Module sfp_module

  Use, Intrinsic :: iso_fortran_env, Only :  wp => real64, li => int64

  Implicit None

  Public :: sfp_long_range
  Public :: sfp_sic

  Private

  Real( wp ), Parameter :: pi = 3.141592653589793238462643383279502884197_wp

Contains

  Subroutine sfp_long_range(  l, q, r, alpha, ew_func, recip_E, q_grid, pot_grid, t_grid, t_recip, error )

    Use, Intrinsic :: iso_fortran_env, Only :  wp => real64, li => int64

    Use lattice_module        , Only : lattice
    Use charge_grid_module    , Only : charge_grid_calculate, charge_grid_find_range

    Implicit None

    Type( lattice )                       , Intent( In    ) :: l
    Real( wp )   , Dimension( :     )     , Intent( In    ) :: q
    Real( wp )   , Dimension( :, :  )     , Intent( In    ) :: r
    Real( wp )                            , Intent( In    ) :: alpha
    Complex( wp ), Dimension( 0: )        , Intent( In    ) :: ew_func
    Real( wp )                            , Intent(   Out ) :: recip_E
    Real( wp )   , Dimension( 0:, 0:, 0: ), Intent(   Out ) :: q_grid
    Real( wp )   , Dimension( 0:, 0:, 0: ), Intent(   Out ) :: pot_grid
    Real( wp )                            , Intent(   Out ) :: t_grid
    Real( wp )                            , Intent(   Out ) :: t_recip
    Integer                               , Intent(   Out ) :: error

    Complex( wp ) :: pot

    Real( wp ), Dimension( 1:3 ) :: f_point
    Real( wp ), Dimension( 1:3 ) :: r_point
    Real( wp ), Dimension( 1:3 ) :: G
    Real( wp ), Dimension( 1:3 ) :: ri

    Real( wp ) :: potr

    Integer, Dimension( 1:3 ) :: range_gauss
    Integer, Dimension( 1:3 ) :: i_grid

    Integer, Dimension( 1:3 ) :: n_grid

    Integer :: iG
    Integer :: i1, i2, i3

    Integer( li ) :: start, finish, rate

    error = 0

    n_grid = Ubound( q_grid ) + 1

    ! Grid the charge
    Call system_clock( start, rate )
    ! First find range of the gaussian along each of the axes of the grid
    Call charge_grid_find_range( l, alpha, n_grid, range_gauss )
    ! Now grid the charge
    Call charge_grid_calculate( l, alpha, q, r, range_gauss, q_grid, error )
    Call system_clock( finish, rate )
    t_grid = Real( finish - start, wp ) / rate

    ! Calculate the potential at each point - CAN BE SLOW!!!!
    Call system_clock( start, rate )
    !$omp parallel default( none ) shared( l, n_grid, ew_func, pot_grid ) &
    !$omp                          private( i1, i2, i3, i_grid, f_point, r_point, &
    !$omp                                   ri, potr, ig, G, pot )
    !$omp do collapse( 3 )
    Do i3 = 0, n_grid( 3 ) - 1
       Do i2 = 0, n_grid( 2 ) - 1
          Do i1 = 0, n_grid( 1 ) - 1
             i_grid = [ i1, i2, i3 ]
             f_point = Real( i_grid, wp ) / n_grid
             Call l%to_direct( f_point, r_point )
             ri = r_point
             potr = 0.0_wp
             Do iG = 1, Ubound( ew_func, Dim = 1 )
                Call l%get_nth_rec_vec( ig + 1, G )
                G = G * 2.0_wp * pi
                pot = Exp( Cmplx( 0.0_wp, Dot_product( G, ri ), wp ) ) * ew_func( ig )
                potr = potr + Real( pot + Conjg( pot ), wp )
             End Do
             potr = potr * 4.0_wp * pi / l%get_volume()
             pot_grid( i1, i2, i3 ) = potr
          End Do
       End Do
    End Do
    !$omp end do
    !$omp end parallel
    !HACK
    ! Where * V / 4 * pi come from ?
    pot_grid = pot_grid * l%get_volume() / ( 4.0_wp * pi )
    Call system_clock( finish, rate )
    t_recip = Real( finish - start, wp ) / rate

    ! And hence the energy
    ! Minus Sign on charge grid as we integrate against the screening charge, which
    ! has opposite sign to the actual charge (as it is screening, Duh!
    ! Minus sign on whole comes here just so can add up all contribs at end rather than confuse myself about signs
    recip_E = - 0.5_wp * Sum( - q_grid * pot_grid ) * ( l%get_volume() / Product( n_grid ) )

  End Subroutine sfp_long_range

  Pure Function sfp_sic( q, alpha ) Result( sic )

    Use, Intrinsic :: iso_fortran_env, Only :  wp => real64

    Real( wp ), Dimension( : ), Intent( In    ) :: q
    Real( wp )                , Intent( In    ) :: alpha

    Real( wp ) :: sic

    sic = - alpha * Sum( q * q ) / Sqrt( 2.0_wp * pi )

  End Function sfp_sic

End Module sfp_module


      subroutine cppp(p1,p2,p3,c)
C............. octpoeh e okpy hoct  (c)  o tpem to kam (p1,p2,p3)
      dimension p1(2),p2(2),p3(2),c(3)
      if((p2(1)-p1(1))*(p3(2)-p1(2))-(p3(1)-p1(1))*(p2(2)-p1(2)).lt.
     *1e-6) return
       xm1=(p1(1)+p2(1))/2.
      ym1=(p1(2)+p2(2))/2.
      xm2=(p2(1)+p3(1))/2.
      ym2=(p2(2)+p3(2))/2.
      a=p1(1)-p2(1)
      b=p1(2)-p2(2)
      q=b*ym1+a*xm1
      d=p2(1)-p3(1)
      e=p2(2)-p3(2)
      f=e*ym2+d*xm2
       dv=a*e-b*d
         if(dv.eq.0.) goto 1
         c(1)=(q*e-b*f)/dv
         c(2)=(a*f-q*d)/dv
       c(3)=sqrt((p1(1)-c(1))**2+(p1(2)-c(2))**2)
      return
  1       c(1)=9999999.
          return
      end


      SUBROUTINE IB01PY( METH, JOB, NOBR, N, M, L, RANKR1, UL, LDUL,
     $                   R1, LDR1, TAU1, PGAL, LDPGAL, K, LDK, R, LDR,
     $                   H, LDH, B, LDB, D, LDD, TOL, IWORK, DWORK,
     $                   LDWORK, IWARN, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     1. To compute the triangular  (QR)  factor of the  p-by-L*s
C     structured matrix  Q,
C
C         [ Q_1s  Q_1,s-1  Q_1,s-2  ...  Q_12  Q_11 ]
C         [  0      Q_1s   Q_1,s-1  ...  Q_13  Q_12 ]
C     Q = [  0       0       Q_1s   ...  Q_14  Q_13 ],
C         [  :       :        :           :     :   ]
C         [  0       0        0     ...   0    Q_1s ]
C
C     and apply the transformations to the p-by-m matrix  Kexpand,
C
C               [ K_1 ]
C               [ K_2 ]
C     Kexpand = [ K_3 ],
C               [  :  ]
C               [ K_s ]
C
C     where, for MOESP approach (METH = 'M'), p = s*(L*s-n), and
C     Q_1i = u2(L*(i-1)+1:L*i,:)'  is  (Ls-n)-by-L,  for  i = 1:s,
C     u2 = Un(1:L*s,n+1:L*s),  K_i = K(:,(i-1)*m+1:i*m)  (i = 1:s)
C     is  (Ls-n)-by-m, and for N4SID approach (METH = 'N'), p = s*(n+L),
C     and
C
C               [   -L_1|1    ]          [ M_i-1 - L_1|i ]
C        Q_11 = [             ],  Q_1i = [               ],  i = 2:s,
C               [ I_L - L_2|1 ]          [     -L_2|i    ]
C
C     are  (n+L)-by-L  matrices, and
C     K_i = K(:,(i-1)*m+1:i*m),  i = 1:s,  is  (n+L)-by-m.
C     The given matrices are:
C     For  METH = 'M',  u2 = Un(1:L*s,n+1:L*s),
C                       K(1:Ls-n,1:m*s);
C
C                           [ L_1|1  ...  L_1|s ]
C     For  METH = 'N',  L = [                   ],   (n+L)-by-L*s,
C                           [ L_2|1  ...  L_2|s ]
C
C                       M = [ M_1  ...  M_s-1 ],  n-by-L*(s-1),  and
C                       K,                        (n+L)-by-m*s.
C                       Matrix M is the pseudoinverse of the matrix GaL,
C                       built from the first  n  relevant singular
C                       vectors,  GaL = Un(1:L(s-1),1:n),  and computed
C                       by SLICOT Library routine IB01PD for METH = 'N'.
C
C     Matrix  Q  is triangularized  (in  R),  exploiting its structure,
C     and the transformations are applied from the left to  Kexpand.
C
C     2. To estimate the matrices B and D of a linear time-invariant
C     (LTI) state space model, using the factor  R,  transformed matrix
C     Kexpand, and the singular value decomposition information provided
C     by other routines.
C
C     IB01PY  routine is intended for speed and efficient use of the
C     memory space. It is generally not recommended for  METH = 'N',  as
C     IB01PX  routine can produce more accurate results.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     METH    CHARACTER*1
C             Specifies the subspace identification method to be used,
C             as follows:
C             = 'M':  MOESP  algorithm with past inputs and outputs;
C             = 'N':  N4SID  algorithm.
C
C     JOB     CHARACTER*1
C             Specifies whether or not the matrices B and D should be
C             computed, as follows:
C             = 'B':  compute the matrix B, but not the matrix D;
C             = 'D':  compute both matrices B and D;
C             = 'N':  do not compute the matrices B and D, but only the
C                     R  factor of  Q  and the transformed Kexpand.
C
C     Input/Output Parameters
C
C     NOBR    (input) INTEGER
C             The number of block rows,  s,  in the input and output
C             Hankel matrices processed by other routines.  NOBR > 1.
C
C     N       (input) INTEGER
C             The order of the system.  NOBR > N > 0.
C
C     M       (input) INTEGER
C             The number of system inputs.  M >= 0.
C
C     L       (input) INTEGER
C             The number of system outputs.  L > 0.
C
C     RANKR1  (input) INTEGER
C             The effective rank of the upper triangular matrix  r1,
C             i.e., the triangular QR factor of the matrix  GaL,
C             computed by SLICOT Library routine IB01PD. It is also
C             the effective rank of the matrix  GaL.  0 <= RANKR1 <= N.
C             If  JOB = 'N',  or  M = 0,  or  METH = 'N',  this
C             parameter is not used.
C
C     UL      (input/workspace) DOUBLE PRECISION array, dimension
C             ( LDUL,L*NOBR )
C             On entry, if  METH = 'M',  the leading  L*NOBR-by-L*NOBR
C             part of this array must contain the matrix  Un  of
C             relevant singular vectors. The first  N  columns of  UN
C             need not be specified for this routine.
C             On entry, if  METH = 'N',  the leading  (N+L)-by-L*NOBR
C             part of this array must contain the given matrix  L.
C             On exit, the leading  LDF-by-L*(NOBR-1) part of this array
C             is overwritten by the matrix  F  of the algorithm in [4],
C             where  LDF = MAX( 1, L*NOBR-N-L ), if  METH = 'M';
C                    LDF = N,                    if  METH = 'N'.
C
C     LDUL    INTEGER
C             The leading dimension of the array  UL.
C             LDUL >= L*NOBR, if  METH = 'M';
C             LDUL >= N+L,    if  METH = 'N'.
C
C     R1      (input) DOUBLE PRECISION array, dimension ( LDR1,N )
C             If  JOB <> 'N',  M > 0,  METH = 'M',  and  RANKR1 = N,
C             the leading  L*(NOBR-1)-by-N  part of this array must
C             contain details of the QR factorization of the matrix
C             GaL,  as computed by SLICOT Library routine IB01PD.
C             Specifically, the leading N-by-N upper triangular part
C             must contain the upper triangular factor  r1  of  GaL,
C             and the lower  L*(NOBR-1)-by-N  trapezoidal part, together
C             with array TAU1, must contain the factored form of the
C             orthogonal matrix  Q1  in the QR factorization of  GaL.
C             If  JOB = 'N',  or  M = 0,  or  METH = 'N', or  METH = 'M'
C             and  RANKR1 < N,  this array is not referenced.
C
C     LDR1    INTEGER
C             The leading dimension of the array  R1.
C             LDR1 >= L*(NOBR-1), if  JOB <> 'N',  M > 0,  METH = 'M',
C                                 and  RANKR1 = N;
C             LDR1 >= 1,          otherwise.
C
C     TAU1    (input) DOUBLE PRECISION array, dimension ( N )
C             If  JOB <> 'N',  M > 0,  METH = 'M',  and  RANKR1 = N,
C             this array must contain the scalar factors of the
C             elementary reflectors used in the QR factorization of the
C             matrix  GaL,  computed by SLICOT Library routine IB01PD.
C             If  JOB = 'N',  or  M = 0,  or  METH = 'N', or  METH = 'M'
C             and  RANKR1 < N,  this array is not referenced.
C
C     PGAL    (input) DOUBLE PRECISION array, dimension
C             ( LDPGAL,L*(NOBR-1) )
C             If  METH = 'N',  or  JOB <> 'N',  M > 0,  METH = 'M'  and
C             RANKR1 < N,  the leading  N-by-L*(NOBR-1)  part of this
C             array must contain the pseudoinverse of the matrix  GaL,
C             as computed by SLICOT Library routine IB01PD.
C             If  METH = 'M'  and  JOB = 'N',  or  M = 0,  or
C             RANKR1 = N,  this array is not referenced.
C
C     LDPGAL  INTEGER
C             The leading dimension of the array  PGAL.
C             LDPGAL >= N,  if   METH = 'N',  or  JOB <> 'N',  M > 0,
C                           and  METH = 'M'  and RANKR1 < N;
C             LDPGAL >= 1,  otherwise.
C
C     K       (input/output) DOUBLE PRECISION array, dimension
C             ( LDK,M*NOBR )
C             On entry, the leading  (p/s)-by-M*NOBR  part of this array
C             must contain the given matrix  K  defined above.
C             On exit, the leading  (p/s)-by-M*NOBR  part of this array
C             contains the transformed matrix  K.
C
C     LDK     INTEGER
C             The leading dimension of the array  K.  LDK >= p/s.
C
C     R       (output) DOUBLE PRECISION array, dimension ( LDR,L*NOBR )
C             If  JOB = 'N',  or  M = 0,  or  Q  has full rank, the
C             leading  L*NOBR-by-L*NOBR  upper triangular part of this
C             array contains the  R  factor of the QR factorization of
C             the matrix  Q.
C             If  JOB <> 'N',  M > 0,  and  Q  has not a full rank, the
C             leading  L*NOBR-by-L*NOBR  upper trapezoidal part of this
C             array contains details of the complete orhogonal
C             factorization of the matrix  Q,  as constructed by SLICOT
C             Library routines MB03OD and MB02QY.
C
C     LDR     INTEGER
C             The leading dimension of the array  R.  LDR >= L*NOBR.
C
C     H       (output) DOUBLE PRECISION array, dimension ( LDH,M )
C             If  JOB = 'N'  or  M = 0,  the leading  L*NOBR-by-M  part
C             of this array contains the updated part of the matrix
C             Kexpand  corresponding to the upper triangular factor  R
C             in the QR factorization of the matrix  Q.
C             If  JOB <> 'N',  M > 0,  and  METH = 'N'  or  METH = 'M'
C             and  RANKR1 < N,  the leading  L*NOBR-by-M  part of this
C             array contains the minimum norm least squares solution of
C             the linear system  Q*X = Kexpand,  from which the matrices
C             B  and  D  are found. The first  NOBR-1  row blocks of  X
C             appear in the reverse order in  H.
C             If  JOB <> 'N',  M > 0,  METH = 'M'  and  RANKR1 = N,  the
C             leading  L*(NOBR-1)-by-M  part of this array contains the
C             matrix product  Q1'*X,  and the subarray
C             L*(NOBR-1)+1:L*NOBR-by-M  contains the  corresponding
C             submatrix of  X,  with  X  defined in the phrase above.
C
C     LDH     INTEGER
C             The leading dimension of the array  H.  LDH >= L*NOBR.
C
C     B       (output) DOUBLE PRECISION array, dimension ( LDB,M )
C             If  M > 0,  JOB = 'B' or 'D'  and  INFO = 0,  the leading
C             N-by-M part of this array contains the system input
C             matrix.
C             If  M = 0  or  JOB = 'N',  this array is not referenced.
C
C     LDB     INTEGER
C             The leading dimension of the array B.
C             LDB >= N, if  M > 0 and JOB = 'B' or 'D';
C             LDB >= 1, if  M = 0 or  JOB = 'N'.
C
C     D       (output) DOUBLE PRECISION array, dimension ( LDD,M )
C             If  M > 0,  JOB = 'D'  and  INFO = 0,  the leading
C             L-by-M part of this array contains the system input-output
C             matrix.
C             If  M = 0  or  JOB = 'B'  or  'N',  this array is not
C             referenced.
C
C     LDD     INTEGER
C             The leading dimension of the array D.
C             LDD >= L, if  M > 0 and JOB = 'D';
C             LDD >= 1, if  M = 0 or  JOB = 'B' or 'N'.
C
C     Tolerances
C
C     TOL     DOUBLE PRECISION
C             The tolerance to be used for estimating the rank of
C             matrices. If the user sets  TOL > 0,  then the given value
C             of  TOL  is used as a lower bound for the reciprocal
C             condition number;  an m-by-n matrix whose estimated
C             condition number is less than  1/TOL  is considered to
C             be of full rank.  If the user sets  TOL <= 0,  then an
C             implicitly computed, default tolerance, defined by
C             TOLDEF = m*n*EPS,  is used instead, where  EPS  is the
C             relative machine precision (see LAPACK Library routine
C             DLAMCH).
C             This parameter is not used if  M = 0  or  JOB = 'N'.
C
C     Workspace
C
C     IWORK   INTEGER array, dimension ( LIWORK )
C             where  LIWORK >= 0,       if  JOB =  'N',  or   M = 0;
C                    LIWORK >= L*NOBR,  if  JOB <> 'N',  and  M > 0.
C
C     DWORK   DOUBLE PRECISION array, dimension ( LDWORK )
C             On exit, if  INFO = 0,  DWORK(1) returns the optimal value
C             of  LDWORK,  and, if  JOB <> 'N',  and  M > 0,  DWORK(2)
C             contains the reciprocal condition number of the triangular
C             factor of the matrix  R.
C             On exit, if  INFO = -28,  DWORK(1)  returns the minimum
C             value of LDWORK.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.
C             LDWORK >= MAX( 2*L, L*NOBR, L+M*NOBR ),
C                                         if  JOB = 'N',  or  M = 0;
C             LDWORK >= MAX( L+M*NOBR, L*NOBR + MAX( 3*L*NOBR+1, M ) ),
C                                         if  JOB <> 'N',  and  M > 0.
C             For good performance,  LDWORK  should be larger.
C
C     Warning Indicator
C
C     IWARN   INTEGER
C             = 0:  no warning;
C             = 4:  the least squares problem to be solved has a
C                   rank-deficient coefficient matrix.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value;
C             = 3:  a singular upper triangular matrix was found.
C
C     METHOD
C
C     The QR factorization is computed exploiting the structure,
C     as described in [4].
C     The matrices  B  and  D  are then obtained by solving certain
C     linear systems in a least squares sense.
C
C     REFERENCES
C
C     [1] Verhaegen M., and Dewilde, P.
C         Subspace Model Identification. Part 1: The output-error
C         state-space model identification class of algorithms.
C         Int. J. Control, 56, pp. 1187-1210, 1992.
C
C     [2] Van Overschee, P., and De Moor, B.
C         N4SID: Two Subspace Algorithms for the Identification
C         of Combined Deterministic-Stochastic Systems.
C         Automatica, Vol.30, No.1, pp. 75-93, 1994.
C
C     [3] Van Overschee, P.
C         Subspace Identification : Theory - Implementation -
C         Applications.
C         Ph. D. Thesis, Department of Electrical Engineering,
C         Katholieke Universiteit Leuven, Belgium, Feb. 1995.
C
C     [4] Sima, V.
C         Subspace-based Algorithms for Multivariable System
C         Identification.
C         Studies in Informatics and Control, 5, pp. 335-344, 1996.
C
C     NUMERICAL ASPECTS
C
C     The implemented method for computing the triangular factor and
C     updating Kexpand is numerically stable.
C
C     FURTHER COMMENTS
C
C     The computed matrices B and D are not the least squares solutions
C     delivered by either MOESP or N4SID algorithms, except for the
C     special case n = s - 1, L = 1. However, the computed B and D are
C     frequently good enough estimates, especially for  METH = 'M'.
C     Better estimates could be obtained by calling SLICOT Library
C     routine IB01PX, but it is less efficient, and requires much more
C     workspace.
C
C     CONTRIBUTOR
C
C     V. Sima, Research Institute for Informatics, Bucharest, Oct. 1999.
C
C     REVISIONS
C
C     Feb. 2000, Sep. 2001, March 2005.
C
C     KEYWORDS
C
C     Identification methods; least squares solutions; multivariable
C     systems; QR decomposition; singular value decomposition.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE, TWO, THREE
      PARAMETER          ( ZERO  = 0.0D0, ONE = 1.0D0, TWO = 2.0D0,
     $                     THREE = 3.0D0 )
C     .. Scalar Arguments ..
      DOUBLE PRECISION   TOL
      INTEGER            INFO, IWARN, L, LDB, LDD, LDH, LDK, LDPGAL,
     $                   LDR, LDR1, LDUL, LDWORK, M, N, NOBR, RANKR1
      CHARACTER          JOB, METH
C     .. Array Arguments ..
      DOUBLE PRECISION   B(LDB, *), D(LDD, *), DWORK(*), H(LDH, *),
     $                   K(LDK, *), PGAL(LDPGAL, *), R(LDR, *),
     $                   R1(LDR1, *), TAU1(*), UL(LDUL, *)
      INTEGER            IWORK( * )
C     .. Local Scalars ..
      DOUBLE PRECISION   EPS, RCOND, SVLMAX, THRESH, TOLL
      INTEGER            I, IERR, ITAU, J, JI, JL, JM, JWORK, LDUN2,
     $                   LNOBR, LP1, MAXWRK, MINWRK, MNOBR, NOBRH,
     $                   NROW, NROWML, RANK
      LOGICAL            MOESP, N4SID, WITHB, WITHD
C     .. Local Array ..
      DOUBLE PRECISION   SVAL(3)
C     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            ILAENV
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           DLAMCH, ILAENV, LSAME
C     .. External Subroutines ..
      EXTERNAL           DGEMM, DGEQRF, DLACPY, DLASET, DORMQR, DSWAP,
     $                   DTRCON, DTRSM, DTRTRS, MA02AD, MB02QY, MB03OD,
     $                   MB04OD, MB04OY, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC          INT, MAX, MOD
C     .. Executable Statements ..
C
C     Decode the scalar input parameters.
C
      MOESP = LSAME( METH, 'M' )
      N4SID = LSAME( METH, 'N' )
      WITHD = LSAME( JOB,  'D' )
      WITHB = LSAME( JOB,  'B' ) .OR. WITHD
      MNOBR = M*NOBR
      LNOBR = L*NOBR
      LDUN2 = LNOBR - L
      LP1   = L + 1
      IF ( MOESP ) THEN
         NROW = LNOBR - N
      ELSE
         NROW = N + L
      END IF
      NROWML = NROW - L
      IWARN  = 0
      INFO   = 0
C
C     Check the scalar input parameters.
C
      IF( .NOT.( MOESP .OR. N4SID ) ) THEN
         INFO = -1
      ELSE IF( .NOT.( WITHB .OR. LSAME( JOB, 'N' ) ) ) THEN
         INFO = -2
      ELSE IF( NOBR.LE.1 ) THEN
         INFO = -3
      ELSE IF( N.GE.NOBR .OR. N.LE.0 ) THEN
         INFO = -4
      ELSE IF( M.LT.0 ) THEN
         INFO = -5
      ELSE IF( L.LE.0 ) THEN
         INFO = -6
      ELSE IF( ( MOESP .AND. WITHB .AND. M.GT.0 ) .AND.
     $         ( RANKR1.LT.ZERO .OR. RANKR1.GT.N ) ) THEN
         INFO = -7
      ELSE IF( ( MOESP .AND. LDUL.LT.LNOBR ) .OR.
     $         ( N4SID .AND. LDUL.LT.NROW ) ) THEN
         INFO = -9
      ELSE IF( LDR1.LT.1 .OR. ( M.GT.0 .AND. WITHB .AND. MOESP .AND.
     $         LDR1.LT.LDUN2 .AND. RANKR1.EQ.N ) ) THEN
         INFO = -11
      ELSE IF( LDPGAL.LT.1 .OR.
     $       ( LDPGAL.LT.N .AND. ( N4SID .OR. ( WITHB .AND. M.GT.0
     $                     .AND. ( MOESP .AND. RANKR1.LT.N ) ) ) ) )
     $      THEN
         INFO = -14
      ELSE IF( LDK.LT.NROW ) THEN
         INFO = -16
      ELSE IF( LDR.LT.LNOBR ) THEN
         INFO = -18
      ELSE IF( LDH.LT.LNOBR ) THEN
         INFO = -20
      ELSE IF( LDB.LT.1 .OR. ( M.GT.0 .AND. WITHB .AND. LDB.LT.N ) )
     $      THEN
         INFO = -22
      ELSE IF( LDD.LT.1 .OR. ( M.GT.0 .AND. WITHD .AND. LDD.LT.L ) )
     $      THEN
         INFO = -24
      ELSE
C
C        Compute workspace.
C        (Note: Comments in the code beginning "Workspace:" describe the
C         minimal amount of workspace needed at that point in the code,
C         as well as the preferred amount for good performance.
C         NB refers to the optimal block size for the immediately
C         following subroutine, as returned by ILAENV.)
C
         MINWRK = MAX( 2*L, LNOBR, L + MNOBR )
         MAXWRK = MINWRK
         MAXWRK = MAX( MAXWRK, L + L*ILAENV( 1, 'DGEQRF', ' ', NROW, L,
     $                                      -1, -1 ) )
         MAXWRK = MAX( MAXWRK, L + LDUN2*ILAENV( 1, 'DORMQR', 'LT',
     $                                           NROW, LDUN2, L, -1 ) )
         MAXWRK = MAX( MAXWRK, L + MNOBR*ILAENV( 1, 'DORMQR', 'LT',
     $                                           NROW, MNOBR, L, -1 ) )
C
         IF( M.GT.0 .AND. WITHB ) THEN
            MINWRK = MAX( MINWRK, 4*LNOBR+1, LNOBR + M )
            MAXWRK = MAX( MINWRK, MAXWRK, LNOBR +
     $                    M*ILAENV( 1, 'DORMQR', 'LT', LNOBR, M, LNOBR,
     $                              -1 ) )
         END IF
C
         IF ( LDWORK.LT.MINWRK ) THEN
            INFO = -28
            DWORK( 1 ) = MINWRK
         END IF
      END IF
C
C     Return if there are illegal arguments.
C
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'IB01PY', -INFO )
         RETURN
      END IF
C
C     Construct in  R  the first block-row of  Q,  i.e., the
C     (p/s)-by-L*s  matrix  [ Q_1s  ...  Q_12  Q_11  ],  where
C     Q_1i,  defined above, is  (p/s)-by-L,  for  i = 1:s.
C
      IF ( MOESP ) THEN
C
         DO 10 I = 1, NOBR
            CALL MA02AD( 'Full', L, NROW, UL(L*(I-1)+1,N+1), LDUL,
     $                    R(1,L*(NOBR-I)+1), LDR )
   10    CONTINUE
C
      ELSE
         JL = LNOBR
         JM = LDUN2
C
         DO 50 JI = 1, LDUN2, L
C
            DO 40 J = JI + L - 1, JI, -1
C
               DO 20 I = 1, N
                  R(I,J) = PGAL(I,JM) - UL(I,JL)
   20          CONTINUE
C
               DO 30 I = N + 1, NROW
                  R(I,J) = -UL(I,JL)
   30          CONTINUE
C
               JL = JL - 1
               JM = JM - 1
   40       CONTINUE
C
   50    CONTINUE
C
         DO 70 J = LNOBR, LDUN2 + 1, -1
C
            DO 60 I = 1, NROW
               R(I,J) = -UL(I,JL)
   60       CONTINUE
C
            JL = JL - 1
            R(N+J-LDUN2,J) = ONE + R(N+J-LDUN2,J)
   70    CONTINUE
      END IF
C
C     Triangularize the submatrix  Q_1s  using an orthogonal matrix  S.
C     Workspace: need 2*L, prefer L+L*NB.
C
      ITAU  = 1
      JWORK = ITAU + L
C
      CALL DGEQRF( NROW, L, R, LDR, DWORK(ITAU), DWORK(JWORK),
     $             LDWORK-JWORK+1, IERR )
C
C     Apply the transformation  S'  to the matrix
C     [ Q_1,s-1  ...  Q_11 ].  Therefore,
C
C                              [ R  P_s-1  P_s-2  ...  P_2  P_1 ]
C     S'[ Q_1,s  ...  Q_11 ] = [                                ].
C                              [ 0  F_s-1  F_s-2  ...  F_2  F_1 ]
C
C     Workspace: need L*NOBR, prefer L+(L*NOBR-L)*NB.
C
      CALL DORMQR( 'Left', 'Transpose', NROW, LDUN2, L, R, LDR,
     $             DWORK(ITAU), R(1,LP1), LDR, DWORK(JWORK),
     $             LDWORK-JWORK+1, IERR )
C
C     Apply the transformation  S'  to each of the submatrices  K_i  of
C     Kexpand = [ K_1'  K_2'  ...  K_s' ]',  K_i = K(:,(i-1)*m+1:i*m)
C     (i = 1:s)  being  (p/s)-by-m.  Denote  ( H_i'  G_i' )' = S'K_i
C     (i = 1:s),  where  H_i  has  L  rows.
C     Finally,  H_i  is saved in  H(L*(i-1)+1:L*i,1:m), i = 1:s.
C     (G_i  is in  K(L+1:p/s,(i-1)*m+1:i*m),  i = 1:s.)
C     Workspace: need L+M*NOBR, prefer L+M*NOBR*NB.
C
      CALL DORMQR( 'Left', 'Transpose', NROW, MNOBR, L, R, LDR,
     $             DWORK(ITAU), K, LDK, DWORK(JWORK), LDWORK-JWORK+1,
     $             IERR )
C
C     Put the rows to be annihilated (matrix F) in  UL(1:p/s-L,1:L*s-L).
C
      CALL DLACPY( 'Full', NROWML, LDUN2, R(LP1,LP1), LDR, UL, LDUL )
C
C     Now, the structure of the transformed matrices is:
C
C         [  R   P_s-1  P_s-2  ...  P_2  P_1  ]             [  H_1  ]
C         [  0     R    P_s-1  ...  P_3  P_2  ]             [  H_2  ]
C         [  0     0      R    ...  P_4  P_3  ]             [  H_3  ]
C         [  :     :      :          :    :   ]             [   :   ]
C         [  0     0      0    ...   R  P_s-1 ]             [ H_s-1 ]
C     Q = [  0     0      0     ...  0    R   ],  Kexpand = [  H_s  ],
C         [  0   F_s-1  F_s-2  ...  F_2  F_1  ]             [  G_1  ]
C         [  0     0    F_s-1  ...  F_3  F_2  ]             [  G_2  ]
C         [  :     :      :          :    :   ]             [   :   ]
C         [  0     0      0     ...  0  F_s-1 ]             [ G_s-1 ]
C         [  0     0      0     ...  0    0   ]             [  G_s  ]
C
C     where the block-rows have been permuted, to better exploit the
C     structure. The block-rows having  R  on the diagonal are dealt
C     with successively in the array  R.
C     The  F  submatrices are stored in the array  UL,  as a block-row.
C
C     Copy  H_1  in  H(1:L,1:m).
C
      CALL DLACPY( 'Full', L, M, K, LDK, H, LDH )
C
C     Triangularize the transformed matrix exploiting its structure.
C     Workspace: need L+MAX(L-1,L*NOBR-2*L,M*(NOBR-1)).
C
      DO 90 I = 1, NOBR - 1
C
C        Copy part of the preceding block-row and then annihilate the
C        current submatrix  F_s-i  using an orthogonal matrix modifying
C        the corresponding submatrix  R.  Simultaneously, apply the
C        transformation to the corresponding block-rows of the matrices
C        R  and  F.
C
         CALL DLACPY( 'Upper', L, LNOBR-L*I, R(L*(I-1)+1,L*(I-1)+1),
     $                LDR, R(L*I+1,L*I+1), LDR )
         CALL MB04OD( 'Full', L, LNOBR-L*(I+1), NROWML, R(L*I+1,L*I+1),
     $                LDR, UL(1,L*(I-1)+1), LDUL, R(L*I+1,L*(I+1)+1),
     $                LDR, UL(1,L*I+1), LDUL, DWORK(ITAU), DWORK(JWORK)
     $              )
C
C        Apply the transformation to the corresponding block-rows of
C        the matrix  G  and copy  H_(i+1)  in  H(L*i+1:L*(i+1),1:m).
C
         DO 80 J = 1, L
            CALL MB04OY( NROWML, M*(NOBR-I), UL(1,L*(I-1)+J), DWORK(J),
     $                   K(J,M*I+1), LDK, K(LP1,1), LDK, DWORK(JWORK) )
   80    CONTINUE
C
         CALL DLACPY( 'Full', L, M, K(1,M*I+1), LDK, H(L*I+1,1), LDH )
   90 CONTINUE
C
C     Return if only the factorization is needed.
C
      IF( M.EQ.0 .OR. .NOT.WITHB ) THEN
         DWORK(1) = MAXWRK
         RETURN
      END IF
C
C     Set the precision parameters. A threshold value  EPS**(2/3)  is
C     used for deciding to use pivoting or not, where  EPS  is the
C     relative machine precision (see LAPACK Library routine DLAMCH).
C
      EPS    = DLAMCH( 'Precision' )
      THRESH = EPS**( TWO/THREE )
      TOLL   = TOL
      IF( TOLL.LE.ZERO )
     $   TOLL = LNOBR*LNOBR*EPS
      SVLMAX = ZERO
C
C     Compute the reciprocal of the condition number of the triangular
C     factor  R  of  Q.
C     Workspace: need 3*L*NOBR.
C
      CALL DTRCON( '1-norm', 'Upper', 'NonUnit', LNOBR, R, LDR, RCOND,
     $             DWORK, IWORK, IERR )
C
      IF ( RCOND.GT.MAX( TOLL, THRESH ) ) THEN
C
C        The triangular factor  R  is considered to be of full rank.
C        Solve for  X,  R*X = H.
C
         CALL DTRSM( 'Left', 'Upper', 'NoTranspose', 'Non-unit',
     $               LNOBR, M, ONE, R, LDR, H, LDH )
      ELSE
C
C        Rank-deficient triangular factor  R.  Compute the
C        minimum-norm least squares solution of  R*X = H  using
C        the complete orthogonal factorization of  R.
C
         DO 100 I = 1, LNOBR
            IWORK(I) = 0
  100    CONTINUE
C
C        Workspace: need   4*L*NOBR+1;
C                   prefer 3*L*NOBR+(L*NOBR+1)*NB.
C
         JWORK = ITAU + LNOBR
         CALL DLASET( 'Lower', LNOBR-1, LNOBR, ZERO, ZERO, R(2,1), LDR )
         CALL MB03OD( 'QR', LNOBR, LNOBR, R, LDR, IWORK, TOLL, SVLMAX,
     $                DWORK(ITAU), RANK, SVAL, DWORK(JWORK),
     $                LDWORK-JWORK+1, IERR )
         MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 )
C
C        Workspace: need L*NOBR+M; prefer L*NOBR+M*NB.
C
         CALL DORMQR( 'Left', 'Transpose', LNOBR, M, LNOBR, R, LDR,
     $                DWORK(ITAU), H, LDH, DWORK(JWORK), LDWORK-JWORK+1,
     $                IERR )
         IF ( RANK.LT.LNOBR ) THEN
C
C           The least squares problem is rank-deficient.
C
            IWARN = 4
         END IF
C
C        Workspace: need L*NOBR+max(L*NOBR,M); prefer larger.
C
         CALL MB02QY( LNOBR, LNOBR, M, RANK, R, LDR, IWORK, H, LDH,
     $                DWORK(ITAU), DWORK(JWORK), LDWORK-JWORK+1, IERR )
         MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 )
      END IF
