MODULE PARAM

    USE MPI

    IMPLICIT NONE

    ! INITIAL MESH FILE-------------------------------------------------
    CHARACTER(LEN=*), PARAMETER :: MESHFILE = "two_boundary.msh"
    !-------------------------------------------------------------------

    ! SET POLYNOMIAL ORDER----------------------------------------------
    INTEGER :: N = 6    ! POLYNOMIAL DEGREE IN X DIRECTION
    INTEGER :: M = 4    ! POLYNOMIAL DEGREE IN Y DIRECTION
    INTEGER :: MNMAX = 12   ! MAXIMUM POLYNOMIAL DEGREE
    !-------------------------------------------------------------------

    ! TIME STEP---------------------------------------------------------
!    DOUBLE PRECISION :: DELTA_T = 1.0D0
    !-------------------------------------------------------------------

    ! WAVE SPEED -------------------------------------------------------
    DOUBLE PRECISION, PARAMETER :: C=1.0D0
    !-------------------------------------------------------------------

    ! TIME--------------------------------------------------------------
    DOUBLE PRECISION :: T_TOTAL = 0.5D0     ! TOTAL TIME INTEGRAL
    INTEGER :: NT = 0.3333E4                    ! TIME STEP NUMBER
    !-------------------------------------------------------------------

    ! SET ADAPATION ----------------------------------------------------
    INTEGER, PARAMETER :: SPLIT_MAX_NUM = 3     ! MAXIMUM SPLIT NUMBER
    !-------------------------------------------------------------------

    ! SET MPI ----------------------------------------------------------
    INTEGER :: RANK     ! PROCESSOR RANK
    INTEGER :: NUM_PROC ! NUMBER OF PROCESSOR
    INTEGER :: IERROR
    !-------------------------------------------------------------------

    ! OUTPUT FILE ------------------------------------------------------
    INTEGER :: FRAME=1
    !-------------------------------------------------------------------

    ! OTHER PARAMETER --------------------------------------------------
    DOUBLE PRECISION, PARAMETER :: PI=4.0D0*DATAN(1.0D0)
    !-------------------------------------------------------------------

END MODULE PARAM


!
! ej8e.f90
!
! Copyright 2016 Bruno S <bruno@oac.unc.edu.ar>
!
! This program is free software; you can redistribute it and/or modify
! it under the terms of the GNU General Public License as published by
! the Free Software Foundation; either version 2 of the License, or
! (at your option) any later version.
!
! This program is distributed in the hope that it will be useful,
! but WITHOUT ANY WARRANTY; without even the implied warranty of
! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
! GNU General Public License for more details.
!
program lyapunov

use precision, pr => dp

implicit none
integer, parameter      :: N = 10000000, K = 2100
integer                 :: i, j, t
real(pr)                :: xat, xat_1, x0, xbt, xbt_1
real(pr)                :: r_0, r_f, r, dr, dx, dx0, lavg, tol, navg

open(unit=10, file='ej8e.dat', status='UNKNOWN', action='WRITE')
write(10, *) "#  t   xat   xbt   dx  lam r "

tol = 1.e-3_pr
r_0 = 2._pr
r_f = 4.0_pr
dr = (r_f - r_0)/real(K, pr)
x0 = 0.6_pr
dx0 = 1.e-3_pr

do j = K, 1, -1
    lavg = 0._pr
    t = 0
    r = r_0 + dr * real(j, pr)
    xat_1 = x0
    xbt_1 = x0 + dx0
    !write(10, *) t + i, x0, r
    do i = 1, N
        xat = r * xat_1 * (1._pr - xat_1)
        xbt = r * xbt_1 * (1._pr - xbt_1)
        dx = abs(xat - xbt)
        navg = log(dx/dx0)
        if (i > 300) then
            if (abs(navg) < tol) then
                write(10, *) t + i, xat, xbt, dx, lavg/real(i,pr) , r
                exit
            end if
        end if
        lavg = lavg + navg
        xat_1 = xat
        xbt_1 = xbt
    end do
end do

close(10)

end program lyapunov


! RUN: bbc -emit-fir %s -o - | FileCheck %s

! CHECK-LABEL: nint_test1
subroutine nint_test1(i, a)
    integer :: i
    real :: a
    i = nint(a)
    ! CHECK: fir.call @llvm.lround.i32.f32
  end subroutine
  ! CHECK-LABEL: nint_test2
  subroutine nint_test2(i, a)
    integer(8) :: i
    real(8) :: a
    i = nint(a, 8)
    ! CHECK: fir.call @llvm.lround.i64.f64
  end subroutine


! { dg-do run }
! Test the fix for PR31711 in which the dependency in the assignment
! at line 18 was detected and then ignored.
!
! Contributed by Tobias Ivarsson <thobes@gmail.com>
!
program laplsolv
  IMPLICIT NONE
  integer, parameter                  :: n = 2
  double precision,dimension(0:n+1, 0:n+1) :: T
  integer                             :: i

  T=0.0
  T(0:n+1 , 0)     = 1.0
  T(0:n+1 , n+1)   = 1.0
  T(n+1   , 0:n+1) = 2.0

  T(1:n,1)=(T(0:n-1,1)+T(1:n,1+1)+1d0)

  if (any (T(1:n,1) .ne. 1d0 )) call abort ()
end program laplsolv


program problem_11

!! How many seats end up occupied?

use aoc_utilities
use iso_fortran_env

implicit none

integer,dimension(:,:),allocatable :: seat_array, prev_array, new_array, original_array
integer :: iunit, istat, i, j, k, n, m, iter
character(len=:),allocatable :: line
logical :: status_ok

integer,parameter :: chunk_size = 256

