! ###############################################################
! #                                                             #
! #                    THE VECTOR LIDORT MODEL                  #
! #                                                             #
! #  (Vector LInearized Discrete Ordinate Radiative Transfer)   #
! #   -      --         -        -        -         -           #
! #                                                             #
! ###############################################################

! ###############################################################
! #                                                             #
! #  Author :      Robert. J. D. Spurr                          #
! #                                                             #
! #  Address :     RT Solutions, inc.                           #
! #                9 Channing Street                            #
! #                Cambridge, MA 02138, USA                     #
! #                Tel: (617) 492 1183                          #
! #                                                             #
! #  Email :       rtsolutions@verizon.net                      #
! #                                                             #
! #  Versions     :   2.0, 2.2, 2.3, 2.4, 2.4R, 2.4RT, 2.4RTC,  #
! #                   2.5, 2.6, 2.7                             #
! #  Release Date :   December 2005  (2.0)                      #
! #  Release Date :   March 2007     (2.2)                      #
! #  Release Date :   October 2007   (2.3)                      #
! #  Release Date :   December 2008  (2.4)                      #
! #  Release Date :   April 2009     (2.4R)                     #
! #  Release Date :   July 2009      (2.4RT)                    #
! #  Release Date :   October 2010   (2.4RTC)                   #
! #  Release Date :   March 2011     (2.5)                      #
! #  Release Date :   May 2012       (2.6)                      #
! #  Release Date :   August 2014    (2.7)                      #
! #                                                             #
! #       NEW: TOTAL COLUMN JACOBIANS          (2.4)            #
! #       NEW: BPDF Land-surface KERNELS       (2.4R)           #
! #       NEW: Thermal Emission Treatment      (2.4RT)          #
! #       Consolidated BRDF treatment          (2.4RTC)         #
! #       f77/f90 Release                      (2.5)            #
! #       External SS / New I/O Structures     (2.6)            #
! #                                                             #
! #       SURFACE-LEAVING / BRDF-SCALING       (2.7)            #
! #       TAYLOR Series / OMP THREADSAFE       (2.7)            #
! #                                                             #
! ###############################################################

!    #####################################################
!    #                                                   #
!    #   This Version of VLIDORT comes with a GNU-style  #
!    #   license. Please read the license carefully.     #
!    #                                                   #
!    #####################################################

! ###############################################################
! #                                                             #
! #  This is vbrdf_aux.f. Utility routines                      #
! #  The subroutines in vbrdf_aux are listed below with their   #
! #      source of origin (order of appearance).                #
! #                                                             #
! #     brdf_gauleg:               Numerical Recipes, 1992      #
! #     derfc_e:                   V. Natraj, 2005              #
! #     GETQUAD2                   M. Christi, 2017             #
! #     VBRDF_Fresnel_Complex      R. Spurr, 2014 (Version 2.7) #
! #     BRDF_QUADRATURE_Gaussian   R. Spurr, 2004               #
! #     BRDF_QUADRATURE_Trapezoid  R. Spurr, 2004 (not used)    #
! #                                                             #
! ###############################################################

      MODULE vbrdf_sup_aux_m

      USE VLIDORT_PARS, only : zero, one, two, half, pie, FPK, QUARTER

!  Everything public here

      public

      CONTAINS

!

      SUBROUTINE GETQUAD2(A,B,N,ROOTS,WGTS)

!  Computes N roots and weights for Gauss-Legendre quadrature on the interval (a,b)

      IMPLICIT NONE

!  Limits of interval

      REAL(FPK), INTENT(IN)  :: A, B

!  Dimension

      INTEGER, INTENT(IN) :: N

!  Quadrature roots and weights

      REAL(FPK), INTENT(OUT) :: ROOTS(N), WGTS(N)

!  Local variables

      INTEGER   :: I, M, N2, NM1
      REAL(FPK) :: IR, MR, NR
      REAL(FPK) :: MIDPT, SFAC
      REAL(FPK) :: DLP_DX, LP, LPM1, LPM2, X, XOLD, XX

!  Threshold for Newton's Method

      REAL(FPK), PARAMETER :: QEPS = 1.0D-13

!  Since roots are symmetric about zero on the interval (-1,1), split the interval
!  in half and only work on the lower half of the interval (-1,0).

      N2 = INT((N + 1)/2)
      NR = REAL(N,FPK)

!  Define the shift [midpoint of (a,b)] and scale factor to later move roots from
!  the interval (-1,1) to the interval (a,b)

      MIDPT = HALF*(B + A)
      SFAC  = HALF*(B - A)

      DO M = 1, N2

!  Find current root of the related Nth order Legendre Polynomial on (-1,0) by Newton's
!  Method using two Legendre Polynomial recurrence relations (e.g. see Abramowitz &
!  Stegan (1972))

         !Define starting point [ after Tricomi (1950) ]
         MR = REAL(M,FPK)
         XX = PIE*(MR - QUARTER)/(NR + HALF)
         X  = (ONE - (NR - ONE)/(8.0_FPK*NR**3) &
             - ONE/(384.0_FPK*NR**4)*(39.0_FPK - 28.0_FPK/SIN(XX)**2))*COS(XX)

         !Use Newton's Method
         DO
            LPM1 = ZERO ; LP = ONE
            DO I = 1, N
               IR = REAL(I,FPK) ; LPM2 = LPM1 ; LPM1 = LP
               LP = ((TWO*IR - ONE)*X*LPM1 - (IR - ONE)*LPM2)/IR
            ENDDO
            DLP_DX = NR*(X*LP - LPM1)/(X**2 - ONE)
            XOLD = X ; X = XOLD - LP/DLP_DX
            IF (ABS(X-XOLD) <= QEPS) EXIT
         ENDDO

!  Shift and scale the current root (and its symmetric counterpart) from the interval (-1,1)
!  to the interval (a,b).  Define their related weights (e.g. see Abramowitz & Stegan (1972)).
!  Note:
!  If (1) N is even or (2) N is odd and M /= N2, then ROOTS(M) and ROOTS(NM1) are unique.
!  If N is odd and M = N2, then M = NM1 and ROOTS(M) = ROOTS(NM1) are one and the same root.

         !On interval lower half: (a,midpt)
         ROOTS(M)   = MIDPT - SFAC*X
         WGTS(M)    = (TWO*SFAC)/((ONE - X**2)*DLP_DX**2)

         !On interval upper half: (midpt,b)
         NM1 = N - M + 1
         ROOTS(NM1) = MIDPT + SFAC*X
         WGTS (NM1) = WGTS(M)

      ENDDO

      END SUBROUTINE GETQUAD2

!

      SUBROUTINE BRDF_GAULEG(X1,X2,X,W,N)

      implicit none

      INTEGER             N
      DOUBLE PRECISION X1,X2,X(N),W(N)
      INTEGER             I, M, J
      DOUBLE PRECISION EPS,XM,XL,P1,P2,P3,PP,Z,Z1
      PARAMETER (EPS=3.D-14)
      M=(N+1)/2
      XM=0.5D0*(X2+X1)
      XL=0.5D0*(X2-X1)
      DO I=1,M
            Z=DCOS(3.141592654D0*(I-.25D0)/(N+.5D0))
1            CONTINUE
                  P1=1.D0
                  P2=0.D0
                  DO J=1,N
                        P3=P2
                        P2=P1
                        P1=((2.D0*J-1.D0)*Z*P2-(J-1.D0)*P3)/J
                  ENDDO
                  PP=N*(Z*P1-P2)/(Z*Z-1.D0)
                  Z1=Z
                  Z=Z1-P1/PP
            IF(DABS(Z-Z1).GT.EPS)GO TO 1
            X(I)=XM-XL*Z
            X(N+1-I)=XM+XL*Z
            W(I)=2.D0*XL/((1.D0-Z*Z)*PP*PP)
            W(N+1-I)=W(I)
      ENDDO
      RETURN
      END SUBROUTINE BRDF_GAULEG

!

      double precision function derfc_e(x)
      implicit none
      double precision :: x

! Returns the complementary error function erfc(x) with fractional error
! everywhere less than 1.2 * 10^7.

      double precision :: t,z

      z = dabs(x)
      t = 1.d0/(1.d0+0.5d0*z)
      derfc_e = t*dexp(-z*z-1.26551223d0+t*(1.00002368d0+t*(.37409196d0+ &
              t*(.09678418d0+t*(-.18628806d0+t*(.27886807d0+t* &
              (-1.13520398d0+t*(1.48851587d0+t*(-.82215223d0+t* &
              .17087277d0)))))))))
      if (x .lt. 0.d0) derfc_e = 2.d0-derfc_e

      return
      END function derfc_e

!

Subroutine VBRDF_Fresnel_Complex ( MR, MI, COSCHI, FP )

!  Renamed for the BRDF supplement.
!    (Same routine occurs also in the VSLEAVE suite)
!    Adapted from SixS code, this is essentially Born/Wolf computation

   implicit none

!  Arguments

   double precision, intent(in)  :: MR, MI, COSCHI
   double precision, intent(out) :: FP

!  Local

   double precision :: MRSQ, MISQ, MSQ, MRMI2, SINCHI_SQ, AA, A1, A2, B1, B2
   double precision :: U, V, VSQ, CMU, CPU, RR2
   double precision :: B1MU, B1PU, B2MV, B2PV, RL2

