module genetics
implicit none
! real*8, parameter :: inf = 1000000000.d0

type group
  real*8  :: fitness  ! values to be sorted by
  integer :: age
  integer, pointer :: chromosome(:)
end type group
contains

! ###################################
! ####    AUXILIARY FUNCTIONS    ####
! ###################################
subroutine group_create(A,genNo)
  type(group)  :: A
  integer, intent(in)  :: genNo
  integer :: i
  allocate(A%chromosome(1:genNo))
  A%chromosome = (/ (i, i=1,genNo) /)
  A%age = 0
end subroutine group_create

subroutine spin_me_round(item)
  type(group)  :: item
  integer :: genNo
  integer :: i
  genNo=size(item%chromosome,1)
  i=minloc(item%chromosome, dim=1)
  item%chromosome=cshift(item%chromosome,i-1)
end subroutine spin_me_round

recursive subroutine QSort(A,nA)
! Type GROUP has been gneralized for purposes of my program, but it's from:
! http://rosettacode.org/wiki/Sorting_algorithms/Quicksort#Fortran
  integer, intent(in) :: nA
  type (group), dimension(nA), intent(in out) :: A
  ! LOCAL VARIABLES
  integer :: left, right
  real*8 :: random
  real*8 :: pivot
  type (group) :: temp
  integer :: marker

      if (nA > 1) then
          call random_number(random)
          pivot = A(int(random*real(nA-1))+1)%fitness   ! random pivor (not best performance, but avoids worst-case)
          left = 0
          right = nA + 1

          do while (left < right)
              right = right - 1
              do while (A(right)%fitness < pivot)
                  right = right - 1
              end do
              left = left + 1
              do while (A(left)%fitness > pivot)
                  left = left + 1
              end do
              if (left < right) then
                  temp = A(left)
                  A(left) = A(right)
                  A(right) = temp
              end if
          end do

          if (left == right) then
              marker = left + 1
          else
              marker = left
          end if

          call QSort(A(:marker-1),marker-1)
          call QSort(A(marker:),nA-marker+1)
      end if
end subroutine QSort

function isElIn(item,list) result(is)
  integer, intent(in) :: list(:), item
  integer :: i
  logical :: is
  is=.false.
  do i=1,size(list)
    if (list(i) == item) then
      is=.true.
    endif
  end do
end function isElIn

function isItemInPop(item,list) result(is)
  type(group), intent(in) :: list(:), item
  integer :: i,j
  logical :: is
  if(size(item%chromosome,1).ne.size(list(1)%chromosome,1)) stop "Error: genetics: amIunique: length of chromosome does not match"
  loopi:do i=1,size(list)
    is=.false.
    do j=1,size(list(i)%chromosome,1)
      if (list(i)%chromosome(j).ne.item%chromosome(j)) then
        cycle loopi
      endif
    end do!j
    is=.true.
    return
  end do loopi!i
end function isItemInPop

recursive function isItemInPopBinary(item,list) result(gdzie)
  type(group), intent(in) :: list(:), item
  integer :: mid,id, gdzie
  ! if(size(item%chromosome,1).ne.size(list(1)%chromosome,1)) stop "Error: genetics: amIunique: length of chromosome does not match"

  mid = size(list,1)/2+1
  if(abs(item%fitness-list(mid)%fitness)<1d-2) then
    id=0
  else if(item%fitness<list(mid)%fitness) then
    id=-1
  else
    id=1
  endif
  print *, mid, id, size(list,1)
  if(size(list,1)==0) then
    gdzie = 0 !not found
  else if (id==1) then
    gdzie = isItemInPopBinary(item,list(:mid-1))
  else if (id==-1) then
    gdzie = isItemInPopBinary(item,list(mid+1:))
    if(gdzie /= 0) then
      gdzie = mid + gdzie
    endif
  else
    gdzie = mid ! SUCCESS
  endif

end function isItemInPopBinary

function mean(list) result(m)
real*8, intent(in) :: list(:)
real*8 :: m
m = sum(list)/size(list)
end function

function variance(list) result(s)
  real*8, intent(in) :: list(:)
  real*8 :: m, s
  m = sum(list)/size(list)
  s = sum((list-m)**2)/size(list)
  s = sqrt(s)
end function variance

subroutine shuffle(a)
  ! http://rosettacode.org/wiki/Knuth_shuffle#Fortran
  integer, intent(inout) :: a(:)
  integer :: i, randpos, temp
  real :: r
  do i = size(a), 2, -1
    call random_number(r)
    randpos = int(r * i) + 1
    temp = a(randpos)
    a(randpos) = a(i)
    a(i) = temp
  end do
end subroutine shuffle

subroutine pick_range(from,to,start,finish)
  ! Modified version of:
  ! http://rosettacode.org/wiki/Pick_random_element#Fortran
  integer, intent(in)  :: from, to
  integer, intent(out) :: start, finish
  integer, allocatable :: a(:)
  integer :: k
  real*8  :: r
  allocate(a(to-from))
  do k=1, to-from
    a(k) = k+from
  end do!k
  call random_number(r)
  start = a(int(r*(size(a))) + 1)
  do
    call random_number(r)
    k = a(int(r*(size(a))) + 1)
    if (k>start) then
      finish = k
      exit
    elseif (k<start) then
      finish = start
      start = k
      exit
    end if
  end do
end subroutine pick_range

! ###################################
! ######      GENOM SCALE      ######
! ###################################
! ### MUTATION
subroutine ScrambleMutation(item)
! Mutation that shuffles randomly the genes.
  integer, intent(inout) :: item(:)
  integer :: len, start,finish
  len = size(item,1)
  call pick_range(2,len,start,finish)
  call shuffle(item(start:finish))
end subroutine ScrambleMutation

subroutine InversionMutation(item)
  ! Mutation that invertes random sequence of genes.
  integer, intent(inout) :: item(:)
  integer :: len, start,finish , i, temp
  len = size(item,1)
  call pick_range(2,len,start,finish)
  ! Inverse given range of genes
  do i=start,(finish+start-1)/2
    temp = item(i)
    item(i) = item(finish+start-i)
    item(finish+start-i) = temp
  end do!i
end subroutine InversionMutation

!### Davis' Order Crossover (O1)
subroutine CrossoverOX1(p1,p2,ch1,ch2)
!Applies so called Davis' Order Crossover OX1 for permutation based crossovers.
  integer, intent(in)  :: p1(:), p2(:)
  integer, intent(out) :: ch1(:), ch2(:)
  integer :: len, start, finish, i, j
  len = size(ch1)
  call pick_range(2,len,start,finish)
  ch1 = -1
  ch2 = -1
  ch1(1) = 1
  ch2(1) = 1
  do i=start,finish
    ch1(i) = p1(i)
    ch2(i) = p2(i)
  enddo!i
  do i=2,len
    if (.not.isElIn(p2(i),ch1)) then
      do j=2,len
        if (ch1(j)==-1) then
          ch1(j) = p2(i)
          exit
        endif
      enddo!j
    endif
    if (.not.isElIn(p1(i),ch2)) then
      do j=2,len
        if (ch2(j)==-1) then
          ch2(j) = p1(i)
          exit
        endif
      enddo!j
    endif
  enddo!i
end subroutine CrossoverOX1

! ###################################
! ######    INDIVIDUAL SCALE    #####
! ###################################
! ### Choose parents
subroutine rouletteWheelSelection(fitnesses,p1)
! Chooses parent from the population by the fitness and weighting by the fitness it randomly chooses a parent.
  real*8,  intent(in) :: fitnesses(:)
  integer, intent(out):: p1
  real*8 :: r, total, pick
  integer :: popNo, i
  popNo = size(fitnesses,1)
  total = sum(fitnesses)
  call random_number(r)
  r=r*total
  pick = 0.d0
  do i=1,popNo
    pick = pick + fitnesses(i)
    if (pick > r)  then
      p1=i
      GOTO 11
    endif
  end do!i
11 continue
  ! TODO CHECK
end subroutine rouletteWheelSelection

!### Fitness function
subroutine fitness(population,distance,shift)
  ! Function calculates the fitness of a chromosome 'item'
  type(group), intent(inout) :: population
  real*8,  intent(in)  :: distance(:,:), shift
  integer :: genNo, i
  genNo = size(population%chromosome)
  population%fitness = 0.d0
  do i=1,genNo
    population%fitness = population%fitness + distance(population%chromosome(i),population%chromosome(mod(i,genNo)+1))
  end do!i
  population%fitness = shift - population%fitness
end subroutine fitness

subroutine cycleLength(population,distance)
  ! Function calculates the total length of the path given by a  chromosome ITEM
  type(group), intent(inout) :: population
  real*8,  intent(in)  :: distance(:,:)
  integer :: genNo, i
  genNo = size(population%chromosome,1)
  population%fitness = 0.d0
  do i=1,genNo
    population%fitness = population%fitness + distance(population%chromosome(i),population%chromosome(mod(i,genNo)+1))
  end do!i
end subroutine cycleLength

! ###################################
! ######   POPULATION SCALE    ######
! ###################################
subroutine growPopulation(population,genNo)
!  Grow population of P individuals, everyone with G genes.
  type(group), intent(inout) :: population(:)
  integer, intent(in)  :: genNo
  integer  :: popNo
  integer  :: i
  popNo = size(population)
  do i=1,popNo
    call group_create(population(i),genNo)
    call shuffle(population(i)%chromosome(2:genNo))
  enddo!i
end subroutine growPopulation

subroutine getHeuristicSolutions(heuristicPop,distance)
  ! Get COUNTRYNO number of heuristicly found chromosome (COUNTRYNO long each)  which is usually moderately good. It uses table of distances DISTANCE.
  ! The reasonably good solutions are found by a greedy algorithm startng from a city and going straight to the closest.
  use cities
  type(group), intent(inout) :: heuristicPop(:)
  real*8,  intent(inout)    :: distance(:,:)
  real*8,  allocatable      :: distance2(:,:)
  integer :: genNo, popNo, i, j, l
  integer :: id, oldid
  real*8  :: r
  genNo=size(distance,1)
  popNo=size(heuristicPop,1)
  ! print *, genNo, popNo
  if(popNo<genNo) stop "Error (genetics: getHeuristicSolutions): You should have population larger than number of cities."
  allocate(distance2(genNo,genNo))

  ! Start clever...
  do  l = 1,genNo
    distance2=distance
    id = l
    r = 0.d0
    heuristicPop(l)%chromosome(1)=id
    do i=1,genNo-1
      r = r + minval(distance2(id,:))
      oldid=id
      id=minloc(distance2(id,:),dim=1)
      heuristicPop(l)%chromosome(i+1)=id
      distance2(oldid,:)=inf
      distance2(:,oldid)=inf
    enddo
    r = r + distance(l,id)
    heuristicPop(l)%chromosome(genNo)=id
    call spin_me_round(heuristicPop(l))
    call cycleLength(heuristicPop(l),distance)
  enddo!l
  ! ...shuffle good items
  do l=genNo+1,popNo
    heuristicPop(l)%chromosome(1)=1
    heuristicPop(l)%chromosome(2:genNo)=heuristicPop(mod(l,genNo-1)+1)%chromosome(2:genNo)
    !TODO shuffling
    call spin_me_round(heuristicPop(l))
    call cycleLength(heuristicPop(l),distance)
  enddo!l
end subroutine getHeuristicSolutions

end module genetics


c===========================================================================
c
c   This file is part of TISEAN
c
c   Copyright (c) 1998-2007 Rainer Hegger, Holger Kantz, Thomas Schreiber
c
c   TISEAN is free software; you can redistribute it and/or modify
c   it under the terms of the GNU General Public License as published by
c   the Free Software Foundation; either version 2 of the License, or
c   (at your option) any later version.
c
c   TISEAN is distributed in the hope that it will be useful,
c   but WITHOUT ANY WARRANTY; without even the implied warranty of
c   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
c   GNU General Public License for more details.
c
c   You should have received a copy of the GNU General Public License
c   along with TISEAN; if not, write to the Free Software
c   Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
c
c===========================================================================
c   power spectrum of spike trains
c   author T. Schreiber (1999)
c===========================================================================
      parameter(nx=1000000)
      dimension x(nx), lx(nx), sp(nx)
      character*72 file, fout
      data iverb/1/

      call whatido("power spectrum of spike trains",iverb)
      nmaxx=ican("l",nx)
      nexcl=ican("x",0)
      jcol=ican("c",0)
      fmax=fcan("F",0)
      nfreq=min(ican("#",0),nx)
      fres=fcan("w",0)
      inter=lopt("i",1)
      isout=igetout(fout,iverb)

      do 10 ifi=1,nstrings()
         call nthstring(ifi,file)
         nmax=nmaxx
         call readfile(nmax,x,nexcl,jcol,file,iverb)
         if(inter.eq.0) goto 1
         do 20 n=2,nmax
 20         x(n)=x(n)+x(n-1)
 1       call sort(nmax,x,lx)
         if(fmax.le.0.) fmax=2*nmax/(x(nmax)-x(1))
         if(nfreq.le.0) nfreq=fmax*(x(nmax)-x(1))/2
         write(istderr(),*) "spikespec: total time covered: ",
     .      x(nmax)-x(1)
         write(istderr(),*) "spikespec: computing ", nfreq,
     .      " frequencies up to ", fmax
         do 30 n=1,nfreq
            f=(n*fmax)/nfreq
 30         sp(n)=sspect(nmax,x,f)
         ibin=nfreq*fres/2
         if(ibin.gt.0) write(istderr(),*)
     .      "spikespec: binning", 2*ibin+1," frequencies"
         if(file.eq."-") file="stdin"
         if(isout.eq.1) call addsuff(fout,file,"_ss")
         call outfile(fout,iunit,iverb)
         do 40 n=1+ibin,nfreq-ibin,2*ibin+1
            f=(n*fmax)/nfreq
            p=0
            do 50 ib=n-ibin,n+ibin
 50            p=p+sp(ib)
 40         write(iunit,*) f, p
            if(iunit.eq.istdout()) write(iunit,*)
            if(iunit.eq.istdout()) write(iunit,*)
 10      if(iunit.ne.istdout()) close(iunit)
      end

      function sspect(nmax,x,f)
      dimension x(nmax)
      data pi/3.1415926/

      omega=2*pi*f
      sr=0
      si=0
      do 10 n=1,nmax
         sr=sr+cos(omega*x(n))
 10      si=si+sin(omega*x(n))
      sspect=sr**2+si**2
      end

      subroutine usage()
