SUBROUTINE clawpack5_setaux(mbc,mx,my, &
     xlower,ylower,dx,dy,maux,aux)
  IMPLICIT NONE

  INTEGER mbc,mx,my,maux
  DOUBLE PRECISION xlower,ylower,dx,dy
  DOUBLE PRECISION aux(maux,1-mbc:mx+mbc,1-mbc:my+mbc)

  INTEGER i,j
  DOUBLE PRECISION yj

  DO i = 1-mbc,mx+mbc
     DO j = 1-mbc,my+mbc
        yj = ylower + (j-0.5d0)*dy
        aux(1,i,j) = yj
     ENDDO
  ENDDO

  RETURN
END SUBROUTINE clawpack5_setaux


        subroutine idz_frm(m,n,w,x,y)
c
c       transforms x into y via a composition
c       of Rokhlin's random transform, random subselection, and an FFT.
c       In contrast to routine idz_sfrm, the present routine works best
c       when the length of the transformed vector is the integer n
c       output by routine idz_frmi, or when the length
c       is not specified, but instead determined a posteriori
c       using the output of the present routine. The transformed vector
c       output by the present routine is randomly permuted.
c
c       input:
c       m -- length of x
c       n -- greatest integer expressible as a positive integer power
c            of 2 that is less than or equal to m, as obtained
c            from the routine idz_frmi; n is the length of y
c       w -- initialization array constructed by routine idz_frmi
c       x -- vector to be transformed
c
c       output:
c       y -- transform of x
c
c       reference:
c       Halko, Martinsson, Tropp, "Finding structure with randomness:
c            probabilistic algorithms for constructing approximate
c            matrix decompositions," SIAM Review, 53 (2): 217-288,
c            2011.
c
        implicit none
        integer m,iw,n,k
        complex*16 w(17*m+70),x(m),y(n)
c
c
c       Apply Rokhlin's random transformation to x, obtaining
c       w(16*m+71 : 17*m+70).
c
        iw = w(3+m+n)
        call idz_random_transf(x,w(16*m+70+1),w(iw))
c
c
c       Subselect from  w(16*m+71 : 17*m+70)  to obtain y.
c
        call idz_subselect(n,w(3),m,w(16*m+70+1),y)
c
c
c       Copy y into  w(16*m+71 : 16*m+n+70).
c
        do k = 1,n
          w(16*m+70+k) = y(k)
        enddo ! k
c
c
c       Fourier transform  w(16*m+71 : 16*m+n+70).
c
        call zfftf(n,w(16*m+70+1),w(4+m+n))
c
c
c       Permute  w(16*m+71 : 16*m+n+70)  to obtain y.
c
        call idz_permute(n,w(3+m),w(16*m+70+1),y)
c
c
        return
        end
c
c
c
c
        subroutine idz_sfrm(l,m,n,w,x,y)
c
c       transforms x into y via a composition
c       of Rokhlin's random transform, random subselection, and an FFT.
c       In contrast to routine idz_frm, the present routine works best
c       when the length l of the transformed vector is known a priori.
c
c       input:
c       l -- length of y; l must be less than or equal to n
c       m -- length of x
c       n -- greatest integer expressible as a positive integer power
c            of 2 that is less than or equal to m, as obtained
c            from the routine idz_frmi
c       w -- initialization array constructed by routine idz_sfrmi
c       x -- vector to be transformed
c
c       output:
c       y -- transform of x
c
c       _N.B._: l must be less than or equal to n.
c
c       reference:
c       Halko, Martinsson, Tropp, "Finding structure with randomness:
c            probabilistic algorithms for constructing approximate
c            matrix decompositions," SIAM Review, 53 (2): 217-288,
c            2011.
c
        implicit none
        integer m,iw,n,l
        complex*16 w(21*m+70),x(m),y(l)
c
c
c       Apply Rokhlin's random transformation to x, obtaining
c       w(19*m+71 : 20*m+70).
c
        iw = w(4+m+l)
        call idz_random_transf(x,w(19*m+70+1),w(iw))
c
c
c       Subselect from  w(19*m+71 : 20*m+70)  to obtain
c       w(20*m+71 : 20*m+n+70).
c
        call idz_subselect(n,w(4),m,w(19*m+70+1),w(20*m+70+1))
c
c
c       Fourier transform  w(20*m+71 : 20*m+n+70).
c
        call idz_sfft(l,w(4+m),n,w(5+m+l),w(20*m+70+1))
c
c
c       Copy the desired entries from  w(20*m+71 : 20*m+n+70)
c       to y.
c
        call idz_subselect(l,w(4+m),n,w(20*m+70+1),y)
c
c
        return
        end
c
c
c
c


program main
  implicit none

  !===> setting of speedy
  integer, parameter :: nbv    = 40
  integer, parameter :: ncase  = 1     ! the product (1000)
!  integer, parameter :: ntime  = 10000 ! the product (10000)
  integer, parameter :: ntime  = 200 ! the product (10000)

  integer :: init(nbv,nbv)
  real(8) :: rand(nbv), pfwgh(nbv), acc(nbv)
  real(8) :: pmat_answ(nbv,nbv), pmat_time(nbv,nbv,ntime), pmat_kkkk(nbv,nbv,ntime), tmp8(nbv,nbv)
  real(8) ::                                               pvec_kkkk(nbv,    ntime)
  real(8) :: aerr(ncase,ntime) , perr(ncase,ntime)

  !===> global variables
  integer :: i, j, k, l, itime, icase
  real(8) :: p_ave, p_std, m_ave, m_std, timer, peff
  character(255) :: fname

  integer t0, t1, t_rate, t_max, diff
!-----------------------------------------------------------------------
  aerr(:,:) = 0.0d0

  call system_clock(t0)
  DO ICASE=1,NCASE
    call random_number(rand)
    pfwgh(:) = rand(:) / sum( rand(:) )
    peff     = 0.0d0
    do j=1,nbv
      tmp8(:,j) = pfwgh(:)
      peff      = peff + pfwgh(j)**2.0d0
    end do
    peff = 1.0d0 / peff

    !===> gen weight
    acc(:)   = 0.0d0
    acc(1)   = pfwgh(1)
    DO j=2,nbv  ;  acc(j) = acc(j-1) + pfwgh(j)  ;  END DO

    pmat_time(:,:,:) = 0.0d0
    pmat_kkkk(:,:,:) = 0.0d0
    DO itime=1,ntime ! MONTE-Carlo Resampling M times
      if( mod(itime,ntime)==0 ) then
        call system_clock(t1, t_rate, t_max)
        timer = dble(t1-t0) / dble(t_rate)
        print '(i6.6,a,i6.6,a,f15.2)', icase," / ", ncase,   "  timer since start (s) :: ", timer
      end if
      CALL get_resampling_mtx(nbv,acc,pmat_time(1:nbv,1:nbv,itime))

      !SLOW!DO j=1,nbv ; DO i=1,nbv
      !SLOW!  pmat_kkkk(i,j,itime) = sum( pmat_time(i,j,1:itime) ) / dble( itime )
      !SLOW!END DO     ; END DO

      IF( itime==1 )THEN
        pmat_kkkk(1:nbv,1:nbv,itime) = pmat_time(1:nbv,1:nbv,itime)
      ELSE
        pmat_kkkk(1:nbv,1:nbv,itime) = ( pmat_kkkk(1:nbv,1:nbv,itime-1)*(dble(itime)-1.0d0) + pmat_time(1:nbv,1:nbv,itime) ) / dble( itime )
      END IF
      DO i=1,nbv
        pvec_kkkk(i,itime)           = sum( pmat_kkkk(i,1:nbv,itime) ) / dble( nbv )
      END DO
      !!DO i=1,nbv
      !!  print '(40i1)', int( pmat_time(i,1:nbv,itime) )
      !!END DO
    END DO

    DO j=1,nbv ; DO i=1,nbv
      pmat_answ(i,j) = sum( pmat_time(i,j,1:ntime) ) / dble( ntime )
    END DO     ; END DO

    DO itime=1,ntime
      aerr(icase,itime) = sum(  abs(pmat_answ(:,:)-pmat_kkkk(:,:,itime)) )
      perr(icase,itime) = sum(  abs(pfwgh(:)      -pvec_kkkk(:  ,itime)) )
    END DO

    IF( icase==1 )THEN
      write(fname,'(a,i6.6,a,i8.8,a,i8.8,a)')"./out_900/sampled-error_M",nbv,"NTIME",ntime,"NCASE",ncase,".bin"
      open(1,file=trim(fname),form="unformatted",access="direct",recl=nbv*nbv*4,action="write")
        write(1,rec=1) (( sngl( tmp8(i,j)            ),j=1,nbv),i=1,nbv)
        write(1,rec=2) (( sngl( pmat_time(i,j,1)     ),j=1,nbv),i=1,nbv)
        write(1,rec=3) (( sngl( pmat_time(i,j,2)     ),j=1,nbv),i=1,nbv)
        write(1,rec=4) (( sngl( pmat_kkkk(i,j,200)   ),j=1,nbv),i=1,nbv)
        write(1,rec=5) (( sngl( pmat_kkkk(i,j,ntime) ),j=1,nbv),i=1,nbv)
      close(1)
    ENDIF
  END DO

    print '(a)', "========================ave time ============================="
    do i=1,nbv
      print '(I3,a,3f8.3,a,3f8.3)', i, &
        "   || one-su, mlt-su, ans :: ",sum(pmat_time(i,:,1)), sum(pmat_kkkk(i,:,200)), sum(pmat_kkkk(i,:,ntime)), &
        "   || wgh, acc, peff :: ",pfwgh(i)*dble(nbv), acc(i), peff
    end do

  !==> statistics
  write(fname,'(a,i6.6,a,i8.8,a,i8.8,a)')"./out_900/sampled-error_M",nbv,"NTIME",ntime,"NCASE",ncase,".txt"
  open(1,file=trim(fname),form="formatted",action="write")
  DO itime=1,ntime
    p_ave = sum( perr(1:ncase,itime) ) / dble( NCASE )
    p_std = dsqrt( sum( (perr(1:ncase,itime)-p_ave)**2.0d0 ) / dble( NCASE ) )
    m_ave = sum( aerr(1:ncase,itime) ) / dble( NCASE )
    m_std = dsqrt( sum( (aerr(1:ncase,itime)-m_ave)**2.0d0 ) / dble( NCASE ) )

    write(1,'(2i,6f15.8,4x,6f15.8)') ncase, itime,                                                          &
      p_ave, p_std, p_ave-p_std, p_ave+p_std, minval( perr(1:ncase,itime) ), maxval( perr(1:ncase,itime) ), &
      m_ave, m_std, m_ave-m_std, m_ave+m_std, minval( aerr(1:ncase,itime) ), maxval( aerr(1:ncase,itime) )
    !!write(6,'(2i,4f15.8)') ncase, itime, ave, std, ave-std, ave+std
  END DO
  close(1)

  print '(a)', "program end from prg_demo-kktrns.f90"
  stop
end

!-----------------------------------------------------------------------
SUBROUTINE get_resampling_mtx(nbv,acc,pmat)
!-----------------------------------------------------------------------
IMPLICIT NONE
  INTEGER, INTENT(in)  :: nbv
  REAL(8), INTENT(in)  :: acc(nbv)
  REAL(8), INTENT(out) :: pmat(nbv,nbv)

  INTEGER :: i, j, k, init(nbv), inum(nbv)
  REAL(8) :: rand(nbv)

  DO j=1,nbv ; init(j) = j  ; END DO
  CALL random_number(rand) ! [0-1]
  CALL quick_sort_asnd(rand,init,1,nbv)

  !==> generate resampling mxm matrix
  inum(:)   = 0
  !(1) :: gen selected paarticle
  DO j=1,nbv ! jth column
    DO i=1,nbv-1
      IF( rand(j)<=acc(i) )THEN
        inum(j) = i
        GOTO 10
      ENDIF
    END DO
    inum(j) = nbv
10  CONTINUE
  END DO
  !!print *, inum(:)

  pmat(:,:) = 0.0d0
  DO i=1,nbv ! (1) diagonal component
    k = inum(i)
    IF( k/=0 .and. pmat(k,k)<0.5d0 )THEN
      pmat(k,k) = 1.0d0
      inum(i)   = 0
    END IF
  END DO

  DO i=1,nbv ! (2) off-diagonal component
    k = inum(i)
    IF( k/=0 )THEN
      DO j=1,nbv
        IF( sum(pmat(:,j))<0.5 )THEN
          pmat(k,j) = 1.0d0
          GOTO 20
        END IF
      END DO
    END IF
