module global_module
   use auxilary_subroutines
implicit none
contains
!
!------------------------------------------------------------------
!subroutine in order to test if the molecular coordinates fulfill
!certain criteria.
!------------------------------------------------------------------
!
subroutine test1 (coords6, n6, logic6)
implicit none
integer, parameter :: dp = SELECTED_REAL_KIND(15)
!
real(dp), allocatable, dimension(:,:), intent(in) :: coords6
integer, intent(in) :: n6
real(dp), allocatable, dimension(:,:) :: d_matrix
real(dp), allocatable, dimension(:) :: distance_vector
integer :: i, j
character(len=1), intent(out) :: logic6
integer, allocatable, dimension(:) :: dv_test
integer :: dv_test_sum
!
!-------------------------------------------------------------------
!Build distance matrix in order to check if no two distances are less
!than 0.5 angstrom, and also, to make sure that there is no atom for
!which all of the distances are alrger than 2.5
!-------------------------------------------------------------
!
call distance_matrix (coords6, n6, d_matrix)
!
logic6 = 'Y'
!
!check if any two distances are less than 1.0 angstrom
!
do i = 1, n6-1
   do j = i+1, n6
      if (d_matrix(i,j) .lt. 1.0) then
         logic6 = 'N'
         exit
      end if
   end do
   if (logic6 == 'N') then
      deallocate(d_matrix)
      exit
   end if
end do
!
!check if at least n - 2 of the distances for every atom
!are less than 2 angstrom this makes sure that the structure is compact
!enough.
!
if (logic6 == 'Y') then
   allocate( dv_test(n6), distance_vector(n6) )
   do i = 1, n6
      do j = 1, n6
         distance_vector(j) = d_matrix(i,j) !take one row out of the
!                                            distance matrix.
      end do
      !
      do j = 1, n6
         if (distance_vector(j) .ge. 2.0) then !record distances greater
!                                               than 2 in that row
            dv_test(j) = 1
         else if (distance_vector(j) .lt. 2.0)then
            dv_test(j) = 0
         end if
      end do
      !
      dv_test_sum = 0 !count number of distances greater than 2 in that
!                                                           row
      do j = 1, n6
         dv_test_sum = dv_test_sum + dv_test(j)
      end do
      !
      if (dv_test_sum .ge. n6 - 2 ) then
         logic6 = 'N'
         exit
         deallocate (d_matrix)
      end if
   end do
   deallocate (distance_vector)
   deallocate (dv_test)
end if
!
if ( logic6 == 'Y' ) then
   deallocate(d_matrix)
end if
!
end subroutine test1
!
!------------------------------------------------------------------
!subroutine to place the center of mass of the molecule in the origin
!of the coordinate system, find the moment of inertia along which the
!maximum order of rotation is, and align the molecule along this axis
!-------------------------------------------------------------------
!
subroutine center_and_main_inertia_vector (mass,n3,coords)
implicit none
integer, parameter :: dp = SELECTED_REAL_KIND(15)
!
real(dp), allocatable, dimension(:), intent(in) :: mass
integer, intent(in) :: n3
real(dp), allocatable, dimension(:,:), intent(inout) :: coords
real(dp), allocatable, dimension(:,:) :: test
real(dp), dimension(3) :: center !center of mass
real(dp), dimension(3,3) :: inert, trans !inertia tensor
real(dp) :: sumxa, sumxb, sumya, sumyb, sumza, sumzb
integer :: i,j
!
!For DSYEV:
!
integer :: n, lwork, lda, info
character :: jobz, uplo
real(dp) :: lwork1
real(dp), dimension(3) :: w
!                                               eigenvalues and
!                                                   eigenvectors
real(dp), allocatable, dimension(:,:) :: work
!
allocate ( test(3,n3) )
!-------------------------------
!Determine center of mass:
!-------------------------------
!
!x-coordinate:
!
sumxa = 0.0
do i = 1, n3
    sumxa = sumxa + mass(i)*coords(i,1)
end do
!
sumxb = 0.0
do i =1, n3
    sumxb = sumxb + mass(i)
end do
!
center(1) = sumxa/sumxb
!
!y - coordinate:
!
sumya = 0.0
do i = 1, n3
    sumya = sumya + mass(i)*coords(i,2)
end do
!
sumyb = 0.0
do i = 1, n3
    sumyb = sumyb + mass(i)
end do
!
center (2) = sumya/sumyb
!
!z - coordinate:
!
sumza = 0.0
do i = 1, n3
    sumza = sumza + mass(i)*coords(i,3)
end do
!
sumzb = 0.0
do i = 1, n3
    sumzb = sumzb + mass(i)
end do
!
center(3) = sumza/sumzb
!
!---------------------------------------
!moving the center of mass at (0,0,0)
!---------------------------------------
!
do i = 1, n3
    coords(i,1) = coords(i,1) - center(1)
end do
!
do i = 1, n3
    coords(i,2) = coords(i,2) - center(2)
end do
!
do i = 1, n3
  coords(i,3) = coords(i,3) - center(3)
end do
!
!-----------------------------------
!Calculating the inertia tensor:
!-----------------------------------
!
inert(1,1) = 0.0
do i = 1, n3
    inert(1,1) = inert(1,1) + mass(i)*( (coords(i,2))**(2.) + &
      (coords(i,3))**(2.) )
end do
!
inert(1,2) = 0.0
do i = 1, n3
    inert(1,2) = inert(1,2) - mass(i)*coords(i,2)*coords(i,1)
end do
!
inert(2,1) = inert(1,2)
!
inert(1,3) = 0.0
do i = 1, n3
    inert(1,3) = inert(1,3) - mass(i)*coords(i,1)*coords(i,3)
end do
!
inert(3,1) = inert(1,3)
!
inert(2,2) = 0.0
do i = 1,n3
    inert(2,2) = inert(2,2) + mass(i)*( (coords(i,1))**(2.) + &
      (coords(i,3))**(2.) )
end do
!
inert(2,3) = 0.0
do i = 1, n3
    inert(2,3) = inert(2,3) - mass(i)*coords(i,2)*coords(i,3)
end do
!
inert(3,2) = inert(2,3)
!
inert(3,3) = 0.0
do i = 1, n3
    inert(3,3) = inert(3,3) + mass(i)*( (coords(i,1))**(2.) + &
      (coords(i,2))**(2.) )
end do
!
!-----------------------------------------------------------------
!Diagonalize the inertia tensor - determine the three principal
!components of the inertia tensor.
!-----------------------------------------------------------------
!
n = 3
lda = 3
jobz = 'N'
uplo = 'U'
lwork = -1
!
!--------------------------------------------
!determine the leading dimention of work:
!--------------------------------------------
!
allocate (work(1,3))
!
   call DSYEV(jobz, uplo, n, inert, lda, w, work, lwork, info)
   write(*,*) 'info:', info, 'lwork1:', work(1,1)
!
   lwork1 = work(1,1)
   deallocate (work)
!
   lwork = int(lwork1)
!
allocate (work(1,lwork))
!
!---------------------------------
!diagonalize:
!---------------------------------
!
jobz = 'V'
!
    call DSYEV(jobz, uplo, n, inert, lda, w, work, lwork, info)
!
    write(*,*) 'eigenvalues of the inertia tensor:', w
    write(*,*)  'info', info
!
deallocate (work)
!
!on input, the DSYEV subroutine takes the matrix inert, which represents
!the inertia tensor. On output it gives the same matrix (inert), but now
!it contains the eigenvectors of the inertia tensor in its columns.
!
do i = 1, 3
   do j = 1, 3
      trans(i,j) = inert(j,i)
   end do
end do
!
do i = 1, 3
   do j = 1, n3
      test(i,j) = coords(j,i)
   end do
end do
!
test = matmul(trans,test)
!
do i = 1, 3
   do j = 1, n3
      coords(j,i) = test(i,j)
   end do
end do
!
end subroutine center_and_main_inertia_vector
!
!----------------------------------------------------------------------
!This subroutine rotates a molecule around z - axis by an angle
!defined in the call of the subroutine
!-------------------------------------------------------------------
!
subroutine rotation(moly, n4, r, molz)
implicit none
integer, parameter :: dp = SELECTED_REAL_KIND(15)
!
real(dp), allocatable, dimension(:,:), intent(in) :: moly
real(dp), allocatable, dimension(:,:) :: coords3, rotated
real(dp), dimension(3,3) :: Rz ! rotation axis
integer, intent(in) :: n4 !dimension of molecule
integer, intent(in) :: r !order of rotation axis
real(dp), allocatable, dimension(:,:), intent(out) :: molz
real(dp), parameter :: pi = 3.141592653589793
real(dp) :: cosz, sinz, k ! = real(r)
integer :: i, j !counters
!
allocate ( coords3(n4,3), rotated(n4,3), molz(n4,4) )
!
do i = 1, n4
    do j = 1, 3
        coords3(i,j) = moly(i,j+1)
    end do
end do
!
k = real(r)
cosz = cos(((2.)*pi)/k)
sinz = sin(((2.)*pi)/k)
!
call z_rotation_matrix (cosz, sinz, Rz)
!
rotated = matmul(coords3, Rz)
!
do i = 1, n4
    molz(i,1) = moly(i,1) ! just transferring the atomic masses
end do
!
do i = 1, n4
    do j = 1, 3
        molz(i,j+1) = rotated(i,j)
    end do
end do
!
deallocate (coords3, rotated)
!
end subroutine rotation
!
!-----------------------------------------------------------
!subroutines to generate the rotation matrices:
!---------------------------------------------------------
!
subroutine x_rotation_matrix (cosx, sinx, Rx)
implicit none
!
integer, parameter :: dp = SELECTED_REAL_KIND(15)
real(dp), intent(in) :: cosx, sinx
real(dp), dimension(3,3), intent(out) :: Rx
!
Rx(1,1)=1
Rx(1,2)=0
Rx(1,3)=0
Rx(2,1)=0
Rx(2,2)=cosx
Rx(2,3)=-sinx
Rx(3,1)=0
Rx(3,2)=sinx
Rx(3,3)=cosx
!
end subroutine x_rotation_matrix
!
subroutine y_rotation_matrix (cosy, siny, Ry)
implicit none
!
integer, parameter :: dp = SELECTED_REAL_KIND(15)
real(dp), intent(in) :: cosy, siny
real(dp), dimension(3,3), intent(out) :: Ry
!
Ry(1,1)=cosy
Ry(1,2)=0
Ry(1,3)=-siny
Ry(2,1)=0
Ry(2,2)=1
Ry(2,3)=0
Ry(3,1)=siny
Ry(3,2)=0
Ry(3,3)=cosy
!
end subroutine y_rotation_matrix
!
subroutine z_rotation_matrix(cosz, sinz, Rz)
implicit none
!
integer, parameter :: dp = SELECTED_REAL_KIND(15)
real(dp), intent(in) :: sinz, cosz
real(dp), dimension(3,3), intent(out) :: Rz
!
Rz(1,1)=cosz
Rz(1,2)=-sinz
Rz(1,3)=0
Rz(2,1)=sinz
Rz(2,2)=cosz
Rz(2,3)=0
Rz(3,1)=0
Rz(3,2)=0
Rz(3,3)=1
!
end subroutine z_rotation_matrix
!
!----------------------------------------------------------
!Align the molecule so that the selcted moment of inertia
!is along the z - axis of the cartesian coordinate system:
!-----------------------------------------------------------
!
subroutine align (vector, mol1, n5, mol2)
implicit none
integer, parameter :: dp = SELECTED_REAL_KIND(15)

real(dp), dimension(3), intent(inout) :: vector
real(dp), dimension(3,1) :: vector1
real(dp), dimension(3,1) :: vecxz !rotation around x-axis to
                !move the vector
                    !to the xz plane
real(dp), dimension(3,1) :: vecz ! the vector is aligned
                    !with z - axis after rotation around y - axis
integer, intent(in) :: n5 !number of atoms in the molecule
real(dp), allocatable, dimension(:,:), intent(in) :: mol1 !input molecule
real(dp), allocatable, dimension(:,:) :: matrix5, coords5, rotated1, rotated2
                    !working functions
real(dp) :: cosx, sinx, cosy, siny ! to rotate space about the x & y - axes
real(dp), dimension(3,3) :: Rx, Ry !Rotation about x & y - axes
real(dp), allocatable, dimension(:,:), intent(out) :: mol2
integer :: i, j
!
!-----------------------------------------------------------------
!This subroutine aligns the axis of interest with the z - axis.
!It does this by determining the sine and cosine of the angles between
!that axis and the z- and x- or y- axes,
!based on its position relative to the coordinate system,
!building the rotation matrices for rotation around the y - and x -
!matrices and then applying them to every atom in the molecule.
!
!This is equivalent to either rotating the entire
!molecule, or "moving space", i.e. rotating the coordinate system,
!to allow the axis of interest to be aligned with the z - axis
!--------------------------------------------------------------
!
do i = 1, 3 !convert to column vector
   vector1(i,1) = vector(i)
end do
!
allocate (coords5(3,n5), mol2(n5,4), matrix5(n5,3))
allocate (rotated1(3,n5), rotated2(3,n5))
!
do i = 1, n5
    do j = 1, 3
        matrix5(i,j) = mol1(i,j+1)
    end do
end do
!
!convert to column vectors:
!
do i = 1, n5
   do j = 1, 3
      coords5(j,i) = matrix5(i,j)
   end do
end do
!
if (dabs(vector(1)) .le. 0.000000000001) then
   if (dabs(vector(2)) .gt. 0.000000000001) then
      !
      !----------------------------
      ! [0,y,z]
      !--------------------------
      !
      !----------------------------------------------
      !find matrix for rotation about the x-axis
      !-----------------------------------------------
      !
      cosx=vector(3)/sqrt( vector(2)**(2.) + vector(3)**(2.) )
      sinx=vector(2)/sqrt( vector(2)**(2.) + vector(3)**(2.) )
      !
      !
      call x_rotation_matrix (cosx, sinx, Rx)
      !
      !--------------------------------------------------------
      !rotate space about the x - axis to bring the inertia vector in
      !the xz-plane:
      !----------------------------------------------------------
      !
      rotated2 = matmul(Rx,coords5)
      vecz = matmul(Rx,vector1)
      write(*,*) 'vecz', vecz
      !
   else if (dabs(vector(2)) .le. 0.000000000001) then
      !
      !-------------------------------------------
      ! [0,0,z]
      !-----------------------------------------------
      !
      vecz = vector1
      write(*,*) 'vecz', vecz
      do i = 1, 3
         do j = 1, n5
            rotated2(i,j) = coords5(i,j)
         end do
      end do
   end if
   !
   !