C
C     Construct the matrix  D,  if needed.
C
      IF ( WITHD )
     $   CALL DLACPY( 'Full', L, M, H(LDUN2+1,1), LDH, D, LDD )
C
C     Compute  B  by solving another linear system (possibly in
C     a least squares sense).
C
C     Make a block-permutation of the rows of the right-hand side,  H,
C     to construct the matrix
C
C        [ H(L*(s-2)+1:L*(s-1),:); ... H(L+1:L*2,:); H(1:L),:) ]
C
C     in  H(1:L*s-L,1:n).
C
      NOBRH = NOBR/2 + MOD( NOBR, 2 ) - 1
C
      DO 120 J = 1, M
C
         DO 110 I = 1, NOBRH
            CALL DSWAP( L, H(L*(I-1)+1,J), 1, H(L*(NOBR-I-1)+1,J), 1 )
  110    CONTINUE
C
  120 CONTINUE
C
C     Solve for  B  the matrix equation  GaL*B = H(1:L*s-L,:),  using
C     the available QR factorization of  GaL,  if  METH = 'M'  and
C     rank(GaL) = n, or the available pseudoinverse of  GaL,  otherwise.
C
      IF ( MOESP .AND. RANKR1.EQ.N ) THEN
C
C        The triangular factor  r1  of  GaL  is considered to be of
C        full rank. Compute  Q1'*H  in  H  and then solve for  B,
C        r1*B = H(1:n,:)  in  B,  where  Q1  is the orthogonal matrix
C        in the QR factorization of  GaL.
C        Workspace: need M; prefer M*NB.
C
         CALL DORMQR( 'Left', 'Transpose', LDUN2, M, N, R1, LDR1,
     $                TAU1, H, LDH, DWORK, LDWORK, IERR )
         MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) )