20  CONTINUE
  END DO

!ORG!  pmat(:,:) = 0.0d0
!ORG!  DO j=1,nbv ! jth column
!ORG!    DO i=1,nbv-1
!ORG!      IF( rand(j)<=acc(i) )THEN
!ORG!        pmat(i,j) = 1.0d0
!ORG!        GOTO 10
!ORG!      END IF
!ORG!    END DO
!ORG!    pmat(nbv,j) = 1.0d0
!ORG!10  CONTINUE
!ORG!  END DO
END SUBROUTINE get_resampling_mtx

!=========================================================
recursive subroutine quick_sort_asnd(var,init,first,last)
!=========================================================
implicit none
  integer :: first, last, i, j, it
  integer :: init(*)
  real(8) :: var(*) , x,t

  x = var( (first+last) / 2 )
  i = first  ;  j = last
  do
    do while (var(i) < x)  ;  i=i+1  ;  end do
    do while (x < var(j))  ;  j=j-1  ;  end do
    if (i >= j) exit
      t       = var(i)  ;  var(i)  = var(j)  ;  var(j)  = t
      it      = init(i) ;  init(i) = init(j) ;  init(j) = it
      i       = i + 1   ;  j       = j - 1
  end do
  if (first < i - 1 ) call quick_sort_asnd(var,init, first, i - 1)
  if (j + 1 < last  ) call quick_sort_asnd(var,init, j + 1, last )

  return
end subroutine quick_sort_asnd


       subroutine diman(x0,y0,r,a,b)
C **      for  h-10/mt           es-1022
C...      to draw an angle and dimension circular arc.
C      x0,y0     x,y  coordinates of the center ofangle.
C      r         radius of the dimension circular arc.
C      a         angle(degree) the angle shall be drawn down to one pl.
C                of decimal
C      b         angle between the line connecting the center with the
C                st. point of the angle forms with the positive dir.
      common /gftab/irdb(5),rdb(17)
       alph=a
       teta=3.14159265/180.0
       f=rdb(17)/rdb(1)
       ff=0.3*f
       pxs=x0+r*cos(b*teta)
       pys=y0+r*sin(b*teta)
       pxf=x0+r*cos((b+a)*teta)
       pyf=y0+r*sin((b+a)*teta)
       x1=pxs+ff*cos((b+75.)*teta)
       y1=pys+ff*sin((b+75.)*teta)
       x2=pxs+ff*cos((b+105.)*teta)
       y2=pys+ff*sin((b+105.)*teta)
      call move(pxs,pys,0)
      call move(x1,y1,1)
      call move(pxs,pys,0)
      call move(x2,y2,1)
      call move(pxs,pys,0)
      call arcia(r,b,a+b)
      x1=pxf+ff*cos((a+b-75.)*teta)
      y1=pyf+ff*sin((a+b-75.)*teta)
      x2=pxf+ff*cos((a+b-105.)*teta)
      y2=pyf+ff*sin((a+b-105.)*teta)
       call move(pxf,pyf,0)
       call move(x1,y1,1)
       call move(pxf,pyf,0)
       call move(x2,y2,1)
       pxc=x0+(r+ff)*cos((a/2.0+b)*teta)
       pyc=y0+(r+ff)*sin((a/2.0+b)*teta)
       call number(pxc,pyc,0.3*f,alph,1,b+a/2.)
       return
       end


Real Function fourpi(srt)
  Real xarray(10), earray(10)
  Save
  Data xarray/0.0001, 1.986597, 6.411932, 7.636956, 9.598362, 9.889740, 10.24317, 10.80138, 11.86988, 12.83925/
  Data earray/2.468, 2.718, 2.968, 0.322E+01, 0.347E+01, 0.372E+01, 0.397E+01, 0.422E+01, 0.447E+01, 0.472E+01/
  pmass = 0.14
  pmass1 = 0.938
  fourpi = 0.000001
  If (srt<=1.52) Return
  plab = srt
  If (plab<earray(1)) Then
    fourpi = 0.00001
    Return
  End If
  Do ie = 1, 10
    If (earray(ie)==plab) Then
      fourpi = xarray(ie)
      Return
    Else If (earray(ie)>plab) Then
      ymin = alog(xarray(ie-1))
      ymax = alog(xarray(ie))
      xmin = alog(earray(ie-1))
      xmax = alog(earray(ie))
      fourpi = exp(ymin+(alog(plab)-xmin)*(ymax-ymin)/(xmax-xmin))
      Return
    End If
  End Do
  Return
End Function fourpi


*     MC01ND EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2020 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          DPMAX
      PARAMETER        ( DPMAX = 20 )
*     .. Local Scalars ..
      DOUBLE PRECISION VI, VR, XI, XR
      INTEGER          DP, I, INFO
*     .. Local Arrays ..
      DOUBLE PRECISION P(DPMAX+1)
*     .. External Subroutines ..
      EXTERNAL         MC01ND
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) DP, XR, XI
      IF ( DP.LE.-1 .OR. DP.GT.DPMAX ) THEN
         WRITE ( NOUT, FMT = 99995 ) DP
      ELSE
         READ ( NIN, FMT = * ) ( P(I), I = 1,DP+1 )
*        Evaluate the polynomial at the given (complex) point.
         CALL MC01ND( DP, XR, XI, P, VR, VI, INFO )
*
         IF ( INFO.NE.0 ) THEN
            WRITE ( NOUT, FMT = 99998 ) INFO
         ELSE
            WRITE ( NOUT, FMT = 99997 ) XR, XI, VR
            WRITE ( NOUT, FMT = 99996 ) XR, XI, VI
         END IF
      END IF
*
      STOP
*
99999 FORMAT (' MC01ND EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from MC01ND = ',I2)
99997 FORMAT (' Real      part of P(',F6.2,SP,F6.2,'*j ) = ',SS,F8.4)
99996 FORMAT (/' Imaginary part of P(',F6.2,SP,F6.2,'*j ) = ',SS,F8.4)
99995 FORMAT (/' DP is out of range.',/' DP = ',I5)
      END


Module control_file
  use num_types
  use omp_lib
  use vector_matrix_utilities, only: matrix_inverse, determinant
  implicit none
CONTAINS

  !!Read the POSCAR for the lattice and atomic
  !!basis.
  !!<parameter name="lattice" regular="true">The real space
  !!lattice.</parameter>
  !!<parameter name="atom_base">The atomic basis
  !!vectors.</parameter>
  !!<parameter name="atom_type" regular="true">The type of each atom
  !!in the basis.</parameter>
  !!<parameter name="lat_param" regular="true">The lattice
  !!parameter.</parameter>
  SUBROUTINE read_POSCAR(lattice, atom_base, atom_type, lat_param)
    integer, allocatable, intent(out) :: atom_type(:)
    real(dp), allocatable :: atom_base(:,:)
    real(dp), intent(out) :: lattice(3,3), lat_param

    character(300) :: line
    integer :: count, j, i, z
    integer, allocatable :: concs(:)
    real(dp) :: lat_inv(3,3)

    open(1,file="POSCAR",status="old")

    read(1,'(a300)') line
    read(1, *) lat_param
    do i=1,3
       read(1,*) lattice(:,i)
    end do
    read(1,'(a300)') line
    call parse_line_for_numbers(line, count, concs)
    if (count==0) then
       read(1, '(a300)') line
       call parse_line_for_numbers(line, count, concs)
    end if
    allocate(atom_type(sum(concs)), atom_base(3, sum(concs)))
    read(1,'(a300)') line
    do i=1,sum(concs)
       read(1,*) atom_base(:,i)
    end do
    close(1)

    line = adjustl(trim(line))
    if (('c'==line(:1)) .or. ('C'==line(:1)) &
         .or. ('k'==line(:1)) .or. ('K'==line(:1))) then
       call matrix_inverse(lat_param*lattice, lat_inv)
       do i=1, sum(concs)
          atom_base(:,i) = matmul(lat_inv, atom_base(:,i))
       end do
    end if

    z = 1
    do i=1,count
       if (concs(i) > 0) then
          do j=1,concs(i)
             atom_type(z) = i-1
             z = z+1
          end do
       end if
    end do
  end SUBROUTINE read_POSCAR

  !!Reads the inputs from the 'KPGEN' control file and the
  !!POSCAR, all parameters are output.
  !!<parameter name="nkpts" regular="true">The number of k-points to
  !!search for.</parameter>
  !!<parameter name="lattice" regular="true">The real space lattice
  !!vectors.</parameter>
  !!<parameter name="atom_base">The atomic basis
  !!vectors.</parameter>
  !!<parameter name="atom_type" regular="true">The type of each atom
  !!in the basis.</parameter>
  !!<parameter name="offset" regular="true">The offset to use on the
  !!k-points.</parameter>
  !!<parameter name="find_offset" regular="true">'True' if the use
  !!didn't provide an offset.</parameter>
  !!<parameter name="eps" regular="true">The floating point
  !!tollerance for relative comparison.</parameter>
  !!<parameter name="symm_flag" regular="true">Flag that indicates the
  !!symmetries to use.</parameter>
  !!<parameter name="min_kpts_flag" regular="true">Flag that indicates
  !!that the grid with the minimum number of k-points should be
  !!selected rather than the grid with the best folding
  !!ratio.</parameter>
  SUBROUTINE get_inputs(nkpts, lattice, atom_type, atom_base, offset, &
       find_offset, symm_flag, min_kpts_flag, eps)
    real(dp), intent(out) :: lattice(3,3), offset(3)
    real(dp), allocatable :: atom_base(:,:)
    integer, allocatable, intent(out) :: atom_type(:)
    integer, intent(out) :: nkpts, symm_flag
    logical, intent(out) :: find_offset, min_kpts_flag
    real(dp), intent(out) :: eps

    ! Input related variables
    character(len=100) :: buffer, label
    integer, parameter :: fh = 15
    integer :: ios, line_count, pos

    ! Control file variables
    real(dp) :: pi, lkpd, kpd, r_vecs(3,3), r_vol, lat_param, vol, rmin
    integer :: kppra
    logical :: def_eps, nkpts_set, def_aeps

    ios = 0
    line_count = 0
    pi = 3.1415926535897932385_dp
    find_offset = .True.
    def_eps = .True.
    def_aeps = .True.
    nkpts_set = .False.
    open(fh, file='KPGEN')

    call read_POSCAR(lattice, atom_base, atom_type, lat_param)
    vol = abs(determinant(lat_param*lattice))

    call matrix_inverse(transpose(lat_param*lattice),r_vecs)
    r_vecs = 2*pi*r_vecs
    r_vol = abs(determinant(r_vecs))
    ! ios is negative if an end of record condition is encountered or if
    ! an endfile condition was detected.  It is positive if an error was
    ! detected.  ios is zero otherwise.

    symm_flag = 0
    min_kpts_flag = .false.
    do while (ios == 0)
       read(fh, '(A)', iostat=ios) buffer
       if (ios == 0) then
          line_count = line_count + 1

          ! Find the first instance of whitespace.  Split label and data.
          pos = scan(buffer, '=')
          label = buffer(1:pos-1)
          buffer = buffer(pos+1:)
          select case (label)
          case ('SHIFT')
             read(buffer, *, iostat=ios) offset
             find_offset = .False.
          case ('NKPTS')
             read(buffer, *, iostat=ios) nkpts
             nkpts_set = .True.
          case ('KPDENSITY')
             read(buffer, *, iostat=ios) kpd
             nkpts = NINT(kpd*r_vol)
             nkpts_set = .True.
          case ('KSPACING')
             read(buffer, *, iostat=ios) lkpd
             nkpts = NINT(((1.0_dp/(2*pi*lkpd))**3)*r_vol)
             nkpts_set = .True.
          case ('KPPRA')
             read(buffer, *, iostat=ios) kppra
             nkpts = size(atom_base,2)*kppra
             nkpts_set = .True.
          case ('RMIN')
             read(buffer, *, iostat=ios) rmin
             nkpts = NINT((rmin**3)/(vol*2**(0.5_dp)))
             nkpts_set = .true.
          case ('USE_SYMMETRY')
             if ("NONE" == adjustl(trim(buffer))) then
                symm_flag = 3
             else if ("TIME_REVERSAL" == adjustl(trim(buffer))) then
                symm_flag = 2
             else if ("STRUCTURAL" == adjustl(trim(buffer))) then
                symm_flag = 1
             else if ("ALL" == adjustl(trim(buffer))) then
                symm_flag = 0
             end if
          case ('MIN_IRR_KPTS')
             if ("TRUE" == adjustl(trim(buffer))) then
                min_kpts_flag = .true.
             end if
          case ('EPS')
             read(buffer, *, iostat=ios) eps
             def_eps = .False.
          case default
             print *, 'Skipping invalid label at line', line_count, label
          end select
       end if
    end do

    if (def_eps .eqv. .True.) then
       eps = 1E-3
    end if

    if (nkpts_set .eqv. .False.) stop "Number of kpoints not set. Exiting."

  end SUBROUTINE get_inputs

  !!Splits a string on empty spaces.
  !!<parameter name="instr" regular="true">The input
  !!string.</parameter>
  !!<parameter name="out1" regular="true">The first item in the
  !!string.</parameter>
  subroutine split_str(instr,out1)
    character(300), intent(inout) :: instr
    character(300), intent(out) :: out1
    integer :: index

    instr = adjustl(TRIM(instr))

    index = SCAN(instr," ")
    out1 = adjustl(TRIM(instr(1:index-1)))
    instr = adjustl(TRIM(instr(index+1:)))
  end subroutine split_str

  !!Searches a string for numbers.
  !!<parameter name="line" regular="true">The line to
  !!search.</parameter>
  !!<parameter name="readEntries" regular="true">The number of entries
  !!read in.</parameter>
  !!<parameter name="values" regular="true">The output values
  !!found.</parameter>
  subroutine parse_line_for_numbers(line,readEntries,values)
    character(300), intent(inout):: line
    integer, intent(out)          :: readEntries
    integer, allocatable, intent(out) :: values(:)

    character(300) :: temp
    integer iE, ierr
    logical :: done

    done = .False.
    if (allocated(values)) deallocate(values)
    allocate(values(len(line)))
    values = 0

    readEntries=0
    iE = 0

    line = trim(adjustl(line)) ! Remove preceding blanks
    if (trim(line)=="") then ! make sure we didn't get a blank line
       readEntries = 0
       return
    endif

    do while (.not. done)
       iE = iE+1
       call split_str(line,temp)
       if (temp=="") then
          done = .True.
          exit
       end if
       read(temp,*,iostat=ierr) values(iE)
       if (ierr /=0) then
          readEntries=iE-1
          return
          !stop "ERROR: line parsing for number failed. Maybe format mismatch?"
       endif
       if (line=="") then
          done = .True.
       end if
    enddo

    readEntries=iE
  end subroutine parse_line_for_numbers

