! Copyright (c) 2015 Alex Kramer <kramer.alex.kramer@gmail.com>
! See the LICENSE.txt file at the top-level directory of this distribution.

! 2-dimensional time-dependent Gaussian wavepacket propagation module
module gaussian
  ! We assume that psi(x,0) is a Gaussian wavepacket such that:
  ! psi(x,0) = (1 / pi sig_x^2)^(1/4) exp(-1/2 ( (x-x0) / sig_x)^2) exp(i p0_x (x - x0) / hb)

  use globvars
  use progvars, only: h, hbar, m, En, phi, sig_x, sig_y, x0, y0

  implicit none

  private

  public :: gaussian_init
  public :: gaussian_cleanup
  public :: gaussian_xyt
  public :: gaussian_px
  public :: gaussian_py
  public :: gaussian_calc_theor_npxy

  ! Precalculated constants
  real(dp) :: p0_x, p0_y
  real(dp) :: p0_x_m, p0_y_m
  real(dp) :: p0_x_2m, p0_y_2m

  real(dp) :: sig_x2, sig_y2

  real(dp) :: sig_p_x, sig_p_y
  real(dp) :: sig_p_x2, sig_p_y2
  real(dp) :: norm_p_x, norm_p_y

  complex(dp) :: j_hb, jhb_m

contains

  subroutine gaussian_init()

    ! Precalculate some constants
    p0_x = sqrt(2.0_dp * m * En) * cos(phi)
    p0_y = sqrt(2.0_dp * m * En) * sin(phi)

    p0_x_m = p0_x / m
    p0_x_2m = p0_x_m / 2.0_dp
    p0_y_m = p0_y / m
    p0_y_2m = p0_y_m / 2.0_dp

    sig_x2 = sig_x**2
    sig_y2 = sig_y**2

    j_hb = j / hbar
    jhb_m = j * hbar / m

    sig_p_x = hbar / sig_x
    sig_p_y = hbar / sig_y

    sig_p_x2 = sig_p_x**2
    sig_p_y2 = sig_p_y**2

    norm_p_x = sqrt(1.0_dp / (sig_x * sqrt_pi))
    norm_p_y = sqrt(1.0_dp / (sig_y * sqrt_pi))

  end subroutine gaussian_init

  subroutine gaussian_cleanup()
  end subroutine gaussian_cleanup

  real(dp) function gaussian_px(p_x) result(val)
    real(dp), intent(in) :: p_x

    real(dp) :: exp_p_x
    ! Taken from Sakurai, p. 58

    exp_p_x = exp(- 0.5_dp * ( (p_x - p0_x) / sig_p_x2)**2 )

    val = norm_p_x * exp_p_x
  end function gaussian_px

  real(dp) function gaussian_py(p_y) result(val)
    real(dp), intent(in) :: p_y

    real(dp) :: exp_p_y
    ! Taken from Sakurai, p. 58

    exp_p_y = exp(- 0.5_dp * ( (p_y - p0_y) / sig_p_y2)**2 )

    val = norm_p_y * exp_p_y
  end function gaussian_py

  ! This gives the two-dimensional momentum space wfunc, but we want the 1D ones?

  complex(dp) function gaussian_xyt(x, y, t) result(val)
    real(dp), intent(in) :: x
    real(dp), intent(in) :: y
    real(dp), intent(in) :: t

    complex(dp) :: norm_x, norm_x2
    complex(dp) :: norm_y, norm_y2

    complex(dp) :: exp_x1, exp_x2
    complex(dp) :: exp_y1, exp_y2

    ! Taken from Shankar, p. 154.

    norm_x2 = sqrt_pi * (sig_x + jhb_m / sig_x * t)
    norm_x = 1 / sqrt(norm_x2)

    norm_y2 = sqrt_pi * (sig_y + jhb_m / sig_y * t)
    norm_y = 1 / sqrt(norm_y2)

    exp_x1 = - ((x - x0) - p0_x_m * t)**2 / &
         (2.0_dp * sig_x2 * (1 + jhb_m / sig_x2 * t))
    exp_y1 = - ((y - y0) - p0_y_m * t)**2 / &
         (2.0_dp * sig_y2 * (1 + jhb_m / sig_y2 * t))

    exp_x2 = j_hb * p0_x * ((x - x0) - p0_x_2m * t)
    exp_y2 = j_hb * p0_y * ((y - y0) - p0_y_2m * t)

    val = norm_x * norm_y * exp(exp_x1 + exp_x2 + exp_y1 + exp_y2)

  end function gaussian_xyt

  subroutine gaussian_calc_theor_npxy(vd_px_arr, vd_py_arr, &
    theor_npx_arr, theor_npy_arr)

    real(dp), intent(in) :: vd_px_arr(:), vd_py_arr(:)
    real(dp), intent(inout) :: theor_npx_arr(:), theor_npy_arr(:)

    integer :: i_px, i_py
    real(dp) :: px, py

    do i_px = 1, size(theor_npx_arr)
       px = vd_px_arr(i_px)
       theor_npx_arr(i_px) = abs(gaussian_px(px))**2
    end do
    do i_py = 1, size(theor_npy_arr)
       py = vd_py_arr(i_py)
       theor_npy_arr(i_py) = abs(gaussian_py(py))**2
    end do

  end subroutine gaussian_calc_theor_npxy

end module gaussian


      SUBROUTINE DJACG(MODE,M,N,Y,F,
     .           FJAC,LDFJAC,YSCALE,FAC,IOPT,
     .           WK,LWK,IWK,LIWK)
c Copyright (c) 2006, Math a la Carte, Inc.
c>> 2006-04-11 DJACG  R. J. Hanson removed unneeded values saved.
c>> 2003-07-08 DJACG  R. J. Hanson fixed bug checking FAC(*) < 0.
c>> 2003-07-08 DJACG  R. J. Hanson fixed bug on MODE < 0 or > N.
c>> 2002-06-21 DJACG  R. J. Hanson modified Salane Code
c--D replaces "?": ?JACG

c     Main routine DJACG, computing numerical derivatives.
c     -----------------------------------------------------------------
C
C***BEGIN PROLOGUE  DJACG
C***DATE WRITTEN  860410
C***Date Modified 060411
C***CATEGORY NO.  D4
C***KEYWORDS  NUMERICAL DIFFERENCING, Numerical Jacobians, Numerical
C             Derivatives
C***AUTHOR    SALANE, DOUGLAS E., SANDIA NATIONAL LABORATORIES
C             NUMERICAL MATHEMATICS DIVISION,1642
C             ALBUQUERQUE, NM 87185
C             Interface reworked by Richard J. Hanson, Rice University.
C             Last changes made by Hanson after leaving Rice University.
C
C***PURPOSE  SUBROUTINE DJACG
C
c  Subroutine DJACG uses finite differences to compute the Jacobian for
c  a system of (M) equations in (N) variables. DJACG is designed
c  for use in numerical methods for solving nonlinear problems where a
c  Jacobian is evaluated repeatedly at neighboring arguments.
c  For example in a Gauss-Newton method for solving non-linear least squares
c  problems. DJACG is suitable for applications in which the  Jacobian
c  is a dense rectangular matrix, over- exactly or under-determined.
C  The interface to the values of equations is with reverse
c  communication.  The code DJACG saves and restores values between
c  calls.  In particular DJACG is thread-safe.

C  The design allows for computation of derivatives that are a sum of
C  analytic and functional values that are not easily differentiated.
C***DESCRIPTION
C
C  SUBROUTINE PARAMETERS
C
C  MODE.......An integer flag that directs user action with reverse
C             communication.  Enter the routine with MODE=0.
C             DJACG returns with MODE=J when computing column J of
C             the Jacobian.  When MODE=0 on return, the Jacobian
C             has been computed.
C  N..........[in] THE NUMBER OF VARIABLES.
C  M..........[in] THE NUMBER OF EQUATIONS.
C  Y(*).......[inout] AN ARRAY OF DIMENSION N. THE POINT AT WHICH THE
C             Jacobian IS TO BE EVALUATED.
C  F(*).......[in] AN ARRAY OF DIMENSION M. THE EQUATIONS EVALUATED AT
C             THE POINT Y. This must be defined when MODE .eq. 0 or
C             just after the first perturbed column is computed,
C             MODE .eq. 1.
C  FJAC(*,*)..[inout] AN ARRAY OF SIZE LDFJAC BY N. FJAC
C             CONTAINS THE Jacobian WHICH IS AN M BY N MATRIX.
c             Columns that are accumulated must have the analytic
c             part defined on entry or else be set to zero.
c             Columns that are skipped can be defined either before
c             or after the routine exits.
C  LDFJAC.....[in] THE LEADING DIMENSION OF THE ARRAY FJAC AS DIMENSIONED
C             IN THE CALLING ROUTINE. LDFJAC MUST BE GREATER OR
C             EQUAL TO M.
C  YSCALE(*)..[in] AN ARRAY OF LENGTH N. THE USER CAN PROVIDE
C             REPRESENTATIVE MAGNITUDES FOR Y VALUES IN THE ARRAY
C             YSCALE. THE USER CAN ALSO USE YSCALE TO PROVIDE
C             APPROPRIATE SIGNS FOR THE INCREMENTS.

C  FAC(*).....[inout] AN ARRAY OF LENGTH N. FAC(I) CONTAINS THE PERCENTAGE
C             FACTOR FOR DIFFERENCING.
C
c  If FAC(1)=0., the array FAC is set to the    square  root  of
c  machine  unit roundoff on the first call to DJACG.
c  Unless the user wishes to initialize FAC,
c  the FAC array should not be altered between subsequent  calls
c  to  DJACG.
c
c   The user  may  provide  FAC  values  if  desired.
C   If the user provides FAC values, FAC(i) should be
c   set to a value between 0 and 1.  DJACG will not permit  FAC(i)  to
c   be  set  to  a  value  that results in too small an increment.  DJACG
c   ensures that
c                     FACMIN <= FAC(i) <= FACMAX.
C   For further details on how the code chooses FACMIN  and  FACMAX  see
c   the report [2].
c
C
C IOPT(*) [in] An integer array defining the methods used to
C   compute the derivatives.  The default is to use one sided differences.
C   Entries in this array are interpreted as follows.

C [0] Use the current settings for all remaining variables.  The starting
C     setting is to simply use one sided differences.
C [k > 0] Use the current settings for all variables from the last
C     specified up to and including variable $k$.
C [-1] Set to use  one sided differences.  (Not needed at the
C     beginning since this is the default state.)
C [-2] Set to use central differences.
C [-3] Set to accumulate the result from whatever type of differences
C     have been specified above into initial values provided in FJAC.  This
C     must be followed by a number $\geq 0$ as any number $< 0$ will turn
C     this off.
C [-4] Skip variables.  This must be followed by a value $\geq 0$
C     as any number $< 0$ will turn this off.

C          Re. state -2:  For variable p, compute numerical derivatives using
C          central divided differences.  This will typically yield more
C          accuracy than the one-sided differences, but with the expense
C          of an additional function evaluation per variable.
C          The increment used for central differencing
C          is the default T=$macheps^{-1/6}$
C          times the increment used in one-sided differencing.
C          To change this factor for succeeding
C          variables,  assign a new value between calls with MODE .gt. 0
C          in the storage location FAC(MODE).

C          The default value T=$macheps^{-1/6}$ is based on the
C          approximate relation T*FAC(J) =$macheps^{2/3}$.
C          This value is near an optimal choice, under certain conditions
C          on higher derivatives, provided FAC(J) = $macheps^{1/2}$.
C          Sometimes larger or smaller values of T will give more accuracy
C          than the default.

C
c          For example if column 3 is not to be computed and column 4 is
c          to be accumulated, then IOPT(1)=2, followed by:
C          IOPT(2)=-4, IOPT(3)=3, IOPT(4)=-3, IOPT(5)=4,
C          IOPT(6)=-1, IOPT(7)=0

c
c
c  wk(*)...[inout]a work array whose dimension is at least LWK.
c  LWK.....[in] the required length of the work array. LWK=3*M+18.
c  iwk(*)..[inout] an integer array whose dimension is at least LIWK.
c             The first 10 positions of IWK contain diagnostics
c             information.
c
c      IWK(1) gives the number of times a function evaluation was computed.
c
c      IWK(2) gives the number of columns in which three  attempts  were
c      made  to  increase  a percentage factor for differencing (i.e.  a
c      component in  the  FAC  array)  but  the  computed  DEL  remained
c      unacceptably  small relative to Y(JCOL) or YSCALE(JCOL).  In such
c      cases the percentage factor is set to the square root of the unit
c      roundoff of the machine.
c
c      IWK(3)  gives the number of columns in which the computed DEL was
c      zero to machine precision because  Y(JCOL)  or  YSCALE(JCOL)  was
c      zero.   In  such  cases DEL is set to the square root of the unit
c      roundoff.
c
c      IWK(4) gives the number of Jacobian columns which  had  to  be
c      recomputed because  the  largest  difference  formed  in the column
c      was close to zero relative to scale, where
c
c                    scale = max(|f (y)|,|f (y+del)|)
c                                  i       i
c
c      and i denotes the row index of  the  largest  difference  in  the
c      column  currently being processed.  IWK(10) gives the last column
c      where this occurred.
c
c      IWK(5) gives the number of columns whose  largest  difference  is
c      close  to  zero  relative  to  scale  after  the  column has been
c      recomputed.
c
c      IWK(6) gives the  number  of  times  scale  information  was  not
c      available  for  use  in  the roundoff and truncation error tests.
c      this occurs when
c
c                    min (|f (y)|,|f (y+del)|) = 0.
c                          i     i
c
c      where i is the index of the largest  difference  for  the  column
c      currently being processed.
c
c      IWK(7) gives the number of times the increment  for  differencing
c      (DEL) was computed and had to be increased because (Y(JCOL)+DEL )
c      -Y(JCOL)) was too small relative to Y(JCOL) or YSCALE(JCOL).
c
c      IWK(8) gives the number of times a component of the FAC array was
c      reduced because changes in function values were large and  excess
c      truncation error was suspected. IWK(9) gives the last column in
c      which this occurred.
c
c      IWK(9) gives the index of the last column where the corresponding
c      component of the FAC array had to be reduced because excessive
c      truncation error was suspected.
c
c      IWK(10) gives the index of the last column where the  differeence
c      was  small  and  the column had to be recomputed with an adjusted
c      increment (see iwk(4)).  the largest derivative  in  this  column
c      may be inaccurate due to excessive roundoff error.
c
c  LIWK.[in] the length of the array iwk. LIWK >= 10+LNTBUF=21.