!  Calculation of FP, Complex RI

   IF ( MI.eq.zero) goto 67

   MRSQ = MR * MR ; MISQ = MI * MI
   MSQ   = MRSQ - MISQ
   MRMI2 = two * MR * MI

   SINCHI_SQ = one - COSCHI * COSCHI
   AA = MSQ - SINCHI_SQ
   A1 = abs(AA)
   A2 = SQRT ( AA*AA + MRMI2 * MRMI2 )

   U = sqrt(half*abs(A1+A2))
   V = sqrt(half*abs(-A1+A2))
   VSQ = V * V
   CMU = ( COSCHI - U ) ; CPU = ( COSCHI + U )
   RR2 = ( CMU*CMU + VSQ ) / ( CPU*CPU + VSQ )

   B1 = MSQ   * COSCHI
   B2 = MRMI2 * COSCHI
   B1MU = B1 - U ; B1PU = B1 + U
   B2PV = B2 + V ; B2MV = B2 - V

   RL2 = ( B1MU*B1MU + B2PV*B2PV ) / ( B1PU*B1PU + B2MV*B2MV )
   FP = half * ( RR2 + RL2 )
   return

!  Calculation of FP. Real RI

67 continue
   MSQ = MR * MR
   SINCHI_SQ = one - COSCHI * COSCHI
   U = sqrt(abs(MSQ - SINCHI_SQ))
   CMU = ( COSCHI - U ) ; CPU = ( COSCHI + U )
   RR2  = CMU*CMU / ( CPU*CPU )
   B1   = MSQ * COSCHI
   B1MU = B1 - U ; B1PU = B1 + U
   RL2  = B1MU*B1MU / ( B1PU*B1PU )
   FP   = half * ( RR2 + RL2 )

!  Finish

   return
end subroutine VBRDF_Fresnel_Complex

      SUBROUTINE BRDF_QUADRATURE_GAUSSIAN &
         ( DO_BRDF_SURFEMISSION, NSTREAMS_BRDF, NBRDF_HALF, &
           X_BRDF, CX_BRDF, SX_BRDF, A_BRDF, &
           BAX_BRDF, CXE_BRDF, SXE_BRDF )

!  include file of dimensions and numbers

      USE VLIDORT_PARS

      IMPLICIT NONE

!  Input
!  =====

!  Emission flag

      LOGICAL ::          DO_BRDF_SURFEMISSION

!  Number of streams

      INTEGER ::          NSTREAMS_BRDF, NBRDF_HALF

!  OUTPUT
!  ======

!  azimuth quadrature streams for BRDF

      DOUBLE PRECISION :: X_BRDF  ( MAXSTREAMS_BRDF )
      DOUBLE PRECISION :: CX_BRDF ( MAXSTREAMS_BRDF )
      DOUBLE PRECISION :: SX_BRDF ( MAXSTREAMS_BRDF )
      DOUBLE PRECISION :: A_BRDF  ( MAXSTREAMS_BRDF )

!  For emission calculations

      DOUBLE PRECISION :: BAX_BRDF ( MAXSTHALF_BRDF )
      DOUBLE PRECISION :: CXE_BRDF ( MAXSTHALF_BRDF )
      DOUBLE PRECISION :: SXE_BRDF ( MAXSTHALF_BRDF )

!  local variables
!  ---------------

      INTEGER ::          I, I1, K

!  BRDF quadrature (Gauss-Legendre)
!  ---------------

!  Save these quantities for efficient coding

      CALL GETQUAD2 ( ZERO, ONE, NBRDF_HALF, X_BRDF, A_BRDF )
      DO I = 1, NBRDF_HALF
        I1 = I + NBRDF_HALF
        X_BRDF(I1) = - X_BRDF(I)
        A_BRDF(I1) =   A_BRDF(I)
        CXE_BRDF(I) = X_BRDF(I)
        SXE_BRDF(I) = DSQRT(ONE-X_BRDF(I)*X_BRDF(I))
      ENDDO
      DO I = 1, NSTREAMS_BRDF
        X_BRDF(I)  = PIE * X_BRDF(I)
        CX_BRDF(I) = DCOS ( X_BRDF(I) )
        SX_BRDF(I) = DSIN ( X_BRDF(I) )
      ENDDO

!  Half space cosine-weight arrays (emission only, non-Lambertian)

      IF ( DO_BRDF_SURFEMISSION ) THEN
        DO K = 1, NBRDF_HALF
          BAX_BRDF(K) = X_BRDF(K) * A_BRDF(K) / PIE
        ENDDO
      ENDIF

!  Finish

      RETURN
      END SUBROUTINE BRDF_QUADRATURE_GAUSSIAN

!

      SUBROUTINE BRDF_QUADRATURE_TRAPEZOID &
         ( DO_BRDF_SURFEMISSION, NSTREAMS_BRDF, NBRDF_HALF, &
           X_BRDF, CX_BRDF, SX_BRDF, A_BRDF, &
           BAX_BRDF, CXE_BRDF, SXE_BRDF )

!  include file of dimensions and numbers

      USE VLIDORT_PARS

      IMPLICIT NONE

!  Input
!  =====

!  Emission flag

      LOGICAL ::          DO_BRDF_SURFEMISSION

!  Number of streams

      INTEGER ::          NSTREAMS_BRDF, NBRDF_HALF

!  OUTPUT
!  ======

!  azimuth quadrature streams for BRDF

      DOUBLE PRECISION :: X_BRDF  ( MAXSTREAMS_BRDF )
      DOUBLE PRECISION :: CX_BRDF ( MAXSTREAMS_BRDF )
      DOUBLE PRECISION :: SX_BRDF ( MAXSTREAMS_BRDF )
      DOUBLE PRECISION :: A_BRDF  ( MAXSTREAMS_BRDF )

!  For emission calculations

      DOUBLE PRECISION :: BAX_BRDF ( MAXSTHALF_BRDF )
      DOUBLE PRECISION :: CXE_BRDF ( MAXSTHALF_BRDF )
      DOUBLE PRECISION :: SXE_BRDF ( MAXSTHALF_BRDF )

!  local variables
!  ---------------

      INTEGER ::          I, I1, K
      DOUBLE PRECISION :: DF1, DEL

!  BRDF quadrature (Trapezium)
!  ---------------

!  Save these quantities for efficient coding

      DF1 = DBLE(NSTREAMS_BRDF - 1 )
      DEL = TWO * PIE / DF1
        DO I = 1, NSTREAMS_BRDF
        I1 = I - 1
        X_BRDF(I) = DBLE(I1) * DEL - PIE
        X_BRDF(I) = DBLE(I1) * DEL
        CX_BRDF(I) = DCOS ( X_BRDF(I) )
        SX_BRDF(I) = DSIN ( X_BRDF(I) )
        CXE_BRDF(I) = CX_BRDF(I)
        SXE_BRDF(I) = SX_BRDF(I)
      ENDDO
        DO I = 2, NSTREAMS_BRDF - 1
        A_BRDF(I)  = DEL / PIE
      ENDDO
      A_BRDF(1)              = DEL * HALF / PIE
      A_BRDF(NSTREAMS_BRDF)  = DEL * HALF / PIE

!  Half space cosine-weight arrays (emission only, non-Lambertian)

      IF ( DO_BRDF_SURFEMISSION ) THEN
        DO K = 1, NBRDF_HALF
          BAX_BRDF(K) = X_BRDF(K) * A_BRDF(K) / PIE
        ENDDO
      ENDIF

!  Finish

      RETURN
      END SUBROUTINE BRDF_QUADRATURE_TRAPEZOID

!  End module

      END MODULE vbrdf_sup_aux_m


      subroutine gen_del1del2_bub3m(p,n,P1,P2,za,zb)
      implicit none
      include 'constants.f'
      include 'zprods_decl.f'
      include 'utoolscc.f'
      double precision p(mxpart,4),P1(4),P2(4)
      integer n,nu
      double precision g1,DEL,a,b
      double precision P1dP2,P1dP1,P2dP2
      double precision del1(4),del2(4)
      double precision pmo(mxpart,4)

      pmo(:,:)=p(:,:)

      P1dP2=0d0
      P1dP1=0d0
      P2dP2=0d0
      do nu=1,3
         P1dP2=P1dP2-P1(nu)*P2(nu)
         P1dP1=P1dP1-P1(nu)*P1(nu)
         P2dP2=P2dP2-P2(nu)*P2(nu)
      enddo
      nu=4
      P1dP2=P1dP2+P1(nu)*P2(nu)
      P1dP1=P1dP1+P1(nu)*P1(nu)
      P2dP2=P2dP2+P2(nu)*P2(nu)

      DEL=P1dP2**2-P1dP1*P2dP2
      g1=P1dP2+dsqrt(DEL)
      a=P1dP1/g1
      b=P2dP2/g1

      do nu=1,4
         del1(nu)=one/(one-a*b)*(P1(nu)-a*P2(nu))
         del2(nu)=one/(one-a*b)*(P2(nu)-b*P1(nu))
      enddo

      do nu=1,4
         pmo(n+1,nu)=del1(nu)
         pmo(n+2,nu)=del2(nu)
      enddo

      if (utoolscc) then
        call spinoruorz(n+2,pmo,zb,za)
      else
        call spinoruorz(n+2,pmo,za,zb)
      endif

      return
      end


