        !COMPILER-GENERATED INTERFACE MODULE: Fri May 22 16:58:36 2020
        ! This source file is for reference only and may not completely
        ! represent the generated interface used by the compiler.
        MODULE COMPUTE_ADD_SOURCES_PORO__genmod
          INTERFACE
            SUBROUTINE COMPUTE_ADD_SOURCES_PORO(ACCELS_POROELASTIC,     &
     &ACCELW_POROELASTIC,IT,I_STAGE)
              USE SPECFEM_PAR, ONLY :                                   &
     &          POROELASTIC,                                            &
     &          NGLOB_POROELASTIC,                                      &
     &          NSOURCES,                                               &
     &          SOURCE_TYPE,                                            &
     &          ANGLESOURCE,                                            &
     &          SOURCE_TIME_FUNCTION,                                   &
     &          IS_PROC_SOURCE,                                         &
     &          ISPEC_SELECTED_SOURCE,                                  &
     &          HXIS_STORE,                                             &
     &          HGAMMAS_STORE,                                          &
     &          IBOOL,                                                  &
     &          POROSITY,                                               &
     &          TORTUOSITY,                                             &
     &          DENSITY,                                                &
     &          KMATO
              REAL(KIND=4) :: ACCELS_POROELASTIC(2,NGLOB_POROELASTIC)
              REAL(KIND=4) :: ACCELW_POROELASTIC(2,NGLOB_POROELASTIC)
              INTEGER(KIND=4) :: IT
              INTEGER(KIND=4) :: I_STAGE
            END SUBROUTINE COMPUTE_ADD_SOURCES_PORO
          END INTERFACE
        END MODULE COMPUTE_ADD_SOURCES_PORO__genmod


! $Id$
! -----------------------------------------------------------
! Module McWeeny
! -----------------------------------------------------------
! Code area 4: density matrix
! -----------------------------------------------------------

!!****h* Conquest/McWeeny
!!  NAME
!!   McWeeny
!!  PURPOSE
!!   To handle the McWeeny/Manolopoulos initialisation of density matrix
!!  AUTHOR
!!   D.R.Bowler
!!  CREATION DATE
!!   21/10/98
!!  MODIFICATION HISTORY
!!   11/05/01 DRB
!!    ROBODoc headers and better output
!!   08/06/2001 dave
!!    Added RCS Id and Log tags; used GenComms throughout
!!    Changed my_barrier to come from GenComms
!!   11:09, 04/02/2003 drb
!!    Major change: stability fix in InitMcW to ensure mu lies between Hamiltonian limits
!!   10:09, 13/02/2006 drb
!!    Removed all explicit references to data_ variables and rewrote in terms of new
!!    matrix routines
!!   2006/11/21 16:53 dave
!!    Changed iprint statements
!!   2008/02/01 17:48 dave
!!    Changes for output to file not stdout
!!   2008/07/31 ast
!!    Added timers
!!   2012/03/01 L.Tong
!!    Added interface for McW_matrix_multiply
!!   2014/09/15 18:30 lat
!!    fixed call start/stop_timer to timer_module (not timer_stdlocks_module !)
!!   2019/10/24 10:30 dave
!!    Added inode and ionode as use-associated from GenComms in module header
!!    for efficiency and best practice; changed function calls
!!***
module McWeeny

  use global_module,          only: io_lun, area_DM
  use timer_module,           only: start_timer, stop_timer
  use timer_stdclocks_module, only: tmr_std_matrices
  use GenComms,               ONLY: inode, ionode

  implicit none

  !!****f* McWeeny/McW_matrix_multiply
  !! PURPOSE
  !!   Interface for McW_matrix_multiply_nondsw and
  !!   McW_matrix_multiply_ds
  !! AUTHOR
  !!   L.Tong
  !! CREATION DATE
  !!   2012/03/01
  !! MODIFICATION HISTORY
  !! SOURCE
  !!
  interface McW_matrix_multiply
     module procedure McW_matrix_multiply_nonds
     module procedure McW_matrix_multiply_ds
  end interface McW_matrix_multiply
  !!*****

contains

  !!****f* McWeeny/McWMin *
  !!
  !!  NAME
  !!   McWMin
  !!  USAGE
  !!
  !!  PURPOSE
  !!   Performs iterative minimisation using McWeeny algorithm
  !!  INPUTS
  !!
  !!
  !!  USES
  !!   datatypes, numbers, logicals, maxima_module, matrix_data
  !!   mult_module, multiply_module, GenBlas
  !!  AUTHOR
  !!   D.R.Bowler
  !!  CREATION DATE
  !!   21/10/98
  !!  MODIFICATION HISTORY
  !!   11/05/01 DRB
  !!    ROBODoc headers and better output also nsf from maxima_module
  !!   08/06/2001 dave
  !!    Tidied and indented
  !!   10:38, 16/05/2007 drb
  !!    Moved matrix_sum to stop error at end
  !!   2011/07/25  L.Tong
  !!     Implemented spin polarisation
  !!     added dependence on matL_dn, matH_dn, matLS, matSL, matL_dnS
  !!     and matSL_dn
  !!   2012/03/11 L.Tong
  !!   - Major rewrite for spin implementation
  !!   - implementation of spin non-polarised case and spin fixed-case
  !!     share same piece of code. Only implementation for the variable
  !!     spin case differs, due to need to use direct sum.
  !!  SOURCE
  !!
  subroutine McWMin(n_L_iterations, deltaE)

    use datatypes
    use numbers
    use matrix_data,   only: Lrange
    use mult_module,   only: allocate_temp_matrix, matrix_sum,         &
                             free_temp_matrix, matL, matH, matS, matT, &
                             symmetrise_L,  matLS, matSL
    use global_module, only: iprint_DM, IPRINT_TIME_THRES1,            &
                             IPRINT_TIME_THRES2,                       &
                             nspin, spin_factor,                       &
                             flag_fix_spin_population
    use timer_module,  only: cq_timer, start_timer, stop_print_timer,  &
                             WITH_LEVEL

    implicit none

    ! Passed variables
    integer,      intent(in)  :: n_L_iterations
    real(double), intent(out) :: deltaE
    ! Local variables
    integer                        :: n_iterations, spin
    integer,      dimension(nspin) :: matRhoNew, mat_oldL
    real(double), dimension(nspin) :: cn, oldE, omega1, c_old
    real(double)                   :: cn_tot, oldE_tot, omega1_tot, c_old_tot
    type(cq_timer)                 :: tmr_l_tmp1,tmr_l_tmp2
    logical,      dimension(nspin) :: done

    ! real(double) :: cn, oldE, omega1, c_old
    ! real(double) :: cn_up, cn_dn, oldE_up, oldE_dn, omega1_up, &
    !      omega1_dn, c_old_up, c_old_dn

    call start_timer(tmr_l_tmp1,WITH_LEVEL)

    done(:) = .false.
    oldE(:) = 1.0e30_double
    oldE_tot = spin_factor * sum(oldE(:))
    c_old(:) = zero
    c_old_tot = zero

    do spin = 1, nspin
       mat_oldL(spin) = allocate_temp_matrix(Lrange,0)
       matRhoNew(spin) = allocate_temp_matrix(Lrange,0)
       call matrix_sum(zero, mat_oldL(spin), one, matL(spin))
    end do

    if (nspin == 1 .or. flag_fix_spin_population) then

       iter: do n_iterations = 1, n_L_iterations

          call start_timer(tmr_l_tmp2, WITH_LEVEL)
          if (inode == ionode .and. iprint_DM >= 1) &
               write (io_lun, 1) n_iterations
          call McW_matrix_multiply_nonds(matH, matS, matL, matT, &
                                         matRhoNew, omega1, cn)

          do spin = 1, nspin
             if (omega1(spin) > oldE(spin) .or.                       &
                 abs(omega1(spin) - oldE(spin)) < 1.0e-08_double .or. &
                 cn(spin) > one .or.                                  &
                 cn(spin) < zero) then

                done(spin) = .true.

             end if
          end do
          if (done(1) .and. done(nspin)) then
             if (inode == ionode .and. iprint_DM > 0) then
                do spin = 1, nspin
                   write (io_lun, 2) spin, c_old(spin), oldE(spin),&
                                     cn(spin), omega1(spin)
                end do
             end if
             call stop_print_timer(tmr_l_tmp2, "a McWeeny iteration", &
                                   IPRINT_TIME_THRES2)
             exit iter
          end if

          deltaE = zero
          do spin = 1, nspin
              ! If new energy is lower, copy new rho into old rho and repeat
              deltaE = deltaE + spin_factor * (omega1(spin) - oldE(spin))
              call matrix_sum(zero, matL(spin), one, matRhoNew(spin))
              oldE(spin) = omega1(spin)
              c_old(spin) = cn(spin)
              if (inode == ionode .and. iprint_DM >= 0) &
                   write (io_lun, 3) spin, oldE(spin), c_old(spin)
           end do ! spin
           call symmetrise_L()
           call stop_print_timer(tmr_l_tmp2, "a McWeeny iteration",&
                                 IPRINT_TIME_THRES2)

        end do iter ! n_iterations

     else ! variable spin

        ! If the spin populations are allowed to vary there will be
        ! only one omega1_tot and cn_tot etc for the entire direct sum

        do n_iterations = 1, n_L_iterations
           call start_timer(tmr_l_tmp2, WITH_LEVEL)
           if (inode == ionode .and. iprint_DM >= 1) &
                write(io_lun, 1) n_iterations
           ! find new rho and energy
           call McW_matrix_multiply_ds(matH, matS, matL, matT, &
                                       matRhoNew, omega1_tot, cn_tot)
           if (omega1_tot > oldE_tot .or.                      &
               abs(omega1_tot - oldE_tot) < 1.0e-8_double .or. &
               cn_tot > one .or. cn_tot < zero) then

              if (inode == ionode .and. iprint_DM > 0) &
                   write (io_lun, 4) c_old_tot, oldE_tot, cn_tot, omega1_tot
              call stop_print_timer(tmr_l_tmp2, "a McWeeny iteration", &
                                    IPRINT_TIME_THRES2)
              exit

           end if
           ! If new energy is lower, copy new rho into old rho and repeat
           deltaE = omega1_tot - oldE_tot
           do spin = 1, nspin
              call matrix_sum(zero, matL(spin), one, matRhoNew(spin))
           end do
           oldE_tot = omega1_tot
           c_old_tot = cn_tot
           if (inode == ionode .and. iprint_DM >= 0) &
                write (io_lun, 5) oldE_tot, c_old_tot
           call symmetrise_L()
           call stop_print_timer(tmr_l_tmp2, "a McWeeny iteration", &
                                 IPRINT_TIME_THRES2)
        end do ! n_iterations

     end if ! (nspin == 1 .or. flag_fix_spin_population)

     do spin = nspin, 1, -1
        if (n_iterations < 3) &
             call matrix_sum(zero, matL(spin), one, mat_oldL(spin))
        call free_temp_matrix(matRhoNew(spin))
        call free_temp_matrix(mat_oldL(spin))
     end do

     if (inode == ionode .and. iprint_DM >= 1) then
        write (io_lun, 6) n_iterations
        if (nspin == 1 .or. flag_fix_spin_population) then
           do spin = 1, nspin
              write (io_lun, 7) spin, omega1(spin)
           end do
        else
           write (io_lun, 8) omega1_tot
        end if
     end if

     call stop_print_timer(tmr_l_tmp1,"MCWEENY",IPRINT_TIME_THRES1)

     return