c usage message

      call whatineed(
     .   "[-F# -## -w# -i -o outfile -l# -x# -c# -V# -h] file(s)")
      call popt("F","maximal frequency [2*l / total time]")
      call popt("#","number of frequencies [F* total time /2]")
      call popt("w","frequency resolution [0]")
      call popt("i","input data: intervals rather than times")
      call popt("l","number of values to be read [all]")
      call popt("x","number of values to be skipped [0]")
      call popt("c","column to be read [1 or file,#]")
      call pout("file_ss")
      call pall()
      stop
      end


 MODULE MAIN1
      INTEGER , PARAMETER :: MXGLVL = 87
      CHARACTER(8) :: SRCTYP
      REAL :: GRIDWS(MXGLVL)
      REAL :: ZI, HS
    END MODULE MAIN1

    PROGRAM TEST
      USE MAIN1
      IF (HS >= ZI) THEN
      ELSEIF (      SRCTYP == 'AREA'     &
               .OR. SRCTYP == 'AREAPOLY' &
               .OR. SRCTYP == 'AREACIRC' &
               .OR. SRCTYP == 'OPENPIT'   ) THEN
         CALL ANYAVG (MXGLVL, GRIDWS)
         CALL ANYAVG (MXGLVL, GRIDWS)
      ELSE
         IF ( HS > 0.0 ) THEN
            CALL ANYAVG (MXGLVL, GRIDWS)
            CALL ANYAVG (MXGLVL, GRIDWS)
            CALL ANYAVG (MXGLVL, GRIDWS)
         ENDIF
      ENDIF
      IF (HS.LT.ZI) THEN
         ZI = HS
      ENDIF
    contains
      SUBROUTINE ANYAVG(NLVLS,HTS)
        INTEGER NLVLS
        REAL HTS(NLVLS)
        IF (5.LT.NLVLS) THEN
           CALL GINTRP (HTS(5),HTS(5+1))
        ENDIF
        CALL GINTRP (HTS(5-1), HTS(5))
      END SUBROUTINE ANYAVG

      subroutine gintrp (x1, x2)
        print *, x1, x2
      end subroutine

    END PROGRAM TEST
! { dg-final { cleanup-modules "main1" } }


Subroutine Writeout_OMPinfo(Nk)
  Use Omp_lib
  Implicit none
  Integer, intent(in) :: Nk
  Integer :: NOMP

  !$ NOMP = omp_get_max_threads()
  !$ Write(*,'("# ++++++++++++++++++++++++++++")')
  !$ Write(*,'("# Number of OpenMP thread =",i8)')  NOMP
  !$ If (Nk < NOMP) then
  !$   Write(*,'("# CAUTION: OMP parallelization is not efficient because of Nk < NOMP.")')
  !$ End If
  !$ Write(*,'("# ++++++++++++++++++++++++++++")')

  Return
End Subroutine Writeout_OMPinfo
!==========================================================================================
Subroutine uGbk_forward_RK4(uGbk, hGGk, NG, Nocc, Nk, dt)
  Implicit none
  Complex(kind(0d0)), parameter :: zI=(0.0d0, 1.0d0)
  Integer, intent(in) :: NG, Nocc, Nk
  Double precision, intent(in) :: dt
  Complex(kind(0d0)), intent(inout) :: uGbk(1:Nk,1:Nocc,1:NG)
  Complex(kind(0d0)), intent(in) :: hGGk(1:Nk,1:NG,1:NG)
  Integer :: ik, ig, ib
  Complex(kind(0d0)) :: k1(1:Nocc,1:NG), k2(1:Nocc,1:NG), k3(1:Nocc,1:NG), k4(1:Nocc,1:NG)

  !$omp parallel
  !$omp do private(ik,k1,k2,k3,k4)
  Do ik = 1, Nk
    k1 = u_h2hu(uGbk(ik,:,:)              , hGGk(ik,:,:))/zI
    k2 = u_h2hu(uGbk(ik,:,:) + 0.5d0*dt*k1, hGGk(ik,:,:))/zI
    k3 = u_h2hu(uGbk(ik,:,:) + 0.5d0*dt*k2, hGGk(ik,:,:))/zI
    k4 = u_h2hu(uGbk(ik,:,:) + dt*k3      , hGGk(ik,:,:))/zI
    uGbk(ik,:,:) = uGbk(ik,:,:) + (k1 + 2.0d0*k2 + 2.0d0*k3 + k4)*dt/6.0d0
  End Do
  !$omp end do
  !$omp end parallel
  Return
Contains
  Function u_h2hu(u, h) result(hu)
    Implicit none
    Complex(kind(0d0)), intent(in) :: u(1:Nocc, 1:NG), h(1:NG, 1:NG)
    Complex(kind(0d0)) :: hu(1:Nocc, 1:NG)
    Integer :: i

!    hu(1:Nocc, 1:NG) = 0.d0
!    Do ig = 1,NG
!      Do ib = 1,Nocc
!        Do i = 1,NG
!          hu(ib,ig) = hu(ib,ig) + h(i,ig)*u(ib,i)
!        End Do
!      End Do
!    End Do
    hu = matmul(u,h)
  End Function u_h2hu
End Subroutine uGbk_forward_RK4
!==========================================================================================
Subroutine uGbk_forward_RK4FFT(uGbk, tGGk, vx, NG, Nocc, Nk, dt)
  Implicit none
  Complex(kind(0d0)), parameter :: zI=(0.0d0, 1.0d0)
  Integer, intent(in) :: NG, Nocc, Nk
  Double precision, intent(in) :: dt
  Complex(kind(0d0)), intent(inout) :: uGbk(1:Nk,1:Nocc,1:NG)
  Complex(kind(0d0)), intent(in) :: tGGk(1:Nk,1:NG,1:NG)
  Double precision, intent(in) :: vx(1:NG)
  Integer :: ik, ig, ib
  Complex(kind(0d0)) :: k1(1:Nocc,1:NG), k2(1:Nocc,1:NG), k3(1:Nocc,1:NG), k4(1:Nocc,1:NG)

  !$omp parallel
  !$omp do private(ik,k1,k2,k3,k4)
  Do ik = 1, Nk
    k1 = u_t_v2hu_FFT(uGbk(ik,:,:)              , tGGk(ik,:,:), vx)/zI
    k2 = u_t_v2hu_FFT(uGbk(ik,:,:) + 0.5d0*dt*k1, tGGk(ik,:,:), vx)/zI
    k3 = u_t_v2hu_FFT(uGbk(ik,:,:) + 0.5d0*dt*k2, tGGk(ik,:,:), vx)/zI
    k4 = u_t_v2hu_FFT(uGbk(ik,:,:) + dt*k3      , tGGk(ik,:,:), vx)/zI
    uGbk(ik,:,:) = uGbk(ik,:,:) + (k1 + 2.0d0*k2 + 2.0d0*k3 + k4)*dt/6.0d0
  End Do
  !$omp end do
  !$omp end parallel
  Return
Contains
  Function u_t_v2hu_FFT(u, t, vx) result(hu)
    Use, intrinsic :: iso_c_binding
    Implicit none
    Complex(kind(0d0)), intent(in) :: u(1:Nocc, 1:NG), t(1:NG, 1:NG)
    Double precision, intent(in) :: vx(1:NG)
    Complex(kind(0d0)) :: hu(1:Nocc, 1:NG), tu(1:Nocc, 1:NG), ux(1:Nocc, 1:NG), vux(1:Nocc, 1:NG), vu(1:Nocc, 1:NG)
    Integer :: i, ib
!For FFTW
    Type(C_PTR) :: planf, planb
    Complex(C_DOUBLE_COMPLEX) :: uwork(1:Nocc, 1:NG)
    Include 'fftw3.f03'

    planf = fftw_plan_dft_1d(NG, uwork(ib,:), ux(ib,:), FFTW_FORWARD, FFTW_ESTIMATE)
    planb = fftw_plan_dft_1d(NG, ux(ib,:), uwork(ib,:), FFTW_BACKWARD, FFTW_ESTIMATE)

    uwork(:,:) = u(:,:) !INTENT = IN variable can not be substituted directly in the fftw_execute_dft without clear reasons
    Do ig = 1,NG
      tu(:,ig) = t(ig,ig)*u(:,ig)
    End Do
    Do ib = 1,Nocc
      Call fftw_execute_dft(planb,uwork(ib,:),ux(ib,:)) !iFFT ux <= u
      vux(ib,:) = vx(:)*ux(ib,:)
      Call fftw_execute_dft(planf,vux(ib,:),vu(ib,:)) !FFT vux => vu
    End Do
    vu = vu/float(NG)

    hu = tu + vu
    Call fftw_destroy_plan(planf)
    Call fftw_destroy_plan(planb)
  End Function u_t_v2hu_FFT
  !==
  Function u_t_v2hu_FFT_old(u, t, vx) result(hu)
    Implicit none
    Complex(kind(0d0)), intent(in) :: u(1:Nocc, 1:NG), t(1:NG, 1:NG)
    Double precision, intent(in) :: vx(1:NG)
    Complex(kind(0d0)) :: hu(1:Nocc, 1:NG), tu(1:Nocc, 1:NG), ux(1:Nocc, 1:NG), vux(1:Nocc, 1:NG), vu(1:Nocc, 1:NG)
    Integer :: i, ib
!For FFTW
    Integer(8) :: planf, planb
    Complex(kind(0d0)) :: work1(1:NG), work2(1:NG)
    Include 'fftw3.f'

    Call dfftw_plan_dft_1d(planf, NG, work1, work2, FFTW_FORWARD, FFTW_ESTIMATE)
    Call dfftw_plan_dft_1d(planb, NG, work2, work1, FFTW_BACKWARD, FFTW_ESTIMATE)
    Do ig = 1,NG
      tu(:,ig) = t(ig,ig)*u(:,ig)
    End Do
    Do ib = 1,Nocc
      Call dfftw_execute_dft(planb,u(ib,:),ux(ib,:)) !iFFT ux <= u
      vux(ib,:) = vx(:)*ux(ib,:)
      Call dfftw_execute_dft(planf,vux(ib,:),vu(ib,:)) !FFT vux => vu
    End Do
    vu = vu/float(NG)

    hu = tu + vu
    Call dfftw_destroy_plan(planf)
    Call dfftw_destroy_plan(planb)
  End Function u_t_v2hu_FFT_old
End Subroutine uGbk_forward_RK4FFT
!==========================================================================================
Subroutine uGbk_forward_exp(uGbk, hGGk, NG, Nocc, Nk, dt)
  Implicit none
  Complex(kind(0d0)), parameter :: zI=(0.0d0, 1.0d0)
  Integer, intent(in) :: NG, Nocc, Nk
  Double precision, intent(in) :: dt
  Complex(kind(0d0)), intent(inout) :: uGbk(1:Nk,1:Nocc,1:NG)
  Complex(kind(0d0)), intent(in) :: hGGk(1:Nk,1:NG,1:NG)
  Integer :: ik, ig, ib
  Complex(kind(0d0)) :: U(1:NG,1:NG)

  !$omp parallel
  !$omp do private(ik,U)
  Do ik = 1, Nk
    U = hdt2U(hGGk(ik,:,:)*dt)
    uGbk(ik,:,:) = U_u2Uu(U, uGbk(ik,:,:))
  End Do
  !$omp end do
  !$omp end parallel
  Return
Contains
  !==
  Function hdt2U(hdt) result(U)
    Implicit none
    Complex(kind(0d0)), intent(in) :: hdt(1:NG, 1:NG)
    Complex(kind(0d0)) :: U(1:NG, 1:NG)
    Complex(kind(0d0)) :: coef(1:NG, 1:NG)
    Double precision :: eigs(1:NG)
    Integer :: i,j,k

    U = (0.d0, 0.d0)
    Call eigh(NG,transpose(hdt),eigs,coef) !Transpose is for the conversion from Row-major to Column-major
    Do i = 1,NG
      Do J = 1,NG
        Do k = 1,NG
          U(j,k) = U(j,k) + exp(-zI*eigs(i))*coef(j,i)*conjg(coef(k,i))
        End Do
      End Do
    End Do
    U = transpose(U)                      !Transpose is for the conversion from Column-major to Row-major
  End Function hdt2U
  !==
  Function U_u2Uu(Unitary, uorb) result(Unitaryuorb)
    Implicit none
    Complex(kind(0d0)), intent(in) :: uorb(1:Nocc, 1:NG), Unitary(1:NG, 1:NG)
    Complex(kind(0d0)) :: Unitaryuorb(1:Nocc, 1:NG)
    Integer :: i

!    Uu(1:Nocc, 1:NG) = 0.d0
!    Do ig = 1,NG
!      Do ib = 1,Nocc
!        Do i = 1,NG
!          Uu(ib,jg) = Uu(ib,ig) + U(i,ig)*u(ib,i)
!        End Do
!      End Do
!    End Do
    Unitaryuorb = matmul(uorb,Unitary)
  End Function U_u2Uu
End Subroutine uGbk_forward_exp
!==========================================================================================
Subroutine eigh(N,H,E,V)
  Implicit none
  Integer, intent(in) :: N
  Complex(kind(0d0)), intent(in) :: H(1:N, 1:N)
  Double precision, intent(out) :: E(1:N)
  Complex(kind(0d0)), intent(out) :: V(1:N, 1:N)
!For ZHEEV
  Integer :: LWORK_EV
  Complex(kind(0d0)) :: WORK_EV(2*(2*N-1)) !The argument is just LWORK_EV
  Double precision :: RWORK_EV(3*N - 2)
  Integer :: INFO_EV
  LWORK_EV = 2*(2*N-1)

  V = H
  Call ZHEEV('V','U',N,V,N,E,WORK_EV,LWORK_EV,RWORK_EV,INFO_EV)

  Return
End Subroutine eigh