end Module control_file


      PROGRAM mperdeg
c    Given a latitude, print the meters per deg of
c  latitude and longitue.
c
      REAL alat, amlat, amlong

      PRINT *,' Enter a latitude:'
      READ *,alat
      CALL lendeg( alat, amlat, amlong)
      PRINT *,' There are ',amlat,' meters per degree latitude.'
      PRINT *,' There are ',amlong,' meters per degree longitude.'
      STOP
      END


      SUBROUTINE CHKCONT(X,C,d)

      IMPLICIT REAL*8(A-H,O-Z)
      DIMENSION X(6),C(6,15),d(15)

      DO i=1,15
         SUM=0.0D0
         DO j=1,6
            SUM=SUM+C(j,i)*X(j)
         ENDDO
         IF(SUM-d(i).GT.(1.0D-3*DABS(SUM))) THEN
C             WRITE(*,*)DABS(SUM-d(i)),(1.0D-3*DABS(SUM))
             WRITE(*,100)i,SUM,d(i)
         ENDIF
      ENDDO

      RETURN
 100  FORMAT(' Contrainte #',I2,' violee !',2D15.4)
      END


       subroutine allencahn_init(meqn,mbc,mx,my,
     &                   xlower,ylower,dx,dy,q)
       implicit none

       integer meqn,mbc,mx,my
       double precision xlower, ylower,dx,dy

       double precision q(1-mbc:mx+mbc, 1-mbc:my+mbc, meqn)
       double precision xc,yc,xp,yp,zp,rp

       integer i,j,m
       double precision x0, y0, th

       double precision pi
       common /compi/pi

       do j = 1-mbc,my+mbc
          do i = 1-mbc,mx+mbc
             xc = xlower + (i-0.5)*dx
             yc = ylower + (j-0.5)*dy
             q(i,j,1) = -1
c             call mapc2m(xc,yc,xp,yp,zp)
             xp = -1 + 2*xc
             yp = -1 + 2*yc
             zp = 0
             rp = sqrt((xp)**2 + (yp)**2)
             if (rp .lt. 0.4d0) then
                q(i,j,1) = 1.d0
             endif

             do m = 1,4
c               # Larger circles
                th = (m-1)*pi/2.d0
                x0 = 0.6*cos(th)
                y0 = 0.6*sin(th)
                rp = sqrt((xp - x0)**2 + (yp-y0)**2)
                if (rp .lt. 0.2) then
                   q(i,j,1) = 1.d0
                endif

c               # Smaller circles
                th = pi/4.d0 + (m-1)*pi/2.d0
                x0 = 0.55d0*cos(th)
                y0 = 0.55d0*sin(th)
                rp = sqrt((xp - x0)**2 + (yp-y0)**2)
                if (rp .lt. 0.15) then
                   q(i,j,1) = 1.d0
                endif
             enddo
          enddo
       enddo

       return
       end


! data race!

MODULE coarray_subs

  IMPLICIT NONE

CONTAINS

  FUNCTION calc_pi(n) RESULT(pi)

    USE opencoarrays, ONLY: co_sum

    IMPLICIT NONE
    INTEGER(8), SAVE, codimension[*] :: accept
    REAL(8) :: r(2), pi
    INTEGER(8), INTENT(in) :: n
    INTEGER(8) :: i

    accept = 0

    DO i = this_image(), n, num_images()
       CALL RANDOM_NUMBER(r)
       IF (r(1)**2 + r(2)**2 <= 1) THEN
          accept = accept + 1
       END IF
    END DO

    sync all

    CALL co_sum(accept, 1)
    pi = 4.0d0 * DBLE(accept)/DBLE(n)

  END FUNCTION calc_pi

END MODULE coarray_subs

PROGRAM main

    USE coarray_subs

    IMPLICIT NONE
    REAL(8), PARAMETER :: pi = 2.0d0*dacos(0.0d0)
    INTEGER(8) ::  n
    CHARACTER (len=64) :: arg
    REAL(8) :: T1, T2, mypi

    CALL RANDOM_SEED()

    critical

    IF (command_argument_count() /= 1 .AND. this_image() == 1) THEN
        error STOP "One command line argument should be passed, which is the number of iterations to perform."
    END IF

    CALL get_command_argument(1, arg)
    call cpu_time(T1)
    READ(arg,*) n

    END critical

    mypi = calc_pi(n)
    call cpu_time(T2)
    IF (this_image() == 1) THEN
        WRITE(*,'(a,f12.6)') "Calculated = ", mypi
        WRITE(*,'(a,f12.6)') "Actual =     ", pi
    END IF
    print *, 'The time usage is:',  T2-T1
END PROGRAM main


C     Test if the region of a 1-D tile is precise

C     Part of tests tile01, tile02, tile03

      subroutine tile05(n, ts, a)
      integer n, ts, a(n)
      integer ti, i, m

C     if(.true.) does not disturb exact region computation
      if(.true.) then
         a(1) = 0
      endif

      do ti=0, n, ts
         if(.true.) then
C           Must be a case of *exact* transformer that Beatrice would
C           like to capture...
            m = min(ti+ts, n)
            DO i = ti, m, 1
               a(i)=0
            enddo
         endif
      enddo
      end


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!
!!!!   MIT License
!!!!
!!!!   ParaMonte: plain powerful parallel Monte Carlo library.
!!!!
!!!!   Copyright (C) 2012-present, The Computational Data Science Lab
!!!!
!!!!   This file is part of the ParaMonte library.
!!!!
!!!!   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.
!!!!
!!!!   ACKNOWLEDGMENT
!!!!
!!!!   ParaMonte is an honor-ware and its currency is acknowledgment and citations.
!!!!   As per the ParaMonte library license agreement terms, if you use any parts of
!!!!   this library for any purposes, kindly acknowledge the use of ParaMonte in your
!!!!   work (education/research/industry/development/...) by citing the ParaMonte
!!!!   library as described on this page:
!!!!
!!!!       https://github.com/cdslaborg/paramonte/blob/master/ACKNOWLEDGMENT.md
!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

module Test_Matrix_mod

    use Matrix_mod
    use Err_mod, only: Err_type
    use Test_mod, only: Test_type
    implicit none

    private
    public :: test_Matrix

    type(Test_type) :: Test

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

contains

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

    subroutine test_Matrix()

        implicit none

        Test = Test_type(moduleName=MODULE_NAME)

        call test_sortPosDefMat()
        call test_getRegresCoef()
        call Test%finalize()
#ifdef CAF_ENABLED
        sync all
#endif

    end subroutine test_Matrix

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

    subroutine test_sortPosDefMat()

        use Constants_mod, only: RK, IK

        implicit none
        integer                 :: rank
        real(RK), allocatable   :: PosDefMat(:,:), OutPosDefMat(:,:), OutPosDefMatRef(:,:)
        integer                 :: i,j

        if (Test%Image%isFirst) call Test%testing("sortPosDefMat")

        rank = 5
        allocate(PosDefMat(rank,rank))
        do j = 1,rank
            do i = 1,j
                PosDefMat(i,j) = i*10 + j
            end do
        end do

        ! switch the variable 4 with 5, such that the output remains a positive-definite matrix.
        OutPosDefMat = sortPosDefMat(rank,PosDefMat,1_IK,[4],[5])

        if (Test%isDebugMode .and. Test%Image%isFirst) then
            write(Test%outputUnit,"(*(g0))")
            write(Test%outputUnit,"(*(g0))") "Original Matrix:"
            do i = 1,rank
                write(Test%outputUnit,"(*(F7.1))") (PosDefMat(i,j),j=1,rank)
            end do
            write(Test%outputUnit,"(*(g0))")
            write(Test%outputUnit,"(*(g0))") "Output Positive-Definite Matrix with variables 4 and 5 swapped:"
            do i = 1,rank
                write(Test%outputUnit,"(*(F7.1))") (OutPosDefMat(i,j),j=1,rank)
            end do
            write(Test%outputUnit,"(*(g0))")
        end if

        OutPosDefMatRef = reshape(  [ 11._RK, 12._RK, 13._RK, 15._RK, 14._RK &
                                    ,  0._RK, 22._RK, 23._RK, 25._RK, 24._RK &
                                    ,  0._RK,  0._RK, 33._RK, 35._RK, 34._RK &
                                    ,  0._RK,  0._RK,  0._RK, 55._RK, 45._RK &
                                    ,  0._RK,  0._RK,  0._RK,  0._RK, 44._RK ] &
                                    , shape = [rank,rank] )
        OutPosDefMatRef = transpose(OutPosDefMatRef)
        do j = 1, rank
            do i = 1, j
                Test%assertion = OutPosDefMatRef(i,j) == OutPosDefMat(i,j)
               !write(*,*) OutPosDefMatRef(i,j) , OutPosDefMat(i,j)
                call Test%verify()
            end do
        end do
        !call Test%skipping()

    end subroutine test_sortPosDefMat

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

    subroutine test_getRegresCoef()

        use Constants_mod, only: RK, IK

        implicit none
        real(RK)                ::  normalizedDifference
        integer , parameter     ::  rankPDM = 4, rankS11 = 3, rankS22 = 1
        real(RK), parameter     ::  PosDefMat(rankPDM,rankPDM) = reshape( &
                                    [ 4.414182620515998_RK, 1.173760167060120_RK, 0.757607629189287_RK, 5.075277296976230_RK &
                                    , 1.173760167060120_RK, 0.866956750091570_RK, 0.310654936099342_RK, 1.621274787164182_RK &
                                    , 0.757607629189287_RK, 0.310654936099342_RK, 0.955157221699132_RK, 1.254186231887444_RK &
                                    , 5.075277296976230_RK, 1.621274787164182_RK, 1.254186231887444_RK, 6.407791808961157_RK ] &
                                    , shape=shape(PosDefMat) )
        real(RK), parameter     ::  RegresCoefMatRef(rankS11,rankS22) = reshape( &
                                    [ 0.792047783119072 &
                                    , 0.253016145889269 &
                                    , 0.195728305363088 ] &
                                    , shape=shape(RegresCoefMatRef) )
        real(RK), parameter     ::  SchurComplementRef(rankS11,rankS11) = reshape( &
                                    [ 0.3943204887314210_RK, -0.110366933940115_RK, -0.235767795395625_RK &
                                    , -0.110366933940115_RK,  0.456748052015843_RK, -0.006674430520204_RK &
                                    , -0.235767795395625_RK, -0.006674430520204_RK,  0.709677475922085_RK ] &
                                    , shape=shape(SchurComplementRef) )
        real(RK)                :: SchurComplement(rankS11,rankS11)
        real(RK)                :: RegresCoefMat(rankS11,rankS22)
        integer                 :: i,j

        if (Test%Image%isFirst) call Test%testing("getRegresCoef")

        call getRegresCoef  ( rankPDM           = rankPDM           &
                            , rankS11           = rankS11           &
                            , rankS22           = rankS22           &
                            , PosDefMat         = PosDefMat         &
                            , RegresCoefMat     = RegresCoefMat     &
                            , SchurComplement   = SchurComplement   &
                            )

        if (Test%isDebugMode .and. Test%Image%isFirst) then
            write(Test%outputUnit,"(*(g0))")
            write(Test%outputUnit,"(*(g0))") "Original Covariance Matrix:"
            do i = 1,rankPDM
                write(Test%outputUnit,"(*(F22.15))") (PosDefMat(i,j),j=1,rankPDM)
            end do
        end if

        if (Test%isDebugMode .and. Test%Image%isFirst) then
            write(Test%outputUnit,"(*(g0))"); write(Test%outputUnit,"(*(g0))") "RegresCoefMat, RegresCoefMatRef, difference, normalizedDifference:"
        end if
        do i = 1,rankS11
            !write(Test%outputUnit,"(*(F22.15))") (RegresCoefMat(i,j),j=1,rankS22), (RegresCoefMatRef(i,j),j=1,rankS22)
            do j = 1,rankS22
                normalizedDifference = abs(RegresCoefMatRef(i,j) - RegresCoefMat(i,j)) / (RegresCoefMatRef(i,j) + RegresCoefMat(i,j))
                if (Test%isDebugMode .and. Test%Image%isFirst) then
                    write(Test%outputUnit,"(*(F22.15))" ) RegresCoefMat(i,j) &
                                                        , RegresCoefMatRef(i,j) &
                                                        , abs(RegresCoefMat(i,j)-RegresCoefMatRef(i,j)) &
                                                        , normalizedDifference
                end if
                Test%assertion = normalizedDifference < 1.e-5_RK
                call Test%verify()
            end do
        end do

        if (Test%isDebugMode .and. Test%Image%isFirst) then
            write(Test%outputUnit,"(*(g0))"); write(Test%outputUnit,"(*(g0))") "SchurComplement, SchurComplementRef, difference, normalizedDifference:"
        end if
        do i = 1,rankS11
            do j = 1,rankS11
                normalizedDifference = abs(SchurComplementRef(i,j) - SchurComplement(i,j)) / (SchurComplementRef(i,j) + SchurComplement(i,j))
                if (Test%isDebugMode .and. Test%Image%isFirst) then
                    write(Test%outputUnit,"(*(F22.15))" ) SchurComplement(i,j) &
                                                        , SchurComplementRef(i,j) &
                                                        , abs(SchurComplement(i,j)-SchurComplementRef(i,j)) &
                                                        , normalizedDifference
                end if
                Test%assertion = normalizedDifference < 1.e-6_RK
                call Test%verify()
            end do
        end do

        write(Test%outputUnit,"(*(g0))")

        !call Test%skipping()

    end subroutine test_getRegresCoef

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