1   format(/,20x,'McWeeny L iteration:',i5)
2   format(2x,'Rounding error found (spin=',i1,'): ',4f25.15)
3   format(2x,'Energy (spin=',i1,'): ',f25.15,' Mid-point: ',f25.15)
4   format(2x,'Rounding error found (direct sum): ',4f25.15)
5   format(2x,'Energy (direct sum): ',f25.15,' Mid-point: ',f25.15)
6   format(/,20x,'Functional value reached after ',i5,' L iterations')
7   format(20x,'Omega (spin=',i1,'): ',f25.15)
8   format(20x,'Omega (direct sum): ', f25.15)

  end subroutine McWMin
  !!***

  !!****f* McWeeny/InitMcW *
  !!
  !!  NAME
  !!   InitMcW
  !!  USAGE
  !!
  !!  PURPOSE
  !!   Initialises L to be a function of H with eigenvalues between 0 and 1
  !!  INPUTS
  !!
  !!
  !!  USES
  !!
  !!  AUTHOR
  !!   D.R.Bowler
  !!  CREATION DATE
  !!   End 10/98
  !!  MODIFICATION HISTORY
  !!   11/05/01 DRB
  !!    ROBODoc headers and better output also nsf from maxima_module
  !!   08/06/2001 dave
  !!    Tidying and added GenComms for gsum
  !!    Added my_barrier to use GenComms statement
  !!   15:25, 10/12/2002 drb
  !!    Bug fix - changed location of output for mubar and added gmin
  !!    and gmax calls on hmin and hmax
  !!   11:08, 04/02/2003 drb
  !!    Implemented quick fix for bracketing mu with Hamiltonian
  !!    limits (required for stability)
  !!   12:30, 2004/06/09 dave
  !!    Fixed assumption that T and S have same range
  !!   2004/10/29 drb
  !!    Removed gsum on SX: MAJOR bug found by TM which was messing up
  !!    initialisation; also removed loops to change hmin and hmax
  !!    (unnecessary, I think)
  !!   2011/07/25 L.Tong
  !!    Adding Spin polarisation
  !!   Friday, 2011/08/05 L.Tong
  !!    Removed the obsolete number_of_bands parameter, and the total
  !!    electron numbers are obtained directly from the global_module
  !!   2012/01/30 L.Tong
  !!    Rewrite for the variable spin case, works for the whole direct
  !!    sum.
  !!   2012/03/08 L.Tong
  !!    Rewrote spin implementation
  !!   2012/05/27 L.Tong
  !!   - Added check for the case ne(spin) > n_o(spin), i.e. the
  !!     number of electrons requested by the user at initialisation
  !!     in one spin channel exceeds the number of orbitals avaliable
  !!     for that spin channel. The end result of this is that
  !!     eigenvalues of the L will no longer be contained within 0 and
  !!     1, due to forced double occupancy of a same spin orbital. A
  !!     warning will be produced if this happens.
  !!  2013/03/06 L.Tong
  !!  - Added check for the case n_o == ne(spin) or n_e, in this case
  !!    mubar will be infinity, and cause the calculation to give
  !!    NaN. When n_o == ne(spin) or n_e, the initial L from
  !!    formulation should have been the identiy matrix (lambda = 0).
  !!  2018/11/15 nakata
  !!    Changed matS, matT, SX and A to be spin_SF dependent
  !!  2018/11/15 nakata
  !!    Removed direct_sum_factor and n_e and
  !!    introduced n_e_ds, n_o_ds and A_ds for variable spin case
  !!  SOURCE
  !!
  subroutine InitMcW

    use datatypes
    use numbers
    use global_module,  only: iprint_DM, ni_in_cell,                  &
                              IPRINT_TIME_THRES1, nspin, nspin_SF,    &
                              flag_fix_spin_population, ne_in_cell,   &
                              ne_spin_in_cell, spin_factor,           &
                              flag_SpinDependentSF
    use species_module, only: species, nsf_species
    use mult_module,    only: allocate_temp_matrix, matH, matS, matT, &
                              matL, mult, matrix_trace, T_S_TS,       &
                              matrix_product_trace, matrix_product,   &
                              free_temp_matrix
    use matrix_data,    only: Lrange, Srange, TSrange
    use GenBlas
    use GenComms,       only: gsum, my_barrier, gmin, gmax, cq_abort
    use timer_module,   only: cq_timer,start_timer, stop_print_timer, &
                              WITH_LEVEL

    implicit none

    ! Local variables
    real(double) :: n_e_ds, n_o, n_o_ds, hmax_ds, hmin_ds, SXHX_ds, A_ds

    real(double), dimension(nspin_SF) :: SX, A
    real(double), dimension(nspin) :: ne, mu1, mu2, mubar, lambda, &
                                      hmin, hmax, SXHX
    integer,      dimension(nspin) :: matXHX, matSXHX, mat_temp
    integer                        :: matTS, length, i, spin, spin_SF
    type(cq_timer)                 :: tmr_l_tmp1

    call start_timer(tmr_l_tmp1, WITH_LEVEL)
    if (inode == ionode .and. iprint_DM > 1) write (io_lun, 1)
    ! We must first initialise rho
    ! ne is the number of electrons per spin channel
    ne(1:nspin) = ne_spin_in_cell(1:nspin)
    ! n_e_ds is total number of electrons
    n_e_ds = spin_factor * sum(ne(:))

    ! n_o is number of support functions
    n_o = zero
    do i = 1, ni_in_cell
       n_o = n_o + nsf_species(species(i))
    end do
    ! we are working with the whole direct sum for variable spin case
    ! so we need to have twice the size of basis set
    n_o_ds = n_o + n_o

    ! check if we have enough orbitals for the given electron
    ! populations for the initialisation procedure to work properly.
    do spin = 1, nspin
       if (ne(spin) / n_o > one) then
          write (io_lun, '(/,2x,a,i1,a,i1,a,f12.6,a,f12.6,a,/)')      &
               '*** WARNING!!! You have too few number of support &
                &functions for the calculation. The number of &
                &electrons in spin = ', spin, ' is greater than the &
                &number of orbitals!. ne(', spin, ') = ', ne(spin),   &
                ', n_o for spin channel = ', n_o, &
                ' ***'
       end if
    end do

    if (nspin == 2) then
       if (inode == ionode .and. iprint_DM > 1) &
            write (io_lun, 3) ne(1), ne(2), n_o
    else
       if (inode == ionode .and. iprint_DM > 1) &
            write (io_lun, 2) n_e_ds, n_o_ds    ! check Miyazaki-san
    end if

    matTS = allocate_temp_matrix(TSrange,0)

    do spin_SF = 1, nspin_SF
       call matrix_product(matT(spin_SF), matS(spin_SF), matTS, mult(T_S_TS))
       SX(spin_SF) = matrix_trace(matTS)
    enddo
    if (inode == ionode .and. iprint_DM > 1) then
       if (nspin_SF == 1) then
          write (io_lun, fmt='(2x,"SX is    ",f25.15)') SX(1)
          write (io_lun, fmt='(2x,"SX/no is ",f25.15)') SX(1) / n_o
       else
          write (io_lun, fmt='(2x,"SX_up is    ",f25.15)') SX(1)
          write (io_lun, fmt='(2x,"SX_up/no is ",f25.15)') SX(1) / n_o
          write (io_lun, fmt='(2x,"SX_dn is    ",f25.15)') SX(2)
          write (io_lun, fmt='(2x,"SX_dn/no is ",f25.15)') SX(2) / n_o
       endif
    end if

    SXHX_ds = zero
    spin_SF = 1
    do spin = 1, nspin
       if (flag_SpinDependentSF) spin_SF = spin
       matXHX(spin) = allocate_temp_matrix(Lrange, 0)
       mat_temp(spin) = allocate_temp_matrix(Srange, 0)
       call McWXHX(matH(spin), matT(spin_SF), matXHX(spin), mat_temp(spin))
       SXHX(spin) = matrix_product_trace(matS(spin_SF), mat_temp(spin))
       SXHX_ds = SXHX_ds + spin_factor * SXHX(spin)
       if (inode == ionode .and. iprint_DM > 1) &
            write (io_lun, '(2x,"SXHX(spin=",i1,") = ",f25.15)') &
                  spin, SXHX(spin)
    end do
    if (inode == ionode .and. iprint_DM > 1) &
            write (io_lun, '(2x,"SXHX_ds = ",f25.15)') &
                  SXHX_ds

    call my_barrier()

    ! Get Gershgorin limits on H
    call GetHLimits(hmin, hmax)
    do spin = 1, nspin
       call gmin(hmin(spin))
       call gmax(hmax(spin))
       if (inode == ionode .and. iprint_DM > 1) &
          write (io_lun, 4) spin, hmin(spin), hmax(spin)
    end do
    ! for variable spin case find min and max of the direct sum
    if (nspin == 2 .and. (.not. flag_fix_spin_population)) then
       hmin_ds = minval(hmin(:))
       hmax_ds = maxval(hmax(:))
       if (inode == ionode .and. iprint_DM > 1) write (io_lun, 5) hmin, hmax
    end if

    do spin_SF = 1, nspin_SF
       A(spin_SF) = (one - SX(spin_SF)/n_o)
    enddo
    if (nspin == 2 .and. (.not. flag_fix_spin_population)) then
       if (nspin_SF==1) A_ds = (one - (SX(1)+SX(1))/n_o_ds)   ! SX(2) = SX(1)
       if (nspin_SF==2) A_ds = (one - (SX(1)+SX(2))/n_o_ds)
    endif

    if (nspin == 1 .or. flag_fix_spin_population) then
       spin_SF = 1
       do spin = 1, nspin
          if (flag_SpinDependentSF) spin_SF = spin
          ! for the rare case where n_o == ne(spin), we have lambda =
          ! 0, and mu_bar = infty. But initial rho will be identity
          ! matrix.
          if (n_o == ne(spin)) then
             mubar(spin) = zero
             lambda(spin) = zero
          else
             mu1(spin) = SXHX(spin) / n_o + hmax(spin) * A(spin_SF)
             mu2(spin) = (hmin(spin) * A(spin_SF) * ne(spin) / (n_o - ne(spin)) - &
                          SXHX(spin) / n_o) / &
                         (n_o * A(spin_SF) / (n_o - ne(spin)) - one)
             if (inode == ionode) &
                  write (io_lun, &
                         '(2x,"Mu1, Mu2, for spin = ",i1," are: ",2f25.15)') &
                         spin, mu1(spin), mu2(spin)
             if ((ne(spin) / (hmax(spin) - mu1(spin))) < &
                 ((n_o - ne(spin)) / (mu1(spin) - hmin(spin)))) then
                mubar(spin) = mu1(spin)
                lambda(spin) = ne(spin) / (hmax(spin) - mu1(spin))
             else if ((ne(spin) / (hmax(spin) - mu2(spin))) > &
                      ((n_o - ne(spin)) / (mu2(spin) - hmin(spin)))) then
                mubar(spin) = mu2(spin)
                lambda(spin) = (n_o - ne(spin)) / (mu2(spin) - hmin(spin))
             else
                call cq_abort('InitMcW: Cannot find mubar.')
             end if
          end if
          if (inode == ionode .and. iprint_DM > 1) &
               write (io_lun, &
                      '(2x,"mubar, lambda for spin = ",i1," are: ",2f25.15)') &
                     spin, mubar(spin), lambda(spin)
       end do
       ! Calculate L0.
       spin_SF = 1
       do spin = 1, nspin
          if (flag_SpinDependentSF) spin_SF = spin
          call McWRho0(matL(spin), matT(spin_SF), matXHX(spin), mubar(spin), &
               lambda(spin), ne(spin), n_o)
       end do
    else ! variable spin
       ! for the rare case where n_o_ds == n_e_ds, we have lambda =
       ! 0, and mu_bar = infty. But initial rho will be identity
       ! matrix.
       if (n_o_ds == n_e_ds) then
          mubar(:) = zero
          lambda(:) = zero
       else
          ! mu1(1) and mu1(2) always equal in this case. Same for mu2
          mu1(:) = SXHX_ds / n_o_ds + hmax_ds * A_ds
          mu2(:) = (hmin_ds * A_ds * n_e_ds / (n_o_ds - n_e_ds) - SXHX_ds / n_o_ds) / &
                   (n_o_ds * A_ds / (n_o_ds - n_e_ds) - one)
          if (inode == ionode) &
               write (io_lun, '(2x,"Mu1, Mu2: ",2f25.15)') mu1(1), mu2(1)
          if ((n_e_ds / (hmax_ds - mu1(1))) < &
              ((n_o_ds - n_e_ds) / (mu1(1) - hmin_ds))) then
             mubar(:) = mu1(:)
             lambda(:) = n_e_ds / (hmax_ds - mu1(:))
          else if ((n_e_ds / (hmax_ds - mu2(1))) < &
                   ((n_o_ds - n_e_ds) / (mu2(1) - hmin_ds))) then
             mubar(:) = mu2(:)
             lambda(:) = (n_o_ds - n_e_ds) / (mu2(:) - hmin_ds)
          else
             call cq_abort('InitMcW: Cannot find mubar.')
          end if
       end if
       if (inode == ionode .and. iprint_DM > 1) then
          write (io_lun, 6) mubar(1)
          write (io_lun, '(2x,"lambda is ",f25.15)') lambda(1)
       end if
       ! Calculate L0.
       spin_SF = 1
       do spin = 1, nspin
          if (flag_SpinDependentSF) spin_SF = spin
          call McWRho0(matL(spin), matT(spin_SF), matXHX(spin), mubar(spin), &
                       lambda(spin), n_e_ds, n_o_ds)
       end do
    end if

    ! Free the temporary matrices, order of deallocation is important
    do spin = nspin, 1, -1
       call free_temp_matrix(mat_temp(spin))
       call free_temp_matrix(matXHX(spin))
    end do
    call free_temp_matrix(matTS)

    call stop_print_timer(tmr_l_tmp1, "McWeeny initialisation", &
                          IPRINT_TIME_THRES1)

