! MIT License
!
! Copyright (c) 2020 SHEMAT-Suite
!
! 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.

!>    @brief calculate ice isobaric heat capacity [J/(kg*K)]
!>    @param[in] i cell index, direction I0
!>    @param[in] j cell index, direction J0
!>    @param[in] k cell index, direction K0
!>    @param[in] ismpl local sample index
!>    @details
!>    After:
!>    Ling, F. & Zhang (2004):
!>    A Numerical Modelfor surface energy balance and the thermal
!>    regime of the active layer and permafrost containing
!>    unfrozen water or brine
!>    Cold Regions Science & Technology, 38, 1-15
!>    Ling and Zhang cite Osterkamp, T. E. (1987):
!>    Freezing and Thawing of Soils and Permafrost
!>    Containing Unfrozen Water or Brine
!>    Water Resources Research, Vol. 23, No. 12, pages 2279-2285
!>    Osterkamp cites Dorsey, N. E. (1940):
!>    Properties of Ordinary Water-Substance, Reinhold, New York
!>    Dorsey cites Dickinson, H., & Osborne, N. (1915):
!>    The specific heat and heat of fusion of ice. Journal of
!>    the Washington Academy of Sciences, 5(10), 338-340.
!>
!>    Alternative:
!>    Fukusako, S.:
!>    Thermophysical Properties of Ice, Snow,and Sea Ice
!>    International Journal of Thermophysics, 1990, 11, 353-372
      DOUBLE PRECISION FUNCTION cpi(i,j,k,ismpl)

        use arrays
        IMPLICIT NONE

        INTEGER i, j, k, ui, ismpl
        DOUBLE PRECISION plocal, tlocal

        tlocal = temp(i,j,k,ismpl)
        IF (tlocal>0.D0) tlocal = 0.D0

!vr (Fukosako 1990)        cpi = 185.D0 + 6.89D0*(273.15D0+tlocal)
        cpi=2110.D0+7.7D0*tlocal

        RETURN
      END


!AU  - Liu, Zhenying;  Chapman, Barbara; Weng, Tien-Hsiung; Hernandez, Oscar
!PY  - 2002/01/01
!SP  - 244
!EP  - 259
!SN  - 978-3-540-40435-4
!T1  - Improving the Performance of OpenMP by Array Privatization
!DO  - 10.1007/3-540-45009-2_19

module times
    double precision t1,t2,t3,t4
    ! run on nt threads
    integer, parameter :: nt=8
    integer, parameter :: onek=3000
    integer, parameter :: tfz=onek/nt
    integer, parameter :: tfo=tfz+1
    integer, parameter :: nnn=onek-1
    integer, parameter :: iter=2000
    integer, parameter :: b8=selected_real_kind(14)
    !real(b8) A(onek,onek)
    !real(b8) B(onek,onek)
    real(b8),allocatable :: A(:,:)
    real(b8),allocatable :: B(:,:)
    real(b8),allocatable :: Aloc(:,:),Bloc(:,:)
    !real(b8) Aloc(onek,0:tfo),Bloc(onek,0:tfo)
!$omp threadprivate(Aloc,Bloc)

end module

subroutine org
    use times
    real(b8)  omp_get_wtime
    real(b8) c
    c=1
    allocate(A(onek,onek))
    allocate(B(onek,onek))
    CALL RANDOM_NUMBER(A)
    CALL RANDOM_NUMBER(B)
    t1=omp_get_wtime()
!$omp parallel default(shared) ,private(i,j)
    do k=1, iter
!$omp do
        do j = 2 ,nnn
            do i = 2 , nnn
                A(i,j) = ( B(i-1,j)+B(i+1,j) + B(i,j-1)+B(i,j+1)) * c
            enddo
        enddo
!$omp do
        do j=1, onek
            do i= 1, onek
                B(i,j) = A(i,j)
            enddo
        enddo
    enddo
!$omp end parallel
    t2=omp_get_wtime()
    t3=t3+(t2-t1)
end subroutine

subroutine mods
    use times
    double precision  omp_get_wtime
!    real(b8) Aloc(onek,0:tfo),Bloc(onek,0:tfo)
!    real(b8),allocatable :: Aloc(:,:),Bloc(:,:)
!    common /bonk/ aloc,bloc
!!$omp threadprivate(/bonk/)

    real(b8) buf_upper(onek,-1:nt+1)
    real(b8) buf_lower(onek,-1:nt+1)
    real(b8) c
!$omp parallel
    allocate(Aloc(onek,0:tfo),Bloc(onek,0:tfo))
    CALL RANDOM_NUMBER(Aloc)
    CALL RANDOM_NUMBER(bloc)
!$omp end parallel
    c=1
    t1=omp_get_wtime()
!$omp
!$omp parallel default(shared) , private(istart_y,iend_y,i,j,k,id)
    id = omp_get_thread_num()
    do k = 1, iter
        buf_upper(1:onek, id)=Bloc(1:onek,tfz)
        buf_lower(1:onek, id) = Bloc(1:onek, 1)
!$omp barrier
        Bloc(1:onek,0)=buf_upper(1:onek,id -1)
        Bloc(1:onek,tfo)=buf_lower(1:onek,id+1)
        istart_y=id*tfz+1
        iend_y=(id+1)*tfz
        do j=istart_y, iend_y
            do i=2, nnn
                Aloc(i,j) = (Bloc(i-1,j) + Bloc(i+1,j)+ Bloc(i,j-1) + Bloc(i,j+1)) * c
            enddo
        enddo
        do j=1, tfz
            do i=1, onek
                Bloc(i,j) = Aloc(i,j)
            enddo
        enddo
    enddo
!$omp end parallel
    t2=omp_get_wtime()
    t4=t4+(t2-t1)
end subroutine

program wow
  use times
  integer omp_get_max_threads
  integer mt
  t3=0
  t4=0
  mt=omp_get_max_threads()
  write(*,'("OMP_NUM_THREADS=",i4," compiled to run on threads=",i4)')mt,nt
  if (nt .gt. mt)then
    write(*,'("recompile with nt=",i4,"set to mt",i4)')nt,mt
    stop
  endif
  call omp_set_num_threads(nt)
  Write(*,*)"doing org"
  call org
  Write(*,*)"doing mods"
  call mods
  write(*,*)"size=",onek," iterations=",iter
  write(*,'("original time",f10.4," modified time",f10.4," speed up",f10.4)')t3,t4,t3/t4
end program


*DECK REBAK
      SUBROUTINE REBAK (NM, N, B, DL, M, Z)
C***BEGIN PROLOGUE  REBAK
C***PURPOSE  Form the eigenvectors of a generalized symmetric
C            eigensystem from the eigenvectors of derived matrix output
C            from REDUC or REDUC2.
C***LIBRARY   SLATEC (EISPACK)
C***CATEGORY  D4C4
C***TYPE      SINGLE PRECISION (REBAK-S)
C***KEYWORDS  EIGENVALUES, EIGENVECTORS, EISPACK
C***AUTHOR  Smith, B. T., et al.
C***DESCRIPTION
C
C     This subroutine is a translation of the ALGOL procedure REBAKA,
C     NUM. MATH. 11, 99-110(1968) by Martin and Wilkinson.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 303-314(1971).
C
C     This subroutine forms the eigenvectors of a generalized
C     SYMMETRIC eigensystem by back transforming those of the
C     derived symmetric matrix determined by  REDUC  or  REDUC2.
C
C     On Input
C
C        NM must be set to the row dimension of the two-dimensional
C          array parameters, B and Z, as declared in the calling
C          program dimension statement.  NM is an INTEGER variable.
C
C        N is the order of the matrix system.  N is an INTEGER
C          variable.  N must be less than or equal to NM.
C
C        B contains information about the similarity transformation
C          (Cholesky decomposition) used in the reduction by  REDUC
C          or  REDUC2  in its strict lower triangle.  B is a two-
C          dimensional REAL array, dimensioned B(NM,N).
C
C        DL contains further information about the transformation.
C          DL is a one-dimensional REAL array, dimensioned DL(N).
C
C        M is the number of eigenvectors to be back transformed.
C          M is an INTEGER variable.
C
C        Z contains the eigenvectors to be back transformed in its
C          first M columns.  Z is a two-dimensional REAL array
C          dimensioned Z(NM,M).
C
C     On Output
C
C        Z contains the transformed eigenvectors in its first
C          M columns.
C
C     Questions and comments should be directed to B. S. Garbow,
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C     ------------------------------------------------------------------
C
C***REFERENCES  B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow,
C                 Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen-
C                 system Routines - EISPACK Guide, Springer-Verlag,
C                 1976.
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   760101  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  REBAK
C
      INTEGER I,J,K,M,N,I1,II,NM
      REAL B(NM,*),DL(*),Z(NM,*)
      REAL X
C
C***FIRST EXECUTABLE STATEMENT  REBAK
      IF (M .EQ. 0) GO TO 200
C
      DO 100 J = 1, M
C     .......... FOR I=N STEP -1 UNTIL 1 DO -- ..........
         DO 100 II = 1, N
            I = N + 1 - II
            I1 = I + 1
            X = Z(I,J)
            IF (I .EQ. N) GO TO 80
C
            DO 60 K = I1, N
   60       X = X - B(K,I) * Z(K,J)
C
   80       Z(I,J) = X / DL(I)
  100 CONTINUE
C
  200 RETURN
      END


subroutine clawpack46_qinit(meqn,mbc, mx,my,mz, &
            xlower,ylower,zlower, dx,dy,dz, q,maux,aux)
    implicit none

    integer :: meqn, mbc, mx, my, mz, maux
    double precision :: xlower, ylower, zlower, dx, dy, dz
    double precision ::   q(1-mbc:mx+mbc, 1-mbc:my+mbc, 1-mbc:mz+mbc,meqn)
    double precision :: aux(1-mbc:mx+mbc, 1-mbc:my+mbc, 1-mbc:mz+mbc,maux)

    integer :: i, j, k, mq
    double precision :: xc

    do mq = 1,meqn
        do i = 1-mbc,mx+mbc
            do j = 1-mbc,my+mbc
                do k = 1-mbc, mz + mbc
                    xc = xlower + (i-0.5d0)*dx
                    if (xc .lt. 0.5d0) then
                        q(i,j,k,mq) = 1.d0
                    else
                        q(i,j,k,mq) = 0
                    endif
                end do
            end do
        end do
    end do

    return
end subroutine clawpack46_qinit


! 3 dimension
program demo

    use ntree_factory_m, only: ntree_t, shape_t, make_boundary, make_ntree, make_range, point_t
    use queue_m, only: queue_t
    implicit none
    class(shape_t), allocatable :: boundary, range
    type(queue_t) :: found
    class(*), allocatable :: data
    type(point_t), allocatable :: point
    type(ntree_t) :: oct_tree
    logical :: info
    integer :: i

    call make_boundary([0.0, 0.0, 0.0], [1.0, 1.0, 1.0], boundary, squared=.true.)
    call make_ntree(boundary, 2, oct_tree)
    call oct_tree%insert(point_t([0.5, 0.5, 0.5]), info)
    call oct_tree%insert(point_t([-0.1, 0.1, 0.2]), info)
    call oct_tree%insert(point_t([0.1, 0.2, 0.4]), info)
    call oct_tree%insert(point_t([0.9, 0.9, 0.99]), info)
    call oct_tree%insert(point_t([0.7, 0.6, 0.5]), info)
    call oct_tree%insert(point_t([0.3, 0.5, 0.6]), info)
    call oct_tree%insert(point_t([randu(), randu(), randu()]), info)
    call make_range([0.9, 0.9, 0.9], 0.5, range)
    call oct_tree%query(range, found)

    if (found%size() == 0) stop
    do i = 1, found%size()
        call found%dequeue(data)
        point = to_point(data)
        write (*, '("x = [",3(f6.2,1x),"] dist = ",f6.2)') point%x(1), point%x(2), point%x(3), &
            norm2([point%x(1) - 0.9, point%x(2) - 0.9, point%x(3) - 0.9])
    end do

contains

    function randu() result(r)
        real :: r
        call random_number(r)
    end function randu

    pure function to_point(x) result(p)
        class(*), intent(in) :: x
        type(point_t) :: p
        select type (x)
        type is (point_t)
            p = x
        end select
    end function to_point

end program demo


      subroutine reduc(nm,n,a,b,dl,ierr)
c
      integer i,j,k,n,i1,j1,nm,nn,ierr
      double precision a(nm,n),b(nm,n),dl(n)
      double precision x,y
c
c     this subroutine is a translation of the algol procedure reduc1,
c     num. math. 11, 99-110(1968) by martin and wilkinson.
c     handbook for auto. comp., vol.ii-linear algebra, 303-314(1971).
c
c     this subroutine reduces the generalized symmetric eigenproblem
c     ax=(lambda)bx, where b is positive definite, to the standard
c     symmetric eigenproblem using the cholesky factorization of b.
c
c     on input
c
c        nm must be set to the row dimension of two-dimensional
c          array parameters as declared in the calling program
c          dimension statement.
c
c        n is the order of the matrices a and b.  if the cholesky
c          factor l of b is already available, n should be prefixed
c          with a minus sign.
c
c        a and b contain the real symmetric input matrices.  only the
c          full upper triangles of the matrices need be supplied.  if
c          n is negative, the strict lower triangle of b contains,
c          instead, the strict lower triangle of its cholesky factor l.
c
c        dl contains, if n is negative, the diagonal elements of l.
c
c     on output
c
c        a contains in its full lower triangle the full lower triangle
c          of the symmetric matrix derived from the reduction to the
c          standard form.  the strict upper triangle of a is unaltered.
c
c        b contains in its strict lower triangle the strict lower
c          triangle of its cholesky factor l.  the full upper
c          triangle of b is unaltered.
c
c        dl contains the diagonal elements of l.
c
c        ierr is set to
c          zero       for normal return,
c          7*n+1      if b is not positive definite.
c
c     questions and comments should be directed to burton s. garbow,
c     mathematics and computer science div, argonne national laboratory
c
c     this version dated august 1983.
c
c     ------------------------------------------------------------------
c
      ierr = 0
      nn = iabs(n)
      if (n .lt. 0) go to 100