c Using reverse communication, DJACG will return  control  to
c the  user  each  time  a  function  value  is required.  The user must
c provide the values of the function f evaluated at y  where  y  is  the
c array return by DJACG.  The user must set
c
c              wk(i)  =   i-th component of f evaluated at y
c
c for i = 1,2,...,M.  After wk is assigned, the user must recall DJACG.
c When DJACG returns to the user with
c
c               MODE = 0,
c
c the computation of the Jacobian is complete.
c
c  Roundoff and truncation errors.
c
c Subroutine DJACG takes advantage of the way in which the   Jacobian
c is  evaluated  to  adjust  increments  for  differencing  to control
c roundoff and truncation errors.  The routine  usually (but not always)
c requires  one additional  function evaluation to  compute a column of the
c Jacobian. Also, the routine returns  a variety of  error  diagnostics
c to warn users when computed derivatives may not be accurate.
c
c WARNING:  DJACG does not  guarantee  the  accuracy  of  the  computed
c derivatives.   In  order  to save on function evaluations, heuristic
c tecniques for increment adjustment and safeguarding  increments  are
c used.  These usually work well, but are not guaranteed.
c
c In order to determine the accuracy of computed derivates, users should
c pay attention to the diagnostic array positions IWK(4), IWK(8), IWK(9)
c and IWK(10). Non-zeros in these position indicate
c possible large roundoff or truncation errors. Here is a summary.
c
C IWK(4) NONZERO => ROUNDOFF ERROR.  IWK(10) LAST NOTED COLUMN.
C IWK(8) NONZERO => TRUNCATION ERROR. IWK(9) LAST NOTED COLUMN.
c
c WARNING:   Some  of the diagnostics returned can only be interpreted
c with a detailed knowledge of the routine.   Nevertheless,  they  are
c provided  to  give  users full access to the information produced by
c the subroutine.
c
c***references  (1)D.E. Salane and L. F. Shampine
c                  "An economical and efficient routine for computing
c                   sparse Jacobians", Report no. SAND85-0977,
c                   Sandia National Laboratories, Albuquerque,NM,87185.
c               (2)D.E. Salane
c                  "Adaptive routines for forming Jacobians
c                   numerically", Report no. SAND86-1319, Sandia
c                   National Laboratories, Albuquerque, NM, 87185
c
C***ROUTINES CALLED  D1MACH
C
C  REQUIRED FORTRAN INTRINSIC FUNCTIONS:
C        ABS,MAX,MIN,SIGN,SQRT
C  REQUIRED Math a la Carte FUNCTIONS:
C        D1MACH
C
C***END PROLOGUE  DJACG
C      IMPLICIT NONE
      INTEGER MODE, N, M, LDFJAC, LWK, LIWK
      DOUBLE PRECISION Y(N),F(M),FJAC(LDFJAC,*),WK(LWK),
     .     YSCALE(N),FAC(N)

      INTEGER IOPT(*),IWK(LIWK)

C
C SET CONSTANTS AND ALGORITHM PARAMETERS.
C PERT........IS USED IN EXTRAPOLATION TEST.
C FACMAX......FAC(I) <= FACMAX.
C EXPFMN......FAC(I) => FACMIN WHERE FACMIN = U ** EXPFMN.
C NIFAC.......ITERATION BOUND USED IN COMPUTING INCREMENT.

      EXTERNAL D1MACH
      DOUBLE PRECISION D1MACH

      DOUBLE PRECISION PERT, FACMAX
      DOUBLE PRECISION USQT, UEGT, UMEGT, UQRT, U3QRT,
     .     U7EGT, FACMIN, SAVY, AY, SGN, CFACT,
     .     DEL, DELM, T1, T2, SAVDEL, DMAX, RDEL, ADIFF,
     .     DIFF, SF, SDF, FJACL, FMJ, DFMJ, RMXFDF, RMNFDF, U

      INTEGER NIFAC
      INTEGER I, J, ITRY, IRDEL, IRCMP, IROWMX, IROW
      INTEGER JCOL, NS, STATEA, STATED, STATES

      INTEGER LRBUF, LNTBUF
      PARAMETER(LRBUF=18, LNTBUF=11)
      DOUBLE PRECISION RBUF(LRBUF)

      INTEGER INTBUF(LNTBUF)
C
C***FIRST EXECUTABLE STATEMENT  DJACG
      IF(MODE .gt. 0 .and. MODE .le. N) GO TO 90
C Do error checking on some parameters.  A returned value of MODE < 0
C denotes that argument number -MODE has an error condition associated
C with it.
C      SUBROUTINE DJACG(MODE,M,N,Y,F,
C     .          FJAC,LDFJAC,YSCALE,FAC,IOPT,
C     .        WK,LWK,IWK,LIWK)
C     Variables 1-5, 6-10, 11-14
C Must have MODE=0 the first time.
      IF(MODE .lt. 0 .or. MODE .gt. N) THEN
C This says that MODE < 0 or MODE > N is error.
         MODE = 1
         GO TO 1000
      END IF
      MODE=2
C Must have M > 0
      IF(M .le. 0) GO TO 1000
      MODE=3
C Must have N > 0
      IF(N .le. 0) GO TO 1000
      MODE=7
C Must have LDFJAC .ge. M if N > 1.
      IF(LDFJAC .lt. M .and. N .gt. 1) GO TO 1000

C Must have FAC() >= 0. The value FAC(1)=0.
C skips this test on the rest of FAC(*).
      IF(FAC(1) .ne. 0.) THEN
         MODE=9
         DO 1010 J=1,N
            IF(FAC(J) .lt. 0.) GO TO 1000
 1010    CONTINUE
      END IF
      MODE=10
C Run throught the IOPT() array making sure that the
C state changes and indices make sense.
      NS=1
 1070 CONTINUE
C A positive value .gt. N is an error.
      IF(IOPT(NS).gt. N) GO TO 1000
C A value of 0 (or N) says to use the present setting for
C the rest of the variables
      IF(IOPT(NS).eq. 0 .or. IOPT(NS) .eq. N) GO TO 1080
C A postitive value < N must be followed by a zero, N, or a
C state change.
      IF(IOPT(NS).gt. 0) THEN
         NS=NS+1
         GO TO 1070
      END IF
      IF(IOPT(NS) .lt. -4) GO TO 1000
      IF(IOPT(NS) .ge. -2) THEN
         NS=NS+1
         GO TO 1070
      END IF
C An accumulation or skip must be followed by a non-negative index.
      IF(IOPT(NS+1) .lt. 0) GO TO 1000
      NS=NS+1
      GO TO 1070
 1080 CONTINUE
      MODE=12
C Must have LWK >= 3*M+LRBUF
      IF(LWK .lt. 3*M+LRBUF) GO TO 1000
      MODE=14
C Must have LIWK >= 21
      IF(LIWK .lt. 21) GO TO 1000
C
c Since reverse communication, initialize JCOL only on first call.
      JCOL=0
C
C COMPUTE APPROPRIATE MACHINE CONSTANTS.
C
      U = D1MACH(4)
      USQT = SQRT(U)

c          UQRT = U**P25
c          U3QRT = U**P75
c          UEGT = U**P125
c          U7EGT = U**P875
c          FACMIN = U**EXPFMN

      UQRT = SQRT(USQT)
      T1=1.D0/USQT
      U3QRT = U/UQRT
      UEGT = SQRT(UQRT)
      UMEGT = 1.D0/UEGT

      U7EGT = U*UMEGT
      FACMIN = U3QRT

      PERT=2.0D+0
      FACMAX=1.D-1

      NIFAC=3

      DO 10 J = 1,LIWK
         IWK(J) = 0
 10   CONTINUE

C  The value FAC=0. means that this code wants to initialize.
      IF(FAC(1) .eq. 0.D0) THEN
         DO 20 J = 1,N
            FAC(J) = USQT
 20      CONTINUE
      END IF

C Default to not accumulate:
      STATEA=1
C Default to use one-sided differences.
      STATED=1
      CFACT=0.D0
C Default to not skip computing columns.
      STATES=1
C Index for processing IOPT(*) states and changes.
      NS = 1

C
 30   CONTINUE
      JCOL = JCOL + 1
C IF IOPT(NS) .eq. 0, the current states hold for the rest
C of the columns.
 1020 CONTINUE
      IF(IOPT(NS) .ne. 0) THEN
C A state change will occur:
         IF(JCOL   .eq. IOPT(NS)+1) THEN
C This signals a state change.  Namely the last variable
C in the group has been processed and a change is required.
            NS=NS+1
         END IF
         IF(IOPT(NS) .lt. 0) THEN
C Set for one-sided or central differences.
            IF(IOPT(NS) .ge. -2) THEN
               STATED=-IOPT(NS)
               STATEA=1
            ELSE
C Set for accumulation or skipping variables.
               IF(IOPT(NS) .eq. -3) STATEA=2
               IF(IOPT(NS) .eq. -4) THEN
                  STATES=2
                  STATEA=1
               END IF
            END IF
            NS=NS+1
         ELSE
            GO TO 1030
         END IF
C Still in range for a state, without change to that state.
         GO TO 1020
      END IF
 1030 CONTINUE
      IF(STATED .gt. 1) THEN

         IF(CFACT .eq. 0D0) THEN

C                    CFACT=U**(-1.D0/6.D0)
C Compute U**(-1/6) using Newton's method;  compute the cube
C root of U**(-1/2).  This is to avoid the ** elmentary function
C which may not be thread-safe or re-entrant.
            CFACT = UMEGT*UMEGT
            DO 1050 J=1,14
               CFACT=(2.D0*CFACT+T1/(CFACT*CFACT))/3.D0
C Converged, to over 7/8 precision.  Escapes from loop.
               IF(ABS(CFACT*CFACT*CFACT*USQT - 1.D0) .lt. U7EGT)
     .              GO TO 1060
 1050       CONTINUE
 1060       CONTINUE
         END IF
      END IF
C Check if this column is to be skipped.
      IF(STATES .gt. 1) GO TO 170
      IRCMP = 0
      ITRY = 0
C Check if this column is to be accumulated.
      IF(STATEA .gt. 1) THEN
C Save the initial contents of the array column for final accumulation.
         DO 40 IROW=1,M
            WK(IROW+2*M)=FJAC(IROW,JCOL)
 40      CONTINUE
      END IF

C
 50   CONTINUE
      SAVY = Y(JCOL)
C
c  Compute DEL. If DEL is too small increase FAC and recompute
c  DEL. NIFAC attempts are made to increase FAC and find an
c  appropriate DEL. If DEL can't be found in this manner, DEL is computed
c  with FAC set to the square root of the machine precision(=USQT).
c  If DEL is zero to machine precision because T is zero or
c  YSCALE is zero, DEL is set to USQT.
C
      IRDEL = 0
      IF (YSCALE(1) .ne. 0.D0) THEN
         AY = ABS(YSCALE(JCOL))

      ELSE
         AY = ABS(Y(JCOL))
      END IF
      SGN=1.D0
      IF(YSCALE(1) .ne. 0.D0)SGN = SIGN(1.D0,YSCALE(JCOL))
      DELM = U7EGT*AY
C
      DO 60 J = 1,NIFAC
         DEL = FAC(JCOL)*AY*SGN
         IF (DEL.EQ.0.D0) THEN
            DEL = USQT*SGN
            IF (ITRY.EQ.0) IWK(3) = IWK(3) + 1
         END IF

         T1 = Y(JCOL) + DEL
         DEL = T1 - Y(JCOL)
         IF (ABS(DEL).LT.DELM) THEN
            IF (J.GE.NIFAC) GO TO 60
            IF (IRDEL.EQ.0) THEN
               IRDEL = 1
               IWK(7) = IWK(7) + 1
            END IF

            T1 = FAC(JCOL)*UMEGT
            FAC(JCOL) = MIN(T1,FACMAX)

         ELSE
            GO TO 70
         END IF

 60   CONTINUE
C
      FAC(JCOL) = USQT
      DEL = USQT*AY*SGN
      IWK(2) = IWK(2) + 1
C
 70   CONTINUE
C  See if central divided differences are intended.
      IF(STATED .gt. 1) THEN
         DEL = CFACT*DEL
      END IF

      SAVDEL = DEL
      Y(JCOL) = Y(JCOL) + DEL
      IWK(1) = IWK(1) + 1
C
c  With reverse communication, DJACG returns to calling routine
c  for function values. Afterwards, DJACG transfers control
c  to the statement after the comment - ENTRY POINT FOR REVERSE
C  COMMUNICATION.

C     Pack up scalars that need saving.  Place in store within
C     WK(*) and IWK(*).
      GO TO 190
 80   CONTINUE
      MODE = JCOL
      RETURN

C  ENTRY  POINT FOR REVERSE COMMUNICATON.

 90   CONTINUE
C     Unpack scalars that needed saving.
C     Take from WK(*) and IWK(*) where they are stored.
      GO TO 220
 100  CONTINUE
C See if this is the second evaluation for a central difference.
C This is true STATED .gt. 1 .and. ITRY .eq. 1.
C and ITRY = 1.
      RDEL = 1.D0/SAVDEL
      IF(STATED .eq. 1) GO TO 140
C IF ITRY = 1, proceed and compute the central divided difference.
      IF(ITRY .eq. 1) GO TO 120
C Otherwise ITRY = 0, so an alternate evaluation is needed.
      Y(JCOL)=SAVY-DEL
      DO 110 I=1,M
         WK(I+M)=WK(I)
 110  CONTINUE
      ITRY=1
      IWK(1) = IWK(1) + 1
      GO TO 190

 120  CONTINUE
C Compute the central divided difference.
      RDEL=.5*RDEL
      DO 130 I=1,M
         FJAC(I,JCOL)=RDEL*(WK(I+M)-WK(I))
 130  CONTINUE

C Restore the component of Y() and move on.
      Y(JCOL) = SAVY
      ITRY=0
      GO TO 170

C Restore the component of Y() and move on.
 140  CONTINUE
      Y(JCOL) = SAVY

C
c  Compute the Jacobian entries.
c  Use largest elements in a column to determine scaling
c  information for roundoff and truncation error tests.
C
      DMAX = 0.D0
      IROWMX = 1

C
      DO 150 IROW = 1,M
         DIFF = WK(IROW) - F(IROW)
         ADIFF = ABS(DIFF)
         IF (ADIFF.GE.DMAX) THEN
            IROWMX = IROW
            DMAX = ADIFF
            SF = F(IROW)
            SDF = WK(IROW)
         END IF

         FJACL = DIFF*RDEL
         IF (ITRY.EQ.1) THEN
            WK(IROW) = FJACL
            WK(IROW+M) = FJAC(IROW,JCOL)
         END IF

         FJAC(IROW,JCOL) = FJACL
 150  CONTINUE

c  If a column is being recomputed (ITRY=1), this section of the
c  code performs an extrapolation test to enable the code to
c  compute small derivatives more accurately.
C
      IF (ITRY.EQ.1) THEN
         T1 = WK(IROWMX+M)
         T2 = WK(IROWMX)*FAC(JCOL)
         IF (ABS(T2).LT.ABS(T1)*PERT) THEN
            T1 = FAC(JCOL)*FAC(JCOL)
            FAC(JCOL) = MAX(T1,FACMIN)
            DO 160 IROW = 1,M
               FJACL = WK(IROW+M)
               FJAC(IROW,JCOL) = FJACL
 160        CONTINUE
         END IF

      END IF
