  subroutine cascaw(nel,rn,delta,iret)

! ====================================================================
!
!     Modified: 19-DEC-2003 BY NVM
!     Edited by KKG, May 2007 to include GDR region fot gamma + A
!     interaction below 20 MeV
!     Modified: 09-MAY-2007 BY NVM
!     Modified: 08/24/16 by CMJ to allow GSM use
!     Modified: 05/2018 by CMJ, XCP-3, to correct tallying of fragment
!          data
!
! ====================================================================

    use, intrinsic:: iso_fortran_env, only: int32, real64
    use modifiedDCMClass, only: results
    use standarddcmdata, only: photonEG

!    implicit none
    implicit real(real64) (a-h,o-z), integer(int32) (i-n)
    integer(int32), intent(  out) :: nel
    real(real64),   intent(in   ) :: rn
    real(real64),   intent(in   ) :: delta
    integer(int32), intent(  out) :: iret

    integer(int32), dimension(5) :: ip1, ip2, ip3
    real(real64),   dimension(3) :: v12, ptemp
    real(real64),   dimension(9) :: p1, p2, p3

    integer(int32) :: mv

! ====================================================================

    common/hcasc/anucl1,anucl2,znucl1,znucl2,t0,eps1,eps2,vpi,a1,a2, &
         & c1,c2,d1,d2,r0n1,r0n2,tf01,tf02,rm1,rm2
    common/resultlaq/an1,an2,zn1,zn2,enext1,enext2,pnucl1(3), &
         & pnucl2(3),amnuc1(3),amnuc2(3)
    common/nucsp/vpr(3),vta(3),radp(3),radt(3),vev(3),vre(3),gev,gre, &
         & vep(3),vet(3),gep,get
    common/activ/mpa(300),myp(5999),myt(5999),myy(5999)
    common/center/xc(2,300),yc(2,300),zc(2,300),iz(2,300)
    common/memorylaq/pmemo(9,5999),imemo(5,5999) &
         & /kypt/ kpt,kyp,kyt,kpt1,kyp1,kyt1,kyy,kyy1
    common/jgstar/ jg
    common/nrapi/nrapi
    common/nucoll/ nucoll,mvcoll(5999)
    common/actim/tint
    common/intcc/intcc
    common/intcen/ipo,int1(300),int2(5999),int3(5999), &
         & int4(100000),ijpa,ist,jst,nrst
    common/ipaul/ip
    common/timgo/timgo,minute,itmgo
    common/iprimc/iprimc
    common/idpme/idpme(5999)
    common/mvup/mvu
    common/bimp/bimp,bimx,bimy
    common/ncollt/ ares1,ares2,collt(4)
    common /stin/ stin,amin
    common/geocrs/ sig1,sig2
!  kkg 10/14/03
    common/inttyp/ ityp
    common /ncasca/ ncas,ncpri
    common/bglab/blab,glab,kobr
    common /gbrems/ tgmin, tgmax, teqv, sxabs, ibrems

! ====================================================================

    parameter (zro=0.0d0)

! ====================================================================

    nel=0
    iret=0

9   mvu=0
    nucoll=0
    an1=anucl1
    zn1=znucl1
    an2=anucl2
    zn2=znucl2
    enext1=zro
    enext2=zro
    pnucl1(1)=zro
    pnucl1(2)=zro
    pnucl1(3)=zro
    pnucl2(1)=zro
    pnucl2(2)=zro
    pnucl2(3)=zro
    amnuc1(1)=zro
    amnuc1(2)=zro
    amnuc1(3)=zro
    amnuc2(1)=zro
    amnuc2(2)=zro
    amnuc2(3)=zro
    tint=zro
    mv=0
    kpt=0
    kyp=0
    kyt=0
    kyy=0
    kpt1=0
    kyp1=0
    kyt1=0
    kyy1=0
    results%projExc%numTotal=0
    results%targExc%numTotal=zro
    results%projExc%numProtons=zro
    results%targExc%numProtons=zro
    results%projExc%numHoles=zro
    results%targExc%numHoles=zro
    do l=1,300
       mpa(l)=1
    end do

    call pinpnq(rn,r0x,r0y,r0z,mv,delta,nel)
    obr1=zro
    if(rm1 > 0.1d0) obr1=0.00144d0*zn1/rm1
    obr2=zro
    if(rm2 > 0.1d0) obr2=0.00144d0*zn2/rm2
    call  vinit(vpr,vta,anucl1,anucl2,t0)
    radp(1)=r0x
    radp(2)=r0y
    radp(3)=r0z
    radt(1)=zro
    radt(2)=zro
    radt(3)=zro

!  extension  to Egamma < 20 MeV
    if(amin < 0.0001d0.and.t0 < 0.020d0)  then
       t0mev = t0*1000.d0
       sgabs = photoneg%photocrosssection(t0mev, anucl2)
       pint = sgabs/sig1
       if(rndm(-1.0_real64) > pint)  then
          go  to  21
       else
          an2=anucl2
          zn2=znucl2
          enext2 = t0
          pnucl2(1)=zro
          pnucl2(2)=zro
          pnucl2(3)= t0
          amnuc2(1)=1.0d0
          amnuc2(2)=zro
          amnuc2(3)=zro
          results%targExc%numHoles = 1.0d0
          results%targExc%numTotal = 1.0d0
          results%targExc%numProtons = zro
          if(rndm(-1.0_real64) <= (znucl2/anucl2)) results%targExc%numProtons = 1.0d0
          if(ibrems == 1)  then
             teqv = teqv + t0
             sxabs = sxabs + sgabs
          endif
          return
       endif
    endif
!
    ip=-1
    ijpa=0
11  na1=an1+0.1d0
    na2=an2+0.1d0
!  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    if(na1 >= 1.and.na2 >= 1)  then    !
       do  l=1,na1                     !
          mpa(l)=1                      !
       enddo                           !
    endif
!   kkg 11/05/03                             !
    if(mv >= 1.and.nucoll.ne.0)   then ! 05.09.97
       do  l=1,mv                      !
          if(na1 >= 1)  myp(l)=1        !
          if(na2 >= 1)  myt(l)=1        !
          if(iabs(idpme(l)) <= 20) then !
             myp(l)=0        !
             myt(l)=0        !
             myy(l)=0        !
          endif                         !
       enddo                           !
    endif                              !
!  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    iprimc=0
! NVM:      call  stopgu(timgo,istop)
! NVM:      if(istop.ne.0)   iret=1
! NVM:      if(istop.ne.0)   return
!      CALL  UPACOW(MV,MVU,0)
    call  upacow(mv,mvu,0)
    call  dissip(ip,t0)
!
! if(NCAS > NCPRI) then
!       write(16,*) ' NCAS,AN1,AN2,ZN1,ZN2,ENEXT1,ENEXT2=',
!    &                NCAS,AN1,AN2,ZN1,ZN2,ENEXT1,ENEXT2
!       write( *,*) ' NCAS,AN1,AN2,ZN1,ZN2,ENEXT1,ENEXT2=',
!    &                NCAS,AN1,AN2,ZN1,ZN2,ENEXT1,ENEXT2
!       endif
!
    call pointn(m,p1,p2,ip1,ip2,v12,u12,t12,sig,sab,tint,nr,n1,n2, &
         & na1,na2,mv,delta,r0x,r0y,r0z)
    ntry=0
    if(m)   203,203,12
203 if(mv == 0)   go  to  205
!----> do  204  l=1,mv
    do   l=1,mv
       myp(l)=0
       myt(l)=0
       myy(l)=0
204    continue
    end do
205 continue
!  kkg 17.06.02
!     IF(MV == 0.and.AN2 == ANUCL2.and.ZN2 == ZNUCL2.and.
!    &   ENEXT2 < 0.001)  GO  TO  21
    if(enext2 < 1.d-7)  go  to  21
!      CALL  UPACOW(MV,MVU,1)
    call  upacow(mv,mvu,1)
    mv=mvu
    go  to  20
12  go  to  (13,14,13,112,15),nr
13  nu=2
    go to 15
14  nu=1
15  continue
    ntry=ntry+1
!  kkg  09/05/08
    call typnew(p1,ip1,p2,ip2,v12,u12,t12,sab,mv,np,nabs, &
         & p3,ip3,n3,nu,n2,na1,na2,iret)
    if(iret == 1)   go  to  11
!
    nrapi=nr
!
!
    ip=0
!  kkg 10/14/03
    if(ityp == 0)  go  to  11
!
    if(np)11,11,16
16  go to  (17,18,19,112,113),nr
17  continue
!
    call pauli1(p1,p2,ip1,ip2,n1,n2,v12,np,mv,tint,ip, results)
!
    kpt1=kpt1+ip
    kpt=kpt+1
    go  to  11
18  continue
!
    call pauli2(p1,p2,p3,ip1,ip2,ip3,n1,n2,n3,v12,np,mv,tint, &
         & ip,obr1, results)
!
    kyp1=kyp1+ip
    kyp=kyp+1
    go  to  11
19  continue
    if(anucl1 < 1.1d0.and.nucoll <= 1) iprimc=1
!
    call pauli3(p1,p2,p3,ip1,ip2,ip3,n1,n2,n3,v12,np,mv,tint, &
         & ip,obr2, results)
!
    kyt1=kyt1+ip
    kyt=kyt+1
    go  to  11
112 call  decren(n1,nur,mv,np)
!----> do 213 l=1,9
    do l=1,9
       p1(l)=pmemo(l,n1)
       if(l <= 5)  ip1(l)=imemo(l,n1)
213    continue
    end do
    call  paulid(mv,n1,nur,1,np,ip)
    go  to  11
113 continue
!
    call pauli4(p1,p2,ip1,ip2,n1,n2,v12,np,mv,tint,ip)