c     .......... form l in the arrays b and dl ..........
      do 80 i = 1, n
         i1 = i - 1
c
         do 80 j = i, n
            x = b(i,j)
            if (i .eq. 1) go to 40
c
            do 20 k = 1, i1
   20       x = x - b(i,k) * b(j,k)
c
   40       if (j .ne. i) go to 60
            if (x .le. 0.0d0) go to 1000
            y = dsqrt(x)
            dl(i) = y
            go to 80
   60       b(j,i) = x / y
   80 continue
c     .......... form the transpose of the upper triangle of inv(l)*a
c                in the lower triangle of the array a ..........
  100 do 200 i = 1, nn
         i1 = i - 1
         y = dl(i)
c
         do 200 j = i, nn
            x = a(i,j)
            if (i .eq. 1) go to 180
c
            do 160 k = 1, i1
  160       x = x - b(i,k) * a(j,k)
c
  180       a(j,i) = x / y
  200 continue
c     .......... pre-multiply by inv(l) and overwrite ..........
      do 300 j = 1, nn
         j1 = j - 1
c
         do 300 i = j, nn
            x = a(i,j)
            if (i .eq. j) go to 240
            i1 = i - 1
c
            do 220 k = j, i1
  220       x = x - a(k,j) * b(i,k)
c
  240       if (j .eq. 1) go to 280
c
            do 260 k = 1, j1
  260       x = x - a(j,k) * b(i,k)
c
  280       a(i,j) = x / dl(i)
  300 continue
c
      go to 1001
c     .......... set error -- b is not positive definite ..........
 1000 ierr = 7 * n + 1
 1001 return
      end


      SUBROUTINE MCHA_CPV(PAR,IFAIL)

c      Chargino masses: diag(MCH(I)) = U*.MCH.V+
c       The squared chargino masses MCH2(i) (i=1..2) and the rotation
c       matrices U(i,j,k), V(i,j,k) (i,j=1..2; k=1..2: real/imaginary part)
c       are stored in the common CHASPEC.
c       In case of a negative MCH2(i), IFAIL=6.

      IMPLICIT NONE

      INTEGER IFAIL

      DOUBLE PRECISION PAR(*),Pi
      DOUBLE PRECISION MCHI2_11,MCHI2_22,MCHI4_12,Tr,det,aux1,aux2,aux
      DOUBLE PRECISION thetaU,thetaV,PhiCHV1,PhiCHU1,PhiCHV2,PhiCHU2

      DOUBLE PRECISION GF,MZ,MW,g1,g2,alSMZ,S2TW,ALEMMZ
      DOUBLE PRECISION tanb,cosb,sinb,vu,vd
      DOUBLE PRECISION phi01,phi02,phi0,phiM1,phiM2,phiM3,
     .              phiAT,phiAB,phiATAU,phiAC,phiAS,phiAMU
      DOUBLE PRECISION mur,M1r,M2r,msi
      DOUBLE PRECISION MCH2(2),U(2,2,2),V(2,2,2)
      DOUBLE PRECISION DDCOS,DDSIN

      COMMON/EWPAR/GF,MZ,MW,g1,g2,alSMZ,S2TW,ALEMMZ
      COMMON/TBPAR/tanb,cosb,sinb,vu,vd
      COMMON/PHASES/phi01,phi02,phi0,phiM1,phiM2,phiM3,
     .              phiAT,phiAB,phiATAU,phiAC,phiAS,phiAMU
      COMMON/GAUGINOPAR/mur,M1r,M2r,msi
      COMMON/CHASPEC/MCH2,U,V

      PI=4d0*DATAN(1d0)

c           1) Squared mass matrix
      MCHI2_11=M2r**2+g2*vd**2
      MCHI2_22=mur**2+g2*vu**2
      MCHI4_12=g2*(M2r**2*vu**2+mur**2*vd**2+2.d0*mur*M2r*vu*vd
     .                                            *DDCOS(phiM2+phi01))

c           2) Eigenvalues: squared masses
      Tr=MCHI2_11+MCHI2_22
      det=(MCHI2_11-MCHI2_22)**2+4.d0*MCHI4_12
      MCH2(1)=(Tr-dsqrt(det))/2.d0
      MCH2(2)=(Tr+dsqrt(det))/2.d0
      IF(MCH2(1).le.0.d0)THEN
c       print*,'chargino mass problem'
       IFAIL=6
       GOTO 616
      ENDIF

c           3) Rotating matrix V0 (special unitary)
      aux1=-M2r*vu*DDSIN(phiM2)+mur*vd*DDSIN(phi01)
      aux2=M2r*vu*DDCOS(phiM2)+mur*vd*DDCOS(phi01)
      IF(dabs(aux2).ge.dabs(aux1)*1.d-10)THEN
        phiCHV1=datan(aux1/aux2)
        IF(aux2.le.0.d0)PhiCHV1=PhiCHV1+Pi
      ELSEIF(aux1.ge.0.d0)THEN
       phiCHV1=Pi/2.d0
      ELSE
       phiCHV1=-Pi/2.d0
      ENDIF

      aux1=M2r**2-mur**2+g2*(vd**2-vu**2)+dsqrt(det)
      aux2=dsqrt(4.d0*MCHI4_12)
      IF(dabs(aux2).ge.dabs(aux1)*1.d-10)THEN
       thetaV=datan(aux1/aux2)
       IF(aux2.le.0.d0)thetaV=thetaV+Pi
      ELSEIF(aux1.ge.0.d0)THEN
       thetaV=Pi/2.d0
      ELSE
       thetaV=-Pi/2.d0
      ENDIF

c           3) Rotating matrix U0 (special unitary)
      aux=g2*(M2r**2*vd**2+mur**2*vu**2+2.d0*mur*M2r*vu*vd
     .                                            *DDCOS(phiM2+phi01))
      aux1=-M2r*vd*DDSIN(phiM2)+mur*vu*DDSIN(phi01)
      aux2=M2r*vd*DDCOS(phiM2)+mur*vu*DDCOS(phi01)
      IF(dabs(aux2).ge.dabs(aux1)*1.d-10)THEN
       phiCHU1=datan(aux1/aux2)
       IF(aux2.le.0.d0)PhiCHU1=PhiCHU1+Pi
      ELSEIF(aux1.ge.0.d0)THEN
       phiCHU1=Pi/2.d0
      ELSE
       phiCHU1=-Pi/2.d0
      ENDIF

      aux1=M2r**2-mur**2+g2*(vu**2-vd**2)+dsqrt(det)
      aux2=dsqrt(4.d0*aux)
      IF(dabs(aux2).ge.dabs(aux1)*1.d-10)THEN
       thetaU=datan(aux1/aux2)
       IF(aux2.le.0.d0)thetaU=thetaU+Pi
      ELSEIF(aux1.ge.0.d0)THEN
       thetaU=Pi/2.d0
      ELSE
       thetaU=-Pi/2.d0
      ENDIF

c           4) Rotating matrices U,V (phase-shIFted)
      aux1=M2r*DDSIN(thetaU)*DDSIN(thetaV)*DDSIN(phiCHV1+phiCHU1+phiM2)
     .      +mur*DDCOS(thetaU)*DDCOS(thetaV)*DDSIN(phi01)
     .      +dsqrt(g2)*vu*DDSIN(thetaU)*DDCOS(thetaV)*DDSIN(phiCHU1)
     .      +dsqrt(g2)*vd*DDSIN(thetaV)*DDCOS(thetaU)*DDSIN(phiCHV1)
      aux2=M2r*DDSIN(thetaU)*DDSIN(thetaV)*DDCOS(phiCHV1+phiCHU1+phiM2)
     .      +mur*DDCOS(thetaU)*DDCOS(thetaV)*DDCOS(phi01)
     .      +dsqrt(g2)*vu*DDSIN(thetaU)*DDCOS(thetaV)*DDCOS(phiCHU1)
     .      +dsqrt(g2)*vd*DDSIN(thetaV)*DDCOS(thetaU)*DDCOS(phiCHV1)
      IF(dabs(aux2).ge.dabs(aux1)*1.d-10)THEN
       phiCHV2=datan(aux1/aux2)
        IF(aux2.le.0.d0)PhiCHV2=PhiCHV2+Pi
      ELSEIF(aux1.ge.0.d0)THEN
       phiCHV2=Pi/2.d0
      ELSE
       phiCHV2=-Pi/2.d0
      ENDIF

      aux1=M2r*DDCOS(thetaU)*DDCOS(thetaV)*DDSIN(phiM2)
     .    +mur*DDSIN(thetaU)*DDSIN(thetaV)*DDSIN(phi01-phiCHV1-phiCHU1)
     .    +dsqrt(g2)*vu*DDCOS(thetaU)*DDSIN(thetaV)*DDSIN(phiCHV1)
     .    +dsqrt(g2)*vd*DDCOS(thetaV)*DDSIN(thetaU)*DDSIN(phiCHU1)
      aux2=M2r*DDCOS(thetaU)*DDCOS(thetaV)*DDCOS(phiM2)
     .    +mur*DDSIN(thetaU)*DDSIN(thetaV)*DDCOS(phiCHV1+phiCHU1-phi01)
     .    -dsqrt(g2)*vu*DDCOS(thetaU)*DDSIN(thetaV)*DDCOS(phiCHV1)
     .    -dsqrt(g2)*vd*DDCOS(thetaV)*DDSIN(thetaU)*DDCOS(phiCHU1)
      IF(dabs(aux2).ge.dabs(aux1)*1.d-10)THEN
       phiCHU2=datan(aux1/aux2)
        IF(aux2.le.0.d0)PhiCHU2=PhiCHU2+Pi
      ELSEIF(aux1.ge.0.d0)THEN
       phiCHU2=Pi/2.d0
      ELSE
       phiCHU2=-Pi/2.d0
      ENDIF

      U(1,1,1)=DDCOS(thetaU)*DDCOS(PhiCHU2)
      U(1,1,2)=DDCOS(thetaU)*DDSIN(PhiCHU2)
      U(1,2,1)=-DDSIN(thetaU)*DDCOS(PhiCHU2+PhiCHU1)
      U(1,2,2)=-DDSIN(thetaU)*DDSIN(PhiCHU2+PhiCHU1)
      U(2,1,1)=DDSIN(thetaU)*DDCOS(PhiCHU1)
      U(2,1,2)=-DDSIN(thetaU)*DDSIN(PhiCHU1)
      U(2,2,1)=DDCOS(thetaU)
      U(2,2,2)=0.d0
c      UCOMP(1,1)=DCMPLX(U(1,1,1),U(1,1,2))
c      UCOMP(1,2)=DCMPLX(U(1,2,1),U(1,2,2))
c      UCOMP(2,1)=DCMPLX(U(2,1,1),U(2,1,2))
c      UCOMP(2,2)=DCMPLX(U(2,2,1),U(2,2,2))

      V(1,1,1)=DDCOS(thetaV)
      V(1,1,2)=0.d0
      V(1,2,1)=-DDSIN(thetaV)*DDCOS(PhiCHV1)
      V(1,2,2)=-DDSIN(thetaV)*DDSIN(PhiCHV1)
      V(2,1,1)=DDSIN(thetaV)*DDCOS(PhiCHV2-PhiCHV1)
      V(2,1,2)=DDSIN(thetaV)*DDSIN(PhiCHV2-PhiCHV1)
      V(2,2,1)=DDCOS(thetaV)*DDCOS(PhiCHV2)
      V(2,2,2)=DDCOS(thetaV)*DDSIN(PhiCHV2)
c      VCOMP(1,1)=DCMPLX(V(1,1,1),V(1,1,2))
c      VCOMP(1,2)=DCMPLX(V(1,2,1),V(1,2,2))
c      VCOMP(2,1)=DCMPLX(V(2,1,1),V(2,1,2))
c      VCOMP(2,2)=DCMPLX(V(2,2,1),V(2,2,2))

c      print*,'mcha',dsqrt(MCH2(1)),dsqrt(MCH2(2))
c      print*,'U11',U(1,1,1),U(1,1,2)
c      print*,'U12',U(1,2,1),U(1,2,2)
c      print*,'U21',U(2,1,1),U(2,1,2)
c      print*,'U22',U(2,2,1),U(2,2,2)
c      print*,'V11',V(1,1,1),V(1,1,2)
c      print*,'V12',V(1,2,1),V(1,2,2)
c      print*,'V21',V(2,1,1),V(2,1,2)
c      print*,'V22',V(2,2,1),V(2,2,2)

 616  RETURN
      END


!==========================================================================
elemental function gsw_ct_from_pt (sa, pt)
!==========================================================================
!
! Calculates Conservative Temperature from potential temperature of seawater
!
! sa      : Absolute Salinity                              [g/kg]
! pt      : potential temperature with                     [deg C]
!           reference pressure of 0 dbar
!
! gsw_ct_from_pt : Conservative Temperature                [deg C]
!--------------------------------------------------------------------------

use gsw_mod_teos10_constants, only : gsw_cp0, gsw_sfac

use gsw_mod_kinds

implicit none

real (r8), intent(in) :: sa, pt

real (r8) :: gsw_ct_from_pt

real (r8) :: pot_enthalpy, x2, x, y

x2 = gsw_sfac*sa
x = sqrt(x2)
y = pt*0.025_r8        ! normalize for F03 and F08