! ==============================================================================
! constantized_storm_module
!
! Module contains routines for constructing a wind and pressure field based on
! a contant Holland based storm.
! ==============================================================================
module constant_storm_module

    implicit none
    save

    ! Holland storm type definition
    type constant_storm_type

        real(kind=8) :: ramp_up_time
        real(kind=8) :: velocity(2)
        real(kind=8) :: R_eye_init(2)
        real(kind=8) :: A
        real(kind=8) :: B
        real(kind=8) :: central_pressure
        real(kind=8) :: ambient_pressure = 101.3d3
        real(kind=8) :: rho_air = 1.3d0

    end type constant_storm_type

    logical, private, parameter :: DEBUG = .true.

contains

    ! Setup routine for the holland model
    subroutine set_constant_storm(storm_data_path, storm, log_unit)

        use geoclaw_module, only: coordinate_system

        implicit none

        ! Subroutine I/O
        character(len=*), intent(in), optional :: storm_data_path
        type(constant_storm_type), intent(in out) :: storm
        integer, intent(in) :: log_unit

        ! Local storage
        integer, parameter :: unit = 701

        ! Storm type does not work for lat-long coordinate systems
        if (coordinate_system == 2) then
            stop "Constant storm type does not work on lat-long coordinates."
        endif

        ! Open data file
        if (present(storm_data_path)) then
            call opendatafile(unit,storm_data_path)
        else
            call opendatafile(unit,'storm.data')
        endif

        ! Read in hurricane parameters
        read(unit,*) storm%ramp_up_time
        read(unit,*) storm%velocity
        read(unit,*) storm%R_eye_init
        read(unit,*) storm%A
        read(unit,*) storm%B
        read(unit,*) storm%central_pressure

        ! Output to log file
        write(log_unit,*) "Storm Data - Constant Storm"
        write(log_unit,"('Ramp Up Time = ',d16.8)") storm%ramp_up_time
        write(log_unit,"('Velocity = ',2d16.8)") storm%velocity
        write(log_unit,"('Eye initial position = ',2d16.8)") storm%R_eye_init
        write(log_unit,"('Holland parameters (A,B) =',2d16.8)") storm%A, storm%B
        write(log_unit,"('Pressures (Pn,Pc) = ',2d16.8)") storm%ambient_pressure,&
                                                        storm%central_pressure
        write(log_unit,"('Density of Air = ',d16.8)") storm%rho_air

    end subroutine set_constant_storm

    ! ==========================================================================
    !  storm_location(t,storm)
    !    Interpolate location of hurricane in the current time interval
    ! ==========================================================================
    function constant_storm_location(t,storm) result(location)

        implicit none

        ! Input
        real(kind=8), intent(in) :: t
        type(constant_storm_type), intent(in out) :: storm

        ! Output
        real(kind=8) :: location(2)

        location = t * storm%velocity + storm%R_eye_init

    end function constant_storm_location

    ! ==========================================================================
    !  storm_direction(t,storm)
    !    Interpolate location of hurricane in the current time interval
    ! ==========================================================================
    real(kind=8) function constant_storm_direction(t,storm) result(theta)

        implicit none

        ! Input
        real(kind=8), intent(in) :: t
        type(constant_storm_type), intent(in out) :: storm

        ! Locals
        real(kind=8) :: junk(2)
        theta = atan2(storm%velocity(2),storm%velocity(1))

    end function constant_storm_direction

    ! ==========================================================================
    !  set_storm_fields()
    ! ==========================================================================
    subroutine set_constant_storm_fields(maux,mbc,mx,my,xlower,ylower,dx,dy,&
                                    t,aux, wind_index, pressure_index, storm)

        use geoclaw_module, only: coriolis, coriolis_forcing

        implicit none

        ! Time of the wind field requested
        integer, intent(in) :: maux,mbc,mx,my
        real(kind=8), intent(in) :: xlower,ylower,dx,dy,t

        ! Storm description, need in out here since we may update the storm
        ! if at next time point
        type(constant_storm_type), intent(in out) :: storm

        ! Array storing wind and presure field
        integer, intent(in) :: wind_index, pressure_index
        real(kind=8), intent(inout) :: aux(maux,1-mbc:mx+mbc,1-mbc:my+mbc)

        ! Locals
        integer :: i, j
        real(kind=8) :: x, y, r, r_km, R_eye(2), f, C, w

        ! Hurrican eye location
        R_eye = constant_storm_location(t,storm)

        ! Parameter constant
        C = storm%A * storm%B * (storm%ambient_pressure - storm%central_pressure) / storm%rho_air

        f = 0.d0
        do j=1-mbc,my+mbc
            y = ylower + (j-0.5d0) * dy - R_eye(2)

            ! Coriolis term
            if (coriolis_forcing) f = coriolis(y)

            do i=1-mbc,mx+mbc
                x = xlower + (i-0.5d0) * dx - R_eye(1)
                r = sqrt(x**2+y**2)

                ! Set wind
                if (abs(r) < 1.0d-4) then
                    aux(wind_index:wind_index + 1,i,j) = 0.d0
                else
                    w = sqrt(C * exp(-storm%A / (1d-3 * r)**storm%B) / (r * 1d-3)**storm%B &
                                + (1d-3 * r * f)**2 / 4.d0) - 1d-3 * r * f / 2.d0

                    aux(wind_index,i,j) = -w * y / r
                    aux(wind_index+1,i,j) =  w * x / r
                endif

                ! Set pressure
                if (abs(r) < 10d-3) then
                    aux(pressure_index,i,j) = storm%ambient_pressure
                else
                    aux(pressure_index,i,j) = storm%central_pressure + (storm%ambient_pressure-storm%central_pressure) &
                                    * exp(-1.d3**storm%B * storm%A / abs(r)**storm%B)
                endif
            enddo
        enddo

        ! Ramp up function
        if (t < 0.d0) then
            aux(wind_index  ,:,:) = aux(wind_index  ,:,:) &
                                * exp(-(t/(storm%ramp_up_time*0.45d0))**2)
            aux(wind_index+1,:,:) = aux(wind_index+1,:,:) &
                                * exp(-(t/(storm%ramp_up_time*0.45d0))**2)
            aux(pressure_index,:,:) = storm%ambient_pressure &
                        + (aux(pressure_index,:,:) - storm%ambient_pressure) &
                        * exp(-(t/(storm%ramp_up_time*0.45d0))**2)
        endif

    end subroutine set_constant_storm_fields

end module constant_storm_module


      SUBROUTINE ZGBTRF( M, N, KL, KU, AB, LDAB, IPIV, INFO )
*
*  -- LAPACK routine (version 3.2) --
*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
*     November 2006
*
*     .. Scalar Arguments ..
      INTEGER            INFO, KL, KU, LDAB, M, N
*     ..
*     .. Array Arguments ..
      INTEGER            IPIV( * )
      COMPLEX*16         AB( LDAB, * )
*     ..
*
*  Purpose
*  =======
*
*  ZGBTRF computes an LU factorization of a complex m-by-n band matrix A
*  using partial pivoting with row interchanges.
*
*  This is the blocked version of the algorithm, calling Level 3 BLAS.
*
*  Arguments
*  =========
*
*  M       (input) INTEGER
*          The number of rows of the matrix A.  M >= 0.
*
*  N       (input) INTEGER
*          The number of columns of the matrix A.  N >= 0.
*
*  KL      (input) INTEGER
*          The number of subdiagonals within the band of A.  KL >= 0.
*
*  KU      (input) INTEGER
*          The number of superdiagonals within the band of A.  KU >= 0.
*
*  AB      (input/output) COMPLEX*16 array, dimension (LDAB,N)
*          On entry, the matrix A in band storage, in rows KL+1 to
*          2*KL+KU+1; rows 1 to KL of the array need not be set.
*          The j-th column of A is stored in the j-th column of the
*          array AB as follows:
*          AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl)
*
*          On exit, details of the factorization: U is stored as an
*          upper triangular band matrix with KL+KU superdiagonals in
*          rows 1 to KL+KU+1, and the multipliers used during the
*          factorization are stored in rows KL+KU+2 to 2*KL+KU+1.
*          See below for further details.
*
*  LDAB    (input) INTEGER
*          The leading dimension of the array AB.  LDAB >= 2*KL+KU+1.
*
*  IPIV    (output) INTEGER array, dimension (min(M,N))
*          The pivot indices; for 1 <= i <= min(M,N), row i of the
*          matrix was interchanged with row IPIV(i).
*
*  INFO    (output) INTEGER
*          = 0: successful exit
*          < 0: if INFO = -i, the i-th argument had an illegal value
*          > 0: if INFO = +i, U(i,i) is exactly zero. The factorization
*               has been completed, but the factor U is exactly
*               singular, and division by zero will occur if it is used
*               to solve a system of equations.
*
*  Further Details
*  ===============
*
*  The band storage scheme is illustrated by the following example, when
*  M = N = 6, KL = 2, KU = 1:
*
*  On entry:                       On exit:
*
*      *    *    *    +    +    +       *    *    *   u14  u25  u36
*      *    *    +    +    +    +       *    *   u13  u24  u35  u46
*      *   a12  a23  a34  a45  a56      *   u12  u23  u34  u45  u56
*     a11  a22  a33  a44  a55  a66     u11  u22  u33  u44  u55  u66
*     a21  a32  a43  a54  a65   *      m21  m32  m43  m54  m65   *
*     a31  a42  a53  a64   *    *      m31  m42  m53  m64   *    *
*
*  Array elements marked * are not used by the routine; elements marked
*  + need not be set on entry, but are required by the routine to store
*  elements of U because of fill-in resulting from the row interchanges.
*
*  =====================================================================
*
*     .. Parameters ..
      COMPLEX*16         ONE, ZERO
      PARAMETER          ( ONE = ( 1.0D+0, 0.0D+0 ),
     $                   ZERO = ( 0.0D+0, 0.0D+0 ) )
      INTEGER            NBMAX, LDWORK
      PARAMETER          ( NBMAX = 64, LDWORK = NBMAX+1 )
*     ..
*     .. Local Scalars ..
      INTEGER            I, I2, I3, II, IP, J, J2, J3, JB, JJ, JM, JP,
     $                   JU, K2, KM, KV, NB, NW
      COMPLEX*16         TEMP
*     ..
*     .. Local Arrays ..
      COMPLEX*16         WORK13( LDWORK, NBMAX ),
     $                   WORK31( LDWORK, NBMAX )
*     ..
*     .. External Functions ..
      INTEGER            ILAENV, IZAMAX
      EXTERNAL           ILAENV, IZAMAX
*     ..
*     .. External Subroutines ..
      EXTERNAL           XERBLA, ZCOPY, ZGBTF2, ZGEMM, ZGERU, ZLASWP,
     $                   ZSCAL, ZSWAP, ZTRSM
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
*     ..
*     .. Executable Statements ..
*
*     KV is the number of superdiagonals in the factor U, allowing for
*     fill-in
*
      KV = KU + KL
*
*     Test the input parameters.
*
      INFO = 0
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( KL.LT.0 ) THEN
         INFO = -3
      ELSE IF( KU.LT.0 ) THEN
         INFO = -4
      ELSE IF( LDAB.LT.KL+KV+1 ) THEN
         INFO = -6
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'ZGBTRF', -INFO )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( M.EQ.0 .OR. N.EQ.0 )
     $   RETURN
*
*     Determine the block size for this environment
*
      NB = ILAENV( 1, 'ZGBTRF', ' ', M, N, KL, KU )
*
*     The block size must not exceed the limit set by the size of the
*     local arrays WORK13 and WORK31.
*
      NB = MIN( NB, NBMAX )
*
      IF( NB.LE.1 .OR. NB.GT.KL ) THEN
*
*        Use unblocked code
*
         CALL ZGBTF2( M, N, KL, KU, AB, LDAB, IPIV, INFO )
      ELSE
*
*        Use blocked code
*
*        Zero the superdiagonal elements of the work array WORK13
*
         DO 20 J = 1, NB
            DO 10 I = 1, J - 1
               WORK13( I, J ) = ZERO
   10       CONTINUE
   20    CONTINUE
*
*        Zero the subdiagonal elements of the work array WORK31
*
         DO 40 J = 1, NB
            DO 30 I = J + 1, NB
               WORK31( I, J ) = ZERO
   30       CONTINUE
   40    CONTINUE
*
*        Gaussian elimination with partial pivoting
*
*        Set fill-in elements in columns KU+2 to KV to zero
*
         DO 60 J = KU + 2, MIN( KV, N )
            DO 50 I = KV - J + 2, KL
               AB( I, J ) = ZERO
   50       CONTINUE
   60    CONTINUE
*
*        JU is the index of the last column affected by the current
*        stage of the factorization
*
         JU = 1
*
         DO 180 J = 1, MIN( M, N ), NB
            JB = MIN( NB, MIN( M, N )-J+1 )
*
*           The active part of the matrix is partitioned
*
*              A11   A12   A13
*              A21   A22   A23
*              A31   A32   A33
*
*           Here A11, A21 and A31 denote the current block of JB columns
*           which is about to be factorized. The number of rows in the
*           partitioning are JB, I2, I3 respectively, and the numbers
*           of columns are JB, J2, J3. The superdiagonal elements of A13
*           and the subdiagonal elements of A31 lie outside the band.
*
            I2 = MIN( KL-JB, M-J-JB+1 )
            I3 = MIN( JB, M-J-KL+1 )
*
*           J2 and J3 are computed after JU has been updated.
*
*           Factorize the current block of JB columns
*
            DO 80 JJ = J, J + JB - 1
*
*              Set fill-in elements in column JJ+KV to zero
*
               IF( JJ+KV.LE.N ) THEN
                  DO 70 I = 1, KL
                     AB( I, JJ+KV ) = ZERO
   70             CONTINUE
               END IF
*
*              Find pivot and test for singularity. KM is the number of
*              subdiagonal elements in the current column.
*
               KM = MIN( KL, M-JJ )
               JP = IZAMAX( KM+1, AB( KV+1, JJ ), 1 )
               IPIV( JJ ) = JP + JJ - J
               IF( AB( KV+JP, JJ ).NE.ZERO ) THEN
                  JU = MAX( JU, MIN( JJ+KU+JP-1, N ) )
                  IF( JP.NE.1 ) THEN
*
*                    Apply interchange to columns J to J+JB-1
*
                     IF( JP+JJ-1.LT.J+KL ) THEN