else if (dabs(vector(1)) .gt. 0.000000000001) then
   if (dabs(vector(2)) .le. 0.000000000001) then
      !
      !---------------------------------------------
      ! [x, 0, z]
      !----------------------------------------------------
      !
      !---------------------------------------------------
      !find matrix for rotation about the y-axis
      !--------------------------------------------------
      !
      cosy = vector(3)/sqrt(vector(1)**(2.) + vector(3)**(2.))
      siny = vector(1)/sqrt(vector(1)**(2.) + vector(3)**(2.))
      !
      call y_rotation_matrix (cosy, siny, Ry)
      !
      !-------------------------------------------------------------
      !rotate space around the y - axis, so that the rotation axis lies
      !along the positive z - axis
      !----------------------------------------------------------------
      !
      rotated2 = matmul(Ry,coords5)
      vecz = matmul(Ry,vector1) !should have the form [0,0,z]
      write(*,*) 'vecz', vecz
   else if (dabs(vector(2)) .gt. 0.000000000001) then
      !
      !-------------------------------------
      ! [x, y, z]
      !---------------------------------------
      !
      !----------------------------------------------
      !find matrix for rotation about the x-axis
      !-----------------------------------------------
      !
      cosx = vector(3)/sqrt( vector(2)**(2.) + vector(3)**(2.) )
      sinx = vector(2)/sqrt( vector(2)**(2.) + vector(3)**(2.) )
      !
      call x_rotation_matrix (cosx, sinx, Rx)
      !
      !--------------------------------------------------------
      !rotate space about the x - axis to bring the inertia vector in
      !the xz-plane:
      !---------------------------------------------------------
      !
      rotated1 = matmul(Rx,coords5)
      vecxz = matmul(Rx,vector1)
      write(*,*) 'vecxz', vecxz
      !
      !---------------------------------------------------
      !find matrix for rotation about the y-axis
      !---------------------------------------------------
      !
      cosy = vecxz(3,1)/sqrt( vecxz(1,1)**(2.) + vecxz(3,1)**(2.) )
      siny = vecxz(1,1)/sqrt( vecxz(1,1)**(2.) + vecxz(3,1)**(2.) )
      !
      call y_rotation_matrix (cosy, siny, Ry)
      !
      !-------------------------------------------------------------
      !rotate space around the y - axis, so that the rotation axis lies
      !along the positive z - axis
      !----------------------------------------------------------------
      !
      rotated2 = matmul(Ry,rotated1)
      vecz = matmul(Ry,vecxz) !should have the form [0,0,z]
      write(*,*) 'vecz', vecz
      !
   end if
end if
!
do i = 1, n5
   mol2(i,1) = mol1(i,1) ! just transferring the atomic masses
end do
!
do i = 1, n5
   do j = 1, 3
      matrix5(i,j) = rotated2(j,i) ! take the transpose
   end do
end do
!
do i = 1, n5
   do j = 1, 3
      mol2(i,j+1) = matrix5(i,j)
   end do
end do
!
deallocate(rotated1, rotated2)
!
end subroutine align
!
!------------------------------------------------------------------
!subroutine in order to test if the molecular coordinates are equal to
!to any previously generated set of coordinates:
!------------------------------------------------------------------
!
subroutine test2 (mass8, coords8, n8, c8, logic8)
implicit none
integer, parameter :: dp = SELECTED_REAL_KIND(15)
!
real(dp), allocatable, dimension(:), intent(in) :: mass8
real(dp), allocatable, dimension(:,:), intent(in) :: coords8
real(dp), allocatable, dimension(:,:) :: mold, mole
integer, intent(in) :: n8, c8
integer :: i, j, k
character(len=1), intent(out) :: logic8
character(len=3) :: file8
integer :: logic5
!
logic8 = 'Y'
!
!check if it is equal to any previous set of generated coordinates
!
if (c8 .gt. 150 )then
   allocate( mold (n8,4), mole(n8,4) )
   do j = 1, n8 !this structure:
      mole(j,1) = mass8(j)
      mole(j,2) = coords8(j,1)
      mole(j,3) = coords8(j,2)
      mole(j,4) = coords8(j,3)
   end do
   do i = 150, c8 - 1
      !
      write(file8, "(I3)") i
      open(unit=i, file=file8, status='old', action='read')
      do k = 1, n8 !previous structure:
         read(i,*) (mold (k,j), j = 1, 4)
      end do
      close(i)
      !
      call compare(mole, mold, n8, logic5)
      if (logic5 == 1) then
         logic8 = 'N'
         exit
      end if
   end do
   deallocate (mold, mole)
end if
!
end subroutine test2
!
!-----------------------------------------------------------------
!Subroutine to compare two matrices (molecular structures), to see
!if they are trully identical.
!-----------------------------------------------------------------
!
subroutine compare (matrix1, matrix2, natoms7, prod)
implicit none
integer, parameter :: dp = SELECTED_REAL_KIND(15)
!
integer :: i, j
integer, intent(in) :: natoms7
real(dp), allocatable, dimension(:,:), intent(in) :: matrix1, matrix2
integer, allocatable, dimension (:) :: comparison, B, BB ! comparison array
integer, intent(out) :: prod ! for the product for the comparison
!
allocate (comparison(natoms7), B(natoms7), BB(natoms7))
!
do i = 1, natoms7 !set them to 0 at the start of the comparison.
    B(i) = 0
    comparison(i) = 0
    BB(i) = 0
end do
!
!--------------------------------------------------------------------
!check if for every atom in matrix1, there is an atom in matrix2 that
!has the same set of coordinates:
!--------------------------------------------------------------------
!
do i = 1, natoms7
   do j = 1, natoms7
      if (j == B(j)) cycle
      if (i == BB(i)) cycle
      if (dabs( matrix1(i,1) - matrix2(j,1)) .LE. 0.0001) then
         if (dabs(matrix1(i,2) - matrix2(j,2)) .LE. 0.015) then
            if (dabs(matrix1(i,3) - matrix2(j,3)) .LE. 0.015) then
               if (dabs(matrix1(i,4) - matrix2(j,4)) .LE. 0.015) then
                  comparison(i) = 1
                  B(j) = j
                  BB(i) = i
                  exit
               end if
            end if
         end if
      end if
   end do
end do
!
!---------------------------------------------------------------------
!and now to see if all the matrix elements have been found to be equal
!----------------------------------------------------------------------
!
prod = 1
do i = 1, natoms7
    prod = prod * comparison(i)
end do
!
deallocate(comparison, B, BB)
!
end subroutine compare
!
!-----------------------------------------------------------------
!To determine if there are symmetrically equivalent atoms:
!-----------------------------------------------------------------
!
subroutine SEA (b_matrix, b_atoms, SEA_array)
implicit none
integer, parameter :: dp = SELECTED_REAL_KIND(15)
!
real(dp), allocatable, dimension(:,:), intent(in) :: b_matrix
integer, intent(in) :: b_atoms !number of atoms
real(dp), allocatable, dimension(:,:) :: distance_m
integer :: i, k, j, l, h, f, prod1
integer, allocatable, dimension(:) :: equivalent, A, B, C
real(dp), allocatable, dimension(:) :: D1, D2
logical, allocatable, dimension(:), intent(out) ::  SEA_array
!
!-------------------------------------------------------------------
!Build distance matrix in order to find two symetrically equivalent atoms
!-------------------------------------------------------------
!
call distance_matrix (b_matrix, b_atoms, distance_m)
!
!-----------------------------------------
!find two symetrically equivalent atoms:
!-----------------------------------------
!
allocate (D1(b_atoms), D2(b_atoms), A(b_atoms), equivalent(b_atoms), &
  B(b_atoms), C(b_atoms), SEA_array(b_atoms) )

do i = 1, b_atoms
    C(i) = 0
    SEA_array(i) = .false.
end do
!
!First, select a column (i) from the distance matrix. The set fo SEA
!to i will be searched for. Then, another one, (i+1), and the set if
!SEA for this one will be searched for as well.
!
determine_SEA: do i = 1, b_atoms - 1
   if (i == C(i)) cycle !It has been found to be a SEA
   do k = i + 1, b_atoms
      if (k == C(k)) cycle !It has been found to be a SEA from
!                             another set
      do h = 1, b_atoms
         equivalent(h) = 0 !return the variable used for comparison to 0.
         B(h) = 0
         A(h) = 0
      end do
!     Now, fill the D1 and D2 vectors used for the comparison with elements
!     from the i and k rows:
      do j = 1, b_atoms
         do l = 1, b_atoms
            D1(j) = distance_m(i,j)
            D2(l) = distance_m(k,l)
         end do
      end do
!     Compare these two columns of the distance matrix
!     to see if they have the same elements
      do j = 1, b_atoms
         do l = 1 , b_atoms
            if (j == A(j)) cycle !to not check a distance that has alread
            if (l == B(l)) cycle !been found to be equal for both atoms
            if ( dabs(D1(j)-D2(l)) .LE. 0.0001 ) then
               equivalent(j) = 1
               A(j) = j
               B(l) = l
               exit
            end if
         end do
      end do
      write(*,*) 'equivalent?', equivalent
      prod1 = 1 !to see if for every element in D1 a corresponding equal
!                element in D2 has been found.
     do f = 1, b_atoms
         prod1 = prod1 * equivalent(f)
         write(*,*) 'prod', prod1
      end do
      if (prod1 == 1) then
!        fix one of the SEA atoms to not have it's atom changed from
!        B to V
         SEA_array(k) = .true. !will not be included
         C(k) = k
      end if
  end do
end do determine_SEA
!
write(*,*) 'SEA Atoms', SEA_array
!
end subroutine SEA
!
!---------------------------------------------------------------------
!Find the kth lexicographical combination
!in the set of combinations of m out of n
!---------------------------------------------------------------------
!
subroutine lexicographical_order (k_comb, ng, n18, combination18)
implicit none
!
integer, intent(in) :: k_comb, ng, n18
integer(kind=16) :: n16, j, test, previous_step
integer :: i, m_comb, l
integer, allocatable, dimension(:), intent(out) :: combination18
logical :: finish
!
allocate( combination18(n18) )
!
!------------------------
!First combination:
!------------------------
!
do i = 1, n18
   combination18(i) = i
end do
!
test = 1
i = 1 ! number of elements in the combination array [1 2 3 ...] of n
j = ng !number of elements in the set from which the combination is
!           selected (n-p)
n16=n18 !integer(kind=16)
finish = .false.
m_comb = 1
!
!---------------------------------
!The other combinations:
!---------------------------------
!
do while ( (i .le. n18) .and. (finish .eqv. .false.) )
   do while (j .ge. 0)
      m_comb = m_comb + 1
      combination18(i) = m_comb
      previous_step = test
      !
      test = test + combination_x_of_p(n16-i,j-i)
      !
      if (test == k_comb) then
         do l = i + 1, n18
            combination18(l) = combination18(l-1) + 1
         end do
         finish = .true.
         exit
      else if (test .gt. k_comb) then
         m_comb = m_comb - 1
         combination18(i) = m_comb
         test = previous_step
         m_comb = m_comb + 1
         exit
      else if (test .lt. k_comb) then
         j = j - 1
      end if
   end do
   i = i + 1
end do
!
write(*,'(I5,A14,I5,A6,I5,A1)') k_comb, 'combination of', n18, &
   'out of', ng, ':'
write(*,*) combination18
!
!--------------------------------------------------
!example:
!--------------------------------------------------
!
!number of combinations of 5 out of 10 = 252
!lets find the 100th in lexicographical order.
!
!The very first combination is:
!
!1 2 3 4 5
!
!and, then the rest are combinations of the type:
!
!1 . . . . . . . . . .
!
!until we get to combinations of the type:
!
!. 2 . . . . . . . . .
!
!But, how many of them are there?
!
!Well, if we fix m(1) = 1, there are nine elements left in n to
!make combinations out of, and four free spaces in
!the set of elements of the 100th combination, so the number of
!1 x x x x combinations is:
!
!C 4 of 9 = 189
!
!So, there are 189 more such combinations, and the 199th is of the type
!2 x x x x. More precisely, the 199th is 2 3 4 5 6.
!
!199th : . 2 . . . . . . . .
!
!That is over 100, so we stick with the 1 . . . . type combinations, which are from 1 to 189, and thus contain the 100th
!combination.
!
!------------------------------------
!
!      [ 1 . . . . ]
!
!By the same logic, we can find the second element in
!the 100th combination as
!
!---------------------------------
!
!1st : 1 2 . . . . . . . .
!
!---------------------------------
!
!c 3 of 8 = 56 + 1 = 57
!
!57th: 1 . 3 . . . . . . .
!
!--------------------------------------
!
!c 3 of 7 = 35 + 57 = 92
!
!92nd: 1 . . 4 . . . . . .
!
!-------------------------------------
!
!c 3 of 6 = 20
!
!112th : 1 . . . 5 . . . .
!
!-----------------------------------------
!
!           [ 1 4 . . . ]
!
!--------------------------------------------
!
!92nd: 1 . . 4 5 . . . . .
!
!------------------------------------------------
!
!c 2 of 5 = 10 + 92 = 102
!
!102nd 1 . . 4 . 6 . . . .
!
!------------------------------------------
!
!           [1 4 5 . . ]
!
!92nd: 1 . . 4 5 6 . . . .
!
!-----------------------------------------
!
!c 1 of 4 = 4
!
!96th 1 . . 4 5 . 7 . . .
!
!--------------------------------------
!
!c 1 of 3 = 3
!
!99th: 1 . . 4 5 . . 8 . .
!
!------------------------------------------
!
!c 1 of 2 = 2 + 99 = 101
!
!101st: 1 . . 4 5 . . . 9
!
!           [1 4 5 8 . ]
!
!--------------------------------------------
!
!99th: 1 . . 4 5 . . 8 9 .
!
!c 0 of 1  = 1
!
!--------------------------------------------------
!
!99 + 1 = 100
!
!100th: 1 . . 4 5 . . 8 . 10
!
!--------------------------------------------------
!
end subroutine lexicographical_order
!
!----------------------------------------------------------------
!to determine the direction of the walk
!----------------------------------------------------------------
!
real(kind=8) function random_walk(x, change)
implicit none
!
real(kind=8), intent(in) :: x, change
real(kind=8), dimension(1) :: walk
!
call random_number(walk)
if (walk(1) .lt. 0.5) then
   random_walk = x + change