!
    kyy1=kyy1+ip
    kyy=kyy+1
!
    go  to  11
!  kkg 17.06.02
20  continue
!  kkg  18/04/03
    if(anucl1 >= 0.9d0)  then
       exmax2=anucl1*(t0+eps2)
    else
       exmax2=t0+amin
    endif
    exmin=0.0001d0
    if((an1 < zn1.or.zn1 < zro.or.enext1 < zro).or. &
         & (an2 < zn2.or.zn2 < zro.or.enext2 < exmin).or. &
         & (enext2 > exmax2)) then
!         write(*,*) 'AN1,ZN1,AN2,ZN2,ENEXT1,ENEXT2=',
!     &               AN1,ZN1,AN2,ZN2,ENEXT1,ENEXT2
       iret=1
       return
    else
       go  to  22
    endif
!  kkg  17.06.02
21  nel=nel+1
    go to 9
!----> do 23 l=1,3
22  do l=1,3
       amnuc1(l)=amnuc1(l)*5.06d0
23     amnuc2(l)=amnuc2(l)*5.06d0
    end do
!   kkg 12/10/04
    if(amin < 0.0001d0.and.ibrems == 1)  then   ! bremss. gamma
       teqv = teqv + t0
    endif
    if(anucl1-2.1d0)  24,26,26
26  am1=.94d0*an1
    call cinema(pnucl1,vpr,ptemp,ct,st,cf,sf,ttemp,am1)
    pnucl1(1)=ptemp(1)
    pnucl1(2)=ptemp(2)
    pnucl1(3)=ptemp(3)
!  kkg 07/13/04
    if(kobr == 1)  then
       pnucl1(3)=-glab*(pnucl1(3)-blab*(ttemp+am1))
    endif
24  continue
    if(anucl2 < 2.1d0)   go  to  27
    am2=.94d0*an2
    call cinema(pnucl2,vta,ptemp,ct,st,cf,sf,ttemp,am2)
    pnucl2(1)=ptemp(1)
    pnucl2(2)=ptemp(2)
    pnucl2(3)=ptemp(3)
!  kkg 07/13/04
    if(kobr == 1)  then
       pnucl2(3)=-glab*(pnucl2(3)-blab*(ttemp+am2))
    endif
27  continue
    collt(1)=collt(1)+kpt1
    collt(2)=collt(2)+kyp1
    collt(3)=collt(3)+kyt1
    collt(4)=collt(4)+kyy1
    ares1=ares1+an1
    ares2=ares2+an2

    if(ncas > ncpri) then
       write(*,*) ' cascaw: ncas,an1,an2,zn1,zn2,enext1,enext2=', &
            & ncas,an1,an2,zn1,zn2,enext1,enext2
       return
    endif

    return
! ====================================================================
  end subroutine cascaw


! THIS VERSION: GALAHAD 2.1 - 22/03/2007 AT 09:00 GMT.

!-*-*-*-*-*-*-*-*-*-  G A L A H A D _ Q P D  M O D U L E  -*-*-*-*-*-*-*-*-*-*-

!  Copyright reserved, Gould/Orban/Toint, for GALAHAD productions
!  Principal author: Nick Gould

!  History -
!   originally released with GALAHAD Version 2.0. August 10th 2005

!  For full documentation, see
!   http://galahad.rl.ac.uk/galahad-www/specs.html

!     -----------------------------------------------------
!     | Provides a generic derived type to hold and share |
!     | private data between the GALAHAD QP packages      |
!     |      NOT INTENDED FOR PUBLIC CONSUMPTION          |
!     -----------------------------------------------------

   MODULE GALAHAD_QPD_double

     USE GALAHAD_RAND_double, ONLY : RAND_seed
     USE GALAHAD_SILS_double, ONLY : SILS_factors, SILS_control,               &
                                     SILS_ainfo, SILS_finfo, SMT_type
     USE GALAHAD_SBLS_double, ONLY: SBLS_data_type
     USE GALAHAD_SCU_double, ONLY : SCU_matrix_type, SCU_info_type, SCU_data_type
     USE GALAHAD_QPP_double, QPD_dims_type => QPP_dims_type

     IMPLICIT NONE

     PRIVATE
     PUBLIC :: QPD_HX, QPD_AX

!--------------------
!   P r e c i s i o n
!--------------------

     INTEGER, PARAMETER :: wp = KIND( 1.0D+0 )

!  ==============================
!  The QPD_data_type derived type
!  ==============================

     TYPE, PUBLIC :: QPD_data_type

! -----------------
!  Scalar componets
! -----------------

!  Common scalar components

       INTEGER :: start_print, stop_print
       LOGICAL :: new_problem_structure

!  QPA scalar components

       INTEGER :: prec_hist
       LOGICAL :: auto_prec, auto_fact

!  QPB/LSQP scalar components

       INTEGER :: trans, remove_more_deps
       LOGICAL :: tried_to_remove_deps, save_structure

! -----------------------
!  Allocatable components
! -----------------------

!  Common allocatable components

       INTEGER, ALLOCATABLE, DIMENSION( : ) :: Abycol_row
       INTEGER, ALLOCATABLE, DIMENSION( : ) :: Abycol_ptr
       REAL ( KIND = wp ), ALLOCATABLE, DIMENSION( : ) :: Abycol_val
       REAL ( KIND = wp ), ALLOCATABLE, DIMENSION( : ) :: RES
       REAL ( KIND = wp ), ALLOCATABLE, DIMENSION( : ) :: RHS
       REAL ( KIND = wp ), ALLOCATABLE, DIMENSION( : ) :: H_s
       REAL ( KIND = wp ), ALLOCATABLE, DIMENSION( : ) :: A_s

!  QPA & QPB allocatable components

       REAL ( KIND = wp ), ALLOCATABLE, DIMENSION( : ) :: S
       REAL ( KIND = wp ), ALLOCATABLE, DIMENSION( : ) :: GRAD

!  QPA & LSQP allocatable components

       INTEGER, ALLOCATABLE, DIMENSION( : ) :: IBREAK
       REAL ( KIND = wp ), ALLOCATABLE, DIMENSION( : ) :: BREAKP

!  QPB & LSQP allocatable components

       INTEGER, ALLOCATABLE, DIMENSION( : ) :: IW
       INTEGER, ALLOCATABLE, DIMENSION( : ) :: K_colptr
       INTEGER, ALLOCATABLE, DIMENSION( : ) :: Index_C_freed
       INTEGER, ALLOCATABLE, DIMENSION( : ) :: Index_C_more_freed
       REAL ( KIND = wp ), ALLOCATABLE, DIMENSION( : ) :: RES_x
       REAL ( KIND = wp ), ALLOCATABLE, DIMENSION( : ) :: SOL_y
       REAL ( KIND = wp ), ALLOCATABLE, DIMENSION( : ) :: RES_y
       REAL ( KIND = wp ), ALLOCATABLE, DIMENSION( : ) :: BEST_y
       REAL ( KIND = wp ), ALLOCATABLE, DIMENSION( : ) :: SOL
       REAL ( KIND = wp ), ALLOCATABLE, DIMENSION( : ) :: BEST
       REAL ( KIND = wp ), ALLOCATABLE, DIMENSION( : ) :: HX
       REAL ( KIND = wp ), ALLOCATABLE, DIMENSION( : ) :: GRAD_L
       REAL ( KIND = wp ), ALLOCATABLE, DIMENSION( : ) :: X_trial
       REAL ( KIND = wp ), ALLOCATABLE, DIMENSION( : ) :: DIST_X_l
       REAL ( KIND = wp ), ALLOCATABLE, DIMENSION( : ) :: DIST_X_u
       REAL ( KIND = wp ), ALLOCATABLE, DIMENSION( : ) :: Z_l
       REAL ( KIND = wp ), ALLOCATABLE, DIMENSION( : ) :: Z_u
       REAL ( KIND = wp ), ALLOCATABLE, DIMENSION( : ) :: BARRIER_X
       REAL ( KIND = wp ), ALLOCATABLE, DIMENSION( : ) :: Y_l
       REAL ( KIND = wp ), ALLOCATABLE, DIMENSION( : ) :: DY_l
       REAL ( KIND = wp ), ALLOCATABLE, DIMENSION( : ) :: DIST_C_l
       REAL ( KIND = wp ), ALLOCATABLE, DIMENSION( : ) :: Y_u
       REAL ( KIND = wp ), ALLOCATABLE, DIMENSION( : ) :: DY_u
       REAL ( KIND = wp ), ALLOCATABLE, DIMENSION( : ) :: DIST_C_u
       REAL ( KIND = wp ), ALLOCATABLE, DIMENSION( : ) :: C
       REAL ( KIND = wp ), ALLOCATABLE, DIMENSION( : ) :: BARRIER_C
       REAL ( KIND = wp ), ALLOCATABLE, DIMENSION( : ) :: SCALE_C
       REAL ( KIND = wp ), ALLOCATABLE, DIMENSION( : ) :: DELTA
       REAL ( KIND = wp ), ALLOCATABLE, DIMENSION( : ) :: DZ_l
       REAL ( KIND = wp ), ALLOCATABLE, DIMENSION( : ) :: DZ_u
       REAL ( KIND = wp ), ALLOCATABLE, DIMENSION( : ) :: X0
       REAL ( KIND = wp ), ALLOCATABLE, DIMENSION( : ) :: DIAG_X
       REAL ( KIND = wp ), ALLOCATABLE, DIMENSION( : ) :: DIAG_C
       REAL ( KIND = wp ), ALLOCATABLE, DIMENSION( : ) :: C_freed
       REAL ( KIND = wp ), ALLOCATABLE, DIMENSION( : ) :: C_more_freed
       REAL ( KIND = wp ), ALLOCATABLE, DIMENSION( : ) :: Y_last
       REAL ( KIND = wp ), ALLOCATABLE, DIMENSION( : ) :: Z_last