pot_enthalpy =  61.01362420681071_r8 + y*(168776.46138048015_r8 + &
               y*(-2735.2785605119625_r8 + y*(2574.2164453821433_r8 + &
               y*(-1536.6644434977543_r8 + y*(545.7340497931629_r8 + &
               (-50.91091728474331_r8 - 18.30489878927802_r8*y)*y))))) + &
               x2*(268.5520265845071_r8 + y*(-12019.028203559312_r8 + &
               y*(3734.858026725145_r8 + y*(-2046.7671145057618_r8 + &
               y*(465.28655623826234_r8 + (-0.6370820302376359_r8 - &
               10.650848542359153_r8*y)*y)))) + &
               x*(937.2099110620707_r8 + y*(588.1802812170108_r8 + &
               y*(248.39476522971285_r8 + (-3.871557904936333_r8 - &
               2.6268019854268356_r8*y)*y)) + &
               x*(-1687.914374187449_r8 + x*(246.9598888781377_r8 + &
               x*(123.59576582457964_r8 - 48.5891069025409_r8*x)) + &
               y*(936.3206544460336_r8 + &
               y*(-942.7827304544439_r8 + y*(369.4389437509002_r8 + &
               (-33.83664947895248_r8 - 9.987880382780322_r8*y)*y))))))

gsw_ct_from_pt = pot_enthalpy/gsw_cp0

return
end function

!--------------------------------------------------------------------------


program fullgrid_cartesian_testdriver

use filesystem, only : mkdir
use phys_consts, only: wp
use meshobj_cart, only : cartmesh

implicit none (type, external)

integer, parameter :: lz=98+4,lx=128+4,ly=144+4     !+4 for ghost cells
real(wp), parameter :: glonctr=207.7_wp,glatctr=65.8_wp
real(wp), dimension(2), parameter :: zlims=[6.2062e+04,9.6794e+05]
real(wp), dimension(2), parameter :: xlims=[-1.5215e+06,1.5215e+06]
real(wp), dimension(2), parameter :: ylims=[-2.0559e+05,2.0559e+05]
real(wp), dimension(lz) :: z
real(wp), dimension(lx) :: xcart
real(wp), dimension(ly) :: y
integer :: iz,ix,iy, i
real(wp) :: minchkvar,maxchkvar
real(wp), dimension(:,:,:), allocatable :: proj

character(:), allocatable :: path
character(1000) :: argv

allocate(proj(1:lz-4,1:lx-4,1:ly-4))

! define a grid, this will include ghost cells
z=[(zlims(1) + (zlims(2)-zlims(1))/(lz-1)*(iz-1),iz=1,lz)]
xcart=[(xlims(1) + (xlims(2)-xlims(1))/(lx-1)*(ix-1),ix=1,lx)]
y=[(ylims(1) + (ylims(2)-ylims(1))/(ly-1)*(iy-1),iy=1,ly)]

! oddly the destructor does not get called when the program unit terminates; however by
!  putting the variable inside the block we cause it to go out of scope before the program
!  ends and that indeed causes the destructor to get triggered (so we can test it)
!!do while (.true.)
block
type(cartmesh) :: x

!!!! grid setup and init
! grid spec.
print*, 'fullgrid_testdriver:  Defining curvilinear coordinates...'
call x%set_coords(z,xcart,y,xcart,y)

print*, 'fullgrid_testdriver:  Setting geographic center of grid...'
call x%set_center(glonctr,glatctr)

! allocations
print*, 'fullgrid_testdriver:  Allocating space for coordinate-specific arrays...'
call x%init()

! call grid generation for this grid def.
print*, 'fullgrid_testdriver:  Calling dipole mesh constructor...'
call x%make()
!!!! end grid setup and init

! check variable allocation and set status
if(.not. all([x%xi_alloc_status,x%dxi_alloc_status,x%difflen_alloc_status,x%null_alloc_status,x%geog_set_status])) &
  error stop "allocation failure"

! now do some basic sanity checks
print*, 'fullgrid_testdriver:  Starting basic checks...'
print*, 'fullgrid_testdriver:  grid type...',x%gridflag
minchkvar=minval(x%z); maxchkvar=maxval(x%z);
print*, ' fullgrid_testdriver, z:  ',minchkvar,maxchkvar
minchkvar=minval(x%x); maxchkvar=maxval(x%x);
print*, ' fullgrid_testdriver, x:  ',minchkvar,maxchkvar
minchkvar=minval(x%y); maxchkvar=maxval(x%y);
print*, ' fullgrid_testdriver, y:  ',minchkvar,maxchkvar
minchkvar=minval(x%r); maxchkvar=maxval(x%r);
print*, ' fullgrid_testdriver, r:  ',minchkvar,maxchkvar
minchkvar=minval(x%theta); maxchkvar=maxval(x%theta);
print*, ' fullgrid_testdriver, theta:  ',minchkvar,maxchkvar
minchkvar=minval(x%phi); maxchkvar=maxval(x%phi);
print*, ' fullgrid_testdriver, phi:  ',minchkvar,maxchkvar
minchkvar=minval(x%er); maxchkvar=maxval(x%er);
print*, ' fullgrid_testdriver, er:  ',minchkvar,maxchkvar
minchkvar=minval(x%etheta); maxchkvar=maxval(x%etheta);
print*, ' fullgrid_testdriver, etheta:  ',minchkvar,maxchkvar
minchkvar=minval(x%ephi); maxchkvar=maxval(x%ephi);
print*, ' fullgrid_testdriver, ephi:  ',minchkvar,maxchkvar
minchkvar=minval(x%ez); maxchkvar=maxval(x%ez);
print*, ' fullgrid_testdriver, ez:  ',minchkvar,maxchkvar
minchkvar=minval(x%ex); maxchkvar=maxval(x%ex);
print*, ' fullgrid_testdriver, ex:  ',minchkvar,maxchkvar
minchkvar=minval(x%ey); maxchkvar=maxval(x%ey);
print*, ' fullgrid_testdriver, ey:  ',minchkvar,maxchkvar
minchkvar=minval(x%Bmag); maxchkvar=maxval(x%Bmag);
print*, ' fullgrid_testdriver, Bmag (nT):  ',minchkvar*1e9,maxchkvar*1e9
minchkvar=minval(x%gz); maxchkvar=maxval(x%gz);
print*, ' fullgrid_testdriver, gz:  ',minchkvar,maxchkvar
minchkvar=minval(x%gx); maxchkvar=maxval(x%gx);
print*, ' fullgrid_testdriver, gx:  ',minchkvar,maxchkvar
minchkvar=minval(x%gy); maxchkvar=maxval(x%gy);
print*, ' fullgrid_testdriver, gy:  ',minchkvar,maxchkvar
minchkvar=minval(x%I); maxchkvar=maxval(x%I);
print*, ' fullgrid_testdriver, I:  ',minchkvar,maxchkvar
minchkvar=minval(x%glon); maxchkvar=maxval(x%glon)
print*, ' fullgrid_testdriver, glon:  ',minchkvar,maxchkvar
minchkvar=minval(x%glat); maxchkvar=maxval(x%glat)
print*, ' fullgrid_testdriver, glat:  ',minchkvar,maxchkvar
minchkvar=minval(x%alt); maxchkvar=maxval(x%alt)
print*, ' fullgrid_testdriver, alt:  ',minchkvar,maxchkvar

! test number of null grid points
print*, ' fullgrid_testdriver, number of null grid points:  ',size(x%inull,1)

! write out the grid data to a file
if (command_argument_count() >= 1) then
  call get_command_argument(1, argv, status=i)
  if (i /= 0) error stop "could not get user file write path"
  path = trim(argv)
  call mkdir(path)
  print*, ' fullgrid_testdriver, writing grid coords. to:  ',path
  call x%writegrid(path,0)
  call x%writegridall(path,1)
endif

end block
!!end do

end program fullgrid_cartesian_testdriver


C
      INCLUDE 'VICMAIN_FOR'
C
      SUBROUTINE MAIN44
C
C----------------------------------------------------------------------
C
C        1984   CONVERT FROM IBM VICAR1 TO VICAR1*
C  4 FEB 1985   CONVERT TO VICAR2
C 31 OCT 1994   CONVERT FOR PORTING
C
C----------------------------------------------------------------------
C
C TRANSFORMS RANGE MEASUREMENT TO DISTANCE ON SURFACE
C (TRANSFORMS FROM SLANT RANGE TO GROUND RANGE)
C
C OUTPUT SCALE IS EQUAL TO AZIMUTH SCALE
C PARAMETER 1 - SENSOR HEIGHT (METERS) SPECIFIED AS AN INTEGER
C PARAMETER 2 - RANGE SAMPLE SPACING (MICRONS) SPECIFIED AS AN INTEGER
C PARAMETER 3 - AZIMUTH SAMP SPACING (MICRONS) SPECIFIED AS AN INTEGER
C PARAMETER 4 - RANGE SCALE (METERS/MICRON ON FILM) FLOATING POINT
C PARAMETER 5 - AZIMUTH SCALE (METERS/MICRON ON FILM) FLOATING POINT
C PARAMETER 6 - ANGLE FROM VERTICAL OF 1ST RETURN (DEGREES) FLOAT. PT.
C
      COMMON / C1 / INBUF, OBUF
      COMMON / C2 / INS1, INS2, F, G
      INTEGER*2 INBUF(20000), OBUF(20000)
      INTEGER   INS1(20000), INS2(20000)
      INTEGER   INUNIT, OUTUNIT, STATUS, ICNT
      REAL*4    F(20000), G(20000)
      CHARACTER*61  MES02
      CHARACTER*50  MES03, MES13
C
C
C   PROCESS THE PARAMETERS
C
      CALL IFMESSAGE('GEOMREC version 31-OCT-94')
      CALL XVUNIT(INUNIT,'INP',1,STATUS,' ')
      CALL XVOPEN(INUNIT,STATUS,'I_FORMAT','BYTE','U_FORMAT','HALF',
     +   'IO_ACT','SA','OPEN_ACT','SA',' ')
C
      CALL XVSIZE(ISL,ISS,NL,NS,INLI,INSI)
      CALL XVP('HEIGHT',IHGT,ICNT)
      CALL XVP('RSSPACE',IRSS,ICNT)
      CALL XVP('ASSPACE',IASS,ICNT)
      CALL XVP('RSCALE',RSCAL,ICNT)
      CALL XVP('ASCALE',ASCAL,ICNT)
      CALL XVP('THETA',ANGLE,ICNT)
C
C      OPEN THE OUTPUT FILE
C
      CALL XVUNIT(OUTUNIT,'OUT',1,STATUS,' ')
      CALL XVOPEN(OUTUNIT,STATUS,'OP','WRITE','O_FORMAT','BYTE',
     +        'U_FORMAT','HALF','IO_ACT','SA','OPEN_ACT','SA',' ')
C
      MES02 = '   INPUT   HEIGHT(PIXEL AND FEET)  = '
      MES03 = '           RANGE SAMP SPACING(MIC) =  '
      MES13 = '  OUTPUT NUMBER OF SAMPLES         =  '
      THETA = ANGLE*(3.1415/180.)
      RSS = FLOAT(IRSS)
      ASS = FLOAT(IASS)
      CONE = 1./(RSS*RSCAL)
      CTWO = 1./(ASS*ASCAL)
      RRES = RSS*RSCAL
      ARES = ASS*ASCAL
      HGT = FLOAT(IHGT)
      HGTFT = HGT * 3.28084
      ONETWO = CONE/CTWO
      HGTM = FLOAT(IHGT)*CONE
      HMS = HGTM*HGTM
      OFFSET = HGT*TAN(THETA)
      SNI = FLOAT(NS-1)
      Z = RRES*SNI
      ZZ = (Z+HGT/COS(THETA))**2 - HGT**2
      SNO = CTWO*(SQRT(ZZ)-OFFSET) + 1.0
      NSO = IFIX(SNO)
C
      WRITE(MES02(42:48),'(F7.1)') HGTM
      WRITE(MES02(52:61),'(F10.1)') HGTFT
      WRITE(MES03(42:48),'(F7.1)') RSS
      WRITE(MES13(41:47),'(I7)') NSO
      CALL XVMESSAGE(MES02,' ')
      CALL XVMESSAGE(MES03,' ')
      CALL XVMESSAGE(MES13,' ')
C
C     INITIALIZE ALL ARRAYS TO ZERO
C
      CALL ZIA(INS1,NSO)
      CALL ZIA(INS2,NSO)
      CALL ZIA(F,NSO)
      CALL ZIA(G,NSO)
      DO 30  KOSAMP= 1, NSO
         ZZ = (ARES*(KOSAMP-1)+OFFSET)**2 + HGT**2
         XINS = CONE*(SQRT(ZZ)-HGT/COS(THETA))
         INS = IFIX(XINS)
         FINS = XINS - FLOAT(INS)
         INS = INS + 2
         IF(INS .GT. NS) GO TO 30
         INS1(KOSAMP) = INS - 1
         INS2(KOSAMP) = INS
         F(KOSAMP) = 1.0 - FINS
         G(KOSAMP) = FINS
   30 CONTINUE
C
C  AI LOOP
C
      DO 100  IOLINE = 1,NL
         CALL XVREAD(INUNIT,INBUF,STATUS,'NSAMPS',NS,'SAMP',ISS,
     +               'LINE',IOLINE,' ')
         DO  90  IOSAMP = 1,NSO
            IN1 = INS1(IOSAMP)
            IN2 = IN1 + 1
            FF = F(IOSAMP)
            GG = 1.0 - FF
            FFF = (INBUF(IN1))
            GGG = (INBUF(IN2))
            XOUT = (FF*FFF) + (GG*GGG)
            IOUT = IFIX( 0.5 + XOUT)
            OBUF(IOSAMP) = IOUT
   90    CONTINUE