else
   random_walk = x - change
end if
!
end function random_walk
!
end module global_module


c               Copyright 1993 Colorado State University
c                       All Rights Reserved

      double precision function catanf(x,a,b,c,d)

      implicit none
      include 'pi.inc'

c ... Argument declarations
      double precision x, a, b, c, d

c ... ******************** flowlib *********************
c ...
c ... (run-time sub-set of modaid, exclusive of modctl)
c ...
c ... release 1.0  (first formal release of modaid)
c ...
c ... james m. vevea
c ... natural resource ecology lab
c ... colorado state university
c ... fort collins, colorado  80523
c ...
c ... this routine is functionally equivalent to the routine of the
c ... same name, described in the publication:
c ...
c ... some graphs and their functional forms
c ... technical report no. 153
c ... william parton and georgo innis  (1972)
c ... natural resource ecology lab.
c ... colorado state university
c ... fort collins, colorado  80523

      catanf = b + (c / PI) * atan(PI * d * (x - a))
c     write(*,*) 'atan = ' , atan(PI * d * (x - a))

      return
      end


c
c --- main program below module
c
      MODULE EULER_ROTATION
      IMPLICIT NONE

!-----------------------------------------------------------------------
! euler rotation of model geometry
!-----------------------------------------------------------------------
! based on code fragments provided for AOMIP by David Holland.
! http://fish.cims.nyu.edu/project_aomip/model_grid/overview.html
!-----------------------------------------------------------------------
!
! C_ALPHA : rotation about z-axis
! C_BETA  : rotation about new y-axis
! C_GAMMA : rotation about new z-axis
!
! C_FORWARD : rotation matricies to geographic coordinates
! C_REVERSE : rotation matricies to model coordinates
!
!-----------------------------------------------------------------------

      REAL*8 ::
     &      C_ALPHA  = 000.0

      REAL*8 ::
     &      C_BETA   = 000.0

      REAL*8 ::
     &      C_GAMMA  = 000.0

      REAL*8,
     &      DIMENSION (1:3, 1:3) ::
     &      C_FORWARD = 0.0

      REAL*8,
     &      DIMENSION (1:3, 1:3) ::
     &      C_REVERSE = 0.0

      REAL*8, PRIVATE, PARAMETER :: C_EPSILON=1.0d-6
      REAL*8, PRIVATE, PARAMETER ::    RADIAN=57.29577951D0
      REAL*8, PRIVATE, PARAMETER :: INVRADIAN=1.d0/RADIAN

!-----------------------------------------------------------------------
      CONTAINS
!-----------------------------------------------------------------------

      REAL*8 FUNCTION C_SIND(X)
      REAL*8 X
      C_SIND = SIN(X*INVRADIAN)
      END FUNCTION C_SIND

      REAL*8 FUNCTION C_COSD(X)
      REAL*8 X
      C_COSD = COS(X*INVRADIAN)
      END FUNCTION C_COSD

      REAL*8 FUNCTION C_INV_SIND(X)
      REAL*8 X
      C_INV_SIND = RADIAN*ASIN(X)
      END FUNCTION C_INV_SIND

      REAL*8 FUNCTION C_INV_COSD(X)
      REAL*8 X
      C_INV_COSD = RADIAN*ACOS(X)
      END FUNCTION C_INV_COSD

      SUBROUTINE C_EULER_ROTATION_MATRIX

!-----------------------------------------------------------------------
! purpose: compute euler rotation matrix
!-----------------------------------------------------------------------
!
! C_ALPHA   : rotation about z-axis
! C_BETA    : rotation about new y-axis
! C_GAMMA   : rotation about new z-axis
! C_REVERSE : rotation to model coordinates
! C_FORWARD : rotation to geographic coordinates
!
!-----------------------------------------------------------------------

      !local vars
      REAL*8 ::
     &
     &      COSA,
     &      SINA,
     &      COSB,
     &      SINB,
     &      COSG,
     &      SING

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

      !compute sin and cos of all angles in degrees
      COSA  = C_COSD (C_ALPHA )
      SINA  = C_SIND (C_ALPHA )
      COSB  = C_COSD (C_BETA  )
      SINB  = C_SIND (C_BETA  )
      COSG  = C_COSD (C_GAMMA )
      SING  = C_SIND (C_GAMMA )

      !compute rotation matrix into model coordinates
      C_REVERSE (1,1) =   COSA * COSB * COSG  -  SINA * SING
      C_REVERSE (1,2) =   SINA * COSB * COSG  +  COSA * SING
      C_REVERSE (1,3) =        - SINB * COSG
      C_REVERSE (2,1) = - COSA * COSB * SING  -  SINA * COSG
      C_REVERSE (2,2) = - SINA * COSB * SING  +  COSA * COSG
      C_REVERSE (2,3) =          SINB * SING
      C_REVERSE (3,1) =   COSA * SINB
      C_REVERSE (3,2) =   SINA * SINB
      C_REVERSE (3,3) =          COSB

      !compute rotation matrix into geographical coordinates
      C_FORWARD (1,1) =   COSG * COSB * COSA  -  SING * SINA
      C_FORWARD (1,2) = - SING * COSB * COSA  -  COSG * SINA
      C_FORWARD (1,3) =          SINB * COSA
      C_FORWARD (2,1) =   COSG * COSB * SINA  +  SING * COSA
      C_FORWARD (2,2) = - SING * COSB * SINA  +  COSG * COSA
      C_FORWARD (2,3) =          SINB * SINA
      C_FORWARD (3,1) = - COSG * SINB
      C_FORWARD (3,2) =   SING * SINB
      C_FORWARD (3,3) =          COSB

!-----------------------------------------------------------------------
      END SUBROUTINE C_EULER_ROTATION_MATRIX

      SUBROUTINE C_MODEL_TO_GEO (X_IN_ANGLE,
     &                           Y_IN_ANGLE,
     &                           X_OUT_ANGLE,
     &                           Y_OUT_ANGLE)