C
C        Compute the solution in  B.
C
         CALL DLACPY( 'Full', N, M, H, LDH, B, LDB )
C
         CALL DTRTRS( 'Upper', 'NoTranspose', 'NonUnit', N, M, R1, LDR1,
     $                B, LDB, IERR )
         IF ( IERR.GT.0 ) THEN
            INFO = 3
            RETURN
         END IF
      ELSE
C
C        Rank-deficient triangular factor  r1.  Use the available
C        pseudoinverse of  GaL  for computing  B  from  GaL*B = H.
C
         CALL DGEMM ( 'NoTranspose', 'NoTranspose', N, M, LDUN2, ONE,
     $                PGAL, LDPGAL, H, LDH, ZERO, B, LDB )
      END IF
C
C     Return optimal workspace in  DWORK(1)  and reciprocal condition
C     number in  DWORK(2).
C
      DWORK(1) = MAXWRK
      DWORK(2) = RCOND
C
      RETURN
C
C *** Last line of IB01PY ***
      END


MODULE anglemod

  USE MathConstants
  USE SubTabulate
  USE SourceReceiverPositions
  USE SortMod
  USE FatalError

  IMPLICIT NONE
  SAVE

  INTEGER          :: ialpha, ibeta
  INTEGER, PRIVATE :: AllocateStatus
  INTEGER,       PRIVATE, PARAMETER :: ENVFile = 5, PRTFile = 6
  REAL (KIND=8), PRIVATE, PARAMETER :: c0 = 1500.0

  TYPE AnglesStructure
     INTEGER       :: Nalpha = 0, Nbeta = 1, iSingle_alpha = 0, iSingle_beta = 0
     REAL (KIND=8) :: Dalpha, Dbeta
     REAL (KIND=8), ALLOCATABLE:: alpha( : ), beta( : )
  END TYPE AnglesStructure

  Type( AnglesStructure ) :: Angles