C
      FMJ = ABS(SF)
      DFMJ = ABS(SDF)
      RMXFDF = MAX(FMJ,DFMJ)
      RMNFDF = MIN(FMJ,DFMJ)
C
c   If scale information is not available, perform no roundoff
c   or truncation error tests.
C
      IF (RMNFDF.NE.0.D0) THEN
C
c    Test for possible roundoff error (first test)
c    and also for possible serious roundoff error (second test).
C
         IF (DMAX.LE. (U3QRT*RMXFDF)) THEN
            IF (DMAX.LE. (U7EGT*RMXFDF)) THEN
               IF (ITRY.EQ.0) THEN
                  T1 = SQRT(FAC(JCOL))
                  FAC(JCOL) = MIN(T1,FACMAX)
                  IRCMP = 1
                  IWK(4) = IWK(4) + 1
                  IWK(10) = JCOL

               ELSE
                  IWK(5) = IWK(5) + 1
               END IF

            ELSE
               T1 = UMEGT*FAC(JCOL)
               FAC(JCOL) = MIN(T1,FACMAX)
            END IF

         END IF
C
c     Test for possible truncation error.
C
         IF (DMAX.GT.UQRT*RMXFDF) THEN
            T1 = FAC(JCOL)*UEGT
            FAC(JCOL) = MAX(T1,FACMIN)
            IWK(8) = IWK(8) + 1
            IWK(9) = JCOL
         END IF

      ELSE
         IWK(6) = IWK(6) + 1
C
      END IF
C
c     If serious roundoff error is suspected, recompute the
c     column.
C
C
      IF (IRCMP.EQ.1) THEN
         IRCMP = 0
         ITRY = 1
         GO TO 50

      END IF

      ITRY = 0

C Branch to this place if this column is skipped.
 170  CONTINUE
C May have asked for this column to be accumulated.
      IF(STATEA .gt. 1 .and. STATES .eq. 1) THEN
         DO 180 IROW=1,M
            FJAC(IROW,JCOL)=FJAC(IROW,JCOL)+WK(IROW+2*M)
 180     CONTINUE
      END IF

      IF (JCOL.LT.N) GO TO 30
C This is the signal that all Jacobian columns are computed.
      MODE = 0
      RETURN

C Internal procedure to save local data.
C This step is needed to make the code re-entrant and threadsafe.
 190  CONTINUE

      RBUF(01)=FACMIN
      RBUF(02)=FACMAX
      RBUF(03)=CFACT
      RBUF(04)=USQT
      RBUF(05)=UEGT

      RBUF(06)=UMEGT
      RBUF(07)=UQRT
      RBUF(08)=U3QRT
      RBUF(09)=U7EGT
      RBUF(10)=U

      RBUF(11)=CFACT
      RBUF(12)=SAVDEL
      RBUF(13)=PERT
      RBUF(14)=SAVY
      RBUF(15)=AY

      RBUF(16)=SGN
      RBUF(17)=DEL
      RBUF(18)=DELM
C Save data values in calling program unit.  When the code is
C entered again these are extracted from storage the store
C in the calling program.  This eliminates the need to save
C any variables.

      DO 200 I=1,LRBUF
         WK(I+3*M)=RBUF(I)
 200  CONTINUE

      INTBUF(01)=NIFAC
      INTBUF(02)=I
      INTBUF(03)=J
      INTBUF(04)=ITRY
      INTBUF(05)=IRDEL

      INTBUF(06)=IRCMP
      INTBUF(07)=JCOL
      INTBUF(08)=NS
      INTBUF(09)=STATEA
      INTBUF(10)=STATED

      INTBUF(11)=STATES

C Save data values in calling program unit.  When the code is
C called again these are extracted.
      DO 210 I =1,LNTBUF
         IWK(I+10)=INTBUF(I)
 210  CONTINUE

      GO TO 80
C Internal procedure to unpack saved data.
 220  CONTINUE
C Extract saved data from store in the calling program unit.
      DO 230 I=1,LRBUF
         RBUF(I)= WK(I+3*M)
 230  CONTINUE

      FACMIN=RBUF(01)
      FACMAX=RBUF(02)
      CFACT =RBUF(03)
      USQT  =RBUF(04)
      UEGT  =RBUF(05)

      UMEGT =RBUF(06)
      UQRT  =RBUF(07)
      U3QRT =RBUF(08)
      U7EGT =RBUF(09)
      U     =RBUF(10)

      CFACT =RBUF(11)
      SAVDEL=RBUF(12)
      PERT  =RBUF(13)
      SAVY  =RBUF(14)
      AY    =RBUF(15)

      SGN   =RBUF(16)
      DEL   =RBUF(17)
      DELM  =RBUF(18)

C Extract saved data from store in the calling program unit.
      DO 240 I =1,LNTBUF
         INTBUF(I)=IWK(I+10)
 240  CONTINUE

      NIFAC =INTBUF(01)
      I     =INTBUF(02)
      J     =INTBUF(03)
      ITRY  =INTBUF(04)
      IRDEL =INTBUF(05)

      IRCMP =INTBUF(06)
      JCOL  =INTBUF(07)
      NS    =INTBUF(08)
      STATEA=INTBUF(09)
      STATED=INTBUF(10)

      STATES=INTBUF(11)
      GO TO 100

 1000 CONTINUE
C Error return when arguments are invalid.
      MODE=-MODE

      END


DO I=1,100
IF(MOD(I,3)==0)THEN
IF(MOD(I,5)==0)THEN
PRINT'("FizzBuzz")'
ELSE
PRINT'("Fizz")'
ENDIF
ELSEIF(MOD(I,5)==0)THEN
PRINT'("Buzz")'
ELSE
PRINT'(I0)',I
ENDIF
ENDDO
END


      subroutine tred3(n, nv, a, d, e, e2)
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY:  double
!...Translated by Pacific-Sierra Research 77to90  4.3E  21:52:17  11/14/01
!...Switches:
      implicit none
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      integer , intent(in) :: n
      integer , intent(in) :: nv
      real(double) , intent(inout) :: a(nv)
      real(double) , intent(inout) :: d(n)
      real(double) , intent(inout) :: e(n)
      real(double) , intent(out) :: e2(n)
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      integer :: i, j, k, l, ii, iz, jk, jm1
      real(double) :: f, g, h, hh, scale
!-----------------------------------------------
!
!
!     this subroutine is a translation of the algol procedure tred3,
!     num. math. 11, 181-195(1968) by martin, reinsch, and wilkinson.
!     handbook for auto. comp., vol.ii-linear algebra, 212-226(1971).
!
!     this subroutine reduces a real symmetric matrix, stored as
!     a one-dimensional array, to a symmetric tridiagonal matrix
!     using orthogonal similarity transformations.
!
!     on input
!
!        n is the order of the matrix.
!
!        nv must be set to the dimension of the array parameter a
!          as declared in the calling program dimension statement.
!
!        a contains the lower triangle of the real symmetric
!          input matrix, stored row-wise as a one-dimensional
!          array, in its first n*(n+1)/2 positions.
!
!     on output
!
!        a contains information about the orthogonal
!          transformations used in the reduction.
!
!        d contains the diagonal elements of the tridiagonal matrix.
!
!        e contains the subdiagonal elements of the tridiagonal
!          matrix in its last n-1 positions.  e(1) is set to zero.
!
!        e2 contains the squares of the corresponding elements of e.
!          e2 may coincide with e if the squares are not needed.
!
!     questions and comments should be directed to burton s. garbow,
!     mathematics and computer science div, argonne national laboratory
!
!     this version dated august 1983.
!
!     ------------------------------------------------------------------
!
!     .......... for i=n step -1 until 1 do -- ..........
      do ii = 1, n
         i = n + 1 - ii
         l = i - 1
         iz = (i*l)/2
         h = 0.0D0
         scale = 0.0D0
         if (l < 1) go to 130
!     .......... scale row (algol tol then not needed) ..........
         do k = 1, l
            iz = iz + 1
            d(k) = a(iz)
            scale = scale + dabs(d(k))
         end do
!
         if (scale /= 0.0D0) go to 140
  130    continue
         e(i) = 0.0D0
         e2(i) = 0.0D0
         go to 290
!
  140    continue
         d(:l) = d(:l)/scale
         h = sum(d(:l)*d(:l))
!
         e2(i) = scale*scale*h
         f = d(l)
         g = -dsign(dsqrt(h),f)
         e(i) = scale*g
         h = h - f*g
         d(l) = f - g
         a(iz) = scale*d(l)
         if (l /= 1) then
            jk = 1
!
            do j = 1, l
               f = d(j)
               g = 0.0D0
               jm1 = j - 1
               if (jm1 >= 1) then
!
                  if (jm1 > 0) then
                     g = sum(a(jk:jm1-1+jk)*d(:jm1))
                     e(:jm1) = e(:jm1) + a(jk:jm1-1+jk)*f
                     jk = jm1 + jk
                  endif
               endif
!
               e(j) = g + a(jk)*f
               jk = jk + 1
            end do
!     .......... form p ..........
            f = 0.0D0
!
            e(:l) = e(:l)/h
            f = sum(e(:l)*d(:l))
!
            hh = f/(h + h)
!     .......... form q ..........
            e(:l) = e(:l) - hh*d(:l)
!
            jk = 1
!     .......... form reduced a ..........
            do j = 1, l
               f = d(j)
               g = e(j)
!
               if (j > 0) then
                  a(jk:j-1+jk) = a(jk:j-1+jk) - f*e(:j) - g*d(:j)
                  jk = j + jk
               endif
!
            end do
!
         endif
  290    continue
         d(i) = a(iz+1)
         a(iz+1) = scale*dsqrt(h)
      end do
!
      return
      end subroutine tred3


	subroutine x2ex(ni,nj,psi,xx,yy)
	implicit none
	integer*4 i,j,ni,nj
	real*8 :: xmin,ymin,xmax,ymax,dx,dy,x,y
	integer*4,parameter :: mn=256
	complex*16 :: psi(mn,mn)
	real*8,intent(out) :: xx,yy
	common /grid/ xmin,ymin,xmax,ymax,dx,dy
	xx=0d0
	yy=0d0

c 	calculate the average value of x,y
	do j=1,nj
	y=ymin+(j-1)*dy
	do i=1,ni
	x=xmin+(i-1)*dx
	xx=xx+abs(psi(i,j))**2*dx*dy*x**2
	yy=yy+abs(psi(i,j))**2*dx*dy*y**2
	enddo
	enddo

	end subroutine


      DOUBLE PRECISION FUNCTION dbetrm(a,b)
C**********************************************************************
C
C     DOUBLE PRECISION FUNCTION DBETRM( A, B )
C          Double Precision Sterling Remainder for Complete
C                    Beta Function
C
C
C                              Function
C
C
C     Log(Beta(A,B)) = Lgamma(A) + Lgamma(B) - Lgamma(A+B)
C     where Lgamma is the log of the (complete) gamma function
C
C     Let ZZ be approximation obtained if each log gamma is approximated
C     by Sterling's formula, i.e.,
C     Sterling(Z) = LOG( SQRT( 2*PI ) ) + ( Z-0.5 ) * LOG( Z ) - Z
C
C     Returns Log(Beta(A,B)) - ZZ
C
C
C                              Arguments
C
C
C     A --> One argument of the Beta
C                    DOUBLE PRECISION A
C
C     B --> The other argument of the Beta
C                    DOUBLE PRECISION B
C
C**********************************************************************
C     .. Scalar Arguments ..
      DOUBLE PRECISION a,b
C     ..
C     .. External Functions ..
      DOUBLE PRECISION dstrem
      EXTERNAL dstrem
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC max,min
C     ..
C     .. Executable Statements ..

C     Try to sum from smallest to largest
      dbetrm = -dstrem(a+b)
      dbetrm = dbetrm + dstrem(max(a,b))
      dbetrm = dbetrm + dstrem(min(a,b))
      RETURN

      END


      DOUBLE PRECISION FUNCTION algdiv(a,b)
C-----------------------------------------------------------------------
C
C     COMPUTATION OF LN(GAMMA(B)/GAMMA(A+B)) WHEN B .GE. 8
C
C                         --------
C
C     IN THIS ALGORITHM, DEL(X) IS THE FUNCTION DEFINED BY
C     LN(GAMMA(X)) = (X - 0.5)*LN(X) - X + 0.5*LN(2*PI) + DEL(X).
C
C-----------------------------------------------------------------------
C     .. Scalar Arguments ..
      DOUBLE PRECISION a,b
C     ..
C     .. Local Scalars ..
      DOUBLE PRECISION c,c0,c1,c2,c3,c4,c5,d,h,s11,s3,s5,s7,s9,t,u,v,w,
     +                 x,x2
C     ..
C     .. External Functions ..
      DOUBLE PRECISION alnrel
      EXTERNAL alnrel
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC dlog
C     ..
C     .. Data statements ..
      DATA c0/.833333333333333D-01/,c1/-.277777777760991D-02/,
     +     c2/.793650666825390D-03/,c3/-.595202931351870D-03/,
     +     c4/.837308034031215D-03/,c5/-.165322962780713D-02/
C     ..
C     .. Executable Statements ..
C------------------------
      IF (a.LE.b) GO TO 10
      h = b/a
      c = 1.0D0/ (1.0D0+h)
      x = h/ (1.0D0+h)
      d = a + (b-0.5D0)
      GO TO 20

   10 h = a/b
      c = h/ (1.0D0+h)
      x = 1.0D0/ (1.0D0+h)
      d = b + (a-0.5D0)
C
C                SET SN = (1 - X**N)/(1 - X)
C
   20 x2 = x*x
      s3 = 1.0D0 + (x+x2)
      s5 = 1.0D0 + (x+x2*s3)
      s7 = 1.0D0 + (x+x2*s5)
      s9 = 1.0D0 + (x+x2*s7)
      s11 = 1.0D0 + (x+x2*s9)
C
C                SET W = DEL(B) - DEL(A + B)
C
      t = (1.0D0/b)**2
      w = ((((c5*s11*t+c4*s9)*t+c3*s7)*t+c2*s5)*t+c1*s3)*t + c0
      w = w* (c/b)
C
C                    COMBINE THE RESULTS
C
      u = d*alnrel(a/b)
      v = a* (dlog(b)-1.0D0)
      IF (u.LE.v) GO TO 30
      algdiv = (w-v) - u
      RETURN

   30 algdiv = (w-u) - v
      RETURN

      END