end module Test_Matrix_mod


!!## SUBROUTINE MODULE: <aQuadratureReflect>
MODULE SUB_aQuadratureReflect
!!### PURPOSE
!! Set up a azimuthal angle $[0,2\Pi]$ Quadrature
!! using the Gauss-Legendre quadrature set.

!!### EXTERNAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_Rsp,KIND_Rdp             !!((01-A-KND_IntrinsicTypes.f90))

!!### EXTERNAL PARAMETERS
USE PAR_Constants_Rdp,ONLY: c_0,c_PI_by_2,c_2,c_2_times_PI !!((02-A-PAR_Constants_Rdp.f90))

!!### EXTERNAL PROCEDURES
USE FUN_Reverse                                            !!((04-A-FUN_Reverse.f90))
USE SUB_CLEAR                                              !!((04-A-SUB_CLEAR.f90))

!!### DEFAULT IMPLICIT
IMPLICIT NONE

!!### DEFAULT ACCESS
PRIVATE

!!### PROCEDURE LISTING
INTERFACE aQuadratureReflect
 MODULE PROCEDURE aQuadratureReflect_Rsp
 MODULE PROCEDURE aQuadratureReflect_Rdp
END INTERFACE

!!### PUBLIC ACCESS LIST
PUBLIC :: aQuadratureReflect

!!### MODULE PROCEDURES
CONTAINS

!!### PURE SUBROUTINE: <aQuadratureGL_Rsp>
PURE SUBROUTINE aQuadratureReflect_Rsp( aOrder , xa , wa , errint , errmsg )
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp              !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "05-B-SUB_aQuadratureReflect.f90.hdr"
!!--begin--
INCLUDE "05-B-SUB_aQuadratureReflect.f90.bdy"
!!--end--
END SUBROUTINE

!!### PURE SUBROUTINE: <aQuadratureGL_Rdp>
PURE SUBROUTINE aQuadratureReflect_Rdp( aOrder , xa , wa , errint , errmsg )
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp              !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "05-B-SUB_aQuadratureReflect.f90.hdr"
!!--begin--
INCLUDE "05-B-SUB_aQuadratureReflect.f90.bdy"
!!--end--
END SUBROUTINE

END MODULE


** Copyright (c) 1989, NVIDIA CORPORATION.  All rights reserved.
**
** 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.

*   Arithmetic IF statements.

	program p
	parameter(n = 31)
	integer rslts(n), expect(n)
	double precision dx

	data rslts / n * 0 /

c ---------- tests 1 - 3: integer arithmetic IF:

	do 10 i = -1, 1, 1
		if (i) 11, 12, 13
		rslts(i+2) = 1
11		rslts(i+2) = rslts(i+2) + 2
		goto 10
12		rslts(i+2) = rslts(i+2) + 4
		goto 10
13		rslts(i+2) = rslts(i+2) + 8
10	continue

c ----------- tests 4 - 6: real arithmetic IF:

	do 20 x = 0, 480.0, 239.3
		if (x - 239.3)  23, 22, 21
21		rslts(4) = x
		goto 20
22		rslts(5) = x
		goto 20
23		rslts(6) = x
20	continue

c ------------ tests 7 - 11:  double precision arithmetic IF:

	data dx / 236.78D17 /

	do 30 i = 1, 5
		if (dble(i-3) * dx) 31, 32, 33
31		rslts(i+6) = 1
		goto 30
32		rslts(i+6) = 2
		goto 30
33		rslts(i+6) = 3
30	continue

c ------------- tests 12 - 18: arithmetic IFs with duplicate labels:

	data i1, i2 / 1, 2 /

	if (i1) 40, 40, 40
40	if (i1) 50, 50, 60
50	rslts(12) = 1
60	rslts(13) = 1
	if (i1 - i2) 51, 51, 61
51	rslts(14) = 1
61	rslts(15) = rslts(15) + 1
	if (i1 + i1 - i2) 61, 62, 61
62	rslts(16) = 1
	if (i2*8) 63, 63, 64
63	rslts(17) = 1
64	rslts(18) = 1

c -------------- tests 19 - 28: Constant arithmetic values:

	if (-6) 70, 71, 72
70	rslts(19) = 1
71	if (99999 ) 71, 73, 74
72	rslts(20) = 1
73	rslts(21) = 1
74	rslts(22) = 1
	if ('0'o) 76, 75, 76
75	rslts(23) = 1
	goto 77
76	rslts(24) = 1
77	if (-i2) 78, 79, 79
79	rslts(25) = 1
78	rslts(26) = 1
	if (i2*2 - i1*4) 80, 81, 81
80	rslts(27) = 1
81	rslts(28) = 1

c ----------- tests 29 - 31: real arithmetic IF with func calls:

	do 200 x = 0, 480.0, 239.3
		if (foo(x) - 240.3)  230, 220, 210
210		rslts(29) = x
		goto 200
220		rslts(30) = x
		goto 200
230		rslts(31) = x
200	continue

c --------------- check results:

	call check(rslts, expect, n)
	data expect / 2, 4, 8,
     +                478, 239, 0,
     +                1, 1, 2, 3, 3,
     +                0, 1, 1, 1, 1, 0, 1,
     +                1, 0, 0, 1, 1,  0, 0, 1, 0, 1,
     +		      478, 239, 0 /
	end

	function foo(z)
	foo = z + 1.0
	return
	end


      program wsac3f
      implicit none

!     Define the Maximum size of the data arrays      p
      integer MAX
      parameter (MAX=300)

!     Define both data arrays, time and amplitude
      real xdata, ydata
      dimension xdata(MAX), ydata(MAX)

!     Define the varaibles used in the call to wsac2()
      character*11 kname
      integer j
      integer nerr
      real cona, conb

!     Set the name the file to be written and initial x value
      kname='expdata    '
      xdata(1) = 0.1
      cona     = 12.3
      conb     = -45.6

!     Create the Amplitude and Time, an Exponential
!     Best viewed with axis as loglin
      ydata(1) = exp(-xdata(1))
      do j=2,MAX
         xdata(j) = xdata(j-1) + xdata(j-1) * 1.0/(4.0 * 3.1415);
         ydata(j) = exp(-xdata(j))
      enddo

!     Create a New Header to store more information
!     Newly created header value are set to a default state
      call newhdr()

!     Store values in the newly created header
!     You must define the following header variables
!        - delta  Time Sampling
!                 Only if the file is evenly spaced
!        - b      Beginning Time
!        - e      Ending Time
!        - npts   Number of Points in the File
!        - iftype File Type
!             - itime Time Series File
!             - irlim Spectral File Real/Imaginary
!             - iamph Spectral File Amplitue/Phase
!             - ixy   X-Y File
!             - iunkn Unknown
!
!     All other variables are up to the user
      call setnhv('npts',    max,        nerr)
      call setlhv('leven',   .false.,    nerr)
      call setfhv('b',       xdata(1),   nerr)
      call setfhv('e',       xdata(max), nerr)
      call setihv('iftype',  'ixy',      nerr)
      call setfhv('user0',   cona,       nerr)
      call setfhv('user1',   conb,       nerr)
      call setkhv('kuser0', 'gendat',    nerr)

!     Write the SAC file kname
!       - kname holds the name of the file to be written
!       - xdata Input Time Data
!       - yfunc Input Amplitude Data
!       - nerr Error return Flag
      call wsac0(kname,xdata,ydata,nerr)

!     Check the Error status
!       - 0 on Success
!       - Non-Zero on Error
      if(nerr .NE. 0) then
         write(*,*)'Error writing SAC File: ', kname,nerr
         call exit(-1)
      endif

      call exit(0)

      end


module resources

use parameters_site
use parameters_plant

implicit none

! Resource variables
real :: DTRINT    ! = MJ GR m-2 d-1 Interception of global radiation
real :: PARAV     ! = mumol PAR m-2 s-1 Average PAR during the photoperiod
real :: PARINT    ! = mol PAR m-2 d-1 PAR captured
real :: PARBASE   ! = mol PAR m-2 d-1 PAR remaining at base
real :: TRANRF    ! = Transpiration realisation factor

contains

! Calculate DTRINT,PARAV,PARINT = light interception variables
Subroutine Light(DAYL,DTR,LAI,BASAL,PAR)
  real :: DAYL,DTR,LAI,BASAL,PAR
  if (DAYL > 0) then
    PARAV = PAR * (1E6/(24*3600)) / DAYL
  else
    PARAV = 0.
  end if
  PARINT = PAR * (1 - exp(-1.0*KLAI*LAI/BASAL))  ! PAR captured, Simon renamed K to KLAI, adjust for BASAL area
  PARBASE = PAR * exp(-1.0*KLAI*LAI/BASAL)       ! PAR remaining at base, Simon
  DTRINT = DTR * (1 - exp(-0.75*KLAI*LAI/BASAL)) ! GR has different extinction, Simon renamed K to KLAI, adjust for BASAL area
end Subroutine Light

! Calculate EVAP,TRAN,TRANRF
! See equations in Marcel van Oijen and Peter Leffelaar Crop Ecology 2010
! Chapter 10(B): Lintul-2: water limited crop growth
Subroutine EVAPTRTRF(Fdepth,PEVAP,PTRAN,CRT,ROOTD,WAL,WCLM,WCL, EVAP,TRAN)
  real :: Fdepth, PEVAP, PTRAN, CRT,ROOTD, WAL,WCLM,WCL,  EVAP, TRAN
  real :: AVAILF, FR, WAAD, WCCR