!*==ssytrs_3.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief \b SSYTRS_3
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download SSYTRS_3 + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE SSYTRS_3( UPLO, N, NRHS, A, LDA, E, IPIV, B, LDB,
!                            INFO )
!
!       .. Scalar Arguments ..
!       CHARACTER          UPLO
!       INTEGER            INFO, LDA, LDB, N, NRHS
!       ..
!       .. Array Arguments ..
!       INTEGER            IPIV( * )
!       REAL               A( LDA, * ), B( LDB, * ), E( * )
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!> SSYTRS_3 solves a system of linear equations A * X = B with a real
!> symmetric matrix A using the factorization computed
!> by SSYTRF_RK or SSYTRF_BK:
!>
!>    A = P*U*D*(U**T)*(P**T) or A = P*L*D*(L**T)*(P**T),
!>
!> where U (or L) is unit upper (or lower) triangular matrix,
!> U**T (or L**T) is the transpose of U (or L), P is a permutation
!> matrix, P**T is the transpose of P, and D is symmetric and block
!> diagonal with 1-by-1 and 2-by-2 diagonal blocks.
!>
!> This algorithm is using Level 3 BLAS.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] UPLO
!> \verbatim
!>          UPLO is CHARACTER*1
!>          Specifies whether the details of the factorization are
!>          stored as an upper or lower triangular matrix:
!>          = 'U':  Upper triangular, form is A = P*U*D*(U**T)*(P**T);
!>          = 'L':  Lower triangular, form is A = P*L*D*(L**T)*(P**T).
!> \endverbatim
!>
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!> \endverbatim
!>
!> \param[in] NRHS
!> \verbatim
!>          NRHS is INTEGER
!>          The number of right hand sides, i.e., the number of columns
!>          of the matrix B.  NRHS >= 0.
!> \endverbatim
!>
!> \param[in] A
!> \verbatim
!>          A is REAL array, dimension (LDA,N)
!>          Diagonal of the block diagonal matrix D and factors U or L
!>          as computed by SSYTRF_RK and SSYTRF_BK:
!>            a) ONLY diagonal elements of the symmetric block diagonal
!>               matrix D on the diagonal of A, i.e. D(k,k) = A(k,k);
!>               (superdiagonal (or subdiagonal) elements of D
!>                should be provided on entry in array E), and
!>            b) If UPLO = 'U': factor U in the superdiagonal part of A.
!>               If UPLO = 'L': factor L in the subdiagonal part of A.
!> \endverbatim
!>
!> \param[in] LDA
!> \verbatim
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!> \endverbatim
!>
!> \param[in] E
!> \verbatim
!>          E is REAL array, dimension (N)
!>          On entry, contains the superdiagonal (or subdiagonal)
!>          elements of the symmetric block diagonal matrix D
!>          with 1-by-1 or 2-by-2 diagonal blocks, where
!>          If UPLO = 'U': E(i) = D(i-1,i),i=2:N, E(1) not referenced;
!>          If UPLO = 'L': E(i) = D(i+1,i),i=1:N-1, E(N) not referenced.
!>
!>          NOTE: For 1-by-1 diagonal block D(k), where
!>          1 <= k <= N, the element E(k) is not referenced in both
!>          UPLO = 'U' or UPLO = 'L' cases.
!> \endverbatim
!>
!> \param[in] IPIV
!> \verbatim
!>          IPIV is INTEGER array, dimension (N)
!>          Details of the interchanges and the block structure of D
!>          as determined by SSYTRF_RK or SSYTRF_BK.
!> \endverbatim
!>
!> \param[in,out] B
!> \verbatim
!>          B is REAL array, dimension (LDB,NRHS)
!>          On entry, the right hand side matrix B.
!>          On exit, the solution matrix X.
!> \endverbatim
!>
!> \param[in] LDB
!> \verbatim
!>          LDB is INTEGER
!>          The leading dimension of the array B.  LDB >= max(1,N).
!> \endverbatim
!>
!> \param[out] INFO
!> \verbatim
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date June 2017
!
!> \ingroup singleSYcomputational
!
!> \par Contributors:
!  ==================
!>
!> \verbatim
!>
!>  June 2017,  Igor Kozachenko,
!>                  Computer Science Division,
!>                  University of California, Berkeley
!>
!>  September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
!>                  School of Mathematics,
!>                  University of Manchester
!>
!> \endverbatim
!
!  ====================================================================
      SUBROUTINE SSYTRS_3(Uplo,N,Nrhs,A,Lda,E,Ipiv,B,Ldb,Info)
      IMPLICIT NONE
!*--SSYTRS_3168
!
!  -- LAPACK computational routine (version 3.7.1) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     June 2017
!
!     .. Scalar Arguments ..
      CHARACTER Uplo
      INTEGER Info , Lda , Ldb , N , Nrhs
!     ..
!     .. Array Arguments ..
      INTEGER Ipiv(*)
      REAL A(Lda,*) , B(Ldb,*) , E(*)
!     ..
!
!  =====================================================================
!
!     .. Parameters ..
      REAL ONE
      PARAMETER (ONE=1.0E+0)
!     ..
!     .. Local Scalars ..
      LOGICAL upper
      INTEGER i , j , k , kp
      REAL ak , akm1 , akm1k , bk , bkm1 , denom
!     ..
!     .. External Functions ..
      LOGICAL LSAME
      EXTERNAL LSAME
!     ..
!     .. External Subroutines ..
      EXTERNAL SSCAL , SSWAP , STRSM , XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC ABS , MAX
!     ..
!     .. Executable Statements ..
!
      Info = 0
      upper = LSAME(Uplo,'U')
      IF ( .NOT.upper .AND. .NOT.LSAME(Uplo,'L') ) THEN
         Info = -1
      ELSEIF ( N<0 ) THEN
         Info = -2
      ELSEIF ( Nrhs<0 ) THEN
         Info = -3
      ELSEIF ( Lda<MAX(1,N) ) THEN
         Info = -5
      ELSEIF ( Ldb<MAX(1,N) ) THEN
         Info = -9
      ENDIF
      IF ( Info/=0 ) THEN
         CALL XERBLA('SSYTRS_3',-Info)
         RETURN
      ENDIF
!
!     Quick return if possible
!
      IF ( N==0 .OR. Nrhs==0 ) RETURN
!
      IF ( upper ) THEN
!
!        Begin Upper
!
!        Solve A*X = B, where A = U*D*U**T.
!
!        P**T * B
!
!        Interchange rows K and IPIV(K) of matrix B in the same order
!        that the formation order of IPIV(I) vector for Upper case.
!
!        (We can do the simple loop over IPIV with decrement -1,
!        since the ABS value of IPIV(I) represents the row index
!        of the interchange with row i in both 1x1 and 2x2 pivot cases)
!
         DO k = N , 1 , -1
            kp = ABS(Ipiv(k))
            IF ( kp/=k ) CALL SSWAP(Nrhs,B(k,1),Ldb,B(kp,1),Ldb)
         ENDDO
!
!        Compute (U \P**T * B) -> B    [ (U \P**T * B) ]
!
         CALL STRSM('L','U','N','U',N,Nrhs,ONE,A,Lda,B,Ldb)
!
!        Compute D \ B -> B   [ D \ (U \P**T * B) ]
!
         i = N
         DO WHILE ( i>=1 )
            IF ( Ipiv(i)>0 ) THEN
               CALL SSCAL(Nrhs,ONE/A(i,i),B(i,1),Ldb)
            ELSEIF ( i>1 ) THEN
               akm1k = E(i)
               akm1 = A(i-1,i-1)/akm1k
               ak = A(i,i)/akm1k
               denom = akm1*ak - ONE
               DO j = 1 , Nrhs
                  bkm1 = B(i-1,j)/akm1k
                  bk = B(i,j)/akm1k
                  B(i-1,j) = (ak*bkm1-bk)/denom
                  B(i,j) = (akm1*bk-bkm1)/denom
               ENDDO
               i = i - 1
            ENDIF
            i = i - 1
         ENDDO
!
!        Compute (U**T \ B) -> B   [ U**T \ (D \ (U \P**T * B) ) ]
!
         CALL STRSM('L','U','T','U',N,Nrhs,ONE,A,Lda,B,Ldb)
!
!        P * B  [ P * (U**T \ (D \ (U \P**T * B) )) ]
!
!        Interchange rows K and IPIV(K) of matrix B in reverse order
!        from the formation order of IPIV(I) vector for Upper case.
!
!        (We can do the simple loop over IPIV with increment 1,
!        since the ABS value of IPIV(I) represents the row index
!        of the interchange with row i in both 1x1 and 2x2 pivot cases)
!
         DO k = 1 , N , 1
            kp = ABS(Ipiv(k))
            IF ( kp/=k ) CALL SSWAP(Nrhs,B(k,1),Ldb,B(kp,1),Ldb)
         ENDDO
!
      ELSE
!
!        Begin Lower
!
!        Solve A*X = B, where A = L*D*L**T.
!
!        P**T * B
!        Interchange rows K and IPIV(K) of matrix B in the same order
!        that the formation order of IPIV(I) vector for Lower case.
!
!        (We can do the simple loop over IPIV with increment 1,
!        since the ABS value of IPIV(I) represents the row index
!        of the interchange with row i in both 1x1 and 2x2 pivot cases)
!
         DO k = 1 , N , 1
            kp = ABS(Ipiv(k))
            IF ( kp/=k ) CALL SSWAP(Nrhs,B(k,1),Ldb,B(kp,1),Ldb)
         ENDDO
!
!        Compute (L \P**T * B) -> B    [ (L \P**T * B) ]
!
         CALL STRSM('L','L','N','U',N,Nrhs,ONE,A,Lda,B,Ldb)