!=======================================================================
!
!  Calculate the Doppler line width of each coolant species for all
!  particles. Contributions from both thermal and turbulent motions
!  are included.
!
!-----------------------------------------------------------------------
SUBROUTINE UPDATE_COOLANT_LINEWIDTHS(NPART,NCOOL,COOLANT,PARTICLE)

   USE HEALPIX_TYPES
   USE COOLANT_MODULE
   USE PARTICLE_MODULE
   USE GLOBAL_MODULE, ONLY : V_TURB

   IMPLICIT NONE

   INTEGER(KIND=I4B),   INTENT(IN)    :: NPART,NCOOL
   TYPE(COOLANT_TYPE),  INTENT(IN)    :: COOLANT(*)
   TYPE(PARTICLE_TYPE), INTENT(INOUT) :: PARTICLE(*)

   INTEGER(KIND=I4B) :: N,P
   REAL(KIND=DP) :: V_THERM

!  Calculate the mean thermal velocity of each coolant species at the relevant
!  gas temperature for each particle. Update the Doppler line widths (cm s^-1)
!  by adding the thermal and turbulent velocities in quadrature.
   DO N=1,NCOOL ! Loop over coolants
      DO P=1,NPART ! Loop over particles
         V_THERM = SQRT(2*KB*PARTICLE(P)%GAS_TEMPERATURE/(COOLANT(N)%MOLECULAR_MASS*MP)) ! v_thermal = (2kT/m)^1/2
         PARTICLE(P)%COOLANT(N)%LINEWIDTH = SQRT(V_THERM**2 + V_TURB**2) ! δv_D = (v_thermal^2 + v_turbulent^2)^1/2
      END DO ! End of loop over particles
   END DO ! End of loop over coolants

   RETURN
END SUBROUTINE UPDATE_COOLANT_LINEWIDTHS
!=======================================================================


      SUBROUTINE MB04QC( STRAB, TRANA, TRANB, TRANQ, DIRECT, STOREV,
     $                   STOREW, M, N, K, V, LDV, W, LDW, RS, LDRS, T,
     $                   LDT, A, LDA, B, LDB, DWORK )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To apply the orthogonal symplectic block reflector
C
C              [  I+V*T*V'  V*R*S*V'  ]
C         Q =  [                      ]
C              [ -V*R*S*V'  I+V*T*V'  ]
C
C     or its transpose to a real 2m-by-n matrix [ op(A); op(B) ] from
C     the left.
C     The k-by-k upper triangular blocks of the matrices
C
C                                 [ S1 ]       [ T11 T12 T13 ]
C         R  = [ R1 R2 R3 ],  S = [ S2 ],  T = [ T21 T22 T23 ],
C                                 [ S3 ]       [ T31 T32 T33 ]
C
C     with R2 unit and S1, R3, T21, T31, T32 strictly upper triangular,
C     are stored rowwise in the arrays RS and T, respectively.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     STRAB   CHARACTER*1
C             Specifies the structure of the first blocks of A and B:
C             = 'Z':  the leading K-by-N submatrices of op(A) and op(B)
C                     are (implicitly) assumed to be zero;
C             = 'N';  no structure to mention.
C
C     TRANA   CHARACTER*1
C             Specifies the form of op( A ) as follows:
C             = 'N':  op( A ) = A;
C             = 'T':  op( A ) = A';
C             = 'C':  op( A ) = A'.
C
C     TRANB   CHARACTER*1
C             Specifies the form of op( B ) as follows:
C             = 'N':  op( B ) = B;
C             = 'T':  op( B ) = B';
C             = 'C':  op( B ) = B'.
C
C     DIRECT  CHARACTER*1
C             This is a dummy argument, which is reserved for future
C             extensions of this subroutine. Not referenced.
C
C     TRANQ   CHARACTER*1
C             = 'N':  apply Q;
C             = 'T':  apply Q'.
C
C     STOREV  CHARACTER*1
C             Specifies how the vectors which define the concatenated
C             Householder reflectors contained in V are stored:
C             = 'C':  columnwise;
C             = 'R':  rowwise.
C
C     STOREW  CHARACTER*1
C             Specifies how the vectors which define the concatenated
C             Householder reflectors contained in W are stored:
C             = 'C':  columnwise;
C             = 'R':  rowwise.
C
C     Input/Output Parameters
C
C     M       (input) INTEGER
C             The number of rows of the matrices op(A) and op(B).
C             M >= 0.
C
C     N       (input) INTEGER
C             The number of columns of the matrices op(A) and op(B).
C             N >= 0.
C
C     K       (input) INTEGER
C             The order of the triangular matrices defining R, S and T.
C             M >= K >= 0.
C
C     V       (input) DOUBLE PRECISION array, dimension
C                     (LDV,K) if STOREV = 'C',
C                     (LDV,M) if STOREV = 'R'
C             On entry with STOREV = 'C', the leading M-by-K part of
C             this array must contain in its columns the vectors which
C             define the elementary reflector used to form parts of Q.
C             On entry with STOREV = 'R', the leading K-by-M part of
C             this array must contain in its rows the vectors which
C             define the elementary reflector used to form parts of Q.
C
C     LDV     INTEGER
C             The leading dimension of the array V.
C             LDV >= MAX(1,M),  if STOREV = 'C';
C             LDV >= MAX(1,K),  if STOREV = 'R'.
C
C     W       (input) DOUBLE PRECISION array, dimension
C                     (LDW,K) if STOREW = 'C',
C                     (LDW,M) if STOREW = 'R'
C             On entry with STOREW = 'C', the leading M-by-K part of
C             this array must contain in its columns the vectors which
C             define the elementary reflector used to form parts of Q.
C             On entry with STOREW = 'R', the leading K-by-M part of
C             this array must contain in its rows the vectors which
C             define the elementary reflector used to form parts of Q.
C
C     LDW     INTEGER
C             The leading dimension of the array W.
C             LDW >= MAX(1,M),  if STOREW = 'C';
C             LDW >= MAX(1,K),  if STOREW = 'R'.
C
C     RS      (input) DOUBLE PRECISION array, dimension (K,6*K)
C             On entry, the leading K-by-6*K part of this array must
C             contain the upper triangular matrices defining the factors
C             R and S of the symplectic block reflector Q. The
C             (strictly) lower portions of this array are not
C             referenced.
C
C     LDRS    INTEGER
C             The leading dimension of the array RS.  LDRS >= MAX(1,K).
C
C     T       (input) DOUBLE PRECISION array, dimension (K,9*K)
C             On entry, the leading K-by-9*K part of this array must
C             contain the upper triangular matrices defining the factor
C             T of the symplectic block reflector Q. The (strictly)
C             lower portions of this array are not referenced.
C
C     LDT     INTEGER
C             The leading dimension of the array T.  LDT >= MAX(1,K).
C
C     A       (input/output) DOUBLE PRECISION array, dimension
C                     (LDA,N) if TRANA = 'N',
C                     (LDA,M) if TRANA = 'C' or TRANA = 'T'
C             On entry with TRANA = 'N', the leading M-by-N part of this
C             array must contain the matrix A.
C             On entry with TRANA = 'T' or TRANA = 'C', the leading
C             N-by-M part of this array must contain the matrix A.
C
C     LDA     INTEGER
C             The leading dimension of the array A.
C             LDA >= MAX(1,M),  if TRANA = 'N';
C             LDA >= MAX(1,N),  if TRANA = 'C' or TRANA = 'T'.
C
C     B       (input/output) DOUBLE PRECISION array, dimension
C                     (LDB,N) if TRANB = 'N',
C                     (LDB,M) if TRANB = 'C' or TRANB = 'T'
C             On entry with TRANB = 'N', the leading M-by-N part of this
C             array must contain the matrix B.
C             On entry with TRANB = 'T' or TRANB = 'C', the leading
C             N-by-M part of this array must contain the matrix B.
C
C     LDB     INTEGER
C             The leading dimension of the array B.
C             LDB >= MAX(1,M),  if TRANB = 'N';
C             LDB >= MAX(1,N),  if TRANB = 'C' or TRANB = 'T'.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK), where
C             LDWORK >= 8*N*K,   if STRAB = 'Z',
C             LDWORK >= 9*N*K,   if STRAB = 'N'.
C
C     REFERENCES
C
C     [1] Kressner, D.
C         Block algorithms for orthogonal symplectic factorizations.
C         BIT, 43 (4), pp. 775-790, 2003.
C
C     NUMERICAL ASPECTS
C
C     The algorithm requires 16*( M - K )*N + ( 26*K - 4 )*K*N floating
C     point operations if STRAB = 'Z' and additional ( 12*K + 2 )*K*N
C     floating point operations if STRAB = 'N'.
C
C     CONTRIBUTORS
C
C     D. Kressner, Technical Univ. Berlin, Germany, and
C     P. Benner, Technical Univ. Chemnitz, Germany, December 2003.
C
C     REVISIONS
C
C     V. Sima, June 2008 (SLICOT version of the HAPACK routine DLAESB).
C     P. Gahinet, The MathWorks, Natick, U.S.A., Mar. 2011.
C
C     KEYWORDS
C
C     Elementary matrix operations, orthogonal symplectic matrix.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         DIRECT, STOREV, STOREW, STRAB, TRANA, TRANB,
     $                  TRANQ
      INTEGER           K, LDA, LDB, LDRS, LDT, LDV, LDW, M, N
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LDA,*), B(LDB,*), DWORK(*), RS(LDRS,*),
     $                  T(LDT,*), V(LDV,*), W(LDW,*)
C     .. Local Scalars ..
      LOGICAL           LA1B1, LCOLV, LCOLW, LTRA, LTRB, LTRQ
      INTEGER           I, ITEMP, PDW1, PDW2, PDW3, PDW4, PDW5, PDW6,
     $                  PDW7, PDW8, PDW9, PR1, PR2, PR3, PS1, PS2, PS3,
     $                  PT11, PT12, PT13, PT21, PT22, PT23, PT31, PT32,
     $                  PT33
      DOUBLE PRECISION  FACT
C     .. External Functions ..
      LOGICAL           LSAME
      EXTERNAL          LSAME
C     .. External Subroutines ..
      EXTERNAL          DAXPY, DCOPY, DGEMM, DLASET, DTRMM
C
C     .. Executable Statements ..
C
C     Quick return if possible.
C
      IF ( M.LE.0 .OR. N.LE.0 )
     $   RETURN
      LA1B1 = LSAME( STRAB, 'N' )
      LCOLV = LSAME( STOREV, 'C' )
      LCOLW = LSAME( STOREW, 'C' )
      LTRA  = LSAME( TRANA,  'T' ) .OR. LSAME( TRANA, 'C' )
      LTRB  = LSAME( TRANB,  'T' ) .OR. LSAME( TRANB, 'C' )
      LTRQ  = LSAME( TRANQ,  'T' ) .OR. LSAME( TRANQ, 'C' )
C
      PR1  = 1
      PR2  = PR1 + K
      PR3  = PR2 + K
      PS1  = PR3 + K
      PS2  = PS1 + K
      PS3  = PS2 + K
      PT11 = 1
      PT12 = PT11 + K
      PT13 = PT12 + K
      PT21 = PT13 + K
      PT22 = PT21 + K
      PT23 = PT22 + K
      PT31 = PT23 + K
      PT32 = PT31 + K
      PT33 = PT32 + K
      PDW1 = 1
      PDW2 = PDW1 + N*K
      PDW3 = PDW2 + N*K
      PDW4 = PDW3 + N*K
      PDW5 = PDW4 + N*K
      PDW6 = PDW5 + N*K
      PDW7 = PDW6 + N*K
      PDW8 = PDW7 + N*K
      PDW9 = PDW8 + N*K
C
C     Update the matrix A.
C
      IF ( LA1B1 ) THEN
C
C        NZ1) DW7 := A1'
C
         IF ( LTRA ) THEN
            DO 10  I = 1, K
               CALL DCOPY( N, A(1,I), 1, DWORK(PDW7+(I-1)*N), 1 )
   10       CONTINUE
         ELSE
            DO 20  I = 1, N
               CALL DCOPY( K, A(1,I), 1, DWORK(PDW7+I-1), N )
   20       CONTINUE
         END IF
C
C        NZ2) DW1 := DW7*W1
C
         CALL DCOPY( N*K, DWORK(PDW7), 1, DWORK(PDW1), 1 )
         IF ( LCOLW ) THEN
            CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N,
     $                  K, ONE, W, LDW, DWORK(PDW1), N )
         ELSE
            CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N,
     $                  K, ONE, W, LDW, DWORK(PDW1), N )
         END IF
C
C        NZ3) DW2 := DW7*V1
C
         CALL DCOPY( N*K, DWORK(PDW7), 1, DWORK(PDW2), 1 )
         IF ( LCOLV ) THEN
            CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N,
     $                  K, ONE, V, LDV, DWORK(PDW2), N )
         ELSE
            CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N,
     $                  K, ONE, V, LDV, DWORK(PDW2), N )
         END IF
         FACT = ONE
      ELSE
         FACT = ZERO
      END IF
C
C     1) DW1 := A2'*W2
C
      IF ( M.GT.K ) THEN
         IF ( LTRA.AND.LCOLW ) THEN
            CALL DGEMM( 'No Transpose', 'No Transpose', N, K, M-K, ONE,
     $                  A(1,K+1), LDA, W(K+1,1), LDW, FACT, DWORK(PDW1),
     $                  N )
         ELSE IF ( LTRA ) THEN
            CALL DGEMM( 'No Transpose', 'Transpose', N, K, M-K, ONE,
     $                  A(1,K+1), LDA, W(1,K+1), LDW, FACT, DWORK(PDW1),
     $                  N )
         ELSE IF ( LCOLW ) THEN
            CALL DGEMM( 'Transpose', 'No Transpose', N, K, M-K, ONE,
     $                  A(K+1,1), LDA, W(K+1,1), LDW, FACT, DWORK(PDW1),
     $                  N )
         ELSE
            CALL DGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE,
     $                  A(K+1,1), LDA, W(1,K+1), LDW, FACT, DWORK(PDW1),
     $                  N )
         END IF
      ELSE IF ( .NOT.LA1B1 ) THEN
         CALL DLASET( 'All', N, K, ZERO, ZERO, DWORK(PDW1), N )
      END IF
C
C     2) DW2 := A2'*V2
C
      IF ( M.GT.K ) THEN
         IF ( LTRA.AND.LCOLV ) THEN
            CALL DGEMM( 'No Transpose', 'No Transpose', N, K, M-K, ONE,
     $                  A(1,K+1), LDA, V(K+1,1), LDV, FACT, DWORK(PDW2),
     $                  N )
         ELSE IF ( LTRA ) THEN
            CALL DGEMM( 'No Transpose', 'Transpose', N, K, M-K, ONE,
     $                  A(1,K+1), LDA, V(1,K+1), LDV, FACT, DWORK(PDW2),
     $                  N )
         ELSE IF ( LCOLV ) THEN
            CALL DGEMM( 'Transpose', 'No Transpose', N, K, M-K, ONE,
     $                  A(K+1,1), LDA, V(K+1,1), LDV, FACT, DWORK(PDW2),
     $                  N )
         ELSE
            CALL DGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE,
     $                  A(K+1,1), LDA, V(1,K+1), LDV, FACT, DWORK(PDW2),
     $                  N )
         END IF
      ELSE IF ( .NOT.LA1B1 ) THEN
         CALL DLASET( 'All', N, K, ZERO, ZERO, DWORK(PDW2), N )
      END IF