!  real :: WCL ! Simon use previously calculated WCL
!  if (Fdepth < ROOTD) then
!    WCL = WAL*0.001 / (ROOTD-Fdepth)
!  else
!    WCL = 0
!  end if                                                       ! (m3 m-3)
  EVAP = PEVAP * max(0., min(1., (WCLM-WCAD)/(WCFC-WCAD) ))     ! = mm d-1 Reduction in evaporation due to soil water content
  WCCR = WCWP + (WCFC - WCWP) * max(0.0, PTRAN/(PTRAN+TRANCO))  ! = m3 m-3 Critical water content below which transpiration is reduced (Eqn 1)
 ! https://hrsl.ba.ars.usda.gov/SPAW/SPAW%20Reference%20Manual/PlantTranspiration.htm
!  WCCR = WCWP + (WCFC - WCWP) * max(0.0, min(1.0, PTRAN/TRANCO)) ! = m3 m-3 Critical water content below which transpiration is reduced (Eqn 1)
  if (WCL > WCCR) then                                          ! Transpiraiton reduction factor (Fig 4)
    FR = max(0., min(1., (WCST-WCL)/(WCST-WCWET) ))             ! Transpiration reduction in wet conditions
  else if (WCCR > WCWP) then                                    ! Gradual reduction due to dryness
    FR = max(0., min(1., (WCL-WCWP)/(WCCR-WCWP)  ))             ! Transpiration reduction in dry conditions
  else
    FR = 0.0                                                     ! Simon added this case explicitly instead of setting lower bound to WCCR
  end if
  TRAN = PTRAN * FR                                             ! = mm d-1 Transpiration reduction due to WCL
  WAAD = 1000. * WCAD * (ROOTDM-Fdepth)                         ! = mm Water in non-frozen soil at air dryness, Simon modified to ROOTDM
  if (EVAP+TRAN > 0.) then
    AVAILF = min( 1., ((WAL-WAAD)/DELT) / (EVAP+TRAN) )         ! = Prevent WAL falling below WAAD
  else
    AVAILF = 0
  end if
  EVAP = EVAP * AVAILF                                          ! (mm d-1)
  TRAN = TRAN * AVAILF                                          ! (mm d-1)
  if (PTRAN > 0.) then
    TRANRF = TRAN / PTRAN                                       ! (-) Water restriction on plant processes
  else
    TRANRF = 1                                                  ! (-) Assume no restriction when PTRAN==0
  end if
end Subroutine EVAPTRTRF

! Calculate root depth growth rate RROOTD,EXPLOR
Subroutine ROOTDG(Fdepth,ROOTD,WAL,WCL,CRT,GRT,DRT, EXPLOR,RROOTD)
  real :: Fdepth,ROOTD,WAL,WCL,CRT,GRT,DRT
  real :: EXPLOR,RROOTD
!  real :: WCL ! Simon use previously calculated WCL
!  if (Fdepth < ROOTD) then
!    WCL = WAL*0.001 / (ROOTD-Fdepth)
!  else
!    WCL = 0
!  end if                                                        ! (m3 m-3)
!  if ( (ROOTD<ROOTDM) .and. (WCL>WCWP) ) then
!     RROOTD = min( RRDMAX, (ROOTDM-ROOTD)/DELT ) ! = m d-1 Root depth growth rate (basically constant = RRDMAX)
!  else
!     RROOTD = 0.
!  end if
  RROOTD = 0
!  EXPLOR = 1000. * RROOTD * WCFC                 ! = mm d-1 Increased access to water by root depth growth, FIXME root death effect needed
  EXPLOR = 0
end Subroutine ROOTDG

end module resources


      SUBROUTINE SETOPENBC(DE_T,D_LTD2,DE_TI,HUT,HVT)
C
C CHANGE RECORD
C ** SUBROUTINE SETOBC SETS OPEN BOUNDARY CONDITIONS FOR
C    CALPUV2T & CALPUV2C   AND  CALPUV9 & CALPUV9C
C
C *** MODIFIED BY PAUL M. CRAIG TO ADDRESS MOVING CALL IN CALPUV2#
C
      USE GLOBAL
C
      DIMENSION HUT(LCM),HVT(LCM)
C
C **  SET OPEN BOUNDARY SURFACE ELEVATIONS
C
      IF(ISDYNSTP.EQ.0)THEN
        TN=DT*FLOAT(N)+TCON*TBEGIN
      ELSE
        TN=TIMESEC  ! Time in seconds relative to beginning of year (simulation time + tbegin)
      ENDIF
      DO M=1,MTIDE
        TM=MOD(TN,TCP(M))   ! TCP is tidal period; remainder of division of TN by TCP(M)
        TM=PI2*TM/TCP(M)    ! PI2 = 2*PI(); 2*PI*(tn/Tp)
        CCCOS(M)=COS(TM)
        SSSIN(M)=SIN(TM)
      ENDDO

      ! *** WEST OPEN BOUNDARY
      DO LL=1,NPBW
        L=LPBW(LL)
        CS(L)=0.0
        CW(L)=0.0
        CE(L)=0.0
        CN(L)=0.0
        FP(L)=PSERT(NPSERW(LL))
        DO M=1,MTIDE
          TC=CCCOS(M)
          TS=SSSIN(M)
          FP(L)=FP(L)+PCBW(LL,M)*TC+PSBW(LL,M)*TS
        ENDDO
        ! *** INACTIVAVE BC'S WHEN ELEVATIONS DROP BELOW BOTTOM+HDRY
        FP1G=FP(L)/G-0.95*HDRY
        IF(FP1G.LT.BELV(L).OR.FP1G.LT.BELV(LEAST(L)))THEN
          FP(L)=(BELV(L)+0.95*HDRY)*G
          CET=0.0
        ELSE
          CET=0.5*D_LTD2*G*HRUO(LEAST(L))*RCX(LEAST(L))*HUT(LEAST(L))
        ENDIF

        IF(ISPBW(LL).GE.1)THEN
          TMP=D_LTD2*SQRT(G*HUT(LEAST(L)))*DXIU(LEAST(L))
          CE(L)=-CET
          FP(L)=CET*(2.*FP(L)
     &        -SQRT(G*HUT(LEAST(L)))*FUHDYE(LEAST(L))*DYIU(LEAST(L))/HUT(LEAST(L)))/TMP
        ELSE
          FP(LEAST(L))=FP(LEAST(L))+CET*FP(L)
          FP(L)=DE_TI*DXYP(L)*FP(L)
        ENDIF
      ENDDO

      ! *** EAST OPEN BOUNDARY
      DO LL=1,NPBE
        L=LPBE(LL)
        CS(L)=0.
        CW(L)=0.
        CE(L)=0.
        CN(L)=0.

        FP(L)=PSERT(NPSERE(LL))
        DO M=1,MTIDE
          TC=CCCOS(M)
          TS=SSSIN(M)
          FP(L)=FP(L)+PCBE(LL,M)*TC+PSBE(LL,M)*TS
        ENDDO
        ! *** INACTIVAVE BC'S WHEN ELEVATIONS DROP BELOW BOTTOM+HDRY
        FP1G=FP(L)/G-0.95*HDRY
        IF(FP1G.LT.BELV(L).OR.FP1G.LT.BELV(LWEST(L)))THEN
          FP(L)=(BELV(L)+0.95*HDRY)*G
          CWT=0.
        ELSE
          CWT=0.5*D_LTD2*G*HRUO(L)*RCX(L)*HUT(L)
        ENDIF
        IF(ISPBE(LL).GE.1)THEN
          TMP=D_LTD2*SQRT(G*HUT(L))*DXIU(L)
          CC(L)=CWT*(1.+TMP)/TMP
          CW(L)=-CWT
          FP(L)=CWT*(2.*FP(L)
     &        +SQRT(G*HUT(L))*FUHDYE(L)*DYIU(L)/HUT(L))/TMP
        ELSE
          FP(LWEST(L))=FP(LWEST(L))+CWT*FP(L)
          FP(L)=DE_TI*DXYP(L)*FP(L)
        ENDIF
      ENDDO

      ! *** SOUTH OPEN BOUNDARY
      DO LL=1,NPBS
        L=LPBS(LL)
        LN=LNC(L)
        CS(L)=0.
        CW(L)=0.
        CE(L)=0.
        CN(L)=0.
        FP(L)=PSERT(NPSERS(LL))
        DO M=1,MTIDE
          TC=CCCOS(M)
          TS=SSSIN(M)
          FP(L)=FP(L)+PCBS(LL,M)*TC+PSBS(LL,M)*TS
        ENDDO
        ! *** INACTIVAVE BC'S WHEN ELEVATIONS DROP BELOW BOTTOM+HDRY
        FP1G=FP(L)/G-0.95*HDRY
        IF(FP1G.LT.BELV(L).OR.FP1G.LT.BELV(LN))THEN
          FP(L)=(BELV(L)+0.95*HDRY)*G
          CNT=0.
        ELSE
          CNT=0.5*D_LTD2*G*HRVO(LN)*RCY(LN)*HVT(LN)
        ENDIF
        IF(ISPBS(LL).GE.1)THEN
          TMP=D_LTD2*SQRT(G*HVT(LN))*DYIV(LN)
          CC(L)=CNT*(1.+TMP)/TMP
          CN(L)=-CNT
          FP(L)=CNT*(2.*FP(L)
     &        -SQRT(G*HVT(LN))*FVHDXE(LN)*DXIV(LN)/HVT(LN))/TMP
        ELSE
          FP(LN)=FP(LN)+CNT*FP(L)
          FP(L)=DE_TI*DXYP(L)*FP(L)
        ENDIF
      ENDDO

      ! *** NORTH OPEN BOUNDARY
      DO LL=1,NPBN
        L=LPBN(LL)
        LS=LSC(L)
        CS(L)=0.
        CW(L)=0.
        CE(L)=0.
        CN(L)=0.
        FP(L)=PSERT(NPSERN(LL))
        DO M=1,MTIDE
          TC=CCCOS(M)
          TS=SSSIN(M)
          FP(L)=FP(L)+PCBN(LL,M)*TC+PSBN(LL,M)*TS
        ENDDO
        ! *** INACTIVAVE BC'S WHEN ELEVATIONS DROP BELOW BOTTOM+HDRY
        FP1G=FP(L)/G-0.95*HDRY
        IF(FP1G.LT.BELV(L).OR.FP1G.LT.BELV(LS))THEN
          FP(L)=(BELV(L)+0.95*HDRY)*G
          CST=0.0
         ELSE
          CST=0.5*D_LTD2*G*HRVO(L)*RCY(L)*HVT(L)
        ENDIF
        IF(ISPBN(LL).GE.1)THEN
          TMP=D_LTD2*SQRT(G*HVT(L))*DYIV(L)
          CC(L)=CST*(1.+TMP)/TMP
          CS(L)=-CST
          FP(L)=CST*(2.*FP(L)
     &         +SQRT(G*HVT(L))*FVHDXE(L)*DXIV(L)/HVT(L))/TMP
         ELSE
          FP(LS)=FP(LS)+CST*FP(L)
          FP(L)=DE_TI*DXYP(L)*FP(L)
        ENDIF
      ENDDO

      RETURN
      END


