      PROGRAM EX0103

      IMPLICIT NONE

*----------- VARIABLE DECLARATION -------------------------------------

* THE SAME AS EX0102
* USE D5P AS THE EVALUATING METHOD (HOWEVER REMOVE THE COMPARASON WITH
* THE TRUE VALUE)
* DFUN1 REFERS TO THE INTEGRAL FROM 0 - 1/2; WHILE DFUN2 1/2 - 1
* DEV REFERS TO THE DEVIATION BETWEEN THE APPROXIMATE AND THE TRUE VALUE

* FUNCTION DECLARATION
      DOUBLE PRECISION  D5P, DFUN1, DFUN2
      EXTERNAL          D5P, DFUN1, DFUN2
* INTEGRAL GRID CALCULATION
      DOUBLE PRECISION  DMIN, DMAX
      INTEGER           N
* RESULTS
      DOUBLE PRECISION  DSOL1, DSOL2, DSOL, DEV

*----------------------------------------------------------------------

* INTEGRAL FROM 0 TO 1/2 : DSOL1

      N = 512
      DMIN = 0.0D0
      DMAX = 0.5D0 ** (1.0D0 / 3.0D0)
      DSOL1 = D5P(N, DFUN1, DMIN, DMAX)

* INTEGRAL FROM 1/2 TO 1 : DSOL2

      N = 512
      DMIN = 0.0D0
      DMAX = 0.5D0 ** (2.0D0 / 3.0D0)
      DSOL2 = D5P(N, DFUN2, DMIN, DMAX)

* FINAL RESULT

      DSOL = DSOL1 + DSOL2
      DEV = DSOL - 4.0D0 * DASIN(1.0D0) / DSQRT(3.0D0)

      PRINT *, 'INTEGRAL FROM 0   TO 0.5 : ', DSOL1
      PRINT *, 'INTEGRAL FROM 0.5 TO 1   : ', DSOL2
      PRINT *, 'TOTAL INTEGRAL VALUE     : ', DSOL
      PRINT *, 'DEVIATION FROM EXACT     : ', DEV

      END PROGRAM EX0103

*----------------------------------------------------------------------

      FUNCTION D5P(N, DFUNC, DMIN, DMAX)

      IMPLICIT NONE

* FUNCTION VARIABLE DECLARATION
      DOUBLE PRECISION  D5P, DFUNC, DMIN, DMAX
      INTEGER           FLR
      EXTERNAL          DFUNC, FLR
* DUMMY
      INTEGER           I
* ERROR CALCULATION VARIABLES
      DOUBLE PRECISION  DH
* CONVERT REAL TO INTEGER FOR THE DUMMY
      INTEGER           K, N

* DEFINING THE INTEGRAL GRIDS
      K = FLR(REAL(DBLE(N) / 4.0D0))
      DH = (DMAX - DMIN) / (4.0D0 * DBLE(K))

* INITIAL AND FINAL POINT CALCULATION
      D5P = 7.0D0 * DFUNC(DMIN) - 7.0D0 * DFUNC(DMAX)

* INTERNAL GRID POINT CALCULATION
      DO 10 I = 1, K
        D5P = D5P + 32.0D0 * DFUNC(DMIN + DBLE(I*4-3) * DH)
        D5P = D5P + 12.0D0 * DFUNC(DMIN + DBLE(I*4-2) * DH)
        D5P = D5P + 32.0D0 * DFUNC(DMIN + DBLE(I*4-1) * DH)
        D5P = D5P + 14.0D0 * DFUNC(DMIN + DBLE(I*4) * DH)
  10  CONTINUE

      D5P = D5P * DH * 2.0D0 / 45.0D0

      RETURN
      END FUNCTION D5P

*----------------------------------------------------------------------

      FUNCTION DFUN1(DVAR)

      IMPLICIT NONE

      DOUBLE PRECISION  DFUN1, DVAR

      DFUN1 = 3.0D0 * (1 - DVAR * DVAR * DVAR) ** (-1.0D0 / 3.0D0)

      RETURN
      END FUNCTION DFUN1

*----------------------------------------------------------------------

      FUNCTION DFUN2(DVAR)

      IMPLICIT NONE

      DOUBLE PRECISION  DFUN2, DVAR

      DFUN2 = 1.5D0 * (1 - DVAR ** 1.5D0) ** (-2.0D0 / 3.0D0)

      RETURN
      END FUNCTION DFUN2

*----------------------------------------------------------------------

      FUNCTION FLR(SVAR)

      IMPLICIT NONE

* FUNCTION VARIABLE DECLARATION
      REAL              SVAR
      INTEGER           FLR

* MAIN PROGRAM

      FLR = INT(SVAR)

      IF (SVAR .LT. 0) FLR = FLR - 1

      RETURN
      END FUNCTION FLR

*----------------------------------------------------------------------


Program abdulmalik
	IMPLICIT NONE
    INTEGER::n,i
    REAL::w(20),k,SUM_P_V,h,max,min
    print*,"enter n"
    read*,n
    call READ_REAL_VECROR(w,20,n)
    K = SUM_P_V(w,n,20)
    max=w(1)
    min=w(1)
    do i=2,n
      if(w(i)>max)then
        max=w(i)
      elseif(w(i)<min)then
        min=w(i)
      endif
    enddo
    h=(k-(max+min))/(n-2)
    print*,h
END Program abdulmalik

SUBROUTINE READ_REAL_VECROR(w,s,n)
	IMPLICIT NONE
    INTEGER,INTENT(IN)::n,s
    REAL,INTENT(out)::w(s)
    INTEGER::i
    do i=1,n
      print*,"enter w(i)"
      read*,w(i)
    enddo
END SUBROUTINE READ_REAL_VECROR

REAL FUNCTION SUM_P_V(w,n,s)
	IMPLICIT NONE
    INTEGER,INTENT(IN)::n,s
    REAL,INTENT(in)::w(s)
    INTEGER::i
    REAL::sum=0
    do i=1,n
      sum=sum+w(i)
    enddo
    SUM_P_V=sum
end FUNCTION SUM_P_V

S2-ex3 Calculate Average Without Max And Min Values In array.f95


      double precision function determ(array,nord,nrows)