C
      IF ( LTRQ ) THEN
C
C        3) DW3 := DW1*T11
C
         CALL DCOPY( N*K, DWORK(PDW1), 1, DWORK(PDW3), 1 )
         CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, K,
     $               ONE, T(1,PT11), LDT, DWORK(PDW3), N )
C
C        4) DW4 := DW2*T31
C
         CALL DCOPY( N*(K-1), DWORK(PDW2), 1, DWORK(PDW4), 1 )
         CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N,
     $               K-1, ONE, T(1,PT31+1), LDT, DWORK(PDW4), N )
C
C        5) DW3 := DW3 + DW4
C
         CALL DAXPY( N*(K-1), ONE, DWORK(PDW4), 1, DWORK(PDW3+N), 1 )
C
         IF ( LA1B1 ) THEN
C
C           NZ4) DW8 := DW7*T21
C
            CALL DCOPY( N*(K-1), DWORK(PDW7), 1, DWORK(PDW8), 1 )
            CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N,
     $                  K-1, ONE, T(1,PT21+1), LDT, DWORK(PDW8), N )
C
C           NZ5) DW3 := DW3 + DW8
C
            CALL DAXPY( N*(K-1), ONE, DWORK(PDW8), 1, DWORK(PDW3+N), 1 )
         END IF
C
C        6) DW4 := DW1*T12
C
         CALL DCOPY( N*K, DWORK(PDW1), 1, DWORK(PDW4), 1 )
         CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N,
     $               K, ONE, T(1,PT12), LDT, DWORK(PDW4), N )
C
C        7) DW5 := DW2*T32
C
         CALL DCOPY( N*(K-1), DWORK(PDW2), 1, DWORK(PDW5), 1 )
         CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N,
     $               K-1, ONE, T(1,PT32+1), LDT, DWORK(PDW5), N )
C
C        8) DW4 := DW4 + DW5
C
         CALL DAXPY( N*(K-1), ONE, DWORK(PDW5), 1, DWORK(PDW4+N), 1 )
C
         IF ( LA1B1 ) THEN
C
C           NZ6) DW8 := DW7*T22
C
            CALL DCOPY( N*K, DWORK(PDW7), 1, DWORK(PDW8), 1 )
            CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N,
     $                   K, ONE, T(1,PT22), LDT, DWORK(PDW8), N )
C
C           NZ7) DW4 := DW4 + DW8
C
            CALL DAXPY( N*K, ONE, DWORK(PDW8), 1, DWORK(PDW4), 1 )
         END IF
C
C        9) DW5 := DW2*T33
C
         CALL DCOPY( N*K, DWORK(PDW2), 1, DWORK(PDW5), 1 )
         CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, K,
     $               ONE, T(1,PT33), LDT, DWORK(PDW5), N )
C
C        10) DW6 := DW1*T13
C
         CALL DCOPY( N*K, DWORK(PDW1), 1, DWORK(PDW6), 1 )
         CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N,
     $               K, ONE, T(1,PT13), LDT, DWORK(PDW6), N )
C
C        11) DW5 := DW5 + DW6
C
         CALL DAXPY( N*K, ONE, DWORK(PDW6), 1, DWORK(PDW5), 1 )
C
         IF ( LA1B1 ) THEN
C
C           NZ8) DW8 := DW7*T23
C
            CALL DCOPY( N*K, DWORK(PDW7), 1, DWORK(PDW8), 1 )
            CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N,
     $                  K, ONE, T(1,PT23), LDT, DWORK(PDW8), N )
C
C           NZ9) DW5 := DW5 + DW8
C
            CALL DAXPY( N*K, ONE, DWORK(PDW8), 1, DWORK(PDW5), 1 )
         END IF
C
C        12) DW1 := DW1*R1
C
         CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, K,
     $               ONE, RS(1,PR1), LDRS, DWORK(PDW1), N )
C
C        13) DW2 := DW2*R3
C
         CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N,
     $               K-1, ONE, RS(1,PR3+1), LDRS, DWORK(PDW2), N )
C
C        14) DW1 := DW1 + DW2
C
         CALL DAXPY( N*(K-1), ONE, DWORK(PDW2), 1, DWORK(PDW1+N), 1 )
C
         IF ( LA1B1 ) THEN
C
C           NZ10) DW7 := DW7*R2
C
            CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Unit', N, K,
     $                  ONE, RS(1,PR2), LDRS, DWORK(PDW7), N )
C
C           NZ11) DW1 := DW1 + DW7
C
            CALL DAXPY( N*K, ONE, DWORK(PDW7), 1, DWORK(PDW1), 1 )
         END IF
C
C        Swap Pointers PDW1 <-> PDW2
C
         ITEMP = PDW2
         PDW2 = PDW1
         PDW1 = ITEMP
      ELSE
C
C        3) DW3 := DW1*T11'
C
         CALL DCOPY( N*K, DWORK(PDW1), 1, DWORK(PDW3), 1 )
         CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K,
     $               ONE, T(1,PT11), LDT, DWORK(PDW3), N )
C
C        4) DW4 := DW2*T13'
C
         CALL DCOPY( N*K, DWORK(PDW2), 1, DWORK(PDW4), 1 )
         CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K,
     $               ONE, T(1,PT13), LDT, DWORK(PDW4), N )
C
C        5) DW3 := DW3 + DW4
C
         CALL DAXPY( N*K, ONE, DWORK(PDW4), 1, DWORK(PDW3), 1 )
C
         IF ( LA1B1 ) THEN
C
C           NZ4) DW8 := DW7*T12'
C
            CALL DCOPY( N*K, DWORK(PDW7), 1, DWORK(PDW8), 1 )
            CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K,
     $                  ONE, T(1,PT12), LDT, DWORK(PDW8), N )
C
C           NZ5) DW3 := DW3 + DW8
C
            CALL DAXPY( N*K, ONE, DWORK(PDW8), 1, DWORK(PDW3), 1 )
         END IF
C
C        6) DW4 := DW2*T23'
C
         CALL DCOPY( N*K, DWORK(PDW2), 1, DWORK(PDW4), 1 )
         CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K,
     $               ONE, T(1,PT23), LDT, DWORK(PDW4), N )
C
C        7) DW5 := DW1*T21'
C
         CALL DCOPY( N*(K-1), DWORK(PDW1+N), 1, DWORK(PDW5), 1 )
         CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K-1,
     $               ONE, T(1,PT21+1), LDT, DWORK(PDW5), N )
C
C        8) DW4 := DW4 + DW5
C
         CALL DAXPY( N*(K-1), ONE, DWORK(PDW5), 1, DWORK(PDW4), 1 )
C
         IF ( LA1B1 ) THEN
C
C           NZ6) DW8 := DW7*T22'
C
            CALL DCOPY( N*K, DWORK(PDW7), 1, DWORK(PDW8), 1 )
            CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K,
     $                  ONE, T(1,PT22), LDT, DWORK(PDW8), N )
C
C           NZ7) DW4 := DW4 + DW8
C
            CALL DAXPY( N*K, ONE, DWORK(PDW8), 1, DWORK(PDW4), 1 )
         END IF
C
C        9) DW5 := DW2*T33'
C
         CALL DCOPY( N*K, DWORK(PDW2), 1, DWORK(PDW5), 1 )
         CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K,
     $               ONE, T(1,PT33), LDT, DWORK(PDW5), N )
C
C        10) DW6 := DW1*T31'
C
         CALL DCOPY( N*(K-1), DWORK(PDW1+N), 1, DWORK(PDW6), 1 )
         CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K-1,
     $               ONE, T(1,PT31+1), LDT, DWORK(PDW6), N )
C
C        11) DW5 := DW5 + DW6
C
         CALL DAXPY( N*(K-1), ONE, DWORK(PDW6), 1, DWORK(PDW5), 1 )
C
         IF ( LA1B1 ) THEN
C
C           NZ8) DW8 := DW7*T32'
C
            CALL DCOPY( N*(K-1), DWORK(PDW7+N), 1, DWORK(PDW8), 1 )
            CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N,
     $                  K-1, ONE, T(1,PT32+1), LDT, DWORK(PDW8), N )
C
C           NZ9) DW5 := DW5 + DW8
C
            CALL DAXPY( N*(K-1), ONE, DWORK(PDW8), 1, DWORK(PDW5), 1 )
         END IF
C
C        12) DW1 := DW1*S1'
C
         CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K-1,
     $               ONE, RS(1,PS1+1), LDRS, DWORK(PDW1+N), N )
C
C        13) DW2 := DW2*S3'
C
         CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K,
     $               ONE, RS(1,PS3), LDRS, DWORK(PDW2), N )
C
C        14) DW2 := DW1 + DW2
C
         CALL DAXPY( N*(K-1), ONE, DWORK(PDW1+N), 1, DWORK(PDW2), 1 )
C
         IF ( LA1B1 ) THEN
C
C           NZ10) DW7 := DW7*S2'
C
            CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K,
     $                  ONE, RS(1,PS2), LDRS, DWORK(PDW7), N )
C
C           NZ11) DW2 := DW2 + DW7
C
            CALL DAXPY( N*K, ONE, DWORK(PDW7), 1, DWORK(PDW2), 1 )
         END IF
      END IF
C
      IF ( LA1B1 ) THEN
C
C        NZ12) DW9 := B1'
C
         IF ( LTRB ) THEN
            DO 30  I = 1, K
               CALL DCOPY( N, B(1,I), 1, DWORK(PDW9+(I-1)*N), 1 )
   30       CONTINUE
         ELSE
            DO 40  I = 1, N
               CALL DCOPY( K, B(1,I), 1, DWORK(PDW9+I-1), N )
   40       CONTINUE
         END IF
C
C        NZ13) DW1 := DW9*W1
C
         CALL DCOPY( N*K, DWORK(PDW9), 1, DWORK(PDW1), 1 )
         IF ( LCOLW ) THEN
            CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N,
     $                  K, ONE, W, LDW, DWORK(PDW1), N )
         ELSE
            CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N,
     $                  K, ONE, W, LDW, DWORK(PDW1), N )
         END IF
C
C        NZ14) DW6 := DW9*V1
C
         CALL DCOPY( N*K, DWORK(PDW9), 1, DWORK(PDW6), 1 )
         IF ( LCOLV ) THEN
            CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N,
     $                  K, ONE, V, LDV, DWORK(PDW6), N )
         ELSE
            CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N,
     $                  K, ONE, V, LDV, DWORK(PDW6), N )
         END IF
      END IF
C
C     15) DW1 := B2'*W2
C
      IF ( M.GT.K ) THEN
         IF ( LTRB.AND.LCOLW ) THEN
            CALL DGEMM( 'No Transpose', 'No Transpose', N, K, M-K, ONE,
     $                  B(1,K+1), LDB, W(K+1,1), LDW, FACT, DWORK(PDW1),
     $                  N )
         ELSE IF ( LTRB ) THEN
C
C           Critical Position
C
            CALL DGEMM( 'No Transpose', 'Transpose', N, K, M-K, ONE,
     $                  B(1,K+1), LDB, W(1,K+1), LDW, FACT, DWORK(PDW1),
     $                  N )
         ELSE IF ( LCOLW ) THEN
            CALL DGEMM( 'Transpose', 'No Transpose', N, K, M-K, ONE,
     $                  B(K+1,1), LDB, W(K+1,1), LDW, FACT, DWORK(PDW1),
     $                  N )
         ELSE
            CALL DGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE,
     $                  B(K+1,1), LDB, W(1,K+1), LDW, FACT, DWORK(PDW1),
     $                  N )
         END IF
      ELSE IF ( .NOT.LA1B1 ) THEN
         CALL DLASET( 'All', N, K, ZERO, ZERO, DWORK(PDW1), N )
      END IF
C
C     16) DW6 := B2'*V2
C
      IF ( M.GT.K ) THEN
         IF ( LTRB.AND.LCOLV ) THEN
            CALL DGEMM( 'No Transpose', 'No Transpose', N, K, M-K, ONE,
     $                  B(1,K+1), LDB, V(K+1,1), LDV, FACT, DWORK(PDW6),
     $                  N )
         ELSE IF ( LTRB ) THEN
            CALL DGEMM( 'No Transpose', 'Transpose', N, K, M-K, ONE,
     $                  B(1,K+1), LDB, V(1,K+1), LDV, FACT, DWORK(PDW6),
     $                  N )
         ELSE IF ( LCOLV ) THEN
            CALL DGEMM( 'Transpose', 'No Transpose', N, K, M-K, ONE,
     $                  B(K+1,1), LDB, V(K+1,1), LDV, FACT, DWORK(PDW6),
     $                  N )
         ELSE
            CALL DGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE,
     $                  B(K+1,1), LDB, V(1,K+1), LDV, FACT, DWORK(PDW6),
     $                  N )
         END IF
      ELSE IF ( .NOT.LA1B1 ) THEN
         CALL DLASET( 'All', N, K, ZERO, ZERO, DWORK(PDW6), N )
      END IF
C
      IF ( LTRQ ) THEN
C
C        17) DW7 := DW1*R1
C
         CALL DCOPY( N*K, DWORK(PDW1), 1, DWORK(PDW7), 1 )
         CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, K,
     $               ONE, RS(1,PR1), LDRS, DWORK(PDW7), N )
C
C        18) DW8 := DW6*R3
C
         CALL DCOPY( N*(K-1), DWORK(PDW6), 1, DWORK(PDW8), 1 )
         CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N,
     $               K-1, ONE, RS(1,PR3+1), LDRS, DWORK(PDW8), N )
C
C        19) DW7 := DW7 + DW8
C
         CALL DAXPY( N*(K-1), ONE, DWORK(PDW8), 1, DWORK(PDW7+N), 1 )
C
         IF ( LA1B1 ) THEN
C
C           NZ15) DW8 := DW9*R2
C
            CALL DCOPY( N*K, DWORK(PDW9), 1, DWORK(PDW8), 1 )
            CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Unit', N, K,
     $                  ONE, RS(1,PR2), LDRS, DWORK(PDW8), N )
C
C           NZ16) DW7 := DW7 + DW8
C
            CALL DAXPY( N*K, ONE, DWORK(PDW8), 1, DWORK(PDW7), 1 )
         END IF
C
C        20) DW8 := DW7*S1
C
         CALL DCOPY( N*(K-1), DWORK(PDW7), 1, DWORK(PDW8), 1 )
         CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N,
     $               K-1, ONE, RS(1,PS1+1), LDRS, DWORK(PDW8), N )
