! written by jxzou at 20190411: read and adjust the orders of d,f,g, etc functions
!  in Gaussian .chk file, to the orders in PySCF

! This subroutine is designed to be called as a module by Python.
!  For INTEL compiler, use
! ---------------------------------------------------------------------
!  f2py -m chk2py -c chk2py.f90 --fcompiler=intelem --compiler=intelem
! ---------------------------------------------------------------------
!  For GNU compiler, use
! ------------------------------
!  f2py -m chk2py -c chk2py.f90
! ------------------------------
!  to compile this file (a chk2py.so file will be generated). Then in
!  Python you can import the chk2py module.

! diagonal elements of overlap matrix using Cartesian functions (6D 10F)
module Sdiag_parameter
 implicit none
 real(kind=8), parameter :: PI = 4d0*DATAN(1d0)
 real(kind=8), parameter :: p1 = 2d0*DSQRT(PI/15d0)
 real(kind=8), parameter :: p2 = 2d0*DSQRT(PI/5d0)
 real(kind=8), parameter :: p3 = 2d0*DSQRT(PI/7d0)
 real(kind=8), parameter :: p4 = 2d0*DSQRT(PI/35d0)
 real(kind=8), parameter :: p5 = 2d0*DSQRT(PI/105d0)
 real(kind=8), parameter :: p6 = (2d0/3d0)*DSQRT(PI)
 real(kind=8), parameter :: p7 = (2d0/3d0)*DSQRT(PI/7d0)
 real(kind=8), parameter :: p8 = (2d0/3d0)*DSQRT(PI/35d0)
 real(kind=8), parameter :: p9 = 2d0*DSQRT(PI/11d0)
 real(kind=8), parameter :: p10 = (2d0/3d0)*DSQRT(PI/11d0)
 real(kind=8), parameter :: p11 = 2d0*DSQRT(PI/231d0)
 real(kind=8), parameter :: p12 = (2d0/3d0)*DSQRT(PI/77d0)
 real(kind=8), parameter :: p13 = 2d0*DSQRT(PI/1155d0)
 real(kind=8), parameter :: Sdiag_d(6)  = [p2,p1,p1,p2,p1,p2]
 real(kind=8), parameter :: Sdiag_f(10) = [p3,p4,p4,p4,p5,p4,p3,p4,p4,p3]
 real(kind=8), parameter :: Sdiag_g(15) = [p6,p7,p7,p5,p8,p5,p7,p8,p8,p7,p6,p7,p5,p7,p6]
 real(kind=8), parameter :: Sdiag_h(21) = &
  [p9,p10,p10,p11,p12,p11,p11,p13,p13,p11,p10,p12,p13,p12,p10,p9,p10,p11,p11,p10,p9]
end module Sdiag_parameter

! Step1:
!  tranform the .chk file to _chk.txt file using Gaussian utility chkchk,
!  and read the MOs from _chk.txt
! Step2:
!  tranform the .chk file to _tmp.fchk file using Gaussian utility formchk,
!  and read shell types from _tmp.fchk
!  (The _chk.txt and _tmp.fchk file will be deleted after reading)
! Step3:
!  adjust its d,f,g, etc. functions order of Gaussian to that of PySCF
subroutine chk2py(chkname, nbf, nif, ab, coeff)
 implicit none
 integer :: i, k, length, chkid
 integer :: ncoeff, nbf, nif
!f2py intent(in) :: nbf, nif
 integer :: system
 integer :: n6dmark,n10fmark,n15gmark,n21hmark
 integer :: n5dmark,n7fmark, n9gmark, n11hmark
 integer, allocatable :: shell_type(:), shell_to_atom_map(:)
 integer, parameter :: iout = 6
 ! mark the index where d, f, g, h functions begin
 integer, allocatable :: d_mark(:), f_mark(:), g_mark(:), h_mark(:)

 real(kind=8), parameter :: diff = 1d-6
 real(kind=8) :: coeff(nbf,nif)
!f2py depend(nbf,nif) :: coeff
!f2py intent(out) :: coeff

 character(len=1) :: ab
!f2py intent(in) :: ab
 character(len=8) :: key
 character(len=8), parameter :: key1 = 'Alpha MO'
 character(len=7), parameter :: key2 = 'Beta MO'
 character(len=240) :: chkname, txtname, buffer