*
                        CALL ZSWAP( JB, AB( KV+1+JJ-J, J ), LDAB-1,
     $                              AB( KV+JP+JJ-J, J ), LDAB-1 )
                     ELSE
*
*                       The interchange affects columns J to JJ-1 of A31
*                       which are stored in the work array WORK31
*
                        CALL ZSWAP( JJ-J, AB( KV+1+JJ-J, J ), LDAB-1,
     $                              WORK31( JP+JJ-J-KL, 1 ), LDWORK )
                        CALL ZSWAP( J+JB-JJ, AB( KV+1, JJ ), LDAB-1,
     $                              AB( KV+JP, JJ ), LDAB-1 )
                     END IF
                  END IF
*
*                 Compute multipliers
*
                  CALL ZSCAL( KM, ONE / AB( KV+1, JJ ), AB( KV+2, JJ ),
     $                        1 )
*
*                 Update trailing submatrix within the band and within
*                 the current block. JM is the index of the last column
*                 which needs to be updated.
*
                  JM = MIN( JU, J+JB-1 )
                  IF( JM.GT.JJ )
     $               CALL ZGERU( KM, JM-JJ, -ONE, AB( KV+2, JJ ), 1,
     $                           AB( KV, JJ+1 ), LDAB-1,
     $                           AB( KV+1, JJ+1 ), LDAB-1 )
               ELSE
*
*                 If pivot is zero, set INFO to the index of the pivot
*                 unless a zero pivot has already been found.
*
                  IF( INFO.EQ.0 )
     $               INFO = JJ
               END IF
*
*              Copy current column of A31 into the work array WORK31
*
               NW = MIN( JJ-J+1, I3 )
               IF( NW.GT.0 )
     $            CALL ZCOPY( NW, AB( KV+KL+1-JJ+J, JJ ), 1,
     $                        WORK31( 1, JJ-J+1 ), 1 )
   80       CONTINUE
            IF( J+JB.LE.N ) THEN
*
*              Apply the row interchanges to the other blocks.
*
               J2 = MIN( JU-J+1, KV ) - JB
               J3 = MAX( 0, JU-J-KV+1 )
*
*              Use ZLASWP to apply the row interchanges to A12, A22, and
*              A32.
*
               CALL ZLASWP( J2, AB( KV+1-JB, J+JB ), LDAB-1, 1, JB,
     $                      IPIV( J ), 1 )
*
*              Adjust the pivot indices.
*
               DO 90 I = J, J + JB - 1
                  IPIV( I ) = IPIV( I ) + J - 1
   90          CONTINUE
*
*              Apply the row interchanges to A13, A23, and A33
*              columnwise.
*
               K2 = J - 1 + JB + J2
               DO 110 I = 1, J3
                  JJ = K2 + I
                  DO 100 II = J + I - 1, J + JB - 1
                     IP = IPIV( II )
                     IF( IP.NE.II ) THEN
                        TEMP = AB( KV+1+II-JJ, JJ )
                        AB( KV+1+II-JJ, JJ ) = AB( KV+1+IP-JJ, JJ )
                        AB( KV+1+IP-JJ, JJ ) = TEMP
                     END IF
  100             CONTINUE
  110          CONTINUE
*
*              Update the relevant part of the trailing submatrix
*
               IF( J2.GT.0 ) THEN
*
*                 Update A12
*
                  CALL ZTRSM( 'Left', 'Lower', 'No transpose', 'Unit',
     $                        JB, J2, ONE, AB( KV+1, J ), LDAB-1,
     $                        AB( KV+1-JB, J+JB ), LDAB-1 )
*
                  IF( I2.GT.0 ) THEN
*
*                    Update A22
*
                     CALL ZGEMM( 'No transpose', 'No transpose', I2, J2,
     $                           JB, -ONE, AB( KV+1+JB, J ), LDAB-1,
     $                           AB( KV+1-JB, J+JB ), LDAB-1, ONE,
     $                           AB( KV+1, J+JB ), LDAB-1 )
                  END IF
*
                  IF( I3.GT.0 ) THEN
*
*                    Update A32
*
                     CALL ZGEMM( 'No transpose', 'No transpose', I3, J2,
     $                           JB, -ONE, WORK31, LDWORK,
     $                           AB( KV+1-JB, J+JB ), LDAB-1, ONE,
     $                           AB( KV+KL+1-JB, J+JB ), LDAB-1 )
                  END IF
               END IF
*
               IF( J3.GT.0 ) THEN
*
*                 Copy the lower triangle of A13 into the work array
*                 WORK13
*
                  DO 130 JJ = 1, J3
                     DO 120 II = JJ, JB
                        WORK13( II, JJ ) = AB( II-JJ+1, JJ+J+KV-1 )
  120                CONTINUE
  130             CONTINUE
*
*                 Update A13 in the work array
*
                  CALL ZTRSM( 'Left', 'Lower', 'No transpose', 'Unit',
     $                        JB, J3, ONE, AB( KV+1, J ), LDAB-1,
     $                        WORK13, LDWORK )
*
                  IF( I2.GT.0 ) THEN
*
*                    Update A23
*
                     CALL ZGEMM( 'No transpose', 'No transpose', I2, J3,
     $                           JB, -ONE, AB( KV+1+JB, J ), LDAB-1,
     $                           WORK13, LDWORK, ONE, AB( 1+JB, J+KV ),
     $                           LDAB-1 )
                  END IF
*
                  IF( I3.GT.0 ) THEN
*
*                    Update A33
*
                     CALL ZGEMM( 'No transpose', 'No transpose', I3, J3,
     $                           JB, -ONE, WORK31, LDWORK, WORK13,
     $                           LDWORK, ONE, AB( 1+KL, J+KV ), LDAB-1 )
                  END IF
*
*                 Copy the lower triangle of A13 back into place
*
                  DO 150 JJ = 1, J3
                     DO 140 II = JJ, JB
                        AB( II-JJ+1, JJ+J+KV-1 ) = WORK13( II, JJ )
  140                CONTINUE
  150             CONTINUE
               END IF
            ELSE
*
*              Adjust the pivot indices.
*
               DO 160 I = J, J + JB - 1
                  IPIV( I ) = IPIV( I ) + J - 1
  160          CONTINUE
            END IF
*
*           Partially undo the interchanges in the current block to
*           restore the upper triangular form of A31 and copy the upper
*           triangle of A31 back into place
*
            DO 170 JJ = J + JB - 1, J, -1
               JP = IPIV( JJ ) - JJ + 1
               IF( JP.NE.1 ) THEN
*
*                 Apply interchange to columns J to JJ-1
*
                  IF( JP+JJ-1.LT.J+KL ) THEN
*
*                    The interchange does not affect A31
*
                     CALL ZSWAP( JJ-J, AB( KV+1+JJ-J, J ), LDAB-1,
     $                           AB( KV+JP+JJ-J, J ), LDAB-1 )
                  ELSE
*
*                    The interchange does affect A31
*
                     CALL ZSWAP( JJ-J, AB( KV+1+JJ-J, J ), LDAB-1,
     $                           WORK31( JP+JJ-J-KL, 1 ), LDWORK )
                  END IF
               END IF
*
*              Copy the current column of A31 back into place
*
               NW = MIN( I3, JJ-J+1 )
               IF( NW.GT.0 )
     $            CALL ZCOPY( NW, WORK31( 1, JJ-J+1 ), 1,
     $                        AB( KV+KL+1-JJ+J, JJ ), 1 )
  170       CONTINUE
  180    CONTINUE
      END IF
*
      RETURN
*
*     End of ZGBTRF
*
      END


c { dg-do compile }
* fixed by patch to safe_from_p to avoid visiting any SAVE_EXPR
* node twice in a given top-level call to it.
* (JCB com.c patch of 1998-06-04.)

      SUBROUTINE TSTSIG11
      IMPLICIT COMPLEX (A-Z)
      EXTERNAL gzi1,gzi2
      branch3 =  sw2 / cw
     .     * (  rdw * (epsh*gzi1(A,B)-gzi2(A,B))
     .     + rdw * (epsh*gzi1(A,B)-gzi2(A,B)) )
     .     + (-1./2. + 2.*sw2/3.) / (sw*cw)
     .     * rdw * (epsh*gzi1(A,B)-gzi2(A,B)
     .     + rdw * (epsh*gzi1(A,B)-gzi2(A,B))
     .     + rdw * (epsh*gzi1(A,B)-gzi2(A,B)) )
     .     * rup * (epsh*gzi1(A,B)-gzi2(A,B)
     .     + rup * (epsh*gzi1(A,B)-gzi2(A,B)) )
     .     * 4.*(3.-tw**2) * gzi2(A,B)
     .     + ((1.+2./tauw)*tw**2-(5.+2./tauw))* gzi1(A,B)
      RETURN
      END


Module Mod_sup_ComputeTidivVE
contains
   subroutine sup_ComputeTidivVE(e,timom,staco,chale,tidiv)

      use typre
      use Mod_Element
      implicit none
      class(FiniteElement) :: e
      real(rp),    intent(in)    :: staco(4)
      real(rp),    intent(in)    :: timom,chale(2)
      real(rp),    intent(out)   :: tidiv

      real(rp)                   :: freq1 !,freto,freq2 ! for the viscoelastic case

      ! Characteristic velocity
      freq1 = (1.0_rp*chale(2)*chale(2)/staco(1))/e%npol4
      !initialization
      tidiv=0.0_rp

      !Compute the stability parameter
      tidiv=freq1/timom

   end subroutine

end module


!----------------------------------------------------------------------
!----------------------------------------------------------------------
! r3b : The Restricted 3-Body Problem
!----------------------------------------------------------------------
!----------------------------------------------------------------------

 SUBROUTINE FUNC(NDIM,U,ICP,PAR,IJAC,F,DFDU,DFDP)
!---------- ----

   IMPLICIT NONE
   INTEGER, INTENT(IN) :: NDIM, IJAC, ICP(*)
   DOUBLE PRECISION, INTENT(IN) :: U(NDIM), PAR(*)
   DOUBLE PRECISION, INTENT(OUT) :: F(NDIM), DFDU(NDIM,*), DFDP(NDIM,*)

   DOUBLE PRECISION x,y,z,xp,yp,zp
   DOUBLE PRECISION rl,rmu,dE,dM,rmc,dE3,dM3,dE5,dM5
   DOUBLE PRECISION dEx,dEy,dEz,cx,cy,cz,dx,dy,dz,ex,ey,ez,vx,vy,vz
   DOUBLE PRECISION vxp,vyp,vzp,dMx,dMy,dMz

! Define the RHS of the dynamical system
   x  = U(1)
   y  = U(2)
   z  = U(3)
   xp = U(4)
   yp = U(5)
   zp = U(6)

   rl  = PAR(1)
   rmu = PAR(2)

   dE = SQRT((x+rmu)**2 + y**2 + z**2)
   dM = SQRT( (x-1+rmu)**2 + y**2 + z**2 )
   rmc = 1 - rmu
   dE3 = 1/dE**3
   dM3 = 1/dM**3
   dE5 = 1/dE**5
   dM5 = 1/dM**5

   F(1) =  xp
   F(2) =  yp
   F(3) =  zp
   F(4) =  2*yp + x - rmc*dE3*(x+rmu) - rmu*dM3*(x-1+rmu)
   F(5) = -2*xp + y - rmc*dE3*y - rmu*dM3*y
   F(6) = -rmc*dE3*z - rmu*dM3*z

   F(4:6) = F(4:6) + rl*F(1:3)

! Set up the linearized equations
   dEx = -3*(x+rmu)*dE5
   dEy = -3*y*dE5
   dEz = -3*z*dE5

   dMx = -3*(x-1+rmu)*dM5
   dMy = -3*y*dM5
   dMz = -3*z*dM5

   cx = 1 - rmc*dE3 - rmc*(x+rmu)*dEx - rmu*dM3 - rmu*(x-1+rmu)*dMx
   cy = -rmc*(x+rmu)*dEy - rmu*(x-1+rmu)*dMy
   cz = -rmc*(x+rmu)*dEz - rmu*(x-1+rmu)*dMz

   dx = -rmc*y*dEx - rmu*y*dMx
   dy = 1 - rmc*dE3 - rmc*y*dEy - rmu*dM3 - rmu*y*dMy
   dz = -rmc*y*dEz - rmu*y*dMz

   ex = -rmc*z*dEx - rmu*z*dMx
   ey = -rmc*z*dEy - rmu*z*dMy
   ez = -rmc*dE3 - rmc*z*dEz - rmu*dM3 - rmu*z*dMz

   vx = U(7)
   vy = U(8)
   vz = U(9)
   vxp= U(10)
   vyp= U(11)
   vzp= U(12)

   F(7) = vxp
   F(8) = vyp
   F(9) = vzp
   F(10)= cx*vx + cy*vy + cz*vz + 2*vyp
   F(11)= dx*vx + dy*vy + dz*vz - 2*vxp
   F(12)= ex*vx + ey*vy + ez*vz

! Scale
   F = F * PAR(11)

 END SUBROUTINE FUNC
!----------------------------------------------------------------------

 SUBROUTINE BCND(NDIM,PAR,ICP,NBC,U0,U1,FB,IJAC,DBC)
!---------- ----

   IMPLICIT NONE
   INTEGER, INTENT(IN) :: NDIM, ICP(*), NBC, IJAC
   DOUBLE PRECISION, INTENT(IN) :: PAR(*), U0(NDIM), U1(NDIM)
   DOUBLE PRECISION, INTENT(OUT) :: FB(NBC), DBC(NBC,*)

   DOUBLE PRECISION fm

! Periodicity boundary conditions
   FB(1:6) = U0(1:6) - U1(1:6)

! Floquet eigenvalue/vector boundary relation
   fm = PAR(4)
   FB(7:12) = U1(7:12) - fm*U0(7:12)

 END SUBROUTINE BCND
!----------------------------------------------------------------------

 SUBROUTINE ICND(NDIM,PAR,ICP,NINT,U,UOLD,UDOT,UPOLD,FI,IJAC,DINT)
!---------- ----

   IMPLICIT NONE
   INTEGER, INTENT(IN) :: NDIM, ICP(*), NINT, IJAC
   DOUBLE PRECISION, INTENT(IN) :: PAR(*)
   DOUBLE PRECISION, INTENT(IN) :: U(NDIM), UOLD(NDIM), UDOT(NDIM), UPOLD(NDIM)
   DOUBLE PRECISION, INTENT(OUT) :: FI(NINT), DINT(NINT,*)