!---------------------------------------------------------------------
! purpose: a coordinate transformation from model coordinates
!          to geographic coordinates
!--------------------------------------------------------------------
!
! variables
!
! X_IN_ANGLE  : X-COORDINATE IN MODEL SYSTEM.
! Y_IN_ANGLE  : Y-COORDINATE IN MODEL SYSTEM.
! X_OUT_ANGLE : X-COORDINATE IN GEOGRAPHICAL SYSTEM.
! Y_OUT_ANGLE : Y-COORDINATE IN GEOGRAPHICAL SYSTEM.
!
! THE ROTATION FROM THE COORDINATE SYSTEM,
! X''',Y''',Z''' BACK TO THE ORIGINAL COORDINATE SYTEM
! CAN BE PERFORMED BY DOING THE ROTATION IN
! REVERSED ORDER AND WITH OPPOSITE SIGN ON THE ROTATED ANGLES.
!
!---------------------------------------------------------------------

      !passed arguments
      REAL*8,
     &      INTENT (IN) ::
     &
     &      X_IN_ANGLE,
     &      Y_IN_ANGLE

      !passed arguments
      REAL*8,
     &      INTENT (OUT) ::
     &
     &      X_OUT_ANGLE,
     &      Y_OUT_ANGLE

      !local vars
      REAL*8 ::
     &
     &      X_TMP_ANGLE,
     &      Y_TMP_ANGLE,
     &      XX,
     &      YY,
     &      ZZ,
     &      XNEW,
     &      YNEW,
     &      ZNEW,
     &      COSTN,
     &      PHI_NEW,
     &      THETA_NEW

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

      !initial angles of rotation
      X_TMP_ANGLE = X_IN_ANGLE
      Y_TMP_ANGLE = Y_IN_ANGLE

      !avoid trouble of an exactly zero angle by adding offset
      X_TMP_ANGLE = X_TMP_ANGLE + C_EPSILON
      Y_TMP_ANGLE = Y_TMP_ANGLE + C_EPSILON

      !spherical coordiantes to cartesian coordinates
      XX = C_COSD (Y_TMP_ANGLE) * C_COSD (X_TMP_ANGLE)
      YY = C_COSD (Y_TMP_ANGLE) * C_SIND (X_TMP_ANGLE)
      ZZ = C_SIND (Y_TMP_ANGLE)

      !new cartesian coordinates are given by
      XNEW = C_FORWARD (1,1) * XX
     &     + C_FORWARD (1,2) * YY
     &     + C_FORWARD (1,3) * ZZ
      YNEW = C_FORWARD (2,1) * XX
     &     + C_FORWARD (2,2) * YY
     &     + C_FORWARD (2,3) * ZZ
      ZNEW = C_FORWARD (3,1) * XX
     &     + C_FORWARD (3,2) * YY
     &     + C_FORWARD (3,3) * ZZ

      !obtain new angles THETA_NEW,COSTN,PHI_NEW
      THETA_NEW  = C_INV_SIND (ZNEW)
      COSTN = SQRT (1.0 - ZNEW**2)

      IF    ((XNEW > 0.0) .AND. (YNEW > 0.0)) THEN

         IF (XNEW < YNEW) THEN
            PHI_NEW = C_INV_COSD (XNEW/COSTN)
         ELSE
            PHI_NEW = C_INV_SIND (YNEW/COSTN)
         ENDIF

      ELSEIF ((XNEW < 0.0) .AND. (YNEW > 0.0)) THEN

         IF (ABS (XNEW) < YNEW) THEN
            PHI_NEW = 180.0 - C_INV_COSD (ABS (XNEW)/COSTN)
         ELSE
            PHI_NEW = 180.0 - C_INV_SIND (YNEW/COSTN)
         ENDIF

      ELSEIF ((XNEW < 0.0) .AND. (YNEW < 0.0)) THEN

         IF (ABS (XNEW) < ABS (YNEW)) THEN
            PHI_NEW =-180.0 + C_INV_COSD (ABS (XNEW)/COSTN)
         ELSE
            PHI_NEW =-180.0 + C_INV_SIND (ABS (YNEW)/COSTN)
         ENDIF

      ELSEIF ((XNEW > 0.0) .AND. (YNEW < 0.0)) THEN

        IF(    XNEW  < ABS (YNEW)) THEN
           PHI_NEW =    - C_INV_COSD (ABS (XNEW)/COSTN)
        ELSE
           PHI_NEW =    - C_INV_SIND (ABS (YNEW)/COSTN)
        ENDIF

      ENDIF

      !new spherical coordinates
      X_OUT_ANGLE = PHI_NEW
      Y_OUT_ANGLE = THETA_NEW

*     IF (X_OUT_ANGLE < 0.0) X_OUT_ANGLE = X_OUT_ANGLE + 360.0

      !avoid trouble of an exactly zero angle by subtracting offset
      X_OUT_ANGLE = X_OUT_ANGLE - C_EPSILON
      Y_OUT_ANGLE = Y_OUT_ANGLE - C_EPSILON

!-----------------------------------------------------------------------
      END SUBROUTINE C_MODEL_TO_GEO

!-----------------------------------------------------------------------
      END MODULE EULER_ROTATION

      program grid_rotated
      use mod_za  ! HYCOM array I/O interface
      use euler_rotation
      implicit none
c
      logical          lperiod
      integer          i,j,mapflg
      double precision ralpha,rbeta,rgamma
      real*8           hmaxa,hmina
      real*8           xi,xo,yi,yo
c
c --- from an existing grid definition file, produce a new grid
c --- definition file after rotating the coordinates.  The existing
c --- file is taken to identify the grids in the rotated frame, and
c --- the new file will identify these same grids in true lon-lat.
c
c --- the new grid will have the same grid sizes in meters, but
c --- a) the true lon and lat will replace the pre-rotation lon and lat,
c --- b) the coriolis   will be w.r.t. true lon and lat, and
c --- c) the grid angle will be w.r.t. true W-E,S-N
c
c --- the model, and pre-processing programs that involve interpolation,
c --- must use the new grid definition file, but post-processing
c --- diagnostic programs that don't use coriollis or the grid angle
c --- can either use the true lon-lats (new grid definition file) or
c --- stay in "rotated space" by using the original grid definition
c --- file which has lon-lats w.r.t. the rotated coordinates.
c
c --- based on the AOMIP Euler rotation code fragments at
c --- http://fish.cims.nyu.edu/project_aomip/model_grid/overview.html
c
      double precision, parameter :: half   = 0.5d0
      double precision, parameter :: halfpi = 1.5707963268d0
      double precision, parameter :: radian = 57.29578d0
c
      real*8 spherdist  ! fn for distance between geo. pos
c
      integer, allocatable :: ip(:,:)
      real*8,  allocatable :: pang(:,:),cori(:,:)
      real*8,  allocatable :: plon(:,:),qlon(:,:),ulon(:,:),vlon(:,:)
      real*8,  allocatable :: plat(:,:),qlat(:,:),ulat(:,:),vlat(:,:)
      real*8,  allocatable :: pscx(:,:),qscx(:,:),uscx(:,:),vscx(:,:)
      real*8,  allocatable :: pscy(:,:),qscy(:,:),uscy(:,:),vscy(:,:)
c
      call xcspmd  !input idm,jdm
      allocate(   ip(idm,jdm) )
      allocate( pang(idm,jdm), cori(idm,jdm) )
      allocate( plat(idm,jdm), plon(idm,jdm) )
      allocate( qlat(idm,jdm), qlon(idm,jdm) )
      allocate( ulat(idm,jdm), ulon(idm,jdm) )
      allocate( vlat(idm,jdm), vlon(idm,jdm) )
      allocate( pscy(idm,jdm), pscx(idm,jdm) )
      allocate( qscy(idm,jdm), qscx(idm,jdm) )
      allocate( uscy(idm,jdm), uscx(idm,jdm) )
      allocate( vscy(idm,jdm), vscx(idm,jdm) )
c
c --- read in the map projection.
c ---   'idm   ' = longitudinal array size
c ---   'jdm   ' = latitudinal  array size
c ---   'mapflg' = map flag (0=mercator,2=uniform,4=f-plane)
c ---   'ralpha' = 1st euler rotation angle
c ---   'rbeta ' = 2nd euler rotation angle
c ---   'rgamma' = 3rd euler rotation angle
c
      call blkini(i,      'idm   ')
      call blkini(j,      'jdm   ')
      call blkini(mapflg, 'mapflg')
      call blkinr(ralpha,
     &           'ralpha','("blkinr: ",a6," =",f11.4," deg")')
      call blkinr(rbeta,
     &           'rbeta ','("blkinr: ",a6," =",f11.4," deg")')
      call blkinr(rgamma,
     &           'rgamma','("blkinr: ",a6," =",f11.4," deg")')
c
      if     (i.ne.idm .or. j.ne.jdm) then
        write(lp,'(/a,a/)') 'stdin and regional.grid.b have',
     &                      ' different idm,jdm values'
        call flush(lp)
        stop
      endif
c
c --- initialize rotated grid
c
      c_alpha = ralpha
      c_beta  = rbeta
      c_gamma = rgamma
c
      call c_euler_rotation_matrix
c
      write(6,*) 'c_angles  = ',c_alpha,c_beta,c_gamma
      write(6,*)
      write(6,*) 'c_forward = ',C_FORWARD
      write(6,*)
      write(6,*) 'c_reverse = ',C_REVERSE
      write(6,*)
c
c --- read in the original, un-rotated, grid.
c
      call zaiost
c
      call zaiopn( 'old', 51)
      call zaiord8(plon, ip,.false., hmina,hmaxa, 51)
      write(6, 6100) 'r-plon',hmina,hmaxa
      call zaiord8(plat, ip,.false., hmina,hmaxa, 51)
      write(6, 6100) 'r-plat',hmina,hmaxa
      call zaiord8(qlon, ip,.false., hmina,hmaxa, 51)
      write(6, 6100) 'r-qlon',hmina,hmaxa
      call zaiord8(qlat, ip,.false., hmina,hmaxa, 51)
      write(6, 6100) 'r-qlat',hmina,hmaxa
      call zaiord8(ulon, ip,.false., hmina,hmaxa, 51)
      write(6, 6100) 'r-ulon',hmina,hmaxa
      call zaiord8(ulat, ip,.false., hmina,hmaxa, 51)
      write(6, 6100) 'r-ulat',hmina,hmaxa
      call zaiord8(vlon, ip,.false., hmina,hmaxa, 51)
      write(6, 6100) 'r-vlon',hmina,hmaxa
      call zaiord8(vlat, ip,.false., hmina,hmaxa, 51)
      write(6, 6100) 'r-vlat',hmina,hmaxa
      call zaiocl( 51)
c
      lperiod = maxval(plon(:,:))-minval(plon(:,:)) .gt. 350.0
c
c --- rotate each grid.
c
      do j= 1,jdm
        do i= 1,idm
          xi = plon(i,j)
          yi = plat(i,j)
          call c_model_to_geo(xi,yi, xo,yo)
          plon(i,j) = xo
          plat(i,j) = yo
          if     (i.eq.idm/2 .and. j.eq.jdm/2) then
            write(6,*) 'i,j,p.rot = ',i,j,xi,yi
            write(6,*) 'i,j,p.geo = ',i,j,xo,yo
          endif
c
          xi = qlon(i,j)
          yi = qlat(i,j)
          call c_model_to_geo(xi,yi, xo,yo)
          qlon(i,j) = xo
          qlat(i,j) = yo
          if     (i.eq.idm/2 .and. j.eq.jdm/2) then
            write(6,*) 'i,j,q.rot = ',i,j,xi,yi
            write(6,*) 'i,j,q.geo = ',i,j,xo,yo
          endif
c
          xi = ulon(i,j)
          yi = ulat(i,j)
          call c_model_to_geo(xi,yi, xo,yo)
          ulon(i,j) = xo
          ulat(i,j) = yo
          if     (i.eq.idm/2 .and. j.eq.jdm/2) then
            write(6,*) 'i,j,u.rot = ',i,j,xi,yi
            write(6,*) 'i,j,u.geo = ',i,j,xo,yo
          endif
c
          xi = vlon(i,j)
          yi = vlat(i,j)
          call c_model_to_geo(xi,yi, xo,yo)
          vlon(i,j) = xo
          vlat(i,j) = yo
          if     (i.eq.idm/2 .and. j.eq.jdm/2) then
            write(6,*) 'i,j,v.rot = ',i,j,xi,yi
            write(6,*) 'i,j,v.geo = ',i,j,xo,yo
          endif
        enddo
      enddo
c
      write(6, *)
      do j= 1,jdm
        write(6,'(a,i5,2f10.3)')
     &    'j,qlat =',j,minval(qlat(:,j)),maxval(qlat(:,j))
        write(6,'(a,i5,2f10.3)')
     &    'j,plat =',j,minval(plat(:,j)),maxval(plat(:,j))
      enddo
      write(6, *)
      do i= 1,idm
        write(6,'(a,i5,2f10.3)')
     &    'i,qlon =',i,minval(qlon(i,:)),maxval(qlon(i,:))
        write(6,'(a,i5,2f10.3)')
     &    'i,plon =',i,minval(plon(i,:)),maxval(plon(i,:))
      enddo
      call zhflsh(6)
c
c --- finite difference approximation for pang.
c
      call rotang(plat,plon,idm,jdm,pang)
c
c --- write header.
c
      call zhopen(61, 'formatted', 'new', 0)
      write(61,'(i5,a)')
     &  idm,   "    'idm   ' = longitudinal array size"
      write(61,'(i5,a)')
     &  jdm,   "    'jdm   ' = latitudinal  array size"
      write(61,'(i5,a,a)')
     &  mapflg,"    'mapflg' = map flag",
     &         " (-1=unknown,0=mercator,2=uniform,4=f-plane)"
      call zhflsh(61)
c
      write(6, *)
      write(6,'(i5,a)')
     &  idm,   "    'idm   ' = longitudinal array size"
      write(6,'(i5,a)')
     &  jdm,   "    'jdm   ' = latitudinal  array size"
      write(6,'(i5,a)')
     &  mapflg,"    'mapflg' = map flag (-1=unknown,0=mercator,...)"
      call zhflsh(6)
c
c --- write grid arrays.
c
      call zaiopn('new', 61)
      call zaiowr8(plon, ip,.false., hmina,hmaxa, 61, .false.)
      write(61,6100) 'plon',hmina,hmaxa
      write(6, 6100) 'plon',hmina,hmaxa
      call zaiowr8(plat, ip,.false., hmina,hmaxa, 61, .false.)
      write(61,6100) 'plat',hmina,hmaxa
      write(6, 6100) 'plat',hmina,hmaxa
      call zaiowr8(qlon, ip,.false., hmina,hmaxa, 61, .false.)
      write(61,6100) 'qlon',hmina,hmaxa
      write(6, 6100) 'qlon',hmina,hmaxa
      call zaiowr8(qlat, ip,.false., hmina,hmaxa, 61, .false.)
      write(61,6100) 'qlat',hmina,hmaxa
      write(6, 6100) 'qlat',hmina,hmaxa
      call zaiowr8(ulon, ip,.false., hmina,hmaxa, 61, .false.)
      write(61,6100) 'ulon',hmina,hmaxa
      write(6, 6100) 'ulon',hmina,hmaxa
      call zaiowr8(ulat, ip,.false., hmina,hmaxa, 61, .false.)
      write(61,6100) 'ulat',hmina,hmaxa
      write(6, 6100) 'ulat',hmina,hmaxa
      call zaiowr8(vlon, ip,.false., hmina,hmaxa, 61, .false.)
      write(61,6100) 'vlon',hmina,hmaxa
      write(6, 6100) 'vlon',hmina,hmaxa
      call zaiowr8(vlat, ip,.false., hmina,hmaxa, 61, .false.)
      write(61,6100) 'vlat',hmina,hmaxa
      write(6, 6100) 'vlat',hmina,hmaxa
      call zaiowr8(pang, ip,.false., hmina,hmaxa, 61, .false.)
      write(61,6100) 'pang',hmina,hmaxa
      write(6, 6100) 'pang',hmina,hmaxa
      write(6, *)
 6100 format(a,':  min,max = ',2f15.5)
      call zhflsh(61)
      call zhflsh(6)
c
c --- grid spacing in meters.
c
      if     (lperiod) then
        write(lp,'(a)') 'domain assumed to be periodic'
      else
        write(lp,'(a)') 'domain assumed to be non-periodic'
      endif
c
      do j= 1,jdm
        do i= 2,idm
          uscx(i,j) = spherdist(plon(i,  j),plat(i,  j),
     &                          plon(i-1,j),plat(i-1,j) )
          qscx(i,j) = spherdist(vlon(i,  j),vlat(i,  j),
     &                          vlon(i-1,j),vlat(i-1,j) )
        enddo
        i=1
        if     (lperiod) then
          uscx(i,j) = spherdist(plon(i,  j),plat(i,  j),
     &                          plon(idm,j),plat(idm,j) )
          qscx(i,j) = spherdist(vlon(i,  j),vlat(i,  j),
     &                          vlon(idm,j),vlat(idm,j) )
        else
          uscx(i,j) = uscx(i+1,j)  ! updated below except in corner
          qscx(i,j) = qscx(i+1,j)  ! updated below except in corner
        endif
        do i= 1,idm-1
          vscx(i,j) = spherdist(qlon(i,  j),qlat(i,  j),
     &                          qlon(i+1,j),qlat(i+1,j) )
          pscx(i,j) = spherdist(ulon(i,  j),ulat(i,  j),
     &                          ulon(i+1,j),ulat(i+1,j) )
          if     (pscx(i,j).gt.100000.0) then
            write(6,*) 'spherdist ',ulon(i,  j),ulat(i,  j),
     &                              ulon(i+1,j),ulat(i+1,j),
     &                              pscx(i,j)
          endif
        enddo
        i=idm
        if     (lperiod) then
          vscx(i,j) = spherdist(qlon(i,  j),qlat(i,  j),
     &                          qlon(1,  j),qlat(1,  j) )
          pscx(i,j) = spherdist(ulon(i,  j),ulat(i,  j),
     &                          ulon(1,  j),ulat(1,  j) )
        else
          vscx(i,j) = vscx(i-1,j)  ! updated below except in corner
          pscx(i,j) = pscx(i-1,j)  ! updated below except in corner
        endif
      enddo
c
      do j= 1,jdm
        if     (j.ne.1) then
          do i= 1,idm
            vscy(i,j) = spherdist(plon(i,  j),plat(i,  j),
     &                            plon(i,j-1),plat(i,j-1) )
            qscy(i,j) = spherdist(ulon(i,  j),ulat(i,  j),
     &                            ulon(i,j-1),ulat(i,j-1) )
          enddo
        endif
        if     (j.ne.jdm) then
          do i= 1,idm
            uscy(i,j) = spherdist(qlon(i,  j),qlat(i,  j),
     &                            qlon(i,j+1),qlat(i,j+1) )
            pscy(i,j) = spherdist(vlon(i,  j),vlat(i,  j),
     &                            vlon(i,j+1),vlat(i,j+1) )
          enddo
        endif
      enddo
c
c     fill in the edges, assuming constant grid aspect ratio
c
      j=1
      do i= 1,idm
        vscy(i,j) = vscx(i,j)*vscy(i,j+1)/vscx(i,j+1)
        qscy(i,j) = qscx(i,j)*qscy(i,j+1)/qscx(i,j+1)
      enddo
      j=jdm
      do i= 1,idm
        uscy(i,j) = uscx(i,j)*uscy(i,j-1)/uscx(i,j-1)
        pscy(i,j) = pscx(i,j)*pscy(i,j-1)/pscx(i,j-1)
      enddo
c
      if     (.not.lperiod) then
        i=1
        do j= 1,jdm
          uscx(i,j) = uscy(i,j)*uscx(i+1,j)/uscy(i+1,j)
          qscx(i,j) = qscy(i,j)*qscx(i+1,j)/qscy(i+1,j)
        enddo
        i=idm
        do j= 1,jdm
          vscx(i,j) = vscy(i,j)*vscx(i-1,j)/vscy(i-1,j)
          pscx(i,j) = pscy(i,j)*pscx(i-1,j)/pscy(i-1,j)
        enddo
      endif
c
      write(lp,*)
      do j= 1,jdm
        write(lp,'(a,i5,3f10.2)')
     &    'j,vy =',j,minval(vscy(:,j)),maxval(vscy(:,j)),
     &               maxval(vscy(:,j))-minval(vscy(:,j))
        write(lp,'(a,i5,3f10.2)')
     &    'j,vx =',j,minval(vscx(:,j)),maxval(vscx(:,j)),
     &               maxval(vscx(:,j))-minval(vscx(:,j))
        write(lp,'(a,i5,3f10.2)')
     &    'j,uy =',j,minval(uscy(:,j)),maxval(uscy(:,j)),
     &               maxval(uscy(:,j))-minval(uscy(:,j))
        write(lp,'(a,i5,3f10.2)')
     &    'j,ux =',j,minval(uscx(:,j)),maxval(uscx(:,j)),
     &               maxval(uscx(:,j))-minval(uscx(:,j))
      enddo
      write(lp,*)
c
c --- write grid arrays.
c
      call zaiowr8(pscx, ip,.false., hmina,hmaxa, 61, .false.)
      write(61,6110) 'pscx',hmina,hmaxa
      write(lp,6110) 'pscx',hmina,hmaxa
      call zaiowr8(pscy, ip,.false., hmina,hmaxa, 61, .false.)
      write(61,6110) 'pscy',hmina,hmaxa
      write(lp,6110) 'pscy',hmina,hmaxa
      call zaiowr8(qscx, ip,.false., hmina,hmaxa, 61, .false.)
      write(61,6110) 'qscx',hmina,hmaxa
      write(lp,6110) 'qscx',hmina,hmaxa
      call zaiowr8(qscy, ip,.false., hmina,hmaxa, 61, .false.)
      write(61,6110) 'qscy',hmina,hmaxa
      write(lp,6110) 'qscy',hmina,hmaxa
      call zaiowr8(uscx, ip,.false., hmina,hmaxa, 61, .false.)
      write(61,6110) 'uscx',hmina,hmaxa
      write(lp,6110) 'uscx',hmina,hmaxa
      call zaiowr8(uscy, ip,.false., hmina,hmaxa, 61, .false.)
      write(61,6110) 'uscy',hmina,hmaxa
      write(lp,6110) 'uscy',hmina,hmaxa
      call zaiowr8(vscx, ip,.false., hmina,hmaxa, 61, .false.)
      write(61,6110) 'vscx',hmina,hmaxa
      write(lp,6110) 'vscx',hmina,hmaxa
      call zaiowr8(vscy, ip,.false., hmina,hmaxa, 61, .false.)
      write(61,6110) 'vscy',hmina,hmaxa
      write(lp,6110) 'vscy',hmina,hmaxa
      write(lp,*)
 6110 format(a,':  min,max = ',2f15.5)
c
c --- coriolis
c
      do j= 1,jdm
        do i= 1,idm
          cori(i,j)=sin(qlat(i,j)/radian)*
     &              8.d0*halfpi/86164.0d0  ! sidereal day
        enddo
      enddo
c
      call zaiowr8(cori, ip,.false., hmina,hmaxa, 61, .false.)
      write(61,6120) 'cori',hmina,hmaxa
      write(lp,6120) 'cori',hmina,hmaxa
      write(lp,*)
 6120 format(a,':  min,max = ',2f15.10)
c
c --- grid aspect ratios
c
      do j= 1,jdm
        do i= 1,idm
          if     (pscy(i,j).eq.0.0) then
            pscx(i,j) = 99.0
          elseif (pscx(i,j).ge.99.0*pscy(i,j)) then
            pscx(i,j) = 99.0
          else
            pscx(i,j) = pscx(i,j)/pscy(i,j)
          endif
        enddo
      enddo
c
      call zaiowr8(pscx, ip,.false., hmina,hmaxa, 61, .false.)
      write(61,6130) 'pasp',hmina,hmaxa
      write(lp,6130) 'pasp',hmina,hmaxa
      write(lp,*)
 6130 format(a,':  min,max = ',2f15.5)
c
      close(unit=61)
      call zaiocl(61)
c
      end
      subroutine blkinr(rvar,cvar,cfmt)
      implicit none
c
      double precision rvar
      character        cvar*6,cfmt*(*)
c
      integer       lp
      common/linepr/lp
c
c     read in one real value from stdin
c
      character*6 cvarin
c
      read(*,*) rvar,cvarin
      write(lp,cfmt) cvarin,rvar
      call flush(lp)
c
      if     (cvar.ne.cvarin) then
        write(lp,*)
        write(lp,*) 'error in blkinr - input ',cvarin,
     +                      ' but should be ',cvar
        write(lp,*)
        call flush(lp)
        stop
      endif
      return
      end
      subroutine blkini(ivar,cvar)
      implicit none
c
      integer     ivar
      character*6 cvar
c
      integer       lp
      common/linepr/lp
c
c     read in one integer value from stdin
c
      character*6 cvarin
c
      read(*,*) ivar,cvarin
      write(lp,6000) cvarin,ivar
      call flush(lp)
c
      if     (cvar.ne.cvarin) then
        write(lp,*)
        write(lp,*) 'error in blkini - input ',cvarin,
     +                      ' but should be ',cvar
        write(lp,*)
        call flush(lp)
        stop
      endif
      return
 6000 format('blkini: ',a6,' =',i6)
      end


      subroutine syminv(nnn,aaa,bbb,bbi)
c
c***********************************************************************
c
c     routine to invert a real symmetric matrix (reference:
c     computing methods v.ii, i.s. berezin and n.p.zhidkov,
c     pergamon press 1965). note that the matrices are
c     packed in the minimum storage mode, (i.e. a(k)=a(i,j),
c     where i>j and k=(i*(i-1))/2+j ).
c     the matrices aaa and bbb may be equivalenced though
c     this will destroy the contents of the original
c     array.
c
c     general version for all real symmetric matrices
c
c     copyright - daresbury laboratory 1993
c     author w.smith (added to dl_poly july 1993)
c
c***********************************************************************
c
      implicit real*8(a-h,o-z)
      dimension aaa(*),bbb(*),bbi(*)
      ind(i,j)=(max0(i,j)*(max0(i,j)-1))/2+min0(i,j)
c
c     factorize matrix aaa into upper and lower forms
      do l=1,nnn
        do m=1,l
          k=ind(l,m)
          bbi(k)=0.d0
          bbb(k)=aaa(k)
          if(m.ne.1)then
            lm=m-1
            do n=1,lm
              ln=ind(l,n)
              mn=ind(m,n)
              temv  =bbb(k)-bbb(ln)*bbb(mn)+bbi(ln)*bbi(mn)
              bbi(k)=bbi(k)-bbi(ln)*bbb(mn)-bbb(ln)*bbi(mn)
              bbb(k)=temv
            enddo
          endif
          if(l.eq.m)then
            if(bbb(k).lt.0.d0)then
              bbi(k)=sqrt(abs(bbb(k)))
              bbb(k)=0.d0
            else
              bbb(k)=sqrt(abs(bbb(k)))
              bbi(k)=0.d0
            endif
          else
            mm=ind(m,m)
            den=1.d0/(bbb(mm)**2+bbi(mm)**2)
            temv  =den*(bbb(k)*bbb(mm)+bbi(k)*bbi(mm))
            bbi(k)=den*(bbi(k)*bbb(mm)-bbb(k)*bbi(mm))
            bbb(k)=temv
          endif
        enddo
      enddo
c
c     invert lower triangular matrix
      do l=1,nnn
        n=ind(l,l)
        den=1.d0/(bbb(n)*bbb(n)+bbi(n)*bbi(n))
        do m=1,l
          k=ind(l,m)
          if(l.eq.m)then
            bbb(k)= den*bbb(k)
            bbi(k)=-den*bbi(k)
          else
            lm=l-1
            suma=0.d0
            sumb=0.d0
            do j=m,lm
              lj=ind(l,j)
              mj=ind(m,j)
              suma=suma-bbb(lj)*bbb(mj)+bbi(lj)*bbi(mj)
              sumb=sumb-bbb(lj)*bbi(mj)-bbi(lj)*bbb(mj)
            enddo
            temv  =den*(suma*bbb(n)+sumb*bbi(n))
            bbi(k)=den*(sumb*bbb(n)-suma*bbi(n))
            bbb(k)=temv
          endif
        enddo
      enddo
c
c     form product of upper and lower inverse triangular matrices
      do l=1,nnn
        do m=1,l
          sum=0.d0
          k=ind(l,m)
          do j=l,nnn
            lj=ind(l,j)
            mj=ind(m,j)
            sum=sum+bbb(lj)*bbb(mj)-bbi(lj)*bbi(mj)
          enddo
          bbb(k)=sum
        enddo
      enddo
      return
      end


c
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c  .                                                             .
c  .                  copyright (c) 1998 by UCAR                 .
c  .                                                             .
c  .       University Corporation for Atmospheric Research       .
c  .                                                             .
c  .                      all rights reserved                    .
c  .                                                             .
c  .                                                             .
c  .                         SPHEREPACK                       .
c  .                                                             .
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c
c
c
c
c ... file vrtec.f
c
c     this file includes documentation and code for
c     subroutine divec          i
c
c ... files which must be loaded with vrtec.f
c
c     sphcom.f, hrfft.f, vhaec.f,shsec.f
c
c     subroutine vrtec(nlat,nlon,isym,nt,vt,ivrt,jvrt,cr,ci,mdc,ndc,
c    +                 wshsec,lshsec,work,lwork,ierror)
c
C*PL*ERROR* Comment line too long
c     given the vector spherical harmonic coefficients cr and ci, precomputed
c     by subroutine vhaec for a vector field (v,w), subroutine vrtec
c     computes the vorticity of the vector field in the scalar array
c     vt.  vt(i,j) is the vorticity at the colatitude
c
c            theta(i) = (i-1)*pi/(nlat-1)
c
c     and longitude
c
c            lambda(j) = (j-1)*2*pi/nlon
c
c     on the sphere.  i.e.,
c
c            vt(i,j) =  [-dv/dlambda + d(sint*w)/dtheta]/sint
c
c     where sint = sin(theta(i)).  w is the east longitudinal and v
c     is the colatitudinal component of the vector field from which
c     cr,ci were precomputed.  required associated legendre polynomials
c     are recomputed rather than stored as they are in subroutine vrtes.
c
c
c     input parameters
c
c     nlat   the number of colatitudes on the full sphere including the
c            poles. for example, nlat = 37 for a five degree grid.
c            nlat determines the grid increment in colatitude as
c            pi/(nlat-1).  if nlat is odd the equator is located at
c            grid point i=(nlat+1)/2. if nlat is even the equator is
c            located half way between points i=nlat/2 and i=nlat/2+1.
c            nlat must be at least 3. note: on the half sphere, the
c            number of grid points in the colatitudinal direction is
c            nlat/2 if nlat is even or (nlat+1)/2 if nlat is odd.
c
c     nlon   the number of distinct londitude points.  nlon determines
c            the grid increment in longitude as 2*pi/nlon. for example
c            nlon = 72 for a five degree grid. nlon must be greater
c            than 3. the axisymmetric case corresponds to nlon=1.
c            the efficiency of the computation is improved when nlon
c            is a product of small prime numbers.
c
c
c     isym   a parameter which determines whether the vorticity is
c            computed on the full or half sphere as follows:
c
c      = 0
c            the symmetries/antsymmetries described in isym=1,2 below
c            do not exist in (v,w) about the equator.  in this case the
c            vorticity is neither symmetric nor antisymmetric about
c            the equator.  the vorticity is computed on the entire
c            sphere.  i.e., in the array vt(i,j) for i=1,...,nlat and
c            j=1,...,nlon.
c
c      = 1
c            w is antisymmetric and v is symmetric about the equator.
c            in this case the vorticity is symmetyric about the
c            equator and is computed for the northern hemisphere
c            only.  i.e., if nlat is odd the vorticity is computed
c            in the array vt(i,j) for i=1,...,(nlat+1)/2 and for
c            j=1,...,nlon.  if nlat is even the vorticity is computed
c            in the array vt(i,j) for i=1,...,nlat/2 and j=1,...,nlon.
c
c      = 2
c            w is symmetric and v is antisymmetric about the equator
c            in this case the vorticity is antisymmetric about the
c            equator and is computed for the northern hemisphere
c            only.  i.e., if nlat is odd the vorticity is computed
c            in the array vt(i,j) for i=1,...,(nlat+1)/2 and for
c            j=1,...,nlon.  if nlat is even the vorticity is computed
c            in the array vt(i,j) for i=1,...,nlat/2 and j=1,...,nlon.
c
c
c      nt    nt is the number of scalar and vector fields.  some
c            computational efficiency is obtained for multiple fields.
c            in the program that calls vrtec, the arrays cr,ci, and vort
C*PL*ERROR* Comment line too long
c            can be three dimensional corresponding to an indexed multiple
c            vector field.  in this case multiple scalar synthesis will
c            be performed to compute the vorticity for each field.  the
c            third index is the synthesis index which assumes the values
c            k=1,...,nt.  for a single synthesis set nt = 1.  the
c            description of the remaining parameters is simplified by
C*PL*ERROR* Comment line too long
c            assuming that nt=1 or that all the arrays are two dimensional.
c
c     ivrt   the first dimension of the array vt as it appears in
c            the program that calls vrtec. if isym = 0 then ivrt
c            must be at least nlat.  if isym = 1 or 2 and nlat is
c            even then ivrt must be at least nlat/2. if isym = 1 or 2
c            and nlat is odd then ivrt must be at least (nlat+1)/2.
c
c     jvrt   the second dimension of the array vt as it appears in
c            the program that calls vrtec. jvrt must be at least nlon.
c
c    cr,ci   two or three dimensional arrays (see input parameter nt)
c            that contain vector spherical harmonic coefficients
c            of the vector field (v,w) as computed by subroutine vhaec.
c     ***    cr and ci must be computed by vhaec prior to calling
c            vrtec.
c
c      mdc   the first dimension of the arrays cr and ci as it
c            appears in the program that calls vrtec. mdc must be at
c            least min0(nlat,nlon/2) if nlon is even or at least
c            min0(nlat,(nlon+1)/2) if nlon is odd.
c
c      ndc   the second dimension of the arrays cr and ci as it
c            appears in the program that calls vrtec. ndc must be at
c            least nlat.
c
c   wshsec   an array which must be initialized by subroutine shseci.
c            once initialized,
c            wshsec can be used repeatedly by vrtec as long as nlon
c            and nlat remain unchanged.  wshsec must not be altered
c            between calls of vrtec
c
c   lshsec   the dimension of the array wshsec as it appears in the
c            program that calls vrtec. define
c
c               l1 = min0(nlat,(nlon+2)/2) if nlon is even or
c               l1 = min0(nlat,(nlon+1)/2) if nlon is odd
c
c            and
c
c               l2 = nlat/2        if nlat is even or
c               l2 = (nlat+1)/2    if nlat is odd
c
c            then lshsec must be at least
c
c            2*nlat*l2+3*((l1-2)*(nlat+nlat-l1-1))/2+nlon+15
c
c     work   a work array that does not have to be saved.
c
c    lwork   the dimension of the array work as it appears in the
c            program that calls vrtec. define
c
c               l1 = min0(nlat,nlon/2) if nlon is even or
c               l1 = min0(nlat,(nlon+1)/2) if nlon is odd
c
c            and
c
c               l2 = nlat/2        if nlat is even or
c               l2 = (nlat+1)/2    if nlat is odd.
c
c            if isym is zero then lwork must be at least
c
c               nlat*(nt*nlon+max0(3*l2,nlon)+2*nt*l1+1)
c
c            if isym is not zero then lwork must be at least
c
c               l2*(nt*nlon+max0(3*nlat,nlon)) + nlat*(2*nt*l1+1)
c
c
c
c     **************************************************************
c
c     output parameters
c
c
c     vt     a two or three dimensional array (see input parameter nt)
c            that contains the vorticity of the vector field (v,w)
C*PL*ERROR* Comment line too long
c            whose coefficients cr,ci where computed by subroutine vhaec.
c            vt(i,j) is the vorticity at the colatitude point theta(i) =
c            (i-1)*pi/(nlat-1) and longitude point lambda(j) =
c            (j-1)*2*pi/nlon. the index ranges are defined above at the
c            input parameter isym.
c
c
c   ierror   an error parameter which indicates fatal errors with input
c            parameters when returned positive.
c          = 0  no errors
c          = 1  error in the specification of nlat
c          = 2  error in the specification of nlon
c          = 3  error in the specification of isym
c          = 4  error in the specification of nt
c          = 5  error in the specification of ivrt
c          = 6  error in the specification of jvrt
c          = 7  error in the specification of mdc
c          = 8  error in the specification of ndc
c          = 9  error in the specification of lshsec
c          = 10 error in the specification of lwork
c **********************************************************************
c
c
      SUBROUTINE DVRTEC(NLAT,NLON,ISYM,NT,VORT,IVRT,JVRT,CR,CI,MDC,NDC,
     +                 WSHSEC,LSHSEC,WORK,LWORK,IERROR)
      DOUBLE PRECISION VORT
      DOUBLE PRECISION CR
      DOUBLE PRECISION CI
      DOUBLE PRECISION WSHSEC
      DOUBLE PRECISION WORK

      DIMENSION VORT(IVRT,JVRT,NT),CR(MDC,NDC,NT),CI(MDC,NDC,NT)
      DIMENSION WSHSEC(LSHSEC),WORK(LWORK)
c
c     check input parameters
c
      IERROR = 1
      IF (NLAT.LT.3) RETURN
      IERROR = 2
      IF (NLON.LT.4) RETURN
      IERROR = 3
      IF (ISYM.LT.0 .OR. ISYM.GT.2) RETURN
      IERROR = 4
      IF (NT.LT.0) RETURN
      IERROR = 5
      IMID = (NLAT+1)/2
      IF ((ISYM.EQ.0.AND.IVRT.LT.NLAT) .OR.
     +    (ISYM.GT.0.AND.IVRT.LT.IMID)) RETURN
      IERROR = 6
      IF (JVRT.LT.NLON) RETURN
      IERROR = 7
      IF (MDC.LT.MIN0(NLAT, (NLON+1)/2)) RETURN
      MMAX = MIN0(NLAT, (NLON+2)/2)
      IERROR = 8
      IF (NDC.LT.NLAT) RETURN
      IERROR = 9
c
c     verify saved work space (same as shec)
c
      LZZ1 = 2*NLAT*IMID
      LABC = 3* (MAX0(MMAX-2,0)* (NLAT+NLAT-MMAX-1))/2
      IF (LSHSEC.LT.LZZ1+LABC+NLON+15) RETURN
      IERROR = 10
c
c     verify unsaved work space (add to what shec requires)
c
      LS = NLAT
      IF (ISYM.GT.0) LS = IMID
      NLN = NT*LS*NLON
c
c     set first dimension for a,b (as requried by shsec)
c
      MAB = MIN0(NLAT,NLON/2+1)
      MN = MAB*NLAT*NT
c     if(lwork.lt.nln+max0(ls*nlon,3*nlat*imid)+2*mn+nlat) return
      L1 = MIN0(NLAT, (NLON+2)/2)
      L2 = (NLAT+1)/2
      IF (ISYM.EQ.0) THEN
          LWKMIN = NLAT* (NT*NLON+MAX0(3*L2,NLON)+2*NT*L1+1)
      ELSE
          LWKMIN = L2* (NT*NLON+MAX0(3*NLAT,NLON)) + NLAT* (2*NT*L1+1)
      END IF
      IF (LWORK.LT.LWKMIN) RETURN
      IERROR = 0
c
c     set work space pointers
c
      IA = 1
      IB = IA + MN
      IS = IB + MN
      IWK = IS + NLAT
      LWK = LWORK - 2*MN - NLAT
      CALL DVRTEC1(NLAT,NLON,ISYM,NT,VORT,IVRT,JVRT,CR,CI,MDC,NDC,
     +            WORK(IA),WORK(IB),MAB,WORK(IS),WSHSEC,LSHSEC,
     +            WORK(IWK),LWK,IERROR)
      RETURN
      END

      SUBROUTINE DVRTEC1(NLAT,NLON,ISYM,NT,VORT,IVRT,JVRT,CR,CI,MDC,NDC,
     +                  A,B,MAB,SQNN,WSHSEC,LSHSEC,WK,LWK,IERROR)
      DOUBLE PRECISION VORT
      DOUBLE PRECISION CR
      DOUBLE PRECISION CI
      DOUBLE PRECISION A
      DOUBLE PRECISION B
      DOUBLE PRECISION SQNN
      DOUBLE PRECISION WSHSEC
      DOUBLE PRECISION WK
      DOUBLE PRECISION FN
      DIMENSION VORT(IVRT,JVRT,NT),CR(MDC,NDC,NT),CI(MDC,NDC,NT)
      DIMENSION A(MAB,NLAT,NT),B(MAB,NLAT,NT),SQNN(NLAT)
      DIMENSION WSHSEC(LSHSEC),WK(LWK)
c
c     set coefficient multiplyers
c
      DO 1 N = 2,NLAT
          FN = DBLE(N-1)
          SQNN(N) = SQRT(FN* (FN+1.D0))
    1 CONTINUE
c
c     compute vorticity scalar coefficients for each vector field
c
      DO 2 K = 1,NT
          DO 3 N = 1,NLAT
              DO 4 M = 1,MAB
                  A(M,N,K) = 0.0D0
                  B(M,N,K) = 0.0D0
    4         CONTINUE
    3     CONTINUE
c
c     compute m=0 coefficients
c
          DO 5 N = 2,NLAT
              A(1,N,K) = SQNN(N)*CR(1,N,K)
              B(1,N,K) = SQNN(N)*CI(1,N,K)
    5     CONTINUE
c
c     compute m>0 coefficients, use mmax from vector coef range
c
          MMAX = MIN0(NLAT, (NLON+1)/2)
          DO 6 M = 2,MMAX
              DO 7 N = M,NLAT
                  A(M,N,K) = SQNN(N)*CR(M,N,K)
                  B(M,N,K) = SQNN(N)*CI(M,N,K)
    7         CONTINUE
    6     CONTINUE
    2 CONTINUE
c
c     synthesize a,b into vort
c
      CALL DSHSEC(NLAT,NLON,ISYM,NT,VORT,IVRT,JVRT,A,B,MAB,NLAT,WSHSEC,
     +           LSHSEC,WK,LWK,IERROR)
      RETURN
      END


!-------------------------------------------------------------------------------
! (C) British Crown Copyright 2020 Met Office
!
! This software is licensed under the terms of the Apache Licence Version 2.0
! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0.
!-------------------------------------------------------------------------------

!> Calculates GPSRO penalty.

module ufo_gnssroonedvarcheck_pen_mod

use kinds, only: kind_real
use missing_values_mod, only: missing_value

private
public :: Ops_GPSRO_pen

contains

SUBROUTINE Ops_GPSRO_pen (Nstate,   &   ! size of state vec.
                          Nobs,     &   ! size of obs vec.
                          x,        &   ! current estimate of soltution
                          xb,       &   ! background
                          yobs,     &   ! observed values
                          ycalc,    &   ! y(x)
                          BM1,      &   ! inverse .of bsck cov matrix
                          OM1,      &   ! inv. of obs+forw cov matrix
                          pen_ob,   &   ! obs penalty
                          pen_back, &   ! back penalty
                          pen_func)     ! total penalty

IMPLICIT NONE

! Subroutine arguments:
INTEGER, INTENT(IN)         :: Nstate
INTEGER, INTENT(IN)         :: Nobs
REAL(kind_real), INTENT(IN)            :: x(:)
REAL(kind_real), INTENT(IN)            :: xb(:)
REAL(kind_real), INTENT(IN)            :: yobs(:)
REAL(kind_real), INTENT(IN)            :: ycalc(:)
REAL(kind_real), INTENT(IN)            :: BM1(:,:)
REAL(kind_real), INTENT(IN)            :: OM1(:,:)
REAL(kind_real),  INTENT(OUT)          :: pen_ob
REAL(kind_real),  INTENT(OUT)          :: pen_back
REAL(kind_real),  INTENT(OUT)          :: pen_func

! Local declarations:
REAL(kind_real)                        :: dx(Nstate)
REAL(kind_real)                        :: dy(Nobs)
REAL(kind_real)                        :: Bdx(Nstate)
REAL(kind_real)                        :: Ody(Nobs)
REAL(kind_real)                        :: J_back
REAL(kind_real)                        :: J_obs
CHARACTER(len=*), PARAMETER :: RoutineName = "Ops_GPSRO_pen"

! deviation from background

dx(:) = x(:) - xb(:)

! calc. Bdx matrix   ie B^-1(x-xb)

Bdx(:) = MATMUL (BM1(:,:), dx(:))

! background term (scalar)

J_back = DOT_PRODUCT (dx(:), Bdx(:))

! obs. meas-calc

dy(:) = yobs(:) - ycalc(:)

!make sure missing data is not included
WHERE (ycalc(:) == missing_value(ycalc(1)) .OR. &
       yobs(:) == missing_value(yobs(1)))

  dy(:) = 0.0
END WHERE

! Ody   O^-1 (ymeas-ycalc)

Ody(:) = MATMUL (OM1(:,:), dy (:))

! observation term. (scalar)

J_obs = DOT_PRODUCT (dy(:), Ody(:))

! SCALAR value required

pen_func = 0.5 * (J_back + J_obs)

pen_ob = 0.5 * J_obs
pen_back = 0.5 * J_back

END SUBROUTINE Ops_GPSRO_pen

end module ufo_gnssroonedvarcheck_pen_mod


      subroutine mod_midpoint(y0,dy0,n,x0,htot,steps,y,
     &                        rn,ecomp,vr,eunit,b,allp1,nexp)
      implicit none

      integer n,steps,nexp
      real*8 y0(n),dy0(n),x0,htot,y(n)
      real*8 rn,vr(*),eunit,b,allp1
      complex*16 ecomp

      real*8 h,h2,y_i(n),y_j(n),dy(n),x,tmp
      integer i,j

      h=htot/steps
      h2=2.0*h

      x=x0
      do i=1,n
        y_j(i)=y0(i)
        y_i(i)=y0(i)+h*dy0(i)
      end do
      do j=2,steps
      x=x+h
      call dfv_m(x,y_i,dy,n,nexp,rn,ecomp,vr,eunit,b,allp1)
      do i=1,n
        tmp=y_j(i)+h2*dy(i)
        y_j(i)=y_i(i)
        y_i(i)=tmp
      end do
      end do
      x=x+h
      call dfv_m(x,y_i,dy,n,nexp,rn,ecomp,vr,eunit,b,allp1)
      do i=1,n
        y(i)=0.5d0*(y_i(i)+y_j(i)+h*dy(i))
      end do
      end


!	Multinomial fourth moments.  Covariances of cross-products.
!	density provides weights.
!	points are in quadpoint.
!	Product means are in mean2th.
function mquarth(density,mean2th,quadpoint)
implicit none
real(kind=8),intent(in)::density(:),mean2th(:,:),quadpoint(:,:)
real(kind=8)::mquarth(size(mean2th,1),size(mean2th,1),size(mean2th,1),size(mean2th,1))
!	Counters
integer::col,col1,row,row1,quad,topcol
!	Product
mquarth=0.0_8
do row=1,size(mean2th,1)
	do col=1,row
		do row1=1,row
			topcol=row1
			if(row==row1)topcol=col
			do col1=1,topcol
				do quad=1,size(density)
					mquarth(row,col,row1,col1)=mquarth(row,col,row1,col1)+&
						(quadpoint(row,quad)*quadpoint(col,quad)-mean2th(row,col))*&
						(quadpoint(row1,quad)*quadpoint(col1,quad)-mean2th(row1,col1))*&
						density(quad)
				end do

				if(row/=row1.or.col/=col1)mquarth(row1,col1,row,col)=mquarth(row,col,row1,col1)
			end do
		end do
	end do
end do
return
end function mquarth


c       Dielectic mixing model of Peplinski et. al. to calculate the complex dielectic of soil:
c
c		Peplinski, ULaby, Dobson, Dielectric Properties of Soils in the 0.3 to 1.3 GHz Range,
c		IEEE Trans Geosci Rem Sensing, Vol 33, No. 3, pp 803-807, May 1995.
c
c		with the corrections given in:
c
c		Peplinski, ULaby, Dobson, Corrections to: Dielectric Properties of Soils in the 0.3 to 1.3 GHz Range,
c		IEEE Trans Geosci Rem Sensing, Vol 33, No. 6, p 1340, Nov. 1995.
c
c		The T dependent form is given in:
c		F. T. Ulaby, R. K. Moore, and A. K. Fung, Microwave Remote Sensing, vol. III. Dedham, MA: Artech House, 1986, Appendix E.
c
c

        program dielecSoil

        real wavlen
        real am
        complex e
        real sand, clay, rhoB, mv
        real rhoS, alpa, epsWInf
        real twoPiTw, epsW0
        real betaReal, epsS
        real epsFwReal, epsRealPartA
        real epsRealPartB, epsReal
        real betaImg, sigmaEff
        real epsFwImgPartA, epsFwImgPartB
        real epsFwImg, epsImgPartA
        real espImgPartB, epsImg
        real pi
        real mVStep
        integer mVItt

        pi = 3.14159265

        wavlen = 0.68 ! Wavelenght
        sand = 0.4    ! Sand percentage
        clay = 0.5    ! Clay percentage
        rhoB = 1.55   ! Bulk density
        mV = 0.05     ! Volumetric water content
        T = 20        ! Temperature
        rhoS = 2.66   ! Specific density of solid soil properties
        alpha = 0.65

        f=3.0e8/wavlen
        print*, 'wavelen', wavlen
        print*, 'f = ', f

        mV = 0.
        mVStep = 0.05
        do 400 mVItt=1,8
        mV = mV + mVStep

        epsWInf = 4.9 ! High frequency limit of dielectric constant of free water
        twoPiTw = 1.1109e-10 - (3.824e-12 * T)+ (6.938e-14 * T**2) -
     1       (5.096e-16* T**3) ! Static dielectric constant for water.
        epsW0 = 88.045 - 0.4147*T+(6.295e-4 * T**2)+(1.075e-5 * T**3)
        betaReal = 1.2748 - (0.519 * sand) - (0.152 * clay) ! Real part of soil dependence constant
        epsS = ((1.01 + (0.44 * rhoS))*(1.01 + (0.44*rhoS)))-0.062 !Dielectric constant of solid soils;
        epsFwReal = epsWInf + (epsW0 - epsWInf) / (1+((f
     1       * twoPiTw )*(f * twoPiTw )))
        epsRealPartA = 1 + (rhoB / rhoS) * ((epsS**alpha) -1)
        epsRealPartB =  ((mV**betaReal) * (epsFwReal**alpha)) -mV
        epsReal = (epsRealPartA + epsRealPartB)**(1/alpha)

        if(f.lt.1.4e9) sigmaEff = 0.0467 + (0.2204 * rhoB) -
     1           (0.4111 * sand) + (0.6614 * clay)
        else sigmaEff = -1.645 + (1.939 * rhoB) - (2.25622 * sand) +
     1   (1.594 * clay)

        betaImg = 1.33797-(0.603*sand)-(0.166*clay)

        epsFwImgPartA = ((f * twoPiTw)  * (epsW0 -
     1   epsWInf)) /  (1 + ((f * twoPiTw )**2))
        epsFwImgPartB = (sigmaEff / (f * twoPiTw))
     1   - ((rhoS - rhoB) / (rhoS * mV));
        epsFwImg = epsFwImgPartA + epsFwImgPartB;
        epsImgPartA = mV**betaImg
        espImgPartB = epsFwImg**alpha
        epsImg = (epsImgPartA*espImgPartB)**(1/alpha)

        e = cmplx(epsReal,epsImg)

        print*, mV, epsReal, epsImg

  400  continue

        end


c
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c  .                                                             .
c  .                  copyright (c) 1998 by UCAR                 .
c  .                                                             .
c  .       University Corporation for Atmospheric Research       .
c  .                                                             .
c  .                      all rights reserved                    .
c  .                                                             .
c  .                                                             .
c  .                         SPHEREPACK                          .
c  .                                                             .
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c
c
c
c ... file shaes.f
c
c     this file contains code and documentation for subroutines
c     shaes and shaesi
c
c ... files which must be loaded with shaes.f
c
c     sphcom.f, hrfft.f
c
c     subroutine shaes(nlat,nlon,isym,nt,g,idg,jdg,a,b,mdab,ndab,
c    +                 wshaes,lshaes,work,lwork,ierror)
c
c     subroutine shaes performs the spherical harmonic analysis
c     on the array g and stores the result in the arrays a and b.
c     the analysis is performed on an equally spaced grid.  the
c     associated legendre functions are stored rather than recomputed
c     as they are in subroutine shaec.  the analysis is described
c     below at output parameters a,b.
c
c     sphcom.f, hrfft.f
c
c
c     input parameters
c
c     nlat   the number of colatitudes on the full sphere including the
c            poles. for example, nlat = 37 for a five degree grid.
c            nlat determines the grid increment in colatitude as
c            pi/(nlat-1).  if nlat is odd the equator is located at
c            grid point i=(nlat+1)/2. if nlat is even the equator is
c            located half way between points i=nlat/2 and i=nlat/2+1.
c            nlat must be at least 3. note: on the half sphere, the
c            number of grid points in the colatitudinal direction is
c            nlat/2 if nlat is even or (nlat+1)/2 if nlat is odd.
c
c     nlon   the number of distinct londitude points.  nlon determines
c            the grid increment in longitude as 2*pi/nlon. for example
c            nlon = 72 for a five degree grid. nlon must be greater
c            than or equal to 4. the efficiency of the computation is
c            improved when nlon is a product of small prime numbers.
c
c     isym   = 0  no symmetries exist about the equator. the analysis
c                 is performed on the entire sphere.  i.e. on the
c                 array g(i,j) for i=1,...,nlat and j=1,...,nlon.
c                 (see description of g below)
c
c            = 1  g is antisymmetric about the equator. the analysis
c                 is performed on the northern hemisphere only.  i.e.
c                 if nlat is odd the analysis is performed on the
c                 array g(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon.
c                 if nlat is even the analysis is performed on the
c                 array g(i,j) for i=1,...,nlat/2 and j=1,...,nlon.
c
c
c            = 2  g is symmetric about the equator. the analysis is
c                 performed on the northern hemisphere only.  i.e.
c                 if nlat is odd the analysis is performed on the
c                 array g(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon.
c                 if nlat is even the analysis is performed on the
c                 array g(i,j) for i=1,...,nlat/2 and j=1,...,nlon.
c
c     nt     the number of analyses.  in the program that calls shaes,
c            the arrays g,a and b can be three dimensional in which
c            case multiple analyses will be performed.  the third
c            index is the analysis index which assumes the values
c            k=1,...,nt.  for a single analysis set nt=1. the
c            discription of the remaining parameters is simplified
c            by assuming that nt=1 or that the arrays g,a and b
c            have only two dimensions.
c
c     g      a two or three dimensional array (see input parameter
c            nt) that contains the discrete function to be analyzed.
c            g(i,j) contains the value of the function at the colatitude
c            point theta(i) = (i-1)*pi/(nlat-1) and longitude point
c            phi(j) = (j-1)*2*pi/nlon. the index ranges are defined
c            above at the input parameter isym.
c
c
c     idg    the first dimension of the array g as it appears in the
c            program that calls shaes.  if isym equals zero then idg
c            must be at least nlat.  if isym is nonzero then idg
c            must be at least nlat/2 if nlat is even or at least
c            (nlat+1)/2 if nlat is odd.
c
c     jdg    the second dimension of the array g as it appears in the
c            program that calls shaes.  jdg must be at least nlon.
c
c     mdab   the first dimension of the arrays a and b as it appears
c            in the program that calls shaes. mdab must be at least
c            min0(nlat,(nlon+2)/2) if nlon is even or at least
c            min0(nlat,(nlon+1)/2) if nlon is odd.
c
c     ndab   the second dimension of the arrays a and b as it appears
c            in the program that calls shaes. ndab must be at least nlat
c
c     wshaes an array which must be initialized by subroutine shaesi.
c            once initialized, wshaes can be used repeatedly by shaes
c            as long as nlon and nlat remain unchanged.  wshaes must
c            not be altered between calls of shaes.
c
c     lshaes the dimension of the array wshaes as it appears in the
c            program that calls shaes. define
c
c               l1 = min0(nlat,(nlon+2)/2) if nlon is even or
c               l1 = min0(nlat,(nlon+1)/2) if nlon is odd
c
c            and
c
c               l2 = nlat/2        if nlat is even or
c               l2 = (nlat+1)/2    if nlat is odd
c
c            then lshaes must be at least
c
c               (l1*l2*(nlat+nlat-l1+1))/2+nlon+15
c
c     work   a work array that does not have to be saved.
c
c     lwork  the dimension of the array work as it appears in the
c            program that calls shaes.  define
c
c               l2 = nlat/2        if nlat is even or
c               l2 = (nlat+1)/2    if nlat is odd
c
c            if isym is zero then lwork must be at least
c            (nt+1)*nlat*nlon. if isym is not zero then
c            lwork must be at least (nt+1)*l2*nlon.
c
c
c     **************************************************************
c
c     output parameters
c
c     a,b    both a,b are two or three dimensional arrays (see input
c            parameter nt) that contain the spherical harmonic
c            coefficients in the representation of g(i,j) given in the
c            discription of subroutine shses. for isym=0, a(m,n) and
c            b(m,n) are given by the equations listed below. symmetric
c            versions are used when isym is greater than zero.
c
c
c
c     definitions
c
c     1. the normalized associated legendre functions
c
c     pbar(m,n,theta) = sqrt((2*n+1)*factorial(n-m)/(2*factorial(n+m)))
c                       *sin(theta)**m/(2**n*factorial(n)) times the
c                       (n+m)th derivative of (x**2-1)**n with respect
c                       to x=cos(theta)
c
c     2. the normalized z functions for m even
c
c     zbar(m,n,theta) = 2/(nlat-1) times the sum from k=0 to k=nlat-1 of
c                       the integral from tau = 0 to tau = pi of
c                       cos(k*theta)*cos(k*tau)*pbar(m,n,tau)*sin(tau)
c                       (first and last terms in this sum are divided
c                       by 2)
c
c     3. the normalized z functions for m odd
c
c     zbar(m,n,theta) = 2/(nlat-1) times the sum from k=0 to k=nlat-1 of
c                       of the integral from tau = 0 to tau = pi of
c                       sin(k*theta)*sin(k*tau)*pbar(m,n,tau)*sin(tau)
c
c     4. the fourier transform of g(i,j).
c
c     c(m,i)          = 2/nlon times the sum from j=1 to j=nlon
c                       of g(i,j)*cos((m-1)*(j-1)*2*pi/nlon)
c                       (the first and last terms in this sum
c                       are divided by 2)
c
c     s(m,i)          = 2/nlon times the sum from j=2 to j=nlon
c                       of g(i,j)*sin((m-1)*(j-1)*2*pi/nlon)
c
c     5. the maximum (plus one) longitudinal wave number
c
c            mmax = min0(nlat,(nlon+2)/2) if nlon is even or
c            mmax = min0(nlat,(nlon+1)/2) if nlon is odd.
c
c     then for m=0,...,mmax-1 and  n=m,...,nlat-1  the arrays a,b are
c     given by
c
c     a(m+1,n+1)      = the sum from i=1 to i=nlat of
c                       c(m+1,i)*zbar(m,n,theta(i))
c                       (first and last terms in this sum are
c                       divided by 2)
c
c     b(m+1,n+1)      = the sum from i=1 to i=nlat of
c                       s(m+1,i)*zbar(m,n,theta(i))
c
c
c     ierror = 0  no errors
c            = 1  error in the specification of nlat
c            = 2  error in the specification of nlon
c            = 3  error in the specification of isym
c            = 4  error in the specification of nt
c            = 5  error in the specification of idg
c            = 6  error in the specification of jdg
c            = 7  error in the specification of mdab
c            = 8  error in the specification of ndab
c            = 9  error in the specification of lshaes
c            = 10 error in the specification of lwork
c
c
c ****************************************************************
c     subroutine shaesi(nlat,nlon,wshaes,lshaes,work,lwork,dwork,
c    +                  ldwork,ierror)
c
c     subroutine shaesi initializes the array wshaes which can then
c     be used repeatedly by subroutine shaes
c
c     input parameters
c
c     nlat   the number of colatitudes on the full sphere including the
c            poles. for example, nlat = 37 for a five degree grid.
c            nlat determines the grid increment in colatitude as
c            pi/(nlat-1).  if nlat is odd the equator is located at
c            grid point i=(nlat+1)/2. if nlat is even the equator is
c            located half way between points i=nlat/2 and i=nlat/2+1.
c            nlat must be at least 3. note: on the half sphere, the
c            number of grid points in the colatitudinal direction is
c            nlat/2 if nlat is even or (nlat+1)/2 if nlat is odd.
c
c     nlon   the number of distinct londitude points.  nlon determines
c            the grid increment in longitude as 2*pi/nlon. for example
c            nlon = 72 for a five degree grid. nlon must be greater
c            than or equal to 4. the efficiency of the computation is
c            improved when nlon is a product of small prime numbers.
c
c     lshaes the dimension of the array wshaes as it appears in the
c            program that calls shaesi. define
c
c               l1 = min0(nlat,(nlon+2)/2) if nlon is even or
c               l1 = min0(nlat,(nlon+1)/2) if nlon is odd
c
c            and
c
c               l2 = nlat/2        if nlat is even or
c               l2 = (nlat+1)/2    if nlat is odd
c
c            then lshaes must be at least
c
c               (l1*l2*(nlat+nlat-l1+1))/2+nlon+15
c
c     work   a real   work array that does not have to be saved.
c
c     lwork  the dimension of the array work as it appears in the
c            program that calls shaesi.  define
c
c               l1 = min0(nlat,(nlon+2)/2) if nlon is even or
c               l1 = min0(nlat,(nlon+1)/2) if nlon is odd
c
c            and
c
c               l2 = nlat/2        if nlat is even or
c               l2 = (nlat+1)/2    if nlat is odd
c
c            then lwork must be at least
c
c               5*nlat*l2+3*((l1-2)*(nlat+nlat-l1-1))/2
c
c
C*PL*ERROR* Comment line too long
c     dwork  a double precision work array that does not have to be saved.
c
c     ldwork the dimension of the array dwork as it appears in the
c            program that calls shaesi.  ldwork must be at least nlat+1
c
c
c     output parameters
c
c     wshaes an array which is initialized for use by subroutine shaes.
c            once initialized, wshaes can be used repeatedly by shaes
c            as long as nlon and nlat remain unchanged.  wshaes must
c            not be altered between calls of shaes.
c
c     ierror = 0  no errors
c            = 1  error in the specification of nlat
c            = 2  error in the specification of nlon
c            = 3  error in the specification of lshaes
c            = 4  error in the specification of lwork
c            = 5  error in the specification of ldwork
c
c
c ****************************************************************
      SUBROUTINE DSHAES(NLAT,NLON,ISYM,NT,G,IDG,JDG,A,B,MDAB,NDAB,
     +                  WSHAES,LSHAES,WORK,LWORK,IERROR)
      DOUBLE PRECISION G
      DOUBLE PRECISION A
      DOUBLE PRECISION B
      DOUBLE PRECISION WSHAES
      DOUBLE PRECISION WORK
      DIMENSION G(IDG,JDG,1),A(MDAB,NDAB,1),B(MDAB,NDAB,1),WSHAES(1),
     +          WORK(1)

      IERROR = 1
      IF (NLAT.LT.3) RETURN
      IERROR = 2
      IF (NLON.LT.4) RETURN
      IERROR = 3
      IF (ISYM.LT.0 .OR. ISYM.GT.2) RETURN
      IERROR = 4
      IF (NT.LT.0) RETURN
      IERROR = 5
      IF ((ISYM.EQ.0.AND.IDG.LT.NLAT) .OR.
     +    (ISYM.NE.0.AND.IDG.LT. (NLAT+1)/2)) RETURN
      IERROR = 6
      IF (JDG.LT.NLON) RETURN
      IERROR = 7
      MMAX = MIN0(NLAT,NLON/2+1)
      IF (MDAB.LT.MMAX) RETURN
      IERROR = 8
      IF (NDAB.LT.NLAT) RETURN
      IERROR = 9
      IMID = (NLAT+1)/2
      IDZ = (MMAX* (NLAT+NLAT-MMAX+1))/2
      LZIMN = IDZ*IMID
      IF (LSHAES.LT.LZIMN+NLON+15) RETURN
      IERROR = 10
      LS = NLAT
      IF (ISYM.GT.0) LS = IMID
      NLN = NT*LS*NLON
      IF (LWORK.LT.NLN+LS*NLON) RETURN
      IERROR = 0
      IST = 0
      IF (ISYM.EQ.0) IST = IMID
      CALL DSHAES1(NLAT,ISYM,NT,G,IDG,JDG,A,B,MDAB,NDAB,WSHAES,IDZ,LS,
     +            NLON,WORK,WORK(IST+1),WORK(NLN+1),WSHAES(LZIMN+1))
      RETURN
      END
      SUBROUTINE DSHAES1(NLAT,ISYM,NT,G,IDGS,JDGS,A,B,MDAB,NDAB,Z,IDZ,
     +                  IDG,JDG,GE,GO,WORK,WHRFFT)
      DOUBLE PRECISION G
      DOUBLE PRECISION A
      DOUBLE PRECISION B
      DOUBLE PRECISION Z
      DOUBLE PRECISION GE
      DOUBLE PRECISION GO
      DOUBLE PRECISION WORK
      DOUBLE PRECISION WHRFFT
      DOUBLE PRECISION TSN
      DOUBLE PRECISION FSN
      DIMENSION G(IDGS,JDGS,1),A(MDAB,NDAB,1),B(MDAB,NDAB,1),Z(IDZ,1),
     +          GE(IDG,JDG,1),GO(IDG,JDG,1),WORK(1),WHRFFT(1)

      LS = IDG
      NLON = JDG
      MMAX = MIN0(NLAT,NLON/2+1)
      MDO = MMAX
      IF (MDO+MDO-1.GT.NLON) MDO = MMAX - 1
      NLP1 = NLAT + 1
      TSN = 2.D0/NLON
      FSN = 4.D0/NLON
      IMID = (NLAT+1)/2
      MODL = MOD(NLAT,2)
      IMM1 = IMID
      IF (MODL.NE.0) IMM1 = IMID - 1
      IF (ISYM.NE.0) GO TO 15
      DO 5 K = 1,NT
          DO 5 I = 1,IMM1
              DO 5 J = 1,NLON
                  GE(I,J,K) = TSN* (G(I,J,K)+G(NLP1-I,J,K))
                  GO(I,J,K) = TSN* (G(I,J,K)-G(NLP1-I,J,K))
    5 CONTINUE
      GO TO 30
   15 DO 20 K = 1,NT
          DO 20 I = 1,IMM1
              DO 20 J = 1,NLON
                  GE(I,J,K) = FSN*G(I,J,K)
   20 CONTINUE
      IF (ISYM.EQ.1) GO TO 27
   30 IF (MODL.EQ.0) GO TO 27
      DO 25 K = 1,NT
          DO 25 J = 1,NLON
              GE(IMID,J,K) = TSN*G(IMID,J,K)
   25 CONTINUE
   27 DO 35 K = 1,NT
          CALL DHRFFTF(LS,NLON,GE(1,1,K),LS,WHRFFT,WORK)
          IF (MOD(NLON,2).NE.0) GO TO 35
          DO 36 I = 1,LS
              GE(I,NLON,K) = .5D0*GE(I,NLON,K)
   36     CONTINUE
   35 CONTINUE
      DO 40 K = 1,NT
          DO 40 MP1 = 1,MMAX
              DO 40 NP1 = MP1,NLAT
                  A(MP1,NP1,K) = 0.D0
                  B(MP1,NP1,K) = 0.D0
   40 CONTINUE
      IF (ISYM.EQ.1) GO TO 145
      DO 110 K = 1,NT
          DO 110 I = 1,IMID
              DO 110 NP1 = 1,NLAT,2
                  A(1,NP1,K) = A(1,NP1,K) + Z(NP1,I)*GE(I,1,K)
  110 CONTINUE
      NDO = NLAT
      IF (MOD(NLAT,2).EQ.0) NDO = NLAT - 1
      DO 120 MP1 = 2,MDO
          M = MP1 - 1
          MB = M* (NLAT-1) - (M* (M-1))/2
          DO 120 K = 1,NT
              DO 120 I = 1,IMID
                  DO 120 NP1 = MP1,NDO,2
                      A(MP1,NP1,K) = A(MP1,NP1,K) +
     +                               Z(NP1+MB,I)*GE(I,2*MP1-2,K)
                      B(MP1,NP1,K) = B(MP1,NP1,K) +
     +                               Z(NP1+MB,I)*GE(I,2*MP1-1,K)
  120 CONTINUE
      IF (MDO.EQ.MMAX .OR. MMAX.GT.NDO) GO TO 135
      MB = MDO* (NLAT-1) - (MDO* (MDO-1))/2
      DO 130 K = 1,NT
          DO 130 I = 1,IMID
              DO 130 NP1 = MMAX,NDO,2
                  A(MMAX,NP1,K) = A(MMAX,NP1,K) +
     +                            Z(NP1+MB,I)*GE(I,2*MMAX-2,K)
  130 CONTINUE
  135 IF (ISYM.EQ.2) RETURN
  145 DO 150 K = 1,NT
          DO 150 I = 1,IMM1
              DO 150 NP1 = 2,NLAT,2
                  A(1,NP1,K) = A(1,NP1,K) + Z(NP1,I)*GO(I,1,K)
  150 CONTINUE
      NDO = NLAT
      IF (MOD(NLAT,2).NE.0) NDO = NLAT - 1
      DO 160 MP1 = 2,MDO
          M = MP1 - 1
          MP2 = MP1 + 1
          MB = M* (NLAT-1) - (M* (M-1))/2
          DO 160 K = 1,NT
              DO 160 I = 1,IMM1
                  DO 160 NP1 = MP2,NDO,2
                      A(MP1,NP1,K) = A(MP1,NP1,K) +
     +                               Z(NP1+MB,I)*GO(I,2*MP1-2,K)
                      B(MP1,NP1,K) = B(MP1,NP1,K) +
     +                               Z(NP1+MB,I)*GO(I,2*MP1-1,K)
  160 CONTINUE
      MP2 = MMAX + 1
      IF (MDO.EQ.MMAX .OR. MP2.GT.NDO) RETURN
      MB = MDO* (NLAT-1) - (MDO* (MDO-1))/2
      DO 170 K = 1,NT
          DO 170 I = 1,IMM1
              DO 170 NP1 = MP2,NDO,2
                  A(MMAX,NP1,K) = A(MMAX,NP1,K) +
     +                            Z(NP1+MB,I)*GO(I,2*MMAX-2,K)
  170 CONTINUE
      RETURN
      END

      SUBROUTINE DSHAESI(NLAT,NLON,WSHAES,LSHAES,WORK,LWORK,DWORK,
     +                   LDWORK,IERROR)
      DOUBLE PRECISION WSHAES
      DOUBLE PRECISION WORK
      DIMENSION WSHAES(*),WORK(*)
C*PT*WARNING* Already double-precision
      DOUBLE PRECISION DWORK(*)
c
c     length of wshaes is (l*(l+1)*imid)/2+nlon+15
c     length of work is 5*l*imid + 3*((l-3)*l+2)/2
c
      IERROR = 1
      IF (NLAT.LT.3) RETURN
      IERROR = 2
      IF (NLON.LT.4) RETURN
      IERROR = 3
      MMAX = MIN0(NLAT,NLON/2+1)
      IMID = (NLAT+1)/2
      LZIMN = (IMID*MMAX* (NLAT+NLAT-MMAX+1))/2
      IF (LSHAES.LT.LZIMN+NLON+15) RETURN
      IERROR = 4
      LABC = 3* ((MMAX-2)* (NLAT+NLAT-MMAX-1))/2
      IF (LWORK.LT.5*NLAT*IMID+LABC) RETURN
      IERROR = 5
      IF (LDWORK.LT.NLAT+1) RETURN
      IERROR = 0
      IW1 = 3*NLAT*IMID + 1
      IDZ = (MMAX* (NLAT+NLAT-MMAX+1))/2
      CALL DSEA1(NLAT,NLON,IMID,WSHAES,IDZ,WORK,WORK(IW1),DWORK)
      CALL DHRFFTI(NLON,WSHAES(LZIMN+1))
      RETURN
      END


c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1992  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     #############################################################
c     ##                                                         ##
c     ##  subroutine gyrate  --  compute the radius of gyration  ##
c     ##                                                         ##
c     #############################################################
c
c
c     "gyrate" computes the radius of gyration of a molecular system
c     from its atomic coordinates; only active atoms are included
c
c
      subroutine gyrate (rg)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'usage.i'
      integer i,k
      real*8 rg,xc,yc,zc
c
c
c     find the centroid of the atomic coordinates
c
      xc = 0.0d0
      yc = 0.0d0
      zc = 0.0d0
      do i = 1, nuse
         k = iuse(i)
         xc = xc + x(k)
         yc = yc + y(k)
         zc = zc + z(k)
      end do
      xc = xc / dble(nuse)
      yc = yc / dble(nuse)
      zc = zc / dble(nuse)
c
c     compute and print out the radius of gyration
c
      rg = 0.0d0
      do i = 1, nuse
         k = iuse(i)
         rg = rg + (x(k)-xc)**2 + (y(k)-yc)**2 + (z(k)-zc)**2
      end do
      rg = sqrt(rg/dble(nuse))
      return
      end


      REAL FUNCTION VECL2 (VX,VY,VZ)

C  This function returns the squared length of a 3D vector.

      REAL  VX,VY,VZ

      VECL2 = VX*VX + VY*VY + VZ*VZ

      END


subroutine meshgrid(xr,yr,x,y)
! Replicates the grid vectors xr and yr to produce a full grid represented by the output coordinate arrays X and Y.
! === Parameters ===
! xr - (vector) x grid points
! yr - (vector) y grid points
! === Output ===
! x  - (matrix) x values at gridpoints
! y  - (matrix) y values at gridpoint
real(kind=8), intent(in)  :: xr(:),yr(:)
real(kind=8), intent(out) :: x(size(xr),size(yr)),y(size(xr),size(yr))
integer i,j,n,m
n = size(xr)
m = size(yr)
do i=1,n
    do j=1,n
        x(i,j) = xr(j)
        y(i,j) = yr(i)
    enddo
enddo
end subroutine meshgrid


program test
  integer :: a = (2*3) * 2
  integer :: b = 2 * 3 * 2
  integer :: arr(-1:2)
  arr(-1) = 11

  if (a == b .and. b == 12) THEN
    a = 10
    b = 20

    if (arr(-1) == 11) THEN
      arr(-1) = 40
    END IF

    if (arr(-1) /= 11) THEN
      arr(-1) = 30 + arr(-1)
    END IF

    if (arr(-1) /= 30) arr(0) = arr(-1) + a*2

  END IF

  print *,a,b,arr(-1),arr(0)
end program test


      SUBROUTINE SORTSVD(M, N, MP, NP, W, U, V)
c------------------------------
c     Sorts the weights and U, V matrices from SVD decomposition
c     Sorts weights in DECREASING order
c     Based on routine SORT2 from Numerical Recipes, pg 231
c     Created by Prashant Valanju, (Sept 1998)
c------------------------------
      USE stel_kinds
      IMPLICIT NONE
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER M, N, MP, NP
      REAL(rprec), DIMENSION(NP) :: W
      REAL(rprec), DIMENSION(MP,NP) :: U
      REAL(rprec), DIMENSION(NP,NP) :: V
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER :: L, IR, I, J
      REAL(rprec), DIMENSION(MP) :: RU
      REAL(rprec), DIMENSION(NP) :: RV
      REAL(rprec) :: RW
C-----------------------------------------------
      IF (M .GT. MP) STOP 'M > MP IN SORTSVD'
      IF (N .GT. NP) STOP 'N > NP IN SORTSVD'

      L = N/2 + 1
      IR = N
   10 CONTINUE
      IF (L .gt. 1) THEN
         L = L - 1
         RW = W(L)
         RU(:M) = U(:M,L)
         RV(:N) = V(:N,L)
      ELSE
         RW = W(IR)
         RU(:M) = U(:M,IR)
         RV(:N) = V(:N,IR)
         W(IR) = W(1)
         U(:M,IR) = U(:M,1)
         V(:N,IR) = V(:N,1)
         IR = IR - 1
         IF (IR .eq. 1) THEN
            W(1) = RW
            U(:M,1) = RU(:M)
            V(:N,1) = RV(:N)
            RETURN
         ENDIF
      ENDIF
      I = L
      J = L + L
   20 CONTINUE
      IF (J .le. IR) THEN
         IF (J .lt. IR) THEN
C                                    !Just change these 2 for increasing
            IF (W(J) .gt. W(J+1)) J = J + 1
         ENDIF
         IF (RW .gt. W(J)) THEN         !Just change these 2 for increasing
            W(I) = W(J)
            U(:M,I) = U(:M,J)
            V(:N,I) = V(:N,J)
            I = J
            J = J + J
         ELSE
            J = IR + 1
         ENDIF
         GO TO 20
      ENDIF
      W(I) = RW
      U(:M,I) = RU(:M)
      V(:N,I) = RV(:N)
      GO TO 10

      END SUBROUTINE SORTSVD