!  LPB allocatable components

       REAL ( KIND = wp ), ALLOCATABLE, DIMENSION( : ) :: X_last

!  QPA allocatable components

       INTEGER, ALLOCATABLE, DIMENSION( : ) :: SC
       INTEGER, ALLOCATABLE, DIMENSION( : ) :: REF
       INTEGER, ALLOCATABLE, DIMENSION( : ) :: C_up_or_low
       INTEGER, ALLOCATABLE, DIMENSION( : ) :: X_up_or_low
       INTEGER, ALLOCATABLE, DIMENSION( : ) :: PERM
       INTEGER, ALLOCATABLE, DIMENSION( : ) :: S_row
       INTEGER, ALLOCATABLE, DIMENSION( : ) :: S_col
       INTEGER, ALLOCATABLE, DIMENSION( : ) :: S_colptr
       REAL ( KIND = wp ), ALLOCATABLE, DIMENSION( : ) :: RES_l
       REAL ( KIND = wp ), ALLOCATABLE, DIMENSION( : ) :: RES_u
       REAL ( KIND = wp ), ALLOCATABLE, DIMENSION( : ) :: A_norms
       REAL ( KIND = wp ), ALLOCATABLE, DIMENSION( : ) :: PERT
       REAL ( KIND = wp ), ALLOCATABLE, DIMENSION( : ) :: VECTOR
       REAL ( KIND = wp ), ALLOCATABLE, DIMENSION( : ) :: B
       REAL ( KIND = wp ), ALLOCATABLE, DIMENSION( : ) :: S_perm
       REAL ( KIND = wp ), ALLOCATABLE, DIMENSION( : ) :: DX
       REAL ( KIND = wp ), ALLOCATABLE, DIMENSION( : ) :: R_pcg
       REAL ( KIND = wp ), ALLOCATABLE, DIMENSION( : ) :: X_pcg
       REAL ( KIND = wp ), ALLOCATABLE, DIMENSION( : ) :: P_pcg
       REAL ( KIND = wp ), ALLOCATABLE, DIMENSION( : ) :: S_val
       REAL ( KIND = wp ), ALLOCATABLE, DIMENSION( : ) :: RES_print
       REAL ( KIND = wp ), ALLOCATABLE, DIMENSION( : , : ) :: DIAG

!  QPB allocatable components

       INTEGER, ALLOCATABLE, DIMENSION( : ) :: Index_X_fixed
       INTEGER, ALLOCATABLE, DIMENSION( : ) :: Index_C_fixed
       INTEGER, ALLOCATABLE, DIMENSION( : ) :: H_band_ptr
       REAL ( KIND = wp ), ALLOCATABLE, DIMENSION( : ) :: X_fixed
       REAL ( KIND = wp ), ALLOCATABLE, DIMENSION( : ) :: C_fixed
       REAL ( KIND = wp ), ALLOCATABLE, DIMENSION( : ) :: GRAD_X_phi
       REAL ( KIND = wp ), ALLOCATABLE, DIMENSION( : ) :: GRAD_C_phi

!  LSQP and WPC allocatable components

       REAL ( KIND = wp ), ALLOCATABLE, DIMENSION( : ) :: COEF0
       REAL ( KIND = wp ), ALLOCATABLE, DIMENSION( : ) :: COEF1
       REAL ( KIND = wp ), ALLOCATABLE, DIMENSION( : ) :: COEF2
       REAL ( KIND = wp ), ALLOCATABLE, DIMENSION( : ) :: COEF3
       REAL ( KIND = wp ), ALLOCATABLE, DIMENSION( : ) :: COEF4
       REAL ( KIND = wp ), ALLOCATABLE, DIMENSION( : ) :: DELTA_cor
       REAL ( KIND = wp ), ALLOCATABLE, DIMENSION( : ) :: DZ_cor_l
       REAL ( KIND = wp ), ALLOCATABLE, DIMENSION( : ) :: DZ_cor_u
       REAL ( KIND = wp ), ALLOCATABLE, DIMENSION( : ) :: DY_cor_l
       REAL ( KIND = wp ), ALLOCATABLE, DIMENSION( : ) :: DY_cor_u

!  WPC allocatable components

       REAL ( KIND = wp ), ALLOCATABLE, DIMENSION( : ) :: Y
       REAL ( KIND = wp ), ALLOCATABLE, DIMENSION( : ) :: PERTURB_X_l
       REAL ( KIND = wp ), ALLOCATABLE, DIMENSION( : ) :: PERTURB_X_u
       REAL ( KIND = wp ), ALLOCATABLE, DIMENSION( : ) :: PERTURB_Y_l
       REAL ( KIND = wp ), ALLOCATABLE, DIMENSION( : ) :: PERTURB_Y_u
       REAL ( KIND = wp ), ALLOCATABLE, DIMENSION( : ) :: PERTURB_Z_l
       REAL ( KIND = wp ), ALLOCATABLE, DIMENSION( : ) :: PERTURB_Z_u
       REAL ( KIND = wp ), ALLOCATABLE, DIMENSION( : ) :: PERTURB_C_l
       REAL ( KIND = wp ), ALLOCATABLE, DIMENSION( : ) :: PERTURB_C_u
       REAL ( KIND = wp ), ALLOCATABLE, DIMENSION( : ) :: DIST_Y_l
       REAL ( KIND = wp ), ALLOCATABLE, DIMENSION( : ) :: DIST_Y_u
       REAL ( KIND = wp ), ALLOCATABLE, DIMENSION( : ) :: DIST_Z_l
       REAL ( KIND = wp ), ALLOCATABLE, DIMENSION( : ) :: DIST_Z_u
       REAL ( KIND = wp ), ALLOCATABLE, DIMENSION( : ) :: MU_X_l
       REAL ( KIND = wp ), ALLOCATABLE, DIMENSION( : ) :: MU_X_U
       REAL ( KIND = wp ), ALLOCATABLE, DIMENSION( : ) :: MU_C_L
       REAL ( KIND = wp ), ALLOCATABLE, DIMENSION( : ) :: MU_C_U
       REAL ( KIND = wp ), ALLOCATABLE, DIMENSION( : ) :: MU

! -----------------------
!  Derived type componets
! -----------------------

!  Common derived type components

       TYPE ( QPD_dims_type ) :: dims
       TYPE ( SMT_type ) :: K, H_sub, A_sub, C_sub
       TYPE ( SILS_factors ) :: FACTORS
       TYPE ( SILS_control ) :: CNTL
       TYPE ( QPP_control_type ) :: QPP_control
       TYPE ( QPP_inform_type ) :: QPP_inform
       TYPE ( QPP_map_type ) :: QPP_map

!  LSQP derived type components

       TYPE ( QPP_map_type ) :: QPP_map_fixed, QPP_map_freed
       TYPE ( QPP_map_type ) :: QPP_map_more_freed
       TYPE ( QPD_dims_type ) :: dims_save_fixed, dims_save_freed
       TYPE ( QPD_dims_type ) :: dims_save_more_freed

!  QPA derived type components

       TYPE ( RAND_seed ) :: seed
       TYPE ( SILS_control ) :: CNTLA
       TYPE ( SILS_ainfo ) :: AINFO
       TYPE ( SILS_finfo ) :: FINFO
       TYPE ( SCU_matrix_type ) :: SCU_mat
       TYPE ( SCU_info_type ) :: SCU_info
       TYPE ( SCU_data_type ) :: SCU_data

!  SBLS derived type components

       TYPE ( SBLS_data_type ) :: SBLS_data

     END TYPE

! -------------------------------------------
!  Subroutines shared between the QP packages
! -------------------------------------------

   CONTAINS

!-*-*-*-*-*-*-*-*-*-*-   Q P D _ H X  S U B R O U T I N E  -*-*-*-*-*-*-*-*-*-

      SUBROUTINE QPD_HX( dims, n, R, H_ne, H_val, H_col, H_ptr, X, op,          &
                         semibw, H_band_ptr )

! =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-

!      ............................................
!      .                                          .
!      .  Perform the operation r := r op H * x   .
!         where op is + or -                      .
!      ............................................

!  Arguments:
!  =========
!
!   dims    see module GALAHAD_QPP
!   H_*     sparse storage by rows or band
!   X       the vector x
!   R       the result of adding H * x to r
!   semibw  if present, only those entries within a band of semi-bandwidth
!           semibw will be accessed
!   op      character string "+" or "-"

! =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-

!  Dummy arguments

      TYPE ( QPD_dims_type ), INTENT( IN ) :: dims
      INTEGER, INTENT( IN ) :: n, H_ne
      INTEGER, OPTIONAL, INTENT( IN ) :: semibw
      CHARACTER( LEN = 1 ), INTENT( IN ) :: op
      INTEGER, INTENT( IN ), DIMENSION( n + 1 ) :: H_ptr
      INTEGER, INTENT( IN ), OPTIONAL, DIMENSION( n ) :: H_band_ptr
      INTEGER, INTENT( IN ), DIMENSION( H_ne ) ::  H_col
      REAL ( KIND = wp ), INTENT( IN ), DIMENSION( n ) :: X
      REAL ( KIND = wp ), INTENT( IN ), DIMENSION( H_ne ) :: H_val
      REAL ( KIND = wp ), INTENT( INOUT ), DIMENSION( n ) :: R

!  Local variables

      INTEGER :: hd_start, hd_end, hnd_start, hnd_end, i, j, l, type
      REAL ( KIND = wp ) :: xi, ri

!  For a banded portion of H

      IF ( PRESENT( semibw ) ) THEN

        IF ( op( 1 : 1 ) == '+' ) THEN

!  r <- r + H * x (commented out since it is not used at present)

!         DO type = 1, 6