!
!        Compute D \ B -> B   [ D \ (L \P**T * B) ]
!
         i = 1
         DO WHILE ( i<=N )
            IF ( Ipiv(i)>0 ) THEN
               CALL SSCAL(Nrhs,ONE/A(i,i),B(i,1),Ldb)
            ELSEIF ( i<N ) THEN
               akm1k = E(i)
               akm1 = A(i,i)/akm1k
               ak = A(i+1,i+1)/akm1k
               denom = akm1*ak - ONE
               DO j = 1 , Nrhs
                  bkm1 = B(i,j)/akm1k
                  bk = B(i+1,j)/akm1k
                  B(i,j) = (ak*bkm1-bk)/denom
                  B(i+1,j) = (akm1*bk-bkm1)/denom
               ENDDO
               i = i + 1
            ENDIF
            i = i + 1
         ENDDO
!
!        Compute (L**T \ B) -> B   [ L**T \ (D \ (L \P**T * B) ) ]
!
         CALL STRSM('L','L','T','U',N,Nrhs,ONE,A,Lda,B,Ldb)
!
!        P * B  [ P * (L**T \ (D \ (L \P**T * B) )) ]
!
!        Interchange rows K and IPIV(K) of matrix B in reverse order
!        from the formation order of IPIV(I) vector for Lower case.
!
!        (We can do the simple loop over IPIV with decrement -1,
!        since the ABS value of IPIV(I) represents the row index
!        of the interchange with row i in both 1x1 and 2x2 pivot cases)
!
         DO k = N , 1 , -1
            kp = ABS(Ipiv(k))
            IF ( kp/=k ) CALL SSWAP(Nrhs,B(k,1),Ldb,B(kp,1),Ldb)
         ENDDO
!
!        END Lower
!
      ENDIF
!
!
!     End of SSYTRS_3
!
      END SUBROUTINE SSYTRS_3


      subroutine tftmat(trans,l1,l2,idp,fold)
      use tfstk
      use ffs
      use ffs_pointer
      use tffitcode
      implicit none
      integer*4 l1,l2,idp,i
      real*8 trans(4,5)
      real*8 utwiss1(ntwissfun),utwiss2(ntwissfun)
      logical*4 fold
      do i=1,mfitdetr
        utwiss1(i)=twiss(l1,idp,i)
        utwiss2(i)=twiss(l2,idp,i)
      enddo
      call tftmatu(utwiss1,utwiss2,
     $     twiss(nlat,idp,mfitnx),twiss(nlat,idp,mfitny),
     $     trans,l1,l2,fold,trpt)
      return
      end

      subroutine tftmatu(utwiss1,utwiss2,amux,amuy,
     $     trans,l1,l2,fold,trpt1)
      use ffs
      use ffs_pointer
      use tffitcode
      implicit none
      integer*4 l1,l2
      real*8 utwiss1(*),utwiss2(*)
      real*8 trans(4,5),amux,amuy
      logical*4 fold,trpt1
      integer*4 i
      real*8 detr,cc,x,px,y,py,r1,r2,r3,r4
      call qgettru(utwiss1,utwiss2,amux,amuy,
     $     trans,l1,l2,.false.,fold,trpt1)
      r1=utwiss1(mfitr1)
      r2=utwiss1(mfitr2)
      r3=utwiss1(mfitr3)
      r4=utwiss1(mfitr4)
      detr=r1*r4-r2*r3
      cc=sqrt(1.d0-detr)
      if(utwiss1(mfitdetr) .lt. 1.d0)then
        do 20 i=1,4
          x=trans(i,1)
          px=trans(i,2)
          y=trans(i,3)
          py=trans(i,4)
          trans(i,1)=cc*x +r1*y+r3*py
          trans(i,2)=cc*px+r2*y+r4*py
          trans(i,3)=cc*y -r4*x+r3*px
          trans(i,4)=cc*py+r2*x-r1*px
20      continue
      else
        do 30 i=1,4
          x=trans(i,1)
          px=trans(i,2)
          y=trans(i,3)
          py=trans(i,4)
          trans(i,1)=cc*y  +(-r4*x+r3*px)
          trans(i,2)=cc*py +( r2*x-r1*px)
          trans(i,3)=cc*x  +( r1*y+r3*trans(i,4))
          trans(i,4)=cc*px +( r2*y+r4*trans(i,4))
30      continue
      endif
      return
      end


subroutine pcgsqrt(xhat,costf,gradx,itermax,nprt)

!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    pcgsqrt
!   prgmmr:      tremolet
!
! abstract: solve inner loop of analysis equation using conjugate
!           gradient preconditioned with sqrt(B).
!
! program history log:
!   2007-04-27  tremolet - initial code
!   2009-01-14  todling  - zero-obs fix
!   2009-01-18  todling  - carry summations in quad precision
!   2010-08-19  lueken   - add only to module use
!   2010-10-01  el akkraoui - add orthogonalization using first few iterates
!   2011-03-02  todling   - revisit memory release: first-in, last-out
!   2012-02-08  el akkraoui - fix estimate (remove xhat) per Selime Gurol
!
!   input argument lits:
!    xhat,gradx
!    costf
!    itermax,nprt
!
!   output argument list:
!    xhat,gradx
!    costf
!
! attributes:
!   language: f90
!   machine:
!
!$$$ end documentation block

use kinds, only: r_kind,i_kind,r_quad
use jfunc, only: iter,jiter
use gsi_4dvar, only: iorthomax
use constants, only: zero,zero_quad,tiny_r_kind
use mpimod, only: mype
use control_vectors, only: control_vector,allocate_cv, &
    deallocate_cv,dot_product,assignment(=)
use timermod,only: timer_ini,timer_fnl

implicit none

! Declare arguments
type(control_vector), intent(inout) :: xhat,gradx
real(r_kind)        , intent(inout) :: costf
integer(i_kind)     , intent(in   ) :: itermax,nprt

! Declare local variables
character(len=*), parameter :: myname='pcgsqrt'
type(control_vector)        :: dirx,xtry,grtry,grad0,gradf
type(control_vector), allocatable, dimension(:) :: cglwork
real(r_quad)                :: beta,alpha,zg0,zgk,zgnew,zfk,dkqk,zdla
integer(i_kind)             :: ii,jj,iortho
logical                     :: lsavinc

!**********************************************************************
call timer_ini('pcgsqrt')

! Allocate local variables
call allocate_cv(dirx)
call allocate_cv(xtry)
call allocate_cv(grtry)
call allocate_cv(grad0)
if (nprt>=1) call allocate_cv(gradf)

! Initializations
dirx=zero
beta=zero_quad
lsavinc=.false.

if(iorthomax>0) then
   allocate(cglwork(iorthomax+1))
   do ii=1,iorthomax+1
      call allocate_cv(cglwork(ii))
      cglwork(ii)=zero
   enddo
end if

! Save initial cost function and gradient
grad0=gradx
zg0=dot_product(grad0,grad0,r_quad)
zgk=zg0

if(iorthomax>0) then
  do ii=1,dirx%lencv
     cglwork(1)%values(ii)=gradx%values(ii)/sqrt(zg0)
  end do
end if

! Perform inner iteration
inner_iteration: do iter=1,itermax
   if (mype==0) write(6,*)trim(myname),': Minimization iteration',iter

!  Search direction
   do ii=1,dirx%lencv
      dirx%values(ii)=-gradx%values(ii)+beta*dirx%values(ii)
   end do

!  Estimate
   do ii=1,xtry%lencv
      xtry%values(ii)=dirx%values(ii)
   end do

!  Evaluate cost and gradient
   call evaljgrad(xtry,zfk,grtry,lsavinc,0,myname)

!  Get A q_k
   do ii=1,grtry%lencv
      grtry%values(ii)=grtry%values(ii)-grad0%values(ii)
   end do

!  Calculate stepsize
   dkqk=dot_product(dirx,grtry,r_quad)
   alpha=zero_quad
   if(abs(dkqk)>tiny_r_kind) alpha = zgk/dkqk

!  Update estimates
   do ii=1,xhat%lencv
      xhat%values(ii) =xhat%values(ii) +alpha* dirx%values(ii)
      gradx%values(ii)=gradx%values(ii)+alpha*grtry%values(ii)
   end do

!  Orthogonormalize against previous gradient
   if(iorthomax>0) then
      iortho=min(iter,iorthomax)
      do jj=iortho,1,-1
        zdla = dot_product(gradx,cglwork(jj))
        do ii=1,gradx%lencv
           gradx%values(ii) = gradx%values(ii) - zdla*cglwork(jj)%values(ii)
        enddo
     enddo
   end if

!  Save gradients for orthonormalization
   zgnew=dot_product(gradx,gradx,r_quad)
   if(iorthomax>0 .and. iter <= iortho) then
      do ii=1,xhat%lencv
         cglwork(iter+1)%values(ii) = gradx%values(ii)/sqrt(zgnew)
      enddo
   end if
!
   beta=zero_quad
   if(abs(zgk)>tiny_r_kind) beta=zgnew/zgk
   zgk=zgnew

!  Evaluate cost for printout
   if (nprt>=1) call evaljgrad(xhat,zfk,gradf,lsavinc,nprt,myname)

   if (mype==0) then
      if (abs(zg0)>tiny_r_kind) then
         write(6,999)trim(myname),': grepgrad grad,reduction,step=',jiter,iter,sqrt(real(zgk,r_kind)),&
              sqrt(real(zgk,r_kind)/real(zg0,r_kind)),real(alpha,r_kind)
      else
         write(6,999)trim(myname),': grepgrad grad,reduction,step=',jiter,iter,sqrt(real(zgk,r_kind)),&
              zero,real(alpha,r_kind)
      endif
   endif