CONTAINS
  SUBROUTINE ReadRayElevationAngles( freq, Depth, TopOpt, RunType )

    REAL      (KIND=8), INTENT( IN  ) :: freq, Depth
    CHARACTER (LEN= 6), INTENT( IN  ) :: TopOpt, RunType
    REAL      (KIND=8)                :: d_theta_recommended

    IF ( TopOpt( 6 : 6 ) == 'I' ) THEN
       READ( ENVFile, * ) Angles%Nalpha, Angles%iSingle_alpha ! option to trace a single beam
    ELSE
       READ( ENVFile, * ) Angles%Nalpha
    END IF

    IF ( Angles%Nalpha == 0 ) THEN   ! automatically estimate Nalpha to use
       IF ( RunType( 1 : 1 ) == 'R' ) THEN
          Angles%Nalpha = 50         ! For a ray trace plot, we don't want too many rays ...
       ELSE
          ! you're letting ME choose? OK: ideas based on an isospeed ocean
          ! limit based on phase of adjacent beams at maximum range
          Angles%Nalpha = MAX( INT( 0.3 * Pos%Rr( Pos%NRr ) * freq / c0 ), 300 )

          ! limit based on having beams that are thin with respect to the water depth
          ! assumes also a full 360 degree angular spread of rays
          ! Should check which Depth is used here, in case where there is a variable bathymetry
          d_theta_recommended = ATAN( Depth / ( 10.0 * Pos%Rr( Pos%NRr ) ) )
          Angles%Nalpha = MAX( INT( pi / d_theta_recommended ), Angles%Nalpha )
       END IF
    END IF

    ALLOCATE( Angles%alpha( MAX( 3, Angles%Nalpha ) ), STAT = AllocateStatus )
    IF ( AllocateStatus /= 0 ) CALL ERROUT( 'ReadRayElevationAngles', 'Insufficient memory to store beam angles'  )

    IF ( Angles%Nalpha > 2 ) Angles%alpha( 3 ) = -999.9
    READ( ENVFile, * ) Angles%alpha

    CALL SubTab( Angles%alpha, Angles%Nalpha )
    CALL Sort(   Angles%alpha, Angles%Nalpha )

    ! full 360-degree sweep? remove duplicate beam
    IF ( Angles%Nalpha > 1 .AND. ABS( MOD( Angles%alpha( Angles%Nalpha ) - Angles%alpha( 1 ), 360.0D0 ) ) < 10.0 * TINY( 1.0D0 ) ) &
         Angles%Nalpha = Angles%Nalpha - 1

    WRITE( PRTFile, * ) '__________________________________________________________________________'
    WRITE( PRTFile, * )
    WRITE( PRTFile, * ) 'Number of beams in elevation   = ', Angles%Nalpha
    IF ( Angles%iSingle_alpha > 0 ) WRITE( PRTFile, * ) 'Trace only beam number ', Angles%iSingle_alpha
    WRITE( PRTFile, * ) 'Beam take-off angles (degrees)'

    IF ( Angles%Nalpha >= 1 ) WRITE( PRTFile, "( 5G14.6 )" ) Angles%alpha( 1 : MIN( Angles%Nalpha, Number_to_Echo ) )
    IF ( Angles%Nalpha > Number_to_Echo ) WRITE( PRTFile,  "( G14.6 )" ) ' ... ', Angles%alpha( Angles%Nalpha )

    IF ( Angles%Nalpha > 1 .AND. Angles%alpha( Angles%Nalpha ) == Angles%alpha( 1 ) ) &
         CALL ERROUT( 'ReadRayElevationAngles', 'First and last beam take-off angle are identical' )

    IF ( TopOpt( 6 : 6 ) == 'I' ) THEN
       IF ( Angles%iSingle_alpha < 1 .OR. Angles%iSingle_alpha > Angles%Nalpha ) &
            CALL ERROUT( 'ReadRayElevationAngles', 'Selected beam, iSingl not in [ 1, Angles%Nalpha ]' )
    END IF

  END SUBROUTINE ReadRayElevationAngles

  !**********************************************************************!

  SUBROUTINE ReadRayBearingAngles( freq, TopOpt, RunType )

    REAL      (KIND=8), INTENT( IN ) :: freq
    CHARACTER (LEN= 6), INTENT( IN ) :: TopOpt, RunType

    IF ( TopOpt( 6 : 6 ) == 'I' ) THEN
       READ( ENVFile, * ) Angles%Nbeta, Angles%iSingle_beta ! option to trace a single beam
    ELSE
       READ( ENVFile, * ) Angles%Nbeta
    END IF

    IF ( Angles%Nbeta == 0 ) THEN   ! automatically estimate Nbeta to use
       IF ( RunType( 1 : 1 ) == 'R' ) THEN
          Angles%Nbeta = 50         ! For a ray trace plot, we don't want too many rays ...
       ELSE
          Angles%Nbeta = MAX( INT( 0.1 * Pos%rr( Pos%NRr ) * freq / c0 ), 300 )
       END IF
    END IF

    ALLOCATE( Angles%beta( MAX( 3, Angles%Nbeta ) ), STAT = AllocateStatus )
    IF ( AllocateStatus /= 0 ) CALL ERROUT( 'ReadRayBearingAngles', 'Insufficient memory to store beam angles'  )

    IF ( Angles%Nbeta > 2 ) Angles%beta( 3 ) = -999.9
    READ( ENVFile, * ) Angles%beta

    CALL SubTab( Angles%beta, Angles%Nbeta )
    CALL Sort(   Angles%beta, Angles%Nbeta )

    ! full 360-degree sweep? remove duplicate beam
    IF ( Angles%Nbeta > 1 .AND. ABS( MOD( Angles%beta( Angles%Nbeta ) - Angles%beta( 1 ), 360.0D0 ) ) < 10.0 * TINY( 1.0D0 ) ) &
         Angles%Nbeta = Angles%Nbeta - 1

    ! Nx2D CASE: beams must lie on rcvr radials--- replace beta with theta
    IF ( RunType( 6 : 6 ) == '2' .AND. RunType( 1 : 1 ) /= 'R' ) THEN
       WRITE( PRTFile, * )
       WRITE( PRTFile, * ) 'Replacing beam take-off angles, beta, with receiver bearing lines, theta'
       DEALLOCATE( Angles%beta )

       Angles%Nbeta = Pos%Ntheta
       ALLOCATE( Angles%beta( MAX( 3, Angles%Nbeta ) ), STAT = AllocateStatus )
       IF ( AllocateStatus /= 0 ) CALL ERROUT( 'ReadRayBearingAngles', 'Insufficient memory to store beam angles'  )
       Angles%beta( 1 : Angles%Nbeta ) = Pos%theta( 1 : Pos%Ntheta )   ! Nbeta should = Ntheta
    END IF

    WRITE( PRTFile, * )
    WRITE( PRTFile, * ) 'Number of beams in bearing   = ', Angles%Nbeta
    IF ( Angles%iSingle_beta > 0 ) WRITE( PRTFile, * ) 'Trace only beam number ', Angles%iSingle_beta
    WRITE( PRTFile, * ) 'Beam take-off angles (degrees)'

    IF ( Angles%Nbeta >= 1 ) WRITE( PRTFile, "( 5G14.6 )" ) Angles%beta( 1 : MIN( Angles%Nbeta, Number_to_Echo ) )
    IF ( Angles%Nbeta > Number_to_Echo ) WRITE( PRTFile, "( G14.6 )" ) ' ... ', Angles%beta( Angles%Nbeta )

    IF ( Angles%Nbeta > 1 .AND. Angles%beta( Angles%Nbeta ) == Angles%beta( 1 ) ) &
         CALL ERROUT( 'ReadRayBearingAngles', 'First and last beam take-off angle are identical' )

    IF ( TopOpt( 6 : 6 ) == 'I' ) THEN
       IF ( Angles%iSingle_beta < 1 .OR. Angles%iSingle_beta > Angles%Nbeta ) &
            CALL ERROUT( 'ReadRayBearingAngles', 'Selected beam, iSingl not in [ 1, Angles%Nbeta ]' )
    END IF
    Angles%beta  = DegRad * Angles%beta   ! convert to radians

    Angles%Dbeta = 0.0
    IF ( Angles%Nbeta /= 1 ) Angles%Dbeta = ( Angles%beta( Angles%NBeta ) - Angles%beta( 1 ) ) / ( Angles%Nbeta - 1 )

  END SUBROUTINE ReadRayBearingAngles