!f2py intent(in) :: chkname
 logical :: alive

 inquire(file=TRIM(chkname),exist=alive)
 if(.not. alive) then
  write(iout,'(A)') 'ERROR in subroutine chk2py: file does not exist!'
  write(iout,'(A)') 'Filename='//TRIM(chkname)
  stop
 end if

 i = index(chkname,'.chk')
 txtname = chkname(1:i-1)//'_chk.txt'

 ! Step1: tranform .chk to _chk.txt using Gaussian utility chkchk
 i = system('chkchk -p '//TRIM(chkname)//' > '//TRIM(txtname))
 if(i /= 0) then
  write(iout,'(A)') 'ERROR in subroutine chk2py: fail to tranform the .chk file&
                   & to _chk.txt file, using Gaussian utility chkchk.'
  write(iout,'(A)') 'File: '//TRIM(chkname)
  write(iout,'(A)') "You can use 'which chkchk' to check if this command exists."
  stop
 end if

 ! read Alpha MO or Beta MO from _chk.txt
 buffer = ' '
 ncoeff = 0
 key = key1
 if(ab/='a' .and. ab/='A') then
  key = key2//' '
 end if

 open(newunit=chkid,file=TRIM(txtname),status='old',position='rewind')
 do while(.true.)
  read(chkid,'(A)') buffer
  if(buffer(7:14) == key) exit
 end do
 BACKSPACE(chkid)

 coeff = 0.0d0
 do i = 1, nif, 1
  read(chkid,'(A)') buffer ! skip one line
  read(chkid,'(4D20.12)') (coeff(k,i), k=1,nbf)
 end do
 ! MOs in _chk.txt read done
 close(chkid,status='delete')

 ! Step2: tranform .chk to _tmp.fchk using Gaussian utility formchk
 i = index(chkname,'.chk')
 txtname = chkname(1:i-1)//'_tmp.fchk'
 i = system('formchk '//TRIM(chkname)//' '//TRIM(txtname)//" >junk_tmp 2>&1")
 if(i /= 0) then
  write(iout,'(A)') 'ERROR in subroutine chk2py: fail to tranform the .chk file&
                   & to _tmp.fchk file, using Gaussian utility formchk.'
  write(iout,'(A)') TRIM(chkname)
  write(iout,'(A)') "You can use 'which formchk' to check if this command exists."
  stop
 end if

 ! Normally, the content in file junk_tmp is:
 ! ' Read checkpoint file xxx.chk'
 ! ' Write formatted file xxx.fchk'
 ! delete the file junk_tmp
 open(newunit=chkid,file='junk_tmp',status='old')
 close(chkid,status='delete')

 open(newunit=chkid,file=TRIM(txtname),status='old',position='rewind')
 do while(.true.)
  read(chkid,'(A)') buffer
  if(buffer(1:17) == 'Number of basis f') exit
 end do
 BACKSPACE(chkid)

 read(chkid,'(A49,2X,I10)') buffer, i
 if(i /= nbf) then
  write(iout,'(A)') 'ERROR in subroutine chk2py: inconsistent number of basis&
                   & functions in .chk file and in PySCF script.'
  write(iout,'(A)') TRIM(chkname)
  close(chkid)
  stop
 end if

 read(chkid,'(A49,2X,I10)') buffer, i
 if(i /= nif) then
  write(iout,'(A)') 'ERROR in subroutine chk2py: inconsistent number of MOs in&
                   & .chk file and in PySCF script.'
  write(iout,'(A)') TRIM(chkname)
  close(chkid)
  stop
 end if

 ! find and read Shell types
 do while(.true.)
  read(chkid,'(A)',iostat=i) buffer
  if(buffer(1:11) == 'Shell types') exit
 end do
 if(i /= 0) then
  write(iout,'(A)') "ERROR in subroutine chk2py: missing the 'Shell types'&
                   & section in .fchk file!"
  write(iout,'(A)') TRIM(chkname)
  close(chkid)
  stop
 end if

 BACKSPACE(chkid)
 read(chkid,'(A49,2X,I10)') buffer, k
 allocate(shell_type(2*k))
 shell_type = 0
 read(chkid,'(6(6X,I6))') (shell_type(i),i=1,k)
 ! read Shell types done

 ! find and read Shell to atom map
 do while(.true.)
  read(chkid,'(A)',iostat=i) buffer
  if(buffer(1:13) == 'Shell to atom') exit
 end do
 if(i /= 0) then
  write(iout,'(A)') "ERROR in subroutine chk2py: missing the 'Shell to atom map'&
                   & section in .fchk file!"
  write(iout,'(A)') TRIM(chkname)
  close(chkid)
  stop
 end if
 allocate(shell_to_atom_map(2*k))
 shell_to_atom_map = 0
 read(chkid,'(6(6X,I6))') (shell_to_atom_map(i),i=1,k)
 ! read Shell to atom map done

 ! all information in .fchk file read done
 close(chkid,status='delete')

! Step3:
! first we adjust the basis functions in each MO according to the Shell to atom map
! this is to ensure that D comes after L functions
 ! split the 'L' into 'S' and 'P'
 call split_L_func(k, shell_type, shell_to_atom_map, length)

 ! sort the shell_type, shell_to_atom_map by ascending order
 ! MOs will be adjusted accordingly
 call sort_shell_and_mo(length, shell_type, shell_to_atom_map, nbf, nif, coeff)
! adjust done

! then we adjust the basis functions in each MO according to the type of basis functions
 k = length  ! update k
 n6dmark = 0
 n10fmark = 0
 n15gmark = 0
 n21hmark = 0
 n5dmark = 0
 n7fmark = 0
 n9gmark = 0
 n11hmark = 0
 allocate(d_mark(k), f_mark(k), g_mark(k), h_mark(k))
 d_mark = 0
 f_mark = 0
 g_mark = 0
 h_mark = 0
 nbf = 0
 do i = 1,k,1
  select case(shell_type(i))
  case( 0)   ! S
   nbf = nbf + 1
  case( 1)   ! 3P
   nbf = nbf + 3
  case(-1)   ! SP or L
   nbf = nbf + 4
  case(-2)   ! 5D
   n5dmark = n5dmark + 1
   d_mark(n5dmark) = nbf + 1
   nbf = nbf + 5
  case( 2)   ! 6D
   n6dmark = n6dmark + 1
   d_mark(n6dmark) = nbf + 1
   nbf = nbf + 6
  case(-3)   ! 7F
   n7fmark = n7fmark + 1
   f_mark(n7fmark) = nbf + 1
   nbf = nbf + 7
  case( 3)   ! 10F
   n10fmark = n10fmark + 1
   f_mark(n10fmark) = nbf + 1
   nbf = nbf + 10
  case(-4)   ! 9G
   n9gmark = n9gmark + 1
   g_mark(n9gmark) = nbf + 1
   nbf = nbf + 9
  case( 4)   ! 15G
   n15gmark = n15gmark + 1
   g_mark(n15gmark) = nbf + 1
   nbf = nbf + 15
  case(-5)   ! 11H
   n11hmark = n11hmark + 1
   h_mark(n11hmark) = nbf + 1
   nbf = nbf + 11
  case( 5)   ! 21H
   n21hmark = n21hmark + 1
   h_mark(n21hmark) = nbf + 1
   nbf = nbf + 21
  end select
 end do
 deallocate(shell_type)

 ! adjust the order of d, f, etc. functions
 do i = 1,n5dmark,1
  call chk2py_permute_5d(nif,coeff(d_mark(i):d_mark(i)+4,:))
 end do
 do i = 1,n6dmark,1
  call chk2py_permute_6d(nif,coeff(d_mark(i):d_mark(i)+5,:))
 end do
 do i = 1,n7fmark,1
  call chk2py_permute_7f(nif,coeff(f_mark(i):f_mark(i)+6,:))
 end do
 do i = 1,n10fmark,1
  call chk2py_permute_10f(nif,coeff(f_mark(i):f_mark(i)+9,:))
 end do
 do i = 1,n9gmark,1
  call chk2py_permute_9g(nif,coeff(g_mark(i):g_mark(i)+8,:))
 end do
 do i = 1,n15gmark,1
  call chk2py_permute_15g(nif,coeff(g_mark(i):g_mark(i)+14,:))
 end do
 do i = 1,n11hmark,1
  call chk2py_permute_11h(nif,coeff(h_mark(i):h_mark(i)+10,:))
 end do
 do i = 1,n21hmark,1
  call chk2py_permute_21h(nif,coeff(h_mark(i):h_mark(i)+20,:))
 end do
! adjustment finished

 deallocate(d_mark, f_mark, g_mark, h_mark)
 return
end subroutine chk2py

! split the 'L' into 'S' and 'P'
subroutine split_L_func(k, shell_type, shell_to_atom_map, length)
 implicit none
 integer i, k0
 integer,intent(in) :: k
 integer,intent(inout) :: shell_type(2*k), shell_to_atom_map(2*k)
 integer,intent(out) :: length
 integer,allocatable :: temp1(:), temp2(:)

 k0 = 2*k
 length = k
 ! set initial values for arrays shell_type, assume 15 will not be used
 shell_type(k+1:k0) = 15
 i = 1
 do while(shell_type(i) /= 15)
  if(shell_type(i) /= -1) then
   i = i + 1
   cycle
  end if
  shell_type(i) = 0
  allocate( temp1(i+1 : k0-1), temp2(i+1 : k0-1) )
  temp1(i+1 : k0-1) = shell_type(i+1 : k0-1)
  shell_type(i+2 : k0) = temp1(i+1 : k0-1)
  temp2(i+1 : k0-1) = shell_to_atom_map(i+1 : k0-1)
  shell_to_atom_map(i+2 : k0) = temp2(i+1 : k0-1)
  deallocate(temp1, temp2)
  shell_type(i+1) = 1
  shell_to_atom_map(i+1) = shell_to_atom_map(i)
  i = i + 2
 end do

 length = i - 1
 shell_type(i : k0) = 0
 return
end subroutine split_L_func

! sort the shell_type, shell_to_atom_map by ascending order
! MOs will be adjusted accordingly
subroutine sort_shell_and_mo(ilen, shell_type, shell_to_atom_map, nbf, nif, coeff)
 implicit none
 integer i, j, k
 integer ibegin, iend, natom
 integer jbegin, jend
 integer, parameter :: ntype = 10
 integer, parameter :: num0(ntype) = [0, 1, -2, 2, -3, 3, -4, 4, -5, 5]
 integer, parameter :: num1(ntype) = [1, 3, 5, 6, 7, 10, 9, 15, 11, 21]
 !                                     S  P  5D 6D 7F 10F 9G 15G 11H 21H
 integer num(ntype)

 integer,intent(in) :: ilen, nbf, nif
 integer,intent(inout) :: shell_type(ilen), shell_to_atom_map(ilen)
 integer,allocatable :: ith(:), ith_bas(:), tmp_type(:)
 real(kind=8),intent(inout) :: coeff(nbf,nif)

 ! find the number of atoms
 natom = shell_to_atom_map(ilen)

 allocate(ith(0:natom), ith_bas(0:natom))
 ith = 0
 ith_bas = 0

 ! find the end position of each atom in array shell_to_atom_map
 do i = 1, natom, 1
  ith(i) = count(shell_to_atom_map==i) + ith(i-1)
 end do

 ! find the end position of basis functions between two atoms
 do i = 1, natom, 1
  ibegin = ith(i-1) + 1
  iend = ith(i)
  allocate(tmp_type(ibegin:iend))
  tmp_type = 0
  tmp_type = shell_type(ibegin:iend)
  num = 0
  do j = 1, ntype, 1
   num(j) = count(tmp_type == num0(j))
  end do
  k = 0
  do j = 1, ntype, 1
   k = k + num(j)*num1(j)
  end do
  ith_bas(i) = ith_bas(i-1) + k
  deallocate(tmp_type)
 end do

 ! adjust the MOs in each atom
 do i = 1, natom, 1
  ibegin = ith(i-1) + 1
  iend = ith(i)
  jbegin = ith_bas(i-1) + 1
  jend = ith_bas(i)
  call sort_shell_and_mo_in_each_atom(iend-ibegin+1, shell_type(ibegin:iend), &
  & jend-jbegin+1, nif, coeff(jbegin:jend,1:nif))
 end do
 ! adjust the MOs in each atom done
 deallocate(ith, ith_bas)
 return
end subroutine sort_shell_and_mo

subroutine sort_shell_and_mo_in_each_atom(ilen1, shell_type, ilen2, nif, coeff)
 implicit none
 integer i, tmp_type
 integer ibegin, iend, jbegin, jend
 integer,parameter :: ntype = 10
 integer,parameter :: num0(ntype) = [0, 1, -2, 2, -3, 3, -4, 4, -5, 5]
 integer,parameter :: num1(ntype) = [1, 3, 5, 6, 7, 10, 9, 15, 11, 21]
 !                                    S  P  5D 6D 7F 10F 9G 15G 11H 21H
 integer,parameter :: rnum(-5:5) = [9, 7, 5, 3, 0, 1, 2, 4, 6, 8, 10]

 integer,intent(in) :: nif, ilen1, ilen2
 integer,intent(inout) :: shell_type(ilen1)
 integer,allocatable :: ith_bas(:)
 real(kind=8),intent(inout) :: coeff(ilen2,nif)
 real(kind=8),allocatable :: tmp_coeff1(:,:), tmp_coeff(:,:)
 logical sort_done

 tmp_type = 0

 ! find the end position of basis functions within an atom
 allocate(ith_bas(0:ilen1))
 ith_bas = 0
 do i = 1, ilen1, 1
   ith_bas(i) = ith_bas(i-1) + num1(rnum(shell_type(i)))
 end do

 sort_done = .false.
 do while(.not. sort_done)
  sort_done = .true.
  do i = 1, ilen1-1, 1
    if(shell_type(i) == 0) cycle
    if(ABS(shell_type(i+1)) >= ABS(shell_type(i))) cycle
    sort_done = .false.
    tmp_type = shell_type(i+1)
    shell_type(i+1) = shell_type(i)
    shell_type(i) = tmp_type
    ibegin = ith_bas(i-1) + 1
    iend = ith_bas(i)
    jbegin = ith_bas(i) + 1
    jend = ith_bas(i+1)
    allocate(tmp_coeff1(ibegin:iend,nif), tmp_coeff(jbegin:jend,nif))
    tmp_coeff1 = 0.0d0
    tmp_coeff = 0.0d0
    tmp_coeff1 = coeff(ibegin:iend,:)
    tmp_coeff = coeff(jbegin:jend,:)
    ith_bas(i) = ibegin+jend-jbegin
    coeff(ibegin: ith_bas(i),:) = tmp_coeff
    ith_bas(i+1) = jend+iend-jbegin+1
    coeff(ibegin+jend-jbegin+1: ith_bas(i+1),:) = tmp_coeff1
    deallocate(tmp_coeff1, tmp_coeff)
  end do
 end do
 deallocate(ith_bas)
 return
end subroutine sort_shell_and_mo_in_each_atom

subroutine chk2py_permute_5d(nif,coeff)
 implicit none
 integer :: i
 integer, parameter :: order(5) = [5, 3, 1, 2, 4]
 integer, intent(in) :: nif
 real(kind=8), intent(inout) :: coeff(5,nif)
 real(kind=8), allocatable :: coeff2(:,:)
! From: the order of spherical d functions in Gaussian
! To: the order of spherical d functions in PySCF
! 1    2    3    4    5
! d0 , d+1, d-1, d+2, d-2
! d-2, d-1, d0 , d+1, d+2

 allocate(coeff2(5,nif), source=0d0)
 forall(i = 1:5) coeff2(i,:) = coeff(order(i),:)
 coeff = coeff2
 deallocate(coeff2)
 return
end subroutine chk2py_permute_5d

subroutine chk2py_permute_6d(nif,coeff)
 use Sdiag_parameter, only: Sdiag_d
 implicit none
 integer :: i
 integer, parameter :: order(6) = [1, 4, 5, 2, 6, 3]
 integer, intent(in) :: nif
 real(kind=8), intent(inout) :: coeff(6,nif)
 real(kind=8), allocatable :: coeff2(:,:)
! From: the order of Cartesian d functions in Gaussian
! To: the order of Cartesian d functions in PySCF
! 1  2  3  4  5  6
! XX,YY,ZZ,XY,XZ,YZ
! XX,XY,XZ,YY,YZ,ZZ

 allocate(coeff2(6,nif), source=coeff)
 forall(i = 1:6) coeff(i,:) = coeff2(order(i),:)/Sdiag_d(i)
 deallocate(coeff2)
 return
end subroutine chk2py_permute_6d

subroutine chk2py_permute_7f(nif,coeff)
 implicit none
 integer :: i
 integer, parameter :: order(7) = [7, 5, 3, 1, 2, 4, 6]
 integer, intent(in) :: nif
 real(kind=8), intent(inout) :: coeff(7,nif)
 real(kind=8), allocatable :: coeff2(:,:)
! From: the order of spherical f functions in Gaussian
! To: the order of spherical f functions in PySCF
! 1    2    3    4    5    6    7
! f0 , f+1, f-1, f+2, f-2, f+3, f-3
! f-3, f-2, f-1, f0 , f+1, f+2, f+3

 allocate(coeff2(7,nif), source=0d0)
 forall(i = 1:7) coeff2(i,:) = coeff(order(i),:)
 coeff = coeff2
 deallocate(coeff2)
 return
end subroutine chk2py_permute_7f

subroutine chk2py_permute_10f(nif,coeff)
 use Sdiag_parameter, only: Sdiag_f
 implicit none
 integer :: i
 integer, parameter :: order(10) = [1, 5, 6, 4, 10, 7, 2, 9, 8, 3]
 integer, intent(in) :: nif
 real(kind=8), intent(inout) :: coeff(10,nif)
 real(kind=8), allocatable :: coeff2(:,:)
! From: the order of Cartesian f functions in Gaussian
! To: the order of Cartesian f functions in PySCF
! 1   2   3   4   5   6   7   8   9   10
! XXX,YYY,ZZZ,XYY,XXY,XXZ,XZZ,YZZ,YYZ,XYZ
! XXX,XXY,XXZ,XYY,XYZ,XZZ,YYY,YYZ,YZZ,ZZZ

 allocate(coeff2(10,nif), source=coeff)
 forall(i = 1:10) coeff(i,:) = coeff2(order(i),:)/Sdiag_f(i)
 deallocate(coeff2)
 return
end subroutine chk2py_permute_10f

subroutine chk2py_permute_9g(nif,coeff)
 implicit none
 integer :: i
 integer, parameter :: order(9) = [9, 7, 5, 3, 1, 2, 4, 6, 8]
 integer, intent(in) :: nif
 real(kind=8), intent(inout) :: coeff(9,nif)
 real(kind=8), allocatable :: coeff2(:,:)
! From: the order of spherical g functions in Gaussian
! To: the order of spherical g functions in PySCF
! 1    2    3    4    5    6    7    8    9
! g0 , g+1, g-1, g+2, g-2, g+3, g-3, g+4, g-4
! g-4, g-3, g-2, g-1, g0 , g+1, g+2, g+3, g+4

 allocate(coeff2(9,nif), source=0d0)
 forall(i = 1:9) coeff2(i,:) = coeff(order(i),:)
 coeff = coeff2
 deallocate(coeff2)
 return
end subroutine chk2py_permute_9g

subroutine chk2py_permute_15g(nif,coeff)
 use Sdiag_parameter, only: Sdiag_g
 implicit none
 integer :: i
 integer, intent(in) :: nif
 real(kind=8), intent(inout) :: coeff(15,nif)
 real(kind=8), allocatable :: coeff2(:,:)
! From: the order of Cartesian g functions in Gaussian
! To: the order of Cartesian g functions in PySCF
! 1    2    3    4    5    6    7    8    9    10   11   12   13   14   15
! ZZZZ,YZZZ,YYZZ,YYYZ,YYYY,XZZZ,XYZZ,XYYZ,XYYY,XXZZ,XXYZ,XXYY,XXXZ,XXXY,XXXX
! xxxx,xxxy,xxxz,xxyy,xxyz,xxzz,xyyy,xyyz,xyzz,xzzz,yyyy,yyyz,yyzz,yzzz,zzzz

 allocate(coeff2(15,nif), source=coeff)
 forall(i = 1:15) coeff(i,:) = coeff2(16-i,:)/Sdiag_g(i)
 deallocate(coeff2)
 return
end subroutine chk2py_permute_15g

subroutine chk2py_permute_11h(nif,coeff)
 implicit none
 integer :: i
 integer, parameter :: order(11) = [11, 9, 7, 5, 3, 1, 2, 4, 6, 8, 10]
 integer, intent(in) :: nif
 real(kind=8), intent(inout) :: coeff(11,nif)
 real(kind=8), allocatable :: coeff2(:,:)
! From: the order of spherical h functions in Gaussian
! To: the order of spherical h functions in PySCF
! 1    2    3    4    5    6    7    8    9    10   11
! h0 , h+1, h-1, h+2, h-2, h+3, h-3, h+4, h-4, h+5, h-5
! h-5, h-4, h-3, h-2, h-1, h0 , h+1, h+2, h+3, h+4, h+5

 allocate(coeff2(11,nif), source=0d0)
 forall(i = 1:11) coeff2(i,:) = coeff(order(i),:)
 coeff = coeff2
 deallocate(coeff2)
 return
end subroutine chk2py_permute_11h

subroutine chk2py_permute_21h(nif,coeff)
 use Sdiag_parameter, only: Sdiag_h
 implicit none
 integer :: i
 integer, intent(in) :: nif
 real(kind=8), intent(inout) :: coeff(21,nif)
 real(kind=8), allocatable :: coeff2(:,:)
! From: the order of Cartesian h functions in Gaussian
! To: the order of Cartesian h functions in PySCF
! 1     2     3     4     5     6     7     8     9     10    11    12    13    14    15    16    17    18    19    20    21
! ZZZZZ,YZZZZ,YYZZZ,YYYZZ,YYYYZ,YYYYY,XZZZZ,XYZZZ,XYYZZ,XYYYZ,XYYYY,XXZZZ,XXYZZ,XXYYZ,XXYYY,XXXZZ,XXXYZ,XXXYY,XXXXZ,XXXXY,XXXXX
! xxxxx,xxxxy,xxxxz,xxxyy,xxxyz,xxxzz,xxyyy,xxyyz,xxyzz,xxzzz,xyyyy,xyyyz,xyyzz,xyzzz,xzzzz,yyyyy,yyyyz,yyyzz,yyzzz,yzzzz,zzzzz

 allocate(coeff2(21,nif), source=coeff)
 forall(i = 1:21) coeff(i,:) = coeff2(22-i,:)/Sdiag_h(i)
 deallocate(coeff2)
 return
end subroutine chk2py_permute_21h


!
!     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.
!
      subroutine coriolissolve(cc,nev,a,b,x,eiga,eigb,eigcorio,iter,d,
     &  temp)
!
!     solves for the complex eigenfrequencies due to Coriolis
!     forces
!
      implicit none
!
      logical wantx
!
      integer nev,iter(*),n,i,j,k,l,m,iii,ksmall,nincrement,
     &  nevcomplex,
     &  ninc,id,ipos
!
      real*8 cc(nev,*),d(*),size
!
      complex*16 a(nev,*),b(nev,*),x(nev,*),eiga(*),eigb(*),eigcorio(*),
     &  temp(nev,*),deig,eig,eignew
!
      n=nev
      wantx=.false.
      nincrement=10
      nevcomplex=0
      ninc=2
      ipos=0
!
!     loop over all modes
!
      loop2: do i=1,nev
      if(d(i).lt.0.d0) cycle
!
!        initial values are taken at regular intervals between
!        the eigenvalues without Coriolis
!
         loop1: do m=1,nincrement
!
!           initial frequency
!
            if(ipos.eq.0) then
               eig=dsqrt(d(i))*(1.d0,0.d0)*m/nincrement
            else
               eig=(dsqrt(d(i-1))+
     &          (dsqrt(d(i))-dsqrt(d(i-1)))*m/nincrement)*(1.d0,0.d0)
            endif
!
            iii=0
            do
               do k=1,nev
                  do l=1,nev
                     a(k,l)=eig*cc(k,l)*(0.d0,1.d0)
                     b(k,l)=-cc(k,l)*(0.d0,1.d0)
                  enddo
                  a(k,k)=a(k,k)-eig*eig+d(k)
                  b(k,k)=b(k,k)+2.d0*eig
               enddo
!
!     solving for the complex eigenvalues
!
               call dlzhes(n,a,n,b,n,temp,n,wantx)
               call dlzit(n,a,n,b,n,temp,n,wantx,iter,eiga,eigb)
!
               if(iter(1).eq.-1) then
                  write(*,*) '*ERROR in coriolissolve: fatal error'
                  write(*,*) '       in dlzit'
                  call exit(201)
               elseif(cdabs(eigb(1)).lt.1.d-10) then
                  write(*,*) '*ERROR in coriolissolve: eigenvalue'
                  write(*,*) '       out of bounds'
                  deig=0.
               else
                  size=1.d30
                  do k=1,nev
                     deig=eiga(k)/eigb(k)
                     if(cdabs(deig).lt.size) then
                        ksmall=k
                        size=cdabs(deig)
                     endif
                  enddo
                  deig=eiga(ksmall)/eigb(ksmall)
               endif
               iii=iii+1
c               write(*,*) 'coriolissolve ',iii,eig
!
               if((cdabs(deig).lt.1.d-3*cdabs(eig)).or.
     &              (cdabs(deig).lt.1.d-3).or.(iii.eq.100)) then
c                  write(*,*) 'csolve ',i,m,(eig+deig)
!
                  id=0
                  eignew=eig+deig
!
                  if((i.ne.1).or.(m.ne.1)) then
                     call ident2(eigcorio,eignew,nevcomplex,ninc,id)
                     if(id.ne.0) then
                        if((cdabs(eignew-eigcorio(id)).lt.
     &                       2.d-3*cdabs(eignew)).or.
     &                     (cdabs(eignew).lt.1.d-3)) cycle loop1
                     endif
                     if(id.ne.nevcomplex) then
                        if((cdabs(eignew-eigcorio(id+1)).lt.
     &                       2.d-3*cdabs(eignew)).or.
     &                     (cdabs(eignew).lt.1.d-3)) cycle loop1
                     endif
                  endif
!
!     solve for the eigenvalues AND eigenvectors
!
                  do k=1,nev
                     do l=1,nev
                        a(k,l)=eig*cc(k,l)*(0.d0,1.d0)
                        b(k,l)=-cc(k,l)*(0.d0,1.d0)
                     enddo
                     a(k,k)=a(k,k)-eig*eig+d(k)
                     b(k,k)=b(k,k)+2.d0*eig
                  enddo
                  wantx=.true.
                  call dlzhes(n,a,n,b,n,temp,n,wantx)
                  call dlzit(n,a,n,b,n,temp,n,wantx,iter,eiga,eigb)
!
!     copying the eigenvector into the right place
!
                  nevcomplex=nevcomplex+1
!
                  do k=nevcomplex,id+2,-1
                     eigcorio(k)=eigcorio(k-1)
                     do j=1,nev
                        x(j,k)=x(j,k-1)
                     enddo
                  enddo
!
                  do j=1,nev
                     x(j,id+1)=temp(j,ksmall)
                  enddo
                  eigcorio(id+1)=eignew
!
                  if(nevcomplex.eq.nev) exit loop2
                  exit
               else
                  eig=eig+deig
               endif
!
            enddo
         enddo loop1
         ipos=1
      enddo loop2
!
      return
      end


! =============================================================================
subroutine rp1(maxmx,meqn,mwaves,maux,mbc,mx,ql,qr,auxl,auxr,wave,s,amdq,apdq)
! =============================================================================
!
! Riemann problems for the 1D cubic equation q_t + (q^3)_x = 0.
!
! waves:     1
! equations: 1
!
! Conserved quantities:
!       1 q
!
! On input, ql contains the state vector at the left edge of each cell
!           qr contains the state vector at the right edge of each cell
!
! On output, wave contains the waves,
!            s the speeds,
!            amdq the  left-going flux difference  A^- \Delta q
!            apdq the right-going flux difference  A^+ \Delta q
!            (where the flux difference is f(qr(i-1)) - f(ql(i)))
!
! Note that the i'th Riemann problem has left state qr(:, i-1)
!                                    and right state ql(:, i)
! From the basic clawpack routine step1, rp is called with ql = qr = q.

    implicit none

    integer, intent(in) :: maxmx, meqn, mwaves, maux, mbc, mx
    double precision, dimension(meqn, 1-mbc:maxmx+mbc),         intent(in)  :: ql, qr
    double precision, dimension(maux, 1-mbc:maxmx+mbc),         intent(in)  :: auxl, auxr
    double precision, dimension(meqn, mwaves, 1-mbc:maxmx+mbc), intent(out) :: wave
    double precision, dimension(meqn, 1-mbc:maxmx+mbc),         intent(out) :: amdq, apdq
    double precision, dimension(mwaves, 1-mbc:maxmx+mbc),       intent(out) :: s

    integer :: i

    do i = 2-mbc, mx+mbc

        wave(1, 1, i) = ql(1, i) - qr(1, i-1)
        ! (ul^3 - ur^3) / (ul - ur) == ul^2 + ul*ur + ur^2
        s(1, i) = ql(1, i)*ql(1, i) + ql(1, i)*qr(1, i-1) + qr(1, i-1)*qr(1, i-1)

        amdq(1,i) = 0.d0
        apdq(1,i) = ql(1, i)*ql(1, i)*ql(1, i) - qr(1, i-1)*qr(1, i-1)*qr(1, i-1)

    enddo

    return
end


module solve
!*Description:* This module contains solvers required for placenta problems
!
! Solvers included in this module are:
!
! BICGSTAB == The STABalized BIConjugate Gradient method
!
! GMRES == Generalised Minimal RESidual method
!
! GMRES solver. The following is the code from mgmres.f90, downloaded from
! www.people.sc.fsu.edu/~jbukhardt/f_src/mgmres/mgmres.html on 13/01/2016
!
! Licensing:
!    This code is distributed under the GNU LGPL license.
! Modified:
!    17 July 2007
! Author:
!    Original C version by Lili Ju.
!    FORTRAN90 version by John Burkardt.
! Reference:
!    Richard Barrett, Michael Berry, Tony Chan, James Demmel,
!    June Donato, Jack Dongarra, Victor Eijkhout, Roidan Pozo,
!    Charles Romine, Henk van der Vorst,
!    Templates for the Solution of Linear Systems:
!    Building Blocks for Iterative Methods,
!    SIAM, 1994.
!    ISBN: 0898714710,
!    LC: QA297.8.T45.
!
!    Tim Kelley,
!    Iterative Methods for Linear and Nonlinear Equations,
!    SIAM, 2004,
!    ISBN: 0898713528,
!    LC: QA297.8.K45.
!
!    Yousef Saad,
!    Iterative Methods for Sparse Linear Systems,
!    Second Edition,
!    SIAM, 2003,
!    ISBN: 0898715342,
!    LC: QA188.S17.
!
!  Parameters:
!    Input, integer ( kind = 4 ) N, the order of the system.
!
!    Input, integer ( kind = 4 ) NZ_NUM, the number of nonzeros.
!
!    Input, integer ( kind = 4 ) IA(N+1), JA(NZ_NUM), the row and column
!    indices of the matrix values.  The row vector has been compressed.
!
!    Input, real ( kind = 8 ) A(NZ_NUM), the matrix values.
!
!    Input, real ( kind = 8 ) X(N), the vector to be multiplied by A'.
!
!    Output, real ( kind = 8 ) W(N), the value of A'*X.
!
! Information:
!    The Sparse Compressed Row storage format is used.
!
!    The matrix A is assumed to be sparse.  To save on storage, only
!    the nonzero entries of A are stored.  The vector JA stores the
!    column index of the nonzero value.  The nonzero values are sorted
!    by row, and the compressed row vector IA then has the property that
!    the entries in A and JA that correspond to row I occur in indices
!    IA[I] through IA[I+1]-1.
!
!
  use math_utilities
  implicit none
  private
  public BICGSTAB_LinSolv
  public pmgmres_ilu_cr
contains
!
!#######################################################################
!

subroutine BICGSTAB_LinSolv(MatrixSize,NonZeros,RHS,Solution,SparseCol,SparseRow,SparseVal,TOLER,MaxIter)
!*Description:*
!   This subroutine uses a preconditioned biconjugate gradient method to solve a
!   linear system Ax=b. Currently this solver is hard-coded to use the diaganol
!   entries of A as a preconditioner (the Jacobi preconditioner). However, this
!   could easily be added as an input variable. Sparsity is defined by compressed
!   row storage.
! Created by ARC: 15-12-2015
!
!   Input:
!   MatrixSize -> the size of the matrix.
!   NonZeros -> The number of non-zero entries.
!   SparseCol -> Define the column indices that have non-zero entries.
!   SparseRow ->Define the indices of SparseCol that represent each row.
!   SparseVal -> The values of non-zero entries.
!   RHS -> The vector on the RHS of the linear system
!
!   FLAGS - 0=Solution found to tolerance
!           1=No convergence max iterations reached
!           -1=breakdown rho=0
!           -2=breakdown omega=0

    use arrays

    !Input/Output Variables
    integer, intent(in) :: MatrixSize,NonZeros
    integer, intent(in) :: SparseCol(NonZeros),SparseRow(MatrixSize+1),MaxIter
    double precision :: Solution(MatrixSize),SparseVal(NonZeros),RHS(MatrixSize),TOLER

    !Local Variables
    integer :: i,k,j,kstart,kend,Iter,FLAG
    double precision :: Ax(MatrixSize),bnrm2,error_r,PreCon(MatrixSize),PreConInv(MatrixSize)
    double precision :: r(MatrixSize),rtilde(MatrixSize),alpha,beta,omega,rho,rho_1
    double precision :: p(MatrixSize),v(MatrixSize),phat(MatrixSize),s(MatrixSize),snorm,resid,shat(MatrixSize),t(MatrixSize)
    real :: start,finish
    call CPU_TIME(start)
    print *, 'In Solver, Tolerance=', TOLER, 'Max iterations=', MaxIter

! PRECONDITIONER MATRIX - THE DIAGONALS OF THE MATRIX A P=diag(A), Jacobi preconditioner Inverse is deltaij/Aij
    DO i=1,MatrixSize
        kstart=SparseRow(i)
        kend=SparseRow(i+1)-1
        DO k=kstart,kend
            IF(SparseCol(k).eq.i)THEN
                PreCon(i)=SparseVal(k)
                PreConInv(i)=1/PreCon(i)
            ENDIF
        ENDDO
    ENDDO

    !bnrm2=norm(RHS)
    bnrm2=sqrt(DOT_PRODUCT(RHS,RHS))!Checked against matlab
    IF(bnrm2.eq.0.0_dp) bnrm2=1.0_dp

    error_r=0.0_dp
    !CALL ax_cr(MatrixSize,SparseRow,SparseCol,SparseVal,solution,Ax)
    DO i=1,MatrixSize !This loop depends on sparsity structure
        Ax(i)=0.0_dp !Initialise Ax for this entry
        kstart=SparseRow(i)
        kend=SparseRow(i+1)-1
        DO k=kstart,kend
            Ax(i)=Ax(i)+SparseVal(k)*solution(SparseCol(k)) !A*X
        ENDDO
    ENDDO
    r=RHS-Ax
    rtilde=r

    error_r=sqrt(DOT_PRODUCT(r,r))/bnrm2 !Checked against matlab

    IF(error_r.lt.TOLER)THEN
        write(*,*) 'Initial guess is perfect, Exiting solver',TOLER
        FLAG=0
    RETURN
    ENDIF
    alpha=0.0_dp
    beta=0.0_dp
    omega=1.0_dp

!START OF ITERATIVE LOOP
     iterative_loop: DO Iter=1,MaxIter
        !rho is dot product of r and t tilde
        rho=DOT_PRODUCT(r,rtilde) !checked against matlab
        IF(rho.EQ.0.0_dp) EXIT iterative_loop
        IF(ITER.GT.1.0_dp)THEN
            beta=(rho/rho_1)*(alpha/omega)
            p=r+beta*(p-omega*v)
            phat=PreConInv*p
            v=0.0_dp*v
        ELSE
            p=r
            phat=PreConInv*p
            v=0.0_dp*p
        ENDIF

        !v=ApHat
        DO i=1,MatrixSize !This loop depends on sparsity structure
            kstart=SparseRow(i)
            kend=SparseRow(i+1)-1
            DO k=kstart,kend
                v(i)=v(i)+SparseVal(k)*phat(SparseCol(k))
            ENDDO
        ENDDO
        !v is correct against matlab

        alpha=rho/DOT_PRODUCT(rtilde,v) !alpha is correct first iter
        s=r-alpha*v

        snorm=sqrt(DOT_PRODUCT(s,s))!snorm correct against matlab

        !!EARLY CONVERGENCE TEST
        IF(snorm.LE.TOLER)THEN
            solution=solution+alpha*phat
            resid=snorm/bnrm2
            EXIT iterative_loop
        ENDIF

        !Stabiliser shat=precon-1*s
        shat=PreConInv*s
        t=0.0_dp*s
        DO i=1,MatrixSize
            kstart=SparseRow(i)
            kend=SparseRow(i+1)-1
            DO k=kstart,kend
                t(i)=t(i)+SparseVal(k)*shat(SparseCol(k)) !A*X !correct first iter
            ENDDO
        ENDDO
        omega=DOT_PRODUCT(t,s)/DOT_PRODUCT(t,t)!omega corect first iter

        solution=solution+alpha*phat+omega*shat
        r=s-omega*t
        error_r=SQRT(DOT_PRODUCT(r,r))/bnrm2

        IF(error_r.LE.TOLER) EXIT iterative_loop
        IF(omega.EQ.0.0_dp) EXIT iterative_loop
        rho_1=rho!

    ENDDO iterative_loop
    IF(error_r.LE.TOLER.OR.snorm.LE.TOLER)THEN
        IF(snorm.LE.TOLER)THEN
            error_r=SQRT(DOT_PRODUCT(s,s))/bnrm2
        ENDIF
!        FLAG=0
        print *, 'Converged with error=',error_r
    ELSEIF(omega.EQ.0)THEN
!        FLAG=-2
        print *, 'Not converged omega =0'
    ELSEIF(rho.EQ.0)THEN
!        FLAG=-1
        print *, 'Not converged rho =0'
    ELSE
!        FLAG=1
        print *, 'Not converged max no of iterations reached'
        print *, 'Error=',error_r
    ENDIF
    CALL CPU_TIME(finish)
    print '("Time= ",f12.9,"seconds")',finish-start

end subroutine BICGSTAB_LinSolv
!
!#############################################################################
!
subroutine pmgmres_ilu_cr ( n, nz_num, ia, ja, a, x, rhs, itr_max, mr, tol_abs, tol_rel,FLAG )
! PMGMRES_ILU_CR applies the preconditioned restarted GMRES algorithm.
!    This routine uses the incomplete LU decomposition for the
!    preconditioning.  This preconditioner requires that the sparse
!    matrix data structure supplies a storage position for each diagonal
!    element of the matrix A, and that each diagonal element of the
!    matrix A is not zero.
!    Input/output, real ( kind = 8 ) X(N); on input, an approximation to
!    the solution.  On output, an improved approximation.
!
!    Input, real ( kind = 8 ) RHS(N), the right hand side of the linear system.
!
!    Input, integer ( kind = 4 ) ITR_MAX, the maximum number of (outer)
!    iterations to take.
!
!    Input, integer ( kind = 4 ) MR, the maximum number of (inner) iterations
!    to take.  MR must be less than N.
!
!    Input, real ( kind = 8 ) TOL_ABS, an absolute tolerance applied to the
!    current residual.
!
!    Input, real ( kind = 8 ) TOL_REL, a relative tolerance comparing the
!    current residual to the initial residual.
!
    implicit none

    integer ( kind = 4 ) mr
    integer ( kind = 4 ) n
    integer ( kind = 4 ) nz_num
    integer ( kind = 4 ) ia(*) !ia(n+1)
    integer ( kind = 4 ) ja(*) !ja(nz_num)
    integer ( kind = 4 ) itr_max

    real ( kind = 8 ) a(*) !a(nz_num)
    real ( kind = 8 ) x(*) !x(n)
    real ( kind = 8 ) rhs(*) !rhs(n)
    real ( kind = 8 ) tol_abs
    real ( kind = 8 ) tol_rel
    integer (kind = 4) FLAG

    real ( kind = 8 ) av
    real ( kind = 8 ) c(mr+1)
    real ( kind = 8 ), parameter :: delta = 1.0D-03
    real ( kind = 8 ) g(mr+1)
    real ( kind = 8 ) h(mr+1,mr)
    real ( kind = 8 ) htmp
    integer ( kind = 4 ) i
    integer ( kind = 4 ) itr
    integer ( kind = 4 ) itr_used
    integer ( kind = 4 ) j
    integer ( kind = 4 ) k
    integer ( kind = 4 ) k_copy

    real ( kind = 8 ) l(ia(n+1)+1)
    real ( kind = 8 ) mu
    real ( kind = 8 ) r(n)
    real ( kind = 8 ) rho
    real ( kind = 8 ) rho_tol
    real ( kind = 8 ) s(mr+1)
    integer ( kind = 4 ) ua(n)
    real ( kind = 8 ) v(n,mr+1);
    logical, parameter :: verbose = .false. !need to change this so verbose only when diagnostics are on
    real ( kind = 8 ) y(mr+1)

    itr_used = 0
    FLAG=0 !not converged

    call rearrange_cr ( n, ia, ja, a )

    call diagonal_pointer_cr ( n, ia, ja, ua )

    call ilu_cr ( n, nz_num, ia, ja, a, ua, l )

    if ( verbose ) then
       write ( *, '(a)' ) ' '
       write ( *, '(a)' ) 'PMGMRES_ILU_CR'
       write ( *, '(a,i4)' ) '  Number of unknowns = ', n
    end if

    do itr = 1, itr_max

       call ax_cr ( n, ia, ja, a, x, r )

       r(1:n) = rhs(1:n) - r(1:n)

!!!! note that uses r,r in the call, but r,z in subroutine ??
       call lus_cr ( n, ia, ja, l, ua, r, r )

       rho = sqrt ( dot_product ( r, r ) )

       if ( verbose ) then
          write ( *, '(a,i4,a,g14.6)' ) '  ITR = ', itr, '  Residual = ', rho
       end if

       if ( itr == 1 ) then
          rho_tol = rho * tol_rel
       end if

       v(1:n,1) = r(1:n) / rho

       g(1) = rho
       g(2:mr+1) = 0.0D+00

       h(1:mr+1,1:mr) = 0.0D+00

       do k = 1, mr

          k_copy = k

          call ax_cr ( n, ia, ja, a, v(1:n,k), v(1:n,k+1) )

          call lus_cr ( n, ia, ja, l, ua, v(1:n,k+1), v(1:n,k+1) )

          av = sqrt ( dot_product ( v(1:n,k+1), v(1:n,k+1) ) )

          do j = 1, k
             h(j,k) = dot_product ( v(1:n,k+1), v(1:n,j) )
             v(1:n,k+1) = v(1:n,k+1) - v(1:n,j) * h(j,k)
          end do

          h(k+1,k) = sqrt ( dot_product ( v(1:n,k+1), v(1:n,k+1) ) )

          if ( ( av + delta * h(k+1,k)) == av ) then
             do j = 1, k
                htmp = dot_product ( v(1:n,k+1), v(1:n,j) )
                h(j,k) = h(j,k) + htmp
                v(1:n,k+1) = v(1:n,k+1) - htmp * v(1:n,j)
             end do
             h(k+1,k) = sqrt ( dot_product ( v(1:n,k+1), v(1:n,k+1) ) )
          end if

          if ( h(k+1,k) /= 0.0D+00 ) then
             v(1:n,k+1) = v(1:n,k+1) / h(k+1,k)
          end if

          if ( 1 < k ) then
             y(1:k+1) = h(1:k+1,k)
             do j = 1, k - 1
                call mult_givens ( c(j), s(j), j, y )
             end do
             h(1:k+1,k) = y(1:k+1)
          end if

          mu = sqrt ( h(k,k)**2 + h(k+1,k)**2 )

          c(k) = h(k,k) / mu
          s(k) = -h(k+1,k) / mu
          h(k,k) = c(k) * h(k,k) - s(k) * h(k+1,k)
          h(k+1,k) = 0.0D+00
          call mult_givens ( c(k), s(k), k, g )

          rho = abs ( g(k+1) )

          itr_used = itr_used + 1

          if ( verbose ) then
             write ( *, '(a,i4,a,g14.6)' ) '  K = ', k, '  Residual = ', rho
          end if

          if ( rho <= rho_tol .and. rho <= tol_abs ) then
             FLAG=1
             exit
          elseif (isnan(rho))then
             FLAG=2
             exit
          end if

       end do

       k = k_copy - 1

       y(k+1) = g(k+1) / h(k+1,k+1)

       do i = k, 1, -1
          y(i) = ( g(i) - dot_product ( h(i,i+1:k+1), y(i+1:k+1) ) ) / h(i,i)
       end do

       do i = 1, n
          x(i) = x(i) + dot_product ( v(i,1:k+1), y(1:k+1) )
       end do

       if ( rho <= rho_tol .and. rho <= tol_abs ) then
          FLAG=1
          exit
       elseif (isnan(rho))then
          FLAG=2
          exit
       end if

    end do

    if ( verbose ) then
       write ( *, '(a)' ) ' '
       write ( *, '(a)' ) 'PMGMRES_ILU_CR:'
       write ( *, '(a,i6)' ) '  Iterations = ', itr_used
       write ( *, '(a,g14.6)' ) '  Final residual = ', rho
    end if

    return
end subroutine pmgmres_ilu_cr

end module solve


      real function backtr(vrgs,nt,vr,vrg,zmin,zmax,ltail,ltpar,
     +                     utail,utpar,discrete)
C%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
C                                                                      %
C Copyright (C) 1996, The Board of Trustees of the Leland Stanford     %
C Junior University.  All rights reserved.                             %
C                                                                      %
C The programs in GSLIB are distributed in the hope that they will be  %
C useful, but WITHOUT ANY WARRANTY.  No author or distributor accepts  %
C responsibility to anyone for the consequences of using them or for   %
C whether they serve any particular purpose or work at all, unless he  %
C says so in writing.  Everyone is granted permission to copy, modify  %
C and redistribute the programs in GSLIB, but only under the condition %
C that this notice and the above copyright notice remain intact.       %
C                                                                      %
C%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
c-----------------------------------------------------------------------
c
c           Back Transform Univariate Data from Normal Scores
c           *************************************************
c
c This subroutine backtransforms a standard normal deviate from a
c specified back transform table and option for the tails of the
c distribution.  Call once with "first" set to true then set to false
c unless one of the options for the tail changes.
c
c
c
c INPUT VARIABLES:
c
c   vrgs             normal score value to be back transformed
c   nt               number of values in the back transform tbale
c   vr(nt)           original data values that were transformed
c   vrg(nt)          the corresponding transformed values
c   zmin,zmax        limits possibly used for linear or power model
c   ltail            option to handle values less than vrg(1):
c   ltpar            parameter required for option ltail
c   utail            option to handle values greater than vrg(nt):
c   utpar            parameter required for option utail
c
c
c   MODIFIED by TMH 10/2008, to allow discrete target distribution
c
c-----------------------------------------------------------------------
      parameter(EPSLON=1.0e-20)
      dimension vr(nt),vrg(nt)
      real      ltpar,utpar,lambda
      integer   ltail,utail
      real vrgs
      integer discrete

c      write(*,*) 'ARG 1 = ',vrgs,vrg(1),vrg(2)
c      write(*,*) 'discrete ? ',discrete

c
c Value in the lower tail?    1=linear, 2=power, (3 and 4 are invalid):
c
c      if(vrgs.le.vrg(1)) then
      if(vrgs.lt.vrg(1)) then
c         write(*,*) 'lower tail', vrgs, vrg(1)
            backtr = vr(1)
            cdflo  = gcum(vrg(1))
            cdfbt  = gcum(vrgs)
            if(ltail.eq.1) then
                  backtr = powint(0.0,cdflo,zmin,vr(1),cdfbt,1.0)
            else if(ltail.eq.2) then
                  cpow   = 1.0 / ltpar
                  backtr = powint(0.0,cdflo,zmin,vr(1),cdfbt,cpow)
            endif
c
c Value in the upper tail?     1=linear, 2=power, 4=hyperbolic:
c
c      else if(vrgs.ge.vrg(nt)) then
      else if(vrgs.gt.vrg(nt)) then
c         write(*,*) 'upper tail'
            backtr = vr(nt)
            cdfhi  = gcum(vrg(nt))
            cdfbt  = gcum(vrgs)
            if(utail.eq.1) then
                  backtr = powint(cdfhi,1.0,vr(nt),zmax,cdfbt,1.0)
            else if(utail.eq.2) then
                  cpow   = 1.0 / utpar
                  backtr = powint(cdfhi,1.0,vr(nt),zmax,cdfbt,cpow)
            else if(utail.eq.4) then
                  lambda = (vr(nt)**utpar)*(1.0-gcum(vrg(nt)))
                  backtr = (lambda/(1.0-gcum(vrgs)))**(1.0/utpar)
            endif
      else
cc Value within the transformation table:
c
c         write(*,*) 'IN table',discrete
c         stop

            call locate(vrg,nt,1,nt,vrgs,j)
            j = max(min((nt-1),j),1)
c            backtr = powint(vrg(j),vrg(j+1),vr(j),vr(j+1),vrgs,1.0)
	     if (discrete.eq.1) then

		     if ((vrgs-vrg(j)).lt.(vrg(j+1)-vrgs)) then
			backtr = vr(j)
		     else
			backtr = vr(j+1);
		     endif
c		     write(*,*) '1',backtr
c	             backtr = nearint(vrg(j),vrg(j+1),vr(j),vr(j+1),vrgs)
c	             write(*,*) '2',backtr

	     else
                 backtr = powint(vrg(j),vrg(j+1),vr(j),vr(j+1),vrgs,1.0)
	     endif
c 	write(*,*) 'backtr=',backtr
c	stop
      endif

      return
      end


!
!     CalculiX - A 3-dimensional finite element program
!              Copyright (C) 1998-2019 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.
!
      subroutine fsub(time,t,a,b,dd,h1,h2,h3,h4,func,funcp)
!
      implicit none
!
      real*8 time,t,a,b,dd,h1,h2,h3,h4,fexp,fsin,fcos,func,funcp,
     &  h8,h9,h10,h11,h12,h13
!
      fexp=dexp(-h1*t)
      fsin=dsin(dd*t)
      fcos=dcos(dd*t)
      h8=(a+b*time)*fexp/h2
      h9=-b*fexp/h2
      h10=-h8*h1
      h11=h8*dd
      h12=h9*(-h1*t-h3/h2)
      h13=h9*(dd*t+h4)
!
!     function
!
c      fsub=(a+b*time)*fexp*(-h1*fsin-dd*fcos)/h2-b*fexp/h2*((-h1*t-h3/h2)*
c     &     fsin-(dd*t+h4)*fcos)
      func=h10*fsin-h11*fcos+h12*fsin-h13*fcos
!
!     derivative of the function
!
      funcp=-h1*func+dd*(h10*fcos+h11*fsin+h12*fcos+h13*fsin)
!
      return
      end


c this is all matrix solving stuff from press et al., numerical recipies

c*****ludcmp*************************************************************
      subroutine ludcmp(A,n,np,indx,d,vv,ierr,lout)
c    this is adaped from numerical recipes by press et al.  <ayc 3/93>
c    this is an lu decomposer and the output is passed to susequent routines

c    Note: change of inputs - esp array vv so it can be fixed in size
c    from above

c    A is input array of n equations and is physically dimensioned np x np
c    note input matrix A is changed by this routine to give LU decomp'ed A

c    indx is output 1-D array of pivot info - this along with variable D is
c    passed to companion subroutines

c    note: code assumes no-trip do's (fortran 77 standard)

      implicit none
      real*8 tiny
      parameter(tiny = 1.0D-70)

      integer n,np,indx(np),imax,ierr,lout
      integer i,j,k
      real*8 A(np,np),vv(np),d,aamax,sum,dum

      ierr = 0

      d = 1.d0
      do 120 i = 1,n
         aamax = 1.d0

         do 110 j = 1,n
            if (dabs(A(i,j)).gt.aamax) aamax = dabs(A(i,j))
110      continue

         if (aamax.le.tiny) then
            write(lout,*) 'ERROR: singular matrix.'
            ierr = 1
            return
         endif

         vv(i) = 1.d0/aamax
120   continue

      do 190 j = 1,n
         do 140 i = 1,j-1
            sum = A(i,j)

            do 130 k= 1,i-1
               sum = sum - A(i,k)*A(k,j)
130         continue

            A(i,j) = sum
140      continue

         aamax = 0.d0
         do 160 i = j,n
            sum = A(i,j)

            do 150 k = 1,j-1
               sum = sum - A(i,k)*A(k,j)
150         continue

            A(i,j) = sum
            dum = vv(i)*dabs(sum)

            if (dum.ge.aamax) then
               imax = i
               aamax = dum
            endif
160      continue

         if (j.ne.imax) then
            do 170 k = 1,n
               dum = A(imax,k)
               A(imax,k) = A(j,k)
               A(j,k) = dum
170         continue

            d = -d
            vv(imax) = vv(j)
         endif

         indx(j) = imax
         if (dabs(A(j,j)).le.tiny) A(j,j) = dsign(tiny,A(j,j))

         if (j.ne.n) then
            dum = 1.d0/A(j,j)

            do 180 i = j+1,n
               A(i,j) = A(i,j)*dum
180         continue
         endif

190   continue

      return
      end

c*****lubksb*************************************************************
      subroutine lubksb(A,n,np,indx,B)
c    this is taken from numerical recipes by press et al.   <ayc 3/93>

c    A is LU decomp'ed array of n equations, physically dimensioned np x np
c    and was obtained by ludcmp

c    indx is 1-D array of pivot info from lubksb

c    B is input column vector (A X = B) but is changed on output to give X

      implicit none

      integer n,np,indx(np),ii,ll
      integer i,j
      real*8 A(np,np),B(np),sum

      ii = 0
      do 120 i = 1,n
         ll = indx(i)
         sum = B(ll)
         B(ll) = B(i)

         if (ii.ne.0) then
            do 110 j = ii,i-1
                sum = sum - A(i,j)*B(j)
110         continue

         elseif (sum.ne.0.d0) then
            ii = i
         endif

         B(i) = sum
120   continue

      do 140 i = n,1,-1
         sum = B(i)

         do 130 j = i+1,n
            sum = sum - A(i,j)*B(j)
130      continue

         B(i) = sum/A(i,i)
140   continue

      return
      end

c*****lfit*************************************************************
      subroutine lfit(x,y,sig,ndata,a,ma,lista,mfit,covar,ncvm,
     2   chisq,funcs,lerr)
c    this is taken from numerical recipes by press et al.   <ayc 4/93>
c    its pretty complicated so you'd better see description in book
c    comments in code are mine <ayc>

c    this program allows you to only adjust mfit of ma coefficients,
c    while keeping the rest fixed - lista is an input vector specifying
c    what parameters you want adjusted

      implicit none

c    mmax is max # of coefficients
      integer mmax
      parameter (mmax = 10)

      integer ndata,ma,lista(ma),mfit,ncvm
      integer kk,ihit,i,j,k
      real*8 x(ndata),y(ndata),sig(ndata),a(ma),covar(ncvm,ncvm),
     2   beta(mmax),afunc(mmax),chisq
      real*8 ym,sig2i,wt,sum
      external funcs

c    the following are for ldu routines which we now use
c    instead of gaussj
      integer indx(mmax),ierr,lerr
      real*8 d,vv(mmax)
c    done declarations

      kk = mfit + 1

      do 12 j = 1,ma
         ihit = 0

         do 11 k = 1,mfit
            if (lista(k).eq.j) ihit = ihit + 1
11       continue

         if (ihit.eq.0) then
            lista(kk) = j
            kk = kk + 1
         else if (ihit.gt.1) then
            stop 'improper set in lista'
         endif
12    continue

      if (kk.ne.(ma+1)) stop 'improper set in lista'

      do 14 j = 1,mfit
         do 13 k = 1,mfit
            covar(j,k) = 0.d0
13       continue
         beta(j) = 0.d0
14    continue

      do 18 i = 1,ndata
         call funcs(x(i),afunc,ma)
         ym = y(i)

         if (mfit.lt.ma) then
            do 15 j = mfit+1,ma
               ym = ym - a(lista(j))*afunc(lista(j))
15          continue
         endif

         sig2i = 1.d0/sig(i)**2

         do 17 j = 1,mfit
            wt = afunc(lista(j))*sig2i
            do 16 k = 1,j
               covar(j,k) = covar(j,k) + wt*afunc(lista(k))
16          continue
            beta(j) = beta(j) + ym*wt
17       continue
18    continue

      if (mfit.gt.1) then
         do 21 j = 2,mfit
            do 19 k = 1,j-1
               covar(k,j) = covar(j,k)
19          continue
21       continue
      endif

c    we have replaced this with call to ldu solver
c     call gaussj(covar,mfit,ncvm,beta,1,1)

c    we use lud routines instead of gaussj
c    we aren't going to do anything with inverse
c    so we just solve to get solution vector

c    NOTE: we have changed some of the inputs of these
c    routines as compared to book!!
      call ludcmp(covar,mfit,ncvm,indx,d,vv,ierr,lerr)
      call lubksb(covar,mfit,ncvm,indx,beta)

c    this has totally messed up covar but we don't
c    need it anymore - see book to get the 3 lines
c    of code to compute inverse of covar from here

      do 22 j = 1,mfit
         a(lista(j)) = beta(j)
22    continue

      chisq = 0.d0
      do 24 i = 1,ndata
         call funcs(x(i),afunc,ma)

         sum = 0.d0
         do 23 j = 1,ma
            sum = sum + a(j)*afunc(j)
23       continue
         chisq = chisq + ((y(i)-sum)/sig(i))**2
24    continue

c     call covsrt(covar,ncvm,ma,lista,mfit)
c    this sorts covariant matrix to original ordering
c    of fitting coefficients; here we neither changed
c    ordering nor do we care about this matrix so
c    we don't worry about it - note with gaussj,
c    covar would have been the inverse of the original;
c    here its become befuddled - but if we cared we
c    could fix it

      return
      end

c*****gaussj*************************************************************

c    again, same source - we were having problems with this before
c    but it works now - still, ldu routines are faster, since
c    they don't compute inverse which we don't use anyway

c    we typed this in so we'll leave it here as an alternative

      subroutine gaussj(a,n,np,b,m,mp)
      implicit none
      include 'cdparams.fh'
c     this is HORRIBLE!  dmm ... fixed 06-17-2003.  THIS is FINALLY
c     the HIDDEN 12 ISOMER PROBLEM !!! ARRGH!

c    note - set nmax to >= mxwells
c      integer nmax
c      parameter (nmax = 50)

      integer n,np,m,mp,i,j,k,irow,icol,l,ll
c      integer ipiv(nmax),indxr(nmax),indxc(nmax)
c      real*8 a(np,np),b(np,mp)
c      real*8 big,dum,pivinv

      integer ipiv(mxWells),indxr(mxWells),indxc(mxWells)
      real*8 a(np,np),b(np,mp)
      real*8 big,dum,pivinv

      do 11 j = 1,n
         ipiv(j) = 0
11    continue

      do 22 i = 1,n
         big = 0.d0
         do 13 j = 1,n

            if (ipiv(j).ne.1) then
               do 12 k = 1,n

                  if (ipiv(k).eq.0) then
                     if (abs(a(j,k)).ge.big) then
                        big = abs(a(j,k))
                        irow = j
                        icol = k
                     endif

                  else if (ipiv(k).gt.1) then
                     return
                  endif
12             continue
            endif
13       continue

         ipiv(icol) = ipiv(icol) + 1
         if (irow.ne.icol) then
            do 14 l = 1,n
               dum = a(irow,l)
               a(irow,l) = a(icol,l)
               a(icol,l) = dum
14          continue

            do 15 l = 1,m
               dum = b(irow,l)
               b(irow,l) = b(icol,l)
               b(icol,l) = dum
15          continue
         endif

         indxr(i) = irow
         indxc(i) = icol
         if (a(icol,icol).eq.0.d0) return

         pivinv = 1.d0/a(icol,icol)
         a(icol,icol) = 1.d0
         do 16 l = 1,n
            a(icol,l) = a(icol,l)*pivinv
16       continue

         do 17 l = 1,m
            b(icol,l) = b(icol,l)*pivinv
17       continue

         do 21 ll = 1,n
            if (ll.ne.icol) then
               dum = a(ll,icol)
               a(ll,icol) = 0.d0

               do 18 l = 1,n
                  a(ll,l) = a(ll,l) - a(icol,l)*dum
18             continue

               do 19 l = 1,m
                  b(ll,l) = b(ll,l) - b(icol,l)*dum
19             continue
            endif
21       continue
22    continue

      do 24 l = n,1,-1
         if (indxr(l).ne.indxc(l)) then
            do 23 k = 1,n
               dum = a(k,indxr(l))
	       a(k,indxr(l)) = a(k,indxc(l))
               a(k,indxc(l)) = dum
23          continue
         endif
24    continue

      return
      end

c $Id$
c $Author$
c $Date$
c $Source$
c $Revision$
c $Log$
c Revision 1.1  2007-02-20 23:10:23  sandeeps
c Initial revision
c
c Revision 1.3  2003/06/17 20:10:27  dmmatheu
c fixed UNBELIEVABLE HIDDEN '12' error in gaussj!  I have been looking
c for this !@#$I#" error for over 3 years ...
c
c Revision 1.2  2000/04/04 17:34:00  dmmatheu
c changed 'tiny' to 1.d-70 instead of 1.d-175 to avoid compile time
c warning
c
c Revision 1.1  2000/04/04 17:33:14  dmmatheu
c Initial revision
c


    !!!!srping phenology model
    subroutine pheno11(tt1,ta,pheno)
    real tt,a,b,pheno1,tt1(366,1),f,pheno(366,1)
    a=0.185
    b=18.4
    pheno1=0.0
    do i=1,366
        tt=tt1(i,1)
        if (tt<ta)then
            f=0.0
        else
            f=1.0/(1.0+exp(-a*(tt-b)))
        endif
        pheno1=pheno1+f
        pheno(i,1)=pheno1
    enddo
    return
    end

    !!!!autumn phenology model
    subroutine phe(pheno,tt1,dayl1,tb,ds)
    real tt1(366),dayl1(366),pheno(366),tb,cdd,tt,ds,dayl
    integer i
    pheno(1)=0
    do i=2,366
        tt=tt1(i)
        dayl=dayl1(i)
        if (dayl>=ds)then
            pheno(i)=0.0
        else
            if (tt<tb)then
                cdd=(tb-tt)*dayl/ds
            else
                cdd=0
            endif
            pheno(i)=pheno(i-1)+cdd
        endif
    enddo
    end

    !!!!calculate photoperiod
    subroutine period2(h,lat,doy)
    real lat1,lat,pi,darta,tmp1,tmp2,omiga,h
    integer doy
    pi=3.1415
    lat1=lat*pi/180.0;
    darta=0.409*sin(2.0*pi*doy/365.0-1.37);
    tmp1=-tan(darta)*tan(lat1);
    if (tmp1<= -0.99999)then
        tmp2=pi;
    elseif (tmp1>= 0.99999)then
        tmp2=0.0;
    else
        tmp2=acos(tmp1);
    endif
    omiga=tmp2;
    h=7.639437*omiga;
    end


use IOClass
use ArrayClass
implicit none

type(IO_) :: f
type(Math_) :: math
real(real64),allocatable :: t(:),ut(:),vt(:),at(:)
real(real64) :: w

! Frequency
w = 1.0d0

t = linspace([0.0d0,1.0d0], 1024)

vt = 2.0d0*t

ut = I_dx(x=t,fx=vt,f0=0.0d0)
at = d_dx(x=t,fx=vt)

call f%open("u.txt","w")
call f%write(t,ut)
call f%close()
call f%plot(option="with lines")

call f%open("a.txt","w")
call f%write(t,at)
call f%close()
call f%plot(option="with lines")

call f%open("v.txt","w")
call f%write(t,vt)
call f%close()
call f%plot(option="with lines")

end


!##########################################################################
        subroutine rungek_conv4th
!##########################################################################
        use vars
        use mpi
        use multidata
        implicit none
        integer :: i,j,k,ib,ii,jj,kk
        double precision :: du2dx,dv2dy,dw2dz
        double precision :: duvdx,duvdy,duwdx,duwdz,dvwdy,dvwdz
        double precision :: sp2,sp1,sn,sm1,sm2

        call boundu

        do ib=1,nbp

           do k=dom(ib)%ksu,dom(ib)%keu
              do i=dom(ib)%isu,dom(ib)%ieu
                 do j=dom(ib)%jsu,dom(ib)%jeu

        ii=i+2; sp2=((-dom(ib)%u(ii+1,j,k)+9.0*dom(ib)%u(ii,j,k)+
     & 9.0*dom(ib)%u(ii-1,j,k)-dom(ib)%u(ii-2,j,k))/16.0)**2
        ii=i+1; sp1=((-dom(ib)%u(ii+1,j,k)+9.0*dom(ib)%u(ii,j,k)+
     & 9.0*dom(ib)%u(ii-1,j,k)-dom(ib)%u(ii-2,j,k))/16.0)**2
        ii=i;   sn=((-dom(ib)%u(ii+1,j,k)+9.0*dom(ib)%u(ii,j,k)+
     & 9.0*dom(ib)%u(ii-1,j,k)-dom(ib)%u(ii-2,j,k))/16.0)**2
        ii=i-1; sm1=((-dom(ib)%u(ii+1,j,k)+9.0*dom(ib)%u(ii,j,k)+
     & 9.0*dom(ib)%u(ii-1,j,k)-dom(ib)%u(ii-2,j,k))/16.0)**2
                 du2dx=(-sp2+27.0*sp1-27.0*sn+sm1)/(24.0*dom(ib)%dx)

        jj=j+1; sp1=((-dom(ib)%u(i,jj+2,k)+9.0*dom(ib)%u(i,jj+1,k)+
     & 9.0*dom(ib)%u(i,jj,k)-dom(ib)%u(i,jj-1,k))/16.0)*
     &((-dom(ib)%v(i+2,jj,k)+9.0*dom(ib)%v(i+1,jj,k)+
     & 9.0*dom(ib)%v(i,jj,k)-dom(ib)%v(i-1,jj,k))/16.0)
        jj=j;   sn=((-dom(ib)%u(i,jj+2,k)+9.0*dom(ib)%u(i,jj+1,k)+
     & 9.0*dom(ib)%u(i,jj,k)-dom(ib)%u(i,jj-1,k))/16.0)*
     &((-dom(ib)%v(i+2,jj,k)+9.0*dom(ib)%v(i+1,jj,k)+
     & 9.0*dom(ib)%v(i,jj,k)-dom(ib)%v(i-1,jj,k))/16.0)
        jj=j-1; sm1=((-dom(ib)%u(i,jj+2,k)+9.0*dom(ib)%u(i,jj+1,k)+
     & 9.0*dom(ib)%u(i,jj,k)-dom(ib)%u(i,jj-1,k))/16.0)*
     &((-dom(ib)%v(i+2,jj,k)+9.0*dom(ib)%v(i+1,jj,k)+
     & 9.0*dom(ib)%v(i,jj,k)-dom(ib)%v(i-1,jj,k))/16.0)
        jj=j-2; sm2=((-dom(ib)%u(i,jj+2,k)+9.0*dom(ib)%u(i,jj+1,k)+
     & 9.0*dom(ib)%u(i,jj,k)-dom(ib)%u(i,jj-1,k))/16.0)*
     &((-dom(ib)%v(i+2,jj,k)+9.0*dom(ib)%v(i+1,jj,k)+
     & 9.0*dom(ib)%v(i,jj,k)-dom(ib)%v(i-1,jj,k))/16.0)
                 duvdy=(-sp1+27.0*sn-27.0*sm1+sm2)/(24.0*dom(ib)%dy)

        kk=k+1; sp1=((-dom(ib)%u(i,j,kk+2)+9.0*dom(ib)%u(i,j,kk+1)+
     & 9.0*dom(ib)%u(i,j,kk)-dom(ib)%u(i,j,kk-1))/16.0)*
     &((-dom(ib)%w(i+2,j,kk)+9.0*dom(ib)%w(i+1,j,kk)+
     & 9.0*dom(ib)%w(i,j,kk)-dom(ib)%w(i-1,j,kk))/16.0)
        kk=k;   sn=((-dom(ib)%u(i,j,kk+2)+9.0*dom(ib)%u(i,j,kk+1)+
     & 9.0*dom(ib)%u(i,j,kk)-dom(ib)%u(i,j,kk-1))/16.0)*
     &((-dom(ib)%w(i+2,j,kk)+9.0*dom(ib)%w(i+1,j,kk)+
     & 9.0*dom(ib)%w(i,j,kk)-dom(ib)%w(i-1,j,kk))/16.0)
        kk=k-1; sm1=((-dom(ib)%u(i,j,kk+2)+9.0*dom(ib)%u(i,j,kk+1)+
     & 9.0*dom(ib)%u(i,j,kk)-dom(ib)%u(i,j,kk-1))/16.0)*
     &((-dom(ib)%w(i+2,j,kk)+9.0*dom(ib)%w(i+1,j,kk)+
     & 9.0*dom(ib)%w(i,j,kk)-dom(ib)%w(i-1,j,kk))/16.0)
        kk=k-2; sm2=((-dom(ib)%u(i,j,kk+2)+9.0*dom(ib)%u(i,j,kk+1)+
     & 9.0*dom(ib)%u(i,j,kk)-dom(ib)%u(i,j,kk-1))/16.0)*
     &((-dom(ib)%w(i+2,j,kk)+9.0*dom(ib)%w(i+1,j,kk)+
     & 9.0*dom(ib)%w(i,j,kk)-dom(ib)%w(i-1,j,kk))/16.0)
                 duwdz=(-sp1+27.0*sn-27.0*sm1+sm2)/(24.0*dom(ib)%dz)

                 dom(ib)%ustar(i,j,k)=(dom(ib)%uoo(i,j,k)-
     & dt*alfapr*(du2dx+duvdy+duwdz))

                 end do
              end do
           end do
        end do

        call boundv

        do ib=1,nbp

           do k=dom(ib)%ksv,dom(ib)%kev
              do i=dom(ib)%isv,dom(ib)%iev
                 do j=dom(ib)%jsv,dom(ib)%jev

        jj=j+2; sp2=((-dom(ib)%v(i,jj+1,k)+9.0*dom(ib)%v(i,jj,k)+
     & 9.0*dom(ib)%v(i,jj-1,k)-dom(ib)%v(i,jj-2,k))/16.0)**2
        jj=j+1; sp1=((-dom(ib)%v(i,jj+1,k)+9.0*dom(ib)%v(i,jj,k)+
     & 9.0*dom(ib)%v(i,jj-1,k)-dom(ib)%v(i,jj-2,k))/16.0)**2
        jj=j  ; sn=((-dom(ib)%v(i,jj+1,k)+9.0*dom(ib)%v(i,jj,k)+
     & 9.0*dom(ib)%v(i,jj-1,k)-dom(ib)%v(i,jj-2,k))/16.0)**2
        jj=j-1; sm1=((-dom(ib)%v(i,jj+1,k)+9.0*dom(ib)%v(i,jj,k)+
     & 9.0*dom(ib)%v(i,jj-1,k)-dom(ib)%v(i,jj-2,k))/16.0)**2
                 dv2dy=(-sp2+27.0*sp1-27.0*sn+sm1)/(24.0*dom(ib)%dy)

        ii=i+1; sp1=((-dom(ib)%v(ii+2,j,k)+9.0*dom(ib)%v(ii+1,j,k)+
     & 9.0*dom(ib)%v(ii,j,k)-dom(ib)%v(ii-1,j,k))/16.0)*
     &((-dom(ib)%u(ii,j+2,k)+9.0*dom(ib)%u(ii,j+1,k)+
     & 9.0*dom(ib)%u(ii,j,k)-dom(ib)%u(ii,j-1,k))/16.0)
        ii=i;   sn=((-dom(ib)%v(ii+2,j,k)+9.0*dom(ib)%v(ii+1,j,k)+
     & 9.0*dom(ib)%v(ii,j,k)-dom(ib)%v(ii-1,j,k))/16.0)*
     &((-dom(ib)%u(ii,j+2,k)+9.0*dom(ib)%u(ii,j+1,k)+
     & 9.0*dom(ib)%u(ii,j,k)-dom(ib)%u(ii,j-1,k))/16.0)
        ii=i-1; sm1=((-dom(ib)%v(ii+2,j,k)+9.0*dom(ib)%v(ii+1,j,k)+
     & 9.0*dom(ib)%v(ii,j,k)-dom(ib)%v(ii-1,j,k))/16.0)*
     &((-dom(ib)%u(ii,j+2,k)+9.0*dom(ib)%u(ii,j+1,k)+
     & 9.0*dom(ib)%u(ii,j,k)-dom(ib)%u(ii,j-1,k))/16.0)
        ii=i-2; sm2=((-dom(ib)%v(ii+2,j,k)+9.0*dom(ib)%v(ii+1,j,k)+
     & 9.0*dom(ib)%v(ii,j,k)-dom(ib)%v(ii-1,j,k))/16.0)*
     &((-dom(ib)%u(ii,j+2,k)+9.0*dom(ib)%u(ii,j+1,k)+
     & 9.0*dom(ib)%u(ii,j,k)-dom(ib)%u(ii,j-1,k))/16.0)
                 duvdx=(-sp1+27.0*sn-27.0*sm1+sm2)/(24.0*dom(ib)%dx)

        kk=k+1; sp1=((-dom(ib)%v(i,j,kk+2)+9.0*dom(ib)%v(i,j,kk+1)+
     & 9.0*dom(ib)%v(i,j,kk)-dom(ib)%v(i,j,kk-1))/16.0)*
     &((-dom(ib)%w(i,j+2,kk)+9.0*dom(ib)%w(i,j+1,kk)+
     & 9.0*dom(ib)%w(i,j,kk)-dom(ib)%w(i,j-1,kk))/16.0)
        kk=k;   sn=((-dom(ib)%v(i,j,kk+2)+9.0*dom(ib)%v(i,j,kk+1)+
     & 9.0*dom(ib)%v(i,j,kk)-dom(ib)%v(i,j,kk-1))/16.0)*
     &((-dom(ib)%w(i,j+2,kk)+9.0*dom(ib)%w(i,j+1,kk)+
     & 9.0*dom(ib)%w(i,j,kk)-dom(ib)%w(i,j-1,kk))/16.0)
        kk=k-1; sm1=((-dom(ib)%v(i,j,kk+2)+9.0*dom(ib)%v(i,j,kk+1)+
     & 9.0*dom(ib)%v(i,j,kk)-dom(ib)%v(i,j,kk-1))/16.0)*
     &((-dom(ib)%w(i,j+2,kk)+9.0*dom(ib)%w(i,j+1,kk)+
     & 9.0*dom(ib)%w(i,j,kk)-dom(ib)%w(i,j-1,kk))/16.0)
        kk=k-2; sm2=((-dom(ib)%v(i,j,kk+2)+9.0*dom(ib)%v(i,j,kk+1)+
     & 9.0*dom(ib)%v(i,j,kk)-dom(ib)%v(i,j,kk-1))/16.0)*
     &((-dom(ib)%w(i,j+2,kk)+9.0*dom(ib)%w(i,j+1,kk)+
     & 9.0*dom(ib)%w(i,j,kk)-dom(ib)%w(i,j-1,kk))/16.0)
                 dvwdz=(-sp1+27.0*sn-27.0*sm1+sm2)/(24.0*dom(ib)%dz)

                 dom(ib)%vstar(i,j,k)=(dom(ib)%voo(i,j,k)-
     & dt*alfapr*(duvdx+dv2dy+dvwdz))

                 end do
              end do
           end do
        end do

        call boundw

        do ib=1,nbp

           do k=dom(ib)%ksw,dom(ib)%kew
              do i=dom(ib)%isw,dom(ib)%iew
                 do j=dom(ib)%jsw,dom(ib)%jew

        kk=k+2; sp2=((-dom(ib)%w(i,j,kk+1)+9.0*dom(ib)%w(i,j,kk)+
     & 9.0*dom(ib)%w(i,j,kk-1)-dom(ib)%w(i,j,kk-2))/16.0)**2
        kk=k+1; sp1=((-dom(ib)%w(i,j,kk+1)+9.0*dom(ib)%w(i,j,kk)+
     & 9.0*dom(ib)%w(i,j,kk-1)-dom(ib)%w(i,j,kk-2))/16.0)**2
        kk=k  ; sn=((-dom(ib)%w(i,j,kk+1)+9.0*dom(ib)%w(i,j,kk)+
     & 9.0*dom(ib)%w(i,j,kk-1)-dom(ib)%w(i,j,kk-2))/16.0)**2
        kk=k-1; sm1=((-dom(ib)%w(i,j,kk+1)+9.0*dom(ib)%w(i,j,kk)+
     & 9.0*dom(ib)%w(i,j,kk-1)-dom(ib)%w(i,j,kk-2))/16.0)**2
                 dw2dz=(-sp2+27.0*sp1-27.0*sn+sm1)/(24.0*dom(ib)%dz)

        ii=i+1; sp1=((-dom(ib)%w(ii+2,j,k)+9.0*dom(ib)%w(ii+1,j,k)+
     & 9.0*dom(ib)%w(ii,j,k)-dom(ib)%w(ii-1,j,k))/16.0)*
     &((-dom(ib)%u(ii,j,k+2)+9.0*dom(ib)%u(ii,j,k+1)+
     & 9.0*dom(ib)%u(ii,j,k)-dom(ib)%u(ii,j,k-1))/16.0)
        ii=i;   sn=((-dom(ib)%w(ii+2,j,k)+9.0*dom(ib)%w(ii+1,j,k)+
     & 9.0*dom(ib)%w(ii,j,k)-dom(ib)%w(ii-1,j,k))/16.0)*
     &((-dom(ib)%u(ii,j,k+2)+9.0*dom(ib)%u(ii,j,k+1)+
     & 9.0*dom(ib)%u(ii,j,k)-dom(ib)%u(ii,j,k-1))/16.0)
        ii=i-1; sm1=((-dom(ib)%w(ii+2,j,k)+9.0*dom(ib)%w(ii+1,j,k)+
     & 9.0*dom(ib)%w(ii,j,k)-dom(ib)%w(ii-1,j,k))/16.0)*
     &((-dom(ib)%u(ii,j,k+2)+9.0*dom(ib)%u(ii,j,k+1)+
     & 9.0*dom(ib)%u(ii,j,k)-dom(ib)%u(ii,j,k-1))/16.0)
        ii=i-2; sm2=((-dom(ib)%w(ii+2,j,k)+9.0*dom(ib)%w(ii+1,j,k)+
     & 9.0*dom(ib)%w(ii,j,k)-dom(ib)%w(ii-1,j,k))/16.0)*
     &((-dom(ib)%u(ii,j,k+2)+9.0*dom(ib)%u(ii,j,k+1)+
     & 9.0*dom(ib)%u(ii,j,k)-dom(ib)%u(ii,j,k-1))/16.0)
                 duwdx=(-sp1+27.0*sn-27.0*sm1+sm2)/(24.0*dom(ib)%dx)

        jj=j+1; sp1=((-dom(ib)%w(i,jj+2,k)+9.0*dom(ib)%w(i,jj+1,k)+
     & 9.0*dom(ib)%w(i,jj,k)-dom(ib)%w(i,jj-1,k))/16.0)*
     &((-dom(ib)%v(i,jj,k+2)+9.0*dom(ib)%v(i,jj,k+1)+
     & 9.0*dom(ib)%v(i,jj,k)-dom(ib)%v(i,jj,k-1))/16.0)
        jj=j;   sn=((-dom(ib)%w(i,jj+2,k)+9.0*dom(ib)%w(i,jj+1,k)+
     & 9.0*dom(ib)%w(i,jj,k)-dom(ib)%w(i,jj-1,k))/16.0)*
     &((-dom(ib)%v(i,jj,k+2)+9.0*dom(ib)%v(i,jj,k+1)+
     & 9.0*dom(ib)%v(i,jj,k)-dom(ib)%v(i,jj,k-1))/16.0)
        jj=j-1; sm1=((-dom(ib)%w(i,jj+2,k)+9.0*dom(ib)%w(i,jj+1,k)+
     & 9.0*dom(ib)%w(i,jj,k)-dom(ib)%w(i,jj-1,k))/16.0)*
     &((-dom(ib)%v(i,jj,k+2)+9.0*dom(ib)%v(i,jj,k+1)+
     & 9.0*dom(ib)%v(i,jj,k)-dom(ib)%v(i,jj,k-1))/16.0)
        jj=j-2; sm2=((-dom(ib)%w(i,jj+2,k)+9.0*dom(ib)%w(i,jj+1,k)+
     & 9.0*dom(ib)%w(i,jj,k)-dom(ib)%w(i,jj-1,k))/16.0)*
     &((-dom(ib)%v(i,jj,k+2)+9.0*dom(ib)%v(i,jj,k+1)+
     & 9.0*dom(ib)%v(i,jj,k)-dom(ib)%v(i,jj,k-1))/16.0)
                 dvwdy=(-sp1+27.0*sn-27.0*sm1+sm2)/(24.0*dom(ib)%dy)

                 dom(ib)%wstar(i,j,k)=(dom(ib)%woo(i,j,k)-
     & dt*alfapr*(duwdx+dvwdy+dw2dz))

                 end do
              end do
           end do

        end do

        return
        end subroutine rungek_conv4th
!##########################################################################
        subroutine rungek_diff4th
!##########################################################################
        use vars
        use mpi
        use multidata
        implicit none
        integer :: i,j,k,ib
        integer :: is,ie,js,je,ks,ke
        double precision :: dxx,dyy,dzz,visc,diff

        fac=1.0

        do ib=1,nbp
        dxx=dom(ib)%dx*dom(ib)%dx
        dyy=dom(ib)%dy*dom(ib)%dy
        dzz=dom(ib)%dz*dom(ib)%dz

        is=dom(ib)%isu; ie=dom(ib)%ieu
        js=dom(ib)%jsu; je=dom(ib)%jeu
        ks=dom(ib)%ksu; ke=dom(ib)%keu

        do k=ks,ke
           do i=is,ie
              do j=js,je
                 visc=dom(ib)%vis(i,j,k)

                 diff=visc*(
     &((-dom(ib)%u(i+2,j,k)+16.0*dom(ib)%u(i+1,j,k)
     &  -30.0*dom(ib)%u(i,j,k)+16.0*dom(ib)%u(i-1,j,k)
     &  -dom(ib)%u(i-2,j,k))/(12.0*dxx))+
     &((-dom(ib)%u(i,j+2,k)+16.0*dom(ib)%u(i,j+1,k)
     &  -30.0*dom(ib)%u(i,j,k)+16.0*dom(ib)%u(i,j-1,k)
     &  -dom(ib)%u(i,j-2,k))/(12.0*dyy))+
     &((-dom(ib)%u(i,j,k+2)+16.0*dom(ib)%u(i,j,k+1)
     &  -30.0*dom(ib)%u(i,j,k)+16.0*dom(ib)%u(i,j,k-1)
     &  -dom(ib)%u(i,j,k-2))/(12.0*dzz)))

                 dom(ib)%ustar(i,j,k)=(dom(ib)%ustar(i,j,k)+
     & dt*alfapr*diff)

                 if (pressureforce) dom(ib)%ustar(i,j,k)=
     & dom(ib)%ustar(i,j,k)+dt*alfapr*forcn

              end do
           end do
        end do

        is=dom(ib)%isv; ie=dom(ib)%iev
        js=dom(ib)%jsv; je=dom(ib)%jev
        ks=dom(ib)%ksv; ke=dom(ib)%kev

        do k=ks,ke
           do i=is,ie
              do j=js,je
                 visc=dom(ib)%vis(i,j+1,k)

                 diff=visc*(
     &((-dom(ib)%v(i+2,j,k)+16.0*dom(ib)%v(i+1,j,k)
     &  -30.0*dom(ib)%v(i,j,k)+16.0*dom(ib)%v(i-1,j,k)
     &  -dom(ib)%v(i-2,j,k))/(12.0*dxx))+
     &((-dom(ib)%v(i,j+2,k)+16.0*dom(ib)%v(i,j+1,k)
     &  -30.0*dom(ib)%v(i,j,k)+16.0*dom(ib)%v(i,j-1,k)
     &  -dom(ib)%v(i,j-2,k))/(12.0*dyy))+
     &((-dom(ib)%v(i,j,k+2)+16.0*dom(ib)%v(i,j,k+1)
     &  -30.0*dom(ib)%v(i,j,k)+16.0*dom(ib)%v(i,j,k-1)
     &  -dom(ib)%v(i,j,k-2))/(12.0*dzz)))

                 dom(ib)%vstar(i,j,k)=(dom(ib)%vstar(i,j,k)+
     & dt*alfapr*diff)

              end do
           end do
        end do

        is=dom(ib)%isw; ie=dom(ib)%iew
        js=dom(ib)%jsw; je=dom(ib)%jew
        ks=dom(ib)%ksw; ke=dom(ib)%kew

        do k=ks,ke
           do i=is,ie
              do j=js,je
                 visc=dom(ib)%vis(i,j,k+1)

                 diff=visc*(
     &((-dom(ib)%w(i+2,j,k)+16.0*dom(ib)%w(i+1,j,k)
     &  -30.0*dom(ib)%w(i,j,k)+16.0*dom(ib)%w(i-1,j,k)
     &  -dom(ib)%w(i-2,j,k))/(12.0*dxx))+
     &((-dom(ib)%w(i,j+2,k)+16.0*dom(ib)%w(i,j+1,k)
     &  -30.0*dom(ib)%w(i,j,k)+16.0*dom(ib)%w(i,j-1,k)
     &  -dom(ib)%w(i,j-2,k))/(12.0*dyy))+
     &((-dom(ib)%w(i,j,k+2)+16.0*dom(ib)%w(i,j,k+1)
     &  -30.0*dom(ib)%w(i,j,k)+16.0*dom(ib)%w(i,j,k-1)
     &  -dom(ib)%w(i,j,k-2))/(12.0*dzz)))

                 dom(ib)%wstar(i,j,k)=(dom(ib)%wstar(i,j,k)+
     & dt*alfapr*diff)

              end do
           end do
        end do

        end do

        if (LENERGY) call mom_buo
        if (LROUGH) call rough_velocity
        return
        end subroutine rungek_diff4th
!##########################################################################
        subroutine rungek_conv2nd
!##########################################################################
        use vars
        use mpi
        use multidata
        implicit none
        integer :: i,j,k,ib
        double precision :: du2dx,dv2dy,dw2dz
        double precision :: up12,um12,vp12,vm12,wp12,wm12
        double precision :: duvdx,duvdy,duwdx,duwdz,dvwdy,dvwdz

        call boundu
!	call exchange(1) !=====================check 7 bc
        do ib=1,nbp

           do k=dom(ib)%ksu,dom(ib)%keu
              do i=dom(ib)%isu,dom(ib)%ieu
                 do j=dom(ib)%jsu,dom(ib)%jeu

                 up12=0.5*(dom(ib)%u(i,j,k)+dom(ib)%u(i+1,j,k))
                 um12=0.5*(dom(ib)%u(i,j,k)+dom(ib)%u(i-1,j,k))
                 du2dx=(up12**2-um12**2)/dom(ib)%dx
                 duvdy=0.25*( (dom(ib)%v(i,j,k)+dom(ib)%v(i+1,j,k))*
     &(dom(ib)%u(i,j,k)+dom(ib)%u(i,j+1,k)) -
     &(dom(ib)%v(i,j-1,k)+dom(ib)%v(i+1,j-1,k))*
     &(dom(ib)%u(i,j,k)+dom(ib)%u(i,j-1,k)) )/dom(ib)%dy
                 duwdz=0.25*( (dom(ib)%w(i,j,k)+dom(ib)%w(i+1,j,k))*
     &(dom(ib)%u(i,j,k)+dom(ib)%u(i,j,k+1)) -
     &(dom(ib)%w(i,j,k-1)+dom(ib)%w(i+1,j,k-1))*
     &(dom(ib)%u(i,j,k)+dom(ib)%u(i,j,k-1)) )/dom(ib)%dz

                 dom(ib)%ustar(i,j,k)=(dom(ib)%uoo(i,j,k)-
     & dt*alfapr*(du2dx+duvdy+duwdz))

                 end do
              end do
           end do
        end do

        call boundv
!	call exchange(2) !======================check 7 bc
        do ib=1,nbp

           do k=dom(ib)%ksv,dom(ib)%kev
              do i=dom(ib)%isv,dom(ib)%iev
                 do j=dom(ib)%jsv,dom(ib)%jev

                 vp12=0.5*(dom(ib)%v(i,j,k)+dom(ib)%v(i,j+1,k))
                 vm12=0.5*(dom(ib)%v(i,j,k)+dom(ib)%v(i,j-1,k))
                 dv2dy=(vp12**2-vm12**2)/dom(ib)%dy
                 duvdx=0.25*( (dom(ib)%u(i,j,k)+dom(ib)%u(i,j+1,k))*
     &(dom(ib)%v(i,j,k)+dom(ib)%v(i+1,j,k)) -
     &(dom(ib)%u(i-1,j,k)+dom(ib)%u(i-1,j+1,k))*
     &(dom(ib)%v(i,j,k)+dom(ib)%v(i-1,j,k)) )/dom(ib)%dx
                 dvwdz=0.25*( (dom(ib)%w(i,j,k)+dom(ib)%w(i,j+1,k))*
     &(dom(ib)%v(i,j,k)+dom(ib)%v(i,j,k+1)) -
     &(dom(ib)%w(i,j,k-1)+dom(ib)%w(i,j+1,k-1))*
     &(dom(ib)%v(i,j,k)+dom(ib)%v(i,j,k-1)) )/dom(ib)%dz

                 dom(ib)%vstar(i,j,k)=(dom(ib)%voo(i,j,k)-
     & dt*alfapr*(duvdx+dv2dy+dvwdz))

                 end do
              end do
           end do
        end do

        call boundw
!	call exchange(3)  !=======================check 7 bc
        do ib=1,nbp

           do k=dom(ib)%ksw,dom(ib)%kew
              do i=dom(ib)%isw,dom(ib)%iew
                 do j=dom(ib)%jsw,dom(ib)%jew

                 wp12=0.5*(dom(ib)%w(i,j,k)+dom(ib)%w(i,j,k+1))
                 wm12=0.5*(dom(ib)%w(i,j,k)+dom(ib)%w(i,j,k-1))
                 dw2dz=(wp12**2-wm12**2)/dom(ib)%dz
                 duwdx=0.25*( (dom(ib)%u(i,j,k)+dom(ib)%u(i,j,k+1))*
     &(dom(ib)%w(i,j,k)+dom(ib)%w(i+1,j,k)) -
     &(dom(ib)%u(i-1,j,k)+dom(ib)%u(i-1,j,k+1))*
     &(dom(ib)%w(i,j,k)+dom(ib)%w(i-1,j,k)) )/dom(ib)%dx
                 dvwdy=0.25*( (dom(ib)%v(i,j,k)+dom(ib)%v(i,j,k+1))*
     &(dom(ib)%w(i,j,k)+dom(ib)%w(i,j+1,k)) -
     &(dom(ib)%v(i,j-1,k)+dom(ib)%v(i,j-1,k+1))*
     &(dom(ib)%w(i,j,k)+dom(ib)%w(i,j-1,k)) )/dom(ib)%dy

                 dom(ib)%wstar(i,j,k)=(dom(ib)%woo(i,j,k)-
     & dt*alfapr*(duwdx+dvwdy+dw2dz))

                 end do
              end do
           end do

        end do

        return
        end subroutine rungek_conv2nd
!##########################################################################
        subroutine rungek_convWENO
!##########################################################################
        use vars
        use mpi
        use multidata
        implicit none
        integer :: i,j,k,ib
        double precision :: du2dx,dv2dy,dw2dz
        double precision :: duvdx,duvdy,duwdx,duwdz,dvwdy,dvwdz
        double precision :: uijk,vijk,wijk,dudx,dudy,dudz
        double precision :: dvdx,dvdy,dvdz,dwdx,dwdy,dwdz

        call boundu
        call HJ_WENO_dx(1)
        call HJ_WENO_dy(1)
        call HJ_WENO_dz(1)

        do ib=1,nbp

           do k=dom(ib)%ksu,dom(ib)%keu
              do i=dom(ib)%isu,dom(ib)%ieu
                 do j=dom(ib)%jsu,dom(ib)%jeu

                    if (dom(ib)%u(i,j,k).gt.0.0) then
                       dudx = dom(ib)%dphi_dxminus(i,j,k)
                    else if (dom(ib)%u(i,j,k).lt.0.0) then
                       dudx = dom(ib)%dphi_dxplus(i,j,k)
                    else
                       dudx = 0.0
                    end if

                    vijk=0.25*(dom(ib)%v(i,j,k)+dom(ib)%v(i+1,j,k)+
     &     dom(ib)%v(i,j-1,k)+dom(ib)%v(i+1,j-1,k))
                    if (vijk.gt.0.0) then
                       dudy = dom(ib)%dphi_dyminus(i,j,k)
                    else if (vijk.lt.0.0) then
                       dudy = dom(ib)%dphi_dyplus(i,j,k)
                    else
                       dudy = 0.0
                    end if

                    wijk=0.25*(dom(ib)%w(i,j,k)+dom(ib)%w(i+1,j,k)+
     &     dom(ib)%w(i,j,k-1)+dom(ib)%w(i+1,j,k-1))
                    if (wijk.gt.0.0) then
                       dudz = dom(ib)%dphi_dzminus(i,j,k)
                    else if (wijk.lt.0.0) then
                       dudz = dom(ib)%dphi_dzplus(i,j,k)
                    else
                       dudz = 0.0
                    end if

                    du2dx=dom(ib)%u(i,j,k)*dudx
                    duvdy=vijk*dudy
                    duwdz=wijk*dudz

                 dom(ib)%ustar(i,j,k)=(dom(ib)%uoo(i,j,k)-
     & dt*alfapr*(du2dx+duvdy+duwdz))

                 end do
              end do
           end do
        end do

        call boundv
        call HJ_WENO_dx(2)
        call HJ_WENO_dy(2)
        call HJ_WENO_dz(2)

        do ib=1,nbp

           do k=dom(ib)%ksv,dom(ib)%kev
              do i=dom(ib)%isv,dom(ib)%iev
                 do j=dom(ib)%jsv,dom(ib)%jev

                    uijk=0.25*(dom(ib)%u(i,j,k)+dom(ib)%u(i,j+1,k)+
     &     dom(ib)%u(i-1,j,k)+dom(ib)%u(i-1,j+1,k))
                    if (uijk.gt.0.0) then
                       dvdx = dom(ib)%dphi_dxminus(i,j,k)
                    else if (uijk.lt.0.0) then
                       dvdx = dom(ib)%dphi_dxplus(i,j,k)
                    else
                       dvdx = 0.0
                    end if

                    if (dom(ib)%v(i,j,k).gt.0.0) then
                       dvdy = dom(ib)%dphi_dyminus(i,j,k)
                    else if (dom(ib)%v(i,j,k).lt.0.0) then
                       dvdy = dom(ib)%dphi_dyplus(i,j,k)
                    else
                       dvdy = 0.0
                    end if

                    wijk=0.25*(dom(ib)%w(i,j,k)+dom(ib)%w(i,j+1,k)+
     &     dom(ib)%w(i,j,k-1)+dom(ib)%w(i,j+1,k-1))
                    if (wijk.gt.0.0) then
                       dvdz = dom(ib)%dphi_dzminus(i,j,k)
                    else if (wijk.lt.0.0) then
                       dvdz = dom(ib)%dphi_dzplus(i,j,k)
                    else
                       dvdz = 0.0
                    end if

                    duvdx=uijk*dvdx
                    dv2dy=dom(ib)%v(i,j,k)*dvdy
                    dvwdz=wijk*dvdz

                 dom(ib)%vstar(i,j,k)=(dom(ib)%voo(i,j,k)-
     & dt*alfapr*(duvdx+dv2dy+dvwdz))

                 end do
              end do
           end do
        end do

        call boundw
        call HJ_WENO_dx(3)
        call HJ_WENO_dy(3)
        call HJ_WENO_dz(3)

        do ib=1,nbp

           do k=dom(ib)%ksw,dom(ib)%kew
              do i=dom(ib)%isw,dom(ib)%iew
                 do j=dom(ib)%jsw,dom(ib)%jew

                    uijk=0.25*(dom(ib)%u(i,j,k)+dom(ib)%u(i,j,k+1)+
     &     dom(ib)%u(i-1,j,k)+dom(ib)%u(i-1,j,k+1))
                    if (uijk.gt.0.0) then
                       dwdx = dom(ib)%dphi_dxminus(i,j,k)
                    else if (uijk.lt.0.0) then
                       dwdx = dom(ib)%dphi_dxplus(i,j,k)
                    else
                       dwdx = 0.0
                    end if

                    vijk=0.25*(dom(ib)%v(i,j,k)+dom(ib)%v(i,j,k+1)+
     &     dom(ib)%v(i,j-1,k)+dom(ib)%v(i,j-1,k+1))
                    if (vijk.gt.0.0) then
                       dwdy = dom(ib)%dphi_dyminus(i,j,k)
                    else if (vijk.lt.0.0) then
                       dwdy = dom(ib)%dphi_dyplus(i,j,k)
                    else
                       dwdy = 0.0
                    end if

                    if (dom(ib)%w(i,j,k).gt.0.0) then
                       dwdz = dom(ib)%dphi_dzminus(i,j,k)
                    else if (dom(ib)%w(i,j,k).lt.0.0) then
                       dwdz = dom(ib)%dphi_dzplus(i,j,k)
                    else
                       dwdz = 0.0
                    end if

                    duwdx=uijk*dwdx
                    dvwdy=vijk*dwdy
                    dw2dz=dom(ib)%w(i,j,k)*dwdz

                 dom(ib)%wstar(i,j,k)=(dom(ib)%woo(i,j,k)-
     & dt*alfapr*(duwdx+dvwdy+dw2dz))

                 end do
              end do
           end do

        end do

        return
        end subroutine rungek_convWENO
!##########################################################################
        subroutine rungek_diff2nd
!##########################################################################
        use vars
        use mpi
        use multidata
        implicit none
        integer :: i,j,k,ib
        integer :: is,ie,js,je,ks,ke
        double precision :: dxx,dyy,dzz,visc,diff

        fac=1.0

!======================================================
!       IMMERSED BOUNDARY MODIFICATIONS
!======================================================

        do ib=1,nbp
        dxx=dom(ib)%dx*dom(ib)%dx
        dyy=dom(ib)%dy*dom(ib)%dy
        dzz=dom(ib)%dz*dom(ib)%dz

        is=dom(ib)%isu; ie=dom(ib)%ieu
        js=dom(ib)%jsu; je=dom(ib)%jeu
        ks=dom(ib)%ksu; ke=dom(ib)%keu

        do k=ks,ke
           do i=is,ie
              do j=js,je
                 visc=dom(ib)%vis(i+1,j,k)

                 dom(ib)%aw(i,j,k)=-visc/dxx
                 dom(ib)%ae(i,j,k)=-visc/dxx
                 dom(ib)%an(i,j,k)=-visc/dyy
                 dom(ib)%as(i,j,k)=-visc/dyy
                 dom(ib)%at(i,j,k)=-visc/dzz
                 dom(ib)%ab(i,j,k)=-visc/dzz

	if (dom(ib)%bc_west.ge.61) 	dom(ib)%aw(is,j,k) = 0.d0
	if (dom(ib)%bc_east.ge.61) 	dom(ib)%ae(ie,j,k) = 0.d0
	if (dom(ib)%bc_north.ge.61) 	dom(ib)%an(i,je,k) = 0.d0
	if (dom(ib)%bc_south.ge.61) 	dom(ib)%as(i,js,k) = 0.d0
	if (dom(ib)%bc_bottom.ge.61) 	dom(ib)%ab(i,j,ks) = 0.d0
	if (dom(ib)%bc_top.ge.61) 	dom(ib)%at(i,j,ke) = 0.d0

                 dom(ib)%ap(i,j,k) = -1.0*(
     &dom(ib)%aw(i,j,k)+dom(ib)%ae(i,j,k)+
     &dom(ib)%as(i,j,k)+dom(ib)%an(i,j,k)+
     &dom(ib)%ab(i,j,k)+dom(ib)%at(i,j,k))

                 diff=-(dom(ib)%ap(i,j,k)*dom(ib)%u(i,j,k)+
     & dom(ib)%an(i,j,k)*dom(ib)%u(i,j+1,k) +
     & dom(ib)%as(i,j,k)*dom(ib)%u(i,j-1,k)+
     & dom(ib)%ae(i,j,k)*dom(ib)%u(i+1,j,k) +
     & dom(ib)%aw(i,j,k)*dom(ib)%u(i-1,j,k)+
     & dom(ib)%at(i,j,k)*dom(ib)%u(i,j,k+1) +
     & dom(ib)%ab(i,j,k)*dom(ib)%u(i,j,k-1))

                 dom(ib)%ustar(i,j,k)=(dom(ib)%ustar(i,j,k)+
     & dt*alfapr*diff)

        if (L_LSM) then! .or. L_LSMbase) then
          dom(ib)%ustar(i,j,k)=dom(ib)%ustar(i,j,k)+dt*alfapr*grx*1.0-
     & dt*alfapr*grz*sin(atan(slope))!*
!     &                                dom(ib)%blku(i,j,k))
        end if

        if (pressureforce) then
	    if (L_LSM) then
	      if (dom(ib)%phi(i,j,k) .ge. 0.0) then
 	        dom(ib)%ustar(i,j,k)= dom(ib)%ustar(i,j,k)+
     & dt*alfapr*forcn
	      endif
	    else if (L_LSMbase) then
		if (dom(ib)%zc(k).le.length) then
		  dom(ib)%ustar(i,j,k)= dom(ib)%ustar(i,j,k)+
     & dt*alfapr*forcn
		endif
	    else
 	      dom(ib)%ustar(i,j,k)=dom(ib)%ustar(i,j,k)+dt*alfapr*forcn
	    endif
	  endif

              end do
           end do
        end do

        is=dom(ib)%isv; ie=dom(ib)%iev
        js=dom(ib)%jsv; je=dom(ib)%jev
        ks=dom(ib)%ksv; ke=dom(ib)%kev

        do k=ks,ke
           do i=is,ie
              do j=js,je
                 visc=dom(ib)%vis(i,j+1,k)

                 dom(ib)%aw(i,j,k)=-visc/dxx
                 dom(ib)%ae(i,j,k)=-visc/dxx
                 dom(ib)%an(i,j,k)=-visc/dyy
                 dom(ib)%as(i,j,k)=-visc/dyy
                 dom(ib)%at(i,j,k)=-visc/dzz
                 dom(ib)%ab(i,j,k)=-visc/dzz

	if (dom(ib)%bc_west.ge.61) 	dom(ib)%aw(is,j,k) = 0.d0
	if (dom(ib)%bc_east.ge.61) 	dom(ib)%ae(ie,j,k) = 0.d0
	if (dom(ib)%bc_north.ge.61) 	dom(ib)%an(i,je,k) = 0.d0
	if (dom(ib)%bc_south.ge.61) 	dom(ib)%as(i,js,k) = 0.d0
	if (dom(ib)%bc_bottom.ge.61) 	dom(ib)%ab(i,j,ks) = 0.d0
	if (dom(ib)%bc_top.ge.61) 	dom(ib)%at(i,j,ke) = 0.d0

                 dom(ib)%ap(i,j,k) = -1.0*(
     &dom(ib)%aw(i,j,k)+dom(ib)%ae(i,j,k)+
     &dom(ib)%as(i,j,k)+dom(ib)%an(i,j,k)+
     &dom(ib)%ab(i,j,k)+dom(ib)%at(i,j,k))

                 diff=-(dom(ib)%ap(i,j,k)*dom(ib)%v(i,j,k)+
     & dom(ib)%an(i,j,k)*dom(ib)%v(i,j+1,k) +
     & dom(ib)%as(i,j,k)*dom(ib)%v(i,j-1,k)+
     & dom(ib)%ae(i,j,k)*dom(ib)%v(i+1,j,k) +
     & dom(ib)%aw(i,j,k)*dom(ib)%v(i-1,j,k)+
     & dom(ib)%at(i,j,k)*dom(ib)%v(i,j,k+1) +
     & dom(ib)%ab(i,j,k)*dom(ib)%v(i,j,k-1))

                 dom(ib)%vstar(i,j,k)=(dom(ib)%vstar(i,j,k)+
     & dt*alfapr*diff)

        if (L_LSM) then! .or. L_LSMbase) then
          dom(ib)%vstar(i,j,k)=dom(ib)%vstar(i,j,k)+dt*alfapr*gry!*