! Integral phase condition
   FI(1) = DOT_PRODUCT(U(1:6),UPOLD(1:6))

! Integral Floquet eigenfunction normalization
   FI(2) = -PAR(5)+DOT_PRODUCT(U(7:12),U(7:12))

 END SUBROUTINE ICND
!----------------------------------------------------------------------

 SUBROUTINE PVLS(NDIM,U,PAR)
!---------- ----

   IMPLICIT NONE
   INTEGER, INTENT(IN) :: NDIM
   DOUBLE PRECISION, INTENT(IN) :: U(NDIM)
   DOUBLE PRECISION, INTENT(INOUT) :: PAR(*)

   DOUBLE PRECISION GETP,rmu,x,y,z,xp,yp,zp,d1,d2,PE,En

   rmu = PAR(2)

   x = GETP("BV0", 1, U)
   y = GETP("BV0", 2, U)
   z = GETP("BV0", 3, U)
   xp= GETP("BV0", 4, U)
   yp= GETP("BV0", 5, U)
   zp= GETP("BV0", 6, U)

   d1 = SQRT((x+rmu)**2 + y**2 + z**2)
   d2 = SQRT( (x-1+rmu)**2 + y**2 + z**2 )

   PE = (x**2 + y**2)/2 + (1-rmu)/d1 + rmu/d2
   En = (xp**2 + yp**2 + zp**2)/2 - PE - rmu*(1-rmu)/2
   PAR(3) = En

 END SUBROUTINE PVLS
!----------------------------------------------------------------------
 SUBROUTINE STPNT
 END SUBROUTINE STPNT
!----------------------------------------------------------------------
 SUBROUTINE FOPT
 END SUBROUTINE FOPT
!----------------------------------------------------------------------
!----------------------------------------------------------------------


submodule (real_transform_routines:multiple_real_forward) real_forward_2d

contains

    module subroutine rfft2f(ldim, l, m, r, wsave, lensav, work, lenwrk, ierror)
        !
        ! rfft2f: real forward fast fourier transform, 2d.
        !
        ! purpose:
        !
        !  rfft2f computes the two-dimensional discrete fourier transform of a
        !  real periodic array.  this transform is known as the forward transform
        !  or fourier analysis, transforming from physical to spectral space.
        !  routine rfft2f is normalized: a call to rfft2f followed by a call to
        !  rfft2b (or vice-versa) reproduces the original array within roundoff
        !  error.
        !
        !  parameters:
        !
        !  integer ldim, the first dimension of the 2d real
        !  array r, which must be at least 2*(l/2+1).
        !
        !  integer l, the number of elements to be transformed
        !  in the first dimension of the two-dimensional real array r.  the value
        !  of l must be less than or equal to that of ldim.  the transform is most
        !  efficient when l is a product of small primes.
        !
        !  integer m, the number of elements to be transformed
        !  in the second dimension of the two-dimensional real array r.  the
        !  transform is most efficient when m is a product of small primes.
        !
        !  input/real r(ldim,m), the real array of two
        !  dimensions.  on input, containing the l-by-m physical data to be
        !  transformed.  on output, the spectral coefficients.
        !
        !  input, real (wp) wsave(lensav).  wsave's contents must be
        !  initialized with a call to rfft2i before the first call to routine rfft2f
        !  or rfft2b with lengths l and m.  wsave's contents may be re-used for
        !  subsequent calls to rfft2f and rfft2b with the same transform lengths.
        !
        !  integer lensav, the number of elements in the wsave
        !  array.  lensav must be at least l + m + int(log(real(l)))
        !  + int(log(real(m))) + 8.
        !
        !  workspace, real (wp) work(lenwrk), provides workspace, and its
        !  contents need not be saved between calls to routines rfft2f and rfft2b.
        !
        !  integer lenwrk, the number of elements in the work
        !  array.  lenwrk must be at least ldim*m.
        !
        !  integer ierror, the error_flag.
        !  0, successful exit;
        !  2, input parameter lensav not big enough;
        !  3, input parameter lenwrk not big enough;
        !  6, input parameter ldim < 2*(l+1);
        !  20, input error returned by lower level routine.
        !
        !--------------------------------------------------------------
        ! Dummy arguments
        !--------------------------------------------------------------
        integer (ip), intent (in)     :: ldim
        integer (ip), intent (in)     :: l
        integer (ip), intent (in)     :: m
        real (wp),    intent (in out) :: r(ldim,m)
        real (wp),    intent (in)     :: wsave(lensav)
        integer (ip), intent (in)     :: lensav
        real (wp),    intent (out)    :: work(lenwrk)
        integer (ip), intent (in)     :: lenwrk
        integer (ip), intent (out)    :: ierror
        !--------------------------------------------------------------
        ! Local variables
        !--------------------------------------------------------------
        integer (ip) :: local_error_flag
        integer (ip) :: ldh, ldw, ldx, lwsav
        integer (ip) :: mmsav, modl, modm, mwsav
        !--------------------------------------------------------------

        ! initialize error flag
        ierror = 0
        !
        !==> verify lensav
        !
        lwsav = l+int(log(real (l, kind=wp))/log(TWO))+4
        mwsav = get_1d_saved_workspace_length(m)
        mmsav = m+int(log(real(m, kind=wp))/log(TWO))+4

        if (lensav < lwsav+mwsav+mmsav) then
            ierror = 2
            call fft_error_handler('rfft2f', 6)
            return
        end if
        !
        !==>  verify lenwrk
        !
        if (lenwrk < (l+1)*m) then
            ierror = 3
            call fft_error_handler('rfft2f', 8)
            return
        end if
        !
        !==>  verify ldim is as big as l
        !
        if (ldim < l) then
            ierror = 5
            call fft_error_handler('rfft2f', -6)
            return
        end if
        !
        !==>  Transform first dimension of array
        !
        associate( &
            arg_1 => m*ldim, &
            arg_2 => l+int(log(real(l, kind=wp))/log(TWO))+4 &
            )

            call rfftmf(m,ldim,l,1,r,arg_1,wsave(1), arg_2,work,size(work),local_error_flag)

        end associate

        if (local_error_flag /= 0) then
            ierror = 20
            call fft_error_handler('rfft2f',-5)
            return
        end if

        ldx = 2*int((l+1)/2)-1

        r(2:ldx,1:m) = HALF * r(2:ldx,1:m)

        r(3:ldx:2,1:m) = -r(3:ldx:2,1:m)

        !==>  Reshuffle to add in nyquist imaginary components
        !
        modl = mod(l,2)
        modm = mod(m,2)
        !
        !==>  Transform second dimension of array
        !
        call rfftmf(1,1,m,ldim,r,m*ldim, &
            wsave(lwsav+mwsav+1),mmsav,work,size(work),local_error_flag)

        associate( mj => 2*((m+1)/2)-1 )

            r(1,2:mj) = HALF * r(1,2:mj)

        end associate

        r(1,3:m:2) = -r(1,3:m:2)

        ldh = int((l+1)/2)

        if ( 1 < ldh ) then
            ldw = 2*ldh
            !
            !==> r and work are switched because the the first dimension
            !    of the input to complex cfftmf must be even.
            !
            call r2w(ldim,ldw,l,m,r,work)
            call cfftmf(ldh-1,1,m,ldh,work(2),ldh*m, &
                wsave(lwsav+1),mwsav,r,l*m, local_error_flag)

            if (local_error_flag /= 0) then
                ierror = 20
                call fft_error_handler('rfft2f',-5)
                return
            end if

            call w2r(ldim,ldw,l,m,r,work)
        end if

        if (modl == 0) then

            call rfftmf(1, 1, m, ldim, r(l,1), m*ldim, wsave(lwsav+mwsav+1), &
                mmsav, work, size(work), local_error_flag)

            associate( mj => 2*((m+1)/2)-1 )

                r(l,2:mj) = HALF * r(l,2:mj)

            end associate

            r(l,3:m:2) = -r(l,3:m:2)

        end if

        if (local_error_flag /= 0) then
            ierror = 20
            call fft_error_handler('rfft2f',-5)
        end if

    end subroutine rfft2f

end submodule real_forward_2d


      DOUBLE PRECISION FUNCTION rcomp(a,x)
C     -------------------
C     EVALUATION OF EXP(-X)*X**A/GAMMA(A)
C     -------------------
C     RT2PIN = 1/SQRT(2*PI)
C     -------------------
C     .. Scalar Arguments ..
      DOUBLE PRECISION a,x
C     ..
C     .. Local Scalars ..
      DOUBLE PRECISION rt2pin,t,t1,u
C     ..
C     .. External Functions ..
      DOUBLE PRECISION gam1,gamma,rlog
      EXTERNAL gam1,gamma,rlog
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC dlog,exp,sqrt
C     ..
C     .. Data statements ..
      DATA rt2pin/.398942280401433D0/
C     ..
C     .. Executable Statements ..
C     -------------------
      rcomp = 0.0D0
      IF (a.GE.20.0D0) GO TO 20
      t = a*dlog(x) - x
      IF (a.GE.1.0D0) GO TO 10
      rcomp = (a*exp(t))* (1.0D0+gam1(a))
      RETURN

   10 rcomp = exp(t)/gamma(a)
      RETURN
C
   20 u = x/a
      IF (u.EQ.0.0D0) RETURN
      t = (1.0D0/a)**2
      t1 = (((0.75D0*t-1.0D0)*t+3.5D0)*t-105.0D0)/ (a*1260.0D0)
      t1 = t1 - a*rlog(u)
      rcomp = rt2pin*sqrt(a)*exp(t1)
      RETURN

      END


!	negative hessian of log conditional probability of an observation.
!	rbetamap is the reduced beta map
!	mask indicates the items presented.
!	condprobcat contains conditional item probabilities.
!	covth is the covariance matrix of the latent vector.
!	cubth provides covariances of products of latent vector elements and of latent vector elements.
!	probcat contains item probabilities.
!	quarth provides covariances of products of latent vector elements.
!	theta is the latent vector.
!	thpr is the independent vector.

function nhessvec(rbetamap,mask,condprobcat,covth,cubth,newtheta,probcat,quarth,theta,thpr)

implicit none
integer,intent(in)::rbetamap(:,:)
logical,intent(in)::mask(:)
real(kind=8),intent(in)::condprobcat(:),covth(:,:),cubth(:,:,:),newtheta(:),probcat(:),quarth(:,:,:,:),theta(:),thpr(:)
real(kind=8)::nhessvec(size(rbetamap,2),size(rbetamap,2))

!	col is a column.
!	row is a row,
integer::row,col

nhessvec=0.0_8
do row=1,size(rbetamap,2)
	do col=1,row

		if(rbetamap(1,row)>0)then
			if(mask(rbetamap(1,row)))then
				if(rbetamap(1,row)==rbetamap(1,col))then
!	Intercepts.
					nhessvec(row, col)=condprobcat(rbetamap(2,row))*condprobcat(rbetamap(2,col))&
						-probcat(rbetamap(2,row))*probcat(rbetamap(2,col))

					if(rbetamap(2,row)==rbetamap(2,col))nhessvec(row,col)=&
						nhessvec(row,col)+probcat(rbetamap(2,row))-condprobcat(rbetamap(2,row))
					if(rbetamap(3,row)>0)then
!	Slope and intercept
						nhessvec(row,col)=newtheta(rbetamap(3,row))*&
							nhessvec(row,col)
					end if
!	Slope and slope
					if(rbetamap(3,col)>0)then
						nhessvec(row, col)=newtheta(rbetamap(3,col))*nhessvec(row,col)
					end if
				end if
			end if
		else
			if(rbetamap(4,row)==0)then
!	Linear and linear
				if(rbetamap(1,col)==0)then
					nhessvec(row,col)=thpr(rbetamap(5,row))*thpr(rbetamap(5,col))*&
						covth(rbetamap(3,row),rbetamap(3,col))
				end if
			else
				if(rbetamap(1,col)==0)then
					if(rbetamap(4,col)==0)then
!	Quadratic by linear
						nhessvec(row,col)=thpr(rbetamap(5,row))*thpr(rbetamap(5,col))*&
							cubth(rbetamap(3,row),rbetamap(4,row),rbetamap(3,col))
					else
!	Quadratic by quadratic
						nhessvec(row,col)=thpr(rbetamap(5,row))*thpr(rbetamap(5,col))*&
							quarth(rbetamap(3,row),rbetamap(4,row),rbetamap(3,col),rbetamap(4,col))
					end if
				end if
			end if
		end if
	end do
end do
return
end function nhessvec


C$Procedure   ZZEPRCSS   ( Earth precession, 1976 IAU model )

      SUBROUTINE ZZEPRCSS ( ET, PRECM )
      IMPLICIT NONE

C$ Abstract
C
C     Return the 1976 IAU Earth precession matrix for a specified time.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     ROTATION
C
C$ Keywords
C
C     FRAMES
C     GEOMETRY
C     MATRIX
C     TRANSFORMATION
C
C$ Declarations

      DOUBLE PRECISION      ET
      DOUBLE PRECISION      PRECM ( 3, 3 )