END MODULE anglemod


MODULE main
!
INTERFACE
!
SUBROUTINE bandred(a,d,e)
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN OUT)::a(:,:)
 REAL(iwp),INTENT(OUT)::d(0:),e(0:)
END SUBROUTINE bandred
!
FUNCTION bandwidth(g) RESULT(nband)
 IMPLICIT NONE
 INTEGER,INTENT(IN)::g(:)
 INTEGER::nband
END FUNCTION bandwidth
!
SUBROUTINE banmul(kb,loads,ans)
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::kb(:,:),loads(0:)
 REAL(iwp),INTENT(OUT)::ans(0:)
END SUBROUTINE banmul
!
SUBROUTINE bantmul(kb,loads,ans)
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::kb(:,:),loads(0:)
 REAL(iwp),INTENT(OUT)::ans(0:)
END SUBROUTINE bantmul
!
SUBROUTINE beamdis(loads,nf,ratmax,interp,nels,ell,argv,nlen,ips)
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::loads(0:),ratmax,ell(:)
 INTEGER,INTENT(IN)::ips,nf(:,:),nels,interp,nlen
 CHARACTER(LEN=15)::argv
END SUBROUTINE beamdis
!
SUBROUTINE beam_gm(gm,ell)
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::ell
 REAL(iwp),INTENT(OUT)::gm(:,:)
END SUBROUTINE beam_gm
!
SUBROUTINE beam_km(km,ei,ell)
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::ei,ell
 REAL(iwp),INTENT(OUT)::km(:,:)
END SUBROUTINE beam_km
!
SUBROUTINE beam_mm(mm,fs,ell)
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::fs,ell
 REAL(iwp),INTENT(OUT)::mm(:,:)
END SUBROUTINE beam_mm
!
SUBROUTINE beemat(bee,deriv)
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::deriv(:,:)
 REAL(iwp),INTENT(OUT)::bee(:,:)
END SUBROUTINE beemat
!
SUBROUTINE bee8(bee,coord,xi,eta,det)
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::coord(:,:),xi,eta
 REAL(iwp),INTENT(OUT)::bee(:,:),det
END SUBROUTINE bee8
!
SUBROUTINE bisect(d,e,acheps,ifail)
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::acheps
 REAL(iwp),INTENT(IN OUT)::d(0:),e(0:)
 INTEGER,INTENT(IN OUT)::ifail
END SUBROUTINE bisect
!
SUBROUTINE bmat_nonaxi(bee,radius,coord,deriv,fun,iflag,lth)
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::deriv(:,:),fun(:),coord(:,:)
 REAL(iwp),INTENT(OUT)::bee(:,:),radius
 INTEGER,INTENT(IN)::iflag,lth
END SUBROUTINE bmat_nonaxi
!
SUBROUTINE checon(loads,oldlds,tol,converged)
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::loads(0:),tol
 REAL(iwp),INTENT(IN OUT)::oldlds(0:)
 logical,INTENT(OUT)::CONVERGED
END SUBROUTINE checon
!
subroutine chobk1(kb,loads)
 implicit none
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),intent(in)::kb(:,:)
 REAL(iwp),intent(in out)::loads(0:)
end subroutine chobk1
!
subroutine chobk2(kb,loads)
!Choleski back-substitution
 implicit none
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),intent(in)::kb(:,:)
 REAL(iwp),intent(in out)::loads(0:)
end subroutine chobk2
!
subroutine cholin(kb)
 implicit none
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),intent(in out)::kb(:,:)
end subroutine cholin
!
SUBROUTINE comred(bk,n)
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 COMPLEX(iwp),INTENT(IN OUT)::bk(:)
 INTEGER,INTENT(IN)::n
END SUBROUTINE COMRED
!
SUBROUTINE COMSUB(bk,loads)
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 COMPLEX(iwp),INTENT(IN)::bk(:)
 COMPLEX(iwp),INTENT(IN OUT)::loads(0:)
END SUBROUTINE comsub
!
SUBROUTINE contour(loads,g_coord,g_num,ned,argv,nlen,ips)
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::loads(0:),g_coord(:,:)
 INTEGER,INTENT(IN)::g_num(:,:),ned,ips,nlen
 CHARACTER(*),INTENT(IN)::argv
END SUBROUTINE contour
!
SUBROUTINE cross_product(b,c,a)
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::b(:),c(:)
 REAL(iwp),INTENT(OUT)::a(:,:)
END SUBROUTINE cross_product
!
SUBROUTINE deemat(dee,e,v)
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::e,v
 REAL(iwp),INTENT(OUT)::dee(:,:)
END SUBROUTINE deemat
!
FUNCTION determinant(jac)RESULT(det)
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::jac(:,:)
 REAL(iwp)::det
END FUNCTION determinant
!
SUBROUTINE dismsh(loads,nf,ratmax,g_coord,g_num,argv,nlen,ips)
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::g_coord(:,:),loads(0:),ratmax
 CHARACTER(*),INTENT(IN)::argv
 INTEGER,INTENT(IN)::g_num(:,:),ips,nf(:,:),nlen