!     &                                dom(ib)%blkv(i,j,k))
        end if

              end do
           end do
        end do

        is=dom(ib)%isw; ie=dom(ib)%iew
        js=dom(ib)%jsw; je=dom(ib)%jew
        ks=dom(ib)%ksw; ke=dom(ib)%kew

        do k=ks,ke
           do i=is,ie
              do j=js,je
                 visc=dom(ib)%vis(i,j,k+1)

                 dom(ib)%aw(i,j,k)=-visc/dxx
                 dom(ib)%ae(i,j,k)=-visc/dxx
                 dom(ib)%an(i,j,k)=-visc/dyy
                 dom(ib)%as(i,j,k)=-visc/dyy
                 dom(ib)%at(i,j,k)=-visc/dzz
                 dom(ib)%ab(i,j,k)=-visc/dzz

	if (dom(ib)%bc_west.ge.61) 	dom(ib)%aw(is,j,k) = 0.d0
	if (dom(ib)%bc_east.ge.61) 	dom(ib)%ae(ie,j,k) = 0.d0
	if (dom(ib)%bc_north.ge.61) 	dom(ib)%an(i,je,k) = 0.d0
	if (dom(ib)%bc_south.ge.61) 	dom(ib)%as(i,js,k) = 0.d0
	if (dom(ib)%bc_bottom.ge.61) 	dom(ib)%ab(i,j,ks) = 0.d0
	if (dom(ib)%bc_top.ge.61) 	dom(ib)%at(i,j,ke) = 0.d0

                 dom(ib)%ap(i,j,k) = -1.0*(
     &dom(ib)%aw(i,j,k)+dom(ib)%ae(i,j,k)+
     &dom(ib)%as(i,j,k)+dom(ib)%an(i,j,k)+
     &dom(ib)%ab(i,j,k)+dom(ib)%at(i,j,k))

                 diff=-(dom(ib)%ap(i,j,k)*dom(ib)%w(i,j,k)+
     & dom(ib)%an(i,j,k)*dom(ib)%w(i,j+1,k) +
     & dom(ib)%as(i,j,k)*dom(ib)%w(i,j-1,k)+
     & dom(ib)%ae(i,j,k)*dom(ib)%w(i+1,j,k) +
     & dom(ib)%aw(i,j,k)*dom(ib)%w(i-1,j,k)+
     & dom(ib)%at(i,j,k)*dom(ib)%w(i,j,k+1) +
     & dom(ib)%ab(i,j,k)*dom(ib)%w(i,j,k-1))

                 dom(ib)%wstar(i,j,k)=(dom(ib)%wstar(i,j,k)+
     & dt*alfapr*diff)

        if (L_LSM.or.LSTRA) then	! Bousnessq approximation 2019 boyang