!           SELECT CASE( type )
!           CASE ( 1 )

!             hd_start  = 1
!             hd_end    = dims%h_diag_end_free
!             hnd_start = hd_end + 1
!             hnd_end   = dims%x_free

!           CASE ( 2 )

!             hd_start  = dims%x_free + 1
!             hd_end    = dims%h_diag_end_nonneg
!             hnd_start = hd_end + 1
!             hnd_end   = dims%x_l_start - 1

!           CASE ( 3 )

!             hd_start  = dims%x_l_start
!             hd_end    = dims%h_diag_end_lower
!             hnd_start = hd_end + 1
!             hnd_end   = dims%x_u_start - 1

!           CASE ( 4 )

!             hd_start  = dims%x_u_start
!             hd_end    = dims%h_diag_end_range
!             hnd_start = hd_end + 1
!             hnd_end   = dims%x_l_end

!           CASE ( 5 )

!             hd_start  = dims%x_l_end + 1
!             hd_end    = dims%h_diag_end_upper
!             hnd_start = hd_end + 1
!             hnd_end   = dims%x_u_end

!           CASE ( 6 )

!             hd_start  = dims%x_u_end + 1
!             hd_end    = dims%h_diag_end_nonpos
!             hnd_start = hd_end + 1
!             hnd_end   = n

!           END SELECT

!  rows with a diagonal entry

!           hd_end = MIN( hd_end, n )
!           DO i = hd_start, hd_end
!             DO l = H_band_ptr( i ), H_ptr( i + 1 ) - 2
!               j = H_col( l )
!               R( j ) = R( j ) + H_val( l ) * X( i )
!               R( i ) = R( i ) + H_val( l ) * X( j )
!             END DO
!             R( i ) = R( i ) + H_val( H_ptr( i + 1 ) - 1 ) * X( i )
!           END DO
!           IF ( hd_end == n ) EXIT

!  rows without a diagonal entry

!           hnd_end = MIN( hnd_end, n )
!           DO i = hnd_start, hnd_end
!             DO l = H_band_ptr( i ), H_ptr( i + 1 ) - 1
!               j = H_col( l )
!               R( j ) = R( j ) + H_val( l ) * X( i )
!               R( i ) = R( i ) + H_val( l ) * X( j )
!             END DO
!           END DO
!           IF ( hnd_end == n ) EXIT

!         END DO
        ELSE

!  r <- r - H * x

          DO type = 1, 6

            SELECT CASE( type )
            CASE ( 1 )

              hd_start  = 1
              hd_end    = dims%h_diag_end_free
              hnd_start = hd_end + 1
              hnd_end   = dims%x_free

            CASE ( 2 )

              hd_start  = dims%x_free + 1
              hd_end    = dims%h_diag_end_nonneg
              hnd_start = hd_end + 1
              hnd_end   = dims%x_l_start - 1

            CASE ( 3 )

              hd_start  = dims%x_l_start
              hd_end    = dims%h_diag_end_lower
              hnd_start = hd_end + 1
              hnd_end   = dims%x_u_start - 1

            CASE ( 4 )

              hd_start  = dims%x_u_start
              hd_end    = dims%h_diag_end_range
              hnd_start = hd_end + 1
              hnd_end   = dims%x_l_end

            CASE ( 5 )

              hd_start  = dims%x_l_end + 1
              hd_end    = dims%h_diag_end_upper
              hnd_start = hd_end + 1
              hnd_end   = dims%x_u_end

            CASE ( 6 )

              hd_start  = dims%x_u_end + 1
              hd_end    = dims%h_diag_end_nonpos
              hnd_start = hd_end + 1
              hnd_end   = n

            END SELECT

!  rows with a diagonal entry

            hd_end = MIN( hd_end, n )
            DO i = hd_start, hd_end
              xi = X( i )
              ri = R( i )
              DO l = H_band_ptr( i ), H_ptr( i + 1 ) - 2
                j = H_col( l )
                R( j ) = R( j ) - H_val( l ) * xi
                ri = ri - H_val( l ) * X( j )
              END DO
              R( i ) = ri - H_val( H_ptr( i + 1 ) - 1 ) * xi
            END DO
            IF ( hd_end == n ) EXIT

!  rows without a diagonal entry

            hnd_end = MIN( hnd_end, n )
            DO i = hnd_start, hnd_end
              xi = X( i )
              ri = R( i )
              DO l = H_band_ptr( i ), H_ptr( i + 1 ) - 1
                j = H_col( l )
                R( j ) = R( j ) - H_val( l ) * xi
                ri = ri - H_val( l ) * X( j )
              END DO
              R( i ) = ri
            END DO
            IF ( hnd_end == n ) EXIT

          END DO
        END IF

!  For the whole of H

      ELSE
        IF ( op( 1 : 1 ) == '+' ) THEN

!  r <- r + H * x

          DO type = 1, 6

            SELECT CASE( type )
            CASE ( 1 )

              hd_start  = 1
              hd_end    = dims%h_diag_end_free
              hnd_start = hd_end + 1
              hnd_end   = dims%x_free

            CASE ( 2 )

              hd_start  = dims%x_free + 1
              hd_end    = dims%h_diag_end_nonneg
              hnd_start = hd_end + 1
              hnd_end   = dims%x_l_start - 1

            CASE ( 3 )

              hd_start  = dims%x_l_start
              hd_end    = dims%h_diag_end_lower
              hnd_start = hd_end + 1
              hnd_end   = dims%x_u_start - 1

            CASE ( 4 )

              hd_start  = dims%x_u_start
              hd_end    = dims%h_diag_end_range
              hnd_start = hd_end + 1
              hnd_end   = dims%x_l_end

            CASE ( 5 )

              hd_start  = dims%x_l_end + 1
              hd_end    = dims%h_diag_end_upper
              hnd_start = hd_end + 1
              hnd_end   = dims%x_u_end

            CASE ( 6 )

              hd_start  = dims%x_u_end + 1
              hd_end    = dims%h_diag_end_nonpos
              hnd_start = hd_end + 1
              hnd_end   = n

            END SELECT

!  rows with a diagonal entry

            hd_end = MIN( hd_end, n )
            DO i = hd_start, hd_end
              xi = X( i )
              ri = R( i )
              DO l = H_ptr( i ), H_ptr( i + 1 ) - 2
                j = H_col( l )
                R( j ) = R( j ) + H_val( l ) * xi
                ri = ri + H_val( l ) * X( j )
              END DO
              R( i ) = ri + H_val( H_ptr( i + 1 ) - 1 ) * xi
            END DO
            IF ( hd_end == n ) EXIT

!  rows without a diagonal entry

            hnd_end = MIN( hnd_end, n )
            DO i = hnd_start, hnd_end
              xi = X( i )
              ri = R( i )
              DO l = H_ptr( i ), H_ptr( i + 1 ) - 1
                j = H_col( l )
                R( j ) = R( j ) + H_val( l ) * xi
                ri = ri + H_val( l ) * X( j )
              END DO
              R( i ) = ri
            END DO
            IF ( hnd_end == n ) EXIT

          END DO
        ELSE

!  r <- r - H * x

          DO type = 1, 6

            SELECT CASE( type )
            CASE ( 1 )

              hd_start  = 1
              hd_end    = dims%h_diag_end_free
              hnd_start = hd_end + 1
              hnd_end   = dims%x_free

            CASE ( 2 )

              hd_start  = dims%x_free + 1
              hd_end    = dims%h_diag_end_nonneg
              hnd_start = hd_end + 1
              hnd_end   = dims%x_l_start - 1

            CASE ( 3 )

              hd_start  = dims%x_l_start
              hd_end    = dims%h_diag_end_lower
              hnd_start = hd_end + 1
              hnd_end   = dims%x_u_start - 1

            CASE ( 4 )

              hd_start  = dims%x_u_start
              hd_end    = dims%h_diag_end_range
              hnd_start = hd_end + 1
              hnd_end   = dims%x_l_end

            CASE ( 5 )

              hd_start  = dims%x_l_end + 1
              hd_end    = dims%h_diag_end_upper
              hnd_start = hd_end + 1
              hnd_end   = dims%x_u_end

            CASE ( 6 )

              hd_start  = dims%x_u_end + 1
              hd_end    = dims%h_diag_end_nonpos
              hnd_start = hd_end + 1
              hnd_end   = n

            END SELECT

!  rows with a diagonal entry

            hd_end = MIN( hd_end, n )
            DO i = hd_start, hd_end
              xi = X( i )
              ri = R( i )
              DO l = H_ptr( i ), H_ptr( i + 1 ) - 2
                j = H_col( l )
                R( j ) = R( j ) - H_val( l ) * xi
                ri = ri - H_val( l ) * X( j )
              END DO
              R( i ) = ri - H_val( H_ptr( i + 1 ) - 1 ) * xi
            END DO
            IF ( hd_end == n ) EXIT

!  rows without a diagonal entry

            hnd_end = MIN( hnd_end, n )
            DO i = hnd_start, hnd_end
              xi = X( i )
              ri = R( i )
              DO l = H_ptr( i ), H_ptr( i + 1 ) - 1
                j = H_col( l )
                R( j ) = R( j ) - H_val( l ) * xi
                ri = ri - H_val( l ) * X( j )
              END DO
              R( i ) = ri
            END DO
            IF ( hnd_end == n ) EXIT

          END DO
        END IF
      END IF
      RETURN

!  End of subroutine QPD_HX

      END SUBROUTINE QPD_HX

!-*-*-*-*-*-*-*-*-*-*-   Q P D _ A x  S U B R O U T I N E  -*-*-*-*-*-*-*-*-

      SUBROUTINE QPD_AX( dim_r, R, m, A_ne, A_val, A_col, A_ptr, dim_x, X, op )

! =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-