end do inner_iteration
costf=zfk

! Release memory
if(iorthomax>0) then
  do ii=iorthomax+1,1,-1
     call deallocate_cv(cglwork(ii))
  enddo
  deallocate(cglwork)
end if
if (nprt>=1) call deallocate_cv(gradf)
call deallocate_cv(grad0)
call deallocate_cv(grtry)
call deallocate_cv(xtry)
call deallocate_cv(dirx)

999 format(2A,2(1X,I3),3(1X,ES25.18))

call timer_fnl('pcgsqrt')
return
end subroutine pcgsqrt


subroutine asciiplot(imag,nx,ny,dny,ilog,imin,imax)
real:: imag(nx,ny), imin,imax
character*16 ascii_chars
character*16 ascii_chars2

character*100 line
integer ::  ilev, dny, ilog
ascii_chars="MNHQ$OC?7>!:-;. "
ascii_chars2=".-+*$#@&"
line=''//ascii_chars(1:1)//ascii_chars(2:2)
line=line(1:2)//ascii_chars(3:3)
!print*, nx, ny, dny, ilog, imin, imax
!return
if (ilog==1) then
   do i=1,nx
      line=''
      ij=0
      do j=1,ny,dny
         ij=ij+1
         ilev=1
         if(imag(i,j)>0.) then
            ilev=(8.*(log(imag(i,j))-log(imin))/(log(imax)-log(imin)))+1
         end if
         if(ilev>8) ilev=8
         if(ilev<1) ilev=1
         i1=ilev
         if(ij==1) then
            line=ascii_chars2(i1:i1)
         else
            line(1:ij)=line(1:ij-1)//ascii_chars2(i1:i1)
         endif
      enddo
      write(*,101) line
   enddo
101 format(100A)
endif

end subroutine asciiplot


      SUBROUTINE AXLOOP (BUF,IBUF,XX,YY,ZZ,HC1,HC2,HC3)
C
      INTEGER         OTPE
      DIMENSION       BUF(50),IBUF(50)
      CHARACTER       UFM*23,UWM*25
      COMMON /XMSSG / UFM,UWM
      COMMON /SYSTEM/ SYSBUF,OTPE
      COMMON /BLANK / IDUM(3),EPSE
C
      PI    = 3.1415926536
      PIBY2 = 1.5707963268
      FPI   = 12.56637062
      C     = 1.
C
      XJ  = BUF(1)
      IAXI= IBUF(2)
      X1  = BUF(3)
      Y1  = BUF(4)
      Z1  = BUF(5)
      X2  = BUF(6)
      Y2  = BUF(7)
      Z2  = BUF(8)
      XC  = BUF(9)
      YC  = BUF(10)
      ZC  = BUF(11)
C
C     FOR NOW, ICID = 0
C
      ICID = IBUF(12)
C
C     CHECK FOR AXISYMMETRIC PROBLEM
C
      IF (IAXI .NE. 1) GO TO 10
      XC = 0.
      YC = 0.
      ZC = Z1
      X2 = 0.
      Y2 = X1
      Z2 = Z1
   10 CONTINUE
C
C     DETERMINE THE DIRECTION OF THE CURRENT LOOP AXIS
C
      CX = X1 - XC
      CY = Y1 - YC
      CZ = Z1 - ZC
      BX = X2 - XC
      BY = Y2 - YC
      BZ = Z2 - ZC
C
C     THE VECTOR AN IS NORMAL TO THE PLANE OF THE LOOP
C
      ANX = CY*BZ - CZ*BY
      ANY = CZ*BX - CX*BZ
      ANZ = CX*BY - CY*BX
      AT1 = SQRT(ANX*ANX + ANY*ANY + ANZ*ANZ)
      AT2  = BX*BX + BY*BY + BZ*BZ
      RAD2 = CX*CX + CY*CY + CZ*CZ
      RADIUS = SQRT(RAD2)
      XIACPI = (XJ*RAD2*PI)/C
C
      ANX = ANX/AT1
      ANY = ANY/AT1
      ANZ = ANZ/AT1
C
C     THE VECTOR R IS FROM THE CENTER OF LOOP TO THE FIELD POINT
C
      RX = XX - XC
      RY = YY - YC
      RZ = ZZ - ZC
C
      R2 = RX*RX + RY*RY + RZ*RZ
      R  = SQRT(R2)
C
C     AT (OR NEAR) CENTER OF LOOP TEST
C
      IF (R .GE. .001) GO TO 218
      COSTHE = 1.
      SINTHE = 0.
      SQAR2S = SQRT(RAD2+R2)
      RX  = ANX
      RY  = ANY
      RZ  = ANZ
      RPX = 0.
      RPY = 0.
      RPZ = 0.
      GO TO 220
  218 CONTINUE
C
      RX = RX/R
      RY = RY/R
      RZ = RZ/R
      COSTHE = ANX*RX + ANY*RY + ANZ*RZ
      SINTHE = SQRT(1. - COSTHE*COSTHE)
C
C     ON (OR VERY NEAR) AXIS OF LOOP TEST
C
      IF (SINTHE .GE. .000001) GO TO 219
      COSTHE = 1.
      SINTHE = 0.
      SQAR2S = SQRT(RAD2+R2)
      RX  = ANX
      RY  = ANY
      RZ  = ANZ
      RPX = 0.
      RPY = 0.
      RPZ = 0.
      GO TO 220
  219 CONTINUE
C
      SQAR2S = SQRT(RAD2 + R2 + (2.*RADIUS*R*SINTHE))
      REALK2 = (4.*RADIUS*R*SINTHE)/(RAD2+R2+(2.*RADIUS*R*SINTHE))
      REALK  = SQRT(REALK2)
      XIACR  = (XJ*RADIUS)/(C*R)
C
C     A CROSS R, NORMAL TO THE PLANE OF A AND R
C
      TX = ANY*RZ - ANZ*RY
      TY = ANZ*RX - ANX*RZ
      TZ = ANX*RY - ANY*RX
C
C     (A CROSS R) CROSS R, NORMAL TO THE PLANE OF R AND (A AND R)
C
      TRPX = TY*RZ - TZ*RY
      TRPY = TZ*RX - TX*RZ
      TRPZ = TX*RY - TY*RX
      AT3  = SQRT(TRPX*TRPX + TRPY*TRPY + TRPZ*TRPZ)
C
C     RPERP, PERPENDICULAR TO THE VECTOR FROM THE CENTER TO THE FIELD PT
C
      RPX = TRPX/AT3
      RPY = TRPY/AT3
      RPZ = TRPZ/AT3
C
C     FOR SMALL POLAR ANGLE OR SMALL RADIUS USE ALTERNATIVE APPROX.
C
      IF (REALK2 .LT. .0001) GO TO 220
C
C     COMPUTE ELLIPTIC INTEGRAL OF FIRST KIND
C
      F = 1.
      DELTF1 = 1.
      DO 240 N = 1,15000
      XN2  = 2.*FLOAT(N)
      XN21 = XN2 - 1.
      DELTF1 = DELTF1*(XN21/XN2)*REALK
      DELTF2 = DELTF1*DELTF1
      F = F + DELTF2
      IF (ABS(DELTF2/F) .LE. EPSE) GO TO 250
  240 CONTINUE
      DELF = ABS(DELTF2/F)
      WRITE (OTPE,245) UWM,XX,YY,ZZ,XC,YC,ZC,X1,Y1,Z1,X2,Y2,Z2,DELF,EPSE
  245 FORMAT (A25,', CONVERGENCE OF ELLIPTIC INTEGRAL IS UNCERTAIN. ',
     1     'GRID OR INTEGRATION POINT AT COORDINATES', /5X,
     2     1P,3E15.6,'  IS TOO CLOSE TO CURRENT LOOP WITH CENTER AT',
     3     /5X,1P,3E15.6,' AND 2 POINTS AT ',1P,3E15.6, /5X,4HAND ,1P,
     4     3E15.6,' COMPUTATIONS WILL CONTINUE WITH LAST VALUES', /5X,
     5     'CONVERGENCE VALUE WAS ',1P,E15.6,
     6     ' CONVERGENCE CRITERION IS ',1P,E15.6)
  250 F = PIBY2*F
C
C     COMPUTE ELLIPTIC INTEGRAL OF SECOND KIND
C
      E = 1.
      DELTE1 = 1.
      DO 260 N = 1,15000
      XN2  = 2.*FLOAT(N)
      XN21 = XN2-1.
      DELTE1 = DELTE1*(XN21/XN2)*REALK
      DELTE2 = (DELTE1*DELTE1)/XN21
      E = E - DELTE2
      IF (ABS(DELTE2/E) .LE. .000001) GO TO 270
  260 CONTINUE
      DELE = ABS(DELTE2/E)
      WRITE (OTPE,245) UWM,XX,YY,ZZ,XC,YC,ZC,X1,Y1,Z1,X2,Y2,Z2,DELE
  270 E = PIBY2*E
C
C     COMPUTE THE RADIAL COMPONENT OF THE MAGNETIC FIELD
C
      BR = XIACR*(COSTHE/SINTHE)*(E/SQAR2S)*(REALK2/(1.-REALK2))