!-------- BA formula-------------------------------------------
	if (LSCALAR.eq..true.) then 	! density variable
      dom(ib)%wstar(i,j,k)=dom(ib)%wstar(i,j,k)+dt*alfapr*gz*         ! gravity
     & ((0.5*(dom(ib)%dens(i,j,k+1)+dom(ib)%dens(i,j,k))
     & -1000.0)/1000.0+1.0)
	else			    	! constant density
      dom(ib)%wstar(i,j,k)=dom(ib)%wstar(i,j,k)+dt*alfapr*gz        ! gravity

	endif
        end if

              end do
           end do
        end do

        end do

        if (LENERGY) call mom_buo
!	if (LSTRA) call mom_buo_dens			! stratification 09/2019
        if (LROUGH) call rough_velocity

        return
        end subroutine rungek_diff2nd
!##########################################################################


      subroutine runY_0000i(k,l,i1,Xtwiddle,Gtwiddle,Shat5zz,N0)
      implicit none
C---  Expression for D0000i obtained from 5.50, following the comment after
C     5.50 on how to add adding additional "00" pairs
C---  (similar to Eq. 5.56b but with "00" added)
      include 'pvDnames.f'
      include 'pvDv.f'
      include 'Darraydef.f'
      include 'Darrays.f'
      integer ep,N0,k,l,i1,np
      parameter(np=3)
      double precision Xtwiddle(0:np,0:np),Gtwiddle(np,np)
      double complex Shat5zz(np,z2max,-2:0)

      if ((i1 .eq. l) .or. (i1 .eq. 0)) then
      return
      endif

      do ep=-2,0

      Dv(dzzzzi(i1)+N0,ep)=
     . (-2*Gtwiddle(k,i1)*Dv(dzzzzi(l)+N0,ep)
     . +Gtwiddle(k,1)*Shat5zz(1,z2(l,i1),ep)
     . +Gtwiddle(k,2)*Shat5zz(2,z2(l,i1),ep)
     . +Gtwiddle(k,3)*Shat5zz(3,z2(l,i1),ep)
     . +Xtwiddle(0,k)*Dv(dzzii(z2(l,i1))+N0,ep)
     . -Xtwiddle(0,0)*Dv(dzziii(z3(k,l,i1))+N0,ep))/(2*Gtwiddle(k,l))

      enddo

      return
      end


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

      SUBROUTINE INVMAP (X0, Y0, X1, Y1, X2, Y2, X3, Y3, X4, Y4, SXI,
     &   SETA, INSIDE)