!      ..............................................
!      .                                            .
!      .  Perform the operation r := r +/- A * x    .
!      .                     or r := r +/- A^T * x  .
!      .                                            .
!      ..............................................

!  Arguments:
!  =========

!   R      the result r of adding/subtracting A * x or A^T *x to/from r
!   X      the vector x
!   op     2 string character: possible values are
!          '+ '   r <- r + A * x
!          '+T'   r <- r + A^T * x
!          '- '   r <- r - A * x
!          '-T'   r <- r - A^T * x

! =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-

!  Dummy arguments

      INTEGER, INTENT( IN ) :: dim_x, dim_r, m, A_ne
      CHARACTER( LEN = 2 ), INTENT( IN ) :: op
      INTEGER, INTENT( IN ), DIMENSION( m + 1 ) :: A_ptr
      INTEGER, INTENT( IN ), DIMENSION( A_ne ) ::  A_col
      REAL ( KIND = wp ), INTENT( IN ), DIMENSION( dim_x ) :: X
      REAL ( KIND = wp ), INTENT( IN ), DIMENSION( A_ne ) :: A_val
      REAL ( KIND = wp ), INTENT( INOUT ), DIMENSION( dim_r ) :: R

!  Local variables

      INTEGER :: i, l
      REAL ( KIND = wp ) :: xi, ri

      IF ( op( 1 : 1 ) == '+' ) THEN

!  r <- r + A^T * x

        IF ( op( 2 : 2 ) == 'T' .OR. op( 2 : 2 ) == 't' ) THEN
          DO i = 1, m
            xi = X( i )
            DO l = A_ptr( i ), A_ptr( i + 1 ) - 1
              R( A_col( l ) ) = R( A_col( l ) ) + A_val( l ) * xi
            END DO
          END DO

!  r <- r + A * x

        ELSE
          DO i = 1, m
            ri = R( i )
            DO l = A_ptr( i ), A_ptr( i + 1 ) - 1
              ri = ri + A_val( l ) * X( A_col( l ) )
            END DO
            R( i ) = ri
          END DO
        END IF

      ELSE

!  r <- r - A^T * x

        IF ( op( 2 : 2 ) == 'T' .OR. op( 2 : 2 ) == 't' ) THEN
          DO i = 1, m
            xi = X( i )
            DO l = A_ptr( i ), A_ptr( i + 1 ) - 1
              R( A_col( l ) ) = R( A_col( l ) ) - A_val( l ) * xi
            END DO
          END DO

!  r <- r - A * x

        ELSE
          DO i = 1, m
            ri = R( i )
            DO l = A_ptr( i ), A_ptr( i + 1 ) - 1
              ri = ri - A_val( l ) * X( A_col( l ) )
            END DO
            R( i ) = ri
          END DO
        END IF

      END IF
      RETURN

!  End of subroutine QPD_Ax

      END SUBROUTINE QPD_Ax

!  End of module GALAHAD_QPD_double

   END MODULE GALAHAD_QPD_double


      module rrsw_kg26

      use parkind ,only : im => kind_im, rb => kind_rb
      use parrrsw, only : ng26

      implicit none
      save

!-----------------------------------------------------------------
! rrtmg_sw ORIGINAL abs. coefficients for interval 26
! band 26: 22650-29000 cm-1 (low - nothing; high - nothing)
!
! Initial version:  JJMorcrette, ECMWF, oct1999
! Revised: MJIacono, AER, jul2006
! Revised: MJIacono, AER, aug2008
! Revised: MJIacono, AER, nov2015, solar variability
!-----------------------------------------------------------------
!
!  name     type     purpose
!  ----   : ----   : ---------------------------------------------
!sfluxrefo: real
!irradnceo: real
!facbrghto: real
!snsptdrko: real
! raylo   : real
!-----------------------------------------------------------------

      integer(kind=im), parameter :: no26 = 16

      real(kind=rb) :: sfluxrefo(no26)
      real(kind=rb) :: irradnceo(no26)
      real(kind=rb) :: facbrghto(no26),snsptdrko(no26)
      real(kind=rb) :: raylo(no26)

!-----------------------------------------------------------------
! rrtmg_sw COMBINED abs. coefficients for interval 26
! band 26: 22650-29000 cm-1 (low - nothing; high - nothing)
!
! Initial version:  JJMorcrette, ECMWF, oct1999
! Revised: MJIacono, AER, jul2006
! Revised: MJIacono, AER, aug2008
! Revised: MJIacono, AER, nov2015, solar variability
!-----------------------------------------------------------------
!
!  name     type     purpose
!  ----   : ----   : ---------------------------------------------
! sfluxref: real
! irradnce: real
! facbrght: real
! snsptdrk: real
! rayl    : real
!-----------------------------------------------------------------

      real(kind=rb) :: sfluxref(ng26)
      real(kind=rb) :: irradnce(ng26)
      real(kind=rb) :: facbrght(ng26),snsptdrk(ng26)
      real(kind=rb) :: rayl(ng26)

      end module rrsw_kg26


! Module to identify which type of node we have and other info about nodes