C
C     COMPUTE THE POLAR COMPONENT OF THE MAGNETIC FIELD
C
      BTHE = XIACR*(1./(SQAR2S*RADIUS*R*SINTHE))*
     1       (((((2.*R2)-((R2+(RADIUS*R*SINTHE))*REALK2))/
     2       (1.-REALK2))*E)-(2.*R2*F))
C
C     GO TO THE RESOLUTION OF FIELD COMPONENTS
C
      GO TO 230
C
C     ALTERNATIVE APPROXIMATION FOR SMALL K**2
C
C     COMPUTE THE RADIAL COMPONENT OF THE MAGNETIC FIELD
C
  220 CONTINUE
      BR = XIACPI*COSTHE*(((2.*RAD2)+(2.*R2)+(RADIUS*R*SINTHE))/
     1     ((SQAR2S)**5))
C
C     COMPUTE THE POLAR COMPONENT OF THE MAGNETIC FIELD
C
      BTHE = -XIACPI*SINTHE*
     1       (((2.*RAD2)-R2+(RADIUS*R*SINTHE))/((SQAR2S)**5))
C
C     RESOLVE MAGNETIC FIELD COMPONENTS INTO RECTANGULAR COMPONENTS
C
  230 CONTINUE
      HCX = RX*BR + RPX*BTHE
      HCY = RY*BR + RPY*BTHE
      HCZ = RZ*BR + RPZ*BTHE
      HC1 = HCX/FPI
      HC2 = HCY/FPI
      HC3 = HCZ/FPI
      RETURN
      END


*     IB01AD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2020 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          LDR, LDU, LDWORK, LDY, LIWORK, LMAX, MMAX,
     $                 NOBRMX, NSMPMX
      PARAMETER        ( LMAX = 5, MMAX = 5, NOBRMX = 20, NSMPMX = 2000,
     $                   LDR = MAX( 2*( MMAX + LMAX )*NOBRMX,
     $                              3*MMAX*NOBRMX ), LDU = NSMPMX,
     $                   LDWORK = MAX( 6*( MMAX + LMAX )*NOBRMX,
     $                                 ( MMAX + LMAX )*( 4*NOBRMX*
     $                                 ( MMAX + LMAX + 1 ) + 2*NOBRMX ),
     $                                 ( MMAX + LMAX )*4*NOBRMX*
     $                                 ( NOBRMX + 1 ) ),
     $                   LDY = NSMPMX, LIWORK = ( MMAX + LMAX )*NOBRMX )
*     .. Local Scalars ..
      LOGICAL          NGIVEN
      CHARACTER        ALG, BATCH, CONCT, CTRL, JOBD, METH
      INTEGER          I, ICYCLE, II, INFO, IWARN, J, L, M, N, NCYCLE,
     $                 NGIV, NOBR, NSAMPL, NSMP
      DOUBLE PRECISION RCOND, TOL
*     .. Local Arrays ..
      DOUBLE PRECISION DWORK(LDWORK), R(LDR, 2*(MMAX+LMAX)*NOBRMX),
     $                 SV(LMAX*NOBRMX), U(LDU, MMAX), Y(LDY, LMAX)
      INTEGER          IWORK(LIWORK)
*     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
*     .. External Subroutines ..
      EXTERNAL         IB01AD
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
*     If the value of N is positive, it will be taken as system order.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) NOBR, N, M, L, NSMP, RCOND, TOL, METH, ALG,
     $                      JOBD, BATCH, CONCT, CTRL
      IF ( LSAME( BATCH, 'F' ) ) THEN
         READ ( NIN, FMT = * ) NCYCLE
      ELSE
         NCYCLE = 1
      END IF
      NSAMPL = NCYCLE*NSMP
*
      NGIVEN = N.GT.0
      IF( NGIVEN )
     $   NGIV = N
      IF ( NOBR.LE.0 .OR. NOBR.GT.NOBRMX ) THEN
         WRITE ( NOUT, FMT = 99997 ) NOBR
      ELSE IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
         WRITE ( NOUT, FMT = 99996 ) M
      ELSE IF ( L.LE.0 .OR. L.GT.LMAX ) THEN
         WRITE ( NOUT, FMT = 99995 ) L
      ELSE IF ( NSMP.LT.0 .OR. NSMP.GT.NSMPMX .OR.
     $        ( NSMP.LT.2*( M + L + 1 )*NOBR - 1 .AND.
     $          LSAME( BATCH, 'O' ) ) .OR.
     $        ( NSAMPL.LT.2*( M + L + 1 )*NOBR - 1 .AND.
     $          LSAME( BATCH, 'L' ) ) .OR.
     $          NSMP.LT.2*NOBR .AND. ( LSAME( BATCH, 'F' ) .OR.
     $                                 LSAME( BATCH, 'I' ) ) ) THEN
         WRITE ( NOUT, FMT = 99994 ) NSMP
      ELSE IF ( NCYCLE.LE.0 .OR. NSAMPL.GT.NSMPMX ) THEN
         WRITE ( NOUT, FMT = 99993 ) NCYCLE
      ELSE
*        Read the matrices U and Y from the input file.
         IF ( M.GT.0 )
     $      READ ( NIN, FMT = * )
     $                         ( ( U(I,J), J = 1, M ), I = 1, NSAMPL )
         READ ( NIN, FMT = * ) ( ( Y(I,J), J = 1, L ), I = 1, NSAMPL )
*        Compute the  R  factor from a QR (or Cholesky) factorization
*        of the Hankel-like matrix (or correlation matrix).
         DO 10 ICYCLE = 1, NCYCLE
            II = ( ICYCLE - 1 )*NSMP + 1
            IF ( NCYCLE.GT.1 ) THEN
               IF ( ICYCLE.GT.1 )      BATCH = 'I'
               IF ( ICYCLE.EQ.NCYCLE ) BATCH = 'L'
            END IF
            CALL IB01AD( METH, ALG, JOBD, BATCH, CONCT, CTRL, NOBR, M,
     $                   L, NSMP, U(II,1), LDU, Y(II,1), LDY, N, R, LDR,
     $                   SV, RCOND, TOL, IWORK, DWORK, LDWORK, IWARN,
     $                   INFO )
   10    CONTINUE
         IF ( INFO.NE.0 ) THEN
            WRITE ( NOUT, FMT = 99998 ) INFO
         ELSE
            IF ( IWARN.NE.0 )
     $         WRITE ( NOUT, FMT = 99990 ) IWARN
            IF( NGIVEN )
     $         N = NGIV
            WRITE ( NOUT, FMT = 99992 ) N
            WRITE ( NOUT, FMT = 99991 ) ( SV(I), I = 1,L*NOBR )
         END IF
      END IF
      STOP
99999 FORMAT ( ' IB01AD EXAMPLE PROGRAM RESULTS', /1X)
99998 FORMAT ( ' INFO on exit from IB01AD = ',I2)
99997 FORMAT (/' NOBR is out of range.',/' NOBR = ', I5)
99996 FORMAT (/' M is out of range.',/' M = ', I5)
99995 FORMAT (/' L is out of range.',/' L = ', I5)
99994 FORMAT (/' NSMP is out of range.',/' NSMP = ', I5)
99993 FORMAT (/' NCYCLE is out of range.',/' NCYCLE = ', I5)
99992 FORMAT ( ' The order of the system is ', I5)
99991 FORMAT ( ' The singular values are ',/ (8(1X,F8.4)))
99990 FORMAT ( ' IWARN on exit from IB01AD = ',I2)
      END


        program testjdqz
        use myjdqz_mod, only :  myjdqz_setup
        implicit none

        integer, parameter :: r8 = kind(1.0d0)

        integer :: lwork
        double complex, allocatable, dimension(:,:) :: zwork
        double complex, allocatable, dimension(:) :: alpha,beta
        double complex, allocatable, dimension(:) :: v,Av,Bv,residu
        double complex, allocatable, dimension(:,:) :: eivec
        double complex :: ztarget

        real*8, allocatable, dimension(:,:,:) :: egn_vectors
        real*8, allocatable, dimension(:) :: rho, omega
	integer, allocatable, dimension(:) :: im_col, in_col
	integer :: ns, mn_col, i, k, jj, m
	real*8 :: enrg1, enrg2, center_freq

        integer :: kmax
        integer :: neq, jmin,jmax,maxstep, testspace
        integer :: order, method, gmres_m, cgstab_l, maxnmv
        real(kind=r8) :: tol, lock
        logical :: wanted

        real(kind=8), external :: dznrm2

        integer :: j,ierr
        character*80 fileA, fileB, arg1
        real(kind=r8) :: time_1, time_2, elapse
        CALL getarg(1, arg1)
        read(arg1,'(e12.4)') center_freq
	write(*,'("freq. = ",e12.4)') center_freq
        open(unit=15,file="jdqz.dat",status="unknown")
	read(15,*) ns, mn_col
c	write(*,*) ns,mn_col
	allocate(im_col(mn_col), in_col(mn_col), stat=ierr)
	allocate(rho(ns), stat=ierr)
	do i=1,mn_col
	 read(15,*) im_col(i), in_col(i)
c	 write(*,*) im_col(i), in_col(i)
	end do
	do i=1,ns
	 read(15,*) rho(i)
c	 write(*,*) rho(i)
	end do
	close(unit=15)
!       ztarget = (0.0d0,0.0d0)
!       ztarget = dcmplx(400.0d0,0.0d0)
        ztarget = dcmplx(center_freq**2,0.0d0)
