C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C     *                                                               *
C     *                  copyright (c) 1999 by UCAR                   *
C     *                                                               *
C     *       UNIVERSITY CORPORATION for ATMOSPHERIC RESEARCH         *
C     *                                                               *
C     *                      all rights reserved                      *
C     *                                                               *
C     *                      FISHPACK version 4.1                     *
C     *                                                               *
C     *     A PACKAGE OF FORTRAN SUBPROGRAMS FOR THE SOLUTION OF      *
C     *                                                               *
C     *      SEPARABLE ELLIPTIC PARTIAL DIFFERENTIAL EQUATIONS        *
C     *                                                               *
C     *                             BY                                *
C     *                                                               *
C     *        JOHN ADAMS, PAUL SWARZTRAUBER AND ROLAND SWEET         *
C     *                                                               *
C     *                             OF                                *
C     *                                                               *
C     *         THE NATIONAL CENTER FOR ATMOSPHERIC RESEARCH          *
C     *                                                               *
C     *                BOULDER, COLORADO  (80307)  U.S.A.             *
C     *                                                               *
C     *                   WHICH IS SPONSORED BY                       *
C     *                                                               *
C     *              THE NATIONAL SCIENCE FOUNDATION                  *
C     *                                                               *
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C
C     PROGRAM TO ILLUSTRATE THE USE OF HWSCSP
C
      DIMENSION       F(48,33)   ,BDTF(33)   ,W(775)     ,R(33)      ,
     1                THETA(48)
C
      PI = PIMACH(DUM)
      INTL = 0
      TS = 0.
      TF = PI/2.
      M = 36
      MBDCND = 6
      RS = 0.
      RF = 1.
      N = 32
      NBDCND = 5
      ELMBDA = 0.
      IDIMF = 48
C
C     GENERATE AND STORE GRID POINTS FOR THE PURPOSE OF COMPUTING THE
C     BOUNDARY DATA AND THE RIGHT SIDE OF THE EQUATION.
C
      MP1 = M+1
      DTHETA = TF/FLOAT(M)
      DO 101 I=1,MP1
         THETA(I) = FLOAT(I-1)*DTHETA
  101 CONTINUE
      NP1 = N+1
      DR = 1./FLOAT(N)
      DO 102 J=1,NP1
         R(J) = FLOAT(J-1)*DR
  102 CONTINUE
C
C     GENERATE NORMAL DERIVATIVE DATA AT EQUATOR
C
      DO 103 J=1,NP1
         BDTF(J) = 0.
  103 CONTINUE
C
C     COMPUTE BOUNDARY DATA ON THE SURFACE OF THE SPHERE
C
      DO 104 I=1,MP1
         F(I,N+1) = COS(THETA(I))**4
  104 CONTINUE
C
C     COMPUTE RIGHT SIDE OF EQUATION
C
      DO 106 I=1,MP1
         CI4 = 12.*COS(THETA(I))**2
         DO 105 J=1,N
            F(I,J) = CI4*R(J)**2
  105    CONTINUE
  106 CONTINUE
C
      CALL HWSCSP (INTL,TS,TF,M,MBDCND,BDTS,BDTF,RS,RF,N,NBDCND,BDRS,
     1             BDRF,ELMBDA,F,IDIMF,PERTRB,IERROR,W)
C
C     COMPUTE DISCRETIZATION ERROR
C
      ERR = 0.
      DO 108 I=1,MP1
         CI4 = COS(THETA(I))**4
         DO 107 J=1,N
            Z = ABS(F(I,J)-CI4*R(J)**4)
            IF (Z .GT. ERR) ERR = Z
  107    CONTINUE
  108 CONTINUE
      IW = INT(W(1))
      PRINT 1001 , IERROR,ERR,IW
C
C     THE FOLLOWING PROGRAM ILLUSTRATES THE USE OF HWSCSP TO SOLVE
C     A THREE DIMENSIONAL PROBLEM WHICH HAS LONGITUDNAL DEPENDENCE
C
      MBDCND = 2
      NBDCND = 1
      DPHI = PI/72.
      ELMBDA = -2.*(1.-COS(DPHI))/DPHI**2
C
C     COMPUTE BOUNDARY DATA ON THE SURFACE OF THE SPHERE
C
      DO 109 I=1,MP1
         F(I,N+1) = SIN(THETA(I))
  109 CONTINUE
C
C     COMPUTE RIGHT SIDE OF THE EQUATION
C
      DO 111 J=1,N
         DO 110 I=1,MP1
            F(I,J) = 0.
  110    CONTINUE
  111 CONTINUE
C
      CALL HWSCSP (INTL,TS,TF,M,MBDCND,BDTS,BDTF,RS,RF,N,NBDCND,BDRS,
     1             BDRF,ELMBDA,F,IDIMF,PERTRB,IERROR,W)
C
C     COMPUTE DISCRETIZATION ERROR   (FOURIER COEFFICIENTS)
C
      ERR = 0
      DO 113 I=1,MP1
         SI = SIN(THETA(I))
         DO 112 J=1,NP1
            Z = ABS(F(I,J)-R(J)*SI)
            IF (Z .GT. ERR) ERR = Z
  112    CONTINUE
  113 CONTINUE
C
      IW = INT(W(1))
      PRINT 1002 , IERROR,ERR,IW
      STOP IERROR
C
 1001 FORMAT (1H1,20X,27HSUBROUTINE HWSCSP EXAMPLE 1///
     1        10X,46HTHE OUTPUT FROM THE NCAR CONTROL DATA 7600 WAS//
     2        32X,10HIERROR = 0/
     3        18X,34HDISCRETIZATION ERROR = 7.99842E-04/
     4        12X,32HREQUIRED LENGTH OF W ARRAY = 775//
     5        10X,32HTHE OUTPUT FROM YOUR COMPUTER IS//
     6        32X,8HIERROR =,I2/18X,22HDISCRETIZATION ERROR =,E12.5/
     7        12X,28HREQUIRED LENGTH OF W ARRAY =,I4)
 1002 FORMAT (1H1,20X,27HSUBROUTINE HWSCSP EXAMPLE 2///
     1        10X,46HTHE OUTPUT FROM THE NCAR CONTROL DATA 7600 WAS//
     2        32X,10HIERROR = 0/
     3        18X,34HDISCRETIZATION ERROR = 5.86824E-05/
     4        12X,32HREQUIRED LENGTH OF W ARRAY = 775//
     5        10X,32HTHE OUTPUT FROM YOUR COMPUTER IS//
     6        32X,8HIERROR =,I2/18X,22HDISCRETIZATION ERROR =,E12.5/
     7        12X,28HREQUIRED LENGTH OF W ARRAY =,I4)
C
      END


module grid_fourier_mod

use       fms_mod, only: mpp_pe, mpp_root_pe, error_mesg, FATAL, &
                         write_version_number

use constants_mod, only: pi

use fft_mod,       only: fft_init, fft_grid_to_fourier, fft_fourier_to_grid

!    provides one-dimensional grid-to-fourier and fourier-to-grid
!    transforms on the first dimension of two- or three-dimensional fields.
!
!----------------------------------------------------------------------------

implicit none
private

character(len=128), parameter :: version = '$Id: grid_fourier.f90,v 11.0 2004/09/28 19:30:50 fms Exp $'
character(len=128), parameter :: tagname = '$Name: latest $'

public :: grid_fourier_init, grid_fourier_end, trans_grid_to_fourier, trans_fourier_to_grid
public :: get_lon_max, get_longitude_origin, get_deg_lon

interface trans_grid_to_fourier
   module procedure trans_grid_to_fourier_3d, trans_grid_to_fourier_2d
end interface

interface trans_fourier_to_grid
   module procedure trans_fourier_to_grid_3d, trans_fourier_to_grid_2d
end interface

interface verify_fourier_imag
   module procedure verify_fourier_imag_3d, verify_fourier_imag_2d
end interface

integer :: num_lon
real    :: longitude_origin_local
logical :: check_local
logical :: module_is_initialized = .false.

real, allocatable, dimension(:) :: deg_lon

contains

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

subroutine grid_fourier_init(num_lon_in, fourier_inc, check, longitude_origin)

integer, intent(in) :: num_lon_in, fourier_inc
logical, intent(in), optional   :: check
real,    intent(in), optional   :: longitude_origin
integer :: i
character(len=8) :: chtmp
real :: total_degrees

if(module_is_initialized) return

call write_version_number(version, tagname)