c
c     calculate determinate of a square matrix
c        (from bevington "data reduction and error analysis
c         for the physical sciences" pg 294)
c     array: matrix to be analyzed
c     nord: order of matrix
c     nrows:  first dimension of matrix in calling routine
c
      double precision array(nrows,nrows)
      double precision saved
      determ = 1.d0
      do k=1,nord
        if (array(k,k).ne.0) go to 130
        do j=k,nord
           if (array(k,j).ne.0) go to 110
        enddo
        determ = 0.d0
        go to 160
c
 110    continue
        do i=k,nord
           saved = array(i,j)
           array(i,j) = array(i,k)
           array(i,k) = saved
        enddo
        determ = -determ
c
 130    continue
        determ = determ*array(k,k)
        if (k.lt.nord) then
           k1 = k+1
           do i=k1,nord
              do j=k1,nord
                 array(i,j)=array(i,j)-array(i,k)*array(k,j)/array(k,k)
              enddo
           enddo
        endif
      enddo
 160  return
c     end double precision function determ
      end


!  *******************************************************************
!  *                                                                 *
!  *                    Function gausv                               *
!  *                                                                 *
!  *******************************************************************
!  Single Precision Version 3.2
!  Written by Gordon A. Fenton, TUNS, Mar. 21, 1993.
!  Latest Update: Dec. 5, 1996
!
!  PURPOSE  return a normally distributed N(0,var) random realization.
!
!  Returns a normally distributed, zero mean, random variable.
!  The argument "var" is the variance of the random number.
!  Ensure that the machine specific random number generator "randu" is
!  initiated in the calling routine with a suitable seed. See `iseed'.
!  Arguments to the function are;
!
!    var  real value prescribing the variance of the random variate. (input)
!
!
!  Notes:
!   1) since randu returns random numbers in the range (0,1), excluding
!      the endpoints, we need not guard against taking the log of zero
!      below.
!
!  REVISION HISTORY:
!  3.1	now using new randu function (RAN2 from Numerical Recipes, 2nd Ed)
!	(Oct 14/96)
!  3.2	eliminated unused local variable `zero' (Dec 5/96)
!---------------------------------------------------------------------------
      real function gausv( var )
      real var, a, r
      logical getnxt
      save a, r
      data twopi/6.2831853071795864769/
      data two/2.0/
      data getnxt/.true./

      if( getnxt ) then
         a = twopi*randu(0)
         r = sqrt(-two*var*alog(randu(0)))
         gausv = r*cos(a)
         getnxt = .false.
      else
         gausv = r*sin(a)
         getnxt = .true.
      endif

      return
      end


      SUBROUTINE TRANS(A,B,C,R)
      IMPLICIT REAL*8 (A-H,O-Z)
C
C     SUBROUTINE TRANS IS TO SET UP THE TRANSFORMATION
C     MATRIX BETWEEN THE ARIES INERTIAL FRAME AND THE LOCAL
C     VERTICAL FRAME ,  IT CAN ALSO USED AS A 3-1-3 EULER TRANSFORMATION
C
      DIMENSION R(3,3)
      R(1,1)= DCOS(A)*DCOS(C) - DSIN(A)*DCOS(B)*DSIN(C)
      R(1,2)= -DCOS(A)*DSIN(C) - DSIN(A)*DCOS(B)*DCOS(C)
      R(1,3)= DSIN(A)*DSIN(B)
      R(2,1)= DSIN(A)*DCOS(C) + DCOS(A)*DCOS(B)*DSIN(C)
      R(2,2)= -DSIN(A)*DSIN(C) + DCOS(A)*DCOS(B)*DCOS(C)
      R(2,3) = -DCOS(A)*DSIN(B)
      R(3,1)= DSIN(B)*DSIN(C)
      R(3,2)= DSIN(B)*DCOS(C)
      R(3,3)= DCOS(B)
      RETURN
      END


! FOURIER transforms

subroutine invfourier(beta,L,nw,ifermi,ioff,cindata,routdata)
! ifermi=1 : fermionic case
!            G(iw_(-n))=G(iw_(n-1))*
! ifermi=0 : bosonic case
!            W(iv_(-n))=W(iv_n)*  BEWARE the irregular part of W should be substracted beforehand!!
  implicit none
  integer i,j,L,iwmax,nw,ifermi,ioff !offdiag element?
  double precision xpi,beta,tau,om,dummy
  DOUBLE PRECISION routdata(L)
  COMPLEX(kind=8) cindata(0:nw-1),cdummy
  iwmax=nw-1
  xpi=acos(-1.D0)
  do i=1,L
     routdata(i)=0.D0
     tau=(real(i-1,kind=8))*beta/real(L,kind=8)
     do j=0,Iwmax
        if (ifermi.eq.1) then
           om=mod((2.d0*real(j,kind=8)+real(ifermi,kind=8))*xpi/Beta*tau,2*xpi)
        else
           om=(2.d0*real(j,kind=8))*xpi/Beta*tau
        endif
        cdummy=cmplx(0.D0,1.D0)*om
        dummy=real(cindata(j)*exp(-cdummy),kind=8)
        routdata(i)=routdata(i)+2.D0/beta*dummy
     enddo
  enddo

  if (ifermi.eq.0) then
     routdata(:)=routdata(:)-1.d0/beta*real(cindata(0),kind=8)
  endif
  !     special treatment for tau=0:
  if (ioff.ne.1) then
     routdata(1)=-1.D0/2.D0*real(ifermi,kind=8)+routdata(1)
  endif

  RETURN
end subroutine invfourier

subroutine invfourierhp(beta,L,nw,cindata,routdata,shift) !high precision
  !shift would be -(mu-realSigma)   !FERMI ONLY ...
  implicit none
  integer i,j,L,iwmax,nw,ioff
  double precision xpi,beta,tau,om,dummy,dtau
  DOUBLE PRECISION routdata(L),shift
  COMPLEX(kind=8) ci,cindata(0:nw-1),cdummy,cintmp(0:nw-1)
  DOUBLE PRECISION zero,one,two

  iwmax=nw-1
  one=1.d0
  zero=0.d0
  two=2.d0
  xpi=acos(-One)
  ci=(0.d0,1.d0)

  dtau = Beta / real(L,kind=8)

  cintmp=cindata

  do i=0,iwmax
     cindata(i)=cindata(i)   -1.d0/(ci*real(2*i+1,kind=8)*xpi/beta) -shift/(ci*real(2*i+1,kind=8)*xpi/beta)**2.d0 !first, second order correction
  enddo

  do i=1,L
     routdata(i)=Zero
     tau=real(i-1)*beta/real(L)
     do j=0,Iwmax
        om=mod((2*j+One)*xpi/Beta*tau,2*xpi)
        cdummy=cmplx(Zero,One)*om
        dummy=cindata(j)*exp(-cdummy)
        routdata(i)=routdata(i)+Two/beta*dummy
     enddo
  enddo

  do i=1,L   !!! it is -1/2 because of convention ... G(tau)<0
     routdata(i)=routdata(i)-1.d0/2.d0 +shift*( ((+dtau*real(i-1)))/2.d0 -beta/4.d0 )
  enddo

  cindata=cintmp
  RETURN
end subroutine invfourierhp


c     =====================================================
       subroutine qinit(maxmx,maxmy,meqn,mbc,mx,my,xlower,ylower,
     &                   dx,dy,q,maux,aux,Rsphere)
c     =====================================================
c
c      # Set initial conditions for q.

c      # -------4-Rossby-Haurwitz wave-----------------------
c
       implicit double precision (a-h,o-z)
       dimension q(meqn, 1-mbc:maxmx+mbc, 1-mbc:maxmy+mbc)
       dimension aux(maux, 1-mbc:maxmx+mbc, 1-mbc:maxmy+mbc)
       double precision Uin(3),Uout(3)
       double precision K
cf2py integer intent(in) maxmx
cf2py integer intent(in) maxmy
cf2py integer optional,intent(in) meqn
cf2py integer intent(in) mbc
cf2py integer intent(in) mx
cf2py integer intent(in) my
cf2py double precision intent(in) xlower
cf2py double precision intent(in) ylower
cf2py double precision intent(in) dx
cf2py double precision intent(in) dy
cf2py intent(in,out) q
cf2py integer optional, intent(in)  maux
cf2py intent(in) aux
cf2py double precision intent(in) Rsphere

       pi = 4.d0*datan(1.d0)

c      # Parameters
       a = 6.37122d6
       K = 7.848d-6
       Omega = 7.292d-5
       G = 9.80616d0
       t0 = 86400.d0
       h0 = 8.d3
       R = 4.d0

       do 20 i=1,mx
        xc = xlower + (i-0.5d0)*dx
          do 20 j=1,my
            yc = ylower + (j-0.5d0)*dy
            call mapc2p(xc,yc,xp,yp,zp,Rsphere)
c            # compute longitude theta from positive x axis:
             rad = dmax1(dsqrt(xp**2 + yp**2),1.d-6)

              if(xp.gt.0.d0.and.yp.gt.0.d0) then
                 theta = dasin(yp/rad)
              elseif(xp.lt.0.d0.and.yp.gt.0.d0) then
                 theta = pi - dasin(yp/rad)
              elseif(xp.lt.0.d0.and.yp.lt.0.d0) then
                 theta = -pi+dasin(-yp/rad)
              elseif(xp.gt.0.d0.and.yp.lt.0.d0) then
                 theta = -dasin(-yp/rad)
              endif

c            # compute phi, at north pole: pi/2 at south pool: -pi/2
             if (zp.gt. 0.d0) then
               phi =  dasin(zp/Rsphere)
             else
               phi = -dasin(-zp/Rsphere)
             endif
c
             xp = theta
             yp = phi
c
             bigA = 0.5d0*K*(2.d0*Omega+K)*dcos(yp)**2.d0 +
     &               0.25d0*K*K*dcos(yp)**(2.d0*R)*(
     &               (1.d0*R+1.d0)*dcos(yp)**2.d0
     &               +(2.d0*R*R - 1.d0*R - 2.d0)
     &               - 2.d0*R*R*(dcos(yp))**(-2.d0))
             bigB = (2.d0*(Omega+K)*K)/((1.d0*R+1.d0)*(1.d0*R+2.d0))
     &               *dcos(yp)**R*( (1.d0*R*R + 2.d0*R + 2.d0)
     &               - (1.d0*R+1.d0)**(2)*dcos(yp)**2 )
             bigC = 0.25d0*K*K*dcos(yp)**(2*R)*( (1.d0*R + 1.d0)*
     &               dcos(yp)**2 - (1.d0*R + 2.d0))

c            # longitude (angular) velocity component
             Uin(1) = (K*dcos(yp)+K*dcos(yp)**(R-1.)*( R*dsin(yp)**2.
     &              - dcos(yp)**2. )*dcos(R*xp))*t0

c            # latitude (angular) velocity component
             Uin(2) = (-K*R*dcos(yp)**(R-1.)*dsin(yp)*dsin(R*xp))*t0

c            # radial velocity component
             Uin(3) = 0.d0
c

c            # calculate velocity vetor in cartesian coordinates
             Uout(1) = (-dsin(xp)*Uin(1)-dsin(yp)*dcos(xp)*Uin(2))
             Uout(2) = (dcos(xp)*Uin(1)-dsin(yp)*dsin(xp)*Uin(2))
             Uout(3) = dcos(yp)*Uin(2)
c
c            # set the clawpack initial values:
             q(1,i,j) =  h0/a + (a/G)*( bigA + bigB*dcos(R*xp)
     &              + bigC*dcos(2.d0*R*xp))
             q(2,i,j) = q(1,i,j)*Uout(1)
             q(3,i,j) = q(1,i,j)*Uout(2)
             q(4,i,j) = q(1,i,j)*Uout(3)

  20         continue

       return
       end


SUBROUTINE Hilbert( X, N )

  ! Forms the Hilbert transform of the function
  ! Real( X( N ) ) is the input time series
  ! N must be a power of 2 and <16384

  COMPLEX, PARAMETER :: CI = ( 0.0, 1.0 )
  COMPLEX X( N )

  ! Check N is positve and a power of 2

  IF ( N <= 0 ) STOP 'FATAL ERROR in HILBERT: N must be positive'

  NT = 2**( INT( LOG10( REAL( N ) ) / 0.30104 ) + 1 )
  IF ( NT /= N ) STOP 'FATAL ERROR in HILBERT: N must be a power of 2'

  ! Fourier transform

  CALL CFFT( X, N, 1 )
  X = X / N   ! scaling ...

  !  Multiply by i * sgn( f )

  IMID = N / 2
  X( 1 : IMID - 1 ) =  CI * X( 1 : IMID - 1 )   ! pos. spectrum
  X( IMID     )     = 0.0                       ! d.c. component
  X( IMID + 1 : N ) = -CI * X( IMID + 1 : N )   ! neg. spectrum

  ! Inverse Fourier transform

  CALL CFFT( X, N, -1 )

END SUBROUTINE Hilbert


constant a = 1 + 2


    program demo_asinh
    use,intrinsic :: iso_fortran_env, only : dp=>real64,sp=>real32
    implicit none
    real(kind=dp), dimension(3) :: x = [ -1.0d0, 0.0d0, 1.0d0 ]

        write (*,*) asinh(x)

    end program demo_asinh


MODULE PE2D_VAR
 USE PE2D_TYPE
 IMPLICIT NONE
 !-----------------------------------------------------------
 !COMPLEX(DPC), PARAMETER :: IM = CMPLX(0.0_DP,1.0_DP,KIND=DP)
 CHARACTER :: TRACK, FREQ, SRCE, ATMO, WIDE, RIG
 CHARACTER(LEN=100) :: VAR_L, VAR_F, VAR_ZX, VAR_ZY, VAR_ANGLE, VAR_DC, VAR_ZS, VAR_RIG
 CHARACTER(LEN=100) :: PATH_TOPO, FILE_TOPO, TOPO, OUT_LP, OUT_LPG, OUT_P, OUT_PC, OUT_TOPO, OUT_EXT
 INTEGER(I4B) :: N, NT, NSYS, M, NS, NR, NA, NZ, MX, NELT, KU, KL, INFO, NDIAG
 INTEGER(I4B) :: NLINES, NCOLS, SRCE_I, FREQ_I, TOPO_I, ATMO_I, WIDE_I, N1, N2
 INTEGER(I4B), ALLOCATABLE, DIMENSION(:) :: IPIV, NN
 REAL(DP) :: ZX, ZY
 REAL(DP) :: C0, DC, L, LX, LY, H, HA, F, ZS, Z0, ZR, AS, K0, LMBDA0, DKZ, DZ, DR, Z1, Z2
 REAL(DP) :: A0, A2, B, TI, TF, NORM, RCOND, FREQ_NAT(2,4), FREQ_VAL(3), ATMO_REF(3)
 REAL(DP) :: LP0, LQ0, LQR, LPR, PR, QR, P0, Q0
 REAL(DP), ALLOCATABLE, DIMENSION(:) :: ALT, X, C, LPG, LPG1, LPG2, LQG, WORK, RWORK, CH
 REAL(DP), ALLOCATABLE, DIMENSION(:,:) :: P, Q, LP, LQ, MCOND, WA, GMT_DATA
 REAL(DP) :: GHX(3), H0, X0, S, XL, XR, ANGLE, THETA
 REAL(DP), ALLOCATABLE, DIMENSION(:) :: LIN, TERR, TERR1, TERR2, SLOPX
 COMPLEX(DPC) :: A, C1, C2, BETA1, BETA2, TAU1, TAU2, SIGMA1, SIGMA2, R, Z, Z_VAL(3)
 COMPLEX(DPC), ALLOCATABLE, DIMENSION(:) :: K, KZ, DK2, CWORK, PHASE, PG
 COMPLEX(DPC), ALLOCATABLE, DIMENSION(:,:) :: TEMP, PHI, PHI1, PHI2, PC, QC
 COMPLEX(DPC), ALLOCATABLE, DIMENSION(:,:) :: T, D, I, E, DD, M1, M2, MB1, MB2, M1T, M2T, MB1T, MB2T
 TYPE(US), SAVE :: SPMAT, SP1, SP2
 !FFT Arrays
 COMPLEX(DP), ALLOCATABLE, DIMENSION(:,:) :: FPHI, FPHIi, FPHIr
 COMPLEX(DP), ALLOCATABLE, DIMENSION(:) :: BUFR, FPHIs
 INTEGER(I4B), DIMENSION(100) :: IFAC
 !-----------------------------------------------------------
END MODULE PE2D_VAR

! !Propagation domain discretization
!### INTEGER :: N, Ns, Na, M, nz, mx
!### REAL(DP) :: k0, lmbda0, Ha, dz, dr, dkz
!### REAL(DP), ALLOCATABLE, DIMENSION(:) :: r, z
!### COMPLEX(DP) :: beta
!## !Atmosphere variables
! #COMPLEX(DP), ALLOCATABLE, DIMENSION(:) :: k, dk2, kz, Phase, Ref, DELTA
!# !Terrain coordinate transform
!# REAL(DP) :: H0, x0, s, xl, xr
!# REAL(DP), ALLOCATABLE, DIMENSION(:) :: alti, linear, alpha, dalpha
! !z-domain Pressure field
!## COMPLEX(DP), ALLOCATABLE, DIMENSION(:,:) :: P, PHI, PHI1, PHI2, Preal, Pimag
!## COMPLEX(DP) :: A0, A2, B
!## REAL(DP) :: Ps
! !kz-domain Pressure field
!### REAL(DP), ALLOCATABLE, DIMENSION(:,:) :: WA, LP, LPrms, P0
!### REAL(DP), ALLOCATABLE, DIMENSION(:) :: CH, LPg, LPrmsg
! !FFT Work array
! COMPLEX(DP), ALLOCATABLE, DIMENSION(:,:) :: FPHI, FPHIi, FPHIr
! COMPLEX(DP), ALLOCATABLE, DIMENSION(:) :: BUFR, FPHIs
! INTEGER, DIMENSION(100) :: IFAC
! !CPU Time
! REAL :: start, finish


PROGRAM main

  USE mo_kind,        ONLY: dp, sp
  use mo_ansi_colors, only: color, c_red, c_green
  USE mo_moment,      ONLY: absdev, average, central_moment, central_moment_var, correlation, &
       covariance, kurtosis, mean, mixed_central_moment, mixed_central_moment_var, &
       moment, skewness, stddev, variance
  USE mo_utils,       only: ne

  IMPLICIT NONE

  REAL(dp), DIMENSION(10) :: dat1, dat2
  REAL(dp) :: a_dp, v_dp, s_dp, k_dp, m_dp, std_dp, ad_dp

  REAL(sp), DIMENSION(10) :: sat1, sat2
  REAL(sp) :: a_sp, v_sp, s_sp, k_sp, m_sp, std_sp, ad_sp

  LOGICAL :: isgood

  real(sp) :: stmp
  real(dp) :: dtmp

  Write(*,*) ''
  Write(*,*) 'Test mo_moment.f90'

  ! Double precision
  dat1 = (/ 1., 2., 3., 4., 5., 6., 7., 8., 9., 10. /)
  isgood = .true.
  ! Test standard
  dtmp = mean(dat1)
  isgood = isgood .and. (nint(10._dp*dtmp) == 55)
  if (.not. isgood) write(*,*) 'mo_moment mean 1'
  dtmp = average(dat1)
  isgood = isgood .and. (nint(10._dp*dtmp) == 55)
  if (.not. isgood) write(*,*) 'mo_moment average 1'
  dtmp = variance(dat1, ddof=1)
  isgood = isgood .and. (nint(10._dp*dtmp) == 92)
  if (.not. isgood) write(*,*) 'mo_moment variance 1'
  dtmp = stddev(dat1, ddof=1)
  isgood = isgood .and. (nint(10._dp*dtmp) == 30)
  if (.not. isgood) write(*,*) 'mo_moment stddev 1'
  dtmp = skewness(dat1)
  isgood = isgood .and. (nint(10._dp*dtmp) == 00)
  if (.not. isgood) write(*,*) 'mo_moment skewness 1'
  dtmp = kurtosis(dat1)
  isgood = isgood .and. (nint(10._dp*dtmp) == -16)
  if (.not. isgood) write(*,*) 'mo_moment kurtosis 1'
  dtmp = absdev(dat1)
  isgood = isgood .and. (nint(10._dp*dtmp) == 25)
  if (.not. isgood) write(*,*) 'mo_moment absdev 1'
  dtmp = central_moment(dat1,2)
  isgood = isgood .and. (nint(100._dp*dtmp) == 825)
  if (.not. isgood) write(*,*) 'mo_moment central_moment 1'
  dtmp = central_moment_var(dat1,2)
  isgood = isgood .and. (nint(10._dp*dtmp) == 53)
  if (.not. isgood) write(*,*) 'mo_moment central_moment_var 1'
  ! Test the mask
  dtmp = mean(dat1(1:9))
  isgood = isgood .and. (nint(10._dp*dtmp) == 50)
  dtmp = average(dat1(1:9))
  isgood = isgood .and. (nint(10._dp*dtmp) == 50)
  dtmp = variance(dat1(1:9), ddof=1)
  isgood = isgood .and. (nint(10._dp*dtmp) == 75)
  dtmp = stddev(dat1(1:9), ddof=1)
  isgood = isgood .and. (nint(10._dp*dtmp) == 27)
  dtmp = skewness(dat1(1:9))
  isgood = isgood .and. (nint(10._dp*dtmp) == 00)
  dtmp = kurtosis(dat1(1:9))
  isgood = isgood .and. (nint(10._dp*dtmp) == -16)
  dtmp = absdev(dat1(1:9))
  isgood = isgood .and. (nint(10._dp*dtmp) == 22)
  dtmp = central_moment(dat1(1:9),2)
  isgood = isgood .and. (nint(10._dp*dtmp) == 67)
  dtmp = central_moment_var(dat1(1:9),2)
  isgood = isgood .and. (nint(10._dp*dtmp) == 38)
  dtmp = mean(dat1, mask=ne(dat1,10._dp))
  isgood = isgood .and. (nint(10._dp*dtmp) == 50)
  dtmp = average(dat1, mask=ne(dat1,10._dp))
  isgood = isgood .and. (nint(10._dp*dtmp) == 50)
  dtmp = variance(dat1, mask=ne(dat1,10._dp), ddof=1)
  isgood = isgood .and. (nint(10._dp*dtmp) == 75)
  dtmp = stddev(dat1, mask=ne(dat1,10._dp), ddof=1)
  isgood = isgood .and. (nint(10._dp*dtmp) == 27)
  dtmp = skewness(dat1, mask=ne(dat1,10._dp))
  isgood = isgood .and. (nint(10._dp*dtmp) == 00)
  dtmp = kurtosis(dat1, mask=ne(dat1,10._dp))
  isgood = isgood .and. (nint(10._dp*dtmp) == -16)
  dtmp = absdev(dat1, mask=ne(dat1,10._dp))
  isgood = isgood .and. (nint(10._dp*dtmp) == 22)
  dtmp = central_moment(dat1, 2, mask=ne(dat1,10._dp))
  isgood = isgood .and. (nint(10._dp*dtmp) == 67)
  dtmp = central_moment_var(dat1, 2, mask=ne(dat1,10._dp))
  isgood = isgood .and. (nint(10._dp*dtmp) == 38)
  if (.not. isgood) write(*,*) 'mo_moment mask'
  ! Test moment
  call moment(dat1, average=a_dp, variance=v_dp, skewness=s_dp, kurtosis=k_dp, mean=m_dp, &
       stddev=std_dp, absdev=ad_dp, mask=ne(dat1,10._dp), ddof=1)
  isgood = isgood .and. (nint(10._dp*m_dp) == 50)
  isgood = isgood .and. (nint(10._dp*a_dp) == 50)
  isgood = isgood .and. (nint(10._dp*v_dp) == 75)
  isgood = isgood .and. (nint(10._dp*std_dp) == 27)
  isgood = isgood .and. (nint(10._dp*s_dp) == 00)
  isgood = isgood .and. (nint(10._dp*k_dp) == -16)
  isgood = isgood .and. (nint(10._dp*ad_dp) == 25)
  if (.not. isgood) write(*,*) 'mo_moment moment'
  ! Test the double input functions
  dat2 = (/ 1.3, 2.7, 3.9, 5.5, 7., 8.8, 11., 13., 15., 16. /)
  dtmp = correlation(dat1,dat2, ddof=1)
  isgood = isgood .and. (nint(10._dp*dtmp) == 10)
  if (.not. isgood) write(*,*) 'mo_moment correlation 1'
  dtmp = covariance(dat1,dat2, ddof=1)
  isgood = isgood .and. (nint(10._dp*dtmp) == 157)
  if (.not. isgood) write(*,*) 'mo_moment covariance 1'
  dtmp = mixed_central_moment(dat1,dat2,1,1)
  isgood = isgood .and. (nint(10._dp*dtmp) == 141)
  dtmp = mixed_central_moment_var(dat1,dat2,1,1)
  isgood = isgood .and. (nint(10._dp*dtmp) == 142)
  dtmp = correlation(dat1(1:9),dat2(1:9), ddof=1)
  isgood = isgood .and. (nint(10._dp*dtmp) == 10)
  if (.not. isgood) write(*,*) 'mo_moment correlation 2'
  dtmp = covariance(dat1(1:9),dat2(1:9), ddof=1)
  isgood = isgood .and. (nint(10._dp*dtmp) == 129)
  if (.not. isgood) write(*,*) 'mo_moment covariance 2'
  dtmp = mixed_central_moment(dat1(1:9),dat2(1:9),1,1)
  isgood = isgood .and. (nint(10._dp*dtmp) == 115)
  dtmp = mixed_central_moment_var(dat1(1:9),dat2(1:9),1,1)
  isgood = isgood .and. (nint(10._dp*dtmp) == 113)
  dtmp = correlation(dat1,dat2, mask=(ne(dat1,10._dp).and.ne(dat2,10._dp)), ddof=1)
  isgood = isgood .and. (nint(10._dp*dtmp) == 10)
  if (.not. isgood) write(*,*) 'mo_moment correlation 3'
  dtmp = covariance(dat1,dat2, mask=(ne(dat1,10._dp).and.ne(dat2,10._dp)), ddof=1)
  isgood = isgood .and. (nint(10._dp*dtmp) == 129)
  if (.not. isgood) write(*,*) 'mo_moment covariance 3'
  dtmp = mixed_central_moment(dat1,dat2,1,1, mask=(ne(dat1,10._dp).and.ne(dat2,10._dp)))
  isgood = isgood .and. (nint(10._dp*dtmp) == 115)
  dtmp = mixed_central_moment_var(dat1,dat2,1,1, mask=(ne(dat1,10._dp).and.ne(dat2,10._dp)))
  isgood = isgood .and. (nint(10._dp*dtmp) == 113)
  if (.not. isgood) write(*,*) 'mo_moment covariance etc.'

  if (isgood) then
     write(*,*) 'mo_moment double precision ', color('o.k.', c_green)
  else
     write(*,*) 'mo_moment double precision ', color('failed!', c_red)
  endif

  ! Single precision
  sat1 = (/ 1., 2., 3., 4., 5., 6., 7., 8., 9., 10. /)
  isgood = .true.
  ! Test standard
  stmp = mean(sat1)
  isgood = isgood .and. (nint(10._sp*stmp) == 55)
  stmp = average(sat1)
  isgood = isgood .and. (nint(10._sp*stmp) == 55)
  stmp = variance(sat1, ddof=1)
  isgood = isgood .and. (nint(10._sp*stmp) == 92)
  stmp = stddev(sat1, ddof=1)
  isgood = isgood .and. (nint(10._sp*stmp) == 30)
  stmp = skewness(sat1)
  isgood = isgood .and. (nint(10._sp*stmp) == 00)
  stmp = kurtosis(sat1)
  isgood = isgood .and. (nint(10._sp*stmp) == -16)
  stmp = absdev(sat1)
  isgood = isgood .and. (nint(10._sp*stmp) == 25)
  stmp = central_moment(sat1,2)
  isgood = isgood .and. (nint(100._sp*stmp) == 825)
  stmp = central_moment_var(sat1,2)
  isgood = isgood .and. (nint(10._sp*stmp) == 53)
  if (.not. isgood) write(*,*) 'mo_moment sp 1'
  ! Test the mask
  stmp = mean(sat1(1:9))
  isgood = isgood .and. (nint(10._sp*stmp) == 50)
  stmp = average(sat1(1:9))
  isgood = isgood .and. (nint(10._sp*stmp) == 50)
  stmp = variance(sat1(1:9), ddof=1)
  isgood = isgood .and. (nint(10._sp*stmp) == 75)
  stmp = stddev(sat1(1:9), ddof=1)
  isgood = isgood .and. (nint(10._sp*stmp) == 27)
  stmp = skewness(sat1(1:9))
  isgood = isgood .and. (nint(10._sp*stmp) == 00)
  stmp = kurtosis(sat1(1:9))
  isgood = isgood .and. (nint(10._sp*stmp) == -16)
  stmp = absdev(sat1(1:9))
  isgood = isgood .and. (nint(10._sp*stmp) == 22)
  stmp = central_moment(sat1(1:9),2)
  isgood = isgood .and. (nint(10._sp*stmp) == 67)
  stmp = central_moment_var(sat1(1:9),2)
  isgood = isgood .and. (nint(10._sp*stmp) == 38)
  stmp = mean(sat1, mask=ne(sat1,10._sp))
  isgood = isgood .and. (nint(10._sp*stmp) == 50)
  stmp = average(sat1, mask=ne(sat1,10._sp))
  isgood = isgood .and. (nint(10._sp*stmp) == 50)
  stmp = variance(sat1, mask=ne(sat1,10._sp), ddof=1)
  isgood = isgood .and. (nint(10._sp*stmp) == 75)
  stmp = stddev(sat1, mask=ne(sat1,10._sp), ddof=1)
  isgood = isgood .and. (nint(10._sp*stmp) == 27)
  stmp = skewness(sat1, mask=ne(sat1,10._sp))
  isgood = isgood .and. (nint(10._sp*stmp) == 00)
  stmp = kurtosis(sat1, mask=ne(sat1,10._sp))
  isgood = isgood .and. (nint(10._sp*stmp) == -16)
  stmp = absdev(sat1, mask=ne(sat1,10._sp))
  isgood = isgood .and. (nint(10._sp*stmp) == 22)
  stmp = central_moment(sat1, 2, mask=ne(sat1,10._sp))
  isgood = isgood .and. (nint(10._sp*stmp) == 67)
  stmp = central_moment_var(sat1, 2, mask=ne(sat1,10._sp))
  isgood = isgood .and. (nint(10._sp*stmp) == 38)
  if (.not. isgood) write(*,*) 'mo_moment sp 2'
  ! Test moment
  call moment(sat1, average=a_sp, variance=v_sp, skewness=s_sp, kurtosis=k_sp, mean=m_sp, &
       stddev=std_sp, absdev=ad_sp, mask=ne(sat1,10._sp), ddof=1)
  isgood = isgood .and. (nint(10._sp*m_sp) == 50)
  isgood = isgood .and. (nint(10._sp*a_sp) == 50)
  isgood = isgood .and. (nint(10._sp*v_sp) == 75)
  isgood = isgood .and. (nint(10._sp*std_sp) == 27)
  isgood = isgood .and. (nint(10._sp*s_sp) == 00)
  isgood = isgood .and. (nint(10._sp*k_sp) == -16)
  isgood = isgood .and. (nint(10._sp*ad_sp) == 25)
  if (.not. isgood) write(*,*) 'mo_moment sp 3'
  ! Test the double input functions
  sat2 = (/ 1.3, 2.7, 3.9, 5.5, 7., 8.8, 11., 13., 15., 16. /)
  stmp = correlation(sat1,sat2, ddof=1)
  isgood = isgood .and. (nint(10._sp*stmp) == 10)
  if (.not. isgood) write(*,*) 'mo_moment sp 4.1'
  stmp = covariance(sat1, sat2, ddof=1)
  isgood = isgood .and. (nint(10._sp*stmp) == 157)
  if (.not. isgood) write(*,*) 'mo_moment sp 4.2'
  stmp = mixed_central_moment(sat1,sat2,1,1)
  isgood = isgood .and. (nint(10._sp*stmp) == 141)
  if (.not. isgood) write(*,*) 'mo_moment sp 4.3'
  stmp = mixed_central_moment_var(sat1,sat2,1,1)
  isgood = isgood .and. (nint(10._sp*stmp) == 142)
  if (.not. isgood) write(*,*) 'mo_moment sp 4.4'
  stmp = correlation(sat1(1:9),sat2(1:9), ddof=1)
  isgood = isgood .and. (nint(10._sp*stmp) == 10)
  if (.not. isgood) write(*,*) 'mo_moment sp 4.5'
  stmp = covariance(sat1(1:9),sat2(1:9), ddof=1)
  isgood = isgood .and. (nint(10._sp*stmp) == 129)
  if (.not. isgood) write(*,*) 'mo_moment sp 4.6'
  stmp = mixed_central_moment(sat1(1:9),sat2(1:9),1,1)
  isgood = isgood .and. (nint(10._sp*stmp) == 115)
  if (.not. isgood) write(*,*) 'mo_moment sp 4.7'
  stmp = mixed_central_moment_var(sat1(1:9),sat2(1:9),1,1)
  isgood = isgood .and. (nint(10._sp*stmp) == 113)
  if (.not. isgood) write(*,*) 'mo_moment sp 4.8'
  stmp = correlation(sat1,sat2, mask=(ne(sat1,10._sp).and.ne(sat2,10._sp)), ddof=1)
  isgood = isgood .and. (nint(10._sp*stmp) == 10)
  if (.not. isgood) write(*,*) 'mo_moment sp 4.9'
  stmp = covariance(sat1,sat2, mask=(ne(sat1,10._sp).and.ne(sat2,10._sp)), ddof=1)
  isgood = isgood .and. (nint(10._sp*stmp) == 129)
  if (.not. isgood) write(*,*) 'mo_moment sp 4.10'
  stmp = mixed_central_moment(sat1,sat2,1,1, mask=(ne(sat1,10._sp).and.ne(sat2,10._sp)))
  isgood = isgood .and. (nint(10._sp*stmp) == 115)
  if (.not. isgood) write(*,*) 'mo_moment sp 4.11'
  stmp = mixed_central_moment_var(sat1,sat2,1,1, mask=(ne(sat1,10._sp).and.ne(sat2,10._sp)))
  isgood = isgood .and. (nint(10._sp*stmp) == 113)
  if (.not. isgood) write(*,*) 'mo_moment sp 4.12'

  if (isgood) then
     write(*,*) 'mo_moment single precision ', color('o.k.', c_green)
  else
     write(*,*) 'mo_moment single precision ', color('failed!', c_red)
  endif

END PROGRAM main


!---------------------------------------------------------------------!
! OWNER: Ithaca Combustion Enterprise, LLC                            !
! COPYRIGHT: © 2012, Ithaca Combustion Enterprise, LLC                !
! LICENSE: BSD 3-Clause License (The complete text of the license can !
!  be found in the `LICENSE-ICE.txt' file included in the ISAT-CK7    !
!  source directory.)                                                 !
!---------------------------------------------------------------------!

subroutine ell_aff_pr( n, c, gg, m, d, T, cp, ggp )

!  Given an ellipsoid E (in R^n), and an m-dimensional affine space A,
!  determine the ellipsoid P(E) which is the orthogonal projection of E onto A,
!  for  1 <= m <= n.

!  E is defined by:  || G^T * (x-c) || <= 1, where the array gg
!  contains the lower Cholesky triangle G in packed format.

!  A is defined by { x | x = d + T * s }, where T is an n x m orthogonal
!  matrix, and s is any m-vector.

!  The orthogonal projection of the general point x is given by:
!  P(x) = { x | d + T * s,  s = T^T * ( x - d ) }.

!  The orthogonal projection of E onto A is given by:
!  P(E) = { x | d + T * s,  || GP^T * ( s - cp ) || <= 1 },  where the
!  array  ggp contains GP in packed format.

!  Method:
!    cp = T^T * ( c - d )
!    F  = G^{-1} * T = U * [ S ; 0 ] * V^T
!    B  = V * S^{-1}
!    GP * GP^T = B * B^T

implicit none

integer, parameter      :: k_dp = kind(1.d0)
integer, intent(in)     :: n, m
real(k_dp), intent(in)  :: c(n), gg((n*(n+1))/2), d(n), T(n,m)
real(k_dp), intent(out) :: cp(m),  ggp((m*(m+1))/2)

integer, parameter ::  ludiag = 0
integer    :: i, j, k, info, lwork
real(k_dp) :: G(n,n), F(n,m), S(m), B(m,m), VT(m,m), work(5*n*n+20*n)

!  check dimensions
if( n < 1 ) then
   write(ludiag,*)'ell_aff_pr: n < 1, n = ', n
   stop
endif

lwork = 5*n*n+20*n  ! amount of work space for SVD

if( m > n ) then
   write(ludiag,*)'ell_aff_pr: m > n, [m n] = ', m, n
   stop
elseif( m < 1 ) then
   write(ludiag,*)'ell_aff_pr: m < 1, m = ', m
   stop
endif

!  form cp = T^T * ( c - d )

cp = matmul( (c-d) , T )

!  unpack G

G = 0.d0

k  = 0
do j = 1, n
   do i = j, n
      k = k + 1
	  G(i,j) = gg(k)
   end do
end do

!  form F = G^{-1} * T
F = T
call dtrsm('L','L','N','N',n,m,1.d0,G,n,F,n)

!  form S and V^T in:  F = U * [ S ; 0 ] * V^T

call dgesvd('N','A',n,m,F,n,S,B,m,VT,m,work,lwork,info)

if( info /= 0 ) then
   write(ludiag,*)'ell_aff_pr: SVD failed, info = ', info
   stop
elseif( S(m) <= 0.d0 ) then
   write(ludiag,*)'ell_aff_pr: zero singular value, S = ', S
   stop
endif

!  form B = V * S^{-1}

do j = 1, m
   B(1:m,j) = VT(j,1:m) / S(j)
end do

!  form GP:  GP * GP^T = B * B^T

call ell_bbt2chol( m, B, ggp )

return
end subroutine ell_aff_pr


program NN
    implicit none
    real    :: inputs(4,1),weights(3,4),biases(3,1),outputs(3,1)

    inputs   = reshape([ 1.0 ,  2.0 ,  3.0 ,  2.5 ],shape(inputs))

    weights  = reshape([ 0.2 ,  0.8 , -0.5 ,  1.0,&
                         0.5 , -0.91,  0.26, -0.5,&
                        -0.26, -0.27,  0.17,  0.87], shape(weights),order=[2,1])

    biases   = reshape([2.0, 3.0, 0.5], shape(biases))

    outputs  = matmul(weights,inputs) + biases
    ! In fortran, dot_product is only for vectors

    print *, outputs
end program NN


                IMPLICIT NONE
                REAL(8)::x,vel,F,m,H
                INTEGER::ixx
                INTEGER,PARAMETER::itime = 100000
	        REAL,PARAMETER::xposeq = 0.00d0, val=1.000d0,delta=0.002d0

	        x = 0.00d0
		vel  = 1.00d0
                F= -val*(x-xposeq)
                m=1.00d0
                ixx=0

                write(16,*) ixx*delta,x
                write(18,*) ixx*delta,vel
                H = 0.5d0 *(vel**2) + 0.5d0 * val *(x**2)
                write(20,*) x,vel
                write(24,*) ixx*delta,H

		do ixx = 1, itime
		  vel = vel + (0.5d0*(F/m)*delta)
                  x=x + (vel*delta)
                  F = -val*(x-xposeq)
                  vel = vel + (0.5d0*(F/m)*delta)
                  write(16,*) ixx*delta,x
                  write(18,*) ixx*delta,vel
                  H = 0.5d0 *(vel**2) + 0.5d0 * val *(x**2)
                  write(20,*) x,vel
                  write(24,*) ixx*delta,H
		end do
		stop
		end


C    Copyright(C) 1999-2020 National Technology & Engineering Solutions
C    of 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    See packages/seacas/LICENSE for details

      SUBROUTINE INTSCT (X1, Y1, X2, Y2, X3, Y3, X4, Y4, U, W, LCROSS)
C***********************************************************************

C  SUBROUTINE INTSCT = CHECKS TO SEE IF THE LINE FROM N1 TO N2
C                      INTERSECTS THE LINE FROM N3 TO N4

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

C  NOTE:  THIS INTERSECTION ROUTINE IS BASED ON AN ALGORITHM GIVEN
C         IN THE BOOK "GEOMETRIC MODELING" BY MICHAEL E. MORTENSON ON
C         PAGES 319 - 320.

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

      LOGICAL LCROSS

      LCROSS = .FALSE.

      if (max(x1, x2) .lt. min(x3, x4)) return
      if (max(y1, y2) .lt. min(y3, y4)) return
      if (max(x3, x4) .lt. min(x1, x2)) return
      if (max(y3, y4) .lt. min(y1, y2)) return

C  SET UP THE FIRST LINE'S VECTORS (A AND B)

      XA = X1
      YA = Y1
      XB = X2 - X1
      YB = Y2 - Y1

C  SET UP THE SECOND LINE'S VECTORS (C AND D)

      XC = X3
      YC = Y3
      XD = X4 - X3
      YD = Y4 - Y3

C  NOW USE THE VECTORS AND SOLVE FOR W.
C  W IS THE PROPORTION OF THE DISTANCE ALONG THE VECTOR D
C  WHERE THE INTERSECTION OCCURS.  LIKEWISE U IS THE PROPORTIONAL
C  DISTANCE ALONG THE VECTOR B FOR THE INTERSECTION.   IF THERE IS
C  AN INTERSECTION, BOTH U AND W MUST BE BETWEEN 0 AND 1.

      DENOM = (YB * XD) - (XB * YD)

C  CHECK FOR SPECIAL PARALLEL CASE - THE DENOMINATOR IS EQUAL TO ZERO.

      IF (DENOM .NE. 0.) THEN

C  CHECK FOR INTERSECTION

         W = ( (YC * XB) - (XB * YA) - (XC * YB) + (YB * XA) ) / DENOM
         IF ( (W .LT. 1.) .AND. (W .GT. 0.) ) THEN

C  W INDICATES AN INTERSECTION HAS OCCURRED.
C  GET THE U VALUE AND CONFIRM.

            IF (XB .NE. 0.) THEN
               U = ( XC + (W * XD) - XA ) / XB
            ELSE
               U = ( YC + (W * YD) - YA ) / YB
            ENDIF
            IF ( (U .LT. 1.) .AND. (U .GT. 0.) ) THEN
               LCROSS = .TRUE.
            ENDIF
         ENDIF
      ENDIF

      RETURN

      END


      SUBROUTINE MB03DD( UPLO, N1, N2, PREC, A, LDA, B, LDB, Q1, LDQ1,
     $                   Q2, LDQ2, DWORK, LDWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute orthogonal matrices Q1 and Q2 for a real 2-by-2,
C     3-by-3, or 4-by-4 regular block upper triangular pencil
C
C                    ( A11 A12 )     ( B11 B12 )
C       aA - bB =  a (         ) - b (         ),                    (1)
C                    (  0  A22 )     (  0  B22 )
C
C     such that the pencil a(Q2' A Q1) - b(Q2' B Q1) is still in block
C     upper triangular form, but the eigenvalues in Spec(A11, B11),
C     Spec(A22, B22) are exchanged, where Spec(X,Y) denotes the spectrum
C     of the matrix pencil (X,Y) and the notation M' denotes the
C     transpose of the matrix M.
C
C     Optionally, to upper triangularize the real regular pencil in
C     block lower triangular form
C
C                   ( A11  0  )     ( B11  0  )
C       aA - bB = a (         ) - b (         ),                     (2)
C                   ( A21 A22 )     ( B21 B22 )
C
C     while keeping the eigenvalues in the same diagonal position.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     UPLO    CHARACTER*1
C             Specifies if the pencil is in lower or upper block
C             triangular form on entry, as follows:
C             = 'U': Upper block triangular, eigenvalues are exchanged
C                    on exit;
C             = 'T': Upper block triangular, B triangular, eigenvalues
C                    are exchanged on exit;
C             = 'L': Lower block triangular, eigenvalues are not
C                    exchanged on exit.
C
C     Input/Output Parameters
C
C     N1      (input/output) INTEGER
C             Size of the upper left block, N1 <= 2.
C             If UPLO = 'U' or UPLO = 'T' and INFO = 0, or UPLO = 'L'
C             and INFO <> 0, N1 and N2 are exchanged on exit; otherwise,
C             N1 is unchanged on exit.
C
C     N2      (input/output) INTEGER
C             Size of the lower right block, N2 <= 2.
C             If UPLO = 'U' or UPLO = 'T' and INFO = 0, or UPLO = 'L'
C             and INFO <> 0, N1 and N2 are exchanged on exit; otherwise,
C             N2 is unchanged on exit.
C
C     PREC    (input) DOUBLE PRECISION
C             The machine precision, (relative machine precision)*base.
C             See the LAPACK Library routine DLAMCH.
C
C     A       (input/output) DOUBLE PRECISION array, dimension
C                (LDA, N1+N2)
C             On entry, the leading (N1+N2)-by-(N1+N2) part of this
C             array must contain the matrix A of the pencil aA - bB.
C             On exit, if N1 = N2 = 1, this array is unchanged, if
C             UPLO = 'U' or UPLO = 'T', but, if UPLO = 'L', it contains
C                                          [  0 1 ]
C             the matrix J' A J, where J = [ -1 0 ]; otherwise, this
C             array contains the transformed quasi-triangular matrix in
C             generalized real Schur form.
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= N1+N2.
C
C     B       (input/output) DOUBLE PRECISION array, dimension
C                (LDB, N1+N2)
C             On entry, the leading (N1+N2)-by-(N1+N2) part of this
C             array must contain the matrix B of the pencil aA - bB.
C             On exit, if N1 = N2 = 1, this array is unchanged, if
C             UPLO = 'U' or UPLO = 'T', but, if UPLO = 'L', it contains
C             the matrix J' B J; otherwise, this array contains the
C             transformed upper triangular matrix in generalized real
C             Schur form.
C
C     LDB     INTEGER
C             The leading dimension of the array B.  LDB >= N1+N2.
C
C     Q1      (output) DOUBLE PRECISION array, dimension (LDQ1, N1+N2)
C             The leading (N1+N2)-by-(N1+N2) part of this array contains
C             the first orthogonal transformation matrix.
C
C     LDQ1    INTEGER
C             The leading dimension of the array Q1.  LDQ1 >= N1+N2.
C
C     Q2      (output) DOUBLE PRECISION array, dimension (LDQ2, N1+N2)
C             The leading (N1+N2)-by-(N1+N2) part of this array contains
C             the second orthogonal transformation matrix.
C
C     LDQ2    INTEGER
C             The leading dimension of the array Q2.  LDQ2 >= N1+N2.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             If N1+N2 = 2 then DWORK is not referenced.
C
C     LDWORK  INTEGER
C             The dimension of the array DWORK.
C             If N1+N2 = 2, then LDWORK = 0; otherwise,
C             LDWORK >= 16*N1 + 10*N2 + 23, if UPLO = 'U';
C             LDWORK >=  7*N1 +  7*N2 + 16, if UPLO = 'T';
C             LDWORK >= 10*N1 + 16*N2 + 23, if UPLO = 'L'.
C             For good performance LDWORK should be generally larger.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0: succesful exit;
C             = 3: the QZ iteration failed in the LAPACK routine DGGES
C                  (if UPLO <> 'T') or DHGEQZ (if UPLO = 'T');
C             = 4: another error occured during execution of DHGEQZ;
C             = 5: reordering of aA - bB in the LAPACK routine DTGSEN
C                  failed because the transformed matrix pencil aA - bB
C                  would be too far from generalized Schur form;
C                  the problem is very ill-conditioned.
C
C     METHOD
C
C     The algorithm uses orthogonal transformations as described in [2]
C     (page 30). The QZ algorithm is used for N1 = 2 or N2 = 2, but it
C     always acts on an upper block triangular pencil.
C
C     REFERENCES
C
C     [1] Benner, P., Byers, R., Mehrmann, V. and Xu, H.
C         Numerical computation of deflating subspaces of skew-
C         Hamiltonian/Hamiltonian pencils.
C         SIAM J. Matrix Anal. Appl., 24 (1), pp. 165-190, 2002.
C
C     [2] Benner, P., Byers, R., Losse, P., Mehrmann, V. and Xu, H.
C         Numerical Solution of Real Skew-Hamiltonian/Hamiltonian
C         Eigenproblems.
C         Tech. Rep., Technical University Chemnitz, Germany,
C         Nov. 2007.
C
C     NUMERICAL ASPECTS
C
C     The algorithm is numerically backward stable.
C
C     CONTRIBUTOR
C
C     Matthias Voigt, Fakultaet fuer Mathematik, Technische Universitaet
C     Chemnitz, October 16, 2008.
C
C     REVISIONS
C
C     V. Sima, July 2009 (SLICOT version of the routine DBTUEX).
C     V. Sima, Nov. 2009, Oct. 2010, Nov. 2010, Mar. 2016, Apr. 2016,
C     May 2016.
C     M. Voigt, Jan. 2012.
C
C     KEYWORDS
C
C     Block triangular pencil, eigenvalue exchange.
C
C     ******************************************************************
C
      DOUBLE PRECISION   ZERO, ONE, TEN, HUND
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0, TEN = 1.0D+1,
     $                     HUND = 1.0D+2 )
C
C     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            INFO, LDA, LDB, LDQ1, LDQ2, LDWORK, N1, N2
      DOUBLE PRECISION   PREC
C
C     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), DWORK( * ),
     $                   Q1( LDQ1, * ), Q2( LDQ2, * )
C
C     .. Local Scalars ..
      LOGICAL            AEVINF, EVINF, LTRIU, LUPLO
      INTEGER            CNT, EVSEL, I, IAEV, IDUM, IEVS, ITMP, J, M
      DOUBLE PRECISION   A11, A22, ABSAEV, ABSEV, ADIF, B11, B22, CO,
     $                   CO1, E, G, MX, NRA, NRB, SFMIN, SI, SI1, TMP,
     $                   TOL, TOLB
C
C     .. Local Arrays ..
      LOGICAL            BWORK( 1 ), OUT( 2 ), SLCT( 4 )
      INTEGER            IDM( 2 )
      DOUBLE PRECISION   AS( 2, 2 ), BS( 2, 2 ), DUM( 8 )
C
C     .. External Functions ..
      LOGICAL            LSAME,  SB02OW
      DOUBLE PRECISION   DLAMCH, DLANGE, DLANHS
      EXTERNAL           DLAMCH, DLANGE, DLANHS, LSAME, SB02OW
C
C     .. External Subroutines ..
      EXTERNAL           DCOPY, DGGES, DHGEQZ, DLACPY, DLAG2, DLARTG,
     $                   DLASET, DROT, DSWAP, DTGEX2, DTGSEN, MB01QD
C
C     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, SIGN
C
C     .. Executable Statements ..
C
C     Decode the input arguments.
C
      LTRIU = LSAME( UPLO, 'T' )
      LUPLO = LSAME( UPLO, 'U' ) .OR. LTRIU
C
C     For efficiency, the input arguments are not tested.
C
      INFO = 0
C
C     Computations.
C
C     (Note: Comments in the code beginning "Workspace:" describe the
C     minimal amount of real workspace needed at that point in the
C     code, as well as the preferred amount for good performance.)
C
      M = N1 + N2
      IF( M.GT.2 ) THEN
         IF( .NOT.LUPLO ) THEN
C
C           Make the pencil upper block triangular.
C           Quick return if A21 = 0 and B21 = 0.
C
            IF( DLANGE( '1-norm', N2, N1, A( N1+1, 1 ), LDA, DWORK )
     $            .EQ.ZERO .AND.
     $          DLANGE( '1-norm', N2, N1, B( N1+1, 1 ), LDB, DWORK )
     $            .EQ.ZERO ) THEN
               IF( N1.EQ.2 ) THEN
                  CALL DGGES( 'Vectors', 'Vectors', 'Not sorted',
     $                        SB02OW, N1, A, LDA, B, LDB, IDUM, DWORK,
     $                        DWORK( M+1 ), DWORK( 2*M+1 ), Q2, LDQ2,
     $                        Q1, LDQ1, DWORK( 3*M+1 ), LDWORK-2*M,
     $                        BWORK, INFO )
                  IF( INFO.NE.0 ) THEN
                     IF( INFO.GE.1 .AND. INFO.LE.N1 ) THEN
                        INFO = 3
                        RETURN
                     ELSE
                        INFO = 4
                        RETURN
                     END IF
                  END IF
                  IF( N2.EQ.1 ) THEN
                     Q1( 3, 3 ) = ONE
                     Q2( 3, 3 ) = ONE
                  END IF
               END IF
               IF( N2.EQ.2 ) THEN
                  CALL DGGES( 'Vectors', 'Vectors', 'Not sorted',
     $                        SB02OW, N2, A( N1+1, N1+1 ), LDA,
     $                        B( N1+1, N1+1 ), LDB, IDUM, DWORK( N1+1 ),
     $                        DWORK( M+N1+1 ), DWORK( 2*M+N1+1 ),
     $                        Q2( N1+1, N1+1 ), LDQ2, Q1( N1+1, N1+1 ),
     $                        LDQ1, DWORK( 3*M+1 ), LDWORK-2*M, BWORK,
     $                        INFO )
                  IF( INFO.NE.0 ) THEN
                     IF( INFO.GE.1 .AND. INFO.LE.N2 ) THEN
                        INFO = 3
                        RETURN
                     ELSE
                        INFO = 4
                        RETURN
                     END IF
                  END IF
                  IF( N1.EQ.1 ) THEN
                     Q1( 1, 1 ) = ONE
                     Q2( 1, 1 ) = ONE
                  END IF
               END IF
               CALL DLASET( 'Full', N2, N1, ZERO, ZERO, Q1( N1+1, 1 ),
     $                      LDQ1 )
               CALL DLASET( 'Full', N1, N2, ZERO, ZERO, Q1( 1, N1+1 ),
     $                      LDQ1 )
               CALL DLASET( 'Full', N2, N1, ZERO, ZERO, Q2( N1+1, 1 ),
     $                      LDQ2 )
               CALL DLASET( 'Full', N1, N2, ZERO, ZERO, Q2( 1, N1+1 ),
     $                      LDQ2 )
               RETURN
            END IF
            IF( N1.EQ.1 ) THEN
               DUM( 1 )  = A( 1, 1 )
               DUM( 2 )  = A( 2, 1 )
               A( 1, 1 ) = A( 2, 2 )
               A( 2, 1 ) = A( 3, 2 )
               A( 1, 2 ) = A( 2, 3 )
               A( 2, 2 ) = A( 3, 3 )
               A( 1, 3 ) = DUM( 2 )
               A( 2, 3 ) = A( 3, 1 )
               A( 3, 3 ) = DUM( 1 )
               A( 3, 1 ) = ZERO
               A( 3, 2 ) = ZERO
               DUM( 1 )  = B( 1, 1 )
               DUM( 2 )  = B( 2, 1 )
               B( 1, 1 ) = B( 2, 2 )
               B( 2, 1 ) = B( 3, 2 )
               B( 1, 2 ) = B( 2, 3 )
               B( 2, 2 ) = B( 3, 3 )
               B( 1, 3 ) = DUM( 2 )
               B( 2, 3 ) = B( 3, 1 )
               B( 3, 3 ) = DUM( 1 )
               B( 3, 1 ) = ZERO
               B( 3, 2 ) = ZERO
            ELSE IF( N2.EQ.1 ) THEN
               DUM( 1 )  = A( 3, 2 )
               DUM( 2 )  = A( 3, 3 )
               A( 2, 3 ) = A( 1, 2 )
               A( 3, 3 ) = A( 2, 2 )
               A( 2, 2 ) = A( 1, 1 )
               A( 3, 2 ) = A( 2, 1 )
               A( 1, 1 ) = DUM( 2 )
               A( 1, 2 ) = A( 3, 1 )
               A( 1, 3 ) = DUM( 1 )
               A( 2, 1 ) = ZERO
               A( 3, 1 ) = ZERO
               DUM( 1 )  = B( 3, 2 )
               DUM( 2 )  = B( 3, 3 )
               B( 2, 3 ) = B( 1, 2 )
               B( 3, 3 ) = B( 2, 2 )
               B( 2, 2 ) = B( 1, 1 )
               B( 3, 2 ) = B( 2, 1 )
               B( 1, 1 ) = DUM( 2 )
               B( 1, 2 ) = B( 3, 1 )
               B( 1, 3 ) = DUM( 1 )
               B( 2, 1 ) = ZERO
               B( 3, 1 ) = ZERO
            ELSE
C
               DO 10 J = 1, N1
                  CALL DSWAP( N1, A( 1,    J ), 1, A( N1+1, N1+J ), 1 )
                  CALL DSWAP( N1, A( 1, N1+J ), 1, A( N1+1,    J ), 1 )
                  CALL DSWAP( N1, B( 1,    J ), 1, B( N1+1, N1+J ), 1 )
                  CALL DSWAP( N1, B( 1, N1+J ), 1, B( N1+1,    J ), 1 )
   10          CONTINUE
C
            END IF
C
            ITMP = N1
            N1 = N2
            N2 = ITMP
         END IF
C
C        Apply the QZ algorithm and order the eigenvalues in
C        DWORK(1:3*N1) to the top.
C        Note that N1 and N2 are interchanged for UPLO = 'L'.
C
         IEVS = 3*N1 + 1
         IAEV = IEVS + 3*N1
         IF( N1.EQ.1 ) THEN
            DWORK( 1 ) = A( 1, 1 )*SIGN( ONE, B( 1, 1 ) )
            DWORK( 2 ) = ZERO
            DWORK( 3 ) = ABS( B( 1, 1 ) )
         ELSE
            SFMIN = DLAMCH( 'Safemin' )
            Q1( 1, 1 ) = A( 1, 1 )
            Q1( 2, 1 ) = A( 2, 1 )
            Q1( 1, 2 ) = A( 1, 2 )
            Q1( 2, 2 ) = A( 2, 2 )
            Q2( 1, 1 ) = B( 1, 1 )
            Q2( 2, 1 ) = B( 2, 1 )
            Q2( 1, 2 ) = B( 1, 2 )
            Q2( 2, 2 ) = B( 2, 2 )
            IF( .NOT.LTRIU .AND. B( 2, 1 ).NE.ZERO ) THEN
C
C              Triangularize B11 and update A11.
C
               A11 = ABS( Q1( 1, 1 ) )
               A22 = ABS( Q1( 2, 2 ) )
               B11 = ABS( Q2( 1, 1 ) )
               B22 = ABS( Q2( 2, 2 ) )
               MX  = MAX( A11 + ABS( Q1( 2, 1 ) ),
     $                    A22 + ABS( Q1( 1, 2 ) ),
     $                    B11 + ABS( Q2( 2, 1 ) ),
     $                    B22 + ABS( Q2( 1, 2 ) ), SFMIN )
               Q1( 1, 1 ) = Q1( 1, 1 ) / MX
               Q1( 2, 1 ) = Q1( 2, 1 ) / MX
               Q1( 1, 2 ) = Q1( 1, 2 ) / MX
               Q1( 2, 2 ) = Q1( 2, 2 ) / MX
               Q2( 1, 1 ) = Q2( 1, 1 ) / MX
               Q2( 2, 1 ) = Q2( 2, 1 ) / MX
               Q2( 1, 2 ) = Q2( 1, 2 ) / MX
               Q2( 2, 2 ) = Q2( 2, 2 ) / MX
               CALL DLARTG( Q2( 1, 1 ), Q2( 2, 1 ), CO,  SI,  E )
               CALL DLARTG( Q2( 2, 2 ), Q2( 2, 1 ), CO1, SI1, G )
               IF( ABS( CO *B( 2, 1 ) - SI *B( 1, 1 ) ).LE.
     $             ABS( CO1*B( 2, 1 ) - SI1*B( 2, 2 ) ) ) THEN
                  CALL DROT( 2, Q1( 1, 1 ), LDQ1, Q1( 2, 1 ), LDQ1, CO,
     $                       SI )
                  Q2( 1, 1 ) = E
                  TMP = Q2( 1, 2 )
                  Q2( 1, 2 ) = SI*Q2( 2, 2 ) + CO*TMP
                  Q2( 2, 2 ) = CO*Q2( 2, 2 ) - SI*TMP
               ELSE
                  CALL DROT( 2, Q1( 1, 2 ), 1, Q1( 1, 1 ), 1, CO1, SI1 )
                  Q2( 2, 2 ) = G
                  TMP = Q2( 1, 2 )
                  Q2( 1, 2 ) = SI1*Q2( 1, 1 ) + CO1*TMP
                  Q2( 1, 1 ) = CO1*Q2( 1, 1 ) - SI1*TMP
               END IF
               Q2( 2, 1 ) = ZERO
            END IF
            CALL DLAG2( Q1, LDQ1, Q2, LDQ2, SFMIN*HUND, DWORK( 2*N1+1 ),
     $                  DWORK( 2*N1+2 ), DWORK( 1 ), DWORK( 2 ),
     $                  DWORK( N1+1 ) )
            DWORK( N1+2 ) = -DWORK( N1+1 )
         END IF
C
         ITMP = IAEV + 3*M
         CALL DCOPY( 3*N1, DWORK, 1, DWORK( IEVS ), 1 )
         IF( LTRIU ) THEN
C
C           Workspace: need   10*N1 + 4*N2.
C
            CALL DHGEQZ( 'Schur', 'Identity', 'Identity', M, 1, M, A,
     $                   LDA, B, LDB, DWORK( IAEV ), DWORK( IAEV+M ),
     $                   DWORK( IAEV+2*M ), Q2, LDQ2, Q1, LDQ1,
     $                   DWORK( ITMP ), LDWORK-ITMP+1, INFO )
            IF( INFO.GE.1 .AND. INFO.LE.M ) THEN
               INFO = 3
               RETURN
            ELSE IF( INFO.NE.0 ) THEN
               INFO = 4
               RETURN
            END IF
         ELSE
C
C           Workspace: need   16*N1 + 10*N2 + 23;
C                      prefer larger.
C
            CALL DGGES(  'Vectors', 'Vectors', 'Not sorted', SB02OW, M,
     $                   A, LDA, B, LDB, IDUM, DWORK( IAEV ),
     $                   DWORK( IAEV+M ), DWORK( IAEV+2*M ), Q2, LDQ2,
     $                   Q1, LDQ1, DWORK( ITMP ), LDWORK-ITMP+1, BWORK,
     $                   INFO )
            IF( INFO.NE.0 ) THEN
               IF( INFO.GE.1 .AND. INFO.LE.M ) THEN
                  INFO = 3
                  RETURN
               ELSE
                  INFO = 4
                  RETURN
               END IF
            END IF
         END IF
C
         TOL   = PREC
         TOLB  = TEN*PREC
         EVSEL = 0
         DO 20 I = 1, M
            SLCT( I ) = .TRUE.
   20    CONTINUE
C
C        WHILE( EVSEL.EQ.0 ) DO
C
   30    CONTINUE
         IF( EVSEL.EQ.0 ) THEN
            CNT = 0
            OUT( 1 ) = .FALSE.
            OUT( 2 ) = .FALSE.
C
            DO 50 I = IAEV, IAEV + M - 1
               AEVINF = ABS( DWORK( 2*M+I ) ).LT.PREC*
     $                ( ABS( DWORK( I ) ) + ABS( DWORK( M+I ) ) )
               DO 40 J = 1, N1
C
C                 Check if an eigenvalue is selected and check if it
C                 is infinite.
C
                  EVINF = ABS( DWORK( 2*N1+J ) ).LT.PREC*
     $                  ( ABS( DWORK( J ) ) + ABS( DWORK( N1+J ) ) )
                  IF( ( .NOT. EVINF .OR. AEVINF ) .AND.
     $                ( .NOT.AEVINF .OR.  EVINF ) .AND.
     $                  .NOT. OUT( J ) ) THEN
                     IF( .NOT.EVINF .OR. .NOT.AEVINF ) THEN
                        ADIF   = ABS( DWORK( J    )/DWORK( 2*N1+J ) -
     $                                DWORK( I    )/DWORK( 2*M+I  ) ) +
     $                           ABS( DWORK( N1+J )/DWORK( 2*N1+J ) -
     $                                DWORK( M+I  )/DWORK( 2*M+I  ) )
                        ABSEV  = ABS( DWORK( J    )/DWORK( 2*N1+J ) ) +
     $                           ABS( DWORK( N1+J )/DWORK( 2*N1+J ) )
                        ABSAEV = ABS( DWORK( I    )/DWORK( 2*M+I  ) ) +
     $                           ABS( DWORK( M+I  )/DWORK( 2*M+I  ) )
                        IF( ADIF.LE.TOL*MAX( TOLB, ABSEV, ABSAEV ) )
     $                        THEN
                           SLCT( I-IAEV+1 ) = .FALSE.
                           OUT( J ) = .TRUE.
                           CNT = CNT + 1
                        END IF
                     ELSE
                        SLCT( I-IAEV+1 ) = .FALSE.
                        OUT( J ) = .TRUE.
                        CNT = CNT + 1
                     END IF
                  END IF
   40          CONTINUE
   50       CONTINUE
C
            IF( CNT.EQ.N1 ) THEN
               EVSEL = 1
            ELSE
C
C              CNT < N1, too few eigenvalues selected.
C
               TOL = TEN*TOL
               CALL DCOPY( 3*N1, DWORK( IEVS ), 1, DWORK, 1 )
            END IF
            GO TO 30
         END IF
C        END WHILE 30
C
C        Workspace: need   7*N1 + 7*N2 + 16;
C                   prefer larger.
C
         ITMP = 3*M + 1
         NRA = DLANHS( '1-norm', M, A, LDA, DWORK )
         NRB = DLANHS( '1-norm', M, B, LDB, DWORK )
         IDM( 1 ) = 2
         IDM( 2 ) = 2
         CALL MB01QD( 'Hess', M, M, 0, 0, NRA, ONE, 2, IDM, A, LDA,
     $                INFO )
         CALL MB01QD( 'Hess', M, M, 0, 0, NRB, ONE, 2, IDM, B, LDB,
     $                INFO )
         CALL DTGSEN( 0, .TRUE., .TRUE., SLCT, M, A, LDA, B, LDB, DWORK,
     $                DWORK( M+1 ), DWORK( 2*M+1 ), Q2, LDQ2, Q1, LDQ1,
     $                IDUM, TMP, TMP, DUM, DWORK( ITMP ), LDWORK-ITMP+1,
     $                IDM, 1, INFO )
         IF( INFO.EQ.1 ) THEN
            INFO = 5
            RETURN
         END IF
C
         CALL MB01QD( 'Hess', M, M, 0, 0, ONE, NRA, 0, IDM, A, LDA,
     $                INFO )
         CALL MB01QD( 'Hess', M, M, 0, 0, ONE, NRB, 0, IDM, B, LDB,
     $                INFO )
C
C        Interchange N1 and N2.
C
         ITMP = N1
         N1 = N2
         N2 = ITMP
C
         IF( .NOT.LUPLO ) THEN
C
C           Permute the rows of Q1 and Q2.
C
            IF( N1.EQ.1 ) THEN
C
               DO 60 J = 1, M
                  TMP = Q1( 3, J )
                  Q1( 3, J ) = Q1( 2, J )
                  Q1( 2, J ) = Q1( 1, J )
                  Q1( 1, J ) = TMP
                  TMP = Q2( 3, J )
                  Q2( 3, J ) = Q2( 2, J )
                  Q2( 2, J ) = Q2( 1, J )
                  Q2( 1, J ) = TMP
   60          CONTINUE
C
            ELSE IF( N2.EQ.1 ) THEN
C
               DO 70 J = 1, M
                  TMP = Q1( 1, J )
                  Q1( 1, J ) = Q1( 2, J )
                  Q1( 2, J ) = Q1( 3, J )
                  Q1( 3, J ) = TMP
                  TMP = Q2( 1, J )
                  Q2( 1, J ) = Q2( 2, J )
                  Q2( 2, J ) = Q2( 3, J )
                  Q2( 3, J ) = TMP
   70          CONTINUE
C
            ELSE
C
               DO 80 J = 1, M
                  CALL DSWAP( N1, Q1( 1, J ), 1, Q1( N1+1, J ), 1 )
                  CALL DSWAP( N1, Q2( 1, J ), 1, Q2( N1+1, J ), 1 )
   80          CONTINUE
C
            END IF
         END IF
      ELSE
C
C        2-by-2 case.
C
         IF( .NOT.LUPLO .AND. A( 2, 1 ).EQ.ZERO
     $                  .AND. B( 2, 1 ).EQ.ZERO ) THEN
            CALL DLASET( 'Full', M, M, ZERO, ONE, Q1, LDQ1 )
            CALL DLASET( 'Full', M, M, ZERO, ONE, Q2, LDQ2 )
            RETURN
         ELSE IF( LUPLO ) THEN
            CALL DLASET( 'Full', M, M, ZERO, ONE, Q1, LDQ1 )
            CALL DLASET( 'Full', M, M, ZERO, ONE, Q2, LDQ2 )
         ELSE
            TMP        =  A( 1, 1 )
            A( 1, 1 )  =  A( 2, 2 )
            A( 2, 2 )  =  TMP
            A( 1, 2 )  = -A( 2, 1 )
            A( 2, 1 )  =  ZERO
            TMP        =  B( 1, 1 )
            B( 1, 1 )  =  B( 2, 2 )
            B( 2, 2 )  =  TMP
            B( 1, 2 )  = -B( 2, 1 )
            B( 2, 1 )  =  ZERO
            Q1( 1, 1 ) =  ZERO
            Q1( 2, 1 ) = -ONE
            Q1( 1, 2 ) =  ONE
            Q1( 2, 2 ) =  ZERO
            Q2( 1, 1 ) =  ZERO
            Q2( 2, 1 ) = -ONE
            Q2( 1, 2 ) =  ONE
            Q2( 2, 2 ) =  ZERO
         END IF
         A11 = A( 1, 1 )
         A22 = A( 2, 2 )
         B11 = B( 1, 1 )
         B22 = B( 2, 2 )
         MX  = MAX( ABS( A11 ), ABS( A22 ), ABS( A( 1, 2 ) ),
     $              ABS( B11 ), ABS( B22 ), ABS( B( 1, 2 ) ),
     $              DLAMCH( 'Safemin' ) )
         AS( 1, 1 ) = A11 / MX
         AS( 2, 1 ) = ZERO
         AS( 1, 2 ) = A( 1, 2 ) / MX
         AS( 2, 2 ) = A22 / MX
         BS( 1, 1 ) = B11 / MX
         BS( 2, 2 ) = B22 / MX
         BS( 1, 2 ) = B( 1, 2 ) / MX
         CALL DLACPY( 'Full', M, M, A, LDA, AS, 2 )
         CALL DLACPY( 'Full', M, M, B, LDB, BS, 2 )
         CALL DTGEX2( .TRUE., .TRUE., M, AS, 2, BS, 2, Q2, LDQ2, Q1,
     $                LDQ1, 1, 1, 1, DUM, 8, ITMP )
C
      END IF
C
      RETURN
C *** Last line of MB03DD ***
      END


!  *********************************************************************
!  *                                                                   *
!  *                S U B R O U T I N E   G D D C A L C                *
!  *                                                      gm   1/21/05 *
!  *                                                                   *
!  *                                                                   *
!  *********************************************************************
! Subroutine GDDCALC:  Calculates growing degree-days by various
! methods.  See McMaster and Wilhelm ref here ***  Method 1 is
! most common for wheat and barley.  Method 2 is most common for corn,
! sorghum, and soybean.

!  INPUTS:  gddday(C,R), gmethod(R), tbase(R), tmax(R), tmin(R), tupper(R)

!  OUTPUTS: gddday(C,R)

      subroutine gddcalc(cname, daynum, df, gddday, gmethod, pf, tbase,
     c tmax, tmin, toptlo, toptup, tupper) !, vf)
!
      implicit none

      integer daynum, gmethod

      real  df, gddday, pf, tbase, tmax, tmin, toptlo, toptup, tupper !, vf

      character *22 cname
      character *256 outfgdd

! Local variables
      real m, tavg, tavgtemp, tf, tmaxtemp, tmintemp, topt, x, x1, x2,
     c   x3, x4, y, y1, y2, y3, y4

! Initialize local variables
      tavg = 0.0
      tavgtemp = 0.0
      tmaxtemp = tmax
      tmintemp = tmin
      topt = (toptlo + toptup) / 2

      !tbase point coordinates
      x1 = tbase
      y1 = 0.0
      !toplo point ccordinates
      x2 = toptlo
      y2 = 1.0 ! maximum development rate
      !toptup point coordinates
      x3= toptup
      y3 = 1.0
      !tupper point coordinates
      x4 = tupper
      y4 = 0.0
!      print *, 'tbase = ', tbase, 'toptlo = ', toptlo, 'toptup = ',
!     c toptup, 'tupper = ', tupper
! Determine method of calculating growing degree-days
! Calculate using Method 1:
! This is a linear model.

      if (gmethod .eq. 1) then
         tavg = (tmax + tmin)/2.0 !need to be able to print tavg
                                     !for method 1
!         gddday = ((tmax + tmin)/2.) - tbase
         gddday = tavg - tbase
         if (gddday .lt. 0.) gddday = 0.

! Calculate using Method 2:
! This is a linear model with an upper threshold limit where no
! additional gdd's are accumulated.
      elseif (gmethod .eq. 2) then
! adjust tmax and tmin if need be and store values in tmaxtemp and tmintemp
         if (tmax .lt. tbase) tmaxtemp = tbase
         if (tmax .gt. toptup) tmaxtemp = toptup
         if (tmin .lt. tbase) tmintemp = tbase
         if (tmin .gt. toptup) tmintemp = toptup

         tavgtemp = (tmaxtemp + tmintemp)/2.
         gddday = tavgtemp - tbase

         if (gddday .lt. 0.) gddday = 0.
         if (gddday .gt. toptup) gddday = toptup
         !print *, 'gddday Method2 = ', gddday

! Calculate using Method 3:
! This is a two-segmented linear model
      else if (gmethod .eq. 3) then
             tavg = (tmax + tmin)/2.

!      if (tavg .GE. tbase) then
!            print *, 'tavg = ', tavg
!      endif

! use the slope equation to determine a temperature factor (tf) by which
! the day's gdd is adjusted.
        if ((tavg .GE. tbase) .AND. (tavg .LE. topt)) then
           m = (y2-y1)/(x2-x1) ! find the slope of the line tbase -topt
      !next find the point on the first segment of the linear model where
      !a line drawn perpendicular from the tavg point on the x axis will
      !interesect the first segment of the linear model. The y part of that
      !point will be the tf factor or the y axis portion of the intersected
      !point.  Know the slope of the line, now find the point of intersection.
      !Use the point-slope equation
      !  y-y1 = m(x-x1) ! x2 and y2 could also be used in place of x1 and y1
           x= tavg
           y = m*x - m*x1 + y1
           tf = y
           gddday = tf*(tavg-tbase)
        elseif ((tavg .GT. topt) .AND. (tavg .LE. tupper)) then
           m = (y4-y2)/(x4-x2)! find the slope of the line topt-tupper
           x = tavg
           y = m*x - m*x4 + y4
           tf = y
           gddday = tf*(tavg-tbase)
        elseif ((tavg .LT. tbase) .OR. (tavg .GT. tupper)) then
           gddday = 0.0
        endif

! Calculate using Method 4:
! This is a three segmented linear model
      elseif (gmethod .eq. 4) then !this is method 3 w/another line segment
             tavg = (tmax + tmin)/2.

        if ((tavg .GE. tbase) .AND. (tavg .LT. toptlo)) then
           m = (y2-y1)/(x2-x1) !find the slope of the line tbase -toptlo
      !  y-y1 = m(x-x1) ! x2 and y2 could also be used in place of x1 and y1
           x= tavg
           y = m*x - m*x1 + y1
           tf = y
           gddday = tf*(tavg-tbase)
        elseif ((tavg .GE. toptlo) .AND. (tavg .LE. toptup)) then
           m = (y3-y2)/(x3-x2)! find the slope of the line toptlo-toptup
           x = tavg       ! this slope should be 0
           y = m*x - m*x2 + y2
           tf = y
           gddday = tf*(tavg-tbase)
        elseif ((tavg .GT. toptup) .AND. (tavg .LE. tupper)) then
           m = (y4-y3)/(x4-x3)! find the slope of the line toptup-tupper
           x = tavg
           y = m*x - m*x3 + y3
           tf = y
           gddday = tf*(tavg-tbase)
! no growth when tavg is lower than tbase or greater than tupper.
        elseif ((tavg .LT. tbase) .OR. (tavg .GT. tupper)) then
           gddday = 0.0
        endif
      endif

! Adjust thermal development units with photoperiod and vernalization
         !dtdu = gddday*(min(df, vf)) is this correct?

!      if(gmethod .eq. 2) then
!        print *, 'tavgtemp = ', tavgtemp, 'method # ', gmethod,
!     c'gddday = ', gddday
!      elseif (gmethod .ne. 2) then
!        print *, 'tavg = ',tavg, 'method # ', gmethod, 'gddday = ',
!     cgddday
!      endif

      ! use the photoperiod factor from the new photoperiod subroutine
      ! applied to soybeans. Adjust the thermal development units with
      ! the photoperiod factor (pf).

      !if (cname .eq. 'Soybean') then
      !    gddday = gddday*pf
      !endif

      return
      end


C     LAST UPDATE 20/12/94
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
      SUBROUTINE FPEARSON(X,A,Y,DYDA)
      IMPLICIT NONE
C
C Purpose: Y(X;A) is Pearson VII. The amplitude. centre and widths of
C          the Pearson VII are stored in consecutive locations of A:
C          A(1) = H,  A(2) = P,  A(3) = FWHM, A(4) = S
C
C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
C Parameters:
C
      DOUBLE PRECISION TINY,HALF,BIG
      PARAMETER(TINY=1.0D-10,HALF=0.5D0,BIG=1.0D03)
C
C Arguments:
C
      DOUBLE PRECISION A(10),DYDA(10)
      DOUBLE PRECISION X,Y
C
C Local variables:
C
      DOUBLE PRECISION  ARG,EX,FAC
C
C-----------------------------------------------------------------------
      IF(A(3).LT.TINY)A(3) = TINY
      IF(A(4).LT.HALF)A(4) = HALF
      IF(A(4).GT.BIG)A(4) = BIG
      ARG = (X-A(2))/A(3)
      EX = 2.0D0**(1.0D0/A(4)) - 1.0D0
      FAC = (1.0D0+4.0D0*ARG*ARG*EX)
      Y = A(1)/FAC**A(4)
      DYDA(1) = 1.0D0/FAC**A(4)
      DYDA(2) = 8.0D0*ARG*A(4)*EX*Y/(A(3)*FAC)
      DYDA(3) = ARG*DYDA(2)
      DYDA(4) = (4.0D0*ARG*ARG*LOG(2.0D0)*(EX+1.0D0)/
     &          (A(4)*FAC)-LOG(FAC))*Y
C
      RETURN
      END