!        ztarget = dcmplx(0.05*center_freq,center_freq)               !for TAEFL test problem
	write(*,'("eigenvalue target = ",e15.7)') real(ztarget)
!	write(*,'("eigenvalue target = ",2(e15.7,2x))') ztarget       !for TAEFL test problem
        fileA = 'a_matrix.dat'
        fileB = 'b_matrix.dat'
        call myjdqz_setup(ztarget, fileA,fileB,neq)

      tol = 1.d-9

!...  kmax is number of eigenvalues we want
      kmax = 40
      allocate(omega(kmax), stat=ierr)

!...  jmin,jmax size of search space
      jmax = min(150,max(30,3*kmax))
      jmin = min(jmax,2*kmax)

      maxstep = 200
!...   take it small to avoid missing eigensolutions
      lock = 1.d-9
!...     order =  0: nearest to target
!...     order = -1: smallest real part
!...     order =  1: largest real part
!...     order = -2: smallest complex part
!...     order =  2: largest complex part
      order = 0
!...     method = 1: gmres(m)
!...     method = 2: cgstab(l)
      method = 1
!...     for gmres(m):
      gmres_m = 99
!...     for cgstab(l):
      cgstab_l= 4
!...     maximum number of matvecs in cgstab or gmres
      maxnmv = 200

!...  testspace = 3 if a reasonable value for target is known, else
!...  set testspace = 2
!...  testspace = 1 seems to better match results in matlab
      testspace = 3
!...     Testspace 1: w = "Standard Petrov" * v (Section 3.1.1)
!...     Testspace 2: w = "Standard 'variable' Petrov" * v (Section 3.1.2)
!...     Testspace 3: w = "Harmonic Petrov" * v (Section 3.5.1)
!
      if ( method .eq. 1 ) then
!...   ---------------------------
!...   storage if GMRES(M) is used
!...   ---------------------------
         lwork =  4 +  gmres_m  + 5*jmax + 3*kmax
      else
!...    --------------------------------
!...    storage if BiCGSTAB(ell) is used
!...    --------------------------------
         lwork = 10 + 6*cgstab_l + 5*jmax + 3*kmax
      end if
!... converged eigenvectors if wanted = .true.
!...  eivec are converged eigenvectors if wanted = .true.,
!...  else converged Schur vectors
      wanted = .true.
!

      allocate( eivec(neq,kmax), alpha(jmax),beta(jmax),
     &          v(neq),Av(neq),Bv(neq),residu(neq),stat=ierr )
      if (ierr.ne.0) then
              write(*,*) 'allocate(eivec), neq,kmax,ierr ',
     &                    neq,kmax,ierr
              stop '** error ** '
      endif

      allocate( zwork(neq,lwork),stat=ierr)
      if (ierr.ne.0) then
              write(*,*) 'allocate(zwork), neq,lwork,ierr',
     &                     neq,lwork,ierr
              stop '** error ** '
      endif

      call cpu_time(time_1)
      call jdqz(alpha, beta, eivec, wanted, neq, ztarget, tol,
     &     kmax, jmax, jmin,
     &     method, gmres_m, cgstab_l, maxnmv, maxstep,
     &     lock, order, testspace, zwork, lwork )
!
      call cpu_time(time_2)
      elapse = time_2 - time_1

      deallocate( zwork, stat=ierr)
      if (ierr.ne.0) then
              write(*,*) 'deallocate(zwork), ierr ',ierr
              stop '** error ** '
      endif

!
!...     Compute the norms of the residuals:
      do j = 1, kmax
         v(1:neq) = eivec(1:neq,j)
         call amul(neq, v, Av )
         call bmul(neq, v, Bv )
         residu(1:neq) = beta(j)*Av(1:neq) - alpha(j)*Bv(1:neq)
         print '("lambda(",i2,"): (",1p,e11.4,",",e11.4,
     &        " )")', j,alpha(j)/beta(j)
         print '(a30,d13.6)', '||beta Ax - alpha Bx||:',
     &          dznrm2( neq, residu, 1 )
      end do
      write(*,10)  elapse, elapse
!
   10 format(1x,'END JDQZ AFTER ',f6.2,' SEC. CPU-TIME AND ', f6.2,
     &       ' SEC. ELAPSED TIME' )

      allocate(egn_vectors(kmax,mn_col,ns), stat=ierr)
      do k=1,kmax
       if(beta(k) .ne. 0.) omega(k)=sqrt(real(alpha(k)/beta(k)))
       jj = 0
       do i=1,ns
        do j = 1, mn_col
         jj = jj + 1
	 egn_vectors(k,j,i) = real(eivec(jj,k))
	end do
       end do
      end do

      write(*,'("Freq. Range: ",e12.4," to " e12.4)')
     >   minval(omega),maxval(omega)
      open(unit=33,file="egn_mode_asci.dat",status="unknown")
      open(unit=34,file="egn_values.dat",status="unknown")
      enrg1 = 1.; enrg2 = 1.   !dummy values for now
       write(33,*) kmax
       write(33,*) mn_col
       write(33,*) ns
       do i=1,mn_col
        write(33,*) im_col(i)
        write(33,*) in_col(i)
       end do
       do i=1,kmax
        write(33,*) real(alpha(i)/beta(i))
        write(34,'(e22.14,2(2x,e15.7))')
     >       dble(alpha(i)/beta(i)), enrg1, enrg2
       end do
       do i=1,ns
        write(33,*) rho(i)
       end do
       do j=1,kmax
        do m = 1,ns
         do i=1,mn_col
          write(33,*) egn_vectors(j,i,m)
          end do
         end do
       end do
       close(unit=33)

      stop
      end program

        subroutine precon(neq,q)
        use myjdqz_mod, only : m,n, L,D,ipiv,U
        use symtrd_mod, only : symtrd_solve
!       ----------------------------------
!       subroutine to compute q = inv(K)*q
!       ----------------------------------
        integer, parameter :: r8 = kind(1.0d0)

        integer neq
        double complex q(neq)

        integer, parameter :: nrhs = 2
        real(kind=r8) :: Brhs(m,n,nrhs)
        integer :: ip,i,k, info

        logical :: isok

        isok = (neq .eq. m*n)
        if (.not.isok) then
                write(*,*) 'precon:invalid neq ',neq
        endif

!       -------------------------------------
!       convert q(1:(m*n)) to Brhs(1:m,1:n,1)
!       -------------------------------------
        ip = 1
        do k=1,n
        do i=1,m
           ip =  i + (k-1)*m
           Brhs(i,k,1) = dble(q(ip))
           Brhs(i,k,2) = dimag(q(ip))
        enddo
        enddo
        call symtrd_solve( m,n,nrhs, L,D,ipiv,U, Brhs,info)
        if (info.ne.0) then
                write(*,*) 'precon: symtrd_solve return info',info
        endif

!       ------------------------------------------
!       convert Brhs(1:m,1:n,1) back to q(1:(m*n))
!       ------------------------------------------

        ip = 1
        do k=1,n
        do i=1,m
          ip = i + (k-1)*m
          q(ip) = dcmplx(Brhs(i,k,1),Brhs(i,k,2))
        enddo
        enddo
        return
        end subroutine precon
        subroutine amul( neq, q, r )
        use myjdqz_mod, only : m,n, Adiag,Asub,Asup
        use symtrd_mod, only : symtrd_matmul
!       -----------------------------
!       subroutine to compute r = A*q
!       -----------------------------
        integer, parameter :: r8 = kind(1.0d0)

        integer neq
        double complex q(neq),r(neq)

        integer, parameter :: nrhs = 2
        real(kind=r8), dimension(m,n,nrhs) :: X,Y
        integer :: i,k,ip

!       ---------------------------------------
!       convert q(1:(m*n)) to X(1:m,1:n,1:nrhs)
!       ---------------------------------------
        ip = 1
        do k=1,n
        do i=1,m
           ip = i + (k-1)*m
           X(i,k,1) = dble(q(ip))
           X(i,k,2) = dimag(q(ip))
        enddo
        enddo

        call symtrd_matmul( m,n,nrhs, Adiag,Asub,Asup, X,Y )

!       ---------------------------------------
!       convert Y(1:m,1:n,1:nrhs) to r(1:(m*n))
!       ---------------------------------------

         ip = 1
         do k=1,n
         do i=1,m
           ip = i + (k-1)*m
           r(ip) = dcmplx(Y(i,k,1),Y(i,k,2))
         enddo
         enddo

         return
         end subroutine amul
        subroutine bmul( neq, q, r )
        use myjdqz_mod, only : m,n, Bdiag,Bsub,Bsup
        use symtrd_mod, only : symtrd_matmul
!       -----------------------------
!       subroutine to compute r = B*q
!       -----------------------------
        integer, parameter :: r8 = kind(1.0d0)
        integer neq
        double complex q(neq),r(neq)

        integer, parameter :: nrhs = 2
        real(kind=8), dimension(m,n,nrhs) :: X,Y
        integer :: i,k,ip

!       ---------------------------------------
!       convert q(1:(m*n)) to X(1:m,1:n,1:nrhs)
!       ---------------------------------------
        ip = 1
        do k=1,n
        do i=1,m
           ip = i + (k-1)*m
           X(i,k,1) = dble(q(ip))
           X(i,k,2) = dimag(q(ip))
        enddo
        enddo

        call symtrd_matmul( m,n,nrhs, Bdiag,Bsub,Bsup, X,Y )