C$ Brief_I/O
C
C     Variable  I/O  Description
C     --------  ---  --------------------------------------------------
C     ET         I   Ephemeris time, in seconds past J2000.
C     PRECM      O   Precession matrix at ET.
C
C$ Detailed_Input
C
C     ET             is the epoch at which the precession matrix is
C                    to be computed.  ET is barycentric dynamical time,
C                    expressed as seconds past J2000.
C
C$ Detailed_Output
C
C     PRECM          is a 3x3 matrix representing the precession of
C                    the Earth from J2000 to the epoch ET.  The
C                    rows of PRECM are the basis vectors for the Earth
C                    mean equator and equinox frame of date, evaluated
C                    at ET.
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     Error free.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     According to reference [2], the precession model used in this
C     routine is that used in the JPL navigation program "Regres."
C
C     The precession matrix is defined using the Euler angles
C
C        zeta ,   z ,  and theta
C            A     A            A
C
C
C     Equation (5-147) of [2] gives the matrix determined by these
C     angles as
C
C        A  =  [ -z   ]   [ theta  ]   [ -zeta  ]
C                  A   3         A  2         A  3
C
C
C     Formulas for the Euler angles are from [2], equation
C     (5-143):
C                                              2                3
C         zeta   =  2306".2181*T  +  0".30188*T   +  0".017998*T
C             A
C
C
C                                              2                3
C         z      =  2306".2181*T  +  1".09468*T   +  0".018203*T
C          A
C
C
C                                              2                3
C         theta  =  2004".3109*T  -  0".42665*T   -  0".041833*T
C              A
C
C$ Examples
C
C     1) Convert a vector V from J2000 to Earth Mean equator and equinox
C        of date coordinates at epoch ET.  Call the resulting vector
C        VMOD.
C
C           CALL ZZEPRCSS ( ET,    PRECM       )
C           CALL MXV      ( PRECM, V,     VMOD )
C
C$ Restrictions
C
C     1)  This is a preliminary version of the routine.
C
C     2)  Though reference [1] does not specify limitations on the
C         range of valid time inputs for this precession model, the
C         fact that the rotation angles used in the model are defined
C         by polynomials implies that the model is not valid for all
C         time.
C
C$ Literature_References
C
C     [1] "Explanatory Supplement to the Astronomical Almanac"
C          edited by P. Kenneth Seidelmann. University Science
C          Books, 20 Edgehill Road, Mill Valley, CA 94941 (1992)
C
C     [2] "Section 5, Geocentric Space-Fixed Position, Velocity, and
C         Acceleration Vectors of Tracking Station" by T. D. Moyer.
C         Draft of JPL Publication documenting the JPL navigation
C         program "Regres."
C
C
C$ Author_and_Institution
C
C     N.J. Bachman       (JPL)
C
C$ Version
C
C-    Beta Version 1.0.0, 24-SEP-1996 (NJB)
C
C-&

C$ Index_Entries
C
C     Earth precession matrix based on 1976 IAU model
C
C-&

C
C     SPICELIB functions
C
      DOUBLE PRECISION      JYEAR
      DOUBLE PRECISION      RPD

C
C     Local parameters
C
      DOUBLE PRECISION      ZETA1
      PARAMETER           ( ZETA1  = 2306.2181D0 )

      DOUBLE PRECISION      ZETA2
      PARAMETER           ( ZETA2  = 0.30188D0   )

      DOUBLE PRECISION      ZETA3
      PARAMETER           ( ZETA3  = 0.017998D0  )

      DOUBLE PRECISION      Z1
      PARAMETER           ( Z1     = 2306.2181D0 )

      DOUBLE PRECISION      Z2
      PARAMETER           ( Z2     = 1.09468D0   )

      DOUBLE PRECISION      Z3
      PARAMETER           ( Z3     = 0.018203D0  )

      DOUBLE PRECISION      THETA1
      PARAMETER           ( THETA1 = 2004.3109D0 )

      DOUBLE PRECISION      THETA2
      PARAMETER           ( THETA2 = -0.42665D0 )

      DOUBLE PRECISION      THETA3
      PARAMETER           ( THETA3 = -0.041833D0 )

C
C     Local variables
C
      DOUBLE PRECISION      SCALE
      DOUBLE PRECISION      T
      DOUBLE PRECISION      ZETA
      DOUBLE PRECISION      Z
      DOUBLE PRECISION      THETA

C
C     No check-in required; this routine does not participate in
C     SPICELIB error handling.
C
C
C     Compute the precession angles first.  The time argument has
C     units of Julian centuries.  The polynomial expressions yield
C     angles in units of arcseconds prior to scaling.  After scaling,
C     the angles are in units of radians.
C
      T      =  ET    / ( JYEAR() * 100.D0 )
      SCALE  =  RPD() / 3600.D0

      ZETA   =  T  * (  ZETA1  + T*( ZETA2  + T*ZETA3  )  ) * SCALE
      Z      =  T  * (  Z1     + T*( Z2     + T*Z3     )  ) * SCALE
      THETA  =  T  * (  THETA1 + T*( THETA2 + T*THETA3 )  ) * SCALE

C
C     Now compute the precession matrix.
C
      CALL EUL2M  ( -Z, THETA, -ZETA, 3, 2, 3, PRECM )

      END


program main

  use DataInputM
  use Thermal2DApplicationM
  use ThermalStrategyM
  use SolvingStrategyM
  use GIDDataOutputM

  implicit none

  type(Thermal2DApplicationDT)   :: application
  type(ThermalStrategyDT)        :: strategy
  type(SolvingStrategyDT)        :: solvingStrategy

  call initFEM2D(application)
  solvingStrategy = InitSolvingStrategy(strategy, application%model)
  call solvingStrategy%useStrategy()
  call initDataOutput()
  call printResults(resultName = 'Temperature'       &
       , step         = 1                            &
       , graphType    = 'Scalar'                     &
       , locationName = 'onNodes'                    &
       , resultNumber = application%model%getnNode()  &
       , component1   = application%model%dof         )
  call printResults(resultName = 'FluxOnTriangs'                     &
       , type         = 'Triangle'                                   &
       , step         = 1                                            &
       , graphType    = 'Vector'                                     &
       , locationName = 'onGaussPoints'                              &
       , gaussPoints  = application%model%heatFlux%triangGPoint       &
       , resultNumber = size(application%model%heatFlux%triangElemID) &
       , elemID       = application%model%heatFlux%triangElemID       &
       , component1   = application%model%heatFlux%triangFlux(:,1)    &
       , component2   = application%model%heatFlux%triangFlux(:,2)    )
  call printResults(resultName = 'FluxOnQuads'                      &
       , type         = 'Quadrilateral'                             &
       , step         = 1                                           &
       , graphType    = 'Vector'                                    &
       , locationName = 'onGaussPoints'                             &
       , gaussPoints  = application%model%heatFlux%quadGPoint        &
       , resultNumber = size(application%model%heatFlux%quadElemID)  &
       , elemID       = application%model%heatFlux%quadElemID        &
       , component1   = application%model%heatFlux%quadFlux(:,1)     &
       , component2   = application%model%heatFlux%quadFlux(:,2)    )

end program main


! Copyright (c) 2012, Johannes Feist
! licensed under the MIT open source license, see LICENSE file

!> conversion factors for various units to/from atomic units
!> based on the 2012-10-28 CODATA values from physics.nist.gov/constants
module atomic_units
  use nrtype
  !> t [a.u.] = t [attoseconds] * au_as
  real(dp), parameter :: au_as   = 1.d0/24.18884326211233d0

  !> EF [a.u.] = sqrt(I [W/cm2] * au_Wcm2toEL2),

  !> i.e. convert from intensity in W/cm2 to peak electric field squared in a.u.
  real(dp), parameter :: au_Wcm2toEL2 = 1.d0/3.5094452159384d16

  !> I [a.u.] = I [W/cm2] * au_Wcm2
  real(dp), parameter :: au_Wcm2 = 1.d0/6.436409342904736d15

  !> x [a.u.] = x [cm] * au_cm
  real(dp), parameter :: au_cm   = 1.d0/5.2917721092d-9

  !> x [a.u.] = x [nm] * au_nm
  real(dp), parameter :: au_nm   = 1.d0/5.2917721092d-2

  !> speed of light in a.u. == 1/alpha
  real(dp), parameter :: au_c    = 137.035999074

  !> E [a.u.] = E [eV] * au_eV (in Hartree atomic units)
  real(dp), parameter :: au_eV   = 1.d0/27.21138505732838d0
end module atomic_units


      real function phi(time)
c
c     + + + PURPOSE + + +
c     Computes PHI(TIME) values for function PSI. (DEFINED IN HDEPTH)
c     (Since phi(t)=psi(t,0), see subroutine PSIS for comments)
c
c     Called from HDEPTH.
c     Author(s): Shirley, Stone
c     Reference in User Guide:
c
c     Changes:
c         1) Common block STRUCT not used.  It was de-referenced.
c         2) SAVE of all local varaibles deleted.
c         3) Double precision vars. changed to single.
c
c     Version: This module recoded from WEPP version 91.10.
c     Date recoded: 04/24/91.
c     Recoded by: Charles R. Meyer.
c
c     + + + KEYWORDS + + +
c
c     + + + ARGUMENT DECLARATIONS + + +
      real time
c
c     + + + ARGUMENT DEFINITIONS + + +
c     time   - CURRENT TIME
c
c     + + + PARAMETERS + + +
      include 'pmxtim.inc'
      include 'pmxpln.inc'
      include 'pmxhil.inc'
c
c     + + + COMMON BLOCKS + + +
c
      include 'cintgrl.inc'
c       read: si
c
      include 'cpass1.inc'
c       read: s(mxtime)
      include 'cpass3.inc'
c       read: ns
c
      include 'cprams1.inc'
c       read: tstar
c
c     + + + LOCAL VARIABLES + + +
c     real b
      double precision s1tom, s2tom, b
      integer iu, k
c
c     + + + LOCAL DEFINITIONS + + +
c     b      - cummulative rainfall excess
c     s1tom  - current value of SI**1.5
c     s2tom  - previous value of SI**1.5
c     iu     - index for integration of rainfall excess
c     k      - index to compare with IU
c
c     + + + FUNCTION DECLARATIONS + + +
c     real sint
      double precision sint
c
c     + + + END SPECIFICATIONS + + +
c
c
      if (time.lt.tstar) then
        b = sint(time)
        iu = ii + 1
      else
        b = si(ns+1)
        iu = ns + 1
      end if
c
      k = 2
      phi = 0.0
      s1tom = 0.0
c
      if (k.ne.iu) then
   10   continue
        s2tom = si(k) ** 1.5
        phi = phi + (s2tom-s1tom) / s(k-1)
cWarning from ftnchek
c       79         phi = phi + (s2tom-s1tom) / s(k-1)
c       ^
cWarning near line 79 col 13: dble truncated to real
        s1tom = s2tom
        k = k + 1
        if (k.ne.iu) go to 10
      end if
c
      phi = (phi+(b**1.5-s1tom)/s(k-1)) / m
cWarning from ftnchek
c     85       phi = (phi+(b**1.5-s1tom)/s(k-1)) / m
c     ^
cWarning near line 85 col 11: dble truncated to real
      if (time.gt.tstar) phi = phi + sqrt(b) * (time-tstar)
c
      return
      end


!
!     CalculiX - A 3-dimensional finite element program
!     Copyright (C) 1998-2015 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program 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 General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
!
!     center of gravity of the projection of the vertices for
!     visibility purposes
!     exact integration for one triangle: routine cubtri
!     if the surfaces are far enough away, one-point integration
!     is used
!
      subroutine geomview(vold,co,pmid,e1,e2,e3,kontri,area,
     &     cs,mcs,inocs,ntrit,nk,mi,sidemean)
!
      implicit none
!
!     change following line if nlabel is increased
!
      character*87 label(46)
!
      integer i,j,l,mi(*),kontri(4,*),i1,mcs,inocs(*),i2,i3,
     &     ntrit,jj,is,m,nkt,icntrl,imag,nk,nlabel
!
      real*8 vold(0:mi(2),*),co(3,*),
     &     pmid(3,*),e3(4,*),e1(3,*),e2(3,*),p1(3),p2(3),p3(3),
     &     cs(17,*),area(*),dd,p21(3),p32(3),
     &     fn,stn,qfn,een,t(3),sidemean,emn
!
      write(*,*) 'Calculating the viewfactors'
      write(*,*)
!
!     change following line if nlabel is increased and the dimension
!     of field label above!
!
      nlabel=46
!
!     updating the displacements for cyclic symmetric structures
!
      if(mcs.gt.0) then
         nkt=0
         do i=1,mcs
            if(int(cs(1,i)).gt.nkt) nkt=int(cs(1,i))
         enddo
         nkt=nk*nkt
         do i=1,nlabel
            do l=1,87
               label(i)(l:l)=' '
            enddo
         enddo
         label(1)(1:1)='U'
         imag=0
         icntrl=2
         call rectcyl(co,vold,fn,stn,qfn,een,cs,nk,icntrl,t,
     &        label,imag,mi,emn)

         do jj=0,mcs-1
            is=cs(1,jj+1)
!
            do i=1,is-1
               do l=1,nk
                  if(inocs(l).ne.jj) cycle
                  do m=1,mi(2)
                     vold(m,l+nk*i)=vold(m,l)
                  enddo
               enddo
            enddo
         enddo
         icntrl=-2
         call rectcyl(co,vold,fn,stn,qfn,een,cs,nkt,icntrl,t,
     &        label,imag,mi,emn)
      endif
!
!     calculating the momentaneous center of the triangles,
!     area of the triangles and normal to the triangles
!
      sidemean=0.d0
      do i=1,ntrit
         i1=kontri(1,i)
         if(i1.eq.0) cycle
         i2=kontri(2,i)
         i3=kontri(3,i)
         do j=1,3
            p1(j)=co(j,i1)+vold(j,i1)
            p2(j)=co(j,i2)+vold(j,i2)
            p3(j)=co(j,i3)+vold(j,i3)
            pmid(j,i)=(p1(j)+p2(j)+p3(j))/3.d0
            p21(j)=p2(j)-p1(j)
            p32(j)=p3(j)-p2(j)
         enddo
!
!     normal to the triangle
!
         e3(1,i)=p21(2)*p32(3)-p32(2)*p21(3)
         e3(2,i)=p21(3)*p32(1)-p32(3)*p21(1)
         e3(3,i)=p21(1)*p32(2)-p32(1)*p21(2)
!
         dd=dsqrt(e3(1,i)*e3(1,i)+e3(2,i)*e3(2,i)+
     &        e3(3,i)*e3(3,i))
!
!     check for degenerated triangles
!
         if(dd.lt.1.d-20) then
            area(i)=0.d0
            cycle
         endif
!
         do j=1,3
            e3(j,i)=e3(j,i)/dd
         enddo
!
!     area of the triangle
!
         area(i)=dd/2.d0
!
!     unit vector parallel to side 1-2
!
         dd=dsqrt(p21(1)*p21(1)+p21(2)*p21(2)+p21(3)*p21(3))
         sidemean=sidemean+dd
         do j=1,3
            e1(j,i)=p21(j)/dd
         enddo