END SUBROUTINE dismsh
!
SUBROUTINE dismsh_ensi(argv,nlen,step,nf,loads)
 IMPLICIT none
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 INTEGER,INTENT(IN)::nlen,step,nf(:,:)
 REAL(iwp),INTENT(IN)::loads(:)
 CHARACTER(LEN=15),INTENT(IN)::argv
END SUBROUTINE dismsh_ensi
!
SUBROUTINE ecmat(ecm,fun,ndof,nodof)
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::fun(:)
 REAL(iwp),INTENT(OUT)::ecm(:,:)
 INTEGER,INTENT(IN)::nodof,ndof
END SUBROUTINE ecmat
!
SUBROUTINE elmat(area,rho,emm)
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::area,rho
 REAL(iwp),INTENT(OUT)::emm(:,:)
END SUBROUTINE elmat
!
SUBROUTINE exc_nods(noexe,exele,g_num,totex,ntote,nf)
 IMPLICIT NONE
 INTEGER,INTENT(IN)::noexe,exele(:),g_num(:,:)
 INTEGER,INTENT(IN OUT)::totex(:),ntote,nf(:,:)
END SUBROUTINE exc_nods
!
SUBROUTINE fkdiag(kdiag,g)
 IMPLICIT NONE
 INTEGER,INTENT(IN)::g(:)
 INTEGER,INTENT(OUT)::kdiag(:)
END SUBROUTINE fkdiag
!
SUBROUTINE fmacat(vmfl,acat)
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::vmfl(:)
 REAL(iwp),INTENT(OUT)::acat(:,:)
END SUBROUTINE fmacat
!
SUBROUTINE fmdsig(dee,e,v)
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::e,v
 REAL(iwp),INTENT(OUT)::dee(:,:)
END SUBROUTINE fmdsig
!
SUBROUTINE fmkdke(km,kp,c,ke,kd,theta)
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::km(:,:),kp(:,:),c(:,:),theta
 REAL(iwp),INTENT(OUT)::ke(:,:),kd(:,:)
END SUBROUTINE fmkdke
!
SUBROUTINE fmplat(d2x,d2y,d2xy,points,aa,bb,i)
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::points(:,:),aa,bb
 REAL(iwp),INTENT(OUT)::d2x(:),d2y(:),d2xy(:)
 INTEGER,INTENT(IN)::i
END SUBROUTINE fmplat
!
SUBROUTINE fmrmat(vmfl,dsbar,dlam,dee,rmat)
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::vmfl(:),dsbar,dlam,dee(:,:)
 REAL(iwp),INTENT(OUT)::rmat(:,:)
END SUBROUTINE fmrmat
!
SUBROUTINE formaa(vmfl,rmat,daatd)
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::vmfl(:),rmat(:,:)
 REAL(iwp),INTENT(OUT)::daatd(:,:)
END SUBROUTINE formaa
!
SUBROUTINE formkb(kb,km,g)
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::km(:,:)
 REAL(iwp),INTENT(OUT)::kb(:,:)
 INTEGER,INTENT(IN)::g(:)
END SUBROUTINE formkb
!
SUBROUTINE formkc(bk,km,cm,g,n)
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::km(:,:),cm(:,:)
 COMPLEX(iwp),INTENT(OUT)::bk(:)
 INTEGER,INTENT(IN)::g(:),n
END SUBROUTINE FORMKC
!
SUBROUTINE formke(km,kp,c,ke,theta)
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::km(:,:),kp(:,:),c(:,:),theta
 REAL(iwp),INTENT(OUT)::ke(:,:)
END SUBROUTINE formke
!
SUBROUTINE formku(ku,km,g)
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::km(:,:)
 REAL(iwp),INTENT(OUT)::ku(:,:)
 INTEGER,INTENT(IN)::g(:)
END SUBROUTINE formku
!
SUBROUTINE formlump(diag,emm,g)
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::emm(:,:)
 REAL(iwp),INTENT(OUT)::diag(0:)
 INTEGER,INTENT(IN)::g(:)
END SUBROUTINE formlump
!
SUBROUTINE formm(stress,m1,m2,m3)
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::stress(:)
 REAL(iwp),INTENT(OUT)::m1(:,:),m2(:,:),m3(:,:)
END SUBROUTINE formm
!
SUBROUTINE formtb(pb,km,g)
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::km(:,:)
 INTEGER,INTENT(IN)::g(:)
 REAL(iwp),INTENT(OUT)::pb(:,:)
END SUBROUTINE formtb
!
SUBROUTINE formupv(ke,c11,c12,c21,c23,c32)
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::c11(:,:),c21(:,:),c23(:,:),c32(:,:),c12(:,:)
 REAL(iwp),INTENT(OUT)::ke(:,:)
END SUBROUTINE formupv
!
SUBROUTINE form_s(gg,ell,kappa,omega,gamma,s)
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::gg(:,:),kappa
 INTEGER,INTENT(IN)::ell
 REAL(iwp),INTENT(OUT)::omega,gamma(:),s(:)
END SUBROUTINE form_s
!
SUBROUTINE fsparv(kv,km,g,kdiag)
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 INTEGER,INTENT(IN)::g(:),kdiag(:)
 REAL(iwp),INTENT(IN)::km(:,:)
 REAL(iwp),INTENT(OUT)::kv(:)
END SUBROUTINE fsparv
!
SUBROUTINE gauss_band(pb,work)
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN OUT)::pb(:,:),work(:,:)
END SUBROUTINE gauss_band
!
SUBROUTINE getname(argv,nlen)
 IMPLICIT NONE
 INTEGER::narg
 INTEGER,INTENT(OUT)::nlen
 CHARACTER(*),INTENT(OUT)::argv
 INTEGER::lnblnk,iargc
END SUBROUTINE getname
!
SUBROUTINE glob_to_axial(axial,global,coord)
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::global(:),coord(:,:)
 REAL(iwp),INTENT(OUT)::axial
END SUBROUTINE glob_to_axial
!
SUBROUTINE glob_to_loc(local,global,gamma,coord)
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::global(:),gamma,coord(:,:)
 REAL(iwp),INTENT(OUT)::local(:)
END SUBROUTINE glob_to_loc
!
SUBROUTINE hinge(coord,holdr,action,react,prop,iel,etype,gamma)
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::holdr(:,:),coord(:,:),action(:),prop(:,:),gamma(:)
 REAL(iwp),INTENT(OUT)::react(:)
 INTEGER,INTENT(IN)::etype(:),iel
END SUBROUTINE hinge
!
SUBROUTINE invar(stress,sigm,dsbar,theta)
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::stress(:)
 REAL(iwp),INTENT(OUT),OPTIONAL::sigm,dsbar,theta
END SUBROUTINE invar
!
SUBROUTINE interp(k,dtim,rt,rl,al,nstep)
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::dtim,rt(:),rl(:)
 INTEGER,INTENT(IN)::k,nstep
 REAL(iwp),INTENT(IN OUT)::al(:,:)
END SUBROUTINE interp
!
SUBROUTINE invert(matrix)
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN OUT)::matrix(:,:)
END SUBROUTINE invert
!
SUBROUTINE linmul_sky(kv,disps,loads,kdiag)
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::kv(:),disps(0:)
 REAL(iwp),INTENT(OUT)::loads(0:)
 INTEGER,INTENT(IN)::kdiag(:)
END SUBROUTINE linmul_sky
!
INTEGER FUNCTION lnblnk( str )
 CHARACTER*(*),INTENT(IN)::str
END FUNCTION lnblnk
!
SUBROUTINE load_function(lf,dtim,al)
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::lf(:,:),dtim
 REAL(iwp),INTENT(IN OUT)::al(:)
END SUBROUTINE load_function
!
SUBROUTINE loc_to_glob(local,global,gamma,coord)
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::local(:),gamma,coord(:,:)
 REAL(iwp),INTENT(OUT)::global(:)
END SUBROUTINE loc_to_glob
!
SUBROUTINE mesh(g_coord,g_num,argv,nlen,ips)
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::g_coord(:,:)
 INTEGER,INTENT(IN)::g_num(:,:),ips,nlen
 CHARACTER(*),INTENT(IN)::argv
END SUBROUTINE mesh
!
SUBROUTINE mesh_ensi(argv,nlen,g_coord,g_num,element,etype,nf,loads,     &
                     nstep,npri,dtim,solid)
 IMPLICIT none
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 INTEGER,INTENT(IN)::nlen,nstep,npri
 INTEGER,INTENT(IN)::g_num(:,:),etype(:),nf(:,:)
 REAL(iwp),INTENT(IN)::g_coord(:,:),loads(:),dtim
 CHARACTER(LEN=15),INTENT(IN)::argv,element
 LOGICAL,INTENT(IN)::solid
END SUBROUTINE mesh_ensi
!
SUBROUTINE mcdpl(phi,psi,dee,stress,pl)
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::stress(:),dee(:,:),phi,psi
 REAL(iwp),INTENT(OUT)::pl(:,:)
END SUBROUTINE mcdpl
!
SUBROUTINE mocouf(phi,c,sigm,dsbar,theta,f)
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::phi,c,sigm,dsbar,theta
 REAL(iwp),INTENT(OUT)::f
END SUBROUTINE mocouf
!
SUBROUTINE mocouq(psi,dsbar,theta,dq1,dq2,dq3)
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::psi,dsbar,theta
 REAL(iwp),INTENT(OUT)::dq1,dq2,dq3
END SUBROUTINE mocouq
!
FUNCTION norm(x)RESULT(l2n)
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::x(:)
 REAL(iwp)::l2n
END FUNCTION norm
!
SUBROUTINE num_to_g(num,nf,g)
 IMPLICIT NONE
 INTEGER,INTENT(IN)::num(:),nf(:,:)
 INTEGER,INTENT(OUT)::g(:)
END SUBROUTINE num_to_g
!
SUBROUTINE pin_jointed(km,ea,coord)
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::ea,coord(:,:)
 REAL(iwp),INTENT(OUT)::km(:,:)
END SUBROUTINE pin_jointed
!
SUBROUTINE pmsh_ensi(argv,nlen,step,loads)
 IMPLICIT none
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 INTEGER,INTENT(IN)::nlen,step
 REAL(iwp),INTENT(IN)::loads(:)
 CHARACTER(LEN=15),INTENT(IN)::argv
END SUBROUTINE pmsh_ensi
!
SUBROUTINE rect_km(km,coord,e,v)
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::coord(:,:),e,v
 REAL(iwp),INTENT(OUT)::km(:,:)
END SUBROUTINE rect_km
!
SUBROUTINE rigid_jointed(km,prop,gamma,etype,iel,coord)
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::gamma(:),coord(:,:),prop(:,:)
 INTEGER,INTENT(IN)::etype(:),iel
 REAL(iwp),INTENT(OUT)::km(:,:)