!--------------------------------------------------------------------------------
! 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_od_vvac
CONTAINS
  SUBROUTINE od_vvac(&
       &     stars,vacuum,cell,&
       &     psq,rht,&
       &     vz)

    !     subroutine which calculates the non warped part of the
    !     vacuum potential (m=0,gz=0)
    !                               Y. Mokrousov
    !     the potential in this subroutine can be defined in two
    !     equivalent ways, which nevertheless give a bit defferent
    !     results, 2nd one seems to be more precise

    USE m_qsf
    USE m_od_cylbes
    USE m_types
    USE m_constants
    IMPLICIT NONE
    TYPE(t_vacuum),INTENT(IN)   :: vacuum
    TYPE(t_stars),INTENT(IN)    :: stars
    TYPE(t_cell),INTENT(IN)     :: cell

    COMPLEX, INTENT (IN) :: psq(stars%ng3)
    REAL,    INTENT (IN) :: rht(:,:) !(vacuum%nmzd,2)
    REAL,    INTENT (OUT) :: vz(:,:) !(vacuum%nmzd,2)

    COMPLEX  rhobar
    INTEGER  k1,k2,irec3,irec2,i,j,ivac,imz,imz1
    REAL     g2 ,a(vacuum%nmzd)
    REAL     fJ,z,zp,phi
    REAL     rht1(vacuum%nmzd)
    REAL     f2(vacuum%nmzd),f22(vacuum%nmzd)

    INTRINSIC cmplx

    DO i = 1,vacuum%nmz
       f2(i) = 0.
       f22(i) = 0.
       DO ivac = 1,vacuum%nvac
          vz(i,ivac) = 0.
       END DO
    END DO

    rhobar = -psq(1)

    DO  k1 = -stars%mx1,stars%mx1
       DO  k2 = -stars%mx2,stars%mx2
          irec3 = stars%ig(k1,k2,0)
          IF (irec3.NE.0) THEN
             irec2 = stars%ig2(irec3)
             IF (irec2.NE.1) THEN
                g2 = stars%sk2(irec2)
                phi = stars%phi2(irec2)
                CALL od_cylbes(1,cell%z1*g2,fJ)
                rhobar = rhobar - 2.*psq(irec3)*CMPLX(fJ/(g2*cell%z1),0.0)

             END IF
          END IF
       ENDDO
    ENDDO
    !----> 1st equivalent way

    DO  i=1,vacuum%nmz
       rht1(i) = fpi_const*(cell%z1+(i-1)*vacuum%delz)*rht(i,1)
    ENDDO
    CALL qsf(vacuum%delz,rht1(1),f2(1),vacuum%nmz,1)

    DO  i = 1,vacuum%nmz
       f2(i) = tpi_const*cell%z1*cell%z1*rhobar-f2(i)
    ENDDO

    DO  i = 1,vacuum%nmz
       DO  j = 1,vacuum%nmz
          IF (j.LT.i) THEN
             f22(j) = 0.0
          ELSE
             f22(j) = f2(j)/(cell%z1+vacuum%delz*(j-1))
          END IF
       ENDDO
       CALL qsf(vacuum%delz,f22(1),a,vacuum%nmz,0)
       DO  ivac =1,vacuum%nvac
          vz(i,ivac) = -a(1)
       ENDDO
    ENDDO
    !----> 2nd equivalent way (via the Green function)

    DO imz = 1,vacuum%nmz
       z = cell%z1 + (imz-1)*vacuum%delz
       DO imz1 = 1,vacuum%nmz
          zp = cell%z1 +  (imz1-1)*vacuum%delz
          IF (imz1.LE.imz) THEN
             rht1(imz1) = fpi_const*LOG(z)*zp*rht(imz1,1)
          ELSE
             rht1(imz1) = fpi_const*LOG(zp)*zp*rht(imz1,1)
          END IF

       END DO
       CALL qsf(vacuum%delz,rht1,a,vacuum%nmz,0)
       vz(imz,1) = tpi_const*LOG(z)*(cell%z1*cell%z1)*rhobar - a(1)
    END DO

    RETURN
  END SUBROUTINE od_vvac
END MODULE m_od_vvac


MODULE m_lsTOjmj

   USE m_clebsch
   USE m_types
   USE m_juDFT

   IMPLICIT NONE

   CONTAINS

   SUBROUTINE lsTOjmj(cmat,l)

      TYPE(t_mat),      INTENT(INOUT)  :: cmat
      INTEGER,          INTENT(IN)     :: l

      INTEGER jj,j,mj,s,ml,i,k

      IF(.NOT.ALLOCATED(cmat%data_r)) THEN
         CALL cmat%init(.TRUE.,2*(2*l+1),2*(2*l+1))
      ENDIF

      !Calculate the matrix of CG-coefficients to transform from |l,ml,ms> to |j=l\pm1/2,mjz>
      !compare utils/occup.f90 from libedsolver
      cmat%data_r = 0.0
      DO jj = -1, 1, 2
         j = 2*l+jj
         DO mj = 1, j+1
            k = mj+(jj+1)*l
            DO s = -1, 1, 2
               DO ml = -l, l
                  IF(ABS((ml-s*0.5)-(mj-1-j*0.5)).GT.1e-12) CYCLE
                  !In libedsolver spin up and down are flipped
                  i = INT(ml+l+1+(1+s)/2.0*(2*l+1))
                  !The minus sign in contrast to occup.f90 stems from the fact
                  !that the spins are stored in reversed order in the solver
                  cmat%data_r(i,k) = clebsch(1.0*l,0.5,1.0*ml,-s*0.5,j*0.5,mj-1-j*0.5)
               ENDDO
            ENDDO
         ENDDO
      ENDDO

   END SUBROUTINE lsTOjmj

END MODULE m_lsTOjmj


      !
      !> calculate hamiltonian_k and eigenvalue
      !
      subroutine mkhm(no,nr,nqx,nqy,nqz,hop,rvec,klist,en,uni,eq)
        implicit none
        integer(4),intent(in):: no,nr,nqx,nqy,nqz,klist(3)
        real(8),intent(in) rvec(nr,3)
        complex(8),intent(in) hop(nr,no,no)
        real(8),intent(out):: eq(no)
        complex(8),intent(out):: uni(no,no),en(no,no)

        integer(4) k,l,m
        real(8),Parameter::pi=3.141592653589793238462643383279d0
        real(8) eq1(no),phase
        complex(8) en2(no,no)

        ! Lapack blas
        integer(4) info
        real(8) rwork(3*no-2),tmp
        complex(8) work(2*no-1)

        !$omp parallel
        !$omp workshare
        en=0.0d0
        uni=0.0d0
        eq=0.0d0
        !$omp end workshare
        do m=1,no
           do l=m,no
              !$omp do private(phase),reduction(+: en)
              do k=1,nr
                 phase=2*pi*klist[1]/nqx*rvec(k,1)+2*pi*klist[2]/nqy*rvec(k,2)&
                      +2*pi*klist[3]/nqz*rvec(k,3) !k@
                 en(l,m)=en(l,m)+hop(k,l,m)*cmplx(cos(phase),-sin(phase))
              end do
              !$omp end do
              en(m,l)=conjg(en(l,m))
           end do
        end do
        !$omp end parallel

        en2=en
        call zheev('V','U',no,en2,no,eq1,work,2*no-1,rwork,info)
        uni=en2
        eq=eq1

        return
      end subroutine mkhm


      subroutine runY_00i1i2i3i4i5(k,l,i1,i2,i3,i4,i5,Xtwiddle,Gtwiddle,
     . Shat7,N0)
      implicit none
C---  Expression for extension of Eq. 5.60c
C---  Calculates D00i1i2i3i4i5, requires D00li1i2i3i4
C---  Small terms of order Xtwiddle(0,k)*Diiiiii,Xtwiddle(0,0)*Diiiiiii
C---  Denominator Gtwiddle(k,l)
      include 'pvDnames.f'
      include 'pvDv.f'
      include 'Darraydef.f'
      include 'Darrays.f'
      integer ep,N0,k,l,i1,i2,i3,i4,i5,np
      parameter(np=3)
      double precision Xtwiddle(0:np,0:np),Gtwiddle(np,np)
      double complex Shat7(np,z6max,-2:0)

      if ( (i1.eq.l).or.(i2.eq.l).or.(i3.eq.l).or.(i4.eq.l).or.(i5.eq.l)
     ..or. (i1.eq.0).or.(i2.eq.0).or.(i3.eq.0).or.(i4.eq.0).or.(i5.eq.0)
     .    ) then
      return
      endif

      do ep=-2,0
      Dv(dzziiiii(z5(i1,i2,i3,i4,i5))+N0,ep)=
     .(-2d0*Gtwiddle(k,i1)*Dv(dzziiiii(z5(l,i2,i3,i4,i5))+N0,ep)
     . -2d0*Gtwiddle(k,i2)*Dv(dzziiiii(z5(l,i1,i3,i4,i5))+N0,ep)
     . -2d0*Gtwiddle(k,i3)*Dv(dzziiiii(z5(l,i1,i2,i4,i5))+N0,ep)
     . -2d0*Gtwiddle(k,i4)*Dv(dzziiiii(z5(l,i1,i2,i3,i5))+N0,ep)
     . -2d0*Gtwiddle(k,i5)*Dv(dzziiiii(z5(l,i1,i2,i3,i4))+N0,ep)
     . +Gtwiddle(k,1)*Shat7(1,z6(l,i1,i2,i3,i4,i5),ep)
     . +Gtwiddle(k,2)*Shat7(2,z6(l,i1,i2,i3,i4,i5),ep)
     . +Gtwiddle(k,3)*Shat7(3,z6(l,i1,i2,i3,i4,i5),ep)
     . +Xtwiddle(k,0)*Dv(diiiiii(z6(l,i1,i2,i3,i4,i5))+N0,ep)
     . -Xtwiddle(0,0)*Dv(diiiiiii(z7(k,l,i1,i2,i3,i4,i5))+N0,ep))
     . /(2d0*Gtwiddle(k,l))

      enddo

      return
      end


subroutine std_vfi(u_x,k2_l_min,x_l,ge_l,i_l,f_l,t_l,h_l,ps_l,nh_l,V,V_wo_MD,k2_wo_MD,beq_aux,beq_wo_md)
    use dimensions; use nrtype
    implicit none
    integer,intent(in)::k2_l_min,x_l,ge_l,i_l,f_l,t_l,h_l,ps_l,nh_l
    real(SP),dimension(nkk,clusters+1,nzz,nh_s,2),intent(in)::V,beq_aux
    real(SP),dimension(nkk,clusters,f_t,L_PI2),intent(in)::u_x
    real(SP),intent(out)::V_wo_MD,beq_wo_md
    integer,intent(out)::k2_wo_MD
    real(SP),dimension(nkk)::ECV,V_k2,u,beq_k2
    integer::k2_l_max,k2_l

        k2_l_max=x_l
        u=-9.0_sp
        ECV=-9.0_sp
        V_k2=-9.0_sp
        do k2_l=k2_l_min,k2_l_max
            u(k2_l)=u_x(x_l-k2_l+1,h_l,f_l,i_l,nh_l)
            call ECV_V_k_l2(u(k2_l),V,ge_l,i_l,f_l,t_l,h_l,ps_l,x_l,k2_l,nh_l,V_k2(k2_l),ECV(k2_l),beq_aux,beq_k2(k2_l))
        end do
        V_wo_MD=maxval(V_k2(k2_l_min:k2_l_max))
        k2_wo_MD=maxloc(V_k2(k2_l_min:k2_l_max),1)+k2_l_min-1
        beq_wo_md=beq_k2(k2_wo_MD)

end subroutine


!  *********************************************************************
!  *                                                                   *
!  *                S U B R O U T I N E   V E R N A L I Z              *
!  *                                                      gm   1/31/05 *
!  *                                                                   *
!  *                                                                   *
!  *********************************************************************
!  The VERNALIZ subroutine determines whether the vernalization requirement
!  is satisfied for winter crops. When the accumulated vernalization days
!  (vd) are equal to or greater than 10.0, VERNALIZ will not be called any
!  more.

!  INPUTS:  daynum(R), hemisp(R), vernal(C), verns(C)

!  OUTPUTS: vernal(C), verns(C)

      subroutine vernaliz(cumvd, daynum, devern, hemisp, tmax,
     c tmin, vd, vtbase, vtoptlo, vtoptup, vtupper) !vernal, verns,

      implicit none

      integer  daynum !, verns

      real cumvd, devern, tmax, tmin, vd, vtbase,
     c vtoptlo, vtoptup, vtupper
      !vernal,

      character *22  hemisp

! Local Variables
      real m, tavg, x, x1, x2, x3, x4, y, y1, y2, y3, y4

      ! initialize cumvd
      cumvd = 0.0
      !vtbase point coordinates
      x1 = vtbase
      y1 = 0.0
      !vtoplo point ccordinates
      x2 = vtoptlo
      y2 = 1.0 ! maximum development rate
      !vtoptup point coordinates
      x3= vtoptup
      y3 = 1.0
      !vtupper point coordinates
      x4 = vtupper
      y4 = 0.0

!      print *, 'in vernaliz and vd = ', vd
      !calculate tavg
      tavg = (tmin + tmax)/2
   !   print *, 'in vernaliz daynum =', daynum, 'tavg =', tavg
!!Need to read in vtbase, vtoptlo, vtoptup, vtupper from a file. These
!! are not necessarily the same values as those for calculating gdd.
!!Read in devern value too.
!!For now hardwire these values as follows:
!      vtbase = -5.0
!      vtoptlo = 0.0
!      vtoptup = 15.0
!      vtupper = 30.0
!!devern - value above which devernalization occurs
!      devern = 30.0