C***********************************************************************

C  THIS IS A TEST OF THE INVERTED MAPPING OF AN ELEMENT

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

      REAL AX, BX, CX, DX, AY, BY, CY, DY
      REAL ALPHA, BETA, GAMMA, RAD
      REAL XI, ETA, XI1, ETA1, XI2, ETA2

      LOGICAL INSIDE

      EPS = 1.E-3
      EPS2 = 1.E-10

C  GET THE A, B, C, AND D VALUES FOR X AND Y.

      AX = X1 - X0
      BX = X2 - X1
      CX = X1 - X2 + X3 -X4
      DX = X4 - X1
      AY = Y1 - Y0
      BY = Y2 - Y1
      CY = Y1 - Y2 + Y3 -Y4
      DY = Y4 - Y1

C  CALCULATE THE ALPHA, BETA, AND GAMMA VALUES.

      ALPHA = (CY * DX) - (CX * DY)
      BETA  = (AX * CY) - (AY * CX) + (BY * DX) - (BX * DY)
      GAMMA = (AX * BY) - (AY * BX)

C  CALCULATE THE XI AND ETA VALUES.

      IF (ALPHA .EQ. 0.) THEN
         ETA = -GAMMA / BETA
         IF ((ETA .EQ. 0) .AND. (BX .EQ. 0)) THEN
            XI = (Y0 - Y1) / (Y2 - Y1)
         ELSE IF ((BX .EQ. -CX) .AND. (ETA .EQ. 1.)) THEN
            XI = (Y0 - Y3)/(Y4 - Y3)
         ELSE IF (BX .EQ. (-CX * ETA)) THEN
            XI = -1000.
         ELSE
            XI = (- AX - (DX * ETA)) / (BX + (CX * ETA))
         ENDIF
      ELSE
         RAD = BETA**2 - (4. * ALPHA * GAMMA)
         IF (RAD .LT. 0.) THEN