C
C  WRITE OUTPUT LINE
C
         CALL XVWRIT(OUTUNIT,OBUF,STATUS,'NSAMPS',NS,' ')
  100 CONTINUE
      CALL XVCLOSE(INUNIT,STATUS,' ')
      CALL XVCLOSE(OUTUNIT,STATUS,' ')
      RETURN
      END


subroutine pro42s( &
        !!! Inputs !!!
        N, Cab, Cw, Cm, &      !! PROSPECT 4 parameters
        solar_zenith, L, soil_moisture, &       ! Two stream parameters
        !!! Outputs !!!
        alpha_c, alpha_i, Tc, Ti, Ac, Ai)       ! Two stream Outputs

    use mod_dataspec_wavelength
    implicit none

    real*8, intent(in) :: N, Cab, Cw, Cm
    real*8, intent(in) :: solar_zenith, L, soil_moisture

    real*8, intent(out), dimension(nw) :: alpha_c, alpha_i, Tc, Ti, Ac, Ai

    real*8, dimension(nw,2) :: LRT

    call PROSPECT_4(N, Cab, Cw, Cm, LRT)
    call two_stream(LRT(:,1), LRT(:,2), solar_zenith, L, soil_moisture, &
        alpha_c, alpha_i, Tc, Ti, Ac, Ai)

end subroutine pro42s


!-----------------------------------------------------------------------
!     Module:        spec_profile
!     Authors:       S. Lazerson (lazerson@pppl.gov)
!     Date:          04/09/2012
!     Description:   This module contains the various profile quantities
!                    which define the equilibrium
!-----------------------------------------------------------------------
      MODULE spec_profile
!-----------------------------------------------------------------------
!     Libraries
!-----------------------------------------------------------------------
      USE stel_kinds
      USE EZspline_obj
      USE EZspline
!-----------------------------------------------------------------------
!     Module Variables
!          torflux_edge Toridal flux at the edge of the plasma
!          press        Pressure
!          torflux      Toroidal Flux
!          iprime       I'=dI/dPsi
!          p_spl        Pressure Spline Object
!          i_spl        I' Spline Object
!----------------------------------------------------------------------
      IMPLICIT NONE

      REAL(rprec) :: torflux_edge
      REAL(rprec) :: curtor
      REAL(rprec) :: pscale
      REAL(rprec), ALLOCATABLE :: press(:)
      REAL(rprec), ALLOCATABLE :: adiab(:)
      REAL(rprec), ALLOCATABLE :: currf(:)
      REAL(rprec), ALLOCATABLE :: iotaf(:)
      REAL(rprec), ALLOCATABLE :: torflux_pies(:)
      REAL(rprec), ALLOCATABLE :: torflux_norm(:)
      REAL(rprec), ALLOCATABLE :: iprime(:)
      REAL(rprec), ALLOCATABLE :: p_cubspl(:,:)
      REAL(rprec), ALLOCATABLE :: ip_cubspl(:,:)
      TYPE(EZspline1_r8) :: p_spl
      TYPE(EZspline1_r8) :: ip_spl
      TYPE(EZspline1_r8) :: iota_spl

      END MODULE spec_profile


      subroutine impsvd(a,m,n,w,v)
c
c     + + + PURPOSE + + +
c
c     SR IMPSVD is an impoundment element singular value
c     decomposition subroutine.  It is utilized in
c     developing least squares fits for a variety of
c     functions. It is taken directly from the book
c     "Numerical Recipes in Fortran".
c
c     Called from: IMPINT
c
c     Copyright (C) 1986, 1992 Numerical Recipes Software
c
c     Permission is granted for use only within USDA Water Erosion
c     Prediction Project code
c
c     + + + KEYWORDS + + +
c
c     + + + PARAMETERS + + +
c
c     + + + ARGUMENT DECLARATIONS + + +
c
      integer m, n
      real a(100,5), w(5), v(5,5)
c
c     + + + ARGUMENT DEFINITIONS + + +
c
c     + + + COMMON BLOCKS + + +
c
c     + + + LOCAL VARIABLES + + +
c
      real rv1(100), x, g, scale, y, anorm, h, z, c, f, s
      integer i, j, jj, k, nm, l, its
c
c     + + + LOCAL DEFINITIONS + + +
c
c     + + + SAVES + + +
c
c     + + + SUBROUTINES CALLED + + +
c
c     + + + DATA INITIALIZATIONS + + +
c
c     + + + END SPECIFICATIONS + + +
c
c
      g = 0.0
      scale = 0.0
      anorm = 0.0
c
      do 140 i = 1, n
        l = i + 1
        rv1(i) = scale * g
        g = 0.0
        s = 0.0
        scale = 0.0
c
        if (i.le.m) then
c
          do 10 k = i, m
            scale = scale + abs(a(k,i))
   10     continue
c
          if (scale.ne.0.0) then
c
            do 20 k = i, m
              a(k,i) = a(k,i) / scale
              s = s + a(k,i) * a(k,i)
   20       continue
c
            f = a(i,i)
            g = -sign(sqrt(s),f)
            h = f * g - s
            a(i,i) = f - g
c
            if (i.ne.n) then
              do 50 j = l, n
                s = 0.0
c
                do 30 k = i, m
                  s = s + a(k,i) * a(k,j)
   30           continue
c
                f = s / h
c
                do 40 k = i, m
                  a(k,j) = a(k,j) + f * a(k,i)
   40           continue
c
   50         continue
            end if
c
            do 60 k = i, m
              a(k,i) = scale * a(k,i)
   60       continue
c
          end if
        end if
c
        w(i) = scale * g
        g = 0.0
        s = 0.0
        scale = 0.0
c
        if ((i.le.m).and.(i.ne.n)) then
c
          do 70 k = l, n
            scale = scale + abs(a(i,k))
   70     continue
c
          if (scale.ne.0.0) then
c
            do 80 k = l, n
              a(i,k) = a(i,k) / scale
              s = s + a(i,k) * a(i,k)
   80       continue
c
            f = a(i,l)
            g = -sign(sqrt(s),f)
            h = f * g - s
            a(i,l) = f - g
c
            do 90 k = l, n
              rv1(k) = a(i,k) / h
   90       continue
c
            if (i.ne.m) then
c
              do 120 j = l, m
                s = 0.0
c
                do 100 k = l, n
                  s = s + a(j,k) * a(i,k)
  100           continue
c
                do 110 k = l, n
                  a(j,k) = a(j,k) + s * rv1(k)
  110           continue
c
  120         continue
            end if
c
            do 130 k = l, n
              a(i,k) = scale * a(i,k)
  130       continue
c
          end if
        end if
c
        anorm = max(anorm,(abs(w(i))+abs(rv1(i))))
c
  140 continue
c
      do 200 i = n, 1, -1
c
        if (i.lt.n) then
c
          if (g.ne.0.0) then
c
            do 150 j = l, n
              v(j,i) = (a(i,j)/a(i,l)) / g
  150       continue
c
            do 180 j = l, n
              s = 0.0
c
              do 160 k = l, n
                s = s + a(i,k) * v(k,j)
  160         continue
c
              do 170 k = l, n
                v(k,j) = v(k,j) + s * v(k,i)
  170         continue
c
  180       continue
c
          end if
c
          do 190 j = l, n
            v(i,j) = 0.0
            v(j,i) = 0.0
  190     continue
c
        end if
c
        v(i,i) = 1.0
        g = rv1(i)
        l = i
  200 continue
c
      do 270 i = n, 1, -1
        l = i + 1
        g = w(i)
c
        if (i.lt.n) then
c
          do 210 j = l, n
            a(i,j) = 0.0
  210     continue
        end if
c
        if (g.ne.0.0) then
          g = 1.0 / g
c
          if (i.ne.n) then
c
            do 240 j = l, n
              s = 0.0
c
              do 220 k = l, m
                s = s + a(k,i) * a(k,j)
  220         continue
c
              f = (s/a(i,i)) * g
c
              do 230 k = i, m
                a(k,j) = a(k,j) + f * a(k,i)
  230         continue
c
  240       continue
c
          end if
c
          do 250 j = i, m
            a(j,i) = a(j,i) * g
  250     continue
c
        else
c
          do 260 j = i, m
            a(j,i) = 0.0
  260     continue
c
        end if
c
        a(i,i) = a(i,i) + 1.0
  270 continue
c
      do 390 k = n, 1, -1
c
        do 370 its = 1, 30
c
          do 280 l = k, 1, -1
            nm = l - 1
            if ((abs(rv1(l))+anorm).eq.anorm) go to 320
            if ((abs(w(nm))+anorm).eq.anorm) go to 290
  280     continue
c
  290     c = 0.0
c
          s = 1.0
c
          do 310 i = l, k
            f = s * rv1(i)
            rv1(i) = c * rv1(i)
            if ((abs(f)+anorm).eq.anorm) go to 320
            g = w(i)
            h = sqrt(f*f+g*g)
            w(i) = h
            h = 1.0 / h
            c = (g*h)
            s = -(f*h)
c
            do 300 j = 1, m
              y = a(j,nm)
              z = a(j,i)
              a(j,nm) = (y*c) + (z*s)
              a(j,i) = -(y*s) + (z*c)
  300       continue
c
  310     continue
c
  320     z = w(k)
c
          if (l.eq.k) then
c
            if (z.lt.0.0) then
              w(k) = -z
c
              do 330 j = 1, n
                v(j,k) = -v(j,k)
  330         continue
c
            end if
c
            go to 380
          end if
c
cdcf      Comment out following line - this line will cause model
cdcf      to potentially stop, with no graceful exit.
cdcf      Instead - alter to print a screen Error message
cdcf      dcf - 6/1/2000
cdcf      if (its.eq.30) pause 'No convergence in 30 iterations'
c
          if (its.ge.30) write(6,1000)
c
          x = w(l)
          nm = k - 1
          y = w(nm)
          g = rv1(nm)
          h = rv1(k)
          f = ((y-z)*(y+z)+(g-h)*(g+h)) / (2.0*h*y)
          g = sqrt(f*f+1.0)
          f = ((x-z)*(x+z)+h*((y/(f+sign(g,f)))-h)) / x
          c = 1.0
          s = 1.0
c
          do 360 j = l, nm
            i = j + 1
            g = rv1(i)
            y = w(i)
            h = s * g
            g = c * g
            z = sqrt(f*f+h*h)
            rv1(j) = z
            c = f / z
            s = h / z
            f = (x*c) + (g*s)
            g = -(x*s) + (g*c)
            h = y * s
            y = y * c
c
            do 340 jj = 1, n
              x = v(jj,j)
              z = v(jj,i)
              v(jj,j) = (x*c) + (z*s)
              v(jj,i) = -(x*s) + (z*c)
  340       continue
c
            z = sqrt(f*f+h*h)
            w(j) = z
c
            if (z.ne.0.0) then
              z = 1.0 / z
              c = f * z
              s = h * z
            end if
c
            f = (c*g) + (s*y)
            x = -(s*g) + (c*y)
c
            do 350 jj = 1, m
              y = a(jj,j)
              z = a(jj,i)
              a(jj,j) = (y*c) + (z*s)
              a(jj,i) = -(y*s) + (z*c)
  350       continue
c
  360     continue
c
          rv1(l) = 0.0
          rv1(k) = f
          w(k) = x
c
  370   continue
c
  380   continue
c
  390 continue
c
 1000 format(/,' ***ERROR***',' In subroutine IMPSVD',
     1       ' no convergence in 30 iterations',/)
      return
      end


!
!  Copyright 2016 ARTED developers
!
!  Licensed under the Apache License, Version 2.0 (the "License");
!  you may not use this file except in compliance with the License.
!  You may obtain a copy of the License at
!
!      http://www.apache.org/licenses/LICENSE-2.0
!
!  Unless required by applicable law or agreed to in writing, software
!  distributed under the License is distributed on an "AS IS" BASIS,
!  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
!  See the License for the specific language governing permissions and
!  limitations under the License.
!
!This file is "Gram_Schmidt.f90"
!This file contain one subroutine.
!Subroutine Gram_Schmidt
!--------10--------20--------30--------40--------50--------60--------70--------80--------90--------100-------110-------120--------130
Subroutine Gram_Schmidt
  use Global_Variables
  use timelog
  implicit none
  integer :: ik,ib,ibt
  real(8) :: s
  complex(8) :: zov

  call timelog_begin(LOG_GRAM_SCHMIDT)
!$omp parallel do private(ib,ibt,zov,s)
  do ik=NK_s,NK_e
  do ib=1,NB
    do ibt=1,ib-1
      zov=sum(conjg(zu_GS(:,ibt,ik))*zu_GS(:,ib,ik))*Hxyz
      zu_GS(:,ib,ik)=zu_GS(:,ib,ik)-zu_GS(:,ibt,ik)*zov
    enddo
    s=sum(abs(zu_GS(:,ib,ik))**2)*Hxyz
    zu_GS(:,ib,ik)=zu_GS(:,ib,ik)/sqrt(s)
  enddo
  enddo
  call timelog_end(LOG_GRAM_SCHMIDT)

  return
End Subroutine Gram_Schmidt


Subroutine Postprocess(iter)
use Aero2DCOM
implicit none
integer i,n,iter
real(8) Cx,Cy,Ctx,Cty,Cpm,Ctm
character(6) wallfunutype
real(8) Fwall(Ib1:Ib2)

wallfunutype='parvel'