1   format(1x,'Welcome to InitMcW')
2   format(2x,'Electrons: ',f15.6,' Orbitals: ',f15.6)
3   format(2x,'Electrons_up: ',f15.6,' Electrons_dn: ',f15.6,' Orbitals for each spin: ',f15.6)
4   format(2x,'Minimum and maximum limites on H(spin=',i1,') are ',2f15.6)
5   format(2x,'Minimum and maximum limites on overall H are ',2f15.6)
6   format(2x,'Mubar is ',f15.6)

    return
  end subroutine InitMcW
  !!***

  !!****f* McWeeny/McW_matrix_multiply_nonds *
  !!
  !!  NAME
  !!   McW_matrix_multiply_nonds
  !!  USAGE
  !!
  !!  PURPOSE
  !!   Performs one iteration of McWeeny iterative scheme
  !!   Ref: PRB 58, 12704 (1998)
  !!  INPUTS
  !!
  !!  USES
  !!
  !!  AUTHOR
  !!   D.R.Bowler
  !!  CREATION DATE
  !!   21/10/98
  !!  MODIFICATION HISTORY
  !!   11/05/01 DRB
  !!    ROBODoc headers and better output also nsf from maxima_module
  !!   08/06/2001 dave
  !!    Added GenComms for gsum
  !!   2011/03/28 L.Tong
  !!    Removed local variable declaration matL2, redundant
  !!   2011/07/26 L.Tong
  !!    Implemented spin polarisation. For this subroutine, the spins
  !!    will be treated separately all together, and this subroutine
  !!    should be called twice involking different spin The matH, matL
  !!    and matRhoNew, and energy, c should be used accordingly for
  !!    different spin channels.
  !!    Decided for simplification, moving matLS and matSL refereces to
  !!    be part of the subroutine parameters instead of module
  !!    references. This tidies the code somewhat, in this case the
  !!    usual optional spin parameter is not required.
  !!    But still needs the flag_spin_polarisation flag to toggle the
  !!    factor of two for total energy calculation
  !!   2012/03/01 L.Tong
  !!    Changed name to McW_matrix_multiply_nonds, and to be called from
  !!    interface McW_matrix_multiply
  !!   2012/03/11 L.Tong
  !!    - Major rewrite of spin implementation
  !!    - Use matLS, matSL from mult module directly
  !!    - All inputs except matS and matInvS are arrays of dimension nspin
  !!   2018/11/15 nakata
  !!    Changed matS and matInvS to be spin_SF dependent
  !!  SOURCE
  !!
  subroutine McW_matrix_multiply_nonds(matH, matS, matL, matInvS, &
                                       matRhoNew, energy, c)
    use datatypes
    use numbers
    use primary_module, only: bundle
    use matrix_data,    only: LSLrange, Lrange, Hrange, Srange
    use mult_module,    only: matrix_product, matrix_sum,             &
                              matrix_product_trace, matrix_scale,     &
                              matrix_transpose, allocate_temp_matrix, &
                              free_temp_matrix, L_S_LS, LS_L_LSL,     &
                              LSL_SL_L, mult, matLS, matSL
    use global_module,  only: iprint_DM, nspin, spin_factor, flag_SpinDependentSF
    use GenComms,       only: gsum, cq_abort, my_barrier

    implicit none

    ! Passed variables
    integer,      dimension(:) :: matH, matS, matL, matInvS, matRhoNew
    real(double), dimension(:) :: energy, c
    ! Local Variables
    integer :: spin, spin_SF
    real(double), dimension(nspin) :: c1, c2, cn
    integer,      dimension(nspin) :: matLSL, matLSLSL, mat_top, mat_bottom

    spin_SF = 1

    do spin = 1, nspin
       if (flag_SpinDependentSF) spin_SF = spin
       call matrix_product(matL(spin), matS(spin_SF), matLS(spin), mult(L_S_LS))
       ! Generate LSL, LSLSL
       matLSL(spin) = allocate_temp_matrix(LSLrange,0)
       matLSLSL(spin) = allocate_temp_matrix(Lrange,0)
       mat_top(spin) = allocate_temp_matrix(Srange,0)
       mat_bottom(spin) = allocate_temp_matrix(Srange,0)
       call my_barrier
       call matrix_product(matLS(spin), matL(spin), matLSL(spin), &
                           mult(LS_L_LSL))
       call matrix_product(matLSL(spin), matLS(spin), matLSLSL(spin), &
                           mult(LSL_SL_L))
       !----------------------------------------------------------------
       ! Shorten L, LSL and LSLSL to range S and take traces (can do it
       ! with sdot because S is symmetric)
       !----------------------------------------------------------------
       call matrix_sum(zero, mat_top(spin),  one, matLSL(spin))
       call matrix_sum(one,  mat_top(spin), -one, matLSLSL(spin))
       c1(spin) = matrix_product_trace(matS(spin_SF), mat_top(spin))
       if (inode == ionode .and. iprint_DM >= 2) &
            write (io_lun, '(2x,"S.top (spin=",i1,") is  ",f25.15)') &
                  spin, c1(spin)
       call matrix_sum(zero, mat_bottom(spin), one, matL(spin))
       c1(spin) = matrix_product_trace(matS(spin_SF), mat_bottom(spin))
       if (inode == ionode .and. iprint_DM >= 2) &
            write (io_lun, '(2x,"N_e (spin=",i1,") is  ",f25.15)') &
                  spin, c1(spin)
       call matrix_sum(one, mat_bottom(spin), -one, matLSL(spin))
       c1(spin) = matrix_product_trace(matS(spin_SF), mat_top(spin))
       c2(spin) = matrix_product_trace(matS(spin_SF), mat_bottom(spin))
       if (c2(spin) /= zero) then
          cn(spin) = c1(spin) / c2(spin)
       else
          call cq_abort('McW_matrix_multiply: c2 is zero for spin', spin)
       endif
       c(spin) = cn(spin)
       if (inode == ionode .and. iprint_DM >= 2) &
            write (io_lun, '(2x,"c, c1, c2 (spin=",i1,") are ",3f25.15)') &
                  spin, cn(spin), c1(spin), c2(spin)
       ! Shorten LSL and LSLSL to range L
       call matrix_scale(zero, matRhoNew(spin))
       call matrix_sum(zero, matRhoNew(spin), -one, matLSLSL(spin))
       call matrix_sum(one, matRhoNew(spin), one + cn(spin), matLSL(spin))
       if(cn(spin) < half) then
          call matrix_sum(one, matRhoNew(spin), (one - two * &
                          cn(spin)), matL(spin))
          call matrix_scale((one / (one - cn(spin))), matRhoNew(spin))
       else
          call matrix_scale(one / cn(spin), matRhoNew(spin))
       endif

       ! Idempotency checks
       !%%! data_L3 = zero
       !%%! call axpy(NSF*NSF*mat(1,Lrange)%length,one,dat_L,1,data_L3,1)
       !%%! ! LSLSL -> 2LSLSL - 3LSL
       !%%! call matrix_add(2.0_double, data_LSLSL, mat(:,Lrange), &
       !%%!      -3.0_double, data_LSL, mat(:,LSLrange), bundle, inode)
       !%%! ! Lnew -> Lnew+(2LSLSL-3LSL) [= Lnew - McW(Lold)]
       !%%! call axpy(NSF*NSF*mat(1,Lrange)%length,one,data_LSLSL,1,data_L3,1)
       !%%! call mult_wrap(inode-1,data_L3,dat_S,data_LS,mult(L_S_LS))
       !%%! call mult_wrap(inode-1,dat_S,data_SL,data_XHX,mult(S_LS_L))
       !%%! cn = dot(NSF*NSF*mat(1,Lrange)%length,data_SLS2, 1, data_L3, 1)
       !%%! call gsum(cn)
       !%%! if(inode.eq.ionode.AND.iprint_DM>=2) &
       !%%!     write(io_lun,*) 'Idempot monitor is ',cn/256.0_double

       ! Shorten rhonew to range H into temp
       call free_temp_matrix(mat_bottom(spin))
       mat_bottom(spin) = allocate_temp_matrix(Hrange, 0)
       call matrix_sum(zero, mat_bottom(spin), one, matRhoNew(spin))
       energy(spin) = matrix_product_trace(mat_bottom(spin), matH(spin))
       if (inode == ionode .and. iprint_DM >= 3) &
            write (io_lun, '(2x,"energy (spin=",i1,") is ",f25.15)') &
                  spin, energy(spin)
       call matrix_sum(zero, mat_top(spin), one, matRhoNew(spin))
       c1(spin) = matrix_product_trace(mat_top(spin), matS(spin_SF))
       if (inode == ionode .and. iprint_DM >= 3) &
            write (io_lun, '(2x,"N_e(2) (spin=",i1,") is ",f25.15)') &
                  spin, c1(spin)
       ! note that N_e is printed without factor of two here even for
       ! spin un-polarised results.
       call free_temp_matrix(mat_bottom(spin))
       call free_temp_matrix(mat_top(spin))
       call free_temp_matrix(matLSLSL(spin))
       call free_temp_matrix(matLSL(spin))
       if (abs(c2(spin)) < 1.0e-6) c(spin) = -0.01_double
    end do ! spin

    return

  end subroutine McW_matrix_multiply_nonds
  !!***

  !!****f* McWeeny/McW_matrix_multiply_ds *
  !! PURPOSE
  !!   Performs one iteration of McWeeny iterative scheme treating the
  !!   overall matrices L, H as direct sums of their spin
  !!   components. This allows population migration from one spin
  !!   channel to another
  !!   Ref: PRB 58, 12704 (1998)
  !! INPUTS
  !! OUTPUT
  !! RETURN VALUE
  !! AUTHOR
  !!   L.Tong
  !! CREATION DATE
  !!   2011/07/26
  !! MODIFICATION HISTORY
  !!   Tuesday, 2011/08/02 L.Tong
  !!     Changed the order of input parameters, replaced energy_up and
  !!     energy_down with energy_total, and c with c_total
  !!   2012/03/01 L.Tong
  !!     Renamed to McW_matrix_multiply_ds, to be called by interface
  !!     McW_matrix_multiply
  !!   2012/03/11 L.Tong
  !!   - Major rewrite of the spin implementation
  !!   - all inputs except matS and matInvS are arrays of dimension nspin
  !!   2018/11/13 17:30 nakata
  !!    Changed matS and matInvS to be spin_SF dependent
  !! SOURCE
  !!
  subroutine McW_matrix_multiply_ds(matH, matS, matL, matInvS, &
                                    matRhoNew, energy_total, c_total)

    use datatypes
    use numbers
    use primary_module, only: bundle
    use matrix_data,    only: LSLrange, Lrange, Hrange, Srange
    use mult_module,    only: matrix_product, matrix_sum,             &
                              matrix_product_trace, matrix_scale,     &
                              matrix_transpose, allocate_temp_matrix, &
                              free_temp_matrix, matLS, matSL, L_S_LS, &
                              LS_L_LSL, LSL_SL_L, mult
    use global_module,  only: iprint_DM, nspin, spin_factor, flag_SpinDependentSF
    use GenComms,       only: gsum, cq_abort, my_barrier

    implicit none

    ! Passed variables
    integer, dimension(:) :: matH, matS, matL, matInvS, matRhoNew
    real(double)          :: energy_total, c_total

    ! Local Variables
    real(double)              :: c1, c2, tmp
    integer, dimension(nspin) :: matLSL, matLSLSL, mat_top, mat_bottom
    integer                   :: spin, spin_SF

    c1 = zero
    c2 = zero
    energy_total = zero
    spin_SF = 1

    do spin = 1, nspin
       if (flag_SpinDependentSF) spin_SF = spin
       call matrix_product(matL(spin), matS(spin_SF), matLS(spin), mult(L_S_LS))
       ! Generate LSL, LSLSL
       matLSL(spin) = allocate_temp_matrix(LSLrange, 0)
       matLSLSL(spin) = allocate_temp_matrix(Lrange, 0)
       mat_top(spin) = allocate_temp_matrix(Srange, 0)
       mat_bottom(spin) = allocate_temp_matrix(Srange, 0)
       call my_barrier
       call matrix_product(matLS(spin), matL(spin), matLSL(spin), &
                           mult(LS_L_LSL))
       call matrix_product(matLSL(spin), matLS(spin), matLSLSL(spin), &
                           mult(LSL_SL_L))
       !----------------------------------------------------------------
       ! Shorten L, LSL and LSLSL to range S and take traces (can do it
       ! with sdot because S is symmetric)
       !----------------------------------------------------------------
       call matrix_sum(zero, mat_top(spin),  one, matLSL(spin))
       call matrix_sum(one,  mat_top(spin), -one, matLSLSL(spin))
       tmp = matrix_product_trace(matS(spin_SF), mat_top(spin))
       if (inode == ionode .and. iprint_DM >= 2) &
            write (io_lun, '(2x,"S.top (spin=",i1,") is ",f25.15)') spin, tmp
       call matrix_sum(zero, mat_bottom(spin), one, matL(spin))
       tmp = matrix_product_trace(matS(spin_SF), mat_bottom(spin))
       if (inode == ionode .and. iprint_DM >= 2) &
            write (io_lun, '(2x,"N_e (spin=",i1,") is ",f25.15)') spin, tmp
       ! get the real mat_bottom for spin up
       call matrix_sum(one, mat_bottom(spin), -one, matLSL(spin))
       ! c1 and c2 calculated
       c1 = c1 + spin_factor * matrix_product_trace(matS(spin_SF), mat_top(spin))
       c2 = c2 + spin_factor * matrix_product_trace(matS(spin_SF), mat_bottom(spin))
       ! finished  mat_bottom here, change to Hrange for something else
       call free_temp_matrix(mat_bottom(spin))
       mat_bottom(spin) = allocate_temp_matrix(Hrange,0)
    end do ! spin
    if (c2 /= zero) then
       c_total = c1 / c2
    else
       call cq_abort('McW_matrix_multiply_ds: c2 is zero')
    end if
    if (inode == ionode .and. iprint_DM >= 2) &
         write (io_lun, '(2x,"c_total, c1, c2 are ",3f25.15)') &
               c_total, c1, c2
    ! Shorten LSL and LSLSL to range L
    do spin = 1, nspin
       call matrix_scale(zero, matRhoNew(spin))
       call matrix_sum(zero, matRhoNew(spin), -one, matLSLSL(spin))
       call matrix_sum(one, matRhoNew(spin), one + c_total, matLSL(spin))
       if (c_total < half) then
          call matrix_sum(one, matRhoNew(spin), (one - two * c_total),&
                          matL(spin))
          call matrix_scale((one/(one - c_total)), matRhoNew(spin))
       else
          call matrix_scale(one/c_total, matRhoNew(spin))
       end if
       call matrix_sum(zero, mat_bottom(spin), one, matRhoNew(spin))
       energy_total = energy_total + spin_factor * &
                      matrix_product_trace(mat_bottom(spin), matH(spin))
    end do ! spin
    if (inode == ionode .and. iprint_DM >= 3) &
         write (io_lun, '(2x,"energy_total: ",f25.15)') energy_total
    do spin = 1, nspin
       call matrix_sum(zero, mat_top(spin), one, matRhoNew(spin))
       tmp = matrix_product_trace(mat_top(spin), matS(spin_SF))
       if (inode == ionode .and. iprint_DM >= 3) &
            write (io_lun, '(2x,"N_e (spin=",i1,") is ",f25.15)') &
                  spin, tmp
    end do ! spin

    ! free temp matrices
    do spin = nspin, 1, -1
       call free_temp_matrix(mat_bottom(spin))
       call free_temp_matrix(mat_top(spin))
       call free_temp_matrix(matLSLSL(spin))
       call free_temp_matrix(matLSL(spin))
    end do

    return

  End Subroutine McW_matrix_multiply_ds
  !!***

  !!****f* MacWeeny/McWXHX
  !! PURPOSE
  !!  sbrt McWXHX: Pre- and post- multiplies H by S^-1, and returns
  !!  the result to both L range (bab) and S range (tm)
  !! INPUTS
  !! OUTPUT
  !! RETURN VALUE
  !! AUTHOR
  !!   drb
  !! CREATION DATE
  !!
  !! MODIFICATION HISTORY
  !! SOURCE
  !!
  subroutine McWXHX(matA, matB, matBAB, mat_temp)

    use datatypes
    use numbers
    use matrix_data,   only: THrange
    use mult_module,   only: matrix_product, matrix_sum, T_H_TH, &
                             TH_T_L, allocate_temp_matrix, mult, &
                             free_temp_matrix, matrix_trace
    use global_module, only: iprint_DM

    implicit none

    ! Passed variables
    integer :: matA, matB, matBAB, mat_temp

    ! Local variable
    integer :: matBA
    real(double) :: xx

    matBA = allocate_temp_matrix(THrange,0)
    call matrix_product(matB, matA, matBA, mult(T_H_TH))
    if (iprint_DM >= 2) xx = matrix_trace(matBA)
    if (inode == ionode .and. iprint_DM >= 2) &
         write (io_lun, '(2x,"Trace of BA:            ",f25.15)') xx
    call matrix_product(matBA, matB, matBAB, mult(TH_T_L))
    if (iprint_DM >= 2) xx = matrix_trace(matBAB)
    if (inode == ionode .and. iprint_DM >= 2) &
         write (io_lun, '(2x,"Trace of BAB (L range): ",f25.15)') xx
    call matrix_sum(zero, mat_temp, one, matBAB)
    if (iprint_DM >= 2) xx = matrix_trace(mat_temp)
    if (inode == ionode .and. iprint_DM >= 2) &
         write (io_lun, '(2x,"Trace of BAB (S range): ",f25.15)') xx
    call free_temp_matrix(matBA)
    return
  end Subroutine McWXHX
  !!***

  !!****f*
  !! PURPOSE
  !! INPUTS
  !! OUTPUT
  !! RETURN VALUE
  !! AUTHOR
  !!   drb
  !! CREATION DATE
  !! MODIFICATION HISTORY
  !! SOURCE
  !!
  subroutine McWRho0(matA, matB, matC, m, l, n_e, n_o)

    use datatypes
    use numbers
    use mult_module,   only: matrix_sum
    use global_module, only: iprint_DM

    implicit none

    integer :: matA, matB, matC
    Real( double ) :: m, l, n_e, n_o, tmp

    tmp = (l*m+n_e)/n_o
    if (inode == ionode .and. iprint_DM >= 2) &
         write (io_lun, '(2x,"l, m, n_e, n_o and tmp are ",5f25.15)') &
               l, m, n_e, n_o, tmp
    call matrix_sum(zero, matA, tmp, matB)
    tmp = -l/n_o
    if (inode == ionode .and. iprint_DM >= 2) &
         write (io_lun, '(2x,"tmp is ",f25.15)') tmp
    call matrix_sum(one, matA, tmp, matC)
    return
  end Subroutine McWRho0
  !!***

  !!****f*
  !! PURPOSE
  !!   Finds the Gershgorin limits on the eigenvalues of the Hamiltonian
  !! INPUTS
  !! OUTPUT
  !! RETURN VALUE
  !! AUTHOR
  !!   drb
  !! CREATION DATE
  !! MODIFICATION HISTORY
  !!   2011/07/25 L.Tong
  !!     Implemented Spin Polarisation support: optional variable spin, that
  !!     makes the subroutine to calculate spin up of spin down components.
  !!   Wednesday, 2011/08/03 L.Tong
  !!     Fixed the bug caused by the conditional if (present (spin)
  !!     .and. spin == 2), on some compilers which does not short circuit
  !!     and evaluates both sides of .and. and when the subroutine is
  !!     called without the optional spin parameter, then spin == 2 gives
  !!     a segmentation fault. Fixed this by introducing logical variable
  !!     do_spin_down, we work out this variable correctly first, and
  !!     then apply conditional on it in place of the previous present
  !!     (spin) .and. spin == 2 conditional. Also moved the conditional
  !!     outside of the inner loops to improve efficiency
  !!   2012/03/11 L.Tong
  !!   - Major rewrite of spin implementation
  !!   - removed optional parameter spin
  !!   - MinH and MaxH are now arrays of spin, each contain min and max
  !!     of H in each spin channels.
  !! SOURCE
  !!
  subroutine GetHLimits(MinH, MaxH)

    use datatypes
    use numbers
    use matrix_module,  only: matrix, matrix_halo
    use matrix_data,    only: mat, Hrange, halo
    use cover_module,   only: BCS_parts
    use primary_module, only: bundle
    use mult_module,    only: matH, return_matrix_value, matrix_pos
    use GenComms,       only: cq_abort
    use maxima_module,  only: maxnsf
    use global_module,  only: nspin
    use memory_module,  only: reg_alloc_mem, reg_dealloc_mem, type_dbl

    implicit none

    ! Passed variables
    real(double), dimension(:) :: MinH, MaxH

    ! Local variables
    integer :: np, nat, nb, ist, i, j, gcspart, wheremat, iprim, nsfi,&
               nsfj, stat, spin
    real(double), dimension(:,:), allocatable :: HMin, HMax
    real(double) :: Hval

    allocate(HMin(maxnsf,nspin), HMax(maxnsf,nspin), STAT=stat)
    if (stat /= 0) &
         call cq_abort("GetHLimits: Error allocating mem: ", maxnsf, nspin)
    call reg_alloc_mem(area_DM, 2*maxnsf*nspin, type_dbl)

    MinH(:) = 1.0e30_double
    MaxH(:) = -1.0e30_double

    call start_timer(tmr_std_matrices)
    do spin = 1, nspin
       iprim = 0
       do np = 1, bundle%groups_on_node
          if (bundle%nm_nodgroup(np) > 0) then
             do nat = 1,bundle%nm_nodgroup(np)
                iprim=iprim+1
                nsfi = mat(np,Hrange)%ndimi(nat)
                HMin(:,spin) = zero
                HMax(:,spin) = zero
                do nb = 1, mat(np,Hrange)%n_nab(nat)
                   ist = mat(np,Hrange)%i_acc(nat) + nb - 1
                   nsfj = mat(np,Hrange)%ndimj(ist)
                   gcspart = &
                        BCS_parts%icover_ibeg(mat(np,Hrange)%i_part(ist)) +&
                        mat(np,Hrange)%i_seq(ist) - 1
                   wheremat = matrix_pos(matH(spin), iprim, &
                                         halo(Hrange)%i_halo(gcspart))
                   if (wheremat == mat(np, Hrange)%onsite(nat)) then
                      do i = 1, nsfj
                         do j = 1, nsfi
                            Hval = return_matrix_value(matH(spin), np, &
                                                       nat, iprim, nb, j, i)
                            HMin(i,spin) = HMin(i,spin) + abs(Hval)
                            HMax(i,spin) = HMax(i,spin) + abs(Hval)
                         end do
                      end do
                   else
                      do i = 1,nsfj
                         do j= 1, nsfi
                            Hval = return_matrix_value(matH(spin), np, &
                                                       nat, iprim, nb, j, i)
                            HMin(i,spin) = HMin(i,spin) - abs(Hval)
                            HMax(i,spin) = HMax(i,spin) + abs(Hval)
                         end do
                      end do
                   end if
                end do ! do nb = 1, mat(np,Hrange)%n_nab(nat)
                ! do a simple search for the min amd max among HMin(i) and HMax(i)
                do i = 1, nsfi
                   if (HMin(i,spin) < MinH(spin)) MinH(spin) = HMin(i,spin)
                   if (HMax(i,spin) > MaxH(spin)) MaxH(spin) = HMax(i,spin)
                enddo
             end do ! nat = bundle%nm_nodgroup
          end if ! (bundle%nm_nodgroup(np) > 0)
       end do ! np
    end do ! spin

    call stop_timer(tmr_std_matrices)

    deallocate(HMin, HMax, STAT=stat)
    if (stat /= 0) &
         call cq_abort("GetHLimits: Error deallocating mem")
    call reg_dealloc_mem(area_DM, 2*maxnsf*nspin, type_dbl)

    return
  end subroutine GetHLimits
  !!***