C**               NEGATIVE RADICAL PROBLEM AS IT APPEARS THAT
C**               THIS MAY OCCUR - IT JUST MEANS THAT THE POINT
C**               TRULY IS NOT IN THE ELEMENT.

C            CALL MESSAGE('** ERROR - NEGATIVE RADICAL IN INVMAP **')
            INSIDE = .FALSE.
            GOTO 100
         ENDIF
         RAD = SQRT (RAD)
         ETA1 = (- BETA + RAD) / (2. * ALPHA)
         ETA2 = (- BETA - RAD) / (2. * ALPHA)

         IF ((ABS(ETA1) .LT. EPS2) .AND. (ABS(BX) .LT. EPS2)) THEN
            XI1 = (Y0 - Y1) / (Y2 - Y1)
         ELSE IF ((BX .EQ. -CX) .AND. (ETA1 .EQ. 1.)) THEN
            XI1 = (Y0 - Y3)/(Y4 - Y3)
         ELSE IF (BX .EQ. (-CX * ETA1)) THEN
            XI1 = -1000.
         ELSE
            XI1 = (- AX - (DX * ETA1)) / (BX + (CX * ETA1))
         ENDIF

         IF ((ABS(ETA2) .LT. EPS2) .AND. (ABS(BX) .LT. EPS2)) THEN
            XI2 = (Y0 - Y1) / (Y2 - Y1)
         ELSE IF ((BX .EQ. -CX) .AND. (ETA2 .EQ. 1.)) THEN
            XI2 = (Y0 - Y3)/(Y4 - Y3)
         ELSE IF (BX .EQ. (-CX * ETA2)) THEN
            XI2 = -1000.
         ELSE
            XI2 = (- AX - (DX * ETA2)) / (BX + (CX * ETA2))
         ENDIF

         D1 = SQRT (ETA1*ETA1 + XI1*XI1)
         D2 = SQRT (ETA2*ETA2 + XI2*XI2)
         IF (D1 .LT. D2) THEN
            ETA = ETA1
            XI = XI1
         ELSE
            ETA = ETA2
            XI = XI2
         ENDIF
      END IF