!
!     unit vector orthogonal to e1 and e3
!
         e2(1,i)=e3(2,i)*e1(3,i)-e3(3,i)*e1(2,i)
         e2(2,i)=e3(3,i)*e1(1,i)-e3(1,i)*e1(3,i)
         e2(3,i)=e3(1,i)*e1(2,i)-e3(2,i)*e1(1,i)
!
!     the fourth component in e3 is the constant term in the
!     equation of the triangle plane in the form
!     e3(1)*x+e3(2)*y+e3(3)*z+e3(4)=0
!
         e3(4,i)=-(e3(1,i)*p1(1)+e3(2,i)*p1(2)
     &        +e3(3,i)*p1(3))
      enddo
      sidemean=sidemean/ntrit
!
      return
      end


      double complex function I3m(s1,s2,s3)
C     This is the function I3m, a massless triangle with all three external
C     lines offshell defined in BDK
C     %\cite{Bern:1997sc}
C     \bibitem{Bern:1997sc}
C     Z.~Bern, L.~J.~Dixon and D.~A.~Kosower,
C     %``One-loop amplitudes for e+ e- to four partons,''
C     Nucl.\ Phys.\ B {\bf 513}, 3 (1998)
C     [arXiv:hep-ph/9708239].
C     %%CITATION = HEP-PH 9708239;%%
C     defined in their equation II.9
C     \int da_1 da_2 da_3 /(-a_1*a_2*s1-a_2*a_3*s2-a_3*a_1*s3)
       implicit none
      include 'constants.f'
      double precision s1,s2,s3,smax,smid,smin,del3,rtdel3
      double precision i3m1a,flag
      double complex i3m1b

      smax=max(s1,s2,s3)
      smin=min(s1,s2,s3)
      smid=s1+s2+s3-smax-smin
      del3=s1**2+s2**2+s3**2-two*(s1*s2+s2*s3+s3*s1)

      if (del3 .gt. 0) then
      rtdel3=sqrt(del3)
         if (smax .lt. 0) then
c---case all negative
             flag=0d0
             i3m=i3m1b(smax,smid,smin,rtdel3,flag)
         elseif (smin .gt. 0) then
c---case all positive
             flag=0d0
             i3m=-i3m1b(-smin,-smid,-smax,rtdel3,flag)
         elseif ((smid .lt. 0) .and. (smin .lt. 0)) then
c---case two negative and one positive
             flag=+1d0
             i3m=i3m1b(smin,smid,smax,rtdel3,flag)
         elseif ((smax .gt. 0).and.(smid .gt. 0)) then
c---case two positive and one negative
             flag=-1d0
             i3m=-i3m1b(-smax,-smid,-smin,rtdel3,flag)
         endif
      elseif (del3 .lt. 0) then
      rtdel3=sqrt(-del3)
         if (smax .lt. 0) then
c---case all negative
             i3m=+dcmplx(i3m1a(+s1,+s2,+s3,rtdel3))
         elseif (smin .gt. 0) then
c---case all positive
             i3m=-dcmplx(i3m1a(-s1,-s2,-s3,rtdel3))
          endif
      endif

      return
      end

      double precision function I3m1a(s1,s2,s3,rtmdel)
      implicit none
C     symmetric form of Lu and Perez
C     %\cite{Lu:1992ny}
c     \bibitem{Lu:1992ny}
c     H.~J.~Lu and C.~A.~Perez,
c     %``Massless one loop scalar three point integral and associated Clausen,
c     %Glaisher and L functions,''
c     SLAC-PUB-5809
      include 'constants.f'
      double precision s1,s2,s3,d1,d2,d3,rtmdel,arg1,arg2,arg3,dclaus

      d1=s1-s2-s3
      d2=s2-s3-s1
      d3=s3-s1-s2

      arg1=two*datan(rtmdel/d1)
      arg2=two*datan(rtmdel/d2)
      arg3=two*datan(rtmdel/d3)
      i3m1a=two/rtmdel*(Dclaus(arg1)+Dclaus(arg2)+Dclaus(arg3))

      end

      double complex function I3m1b(s1,s2,s3,rtdel,flag)
      implicit none
C     form of Ussyukina and Davydychev
C %\cite{Usyukina:1994iw}
C \bibitem{Usyukina:1994iw}
C   N.~I.~Usyukina and A.~I.~Davydychev,
C   %``New results for two loop off-shell three point diagrams,''
C  Phys.\ Lett.\ B {\bf 332}, 159 (1994)
C  [arXiv:hep-ph/9402223].
C  %%CITATION = HEP-PH 9402223;%%

      include 'constants.f'
      double precision s1,s2,s3,d3,temp,ddilog,xlog,ylog,rat
      double precision x,y,rho,rtdel,argx,argy,argdlx,argdly,flag
      d3=s3-s1-s2
      x=s1/s3
      y=s2/s3
      rat=0.5d0*(d3+rtdel)/s3
      if (abs(rat) .lt. 1d-3) rat=2d0*s1*s2/(s3*(d3-rtdel))
      rho=1d0/rat
      argx=rho*x
      argy=rho*y
      argdlx=-argx
      argdly=-argy

      if ((argdlx .gt. 1d0) .or. (argdly .gt. 1d0)) then
      write(6,*) 'problems with call of I3m1b'
      write(6,*) 'argdlx',argdlx
      write(6,*) 'argdly',argdly
      stop
      endif

      xlog=log(abs(argx))
      ylog=log(abs(argy))
      temp=xlog*ylog+pisq/3d0+(ylog-xlog)*log((one+argy)/(one+argx))
     & +two*(ddilog(argdlx)+ddilog(argdly))
      I3m1b=Dcmplx(temp-abs(flag)*pisq)+impi*Dcmplx(flag*(xlog+ylog))
      I3m1b=-I3m1b/Dcmplx(rtdel)
      end