C
C        21) DW3 := DW3 - DW8
C
         CALL DAXPY( N*(K-1), -ONE, DWORK(PDW8), 1, DWORK(PDW3+N), 1 )
C
C        22) DW8 := DW7*S3
C
         CALL DCOPY( N*K, DWORK(PDW7), 1, DWORK(PDW8), 1 )
         CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N,
     $               K, ONE, RS(1,PS3), LDRS, DWORK(PDW8), N )
C
C        23) DW5 := DW5 - DW8
C
         CALL DAXPY( N*K, -ONE, DWORK(PDW8), 1, DWORK(PDW5), 1 )
C
C        24) DW7 := DW7*S2
C
         CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, K,
     $               -ONE, RS(1,PS2), LDRS, DWORK(PDW7), N )
      ELSE
C
C        17) DW7 := DW6*S3'
C
         CALL DCOPY( N*K, DWORK(PDW6), 1, DWORK(PDW7), 1 )
         CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K,
     $               ONE, RS(1,PS3), LDRS, DWORK(PDW7), N )
C
C        18) DW8 := DW1*S1'
C
         CALL DCOPY( N*(K-1), DWORK(PDW1+N), 1, DWORK(PDW8), 1 )
         CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K-1,
     $               ONE, RS(1,PS1+1), LDRS, DWORK(PDW8), N )
C
C        19) DW7 := DW7 + DW8
C
         CALL DAXPY( N*(K-1), ONE, DWORK(PDW8), 1, DWORK(PDW7), 1 )
C
         IF ( LA1B1 ) THEN
C
C           NZ15) DW8 := DW9*S2'
C
            CALL DCOPY( N*K, DWORK(PDW9), 1, DWORK(PDW8), 1 )
            CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K,
     $                  ONE, RS(1,PS2), LDRS, DWORK(PDW8), N )
C
C           NZ16) DW7 := DW7 + DW8
C
            CALL DAXPY( N*K, ONE, DWORK(PDW8), 1, DWORK(PDW7), 1 )
         END IF
C
C        20) DW8 := DW7*R1'
C
         CALL DCOPY( N*K, DWORK(PDW7), 1, DWORK(PDW8), 1 )
         CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K,
     $               ONE, RS(1,PR1), LDRS, DWORK(PDW8), N )
C
C        21) DW3 := DW3 + DW8
C
         CALL DAXPY( N*K, ONE, DWORK(PDW8), 1, DWORK(PDW3), 1 )
C
C        22) DW8 := DW7*R3'
C
         CALL DCOPY( N*(K-1), DWORK(PDW7+N), 1, DWORK(PDW8), 1 )
         CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K-1,
     $               ONE, RS(1,PR3+1), LDRS, DWORK(PDW8), N )
C
C        23) DW5 := DW5 + DW8
C
         CALL DAXPY( N*(K-1), ONE, DWORK(PDW8), 1, DWORK(PDW5), 1 )
C
C        24) DW7 := DW7*R2'
C
         CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, K,
     $               ONE, RS(1,PR2), LDRS, DWORK(PDW7), N )
      END IF
C
C     25) A2 := A2 + W2*DW3'
C
      IF ( M.GT.K ) THEN
         IF ( LTRA.AND.LCOLW ) THEN
            CALL DGEMM( 'No Transpose', 'Transpose', N, M-K, K, ONE,
     $                  DWORK(PDW3), N, W(K+1,1), LDW, ONE, A(1,K+1),
     $                  LDA )
         ELSE IF ( LTRA ) THEN
            CALL DGEMM( 'No Transpose', 'No Transpose', N, M-K, K, ONE,
     $                  DWORK(PDW3), N, W(1,K+1), LDW, ONE, A(1,K+1),
     $                  LDA )
         ELSE IF ( LCOLW ) THEN
            CALL DGEMM( 'No Transpose', 'Transpose', M-K, N, K, ONE,
     $                  W(K+1,1), LDW, DWORK(PDW3), N, ONE, A(K+1,1),
     $                  LDA )
         ELSE
            CALL DGEMM( 'Transpose', 'Transpose', M-K, N, K, ONE,
     $                  W(1,K+1), LDW, DWORK(PDW3), N, ONE, A(K+1,1),
     $                  LDA )
         END IF
      END IF
C
C     26) A2 := A2 + V2*DW5'
C
      IF ( M.GT.K ) THEN
         IF ( LTRA.AND.LCOLV ) THEN
            CALL DGEMM( 'No Transpose', 'Transpose', N, M-K, K, ONE,
     $                  DWORK(PDW5), N, V(K+1,1), LDV, ONE, A(1,K+1),
     $                  LDA )
         ELSE IF ( LTRA ) THEN
            CALL DGEMM( 'No Transpose', 'No Transpose', N, M-K, K, ONE,
     $                  DWORK(PDW5), N, V(1,K+1), LDV, ONE, A(1,K+1),
     $                  LDA )
         ELSE IF ( LCOLV ) THEN
            CALL DGEMM( 'No Transpose', 'Transpose', M-K, N, K, ONE,
     $                  V(K+1,1), LDV, DWORK(PDW5), N, ONE, A(K+1,1),
     $                  LDA )
         ELSE
            CALL DGEMM( 'Transpose', 'Transpose', M-K, N, K, ONE,
     $                  V(1,K+1), LDV, DWORK(PDW5), N, ONE, A(K+1,1),
     $                  LDA )
         END IF
      END IF
C
C     27) DW4 := DW4 + DW7
C
      CALL DAXPY( N*K, ONE, DWORK(PDW7), 1, DWORK(PDW4), 1 )
C
C     28) DW3 := DW3*W1'
C
      IF ( LCOLW ) THEN
         CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K, ONE,
     $               W, LDW, DWORK(PDW3), N )
      ELSE
         CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Unit', N, K,
     $               ONE, W, LDW, DWORK(PDW3), N )
      END IF
C
C     29) DW4 := DW4 + DW3
C
      CALL DAXPY( N*K, ONE, DWORK(PDW3), 1, DWORK(PDW4), 1 )
C
C     30) DW5 := DW5*V1'
C
      IF ( LCOLV ) THEN
         CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K, ONE,
     $               V, LDV, DWORK(PDW5), N )
      ELSE
         CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Unit', N, K,
     $               ONE, V, LDV, DWORK(PDW5), N )
      END IF
C
C     31) DW4 := DW4 + DW5
C
      CALL DAXPY( N*K, ONE, DWORK(PDW5), 1, DWORK(PDW4), 1 )
C
C     32) A1 := A1 + DW4'
C
      IF ( LA1B1 ) THEN
         IF ( LTRA ) THEN
            DO 50  I = 1, K
               CALL DAXPY( N, ONE, DWORK(PDW4+(I-1)*N), 1, A(1,I), 1 )
   50       CONTINUE
         ELSE
            DO 60  I = 1, N
               CALL DAXPY( K, ONE, DWORK(PDW4+I-1), N, A(1,I), 1 )
   60       CONTINUE
         END IF
      ELSE
         IF ( LTRA ) THEN
            DO 70  I = 1, K
               CALL DCOPY( N, DWORK(PDW4+(I-1)*N), 1, A(1,I), 1 )
   70       CONTINUE
         ELSE
            DO 80  I = 1, N
               CALL DCOPY( K, DWORK(PDW4+I-1), N, A(1,I), 1 )
   80       CONTINUE
         END IF
      END IF
C
C     Update the matrix B.
C
      IF ( LTRQ ) THEN
C
C        33) DW3 := DW1*T11
C
         CALL DCOPY( N*K, DWORK(PDW1), 1, DWORK(PDW3), 1 )
         CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, K,
     $               ONE, T(1,PT11), LDT, DWORK(PDW3), N )
C
C        34) DW4 := DW6*T31
C
         CALL DCOPY( N*(K-1), DWORK(PDW6), 1, DWORK(PDW4), 1 )
         CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N,
     $               K-1, ONE, T(1,PT31+1), LDT, DWORK(PDW4), N )
C
C        35) DW3 := DW3 + DW4
C
         CALL DAXPY( N*(K-1), ONE, DWORK(PDW4), 1, DWORK(PDW3+N), 1 )
C
         IF ( LA1B1 ) THEN
C
C           NZ17) DW8 := DW9*T21
C
            CALL DCOPY( N*(K-1), DWORK(PDW9), 1, DWORK(PDW8), 1 )
            CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N,
     $                  K-1, ONE, T(1,PT21+1), LDT, DWORK(PDW8), N )
C
C           NZ18) DW3 := DW3 + DW8
C
            CALL DAXPY( N*(K-1), ONE, DWORK(PDW8), 1, DWORK(PDW3+N), 1 )
         END IF
C
C        36) DW4 := DW2*S1
C
         CALL DCOPY( N*(K-1), DWORK(PDW2), 1, DWORK(PDW4), 1 )
         CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N,
     $               K-1, ONE, RS(1,PS1+1), LDRS, DWORK(PDW4), N )
C
C        37) DW3 := DW3 + DW4
C
         CALL DAXPY( N*(K-1), ONE, DWORK(PDW4), 1, DWORK(PDW3+N), 1 )
C
C        38) DW4 := DW1*T12
C
         CALL DCOPY( N*K, DWORK(PDW1), 1, DWORK(PDW4), 1 )
         CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, K,
     $               ONE, T(1,PT12), LDT, DWORK(PDW4), N )
C
C        38) DW5 := DW6*T32
C
         CALL DCOPY( N*(K-1), DWORK(PDW6), 1, DWORK(PDW5), 1 )
         CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N,
     $               K-1, ONE, T(1,PT32+1), LDT, DWORK(PDW5), N )
C
C        40) DW4 := DW4 + DW5
C
         CALL DAXPY( N*(K-1), ONE, DWORK(PDW5), 1, DWORK(PDW4+N), 1 )
C
         IF ( LA1B1 ) THEN
C
C           NZ19) DW8 := DW9*T22
C
            CALL DCOPY( N*K, DWORK(PDW9), 1, DWORK(PDW8), 1 )
            CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N,
     $                  K, ONE, T(1,PT22), LDT, DWORK(PDW8), N )
C
C           NZ20) DW4 := DW4 + DW8
C
            CALL DAXPY( N*K, ONE, DWORK(PDW8), 1, DWORK(PDW4), 1 )
         END IF
C
C        41) DW5 := DW2*S2
C
         CALL DCOPY( N*K, DWORK(PDW2), 1, DWORK(PDW5), 1 )
         CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, K,
     $               ONE, RS(1,PS2), LDRS, DWORK(PDW5), N )
C
C        42) DW4 := DW4 + DW5
C
         CALL DAXPY( N*K, ONE, DWORK(PDW5), 1, DWORK(PDW4), 1 )
C
C        43) DW6 := DW6*T33
C
         CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, K,
     $               ONE, T(1,PT33), LDT, DWORK(PDW6), N )
C
C        44) DW1 := DW1*T13
C
         CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, K,
     $               ONE, T(1,PT13), LDT, DWORK(PDW1), N )
C
C        45) DW6 := DW6 + DW1
C
         CALL DAXPY( N*K, ONE, DWORK(PDW1), 1, DWORK(PDW6), 1 )
C
         IF ( LA1B1 ) THEN
C
C           NZ19) DW9 := DW9*T23
C
            CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N,
     $                  K, ONE, T(1,PT23), LDT, DWORK(PDW9), N )
C
C           NZ20) DW6 := DW6 + DW9
C
            CALL DAXPY( N*K, ONE, DWORK(PDW9), 1, DWORK(PDW6), 1 )
         END IF
C
C        46) DW2 := DW2*S3
C
         CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, K,
     $               ONE, RS(1,PS3), LDRS, DWORK(PDW2), N )
C
C        45) DW6 := DW6 + DW2
C
         CALL DAXPY( N*K, ONE, DWORK(PDW2), 1, DWORK(PDW6), 1 )
      ELSE
C
C        33) DW3 := DW1*T11'
C
         CALL DCOPY( N*K, DWORK(PDW1), 1, DWORK(PDW3), 1 )
         CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K,
     $               ONE, T(1,PT11), LDT, DWORK(PDW3), N )
C
C        34) DW4 := DW6*T13'
C
         CALL DCOPY( N*K, DWORK(PDW6), 1, DWORK(PDW4), 1 )
         CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K,
     $               ONE, T(1,PT13), LDT, DWORK(PDW4), N )
C
C        35) DW3 := DW3 + DW4
C
         CALL DAXPY( N*K, ONE, DWORK(PDW4), 1, DWORK(PDW3), 1 )
C
         IF ( LA1B1 ) THEN
C
C           NZ17) DW8 := DW9*T12'
C
            CALL DCOPY( N*K, DWORK(PDW9), 1, DWORK(PDW8), 1 )
            CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K,
     $                  ONE, T(1,PT12), LDT, DWORK(PDW8), N )
C
C           NZ18) DW3 := DW3 + DW8
C
            CALL DAXPY( N*K, ONE, DWORK(PDW8), 1, DWORK(PDW3), 1 )
         END IF
C
C        36) DW4 := DW2*R1'
C
         CALL DCOPY( N*K, DWORK(PDW2), 1, DWORK(PDW4), 1 )
         CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K,
     $               ONE, RS(1,PR1), LDRS, DWORK(PDW4), N )
C
C        37) DW3 := DW3 - DW4
C
         CALL DAXPY( N*K, -ONE, DWORK(PDW4), 1, DWORK(PDW3), 1 )
C
C        38) DW4 := DW6*T23'
C
         CALL DCOPY( N*K, DWORK(PDW6), 1, DWORK(PDW4), 1 )
         CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K,
     $               ONE, T(1,PT23), LDT, DWORK(PDW4), N )
C
C        39) DW5 := DW1*T21'
C
         CALL DCOPY( N*(K-1), DWORK(PDW1+N), 1, DWORK(PDW5), 1 )
         CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K-1,
     $               ONE, T(1,PT21+1), LDT, DWORK(PDW5), N )
C
C        40) DW4 := DW4 + DW5
C
         CALL DAXPY( N*(K-1), ONE, DWORK(PDW5), 1, DWORK(PDW4), 1 )
C
         IF ( LA1B1 ) THEN
C
C           NZ19) DW8 := DW9*T22'
C
            CALL DCOPY( N*K, DWORK(PDW9), 1, DWORK(PDW8), 1 )
            CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K,
     $                  ONE, T(1,PT22), LDT, DWORK(PDW8), N )
C
C           NZ20) DW4 := DW4 + DW8
C
            CALL DAXPY( N*K, ONE, DWORK(PDW8), 1, DWORK(PDW4), 1 )
         END IF
C
C        41) DW5 := DW2*R2'
C
         CALL DCOPY( N*K, DWORK(PDW2), 1, DWORK(PDW5), 1 )
         CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, K,
     $               ONE, RS(1,PR2), LDRS, DWORK(PDW5), N )