if(mod(num_lon_in,2) .ne. 0) then
  write(chtmp,'(i8)') num_lon_in
  call error_mesg('grid_fourier_init','num_lon must be even, but num_lon='//chtmp, FATAL)
end if

if(num_lon_in .eq. 0) then
  call error_mesg('grid_fourier_init','num_lon cannot be zero', FATAL)
end if

num_lon = num_lon_in

if(present(check)) then
  check_local = check
else
  check_local = .false.
end if

if(present(longitude_origin)) then
  longitude_origin_local = longitude_origin
else
  longitude_origin_local = 0.0
end if

total_degrees = 360./float(fourier_inc)

if(allocated(deg_lon)) deallocate(deg_lon)
allocate(deg_lon(num_lon))
do i=1,num_lon
  deg_lon(i) = 180*longitude_origin_local/pi &
     + (i-1)*total_degrees/float(num_lon)
  if(deg_lon(i) .ge. total_degrees) then
    deg_lon(i) = deg_lon(i) - total_degrees
  endif
  if(deg_lon(i) .lt. 0.0) then
    deg_lon(i) = deg_lon(i) + total_degrees
  endif
end do

call fft_init(num_lon)

module_is_initialized = .true.

return
end subroutine grid_fourier_init

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

function trans_grid_to_fourier_3d(grid) result(fourier)

real,    intent(in),  dimension(:,:,:) :: grid
complex, dimension(0:size(grid,1)/2, size(grid,2), size(grid,3)) :: fourier
real, dimension(size(grid,1)+1,size(grid,2),size(grid,3)) :: grid1
character(len=8) :: chtmp1, chtmp2

if(.not.module_is_initialized) then
  call error_mesg('trans_grid_to_fourier','module grid_fourier not initialized', FATAL)
end if

if(size(grid,1).ne.num_lon) then
  write(chtmp1,'(i8)') size(grid,1)
  write(chtmp2,'(i8)') num_lon
  call error_mesg('trans_grid_to_fourier', &
    'size(grid,1) must equal num_lon, but size(grid,1)='//chtmp1//' num_lon='//chtmp2, FATAL)
end if

grid1(1:size(grid,1),:,:) = grid
grid1(size(grid,1)+1,:,:) = grid(1,:,:)
fourier = fft_grid_to_fourier(grid1)

return
end function trans_grid_to_fourier_3d
!------------------------------------------------------------------------------------------------------

function trans_fourier_to_grid_3d(fourier) result(grid)

complex, intent(in), dimension(0:,:,:) :: fourier
real, dimension(2*(size(fourier,1)-1), size(fourier,2), size(fourier,3)) :: grid
real, dimension(2*size(fourier,1)-1,   size(fourier,2), size(fourier,3)) :: grid1
character(len=8) :: chtmp1, chtmp2

if(.not.module_is_initialized) then
  call error_mesg('trans_fourier_to_grid','module grid_fourier not initialized', FATAL)
end if

if(2*(size(fourier,1)-1) .ne. num_lon) then
  write(chtmp1,'(i8)') size(fourier,1)
  write(chtmp2,'(i8)') num_lon
  call error_mesg('trans_fourier_to_grid', &
  '2*(size(fourier,1)-1) must equal num_lon, but size(fourier,1)='//chtmp1//' num_lon='//chtmp2, FATAL)
end if

if(check_local)  call verify_fourier_imag(fourier)

grid1 = fft_fourier_to_grid(fourier)
grid = grid1(1:2*(size(fourier,1)-1),:,:)

return
end function trans_fourier_to_grid_3d
!------------------------------------------------------------------------------------------------------

subroutine verify_fourier_imag_3d(fourier)

complex, intent(in), dimension(0:,:,:) :: fourier
integer :: j, k
character(len=56) :: chtmp='aimag(fourier(   ,   ,   ))=                            '

do k=1,size(fourier,3)
  do j=1,size(fourier,2)
    if(aimag(fourier(0,j,k)) .ne. 0.0) then
      chtmp(15:17) = '  0'
      write(chtmp(19:21),'(i3)') j
      write(chtmp(23:25),'(i3)') k
      write(chtmp(29:52),'(1pe24.16)') aimag(fourier(0,j,k))
      call error_mesg('verify_fourier_imag',chtmp//'  It should be zero.', FATAL)
    end if
  end do
end do

if(mod(num_lon,2).eq.0) then
  do k=1,size(fourier,3)
    do j=1,size(fourier,2)
      if(aimag(fourier(num_lon/2,j,k)) .ne. 0.0) then
        write(chtmp(15:17),'(i3)') num_lon/2
        write(chtmp(19:21),'(i3)') j
        write(chtmp(23:25),'(i3)') k
        write(chtmp(29:52),'(1pe24.16)') aimag(fourier(0,j,k))
        call error_mesg('verify_fourier_imag',chtmp//'  It should be zero.', FATAL)
      end if
    end do
  end do
end if

return
end subroutine verify_fourier_imag_3d
!------------------------------------------------------------------------------------------------------

!  The remaining routines are 2d version of the 3d versions described above)

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

function trans_fourier_to_grid_2d (fourier) result(grid)

complex, intent(in), dimension(0:,:) :: fourier
complex, dimension(0:size(fourier,1)-1, size(fourier,2), 1) :: fourier_3d

real, dimension(2*(size(fourier,1)-1), size(fourier,2)) :: grid
real, dimension(2*(size(fourier,1)-1), size(fourier,2), 1) :: grid_3d

fourier_3d(:,:,1) = fourier(:,:)
grid_3d = trans_fourier_to_grid_3d(fourier_3d)
grid(:,:) = grid_3d(:,:,1)

return
end function trans_fourier_to_grid_2d
!------------------------------------------------------------------------------------------------------

function trans_grid_to_fourier_2d (grid) result(fourier)

real,    intent(in),  dimension(:,:) :: grid
complex, dimension(0:size(grid,1)/2, size(grid,2)) :: fourier

real, dimension(size(grid,1), size(grid,2), 1) :: grid_3d
complex, dimension(0:size(grid,1)/2, size(grid,2), 1) :: fourier_3d

grid_3d(:,:,1) = grid(:,:)
fourier_3d = trans_grid_to_fourier_3d(grid_3d)
fourier(:,:) = fourier_3d(:,:,1)

return
end function trans_grid_to_fourier_2d

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

subroutine verify_fourier_imag_2d(fourier)

complex, intent(in), dimension(0:,:) :: fourier
complex, dimension(0:size(fourier,1)-1, size(fourier,2), 1) :: fourier_3d

fourier_3d(:,:,1) = fourier(:,:)
call verify_fourier_imag_3d(fourier_3d)

return
end subroutine verify_fourier_imag_2d

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

subroutine get_lon_max(lon_max_out)

integer, intent (out) :: lon_max_out

if(.not.module_is_initialized) then
  call error_mesg('get_lon_max','module grid_fourier not initialized', FATAL)
end if

lon_max_out = num_lon

return
end subroutine get_lon_max

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

subroutine get_longitude_origin(longitude_origin_out)

real, intent (out) :: longitude_origin_out

if(.not.module_is_initialized) then
  call error_mesg('get_longitude_origin','module grid_fourier not initialized', FATAL)
end if

longitude_origin_out = longitude_origin_local

return
end subroutine get_longitude_origin

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

subroutine get_deg_lon(deg_lon_out)

real, intent (out), dimension(:) :: deg_lon_out
character(len=8) :: chtmp1, chtmp2

if(.not.module_is_initialized) then
  call error_mesg('get_deg_lon','module grid_fourier not initialized', FATAL)
end if
if(size(deg_lon_out,1).ne.num_lon) then
  write(chtmp1,'(i8)') size(deg_lon_out,1)
  write(chtmp2,'(i8)') num_lon
  call error_mesg('get_deg_lon', &
    'size of deg_lon does not equal num_lon. size(deg_lon)='//chtmp1//' num_lon='//chtmp2, FATAL)
end if

deg_lon_out(:) = deg_lon(:)

return
end subroutine get_deg_lon

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

subroutine grid_fourier_end

if(.not.module_is_initialized) return
deallocate(deg_lon)
!call fft_end
module_is_initialized = .false.

return
end subroutine grid_fourier_end

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

end module grid_fourier_mod


      double precision function psi(xp,yp,zp,t)
      implicit none

      double precision xp,yp,zp,t
      double precision pi2, revs_per_second

      double precision pi
      common /compi/ pi

      common /spherecomm/ revs_per_second

      pi2 = 2*pi

c     # Solid body rotation
      psi = pi2*revs_per_second*zp

      psi = -psi

      end

      subroutine get_psi_vel(xd1,xd2,ds,vn,t)
      implicit none

      double precision xd1(3),xd2(3), ds, vn, psi,t

      vn = (psi(xd1(1),xd1(2),xd1(3),t) -
     &      psi(xd2(1),xd2(2),xd2(3),t))/ds

      end


! 6.2.5 Identity matrix distribution
! Write a program that distributes an identity matrix over the processes.  The
! dimension and the number of processes are given.  Distribute by rows
! (Fortran).
! The program reads the matrix size S, takes the number of processes N, and
! calculates how many columns (with remainder) must take every process.
! You can either operate with local or global indices on each process.  At the
! end, rank 0 collects parts of the matrix from other ranks and prints the
! entire thing.
!
! Compile and run:
! $ mpifort -O0 -Wall -Wextra -fcheck=bounds -fbacktrace identity_matrix.f90
! $ mpirun -np 3 --oversubscribe ./a.out
! Enter size 7.
program identity_matrix
    use mpi_f08
    implicit none

    integer :: my_rank, n_ranks, top_rank, bottom_rank
    type(MPI_Status) :: status
    integer :: remainder, n_rows, n_rows_r, row, row_s, row_e, i, r
    integer :: s ! matrix size
    integer, allocatable :: e(:, :)
    integer, allocatable :: e_big(:, :)
    !type(MPI_Datatype) :: np1_rows_t
    !type(MPI_Datatype) :: n_rows_t
    integer(kind=MPI_ADDRESS_KIND) :: lb, integer_extent
    type(MPI_Datatype) :: row_t
    type(MPI_Datatype) :: row_resized_t

    call MPI_Init()
    call MPI_Comm_rank(MPI_COMM_WORLD, my_rank)
    call MPI_Comm_size(MPI_COMM_WORLD, n_ranks)

    if (my_rank == 0) then
        read *, s
        remainder = mod(s, n_ranks)
        n_rows    = (s - remainder) / n_ranks
        do r = 0, n_ranks - 1
            ! Let first processes have one extra column for even division.
            if (r < remainder) then
                n_rows_r = n_rows + 1
            else
                n_rows_r = n_rows
            end if
            call MPI_Bsend(s,        1, MPI_INTEGER, r, 0, MPI_COMM_WORLD)
            call MPI_Bsend(n_rows_r, 1, MPI_INTEGER, r, 0, MPI_COMM_WORLD)
        end do
    end if ! my_rank == 0
    call MPI_Recv(s,      1, MPI_INTEGER, 0, 0, MPI_COMM_WORLD, status)
    call MPI_Recv(n_rows, 1, MPI_INTEGER, 0, 0, MPI_COMM_WORLD, status)

    ! Inefficient method with three branches:
    !if (my_rank == 0) then
    !    row = 1
    !    row_s = row
    !    row_e = row + n_rows - 1
    !    row = row_e + 1
    !    call MPI_Send(row, 1, MPI_INTEGER, 1, 0, MPI_COMM_WORLD)
    !else if (0 < my_rank .and. my_rank < n_ranks - 1) then
    !    call MPI_Recv(row, 1, MPI_INTEGER, my_rank - 1, 0, MPI_COMM_WORLD, status)
    !    row_s = row
    !    row_e = row + n_rows - 1
    !    row = row_e + 1
    !    call MPI_Send(row, 1, MPI_INTEGER, my_rank + 1, 0, MPI_COMM_WORLD)
    !else ! n_ranks - 1
    !    call MPI_Recv(row, 1, MPI_INTEGER, my_rank - 1, 0, MPI_COMM_WORLD, status)
    !    row_s = row
    !    row_e = row + n_rows - 1
    !end if

    ! More efficient method using MPI_PROC_NULL to suppress unnecessary calls.

    top_rank = my_rank - 1
    if (top_rank == -1) top_rank = MPI_PROC_NULL
    bottom_rank = my_rank + 1
    if (bottom_rank == n_ranks) bottom_rank = MPI_PROC_NULL

    row = 1
    call MPI_Recv(row, 1, MPI_INTEGER, top_rank, 0, MPI_COMM_WORLD, status)
    row_s = row
    row_e = row + n_rows - 1
    row = row_e + 1
    call MPI_Send(row, 1, MPI_INTEGER, bottom_rank, 0, MPI_COMM_WORLD)

    ! Initialize the local matrix.
    allocate(e(row_s:row_e, s), source=0)
    do row = row_s, row_e
        e(row, row) = 1
    end do

    ! Define the strided type that will contain all local rows.  On all ranks it
    ! has n_rows.  On first ranks < R it has one extra row and on last ranks
    ! >= R it has one less.  When sending to rank~0 this will always work
    ! because the receive can get less than the specified count.
    ! Method 2: define a row type and resize its extent to be of 1 integer size.
    ! With such a type a contiguous type will exactly follow the row order.
    call MPI_Type_get_extent(MPI_INTEGER, lb, integer_extent)
    if (my_rank == 0) then
        ! Method 1:
        !call MPI_Type_vector(s, n_rows, s, MPI_INTEGER, np1_rows_t)
        !call MPI_Type_commit(np1_rows_t)
        !if (remainder /= 0) then
        !    call MPI_Type_vector(s, n_rows - 1, s, MPI_INTEGER, n_rows_t)
        !    call MPI_Type_commit(n_rows_t)
        !end if
        ! Method 2:
        call MPI_Type_vector(s, 1, s, MPI_INTEGER, row_t)
        call MPI_Type_create_resized(row_t, lb, integer_extent, row_resized_t)
        call MPI_Type_commit(row_resized_t)
    else
        ! On rank /= 0 this row type is for the local e array.
        call MPI_Type_vector(s, 1, n_rows, MPI_INTEGER, row_t)
        call MPI_Type_create_resized(row_t, lb, integer_extent, row_resized_t)
        call MPI_Type_commit(row_resized_t)
    end if

    if (my_rank == 0) then
        allocate(e_big(s, s))
        ! Copy from e to e_big first slice.
        e_big(row_s:row_e, :) = e(row_s:row_e, :)
        ! Collect the other slices from other processes.
        do r = 1, n_ranks - 1
            ! Get row_s from other ranks.
            call MPI_Recv(row_s, 1, MPI_INTEGER, r, 0, MPI_COMM_WORLD, status)
            ! Method 1 (using two types):
            !if (remainder /= 0 .and. r >= remainder) then
            !    call MPI_Recv(e_big(row_s, 1), 1, n_rows_t, r, 0, MPI_COMM_WORLD, status)
            !else
            !    call MPI_Recv(e_big(row_s, 1), 1, np1_rows_t, r, 0, MPI_COMM_WORLD, status)
            !end if
            ! Method 2 (using one resized row and contiguous type):
            call MPI_Recv(e_big(row_s, 1), n_rows + 1, row_resized_t, r, 0, MPI_COMM_WORLD, status)
        end do
    else
        call MPI_Send(row_s, 1,         MPI_INTEGER, 0, 0, MPI_COMM_WORLD)
        !call MPI_Send(e,     n_rows * s, MPI_INTEGER, 0, 0, MPI_COMM_WORLD)     ! Method 1: send all elements.
        call MPI_Send(e(row_s, 1), n_rows, row_resized_t, 0, 0, MPI_COMM_WORLD) ! Method 2: send resized rows.
    end if

    if (my_rank == 0) then
        do row = 1, s
            print '(*(i0, 1x))', e_big(row, :)
        end do
        deallocate(e_big)
    end if

    ! Method 1: release both types.
    !if (my_rank == 0) then
    !    call MPI_Type_free(np1_rows_t)
    !    if (remainder /= 0) then
    !        call MPI_Type_free(n_rows_t)
    !    end if
    !end if
    !call MPI_Type_free(n_rows_t)
    !call MPI_Type_free(np1_rows_t)
    ! Method 2: release only the resized row type.
    call MPI_Type_free(row_resized_t)

    deallocate(e)
    call MPI_Finalize()
end program identity_matrix


      subroutine covar(n,r,ldr,ipvt,tol,wa)
      integer n,ldr
      integer ipvt(n)
      double precision tol
      double precision r(ldr,n),wa(n)
c     **********
c
c     subroutine covar
c
c     given an m by n matrix a, the problem is to determine
c     the covariance matrix corresponding to a, defined as
c
c                    t
c           inverse(a *a) .
c
c     this subroutine completes the solution of the problem
c     if it is provided with the necessary information from the
c     qr factorization, with column pivoting, of a. that is, if
c     a*p = q*r, where p is a permutation matrix, q has orthogonal
c     columns, and r is an upper triangular matrix with diagonal
c     elements of nonincreasing magnitude, then covar expects
c     the full upper triangle of r and the permutation matrix p.
c     the covariance matrix is then computed as
c
c                      t     t
c           p*inverse(r *r)*p  .
c
c     if a is nearly rank deficient, it may be desirable to compute
c     the covariance matrix corresponding to the linearly independent
c     columns of a. to define the numerical rank of a, covar uses
c     the tolerance tol. if l is the largest integer such that
c
c           abs(r(l,l)) .gt. tol*abs(r(1,1)) ,
c
c     then covar computes the covariance matrix corresponding to
c     the first l columns of r. for k greater than l, column
c     and row ipvt(k) of the covariance matrix are set to zero.
c
c     the subroutine statement is
c
c       subroutine covar(n,r,ldr,ipvt,tol,wa)
c
c     where
c
c       n is a positive integer input variable set to the order of r.
c
c       r is an n by n array. on input the full upper triangle must
c         contain the full upper triangle of the matrix r. on output
c         r contains the square symmetric covariance matrix.
c
c       ldr is a positive integer input variable not less than n
c         which specifies the leading dimension of the array r.
c
c       ipvt is an integer input array of length n which defines the
c         permutation matrix p such that a*p = q*r. column j of p
c         is column ipvt(j) of the identity matrix.
c
c       tol is a nonnegative input variable used to define the
c         numerical rank of a in the manner described above.
c
c       wa is a work array of length n.
c
c     subprograms called
c
c       fortran-supplied ... dabs
c
c     argonne national laboratory. minpack project. august 1980.
c     burton s. garbow, kenneth e. hillstrom, jorge j. more
c
c     **********
      integer i,ii,j,jj,k,km1,l
      logical sing
      double precision one,temp,tolr,zero
      data one,zero /1.0d0,0.0d0/
c
c     form the inverse of r in the full upper triangle of r.
c
      tolr = tol*dabs(r(1,1))
      l = 0
      do 40 k = 1, n
         if (dabs(r(k,k)) .le. tolr) go to 50
         r(k,k) = one/r(k,k)
         km1 = k - 1
         if (km1 .lt. 1) go to 30
         do 20 j = 1, km1
            temp = r(k,k)*r(j,k)
            r(j,k) = zero
            do 10 i = 1, j
               r(i,k) = r(i,k) - temp*r(i,j)
   10          continue
   20       continue
   30    continue
         l = k
   40    continue
   50 continue
c
c     form the full upper triangle of the inverse of (r transpose)*r
c     in the full upper triangle of r.
c
      if (l .lt. 1) go to 110
      do 100 k = 1, l
         km1 = k - 1
         if (km1 .lt. 1) go to 80
         do 70 j = 1, km1
            temp = r(j,k)
            do 60 i = 1, j
               r(i,j) = r(i,j) + temp*r(i,k)
   60          continue
   70       continue
   80    continue
         temp = r(k,k)
         do 90 i = 1, k
            r(i,k) = temp*r(i,k)
   90       continue
  100    continue
  110 continue
c
c     form the full lower triangle of the covariance matrix
c     in the strict lower triangle of r and in wa.
c
      do 130 j = 1, n
         jj = ipvt(j)
         sing = j .gt. l
         do 120 i = 1, j
            if (sing) r(i,j) = zero
            ii = ipvt(i)
            if (ii .gt. jj) r(ii,jj) = r(i,j)
            if (ii .lt. jj) r(jj,ii) = r(i,j)
  120       continue
         wa(jj) = r(j,j)
  130    continue
c
c     symmetrize the covariance matrix in r.
c
      do 150 j = 1, n
         do 140 i = 1, j
            r(i,j) = r(j,i)
  140       continue
         r(j,j) = wa(j)
  150    continue
      return
c
c     last card of subroutine covar.
c
      end


C Given the vector from target center to surface point, compute the
C (line,sample) location of the image of the surface point in a perspective
C projection camera system.
C
      SUBROUTINE ELLIPSE_PROJ(OM,VSC,FL,OAL,OAS,SCALE,RA,RB,RC,
     &		V,rline,rsamp,ind)
      IMPLICIT NONE
      REAL*8 OM(3,3)		!Camera to planet transformation matrix
      REAL*8 VSC(3)		!Vector from target center to spacecraft (RS)
      REAL*4 FL			!Camera focal length in mm
      REAL*4 OAL,OAS		!Optical axis intercept line-sample
      REAL*4 SCALE 		!Picture scale in pixels/mm
      REAL*8 RA,RB,RC		!Target radii
      REAL*8 V(3)		!Vector from target center to surface point
      REAL*8 RLINE,RSAMP 	!Output image coordinates
      INTEGER*4 IND		! =1 if RLINE,RSAMP are valid, =0 otherwise

      REAL*8 x0,y0,z0,xc,yc,zc,S,DOT

C     ...Compute vector from camera to surface point
      xc = V(1) - VSC(1)
      yc = V(2) - VSC(2)
      zc = V(3) - VSC(3)

C     ...Compute dot product of vector with surface normal
      DOT = xc*(v(1)/ra) + yc*(v(2)/rb) + zc*(v(3)/rc)
      IF (DOT .GT. 0.) THEN	!Point is on back side of target
	IND = 0
        RETURN
      ENDIF

C     ...Rotate vector into camera coordinates
      x0 = OM(1,1)*xc + OM(1,2)*yc + OM(1,3)*zc
      y0 = OM(2,1)*xc + OM(2,2)*yc + OM(2,3)*zc
      z0 = OM(3,1)*xc + OM(3,2)*yc + OM(3,3)*zc

C     ...Scale vector into pixels
      S = FL*SCALE/z0			!pixels/km
      RLINE = S*y0 + OAL
      RSAMP = S*x0 + OAS
      IND = 1
      RETURN
      END


      REAL FUNCTION CSEDTAUS(DENBULK,TAUCO,VDRO,VDR,VDRC,IOPT,L)
      INTEGER::IOPT,L
      REAL::BULKDEN,DENBULK,TMP,TAUCO,VDRO,VDR,VDRC
C
C CHANGE RECORD
C
C#######################################################################
C  HQI ADDED, 11/18/2003, HAMRICK COMMENTED OUT SINCE NOT NEEDED FOR
C  FOR 11/24 VERSION OF IOPT= 99 THAT IS ACTIVE AS OF 01/08/2004
C#######################################################################
C **  CALCULATES CRITIAL STRESS FOR SURFACE EROSION OF COHESIVE
C **  SEDIMENT AS A FUNCTION OF BED BULK DENSITY
C **
C **  IOPT=1  BASED ON
C **  HWANG, K. N., AND A. J. MEHTA, 1989: FINE SEDIMENT ERODIBILITY
C **  IN LAKE OKEECHOBEE FLORIDA. COASTAL AND OCEANOGRAPHIC ENGINEERING
C **  DEPARTMENT, UNIVERSITY OF FLORIDA, GAINESVILLE, FL32661
C **
C **  IOPT=2  BASED ON J. M. HAMRICK'S MODIFICATION OF
C **  SANFORD, L.P., AND J. P. Y. MAA, 2001: A UNIFIED EROSION FORMULATI
C **  FOR FINE SEDIMENT, MARINE GEOLOGY, 179, 9-23.
C
      IF(IOPT.EQ.1)THEN
        BULKDEN=0.001*DENBULK  ! *** PMC Changed to prevent
        IF(BULKDEN.LE.1.065)THEN
          CSEDTAUS=1.0E-12  ! PMC Changed from 0 to prevent div by 0
        ELSE
          TMP=(BULKDEN-1.065)**0.2
          CSEDTAUS=0.001*(0.883*TMP+0.05)
        ENDIF
      ELSEIF(IOPT.EQ.2)THEN
        CSEDTAUS=TAUCO*(1.+VDRO)/(1.+VDR)
      ELSEIF(IOPT.EQ.3)THEN
        CSEDTAUS=TAUCO*(1.+VDRO)/(1.+VDRC)
      ELSEIF(IOPT.GE.99)THEN
        !#######################################################################
        !  HQI CHANGE, 08/25/03, AND 11/24/03  SO AND RM
        !  CHANGE TO IMPLEMENT CRITICAL SHEAR STRESS OPTION
        !  CSEDTAUS IS TAU/RHO WITH TAU IN DYNE/CM^2
        !  IWRSP(1) = 99 FOR SHEAR STRESS AS A FUNCTION OF BULK DENSITY FROM
        !                SED-FLUME EXPERIMENTS
        IF(L.LE.265) THEN
          CSEDTAUS=0.2/1000.
        ELSE
          CSEDTAUS=0.4/1000.
        ENDIF
      ELSE
        STOP 'CSEDTAUS: BAD SEDIMENT RESUSPENSION OPTION! STOPPING!'
      ENDIF
C
C#######################################################################
C#######################################################################
C  HQI ADDED, 11/18/2003
C  COMPUTE THE D90 OF A CELL BED FROM THE FRACTIONS OF EACH GRAIN SIZE
C  AND THE COMPUTED D50'S (I.E. THE DEFF FOR THE FOUR CLASSES.
C      SEDDIA(1)=22.0*1.E-6 !CONVERT MICRON TO METER
C      UBND = 999.
C      LBND = -999.
C 6400, 570, 160, 63 IN MICRONS
C        LBND = 0.
C        LSIZE = 0.
C  SEDPHIC ** GP-CONVERT SEDIMENT DIAMETERS IN M TO MM AND SET PHI SIZE
C      SEDDIA(1)=22.0*1.E-6 !CONVERT MICRON TO METER
C **  GP - SET MEAN PHI FOR TOP LAYER OF BED
C      RTVAR3W=0.
C      RTVAR3E=0.
C      RSIGPHI=0.
C        RTVAR3E=1.
C      ELSE
C      RSIGPHI=2.**(RSIGPHI)
C **  SET MEAN D50
C      D50SIG=0.
C      RSNDBT=0.
C       !D50SIG=D50SIG+SNDB(L,KTOP,NX)*(SEDDIA(NS))
C      !D50SIG=D50SIG+SEDB(L,KTOP,1)*(SEDDIA(1))
C      !D50SIG=D50SIG/RSNDBT
C ** COMPUTE THE D90 FROM THE STANDARD DEVIATION OF GRAIN SIZE
C    DISTRIBUTIONIN BED
C      Z90 = 1.281551  !(Z-SCORE FOR THE 90TH PERCENTILE)
C ** COHESIVE CONCENTRATION
C      COHCON= (SEDB(L,KTOP,1)*1E-6)/HBED(L,KTOP)
C      CSEDTAUS=(0.36*((D90SIG/D50SIG)**0.948803))
C        CSEDTAUS = 2./10000.
C       STOP
C#######################################################################
C
      RETURN
      END


!Runge-Kutta 4th Order!

subroutine iterate (rt)
	use params

	implicit none
	integer :: rt,BC
	complex*16, dimension(-NX/2:NX/2,-NY/2:NY/2,-NZ/2:NZ/2) :: k1,k2,k3,k4

	call rhs(GRID, k1,rt)
	call rhs(GRID + 0.5d0*DT*k1,k2,rt)
	call rhs(GRID + 0.5d0*DT*k2,k3,rt)
	call rhs(GRID + DT*k3,k4,rt)
	GRID = GRID + DT*(k1 + 2.0d0*k2 + 2.0d0*k3 + k4)/6.0d0

	if (rt == 0 .or. rtNorm) then
		if (RHSType .eq. 0) then
			call calc_norm
			GRID = GRID/sqrt(NORM)
			GRID = GRID*sqrt(DSPACE*DSPACE*DSPACE*NX*NY*NZ)
		end if
		if (RHSType .eq. 1) then
			call calc_norm
			GRID = GRID/sqrt(NORM)
		end if
	end if
	if(rt .eq. 1 .and. abs(DVDT) > 0.0d0) then
		VOB = VOB + DVDT
	end if
end subroutine
!!!!!!!!!!!!!!!!!!!!!!!

!Homogeneous Dimentionless - With Ramping!

subroutine rhs (gt, kk,rt)
	use params
	implicit none
	integer :: i,j,k,rt
	complex*16 :: ddx,ddy,ddz,laplacian
	complex*16, dimension(-NX/2:NX/2,-NY/2:NY/2,-NZ/2:NZ/2) :: gt, kk
	kk=0
!HOMG with chemical potential
	if(RHSType .eq. 0) then
		!$OMP PARALLEL DO
		do i = -NX/2,NX/2
			do j = -NY/2,NY/2
				do k = -NZ/2,NZ/2
					kk(i,j,k) = -0.5d0*laplacian(gt,i,j,k)&	!laplacian
							+gt(i,j,k)*gt(i,j,k)*CONJG(gt(i,j,k))&	!Nonlinear
					 		-gt(i,j,k)&	!Chemical Potential
							+OBJPOT(i,j,k)*gt(i,j,k)&	!Obstacle potential
							+tanh(TIME/VTVTIME)*VOB*EYE*ddx(gt,i,j,k)&!Moving frame
							+OMEGA*EYE*(i*DSPACE*ddy(gt,i,j,k)-j*DSPACE*ddx(gt,i,j,k))!Rotation
				end do
			end do
		end do
		!$OMP END PARALLEL DO
	end if
!Harmonic Dimentionless
	if(RHSType .eq. 1) then
		!$OMP PARALLEL DO
		do i = -NX/2,NX/2
			do j = -NY/2,NY/2
				do k = -NZ/2,NZ/2
				kk(i,j,k) = -0.5d0*laplacian(gt,i,j,k)&	!laplacian
						+harm_osc_C*gt(i,j,k)*gt(i,j,k)*CONJG(gt(i,j,k))&	!Nonlinear
			 			+OBJPOT(i,j,k)*gt(i,j,k)&	!potential
						- harm_osc_mu*gt(i,j,k)	!Chemical Potential
				end do
			end do
		end do
		!$OMP END PARALLEL DO
	end if
	if(DBLE(GAMMAC) > 0.0d0) then
		kk=kk/(EYE-GAMMAC)	!Damping
	else
		kk = kk/EYE !No damping
	end if
end subroutine
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

integer function BC(s,n)
	use params
	implicit none
	integer :: s,n
	BC=s
	select case (n)
    	case (0)
    		if(s.eq.NX/2+1  .and. BCX.eq.0)BC=NX/2
			if(s.eq.NX/2+1  .and. BCX.eq.1)BC=-NX/2
    		if(s.eq.-NX/2-1 .and. BCX.eq.0)BC=-NX/2
			if(s.eq.-NX/2-1 .and. BCX.eq.1)BC=NX/2
    		if(s.eq.NX/2+2  .and. BCX.eq.0)BC=NX/2-1
			if(s.eq.NX/2+2  .and. BCX.eq.1)BC=-NX/2+1
    		if(s.eq.-NX/2-2 .and. BCX.eq.0)BC=-NX/2+1
			if(s.eq.-NX/2-2 .and. BCX.eq.1)BC=NX/2-1
    	case (1)
    		if(s.eq.NY/2+1  .and. BCY.eq.0)BC=NY/2
			if(s.eq.NY/2+1  .and. BCY.eq.1)BC=-NY/2
    		if(s.eq.-NY/2-1 .and. BCY.eq.0)BC=-NY/2
			if(s.eq.-NY/2-1 .and. BCY.eq.1)BC=NY/2
			if(s.eq.NY/2+2  .and. BCY.eq.0)BC=NY/2-1
			if(s.eq.NY/2+2  .and. BCY.eq.1)BC=-NY/2+1
    		if(s.eq.-NY/2-2 .and. BCY.eq.0)BC=-NY/2+1
			if(s.eq.-NY/2-2 .and. BCY.eq.1)BC=NY/2-1
    	case (2)
    		if(s.eq.NZ/2+1  .and. BCZ.eq.0)BC=NZ/2
			if(s.eq.NZ/2+1  .and. BCZ.eq.1)BC=-NZ/2
    		if(s.eq.-NZ/2-1 .and. BCZ.eq.0)BC=-NZ/2
			if(s.eq.-NZ/2-1 .and. BCZ.eq.1)BC=NZ/2
			if(s.eq.NZ/2+2  .and. BCZ.eq.0)BC=NZ/2-1
			if(s.eq.NZ/2+2  .and. BCZ.eq.1)BC=-NZ/2+1
    		if(s.eq.-NZ/2-2 .and. BCZ.eq.0)BC=-NZ/2+1
			if(s.eq.-NZ/2-2 .and. BCZ.eq.1)BC=NZ/2-1
	end select
end function
!!!!!!!!!!!!!!!!!!!!!!!!!!

COMPLEX*16 function laplacian(gt,i,j,k)
	use params
	implicit none
	integer :: i,j,k,BC
	complex*16, dimension(-NX/2:NX/2,-NY/2:NY/2,-NZ/2:NZ/2) :: gt

	laplacian = (-6.0d0*gt(i,j,k)+ gt(BC(i,0),BC(j+1,1),BC(k,2))&
					+gt(BC(i,0),BC(j-1,1),BC(k,2))+gt(BC(i+1,0),BC(j,1),BC(k,2))&
					+gt(BC(i-1,0),BC(j,1),BC(k,2))+gt(BC(i,0),BC(j,1),BC(k-1,2))&
					+gt(BC(i,0),BC(j,1),BC(k+1,2)))/(DSPACE**2.0d0)
end function

COMPLEX*16 function ddx(gt,i,j,k)
	use params
	implicit none
	integer :: i,j,k,BC
	complex*16, dimension(-NX/2:NX/2,-NY/2:NY/2,-NZ/2:NZ/2) :: gt

	ddx = ((1.0d0/12.0d0)*gt(BC(i-2,0),j,k)-(2.0d0/3.0d0)*gt(BC(i-1,0),j,k)&
					+ (2.0d0/3.0d0)*gt(BC(i+1,0),j,k)-(1.0d0/12.0d0)*gt(BC(i+2,0),j,k))/DSPACE
end function

COMPLEX*16 function ddy(gt,i,j,k)
	use params
	implicit none
	integer :: BC,i,j,k
	complex*16, dimension(-NX/2:NX/2,-NY/2:NY/2,-NZ/2:NZ/2) :: gt
	ddy = ((1.0d0/12.0d0)*gt(i,BC(j-2,1),k)-(2.0d0/3.0d0)*gt(i,BC(j-1,1),k)&
					+ (2.0d0/3.0d0)*gt(i,BC(j+1,1),k)-(1.0d0/12.0d0)*gt(i,BC(j+2,1),k))/DSPACE
end function

COMPLEX*16 function ddz(gt,i,j,k)
	use params
	implicit none
	complex*16, dimension(-NX/2:NX/2,-NY/2:NY/2,-NZ/2:NZ/2) :: gt
	integer :: BC,i,j,k
	ddz = ((1.0d0/12.0d0)*gt(i,j,BC(k-2,2))-(2.0d0/3.0d0)*gt(i,j,BC(k-1,2))&
					+ (2.0d0/3.0d0)*gt(i,j,BC(k+1,2))-(1.0d0/12.0d0)*gt(i,j,BC(k+2,2)))/DSPACE
end function


program circlearea
    real r, area, pi
    parameter (pi = 3.14159)
!    This program computes the area of a circle.
    print *, "What is the radius?"
    read *, r
    area = pi * r ** 2
    print *, "The area is", area
    print *, "Bye!"
    end program circlearea


    subroutine oceanic_T(time)
!   +++++++++++++++++++++++++++++++
    use constante, only: PI_n_CO2_atm
    use co2_interpolation, only: find_co2_interval
    implicit none
    include 'combine_foam.inc'
    double precision:: xi

    ! Note: temp_box(nbasin) is the GMST (Global Mean Surface Temperature)

    if (nclimber==1) then ! fixed CO2 mode

        temp_box = Toceclimber(:,1)

    else ! CO2 interpolation

        p=var(12,nbasin)/PI_n_CO2_atm

        call find_co2_interval(co2climber, p, k1, k2, xi)
        temp_box  =  (1-xi) * Toceclimber(:,k1)  +  xi * Toceclimber(:,k2)

    end if

    end


module triangular_channel

    use define_settings, only: setting
    use define_globals
    use define_indexes
    use define_keys

    implicit none

    !%-----------------------------------------------------------------------------
    !% Description:
    !% triangular channel geometry
    !%

    private

    public :: triangular_depth_from_volume
    public :: triangular_area_from_depth
    public :: triangular_area_from_depth_singular
    public :: triangular_topwidth_from_depth
    public :: triangular_topwidth_from_depth_singular
    public :: triangular_perimeter_from_depth
    public :: triangular_perimeter_from_depth_singular
    public :: triangular_hyddepth_from_depth
    public :: triangular_hyddepth_from_depth_singular
    public :: triangular_hydradius_from_depth_singular

    contains

!%==========================================================================
!% PUBLIC
!%==========================================================================
!%
    subroutine triangular_depth_from_volume (elemPGx, Npack, thisCol)
        !%-----------------------------------------------------------------------------
        !% Description:
        !% Only applies on open channels (or non-surcharged triangular conduits)
        !% Input elemPGx is pointer (already assigned) for elemPGalltm, elemPGetm or elemPGac
        !% Assumes that volume > 0 is enforced in volume computations.
        !% NOTE: this does NOT limit the depth by surcharge height at this point
        !% This will be done after the head is computed.
        !%-----------------------------------------------------------------------------
        integer, target, intent(in) :: elemPGx(:,:), Npack, thisCol
        integer, pointer :: thisP(:)
        real(8), pointer :: depth(:), volume(:), length(:), breadth(:), sideslope(:)
        !%-----------------------------------------------------------------------------
        thisP   => elemPGx(1:Npack,thisCol)
        depth   => elemR(:,er_Depth)
        volume  => elemR(:,er_Volume)
        length  => elemR(:,er_Length)
        breadth => elemSGR(:,esgr_Triangular_TopBreadth)
        sideslope => elemSGR(:,esgr_Triangular_Slope)
        !%-----------------------------------------------------------------------------

        depth(thisP) = sqrt((volume(thisP)/length(thisP)) / sideslope(thisP))

    end subroutine triangular_depth_from_volume
    !%
!%==========================================================================
!%==========================================================================
!%
    elemental real(8) function triangular_area_from_depth (indx) result (outvalue)
        !%-----------------------------------------------------------------------------
        !% Description:
        !% Computes area from known depth for triangular cross section
        !%-----------------------------------------------------------------------------
        integer, intent(in) :: indx  ! may be a packed array of indexes
        !%-----------------------------------------------------------------------------
        outvalue = elemSGR(indx,esgr_Triangular_Slope) * (elemR(indx,er_Depth) ** twoR)

    end function triangular_area_from_depth
!%
!%==========================================================================
!%==========================================================================
!%
    real(8) function triangular_area_from_depth_singular (indx) result (outvalue)
        !%-----------------------------------------------------------------------------
        !% Description:
        !% Computes area from known depth for triangular cross section of a single element
        !% The input indx is the row index in full data 2D array.
        !%-----------------------------------------------------------------------------
        integer, intent(in) :: indx
        real(8), pointer :: depth(:), breadth(:), sideslope(:)
        !%-----------------------------------------------------------------------------
        depth   => elemR(:,er_Depth)
        sideslope => elemSGR(:,esgr_Triangular_Slope)
        breadth => elemSGR(:,esgr_Triangular_TopBreadth)
        !%-----------------------------------------------------------------------------
        outvalue = sideslope(indx) * (depth(indx) ** twoR)

    end function triangular_area_from_depth_singular
!%
!%==========================================================================
!%==========================================================================
!%
    subroutine triangular_topwidth_from_depth (elemPGx, Npack, thisCol)
        !%
        !%-----------------------------------------------------------------------------
        !% Description:
        !% Computes the topwidth from a known depth in a triangular channel
        !%-----------------------------------------------------------------------------
        integer, target, intent(in) :: elemPGx(:,:)
        integer, intent(in) ::  Npack, thisCol
        integer, pointer :: thisP(:)
        real(8), pointer :: breadth(:), topwidth(:), sideslope(:), depth(:)
        !%-----------------------------------------------------------------------------
        thisP    => elemPGx(1:Npack,thisCol)
        topwidth => elemR(:,er_Topwidth)
        sideslope => elemSGR(:,esgr_Triangular_Slope)
        depth    => elemR(:,er_Depth)
        !%-----------------------------------------------------------------------------

        topwidth(thisP) = twoR * sideslope(thisP) * depth(thisP)

    end subroutine triangular_topwidth_from_depth
!%
!%==========================================================================
!%==========================================================================
!%
    real(8) function triangular_topwidth_from_depth_singular (indx) result (outvalue)
        !%-----------------------------------------------------------------------------
        !% Description:
        !% Computes the topwidth for a triangular cross section of a single element
        !%-----------------------------------------------------------------------------
        integer, intent(in) :: indx
        real(8), pointer :: depth(:), sideslope(:)
        !%-----------------------------------------------------------------------------
        depth   => elemR(:,er_Depth)
        sideslope => elemSGR(:,esgr_Triangular_Slope)
        !%-----------------------------------------------------------------------------
        !%
        outvalue = twoR * sideslope(indx) * depth(indx)

    end function triangular_topwidth_from_depth_singular
!%
!%==========================================================================
!%==========================================================================
!%
    subroutine triangular_perimeter_from_depth (elemPGx, Npack, thisCol)
        !%
        !%-----------------------------------------------------------------------------
        !% Description:
        !% Computes the perimeter from a known depth in a triangular channel
        !%-----------------------------------------------------------------------------
        integer, target, intent(in) :: elemPGx(:,:)
        integer, intent(in) ::  Npack, thisCol
        integer, pointer :: thisP(:)
        real(8), pointer :: breadth(:), depth(:), perimeter(:)
        !%-----------------------------------------------------------------------------
        thisP     => elemPGx(1:Npack,thisCol)
        breadth   => elemSGR(:,esgr_Triangular_TopBreadth)
        depth     => elemR(:,er_Depth)
        perimeter => elemR(:,er_Perimeter)
        !%-----------------------------------------------------------------------------

        perimeter(thisP) = twoR * sqrt(((breadth(thisP) ** twoR) / fourR) + (depth(thisP) ** twoR))

    end subroutine triangular_perimeter_from_depth
!%
!%==========================================================================
!%==========================================================================
!%
    real(8) function triangular_perimeter_from_depth_singular (indx) result (outvalue)
        !%
        !%-----------------------------------------------------------------------------
        !% Description:
        !% Computes wetted perimeter from known depth for a triangular cross section of
        !% a single element
        !%-----------------------------------------------------------------------------
        !%-----------------------------------------------------------------------------
        integer, intent(in) :: indx
        real(8), pointer :: depth(:), breadth(:)
        !%-----------------------------------------------------------------------------
        depth   => elemR(:,er_Depth)
        breadth => elemSGR(:,esgr_Triangular_TopBreadth)
        !%-----------------------------------------------------------------------------

        outvalue = twoR * sqrt(((breadth(indx) ** twoR) / fourR) + (depth(indx) ** twoR))

    end function triangular_perimeter_from_depth_singular
!%
!%==========================================================================
!%==========================================================================
!%
    subroutine triangular_hyddepth_from_depth (elemPGx, Npack, thisCol)
        !%
        !%-----------------------------------------------------------------------------
        !% Description:
        !% Computes the hydraulic (average) depth from a known depth in a triangular channel
        !%-----------------------------------------------------------------------------
        integer, target, intent(in) :: elemPGx(:,:)
        integer, intent(in) ::  Npack, thisCol
        integer, pointer :: thisP(:)
        real(8), pointer :: hyddepth(:), depth(:)
        !%-----------------------------------------------------------------------------
        thisP     => elemPGx(1:Npack,thisCol)
        depth     => elemR(:,er_Depth)
        hyddepth  => elemR(:,er_HydDepth)
        !%-----------------------------------------------------------------------------

        hyddepth(thisP) = depth(thisP) / twoR

    end subroutine triangular_hyddepth_from_depth
!%
!%==========================================================================
!%==========================================================================
!%
    real(8) function triangular_hyddepth_from_depth_singular (indx) result (outvalue)
        !%
        !%-----------------------------------------------------------------------------
        !% Description:
        !% Computes hydraulic depth from known depth for triangular cross section of
        !% a single element
        !%-----------------------------------------------------------------------------
        integer, intent(in) :: indx
        !%-----------------------------------------------------------------------------

        outvalue = elemR(indx,er_Depth) / twoR

    end function triangular_hyddepth_from_depth_singular
!%
!%==========================================================================
!%==========================================================================
!%
    real(8) function triangular_hydradius_from_depth_singular (indx) result (outvalue)
        !%
        !%-----------------------------------------------------------------------------
        !% Description:
        !% Computes hydraulic radius from known depth for a triangular cross section of
        !% a single element
        !%-----------------------------------------------------------------------------
        integer, intent(in) :: indx
        real(8), pointer :: depth(:), breadth(:), sideslope(:)
        !%-----------------------------------------------------------------------------
        depth   => elemR(:,er_Depth)
        sideslope => elemSGR(:,esgr_Triangular_Slope)
        breadth => elemSGR(:,esgr_Triangular_TopBreadth)
        !%-----------------------------------------------------------------------------

        outvalue = (sideslope(indx) * depth(indx)) / (twoR * sqrt(oneR + sideslope(indx) ** twoR))

    end function triangular_hydradius_from_depth_singular
    !%
!%==========================================================================

end module triangular_channel


      subroutine setupmom(p)
      implicit none
      include 'constants.f'
      include 'masses.f'
      double precision al,be,ro,si,th,ph,p(mxpart,4),E1,E2,E7,y

C----setup p
      al=1.04225677d0
      be=0.5564225677d0
      ro=0.86454322d0
      si=1.04225677d0
      th=0.63425677d0
      ph=0.145563425677d0
      zmass=91.188d0
      p(:,:)=0d0

      E1=343.43678d0
      E2=436.68843678d0
      y=0.5d0*(1d0+cos(th))
      E7=-(zmass**2-zmass*E1-zmass*E2+E1*E2)/(zmass-E1*y-E2*(1d0-y))

      p(1,4)=-E1
      p(1,1)=0d0
      p(1,2)=0d0
      p(1,3)=+E1

      p(2,4)=-E2
      p(2,1)=0d0
      p(2,2)=0d0
      p(2,3)=-E2

      p(3,4)=+0.5d0*zmass
      p(3,1)=+0.5d0*zmass*sin(al)*cos(ro)
      p(3,2)=+0.5d0*zmass*sin(al)*sin(ro)
      p(3,3)=+0.5d0*zmass*cos(al)

      p(4,4)=+0.5d0*zmass
      p(4,1)=-0.5d0*zmass*sin(al)*cos(ro)
      p(4,2)=-0.5d0*zmass*sin(al)*sin(ro)
      p(4,3)=-0.5d0*zmass*cos(al)

      p(5,4)=+0.5d0*zmass
      p(5,1)=+0.5d0*zmass*sin(be)*cos(si)
      p(5,2)=+0.5d0*zmass*sin(be)*sin(si)
      p(5,3)=+0.5d0*zmass*cos(be)

      p(6,4)=+0.5d0*zmass
      p(6,1)=-0.5d0*zmass*sin(be)*cos(si)
      p(6,2)=-0.5d0*zmass*sin(be)*sin(si)
      p(6,3)=-0.5d0*zmass*cos(be)

      p(7,4)=E7
      p(7,1)=E7*sin(th)*sin(ph)
      p(7,2)=E7*sin(th)*cos(ph)
      p(7,3)=E7*cos(th)

      p(8,:)=-p(1,:)-p(2,:)-p(3,:)-p(4,:)-p(5,:)-p(6,:)-p(7,:)

      return
      end


cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c Copyright 2001, 2002, 2003, 2004, 2005, 2006, 2007, Washington University,
c Mallinckrodt Institute of Radiology. All Rights Reserved.
c This software may not be reproduced, copied, or distributed without written
c permission of Washington University. For further information contact A. Z. Snyder.
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c $Header: /data/petsun4/data1/src_solaris/gauss_4dfp/RCS/hsphere3d.f,v 1.2 2007/04/17 05:25:58 avi Exp $
c $Log: hsphere3d.f,v $
c Revision 1.2  2007/04/17  05:25:58  avi
c gcc compliant
c
c Revision 1.1  2001/07/11  04:22:13  avi
c Initial revision
c
      subroutine hsphere3d(image,nx,ny,nz,mmppix,radius)
c     frequencey domain filter for hard sphere kernel
c     modified gauss3d.f
c     Author: Avi Snyder 09/Jul/01
c     analyztic expresion for factor derived with help of D. Yablonskiy
c
c     inputs: real*4 image(nx,ny,nz)	! image to be filtered
c             real*4 mmppix(3)		! x, y, z voxel dimensions in mm
c             real*4 radius		! hard shpere radius in mm
c
c     variables modified: image         ! input image overwritten
c
c     subroutines called:  FFT, REALT in FORTRAN source fftsun.f
c                          FFT algorithm by Richard C. Singleton via FFTPE.FTN
c
c     restrictions: mixed radix FFT accepts any nx, ny, nz but
c                   nx must be divisible by 2
c                   memory allocation requirement 8*(nx/2+1)*ny*nz bytes

      real*4 image(nx,ny,nz)
      real*4 mmppix(3)
      pointer (pa,a),(pb,b)
      real*4 a((nx/2+1)*ny*nz),b((nx/2+1)*ny*nz)

      if(mod(nx,2).ne.0)then
        write(*,"('hsphere3d: nx=',i4,' not divisible by 2')")nx
        call exit(-1)
      endif
      twopi=8.0*atan(1.)
      pa=malloc(4*(nx/2+1)*ny*nz)
      pb=malloc(4*(nx/2+1)*ny*nz)

      i=1
      do 21 iz=1,nz
      do 21 iy=1,ny
      do 21 ix=1,nx,2
      a(i)=image(ix,iy,iz)
      b(i)=image(ix+1,iy,iz)
   21 i=i+1

      n1=nx/2
      n=n1*ny*nz
      call FFT(a,b,ny*nz,n1,1,-1)
      call REALT(a,b,ny*nz,n1,1,-1)
      call FFT(a(n+1),b(n+1),nz,ny,1,-1)
      call FFT(a(n+1),b(n+1),1,nz,ny,-1)
      call FFT(a,b,nz,ny,n1,-1)
      call FFT(a,b,1,nz,n1*ny,-1)

      i=1
      do 31 iz=1,nz
      if(iz.le.nz/2+1)then
        fz=float(iz-1)/(float(nz)*mmppix(3))
      else
        fz=float(nz-iz+1)/(float(nz)*mmppix(3))
      endif
      do 31 iy=1,ny
      if(iy.le.ny/2+1)then
        fy=float(iy-1)/(float(ny)*mmppix(2))
      else
        fy=float(ny-iy+1)/(float(ny)*mmppix(2))
      endif
      do 31 ix=1,n1
      fx=float(ix-1)/(float(nx)*mmppix(1))
      f=sqrt(fx**2+fy**2+fz**2)
      if(f.eq.0.0)then
        factor=1.0
      else
        theta=twopi*f*radius
        factor=3.0*(sin(theta)-theta*cos(theta))/theta**3
      endif
      a(i)=factor*a(i)
      b(i)=factor*b(i)
   31 i=i+1
      fx=0.5/mmppix(1)
      do 32 iz=1,nz
      if(iz.le.nz/2+1)then
        fz=float(iz-1)/(float(nz)*mmppix(3))
      else
        fz=float(nz-iz+1)/(float(nz)*mmppix(3))
      endif
      do 32 iy=1,ny
      if(iy.le.ny/2+1)then
        fy=float(iy-1)/(float(ny)*mmppix(2))
      else
        fy=float(ny-iy+1)/(float(ny)*mmppix(2))
      endif
      f=sqrt(fx**2+fy**2+fz**2)
      theta=twopi*f*radius
      factor=3.0*(sin(theta)-theta*cos(theta))/theta**3
      a(i)=factor*a(i)
      b(i)=factor*b(i)
   32 i=i+1

      call FFT(a,b,1,nz,n1*ny,+1)
      call FFT(a,b,nz,ny,n1,+1)
      call FFT(a(n+1),b(n+1),1,nz,ny,+1)
      call FFT(a(n+1),b(n+1),nz,ny,1,+1)
      call REALT(a,b,ny*nz,n1,1,+1)
      call FFT(a,b,ny*nz,n1,1,+1)

      i=1
      do 29 iz=1,nz
      do 29 iy=1,ny
      do 29 ix=1,nx,2
      image(ix,iy,iz)=a(i)
      image(ix+1,iy,iz)=b(i)
   29 i=i+1

      call free(pa)
      call free(pb)
      return
      end


! =========================================================
subroutine rp1(maxmx,meqn,mwaves,maux,mbc,mx,ql,qr,auxl,auxr,fwave,s,amdq,apdq)
! =========================================================

! Solve Riemann problems for the 1D shallow water equations
! with topography source terms
!   (h)_t + (u h)_x = 0
!   (uh)_t + ( uuh + .5*gh^2 )_x = -ghB_x
! using Roe's approximate Riemann solver and the f-wave formulation
! to incorporate source terms

! fwaves: 2
! equations: 2

! Conserved quantities:
!       1 depth
!       2 momentum

! Auxiliary arrays:
!       1 topography/bathymetry B

! This function solves the Riemann problem at all interfaces in one call

! On input, ql contains the state vector at the left edge of each cell
!           qr contains the state vector at the right edge of each cell
! On output, fwave contains the fwaves,
!            s the speeds,
!            amdq the  left-going flux difference  A^- \Delta q
!            apdq the right-going flux difference  A^+ \Delta q

! Note that the i'th Riemann problem has left state qr(:,i-1)
!                                    and right state ql(:,i)
! From the basic clawpack routine step1, rp is called with ql = qr = q.

    implicit double precision (a-h,o-z)

    dimension   ql(meqn,           1-mbc:maxmx+mbc)
    dimension   qr(meqn,           1-mbc:maxmx+mbc)
    dimension    s(mwaves,         1-mbc:maxmx+mbc)
    dimension fwave(meqn,  mwaves, 1-mbc:maxmx+mbc)
    dimension amdq(meqn,           1-mbc:maxmx+mbc)
    dimension apdq(meqn,           1-mbc:maxmx+mbc)
    dimension auxl(maux,           1-mbc:maxmx+mbc)
    dimension auxr(maux,           1-mbc:maxmx+mbc)

!     # Gravity constant set in the setprob.f
    common /cparam/ grav

!     # Local storage
!     ---------------
    dimension delta(2)

!     # Main loop of the Riemann solver.
    do 30 i=2-mbc,mx+mbc

    !     # compute  Roe-averaged quantities:
        ubar = (qr(2,i-1)/dsqrt(qr(1,i-1)) + ql(2,i)/dsqrt(ql(1,i)))/ &
        ( dsqrt(qr(1,i-1)) + dsqrt(ql(1,i)) )
        cbar=dsqrt(0.5d0*grav*(qr(1,i-1) + ql(1,i)))

    !     # jump in topography:

    !     # delta = flux difference + source
        delta(1) = ql(2,i) - qr(2,i-1)
        df = (ql(2,i)**2/ql(1,i) + 0.5d0*grav*ql(1,i)**2) - &
             (qr(2,i-1)**2/qr(1,i-1) + 0.5d0*grav*qr(1,i-1)**2)
        dB = auxl(1,i) - auxr(1,i-1)
        delta(2) = df + 0.5d0*grav*(ql(1,i)+qr(1,i-1))*dB

    !     # Compute coeffs in the evector expansion of delta(1),delta(2)
        a1 = 0.5d0*(-delta(2) + (ubar + cbar) * delta(1))/cbar
        a2 = 0.5d0*( delta(2) - (ubar - cbar) * delta(1))/cbar

    !     # Finally, compute the waves.
        fwave(1,1,i) = a1
        fwave(2,1,i) = a1*(ubar - cbar)
        s(1,i) = ubar - cbar

        fwave(1,2,i) = a2
        fwave(2,2,i) = a2*(ubar + cbar)
        s(2,i) = ubar + cbar

    30 END DO

!     # No entropy fix
!     ----------------------------------------------
!     # amdq = SUM fwave   over left-going waves
!     # apdq = SUM fwave   over right-going waves

    do 100 m=1,2
        do 100 i=2-mbc, mx+mbc
            amdq(m,i) = 0.d0
            apdq(m,i) = 0.d0
            do 90 mw=1,mwaves
                if (s(mw,i) < 0.d0) then
                    amdq(m,i) = amdq(m,i) + fwave(m,mw,i)
                else
                    apdq(m,i) = apdq(m,i) + fwave(m,mw,i)
                endif
            90 END DO
    100 END DO

!    -----------------------------------------------
    return
    end subroutine rp1


      subroutine fpcoco(iopt,m,x,y,w,v,s,nest,maxtr,maxbin,n,t,c,sq,sx,
     * bind,e,wrk,lwrk,iwrk,kwrk,ier)
c  ..scalar arguments..
      real s,sq
      integer iopt,m,nest,maxtr,maxbin,n,lwrk,kwrk,ier
c  ..array arguments..
      integer iwrk(kwrk)
      real x(m),y(m),w(m),v(m),t(nest),c(nest),sx(m),e(nest),wrk(lwrk)
      logical bind(nest)
c  ..local scalars..
      integer i,ia,ib,ic,iq,iu,iz,izz,i1,j,k,l,l1,m1,nmax,nr,n4,n6,n8,
     * ji,jib,jjb,jl,jr,ju,mb,nm
      real sql,sqmax,term,tj,xi,half
c  ..subroutine references..
c    fpcosp,fpbspl,fpadno,fpdeno,fpseno,fpfrno
c  ..
c  set constant
      half = 0.5e0
c  determine the maximal admissible number of knots.
      nmax = m+4
c  the initial choice of knots depends on the value of iopt.
c    if iopt=0 the program starts with the minimal number of knots
c    so that can be guarantied that the concavity/convexity constraints
c    will be satisfied.
c    if iopt = 1 the program will continue from the point on where she
c    left at the foregoing call.
      if(iopt.gt.0) go to 80
c  find the minimal number of knots.
c  a knot is located at the data point x(i), i=2,3,...m-1 if
c    1) v(i) ^= 0    and
c    2) v(i)*v(i-1) <= 0  or  v(i)*v(i+1) <= 0.
      m1 = m-1
      n = 4
      do 20 i=2,m1
        if(v(i).eq.0. .or. (v(i)*v(i-1).gt.0. .and.
     *  v(i)*v(i+1).gt.0.)) go to 20
        n = n+1
c  test whether the required storage space exceeds the available one.
        if(n+4.gt.nest) go to 200
        t(n) = x(i)
  20  continue
c  find the position of the knots t(1),...t(4) and t(n-3),...t(n) which
c  are needed for the b-spline representation of s(x).
      do 30 i=1,4
        t(i) = x(1)
        n = n+1
        t(n) = x(m)
  30  continue
c  test whether the minimum number of knots exceeds the maximum number.
      if(n.gt.nmax) go to 210
c  main loop for the different sets of knots.
c  find corresponding values e(j) to the knots t(j+3),j=1,2,...n-6
c    e(j) will take the value -1,1, or 0 according to the requirement
c    that s(x) must be locally convex or concave at t(j+3) or that the
c    sign of s''(x) is unrestricted at that point.
  40  i= 1
      xi = x(1)
      j = 4
      tj = t(4)
      n6 = n-6
      do 70 l=1,n6
  50    if(xi.eq.tj) go to 60
        i = i+1
        xi = x(i)
        go to 50
  60    e(l) = v(i)
        j = j+1
        tj = t(j)
  70  continue
c  we partition the working space
      nm = n+maxbin
      mb = maxbin+1
      ia = 1
      ib = ia+4*n
      ic = ib+nm*maxbin
      iz = ic+n
      izz = iz+n
      iu = izz+n
      iq = iu+maxbin
      ji = 1
      ju = ji+maxtr
      jl = ju+maxtr
      jr = jl+maxtr
      jjb = jr+maxtr
      jib = jjb+mb
c  given the set of knots t(j),j=1,2,...n, find the least-squares cubic
c  spline which satisfies the imposed concavity/convexity constraints.
      call fpcosp(m,x,y,w,n,t,e,maxtr,maxbin,c,sq,sx,bind,nm,mb,wrk(ia),
     * wrk(ib),wrk(ic),wrk(iz),wrk(izz),wrk(iu),wrk(iq),iwrk(ji),
     * iwrk(ju),iwrk(jl),iwrk(jr),iwrk(jjb),iwrk(jib),ier)
c  if sq <= s or in case of abnormal exit from fpcosp, control is
c  repassed to the driver program.
      if(sq.le.s .or. ier.gt.0) go to 300
c  calculate for each knot interval t(l-1) <= xi <= t(l) the
c  sum((wi*(yi-s(xi)))**2).
c  find the interval t(k-1) <= x <= t(k) for which this sum is maximal
c  on the condition that this interval contains at least one interior
c  data point x(nr) and that s(x) is not given there by a straight line.
  80  sqmax = 0.
      sql = 0.
      l = 5
      nr = 0
      i1 = 1
      n4 = n-4
      do 110 i=1,m
        term = (w(i)*(sx(i)-y(i)))**2
        if(x(i).lt.t(l) .or. l.gt.n4) go to 100
        term = term*half
        sql = sql+term
        if(i-i1.le.1 .or. (bind(l-4).and.bind(l-3))) go to 90
        if(sql.le.sqmax) go to 90
        k = l
        sqmax = sql
        nr = i1+(i-i1)/2
  90    l = l+1
        i1 = i
        sql = 0.
 100    sql = sql+term
 110  continue
      if(m-i1.le.1 .or. (bind(l-4).and.bind(l-3))) go to 120
      if(sql.le.sqmax) go to 120
      k = l
      nr = i1+(m-i1)/2
c  if no such interval is found, control is repassed to the driver
c  program (ier = -1).
 120  if(nr.eq.0) go to 190
c  if s(x) is given by the same straight line in two succeeding knot
c  intervals t(l-1) <= x <= t(l) and t(l) <= x <= t(l+1),delete t(l)
      n8 = n-8
      l1 = 0
      if(n8.le.0) go to 150
      do 140 i=1,n8
        if(.not. (bind(i).and.bind(i+1).and.bind(i+2))) go to 140
        l = i+4-l1
        if(k.gt.l) k = k-1
        n = n-1
        l1 = l1+1
        do 130 j=l,n
          t(j) = t(j+1)
 130    continue
 140  continue
c  test whether we cannot further increase the number of knots.
 150  if(n.eq.nmax) go to 180
      if(n.eq.nest) go to 170
c  locate an additional knot at the point x(nr).
      j = n
      do 160 i=k,n
        t(j+1) = t(j)
        j = j-1
 160  continue
      t(k) = x(nr)
      n = n+1
c  restart the computations with the new set of knots.
      go to 40
c  error codes and messages.
 170  ier = -3
      go to 300
 180  ier = -2
      go to 300
 190  ier = -1
      go to 300
 200  ier = 4
      go to 300
 210  ier = 5
 300  return
      end


      SUBROUTINE AGC(BUFIN,BUFOUT,SCRBUF,SPEC)
!     AGC CALCULATES AND APPLIES AGC (AUTOMATIC GAIN CONTROL) TO AN ARRAY OF REAL
! VALUES (A SEISMIC TRACE).  AGC IS A TYPE OF SCALING SUCH THAT THE AVERAGE
! ABSOLUTE VALUE OF THE AMPLITUDES WITHIN A WINDOW WILL BE A CERTAIN LEVEL
! AFTER SCALING.
!     THIS AGC PROGRAM DIFFERS FROM OTHER AGCS IN THE WAY IT HANDLES ZERO (OR
! NEAR ZERO) INPUT AMPLITUDES.  IF THE WINDOW CONTAINS TOO MANY ZEROES, THE
! CALCULATED MULTIPLIER FOR THAT WINDOW IS IGNORED AND THE LAST ONE IS USED.
! E.G. IN THE CASE OF MUTES PRIOR TO P-BREAKS, THE FIRST MULTIPLIER WILL BE
! CALULATED FROM SAY 75 PERCENT LIVE VALUES, THUS PREVENTING THE P-BREAKS FROM
! BEING OVERDRIVEN.
!     ANY TRACE WITH ALL AMPLITIDES BELOW A CERTAIN LEVEL (DEAD) WILL BE SET TO
! ZERO.
!
!   AGC VARIABLES:
!   ARGUMENTS:
!   BUFIN  - THE INPUT ARRAY (REAL)
!   BUFOUT -  THE OUTPUT ARRAY (REAL) - THE INPUT AND OUTPUT ARRAYS MAY BE THE
!             SAME.
!   SCRBUF  - A SCRATCH ARRAY (REAL) - MUST BE INDXET LONG
!    SPEC   - SPECIAL CASE SWITCH
!           <0, PRINT THE AVERAGE ABSOLUTE VALUE FOR EACH WINDOW
!           =0, DO NOTHING SPECIAL
! COMMON VARIABLE:
!   INDXST  - THE INDX OF THE FIRST SAMPLE IN BUFIN TO PROCESS.  BUFOUT WILL
!             HAVE UNTOUCHED DATA VALUES PRIOR TO INDXST.  THIS PARAMETER CAN BE
!             NON-ZERO IN ORDER TO AVOID SCALING THE WATER LAYER (SAY CPU TIME).
!             THIS SHOULD BE 1 IN MOST CASES.
!   INDXET - THE INDEX OF BUFIN OF THE LAST SAMPLE TO PROCESS.  THE NUMBER OF
!            SAMPLES IN THE ARRAY (WHEN INDXET IS 1).
!   OLEVEL - THE OUTPUT AMPLITUDE LEVEL.  THE AVERAGE ABSOLUTE VALUE.
!   CLIP   - THE CLIP LEVEL.  ANY AMPLITUDE (ABS VALUE) EXCEEDING THE CLIP
!            VALUE WILL BE SET TO CLIP.
!   NPTS   - THE NUMBER OF SAMPLES IN EACH WINDOW( THE WINDOW LENGTH IN SAMPLES)
!            REMEMBER THAT THE WINDOW IS SLIDE (ADVANCED) BY ONE SAMPLE
!   NDEAD  - THE NUMBER OF DEAD VALUES TO ALLOW IN A WINDOW IN ORDER TO GET A
!            NEW WINDOW MULTIPLIER.
!   DEAD   - A LEVEL BELOW WHICH AN AMPLITUDE IS CONSIDERED DEAD.
!   MIDPT  - THE MID POINT OF THE WINDOW TO RECEIVE THE MULTIPLIER FOR THE WINDOW
!            A FORWARD LOOKING WINDOW WOULD HAVE MIDPT=1
!   agcpct - The percent AGC, expressed as percent/100.  agcpct
!            multiplies the multiplier.  An agcpct < 1 has the
!            effect of lessening the AGC (makes it "softer").
!
!
!    PAUL HENKART, SCRIPPS INSTITUTION OF OCEANOGRAPHY, JANUARY 1979
!  mod 13 April 1991 by pch - add agcpct
!  mod June 96 by s.s - change the way agcpct works
!
      COMMON /AGCCOM/ INDXST,INDXET,OLEVEL,CLIP,NPTS,NDEAD,DEAD,MIDPT,
     &     agcpct
      DIMENSION BUFIN(1),BUFOUT(1),SCRBUF(1)
      LOGICAL FIRST
      double precision agctot, agcmean
      FIRST=.TRUE.
      NZEROS=0
      SUM=0.
      NDONE=0
!****
!****       PUT THE ABSOLUTE VALUES INTO SCRBUF
!****
      DO 100 I = 1, INDXET
      SCRBUF(I)=ABS(BUFIN(I))
  100 CONTINUE
!  S.S  percent agc change.  First, find the average absolute value of nonzero
!    samples for the entire trace
      if( agcpct .ne. 1.) then
        agctot = 0
        nnonzero = 0
        do 110 i=1,indxet
          if(scrbuf(i) .ne. 0.) then
            agctot = agctot + abs(scrbuf(i))
            nnonzero = nnonzero + 1
          endif
110     continue
        agcmean = agctot / nnonzero
!        write (*,*) 'agcmean ',agcmean,' agcpct',agcpct
      endif
!****
!****            FIND THE FIRST WINDOW WITH A GOOD MULTIPLIER
!****
      INDX=INDXST-1
      DO 190 I = 1, NPTS                                                !  DO THE FIRST WINDOW
         J = INDX + I
         IF( SCRBUF(J) .GT. DEAD ) THEN
             SUM = SUM + SCRBUF(J)
         ELSE
             NZEROS = NZEROS + 1
         ENDIF
  190 CONTINUE
  200 CONTINUE
      NDONE = NDONE + 1
      IF(NZEROS.LT.NDEAD) GO TO 300
      J=INDXST+NDONE-1
      K = J + NPTS
      IF(K.GT.INDXET) GO TO 250
      IF( SCRBUF(J).LE.DEAD) THEN
          NZEROS = NZEROS - 1
          IF( nzeros .LT. 0 ) nzeros = 0
      ELSE
          SUM = SUM - SCRBUF(J)
      ENDIF
      IF( SCRBUF(K) .LE. DEAD ) THEN
          NZEROS = NZEROS + 1
          IF( nzeros .GT. npts ) nzeros = npts
      ELSE
          SUM = SUM + SCRBUF(K)
      ENDIF
      GO TO 200
!****
!****           THE TRACE IS DEAD HERE
!****
  250 CONTINUE
      DO I = 1, INDXET                                              ! MOVE THE INPUT WITHOUT CHANGING THE AMPLITUDES
         BUFOUT(I)=BUFIN(I)
      ENDDO
      PRINT 270
  270 FORMAT(' ***  WARNING  ***  NOT ENOUGH NON-ZERO VALUES IN ORDER',
     *   ' TO AGC, NO AGC APPLIED.')
      RETURN
!****
!****
  300 CONTINUE
      TEMP=FLOAT(NPTS-NZEROS)                                           ! CHECK FOR NUMBER SIZE
      IF( TEMP .LE. 0. ) THEN
          AVE = CLIP
      ELSE
          AVE = SUM / TEMP
      ENDIF
      IF(AVE.EQ.0.) AVE=.00000001
      IF( SPEC .LT. 0 ) PRINT *,' ave=',ave,' ndone=',ndone
!****
!****         MULTIPLY THE CENTRE POINT OF THE WINDOW AND ADVANCE THE WINDOW
!****         ONE SAMPLE AND REPEAT
!****           USE THE FIRST MULTIPLIER FOR ALL POINTS LESS THAN THE FIRST MID
!****      POINT
!****
! S.S.  changing way pctagc works
!      xmult = olevel / ave * agcpct
!      xmult = olevel / ave / (2.-agcpct)
      IF( agcpct .EQ. 1. ) THEN
          xmult = olevel / ave
      ELSE
          xmult = olevel / (ave + ((1.-agcpct) * agcmean))
      ENDIF
      IF( FIRST ) THEN
          FIRST = .FALSE.
          N = INDXST + NDONE + MIDPT - 3
          DO 390 I = 1, N
             BUFOUT(I) = BUFIN(I) * XMULT
             IF( CLIP .NE. 0. ) THEN
                 IF( ABS(BUFOUT(I)) .GT. CLIP )
     *               BUFOUT(I) = SIGN(CLIP,BUFIN(I))
             ENDIF
  390     CONTINUE
      ENDIF
  400 CONTINUE
      I = INDXST + NDONE + MIDPT - 2
      BUFOUT(I) = BUFIN(I) * XMULT
      IF( CLIP .NE. 0.) THEN
          IF( ABS(BUFOUT(I)) .GT. CLIP )
     *        BUFOUT(I) = SIGN(CLIP,BUFIN(I))
      ENDIF
      IF( INDXST+NPTS+NDONE-1 .GT. INDXET ) GOTO 1000
      J=INDXST+NDONE-1
      K=J+NPTS
      IF( SCRBUF(J) .LE. DEAD ) THEN
          NZEROS = NZEROS - 1
          IF( nzeros .LT. 0 ) nzeros = 0
      ELSE
          SUM = SUM - SCRBUF(J)
      ENDIF
      IF( SCRBUF(K) .LE. DEAD ) THEN
          NZEROS = NZEROS + 1
          IF( nzeros .GT. npts ) nzeros = npts
      ELSE
          SUM = SUM + SCRBUF(K)
      ENDIF
      NDONE = NDONE + 1
      IF( NZEROS .LT. NDEAD ) GOTO 300
      GOTO 400
!****
!****            FINISHED FINDING XMULTIPLIERS, NOW FINISH THE REMAINDER OF THE
!****       LAST WINDOW
!****
 1000 CONTINUE
      J=INDXST+NDONE+MIDPT-1
      DO 1010 I=J,INDXET
      BUFOUT(I)=BUFIN(I)*XMULT
      IF(CLIP.EQ.0.) GO TO 1010
      IF(ABS(BUFOUT(I)).GT.CLIP) BUFOUT(I)=SIGN(CLIP,BUFIN(I))
 1010 CONTINUE
      RETURN
      END


!*****************************************************************************80
!
!! Assemble the elemental to solve for coefficients the problem
!  Discussion:
!             As the elemental matrices are created we add them to the global
!
!  Input:
!           isotope - material isotop identifier
!           delay_group - delayed neutron group identifier
!           n - element number
!
!  Output:
!

subroutine assemble_matrix_ss (isotope,delay_group,n,nl_iter)

    USE element_matrices_M
    USE flags_M
    USE material_info_M
    USE mesh_info_M
    USE global_parameters_M
    USE solution_vectors_M
    use Mod_GlobalConstants

    use Mod_SetupOutputFiles

    implicit none

!---Dummy variables
    integer, intent(in) :: isotope
    integer, intent(in) :: delay_group
    integer, intent(in) :: n
    integer, intent(in) :: nl_iter

!---Local variables
    integer :: i, j, ii, jj, nr,nc, length
!---Inversion routine parameters
    integer :: lda, info, lwork
    integer,  dimension(3) :: ipiv
    real(dp), dimension(3) :: work

    length = 3
!---Initialize
    ipiv =  0.0_dp
    work =  0.0_dp
    lda =   length
    lwork = length

    elem_matrix_G        = 0.0_dp
    elem_vec_w_left_face = 0.0_dp
    elem_vec_q_final     = 0.0_dp

    do i = 1, nodes_per_elem
        !---Calculate q vector
        !if(nl_iter == 1) then
            elem_vec_q_final(isotope,delay_group,i) = &
                 total_power_initial*spatial_power_frac_fcn(n,i)*(allPrecursorData(isotope) % groupBeta(delay_group)/gen_time)*elem_vec_q(i)
        !end if

        do j = 1, nodes_per_elem
            if (n > 1) then
                elem_vec_w_left_face(i) = elem_vec_w_left_face(i) + &
                                          matrix_W_left_face(i,j)*&
                                          precursor_soln_new(isotope,delay_group, n-1,3)
            else
                !---First element
                elem_vec_w_left_face(i) = elem_vec_w_left_face(i) + &
                       matrix_W_left_face(i,j)*&
                       precursor_soln_new(isotope,delay_group,num_elem,3)

            end if
            elem_matrix_G(i,j) = -elem_matrix_U(i,j) + &
                       (allPrecursorData(isotope) % decayConst(delay_group))*elem_matrix_A(i,j) + &
                       matrix_W_right_face(i,j)
        end do
    end do

!****************************************************************
if(DEBUG .eqv. .TRUE.) then
    write(outfile_unit,fmt='(a)'), ' '
    write(outfile_unit,fmt='(a,4I6)'),'G Matrix | element --> ',n
    do i=1,nodes_per_elem
          write(outfile_unit,fmt='(12es14.3)') &
               (elem_matrix_G(i,j),j=1,nodes_per_elem)
    end do

    write(outfile_unit,fmt='(a)'), ' '
    write(outfile_unit,fmt='(a,4I6)'),'left face vector | element --> ', n
    do j=1,nodes_per_elem
          write(outfile_unit,fmt='(12es14.3)') elem_vec_w_left_face(j)
    end do

    write(outfile_unit,fmt='(a)'),' '
    write(outfile_unit,fmt='(a,4I6)'),'beta/gen time *{q} element source vector | element --> ',n
    write(outfile_unit,fmt='(12es14.3)') &
         (elem_vec_q_final(isotope,delay_group,i),i=1,nodes_per_elem)
end if

end subroutine assemble_matrix_ss


!***********************************/
!	Name:衝突三角形の作る多角形における頂点並べ替えプログラム
!	Alias:SortVertexByAngle
!	Description:同時に共有面積の計算も実行しているため注意
!	Type:
!	Input:
!	Output:
!	Note:
!	Author:Akitaka Toyota
!	Date:2017.12.07
!	Update:
!	Other:not parallelize
!***********************************/
    subroutine OSortVertexByAngle(CUV)
    use StructVar_Mod
    use FrequentOperation
    implicit none

    type(CountUpVertex), intent(inout) :: CUV

    integer :: iPoint
    integer :: iYMinNumber
    integer :: iSort1, iSort2, iTmp, iExit
    integer, allocatable :: AccessOrder(:)
    double precision, allocatable :: AngleOfPointVector(:)

    allocate(AccessOrder(CUV%iTotalVertexNum+1))
    allocate(AngleOfPointVector(CUV%iTotalVertexNum))
    !minlocでy方向最小座標を持つ配列番号を特定
    !全成分から特定した配列番号の要素を引く
    iYMinNumber = minloc(CUV%AdditionVertex(1:6,2),1)
    do iTmp=1, CUV%iTotalVertexNum
        CUV%AdditionVertex(iTmp,:) = CUV%AdditionVertex(iTmp,:) - CUV%AdditionVertex(iYMinNumber,:)
    end do

    !xy平面における角度の値を求める
    do iPoint=1,CUV%iTotalVertexNum
        AngleOfPointVector(iPoint) = atan2(CUV%AdditionVertex(iPoint,2), CUV%AdditionVertex(iPoint,1))
    end do

    !角度が小さい順に点の順序の並び換えを行う...というより点の処理順序を決定する(内挿用点番号1→4番的な)
    !データ数が十分少ないため，挿入ソートを利用
    !内挿用点番号iとjの角度を比較し，
    !i>jならj-1として再びiとjの比較
    !j-1<iとなったところでiとjをスワップ
    !以降繰り返し
!挿入ソート
    do iTmp=1, CUV%iTotalVertexNum+1
        AccessOrder(iTmp)=iTmp
    end do

    do iSort1=2, CUV%iTotalVertexNum !2番目から最後の要素まで
        iTmp=iSort1 !現在の並べ替え対象をiTmp番とする
        if(AngleOfPointVector(iSort1-1) > AngleOfPointVector(iTmp)) then !iSort-1番とiSort番の値を比較し，iSort番の方が小さければ入れ替え発生
            iExit = 0 !離脱判定の初期化
            do iSort2 = iTmp, 2, -1 !iSort番目までの値を順々に右へずらし，A<iSortとなる初めての位置にデータを挿入する
                if(AngleOfPointVector(iSort2-1) > AngleOfPointVector(iTmp)) then
                    AccessOrder(iSort2) = AccessOrder(iSort2-1)
                else
                    AccessOrder(iSort2) = AccessOrder(iSort1)
                    iExit = 1
                end if
                if(iExit == 1) exit
            end do
        end if
    end do

    AccessOrder(CUV%iTotalVertexNum+1) = AccessOrder(1)

    CUV%SharedArea = 0.0d0
    do iPoint=1, CUV%iTotalVertexNum
        CUV%SharedArea = CUV%SharedArea &
            &   + 0.5d0*AbsCrossProduct(CUV%AdditionVertex(AccessOrder(iPoint),:),CUV%AdditionVertex(AccessOrder(iPoint+1),:))
    end do

    return
    end subroutine OSortVertexByAngle


      module src_scatter

      use src_hilfe
      use src_global
      contains
        subroutine rayleighsph(aovrb)

    implicit none

    INCLUDE 'parameter.incf'
    Include 'fields.incf'
    include 'variablen.incf'

!
!-----------------------------------------------------------------------
!     This routine calculates the scattering amplitudes for a spheriod
!     (oblate/prolate/spherical) samll compared with wavelength using
!     the Rayleigh's approximation.
!-----------------------------------------------------------------------
!
!      common/glhydbdy/glbdy(12),glcad(2,6)
!
!      complex*16  pvz,phy
!      common/glraylei/pvz,phy
!
      complex*16 hat
      real*8 vlght,eccn,eccnsq,lz, ffreq, ddeq, ddmx
    real*8, parameter :: ppi=3.14159265358979d0
      data vlght/3.d8/
!
!===> Calculate lz (L3) for oblate/prolate spheroid.
!
      ffreq  = freq*1e9
      refrc = cmplx(refre,refim)
      ddeq   = deq *0.001
      ddmx   = dmx *0.001
 !     aovrb = glbdy(9)

      eps=refrc**2
      if(ddeq.le.0.0d0) ddeq=ddmx*min(1.d0,aovrb)/aovrb**(2.d0/3.d0)    !

!
      if(aovrb.gt.1.0d0) then

!
!-->  prolate spheroid:
!
      eccnsq=1.0d0-1.0d0/(aovrb*aovrb)

      eccn=sqrt(eccnsq)
   lz=(0.5d0*dlog((1.0d0+eccn)/(1.0d0-eccn))/eccn-1.0d0)*(1.0d0-eccnsq)/eccnsq
!
      else if(aovrb.lt.1.0d0) then

!
!-->  oblate spheroid:
!
      eccnsq=1.0d0/(aovrb*aovrb)-1.0d0!

      eccn=sqrt(eccnsq)

      lz=(1.0d0+eccnsq)*(1.0d0-datan(eccn)/eccn)/eccnsq
!
      else
!
!-->  sphere:
!
      lz=1.d0/3.d0
!
      endif
!
!===> Calculate polarizibility and scattering amplitude components.
!
      hat=(ppi*ffreq/vlght)**2*ddeq**3/6.0d0*(eps-1.0d0)    !

      phy=hat/((eps-1.0d0)*(1.0d0-lz)/2.0d0+1.0d0)    !
      pvz=hat/((eps-1.0d0)*lz+1.0d0)    !

!
!
      return
      end subroutine

!
!=======================================================================
!
      subroutine miesphere()

      Implicit none

!
!-----------------------------------------------------------------------
!     This routine calculates the scattering amplitudes for a sphere of
!     arbitrary size using the Mie theory algorithm described by van de
!     Hulst, 1981: "Light Scattering by Small Particles", Chapter 9.
!     This routine uses SI units.  by C. Tang, cxt@lance.colostate.edu
!-----------------------------------------------------------------------
!

      Include 'parameter.incf'
      Include 'variablen.incf'

!      common/glhydbdy/glbdy(12),glcad(2,6)
!      common/ensemmtx/stks

      real  sem(7), nst
      complex*16  as(mrank),bs(mrank),samp(4,mds)
      real*8  x,wvnm, rpsix(mrank),tx(2),uu,pia,pib,pic,tau,&
            chix0,chix1,chix2,psix0,psix1
      complex*16  dpsiz(mrank),tz(2),ztmp,xix0,xix1,sumh,sumv

      integer :: i, ids, idr, n,ia1
      integer, parameter :: nds = 2
      real*8, parameter :: degrad = 1.745329251994329d-2
      real, parameter :: phsct(mds) =(0.d0,1.8d2),thsct(mds)=(0d0,1.8d2)
      real :: freq0
      real*8 :: ddeq
      include 'constants.incf'

!
!===> Series terminated after n terms
!

      refrc = cmplx(refre,refim)
      ddeq   = deq *0.001    !equivolume diameter of the particle in mm

      freq0 = freq*1.e9
      wvnm=2*pi*freq0/vlght

      x=wvnm*ddeq/2

      n=INT(x+4*x**(1.0d0/3.0d0)+20)

!===> Calculate logarithmic derivatives of Riccati-Bessel functions psiz
!     (of complex argument refrc*x), and ratio of psix (of real argument
!     x, rpsix(i)=psix(i-1)/psix(i)).
!
!-->  the tx and tz are used to recur down to the highest order function
!     that are needed.  first set the nozero starting order values for
!     downward recursion, then recur downward to obtain order n.
!

      nst = n+abs(refrc)*x+15
      tx(1) = (nst+1) / x
      tz(1)= (nst+1) / (x * refrc)

      do 10 i=nst-1,n,-1
      ia1=i+1
      tx(2)=(i+ia1)/x-1.0d0/tx(1)
      tx(1)=tx(2)
      ztmp = ia1 / (x*refrc)
      tz(2) = ztmp - 1.0d0 / (tz(1) + ztmp)
      tz(1)= tz(2)
 10   continue
      dpsiz(n)=tz(2)
      rpsix(n)=tx(2)
!
!-->  continue downward recursion to order 1.
!
      do 20 i=n-1,1,-1
      ia1=i+1
      rpsix(i)=(i+ia1)/x-1.0d0/rpsix(ia1)
      ztmp=ia1/x/refrc
      dpsiz(i)=ztmp-1.0d0/(dpsiz(ia1)+ztmp)
 20   continue
!
!===> Recur upward to calculate Riccati-Bessel functions psix and chix
!     all of real argument x.  Then compute the a and b arrays.
!
      psix1=sin(x)
      chix0=cos(x)
      chix1=chix0/x+psix1

      do 30 i=1,n
      ia1=i+1
      psix0=psix1
      psix1=psix1/rpsix(i)

      ztmp=(i+ia1)/(i*ia1*dcmplx(0.0d0,wvnm))
      xix0=dcmplx(psix0,chix0)
      xix1=dcmplx(psix1,chix1)
      tz(1)=dpsiz(i)/refrc+i/x
      tz(2)=dpsiz(i)*refrc+i/x
      as(i)=ztmp*(tz(1)*psix1-psix0)/(tz(1)*xix1-xix0)
      bs(i)=ztmp*(tz(2)*psix1-psix0)/(tz(2)*xix1-xix0)

      chix2=(i+ia1)*chix1/x-chix0
      chix0=chix1
      chix1=chix2
 30   continue
!
!===> Starting with order 1 and 2, recur upward to calculate associated
!     Legendre functions divided by sin(theta) (argument cos(theta), at
!     azimuthal mode m=1).  Then compute scattering amplitudes.
!
      do 50 ids=1,nds

      uu=cos(thsct(ids)*degrad)
      pia=1.0d0
      pib=3.0d0*uu
      sumv=bs(1)+as(1)*uu + bs(2)*pib+as(2)*(6.0d0*uu*uu-3.0d0)
      sumh=as(1)+bs(1)*uu + as(2)*pib+bs(2)*(6.0d0*uu*uu-3.0d0)
      do 40 i=3,n
      pic=((2*i-1)*uu*pib-i*pia)/(i-1)
      tau=i*uu*pic-(i+1)*pib
      pia=pib
      pib=pic
      sumv=sumv + bs(i)*pic+as(i)*tau
      sumh=sumh + as(i)*pic+bs(i)*tau
 40   continue

      samp(1,ids)= sumv*cos(phsct(ids)*degrad)
!      samp(2,ids)=-sumh*sin(phsct(ids)*degrad)
!      samp(3,ids)= sumv*sin(phsct(ids)*degrad)
!      samp(4,ids)= sumh*cos(phsct(ids)*degrad)

 50   continue
!
!===> Elements in extinction and backscattering Mueller matrices.
!

      sem(1)=-2*real(samp(1,1)*cmplx(0.0,-1.0))

      sem(4)= abs(samp(1,2))**2
      sem(6)=-sem(4)

      do 60 idr=1,ndr

      stks( 1,idr)= sem(1)
      stks( 2,idr)= 0.0
      stks( 3,idr)= 0.0
      stks( 4,idr)= 0.0
      stks( 5,idr)= 0.0

      stks( 6,idr)= sem(4)
      stks( 7,idr)= 0.0
      stks( 8,idr)= 0.0
      stks( 9,idr)= 0.0
      stks(10,idr)= sem(4)
      stks(11,idr)= 0.0
      stks(12,idr)=-sem(4)
      stks(13,idr)= 0.0
      stks(14,idr)=-sem(4)

 60   continue
!
!

      return
      end subroutine

      end module src_scatter