!
! Copyright (C) 2001-2007 Quantum ESPRESSO group
! This file is distributed under the terms of the
! GNU General Public License. See the file `License'
! in the root directory of the present distribution,
! or http://www.gnu.org/copyleft/gpl.txt .
!
!
!----------------------------------------------------------------------
subroutine vloc_of_g (mesh, msh, rab, r, vloc_at, zp, tpiba2, ngl, &
     gl, omega, vloc)
  !----------------------------------------------------------------------
  !
  !    This routine computes the Fourier transform of the local
  !    part of an atomic pseudopotential, given in numerical form.
  !    A term erf(r)/r is subtracted in real space (thus making the
  !    function short-ramged) and added again in G space (for G<>0)
  !    The G=0 term contains \int (V_loc(r)+ Ze^2/r) 4pi r^2 dr.
  !    This is the "alpha" in the so-called "alpha Z" term of the energy.
  !    Atomic Ry units everywhere.
  !
  USE kinds
  USE constants, ONLY : pi, fpi, e2, eps8
  implicit none
  !
  !    first the dummy variables
  !
  integer, intent(in) :: ngl, mesh, msh
  ! ngl : the number of shells of G vectors
  ! mesh: number of grid points in the radial grid
  ! msh : as above, used for radial integration
  !
  real(DP), intent(in) :: zp, rab (mesh), r (mesh), vloc_at (mesh), tpiba2, &
                          omega, gl (ngl)
  ! zp : valence pseudocharge
  ! rab: the derivative of mesh points
  ! r  : the mesh points
  ! vloc_at: local part of the atomic pseudopotential on the radial mesh
  ! tpiba2 : 2 pi / alat
  ! omega  : the volume of the unit cell
  ! gl     : the moduli of g vectors for each shell
  !
  real(DP), intent(out):: vloc (ngl)
  !
  ! vloc: the fourier transform of the potential
  !
  !    local variables
  !
  real(DP) :: vlcp, fac, gx
  real(DP), allocatable :: aux (:), aux1 (:)
  integer :: igl, igl0, ir
  ! igl :counter on g shells vectors
  ! igl0:first shell with g != 0
  ! ir  :counter on mesh points
  !
  real(DP), external :: qe_erf
  !
  allocate ( aux(msh), aux1(msh) )
  if (gl (1) < eps8) then
     !
     ! first the G=0 term
     !
        do ir = 1, msh
           aux (ir) = r (ir) * (r (ir) * vloc_at (ir) + zp * e2)
        enddo
     call simpson (msh, aux, rab, vlcp)
     vloc (1) = vlcp
     igl0 = 2
  else
     igl0 = 1
  endif
  !
  !   here the G<>0 terms, we first compute the part of the integrand
  !   function independent of |G| in real space
  !
  do ir = 1, msh
     aux1 (ir) = r (ir) * vloc_at (ir) + zp * e2 * qe_erf (r (ir) )
  enddo
  fac = zp * e2 / tpiba2
  !
  !    and here we perform the integral, after multiplying for the |G|
  !    dependent part
  !
  do igl = igl0, ngl
     gx = sqrt (gl (igl) * tpiba2)
     do ir = 1, msh
        aux (ir) = aux1 (ir) * sin (gx * r (ir) ) / gx
     enddo
     call simpson (msh, aux, rab, vlcp)
        !
        !   here we re-add the analytic fourier transform of the erf function
        !
        vlcp = vlcp - fac * exp ( - gl (igl) * tpiba2 * 0.25d0) / gl (igl)
     vloc (igl) = vlcp
  enddo
  vloc (:) = vloc(:) * fpi / omega
  deallocate (aux, aux1)

return
end subroutine vloc_of_g
!
!----------------------------------------------------------------------
subroutine vloc_coul (zp, tpiba2, ngl, gl, omega, vloc)
  !----------------------------------------------------------------------
  !
  !    Fourier transform of the Coulomb potential - For all-electron
  !    calculations, in specific cases only, for testing purposes
  !
  USE kinds
  USE constants, ONLY : fpi, e2, eps8
  implicit none
  !
  integer, intent(in) :: ngl
  ! the number of shells of G vectors
  real(DP), intent(in) :: zp, tpiba2, omega, gl (ngl)
  ! valence pseudocharge
  ! 2 pi / alat
  ! the volume of the unit cell
  ! the moduli of g vectors for each shell
  real(DP), intent (out) :: vloc (ngl)
  ! the fourier transform of the potential
  !
  integer :: igl0
  !
  if (gl (1) < eps8) then
     igl0 = 2
     vloc(1) = 0.0_dp
  else
     igl0 = 1
  endif

  vloc (igl0:ngl) = - fpi * zp *e2 / omega / tpiba2 / gl (igl0:ngl)

return
end subroutine vloc_coul


! -*- f90 -*-
!****************************************
! Routine for rank-deficient jacobian update

SUBROUTINE UPDATEJAC(m,n,fjac, fvec, fvec_new, acc, v, a)
  IMPLICIT NONE
  INTEGER m, n, i, j
  REAL (KIND=8) fjac(m,n), fvec(m), fvec_new(m), acc(m)
  REAL (KIND=8) v(n), a(n), djac(m), v2(n), r1(m)

  r1 = fvec + 0.5*MATMUL(fjac,v) + 0.125d+0*acc
  djac = 2.0*(r1 - fvec - 0.5*MATMUL(fjac,v))/DOT_PRODUCT(v,v)
  DO i = 1,m
     DO j = 1,n
        fjac(i,j) = fjac(i,j) + djac(i)*0.5d+0*v(j)
     END DO
  END DO
  v2 = 0.5d+0*(v + a)
  djac = 0.5*(fvec_new - r1 - MATMUL(fjac,v2))/DOT_PRODUCT(v2,v2)
  DO i = 1,m
     DO j = 1,n
        fjac(i,j) = fjac(i,j) + djac(i)*v2(j)
     END DO
  END DO
END SUBROUTINE UPDATEJAC


*DECK RADF4
      SUBROUTINE RADF4 (IDO, L1, CC, CH, WA1, WA2, WA3)
C***BEGIN PROLOGUE  RADF4
C***SUBSIDIARY
C***PURPOSE  Calculate the fast Fourier transform of subvectors of
C            length four.
C***LIBRARY   SLATEC (FFTPACK)
C***TYPE      SINGLE PRECISION (RADF4-S)
C***AUTHOR  Swarztrauber, P. N., (NCAR)
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   790601  DATE WRITTEN
C   830401  Modified to use SLATEC library source file format.
C   860115  Modified by Ron Boisvert to adhere to Fortran 77 by
C           (a) changing dummy array size declarations (1) to (*).
C           (b) changing definition of variable HSQT2 by using
C               FORTRAN intrinsic function SQRT instead of a DATA
C               statement.
C   881128  Modified by Dick Valent to meet prologue standards.
C   890831  Modified array declarations.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900402  Added TYPE section.  (WRB)
C***END PROLOGUE  RADF4
      DIMENSION CC(IDO,L1,4), CH(IDO,4,*), WA1(*), WA2(*), WA3(*)
C***FIRST EXECUTABLE STATEMENT  RADF4
      HSQT2 = .5*SQRT(2.)
      DO 101 K=1,L1
         TR1 = CC(1,K,2)+CC(1,K,4)
         TR2 = CC(1,K,1)+CC(1,K,3)
         CH(1,1,K) = TR1+TR2
         CH(IDO,4,K) = TR2-TR1
         CH(IDO,2,K) = CC(1,K,1)-CC(1,K,3)
         CH(1,3,K) = CC(1,K,4)-CC(1,K,2)
  101 CONTINUE
      IF (IDO-2) 107,105,102
  102 IDP2 = IDO+2
      IF((IDO-1)/2.LT.L1) GO TO 111
      DO 104 K=1,L1
CDIR$ IVDEP
         DO 103 I=3,IDO,2
            IC = IDP2-I
            CR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2)
            CI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2)
            CR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3)
            CI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3)
            CR4 = WA3(I-2)*CC(I-1,K,4)+WA3(I-1)*CC(I,K,4)
            CI4 = WA3(I-2)*CC(I,K,4)-WA3(I-1)*CC(I-1,K,4)
            TR1 = CR2+CR4
            TR4 = CR4-CR2
            TI1 = CI2+CI4
            TI4 = CI2-CI4
            TI2 = CC(I,K,1)+CI3
            TI3 = CC(I,K,1)-CI3
            TR2 = CC(I-1,K,1)+CR3
            TR3 = CC(I-1,K,1)-CR3
            CH(I-1,1,K) = TR1+TR2
            CH(IC-1,4,K) = TR2-TR1
            CH(I,1,K) = TI1+TI2
            CH(IC,4,K) = TI1-TI2
            CH(I-1,3,K) = TI4+TR3
            CH(IC-1,2,K) = TR3-TI4
            CH(I,3,K) = TR4+TI3
            CH(IC,2,K) = TR4-TI3
  103    CONTINUE
  104 CONTINUE
      GO TO 110
  111 DO 109 I=3,IDO,2
         IC = IDP2-I
CDIR$ IVDEP
         DO 108 K=1,L1
            CR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2)
            CI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2)
            CR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3)
            CI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3)
            CR4 = WA3(I-2)*CC(I-1,K,4)+WA3(I-1)*CC(I,K,4)
            CI4 = WA3(I-2)*CC(I,K,4)-WA3(I-1)*CC(I-1,K,4)
            TR1 = CR2+CR4
            TR4 = CR4-CR2
            TI1 = CI2+CI4
            TI4 = CI2-CI4
            TI2 = CC(I,K,1)+CI3
            TI3 = CC(I,K,1)-CI3
            TR2 = CC(I-1,K,1)+CR3
            TR3 = CC(I-1,K,1)-CR3
            CH(I-1,1,K) = TR1+TR2
            CH(IC-1,4,K) = TR2-TR1
            CH(I,1,K) = TI1+TI2
            CH(IC,4,K) = TI1-TI2
            CH(I-1,3,K) = TI4+TR3
            CH(IC-1,2,K) = TR3-TI4
            CH(I,3,K) = TR4+TI3
            CH(IC,2,K) = TR4-TI3
  108    CONTINUE
  109 CONTINUE
  110 IF (MOD(IDO,2) .EQ. 1) RETURN
  105 DO 106 K=1,L1
         TI1 = -HSQT2*(CC(IDO,K,2)+CC(IDO,K,4))
         TR1 = HSQT2*(CC(IDO,K,2)-CC(IDO,K,4))
         CH(IDO,1,K) = TR1+CC(IDO,K,1)
         CH(IDO,3,K) = CC(IDO,K,1)-TR1
         CH(1,2,K) = TI1-CC(IDO,K,3)
         CH(1,4,K) = TI1+CC(IDO,K,3)
  106 CONTINUE
  107 RETURN
      END


program phaml_master
use phaml
use phaml_user_mod
implicit none
type(phaml_solution_type) :: soln
real(my_real) :: x(0:20),y(0:20),u(0:20),ux(0:20),uy(0:20),uxx(0:20),uyy(0:20)
integer :: i
call phaml_create(soln,nproc=4)
power=4
call update_usermod(soln)
call phaml_solve_pde(soln,max_vert=500,degree=3,mg_cycles=20)
x = (/ (i/20.0_my_real,i=0,20) /)
y = 0.4_my_real
call phaml_evaluate(soln,x,y,u,ux,uy,uxx,uyy)
do i=0,20
   write(6,"(SS,1P,2E19.12E2)") x(i),u(i)
end do
do i=0,20
   write(6,"(SS,1P,3E19.12E2)") x(i),ux(i),uy(i)
end do
do i=0,20
   write(6,"(SS,1P,3E19.12E2)") x(i),uxx(i),uyy(i)
end do
call phaml_destroy(soln)
end program phaml_master


      real function nrievl (x, y, datain, nxpix, nypix, lendan, intere,
     *  scale)

C NRIEVAL -- Procedure to evaluate the 2D interpolant at a given value
C of x and y. NRIEVAL allows the interpolation of a few interpolated
C points without the computing time and storage required for the
C sequential version. The routine assumes that 1 <= x <= nxpix and
C 1 <= y <= nypix.
C
C This is a modified version to allow for a stretch factor (the scale
C parameter) in the SINC case.
C
C Modifications: Richard Hook, ST-ECF@STScI, December 2003
C
C This version supports most options, with the exception of SPLINE3.
C
C Richard Hook modified it, September 2002
C Warren Hack, June 2004
C
      IMPLICIT NONE

      integer nxpix, nypix
      integer lendan
      integer intere
      real scale
      real x, y
      real datain(lendan,*)
      integer nx, ny
      real hold21, hold12, hold22
      real sx, sy, tx, ty
      real xval, yval
      real value
      real coeff(16 +3,16 +3)
      integer nterms
      integer rowleh
      integer xindex, yindex, firstw, lastrw
      integer i, j
C  Used for SPLINE3 option
C      integer kx, ky
C      real tmp(19*19)
C  Used for SINC option
      real taper(15), ac(15), ar(15)
      integer nconv

      nconv = 15

C Define common terms
         nx = int(x)
         ny = int(y)

C Nearest neighbour
      nrievl = 0.
      IF(INTERE.EQ.1) THEN
         nrievl = (datain(int (x+0.5), int (y+0.5)))

C Bilinear
      ELSE IF(INTERE.EQ.2) THEN
         sx = x - nx
         tx = 1. - sx
         sy = y - ny
         ty = 1. - sy
         if (nx .ge. nxpix) THEN
            hold21 = 2. * datain(nx,ny) - datain(nx-1,ny)
         ELSE
            hold21 = datain(nx+1,ny)
         ENDIF

         if (ny .ge. nypix) THEN
            hold12 = 2. * datain(nx,ny) - datain(nx,ny-1)
         ELSE
            hold12 = datain(nx,ny+1)
         ENDIF

         if (nx .ge. nxpix .and. ny .ge. nypix) THEN
            hold22 = 2. * hold21 - (2. * datain(nx,ny-1) -
     *         datain(nx-1,ny-1))
         ELSE IF (nx .ge. nxpix) THEN
            hold22 = 2. * hold12 - datain(nx-1,ny+1)
         ELSE IF (ny .ge. nypix) THEN
               hold22 = 2. * hold21 - datain(nx+1,ny-1)
         ELSE
               hold22 = datain(nx+1,ny+1)
         ENDIF

         value = tx * ty * datain(nx,ny) + sx * ty * hold21 + sy * tx
     *    * hold12 + sx * sy * hold22

         nrievl = value

C Bicubic polynomial: 'poly3'
      ELSE IF(INTERE.EQ.3) THEN
         rowleh = 16 + 3
         nterms = 4
         yindex = 1

C	    major problem is that near the edge the interior polynomial
C	    must be defined
C
C	    use boundary projection to extend the data rows
         DO j = ny-1, ny+2

C		check that the data row is defined
            IF (j .ge.1 .and. j .le. nypix ) THEN

C		         extend the rows
               xindex = 1
               DO i=nx-1, nx+2
                  IF (i .lt. 1) THEN
                     coeff(xindex,yindex) = 2. * datain(1,j) -
     *                     datain(2-i,j)
                  ELSE IF (i .gt. nxpix) THEN
                     coeff(xindex,yindex) = 2. * datain(nxpix,j) -
     *                     datain(2*nxpix-i,j)
                  ELSE
                     coeff(xindex,yindex) = datain(i,j)
                  ENDIF
                  xindex = xindex + 1
               ENDDO

            ELSE IF (j .eq. (ny + 2)) THEN
C		         extend the rows
               xindex = 1
               DO i=nx-1, nx+2
                  IF (i .lt. 1) THEN
                     coeff(xindex,yindex) = 2. * datain(1,nypix-2) -
     *                   datain(2-i,nypix-2)
                  ELSE if (i .gt. nxpix) THEN
                     coeff(xindex,yindex) = 2. * datain(nxpix,nypix-2)
     *                   - datain(2*nxpix-i,nypix-2)
                  ELSE
                     coeff(xindex,yindex) = datain(i,nypix-2)
                  ENDIF
                  xindex = xindex + 1
               ENDDO
            ENDIF
            yindex = yindex + 1
         ENDDO
C End of loop over rows (j)
C	 project columns
C
C  awsur -- Weighted sum of 2 real vectors.
C           awsur(a,b,c,npix,k1,k2) : c(i) = k1*a(i) + k2*b(i)

         firstw = max (1, 3 - ny)
         IF (firstw .gt. 1) THEN
            DO j= 1, firstw
               call WSUMR (coeff(1, firstw), coeff(1, 2*firstw-j),
     *            coeff(1,j), nterms, 2., -1.)
            ENDDO
         ENDIF

         lastrw = min (nterms, nypix - ny + 2)
         IF (lastrw .lt. nterms) THEN
            DO j= lastrw + 1, nterms - 1
               call WSUMR (coeff(1,lastrw), coeff(1,2*lastrw-j),
     *            coeff(1,j), nterms, 2., -1.)
            ENDDO
         ELSE if (lastrw .eq. 2) THEN
            call WSUMR (coeff(1,lastrw), coeff(1,4), coeff(1,4),
     *         nterms, 2., -1.)

         ELSE
            call WSUMR (coeff(1,lastrw), coeff(1,2*lastrw-4),
     *         coeff(1,4), nterms, 2., -1.)
         ENDIF

C  center the x value and call evaluation routine
         xval = 2 + (x - nx)
         yval = 2 + (y - ny)
         call iibip3 (coeff, 0, rowleh, xval, yval, value, 1)

         nrievl = (value)

C BIPOLY5 case: 'poly5'
      ELSE IF (INTERE.EQ.4) THEN
         rowleh = 16 + 3
         nterms = 6

C	     major problem is to define interior polynomial near the edge
C
C	     loop over the rows of data
         yindex = 1
         DO j = ny - 2, ny+3
C		select the  rows containing data
            if (j .ge. 1 .and. j .le. nypix) THEN

C		         extend the rows
               xindex = 1
               DO i = nx - 2, nx+3
                  if (i .lt. 1) THEN
                     coeff(xindex,yindex) = 2. * datain(1,j) -
     *                     datain(2-i,j)
                  ELSE if (i .gt. nxpix) THEN
                     coeff(xindex,yindex) = 2. * datain(nxpix,j) -
     *                     datain(2*nxpix-i,j)
                  ELSE
                     coeff(xindex,yindex) = datain(i,j)
                  ENDIF
                  xindex = xindex + 1
               ENDDO

            ELSE if (j .eq. (ny + 3)) THEN
C		         extend the rows
               xindex = 1
               DO i = nx - 2, nx + 3
                  IF (i .lt. 1) THEN
                     coeff(xindex,yindex) = 2. * datain(1,nypix-3) -
     *                     datain(2-i,nypix-3)
                  ELSE if (i .gt. nxpix) THEN
                     coeff(xindex,yindex) = 2. * datain(nxpix,nypix-3)
     *                   - datain(2*nxpix-i,nypix-3)
                  ELSE
                     coeff(xindex,yindex) = datain(i,nypix-3)
                  ENDIF

                  xindex = xindex + 1
               ENDDO
            ENDIF

C     End of loop of 'j'
            yindex = yindex + 1
         ENDDO
C	   project columns

         firstw = max (1, 4 - ny)
         if (firstw .gt. 1) THEN
            DO j = 1, firstw
               call WSUMR (coeff(1,firstw), coeff(1,2*firstw-j),
     *            coeff(1,j), nterms, 2., -1.)
            ENDDO
         ENDIF

         lastrw = min (nterms, nypix - ny + 3)
         if (lastrw .lt. nterms) THEN
            DO j = lastrw + 1, nterms - 1
               call WSUMR (coeff(1,lastrw), coeff(1,2*lastrw-j),
     *            coeff(1,j), nterms, 2., -1.)
            ENDDO
         ELSE if (lastrw .eq. 3) THEN
            call WSUMR (coeff(1,lastrw), coeff(1,6), coeff(1,6),
     *            nterms, 2., -1.)
         ELSE
            call WSUMR (coeff(1,lastrw), coeff(1,2*lastrw-6),
     *            coeff(1,6), nterms, 2., -1.)
         ENDIF
C	     call evaluation routine
         xval = 3 + (x - nx)
         yval = 3 + (y - ny)
         call iibip5 (coeff, 0, rowleh, xval, yval, value, 1)

         nrievl = (value)
C End of 'poly5' case
C
C  Spline case not implemented due to requirement of 'iispld',
C  derived from ii_spline2d.x, to dynamically allocate a working
C  array for the computation.
C
C      ELSE IF (INTERE.EQ.5) THEN
C         rowleh = 16 + 3
C         ky = 0
C         DO 510 j = ny - 16 /2 + 1, ny + 16 /2
C            if (.not.(j .lt. 1 .or. j .gt. nypix)) THEN
C               ky = ky + 1
C                if (ky .eq. 1) THEN
C                   yindex = ny - j + 1
C                ENDIF
C
C                kx = 0
C                DO 540 i = nx - 16 /2 + 1, nx + 16 /2
C                   if (.not.(i .lt. 1 .or. i .gt. nxpix)) THEN
C                      kx = kx + 1
C                      if (kx .eq. 1) THEN
C                         xindex = nx - i + 1
C                      ENDIF
C                      coeff(kx+1,ky+1) = datain(i,j)
C                   ENDIF
C
C 540            ENDDO
C                coeff(1,ky+1) = 0.
C                coeff(kx+2,ky+1) = 0.
C                coeff(kx+3,ky+1) = 0.
C             ENDIF
C 510      ENDDO
C
C          call SET1R (0., coeff(1,1), kx+3)
C          call SET1R (0., coeff(1,ky+2), kx+3)
C          call SET1R (0., coeff(1,ky+3),kx+3)
C          call iispld (coeff, tmp, kx, ky+2, rowleh, rowleh)
C          call iispld (tmp, coeff, ky, kx+2, rowleh, rowleh)
C          xval = xindex + 1 + (x - nx)
C          yval = yindex + 1 + (y - ny)
C         call iibis3 (coeff, 0, rowleh, xval, yval, value, 1)
C         nrievl = (value)
      ELSE IF (INTERE.EQ.6 .OR. INTERE.EQ.7) THEN

C      subroutine iinisc (coeff, firstt, lencof, lenary, x, y, zfit,
C    * npts, nconv, taper, ac, ar, mindx, mindy, scale)
C      where
C      nconv = 2 * nsinc + 1 and nsinc = sinc truncation length

      call iinisc (datain, 0, lendan, nypix, x, y, value, 1, nconv,
     *      taper, ac, ar, 0.001, 0.001, scale)
         nrievl = (value)

      ENDIF

      end