end module McWeeny


*DECK LA05BS
      SUBROUTINE LA05BS (A, IND, IA, N, IP, IW, W, G, B, TRANS)
C***BEGIN PROLOGUE  LA05BS
C***SUBSIDIARY
C***PURPOSE  Subsidiary to SPLP
C***LIBRARY   SLATEC
C***TYPE      SINGLE PRECISION (LA05BS-S, LA05BD-D)
C***AUTHOR  (UNKNOWN)
C***DESCRIPTION
C
C     THIS SUBPROGRAM IS A SLIGHT MODIFICATION OF A SUBPROGRAM
C     FROM THE C. 1979 AERE HARWELL LIBRARY.  THE NAME OF THE
C     CORRESPONDING HARWELL CODE CAN BE OBTAINED BY DELETING
C     THE FINAL LETTER =S= IN THE NAMES USED HERE.
C     REVISED SEP. 13, 1979.
C
C     ROYALTIES HAVE BEEN PAID TO AERE-UK FOR USE OF THEIR CODES
C     IN THE PACKAGE GIVEN HERE.  ANY PRIMARY USAGE OF THE HARWELL
C     SUBROUTINES REQUIRES A ROYALTY AGREEMENT AND PAYMENT BETWEEN
C     THE USER AND AERE-UK.  ANY USAGE OF THE SANDIA WRITTEN CODES
C     SPLP( ) (WHICH USES THE HARWELL SUBROUTINES) IS PERMITTED.
C
C IP(I,1),IP(I,2) POINT TO START OF ROW/COLUMN I OF U.
C IW(I,1),IW(I,2) ARE LENGTHS OF ROW/COL I OF U.
C IW(.,3),IW(.,4) HOLD ROW/COL NUMBERS IN PIVOTAL ORDER.
C
C***SEE ALSO  SPLP
C***ROUTINES CALLED  XERMSG, XSETUN
C***COMMON BLOCKS    LA05DS
C***REVISION HISTORY  (YYMMDD)
C   811215  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900402  Added TYPE section.  (WRB)
C   920410  Corrected second dimension on IW declaration.  (WRB)
C***END PROLOGUE  LA05BS
      REAL A(IA), B(*), AM, W(*), G, SMALL
      LOGICAL TRANS
      INTEGER IND(IA,2), IW(N,8)
      INTEGER IP(N,2)
      COMMON /LA05DS/ SMALL, LP, LENL, LENU, NCP, LROW, LCOL
C***FIRST EXECUTABLE STATEMENT  LA05BS
      IF (G.LT.0.) GO TO 130
      KLL = IA - LENL + 1
      IF (TRANS) GO TO 80