!       ---------------------------------------
!       convert Y(1:m,1:n,1:nrhs) to r(1:(m*n))
!       ---------------------------------------

         ip = 1
         do k=1,n
         do i=1,m
           ip = i + (k-1)*m
           r(ip) = dcmplx(Y(i,k,1),Y(i,k,2))
         enddo
         enddo

         return
         end subroutine bmul


!  Program to Find Spikes in Water Vapor Density for Eagle Lake
!  Updated 14 December 2018
!

        implicit none

        character (len=25) infile,outfile1,outfile2,dfile
        character (len=1) response
        character(len=1), parameter :: c_esc = achar(27)
        character(len=*), parameter :: c_red = '[31m'
        character(len=*), parameter :: c_bold = '[1m'
        character(len=*), parameter :: c_reset = '[0m'

        integer, parameter :: dp=kind(1.0d0)
        integer, Parameter :: Medium=Selected_INT_Kind(6)
        integer, Parameter :: Long=Selected_INT_Kind(9)
        integer stat,iday,unr,ix1,ix2,nw1,nw2,nw,n,i,j,jj,day,year(80000),doy(80000),hrmin(80000),hr,dist
        integer(kind=Medium) ::  finish,oldhr,nrecord,del,kk
        integer(kind=long) :: d1(80000)

        real sdev,rn,nr,sec(80000),Ux(80000),Uy(80000),Uz(80000),Ts(80000),rhoc(80000),rhov(80000),P(80000),agc(80000)
        real del_rhovw(80000),drhov,nbeg,nend,diff,sdev_hi,sdev_low,del_hi,del_low

        real(kind=dp) ::  sumrhov,sumrhov2,rhovavg,stdevrhov,SD_rhov(80000)

        write (6,'(A22)') 'Name of the input file'
        read (5,*) infile
        open(1,file=infile)

        write (6,'(/,A53)') 'Name of the intermediate file made using first window'
        read (5,*) outfile1

        write (6,'(/,A22)') 'Name of the final file'
        read (5,*) outfile2

        open(2,file=outfile1,action='READWRITE')
        open(4,file=outfile2,action='WRITE')

        write(dfile,"(a8)")("diag.dat")
        open(3,file=dfile)

        write (6,'(/,A61)') 'Size of the 1st and 2nd Window & Critical Standard Deviation Value'
        read (5,*) nw1,nw2,sdev

!
!  Define Critical Values of the Difference of Instantaneous Value From the Window Average for Each Variable.
!  This is a Critical and Somewhat Subjective Step.
!

!  rhov in gm/m3
        drhov=5.0

!  Upper and lower coefficients for the
        sdev_hi=1.3
        sdev_low=.6

        del_hi=1.6
        del_low=.3

        sumrhov=0.0
        sumrhov2=0.0

!
!  Read All the Data Into Arrays and Determine When End of the Hour is Reached
!

        i=1
        nrecord=0
        stat=0
        finish=0
        nw=nw1
        write(6,'(/,A15,2x,I4,/)') 'Running Window ',nw
        call sleep(2)

 10 	do while (stat==0)

         if(stat/=0) then
         go to 90
         end if

        if(finish==0) then

        unr=1
        read (1,*,iostat=stat,end=90) year(i),doy(i),hrmin(i),sec(i),ux(i),uy(i),uz(i),Ts(i),  &
                                    d1(i),rhoc(i),rhov(i),P(i),agc(i)

        else
        unr=2
        read (2,*,iostat=stat,end=90) year(i),doy(i),hrmin(i),sec(i),ux(i),uy(i),uz(i),Ts(i),  &
                                      d1(i),rhoc(i),rhov(i),P(i),agc(i)
        end if

        hr=INT(hrmin(i)/100)
        day=doy(i)

        if(i==1) then
        iday=doy(i)
        oldhr=hr
        end if

        nrecord=nrecord+1

!
!  Check if Entered New Hour. If So, Back Up One Record, So Next Record Read is the First of the New Hour.
!

        if((hr.NE.oldhr).or.(doy(i)>iday)) then
        backspace(unit=unr)
        oldhr=hr

        if((hrmin(i-1)==2359).and.(sec(i-1)==59.95)) then
        hr=24
        i=i+1
        go to 90
        end if

        go to 90
        end if

        oldhr=hr
        i=i+1
        go to 10

   90   n=i-1
        rn= float(n)
        hr=hr*100

        nrecord=nrecord-1
        write(6,'(/,A15,2x,I4)') 'Processing Hour',hr
        write(6,109) nrecord
 109    format(2x,I6,2x,'records read')

!
!  Sum the Variables and Products Required for Later Calculations.
!  Statistics Calculated for All Values in the Window Except the Given Value.
!
        if(finish==0) then
        nw=nw1
        else
        nw=nw2
        end if

        nr=float(nw)

        if(nw<100) then
        dist=40
        else
        dist=60
        end if

        do j=1,(n-nw),nw

        do i=j,(j+(nw-1)),1
        sumrhov=sumrhov+rhov(i)
        sumrhov2=sumrhov2+rhov(i)*rhov(i)
	    end do

!
!  Calculate Averages and Standard Deviations in the Window
!

        rhovavg=sumrhov/nr
        stdevrhov=sqrt((sumrhov2-(sumrhov**2.0)/nr)/(nr-1))

        sumrhov=0.0
        sumrhov2=0.0

        do i=j,(j+(nw-1))

!
!  Calculate Difference From Instantaneous Values From Window Average
!

        del_rhovw(i)=ABS(rhov(i)-rhovavg)

!
!  Determine Number of Standard Deviations Away From Window Average
!

        SD_rhov(i)=ABS((rhov(i)-rhovavg)/stdevrhov)

!
!  For Each Variable, Check if Values Exceed Standard Deviations and Absolute Difference Limits.
!  If They Exceed Criteria, Write 60 Earlier Values, Flagged Value, Then 60 Later Values
!

        if(((ABS(del_rhovw(i)).GT.drhov).and.(ABS(SD_rhov(i)).GT.(sdev*sdev_low))).or. &
          &((ABS(SD_rhov(i)).GT.sdev).and.(ABS(del_rhovw(i)).GT.(drhov*del_low))).or. &
          &(ABS(del_rhovw(i)).GT.(drhov*del_hi)).or. &
          &(ABS(SD_rhov(i)).GT.(sdev*sdev_hi))) then

        write(6,'(/)')
        do jj=dist,1,-1
        write(6,150) (-jj),hrmin(i-jj),sec(i-jj),rhov(i-jj)
   150  format(I3,2x,I4,2x,F5.2,4x,F6.2)
        end do

        write(6,'(A1)') ' '
        write(6,145) c_esc,c_red,c_esc,c_bold,c_esc,hrmin(i),sec(i),rhov(i),SD_rhov(i),del_rhovw(i),c_esc,c_reset
   145  format(a1,a4,a1,a3,a1,'   0',2x,I4,2x,F5.2,4x,F6.2,3x,'# Stdev = ',F5.1,2x,'drhov_win =  ',F5.1,2x,a1,a3)
        write(6,'(A1)') ' '

        do jj=1,dist
        write(6,150) (jj),hrmin(i+jj),sec(i+jj),rhov(i+jj)
        end do

        write(6,'(A30)', advance="no") 'Problem?  Enter Y or N    '
        read(5,*) response

        if(response=='Y'.or.response=='y') then
        write(6,'(A1)') ' '
        write(6,'(A39)',advance="no") 'First and last index to be replaced    '
        read(5,*) ix1,ix2
        nbeg=rhov(i+ix1-1)
        nend=rhov(i+ix2+1)
        del=ix2-ix1
        diff=nend-nbeg
        kk=0

        do jj=ix1,ix2,1
        kk=kk+1
        write(3,408) hrmin(i+jj),sec(i+jj),rhov(i+jj)
   408  format('original'  I4,2x,F5.2,2x,'rhov= ',F5.2)

        if((ix1>0.and.ix2>0).or.(ix1<0.and.ix2<0)) then
        rhov(i+jj)=nbeg+kk*(diff/ABS(ix1+ix2))
        else
        rhov(i+jj)=nbeg+kk*(diff/(ABS(ix1)+ix2+2))
        end if

        write(3,409) hrmin(i+jj),sec(i+jj),rhov(i+jj)
   409  format('new'  I4,2x,F5.2,2x,'rhov= ',F5.2,/)

        end do

        end if

        end if

        end do

        end do

!
!  Write Out the New Data for the Hour
!

        do i=1,n,1
        if(finish==0) then
        write(2,200) year(i),doy(i),hrmin(i),sec(i),ux(i),uy(i),uz(i),Ts(i),  &
                    d1(i),rhoc(i),rhov(i),P(i),agc(i)

  200   format(I4,2x,I3,2x,I4,2x,F5.2,2x,3(F9.5,2x),F8.5,2x,I6,2x,F9.4,2x,F9.6,2x,F8.5,2x,F6.2)
        else
        write(4,200) year(i),doy(i),hrmin(i),sec(i),ux(i),uy(i),uz(i),Ts(i),  &
                     d1(i),rhoc(i),rhov(i),P(i),agc(i)
        end if
        end do

        if(hr==2400) then
        go to 92
        end if

        i=1
        nrecord=0
        go to 10

        end do

   92   finish=finish+1

        if(finish==1) then
        rewind(unit=2)
        stat=0
        nrecord=0
        i=1
        nw=nw2
        write(6,'(/,A15,2x,I4,/)') 'Running Window ',nw2
        call sleep(2)
        go to 10
        end if

        if(finish==2) then
        go to 99
        end if

  99    end