n=3
if(mod(iter,100)==0) then
 DO i=1,n-1
  Clrec(i)=Clrec(i+1)
  Cdrec(i)=Cdrec(i+1)
  Cfrec(i)=Cfrec(i+1)
  Cmrec(i)=Cmrec(i+1)
  Xpcrec(i)=Xpcrec(i+1)
  Ypcrec(i)=Ypcrec(i+1)
  Pnw(:,i)=Pnw(:,i+1)
  Unw(:,i)=Unw(:,i+1)
  Vnw(:,i)=Vnw(:,i+1)
  Tnw(:,i)=Tnw(:,i+1)
  mutnw(:,i)=mutnw(:,i+1)
  hcvnw(:,i)=hcvnw(:,i+1)
  Axnw(:,i)=Axnw(:,i+1)
  Aynw(:,i)=Aynw(:,i+1)
  Ypnw(:,i)=Ypnw(:,i+1)
 end DO
 Clrec(n)=Cl
 Cdrec(n)=Cd
 Cfrec(n)=Cf
 Cmrec(n)=Cm
 Xpcrec(n)=Xpc
 Ypcrec(n)=Ypc
 Pnw(:,n)=P(Ib1:Ib2,1)
 Unw(:,n)=U(Ib1:Ib2,1)
 Vnw(:,n)=V(Ib1:Ib2,1)
 Tnw(:,n)=T(Ib1:Ib2,1)
 mutnw(:,n)=mut(Ib1:Ib2,1)
 hcvnw(:,n)=hcv
 Axnw(:,n)=Ax
 Aynw(:,n)=Ay
 if(Turmod=='sa'.or.Turmod=='sst') then
  Ypnw(:,n)=Yplus
 else if(Turmod=='ke') then
  Ypnw(:,n)=Ystar
 end if
end if
if(Tmptype=='fixed') then
 Fwall=Tf
else if(Tmptype=='flux') then
 if(Walltreat=='wf') then
  Fwall=T(Ib1:Ib2,1)+Qf*Tplus/(ca*rho(Ib1:Ib2,1)*ustar)
 else
  Fwall=T(Ib1:Ib2,1)+Qf*Yp/(ka+ca*mut(Ib1:Ib2,1)/Prt)
 end if
end if
DO i=Ib1,Ib2
 if(Turmod=='sa'.and.Walltreat=='lr'.or.(Turmod=='sst'.and.Walltreat=='lr').or.Turmod=='lam'.or.Turmod=='inv') then
  Q(i)=ca*(ka/ca+mut(i,1)/Prt)*(T(i,1)-Fwall(i))/Yp(i)
  if(Ta-Fwall(i)/=0) then
   hcv(i)=Q(i)/(Ta-Fwall(i))
  else
   hcv(i)=Q(i)
  end if
  Ax(i)=(mu(i,1)+mut(i,1))*U(i,1)/Yp(i)
  Ay(i)=(mu(i,1)+mut(i,1))*V(i,1)/Yp(i)
 else if(Turmod=='ke'.or.(Turmod=='sa'.and.Walltreat=='wf').or.(Turmod=='sst'.and.Walltreat=='wf')) then
  if(Ta-Fwall(i)/=0) then
   hcv(i)=Q(i)/(Fwall(i)-Ta)
  else
   hcv(i)=Q(i)
  end if
  if(wallfunutype=='parvel') then
   Ax(i)=rho(i,1)*ustar(i)*Un(i,1)*Yga(i,1)/Uplus(i)/da(i,1)**2
   Ay(i)=-rho(i,1)*ustar(i)*Un(i,1)*Xga(i,1)/Uplus(i)/da(i,1)**2
  else
   Ax(i)=rho(i,1)*ustar(i)*U(i,1)/Uplus(i)
   Ay(i)=rho(i,1)*ustar(i)*V(i,1)/Uplus(i)
  end if
 end if
end DO
Cx=0
Cy=0
Ctx=0
Cty=0
Cpm=0
Ctm=0
DO i=Ib1,Ib2
 Cx=Cx+P(i,1)*(Yg(i+1,1)-Yg(i,1))
 Cy=Cy+P(i,1)*(-Xg(i+1,1)+Xg(i,1))
 Ctx=Ctx+Ax(i)*DR(i)
 Cty=Cty+Ay(i)*DR(i)
 Cpm=Cpm+(Xw(i)-0.25*c)*P(i,1)*(-Xg(i+1,1)+Xg(i,1))-Yw(i)*P(i,1)*(Yg(i+1,1)-Yg(i,1))
 Ctm=Ctm+(Xw(i)-0.25*c)*Ay(i)*DR(i)-Yw(i)*Ax(i)*DR(i)
end DO
Xpc=0.25+Cpm/(c*Cy)
Ypc=0
Cl=((Cty+Cy)*cos(AoA*Pi/180)-(Ctx+Cx)*sin(AoA*Pi/180))/(0.5*rhoi*Vfar**2*c)
Cd=(Cy*sin(AoA*Pi/180)+Cx*cos(AoA*Pi/180))/(0.5*rhoi*Vfar**2*c)
Cf=(Cty*sin(AoA*Pi/180)+Ctx*cos(AoA*Pi/180))/(0.5*rhoi*Vfar**2*c)
Cm=-(Cpm+Ctm)/(0.5*rhoi*Vfar**2*c**2)
end Subroutine Postprocess


SUBROUTINE glob_to_axial(axial,global,coord)
!
! This subroutine transforms the global end reactions
! into an axial force for rod elements (2- or 3-d).
!
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::global(:),coord(:,:)
 REAL(iwp),INTENT(OUT)::axial
 REAL(iwp)::add,ell,zero=0.0_iwp
 INTEGER::ndim,i
 ndim=UBOUND(coord,2)
 add=zero
 DO i=1,ndim
   add=add+(coord(2,i)-coord(1,i))**2
 END DO
 ell=SQRT(add)
 axial=zero
 DO i=1,ndim
   axial=axial+(coord(2,i)-coord(1,i))/ell*global(ndim+i)
 END DO
RETURN
END SUBROUTINE glob_to_axial


C introduced a program header by Manju : 17-4-96
C introduced a dummy function second() by Manju : 17-4-96
      PROGRAM Linpackd
      double precision aa(200,200),a(201,200),b(200),x(200)
      double precision time(8,6),cray,ops,total,norma,normx
      double precision resid,residn,eps,epslon
      integer ipvt(200)
      lda = 201
      ldaa = 200
c
      n = 100
      cray = .056
      write(6,1)
    1 format(' Please send the results of this run to:'//
     $       ' Jack J. Dongarra'/
     $       ' Computer Science Department'/
     $       ' University of Tennessee'/
     $       ' Knoxville, Tennessee 37996-1300'//
     $       ' Fax: 615-974-8296'//
     $       ' Internet: dongarra@cs.utk.edu'/)
      ops = (2.0d0*n**3)/3.0d0 + 2.0d0*n**2
c
         call matgen(a,lda,n,b,norma)
         t1 = second()
         call dgefa(a,lda,n,ipvt,info)
         time(1,1) = second() - t1
         t1 = second()
         call dgesl(a,lda,n,ipvt,b,0)
         time(1,2) = second() - t1
         total = time(1,1) + time(1,2)
c
c     compute a residual to verify results.
c
         do 10 i = 1,n
            x(i) = b(i)
   10    continue
         call matgen(a,lda,n,b,norma)
         do 20 i = 1,n
            b(i) = -b(i)
   20    continue
         call dmxpy(n,b,n,lda,x,a)
         resid = 0.0
         normx = 0.0
         do 30 i = 1,n
            resid = dmax1( resid, dabs(b(i)) )
            normx = dmax1( normx, dabs(x(i)) )
   30    continue
         eps = epslon(1.0d0)
         residn = resid/( n*norma*normx*eps )
         write(6,40)
   40    format('     norm. resid      resid           machep',
     $          '         x(1)          x(n)')
         write(6,50) residn,resid,eps,x(1),x(n)
   50    format(1p5e16.8)