! OLD WAY OF DOING VERNALIZATION:
!! Assume that plant is fully vernalized after 1 Jan (northern hemisphere)
!! or 1 July (southern hemisphere, ignore leap years for now):
!
!!probably don't need hemisp any more???
!      if (hemisp .eq. 'north' .and. daynum .eq. 1) then
!!      if (hemisp .eq. 'north' .and. daynum .eq. 328) then !testing vernalization with UPGM
!! what is vernal for and is it still needed?
!	     vernal = 1.0
!	     verns = daynum
!	     print *, 'verns = ', verns
!
!	elseif (hemisp .eq. 'south' .and. daynum .eq. 182) then
!
!	     vernal = 1.0
!	     verns = daynum
!	     print *, 'verns = ', verns
!
!	endif
! END OF OLD WAY OF DOING VERNALIZATION

!Decided to move this section to PhenologyMMS.for p1v and vf0 only need to
!be calculated once.
!Calculate the vernalization factor
!!  p1v is the vernalization coefficient and should be read in from a file.
!!  For now, hardwire it here.
!      p1v = 15
!! vf is the relative development rate when the crop is unvernalized
!      vf0 = 1-(p1v/50)

!  Calculate cumvd = the accumulated vernalization-days
! find the slope of the line for the vernalization relationship with daily ave temp
        if ((tavg .GE. vtbase) .AND. (tavg .LT. vtoptlo)) then
           m = (y2-y1)/(x2-x1) !find the slope of the line vtbase - vtoptlo
      !  y-y1 = m(x-x1) ! x2 and y2 could also be used in place of x1 and y1
           x= tavg
           y = m*x - m*x1 + y1
           cumvd = cumvd + y
        elseif ((tavg .GE. vtoptlo) .AND.
     c   (tavg .LE. vtoptup)) then
           m = (y3-y2)/(x3-x2)! find the slope of the line vtoptlo-vtoptup
           x = tavg            ! this slope should be 0
           y = m*x - m*x2 + y2
           cumvd = cumvd + y
        elseif ((tavg .GT. vtoptup) .AND.
     c   (tavg .LE. vtupper)) then
           m = (y4-y3)/(x4-x3)! find the slope of the line vtoptup-vtupper
           x = tavg
           y = m*x - m*x3 + y3
           cumvd = cumvd + y
! no vernalization when tavg is less than vtbase
        elseif (tavg .LT. vtbase) then
           y = 0.0
           cumvd = cumvd + y
        elseif ((tavg .GT. vtupper) .and. (tavg .LT. devern)) then
           y = 0.0
           cumvd = cumvd + y
! de-vernalization when daily tmax is greater than a set value
        elseif ((tavg .GT. devern) .and. (vd .LT. 10)) then
           cumvd = cumvd - 1
        endif
!debe decided to move this code to PhenologyMMS. vf is not used in
!vernaliz but will be used to affect development rate and needs to be
! available in PhenologyMMS.for.
!!  calculate the vernalization factor vf
!      vf = vf0 + (cumvd/p1v)

   !   print *,'in vernaliz and cumvd = ', cumvd, 'daynum = ', daynum
      return
      end


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 ARELAX (MXND, XN, YN, LXK, KXL, NXL, LLL, ARFACT)
C***********************************************************************

C  SUBROUTINE ARELAX = CALCULATES UNDER - RELAXATION FACTOR FOR AREA PULL
C                      AND LAPLACIAN SMOOTHER

C***********************************************************************

C  NOTE:
C     THE AREA PULL AND LAPLACIAN SMOOTHER WILL OVER - CORRECT
C     AND BECOME UNSTABLE WHEN TYPICAL MESH ELEMENTS ARE MUCH
C     LONGER THAN THEY ARE WIDE, SAY BY A FACTOR OF SIX OR MORE.
C     THIS ROUTINE COMPUTES AN APPROPRIATE UNDER - RELAXATION
C     FACTOR TO BE USED TO HELP CORRECT THIS PROBLEM.  ON REGIONS
C     WHICH HAVE GENERALLY NEAR SQUARE ELEMENTS WITH A SMALL
C     PERCENTAGE OF VERY LONG THIN ELEMENTS THIS FACTOR WILL
C     PROBABLY NOT ADEQUATELY HANDLE THE DIFFICULTY.  IN SUCH
C     SITUATIONS AN ALTERNATE SMOOTHER  (SUCH AS THE CENTROID - AREA -
C     PULL) SHOULD BE USED.
C     THE FACTOR RETURNED BY THIS ROUTINE MAY BE LARGER THAN ONE,
C     WHICH MEANS THAT OVER - RELAXATION IS APPROPRIATE.

C***********************************************************************

      DIMENSION NODES (4), LXK (4, MXND), KXL (2, 3 * MXND)
      DIMENSION NXL (2, 3 * MXND)
      DIMENSION XN (MXND), YN (MXND)

      LOGICAL CCW

      ARFACT = 1.0
      RATSUM = 0.
      NUM = 0

      DO 100 MYL = 1, LLL

C  SKIP BOUNDARY LINES

         IF (KXL(1, myL) .gt. 0 .and. KXL (2, myL) .GT. 0) THEN
            CCW = .TRUE.
            CALL GNXKA (MXND, XN, YN, KXL (1, MYL), NODES, AREA1, LXK,
     &         NXL, CCW)
            CALL GNXKA (MXND, XN, YN, KXL (2, MYL), NODES, AREA2, LXK,
     &         NXL, CCW)
            N1 = NXL (1, MYL)
            N2 = NXL (2, MYL)
            DXDY = (XN (N2) - XN (N1)) **2 + (YN (N2) - YN (N1)) **2
            IF (AREA1 + AREA2 .GT. 0) THEN
               RATIO = 2.0 * DXDY /  (AREA1 + AREA2)
               IF (RATIO .GE. 0.99) THEN
                  NUM = NUM + 1
                  RATSUM = RATSUM + RATIO
               ENDIF
            ENDIF
         ENDIF
  100 CONTINUE

      IF (NUM .LE. 0) RETURN
      ASPECT = RATSUM / DBLE(NUM)
      ARFACT = AMIN1 (2.0 / ASPECT, 1.5)

      RETURN

      END


subroutine wavenr(h         ,t         ,k         ,ag        )
!----- LGPL --------------------------------------------------------------------
!
!  Copyright (C)  Stichting Deltares, 2011-2016.
!
!  This library is free software; you can redistribute it and/or
!  modify it under the terms of the GNU Lesser General Public
!  License as published by the Free Software Foundation version 2.1.
!
!  This library is distributed in the hope that it will be useful,
!  but WITHOUT ANY WARRANTY; without even the implied warranty of
!  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
!  Lesser General Public License for more details.
!
!  You should have received a copy of the GNU Lesser General Public
!  License along with this library; if not, see <http://www.gnu.org/licenses/>.
!
!  contact: delft3d.support@deltares.nl
!  Stichting Deltares
!  P.O. Box 177
!  2600 MH Delft, The Netherlands
!
!  All indications and logos of, and references to, "Delft3D" and "Deltares"
!  are registered trademarks of Stichting Deltares, and remain the property of
!  Stichting Deltares. All rights reserved.
!
!-------------------------------------------------------------------------------
!  $Id: wavenr.f90 5717 2016-01-12 11:35:24Z mourits $
!  $HeadURL: https://svn.oss.deltares.nl/repos/delft3d/tags/6686/src/utils_lgpl/deltares_common/packages/deltares_common/src/wavenr.f90 $
!!--description-----------------------------------------------------------------
!
!    Function: Approximation of the dispersion, original sub-
!              routine Disp10 (L, T, h, g)
! Method used: relation according to linear wave theory:
!
!  = k TANH k
!
! h k = 2 pi h / L and w = (2 pi / T) sqrt (h/g), and L as
! nown.
! ational function approximation is made of the form :
!
!     1 + a1 w^2 + a2 w^4 + a3 w^6 + a4 w^8 + a5 w^10 + a6 w^12
! w^2 ---------------------------------------------------------
!     1 + b1 w^2 + b2 w^4 + b3 w^6 + b4 w^8           + a6 w^10
!
! ing the exact values for L for:
!  0.4, 0.7, 1.0, 1.3, 1.6, 1.95, 2.35, 2.9, 3.8 and 6.5,
!  a relative error less than 1.7E-6 for all w.
!
!
!!--pseudo code and references--------------------------------------------------
! NONE
!!--declarations----------------------------------------------------------------
    use precision
    use mathconsts
    !
    implicit none
    !
!
! Local parameters
!
    real(hp), parameter :: a1 = 5.060219360721177D-01, a2 = 2.663457535068147D-01,&
                         & a3 = 1.108728659243231D-01, a4 = 4.197392043833136D-02,&
                         & a5 = 8.670877524768146D-03, a6 = 4.890806291366061D-03,&
                         & b1 = 1.727544632667079D-01, b2 = 1.191224998569728D-01,&
                         & b3 = 4.165097693766726D-02, b4 = 8.674993032204639D-03
!
! Global variables
!
    real(fp), intent(in)               :: h  !!  Waterheight
    real(fp), intent(out)              :: k  !!  Approxiamation of wave lenght
    real(fp), intent(in)               :: t  !!  Period
    real(fp), intent(in)               :: ag !!  Gravitational acceleration
!
!
! Local variables
!
    real(hp)               :: den                  ! Denominator
    real(hp)               :: kd                   ! Double value for K
    real(hp)               :: num                  ! Numerator
    real(hp)               :: ome2                 ! Omega
!
!
!! executable statements -------------------------------------------------------
!
    ome2 = (2.0D0*pi_hp/real(t, hp))**2*real(h, hp)/real(ag, hp)
    !
    num = 1.0D0 +                                                               &
        & ome2*(a1 + ome2*(a2 + ome2*(a3 + ome2*(a4 + ome2*(a5 + ome2*a6)))))
    den = 1.0D0 + ome2*(b1 + ome2*(b2 + ome2*(b3 + ome2*(b4 + ome2*a6))))
    kd = sqrt(ome2*num/den)/real(h, hp)
    k = real(kd, fp)
end subroutine wavenr


*> \brief \b SSYTRS2
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download SSYTRS2 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
*  Definition:
*  ===========
*
*       SUBROUTINE SSYTRS2( UPLO, N, NRHS, A, LDA, IPIV, B, LDB,
*                           WORK, INFO )
*
*       .. Scalar Arguments ..
*       CHARACTER          UPLO
*       INTEGER            INFO, LDA, LDB, N, NRHS
*       ..
*       .. Array Arguments ..
*       INTEGER            IPIV( * )
*       REAL               A( LDA, * ), B( LDB, * ), WORK( * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> SSYTRS2 solves a system of linear equations A*X = B with a real
*> symmetric matrix A using the factorization A = U*D*U**T or
*> A = L*D*L**T computed by SSYTRF and converted by SSYCONV.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] UPLO
*> \verbatim
*>          UPLO is CHARACTER*1
*>          Specifies whether the details of the factorization are stored
*>          as an upper or lower triangular matrix.
*>          = 'U':  Upper triangular, form is A = U*D*U**T;
*>          = 'L':  Lower triangular, form is A = L*D*L**T.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The order 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 matrix B.  NRHS >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*>          A is REAL array, dimension (LDA,N)
*>          The block diagonal matrix D and the multipliers used to
*>          obtain the factor U or L as computed by SSYTRF.
*>          Note that A is input / output. This might be counter-intuitive,
*>          and one may think that A is input only. A is input / output. This
*>          is because, at the start of the subroutine, we permute A in a
*>          "better" form and then we permute A back to its original form at
*>          the end.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*>          LDA is INTEGER
*>          The leading dimension of the array A.  LDA >= max(1,N).
*> \endverbatim
*>
*> \param[in] IPIV
*> \verbatim
*>          IPIV is INTEGER array, dimension (N)
*>          Details of the interchanges and the block structure of D
*>          as determined by SSYTRF.
*> \endverbatim
*>
*> \param[in,out] B
*> \verbatim
*>          B is REAL array, dimension (LDB,NRHS)
*>          On entry, the right hand side matrix B.
*>          On exit, the solution matrix X.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*>          LDB is INTEGER
*>          The leading dimension of the array B.  LDB >= max(1,N).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*>          WORK is REAL array, dimension (N)
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*>          INFO is INTEGER
*>          = 0:  successful exit
*>          < 0:  if INFO = -i, the i-th argument had an illegal value
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2015
*
*> \ingroup realSYcomputational
*
*  =====================================================================
      SUBROUTINE SSYTRS2( UPLO, N, NRHS, A, LDA, IPIV, B, LDB,
     $                    WORK, INFO )