C  CHECK TO SEE IF ETA AND XI ARE WITHIN THE ELEMENT

      IF (.NOT. ((ETA .LE. 1.0 + EPS) .AND.
     &   (ETA .GE. 0.0 - EPS)) ) THEN
         INSIDE = .FALSE.
         GOTO 100
      ELSE IF (.NOT. ((XI .LE. 1.0 + EPS) .AND.
     &   (XI .GE. 0.0 - EPS)) ) THEN
         INSIDE = .FALSE.
         GOTO 100
      ELSE
         INSIDE = .TRUE.
      ENDIF
      SXI = XI
      SETA = ETA

  100 CONTINUE
      RETURN

      END


      SUBROUTINE MB03DZ( A, LDA, B, LDB, CO1, SI1, CO2, SI2 )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To compute unitary matrices Q1 and Q2 for a complex 2-by-2 regular
C     pencil aA - bB with A, B upper triangular, such that
C     Q2' (aA - bB) Q1 is still upper triangular but the eigenvalues are
C     in reversed order. The matrices Q1 and Q2 are represented by
C
C          (  CO1  SI1  )       (  CO2  SI2  )
C     Q1 = (            ), Q2 = (            ).
C          ( -SI1' CO1  )       ( -SI2' CO2  )
C
C     The notation M' denotes the conjugate transpose of the matrix M.
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     A       (input) COMPLEX*16 array, dimension (LDA, 2)
C             On entry, the leading 2-by-2 upper triangular part of
C             this array must contain the matrix A of the pencil.
C             The (2,1) entry is not referenced.
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= 2.
C
C     B       (input) COMPLEX*16 array, dimension (LDB, 2)
C             On entry, the leading 2-by-2 upper triangular part of
C             this array must contain the matrix B of the pencil.
C             The (2,1) entry is not referenced.
C
C     LDB     INTEGER
C             The leading dimension of the array B.  LDB >= 2.
C
C     CO1     (output) DOUBLE PRECISION
C             The upper left element of the unitary matrix Q1.
C
C     SI1     (output) COMPLEX*16
C             The upper right element of the unitary matrix Q1.
C
C     CO2     (output) DOUBLE PRECISION
C             The upper left element of the unitary matrix Q2.
C
C     SI2     (output) COMPLEX*16
C             The upper right element of the unitary matrix Q2.
C
C     METHOD
C
C     The algorithm uses unitary transformations as described on page 42
C     in [1].
C
C     REFERENCES
C
C     [1] Benner, P., Byers, R., Mehrmann, V. and Xu, H.
C         Numerical Computation of Deflating Subspaces of Embedded
C         Hamiltonian Pencils.
C         Tech. Rep. SFB393/99-15, Technical University Chemnitz,
C         Germany, June 1999.
C
C     NUMERICAL ASPECTS
C
C     The algorithm is numerically backward stable.
C
C     CONTRIBUTOR
C
C     Matthias Voigt, Fakultaet fuer Mathematik, Technische Universitaet
C     Chemnitz, January 26, 2009.
C
C     REVISIONS
C
C     V. Sima, Aug. 2009 (SLICOT version of the routine ZBTUEX).
C     V. Sima, Nov. 2009, Nov. 2010, Dec. 2010.
C     M. Voigt, Jan. 2012.
C
C     KEYWORDS
C
C     Eigenvalue exchange, matrix pencil, upper triangular matrix.
C
C     ******************************************************************
C
C     .. Scalar Arguments ..
      INTEGER            LDA, LDB
      DOUBLE PRECISION   CO1, CO2
      COMPLEX*16         SI1, SI2
C
C     .. Array Arguments ..
      COMPLEX*16         A( LDA, * ), B( LDB, * )
C
C     .. Local Scalars ..
      COMPLEX*16         D, G, TMP
C
C     .. External Subroutines ..
      EXTERNAL           ZLARTG
C
C     .. Executable Statements ..
C
C     For efficiency, the input arguments are not tested.
C
C     Computations.
C
      G = A( 1, 1 )*B( 2, 2 ) - A( 2, 2 )*B( 1, 1 )
      D = A( 1, 2 )*B( 2, 2 ) - A( 2, 2 )*B( 1, 2 )
      CALL ZLARTG( D, G, CO1, SI1, TMP )
      D = A( 1, 2 )*B( 1, 1 ) - A( 1, 1 )*B( 1, 2 )
      CALL ZLARTG( D, G, CO2, SI2, TMP )
C
      RETURN
C *** Last line of MB03DZ ***
      END