C
C     MULTIPLY VECTOR BY INVERSE OF L
      IF (LENL.LE.0) GO TO 20
      L1 = IA + 1
      DO 10 KK=1,LENL
         K = L1 - KK
         I = IND(K,1)
         IF (B(I).EQ.0.) GO TO 10
         J = IND(K,2)
         B(J) = B(J) + A(K)*B(I)
   10 CONTINUE
   20 DO 30 I=1,N
         W(I) = B(I)
         B(I) = 0.
   30 CONTINUE
C
C     MULTIPLY VECTOR BY INVERSE OF U
      N1 = N + 1
      DO 70 II=1,N
         I = N1 - II
         I = IW(I,3)
         AM = W(I)
         KP = IP(I,1)
         IF (KP.GT.0) GO TO 50
         KP = -KP
         IP(I,1) = KP
         NZ = IW(I,1)
         KL = KP - 1 + NZ
         K2 = KP + 1
         DO 40 K=K2,KL
            J = IND(K,2)
            AM = AM - A(K)*B(J)
   40    CONTINUE
   50    IF (AM.EQ.0.) GO TO 70
         J = IND(KP,2)
         B(J) = AM/A(KP)
         KPC = IP(J,2)
         KL = IW(J,2) + KPC - 1
         IF (KL.EQ.KPC) GO TO 70
         K2 = KPC + 1
         DO 60 K=K2,KL
            I = IND(K,1)
            IP(I,1) = -ABS(IP(I,1))
   60    CONTINUE
   70 CONTINUE
      GO TO 140
C
C     MULTIPLY VECTOR BY INVERSE OF TRANSPOSE OF U
   80 DO 90 I=1,N
         W(I) = B(I)
         B(I) = 0.
   90 CONTINUE
      DO 110 II=1,N
         I = IW(II,4)
         AM = W(I)
         IF (AM.EQ.0.) GO TO 110
         J = IW(II,3)
         KP = IP(J,1)
         AM = AM/A(KP)
         B(J) = AM
         KL = IW(J,1) + KP - 1
         IF (KP.EQ.KL) GO TO 110
         K2 = KP + 1
         DO 100 K=K2,KL
            I = IND(K,2)
            W(I) = W(I) - AM*A(K)
  100    CONTINUE
  110 CONTINUE
C
C     MULTIPLY VECTOR BY INVERSE OF TRANSPOSE OF L
      IF (KLL.GT.IA) RETURN
      DO 120 K=KLL,IA
         J = IND(K,2)
         IF (B(J).EQ.0.) GO TO 120
         I = IND(K,1)
         B(I) = B(I) + A(K)*B(J)
  120 CONTINUE
      GO TO 140
C
  130 CALL XSETUN(LP)
      IF (LP .GT. 0) CALL XERMSG ('SLATEC', 'LA05BS',
     +   'EARLIER ENTRY GAVE ERROR RETURN.', -8, 2)
  140 RETURN
      END


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

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

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

module VSLEAVE_Sup_Inputs_def

!  Version 2.6 Notes
!  -----------------

!  Observational Geometry Inputs. Marked with !@@
!     Installed 31 December 2012.
!       Observation-Geometry New dimensioning.    MAX_USER_OBSGEOMS
!       Observation-Geometry input control.       DO_USER_OBSGEOMS
!       Observation-Geometry input control.       N_USER_OBSGEOMS
!       User-defined Observation Geometry angles. USER_OBSGEOMS
!     Added solar_sources flag for better control (DO_SOLAR_SOURCES)
!     Added Overall-exact flag for better control (DO_EXACT)

!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@

!  Upgrade for Version 2.7
!  -----------------------

!  New Water-leaving code developed/tested by R. Spurr, April 2014
!  Based in part on Modified-6S code by A. Sayer.
!  Validated against Modified-6 OCEABRDF.F code, 24  April 2014.

!  Water-leaving upgrade according to the modified 6S specification
!  New code calculates transmittances into and out of ocean, using
!  usual sun-glint rough surface approximations. In addition, the
!  water-leaving term itself is now SZA-dependent (A. Sayer), and
!  there is now a correction for Whitecaps (again, from 6S)

!  This upgrade gives the  water-leaving terms some directionality,
!  but they are still azimuth-independent

!  Earlier version inputs were just Wavelength/Salinity/PigmentConc
!  This was enough for the isotropic case (Fast Option) in Version 2.6.
!  For Version 2.7, we require additional inputs, including:
!    - Wind-speed and Direction (direction was not used in earlier version)
!    - flags to control use sunglint shadowing and foam (whitecaps) correction.

!  This water-leaving option is designed to work alongside the "NewCM" glint
!  reflectance option in the VBRDF code. The glint and whitecap calculations
!  in the two supplements are the same.

!  You need to make sure that the wind input information is the same as that
!  used for the "NewCM" glint option in the VBRDF supplement. Also, the Foam
!  correction applied here in the surface-leaving code should also be
!  applied for "NewCM" glint.

!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@

!  This module contains the following structures:

!  VSLEAVE_Sup_Inputs - Intent(In) for VSLEAVE_Sup

use VLIDORT_PARS

implicit none

! #####################################################################
! #####################################################################

type VSLEAVE_Sup_Inputs

!  General control variables
!  -------------------------

!  Inclusion flag (not really necessary, Brian)

      LOGICAL :: SL_DO_SLEAVING

!  Isotropic flag

      LOGICAL :: SL_DO_ISOTROPIC

!  Exact flag (!@@) and Exact only flag --> no Fourier term calculations

      LOGICAL :: SL_DO_EXACT
      LOGICAL :: SL_DO_EXACTONLY

!  Fluorescence flag

      LOGICAL :: SL_DO_FLUORESCENCE

!   !@@ Solar sources + Observational Geometry flag !@@

      LOGICAL :: SL_DO_SOLAR_SOURCES
      LOGICAL :: SL_DO_USER_OBSGEOMS

!  Geometry and integer control
!  ----------------------------

!  Number of Stokes components

      INTEGER :: SL_NSTOKES

!  Number of discrete ordinate streams

      INTEGER :: SL_NSTREAMS

!  number of solar beams to be processed

      INTEGER :: SL_NBEAMS

!  Bottom-of-atmosphere solar zenith angles, DEGREES

      REAL(fpk), dimension (MAXBEAMS) :: SL_BEAM_SZAS

!  user-defined relative azimuths

      INTEGER                                 :: SL_N_USER_RELAZMS
      REAL(fpk), dimension (MAX_USER_RELAZMS) :: SL_USER_RELAZMS

!  User-defined zenith angle input

      LOGICAL                                 :: SL_DO_USER_STREAMS
      INTEGER                                 :: SL_N_USER_STREAMS
      REAL(fpk), dimension (MAX_USER_STREAMS) :: SL_USER_ANGLES_INPUT

!  !@@ Observational geometry inputs

      INTEGER                                    :: SL_N_USER_OBSGEOMS
      REAL(fpk), dimension (MAX_USER_OBSGEOMS,3) :: SL_USER_OBSGEOMS

!  Water-leaving variables
!  -----------------------

!  Input Salinity in [ppt]

      REAL(fpk) :: SL_SALINITY

!  Input Chlorophyll concentration in [mg/M]

      REAL(fpk) :: SL_CHLORCONC

!  Input wavelength in [Microns]

      REAL(fpk) :: SL_WAVELENGTH

!  Changed for Version 2.7
!     Input Wind speed in m/s, and azimuth directions relative to Sun positions

      REAL(fpk) :: SL_WINDSPEED, SL_WINDDIR ( MAXBEAMS )

!  Removed, Version 2.7 --> Quadrature is internal.
!     Number of azimuth quadrature streams for reflectivity
!        (only for non-isotropic water leaving)
!      INTEGER :: SL_NSTREAMS_AZQUAD

!  New for Version 2.7.
!    Flags for glint shadowing, Foam Correction, facet Isotropy

      LOGICAL   :: SL_DO_GlintShadow
      LOGICAL   :: SL_DO_FoamOption
      LOGICAL   :: SL_DO_FacetIsotropy

!  Fluorescence variables
!  ----------------------

!  Input wavelength in [nm]

      REAL(fpk) :: SL_FL_Wavelength

!  Input Latitude/Longitude in [degs]

      REAL(fpk) :: SL_FL_Latitude, SL_FL_Longitude

!  Input Epoch

      INTEGER :: SL_FL_Epoch(6)

!  Input F755 Amplitude

      REAL(fpk) :: SL_FL_Amplitude755

!  Flag for using Data Gaussians

      LOGICAL :: SL_FL_DO_DataGaussian

!  Input (non-data) Gaussians

      REAL(fpk) :: SL_FL_InputGAUSSIANS(3,2)

end type VSLEAVE_Sup_Inputs

! #####################################################################
! #####################################################################

!  EVERYTHING PUBLIC HERE

   PRIVATE
   PUBLIC :: VSLEAVE_Sup_Inputs

end module VSLEAVE_Sup_Inputs_def


      SUBROUTINE ALG09
C
      REAL LOSS,LAMI,LAMIP1,LAMIM1
C
      DIMENSION XX1(21),XX2(21),XX3(21),XX4(21),XX5(21),XX6(21),SOL(21),
     1WPARA(21),WD(21),DIF(21),WS(21),PM1(21),XINC(21),BETA1(21),TALPH1(
     221),ANG(21),HIGHM(21),WT(21),XMR(21)
C
      COMMON /UD3PRT/ IPRTC
      COMMON /UD300C/ NSTNS,NSTRMS,NMAX,NFORCE,NBL,NCASE,NSPLIT,NREAD,
     1NPUNCH,NPAGE,NSET1,NSET2,ISTAG,ICASE,IFAILO,IPASS,I,IVFAIL,IFFAIL,
     2NMIX,NTRANS,NPLOT,ILOSS,LNCT,ITUB,IMID,IFAIL,ITER,LOG1,LOG2,LOG3,
     3LOG4,LOG5,LOG6,IPRINT,NMANY,NSTPLT,NEQN,NSPEC(30),NWORK(30),
     4NLOSS(30),NDATA(30),NTERP(30),NMACH(30),NL1(30),NL2(30),NDIMEN(30)
     5,IS1(30),IS2(30),IS3(30),NEVAL(30),NDIFF(4),NDEL(30),NLITER(30),
     6NM(2),NRAD(2),NCURVE(30),NWHICH(30),NOUT1(30),NOUT2(30),NOUT3(30),
     7NBLADE(30),DM(11,5,2),WFRAC(11,5,2),R(21,30),XL(21,30),X(21,30),
     8H(21,30),S(21,30),VM(21,30),VW(21,30),TBETA(21,30),DIFF(15,4),
     9FDHUB(15,4),FDMID(15,4),FDTIP(15,4),TERAD(5,2),DATAC(100),
     1DATA1(100),DATA2(100),DATA3(100),DATA4(100),DATA5(100),DATA6(100),
     2DATA7(100),DATA8(100),DATA9(100),FLOW(10),SPEED(30),SPDFAC(10),
     3BBLOCK(30),BDIST(30),WBLOCK(30),WWBL(30),XSTN(150),RSTN(150),
     4DELF(30),DELC(100),DELTA(100),TITLE(18),DRDM2(30),RIM1(30),
     5XIM1(30),WORK(21),LOSS(21),TANEPS(21),XI(21),VV(21),DELW(21),
     6LAMI(21),LAMIM1(21),LAMIP1(21),PHI(21),CR(21),GAMA(21),SPPG(21),
     7CPPG(21),HKEEP(21),SKEEP(21),VWKEEP(21),DELH(30),DELT(30),VISK,
     8SHAPE,SCLFAC,EJ,G,TOLNCE,XSCALE,PSCALE,PLOW,RLOW,XMMAX,RCONST,
     9FM2,HMIN,C1,PI,CONTR,CONMX
C
      WMAX=0.7
      L1=I+NL1(I)
      XN=SPEED(I)*SPDFAC(ICASE)*PI/(30.0*SCLFAC)
      IF(IPRINT.EQ.0)GO TO 116
      L2=ABS(FLOAT(NEVAL(I)))
      CALL ALG03(LNCT,7+NSTRMS)
      LNCT=LNCT-3
      IF(NEVAL(I).GT.0.AND.IPRTC.EQ.1) WRITE(LOG2,100) L1,I,L2
      IF(NEVAL(I).LT.0.AND.IPRTC.EQ.1) WRITE(LOG2,110) L1,I,L2
100   FORMAT(2X,/,8X,57HLOSS COEFFICIENT DETERMINATION FOR BLADE BETWEEN
     1 STATIONS,I3,4H AND,I3,47H - AS INCORPORATED IN ABOVE RESULTS  BLA
     1DE TYPE,I2,/,8X,116(1H*),/,2X)
110   FORMAT(2X,/,8X,57HLOSS COEFFICIENT DETERMINATION FOR BLADE BETWEEN
     1 STATIONS,I3,4H AND,I3,47H - FOR PURPOSES OF COMPARISON ONLY   BLA
     2DE TYPE,I2,/,8X,116(1H*),/,2X)