c
         write(6,60) n
   60    format(//'    times are reported for matrices of order ',i5)
         write(6,70)
   70    format(6x,'dgefa',6x,'dgesl',6x,'total',5x,'mflops',7x,'unit',
     $         6x,'ratio')
c
         time(1,3) = total
         time(1,4) = ops/(1.0d6*total)
         time(1,5) = 2.0d0/time(1,4)
         time(1,6) = total/cray
         write(6,80) lda
   80    format(' times for array with leading dimension of',i4)
         write(6,110) (time(1,i),i=1,6)
c
         call matgen(a,lda,n,b,norma)
         t1 = second()
         call dgefa(a,lda,n,ipvt,info)
         time(2,1) = second() - t1
         t1 = second()
         call dgesl(a,lda,n,ipvt,b,0)
         time(2,2) = second() - t1
         total = time(2,1) + time(2,2)
         time(2,3) = total
         time(2,4) = ops/(1.0d6*total)
         time(2,5) = 2.0d0/time(2,4)
         time(2,6) = total/cray
c
         call matgen(a,lda,n,b,norma)
         t1 = second()
         call dgefa(a,lda,n,ipvt,info)
         time(3,1) = second() - t1
         t1 = second()
         call dgesl(a,lda,n,ipvt,b,0)
         time(3,2) = second() - t1
         total = time(3,1) + time(3,2)
         time(3,3) = total
         time(3,4) = ops/(1.0d6*total)
         time(3,5) = 2.0d0/time(3,4)
         time(3,6) = total/cray
c
         ntimes = 10
         tm2 = 0
         t1 = second()
         do 90 i = 1,ntimes
            tm = second()
            call matgen(a,lda,n,b,norma)
            tm2 = tm2 + second() - tm
            call dgefa(a,lda,n,ipvt,info)
   90    continue
         time(4,1) = (second() - t1 - tm2)/ntimes
         t1 = second()
         do 100 i = 1,ntimes
            call dgesl(a,lda,n,ipvt,b,0)
  100    continue
         time(4,2) = (second() - t1)/ntimes
         total = time(4,1) + time(4,2)
         time(4,3) = total
         time(4,4) = ops/(1.0d6*total)
         time(4,5) = 2.0d0/time(4,4)
         time(4,6) = total/cray
c
         write(6,110) (time(2,i),i=1,6)
         write(6,110) (time(3,i),i=1,6)
         write(6,110) (time(4,i),i=1,6)
  110    format(6(1pe11.3))
c
         call matgen(aa,ldaa,n,b,norma)
         t1 = second()
         call dgefa(aa,ldaa,n,ipvt,info)
         time(5,1) = second() - t1
         t1 = second()
         call dgesl(aa,ldaa,n,ipvt,b,0)
         time(5,2) = second() - t1
         total = time(5,1) + time(5,2)
         time(5,3) = total
         time(5,4) = ops/(1.0d6*total)
         time(5,5) = 2.0d0/time(5,4)
         time(5,6) = total/cray
c
         call matgen(aa,ldaa,n,b,norma)
         t1 = second()
         call dgefa(aa,ldaa,n,ipvt,info)
         time(6,1) = second() - t1
         t1 = second()
         call dgesl(aa,ldaa,n,ipvt,b,0)
         time(6,2) = second() - t1
         total = time(6,1) + time(6,2)
         time(6,3) = total
         time(6,4) = ops/(1.0d6*total)
         time(6,5) = 2.0d0/time(6,4)
         time(6,6) = total/cray
c
         call matgen(aa,ldaa,n,b,norma)
         t1 = second()
         call dgefa(aa,ldaa,n,ipvt,info)
         time(7,1) = second() - t1
         t1 = second()
         call dgesl(aa,ldaa,n,ipvt,b,0)
         time(7,2) = second() - t1
         total = time(7,1) + time(7,2)
         time(7,3) = total
         time(7,4) = ops/(1.0d6*total)
         time(7,5) = 2.0d0/time(7,4)
         time(7,6) = total/cray
c
         ntimes = 10
         tm2 = 0
         t1 = second()
         do 120 i = 1,ntimes
            tm = second()
            call matgen(aa,ldaa,n,b,norma)
            tm2 = tm2 + second() - tm
            call dgefa(aa,ldaa,n,ipvt,info)
  120    continue
         time(8,1) = (second() - t1 - tm2)/ntimes
         t1 = second()
         do 130 i = 1,ntimes
            call dgesl(aa,ldaa,n,ipvt,b,0)
  130    continue
         time(8,2) = (second() - t1)/ntimes
         total = time(8,1) + time(8,2)
         time(8,3) = total
         time(8,4) = ops/(1.0d6*total)
         time(8,5) = 2.0d0/time(8,4)
         time(8,6) = total/cray
c
         write(6,140) ldaa
  140    format(/' times for array with leading dimension of',i4)
         write(6,110) (time(5,i),i=1,6)
         write(6,110) (time(6,i),i=1,6)
         write(6,110) (time(7,i),i=1,6)
         write(6,110) (time(8,i),i=1,6)
      stop
      end

      subroutine second()
      INTEGER k
C dummy computation
      k = 1
      return
      end

      subroutine matgen(a,lda,n,b,norma)
      double precision a(lda,1),b(1),norma
c
      init = 1325
      norma = 0.0
      do 30 j = 1,n
         do 20 i = 1,n
            init = mod(3125*init,65536)
            a(i,j) = (init - 32768.0)/16384.0
            norma = dmax1(dabs(a(i,j)), norma)
   20    continue
   30 continue
      do 35 i = 1,n
          b(i) = 0.0
   35 continue
      do 50 j = 1,n
         do 40 i = 1,n
            b(i) = b(i) + a(i,j)
   40    continue
   50 continue
      return
      end
      subroutine dgefa(a,lda,n,ipvt,info)
      integer lda,n,ipvt(1),info
      double precision a(lda,1)
c
c     dgefa factors a double precision matrix by gaussian elimination.
c
c     dgefa is usually called by dgeco, but it can be called
c     directly with a saving in time if  rcond  is not needed.
c     (time for dgeco) = (1 + 9/n)*(time for dgefa) .
c
c     on entry
c
c        a       double precision(lda, n)
c                the matrix to be factored.
c
c        lda     integer
c                the leading dimension of the array  a .
c
c        n       integer
c                the order of the matrix  a .
c
c     on return
c
c        a       an upper triangular matrix and the multipliers
c                which were used to obtain it.
c                the factorization can be written  a = l*u  where
c                l  is a product of permutation and unit lower
c                triangular matrices and  u  is upper triangular.
c
c        ipvt    integer(n)
c                an integer vector of pivot indices.
c
c        info    integer
c                = 0  normal value.
c                = k  if  u(k,k) .eq. 0.0 .  this is not an error
c                     condition for this subroutine, but it does
c                     indicate that dgesl or dgedi will divide by zero
c                     if called.  use  rcond  in dgeco for a reliable
c                     indication of singularity.
c
c     linpack. this version dated 08/14/78 .
c     cleve moler, university of new mexico, argonne national lab.
c
c     subroutines and functions
c
c     blas daxpy,dscal,idamax
c
c     internal variables
c
      double precision t
      integer idamax,j,k,kp1,l,nm1
c
c
c     gaussian elimination with partial pivoting
c
      info = 0
      nm1 = n - 1
      if (nm1 .lt. 1) go to 70
      do 60 k = 1, nm1
         kp1 = k + 1
c
c        find l = pivot index
c
         l = idamax(n-k+1,a(k,k),1) + k - 1
         ipvt(k) = l
c
c        zero pivot implies this column already triangularized
c
         if (a(l,k) .eq. 0.0d0) go to 40
c
c           interchange if necessary
c
            if (l .eq. k) go to 10
               t = a(l,k)
               a(l,k) = a(k,k)
               a(k,k) = t
   10       continue
c
c           compute multipliers
c
            t = -1.0d0/a(k,k)
            call dscal(n-k,t,a(k+1,k),1)
c
c           row elimination with column indexing
c
            do 30 j = kp1, n
               t = a(l,j)
               if (l .eq. k) go to 20
                  a(l,j) = a(k,j)
                  a(k,j) = t
   20          continue
               call daxpy(n-k,t,a(k+1,k),1,a(k+1,j),1)
   30       continue
         go to 50
   40    continue
            info = k
   50    continue
   60 continue
   70 continue
      ipvt(n) = n
      if (a(n,n) .eq. 0.0d0) info = n
      return
      end
      subroutine dgesl(a,lda,n,ipvt,b,job)
      integer lda,n,ipvt(1),job
      double precision a(lda,1),b(1)
c
c     dgesl solves the double precision system
c     a * x = b  or  trans(a) * x = b
c     using the factors computed by dgeco or dgefa.
c
c     on entry
c
c        a       double precision(lda, n)
c                the output from dgeco or dgefa.
c
c        lda     integer
c                the leading dimension of the array  a .
c
c        n       integer
c                the order of the matrix  a .
c
c        ipvt    integer(n)
c                the pivot vector from dgeco or dgefa.
c
c        b       double precision(n)
c                the right hand side vector.
c
c        job     integer
c                = 0         to solve  a*x = b ,
c                = nonzero   to solve  trans(a)*x = b  where
c                            trans(a)  is the transpose.
c
c     on return
c
c        b       the solution vector  x .
c
c     error condition
c
c        a division by zero will occur if the input factor contains a
c        zero on the diagonal.  technically this indicates singularity
c        but it is often caused by improper arguments or improper
c        setting of lda .  it will not occur if the subroutines are
c        called correctly and if dgeco has set rcond .gt. 0.0
c        or dgefa has set info .eq. 0 .
c
c     to compute  inverse(a) * c  where  c  is a matrix
c     with  p  columns
c           call dgeco(a,lda,n,ipvt,rcond,z)
c           if (rcond is too small) go to ...
c           do 10 j = 1, p
c              call dgesl(a,lda,n,ipvt,c(1,j),0)
c        10 continue
c
c     linpack. this version dated 08/14/78 .
c     cleve moler, university of new mexico, argonne national lab.
c
c     subroutines and functions
c
c     blas daxpy,ddot
c
c     internal variables
c
      double precision ddot,t
      integer k,kb,l,nm1
c
      nm1 = n - 1
      if (job .ne. 0) go to 50
c
c        job = 0 , solve  a * x = b
c        first solve  l*y = b
c
         if (nm1 .lt. 1) go to 30
         do 20 k = 1, nm1
            l = ipvt(k)
            t = b(l)
            if (l .eq. k) go to 10
               b(l) = b(k)
               b(k) = t
   10       continue
            call daxpy(n-k,t,a(k+1,k),1,b(k+1),1)
   20    continue
   30    continue
c
c        now solve  u*x = y
c
         do 40 kb = 1, n
            k = n + 1 - kb
            b(k) = b(k)/a(k,k)
            t = -b(k)
            call daxpy(k-1,t,a(1,k),1,b(1),1)
   40    continue
      go to 100
   50 continue
c
c        job = nonzero, solve  trans(a) * x = b
c        first solve  trans(u)*y = b
c
         do 60 k = 1, n
            t = ddot(k-1,a(1,k),1,b(1),1)
            b(k) = (b(k) - t)/a(k,k)
   60    continue
c
c        now solve trans(l)*x = y
c
         if (nm1 .lt. 1) go to 90
         do 80 kb = 1, nm1
            k = n - kb
            b(k) = b(k) + ddot(n-k,a(k+1,k),1,b(k+1),1)
            l = ipvt(k)
            if (l .eq. k) go to 70
               t = b(l)
               b(l) = b(k)
               b(k) = t
   70       continue
   80    continue
   90    continue
  100 continue
      return
      end
      subroutine daxpy(n,da,dx,incx,dy,incy)
c
c     constant times a vector plus a vector.
c     jack dongarra, linpack, 3/11/78.
c
      double precision dx(1),dy(1),da
      integer i,incx,incy,ix,iy,m,mp1,n
c
      if(n.le.0)return
      if (da .eq. 0.0d0) return
      if(incx.eq.1.and.incy.eq.1)go to 20
c
c        code for unequal increments or equal increments
c          not equal to 1
c
      ix = 1
      iy = 1
      if(incx.lt.0)ix = (-n+1)*incx + 1
      if(incy.lt.0)iy = (-n+1)*incy + 1
      do 10 i = 1,n
        dy(iy) = dy(iy) + da*dx(ix)
        ix = ix + incx
        iy = iy + incy
   10 continue
      return
c
c        code for both increments equal to 1
c
   20 continue
      do 30 i = 1,n
        dy(i) = dy(i) + da*dx(i)
   30 continue
      return
      end
      double precision function ddot(n,dx,incx,dy,incy)
c
c     forms the dot product of two vectors.
c     jack dongarra, linpack, 3/11/78.
c
      double precision dx(1),dy(1),dtemp
      integer i,incx,incy,ix,iy,m,mp1,n
c
      ddot = 0.0d0
      dtemp = 0.0d0
      if(n.le.0)return
      if(incx.eq.1.and.incy.eq.1)go to 20
c
c        code for unequal increments or equal increments
c          not equal to 1
c
      ix = 1
      iy = 1
      if(incx.lt.0)ix = (-n+1)*incx + 1
      if(incy.lt.0)iy = (-n+1)*incy + 1
      do 10 i = 1,n
        dtemp = dtemp + dx(ix)*dy(iy)
        ix = ix + incx
        iy = iy + incy
   10 continue
      ddot = dtemp
      return
c
c        code for both increments equal to 1
c
   20 continue
      do 30 i = 1,n
        dtemp = dtemp + dx(i)*dy(i)
   30 continue
      ddot = dtemp
      return
      end
      subroutine  dscal(n,da,dx,incx)
c
c     scales a vector by a constant.
c     jack dongarra, linpack, 3/11/78.
c
      double precision da,dx(1)
      integer i,incx,m,mp1,n,nincx
c
      if(n.le.0)return
      if(incx.eq.1)go to 20
c
c        code for increment not equal to 1
c
      nincx = n*incx
      do 10 i = 1,nincx,incx
        dx(i) = da*dx(i)
   10 continue
      return
c
c        code for increment equal to 1
c
   20 continue
      do 30 i = 1,n
        dx(i) = da*dx(i)
   30 continue
      return
      end
      integer function idamax(n,dx,incx)
c
c     finds the index of element having max. dabsolute value.
c     jack dongarra, linpack, 3/11/78.
c
      double precision dx(1),dmax
      integer i,incx,ix,n
c
      idamax = 0
      if( n .lt. 1 ) return
      idamax = 1
      if(n.eq.1)return
      if(incx.eq.1)go to 20
c
c        code for increment not equal to 1
c
      ix = 1
      dmax = dabs(dx(1))
      ix = ix + incx
      do 10 i = 2,n
         if(dabs(dx(ix)).le.dmax) go to 5
         idamax = i
         dmax = dabs(dx(ix))
    5    ix = ix + incx
   10 continue
      return
c
c        code for increment equal to 1
c
   20 dmax = dabs(dx(1))
      do 30 i = 2,n
         if(dabs(dx(i)).le.dmax) go to 30
         idamax = i
         dmax = dabs(dx(i))
   30 continue
      return
      end
      double precision function epslon (x)
      double precision x
c
c     estimate unit roundoff in quantities of size x.
c
      double precision a,b,c,eps
c
c     this program should function properly on all systems
c     satisfying the following two assumptions,
c        1.  the base used in representing dfloating point
c            numbers is not a power of three.
c        2.  the quantity  a  in statement 10 is represented to
c            the accuracy used in dfloating point variables
c            that are stored in memory.
c     the statement number 10 and the go to 10 are intended to
c     force optimizing compilers to generate code satisfying
c     assumption 2.
c     under these assumptions, it should be true that,
c            a  is not exactly equal to four-thirds,
c            b  has a zero for its last bit or digit,
c            c  is not exactly equal to one,
c            eps  measures the separation of 1.0 from
c                 the next larger dfloating point number.
c     the developers of eispack would appreciate being informed
c     about any systems where these assumptions do not hold.
c
c     *****************************************************************
c     this routine is one of the auxiliary routines used by eispack iii
c     to avoid machine dependencies.
c     *****************************************************************
c
c     this version dated 4/6/83.
c
      a = 4.0d0/3.0d0
   10 b = a - 1.0d0
      c = b + b + b
      eps = dabs(c-1.0d0)
      if (eps .eq. 0.0d0) go to 10
      epslon = eps*dabs(x)
      return
      end
      subroutine dmxpy (n1, y, n2, ldm, x, m)
      double precision y(*), x(*), m(ldm,*)
c
c   purpose:
c     multiply matrix m times vector x and add the result to vector y.
c
c   parameters:
c
c     n1 integer, number of elements in vector y, and number of rows in
c         matrix m
c
c     y double precision(n1), vector of length n1 to which is added
c         the product m*x
c
c     n2 integer, number of elements in vector x, and number of columns
c         in matrix m
c
c     ldm integer, leading dimension of array m
c
c     x double precision(n2), vector of length n2
c
c     m double precision(ldm,n2), matrix of n1 rows and n2 columns
c
c ----------------------------------------------------------------------
c
c   cleanup odd vector
c
      j = mod(n2,2)
      if (j .ge. 1) then
         do 10 i = 1, n1
            y(i) = (y(i)) + x(j)*m(i,j)
   10    continue
      endif
c
c   cleanup odd group of two vectors
c
      j = mod(n2,4)
      if (j .ge. 2) then
         do 20 i = 1, n1
            y(i) = ( (y(i))
     $             + x(j-1)*m(i,j-1)) + x(j)*m(i,j)
   20    continue
      endif
c
c   cleanup odd group of four vectors
c
      j = mod(n2,8)
      if (j .ge. 4) then
         do 30 i = 1, n1
            y(i) = ((( (y(i))
     $             + x(j-3)*m(i,j-3)) + x(j-2)*m(i,j-2))
     $             + x(j-1)*m(i,j-1)) + x(j)  *m(i,j)
   30    continue
      endif
c
c   cleanup odd group of eight vectors
c
      j = mod(n2,16)
      if (j .ge. 8) then
         do 40 i = 1, n1
            y(i) = ((((((( (y(i))
     $             + x(j-7)*m(i,j-7)) + x(j-6)*m(i,j-6))
     $             + x(j-5)*m(i,j-5)) + x(j-4)*m(i,j-4))
     $             + x(j-3)*m(i,j-3)) + x(j-2)*m(i,j-2))
     $             + x(j-1)*m(i,j-1)) + x(j)  *m(i,j)
   40    continue
      endif
c
c   main loop - groups of sixteen vectors
c
      jmin = j+16
      do 60 j = jmin, n2, 16
         do 50 i = 1, n1
            y(i) = ((((((((((((((( (y(i))
     $             + x(j-15)*m(i,j-15)) + x(j-14)*m(i,j-14))
     $             + x(j-13)*m(i,j-13)) + x(j-12)*m(i,j-12))
     $             + x(j-11)*m(i,j-11)) + x(j-10)*m(i,j-10))
     $             + x(j- 9)*m(i,j- 9)) + x(j- 8)*m(i,j- 8))
     $             + x(j- 7)*m(i,j- 7)) + x(j- 6)*m(i,j- 6))
     $             + x(j- 5)*m(i,j- 5)) + x(j- 4)*m(i,j- 4))
     $             + x(j- 3)*m(i,j- 3)) + x(j- 2)*m(i,j- 2))
     $             + x(j- 1)*m(i,j- 1)) + x(j)   *m(i,j)
   50    continue
   60 continue
      return
      end


 SUBROUTINE expot8(rot,a)
 !***********************************************************************
 !
 !     calculates a rotation matrix from a rotation vector
 !
 !***********************************************************************
 IMPLICIT NONE
 REAL (kind=8) rot(3),a(9)
 REAL t1,t2,t3,modul,c1,c2,c3

 modul = SQRT(DOT_PRODUCT(rot,rot))

 IF(modul <= 0.1D-31) THEN

   a(1) = 1d0
   a(2) = 0d0
   a(3) = 0d0
   a(4) = 0d0
   a(5) = 1d0
   a(6) = 0d0
   a(7) = 0d0
   a(8) = 0d0
   a(9) = 1d0

 ELSE

   t1 = rot(1)/modul
   t2 = rot(2)/modul
   t3 = rot(3)/modul
   c1 = SIN(modul)
   c2 = 2D0*(SIN(modul/2D0))**2
   c3 = 1D0 - c2

   a(1) = c3         + c2 * t1*t1
   a(2) =      c1*t3 + c2 * t2*t1
   a(3) =    - c1*t2 + c2 * t3*t1
   a(4) =    - c1*t3 + c2 * t1*t2
   a(5) = c3         + c2 * t2*t2
   a(6) =      c1*t1 + c2 * t3*t2
   a(7) =      c1*t2 + c2 * t1*t3
   a(8) =    - c1*t1 + c2 * t2*t3
   a(9) = c3         + c2 * t3*t3

 END IF

 RETURN
 END SUBROUTINE expot8


module mod_layer

  ! Defines the layer type and its methods.

  use mod_activation
  use mod_kinds, only: ik, rk
  use mod_random, only: randn

  implicit none

  private
  public :: array1d, array2d, db_init, db_co_sum, dw_init, dw_co_sum, layer_type

  type :: layer_type
    real(rk), allocatable :: a(:) ! activations
    real(rk), allocatable :: b(:) ! biases
    real(rk), allocatable :: w(:,:) ! weights
    real(rk), allocatable :: z(:) ! arg. to activation function
    procedure(activation_function), pointer, nopass :: activation => null()
    procedure(activation_function), pointer, nopass :: activation_prime => null()
    character(len=:), allocatable :: activation_str ! activation character string
  contains
    procedure, public, pass(self) :: set_activation
  end type layer_type

  type :: array1d
    real(rk), allocatable :: array(:)
  end type array1d

  type :: array2d
    real(rk), allocatable :: array(:,:)
  end type array2d

  interface layer_type
    module procedure :: constructor
  end interface layer_type

  interface array1d
    module procedure :: array1d_constructor
  end interface array1d

  interface array2d
    module procedure :: array2d_constructor
  end interface array2d

contains

  type(layer_type) function constructor(this_size, next_size) result(layer)
    ! Layer class constructor. this_size is the number of neurons in the layer.
    ! next_size is the number of neurons in the next layer, used to allocate
    ! the weights.
    integer(ik), intent(in) :: this_size, next_size
    allocate(layer % a(this_size))
    allocate(layer % z(this_size))
    layer % a = 0
    layer % z = 0
    layer % w = randn(this_size, next_size) / this_size
    layer % b = randn(this_size)
  end function constructor

  pure type(array1d) function array1d_constructor(length) result(a)
    ! Overloads the default type constructor.
    integer(ik), intent(in) :: length
    allocate(a % array(length))
    a % array = 0
  end function array1d_constructor

  pure type(array2d) function array2d_constructor(dims) result(a)
    ! Overloads the default type constructor.
    integer(ik), intent(in) :: dims(2)
    allocate(a % array(dims(1), dims(2)))
    a % array = 0
  end function array2d_constructor

  pure subroutine db_init(db, dims)
    ! Initialises biases structure.
    type(array1d), allocatable, intent(in out) :: db(:)
    integer(ik), intent(in) :: dims(:)
    integer(ik) :: n, nm
    nm = size(dims)
    allocate(db(nm))
    do n = 1, nm - 1
      db(n) = array1d(dims(n))
    end do
    db(n) = array1d(dims(n))
  end subroutine db_init

  pure subroutine dw_init(dw, dims)
    ! Initialises weights structure.
    type(array2d), allocatable, intent(in out) :: dw(:)
    integer(ik), intent(in) :: dims(:)
    integer(ik) :: n, nm
    nm = size(dims)
    allocate(dw(nm))
    do n = 1, nm - 1
      dw(n) = array2d(dims(n:n+1))
    end do
    dw(n) = array2d([dims(n), 1])
  end subroutine dw_init

  subroutine db_co_sum(db)
    ! Performs a collective sum of bias tendencies.
    type(array1d), allocatable, intent(in out) :: db(:)
    integer(ik) :: n
    do n = 2, size(db)
#ifdef CAF
      call co_sum(db(n) % array)
#endif
    end do
  end subroutine db_co_sum

  subroutine dw_co_sum(dw)
    ! Performs a collective sum of weights tendencies.
    type(array2d), allocatable, intent(in out) :: dw(:)
    integer(ik) :: n
    do n = 1, size(dw) - 1
#ifdef CAF
      call co_sum(dw(n) % array)
#endif
    end do
  end subroutine dw_co_sum

  pure elemental subroutine set_activation(self, activation)
    ! Sets the activation function. Input string must match one of
    ! provided activation functions, otherwise it defaults to sigmoid.
    ! If activation not present, defaults to sigmoid.
    class(layer_type), intent(in out) :: self
    character(len=*), intent(in) :: activation
    select case(trim(activation))
      case('gaussian')
        self % activation => gaussian
        self % activation_prime => gaussian_prime
        self % activation_str = 'gaussian'
      case('relu')
        self % activation => relu
        self % activation_prime => relu_prime
        self % activation_str = 'relu'
      case('sigmoid')
        self % activation => sigmoid
        self % activation_prime => sigmoid_prime
        self % activation_str = 'sigmoid'
      case('step')
        self % activation => step
        self % activation_prime => step_prime
        self % activation_str = 'step'
      case('tanh')
        self % activation => tanhf
        self % activation_prime => tanh_prime
        self % activation_str = 'tanh'
      case default
        self % activation => sigmoid
        self % activation_prime => sigmoid_prime
        self % activation_str = 'sigmoid'
    end select
  end subroutine set_activation

end module mod_layer


module Op_m
  USE NumParameters_m
  USE Basis_m, only : Basis_t
  implicit none
  private

  TYPE :: Op_t

    TYPE (Basis_t),    pointer     :: Basis

    real (kind=Rk),    allocatable :: RMat(:,:)
  END TYPE Op_t

  public :: Op_t,write_Op,Set_Op,dealloc_Op,calc_OpPsi

contains
  SUBROUTINE alloc_Op(Op,nb)
    TYPE(Op_t),  intent(inout) :: Op
    integer,     intent(in)    :: nb

    CALL dealloc_Op(Op)

    IF (nb < 1) STOP 'ERROR in init_Op: nb < 1!'

    allocate(Op%RMat(nb,nb))

  END SUBROUTINE alloc_Op

  SUBROUTINE dealloc_Op(Op)
    TYPE(Op_t), intent(inout) :: Op

    nullify(Op%Basis)

    IF (allocated(Op%RMat)) THEN
      deallocate(Op%RMat)
    END IF

  END SUBROUTINE dealloc_Op

  SUBROUTINE write_Op(Op)
    USE UtilLib_m, only : Write_RMat

    TYPE(Op_t), intent(in) :: Op

    integer :: i

    IF (associated(Op%Basis)) THEN
      write(out_unitp,*) ' The basis is linked to Op.'
    END IF

    IF (allocated(Op%RMat)) THEN
      write(out_unitp,*) 'Writing Op (real):'
      write(out_unitp,*)
      CALL Write_RMat(Op%RMat,out_unitp,5,name_info='Op%Rmat')
      write(out_unitp,*) 'END Writing Op'
    END IF

  END SUBROUTINE write_Op

  SUBROUTINE Set_Op(Op,Basis)
  USE Basis_m
  USE Molec_m

    TYPE(Op_t),     intent(inout)       :: Op
    TYPE (Basis_t), intent(in),  target :: Basis

    integer :: ib,iq

    real (kind=Rk), allocatable :: V(:),OpPsi_g(:)

    IF (.NOT. Basis_IS_allocated(Basis)) THEN
      STOP 'ERROR in Set_Op: the Basis is not initialized'
    END IF

    CALL alloc_Op(Op,Basis%nb)

    Op%Basis => Basis

    ! calculation of a potential on the grid
    allocate(V(Basis%nq))
    DO iq=1,Basis%nq
      V(iq) = Calc_pot(Basis%x(iq))
    END DO

    ! calculation of Op|b_i>
    DO ib=1,Basis%nb
      OpPsi_g = V * Basis%d0gb(:,ib) ! potential part
      OpPsi_g = OpPsi_g -HALF/mass * Basis%d2gb(:,ib,1,1) ! -1/2mass d2./dx2 part
      ! OpPsi_g is a vector on the grid. It must be projected on the basis (integration)
      OpPsi_g = OpPsi_g * Basis%w
      Op%RMat(:,ib) = matmul(transpose(Basis%d0gb),OpPsi_g)
    END DO

    CALL write_Op(Op)

  END SUBROUTINE Set_Op

  SUBROUTINE calc_OpPsi(Op,Psi,OpPsi)
    USE psi_m, ONLY : psi_t

    TYPE(Op_t),  intent(in)     :: Op
    TYPE(psi_t), intent(in)     :: Psi
    TYPE(psi_t), intent(inout)  :: OpPsi

    IF (.NOT. allocated(Op%RMat)) THEN
      STOP 'ERROR in calc_OpPsi: Op is not initialized!'
    END IF

    IF (allocated(Psi%RVec)) THEN
      OpPsi%RVec = matmul(Op%RMat,Psi%RVec)
    ELSE IF (allocated(Psi%CVec)) THEN
      OpPsi%CVec = matmul(Op%RMat,Psi%CVec)
    ELSE
      STOP 'ERROR in calc_OpPsi: Psi is not initialized!'
    END IF

  END SUBROUTINE calc_OpPsi

   end module Op_m


!*==sgels.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief  SGELS solves overdetermined or underdetermined systems for GE matrices
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download SGELS + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE SGELS( TRANS, M, N, NRHS, A, LDA, B, LDB, WORK, LWORK,
!                         INFO )
!
!       .. Scalar Arguments ..
!       CHARACTER          TRANS
!       INTEGER            INFO, LDA, LDB, LWORK, M, N, NRHS
!       ..
!       .. Array Arguments ..
!       REAL               A( LDA, * ), B( LDB, * ), WORK( * )
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> SGELS solves overdetermined or underdetermined real linear systems
!> involving an M-by-N matrix A, or its transpose, using a QR or LQ
!> factorization of A.  It is assumed that A has full rank.
!>
!> The following options are provided:
!>
!> 1. If TRANS = 'N' and m >= n:  find the least squares solution of
!>    an overdetermined system, i.e., solve the least squares problem
!>                 minimize || B - A*X ||.
!>
!> 2. If TRANS = 'N' and m < n:  find the minimum norm solution of
!>    an underdetermined system A * X = B.
!>
!> 3. If TRANS = 'T' and m >= n:  find the minimum norm solution of
!>    an underdetermined system A**T * X = B.
!>
!> 4. If TRANS = 'T' and m < n:  find the least squares solution of
!>    an overdetermined system, i.e., solve the least squares problem
!>                 minimize || B - A**T * X ||.
!>
!> Several right hand side vectors b and solution vectors x can be
!> handled in a single call; they are stored as the columns of the
!> M-by-NRHS right hand side matrix B and the N-by-NRHS solution
!> matrix X.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] TRANS
!> \verbatim
!>          TRANS is CHARACTER*1
!>          = 'N': the linear system involves A;
!>          = 'T': the linear system involves A**T.
!> \endverbatim
!>
!> \param[in] M
!> \verbatim
!>          M is INTEGER
!>          The number of rows of the matrix A.  M >= 0.
!> \endverbatim
!>
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>          The number of columns of the matrix A.  N >= 0.
!> \endverbatim
!>
!> \param[in] NRHS
!> \verbatim
!>          NRHS is INTEGER
!>          The number of right hand sides, i.e., the number of
!>          columns of the matrices B and X. NRHS >=0.
!> \endverbatim
!>
!> \param[in,out] A
!> \verbatim
!>          A is REAL array, dimension (LDA,N)
!>          On entry, the M-by-N matrix A.
!>          On exit,
!>            if M >= N, A is overwritten by details of its QR
!>                       factorization as returned by SGEQRF;
!>            if M <  N, A is overwritten by details of its LQ
!>                       factorization as returned by SGELQF.
!> \endverbatim
!>
!> \param[in] LDA
!> \verbatim
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,M).
!> \endverbatim
!>
!> \param[in,out] B
!> \verbatim
!>          B is REAL array, dimension (LDB,NRHS)
!>          On entry, the matrix B of right hand side vectors, stored
!>          columnwise; B is M-by-NRHS if TRANS = 'N', or N-by-NRHS
!>          if TRANS = 'T'.
!>          On exit, if INFO = 0, B is overwritten by the solution
!>          vectors, stored columnwise:
!>          if TRANS = 'N' and m >= n, rows 1 to n of B contain the least
!>          squares solution vectors; the residual sum of squares for the
!>          solution in each column is given by the sum of squares of
!>          elements N+1 to M in that column;
!>          if TRANS = 'N' and m < n, rows 1 to N of B contain the
!>          minimum norm solution vectors;
!>          if TRANS = 'T' and m >= n, rows 1 to M of B contain the
!>          minimum norm solution vectors;
!>          if TRANS = 'T' and m < n, rows 1 to M of B contain the
!>          least squares solution vectors; the residual sum of squares
!>          for the solution in each column is given by the sum of
!>          squares of elements M+1 to N in that column.
!> \endverbatim
!>
!> \param[in] LDB
!> \verbatim
!>          LDB is INTEGER
!>          The leading dimension of the array B. LDB >= MAX(1,M,N).
!> \endverbatim
!>
!> \param[out] WORK
!> \verbatim
!>          WORK is REAL array, dimension (MAX(1,LWORK))
!>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!> \endverbatim
!>
!> \param[in] LWORK
!> \verbatim
!>          LWORK is INTEGER
!>          The dimension of the array WORK.
!>          LWORK >= max( 1, MN + max( MN, NRHS ) ).
!>          For optimal performance,
!>          LWORK >= max( 1, MN + max( MN, NRHS )*NB ).
!>          where MN = min(M,N) and NB is the optimum block size.
!>
!>          If LWORK = -1, then a workspace query is assumed; the routine
!>          only calculates the optimal size of the WORK array, returns
!>          this value as the first entry of the WORK array, and no error
!>          message related to LWORK is issued by XERBLA.
!> \endverbatim
!>
!> \param[out] INFO
!> \verbatim
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>          > 0:  if INFO =  i, the i-th diagonal element of the
!>                triangular factor of A is zero, so that A does not have
!>                full rank; the least squares solution could not be
!>                computed.
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date December 2016
!
!> \ingroup realGEsolve
!
!  =====================================================================
      SUBROUTINE SGELS(Trans,M,N,Nrhs,A,Lda,B,Ldb,Work,Lwork,Info)
      IMPLICIT NONE