C
C        42) DW4 := DW4 - DW5
C
         CALL DAXPY( N*K, -ONE, DWORK(PDW5), 1, DWORK(PDW4), 1 )
C
C        43) DW6 := DW6*T33'
C
         CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K,
     $               ONE, T(1,PT33), LDT, DWORK(PDW6), N )
C
C        44) DW1 := DW1*T31'
C
         CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K-1,
     $               ONE, T(1,PT31+1), LDT, DWORK(PDW1+N), N )
C
C        45) DW6 := DW6 + DW1
C
         CALL DAXPY( N*(K-1), ONE, DWORK(PDW1+N), 1, DWORK(PDW6), 1 )
C
         IF ( LA1B1 ) THEN
C
C           NZ19) DW9 := DW9*T32'
C
            CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N,
     $                  K-1, ONE, T(1,PT32+1), LDT, DWORK(PDW9+N), N )
C
C           NZ20) DW6 := DW6 + DW9
C
            CALL DAXPY( N*(K-1), ONE, DWORK(PDW9+N), 1, DWORK(PDW6), 1 )
         END IF
C
C        46) DW2 := DW2*R3'
C
         CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K-1,
     $               ONE, RS(1,PR3+1), LDRS, DWORK(PDW2+N), N )
C
C        45) DW6 := DW6 - DW2
C
         CALL DAXPY( N*(K-1), -ONE, DWORK(PDW2+N), 1, DWORK(PDW6), 1 )
      END IF
C
C     46) B2 := B2 + W2*DW3'
C
      IF ( M.GT.K ) THEN
         IF ( LTRB.AND.LCOLW ) THEN
            CALL DGEMM( 'No Transpose', 'Transpose', N, M-K, K, ONE,
     $                  DWORK(PDW3), N, W(K+1,1), LDW, ONE, B(1,K+1),
     $                  LDB )
         ELSE IF ( LTRB ) THEN
            CALL DGEMM( 'No Transpose', 'No Transpose', N, M-K, K, ONE,
     $                  DWORK(PDW3), N, W(1,K+1), LDW, ONE, B(1,K+1),
     $                  LDB )
         ELSE IF ( LCOLW ) THEN
            CALL DGEMM( 'No Transpose', 'Transpose', M-K, N, K, ONE,
     $                  W(K+1,1), LDW, DWORK(PDW3), N, ONE, B(K+1,1),
     $                  LDB )
         ELSE
            CALL DGEMM( 'Transpose', 'Transpose', M-K, N, K, ONE,
     $                  W(1,K+1), LDW, DWORK(PDW3), N, ONE, B(K+1,1),
     $                  LDB )
         END IF
      END IF
C
C     47) B2 := B2 + V2*DW6'
C
      IF ( M.GT.K ) THEN
         IF ( LTRB.AND.LCOLV ) THEN
            CALL DGEMM( 'No Transpose', 'Transpose', N, M-K, K, ONE,
     $                  DWORK(PDW6), N, V(K+1,1), LDV, ONE, B(1,K+1),
     $                  LDB )
         ELSE IF ( LTRB ) THEN
            CALL DGEMM( 'No Transpose', 'No Transpose', N, M-K, K, ONE,
     $                  DWORK(PDW6), N, V(1,K+1), LDV, ONE, B(1,K+1),
     $                  LDB )
         ELSE IF ( LCOLV ) THEN
            CALL DGEMM( 'No Transpose', 'Transpose', M-K, N, K, ONE,
     $                  V(K+1,1), LDV, DWORK(PDW6), N, ONE, B(K+1,1),
     $                  LDB )
         ELSE
            CALL DGEMM( 'Transpose', 'Transpose', M-K, N, K, ONE,
     $                  V(1,K+1), LDV, DWORK(PDW6), N, ONE, B(K+1,1),
     $                  LDB )
         END IF
      END IF
C
C     48) DW3 := DW3*W1'
C
      IF ( LCOLW ) THEN
         CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K, ONE,
     $               W, LDW, DWORK(PDW3), N )
      ELSE
         CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Unit', N, K,
     $               ONE, W, LDW, DWORK(PDW3), N )
      END IF
C
C     49) DW4 := DW4 + DW3
C
      CALL DAXPY( N*K, ONE, DWORK(PDW3), 1, DWORK(PDW4), 1 )
C
C     50) DW6 := DW6*V1'
C
      IF ( LCOLV ) THEN
         CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K, ONE,
     $               V, LDV, DWORK(PDW6), N )
      ELSE
         CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Unit', N, K,
     $               ONE, V, LDV, DWORK(PDW6), N )
      END IF
C
C     51) DW4 := DW4 + DW6
C
      CALL DAXPY( N*K, ONE, DWORK(PDW6), 1, DWORK(PDW4), 1 )
C
C     52) B1 := B1 + DW4'
C
      IF ( LA1B1 ) THEN
         IF ( LTRB ) THEN
            DO 90  I = 1, K
               CALL DAXPY( N, ONE, DWORK(PDW4+(I-1)*N), 1, B(1,I), 1 )
   90       CONTINUE
         ELSE
            DO 100  I = 1, N
               CALL DAXPY( K, ONE, DWORK(PDW4+I-1), N, B(1,I), 1 )
  100       CONTINUE
         END IF
      ELSE
         IF ( LTRB ) THEN
            DO 110  I = 1, K
               CALL DCOPY( N, DWORK(PDW4+(I-1)*N), 1, B(1,I), 1 )
  110       CONTINUE
         ELSE
            DO 120  I = 1, N
               CALL DCOPY( K, DWORK(PDW4+I-1), N, B(1,I), 1 )
  120       CONTINUE
         END IF
      END IF
C
      RETURN
C *** Last line of MB04QC ***
      END


!  IMPLICITFVMMESH488.f90
!
!  FUNCTIONS:
!  IMPLICITFVMMESH488 - Entry point of console application.
!

!****************************************************************************
!
!  PROGRAM: IMPLICITFVMMESH488
!
!  PURPOSE:  Entry point for the console application.
!
!****************************************************************************

! THIS PROGRAM IS SOLVING HEAT TRANSFER IN 2D BY FVM
! IMPLCIT METHOD
! BY MEHRDAD BABA HOSEIN POUR
! BEYOND SKY!

program Implicit_FVM

implicit none

integer :: NNODE,i,NELEM,ELEM,j,M,G,N

DOUBLE PRECISION :: DELT,ALPHA,H,RO,CP,TINF

double precision,allocatable,dimension(:):: X,Y,T,BOUNDARY,CONS,RHS,K

double precision,allocatable,dimension(:,:)::XT,YT,DELL,A,D

integer,allocatable,dimension(:):: ELEM_1,ELEM_2,ELEM_3,NODE

INTEGER,allocatable,dimension(:,:)::NEIGHBOUR

NNODE=488

NELEM=894

H=28

RO=7800

CP=480

TINF=0

allocate (X(NNODE),Y(NNODE),NODE(NNODE),T(NNODE),BOUNDARY(NELEM),ELEM_1(NELEM),ELEM_2(NELEM),ELEM_3(NELEM),XT(3,NELEM),YT(3,NELEM))

allocate (NEIGHBOUR(NNODE,7*2),DELL(NNODE,7*2),D(NNODE,7*2),K(NNODE),CONS(NNODE),A(NNODE,NNODE),RHS(NNODE))

Open(1,file='Mesh 488.txt')

Do i=1,NNODE

	Read(1,*)NODE(i),X(i),Y(i)

End do

do i=NNODE+1,NELEM+NNODE

  	Read(1,*)ELEM,ELEM_1(ELEM),ELEM_2(ELEM),ELEM_3(ELEM)

    end do

    Do i=1,NNODE

	T(i)=50

End do

ALPHA=3.5

DELT=0.00000001

Do i=1,NNODE

	BOUNDARY(i)=0

    DO J=1,NNODE

      A(I,J)=0

      END DO

    DO G=1,14

    D(I,G)=0

    END DO

End do

    do i= 1 ,NELEM

      do j=1,3

        if (j==1)then

      XT(j,i)=X(ELEM_1(i))

      YT(j,i)=Y(ELEM_1(i))

      elseif (j==2)then

      XT(j,i)=X(ELEM_2(i))

      YT(j,i)=Y(ELEM_2(i))

      elseif (j==3)then

      XT(j,i)=X(ELEM_3(i))

      YT(j,i)=Y(ELEM_3(i))

      end if

      end do

      end do

      DO N=1,75

DO I= 1,NNODE

  M=1

      DO J =1,NELEM

        IF (ELEM_1(J)==NODE(I)) THEN

          NEIGHBOUR(I,M)=ELEM_2(J)

          M=M+1

          NEIGHBOUR(I,M)=ELEM_3(J)

          M=M+1

          ELSEIF (ELEM_2(J)==NODE(I)) THEN

          NEIGHBOUR(I,M)=ELEM_1(J)

          M=M+1

          NEIGHBOUR(I,M)=ELEM_3(J)

          M=M+1

          ELSEIF (ELEM_3(J)==NODE(I)) THEN

          NEIGHBOUR(I,M)=ELEM_1(J)

          M=M+1

          NEIGHBOUR(I,M)=ELEM_2(J)

          M=M+1

           END IF

            if ((XT(1,J)==0.AND.XT(2,J)==0))THEN

          BOUNDARY(J)=1

      T(ELEM_1(J))=T(ELEM_1(J))+(((H*DELT)/(RO*CP*ABS(YT(1,J)-YT(2,J))))*(T(ELEM_1(J))-TINF))

      T(ELEM_2(J))=T(ELEM_2(J))+(((H*DELT)/(RO*CP*ABS(YT(1,J)-YT(2,J))))*(T(ELEM_2(J))-TINF))

        ELSEIF((XT(2,J)==0.AND.XT(3,J)==0))THEN

        BOUNDARY(J)=1

      T(ELEM_2(J))=T(ELEM_2(J))+(((H*DELT)/(RO*CP*ABS(YT(3,J)-YT(2,J))))*(T(ELEM_2(J))-TINF))

      T(ELEM_3(J))=T(ELEM_3(J))+(((H*DELT)/(RO*CP*ABS(YT(3,J)-YT(2,J))))*(T(ELEM_3(J))-TINF))

       ELSEIF((XT(1,J)==0.AND.XT(3,J)==0))then

      BOUNDARY(J)=1

      T(ELEM_1(J))=T(ELEM_1(J))+(((H*DELT)/(RO*CP*ABS(YT(1,J)-YT(3,J))))*(T(ELEM_1(J))-TINF))

      T(ELEM_3(J))=T(ELEM_3(J))+(((H*DELT)/(RO*CP*ABS(YT(3,J)-YT(1,J))))*(T(ELEM_3(J))-TINF))

      elseif ((YT(1,J)==0.AND.YT(2,J)==0))THEN

      BOUNDARY(J)=2

     T(ELEM_1(J))=100

     T(ELEM_2(J))=100

      ELSEIF((YT(2,J)==0.AND.YT(3,J)==0))THEN

      BOUNDARY(J)=2

     T(ELEM_2(J))=100

     T(ELEM_3(J))=100

      ELSEIF((YT(1,J)==0.AND.YT(3,J)==0))then

     BOUNDARY(J)=2

     T(ELEM_1(J))=100

     T(ELEM_3(J))=100

      elseif ((XT(1,J)==1.AND.XT(2,J)==1))THEN

      BOUNDARY(J)=3

     T(ELEM_1(J))=50

     T(ELEM_2(J))=50

      ELSEIF((XT(2,J)==1.AND.XT(3,J)==1))THEN

      BOUNDARY(J)=3

     T(ELEM_2(J))=50

     T(ELEM_3(J))=50

      ELSEIF((XT(1,J)==1.AND.XT(3,J)==1))then

     BOUNDARY(J)=3

     T(ELEM_1(J))=50

     T(ELEM_3(J))=50

      elseif ((YT(1,J)==1.AND.YT(2,J)==1))THEN

      BOUNDARY(J)=4

      T(ELEM_1(J))=((1-2*(ALPHA*DELT/(((XT(1,J)-XT(2,J))**2))))*T(ELEM_1(J)))+&

      &((ALPHA*DELT/(((XT(1,J)-XT(2,J))**2)))*(T(ELEM_1(J))+T(ELEM_2(J))))

      T(ELEM_2(J))=((1-2*(ALPHA*DELT/(((XT(1,J)-XT(2,J))**2))))*T(ELEM_2(J)))+&

      &((ALPHA*DELT/(((XT(1,J)-XT(2,J))**2)))*(T(ELEM_1(J))+T(ELEM_2(J))))

      ELSEIF((YT(2,J)==1.AND.YT(3,J)==1))THEN

      BOUNDARY(J)=4

      T(ELEM_2(J))=((1-2*(ALPHA*DELT/(((XT(1,J)-XT(2,J))**2))))*T(ELEM_2(J)))+&

      &((ALPHA*DELT/(((XT(3,J)-XT(2,J))**2)))*(T(ELEM_3(J))+T(ELEM_2(J))))

      T(ELEM_3(J))=((1-2*(ALPHA*DELT/(((XT(1,J)-XT(2,J))**2))))*T(ELEM_3(J)))+&

      &((ALPHA*DELT/(((XT(3,J)-XT(2,J))**2)))*(T(ELEM_3(J))+T(ELEM_2(J))))

      ELSEIF((YT(1,J)==1.AND.YT(3,J)==1))then

      BOUNDARY(J)=4

      T(ELEM_1(J))=((1-2*(ALPHA*DELT/(((XT(1,J)-XT(2,J))**2))))*T(ELEM_1(J)))+&

      &((ALPHA*DELT/(((XT(3,J)-XT(1,J))**2)))*(T(ELEM_3(J))+T(ELEM_1(J))))

      T(ELEM_3(J))=((1-2*(ALPHA*DELT/(((XT(1,J)-XT(2,J))**2))))*T(ELEM_3(J)))+&

      &((ALPHA*DELT/(((XT(3,J)-XT(1,J))**2)))*(T(ELEM_3(J))+T(ELEM_1(J))))

      ELSE

        DO G=1,M-1

          DELL(I,G)=SQRT(((X(I)-X(NEIGHBOUR(I,G)))**2)+((Y(I)-Y(NEIGHBOUR(I,G)))**2))

          D(I,G)=D(I,G)+((ALPHA*DELT/(DELL(I,G)**2)))

          A(I,NEIGHBOUR(I,G))=A(I,NEIGHBOUR(I,G))-(D(I,G)/2)

          A(I,I)=1+(D(I,G))

          END DO

          RHS(I)=T(I)

      end if

          END DO

          K(I)=0

          CONS(I)=(M-1)

          DO G=1,M-1

          DELL(I,G)=SQRT(((X(I)-X(NEIGHBOUR(I,G)))**2)+((Y(I)-Y(NEIGHBOUR(I,G)))**2))

          K(I)=K(I)+((ALPHA*DELT/(DELL(I,G)**2))*T(NEIGHBOUR(I,G)))

          END DO

          K(I)=K(I)/2

          T(I)=((1-(CONS(I)*K(I)))*T(I))+K(I)

          END DO

          END DO