module node_id_mod
use abaqus_utils_mod
implicit none

    private

    ! Information about status
    public  :: are_uel_coords_obtained
    public  :: is_mesh_info_setup

    ! External setup requests
    public  :: set_uel_coords
    public  :: setup_mesh_info          ! subroutine(node_labels, node_coordinates)

    ! Get node wheel node information
    public  :: get_inds                 ! function(node_label) result(mesh_inds)
    public  :: get_label                ! function(mesh_inds) result(node_label)
    public  :: get_node_coords          ! function(mesh_inds) result(node_coords)
    public  :: get_node_dofs            ! function(mesh_inds) result(node_dofs)
    public  :: get_mesh_size            ! function() result(size(wheel_contact_node_labels))
    public  :: get_angle_incr           ! function() result(the_angle_incr)
    public  :: get_element_order        ! function() result(the_element_order)

    ! Node type
    public  :: is_wheel_rp_node         ! function(node_label) result (is_wheel_rp)
    public  :: is_rail_rp_node          ! function(node_label) result (is_rail_rp)
    public  :: get_node_type_by_label   ! function(node_label) result(node_type)
    public  :: get_node_type            ! subroutine(node_label, node_coords, node_type)

    ! Constants
    public  :: NODE_TYPE_UNKNOWN        !
    public  :: NODE_TYPE_WHEEL_RP       !
    public  :: NODE_TYPE_RAIL_RP        !
    public  :: NODE_TYPE_WHEEL_CONTACT  !

    ! Parameters for node types
    integer, parameter  :: NODE_TYPE_UNKNOWN = -1
    integer, parameter  :: NODE_TYPE_WHEEL_RP = 1
    integer, parameter  :: NODE_TYPE_RAIL_RP = 2
    integer, parameter  :: NODE_TYPE_WHEEL_CONTACT = 3

    ! Internal parameters
    double precision, parameter         :: POS_TOL = 1.e-2

    ! Temporary storage until used, then deallocated
    double precision, allocatable, save :: uel_coords(:,:)

    ! Set at beginning of simulation, never changed
    logical, save                       :: uel_coords_obtained = .false.
    double precision, allocatable, save :: wheel_rp_coords(:)
    double precision, allocatable, save :: rail_rp_coords(:)
    integer, allocatable, save          :: wheel_rp_node_label
    integer, allocatable, save          :: rail_rp_node_label
    integer, allocatable, save          :: wheel_contact_node_labels(:,:)
    double precision, allocatable, save :: wheel_contact_node_coords(:,:,:)
    integer, allocatable, save          :: wheel_contact_node_dofs(:,:,:)
    integer, save                       :: element_order=0
    double precision, save              :: angle_incr=0

    contains

    function are_uel_coords_obtained() result(is_obtained)
    implicit none
        logical         :: is_obtained

        is_obtained = uel_coords_obtained

    end function

    subroutine set_uel_coords(the_uel_coords)
    implicit none
        double precision, intent(in)        :: the_uel_coords(:,:)

        allocate(uel_coords, source=the_uel_coords)
        uel_coords_obtained = .true.

    end subroutine

    function is_mesh_info_setup() result(is_setup)
    implicit none
        logical     :: is_setup

        is_setup = allocated(wheel_contact_node_labels)

    end function

    function get_mesh_size() result(mesh_size)
    implicit none
        integer     :: mesh_size(2)

        mesh_size = [size(wheel_contact_node_labels,1), size(wheel_contact_node_labels,2)]

    end function

    subroutine setup_mesh_info(node_labels, node_coordinates)
    use sort_mod, only : unique
    use usub_utils_mod, only : get_fid
    implicit none
        integer, intent(in)             :: node_labels(:)           ! size=(num_nodes)
        double precision, intent(in)    :: node_coordinates(:,:)    ! size=(3, num_nodes)

        double precision, allocatable   :: rel_coords(:,:)
        double precision, allocatable   :: xcoords(:), uxcoords(:)
        double precision, allocatable   :: angles(:), uangles(:)
        double precision, allocatable   :: x_dist_square(:), a_dist_square(:)
        double precision                :: max_radius

        integer                         :: nt, na, nx   ! Number of nodes (total, angular, x)
        integer                         :: ka, kx       ! Iterators in angular and x directions
        integer                         :: min_ind(1)   ! Index of identified point
        integer                         :: n_filled     ! Number of filled positions

        ! Calculate coordinates relative the wheel center
        allocate(rel_coords, source=node_coordinates)
        if (.not.allocated(wheel_rp_coords)) then
            write(*,*) 'wheel rp coords should have been allocated by now, exiting...'
            call xit()
        endif
        do ka=1,3
            rel_coords(ka,:) = rel_coords(ka,:) - wheel_rp_coords(ka)
        enddo

        nt = size(node_labels)
        allocate(xcoords(nt), angles(nt))
        allocate(x_dist_square(nt), a_dist_square(nt))

        max_radius = sqrt(maxval(rel_coords(2,:)**2 + rel_coords(3, :)**2))

        angles = atan2(-rel_coords(3,:), -rel_coords(2, :))
        xcoords = rel_coords(1,:)

        call unique(angles, uangles, POS_TOL/max_radius)
        call unique(xcoords, uxcoords, POS_TOL)
        na = size(uangles)
        nx = size(uxcoords)

        allocate(wheel_contact_node_labels(na, nx))
        allocate(wheel_contact_node_coords(3, na, nx))
        wheel_contact_node_labels = -1
        wheel_contact_node_coords = 0.d0
        do kx=1,nx
            x_dist_square = (uxcoords(kx) - xcoords)**2
            do ka=1,na
                a_dist_square = ((uangles(ka) - angles)*max_radius)**2
                min_ind = minloc(x_dist_square + a_dist_square)
                if ((x_dist_square(min_ind(1))+a_dist_square(min_ind(1))) < 2*POS_TOL**2) then
                    wheel_contact_node_labels(ka, kx) = node_labels(min_ind(1))
                    wheel_contact_node_coords(:, ka, kx) = node_coordinates(:, min_ind(1))
                endif
            enddo
        enddo
        n_filled = na*nx - (-sum(wheel_contact_node_labels, mask=(wheel_contact_node_labels==-1)))
        if (n_filled == na*nx) then
            element_order = 1
        elseif (n_filled == nt) then
            element_order = 2
        else
            write(*,*) 'Could not find all node positions.'
            write(*,*) n_filled, nt, na, nx
            write(*,*) 'Identified positions (kx along rows, ka along cols):'
            write(*,"(10X)", advance="no")
            do kx=1,nx
                write(*, "(I5)", advance="no") kx
            enddo
            write(*,*) ''
            do ka=1,na
                write(*, "(I10)", advance="no") ka
                do kx=1,nx
                    write(*, "(I5)", advance="no") wheel_contact_node_labels(ka, kx)
                enddo
                write(*,*) ''
            enddo
        endif
        angle_incr = element_order*(uangles(na) - uangles(1))/(na-1)
        ! Allocate here as we have na and nx defined
        allocate(wheel_contact_node_dofs(3, na, nx))
        call get_wheel_contact_node_dofs()

    end subroutine setup_mesh_info

    subroutine get_wheel_contact_node_dofs()
    use find_mod, only: find
    implicit none
        integer             :: nnod
        integer             :: k1, mesh_inds(2)

        nnod = size(uel_coords,2)
        ! First 3 dofs are wheel rp translations
        ! Next 3 dofs are wheel rp rotations
        ! Thereafter comes wheel contact node translation dofs in pairs of 3 for each node
        ! First coords are wheel rp coordinates
        ! Thereafter comes wheel contact node coordinates, in same order as dofs
        do k1=2,nnod
            mesh_inds = find(wheel_contact_node_coords, uel_coords(:,k1), point_dim=1, tol=POS_TOL)
            wheel_contact_node_dofs(:, mesh_inds(1), mesh_inds(2)) = [1, 2, 3] + 3*k1
        enddo

        ! From now on we no longer need the uel_coords
        deallocate(uel_coords)

    end subroutine get_wheel_contact_node_dofs

    function get_angle_incr() result(the_angle_incr)
    implicit none
        double precision        :: the_angle_incr

        the_angle_incr = angle_incr

    end function

    function get_element_order() result(the_element_order)
    implicit none
        integer                 :: the_element_order

        the_element_order = element_order

    end function

    function get_inds(node_label) result(mesh_inds)
    use find_mod, only : find
    implicit none
        integer, intent(in)     :: node_label
        integer                 :: mesh_inds(2)

        mesh_inds = find(wheel_contact_node_labels, node_label)

    end function

    function get_label(mesh_inds) result(node_label)
    implicit none
        integer, intent(in)     :: mesh_inds(2)
        integer                 :: node_label

        node_label = wheel_contact_node_labels(mesh_inds(1), mesh_inds(2))

    end function

    function get_node_coords(mesh_inds) result(node_coords)
    implicit none
        integer, intent(in)     :: mesh_inds(2)
        double precision        :: node_coords(3)

        node_coords = wheel_contact_node_coords(:, mesh_inds(1), mesh_inds(2))
    end function

    function get_node_dofs(mesh_inds) result(node_dofs)
    implicit none
        integer, intent(in)     :: mesh_inds(2)
        integer                 :: node_dofs(3)

        node_dofs = wheel_contact_node_dofs(:, mesh_inds(1), mesh_inds(2))
    end function

    function is_wheel_rp_node(node_label) result(is_wheel_rp)
    implicit none
        integer, intent(in)             :: node_label
        logical                         :: is_wheel_rp

        if (allocated(wheel_rp_node_label)) then
            is_wheel_rp = node_label == wheel_rp_node_label
        else
            write(*,*) 'WARNING: is_wheel_rp_node called before wheel_rp_node_label has been set'
            is_wheel_rp = .false.
        endif
    end function

    function is_rail_rp_node(node_label) result(is_rail_rp)
    implicit none
        integer, intent(in)             :: node_label
        logical                         :: is_rail_rp

        if (allocated(rail_rp_node_label)) then
            is_rail_rp = node_label == rail_rp_node_label
        else
            write(*,*) 'WARNING: is_rail_rp_node called before rail_rp_node_label has been set'
            is_rail_rp = .false.
        endif
    end function

    subroutine get_node_type(node_label, node_coords, node_type)
    implicit none
        integer, intent(in)             :: node_label
        double precision, intent(in)    :: node_coords(3)
        integer, intent(out)            :: node_type

        ! Try first to get by label, this is the fastest method
        node_type = get_node_type_by_label(node_label)

        if (node_type == NODE_TYPE_UNKNOWN) then
            ! If node type not known, probably because label is not setup yet.
            ! Get rp node by coordinate will also setup the label
            call get_rp_node_type_by_coord(node_label, node_coords, node_type)
            if (node_type == NODE_TYPE_UNKNOWN) then
                write(*,*) 'Could not identify node type'
                if (.not.is_mesh_info_setup()) then
                    write(*,*) 'mesh info not setup, this is a likely cause'
                endif
                call xit()
            endif
        endif

    end subroutine

    subroutine get_rp_node_type_by_coord(node_label, node_coords, node_type)
    use linalg_mod, only : norm
    implicit none
        integer, intent(in)             :: node_label
        double precision, intent(in)    :: node_coords(3)
        integer, intent(out)            :: node_type

        if (.not.allocated(wheel_rp_coords)) then
            call set_rp_node_coords()
        endif

        if (norm(node_coords - wheel_rp_coords) < POS_TOL) then
            allocate(wheel_rp_node_label)
            wheel_rp_node_label = node_label
            node_type = NODE_TYPE_WHEEL_RP
        elseif (norm(node_coords - rail_rp_coords) < POS_TOL) then
            allocate(rail_rp_node_label)
            rail_rp_node_label = node_label
            node_type = NODE_TYPE_RAIL_RP
        else
            node_type = NODE_TYPE_UNKNOWN
        endif

    end subroutine

    function get_node_type_by_label(node_label) result(node_type)
    implicit none
        integer, intent(in)     :: node_label
        integer                 :: node_type

        node_type = NODE_TYPE_UNKNOWN

        if (allocated(wheel_rp_node_label)) then
            if (node_label == wheel_rp_node_label) then
                node_type = NODE_TYPE_WHEEL_RP
                return
            endif
        endif

        if (allocated(rail_rp_node_label)) then
            if (node_label == rail_rp_node_label) then
                node_type = NODE_TYPE_RAIL_RP
                return
            endif
        endif

        if (is_mesh_info_setup()) then
            if (all(get_inds(node_label) > -1)) then
                node_type = NODE_TYPE_WHEEL_CONTACT
                return
            endif
        endif

    end function get_node_type_by_label

    subroutine set_rp_node_coords()
    use filenames_mod, only : rp_node_coords_file_name
    use usub_utils_mod, only : get_fid, check_iostat
    implicit none
        integer             :: file_id
        integer             :: io_stat

        file_id = get_fid(rp_node_coords_file_name)
        allocate(wheel_rp_coords(3), rail_rp_coords(3))
        read(file_id, *, iostat=io_stat) wheel_rp_coords
        call check_iostat(io_stat, 'Could not read wheel_rp_coords from "'//rp_node_coords_file_name//'"')
        read(file_id, *, iostat=io_stat) rail_rp_coords
        call check_iostat(io_stat, 'Could not read rail_rp_coords from "'//rp_node_coords_file_name//'"')
        close(file_id)

    end subroutine

end module node_id_mod


C    @(#)xallocq.f	20.4 2/13/96
C****************************************************************
C
C   File: xallocq.f
C   Purpose: Routine to obtain reactive allocation based upon the
c            final solution values and the state of the bus, using
C            the data from alternate base case.
C
C   Author: Walt Powell  Date: 26 July 1993
C                        Modified:
C   Called by:
C
C****************************************************************
        subroutine xallocq (nb, qk, qgen, qgnmax, qgnmin, qload, totcap,
     1                     usecap, totrek, userek, unsked, qerr)
C
C       This subroutine allocates Q to load, generation, shunt,
C       unscheduled, and Q_error according to Qk.
C
C     Input paramters:
C
C     NB     - external bus number.
C     QK     - computed net reactive injection.
C
C     Output paramters:
C
C     QGEN   - reactive generation in MVAR.
C     QLOAD  - reactive load in MVAR.
C     QGNMAX - maximum reactive generation in MVAR.
C     QGNMIN - minimum reactive generation in MVAR.
C     TOTCAP - total capacitive shunt in MVAR.
C     TOTREK - total reactive shunt in MVAR.
C     USECAP - used capacitive shunt in MVAR.
C     USEREK - used capacitive shunt in MVAR.
C     UNSKED - reactive shunt unscheduled in MVAR.
C     QERR   - reactive shunt mismatched in MVAR.
C
      include 'ipfinc/parametr.inc'

      include 'ipfinc/blank.inc'
      include 'ipfinc/alt_case.inc'
      include 'ipfinc/alt_flag.inc'

      common /scratch/ scratch(22*MAXBUS)
      integer ptrtbx(MAXBUS)
      equivalence (ptrtbx, scratch(12*MAXBUS+1))
C
c***      logical xallocq_loaded
      logical capsw
      character kode2 * 1, kodeyr * 2, kownr2 * 3

      if (.not. tbx_flag) then
         do i = 1, ontot
            ptrtbx(i)  = 0
         enddo
         do jt = 1, ontotb
            j = oltbx(2,jt)
            ptrtbx(j) = jt
         enddo
         tbx_flag = .true.
      endif

      kt = oinp2opt(nb)
      qkmva = qk * bmva
      vksq = olde(kt) ** 2 + oldf(kt) ** 2
      vk = sqrt (vksq)
C
C     Obtain total susceptance.  Note: BX bus type store initial
C     value on B record.  The total is in array XDATA.
C
      ktyp = okbsdta(1,nb)
C
      if (ktyp .eq. 11) then
C
         jtbx = ptrtbx(nb)
         if (jtbx .gt. 0) then
            nt = oltbx(5,jtbx)
            totrek = oxdata(3,nt) * vksq
            totcap = oxdata(4,nt) * vksq
         else
            call erexit
         endif
      else if (ktyp .eq. 5 .or. ktyp .eq. 12) then
         qgen = qkmva
         qload  = 0.0
         qgnmax = qgen
         qgnmin = qgen
         totcap = 0.0
         totrek = 0.0
         usecap = 0.0
         userek = 0.0
         unsked = 0.0
         go to 1280
      else
         sksusp = obusdta(6,nb) * vksq
         totcap = amax1 (sksusp, 0.0)
         totrek = amin1 (sksusp, 0.0)
      endif

      qload = obusdta(4,nb)
      if (ktyp .eq. 1 .or. ktyp .eq. 4 .or. ktyp .eq. 10) then
         if (obusdta(10,nb) .lt. 0.0) then
            qgnmax = 0.0
            qgnmin = 0.0
         else
            qgnmax = obusdta(9,nb)
            qgnmin = obusdta(9,nb)
         endif
      else
         qgnmax = obusdta(9,nb)
         qgnmin = obusdta(10,nb)
      endif
      bfixed = 0.0
      ncb = okbsdta(15,nb)
      do while (ncb .gt. 0)
         qload2 = obctbl(3,ncb)
         sksus2 = obctbl(5,ncb) * vksq
         if (ktyp .eq. 1 .or. ktyp .eq. 4 .or. ktyp .eq. 10) then
            if (obctbl(12,ncb) .lt. 0.0) then
            else
               qgnmax = qgnmax + obctbl(11,ncb)
               qgnmin = qgnmin + obctbl(11,ncb)
            endif
         else
            qgnmax = qgnmax + obctbl(11,ncb)
            qgnmin = qgnmin + obctbl(12,ncb)
         endif
         call getchr(1,kode2,okbctbl(8,ncb))
         call getchr(2,kodeyr,okbctbl(9,ncb))
         call getchr(3,kownr2,okbctbl(10,ncb))
         if (kode2 .eq. 'A') then
            if (kodeyr .eq. '01' .or. kodeyr .eq. '02') then
               bfixed = bfixed + sksus2
               sksus2 = 0.0
            else
               bfixed = bfixed + sksus2
               sksus2 = 0.0
            endif
            if (kodeyr .eq. '01') then

C              This load is constant current. It appears on the
C              RHS in the Qk equation. Transfer it to the LHS.

               qload2 = qload2 * sqrt (vksq)
               qkmva = qkmva - qload2
            endif
         else if (kodeyr .eq. '*P') then
            bfixed = bfixed + sksus2
            sksus2 = 0.0
         else if (kodeyr .eq. '*I') then
            bfixed = bfixed + sksus2
            sksus2 = 0.0

C           This load is constant current. It appears on the
C           RHS in the Qk equation. Transfer it to the LHS.

            qload2 = qload2 * sqrt (vksq)
            qkmva = qkmva - qload2
         endif
         qload = qload + qload2
         totcap = totcap + amax1 (sksus2, 0.0)
         totrek = totrek + amin1 (sksus2, 0.0)
         ncb = obctbl_nxt(ncb)
      enddo

      totcap = totcap + amax1( bfixed, 0.0 )
      totrek = totrek + amin1( bfixed, 0.0 )
      qgen = qkmva + qload + oineti(kt) * vk * bmva
C
C     Remove switched shunt from BQ busses.
C
C     "CAPSW" = .TRUE.  - shunt susceptance is fixed.
C               .FALSE. - shunt susceptance is adjustable.
C
      usecap = totcap
      userek = totrek
      capsw = .true.
      if (ktyp .eq. 1 .or. ktyp .eq. 4 .or. ktyp .eq. 10) then
      else if (usecap .gt. 0.0 .or. userek .lt. 0.0) then

         if (ktyp .eq. 7) then

            jtbx = ptrtbx(nb)
            if (jtbx .gt. 0) then
               ltyp = oltbx(1,jtbx)
               ityp = oltbx(7,jtbx)
               if (ityp .eq. 3) then
C
C                 Q_min limit hit. Remove all capacitors.
C
                  usecap = amax1( 0.0, bfixed )
C
               else if (ityp .eq. 4) then
C
C                 Q_max limit hit. Remove all reactors.
C
                  userek = amin1( 0.0, bfixed )
C
               else
                  capsw = .false.
               endif
            else
               call erexit
            endif
C
  130       continue
C
C       "BG" shunt is held constant. CAPSW does not need to be set
C        to .TRUE., which implies fixed Qshunt, since .TRUE. is its
C        default value.
C
         else if (ktyp .eq. 11) then
C
C           "BX" shunt is explicitly defined.
C
            jtbx = ptrtbx(nb)
            if (jtbx .gt. 0) then
               nt = oltbx(5,jtbx)
               userek = oxdata(5,nt) * vksq + amin1 (0.0, bfixed)
               usecap = oxdata(6,nt) * vksq + amax1 (0.0, bfixed)
            else
               call erexit
            endif
C
  150       continue

         else if (ktyp .eq. 2 .or. ktyp .eq. 3) then
C
C           "BE" and "BS" have allocatable shunt also.
C
            capsw = .false.
         endif
      endif
C
C     Remove "ficticious generation" from BQ, BE, and BS busses.
C     This ficticious generation compensates any unused shunt.
C
      if (.not. capsw) then
         xusecp = usecap - amax1 (0.0, bfixed)
         xuserk = userek - amin1 (0.0, bfixed)
         if (qgen * xusecp .lt. 0.0) then
            if (abs(qgen) .le. abs(xusecp) + 0.5) then
               usecap = usecap + qgen
               qkmva = qkmva - qgen
               qgen = 0.0
            else
               qgen = qgen + xusecp
               qkmva = qkmva + xusecp
               usecap = usecap - xusecp
            endif
         else if (qgen * xuserk .lt. 0.0) then
            if ( abs(qgen) .le. abs(xuserk) + 0.5 ) then
               userek = userek + qgen
               qkmva = qkmva - qgen
               qgen = 0.0
            else
               qgen = qgen + xuserk
               qkmva = qkmva + xuserk
               userek = userek - xuserk
            endif
         endif
      endif

 1280 qgen = qgen - dim( qgen, qgnmax ) + dim( qgnmin, qgen )

      if ( dim( qkmva, qgnmax - qload ) .gt. 0.5 ) then
         unsked = dim( qkmva, qgnmax - qload )
      else if ( dim ( qgnmin - qload, qkmva ) .gt. 0.5 ) then
         unsked = -dim( qgnmin - qload, qkmva )
      else
         unsked = 0.0
      end if
      qerr = 0.0

      return
      end


C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    PDSENS.F    PACKS GRIB PDS EXTENSION 41- FOR ENSEMBLE
C   PRGMMR: RICHARD WOBUS    ORG: W/NP20     DATE: 98-09-28
C
C ABSTRACT: PACKS BRIB PDS EXTENSION STARTING ON BYTE 41 FOR ENSEMBLE
C    FORECAST PRODUCTS. FOR FORMAT OF PDS EXTENSION, SEE NMC OFFICE NOTE 38
C
C PROGRAM HISTORY LOG:
C   95-03-14  ZOLTAN TOTH AND MARK IREDELL
C   95-10-31  IREDELL     REMOVED SAVES AND PRINTS
C   98-09-28  WOBUS       CORRECTED MEMBER ENTRY, BLANK ALL UNUSED FIELDS
C 2001-06-05  IREDELL   APPLY LINUX PORT BY EBISUZAKI
C
C USAGE:    CALL PDSENS.F(KENS,KPROB,XPROB,KCLUST,KMEMBR,ILAST,MSGA)
C   INPUT ARGUMENT LIST:
C     KENS(5)  - BYTES 41-45 (GENERAL SECTION, ALWAYS PRESENT.)
C     KPROB(2) - BYTES 46-47 (PROBABILITY SECTION, PRESENT ONLY IF NEEDE
C     XPROB(2) - BYTES 48-51&52-55 (PROBABILITY SECTION, IF NEEDED.)
C     KCLUST(16)-BYTES 61-76 (CLUSTERING SECTION, IF NEEDED.)
C     KMEMBR(80)-BYTES 77-86 (CLUSTER MEMBERSHIP SECTION, IF NEEDED.)
C     ILAST    - LAST BYTE TO BE PACKED (IF GREATER OR EQUAL TO FIRST BY
C                IN ANY OF FOUR SECTIONS ABOVE, WHOLE SECTION IS PACKED.
C
C   OUTPUT ARGUMENT LIST:      (INCLUDING WORK ARRAYS)
C     MSGA     - FULL PDS SECTION, INCLUDING NEW ENSEMBLE EXTENSION
C
C REMARKS: USE PDSEUP.F FOR UNPACKING PDS ENSEMBLE EXTENSION.
C   SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT.
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 77
C   MACHINE:  CRAY, WORKSTATIONS
C
C$$$
C    TESTING GRIB EXTENSION 41- PACKER AND UNPACKER SUBROUTINES
C
CFPP$ NOCONCUR R
      SUBROUTINE PDSENS(KENS,KPROB,XPROB,KCLUST,KMEMBR,ILAST,MSGA)
      INTEGER KENS(5),KPROB(2),KCLUST(16),KMEMBR(80)
      DIMENSION XPROB(2)
      CHARACTER*1 MSGA(100)
      IF(ILAST.LT.41) THEN
      GO TO 333
      ENDIF
C    PACKING IS DONE IN FOUR SECTIONS ENDING AT BYTE IL
      IF(ILAST.GE.41) IL=45
      IF(ILAST.GE.46) IL=55
      IF(ILAST.GE.61) IL=76
      IF(ILAST.GE.77) IL=86
          do i=42,il
            CALL SBYTEC(MSGA, 0, i*8, 8)
          enddo
C    CHANGING THE NUMBER OF BYTES (FIRST THREE BYTES IN PDS)
      CALL SBYTEC(MSGA, IL, 0,24)
C    PACKING FIRST SECTION (GENERAL INTORMATION SECTION)
      IF(IL.GE.45) CALL SBYTESC(MSGA,KENS,40*8,8,0,5)
C    PACKING 2ND SECTION (PROBABILITY SECTION)
      IF(IL.GE.55) THEN
          CALL SBYTESC(MSGA,KPROB,45*8,8,0,2)
      CALL W3FI01(LW)
      CALL W3FI76(XPROB(1),IEXP,IMANT,8*LW)
      CALL SBYTEC(MSGA,IEXP,47*8,8)
      CALL SBYTEC(MSGA,IMANT,48*8,24)
      CALL W3FI76(XPROB(2),IEXP,IMANT,8*LW)
      CALL SBYTEC(MSGA,IEXP,51*8,8)
      CALL SBYTEC(MSGA,IMANT,52*8,24)
      ENDIF
C    PACKING 3RD SECTION (CLUSTERING INFORMATION)
      IF(IL.GE.76) CALL SBYTESC(MSGA,KCLUST,60*8,8,0,16)
C    PACKING 4TH SECTION (CLUSTER MEMBERSHIP)
      IF(IL.GE.86) CALL SBYTESC(MSGA,KMEMBR,76*8,1,0,80)
C
 333  CONTINUE
      RETURN
      END


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!   EVB-QMDFF - RPMD molecular dynamics and rate constant calculations on
!               black-box generated potential energy surfaces
!
!   Copyright (c) 2021 by Julien Steffen (steffen@pctc.uni-kiel.de)
!                         Stefan Grimme (grimme@thch.uni-bonn.de) (QMDFF code)
!
!   Permission is hereby granted, free of charge, to any person obtaining a
!   copy of this software and associated documentation files (the "Software"),
!   to deal in the Software without restriction, including without limitation
!   the rights to use, copy, modify, merge, publish, distribute, sublicense,
!   and/or sell copies of the Software, and to permit persons to whom the
!   Software is furnished to do so, subject to the following conditions:
!
!   The above copyright notice and this permission notice shall be included in
!   all copies or substantial portions of the Software.
!
!   THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
!   IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
!   FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
!   THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
!   LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
!   FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
!   DEALINGS IN THE SOFTWARE.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!
!     subroutine ehtfull: If Wiberg-Mayer bond orders for QMDFF parameterization
!        don´t exist, calculate them based on EHT!
!
!     part of QMDFF
!
subroutine ehtfull(n,at,xyz,q,nel,nbf,eel,wb,gscal)
use qmdff
implicit none
integer::n,at(n),nel,nbf
real(kind=8)::xyz(3,n),eel,wb(n,n),q(n),gscal
logical::dens

real(kind=8)::b,bb,temp,xsum,eh1,gab,rab,brow(7)
real(kind=4),allocatable::X(:,:)
real(kind=4),allocatable::P(:,:)
real(kind=4),allocatable::S(:,:)
real(kind=4),allocatable::H(:,:)
real(kind=4),allocatable::aux(:)
real(kind=4),allocatable ::emo(:)
real(kind=4),allocatable ::ep (:)
real(kind=4),allocatable ::focc(:)
integer,allocatable::iwork(:)
integer,allocatable::iiwork(:)
integer::LWORK,LIWORK,INFO
integer::npr,ii,jj,i,j,kk,m,k,iat,jat,lina
integer::mmm(10),xi,xj,ihomo,irow,jrow,pqn
character(len=1)::flag

mmm=(/1,2,2,2,3,3,3,3,3,3/)
liwork = 3 + 5*nbf
lwork  = 1 + 6*nbf + 2*nbf**2
allocate(H(nbf,nbf),X(nbf,nbf),aux(lwork),P(nbf,nbf), &
  & iwork(liwork),emo(nbf),focc(nbf),ep(nbf),S(nbf,nbf))
!
!     print out info message
!
write(10,*)'Doing full Extended Hückel calculation ...'
write(10,*)'Number of atoms    : ',n
write(10,*)'Number of electrons  : ',nel
write(10,*)'Number of basis functions  : ',nbf

!
!     calculate overlap integrals
!
call stints(n,nbf,xyz,X)
S = X

b=1.75
do irow=1,6
   brow(irow)=b
   b=b+0.20
end do

do ii=1,nbf
   xi=aoat(ii)
   irow=pqn(at(xi))
   do jj=1,ii-1
     xj=aoat(jj)
     jrow=pqn(at(xj))
     bb=0.5*(brow(irow)+brow(jrow))
     H(jj,ii)=X(jj,ii)*bb*(hdiag(ii)+hdiag(jj))*0.5
     H(ii,jj)=0
     X(ii,jj)=0
   end do
   H(ii,ii)=hdiag(ii)
end do

if (abs(gscal).gt.1.d-6) then
   do i=1,nbf
      ii=aoat(i)
      do j=1,i
         jj=aoat(j)
         eh1=0.0d0
         do kk=1,n
            eh1=eh1+q(kk)*(gab(n,xyz,at,kk,ii)+gab(n,xyz,at,kk,jj))
         end do
         H(j,i)=H(j,i)-X(j,i)*eh1*0.5d0*gscal
      end do
   end do
end if
!
!     diagonalize the Hamiltonian matrix
!     by calling the lapack routine
!     (generalized symmetric definite eigenproblem)
!
flag='V'
call SSYGVD(1,flag,'U',nbf,H,nbf,X,nbf,emo,aux, &
   & LWORK,IWORK,LIWORK,INFO)
temp=1500.0d0
focc=0
do i=1,nel/2
   focc(i)=2.0d0
end do
if (2*(nel/2).ne.nel) then
   ihomo=nel/2+1
   ep=0
   ep(1:ihomo)=1.0
   call fermismear(.false.,nbf,ihomo,temp,emo,ep)
   focc=0
   if (ihomo.gt.1) then
      focc(1:ihomo-1)=1.0
      call fermismear(.false.,nbf,ihomo-1,temp,emo,focc)
   end if
   focc(1:nbf)=focc(1:nbf)+ep(1:nbf)
else
   ihomo=nel/2
   call fermismear(.false.,nbf,ihomo,temp,emo,focc)
   focc=focc*2.
end if
emo=emo/27.212
eel=0
do i=1,nbf
   eel=eel+emo(i)*focc(i)
end do

!     calc P and WBOs
write(10,*)
write(10,*)'Total electronic energy  : ',eel
!
!     looking at the name it seems that it print out
!     eigenvalues and/or eigenvectors
!
write(10,*)
write(10,*) "Print out of all EHT orbitals (eigenvalues and occupations)"
write(10,*)
call preig4(10,focc,emo,nbf)
do m=1,nbf
   do i=1,nbf
      X(i,m)=H(i,m)
      H(i,m)=H(i,m)*focc(m)
   end do
end do
!
!     call LAPACK routine for operations with three matrices..
!
call sgemm('N','T',nbf,nbf,nbf,1.0,X, &
   &  nbf,H,nbf,0.0,P,nbf)
call sgemm('N','N',nbf,nbf,nbf,1.0,P, &
   &  nbf,S,nbf,0.0,H,nbf)
wb=0
do i=1,n
   do j=1,i-1
   xsum=0.0
   rab=(xyz(1,i)-xyz(1,j))**2 &
    & +(xyz(2,i)-xyz(2,j))**2 &
    & +(xyz(3,i)-xyz(3,j))**2
   if(rab.lt.100.0)then
      do k=fila(1,i),fila(2,i)
         do m=fila(1,j),fila(2,j)
            xsum=xsum+H(k,m)*H(m,k)
         end do
      end do
   end if
!
!     this scales WBO to about 1,2,3 for ethane,ethene,ethyne
!     the model WBO are NOT used, this is just for convenience
!     and in strange cases when the DFT (orca.out) WBO do not
!     exist
!
      wb(i,j)=xsum*1.0
      wb(j,i)=xsum*1.0
   end do
end do

deallocate(emo,ep,focc,H,X,P,S,aux,iwork)
return
end subroutine ehtfull