!*--SGELS186
!
!  -- LAPACK driver routine (version 3.7.0) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     December 2016
!
!     .. Scalar Arguments ..
      CHARACTER Trans
      INTEGER Info , Lda , Ldb , Lwork , M , N , Nrhs
!     ..
!     .. Array Arguments ..
      REAL A(Lda,*) , B(Ldb,*) , Work(*)
!     ..
!
!  =====================================================================
!
!     .. Parameters ..
      REAL ZERO , ONE
      PARAMETER (ZERO=0.0E0,ONE=1.0E0)
!     ..
!     .. Local Scalars ..
      LOGICAL lquery , tpsd
      INTEGER brow , i , iascl , ibscl , j , mn , nb , scllen , wsize
      REAL anrm , bignum , bnrm , smlnum
!     ..
!     .. Local Arrays ..
      REAL rwork(1)
!     ..
!     .. External Functions ..
      LOGICAL LSAME
      INTEGER ILAENV
      REAL SLAMCH , SLANGE
      EXTERNAL LSAME , ILAENV , SLAMCH , SLANGE
!     ..
!     .. External Subroutines ..
      EXTERNAL SGELQF , SGEQRF , SLABAD , SLASCL , SLASET , SORMLQ ,    &
     &         SORMQR , STRTRS , XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC MAX , MIN , REAL