! read the file:
open(newunit=iunit, file='input.txt', iostat=istat)
n = number_of_lines_in_file(iunit)
do i = 1, n
    call read_line_from_file(iunit,chunk_size,line,status_ok)
    if (.not. allocated(seat_array)) then
        m = len(line)
        allocate(seat_array(n, m))
    end if
    ! in the seat array:
    ! -1 = floor (.)
    ! 0 = empty (L)
    ! 1 = occupied (#)
    do j = 1, m
        select case (line(j:j))
        case('.'); seat_array(i,j) = -1
        case('L'); seat_array(i,j) = 0
        case('#'); seat_array(i,j) = 1
        case default; error stop 'invalid value: '//line(j:j)
        end select
    end do
end do

write(*,*) '---------------------------------------------'
write(*,*) ' Part 1 '
write(*,*) '---------------------------------------------'

original_array = seat_array ! reset to original

write(*,*) '--'
call print_array(seat_array)

prev_array = seat_array
iter = 0
do
    iter = iter + 1
    ! If a seat is empty (L) and there are no occupied seats adjacent to it, the seat becomes occupied.
    ! If a seat is occupied (#) and four or more seats adjacent to it are also occupied, the seat becomes empty.
    ! Otherwise, the seat's state does not change.
    do i = 1, n
        do j = 1, m
            select case (prev_array(i,j))
            case(0) ! empty
                ! check for any occupied adjacent seats
                if (number_of_occupied_adjacent_sets(i, j, prev_array)==0) seat_array(i,j) = 1
            case(1) ! occupied
                if (number_of_occupied_adjacent_sets(i, j, prev_array)>=4) seat_array(i,j) = 0
            end select
        end do
    end do

    write(*,*) '--'
    call print_array(seat_array)

    ! has it changed:
    if (all(prev_array == seat_array)) then
        write(*,*) 'done in ', iter, 'iterations'
        exit
    else
        prev_array = seat_array
    end if

end do
write(*,*) 'number occupied (part 1): ', count(seat_array==1)

write(*,*) '---------------------------------------------'
write(*,*) ' Part 2 '
write(*,*) '---------------------------------------------'

seat_array = original_array

write(*,*) '--'
call print_array(seat_array)

prev_array = seat_array
iter = 0
do
    iter = iter + 1
    ! If a seat is empty (L) and there are no occupied seats adjacent to it, the seat becomes occupied.
    ! If a seat is occupied (#) and 5 or more seats adjacent to it are also occupied, the seat becomes empty.
    ! Otherwise, the seat's state does not change.
    do i = 1, n
        do j = 1, m
            select case (prev_array(i,j))
            case(0) ! empty
                ! check for any occupied adjacent seats
                if (number_of_occupied_adjacent_sets_2(i, j, prev_array)==0) seat_array(i,j) = 1
            case(1) ! occupied
                if (number_of_occupied_adjacent_sets_2(i, j, prev_array)>=5) seat_array(i,j) = 0
            end select
        end do
    end do

    write(*,*) '--'
    call print_array(seat_array)

    ! has it changed:
    if (all(prev_array == seat_array)) then
        write(*,*) 'done in ', iter, 'iterations'
        exit
    else
        prev_array = seat_array
    end if

   ! if (iter==2) stop

end do
write(*,*) 'number occupied (part 2): ', count(seat_array==1)

contains

    function number_of_occupied_adjacent_sets(i, j, iarray) result(n_occupied)
    !! for part 1
    implicit none
    integer,intent(in) :: i, j !! Index to check
    integer,dimension(:,:),intent(in) :: iarray
    integer :: n_occupied, ii, jj

    integer :: n, m

    n = size(iarray,1)
    m = size(iarray,2)

    n_occupied = 0

    ! ###
    ! #x#
    ! ###

    do ii = i-1, i+1
        do jj = j-1, j+1
            if (ii==i .and. jj==j) cycle
            if (ii>0 .and. ii<=n .and. jj>0 .and. jj<=m) then
                if (iarray(ii,jj)==1) n_occupied = n_occupied + 1
            end if
        end do
    end do

    end function number_of_occupied_adjacent_sets

    function number_of_occupied_adjacent_sets_2(i, j, iarray) result(n_occupied)
    !! for part 2

    implicit none

    integer,intent(in) :: i, j !! Index to check
    integer,dimension(:,:),intent(in) :: iarray

    integer :: n_occupied, ii, jj, k
    integer :: n, m

    n = size(iarray,1)
    m = size(iarray,2)

    n_occupied = 0

    ! ###
    ! #x#
    ! ###

    do ii = i-1, 1, -1
        select case (iarray(ii,j))
        case(1)
            n_occupied = n_occupied + 1
            exit
        case(0)
            exit
        end select
    end do ! up
    do ii = i+1, n
        select case (iarray(ii,j))
        case(1)
            n_occupied = n_occupied + 1
            exit
        case(0)
            exit
        end select
    end do ! down
    do jj = j-1, 1, -1
        select case (iarray(i,jj))
        case(1)
            n_occupied = n_occupied + 1
            exit
        case(0)
            exit
        end select
    end do ! left
    do jj = j+1, m
        select case (iarray(i,jj))
        case(1)
            n_occupied = n_occupied + 1
            exit
        case(0)
            exit
        end select
    end do ! right

    ! up->left
    do k = 1, max(i-1,j-1)
        ii = i - k
        jj = j - k
        if (ii>0 .and. ii<=n .and. jj>0 .and. jj<=m) then
            select case (iarray(ii,jj))
            case(1)
                n_occupied = n_occupied + 1
                exit
            case(0)
                exit
            end select
        end if
    end do
    ! up->right
    do k = 1, max(i-1,m-j)
        ii = i - k
        jj = j + k
        if (ii>0 .and. ii<=n .and. jj>0 .and. jj<=m) then
            select case (iarray(ii,jj))
            case(1)
                n_occupied = n_occupied + 1
                exit
            case(0)
                exit
            end select
        end if
    end do
    ! down->left
    do k = 1, max(n-i,j-1)
        ii = i + k
        jj = j - k
        if (ii>0 .and. ii<=n .and. jj>0 .and. jj<=m) then
            select case (iarray(ii,jj))
            case(1)
                n_occupied = n_occupied + 1
                exit
            case(0)
                exit
            end select
        end if
    end do
    ! down->right
    do k = 1, max(n-i,m-j)
        ii = i + k
        jj = j + k
        if (ii>0 .and. ii<=n .and. jj>0 .and. jj<=m) then
            select case (iarray(ii,jj))
            case(1)
                n_occupied = n_occupied + 1
                exit
            case(0)
                exit
            end select
        end if
    end do

    end function number_of_occupied_adjacent_sets_2

    subroutine print_array(iarray)
    implicit none
    integer,dimension(:,:),intent(in) :: iarray
    integer :: i, j

    do i = 1, size(iarray,1)
        do j = 1, size(iarray, 2)
            select case (iarray(i,j))
            case(-1); write(*,'(A)', advance='NO') '.'
            case(0);  write(*,'(A)', advance='NO') 'L'
            case(1);  write(*,'(A)', advance='NO') '#'
            end select
        end do
        write(*,'(A)') ''
    end do

    end subroutine print_array

end program problem_11


      MODULE m_qsf

!      interface qsf
!        module procedure qsfReal, qsfComplex
!      end interface

      CONTAINS

      SUBROUTINE qsf(h,y,z,ndim,isave)
c     ..................................................................
c     subroutine qsf
c     purpose
c        to integrate an equidistant table of function values.
c     description of parameters
c         h     - the increment of arguement values.
c         y     - the input vector of function values.  y must be
c                 dimensioned ndim.
c         z     - if isave = 0,z is the final value of the integration.
c                 if isave not 0,z is the resulting vector of integrals
c                 for each y value. in this case it must be dimensioned
c                 ndim.
c         ndim  - the number of points in the table.
c         isave - determines whether a single value or multiple results
c                 will be returned
c                  isave =  0  - only the final value of the integra-
c                                tion will be returned.
c                  isave ne 0  - the results of integration at each
c                                point in the table will be returned.
c     remarks
c        no action in case ndim less than 3.
c     subroutines and function subprograms required
c        none
c     method
c        integration is done by means of simpsons rule together with
c        newtons 3/8 rule or a combination of these two rules. trunca-
c        tion error is of order h**5 if ndim greater than 3. if ndim = 3
c        truncation error is of order h**4.
c     reference
c        (1) f.b.hildebrand, introduction to numerical analysis,
c            mcgraw-hill, new york/toronto/london, 1956, pp.71-76.
c        (2) r. zurmuehl, praktische mathematic fuer ingenieure und
c            physiker, springer, berlin/goettingen/heidelberg, 1963,
c            pp. 214-221.
c     ..................................................................
C     .. Scalar Arguments ..

      IMPLICIT NONE
      REAL h
      INTEGER isave,ndim
C     ..
C     .. Array Arguments ..
      REAL y(ndim),z(*)
C     ..
C     .. Local Scalars ..
      REAL aux,aux1,aux2,ht,sum1,sum2,val
      INTEGER i
      LOGICAL save
C     ..
      save = isave .NE. 0
      ht = h / 3.0
      IF ( ndim == 5 ) THEN
        GOTO 140
      ELSEIF ( ndim < 5 ) THEN
        GOTO 130
      ENDIF
c     ndim is greater than 5. preparations of integration loop
      sum1 = y(2) + y(2)
      sum1 = sum1 + sum1
      sum1 = ht* (y(1)+sum1+y(3))
      aux1 = y(4) + y(4)
      aux1 = aux1 + aux1
      aux1 = sum1 + ht* (y(3)+aux1+y(5))
      aux2 = ht* (y(1)+3.875e0* (y(2)+y(5))+2.625e0* (y(3)+y(4))+y(6))
      IF (.NOT.save) GO TO 30
   20 z(1) = 0.e0
      sum2 = y(5) + y(5)
      sum2 = sum2 + sum2
      sum2 = aux2 - ht* (y(4)+sum2+y(6))
      aux = y(3) + y(3)
      aux = aux + aux
      z(2) = sum2 - ht* (y(2)+aux+y(4))
      z(3) = sum1
      z(4) = sum2
   30 CONTINUE
      IF ( ndim <= 6 ) THEN
         GOTO 70
      ENDIF
c     integration loop
   40 DO 60 i = 7,ndim,2
         sum1 = aux1
         sum2 = aux2
         aux1 = y(i-1) + y(i-1)
         aux1 = aux1 + aux1
         aux1 = sum1 + ht* (y(i-2)+aux1+y(i))
         IF (save) z(i-2) = sum1
         IF ( i >= ndim ) THEN
           GOTO 100
         ENDIF
         aux2 = y(i) + y(i)
         aux2 = aux2 + aux2
         aux2 = sum2 + ht* (y(i-1)+aux2+y(i+1))
         IF (save) z(i-1) = sum2
   60 CONTINUE
   70 IF (.NOT.save) GO TO 90
   80 z(ndim-1) = aux1
      z(ndim) = aux2
      RETURN
   90 z(1) = aux2
      RETURN
  100 IF (.NOT.save) GO TO 120
  110 z(ndim-1) = sum2
      z(ndim) = aux1
      RETURN
  120 z(1) = aux1
      RETURN
c     end of integration loop
  130 CONTINUE
      IF ( ndim == 3 ) THEN
        GOTO 210
      ELSEIF ( ndim < 3 ) THEN
        GOTO 230
      ENDIF
c     ndim is equal to 4 or 5
  140 sum2 = 1.125e0*ht* (y(1)+y(2)+y(2)+y(2)+y(3)+y(3)+y(3)+y(4))
      sum1 = y(2) + y(2)
      sum1 = sum1 + sum1
      sum1 = ht* (y(1)+sum1+y(3))
      IF (.NOT.save) GO TO 160
  150 z(1) = 0.e0
      aux1 = y(3) + y(3)
      aux1 = aux1 + aux1
      z(2) = sum2 - ht* (y(2)+aux1+y(4))
  160 CONTINUE
      IF ( ndim < 5 ) THEN
        GOTO 190
      ENDIF
  170 aux1 = y(4) + y(4)
      aux1 = aux1 + aux1
      val = sum1 + ht* (y(3)+aux1+y(5))
      IF (save) GO TO 180
      z(1) = val
      RETURN
  180 z(5) = val
      GO TO 200
  190 IF (save) GO TO 200
      z(1) = sum2
      RETURN
  200 z(3) = sum1
      z(4) = sum2
      RETURN
c     ndim is equal to 3
  210 sum2 = y(2) + y(2)
      sum2 = sum2 + sum2
      val = ht* (y(1)+sum2+y(3))
      IF (save) GO TO 220
      z(1) = val
      RETURN
  220 z(1) = 0.e0
      z(2) = ht* (1.25e0*y(1)+y(2)+y(2)-.25e0*y(3))
      z(3) = val
  230 RETURN
      END SUBROUTINE qsf

      subroutine qsfComplex( h, y, z, ndim, isave )

        implicit none

        REAL h
        INTEGER isave,ndim
        COMPLEX y(ndim),z(*)

        real zr(ndim), zi(ndim)

        call qsf( h,  real(y), zr, ndim, isave )
        call qsf( h, aimag(y), zi, ndim, isave )
        z(1:ndim) = cmplx( zr(1:ndim), zi(1:ndim) )

      end subroutine qsfComplex

      END MODULE m_qsf


module mother
real, parameter :: pi = 4.*atan(1.)
real :: tau

interface
module elemental real function pi2tau(pi)
  real, intent(in) :: pi
end function pi2tau
end interface

contains

end module mother

program hier1
use mother

tau = pi2tau(pi)

print *,'pi=',pi, 'tau=', tau

end program


    Program dsterf_example

!     DSTERF Example Program Text

!     Copyright (c) 2018, Numerical Algorithms Group (NAG Ltd.)
!     For licence see
!       https://github.com/numericalalgorithmsgroup/LAPACK_Examples/blob/master/LICENCE.md

!     .. Use Statements ..
      Use lapack_interfaces, Only: dsterf
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Integer, Parameter :: nin = 5, nout = 6
!     .. Local Scalars ..
      Integer :: info, n
!     .. Local Arrays ..
      Real (Kind=dp), Allocatable :: d(:), e(:)
!     .. Executable Statements ..
      Write (nout, *) 'DSTERF Example Program Results'
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) n

      Allocate (d(n), e(n-1))

!     Read T from data file

      Read (nin, *) d(1:n)
      Read (nin, *) e(1:n-1)

!     Calculate the eigenvalues of T
      Call dsterf(n, d, e, info)

      Write (nout, *)
      If (info>0) Then
        Write (nout, *) 'Failure to converge.'
      Else
        Write (nout, *) 'Eigenvalues'
        Write (nout, 100) d(1:n)
      End If

100   Format (3X, (9F8.4))
    End Program


subroutine get_cdf(c,spec,ndim)
  !-------------------------------------------------
  !     returns solar spectrum (CDF) and wavelengths
  !-------------------------------------------------
  implicit none

  integer, intent(in):: ndim
  real*8, intent(in):: spec(2,ndim)
  real*8, intent(inout):: c(ndim)
  real*8 :: f(ndim),l(ndim)

  integer :: i

  !initialise each array
  do i=1,ndim
     l(i)=0.
     f(i) = 0.
     c(i) = 0.
  enddo

  l(:)=spec(1,:)
  f(:)=spec(2,:)

  !numerical integration to produce cumulative distribution
  do i=1,ndim-1
     c(i+1)= c(i) + 0.5*( f(i+1) + f(i) ) * ( l(i+1) - l(i) )
  enddo

  !normalise cumulative distribution to get cdf
  c=c/c(ndim)

  return
end subroutine get_cdf


Module mo_model

  use mo_kind   , only: dp, i4

  implicit none

  private

  public :: getrange
  public :: model

  interface model
     module procedure model_1d, model_0d
  end interface model

  ! module variables
  integer(i4) :: npara = 3

contains

  function GetRange()
    implicit none

    real(dp), dimension(npara,2)  :: GetRange   ! min value and max value of parameter
    real(dp), parameter           :: my_pi = 3.141592653589793238462643383279502884197_dp

    GetRange(1,:)  = (/  -my_pi,  my_pi /) ! min & max parameter 1
    GetRange(2,:)  = (/  -my_pi,  my_pi /) ! min & max parameter 2
    GetRange(3,:)  = (/  -my_pi,  my_pi /) ! min & max parameter 3

  end function GetRange

  function model_1d(paraset,x)
    implicit none

    real(dp), dimension(npara),   intent(in)  :: paraset   ! parameter set
    real(dp), dimension(:),       intent(in)  :: x         ! variables
    real(dp), dimension(size(x))              :: model_1d  ! modeled output

    ! local variables
    real(dp), parameter :: my_b = 2.0_dp

    model_1d(:) = sin(paraset(1))  + x(:)*(sin(paraset(2)))**2  + my_b * paraset(3)**4  * sin(paraset(1))

  end function model_1d

  function model_0d(paraset,x)
    implicit none

    real(dp), dimension(npara),   intent(in)  :: paraset   ! parameter set
    real(dp),                     intent(in)  :: x         ! variables
    real(dp)                                  :: model_0d  ! modeled output

    ! local variables
    real(dp), parameter :: my_b = 2.0_dp

    model_0d = sin(paraset(1))  + x*(sin(paraset(2)))**2  + my_b * paraset(3)**4  * sin(paraset(1))
  end function model_0d

end Module mo_model


MODULE FUN_xyzSAREA
!!#### PURPOSE
!! Calculate the signed area of various shapes in R^3:
!!  1. quadrilateral [Qd]
!!  2. triangle [Tr]
!!  3. polygon [Pg]

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

!!#### EXTERNAL PARAMETERS
USE PAR_Constants_Rsp,ONLY: c_1_by_2_Rsp => c_1_by_2       !!((02-A-PAR_Constants_Rsp.f90))
USE PAR_Constants_Rdp,ONLY: c_1_by_2_Rdp => c_1_by_2       !!((02-A-PAR_Constants_Rdp.f90))

!!#### EXTERNAL PROCEDURES
USE FUN_xyzCOLLAPSE,ONLY: xyzCOLLAPSE_Pg                   !!((05-B-FUN_xyzCOLLAPSE.f90))
USE FUN_xySAREA    ,ONLY: xySAREA_Tr,xySAREA_Qg,xySAREA_Pg !!((03-A-FUN_xySAREA.f90))

!!#### DEFAULT IMPLICIT
IMPLICIT NONE

!!#### DEFAULT ACCES
PRIVATE

!!#### PROCEDURE OVERLOADING
INTERFACE xyzSAREA_Tr
 MODULE PROCEDURE xyzSAREA_Tr_Rsp
 MODULE PROCEDURE xyzSAREA_Tr_Rdp
END INTERFACE

INTERFACE xyzSAREA_Qg
 MODULE PROCEDURE xyzSAREA_Qg_Rsp
 MODULE PROCEDURE xyzSAREA_Qg_Rdp
END INTERFACE

INTERFACE xyzSAREA_Pg
 MODULE PROCEDURE xyzSAREA_Pg_Rsp
 MODULE PROCEDURE xyzSAREA_Pg_Rdp
END INTERFACE

!!#### PUBLIC ACCESS LIST
PUBLIC :: xyzSAREA_Tr
PUBLIC :: xyzSAREA_Qg
PUBLIC :: xyzSAREA_Pg

CONTAINS

FUNCTION xyzSAREA_Tr_Rsp( Tr , M32_transform ) RESULT(SAREA)
!!#### LOCAL KINDS
INTEGER    ,PARAMETER :: KIND_R      = KIND_Rsp
!!#### LOCAL PARAMETERS
REAL(KIND_R),PARAMETER :: c_1_by_2 = c_1_by_2_Rsp
INCLUDE "06-B-FUN_xyzSAREA_Tr.f90.hdr"
!!--begin--
INCLUDE "06-B-FUN_xyzSAREA_Tr.f90.bdy"
!!--end--
END FUNCTION

FUNCTION xyzSAREA_Tr_Rdp( Tr , M32_transform ) RESULT(SAREA)
!!#### LOCAL KINDS
INTEGER    ,PARAMETER :: KIND_R      = KIND_Rdp
!!#### LOCAL PARAMETERS
REAL(KIND_R),PARAMETER :: c_1_by_2 = c_1_by_2_Rdp
INCLUDE "06-B-FUN_xyzSAREA_Tr.f90.hdr"
!!--begin--
INCLUDE "06-B-FUN_xyzSAREA_Tr.f90.bdy"
!!--end--
END FUNCTION

FUNCTION xyzSAREA_Qg_Rsp( Qg , M32_transform ) RESULT(SAREA)
!!#### LOCAL KINDS
INTEGER    ,PARAMETER :: KIND_R      = KIND_Rsp
!!#### LOCAL PARAMETERS
REAL(KIND_R),PARAMETER :: c_1_by_2 = c_1_by_2_Rsp
INCLUDE "06-B-FUN_xyzSAREA_Qg.f90.hdr"
!!--begin--
INCLUDE "06-B-FUN_xyzSAREA_Qg.f90.bdy"
!!--end--
END FUNCTION

FUNCTION xyzSAREA_Qg_Rdp( Qg , M32_transform ) RESULT(SAREA)
!!#### LOCAL KINDS
INTEGER    ,PARAMETER :: KIND_R      = KIND_Rdp
!!#### LOCAL PARAMETERS
REAL(KIND_R),PARAMETER :: c_1_by_2 = c_1_by_2_Rdp
INCLUDE "06-B-FUN_xyzSAREA_Qg.f90.hdr"
!!--begin--
INCLUDE "06-B-FUN_xyzSAREA_Qg.f90.bdy"
!!--end--
END FUNCTION

FUNCTION xyzSAREA_Pg_Rsp( N , Pg , M32_transform ) RESULT(SAREA)
!!#### LOCAL KINDS
INTEGER    ,PARAMETER :: KIND_R      = KIND_Rsp
!!#### LOCAL PARAMETERS
REAL(KIND_R),PARAMETER :: c_1_by_2 = c_1_by_2_Rsp
INCLUDE "06-B-FUN_xyzSAREA_Pg.f90.hdr"
!!--begin--
INCLUDE "06-B-FUN_xyzSAREA_Pg.f90.bdy"
!!--end--
END FUNCTION

FUNCTION xyzSAREA_Pg_Rdp( N , Pg , M32_transform ) RESULT(SAREA)
!!#### LOCAL KINDS
INTEGER    ,PARAMETER :: KIND_R      = KIND_Rdp
!!#### LOCAL PARAMETERS
REAL(KIND_R),PARAMETER :: c_1_by_2 = c_1_by_2_Rdp
INCLUDE "06-B-FUN_xyzSAREA_Pg.f90.hdr"
!!--begin--
INCLUDE "06-B-FUN_xyzSAREA_Pg.f90.bdy"
!!--end--
END FUNCTION

END MODULE


!  ddmod.f
!
!  This work was supported by the Director, Office of Science, Division
!  of Mathematical, Information, and Computational Sciences of the
!  U.S. Department of Energy under contract number DE-AC03-76SF00098.
!
!  Copyright (c) 2000-2008
!
!  Fortran-90 module file to use with double-double numbers.
!
!  Yozo Hida
!  David H Bailey    2008-03-20

module ddmodule
  use ddext
  implicit none

  type dd_real
    sequence
    real*8 :: re(2)
  end type dd_real

  type dd_complex
    sequence
    real*8 :: cmp(4)
  end type dd_complex

  real*8 d_dd_eps
  parameter (d_dd_eps = 4.93038065763132d-32)

  type (dd_real) dd_one, dd_zero, dd_eps, dd_huge, dd_tiny
  parameter (dd_one = dd_real((/1.0d0, 0.0d0/)), &
             dd_zero = dd_real((/0.0d0, 0.0d0/)))
  parameter (dd_eps = dd_real((/d_dd_eps, 0.0d0/)))
  parameter (dd_huge = dd_real((/1.79769313486231570815d+308, &
                                 9.97920154767359795037d+291/)))
  parameter (dd_tiny = dd_real((/4.00833672001794555599d-292, 0.0d0/)))

  interface assignment (=)
    module procedure assign_dd_str
    module procedure assign_dd
    module procedure assign_dd_d
    module procedure assign_d_dd
    module procedure assign_dd_i
    module procedure assign_i_dd
    module procedure assign_ddc
    module procedure assign_ddc_dd
    module procedure assign_dd_ddc
    module procedure assign_ddc_d
    module procedure assign_d_ddc
    module procedure assign_ddc_dc
    module procedure assign_dc_ddc
    module procedure assign_ddc_i
  end interface

  interface operator (+)
    module procedure add_dd
    module procedure add_dd_d
    module procedure add_d_dd
    module procedure add_dd_i
    module procedure add_i_dd
    module procedure add_ddc
    module procedure add_ddc_dd
    module procedure add_dd_ddc
    module procedure add_ddc_d
    module procedure add_d_ddc
  end interface

  interface operator (-)
    module procedure sub_dd
    module procedure sub_dd_d
    module procedure sub_d_dd
    module procedure neg_dd
    module procedure sub_ddc
    module procedure sub_ddc_dd
    module procedure sub_dd_ddc
    module procedure sub_ddc_d
    module procedure sub_d_ddc
    module procedure neg_ddc
  end interface

  interface operator (*)
    module procedure mul_dd
    module procedure mul_dd_d
    module procedure mul_d_dd
    module procedure mul_dd_i
    module procedure mul_i_dd
    module procedure mul_ddc
    module procedure mul_ddc_dd
    module procedure mul_dd_ddc
    module procedure mul_ddc_d
    module procedure mul_d_ddc
    module procedure mul_ddc_i
    module procedure mul_i_ddc
  end interface

  interface operator (/)
    module procedure div_dd
    module procedure div_dd_d
    module procedure div_d_dd
    module procedure div_dd_i
    module procedure div_i_dd
    module procedure div_ddc
    module procedure div_ddc_dd
    module procedure div_dd_ddc
    module procedure div_ddc_d
  end interface

  interface operator (**)
    module procedure pwr_dd
    module procedure pwr_dd_i
    module procedure pwr_d_dd
    module procedure pwr_ddc_i
  end interface

  interface ddreal
    module procedure to_dd_i
    module procedure to_dd_d
    module procedure to_dd_dd
    module procedure to_dd_str
    module procedure to_dd_ddc
  end interface

  interface ddcomplex
     module procedure to_ddc_dd
     module procedure to_ddc_dd2
     module procedure to_ddc_d
     module procedure to_ddc_dc
  end interface

  interface real
    module procedure to_d_dd
    module procedure to_dd_ddc
  end interface

  interface int
    module procedure to_int_dd
  end interface

  interface sin
    module procedure ddsin
  end interface
  interface cos
    module procedure ddcos
  end interface
  interface tan
    module procedure ddtan
  end interface
  interface sincos
    module procedure ddsincos
  end interface

  interface asin
    module procedure ddasin
  end interface
  interface acos
    module procedure ddacos
  end interface
  interface atan
    module procedure ddatan
  end interface
  interface atan2
    module procedure ddatan2
  end interface

  interface exp
    module procedure ddexp
    module procedure ddcexp
  end interface
  interface log
    module procedure ddlog
    module procedure ddclog
  end interface
  interface log10
    module procedure ddlog10
  end interface

  interface sqrt
    module procedure ddsqrt
  end interface
  interface sqr
    module procedure ddsqr
  end interface
  interface nroot
    module procedure ddnroot
  end interface

  interface sinh
    module procedure ddsinh
  end interface
  interface cosh
    module procedure ddcosh
  end interface
  interface tanh
    module procedure ddtanh
  end interface
  interface sincosh
    module procedure ddsincosh
  end interface

  interface asinh
    module procedure ddasinh
  end interface
  interface acosh
    module procedure ddacosh
  end interface
  interface atanh
    module procedure ddatanh
  end interface

  interface aint
    module procedure ddaint
  end interface

  interface anint
    module procedure ddanint
  end interface

  interface nint
    module procedure ddnint
  end interface

  interface abs
    module procedure ddabs
    module procedure ddcabs
  end interface

  interface sign
    module procedure ddsign
    module procedure ddsign_dd_d
  end interface

  interface random_number
    module procedure ddrand
  end interface

  interface aimag
    module procedure dd_aimag
  end interface

  interface operator (==)
    module procedure eq_dd
    module procedure eq_dd_d
    module procedure eq_d_dd
    module procedure eq_dd_i
    module procedure eq_i_dd
    module procedure eq_ddc
    module procedure eq_ddc_dd
    module procedure eq_dd_ddc
  end interface

  interface operator (/=)
    module procedure ne_dd
    module procedure ne_dd_d
    module procedure ne_d_dd
    module procedure ne_dd_i
    module procedure ne_i_dd
    module procedure ne_ddc
    module procedure ne_ddc_dd
    module procedure ne_dd_ddc
  end interface

  interface operator (>)
    module procedure gt_dd
    module procedure gt_dd_d
    module procedure gt_d_dd
    module procedure gt_dd_i
    module procedure gt_i_dd
  end interface

  interface operator (<)
    module procedure lt_dd
    module procedure lt_dd_d
    module procedure lt_d_dd
    module procedure lt_dd_i
    module procedure lt_i_dd
  end interface

  interface operator (>=)
    module procedure ge_dd
    module procedure ge_dd_d
    module procedure ge_d_dd
    module procedure ge_dd_i
    module procedure ge_i_dd
  end interface

  interface operator (<=)
    module procedure le_dd
    module procedure le_dd_d
    module procedure le_d_dd
    module procedure le_dd_i
    module procedure le_i_dd
  end interface

  interface read_scalar
    module procedure ddinpq
    module procedure ddcinpq
  end interface

  interface write_scalar
    module procedure ddoutq
    module procedure ddcoutq
  end interface

  interface ddread
    module procedure ddinpq
  end interface

  interface ddwrite
    module procedure ddoutq
  end interface

  interface ddcread
    module procedure ddcinpq
  end interface

  interface ddcwrite
    module procedure ddcoutq
  end interface

  interface dble
    module procedure to_d_dd
    module procedure to_d_ddc
  end interface

  interface cmplx
    module procedure to_dc_ddc
  end interface

  interface conjg
    module procedure ddcconjg
  end interface

  interface min
    module procedure ddmin
    module procedure ddmin2
  end interface
  interface max
    module procedure ddmax
    module procedure ddmax2
  end interface
  interface mod
    module procedure ddmod
  end interface

  interface ddpi
    module procedure dd_pi
  end interface

  interface huge
    module procedure ddhuge
  end interface

  interface safe_huge
    module procedure dd_safe_huge
  end interface

  interface tiny
    module procedure ddtiny
  end interface

  interface epsilon
    module procedure ddepsilon
  end interface

  interface radix
    module procedure dd_radix
  end interface

  interface digits
    module procedure dd_digits
  end interface

  interface maxexponent
    module procedure dd_max_expn
  end interface

  interface minexponent
    module procedure dd_min_expn
  end interface

  interface nan
    module procedure dd_nan
  end interface

contains

! Assignments
  subroutine assign_dd_str(a, s)
    type (dd_real), intent(inout) :: a
    character (len=*), intent(in) :: s
    character*80 t
    t = s
    call ddinpc (t, a%re)
  end subroutine assign_dd_str

  elemental subroutine assign_dd (a, b)
    type (dd_real), intent(inout) :: a
    type (dd_real), intent(in) :: b
    a%re = b%re
  end subroutine assign_dd

  elemental subroutine assign_dd_d(a, d)
    type (dd_real), intent(inout) :: a
    real*8, intent(in) :: d
    a%re(1) = d
    a%re(2) = 0.0d0
  end subroutine assign_dd_d

  elemental subroutine assign_d_dd(d, a)
    real*8, intent(inout) :: d
    type (dd_real), intent(in) :: a
    d = a%re(1)
  end subroutine assign_d_dd

  elemental subroutine assign_dd_i(a, i)
    type (dd_real), intent(inout) :: a
    integer, intent(in) :: i
    a%re(1) = i
    a%re(2) = 0.0d0
  end subroutine assign_dd_i

  elemental subroutine assign_i_dd(i, a)
    integer, intent(inout) :: i
    type (dd_real), intent(in) :: a
    i = a%re(1)
  end subroutine assign_i_dd

  elemental subroutine assign_ddc (a, b)
    type (dd_complex), intent(inout) :: a
    type (dd_complex), intent(in) :: b
    a%cmp = b%cmp
  end subroutine assign_ddc

  elemental subroutine assign_ddc_dd (ddc, dd)
    type (dd_complex), intent (inout) :: ddc
    type (dd_real), intent(in) :: dd
    ddc%cmp(1:2) = dd%re
    ddc%cmp(3:4) = 0.d0
  end subroutine assign_ddc_dd

  elemental subroutine assign_dd_ddc (dd, ddc)
    type (dd_real), intent (inout) :: dd
    type (dd_complex), intent(in) :: ddc
    dd%re = ddc%cmp(1:2)
  end subroutine assign_dd_ddc

  elemental subroutine assign_ddc_d (ddc, d)
    type (dd_complex), intent (inout) :: ddc
    real*8, intent(in) :: d
    ddc%cmp(1) = d
    ddc%cmp(2:4) = 0.d0
  end subroutine assign_ddc_d

  elemental subroutine assign_ddc_i (ddc, i)
    type (dd_complex), intent (inout) :: ddc
    integer, intent(in) :: i
    ddc%cmp(1) = i
    ddc%cmp(2:4) = 0.d0
  end subroutine assign_ddc_i

  elemental subroutine assign_d_ddc (d, ddc)
    real*8, intent(inout) :: d
    type (dd_complex), intent (in) :: ddc
    d = ddc%cmp(1)
  end subroutine assign_d_ddc

  elemental subroutine assign_ddc_dc (ddc, dc)
    type (dd_complex), intent (inout) :: ddc
    complex (kind (0.d0)), intent (in) :: dc
    ddc%cmp(1) = dble (dc)
    ddc%cmp(2) = 0.d0
    ddc%cmp(3) = aimag (dc)
    ddc%cmp(4) = 0.d0
  end subroutine assign_ddc_dc

  elemental subroutine assign_dc_ddc (dc, ddc)
    complex (kind (0.D0)), intent (inout) :: dc
    type (dd_complex), intent (in) :: ddc
    dc = cmplx (ddc%cmp(1), ddc%cmp(3), kind (0.d0))
  end subroutine assign_dc_ddc

! Conversions

  elemental type (dd_real) function to_dd_i(ia)
    integer, intent(in) :: ia
    to_dd_i%re(1) = ia
    to_dd_i%re(2) = 0.d0
  end function to_dd_i

  elemental type (dd_real) function to_dd_d(a)
    real*8, intent(in) :: a
    to_dd_d%re(1) = a
    to_dd_d%re(2) = 0.0d0
  end function to_dd_d

  elemental type (dd_real) function to_dd_dd(a)
    type (dd_real), intent(in) :: a
    to_dd_dd%re = a%re
  end function to_dd_dd

  elemental real*8 function to_d_dd(a)
    type (dd_real), intent(in) :: a
    to_d_dd = a%re(1)
  end function to_d_dd

  elemental integer function to_int_dd(a)
    type (dd_real), intent(in) :: a
    to_int_dd = a%re(1)
  end function to_int_dd

  type (dd_real) function to_dd_str(s)
    character (len=*), intent(in) :: s
    character*80 t
    t = s
    call ddinpc (t, to_dd_str%re)
  end function to_dd_str

  elemental type (dd_real) function to_dd_ddc(ddc)
    type (dd_complex), intent(in) :: ddc
    to_dd_ddc%re = ddc%cmp(1:2)
  end function to_dd_ddc

  elemental type (dd_complex) function to_ddc_dd(dd)
    type (dd_real), intent(in) :: dd
    to_ddc_dd%cmp(1:2) = dd%re
    to_ddc_dd%cmp(3:4) = 0.d0
  end function to_ddc_dd

  elemental type (dd_complex) function to_ddc_dd2(x, y)
    type (dd_real), intent(in) :: x, y
    to_ddc_dd2%cmp(1:2) = x%re
    to_ddc_dd2%cmp(3:4) = y%re
  end function to_ddc_dd2

  elemental type (dd_complex) function to_ddc_d(d)
    real*8, intent(in) :: d
    to_ddc_d%cmp(1) = d
    to_ddc_d%cmp(2:4) = 0.d0
  end function to_ddc_d

  elemental complex (kind (0.D0)) function to_dc_ddc (ddc)
    type (dd_complex), intent (in) :: ddc
    to_dc_ddc = cmplx (ddc%cmp(1), ddc%cmp(3), kind (0.d0))
  end function to_dc_ddc

  elemental type (dd_complex) function to_ddc_dc (dc)
    complex (kind (0.d0)), intent(in) :: dc
    to_ddc_dc%cmp(1) = dble (dc)
    to_ddc_dc%cmp(2) = 0.d0
    to_ddc_dc%cmp(3) = aimag (dc)
    to_ddc_dc%cmp(4) = 0.d0
  end function to_ddc_dc

  elemental real*8 function to_d_ddc(ddc)
    type (dd_complex), intent(in) :: ddc
    to_d_ddc = ddc%cmp(1)
  end function to_d_ddc

!  Complex conjugation
  elemental type (dd_complex) function ddcconjg (ddc)
    type (dd_complex), intent(in) :: ddc
    ddcconjg%cmp(1:2) = ddc%cmp(1:2)
    ddcconjg%cmp(3:4) = - ddc%cmp(3:4)
  end function ddcconjg

! Additions
  elemental type (dd_real) function add_dd(a, b)
    type (dd_real), intent(in) :: a, b
    call f_dd_add(a%re, b%re, add_dd%re)
  end function add_dd

  elemental type (dd_real) function add_dd_d(a, b)
    type (dd_real), intent(in) :: a
    real*8, intent(in) :: b
    call f_dd_add_dd_d(a%re, b, add_dd_d%re)
  end function add_dd_d

  elemental type (dd_real) function add_d_dd(a, b)
    real*8, intent(in) :: a
    type (dd_real), intent(in) :: b
    call f_dd_add_dd_d(b%re, a, add_d_dd%re)
  end function add_d_dd

  elemental type (dd_real) function add_i_dd(a, b)
    integer, intent(in) :: a
    type (dd_real), intent(in) :: b
    call f_dd_add_dd_d(b%re, dble(a), add_i_dd%re)
  end function add_i_dd

  elemental type (dd_real) function add_dd_i(a, b)
    type (dd_real), intent(in) :: a
    integer, intent(in) :: b
    call f_dd_add_dd_d(a%re, dble(b), add_dd_i%re)
  end function add_dd_i

  elemental type (dd_complex) function add_ddc(a, b)
    type (dd_complex), intent(in) :: a, b
    call f_dd_add (a%cmp(1:2), b%cmp(1:2), add_ddc%cmp(1:2))
    call f_dd_add (a%cmp(3:4), b%cmp(3:4), add_ddc%cmp(3:4))
  end function add_ddc

  elemental type (dd_complex) function add_ddc_d(a, b)
    type (dd_complex), intent(in) :: a
    real*8, intent(in) :: b
    type (dd_real) :: ddb
    ddb%re(1) = b
    ddb%re(2) = 0.d0
    call f_dd_add (a%cmp(1:2), ddb%re, add_ddc_d%cmp(1:2))
    add_ddc_d%cmp(3:4) = a%cmp(3:4)
  end function add_ddc_d

  elemental type (dd_complex) function add_d_ddc(a, b)
    real*8, intent(in) :: a
    type (dd_complex), intent(in) :: b
    type (dd_real) dda
    dda%re(1) = a
    dda%re(2) = 0.d0
    call f_dd_add (dda%re, b%cmp(1:2), add_d_ddc%cmp(1:2))
    add_d_ddc%cmp(3:4) = b%cmp(3:4)
  end function add_d_ddc

  elemental type (dd_complex) function add_ddc_dd(a, b)
    type (dd_complex), intent(in) :: a
    type (dd_real), intent(in) :: b
    call f_dd_add (a%cmp(1:2), b%re, add_ddc_dd%cmp(1:2))
    add_ddc_dd%cmp(3:4) = a%cmp(3:4)
  end function add_ddc_dd

  elemental type (dd_complex) function add_dd_ddc(a, b)
    type (dd_real), intent(in) :: a
    type (dd_complex), intent(in) :: b
    call f_dd_add (a%re, b%cmp(1:2), add_dd_ddc%cmp(1:2))
    add_dd_ddc%cmp(3:4) = b%cmp(3:4)
  end function add_dd_ddc

! Subtractions
  elemental type (dd_real) function sub_dd(a, b)
    type (dd_real), intent(in) :: a, b
    call f_dd_sub(a%re, b%re, sub_dd%re)
  end function sub_dd

  elemental type (dd_real) function sub_dd_d(a, b)
    type (dd_real), intent(in) :: a
    real*8, intent(in) :: b
    call f_dd_sub_dd_d(a%re, b, sub_dd_d%re)
  end function sub_dd_d

  elemental type (dd_real) function sub_d_dd(a, b)
    real*8, intent(in) :: a
    type (dd_real), intent(in) :: b
    call f_dd_sub_d_dd(a, b%re, sub_d_dd%re)
  end function sub_d_dd

  elemental type (dd_complex) function sub_ddc(a, b)
    type (dd_complex), intent(in) :: a, b
    call f_dd_sub (a%cmp(1:2), b%cmp(1:2), sub_ddc%cmp(1:2))
    call f_dd_sub (a%cmp(3:4), b%cmp(3:4), sub_ddc%cmp(3:4))
  end function sub_ddc

  elemental type (dd_complex) function sub_ddc_d(a, b)
    type (dd_complex), intent(in) :: a
    real*8, intent(in) :: b
    type (dd_real) ddb
    ddb%re(1) = b
    ddb%re(2) = 0.d0
    call f_dd_sub (a%cmp(1:2), ddb%re, sub_ddc_d%cmp(1:2))
    sub_ddc_d%cmp(3:4) = a%cmp(3:4)
  end function sub_ddc_d

  elemental type (dd_complex) function sub_d_ddc(a, b)
    real*8, intent(in) :: a
    type (dd_complex), intent(in) :: b
    type (dd_real) dda
    dda%re(1) = a
    dda%re(2) = 0.d0
    call f_dd_sub (dda%re, b%cmp(1:2), sub_d_ddc%cmp(1:2))
    sub_d_ddc%cmp(3:4) = - b%cmp(3:4)
  end function sub_d_ddc

  elemental type (dd_complex) function sub_ddc_dd(a, b)
    type (dd_complex), intent(in) :: a
    type (dd_real), intent(in) :: b
    call f_dd_sub (a%cmp(1:2), b%re, sub_ddc_dd%cmp(1:2))
    sub_ddc_dd%cmp(3:4) = a%cmp(3:4)
  end function sub_ddc_dd

  elemental type (dd_complex) function sub_dd_ddc(a, b)
    type (dd_real), intent(in) :: a
    type (dd_complex), intent(in) :: b
    call f_dd_sub (a%re, b%cmp(1:2), sub_dd_ddc%cmp(1:2))
    sub_dd_ddc%cmp(3:4) = - b%cmp(3:4)
  end function sub_dd_ddc

! Unary Minus
  elemental type (dd_real) function neg_dd(a)
    type (dd_real), intent(in) :: a
    neg_dd%re = -a%re
  end function neg_dd

  elemental type (dd_complex) function neg_ddc(a)
    type (dd_complex), intent(in) :: a
    neg_ddc%cmp = - a%cmp
  end function neg_ddc

! Multiplications
  elemental type (dd_real) function mul_dd(a, b)
    type (dd_real), intent(in) :: a, b
    call f_dd_mul(a%re, b%re, mul_dd%re)
  end function mul_dd

  elemental type (dd_real) function mul_dd_d(a, b)
    type (dd_real), intent(in) :: a
    real*8, intent(in) :: b
    call f_dd_mul_dd_d(a%re, b, mul_dd_d%re)
  end function mul_dd_d

  elemental type (dd_real) function mul_d_dd(a, b)
    real*8, intent(in) :: a
    type (dd_real), intent(in) :: b
    call f_dd_mul_dd_d(b%re, a, mul_d_dd%re)
  end function mul_d_dd

  elemental type (dd_real) function mul_dd_i(a, b)
    type (dd_real), intent(in) :: a
    integer, intent(in) :: b
    call f_dd_mul_dd_d(a%re, dble(b), mul_dd_i%re)
  end function mul_dd_i

  elemental type (dd_real) function mul_i_dd(a, b)
    integer, intent(in) :: a
    type (dd_real), intent(in) :: b
    call f_dd_mul_dd_d(b%re, dble(a), mul_i_dd%re)
  end function mul_i_dd

  elemental type (dd_complex) function mul_ddc(a, b)
    type (dd_complex), intent(in) :: a, b
    type (dd_real) t1, t2
    call f_dd_mul (a%cmp(1:2), b%cmp(1:2), t1%re)
    call f_dd_mul (a%cmp(3:4), b%cmp(3:4), t2%re)
    call f_dd_sub (t1%re, t2%re, mul_ddc%cmp(1:2))
    call f_dd_mul (a%cmp(1:2), b%cmp(3:4), t1%re)
    call f_dd_mul (a%cmp(3:4), b%cmp(1:2), t2%re)
    call f_dd_add (t1%re, t2%re, mul_ddc%cmp(3:4))
  end function mul_ddc

  elemental type (dd_complex) function mul_ddc_d(a, b)
    type (dd_complex), intent(in) :: a
    real*8, intent(in) :: b
    call f_dd_mul_dd_d (a%cmp(1:2), b, mul_ddc_d%cmp(1:2))
    call f_dd_mul_dd_d (a%cmp(3:4), b, mul_ddc_d%cmp(3:4))
  end function mul_ddc_d

  elemental type (dd_complex) function mul_d_ddc(a, b)
    real*8, intent(in) :: a
    type (dd_complex), intent(in) :: b
    call f_dd_mul_dd_d (b%cmp(1:2), a, mul_d_ddc%cmp(1:2))
    call f_dd_mul_dd_d (b%cmp(3:4), a, mul_d_ddc%cmp(3:4))
  end function mul_d_ddc

  elemental type (dd_complex) function mul_ddc_i(a, b)
    type (dd_complex), intent(in) :: a
    integer, intent(in) :: b
    call f_dd_mul_dd_d (a%cmp(1:2), dble(b), mul_ddc_i%cmp(1:2))
    call f_dd_mul_dd_d (a%cmp(3:4), dble(b), mul_ddc_i%cmp(3:4))
  end function mul_ddc_i

  elemental type (dd_complex) function mul_i_ddc(a, b)
    integer, intent(in) :: a
    type (dd_complex), intent(in) :: b
    call f_dd_mul_dd_d (b%cmp(1:2), dble(a), mul_i_ddc%cmp(1:2))
    call f_dd_mul_dd_d (b%cmp(3:4), dble(a), mul_i_ddc%cmp(3:4))
  end function mul_i_ddc

  elemental type (dd_complex) function mul_ddc_dd(a, b)
    type (dd_complex), intent(in) :: a
    type (dd_real), intent(in) :: b
    call f_dd_mul (a%cmp(1:2), b%re, mul_ddc_dd%cmp(1:2))
    call f_dd_mul (a%cmp(3:4), b%re, mul_ddc_dd%cmp(3:4))
  end function mul_ddc_dd

  elemental type (dd_complex) function mul_dd_ddc(a, b)
    type (dd_real), intent(in) :: a
    type (dd_complex), intent(in) :: b
    call f_dd_mul (a%re, b%cmp(1:2), mul_dd_ddc%cmp(1:2))
    call f_dd_mul (a%re, b%cmp(3:4), mul_dd_ddc%cmp(3:4))
  end function mul_dd_ddc

! Divisions
  elemental type (dd_real) function div_dd(a, b)
    type (dd_real), intent(in) :: a, b
    call f_dd_div(a%re, b%re, div_dd%re)
  end function div_dd

  elemental type (dd_real) function div_dd_d(a, b)
    type (dd_real), intent(in) :: a
    real*8, intent(in) :: b
    call f_dd_div_dd_d(a%re, b, div_dd_d%re)
  end function div_dd_d

  elemental type (dd_real) function div_d_dd(a, b)
    real*8, intent(in) :: a
    type (dd_real), intent(in) :: b
    call f_dd_div_d_dd(a, b%re, div_d_dd%re)
  end function div_d_dd

  elemental type (dd_real) function div_dd_i(a, b)
    type (dd_real), intent(in) :: a
    integer, intent(in) :: b
    call f_dd_div_dd_d(a%re, dble(b), div_dd_i%re)
  end function div_dd_i

  elemental type (dd_real) function div_i_dd(a, b)
    integer, intent(in) :: a
    type (dd_real), intent(in) :: b
    call f_dd_div_d_dd(dble(a), b%re, div_i_dd%re)
  end function div_i_dd

  elemental type (dd_complex) function div_ddc(a, b)
    type (dd_complex), intent(in) :: a, b
    type (dd_real) t1, t2, t3, t4, t5
    call f_dd_mul (a%cmp(1:2), b%cmp(1:2), t1%re)
    call f_dd_mul (a%cmp(3:4), b%cmp(3:4), t2%re)
    call f_dd_add (t1%re, t2%re, t3%re)
    call f_dd_mul (a%cmp(1:2), b%cmp(3:4), t1%re)
    call f_dd_mul (a%cmp(3:4), b%cmp(1:2), t2%re)
    call f_dd_sub (t2%re, t1%re, t4%re)
    call f_dd_mul (b%cmp(1:2), b%cmp(1:2), t1%re)
    call f_dd_mul (b%cmp(3:4), b%cmp(3:4), t2%re)
    call f_dd_add (t1%re, t2%re, t5%re)
    call f_dd_div (t3%re, t5%re, div_ddc%cmp(1:2))
    call f_dd_div (t4%re, t5%re, div_ddc%cmp(3:4))
  end function div_ddc

  elemental type (dd_complex) function div_ddc_d(a,b)
    type (dd_complex), intent(in) :: a
    real*8, intent(in) :: b
    call f_dd_div_dd_d(a%cmp(1:2), b, div_ddc_d%cmp(1:2))
    call f_dd_div_dd_d(a%cmp(3:4), b, div_ddc_d%cmp(3:4))
  end function div_ddc_d

  elemental type (dd_complex) function div_ddc_dd(a, b)
    type (dd_complex), intent(in) :: a
    type (dd_real), intent(in) :: b
    call f_dd_div (a%cmp(1:2), b%re, div_ddc_dd%cmp(1:2))
    call f_dd_div (a%cmp(3:4), b%re, div_ddc_dd%cmp(3:4))
  end function div_ddc_dd

  elemental type (dd_complex) function div_dd_ddc(a, b)
    type (dd_real), intent(in) :: a
    type (dd_complex), intent(in) :: b
    type (dd_real) t1, t2, t3, t4, t5
    call f_dd_mul (a%re, b%cmp(1:2), t1%re)
    call f_dd_mul (a%re, b%cmp(3:4), t2%re)
    t2%re = - t2%re
    call f_dd_mul (b%cmp(1:2), b%cmp(1:2), t3%re)
    call f_dd_mul (b%cmp(3:4), b%cmp(3:4), t4%re)
    call f_dd_add (t3%re, t4%re, t5%re)
    call f_dd_div (t1%re, t5%re, div_dd_ddc%cmp(1:2))
    call f_dd_div (t2%re, t5%re, div_dd_ddc%cmp(3:4))
  end function div_dd_ddc

! Power
  elemental type (dd_real) function pwr_dd (a, b)
    type (dd_real), intent(in) :: a, b
    type (dd_real) q1, q2
    call f_dd_log(a%re, q1%re)
    call f_dd_mul(q1%re, b%re, q2%re)
    call f_dd_exp(q2%re, pwr_dd%re)
  end function pwr_dd

  elemental type (dd_real) function pwr_dd_i(a, n)
    type (dd_real), intent(in) :: a
    integer, intent(in) :: n
    call f_dd_npwr(a%re, n, pwr_dd_i%re)
  end function pwr_dd_i

  elemental type (dd_real) function pwr_d_dd(a, b)
    real*8, intent(in) :: a
    type (dd_real), intent(in) :: b
    type (dd_real) q1, q2, q3
    q1%re(1) = a
    q1%re(2) = 0.d0
    call f_dd_log(q1%re, q2%re)
    call f_dd_mul(q2%re, b%re, q3%re)
    call f_dd_exp(q3%re, pwr_d_dd%re)
  end function pwr_d_dd

  elemental type (dd_complex) function pwr_ddc_i(a, n)
    type (dd_complex), intent(in) :: a
    integer, intent(in) :: n
    integer i2, j, n1
    type (dd_real) t1, t2, t3
    type (dd_complex) c1, c2

    intrinsic :: iabs, ishft

    if (n == 0) then
      if (all(a%cmp == 0.d0)) then
        !write (6, *) 'pwr_ddc_i: a = 0 and n = 0'
        call f_dd_nan(pwr_ddc_i%cmp(1:2))
        call f_dd_nan(pwr_ddc_i%cmp(3:4))
        return
      endif
      pwr_ddc_i%cmp(1) = 1.d0
      pwr_ddc_i%cmp(2:4) = 0.d0
      return
    endif
    n1 = iabs (n)
    i2 = ishft(1, n1-1)

    c1%cmp(1) = 1.d0
    c1%cmp(2:4) = 0.d0

110 continue

    if (n1 >= i2) then
      call f_dd_mul (a%cmp(1:2), c1%cmp(1:2), t1%re)
      call f_dd_mul (a%cmp(3:4), c1%cmp(3:4), t2%re)
      call f_dd_sub (t1%re, t2%re, c2%cmp(1:2))
      call f_dd_mul (a%cmp(1:2), c1%cmp(3:4), t1%re)
      call f_dd_mul (a%cmp(3:4), c1%cmp(1:2), t2%re)
      call f_dd_add (t1%re, t2%re, c2%cmp(3:4))
      do j = 1, 4
        c1%cmp(j) = c2%cmp(j)
      enddo
      n1 = n1 - i2
    endif
    i2 = i2 / 2
    if (i2 >= 1) then
      call f_dd_mul (c1%cmp(1:2), c1%cmp(1:2), t1%re)
      call f_dd_mul (c1%cmp(3:4), c1%cmp(3:4), t2%re)
      call f_dd_sub (t1%re, t2%re, c2%cmp(1:2))
      call f_dd_mul (c1%cmp(1:2), c1%cmp(3:4), t1%re)
      c2%cmp(3:4) = 2.d0 * t1%re
      c1%cmp = c2%cmp
      goto 110
    endif

    if (n > 0) then
      pwr_ddc_i%cmp = c1%cmp
    else
      c1%cmp(3:4) = - c1%cmp(3:4)
      call f_dd_mul (c1%cmp(1:2), c1%cmp(1:2), t1%re)
      call f_dd_mul (c1%cmp(3:4), c1%cmp(3:4), t2%re)
      call f_dd_add (t1%re, t2%re, t3%re)
      call f_dd_div (c1%cmp(1:2), t3%re, pwr_ddc_i%cmp(1:2))
      call f_dd_div (c1%cmp(3:4), t3%re, pwr_ddc_i%cmp(3:4))
    endif

    return
  end function pwr_ddc_i

! Trigonometric Functions
  elemental type (dd_real) function ddsin(a)
    type (dd_real), intent(in) :: a
    call f_dd_sin(a%re, ddsin%re)
  end function ddsin

  elemental type (dd_real) function ddcos(a)
    type (dd_real), intent(in) :: a
    call f_dd_cos(a%re, ddcos%re)
  end function ddcos

  elemental type (dd_real) function ddtan(a)
    type (dd_real), intent(in) :: a
    call f_dd_tan(a%re, ddtan%re)
  end function ddtan

  elemental subroutine ddsincos(a, s, c)
    type (dd_real), intent(in) :: a
    type (dd_real), intent(out) :: s, c
    call f_dd_sincos(a%re, s%re, c%re)
  end subroutine ddsincos

! Inverse Trigonometric Functions
  elemental type (dd_real) function ddasin(a)
    type (dd_real), intent(in) :: a
    call f_dd_asin(a%re, ddasin%re)
  end function ddasin

  elemental type (dd_real) function ddacos(a)
    type (dd_real), intent(in) :: a
    call f_dd_acos(a%re, ddacos%re)
  end function ddacos

  elemental type (dd_real) function ddatan(a)
    type (dd_real), intent(in) :: a
    call f_dd_atan(a%re, ddatan%re)
  end function ddatan

  elemental type (dd_real) function ddatan2(a, b)
    type (dd_real), intent(in) :: a, b
    call f_dd_atan2(a%re, b%re, ddatan2%re)
  end function ddatan2

! Exponential and Logarithms
  elemental type (dd_real) function ddexp(a)
    type (dd_real), intent(in) :: a
    call f_dd_exp(a%re, ddexp%re)
  end function ddexp

  elemental type (dd_complex) function ddcexp (a)
    type (dd_complex), intent(in) :: a
    type (dd_real) t1, t2, t3
    call f_dd_exp (a%cmp(1:2), t1%re)
    call f_dd_sincos (a%cmp(3:4), t3%re, t2%re)
    call f_dd_mul (t1%re, t2%re, ddcexp%cmp(1:2))
    call f_dd_mul (t1%re, t3%re, ddcexp%cmp(3:4))
  end function ddcexp

  elemental type (dd_real) function ddlog(a)
    type (dd_real), intent(in) :: a
    call f_dd_log(a%re, ddlog%re)
  end function ddlog

  elemental type (dd_complex) function ddclog (a)
    type (dd_complex), intent(in) :: a
    type (dd_real) t1, t2, t3
    call f_dd_mul (a%cmp(1:2), a%cmp(1:2), t1%re)
    call f_dd_mul (a%cmp(3:4), a%cmp(3:4), t2%re)
    call f_dd_add (t1%re, t2%re, t3%re)
    call f_dd_log (t3%re, t1%re)
    ddclog%cmp(1:2) = 0.5d0 * t1%re
    call f_dd_atan2 (a%cmp(3:4), a%cmp(1:2), ddclog%cmp(3:4))
  end function ddclog

  elemental type (dd_real) function ddlog10(a)
    type (dd_real), intent(in) :: a
    call f_dd_log10(a%re, ddlog10%re)
  end function ddlog10

! SQRT, etc.
  elemental type (dd_real) function ddsqrt(a)
    type (dd_real), intent(in) :: a
    call f_dd_sqrt(a%re, ddsqrt%re)
  end function ddsqrt

  elemental type (dd_real) function ddsqr(a)
    type (dd_real), intent(in) :: a
    call f_dd_sqr(a%re, ddsqr%re)
  end function ddsqr

  elemental type (dd_real) function ddnroot(a, n)
    type (dd_real), intent(in) :: a
    integer, intent(in) :: n
    call f_dd_nroot(a%re, n, ddnroot%re)
  end function ddnroot

! Hyperbolic Functions
  elemental type (dd_real) function ddsinh(a)
    type (dd_real), intent(in) :: a
    call f_dd_sinh(a%re, ddsinh%re)
  end function ddsinh

  elemental type (dd_real) function ddcosh(a)
    type (dd_real), intent(in) :: a
    call f_dd_cosh(a%re, ddcosh%re)
  end function ddcosh

  elemental type (dd_real) function ddtanh(a)
    type (dd_real), intent(in) :: a
    call f_dd_tanh(a%re, ddtanh%re)
  end function ddtanh

  elemental subroutine ddsincosh(a, s, c)
    type (dd_real), intent(in) :: a
    type (dd_real), intent(out) :: s, c
    call f_dd_sincosh(a%re, s%re, c%re)
  end subroutine ddsincosh

! Inverse Hyperbolic Functions
  elemental type (dd_real) function ddasinh(a)
    type (dd_real), intent(in) :: a
    call f_dd_asinh(a%re, ddasinh%re)
  end function ddasinh

  elemental type (dd_real) function ddacosh(a)
    type (dd_real), intent(in) :: a
    call f_dd_acosh(a%re, ddacosh%re)
  end function ddacosh

  elemental type (dd_real) function ddatanh(a)
    type (dd_real), intent(in) :: a
    call f_dd_atanh(a%re, ddatanh%re)
  end function ddatanh

! Rounding
  elemental type (dd_real) function ddaint(a)
    type (dd_real), intent(in) :: a
    call f_dd_aint(a%re, ddaint%re)
  end function ddaint

  elemental type (dd_real) function ddanint(a)
    type (dd_real), intent(in) :: a
    call f_dd_nint(a%re, ddanint%re)
  end function ddanint

  elemental integer function ddnint(a)
    type (dd_real), intent(in) :: a
    ddnint = to_int_dd(ddaint(a));
  end function ddnint

! Random Number Generator
  subroutine ddrand(harvest)
    type (dd_real), intent(out) :: harvest
    call f_dd_rand(harvest%re)
  end subroutine ddrand

! Equality
  elemental logical function eq_dd(a, b)
    type (dd_real), intent(in) :: a, b
    integer :: r
    call f_dd_comp(a%re, b%re, r)
    if (r == 0) then
      eq_dd = .true.
    else
      eq_dd = .false.
    end if
  end function eq_dd

  elemental logical function eq_dd_d(a, b)
    type (dd_real), intent(in) :: a
    real*8, intent(in) :: b
    integer :: r
    call f_dd_comp_dd_d(a%re, b, r)
    if (r == 0) then
      eq_dd_d = .true.
    else
      eq_dd_d = .false.
    end if
  end function eq_dd_d

  elemental logical function eq_d_dd(a, b)
    real*8, intent(in) :: a
    type (dd_real), intent(in) :: b
    integer :: r
    call f_dd_comp_dd_d(b%re, a, r)
    if (r == 0) then
      eq_d_dd = .true.
    else
      eq_d_dd = .false.
    end if
  end function eq_d_dd

  elemental logical function eq_dd_i(a, b)
    type (dd_real), intent(in) :: a
    integer, intent(in) :: b
    eq_dd_i = eq_dd_d(a, dble(b))
  end function eq_dd_i

  elemental logical function eq_i_dd(a, b)
    integer, intent(in) :: a
    type (dd_real), intent(in) :: b
    eq_i_dd = eq_d_dd(dble(a), b)
  end function eq_i_dd

  elemental logical function eq_ddc (a, b)
    type (dd_complex), intent(in) :: a, b
    integer :: i1, i2
    call f_dd_comp (a%cmp(1:2), b%cmp(1:2), i1)
    call f_dd_comp (a%cmp(3:4), b%cmp(3:4), i2)
    if (i1 == 0 .and. i2 == 0) then
      eq_ddc = .true.
    else
      eq_ddc = .false.
    endif
  end function eq_ddc

  elemental logical function eq_ddc_dd (a, b)
    type (dd_complex), intent(in) :: a
    type (dd_real), intent(in) :: b
    integer :: i1
    call f_dd_comp (a%cmp(1:2), b%re, i1)
    if (i1 == 0 .and. all(a%cmp(3:4) == 0.d0)) then
      eq_ddc_dd = .true.
    else
      eq_ddc_dd = .false.
    endif
  end function eq_ddc_dd

  elemental logical function eq_dd_ddc (a, b)
    type (dd_real), intent(in) :: a
    type (dd_complex), intent(in) :: b
    integer :: i1
    call f_dd_comp (a%re, b%cmp(1:2), i1)
    if (i1 == 0 .and. all(b%cmp(3:4) == 0.d0)) then
      eq_dd_ddc = .true.
    else
      eq_dd_ddc = .false.
    endif
  end function eq_dd_ddc

! Non-Equality
  elemental logical function ne_dd(a, b)
    type (dd_real), intent(in) :: a, b
    integer :: r
    call f_dd_comp(a%re, b%re, r)
    if (r == 0) then
      ne_dd = .false.
    else
      ne_dd = .true.
    end if
  end function ne_dd

  elemental logical function ne_dd_d(a, b)
    type (dd_real), intent(in) :: a
    real*8, intent(in) :: b
    integer :: r
    call f_dd_comp_dd_d(a%re, b, r)
    if (r == 0) then
      ne_dd_d = .false.
    else
      ne_dd_d = .true.
    end if
  end function ne_dd_d

  elemental logical function ne_d_dd(a, b)
    real*8, intent(in) :: a
    type (dd_real), intent(in) :: b
    integer :: r
    call f_dd_comp_dd_d(b%re, a, r)
    if (r == 0) then
      ne_d_dd = .false.
    else
      ne_d_dd = .true.
    end if
  end function ne_d_dd

  elemental logical function ne_dd_i(a, b)
    type (dd_real), intent(in) :: a
    integer, intent(in) :: b
    ne_dd_i = ne_dd_d(a, dble(b))
  end function ne_dd_i

  elemental logical function ne_i_dd(a, b)
    integer, intent(in) :: a
    type (dd_real), intent(in) :: b
    ne_i_dd = ne_d_dd(dble(a), b)
  end function ne_i_dd

  elemental logical function ne_ddc (a, b)
    type (dd_complex), intent(in) :: a, b
    integer :: i1, i2
    call f_dd_comp (a%cmp(1:2), b%cmp(1:2), i1)
    call f_dd_comp (a%cmp(3:4), b%cmp(3:4), i2)
    if (i1 /= 0 .or. i2 /= 0) then
      ne_ddc = .true.
    else
      ne_ddc = .false.
    endif
  end function ne_ddc

  elemental logical function ne_ddc_dd (a, b)
    type (dd_complex), intent(in) :: a
    type (dd_real), intent(in) :: b
    integer :: i1
    call f_dd_comp (a%cmp(1:2), b%re, i1)
    if (i1 /= 0 .or. any(a%cmp(3:4) /= 0.d0)) then
      ne_ddc_dd = .true.
    else
      ne_ddc_dd = .false.
    endif
  end function ne_ddc_dd

  elemental logical function ne_dd_ddc (a, b)
    type (dd_real), intent(in) :: a
    type (dd_complex), intent(in) :: b
    integer :: i1
    call f_dd_comp (a%re, b%cmp(1:2), i1)
    if (i1 /= 0 .or. any(b%cmp(3:4) /= 0.d0)) then
      ne_dd_ddc = .true.
    else
      ne_dd_ddc = .false.
    endif
  end function ne_dd_ddc

! Greater-Than
  elemental logical function gt_dd(a, b)
    type (dd_real), intent(in) :: a, b
    integer :: r
    call f_dd_comp(a%re, b%re, r)
    if (r == 1) then
      gt_dd = .true.
    else
      gt_dd = .false.
    end if
  end function gt_dd

  elemental logical function gt_dd_d(a, b)
    type (dd_real), intent(in) :: a
    real*8, intent(in) :: b
    integer :: r
    call f_dd_comp_dd_d(a%re, b, r)
    if (r == 1) then
      gt_dd_d = .true.
    else
      gt_dd_d = .false.
    end if
  end function gt_dd_d

  elemental logical function gt_d_dd(a, b)
    real*8, intent(in) :: a
    type (dd_real), intent(in) :: b
    integer :: r
    call f_dd_comp_dd_d(b%re, a, r)
    if (r == -1) then
      gt_d_dd = .true.
    else
      gt_d_dd = .false.
    end if
  end function gt_d_dd

  elemental logical function gt_dd_i(a, b)
    type (dd_real), intent(in) :: a
    integer, intent(in) :: b
    gt_dd_i = gt_dd_d(a, dble(b))
  end function gt_dd_i

  elemental logical function gt_i_dd(a, b)
    integer, intent(in) :: a
    type (dd_real), intent(in) :: b
    gt_i_dd = gt_d_dd(dble(a), b)
  end function gt_i_dd

! Less-Than
  elemental logical function lt_dd(a, b)
    type (dd_real), intent(in) :: a, b
    integer :: r
    call f_dd_comp(a%re, b%re, r)
    if (r == -1) then
      lt_dd = .true.
    else
      lt_dd = .false.
    end if
  end function lt_dd

  elemental logical function lt_dd_d(a, b)
    type (dd_real), intent(in) :: a
    real*8, intent(in) :: b
    integer :: r
    call f_dd_comp_dd_d(a%re, b, r)
    if (r == -1) then
      lt_dd_d = .true.
    else
      lt_dd_d = .false.
    end if
  end function lt_dd_d

  elemental logical function lt_d_dd(a, b)
    real*8, intent(in) :: a
    type (dd_real), intent(in) :: b
    integer :: r
    call f_dd_comp_dd_d(b%re, a, r)
    if (r == 1) then
      lt_d_dd = .true.
    else
      lt_d_dd = .false.
    end if
  end function lt_d_dd

  elemental logical function lt_dd_i(a, b)
    type (dd_real), intent(in) :: a
    integer, intent(in) :: b
    lt_dd_i = lt_dd_d(a, dble(b))
  end function lt_dd_i

  elemental logical function lt_i_dd(a, b)
    integer, intent(in) :: a
    type (dd_real), intent(in) :: b
    lt_i_dd = lt_d_dd(dble(a), b)
  end function lt_i_dd

! Greater-Than-Or-Equal-To
  elemental logical function ge_dd(a, b)
    type (dd_real), intent(in) :: a, b
    integer :: r
    call f_dd_comp(a%re, b%re, r)
    if (r >= 0) then
      ge_dd = .true.
    else
      ge_dd = .false.
    end if
  end function ge_dd

  elemental logical function ge_dd_d(a, b)
    type (dd_real), intent(in) :: a
    real*8, intent(in) :: b
    integer :: r
    call f_dd_comp_dd_d(a%re, b, r)
    if (r >= 0) then
      ge_dd_d = .true.
    else
      ge_dd_d = .false.
    end if
  end function ge_dd_d

  elemental logical function ge_d_dd(a, b)
    real*8, intent(in) :: a
    type (dd_real), intent(in) :: b
    integer :: r
    call f_dd_comp_dd_d(b%re, a, r)
    if (r <= 0) then
      ge_d_dd = .true.
    else
      ge_d_dd = .false.
    end if
  end function ge_d_dd

  elemental logical function ge_dd_i(a, b)
    type (dd_real), intent(in) :: a
    integer, intent(in) :: b
    ge_dd_i = ge_dd_d(a, dble(b))
  end function ge_dd_i

  elemental logical function ge_i_dd(a, b)
    integer, intent(in) :: a
    type (dd_real), intent(in) :: b
    ge_i_dd = ge_d_dd(dble(a), b)
  end function ge_i_dd

! Less-Than-Or-Equal-To
  elemental logical function le_dd(a, b)
    type (dd_real), intent(in) :: a, b
    integer :: r
    call f_dd_comp(a%re, b%re, r)
    if (r <= 0) then
      le_dd = .true.
    else
      le_dd = .false.
    end if
  end function le_dd

  elemental logical function le_dd_d(a, b)
    type (dd_real), intent(in) :: a
    real*8, intent(in) :: b
    integer :: r
    call f_dd_comp_dd_d(a%re, b, r)
    if (r <= 0) then
      le_dd_d = .true.
    else
      le_dd_d = .false.
    end if
  end function le_dd_d

  elemental logical function le_d_dd(a, b)
    real*8, intent(in) :: a
    type (dd_real), intent(in) :: b
    integer :: r
    call f_dd_comp_dd_d(b%re, a, r)
    if (r >= 0) then
      le_d_dd = .true.
    else
      le_d_dd = .false.
    end if
  end function le_d_dd

  elemental logical function le_dd_i(a, b)
    type (dd_real), intent(in) :: a
    integer, intent(in) :: b
    le_dd_i = le_dd_d(a, dble(b))
  end function le_dd_i

  elemental logical function le_i_dd(a, b)
    integer, intent(in) :: a
    type (dd_real), intent(in) :: b
    le_i_dd = le_d_dd(dble(a), b)
  end function le_i_dd

! Absolute Value
  elemental type (dd_real) function ddabs(a)
    type (dd_real), intent(in) :: a
    call f_dd_abs(a%re, ddabs%re)
  end function ddabs

  elemental type (dd_real) function ddcabs (ddc)
    type (dd_complex), intent(in) :: ddc
    type (dd_real) t1, t2, t3
    call f_dd_mul (ddc%cmp(1:2), ddc%cmp(1:2), t1%re)
    call f_dd_mul (ddc%cmp(3:4), ddc%cmp(3:4), t2%re)
    call f_dd_add (t1%re, t2%re, t3%re)
    call f_dd_sqrt (t3%re, ddcabs%re)
  end function ddcabs

! Sign transfer
  elemental type (dd_real) function ddsign(a, b) result (c)
    type (dd_real), intent(in) :: a, b
    if (b%re(1) .gt. 0.0d0) then
      if (a%re(1) .gt. 0.0d0) then
        c%re = a%re
      else
        c%re = -a%re
      end if
    else
      if (a%re(1) .gt. 0.0d0) then
        c%re = -a%re
      else
        c%re = a%re
      end if
    endif
  end function ddsign

  elemental type (dd_real) function ddsign_dd_d(a, b) result (c)
    type (dd_real), intent(in) :: a
    real*8, intent(in) ::  b
    if (b .gt. 0.0d0) then
      if (a%re(1) .gt. 0.0d0) then
        c%re = a%re
      else
        c%re = -a%re
      end if
    else
      if (a%re(1) .gt. 0.0d0) then
        c%re = -a%re
      else
        c%re = a%re
      end if
    endif
  end function ddsign_dd_d

! Input
  subroutine ddinpq(u, q1, q2, q3, q4, q5, q6, q7, q8, q9)
    integer, intent(in) :: u
    type (dd_real), intent(in) :: q1
    type (dd_real), intent(in), optional :: q2, q3, q4, q5, q6, q7, q8, q9
!    CHARACTER (LEN=72) :: str

    call ddinp (u, q1%re)

    if (present(q2)) then
      call ddinp (u, q2%re)
    end if

    if (present(q3)) then
      call ddinp (u, q3%re)
    end if

    if (present(q4)) then
      call ddinp (u, q4%re)
    end if

    if (present(q5)) then
      call ddinp (u, q5%re)
    end if

    if (present(q6)) then
      call ddinp (u, q6%re)
    end if

    if (present(q7)) then
      call ddinp (u, q7%re)
    end if

    if (present(q8)) then
      call ddinp (u, q8%re)
    end if

    if (present(q9)) then
      call ddinp (u, q9%re)
   end if

  end subroutine ddinpq

  subroutine ddcinpq(u, q1, q2, q3, q4, q5, q6, q7, q8, q9)
    integer, intent(in) :: u
    type (dd_complex), intent(in) :: q1
    type (dd_complex), intent(in), optional :: q2, q3, q4, q5, q6, q7, q8, q9

    call ddinp (u, q1%cmp(1:2))
    call ddinp (u, q1%cmp(3:4))

    if (present(q2)) then
      call ddinp (u, q2%cmp(1:2))
      call ddinp (u, q2%cmp(3:4))
    end if

    if (present(q3)) then
      call ddinp (u, q3%cmp(1:2))
      call ddinp (u, q3%cmp(3:4))
    end if

    if (present(q4)) then
      call ddinp (u, q4%cmp(1:2))
      call ddinp (u, q4%cmp(3:4))
    end if

    if (present(q5)) then
      call ddinp (u, q5%cmp(1:2))
      call ddinp (u, q5%cmp(3:4))
    end if

    if (present(q6)) then
      call ddinp (u, q6%cmp(1:2))
      call ddinp (u, q6%cmp(3:4))
    end if

    if (present(q7)) then
      call ddinp (u, q7%cmp(1:2))
      call ddinp (u, q7%cmp(3:4))
    end if

    if (present(q8)) then
      call ddinp (u, q8%cmp(1:2))
      call ddinp (u, q8%cmp(3:4))
    end if

    if (present(q9)) then
      call ddinp (u, q9%cmp(1:2))
      call ddinp (u, q9%cmp(3:4))
    end if

  end subroutine ddcinpq

! Output
  subroutine ddoutq(u, q1, q2, q3, q4, q5, q6, q7, q8, q9)
    integer, intent(in) :: u
    type (dd_real), intent(in) :: q1
    type (dd_real), intent(in), optional :: q2, q3, q4, q5, q6, q7, q8, q9
!    CHARACTER (LEN=72) :: str

    call ddout (u, q1%re)

    if (present(q2)) then
      call ddout (u, q2%re)
    end if

    if (present(q3)) then
      call ddout (u, q3%re)
    end if

    if (present(q4)) then
      call ddout (u, q4%re)
    end if

    if (present(q5)) then
      call ddout (u, q5%re)
    end if

    if (present(q6)) then
      call ddout (u, q6%re)
    end if

    if (present(q7)) then
      call ddout (u, q7%re)
    end if

    if (present(q8)) then
      call ddout (u, q8%re)
    end if

    if (present(q9)) then
      call ddout (u, q9%re)
   end if

  end subroutine ddoutq

  subroutine ddcoutq(u, q1, q2, q3, q4, q5, q6, q7, q8, q9)
    integer, intent(in) :: u
    type (dd_complex), intent(in) :: q1
    type (dd_complex), intent(in), optional :: q2, q3, q4, q5, q6, q7, q8, q9

    call ddout (u, q1%cmp(1:2))
    call ddout (u, q1%cmp(3:4))

    if (present(q2)) then
      call ddout (u, q2%cmp(1:2))
      call ddout (u, q2%cmp(3:4))
    end if

    if (present(q3)) then
      call ddout (u, q3%cmp(1:2))
      call ddout (u, q3%cmp(3:4))
    end if

    if (present(q4)) then
      call ddout (u, q4%cmp(1:2))
      call ddout (u, q4%cmp(3:4))
    end if

    if (present(q5)) then
      call ddout (u, q5%cmp(1:2))
      call ddout (u, q5%cmp(3:4))
    end if

    if (present(q6)) then
      call ddout (u, q6%cmp(1:2))
      call ddout (u, q6%cmp(3:4))
    end if

    if (present(q7)) then
      call ddout (u, q7%cmp(1:2))
      call ddout (u, q7%cmp(3:4))
    end if

    if (present(q8)) then
      call ddout (u, q8%cmp(1:2))
      call ddout (u, q8%cmp(3:4))
    end if

    if (present(q9)) then
      call ddout (u, q9%cmp(1:2))
      call ddout (u, q9%cmp(3:4))
    end if

  end subroutine ddcoutq

  elemental type (dd_real) function ddmin2(a, b)
    type (dd_real), intent(in) :: a, b
    integer :: r
    call f_dd_comp(a%re, b%re, r)
    if (r == 1) then
      ddmin2 = b
    else
      ddmin2 = a
    end if
  end function ddmin2

  elemental type (dd_real) function ddmin(a1, a2, a3, a4, a5, a6, a7, a8, a9)
    type (dd_real), intent(in) :: a1, a2, a3
    type (dd_real), intent(in), optional :: a4, a5, a6, a7, a8, a9
    ddmin = ddmin2(ddmin2(a1, a2), a3)
    if (present(a4)) ddmin = ddmin2(ddmin, a4)
    if (present(a5)) ddmin = ddmin2(ddmin, a5)
    if (present(a6)) ddmin = ddmin2(ddmin, a6)
    if (present(a7)) ddmin = ddmin2(ddmin, a7)
    if (present(a8)) ddmin = ddmin2(ddmin, a8)
    if (present(a9)) ddmin = ddmin2(ddmin, a9)
  end function ddmin

  elemental type (dd_real) function ddmax2(a, b)
    type (dd_real), intent(in) :: a, b
    integer :: r
    call f_dd_comp(a%re, b%re, r)
    if (r == -1) then
      ddmax2 = b
    else
      ddmax2 = a
    end if
  end function ddmax2

  elemental type (dd_real) function ddmax(a1, a2, a3, a4, a5, a6, a7, a8, a9)
    type (dd_real), intent(in) :: a1, a2, a3
    type (dd_real), intent(in), optional :: a4, a5, a6, a7, a8, a9
    ddmax = ddmax2(ddmax2(a1, a2), a3)
    if (present(a4)) ddmax = ddmax2(ddmax, a4)
    if (present(a5)) ddmax = ddmax2(ddmax, a5)
    if (present(a6)) ddmax = ddmax2(ddmax, a6)
    if (present(a7)) ddmax = ddmax2(ddmax, a7)
    if (present(a8)) ddmax = ddmax2(ddmax, a8)
    if (present(a9)) ddmax = ddmax2(ddmax, a9)
  end function ddmax

  elemental type (dd_real) function ddmod (a, b)
    type (dd_real), intent(in) :: a, b
    type (dd_real) :: s1, s2
    call f_dd_div (a%re, b%re, s1%re)
    call f_dd_aint(s1%re, s2%re)
    call f_dd_mul (s2%re, b%re, s1%re)
    call f_dd_sub (a%re, s1%re, ddmod%re)
  end function ddmod

  pure type (dd_real) function dd_pi()
    call f_dd_pi(dd_pi%re)
  end function dd_pi

subroutine ddinp (iu, a)

!   This routine reads the DD number A from logical unit IU.  The input
!   value must be placed on a single line of not more than 80 characters.

implicit none
integer iu, ln
parameter (ln = 80)
character*80 cs
real*8 a(2)

read (iu, '(a)', end = 100) cs
call ddinpc (cs, a)
goto 110

100 write (6, 1)
1  format ('*** ddinp: End-of-file encountered.')
! call ddabrt
stop

110 return
end subroutine

subroutine ddinpc (a, b)

!   Converts the CHARACTER*80 array A into the DD number B.

implicit none
integer i, id, ie, inz, ip, is, k, ln, lnn, beg
parameter (ln = 80)
real*8 bi
character*80 a
character*1 ai
character*10 dig
character*16 ca
parameter (dig = '0123456789')
real*8 b(2), f(2), s0(2), s1(2), s2(2)

id = 0
ip = -1
is = 0
inz = 0
s1(1) = 0.d0
s1(2) = 0.d0

beg = 0
do i = 1, 80
  if (a(i:i) /= ' ') then
    beg = i
    goto 80
  end if
end do

goto 210
80 continue

do i = beg, 80
  if (a(i:i) == ' ') then
    lnn = i-1
    goto 90
  end if
 enddo

lnn = 80
90 continue

!   Scan for digits, looking for the period also.

do i = beg, lnn
  ai = a(i:i)
  if (ai .eq. '.') then
    if (ip >= 0) goto 210
    ip = id
    inz = 1
  elseif (ai .eq. '+') then
    if (id .ne. 0 .or. ip >= 0 .or. is .ne. 0) goto 210
    is = 1
  elseif (ai .eq. '-') then
    if (id .ne. 0 .or. ip >= 0 .or. is .ne. 0) goto 210
    is = -1
  elseif (ai .eq. 'e' .or. ai .eq. 'E' .or. ai .eq. 'd' .or. ai .eq. 'D') then
    goto 100
  elseif (index (dig, ai) .eq. 0) then
    goto 210
  else
!    read (ai, '(f1.0)') bi
    bi = index (dig, ai) - 1
    if (inz > 0 .or. bi > 0.d0) then
      inz = 1
      id = id + 1
!    call ddmuld (s1, 10.d0, s0)
      call f_dd_mul_dd_d (s1, 10.d0, s0)
      f(1) = bi
      f(2) = 0.d0
!    call dddqc (bi, f)
!    call ddadd (s0, f, s1)
      call f_dd_add (s0, f, s1)
    endif
  endif
enddo

100   continue
if (is .eq. -1) then
  s1(1) = - s1(1)
  s1(2) = - s1(2)
endif
k = i
if (ip == -1) ip = id
ie = 0
is = 0
ca = ' '

do i = k + 1, lnn
  ai = a(i:i)
  if (ai .eq. ' ') then
  elseif (ai .eq. '+') then
    if (ie .ne. 0 .or. is .ne. 0) goto 210
    is = 1
  elseif (ai .eq. '-') then
    if (ie .ne. 0 .or. is .ne. 0) goto 210
    is = -1
  elseif (index (dig, ai) .eq. 0) then
    goto 210
  else
    ie = ie + 1
    if (ie .gt. 3) goto 210
    ca(ie:ie) = ai
  endif
enddo

! read (ca, '(i4)') ie
ie = dddigin (ca, 4)
if (is .eq. -1) ie = - ie
ie = ie + ip - id
s0(1) = 10.d0
s0(2) = 0.d0
! call ddnpwr (s0, ie, s2)
call f_dd_npwr (s0, ie, s2)
! call ddmul (s1, s2, b)
call f_dd_mul (s1, s2, b)
goto 220

210  write (6, 1) a
1 format ('*** ddinpc: Syntax error in literal string: ', a)
! call ddabrt
stop

220  return
end subroutine

subroutine ddout (iu, a)

!   This routine writes the DD number A on logical unit iu using a standard
!   E format, with lines 40 characters long.

implicit none
integer iu, ln
parameter (ln = 40)
character cs(40)
real*8 a(2)

call ddoutc (a, cs)
write (iu, '(40a)') cs

return
end subroutine

subroutine ddoutc (a, b)
  implicit none
  real*8 a(2)
  character b(40)

  b(1) = ' '
  b(2) = ' '
  call f_dd_swrite(a, 31, b(3), 38)
end subroutine

  real*8 function dddigin (ca, n)
    implicit none
    real*8 d1
    character*(*), ca
    character*16 digits
    integer i, k, n
    parameter (digits = '0123456789')

    d1 = 0.d0

    do i = 1, n
      k = index (digits, ca(i:i)) - 1
      if (k < 0) then
        write (6, *) 'dddigin: non-digit in character string'
      elseif (k <= 9) then
        d1 = 10.d0 * d1 + k
      endif
    enddo

    dddigin = d1
  end function

  character*16 function dddigout (a, n)
    implicit none
    real*8 a, d1, d2
    character*16 ca, digits
    parameter (digits = '0123456789')
    integer i, is, k, n
    real*8 dabs, dint

    intrinsic :: dabs, dint

    ca = ' '
    is = sign (1.d0, a)
    d1 = dabs (a)

    do i = n, 1, -1
      d2 = dint (d1 / 10.d0)
      k = 1.d0 + (d1 - 10.d0 * d2)
      d1 = d2
      ca(i:i) = digits(k:k)
      if (d1 == 0.d0) goto 100
    enddo

    i = 0

100 continue

    if (is < 0 .and. i > 1) then
      ca(i-1:i-1) = '-'
    elseif (i == 0 .or. is < 0 .and. i == 1) then
      ca = '****************'
    endif

    dddigout = ca
    return
  end function

elemental type (dd_real) function ddhuge(a)
  type (dd_real), intent(in) :: a
  ddhuge = dd_huge
end function ddhuge

elemental type (dd_real) function dd_safe_huge(a)
  type (dd_real), intent(in) :: a
  dd_safe_huge = dd_real((/1.7976931080746007281d+308, &
                           9.97920154767359795037d+291/));
end function dd_safe_huge

elemental type (dd_real) function ddtiny(a)
  type (dd_real), intent(in) :: a
  ddtiny = dd_tiny
end function ddtiny

elemental type (dd_real) function ddepsilon(a)
  type (dd_real), intent(in) :: a
  ddepsilon = dd_eps
end function ddepsilon

elemental integer function dd_radix(a)
  type (dd_real), intent(in) :: a
  dd_radix = 2
end function dd_radix

elemental integer function dd_digits(a)
  type (dd_real), intent(in) :: a
  dd_digits = 104
end function dd_digits

elemental integer function dd_max_expn(a)
  type (dd_real), intent(in) :: a
  dd_max_expn = 1023
end function dd_max_expn

elemental integer function dd_min_expn(a)
  type (dd_real), intent(in) :: a
  dd_min_expn = -969
end function dd_min_expn

elemental integer function dd_precision(a)
  type (dd_real), intent(in) :: a
  dd_precision = 31
end function dd_precision

elemental integer function dd_range(a)
  type (dd_real), intent(in) :: a
  dd_range = 291
end function dd_range

elemental type (dd_real) function dd_nan(a)
  type (dd_real), intent(in) :: a
  call f_dd_nan(dd_nan%re)
end function dd_nan

elemental type (dd_real) function dd_aimag(a)
  type (dd_complex), intent(in) :: a
  dd_aimag%re = a%cmp(3:4)
end function

end module ddmodule


!*****************************************************************************
! FILE: omp_dotprod_openmp.f
! DESCRIPTION:
!   This simple program is the OpenMP version of a dot product and the
!   second of four codes used to show the progression from a serial program to a
!   hybrid MPI/OpenMP program.  The relevant codes are:
!      - omp_dotprod_serial.f  - Serial version
!      - omp_dotprod_openmp.f  - OpenMP only version
!      - omp_dotprod_mpi.f     - MPI only version
!      - omp_dotprod_hybrid.f  - Hybrid MPI and OpenMP version
! SOURCE: Blaise Barney
! LAST REVISED:  06/02/17 Blaise Barney
!******************************************************************************

      program dotprod

! Define length of dot product vectors and number of OpenMP threads
      integer VECLEN, NUMTHREADS
      parameter(VECLEN=100)
      parameter(NUMTHREADS=8)

      integer i, tid, OMP_GET_THREAD_NUM
      real*8 a(VECLEN*NUMTHREADS), b(VECLEN*NUMTHREADS), sum, psum

      print *, 'Starting omp_dotprod_openmp. Using',NUMTHREADS,
     &         ' threads'

! Initialize dot product vectors
      do i=1, VECLEN*NUMTHREADS
        a(i)=1.0
        b(i)=a(i)
      end do
! Initialize global sum
      sum = 0.0

! Perform the dot product in an OpenMP parallel region for loop with a sum reduction
! For illustration purposes:
!   - Explicitly sets number of threads
!   - Each thread keeps track of its partial sum

!$OMP PARALLEL PRIVATE(i,tid,psum) NUM_THREADS(NUMTHREADS)
      psum = 0.0
      tid = OMP_GET_THREAD_NUM()

!$OMP DO REDUCTION(+:sum)
      do i=1, VECLEN*NUMTHREADS
        sum = sum + a(i) * b(i)
        psum = sum
      end do
!$OMP END DO
      print *, 'Thread',tid,' partial sum =',psum
!$OMP END PARALLEL

      print *, 'Done. OpenMP version: sum  =', sum

      end


program main

use test, only: test_value
use io, only: stdout

use geom

implicit none

integer :: ierr
double precision :: lon1, lat1, lon2, lat2, dist, az

lon1 = 5.0d0
lat1 = 52.0d0
dist = 123.0d0/6371.0d0
az = -50.0d0
call distaz2lola(lon1,lat1,dist,az,lon2,lat2,'radians','degrees',ierr)
call test_value(lon2,3.6015261937179939d0,'distaz2lola: lon2')
call test_value(lat2,52.702854017526889d0,'distaz2lola: lat2')

lon1 = -77.9d0
lat1 = 40.8d0
lon2 = -90.3d0
lat2 = 38.6d0
call lola2distaz(lon1,lat1,lon2,lat2,dist,az,'radians','degrees',ierr)
call test_value(dist,0.17072370996955819d0,'lola2distaz: dist')
call test_value(az,-98.965076442115560d0,'lola2distaz: az')

! str2vec
! strdip2normal
! strdip2updip
! normal2strike
! normal2updip
! pnpoly

write(stdout,*) 'geom_module unit test passed'
end


! 	Late Penalty Calculator in Fortran
!	Jim Teresco, August 2019
!	===================================================
        program late

	implicit none

	integer lateness
	double precision penalty

 	lateness = 1
 	penalty = 0.0

	do while ( penalty < 100.0 )
	   penalty = 1.08 ** lateness
    	   print *, "Hour ", lateness, " late = ", penalty
           lateness = lateness + 1
	end do

	end


program i
   integer, parameter::a= ((3 + 4) * 2)
   integer, parameter::b= 3 + 6 / 3 * 3 + 2
   stop a + b
end program i


MODULE Snowdepthmod
    IMPLICIT NONE
CONTAINS

    SUBROUTINE model_snowdepth(Snowmelt, &
        Sdepth_t1, &
        Snowaccu, &
        E, &
        rho, &
        Sdepth)
        IMPLICIT NONE
        REAL, INTENT(IN) :: Snowmelt
        REAL, INTENT(IN) :: Sdepth_t1
        REAL, INTENT(IN) :: Snowaccu
        REAL, INTENT(IN) :: E
        REAL, INTENT(IN) :: rho
        REAL, INTENT(OUT) :: Sdepth
        !- Name: SnowDepth -Version: 1.0, -Time step: 1
        !- Description:
    !            * Title: snow cover depth Calculation
    !            * Author: STICS
    !            * Reference: doi:http://dx.doi.org/10.1016/j.agrformet.2014.05.002
    !            * Institution: INRA
    !            * Abstract: snow cover depth Calculation
        !- inputs:
    !            * name: Snowmelt
    !                          ** description : snow melt
    !                          ** inputtype : variable
    !                          ** variablecategory : state
    !                          ** datatype : DOUBLE
    !                          ** default : 0.0
    !                          ** min : 0.0
    !                          ** max : 100.0
    !                          ** unit : m
    !                          ** uri :
    !            * name: Sdepth_t1
    !                          ** description : snow cover depth Calculation in previous day
    !                          ** inputtype : variable
    !                          ** variablecategory : state
    !                          ** datatype : DOUBLE
    !                          ** default : 0.0
    !                          ** min : 0.0
    !                          ** max : 5000.0
    !                          ** unit : m
    !                          ** uri :
    !            * name: Snowaccu
    !                          ** description : snowfall accumulation
    !                          ** inputtype : variable
    !                          ** variablecategory : rate
    !                          ** datatype : DOUBLE
    !                          ** default : 0.0
    !                          ** min :
    !                          ** max :
    !                          ** unit : mmW/d
    !                          ** uri :
    !            * name: E
    !                          ** description : snow compaction parameter
    !                          ** inputtype : parameter
    !                          ** parametercategory : constant
    !                          ** datatype : DOUBLE
    !                          ** default : 0.0
    !                          ** min :
    !                          ** max :
    !                          ** unit : mm/mm/d
    !                          ** uri :
    !            * name: rho
    !                          ** description : The density of the new snow fixed by the user
    !                          ** inputtype : parameter
    !                          ** parametercategory : constant
    !                          ** datatype : DOUBLE
    !                          ** default : 100
    !                          ** min :
    !                          ** max :
    !                          ** unit : kg/m**3
    !                          ** uri :
        !- outputs:
    !            * name: Sdepth
    !                          ** description : snow cover depth Calculation
    !                          ** variablecategory : state
    !                          ** datatype : DOUBLE
    !                          ** min : 0.0
    !                          ** max : 500.0
    !                          ** unit : m
    !                          ** uri :
        Sdepth = 0.0
        IF(Snowmelt .LE. Sdepth_t1 + (Snowaccu / rho)) THEN
            Sdepth = Snowaccu / rho + Sdepth_t1 - Snowmelt - (Sdepth_t1 * E)
        END IF
    END SUBROUTINE model_snowdepth

END MODULE


module module_parameters
 !CHARACTER(len=5),PARAMETER  :: CHARA="1E-01"  !DELETE
           REAL(8),PARAMETER :: ALPHA=1E-04 !Alpha decides how to stretch the grid i.e. alpha=0 means homogenous grid  !It can be set to minimum 1E-15
        INTEGER,PARAMETER :: N= 101 	!NUMBER OF NODE POINTS IN FVM
        REAL(8),PARAMETER :: RHO=1.225			!kg/m^3
        REAL(8),PARAMETER :: DYN_VIS=1.802*1E-5 		!kg/m.s Dynamic Viscosity of Air
        REAL(8),PARAMETER :: KIN_VIS=1.4725*1E-5		!m^2/s Kinematic Viscosity of Air
        REAL(8),PARAMETER :: CONV_CRIT=1E-10           !convergence criteria ( max permissible error)
        INTEGER,PARAMETER :: MAX_ITER=10000       !Maximum iterations if convergence is not reached
        CHARACTER(len=1)  :: PLOT="N"               !automatic plotting set Yes(Y) or No(N)

contains
subroutine case_select(NUM_CASE,VW, H, DPDX)
implicit none
  REAL(8),INTENT(OUT)         ::VW, H, DPDX
  INTEGER,INTENT(IN)          :: NUM_CASE

        if (NUM_CASE==1) then
        VW=12.84;        H=66E-3;         DPDX=0.0d0		!CASE 1
	elseif (NUM_CASE==2) then
	VW=12.84;	 H=66E-3;	  DPDX=-0.808 	        !CASE 2
	elseif (NUM_CASE==3) then
	VW=12.84;	 H=66E-3;	  DPDX=-1.486		!CASE 3
	elseif (NUM_CASE==4) then
	VW=12.84;	 H=66E-3;	  DPDX=-1.510		!CASE 4
	elseif (NUM_CASE==5) then
	VW=12.84;	 H=66E-3;	  DPDX=-1.960		!CASE 5
	elseif (NUM_CASE==6) then
	VW=8.59;	 H=66E-3;	  DPDX=-1.430		!CASE 6
	elseif (NUM_CASE==7) then
	VW=17.08;	 H=101E-3;	  DPDX=-3.548		!CASE 7
	elseif (NUM_CASE==8) then
	VW=12.84;	 H=101E-3;	  DPDX=-2.323		!CASE 8
	elseif (NUM_CASE==9) then
	VW=8.59;	 H=101E-3;	  DPDX=-1.212		!CASE 9
	elseif (NUM_CASE==10) then
	VW=12.84;	 H=66E-3;	  DPDX=-4.830		!CASE 10
	elseif (NUM_CASE==11) then
	VW=12.84;	 H=66E-3;	  DPDX=-7.500		!CASE 11
	elseif (NUM_CASE==12) then
	VW=12.84;	 H=66E-3;	  DPDX=-14.30		!CASE 12
	elseif (NUM_CASE==13) then
	VW=12.84;	 H=66E-3;	  DPDX=-18.50		!CASE 13
	elseif (NUM_CASE==14) then
	VW=8.59;	 H=66E-3;	  DPDX=-20.80		!CASE 14
	elseif (NUM_CASE==15) then
	VW=0.0D0;	 H=66E-3;	  DPDX=-13.14		!CASE 15
	elseif (NUM_CASE==16) then
	VW=1.8; 	 H=30E-3;	  DPDX=-0.48		!CASE 16
	elseif (NUM_CASE==17) then
	VW=3.09;	 H=30E-3;	  DPDX=-0.60		!CASE 17
	elseif (NUM_CASE==18) then
	VW=3.75;	 H=30E-3;	  DPDX=-0.66		!CASE 18
        else
        PRINT *, "Invalid Case Selected. Exiting."
        end if

end subroutine case_select
end module module_parameters


!
! wavy - A spectral ocean wave modeling and development framework
! Copyright (c) 2017, Wavebit Scientific LLC
! All rights reserved.
!
! Licensed under the BSD-3 clause license. See LICENSE for details.
!
program test_pierson_moskowitz

use mod_precision,only:rk => realkind
use mod_spectrum,only:spectrum_type
use mod_spectral_shapes,only:piersonMoskowitz
use mod_utility,only:range

implicit none

type(spectrum_type) :: spec
real(kind=rk),dimension(:),allocatable :: wspd
real(kind=rk),parameter :: grav = 9.8_rk
integer :: n

write(*,*)
write(*,*)'Test omnidirectional spectrum with Pierson-Moskowitz shape;'
write(*,*)'Vary wind speed from 5 to 60 m/s with 5 m/s increments.'
write(*,*)

! Initialize spectrum
spec = spectrum_type(fmin=0.0313_rk,fmax=2._rk,df=1.1_rk,ndirs=1,depth=1e3_rk)

! Set array of wind speed values
wspd = range(5,60,5)

write(*,fmt='(a)')'   wspd      Hs      Tp       Tm1      Tm2      mss      m0(f)'&
                //'    m1(f)    m2(f)'
write(*,fmt='(a)')'----------------------------------------------------------'&
                //'----------------------'
do n = 1,size(wspd)
  ! Set the spectrum field to Pierson-Moskowitz parametric shape
  call spec % setSpectrum(piersonMoskowitz(spec % getFrequency(),wspd=wspd(n),&
                                           grav=grav))
  write(*,fmt='(9(f8.4,1x))')wspd(n),spec % significantWaveHeight(),&
    1./spec % peakFrequency(),spec % meanPeriod(),&
    spec % meanPeriodZeroCrossing(),spec % meanSquareSlope(),&
    spec % frequencyMoment(0),spec % frequencyMoment(1),&
    spec % frequencyMoment(2)
enddo

endprogram test_pierson_moskowitz


! analyze_soln.f90
! author: sunder

!-----------------------------------------------------------------------
! Find the LMAX error of the solution for peridic case and print it
!-----------------------------------------------------------------------

subroutine analyze_soln
    use ader_weno
    implicit none
    integer :: i, q
    double precision :: u_exact, xp
    double precision :: q0(nVar)
    double precision :: error(IMAX)

    do i = 1, IMAX
        u_exact = 0.0
        do q = 1, N+1
            xp = x(i) - 0.5*dx + dx*xGP(q)
            call initial_field(q0, xp)
            u_exact = u_exact + wGP(q)*q0(1)
        end do

        error(i) = abs(u_exact - uh(1,i))

    end do

    print *, 'Lmax = ', maxval(error)

end subroutine analyze_soln


      PROGRAM xcosft1
C     driver for routine cosft1
      INTEGER NP
      REAL EPS,PI,WIDTH
      PARAMETER(EPS=1.0E-3,NP=17,WIDTH=30.0,PI=3.14159)
      INTEGER i,j,nlim
      REAL big,per,scal,small,data(NP)
1     write(*,'(1x,a,i2,a)') 'Period of cosine in channels (2-',NP,')'
      read(*,*) per
      if (per.le.0.) stop
      do 11 i=1,NP
        data(i)=cos(2.0*PI*(i-1)/per)
11    continue
      call cosft1(data,NP-1)
      big=-1.0e10
      small=1.0e10
      do 12 i=1,NP
        if (data(i).lt.small) small=data(i)
        if (data(i).gt.big) big=data(i)
12    continue
      scal=WIDTH/(big-small)
      do 13 i=1,NP
        nlim=scal*(data(i)-small)+EPS
        write(*,'(1x,i2,f6.2,1x,60a1)') i,data(i),('*',j=1,nlim+1)
13    continue
      write(*,*) 'press continue ...'
      read(*,*)
      call cosft1(data,NP-1)
      big=-1.0e10
      small=1.0e10
      do 14 i=1,NP
        if (data(i).lt.small) small=data(i)
        if (data(i).gt.big) big=data(i)
14    continue
      scal=WIDTH/(big-small)
      do 15 i=1,NP
        nlim=scal*(data(i)-small)+EPS
        write(*,'(1x,i4,1x,60a1)') i,('*',j=1,nlim+1)
15    continue
      goto 1
      END

NR-Functions/Numerical Recipes- Example & Functions/Examples/xcosft1.for


! ::
! :: ----------------------------------------------------------
! ::
       subroutine pm_add_to_grav(lo, hi, point_mass,&
                                 phi,phi_lo,phi_hi, &
                                 grav,grav_lo,grav_hi, &
                                 problo,dx) &
                                 bind(C, name="pm_add_to_grav")

       use bl_constants_module         , only : HALF
       use fundamental_constants_module, only : Gconst
       use prob_params_module          , only : center

       use amrex_fort_module, only : rt => amrex_real
       implicit none
       integer         , intent(in   ) :: lo(3), hi(3)
       integer         , intent(in   ) :: grav_lo(3), grav_hi(3)
       integer         , intent(in   ) :: phi_lo(3), phi_hi(3)
       real(rt)        , intent(in   ) :: point_mass
       real(rt)        , intent(inout) :: phi(phi_lo(1):phi_hi(1),phi_lo(2):phi_hi(2),phi_lo(3):phi_hi(3))
       real(rt)        , intent(inout) :: grav(grav_lo(1):grav_hi(1),grav_lo(2):grav_hi(2),grav_lo(3):grav_hi(3),3)
       real(rt)        , intent(in   ) :: problo(3),dx(3)

       integer          :: i,j,k
       real(rt)         :: x,y,z,rsq,radial_force,rinv

!      This computes radial gravity due to a point mass at center().
       do k = lo(3), hi(3)
          z = problo(3) + (dble(k)+HALF) * dx(3) - center(3)
          do j = lo(2), hi(2)
             y = problo(2) + (dble(j)+HALF) * dx(2) - center(2)
             do i = lo(1), hi(1)
                x = problo(1) + (dble(i)+HALF) * dx(1) - center(1)

                rsq = x*x + y*y + z*z
                radial_force = -Gconst * point_mass / rsq

                rinv = 1.e0_rt/sqrt(rsq)

                ! Note that grav may have more ghost zones than
                ! phi, so we need to check that we're doing
                ! valid indexing here.

                if ( i .ge. phi_lo(1) .and. i .le. phi_hi(1) .and. &
                     j .ge. phi_lo(2) .and. j .le. phi_hi(2) .and. &
                     k .ge. phi_lo(3) .and. k .le. phi_hi(3) ) then

                   phi(i,j,k) = phi(i,j,k) - Gconst * point_mass * rinv

                endif

                grav(i,j,k,1) = grav(i,j,k,1) + radial_force * (x*rinv)
                grav(i,j,k,2) = grav(i,j,k,2) + radial_force * (y*rinv)
                grav(i,j,k,3) = grav(i,j,k,3) + radial_force * (z*rinv)

             end do
          end do
       end do

       end subroutine pm_add_to_grav

! :::
! ::: ------------------------------------------------------------------
! :::

      subroutine pm_compute_delta_mass(lo, hi, delta_mass, &
                                       uin, uin_lo, uin_hi, &
                                       uout, uout_lo, uout_hi, &
                                       vol,  vol_lo, vol_hi, &
                                       problo,dx,time,dt) &
                                       bind(C, name="pm_compute_delta_mass")

      use meth_params_module, only : NVAR, URHO
      use prob_params_module, only : center

      use amrex_fort_module, only : rt => amrex_real
      implicit none

      integer, intent(in) :: lo(3),      hi(3)
      integer, intent(in) :: uin_lo(3),  uin_hi(3)
      integer, intent(in) :: uout_lo(3), uout_hi(3)
      integer, intent(in) :: vol_lo(3),  vol_hi(3)

      real(rt), intent(inout) ::   delta_mass
      real(rt), intent(in) ::   uin(uin_lo(1):uin_hi(1),uin_lo(2):uin_hi(2),  &
                                  uin_lo(3):uin_hi(3),NVAR)
      real(rt), intent(in) ::  uout(uout_lo(1):uout_hi(1),uout_lo(2):uout_hi(2), &
                                  uout_lo(3):uout_hi(3),NVAR)
      real(rt), intent(in) ::   vol(vol_lo(1):vol_hi(1),vol_lo(2):vol_hi(2), &
                                  vol_lo(3):vol_hi(3))
      real(rt), intent(in) :: problo(3),dx(3),time,dt

      real(rt)           :: eps
      integer            :: ii,icen,istart,iend
      integer            :: jj,jcen,jstart,jend
      integer            :: kk,kcen,kstart,kend
      integer, parameter :: box_size = 2

      ! This is just a small number to keep precision issues from making
      !   icen,jcen,kcen one cell too low.
      eps = 1.e-8_rt

      ! This should be the cell whose lower left corner is at "center"
      icen = floor( (center(1)-problo(1))/dx(1) + eps)
      jcen = floor( (center(2)-problo(2))/dx(2) + eps)
      kcen = floor( (center(3)-problo(3))/dx(3) + eps)

      ! Make sure we only count contributions from this grid
      istart = max(icen-box_size, lo(1))
      jstart = max(jcen-box_size, lo(2))
      kstart = max(kcen-box_size, lo(3))

      iend = min(icen+box_size-1, hi(1))
      jend = min(jcen+box_size-1, hi(2))
      kend = min(kcen+box_size-1, hi(3))

      do kk = kstart,kend
         do jj = jstart,jend
            do ii = istart,iend
               delta_mass = delta_mass + vol(ii,jj,kk) * (uout(ii,jj,kk,URHO)-uin(ii,jj,kk,URHO))
            end do
         end do
      end do

      end subroutine pm_compute_delta_mass

! :::
! ::: ------------------------------------------------------------------
! :::

      subroutine pm_fix_solution(lo,hi, &
                                 uin,uin_lo,uin_hi, &
                                 uout,uout_lo,uout_hi, &
                                 problo,dx,time,dt) &
                                 bind(C, name="pm_fix_solution")

      use meth_params_module, only : NVAR
      use prob_params_module, only : center

      use amrex_fort_module, only : rt => amrex_real
      implicit none

      integer, intent(in) :: lo(3),      hi(3)
      integer, intent(in) :: uin_lo(3),  uin_hi(3)
      integer, intent(in) :: uout_lo(3), uout_hi(3)

      real(rt), intent(in)::   uin(  uin_lo(1):uin_hi(1),    uin_lo(2):uin_hi(2),  &
                                    uin_lo(3):uin_hi(3),NVAR)
      real(rt), intent(inout) ::  uout( uout_lo(1):uout_hi(1),  uout_lo(2):uout_hi(2), &
                                    uout_lo(3):uout_hi(3),NVAR)
      real(rt), intent(in) :: problo(3),dx(3),time,dt

      real(rt)           :: eps
      integer            :: ii,icen,istart,iend
      integer            :: jj,jcen,jstart,jend
      integer            :: kk,kcen,kstart,kend
      integer, parameter :: box_size = 2

      ! This is just a small number to keep precision issues from making
      !   icen,jcen,kcen one cell too low.
      eps = 1.e-8_rt

      ! This should be the cell whose lower left corner is at "center"
      icen = floor( (center(1)-problo(1))/dx(1) + eps)
      jcen = floor( (center(2)-problo(2))/dx(2) + eps)
      kcen = floor( (center(3)-problo(3))/dx(3) + eps)

      ! Make sure we only count contributions from this grid
      istart = max(icen-box_size, lo(1))
      jstart = max(jcen-box_size, lo(2))
      kstart = max(kcen-box_size, lo(3))

      iend = min(icen+box_size-1, hi(1))
      jend = min(jcen+box_size-1, hi(2))
      kend = min(kcen+box_size-1, hi(3))

      do kk = kstart,kend
         do jj = jstart,jend
            do ii = istart,iend
               uout(ii,jj,kk,:) = uin(ii,jj,kk,:)
            end do
         end do
      end do

      end subroutine pm_fix_solution