*
*  -- LAPACK computational routine (version 3.6.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2015
*
*     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            INFO, LDA, LDB, N, NRHS
*     ..
*     .. Array Arguments ..
      INTEGER            IPIV( * )
      REAL               A( LDA, * ), B( LDB, * ), WORK( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ONE
      PARAMETER          ( ONE = 1.0E+0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            UPPER
      INTEGER            I, IINFO, J, K, KP
      REAL               AK, AKM1, AKM1K, BK, BKM1, DENOM
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     ..
*     .. External Subroutines ..
      EXTERNAL           SSCAL, SSYCONV, SSWAP, STRSM, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX
*     ..
*     .. Executable Statements ..
*
      INFO = 0
      UPPER = LSAME( UPLO, 'U' )
      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( NRHS.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -5
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -8
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'SSYTRS2', -INFO )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( N.EQ.0 .OR. NRHS.EQ.0 )
     $   RETURN
*
*     Convert A
*
      CALL SSYCONV( UPLO, 'C', N, A, LDA, IPIV, WORK, IINFO )
*
      IF( UPPER ) THEN
*
*        Solve A*X = B, where A = U*D*U**T.
*
*       P**T * B
        K=N
        DO WHILE ( K .GE. 1 )
         IF( IPIV( K ).GT.0 ) THEN
*           1 x 1 diagonal block
*           Interchange rows K and IPIV(K).
            KP = IPIV( K )
            IF( KP.NE.K )
     $         CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
            K=K-1
         ELSE
*           2 x 2 diagonal block
*           Interchange rows K-1 and -IPIV(K).
            KP = -IPIV( K )
            IF( KP.EQ.-IPIV( K-1 ) )
     $         CALL SSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ), LDB )
            K=K-2
         END IF
        END DO
*
*  Compute (U \P**T * B) -> B    [ (U \P**T * B) ]
*
        CALL STRSM('L','U','N','U',N,NRHS,ONE,A,LDA,B,LDB)
*
*  Compute D \ B -> B   [ D \ (U \P**T * B) ]
*
         I=N
         DO WHILE ( I .GE. 1 )
            IF( IPIV(I) .GT. 0 ) THEN
              CALL SSCAL( NRHS, ONE / A( I, I ), B( I, 1 ), LDB )
            ELSEIF ( I .GT. 1) THEN
               IF ( IPIV(I-1) .EQ. IPIV(I) ) THEN
                  AKM1K = WORK(I)
                  AKM1 = A( I-1, I-1 ) / AKM1K
                  AK = A( I, I ) / AKM1K
                  DENOM = AKM1*AK - ONE
                  DO 15 J = 1, NRHS
                     BKM1 = B( I-1, J ) / AKM1K
                     BK = B( I, J ) / AKM1K
                     B( I-1, J ) = ( AK*BKM1-BK ) / DENOM
                     B( I, J ) = ( AKM1*BK-BKM1 ) / DENOM
 15              CONTINUE
               I = I - 1
               ENDIF
            ENDIF
            I = I - 1
         END DO
*
*      Compute (U**T \ B) -> B   [ U**T \ (D \ (U \P**T * B) ) ]
*
         CALL STRSM('L','U','T','U',N,NRHS,ONE,A,LDA,B,LDB)
*
*       P * B  [ P * (U**T \ (D \ (U \P**T * B) )) ]
*
        K=1
        DO WHILE ( K .LE. N )
         IF( IPIV( K ).GT.0 ) THEN
*           1 x 1 diagonal block
*           Interchange rows K and IPIV(K).
            KP = IPIV( K )
            IF( KP.NE.K )
     $         CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
            K=K+1
         ELSE
*           2 x 2 diagonal block
*           Interchange rows K-1 and -IPIV(K).
            KP = -IPIV( K )
            IF( K .LT. N .AND. KP.EQ.-IPIV( K+1 ) )
     $         CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
            K=K+2
         ENDIF
        END DO
*
      ELSE
*
*        Solve A*X = B, where A = L*D*L**T.
*
*       P**T * B
        K=1
        DO WHILE ( K .LE. N )
         IF( IPIV( K ).GT.0 ) THEN
*           1 x 1 diagonal block
*           Interchange rows K and IPIV(K).
            KP = IPIV( K )
            IF( KP.NE.K )
     $         CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
            K=K+1
         ELSE
*           2 x 2 diagonal block
*           Interchange rows K and -IPIV(K+1).
            KP = -IPIV( K+1 )
            IF( KP.EQ.-IPIV( K ) )
     $         CALL SSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ), LDB )
            K=K+2
         ENDIF
        END DO
*
*  Compute (L \P**T * B) -> B    [ (L \P**T * B) ]
*
        CALL STRSM('L','L','N','U',N,NRHS,ONE,A,LDA,B,LDB)
*
*  Compute D \ B -> B   [ D \ (L \P**T * B) ]
*
         I=1
         DO WHILE ( I .LE. N )
            IF( IPIV(I) .GT. 0 ) THEN
              CALL SSCAL( NRHS, ONE / A( I, I ), B( I, 1 ), LDB )
            ELSE
                  AKM1K = WORK(I)
                  AKM1 = A( I, I ) / AKM1K
                  AK = A( I+1, I+1 ) / AKM1K
                  DENOM = AKM1*AK - ONE
                  DO 25 J = 1, NRHS
                     BKM1 = B( I, J ) / AKM1K
                     BK = B( I+1, J ) / AKM1K
                     B( I, J ) = ( AK*BKM1-BK ) / DENOM
                     B( I+1, J ) = ( AKM1*BK-BKM1 ) / DENOM
 25              CONTINUE
                  I = I + 1
            ENDIF
            I = I + 1
         END DO
*
*  Compute (L**T \ B) -> B   [ L**T \ (D \ (L \P**T * B) ) ]
*
        CALL STRSM('L','L','T','U',N,NRHS,ONE,A,LDA,B,LDB)
*
*       P * B  [ P * (L**T \ (D \ (L \P**T * B) )) ]
*
        K=N
        DO WHILE ( K .GE. 1 )
         IF( IPIV( K ).GT.0 ) THEN
*           1 x 1 diagonal block
*           Interchange rows K and IPIV(K).
            KP = IPIV( K )
            IF( KP.NE.K )
     $         CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
            K=K-1
         ELSE
*           2 x 2 diagonal block
*           Interchange rows K-1 and -IPIV(K).
            KP = -IPIV( K )
            IF( K.GT.1 .AND. KP.EQ.-IPIV( K-1 ) )
     $         CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
            K=K-2
         ENDIF
        END DO
*
      END IF
*
*     Revert A
*
      CALL SSYCONV( UPLO, 'R', N, A, LDA, IPIV, WORK, IINFO )
*
      RETURN
*
*     End of SSYTRS2
*
      END


      double complex function cdot(e1,e2)
      implicit none
      double complex e1(4),e2(4)
      cdot=e1(4)*e2(4)-e1(1)*e2(1)-e1(2)*e2(2)-e1(3)*e2(3)
      return
      end


SUBROUTINE CGGLSE_F95( A, B, C, D, X, INFO )
!
!  -- LAPACK95 interface driver routine (version 3.0) --
!     UNI-C, Denmark; Univ. of Tennessee, USA; NAG Ltd., UK
!     September, 2000
!
!   .. USE STATEMENTS ..
    USE LA_PRECISION, ONLY: WP => SP
    USE LA_AUXMOD, ONLY: ERINFO
    USE F77_LAPACK, ONLY: GGLSE_F77 => LA_GGLSE
!   .. IMPLICIT STATEMENT ..
    IMPLICIT NONE
!   .. SCALAR ARGUMENTS ..
    INTEGER, INTENT(OUT), OPTIONAL :: INFO
!   .. ARRAY ARGUMENTS ..
    COMPLEX(WP), INTENT(INOUT) :: A(:,:), B(:,:), C(:), D(:)
    COMPLEX(WP), INTENT(OUT) :: X(:)
!----------------------------------------------------------------------
!
! Purpose
! =======
!
!       LA_GGLSE solves the linear equality-constrained least squares
! (LSE) problem:
!      min || c - A*x||2 subject to B*x = d,
! where A and B are real or complex rectangular matrices and c and d are
! real or complex vectors. Further, A is m by n, B is p by n, c is m by 1
! and d is p by 1, and it is assumed that
!       p <= n <=  m + p, rank(B) = p,  rank [ A ] = n.
!                                            [ B ]
! These conditions ensure that the LSE problem has a unique solution x.
! This is obtained using the generalized RQ factorization of the matrices
! B and A.
!
! =========
!
!        SUBROUTINE LA_GGLSE( A, B, C, D, X, INFO=info )
!          <type>(<wp>), INTENT( INOUT ) :: A(:,:), B(:,:), C(:), D(:)
!          <type>(<wp>), INTENT( OUT ) :: X(:)
!          INTEGER, INTENT(OUT), OPTIONAL :: INFO
!        where
!          <type> ::= REAL | COMPLEX
!          <wp>   ::= KIND(1.0) | KIND(1.0D0)
!
! Arguments
! =========
!
! A       (input/output) REAL or COMPLEX array, shape (:,:) with
!         size(A,1) = m and size(A,2) = n.
!         On entry, the matrix A.
!         On exit, the contents of A are destroyed.
! B       (input/output) REAL or COMPLEX array, shape (:,:) with
!         size(B,1) = p and size(B,2) = n.
!         On entry, the matrix B.
!         On exit, the contents of B are destroyed.
! C       (input/output) REAL or COMPLEX array, shape (:) with
!         size(C) = m.
!         On entry, the vector c.
!         On exit, the residual sum of squares for the solution is given
!  	  by the sum of squares of elements n-p+1 to m.
! D       (input/output) REAL or COMPLEX array, shape (:) with
!         size(D) = p.
!         On entry, The vectors d.
!         On exit, the contents of D are destroyed.
! X       (output) REAL or COMPLEX array, shape (:) with size(X) = n.
!         The solution vector x.
! INFO    Optional (output) INTEGER.
!         = 0: successful exit.
!         < 0: if INFO = -i, the i-th argument had an illegal value.
!         If INFO is not present and an error occurs, then the program
!         is terminated with an error message.
!----------------------------------------------------------------------
!   .. PARAMETERS ..
    CHARACTER(LEN=8), PARAMETER :: SRNAME = 'LA_GGLSE'
!   .. LOCAL SCALARS ..
    INTEGER :: LINFO, ISTAT, ISTAT1, N, M, MN, P
!   .. LOCAL SAVE SCALARS ..
    INTEGER, SAVE :: LWORK = 0
!   .. LOCAL POINTERS ..
    COMPLEX(WP), POINTER :: WORK(:)
!   .. INTRINSIC FUNCTIONS ..
    INTRINSIC SIZE, MAX, MIN
!   .. EXECUTABLE STATEMENTS ..
    LINFO = 0; ISTAT = 0; M = SIZE(A,1); N = SIZE(A,2); P = SIZE(B,1)
    MN = MIN(M,N)
!   .. TEST THE ARGUMENTS
    IF( M < 0 .OR. N < 0 ) THEN; LINFO = -1
    ELSE IF( P < 0 .OR. P > N .OR. P < N-M .OR. SIZE(B,2) /= N ) THEN; LINFO = -2
    ELSE IF( SIZE(C) /= M ) THEN; LINFO = -3
    ELSE IF( SIZE(D) /= P ) THEN; LINFO = -4
    ELSE IF( SIZE(X) /= N ) THEN; LINFO = -5
    ELSE
       LWORK = MAX( 1, M + N + P , LWORK )
       ALLOCATE( WORK(LWORK), STAT = ISTAT )
       IF( ISTAT /= 0 ) THEN
          DEALLOCATE( WORK, STAT=ISTAT1 )
          LWORK = MAX( 1, M + N + P )
          ALLOCATE( WORK(LWORK), STAT = ISTAT )
          IF( ISTAT == 0 ) CALL ERINFO( -200, SRNAME, LINFO )
       END IF
       IF ( ISTAT == 0 ) THEN
!      .. CALL LAPACK77 ROUTINE
          CALL GGLSE_F77( M, N, P, A, MAX(1,M), B, MAX(1,P), &
                          C, D, X, WORK, LWORK, LINFO )
          IF( LINFO == 0 ) LWORK = INT(WORK(1))
       ELSE; LINFO = -100; END IF
       DEALLOCATE(WORK, STAT = ISTAT1 )
    END IF
    CALL ERINFO( LINFO, SRNAME, INFO, ISTAT )
 END SUBROUTINE CGGLSE_F95