OPEN(UNIT=15,FILE='MESH488_IMPLICIT.PLT')

        WRITE(15,*) 'VARIABLES="X","Y","T"'

        WRITE(15,*)"Zone T='Coordinate.'"

write(15,*)"I=",NNODE, "J=",NELEM,",F=FEPOINT ET=Triangle"

do i=1,NNODE

	write(15,*)X(i),Y(i),T(i)

end do

do J=1,NELEM

	write(15,*)ELEM_1(J),ELEM_2(J),ELEM_3(J)

end do

close(15)

!deallocate (X,Y,T,BOUNDARY,ELEM_1,ELEM_2,ELEM_3,XT,YT,NEIGHBOUR)

contains

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!gauss_seidle_method!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

subroutine gauss_seidle_method(NNODE,A,RHS,T)

implicit none

integer::NNODE

DOUBLE PRECISION,dimension(NNODE*NNODE,NNODE*NNODE)::A

DOUBLE PRECISION,dimension(NNODE*NNODE)::RHS

DOUBLE PRECISION,dimension(NNODE*NNODE)::T

integer::i,j,iter,k

real::old,sum,ea,es,s,dummy

es=0.00001

!checking diagonal dominant

do i=1,NNODE*NNODE  ;   s=0

do j=1,NNODE*NNODE

if(i.ne.j)s=s+abs(A(i,j))

enddo

if(abs(A(i,i)).lt.s)then

write(*,*) "these equtions are not diagonal-dominance"

stop  ;  endif  ;  enddo

do i=1,NNODE*NNODE

  dummy=A(i,i)

do j=1,NNODE*NNODE

A(i,j)=A(i,j)/dummy

enddo   ;  RHS(i)=RHS(i)/dummy

enddo

iter=0    ;  k=0

do while (iter<10.and. k==0)

iter=iter+1

k=1

do i=1,NNODE*NNODE

old=T(i)

sum=RHS(i)

do j=1,NNODE*NNODE

if(i.ne.j)then

sum=sum-A(i,j)*T(j)

endif

enddo

T(i)=sum

if(T(i).ne.0 .and. k==1) then

   ea=(abs(T(i)-old)/T(i))*100

if(ea.gt.es) then

   k=0

   end if

   end if

enddo

enddo

END SUBROUTINE

end program Implicit_FVM


*###[ ffxd0m0:
	subroutine ffxd0m0(cd0, xpi, ier)
***#[*comment:***********************************************************
*									*
*	D0 function for 4 masses = 0					*
*	input parameters as for ffxd0					*
*									*
*	algorithm taken from						*
*	Denner, Nierste, Scharf, Nucl. Phys. B367 (1991) 637-656	*
*									*
***#]*comment:***********************************************************
*  #[ declarations:
	implicit none
*
*	arguments
*
	DOUBLE PRECISION xpi(13)
	DOUBLE COMPLEX cd0
	integer ier

	DOUBLE PRECISION a, b, c, d
	DOUBLE COMPLEX x(2), z(2), k1, k2, t1, t2
	DOUBLE COMPLEX dl1, dl2, zl, ww, tlg
	DOUBLE COMPLEX k12, k23, k34, k14, k13, k24
	integer j, ipi1(2), ipi2(2), nffeta

	include 'ff.h'

	a = xpi(10)*xpi(7)
	b = xpi(9)*xpi(10) + xpi(5)*xpi(7) - xpi(8)*xpi(6)
	c = xpi(5)*xpi(9)
	d = -xpi(6)

	k1 = DCMPLX(c, precx*d)
	k2 = sqrt(b*b - 4*a*k1)
	x(1) = (-b - k2)/2D0/a
	x(2) = (-b + k2)/2D0/a
	if(abs(x(1)) .gt. abs(x(2))) then
	  x(2) = k1/a/x(1)
	else
	  x(1) = k1/a/x(2)
	endif

	k12 = DCMPLX(-xpi(5), -precx)
	k13 = DCMPLX(-xpi(9), -precx)
	k23 = DCMPLX(-xpi(6), -precx)
	k34 = DCMPLX(-xpi(7), -precx)
	k14 = DCMPLX(-xpi(8), -precx)
	k24 = DCMPLX(-xpi(10), -precx)

	k1 = k34/k13
	k2 = k24/k12
	ww = log(k12) + log(k13) - log(k14) - log(k23)

	do 100 j = 1, 2
	  t1 = 1 + k1*x(j)
	  t2 = 1 + k2*x(j)
	  call ffzzdl(dl1, ipi1(j), zl, t1, ier)
	  call ffzzdl(dl2, ipi2(j), zl, t2, ier)
	  tlg = log(-x(j))
	  z(j) = tlg*(ww - .5D0*tlg) - dl1 - dl2 -
     +      c2ipi*( nffeta(-x(j), k1, ier)*log(t1) +
     +              nffeta(-x(j), k2, ier)*log(t2) )
  100   continue

	ww = z(2) - z(1) +
     +    (ipi1(1) + ipi2(1) - ipi1(2) - ipi2(2))*pi12
	cd0 = ww/a/(x(1) - x(2))
	end


subroutine qk61 ( f, a, b, result, abserr, resabs, resasc )

!*****************************************************************************80
!
!! QK61 carries out a 61 point Gauss-Kronrod quadrature rule.
!
!  Discussion:
!
!    This routine approximates
!      I = integral ( A <= X <= B ) F(X) dx
!    with an error estimate, and
!      J = integral ( A <= X <= B ) | F(X) | dx
!
!  Author:
!
!    Robert Piessens, Elise de Doncker-Kapenger,
!    Christian Ueberhuber, David Kahaner
!
!  Reference:
!
!    Robert Piessens, Elise de Doncker-Kapenger,
!    Christian Ueberhuber, David Kahaner,
!    QUADPACK, a Subroutine Package for Automatic Integration,
!    Springer Verlag, 1983
!
!  Parameters:
!
!    Input, external real ( kind = 4 ) F, the name of the function routine, of the form
!      function f ( x )
!      real ( kind = 4 ) f
!      real ( kind = 4 ) x
!    which evaluates the integrand function.
!
!    Input, real ( kind = 4 ) A, B, the limits of integration.
!
!    Output, real ( kind = 4 ) RESULT, the estimated value of the integral.
!                    result is computed by applying the 61-point
!                    Kronrod rule (resk) obtained by optimal addition of
!                    abscissae to the 30-point Gauss rule (resg).
!
!    Output, real ( kind = 4 ) ABSERR, an estimate of | I - RESULT |.
!
!    Output, real ( kind = 4 ) RESABS, approximation to the integral of the absolute
!    value of F.
!
!    Output, real ( kind = 4 ) RESASC, approximation to the integral | F-I/(B-A) |
!    over [A,B].
!
!  Local Parameters:
!
!           centr  - mid point of the interval
!           hlgth  - half-length of the interval
!           absc   - abscissa
!           fval*  - function value
!           resg   - result of the 30-point Gauss rule
!           resk   - result of the 61-point Kronrod rule
!           reskh  - approximation to the mean value of f
!                    over (a,b), i.e. to i/(b-a)
!
  implicit none

  real ( kind = 4 ) a
  real ( kind = 4 ) absc
  real ( kind = 4 ) abserr
  real ( kind = 4 ) b
  real ( kind = 4 ) centr
  real ( kind = 4 ) dhlgth
  real ( kind = 4 ), external :: f
  real ( kind = 4 ) fc
  real ( kind = 4 ) fsum
  real ( kind = 4 ) fval1
  real ( kind = 4 ) fval2
  real ( kind = 4 ) fv1(30)
  real ( kind = 4 ) fv2(30)
  real ( kind = 4 ) hlgth
  integer ( kind = 4 ) j
  integer ( kind = 4 ) jtw
  integer ( kind = 4 ) jtwm1
  real ( kind = 4 ) resabs
  real ( kind = 4 ) resasc
  real ( kind = 4 ) resg
  real ( kind = 4 ) resk
  real ( kind = 4 ) reskh
  real ( kind = 4 ) result
  real ( kind = 4 ) wg(15)
  real ( kind = 4 ) wgk(31)
  real ( kind = 4 ) xgk(31)
!
!           the abscissae and weights are given for the
!           interval (-1,1). because of symmetry only the positive
!           abscissae and their corresponding weights are given.
!
!           xgk   - abscissae of the 61-point Kronrod rule
!                   xgk(2), xgk(4)  ... abscissae of the 30-point
!                   Gauss rule
!                   xgk(1), xgk(3)  ... optimally added abscissae
!                   to the 30-point Gauss rule
!
!           wgk   - weights of the 61-point Kronrod rule
!
!           wg    - weigths of the 30-point Gauss rule
!
  data xgk(1),xgk(2),xgk(3),xgk(4),xgk(5),xgk(6),xgk(7),xgk(8), &
     xgk(9),xgk(10)/ &
       9.994844100504906E-01,     9.968934840746495E-01, &
       9.916309968704046E-01,     9.836681232797472E-01, &
       9.731163225011263E-01,     9.600218649683075E-01, &
       9.443744447485600E-01,     9.262000474292743E-01, &
       9.055733076999078E-01,     8.825605357920527E-01/
  data xgk(11),xgk(12),xgk(13),xgk(14),xgk(15),xgk(16),xgk(17), &
    xgk(18),xgk(19),xgk(20)/ &
       8.572052335460611E-01,     8.295657623827684E-01, &
       7.997278358218391E-01,     7.677774321048262E-01, &
       7.337900624532268E-01,     6.978504947933158E-01, &
       6.600610641266270E-01,     6.205261829892429E-01, &
       5.793452358263617E-01,     5.366241481420199E-01/
  data xgk(21),xgk(22),xgk(23),xgk(24),xgk(25),xgk(26),xgk(27), &
    xgk(28),xgk(29),xgk(30),xgk(31)/ &
       4.924804678617786E-01,     4.470337695380892E-01, &
       4.004012548303944E-01,     3.527047255308781E-01, &
       3.040732022736251E-01,     2.546369261678898E-01, &
       2.045251166823099E-01,     1.538699136085835E-01, &
       1.028069379667370E-01,     5.147184255531770E-02, &
       0.0E+00                   /
  data wgk(1),wgk(2),wgk(3),wgk(4),wgk(5),wgk(6),wgk(7),wgk(8), &
    wgk(9),wgk(10)/ &
       1.389013698677008E-03,     3.890461127099884E-03, &
       6.630703915931292E-03,     9.273279659517763E-03, &
       1.182301525349634E-02,     1.436972950704580E-02, &
       1.692088918905327E-02,     1.941414119394238E-02, &
       2.182803582160919E-02,     2.419116207808060E-02/
  data wgk(11),wgk(12),wgk(13),wgk(14),wgk(15),wgk(16),wgk(17), &
    wgk(18),wgk(19),wgk(20)/ &
       2.650995488233310E-02,     2.875404876504129E-02, &
       3.090725756238776E-02,     3.298144705748373E-02, &
       3.497933802806002E-02,     3.688236465182123E-02, &
       3.867894562472759E-02,     4.037453895153596E-02, &
       4.196981021516425E-02,     4.345253970135607E-02/
  data wgk(21),wgk(22),wgk(23),wgk(24),wgk(25),wgk(26),wgk(27), &
    wgk(28),wgk(29),wgk(30),wgk(31)/ &
       4.481480013316266E-02,     4.605923827100699E-02, &
       4.718554656929915E-02,     4.818586175708713E-02, &
       4.905543455502978E-02,     4.979568342707421E-02, &
       5.040592140278235E-02,     5.088179589874961E-02, &
       5.122154784925877E-02,     5.142612853745903E-02, &
       5.149472942945157E-02/
  data wg(1),wg(2),wg(3),wg(4),wg(5),wg(6),wg(7),wg(8)/ &
       7.968192496166606E-03,     1.846646831109096E-02, &
       2.878470788332337E-02,     3.879919256962705E-02, &
       4.840267283059405E-02,     5.749315621761907E-02, &
       6.597422988218050E-02,     7.375597473770521E-02/
  data wg(9),wg(10),wg(11),wg(12),wg(13),wg(14),wg(15)/ &
       8.075589522942022E-02,     8.689978720108298E-02, &
       9.212252223778613E-02,     9.636873717464426E-02, &
       9.959342058679527E-02,     1.017623897484055E-01, &
       1.028526528935588E-01/

  centr = 5.0E-01*(b+a)
  hlgth = 5.0E-01*(b-a)
  dhlgth = abs(hlgth)
!	print*, 'ab',a,b
!
!  Compute the 61-point Kronrod approximation to the integral,
!  and estimate the absolute error.
!

  resg = 0.0E+00
  fc = f(centr)
  resk = wgk(31)*fc
  resabs = abs(resk)

!        print*, 'SLEEPING '
!	CALL SLEEP(50)
  do j = 1, 15
    jtw = j*2
    absc = hlgth*xgk(jtw)
    fval1 = f(centr-absc)
    fval2 = f(centr+absc)
    fv1(jtw) = fval1
    fv2(jtw) = fval2
    fsum = fval1+fval2
    resg = resg+wg(j)*fsum
    resk = resk+wgk(jtw)*fsum
    resabs = resabs+wgk(jtw)*(abs(fval1)+abs(fval2))
  end do

  do j = 1, 15
    jtwm1 = j*2-1
    absc = hlgth*xgk(jtwm1)
    fval1 = f(centr-absc)
    fval2 = f(centr+absc)
    fv1(jtwm1) = fval1
    fv2(jtwm1) = fval2
    fsum = fval1+fval2
    resk = resk+wgk(jtwm1)*fsum
    resabs = resabs+wgk(jtwm1)*(abs(fval1)+abs(fval2))
  end do

  reskh = resk * 5.0E-01
  resasc = wgk(31)*abs(fc-reskh)

  do j = 1, 30
    resasc = resasc+wgk(j)*(abs(fv1(j)-reskh)+abs(fv2(j)-reskh))
  end do

  result = resk*hlgth
  resabs = resabs*dhlgth
  resasc = resasc*dhlgth
  abserr = abs((resk-resg)*hlgth)

  if ( resasc /= 0.0E+00 .and. abserr /= 0.0E+00) then
    abserr = resasc*min ( 1.0E+00,(2.0E+02*abserr/resasc)**1.5E+00)
  end if

  if ( resabs > tiny ( resabs ) / (5.0E+01* epsilon ( resabs ) )) then
    abserr = max ( ( epsilon ( resabs ) *5.0E+01)*resabs, abserr )
  end if
!	print*,'result',result
  return
end