116   L2=NDIMEN(I)+1
      GO TO(120,140,160,180),L2
120   DO 130 J=1,NSTRMS
      XX2(J)=R(J,L1)
130   XX6(J)=R(J,I)
      GO TO 200
140   DO 150 J=1,NSTRMS
      XX2(J)=R(J,L1)/R(NSTRMS,L1)
150   XX6(J)=R(J,I)/R(NSTRMS,I)
      GO TO 200
160   DO 170 J=1,NSTRMS
      XX2(J)=XL(J,L1)
170   XX6(J)=XL(J,I)
      GO TO 200
180   DO 190 J=1,NSTRMS
      XX2(J)=XL(J,L1)/XL(NSTRMS,L1)
190   XX6(J)=XL(J,I)/XL(NSTRMS,I)
200   L2=IS2(I)
      CALL ALG01(DATAC(L2),DATA5(L2),NDATA(I),XX6,SOL,X1,NSTRMS,NTERP(I
     1),0)
      Q=1.0
      IF(SPEED(I).LT.0.0)GO TO 208
      IF(SPEED(I).GT.0.0)GO TO 206
      IF(I.LT.3)GO TO 208
      II=I-1
204   IF(SPEED(II).NE.0.0)GO TO 205
      IF(II.EQ.2)GO TO 208
      II=II-1
      GO TO 204
205   IF(SPEED(II).LT.0.0)Q=-1.0
      GO TO 208
206   Q=-1.0
208   DO 210 J=1,NSTRMS
      TALPH1(J)=(VW(J,L1)-XN*R(J,L1))/VM(J,L1)
210   DIF(J)=1.0-VM(J,I)/VM(J,L1)*SQRT((1.0+TBETA(J,I)**2)/(1.0+TALPH1(J
     1)**2))+(VM(J,L1)*TALPH1(J)-VM(J,I)*TBETA(J,I))/(2.0*SOL(J)*VM(J,L1
     2)*SQRT(1.0+TALPH1(J)**2))*Q
      L2=ABS(FLOAT(NEVAL(I)))
      L3=NDIFF(L2)
      CALL ALG01(DIFF(1,L2),FDHUB(1,L2),L3,DIF,XX3,X1,NSTRMS,0,0)
      CALL ALG01(DIFF(1,L2),FDMID(1,L2),L3,DIF,XX4,X1,NSTRMS,0,0)
      CALL ALG01(DIFF(1,L2),FDTIP(1,L2),L3,DIF,XX5,X1,NSTRMS,0,0)
      XX1(1)=0.1
      XX1(2)=0.5
      XX1(3)=0.9
      DO 220 J=1,NSTRMS
      XX1(4)=XX3(J)
      XX1(5)=XX4(J)
      XX1(6)=XX5(J)
      X1=(R(J,I)-R(1,I))/(R(NSTRMS,I)-R(1,I))
220   CALL ALG01(XX1,XX1(4),3,X1,WPARA(J),X1,1,0,0)
      DO 230 J=1,NSTRMS
      XMR(J)=0.0
      HIGHM(J)=0.0
      ANG(J)=0.0
      WS(J)=0.0
      XINC(J)=0.0
      BETA1(J)=0.0
      WD(J)=WPARA(J)*2.0*SOL(J)*SQRT(1.0+TBETA(J,I)**2)
230   WT(J)=WD(J)
      IF(NDEL(I).EQ.0)GO TO 384
      L2=IS3(I)
      CALL ALG01(DELC(L2),DELTA(L2),NDEL(I),XX2,PM1,X1,NSTRMS,1,0)
      IF(NDATA(L1).EQ.0)GO TO 340
      CALL ALG01(R(1,L1),X(1,L1),NSTRMS,R(1,L1),X1,XX1,NSTRMS,0,1)
      L2=NDIMEN(L1)+1
      GO TO(240,260,280,300),L2
240   DO 250 J=1,NSTRMS
250   XX2(J)=R(J,L1)
      GO TO 320
260   DO 270 J=1,NSTRMS
270   XX2(J)=R(J,L1)/R(J,NSTRMS)
      GO TO 320
280   DO 290 J=1,NSTRMS
290   XX2(J)=XL(J,L1)
      GO TO 320
300   DO 310 J=1,NSTRMS
310   XX2(J)=XL(J,L1)/XL(NSTRMS,L1)
320   L2=IS2(L1)
      L3=NDATA(L1)
      CALL ALG01(DATAC(L2),DATA1(L2),L3,XX2,XX3,X1,NSTRMS,NTERP(L1),0)
      CALL ALG01(DATAC(L2),DATA3(L2),L3,XX2,XX4,X1,NSTRMS,NTERP(L1),0)
      DO 330 J=1,NSTRMS
      X1=(ATAN((R(J,L1+1)-R(J,L1))/(X(J,L1+1)-X(J,L1)))+ATAN((R(J,L1)-R(
     1J,L1-1))/(X(J,L1)-X(J,L1-1))))/2.0
      BETA1(J)=ATAN((TAN(XX3(J)/C1)*(1.0-XX1(J)*TAN(X1))-TAN(X1)*TAN(XX4
     1(J)/C1)*SQRT(1.0+XX1(J)**2))*COS(X1))
330   XINC(J)=(ATAN(TALPH1(J))-BETA1(J))*Q
340   DO 380 J=1,NSTRMS
      ANG(J)=XINC(J)+PM1(J)/C1
      X1=H(J,L1)-(VM(J,L1)**2+VW(J,L1)**2)/(2.0*G*EJ)
      IF(X1.LT.HMIN)X1=HMIN
      X4=ALG8(X1,S(J,L1))
      X2=(X4+1.0)/(X4-1.0)
      X3=SQRT(X2)
      X5=ALG9(X1,S(J,L1),VM(J,L1)**2*(1.0+TALPH1(J)**2))
      XMR(J)=SQRT(X5)
      X6=X5
      IF(X6.LT.1.0)X6=1.0
      X7=X3*ATAN(SQRT(X6-1.0)/X3)-ATAN(SQRT(X6-1.0))+ANG(J)
      X10=0.0
      IF(X7.LE.0.0)GO TO 376
      X8=0.4*PI*(X3-1.0)
      IF(X7.GT.X8)GO TO 374
      X9 = 1.0
      K=1
350   X10=X9-(X2+X9*X9)*(1.0+X9*X9)/(X9*X9*(X2-1.0))*(X3*ATAN(X9/X3)-ATA
     1N(X9)-X7)
      IF(ABS(X10-X9).LE.0.00001)GO TO 376
      IF(K.GT.20)GO TO 360
      K=K+1
      X9=X10
      GO TO 350
360   IF(IPRINT.EQ.0)GO TO 374
      CALL ALG03(LNCT,1)
      WRITE(LOG2,370)IPASS,I,J
370   FORMAT(5X,4HPASS,I3,9H  STATION,I3,12H  STREAMLINE,I3,58H  PRANDTL
     1-MEYER FUNCTION NOT CONVERGED - USE INLET MACH NO)
374   X10=SQRT(X6-1.0)
376   HIGHM(J)=SQRT(1.0+X10*X10)
      X1=(HIGHM(J)+SQRT(X6))/2.0
      IF(X5.LT.1.0)X1=X1*SQRT(X5)
      IF(X1.LE.1.0)GO TO 380
      X1=X1*X1
      WS(J)=(((X4+1.0)*X1/((X4-1.0)*X1+2.0))**(X4/(X4-1.0))*((X4+1.0)/(2
     1.0*X4*X1-X4+1.0))**(1.0/(X4-1.0))-1.0)/((1.0+(X4-1.0)/2.0*X5)**(X4
     2/(1.0-X4))-1.0)
380   WT(J)=WD(J)+WS(J)
384   IF(IPRINT.EQ.1)GO TO 400
      L2=IS2(I)
      L3=NTERP(I)
      L4=NDATA(I)
      IF(NWORK(I).GE.5)
     1CALL ALG01(DATAC(L2),DATA6(L2),L4,XX6,XX5,X1,NSTRMS,L3,0)
      CALL ALG01(DATAC(L2),DATA1(L2),L4,XX6,XX1,X1,NSTRMS,L3,0)
      CALL ALG01(DATAC(L2),DATA4(L2),L4,XX6,XX4,X1,NSTRMS,L3,0)
      CALL ALG01(DATAC(L2),DATA3(L2),L4,XX6,XX3,X1,NSTRMS,L3,0)
      NDATA(I)=NSTRMS
      L2=L2-1
      DO 390 J=1,NSTRMS
      K=L2+J
      DATAC(K)=XX6(J)
      IF(NWORK(I).GE.5)
     1DATA6(K)=XX5(J)
      DATA1(K)=XX1(J)
      IF(WT(J).GT.WMAX)WT(J)=WMAX
      DATA2(K)=WT(J)
      DATA3(K)=XX3(J)
      DATA4(K)=XX4(J)
390   DATA5(K)=SOL(J)
      GO TO 450
400   IF(LNCT+3.LE.NPAGE)GO TO 420
      IF(IPRTC.NE.0) WRITE(LOG2,410)
410   FORMAT(1H1)
      LNCT=4+NSTRMS
  420 IF(IPRTC.EQ.1) WRITE(LOG2,430)