END SUBROUTINE rigid_jointed
!
SUBROUTINE rod_km(km,ea,length)
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::ea,length
 REAL(iwp),INTENT(OUT)::km(:,:)
END SUBROUTINE rod_km
!
SUBROUTINE rod_mm(mm,length)
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),intent(in)::length
 REAL(iwp),intent(out)::mm(:,:)
END SUBROUTINE rod_mm
!
SUBROUTINE sample(element,s,wt)
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(OUT)::s(:,:)
 REAL(iwp),INTENT(OUT),optional::wt(:)
 CHARACTER(*),INTENT(IN)::element
END SUBROUTINE sample
!
SUBROUTINE seep4(kp,coord,perm)
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::coord(:,:),perm(:,:)
 REAL(iwp),INTENT(OUT)::kp(:,:)
END SUBROUTINE seep4
!
SUBROUTINE shape_der(der,points,i)
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 INTEGER,INTENT(IN)::i
 REAL(iwp),INTENT(IN)::points(:,:)
 REAL(iwp),INTENT(OUT)::der(:,:)
END SUBROUTINE shape_der
!
SUBROUTINE shape_fun(fun,points,i)
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 INTEGER,INTENT(in)::i
 REAL(iwp),INTENT(IN)::points(:,:)
 REAL(iwp),INTENT(OUT)::fun(:)
END SUBROUTINE shape_fun
!
SUBROUTINE solve_band(pb,work,loads)
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::pb(:,:),work(:,:)
 REAL(iwp),INTENT(OUT)::loads(0:)
END SUBROUTINE solve_band
!
SUBROUTINE spabac(kv,loads,kdiag)
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::kv(:)
 REAL(iwp),INTENT(IN OUT)::loads(0:)
 INTEGER,INTENT(IN)::kdiag(:)
END SUBROUTINE spabac
!
SUBROUTINE spabac_gauss(kv,loads,kdiag)
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::kv(:)
 REAL(iwp),INTENT(IN OUT)::loads(0:)
 INTEGER,INTENT(IN)::kdiag(:)
END SUBROUTINE spabac_gauss
!
SUBROUTINE sparin(kv,kdiag)
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN OUT)::kv(:)
 INTEGER,INTENT(IN)::kdiag(:)
END SUBROUTINE sparin
!
SUBROUTINE sparin_gauss(kv,kdiag)
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 INTEGER,INTENT(IN)::kdiag(:)
 REAL(iwp),INTENT(OUT)::kv(:)
END SUBROUTINE sparin_gauss
!
SUBROUTINE stability(kv,gv,kdiag,tol,limit,iters,evec,eval)
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 INTEGER,INTENT(IN)::limit,kdiag(:)
 INTEGER,INTENT(OUT)::iters
 REAL(iwp),INTENT(IN OUT)::kv(:),gv(:),tol,eval
 REAL(iwp),INTENT(OUT)::evec(:)
END SUBROUTINE stability
!
SUBROUTINE stiff3(km,coord,ym,pr)
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::coord(:,:),ym,pr
 REAL(iwp),INTENT(OUT)::km(:,:)
END SUBROUTINE stiff3
!
SUBROUTINE stiff4(km,coord,ym,pr)
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::coord(:,:),ym,pr
 REAL(iwp),INTENT(OUT)::km(:,:)
END SUBROUTINE stiff4
!
SUBROUTINE stiff6(km,coord,ym,pr)
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::coord(:,:),ym,pr
 REAL(iwp),INTENT(OUT)::km(:,:)
END SUBROUTINE stiff6
!
SUBROUTINE stiff10(km,coord,ym,pr)
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::coord(:,:),ym,pr
 REAL(iwp),INTENT(OUT)::km(:,:)
END SUBROUTINE stiff10
!
SUBROUTINE stiff15(km,coord,ym,pr)
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::coord(:,:),ym,pr
 REAL(iwp),INTENT(OUT)::km(:,:)
END SUBROUTINE stiff15
!
SUBROUTINE vecmsh(loads,nf,ratmax,cutoff,g_coord,g_num,argv,nlen,ips)
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::g_coord(:,:),loads(0:),ratmax,cutoff
 INTEGER,INTENT(IN)::g_num(:,:),ips,nf(:,:),nlen
 CHARACTER(*),INTENT(IN)::argv
END SUBROUTINE vecmsh
!
SUBROUTINE vmdpl(dee,stress,pl)
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::stress(:),dee(:,:)
 REAL(iwp),INTENT(OUT)::pl(:,:)
END SUBROUTINE vmdpl
!
SUBROUTINE vmflow(stress,dsbar,vmfl)
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::stress(:),dsbar
 REAL(iwp),INTENT(OUT)::vmfl(:)
END SUBROUTINE vmflow
!
END INTERFACE
!
END MODULE main


! Check that we correctly simplify ISNAN
!
! { dg-do compile }
!
! { dg-options "-fno-range-check" }
! { dg-add-options ieee }
! { dg-skip-if "NaN not supported" { spu-*-* } }

  implicit none
  real, parameter :: inf = 2 * huge(inf)
  real, parameter :: nan1 = 0. / 0.
  real, parameter :: nan2 = 1.5 * nan1
  real, parameter :: nan3 = inf / inf
  real, parameter :: nan4 = inf - inf
  real, parameter :: nan5 = 0. * inf
  real, parameter :: normal = 42.

  integer(kind=merge(4, 0, isnan(nan1))) :: a
  integer(kind=merge(4, 0, isnan(nan2))) :: b
  integer(kind=merge(4, 0, isnan(nan3))) :: c
  integer(kind=merge(4, 0, isnan(nan4))) :: d
  integer(kind=merge(4, 0, isnan(nan5))) :: e

  integer(kind=merge(0, 4, isnan(inf))) :: f
  integer(kind=merge(0, 4, isnan(-inf))) :: g
  integer(kind=merge(0, 4, isnan(normal))) :: h

  end


      subroutine setprob
      implicit double precision (a-h,o-z)
      common /comaux/ z1,c1,z2,c2
c
c     # Set the material parameters for the acoustic equations
c
      !open(unit=7,file='setprob.data',status='old',form='formatted')
      call opendatafile(7, 'setprob.data')
c
c     # Piecewise constant medium with single interface as specified
c     # in setaux.f

c     # Impedance and sound speed in the two materials:

      read(7,*) z1
      read(7,*) c1
      read(7,*) z2
      read(7,*) c2

      return
      end


module gls_mod

    implicit none
    integer, parameter :: dp=kind(0.d0)
    real(dp), parameter :: twopi=2.0_dp*acos(-1.0_dp)
    save