!     ..
!     .. Executable Statements ..
!
!     Test the input arguments.
!
      Info = 0
      mn = MIN(M,N)
      lquery = (Lwork==-1)
      IF ( .NOT.(LSAME(Trans,'N') .OR. LSAME(Trans,'T')) ) THEN
         Info = -1
      ELSEIF ( M<0 ) THEN
         Info = -2
      ELSEIF ( N<0 ) THEN
         Info = -3
      ELSEIF ( Nrhs<0 ) THEN
         Info = -4
      ELSEIF ( Lda<MAX(1,M) ) THEN
         Info = -6
      ELSEIF ( Ldb<MAX(1,M,N) ) THEN
         Info = -8
      ELSEIF ( Lwork<MAX(1,mn+MAX(mn,Nrhs)) .AND. .NOT.lquery ) THEN
         Info = -10
      ENDIF
!
!     Figure out optimal block size
!
      IF ( Info==0 .OR. Info==-10 ) THEN
!
         tpsd = .TRUE.
         IF ( LSAME(Trans,'N') ) tpsd = .FALSE.
!
         IF ( M>=N ) THEN
            nb = ILAENV(1,'SGEQRF',' ',M,N,-1,-1)
            IF ( tpsd ) THEN
               nb = MAX(nb,ILAENV(1,'SORMQR','LN',M,Nrhs,N,-1))
            ELSE
               nb = MAX(nb,ILAENV(1,'SORMQR','LT',M,Nrhs,N,-1))
            ENDIF
         ELSE
            nb = ILAENV(1,'SGELQF',' ',M,N,-1,-1)
            IF ( tpsd ) THEN
               nb = MAX(nb,ILAENV(1,'SORMLQ','LT',N,Nrhs,M,-1))
            ELSE
               nb = MAX(nb,ILAENV(1,'SORMLQ','LN',N,Nrhs,M,-1))
            ENDIF
         ENDIF
!
         wsize = MAX(1,mn+MAX(mn,Nrhs)*nb)
         Work(1) = REAL(wsize)
!
      ENDIF
!
      IF ( Info/=0 ) THEN
         CALL XERBLA('SGELS ',-Info)
         RETURN
      ELSEIF ( lquery ) THEN
         RETURN
      ENDIF
!
!     Quick return if possible
!
      IF ( MIN(M,N,Nrhs)==0 ) THEN
         CALL SLASET('Full',MAX(M,N),Nrhs,ZERO,ZERO,B,Ldb)
         RETURN
      ENDIF
!
!     Get machine parameters
!
      smlnum = SLAMCH('S')/SLAMCH('P')
      bignum = ONE/smlnum
      CALL SLABAD(smlnum,bignum)
!
!     Scale A, B if max element outside range [SMLNUM,BIGNUM]
!
      anrm = SLANGE('M',M,N,A,Lda,rwork)
      iascl = 0
      IF ( anrm>ZERO .AND. anrm<smlnum ) THEN
!
!        Scale matrix norm up to SMLNUM
!
         CALL SLASCL('G',0,0,anrm,smlnum,M,N,A,Lda,Info)
         iascl = 1
      ELSEIF ( anrm>bignum ) THEN
!
!        Scale matrix norm down to BIGNUM
!
         CALL SLASCL('G',0,0,anrm,bignum,M,N,A,Lda,Info)
         iascl = 2
      ELSEIF ( anrm==ZERO ) THEN
!
!        Matrix all zero. Return zero solution.
!
         CALL SLASET('F',MAX(M,N),Nrhs,ZERO,ZERO,B,Ldb)
         GOTO 100
      ENDIF
!
      brow = M
      IF ( tpsd ) brow = N
      bnrm = SLANGE('M',brow,Nrhs,B,Ldb,rwork)
      ibscl = 0
      IF ( bnrm>ZERO .AND. bnrm<smlnum ) THEN
!
!        Scale matrix norm up to SMLNUM
!
         CALL SLASCL('G',0,0,bnrm,smlnum,brow,Nrhs,B,Ldb,Info)
         ibscl = 1
      ELSEIF ( bnrm>bignum ) THEN
!
!        Scale matrix norm down to BIGNUM
!
         CALL SLASCL('G',0,0,bnrm,bignum,brow,Nrhs,B,Ldb,Info)
         ibscl = 2
      ENDIF
!
      IF ( M>=N ) THEN
!
!        compute QR factorization of A
!
         CALL SGEQRF(M,N,A,Lda,Work(1),Work(mn+1),Lwork-mn,Info)
!
!        workspace at least N, optimally N*NB
!
         IF ( .NOT.tpsd ) THEN
!
!           Least-Squares Problem min || A * X - B ||
!
!           B(1:M,1:NRHS) := Q**T * B(1:M,1:NRHS)
!
            CALL SORMQR('Left','Transpose',M,Nrhs,N,A,Lda,Work(1),B,Ldb,&
     &                  Work(mn+1),Lwork-mn,Info)
!
!           workspace at least NRHS, optimally NRHS*NB
!
!           B(1:N,1:NRHS) := inv(R) * B(1:N,1:NRHS)
!
            CALL STRTRS('Upper','No transpose','Non-unit',N,Nrhs,A,Lda, &
     &                  B,Ldb,Info)
!
            IF ( Info>0 ) RETURN
!
            scllen = N
!
         ELSE
!
!           Underdetermined system of equations A**T * X = B
!
!           B(1:N,1:NRHS) := inv(R**T) * B(1:N,1:NRHS)
!
            CALL STRTRS('Upper','Transpose','Non-unit',N,Nrhs,A,Lda,B,  &
     &                  Ldb,Info)
!
            IF ( Info>0 ) RETURN
!
!           B(N+1:M,1:NRHS) = ZERO
!
            DO j = 1 , Nrhs
               DO i = N + 1 , M
                  B(i,j) = ZERO
               ENDDO
            ENDDO
!
!           B(1:M,1:NRHS) := Q(1:N,:) * B(1:N,1:NRHS)
!
            CALL SORMQR('Left','No transpose',M,Nrhs,N,A,Lda,Work(1),B, &
     &                  Ldb,Work(mn+1),Lwork-mn,Info)
!
!           workspace at least NRHS, optimally NRHS*NB
!
            scllen = M
!
         ENDIF
!
      ELSE
!
!        Compute LQ factorization of A
!
         CALL SGELQF(M,N,A,Lda,Work(1),Work(mn+1),Lwork-mn,Info)
!
!        workspace at least M, optimally M*NB.
!
         IF ( .NOT.tpsd ) THEN
!
!           underdetermined system of equations A * X = B
!
!           B(1:M,1:NRHS) := inv(L) * B(1:M,1:NRHS)
!
            CALL STRTRS('Lower','No transpose','Non-unit',M,Nrhs,A,Lda, &
     &                  B,Ldb,Info)
!
            IF ( Info>0 ) RETURN
!
!           B(M+1:N,1:NRHS) = 0
!
            DO j = 1 , Nrhs
               DO i = M + 1 , N
                  B(i,j) = ZERO
               ENDDO
            ENDDO
!
!           B(1:N,1:NRHS) := Q(1:N,:)**T * B(1:M,1:NRHS)
!
            CALL SORMLQ('Left','Transpose',N,Nrhs,M,A,Lda,Work(1),B,Ldb,&
     &                  Work(mn+1),Lwork-mn,Info)
!
!           workspace at least NRHS, optimally NRHS*NB
!
            scllen = N
!
         ELSE
!
!           overdetermined system min || A**T * X - B ||
!
!           B(1:N,1:NRHS) := Q * B(1:N,1:NRHS)
!
            CALL SORMLQ('Left','No transpose',N,Nrhs,M,A,Lda,Work(1),B, &
     &                  Ldb,Work(mn+1),Lwork-mn,Info)
!
!           workspace at least NRHS, optimally NRHS*NB
!
!           B(1:M,1:NRHS) := inv(L**T) * B(1:M,1:NRHS)
!
            CALL STRTRS('Lower','Transpose','Non-unit',M,Nrhs,A,Lda,B,  &
     &                  Ldb,Info)
!
            IF ( Info>0 ) RETURN
!
            scllen = M
!
         ENDIF
!
      ENDIF
!
!     Undo scaling
!
      IF ( iascl==1 ) THEN
         CALL SLASCL('G',0,0,anrm,smlnum,scllen,Nrhs,B,Ldb,Info)
      ELSEIF ( iascl==2 ) THEN
         CALL SLASCL('G',0,0,anrm,bignum,scllen,Nrhs,B,Ldb,Info)
      ENDIF
      IF ( ibscl==1 ) THEN
         CALL SLASCL('G',0,0,smlnum,bnrm,scllen,Nrhs,B,Ldb,Info)
      ELSEIF ( ibscl==2 ) THEN
         CALL SLASCL('G',0,0,bignum,bnrm,scllen,Nrhs,B,Ldb,Info)
      ENDIF
!
 100  Work(1) = REAL(wsize)
!
!
!     End of SGELS
!
      END SUBROUTINE SGELS


C    Copyright(C) 1999-2020 National Technology & Engineering Solutions
C    of Sandia, LLC (NTESS).  Under the terms of Contract DE-NA0003525 with
C    NTESS, the U.S. Government retains certain rights in this software.
C
C    See packages/seacas/LICENSE for details

      SUBROUTINE QUAD(XXX, XI, XG, NDIM, NNODES, NQUAD, WT)
      DIMENSION XXX(NDIM+1,NNODES,NQUAD), XI(NDIM,*), XG(NDIM,*)

      IF (NQUAD .EQ. 1) THEN
          QUADL = 0.0
      ELSE
          QUADL = 1./SQRT(3.)
      END IF

      WT = 2.**NDIM / DBLE(NQUAD)
      IF (NQUAD .EQ. 1) THEN
          XG(1,1) = 0.0
          XG(2,1) = 0.0
          XG(3,1) = 0.0
      ELSE
          DO 20 I=1, NNODES
              DO 10 J=1, NDIM
                  XG(J,I) = XI(J,I) * QUADL
   10         CONTINUE
   20     CONTINUE
      END IF

      IF (NDIM .EQ. 3) THEN
          DO 40 I=1, NQUAD
              DO 30 J=1, NNODES
                  TMP1 = (1. + XI(1,J) * XG(1,I))
                  TMP2 = (1. + XI(2,J) * XG(2,I))
                  TMP3 = (1. + XI(3,J) * XG(3,I))

                  XXX(1,J,I) = TMP1    * TMP2 * TMP3 / 8.0
                  XXX(2,J,I) = XI(1,J) * TMP2 * TMP3 / 8.0
                  XXX(3,J,I) = XI(2,J) * TMP1 * TMP3 / 8.0
                  XXX(4,J,I) = XI(3,J) * TMP1 * TMP2 / 8.0
   30         CONTINUE
   40     CONTINUE
      ELSE
          DO 60 I=1, NQUAD
              DO 50 J=1, NNODES
                  TMP1 = (1. + XI(1,J) * XG(1,I))
                  TMP2 = (1. + XI(2,J) * XG(2,I))

                  XXX(1,J,I) = TMP1    * TMP2 / 4.0
                  XXX(2,J,I) = XI(1,J) * TMP2 / 4.0
                  XXX(3,J,I) = XI(2,J) * TMP1 / 4.0
   50         CONTINUE
   60     CONTINUE
      END IF
      RETURN
      END