430   FORMAT(5X,   'STREAM  INLET   OUTLET  CASCADE   DIFF       LOSS
     1DIFFUSION  BLADE  INCIDENCE  EXPANSION INLET  EXPANDED SHOCK   TOT
     2AL',/,5X,  '-LINE   RADIUS  RADIUS  SOLIDITY  FACTOR  PARAMETER
     3LOSS     ANGLE    ANGLE      ANGLE    M.NO  MACH NO   LOSS   LOSS
     4',/,2X)
      LNCT=LNCT+3
      DO 440 J=1,NSTRMS
      X1=BETA1(J)*C1*Q
      X2=XINC(J)*C1
      X3=ANG(J)*C1
  440 IF(IPRTC.EQ.1)
     *WRITE(LOG2,460)J,R(J,L1),R(J,I),SOL(J),DIF(J),WPARA(J),WD(J),X1,X2
     1,X3,XMR(J),HIGHM(J),WS(J),WT(J)
450   CONTINUE
460   FORMAT(I9,F10.3,F8.3,2F9.4,F10.5,F9.5,2F9.3,F10.3,F10.4,F8.4,F8.5,
     1F9.5)
      RETURN
      END


Subroutine pyrand
  Common /ludat1/mstu(200), paru(200), mstj(200), parj(200)
  Save /ludat1/
  Common /ludat2/kchg(500, 3), pmas(500, 4), parf(2000), vckm(4, 4)
  Save /ludat2/
  Common /pysubs/msel, msub(200), kfin(2, -40:40), ckin(200)
  Save /pysubs/
  Common /pypars/mstp(200), parp(200), msti(200), pari(200)
  Save /pypars/
  Common /pyint1/mint(400), vint(400)
  Save /pyint1/
  Common /pyint2/iset(200), kfpr(200, 2), coef(200, 20), icol(40, 4, 2)
  Save /pyint2/
  Common /pyint3/xsfx(2, -40:40), isig(1000, 3), sigh(1000)
  Save /pyint3/
  Common /pyint4/widp(21:40, 0:40), wide(21:40, 0:40), wids(21:40, 3)
  Save /pyint4/
  Common /pyint5/ngen(0:200, 3), xsec(0:200, 3)
  Save /pyint5/
  mint(17) = 0
  mint(18) = 0
  vint(143) = 1.
  vint(144) = 1.
  If (msub(95)==1 .Or. mint(82)>=2) Call pymult(2)
  isub = 0
  100 mint(51) = 0
  If (mint(82)==1 .And. (isub<=90 .Or. isub>96)) Then
    rsub = xsec(0, 1)*rlu(0)
    Do i = 1, 200
      If (msub(i)/=1) Goto 110
      isub = i
      rsub = rsub - xsec(i, 1)
      If (rsub<=0.) Goto 120
    110 End Do
    120 If (isub==95) isub = 96
  Else If (mint(82)>=2 .And. isub==0) Then
    rsub = vint(131)*rlu(0)
    isub = 96
    If (rsub>vint(106)) isub = 93
    If (rsub>vint(106)+vint(104)) isub = 92
    If (rsub>vint(106)+vint(104)+vint(103)) isub = 91
  End If
  If (mint(82)==1) ngen(0, 1) = ngen(0, 1) + 1
  If (mint(82)==1) ngen(isub, 1) = ngen(isub, 1) + 1
  mint(1) = isub
  mint(72) = 0
  kfr1 = 0
  If (iset(isub)==1 .Or. iset(isub)==3) Then
    kfr1 = kfpr(isub, 1)
  Else If (isub>=71 .And. isub<=77) Then
    kfr1 = 25
  End If
  If (kfr1/=0) Then
    taur1 = pmas(kfr1, 1)**2/vint(2)
    gamr1 = pmas(kfr1, 1)*pmas(kfr1, 2)/vint(2)
    mint(72) = 1
    mint(73) = kfr1
    vint(73) = taur1
    vint(74) = gamr1
  End If
  If (isub==141) Then
    kfr2 = 23
    taur2 = pmas(kfr2, 1)**2/vint(2)
    gamr2 = pmas(kfr2, 1)*pmas(kfr2, 2)/vint(2)
    mint(72) = 2
    mint(74) = kfr2
    vint(75) = taur2
    vint(76) = gamr2
  End If
  vint(63) = 0.
  vint(64) = 0.
  mint(71) = 0
  vint(71) = ckin(3)
  If (mint(82)>=2) vint(71) = 0.
  If (iset(isub)==2 .Or. iset(isub)==4) Then
    Do i = 1, 2
      If (kfpr(isub,i)==0) Then
      Else If (mstp(42)<=0) Then
        vint(62+i) = pmas(kfpr(isub,i), 1)**2
      Else
        vint(62+i) = ulmass(kfpr(isub,i))**2
      End If
    End Do
    If (min(vint(63),vint(64))<ckin(6)**2) mint(71) = 1
    If (mint(71)==1) vint(71) = max(ckin(3), ckin(5))
  End If
  If (iset(isub)==0) Then
    is = int(1.5+rlu(0))
    vint(63) = vint(3)**2
    vint(64) = vint(4)**2
    If (isub==92 .Or. isub==93) vint(62+is) = parp(111)**2
    If (isub==93) vint(65-is) = parp(111)**2
    sh = vint(2)
    sqm1 = vint(3)**2
    sqm2 = vint(4)**2
    sqm3 = vint(63)
    sqm4 = vint(64)
    sqla12 = (sh-sqm1-sqm2)**2 - 4.*sqm1*sqm2
    sqla34 = (sh-sqm3-sqm4)**2 - 4.*sqm3*sqm4
    thter1 = sqm1 + sqm2 + sqm3 + sqm4 - (sqm1-sqm2)*(sqm3-sqm4)/sh - sh
    thter2 = sqrt(max(0.,sqla12))*sqrt(max(0.,sqla34))/sh
    thl = 0.5*(thter1-thter2)
    thu = 0.5*(thter1+thter2)
    thm = min(max(thl,parp(101)), thu)
    jtmax = 0
    If (isub==92 .Or. isub==93) jtmax = isub - 91
    Do jt = 1, jtmax
      mint(13+3*jt-is*(2*jt-3)) = 1
      sqmmin = vint(59+3*jt-is*(2*jt-3))
      sqmi = vint(8-3*jt+is*(2*jt-3))**2
      sqmj = vint(3*jt-1-is*(2*jt-3))**2
      sqmf = vint(68-3*jt+is*(2*jt-3))
      squa = 0.5*sh/sqmi*((1.+(sqmi-sqmj)/sh)*thm+sqmi-sqmf-sqmj**2/sh+(sqmi+sqmj)*sqmf/sh+(sqmi-sqmj)**2/sh**2*sqmf)
      quar = sh/sqmi*(thm*(thm+sh-sqmi-sqmj-sqmf*(1.-(sqmi-sqmj)/sh))+sqmi*sqmj-sqmj*sqmf*(1.+(sqmi-sqmj-sqmf)/sh))
      sqmmax = squa + sqrt(max(0.,squa**2-quar))
      If (abs(quar/squa**2)<1.E-06) sqmmax = 0.5*quar/squa
      sqmmax = min(sqmmax, (vint(1)-sqrt(sqmf))**2)
      vint(59+3*jt-is*(2*jt-3)) = sqmmin*(sqmmax/sqmmin)**rlu(0)
    End Do
    sqm3 = vint(63)
    sqm4 = vint(64)
    sqla34 = (sh-sqm3-sqm4)**2 - 4.*sqm3*sqm4
    thter1 = sqm1 + sqm2 + sqm3 + sqm4 - (sqm1-sqm2)*(sqm3-sqm4)/sh - sh
    thter2 = sqrt(max(0.,sqla12))*sqrt(max(0.,sqla34))/sh
    thl = 0.5*(thter1-thter2)
    thu = 0.5*(thter1+thter2)
    b = vint(121)
    c = vint(122)
    If (isub==92 .Or. isub==93) Then
      b = 0.5*b
      c = 0.5*c
    End If
    thm = min(max(thl,parp(101)), thu)
    expth = 0.
    tharg = b*(thm-thu)
    If (tharg>-20.) expth = exp(tharg)
    150 th = thu + log(expth+(1.-expth)*rlu(0))/b
    th = max(thm, min(thu,th))
    ratlog = min((b+c*(th+thm))*(th-thm), (b+c*(th+thu))*(th-thu))
    If (ratlog<log(rlu(0))) Goto 150
    vint(21) = 1.
    vint(22) = 0.
    vint(23) = min(1., max(-1.,(2.*th-thter1)/thter2))
  Else If (iset(isub)>=1 .And. iset(isub)<=4) Then
    Call pyklim(1)
    If (mint(51)/=0) Goto 100
    rtau = rlu(0)
    mtau = 1
    If (rtau>coef(isub,1)) mtau = 2
    If (rtau>coef(isub,1)+coef(isub,2)) mtau = 3
    If (rtau>coef(isub,1)+coef(isub,2)+coef(isub,3)) mtau = 4
    If (rtau>coef(isub,1)+coef(isub,2)+coef(isub,3)+coef(isub,4)) mtau = 5
    If (rtau>coef(isub,1)+coef(isub,2)+coef(isub,3)+coef(isub,4)+coef(isub,5)) mtau = 6
    Call pykmap(1, mtau, rlu(0))
    If (iset(isub)==3 .Or. iset(isub)==4) Then
      Call pyklim(4)
      If (mint(51)/=0) Goto 100
      rtaup = rlu(0)
      mtaup = 1
      If (rtaup>coef(isub,15)) mtaup = 2
      Call pykmap(4, mtaup, rlu(0))
    End If
    Call pyklim(2)
    If (mint(51)/=0) Goto 100
    ryst = rlu(0)
    myst = 1
    If (ryst>coef(isub,7)) myst = 2
    If (ryst>coef(isub,7)+coef(isub,8)) myst = 3
    Call pykmap(2, myst, rlu(0))
    Call pyklim(3)
    If (mint(51)/=0) Goto 100
    If (iset(isub)==2 .Or. iset(isub)==4) Then
      rcth = rlu(0)
      mcth = 1
      If (rcth>coef(isub,10)) mcth = 2
      If (rcth>coef(isub,10)+coef(isub,11)) mcth = 3
      If (rcth>coef(isub,10)+coef(isub,11)+coef(isub,12)) mcth = 4
      If (rcth>coef(isub,10)+coef(isub,11)+coef(isub,12)+coef(isub,13)) mcth = 5
      Call pykmap(3, mcth, rlu(0))
    End If
  Else If (iset(isub)==5) Then
    Call pymult(3)
    isub = mint(1)
  End If
  vint(24) = paru(2)*rlu(0)
  mint(51) = 0
  If (isub<=90 .Or. isub>100) Call pyklim(0)
  If (mint(51)/=0) Goto 100
  If (mint(82)==1 .And. mstp(141)>=1) Then
    mcut = 0
    If (msub(91)+msub(92)+msub(93)+msub(94)+msub(95)==0) Call pykcut(mcut)
    If (mcut/=0) Goto 100
  End If
  Call pysigh(nchn, sigs)
  If (mint(82)==1 .And. isub<=90 .Or. isub>=96) Then
    xsec(isub, 2) = xsec(isub, 2) + sigs
  Else If (mint(82)==1) Then
    xsec(isub, 2) = xsec(isub, 2) + xsec(isub, 1)
  End If
  If (mint(43)==4 .And. mstp(82)>=3) Then
    vint(153) = sigs
    Call pymult(4)
  End If
  viol = sigs/xsec(isub, 1)
  If (viol<rlu(0)) Goto 100
  If (mstp(123)<=0) Then
    If (viol>1.) Then
      Write (mstu(11), 1000) viol, ngen(0, 3) + 1
      Write (mstu(11), 1100) isub, vint(21), vint(22), vint(23), vint(26)
      Stop
    End If
  Else If (mstp(123)==1) Then
    If (viol>vint(108)) Then
      vint(108) = viol
    End If
  Else If (viol>vint(108)) Then
    vint(108) = viol
    If (viol>1.) Then
      xdif = xsec(isub, 1)*(viol-1.)
      xsec(isub, 1) = xsec(isub, 1) + xdif
      If (msub(isub)==1 .And. (isub<=90 .Or. isub>96)) xsec(0, 1) = xsec(0, 1) + xdif
      vint(108) = 1.
    End If
  End If
  vint(148) = 1.
  If (mint(43)==4 .And. (isub<=90 .Or. isub>=96) .And. mstp(82)>=3) Then
    Call pymult(5)
    If (vint(150)<rlu(0)) Goto 100
  End If
  If (mint(82)==1 .And. msub(95)==1) Then
    If (isub<=90 .Or. isub>=95) ngen(95, 1) = ngen(95, 1) + 1
    If (isub<=90 .Or. isub>=96) ngen(96, 2) = ngen(96, 2) + 1
  End If
  If (isub<=90 .Or. isub>=96) mint(31) = mint(31) + 1
  rsigs = sigs*rlu(0)
  qt2 = vint(48)
  rqqbar = parp(87)*(1.-(qt2/(qt2+(parp(88)*parp(82))**2))**2)
  If (isub/=95 .And. (isub/=96 .Or. mstp(82)<=1 .Or. rlu(0)>rqqbar)) Then
    Do ichn = 1, nchn
      kfl1 = isig(ichn, 1)
      kfl2 = isig(ichn, 2)
      mint(2) = isig(ichn, 3)
      rsigs = rsigs - sigh(ichn)
      If (rsigs<=0.) Goto 210
    End Do
  Else If (isub==96) Then
    Call pyspli(mint(11), 21, kfl1, kfldum)
    Call pyspli(mint(12), 21, kfl2, kfldum)
    mint(1) = 11
    mint(2) = 1
    If (kfl1==kfl2 .And. rlu(0)<0.5) mint(2) = 2
  Else
    kfl1 = 21
    kfl2 = 21
    rsigs = 6.*rlu(0)
    mint(2) = 1
    If (rsigs>1.) mint(2) = 2
    If (rsigs>2.) mint(2) = 3
  End If
  210 If (mint(2)>10) Then
    mint(1) = mint(2)/10
    mint(2) = mod(mint(2), 10)
  End If
  mint(15) = kfl1
  mint(16) = kfl2
  mint(13) = mint(15)
  mint(14) = mint(16)
  vint(141) = vint(41)
  vint(142) = vint(42)
  Return
  1000 Format (1X, 'Error: maximum violated by', 1P, E11.3, 1X, 'in event', 1X, I7, '.'/1X, 'Execution stopped!')
  1100 Format (1X, 'ISUB = ', I3, '; Point of violation:'/1X, 'tau=', 1P, E11.3, ', y* =', E11.3, ', cthe = ', 0P, F11.7, ', tau'' =', 1P, E11.3)
End Subroutine pyrand


C     This File is Automatically generated by ALOHA
C     The process calculated in this file is:
C     P(1,2)*P(2,1) - P(-1,1)*P(-1,2)*Metric(1,2)
C
      SUBROUTINE MP_VVS4L2P0_1(P2, S3, COUP, M1, W1, P1, COEFF)
      IMPLICIT NONE
      COMPLEX*32 CI
      PARAMETER (CI=(0Q0,1Q0))
      COMPLEX*32 TMP2
      COMPLEX*32 S3(*)
      REAL*16 M1
      INCLUDE 'coef_specs.inc'
      COMPLEX*32 COEFF(MAXLWFSIZE,0:VERTEXMAXCOEFS-1,MAXLWFSIZE)
      COMPLEX*32 P2(0:3)
      REAL*16 W1
      COMPLEX*32 P1(0:3)
      COMPLEX*32 COUP
      P1(0) = +P2(0)+S3(1)
      P1(1) = +P2(1)+S3(2)
      P1(2) = +P2(2)+S3(3)
      P1(3) = +P2(3)+S3(4)
      TMP2 = (P1(0)*P2(0)-P1(1)*P2(1)-P1(2)*P2(2)-P1(3)*P2(3))
      COEFF(1,0,1)= COUP*S3(5)*(-CI*(TMP2)+CI*(P1(0)*P2(0)))
      COEFF(2,0,1)= COUP*CI * P1(0)*P2(1)*S3(5)
      COEFF(3,0,1)= COUP*CI * P1(0)*P2(2)*S3(5)
      COEFF(4,0,1)= COUP*CI * P1(0)*P2(3)*S3(5)
      COEFF(1,1,1)= 0Q0
      COEFF(2,1,1)= COUP*CI * P2(1)*S3(5)
      COEFF(3,1,1)= COUP*CI * P2(2)*S3(5)
      COEFF(4,1,1)= COUP*CI * P2(3)*S3(5)
      COEFF(1,2,1)= COUP*S3(5)*(+CI*(P2(1)+P1(1)))
      COEFF(2,2,1)= COUP*CI * P1(0)*S3(5)
      COEFF(3,2,1)= 0Q0
      COEFF(4,2,1)= 0Q0
      COEFF(1,3,1)= COUP*S3(5)*(+CI*(P2(2)+P1(2)))
      COEFF(2,3,1)= 0Q0
      COEFF(3,3,1)= COUP*CI * P1(0)*S3(5)
      COEFF(4,3,1)= 0Q0
      COEFF(1,4,1)= COUP*S3(5)*(+CI*(P2(3)+P1(3)))
      COEFF(2,4,1)= 0Q0
      COEFF(3,4,1)= 0Q0
      COEFF(4,4,1)= COUP*CI * P1(0)*S3(5)
      COEFF(1,5,1)= 0Q0
      COEFF(2,5,1)= 0Q0
      COEFF(3,5,1)= 0Q0
      COEFF(4,5,1)= 0Q0
      COEFF(1,6,1)= 0Q0
      COEFF(2,6,1)= COUP*CI * S3(5)
      COEFF(3,6,1)= 0Q0
      COEFF(4,6,1)= 0Q0
      COEFF(1,7,1)= COUP*CI * S3(5)
      COEFF(2,7,1)= 0Q0
      COEFF(3,7,1)= 0Q0
      COEFF(4,7,1)= 0Q0
      COEFF(1,8,1)= 0Q0
      COEFF(2,8,1)= 0Q0
      COEFF(3,8,1)= COUP*CI * S3(5)
      COEFF(4,8,1)= 0Q0
      COEFF(1,9,1)= 0Q0
      COEFF(2,9,1)= 0Q0
      COEFF(3,9,1)= 0Q0
      COEFF(4,9,1)= 0Q0
      COEFF(1,10,1)= COUP*CI * S3(5)
      COEFF(2,10,1)= 0Q0
      COEFF(3,10,1)= 0Q0
      COEFF(4,10,1)= 0Q0
      COEFF(1,11,1)= 0Q0
      COEFF(2,11,1)= 0Q0
      COEFF(3,11,1)= 0Q0
      COEFF(4,11,1)= COUP*CI * S3(5)
      COEFF(1,12,1)= 0Q0
      COEFF(2,12,1)= 0Q0
      COEFF(3,12,1)= 0Q0
      COEFF(4,12,1)= 0Q0
      COEFF(1,13,1)= 0Q0
      COEFF(2,13,1)= 0Q0
      COEFF(3,13,1)= 0Q0
      COEFF(4,13,1)= 0Q0
      COEFF(1,14,1)= COUP*CI * S3(5)
      COEFF(2,14,1)= 0Q0
      COEFF(3,14,1)= 0Q0
      COEFF(4,14,1)= 0Q0
      COEFF(1,0,2)= COUP*-CI * P1(1)*P2(0)*S3(5)
      COEFF(2,0,2)= COUP*-S3(5)*(+CI*(P1(1)*P2(1)+TMP2))
      COEFF(3,0,2)= COUP*-CI * P1(1)*P2(2)*S3(5)
      COEFF(4,0,2)= COUP*-CI * P1(1)*P2(3)*S3(5)
      COEFF(1,1,2)= COUP*-CI * P1(1)*S3(5)
      COEFF(2,1,2)= COUP*-S3(5)*(+CI*(P2(0)+P1(0)))
      COEFF(3,1,2)= 0Q0
      COEFF(4,1,2)= 0Q0
      COEFF(1,2,2)= COUP*-CI * P2(0)*S3(5)
      COEFF(2,2,2)= 0Q0
      COEFF(3,2,2)= COUP*-CI * P2(2)*S3(5)
      COEFF(4,2,2)= COUP*-CI * P2(3)*S3(5)
      COEFF(1,3,2)= 0Q0
      COEFF(2,3,2)= COUP*S3(5)*(+CI*(P2(2)+P1(2)))
      COEFF(3,3,2)= COUP*-CI * P1(1)*S3(5)
      COEFF(4,3,2)= 0Q0
      COEFF(1,4,2)= 0Q0
      COEFF(2,4,2)= COUP*S3(5)*(+CI*(P2(3)+P1(3)))
      COEFF(3,4,2)= 0Q0
      COEFF(4,4,2)= COUP*-CI * P1(1)*S3(5)
      COEFF(1,5,2)= 0Q0
      COEFF(2,5,2)= COUP*-CI * S3(5)
      COEFF(3,5,2)= 0Q0
      COEFF(4,5,2)= 0Q0
      COEFF(1,6,2)= COUP*-CI * S3(5)
      COEFF(2,6,2)= 0Q0
      COEFF(3,6,2)= 0Q0
      COEFF(4,6,2)= 0Q0
      COEFF(1,7,2)= 0Q0
      COEFF(2,7,2)= 0Q0
      COEFF(3,7,2)= 0Q0
      COEFF(4,7,2)= 0Q0
      COEFF(1,8,2)= 0Q0
      COEFF(2,8,2)= 0Q0
      COEFF(3,8,2)= 0Q0
      COEFF(4,8,2)= 0Q0
      COEFF(1,9,2)= 0Q0
      COEFF(2,9,2)= 0Q0
      COEFF(3,9,2)= COUP*-CI * S3(5)
      COEFF(4,9,2)= 0Q0
      COEFF(1,10,2)= 0Q0
      COEFF(2,10,2)= COUP*CI * S3(5)
      COEFF(3,10,2)= 0Q0
      COEFF(4,10,2)= 0Q0
      COEFF(1,11,2)= 0Q0
      COEFF(2,11,2)= 0Q0
      COEFF(3,11,2)= 0Q0
      COEFF(4,11,2)= 0Q0
      COEFF(1,12,2)= 0Q0
      COEFF(2,12,2)= 0Q0
      COEFF(3,12,2)= 0Q0
      COEFF(4,12,2)= COUP*-CI * S3(5)
      COEFF(1,13,2)= 0Q0
      COEFF(2,13,2)= 0Q0
      COEFF(3,13,2)= 0Q0
      COEFF(4,13,2)= 0Q0
      COEFF(1,14,2)= 0Q0
      COEFF(2,14,2)= COUP*CI * S3(5)
      COEFF(3,14,2)= 0Q0
      COEFF(4,14,2)= 0Q0
      COEFF(1,0,3)= COUP*-CI * P1(2)*P2(0)*S3(5)
      COEFF(2,0,3)= COUP*-CI * P1(2)*P2(1)*S3(5)
      COEFF(3,0,3)= COUP*-S3(5)*(+CI*(P1(2)*P2(2)+TMP2))
      COEFF(4,0,3)= COUP*-CI * P1(2)*P2(3)*S3(5)
      COEFF(1,1,3)= COUP*-CI * P1(2)*S3(5)
      COEFF(2,1,3)= 0Q0
      COEFF(3,1,3)= COUP*-S3(5)*(+CI*(P2(0)+P1(0)))
      COEFF(4,1,3)= 0Q0
      COEFF(1,2,3)= 0Q0
      COEFF(2,2,3)= COUP*-CI * P1(2)*S3(5)
      COEFF(3,2,3)= COUP*S3(5)*(+CI*(P2(1)+P1(1)))
      COEFF(4,2,3)= 0Q0
      COEFF(1,3,3)= COUP*-CI * P2(0)*S3(5)
      COEFF(2,3,3)= COUP*-CI * P2(1)*S3(5)
      COEFF(3,3,3)= 0Q0
      COEFF(4,3,3)= COUP*-CI * P2(3)*S3(5)
      COEFF(1,4,3)= 0Q0
      COEFF(2,4,3)= 0Q0
      COEFF(3,4,3)= COUP*S3(5)*(+CI*(P2(3)+P1(3)))
      COEFF(4,4,3)= COUP*-CI * P1(2)*S3(5)
      COEFF(1,5,3)= 0Q0
      COEFF(2,5,3)= 0Q0
      COEFF(3,5,3)= COUP*-CI * S3(5)
      COEFF(4,5,3)= 0Q0
      COEFF(1,6,3)= 0Q0
      COEFF(2,6,3)= 0Q0
      COEFF(3,6,3)= 0Q0
      COEFF(4,6,3)= 0Q0
      COEFF(1,7,3)= 0Q0
      COEFF(2,7,3)= 0Q0
      COEFF(3,7,3)= COUP*CI * S3(5)
      COEFF(4,7,3)= 0Q0
      COEFF(1,8,3)= COUP*-CI * S3(5)
      COEFF(2,8,3)= 0Q0
      COEFF(3,8,3)= 0Q0
      COEFF(4,8,3)= 0Q0
      COEFF(1,9,3)= 0Q0
      COEFF(2,9,3)= COUP*-CI * S3(5)
      COEFF(3,9,3)= 0Q0
      COEFF(4,9,3)= 0Q0
      COEFF(1,10,3)= 0Q0
      COEFF(2,10,3)= 0Q0
      COEFF(3,10,3)= 0Q0
      COEFF(4,10,3)= 0Q0
      COEFF(1,11,3)= 0Q0
      COEFF(2,11,3)= 0Q0
      COEFF(3,11,3)= 0Q0
      COEFF(4,11,3)= 0Q0
      COEFF(1,12,3)= 0Q0
      COEFF(2,12,3)= 0Q0
      COEFF(3,12,3)= 0Q0
      COEFF(4,12,3)= 0Q0
      COEFF(1,13,3)= 0Q0
      COEFF(2,13,3)= 0Q0
      COEFF(3,13,3)= 0Q0
      COEFF(4,13,3)= COUP*-CI * S3(5)
      COEFF(1,14,3)= 0Q0
      COEFF(2,14,3)= 0Q0
      COEFF(3,14,3)= COUP*CI * S3(5)
      COEFF(4,14,3)= 0Q0
      COEFF(1,0,4)= COUP*-CI * P1(3)*P2(0)*S3(5)
      COEFF(2,0,4)= COUP*-CI * P1(3)*P2(1)*S3(5)
      COEFF(3,0,4)= COUP*-CI * P1(3)*P2(2)*S3(5)
      COEFF(4,0,4)= COUP*-S3(5)*(+CI*(P1(3)*P2(3)+TMP2))
      COEFF(1,1,4)= COUP*-CI * P1(3)*S3(5)
      COEFF(2,1,4)= 0Q0
      COEFF(3,1,4)= 0Q0
      COEFF(4,1,4)= COUP*-S3(5)*(+CI*(P2(0)+P1(0)))
      COEFF(1,2,4)= 0Q0
      COEFF(2,2,4)= COUP*-CI * P1(3)*S3(5)
      COEFF(3,2,4)= 0Q0
      COEFF(4,2,4)= COUP*S3(5)*(+CI*(P2(1)+P1(1)))
      COEFF(1,3,4)= 0Q0
      COEFF(2,3,4)= 0Q0
      COEFF(3,3,4)= COUP*-CI * P1(3)*S3(5)
      COEFF(4,3,4)= COUP*S3(5)*(+CI*(P2(2)+P1(2)))
      COEFF(1,4,4)= COUP*-CI * P2(0)*S3(5)
      COEFF(2,4,4)= COUP*-CI * P2(1)*S3(5)
      COEFF(3,4,4)= COUP*-CI * P2(2)*S3(5)
      COEFF(4,4,4)= 0Q0
      COEFF(1,5,4)= 0Q0
      COEFF(2,5,4)= 0Q0
      COEFF(3,5,4)= 0Q0
      COEFF(4,5,4)= COUP*-CI * S3(5)
      COEFF(1,6,4)= 0Q0
      COEFF(2,6,4)= 0Q0
      COEFF(3,6,4)= 0Q0
      COEFF(4,6,4)= 0Q0
      COEFF(1,7,4)= 0Q0
      COEFF(2,7,4)= 0Q0
      COEFF(3,7,4)= 0Q0
      COEFF(4,7,4)= COUP*CI * S3(5)
      COEFF(1,8,4)= 0Q0
      COEFF(2,8,4)= 0Q0
      COEFF(3,8,4)= 0Q0
      COEFF(4,8,4)= 0Q0
      COEFF(1,9,4)= 0Q0
      COEFF(2,9,4)= 0Q0
      COEFF(3,9,4)= 0Q0
      COEFF(4,9,4)= 0Q0
      COEFF(1,10,4)= 0Q0
      COEFF(2,10,4)= 0Q0
      COEFF(3,10,4)= 0Q0
      COEFF(4,10,4)= COUP*CI * S3(5)
      COEFF(1,11,4)= COUP*-CI * S3(5)
      COEFF(2,11,4)= 0Q0
      COEFF(3,11,4)= 0Q0
      COEFF(4,11,4)= 0Q0
      COEFF(1,12,4)= 0Q0
      COEFF(2,12,4)= COUP*-CI * S3(5)
      COEFF(3,12,4)= 0Q0
      COEFF(4,12,4)= 0Q0
      COEFF(1,13,4)= 0Q0
      COEFF(2,13,4)= 0Q0
      COEFF(3,13,4)= COUP*-CI * S3(5)
      COEFF(4,13,4)= 0Q0
      COEFF(1,14,4)= 0Q0
      COEFF(2,14,4)= 0Q0
      COEFF(3,14,4)= 0Q0
      COEFF(4,14,4)= 0Q0
      END