contains

    subroutine readfile(name,nmax,wexp,deferr,wsum,t,flx,flxerr,ww)
    use omp_lib
    implicit none

    character, intent(in) :: name*80
    integer, intent(in) :: nmax
    integer, intent(inout) :: wexp
    real(dp), intent(in) :: deferr
    real(dp), intent(out) :: wsum
    real(dp), dimension(:), allocatable, intent(out) :: flx, flxerr, ww, t

    character :: line*1024
    logical :: isinputfile, iforce
    integer :: io=0, ae=0, ioc=0, i, ntok, n
    real(dp) :: tmin

    iforce=.false.
    tmin=1.0d30

    inquire(file=name, exist=isinputfile)
    if (isinputfile.eqv.(.false.)) then
        write(0,*) "ERROR: input file does not exist."
        stop
        endif

    ! >>> Read time-series and calculate some sums.

    open(unit=1, file=name, status='old' )
    i=1
    do
        read(1,'(a)',IOSTAT=io) line
        if (io>0) then
            print *,name
            write(0,*) "I/O ERROR ",io,": unreadable input."
            close(1)
            stop
        endif
        if (io<0) exit
        if (index(line,'#')/=0) cycle                  ! skip comment line
        if (lnblnk(line)==0) cycle                     ! skip empty line
        N=i
        i=i+1
    enddo

    allocate(flx(n), STAT = ae)
    allocate(flxerr(n), STAT = ae)
    allocate(ww(n), STAT = ae)
    allocate(t(n), STAT = ae)

    if(ae/=0) then
      write(0,*) "ALLOCATION ERROR ",ae
    endif

    !print *,N," lines read."

    rewind(1,IOSTAT=io)
    if(io/=0) then
      write(0,*) "I/O ERROR ",io,": rewind failed."
    endif

    if (index(name,'#') .gt. 0)  read(1,*)     ! skip header
    wsum = 0.0_dp
    i=1
    do
        read(1,'(a)',IOSTAT=io) line                   ! read line from datafile
        if (io>0) then
            write(0,*) "I/O ERROR: unreadable input."
            close(1)
            stop
        endif
        if (io<0) exit                                 ! End of file, exit loop.
        ! print *,line
        if (index(line,'#')/=0) cycle                  ! skip comment line
        if (lnblnk(line)==0) cycle                     ! skip empty line
        ntok=ntokens(line)

        if ( ntok == 3 ) then                          ! error values present (3rd column)
            read(line,*,IOSTAT=ioc) t(i),flx(i),flxerr(i)
            !write(6,*) i,t(i),flx(i),flxerr(i)
            if (flxerr(i)==0.0_dp) flxerr(i)=deferr
            if (ioc>0) then
                write(0,*) "I/O ERROR: unreadable input."
                close(1)
                stop
            endif
        else if ( ntok == 2 ) then                      ! no error values, will use variance
            read(line,*,IOSTAT=ioc) t(i),flx(i)
            if (ioc>0) then
                write(0,*) "I/O ERROR: unreadable input."
                close(1)
                stop
            endif
            flxerr(i) = 1.0_dp
            if ( wexp == 2 ) then
                write(0,*) "WARNING: no error values in input file!"
                write(0,*) "  Forcing wexp = 0"
                wexp=0
                iforce=.true.
            endif
        else
            write(0,*) "I/O ERROR: number of input columns must be 2 or 3."
            close(1)
            stop
        endif

        N = i
        tmin = MIN(tmin,t(i))
        ww(i) = (1.0_dp/FLXerr(i))**wexp
        wsum  = wsum + ww(i)
        i=i+1
        if (i>nmax) then
            write(0,*) "WARNING: input has reached maximum number of points (",nmax,")!"
            exit
        endif

    end do
    close(1)

    t=t-tmin   ! Shift times by tmin.

    ! >>> Shift the time values, compute time base and normalize weights:
    ww = ww / wsum                 ! normalize weights

    if (iforce) then    ! wexp = 0 was forced (2-column input line was found)
        wsum=n
        ww=1.0_dp/DFLOAT(n)
        flxerr=1.0_dp
    endif

    contains

      integer function ntokens(line)
      character,intent(in):: line*(*)
      integer i, n, toks

      i = 1;
      n = len_trim(line)
      toks = 0
      ntokens = 0
      do while(i <= n)
         do while(line(i:i) == ' ')
           i = i + 1
           if (n < i) return
         enddo
         toks = toks + 1
         ntokens = toks
         do
           i = i + 1
           if (n < i) return
           if (line(i:i) == ' ') exit
         enddo
      enddo
      end function ntokens

    end subroutine readfile

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

    subroutine glsspec(nthread,name,isout,Fbeg,Fend,ofac,t,flx,ww,yy,psin,powsin,amp,ph,cbest,rms)

    implicit none

    character, intent(in) :: name*80
    integer, intent(in) :: isout, nthread
    real(dp), intent(in) :: ofac,fbeg,fend
    real(dp), dimension(:), intent(in) :: t,flx,ww
    real(dp), intent(out) :: psin,powsin,rms,yy

    integer :: i,n,nstep,jj,ix
    real(dp),dimension(size(t)) :: wy,v
    real(dp), allocatable, dimension(:) :: freq, pow, sw, powls
    real(dp) :: tbase,step,flxmean, &
                a,b,c,ph,amp,cbest,pls

    !$call omp_set_num_threads(nthread)

    ! Number of epochs:
    n=size(t)

    ! Time base:
    tbase=MAXVAL(t)

    ! Frequency step:
    step = 1.0_dp/tbase/ofac
    nstep= int(dabs(Fend-Fbeg)/step)+1

    !print *,nstep
    allocate(freq(nstep))
    allocate(pow(nstep))
    allocate(powls(nstep))
    if(isout==1) allocate(sw(nstep))

    !----

    flxmean=0.0_dp
    do i=1,n
        flxmean = flxmean + flx(i)*ww(i)     ! weighted mean
    end do

    yy=0.0_dp
    do i=1,n
        wy(i) = flx(i)-flxmean            ! centering flux
        yy    = yy + wy(i)**2*ww(i)       ! sum for chi2 above the mean
        wy(i) = wy(i)*ww(i)               ! attach weights to centered data (saves many multiplications)
    end do

    rms=sqrt(yy*n/(n-1))

    ! >>> Compute GLS spectrum.

    !$omp parallel do private(v,a,b,c)

    do jj=1,nstep
        freq(jj)=fbeg+(jj-1)*step
        v = t * twopi * freq(jj)
        call sinefit(v,wy,ww,yy,a,b,c,pow(jj),powls(jj))
        if(isout==1) call specwin(v,sw(jj))
    enddo
    !$omp end parallel do

    powsin=MAXVAL(pow)
    ix=MAXLOC(pow,1)
    v=t*twopi*freq(ix)
    call sinefit(v,wy,ww,yy,a,b,c,powsin,pls)
    ph = MOD(DATAN2(a,b)+twopi, twopi)
    amp = DSQRT(a**2+b**2)
    cbest = flxmean+c
    psin = 1.0_dp/freq(ix)

    if(isout==1) then    ! open output file for spectrum
        open(unit=10, file=TRIM(name)//'.gls')
        write(10,'(4A18)')  "#frequency","pow","window","powLS"
        do jj=1,nstep
            write(10,*) freq(jj), pow(jj), sw(jj), powls(jj)
        enddo
        close(10)
    endif

    deallocate(freq)
    deallocate(pow)
    if(allocated(sw)) deallocate(sw)
    deallocate(powls)

    end subroutine glsspec

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

    pure subroutine sinefit(v,z,ww,yy,A,B,off,pow,powls)
    ! fit sine wave y=A*cosx+B*sinx+off
    ! A,B,off - fit parameter
    implicit none

    real(dp), dimension(:), intent(in) :: v, z, ww
    real(dp), intent(in) :: yy

    real(dp), intent(out) :: a,b,off,pow,powls

    integer :: i,n
    real(dp) :: cc,ss,cs,c,s,yc,ys,d,cosx,sinx

    n=size(v)

    CC = 0.
    CS = 0.
    C  = 0.
    S  = 0.
    YC = 0.
    YS = 0.
    do i=1,N                        ! calculate the weighted sums
       cosx = cos(v(i))
       sinx = sin(v(i))
       CC = CC + ww(i) * cosx**2
       CS = CS + ww(i) * cosx*sinx
       C  = C  + ww(i) * cosx
       S  = S  + ww(i) * sinx
       YC = YC + z(i) * cosx
       YS = YS + z(i) * sinx
    enddo
    SS = 1. - CC
    D  = CC*SS - CS*CS
    powLS = (SS*YC**2/D+CC*YS**2/D-2*CS*YC*YS/D) / YY         ! Lomb-Scargle power
    CC = CC - C*C
    SS = SS - S*S
    CS = CS - C*S
    D  = CC*SS - CS*CS
    A = (YC*SS-YS*CS) / D
    B = (YS*CC-YC*CS) / D
    off = -A*C-B*S
    !      pow= (A*YC+B*YS)/ YY
    pow = (SS*YC**2/D+CC*YS**2/D-2*CS*YC*YS/D) / YY           ! GLS power
    end subroutine sinefit

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

    subroutine specwin(v,WS)
    implicit none

    real(dp), dimension(:), intent(in) :: v

    real(dp), intent(out) :: ws

    integer :: i,n
    real(dp) :: wc

    n=size(v)

    wc = 0.0_dp
    ws = 0.0_dp
    do i=1,n
       wc = wc + cos(v(i))
       ws = ws + sin(v(i))
    enddo
    ws = (wc**2.0_dp+ws**2.0_dp) / n**2.0_dp
    return
    end subroutine specwin

end module gls_mod


!--------------------------------------------------------------------------------
! Copyright (c) 2016 Peter Grünberg Institut, Forschungszentrum Jülich, Germany
! This file is part of FLEUR and available as free software under the conditions
! of the MIT license as expressed in the LICENSE file in more detail.
!--------------------------------------------------------------------------------

      module m_wann_wigner_seitz
      use m_juDFT
      contains
      subroutine wann_wigner_seitz(
     >          l_get_rvecnum,num,amat,
     >          rvecnum_in,
     <          rvecnum,rvec,ndegen)

      implicit none
      logical, intent(in) :: l_get_rvecnum
      integer, intent(in) :: num(:)
      real, intent(in)    :: amat(:,:)
      integer,intent(in)  :: rvecnum_in
      integer, intent(out):: rvecnum
      integer, intent(out):: rvec(:,:)
      integer, intent(out):: ndegen(:)

      integer             :: idist (3)
      real                :: dist(1331),summa,dist_min
      integer             :: k1,k2,k3,i1,i2,i3,count,i,j
      real                :: eps7,eps8
      real                :: metric(3,3)

      eps7=1.e-7
      eps8=1.e-8
      rvecnum=0

      metric=matmul(transpose(amat),amat)

      rvecnum = 0
      do k1=-2*num(1),2*num(1)
       do k2=-2*num(2),2*num(2)
        do k3=-2*num(3),2*num(3)
         count=0
         do i1=-5,5
          do i2=-5,5
           do i3=-5,5
            count=count+1
            ! Get |r-R|^2
            idist(1)=k1-i1*num(1)
            idist(2)=k2-i2*num(2)
            idist(3)=k3-i3*num(3)
            dist(count)=0.0
            do i=1,3
             do j=1,3
              dist(count)=dist(count)+
     +         real(idist(i))*metric(i,j)*real(idist(j))
             enddo !i
            enddo !j
           enddo !i3
          enddo !i2
         enddo !i1
         dist_min=minval(dist)
         if (abs(dist(666) - dist_min ) .lt. eps7 ) then
                rvecnum = rvecnum + 1
                if(.not. l_get_rvecnum) then
c                   if(.not.allocated(ndegen))
c     &                 allocate(ndegen(rvecnum_in))
                   ndegen(rvecnum)=0
                   do i=1,1331
                      if (abs (dist (i) - dist_min) .lt. eps7 )
     &                   ndegen(rvecnum)=ndegen(rvecnum)+1
                   end do
                   rvec(1,rvecnum) = k1
                   rvec(2,rvecnum) = k2
                   rvec(3,rvecnum) = k3
                endif
         endif
        enddo !k3
       enddo !k2
      enddo !k1
      if(l_get_rvecnum) return

c------ Consistency Check.
      summa = 0.0
      do i = 1, rvecnum
       summa = summa + 1.0/real(ndegen(i))
      enddo
      if (abs (summa - real(num(1)*num(2)*num(3)) ) > eps8) then
         CALL juDFT_error("problem finding Wigner-Seitz points",
     +                    calledby ="wann_wigner_seitz")
      endif

      end subroutine wann_wigner_seitz

      end module m_wann_wigner_seitz


      subroutine runCP_0000(Gr,S0000,N0)
      implicit none
      include 'TRconstants.f'
      include 'pvCnames.f'
      include 'pvCv.f'
      include 'Carraydef.f'
      include 'Carrays.f'
      integer ep,N0,m,n,np
      parameter(np=2)
      double precision Gr(np,np)
      double complex S0000(-2:0),bit,pole

      do ep=-2,0
      bit=czip
      do n=1,np
      do m=1,np
      bit=bit+Gr(n,m)*Cv(czzii(z2(n,m))+N0,ep)
      enddo
      enddo

      pole=czip
      if (ep .gt. -2) pole=4d0*Cv(cc0000+N0,ep-1)

c--- note: we have simplified the recursion relation by using DD (5.9)
c--- so that S0000 = 2B00(0)+2*m0sq*C00
      Cv(cc0000+N0,ep)=
     . (pole
     . +S0000(ep)
     . -bit)/12d0
      enddo

      return
      end


      SUBROUTINE cumchi(x,df,cum,ccum)
C**********************************************************************
C
C     SUBROUTINE FUNCTION CUMCHI(X,DF,CUM,CCUM)
C             CUMulative of the CHi-square distribution
C
C
C                              Function
C
C
C     Calculates the cumulative chi-square distribution.
C
C
C                              Arguments
C
C
C     X       --> Upper limit of integration of the
C                 chi-square distribution.
C                                                 X is DOUBLE PRECISION
C
C     DF      --> Degrees of freedom of the
C                 chi-square distribution.
C                                                 DF is DOUBLE PRECISION
C
C     CUM <-- Cumulative chi-square distribution.
C                                                 CUM is DOUBLE PRECISIO
C
C     CCUM <-- Compliment of Cumulative chi-square distribution.
C                                                 CCUM is DOUBLE PRECISI
C
C
C                              Method
C
C
C     Calls incomplete gamma function (CUMGAM)
C
C**********************************************************************
C     .. Scalar Arguments ..
      DOUBLE PRECISION df,x,cum,ccum
C     ..
C     .. Local Scalars ..
      DOUBLE PRECISION a,xx
C     ..
C     .. External Subroutines ..
      EXTERNAL cumgam
C     ..
C     .. Executable Statements ..
      a = df*0.5D0
      xx = x*0.5D0
      CALL cumgam(xx,a,cum,ccum)
      RETURN

      END