text:
! This file was automatically generated by SWIG (http://www.swig.org).
! Version 4.0.0
!
! Do not make changes to this file unless you know what you are doing--modify
! the SWIG interface file instead.

! ---------------------------------------------------------------
! Programmer(s): Auto-generated by swig.
! ---------------------------------------------------------------
! SUNDIALS Copyright Start
! Copyright (c) 2002-2019, Lawrence Livermore National Security
! and Southern Methodist University.
! All rights reserved.
!
! See the top-level LICENSE and NOTICE files for details.
!
! SPDX-License-Identifier: BSD-3-Clause
! SUNDIALS Copyright End
! ---------------------------------------------------------------

module fsunlinsol_klu_mod
 use, intrinsic :: ISO_C_BINDING
 use fsundials_linearsolver_mod
 use fsundials_types_mod
 use fsundials_nvector_mod
 use fsundials_types_mod
 use fsundials_matrix_mod
 use fsundials_nvector_mod
 use fsundials_types_mod
 implicit none
 private

 ! DECLARATION CONSTRUCTS
 integer(C_INT), parameter, public :: SUNKLU_ORDERING_DEFAULT = 1_C_INT
 integer(C_INT), parameter, public :: SUNKLU_REINIT_FULL = 1_C_INT
 integer(C_INT), parameter, public :: SUNKLU_REINIT_PARTIAL = 2_C_INT
 public :: FSUNLinSol_KLU
 public :: FSUNLinSol_KLUReInit
 public :: FSUNLinSol_KLUSetOrdering
 public :: FSUNKLU
 public :: FSUNKLUReInit
 public :: FSUNKLUSetOrdering

 integer, parameter :: swig_cmem_own_bit = 0
 integer, parameter :: swig_cmem_rvalue_bit = 1
 integer, parameter :: swig_cmem_const_bit = 2
 type, bind(C) :: SwigClassWrapper
  type(C_PTR), public :: cptr = C_NULL_PTR
  integer(C_INT), public :: cmemflags = 0
 end type
 type, public :: SWIGTYPE_p_klu_l_symbolic
  type(SwigClassWrapper), public :: swigdata
 end type
 public :: FSUNLinSol_KLUGetSymbolic
 type, public :: SWIGTYPE_p_klu_l_numeric
  type(SwigClassWrapper), public :: swigdata
 end type
 public :: FSUNLinSol_KLUGetNumeric
 type, public :: SWIGTYPE_p_klu_l_common
  type(SwigClassWrapper), public :: swigdata
 end type
 public :: FSUNLinSol_KLUGetCommon
 public :: FSUNLinSolGetType_KLU
 public :: FSUNLinSolGetID_KLU
 public :: FSUNLinSolInitialize_KLU
 public :: FSUNLinSolSetup_KLU
 public :: FSUNLinSolSolve_KLU
 public :: FSUNLinSolLastFlag_KLU
 public :: FSUNLinSolSpace_KLU
 public :: FSUNLinSolFree_KLU

! WRAPPER DECLARATIONS
interface
function swigc_FSUNLinSol_KLU(farg1, farg2) &
bind(C, name="_wrap_FSUNLinSol_KLU") &
result(fresult)
use, intrinsic :: ISO_C_BINDING
type(C_PTR), value :: farg1
type(C_PTR), value :: farg2
type(C_PTR) :: fresult
end function

function swigc_FSUNLinSol_KLUReInit(farg1, farg2, farg3, farg4) &
bind(C, name="_wrap_FSUNLinSol_KLUReInit") &
result(fresult)
use, intrinsic :: ISO_C_BINDING
type(C_PTR), value :: farg1
type(C_PTR), value :: farg2
integer(C_INT64_T), intent(in) :: farg3
integer(C_INT), intent(in) :: farg4
integer(C_INT) :: fresult
end function

function swigc_FSUNLinSol_KLUSetOrdering(farg1, farg2) &
bind(C, name="_wrap_FSUNLinSol_KLUSetOrdering") &
result(fresult)
use, intrinsic :: ISO_C_BINDING
type(C_PTR), value :: farg1
integer(C_INT), intent(in) :: farg2
integer(C_INT) :: fresult
end function

function swigc_FSUNKLU(farg1, farg2) &
bind(C, name="_wrap_FSUNKLU") &
result(fresult)
use, intrinsic :: ISO_C_BINDING
type(C_PTR), value :: farg1
type(C_PTR), value :: farg2
type(C_PTR) :: fresult
end function

function swigc_FSUNKLUReInit(farg1, farg2, farg3, farg4) &
bind(C, name="_wrap_FSUNKLUReInit") &
result(fresult)
use, intrinsic :: ISO_C_BINDING
type(C_PTR), value :: farg1
type(C_PTR), value :: farg2
integer(C_INT64_T), intent(in) :: farg3
integer(C_INT), intent(in) :: farg4
integer(C_INT) :: fresult
end function

function swigc_FSUNKLUSetOrdering(farg1, farg2) &
bind(C, name="_wrap_FSUNKLUSetOrdering") &
result(fresult)
use, intrinsic :: ISO_C_BINDING
type(C_PTR), value :: farg1
integer(C_INT), intent(in) :: farg2
integer(C_INT) :: fresult
end function

function swigc_FSUNLinSol_KLUGetSymbolic(farg1) &
bind(C, name="_wrap_FSUNLinSol_KLUGetSymbolic") &
result(fresult)
use, intrinsic :: ISO_C_BINDING
import :: swigclasswrapper
type(C_PTR), value :: farg1
type(SwigClassWrapper) :: fresult
end function

function swigc_FSUNLinSol_KLUGetNumeric(farg1) &
bind(C, name="_wrap_FSUNLinSol_KLUGetNumeric") &
result(fresult)
use, intrinsic :: ISO_C_BINDING
import :: swigclasswrapper
type(C_PTR), value :: farg1
type(SwigClassWrapper) :: fresult
end function

function swigc_FSUNLinSol_KLUGetCommon(farg1) &
bind(C, name="_wrap_FSUNLinSol_KLUGetCommon") &
result(fresult)
use, intrinsic :: ISO_C_BINDING
import :: swigclasswrapper
type(C_PTR), value :: farg1
type(SwigClassWrapper) :: fresult
end function

function swigc_FSUNLinSolGetType_KLU(farg1) &
bind(C, name="_wrap_FSUNLinSolGetType_KLU") &
result(fresult)
use, intrinsic :: ISO_C_BINDING
type(C_PTR), value :: farg1
integer(C_INT) :: fresult
end function

function swigc_FSUNLinSolGetID_KLU(farg1) &
bind(C, name="_wrap_FSUNLinSolGetID_KLU") &
result(fresult)
use, intrinsic :: ISO_C_BINDING
type(C_PTR), value :: farg1
integer(C_INT) :: fresult
end function

function swigc_FSUNLinSolInitialize_KLU(farg1) &
bind(C, name="_wrap_FSUNLinSolInitialize_KLU") &
result(fresult)
use, intrinsic :: ISO_C_BINDING
type(C_PTR), value :: farg1
integer(C_INT) :: fresult
end function

function swigc_FSUNLinSolSetup_KLU(farg1, farg2) &
bind(C, name="_wrap_FSUNLinSolSetup_KLU") &
result(fresult)
use, intrinsic :: ISO_C_BINDING
type(C_PTR), value :: farg1
type(C_PTR), value :: farg2
integer(C_INT) :: fresult
end function

function swigc_FSUNLinSolSolve_KLU(farg1, farg2, farg3, farg4, farg5) &
bind(C, name="_wrap_FSUNLinSolSolve_KLU") &
result(fresult)
use, intrinsic :: ISO_C_BINDING
type(C_PTR), value :: farg1
type(C_PTR), value :: farg2
type(C_PTR), value :: farg3
type(C_PTR), value :: farg4
real(C_DOUBLE), intent(in) :: farg5
integer(C_INT) :: fresult
end function

function swigc_FSUNLinSolLastFlag_KLU(farg1) &
bind(C, name="_wrap_FSUNLinSolLastFlag_KLU") &
result(fresult)
use, intrinsic :: ISO_C_BINDING
type(C_PTR), value :: farg1
integer(C_LONG) :: fresult
end function

function swigc_FSUNLinSolSpace_KLU(farg1, farg2, farg3) &
bind(C, name="_wrap_FSUNLinSolSpace_KLU") &
result(fresult)
use, intrinsic :: ISO_C_BINDING
type(C_PTR), value :: farg1
type(C_PTR), value :: farg2
type(C_PTR), value :: farg3
integer(C_INT) :: fresult
end function

function swigc_FSUNLinSolFree_KLU(farg1) &
bind(C, name="_wrap_FSUNLinSolFree_KLU") &
result(fresult)
use, intrinsic :: ISO_C_BINDING
type(C_PTR), value :: farg1
integer(C_INT) :: fresult
end function

end interface

contains
 ! MODULE SUBPROGRAMS
function FSUNLinSol_KLU(y, a) &
result(swig_result)
use, intrinsic :: ISO_C_BINDING
type(SUNLinearSolver), pointer :: swig_result
type(N_Vector), target, intent(inout) :: y
type(SUNMatrix), target, intent(inout) :: a
type(C_PTR) :: fresult
type(C_PTR) :: farg1
type(C_PTR) :: farg2

farg1 = c_loc(y)
farg2 = c_loc(a)
fresult = swigc_FSUNLinSol_KLU(farg1, farg2)
call c_f_pointer(fresult, swig_result)
end function

function FSUNLinSol_KLUReInit(s, a, nnz, reinit_type) &
result(swig_result)
use, intrinsic :: ISO_C_BINDING
integer(C_INT) :: swig_result
type(SUNLinearSolver), target, intent(inout) :: s
type(SUNMatrix), target, intent(inout) :: a
integer(C_INT64_T), intent(in) :: nnz
integer(C_INT), intent(in) :: reinit_type
integer(C_INT) :: fresult
type(C_PTR) :: farg1
type(C_PTR) :: farg2
integer(C_INT64_T) :: farg3
integer(C_INT) :: farg4

farg1 = c_loc(s)
farg2 = c_loc(a)
farg3 = nnz
farg4 = reinit_type
fresult = swigc_FSUNLinSol_KLUReInit(farg1, farg2, farg3, farg4)
swig_result = fresult
end function

function FSUNLinSol_KLUSetOrdering(s, ordering_choice) &
result(swig_result)
use, intrinsic :: ISO_C_BINDING
integer(C_INT) :: swig_result
type(SUNLinearSolver), target, intent(inout) :: s
integer(C_INT), intent(in) :: ordering_choice
integer(C_INT) :: fresult
type(C_PTR) :: farg1
integer(C_INT) :: farg2

farg1 = c_loc(s)
farg2 = ordering_choice
fresult = swigc_FSUNLinSol_KLUSetOrdering(farg1, farg2)
swig_result = fresult
end function

function FSUNKLU(y, a) &
result(swig_result)
use, intrinsic :: ISO_C_BINDING
type(SUNLinearSolver), pointer :: swig_result
type(N_Vector), target, intent(inout) :: y
type(SUNMatrix), target, intent(inout) :: a
type(C_PTR) :: fresult
type(C_PTR) :: farg1
type(C_PTR) :: farg2

farg1 = c_loc(y)
farg2 = c_loc(a)
fresult = swigc_FSUNKLU(farg1, farg2)
call c_f_pointer(fresult, swig_result)
end function

function FSUNKLUReInit(s, a, nnz, reinit_type) &
result(swig_result)
use, intrinsic :: ISO_C_BINDING
integer(C_INT) :: swig_result
type(SUNLinearSolver), target, intent(inout) :: s
type(SUNMatrix), target, intent(inout) :: a
integer(C_INT64_T), intent(in) :: nnz
integer(C_INT), intent(in) :: reinit_type
integer(C_INT) :: fresult
type(C_PTR) :: farg1
type(C_PTR) :: farg2
integer(C_INT64_T) :: farg3
integer(C_INT) :: farg4

farg1 = c_loc(s)
farg2 = c_loc(a)
farg3 = nnz
farg4 = reinit_type
fresult = swigc_FSUNKLUReInit(farg1, farg2, farg3, farg4)
swig_result = fresult
end function

function FSUNKLUSetOrdering(s, ordering_choice) &
result(swig_result)
use, intrinsic :: ISO_C_BINDING
integer(C_INT) :: swig_result
type(SUNLinearSolver), target, intent(inout) :: s
integer(C_INT), intent(in) :: ordering_choice
integer(C_INT) :: fresult
type(C_PTR) :: farg1
integer(C_INT) :: farg2

farg1 = c_loc(s)
farg2 = ordering_choice
fresult = swigc_FSUNKLUSetOrdering(farg1, farg2)
swig_result = fresult
end function

function FSUNLinSol_KLUGetSymbolic(s) &
result(swig_result)
use, intrinsic :: ISO_C_BINDING
type(SWIGTYPE_p_klu_l_symbolic) :: swig_result
type(SUNLinearSolver), target, intent(inout) :: s
type(SwigClassWrapper) :: fresult
type(C_PTR) :: farg1

farg1 = c_loc(s)
fresult = swigc_FSUNLinSol_KLUGetSymbolic(farg1)
swig_result%swigdata = fresult
end function

function FSUNLinSol_KLUGetNumeric(s) &
result(swig_result)
use, intrinsic :: ISO_C_BINDING
type(SWIGTYPE_p_klu_l_numeric) :: swig_result
type(SUNLinearSolver), target, intent(inout) :: s
type(SwigClassWrapper) :: fresult
type(C_PTR) :: farg1

farg1 = c_loc(s)
fresult = swigc_FSUNLinSol_KLUGetNumeric(farg1)
swig_result%swigdata = fresult
end function

function FSUNLinSol_KLUGetCommon(s) &
result(swig_result)
use, intrinsic :: ISO_C_BINDING
type(SWIGTYPE_p_klu_l_common) :: swig_result
type(SUNLinearSolver), target, intent(inout) :: s
type(SwigClassWrapper) :: fresult
type(C_PTR) :: farg1

farg1 = c_loc(s)
fresult = swigc_FSUNLinSol_KLUGetCommon(farg1)
swig_result%swigdata = fresult
end function

function FSUNLinSolGetType_KLU(s) &
result(swig_result)
use, intrinsic :: ISO_C_BINDING
integer(SUNLinearSolver_Type) :: swig_result
type(SUNLinearSolver), target, intent(inout) :: s
integer(C_INT) :: fresult
type(C_PTR) :: farg1

farg1 = c_loc(s)
fresult = swigc_FSUNLinSolGetType_KLU(farg1)
swig_result = fresult
end function

function FSUNLinSolGetID_KLU(s) &
result(swig_result)
use, intrinsic :: ISO_C_BINDING
integer(SUNLinearSolver_ID) :: swig_result
type(SUNLinearSolver), target, intent(inout) :: s
integer(C_INT) :: fresult
type(C_PTR) :: farg1

farg1 = c_loc(s)
fresult = swigc_FSUNLinSolGetID_KLU(farg1)
swig_result = fresult
end function

function FSUNLinSolInitialize_KLU(s) &
result(swig_result)
use, intrinsic :: ISO_C_BINDING
integer(C_INT) :: swig_result
type(SUNLinearSolver), target, intent(inout) :: s
integer(C_INT) :: fresult
type(C_PTR) :: farg1

farg1 = c_loc(s)
fresult = swigc_FSUNLinSolInitialize_KLU(farg1)
swig_result = fresult
end function

function FSUNLinSolSetup_KLU(s, a) &
result(swig_result)
use, intrinsic :: ISO_C_BINDING
integer(C_INT) :: swig_result
type(SUNLinearSolver), target, intent(inout) :: s
type(SUNMatrix), target, intent(inout) :: a
integer(C_INT) :: fresult
type(C_PTR) :: farg1
type(C_PTR) :: farg2

farg1 = c_loc(s)
farg2 = c_loc(a)
fresult = swigc_FSUNLinSolSetup_KLU(farg1, farg2)
swig_result = fresult
end function

function FSUNLinSolSolve_KLU(s, a, x, b, tol) &
result(swig_result)
use, intrinsic :: ISO_C_BINDING
integer(C_INT) :: swig_result
type(SUNLinearSolver), target, intent(inout) :: s
type(SUNMatrix), target, intent(inout) :: a
type(N_Vector), target, intent(inout) :: x
type(N_Vector), target, intent(inout) :: b
real(C_DOUBLE), intent(in) :: tol
integer(C_INT) :: fresult
type(C_PTR) :: farg1
type(C_PTR) :: farg2
type(C_PTR) :: farg3
type(C_PTR) :: farg4
real(C_DOUBLE) :: farg5

farg1 = c_loc(s)
farg2 = c_loc(a)
farg3 = c_loc(x)
farg4 = c_loc(b)
farg5 = tol
fresult = swigc_FSUNLinSolSolve_KLU(farg1, farg2, farg3, farg4, farg5)
swig_result = fresult
end function

function FSUNLinSolLastFlag_KLU(s) &
result(swig_result)
use, intrinsic :: ISO_C_BINDING
integer(C_LONG) :: swig_result
type(SUNLinearSolver), target, intent(inout) :: s
integer(C_LONG) :: fresult
type(C_PTR) :: farg1

farg1 = c_loc(s)
fresult = swigc_FSUNLinSolLastFlag_KLU(farg1)
swig_result = fresult
end function

function FSUNLinSolSpace_KLU(s, lenrwls, leniwls) &
result(swig_result)
use, intrinsic :: ISO_C_BINDING
integer(C_INT) :: swig_result
type(SUNLinearSolver), target, intent(inout) :: s
integer(C_LONG), dimension(*), target, intent(inout) :: lenrwls
integer(C_LONG), dimension(*), target, intent(inout) :: leniwls
integer(C_INT) :: fresult
type(C_PTR) :: farg1
type(C_PTR) :: farg2
type(C_PTR) :: farg3

farg1 = c_loc(s)
farg2 = c_loc(lenrwls(1))
farg3 = c_loc(leniwls(1))
fresult = swigc_FSUNLinSolSpace_KLU(farg1, farg2, farg3)
swig_result = fresult
end function

function FSUNLinSolFree_KLU(s) &
result(swig_result)
use, intrinsic :: ISO_C_BINDING
integer(C_INT) :: swig_result
type(SUNLinearSolver), target, intent(inout) :: s
integer(C_INT) :: fresult
type(C_PTR) :: farg1

farg1 = c_loc(s)
fresult = swigc_FSUNLinSolFree_KLU(farg1)
swig_result = fresult
end function

end module

max_stars_repo_name: xantares/sundials

max_issues_repo_name: xantares/sundials

max_forks_repo_name: xantares/sundials


text:
! -*- f90 -*-
!
! Copyright (c) 2009-2012 Cisco Systems, Inc.  All rights reserved.
! Copyright (c) 2009-2012 Los Alamos National Security, LLC.
!               All Rights reserved.
! $COPYRIGHT$

   ! This wrapper mimics how the MPI_Recv_wrapper will eventually work.
   ! Eventually buf will be typed, TYPE(*), DIMENSION(..)
   ! Now can only mimic with explicit type and rank for assumed-shape dummy
   ! arguments.
   !
   subroutine MPI_Recv_f08_desc_int_2d(buf,count,datatype,source,tag,comm,status,ierror)
      use :: OMPI_Fortran_binding
      implicit none
      integer, INTENT(IN), target :: buf(:,:)
      INTEGER, INTENT(IN) :: count, source, tag
      TYPE(MPI_Datatype), INTENT(IN) :: datatype
      TYPE(MPI_Comm), INTENT(IN) :: comm
      TYPE(MPI_Status), INTENT(OUT) :: status
      INTEGER, OPTIONAL, INTENT(OUT) :: ierror

      integer :: c_ierror
      type(CFI_cdesc_t) :: buf_desc

      call make_desc_f(buf, buf_desc)
      !call print_desc(buf_desc)

      call ompi_recv_f08_desc_f(buf_desc, count, datatype%MPI_VAL, source, tag, comm%MPI_VAL, status, c_ierror)

      if (present(ierror)) ierror = c_ierror

   end subroutine MPI_Recv_f08_desc_int_2d

! WARNING, not yet implemented, stub used to test MPI_SUBARRAYS_SUPPORTED usage
!
   subroutine MPI_Recv_f08_desc_dbl_1d(buf,count,datatype,source,tag,comm,status,ierror)
      use :: OMPI_Fortran_binding
      implicit none
      double precision, INTENT(IN), target :: buf(:)
      INTEGER, INTENT(IN) :: count, source, tag
      TYPE(MPI_Datatype), INTENT(IN) :: datatype
      TYPE(MPI_Comm), INTENT(IN) :: comm
      TYPE(MPI_Status), INTENT(OUT) :: status
      INTEGER, OPTIONAL, INTENT(OUT) :: ierror

      integer :: c_ierror

      ! this hack is to remove compiler warning about no change to out variable
      status = MPI_STATUS_IGNORE

      c_ierror = 1
      print *, "WARNING, testing of double precision arrays not yet supported with subarrays"

      if (present(ierror)) ierror = c_ierror

   end subroutine MPI_Recv_f08_desc_dbl_1d

! WARNING, not yet implemented, stub used to test MPI_SUBARRAYS_SUPPORTED usage
!
   subroutine MPI_Recv_f08_desc_dbl_0d(buf,count,datatype,source,tag,comm,status,ierror)
      use :: OMPI_Fortran_binding
      implicit none
      double precision, INTENT(IN), target :: buf
      INTEGER, INTENT(IN) :: count, source, tag
      TYPE(MPI_Datatype), INTENT(IN) :: datatype
      TYPE(MPI_Comm), INTENT(IN) :: comm
      TYPE(MPI_Status), INTENT(OUT) :: status
      INTEGER, OPTIONAL, INTENT(OUT) :: ierror

      integer :: c_ierror

      ! this hack is to remove compiler warning about no change to out variable
      status = MPI_STATUS_IGNORE

      c_ierror = 1
      print *, "WARNING, testing of double precision arrays not yet supported with subarrays"

      if (present(ierror)) ierror = c_ierror

   end subroutine MPI_Recv_f08_desc_dbl_0d

max_stars_repo_name: urids/XSCALAMPI

max_issues_repo_name: urids/XSCALAMPI

max_forks_repo_name: urids/XSCALAMPI


text:
!==============================================================================!
  subroutine eos(dens_0, dens_1)
!------------------------------------------------------------------------------!
! Applies equation of state for Moin model problems                            !
!------------------------------------------------------------------------------!
!----------------------------------[Modules]-----------------------------------!
  use all_mod
  use pro_mod
  use les_mod
  use rans_mod
  use par_mod
  use Moin_Problem_mod !  module to control conflicting Moin modules
!------------------------------------------------------------------------------!
  implicit none
!---------------------------------[Parameters]---------------------------------!
  real,          intent (in) :: dens_0, dens_1 ! dens_0 >= dens_1
!-----------------------------------[Locals]-----------------------------------!
  integer :: c
!==============================================================================!

  !------------------!
  !   applying EOS   !
  !------------------!

  select case (Moin_Problem())
  case (4) ! RT
    do c = 1, NC
      rho % n(c) =  1.0 / ( 9.0*zmix % n(c) + 1.0)
    end do
  case (10)
    do c = 1, NC
      rho % n(c) = Moin_Problem_EOS (zmix % n(c))
    end do
  case (30)
    do c = 1, NC
      rho % n(c) = Moin_Problem_EOS (zmix % n(c))
    end do
  case default
    do c = 1, NC
      rho % n(c) = 1.0 / ( (zmix % n(c)/dens_1) + (1.0-zmix % n(c))/dens_0 )
    end do
  end select

  !--------------------------------------------------!
  !   applying BC and updating dependent variables   !
  !--------------------------------------------------!

  call CalcDens(rho,.FALSE.,dens_0,dens_1,Moin_Problem())  ! update other variables and apply BC

  !updating dynamic viscosity
  select case (Moin_Problem())
!    case (10)
!        do c = 1, NC
!            visc_dyn(c)     = Moin_Problem_visc_dyn_of_Z(zmix % n(c)) / 224.28074617774
!            visczmix_dyn(c) = visc_dyn(c) / 0.7
!        end do
    !VISc                = minval(visc_dyn)
    !visczmix            = minval(visczmix_dyn)
  end select

  !-----------------------------!
  !   Applying EOS to borders   !
  !-----------------------------!

  select case (Moin_Problem())
  case (4) ! RT
    do c = -NbC,-1
      rho % n(c) =  1.0/( 9.0*zmix % n(c) + 1.0)
    end do
  case (10)
    do c = -NbC,-1
      rho % n(c) = Moin_Problem_EOS (zmix % n(c))
    end do
  case (30)
    do c = -NbC,-1
      rho % n(c) = Moin_Problem_EOS (zmix % n(c))
    end do
  case default
    do c = -NbC,-1
      rho % n(c) = 1.0/( (zmix % n(c)/dens_1) + (1.0-zmix % n(c))/dens_0 )
    end do
  end select

  select case (Moin_Problem())
!    case (10)
!        do c = -NbC, 1
!            visc_dyn(c)     = Moin_Problem_visc_dyn_of_Z(zmix % n(c)) / 224.28074617774
!            visczmix_dyn(c) = visc_dyn(c) / 0.7
!        end do
    !VISc                = minval(visc_dyn)
    !visczmix            = minval(visczmix_dyn)

    !write (*,*) "MIN(visc_dyn)    =", minval(visc_dyn), "visc_dyn(1)=", visc_dyn(1)
    !write (*,*) "MIN(visczmix_dYn)=", minval(visczmix_dyn)
  end select

  !--------------------------------------------------!
  !   applying BC and updating dependent variables   !
  !--------------------------------------------------!
  call wait
  call Exchng(rho % n) !main source for rho presicion
  call Exchng(visc_dyn)
  call Exchng(visczmix_dyn)

end subroutine eos

! if(this < 2) open(991, FILE="out.dat", status='replace', access="sequential", position='append', action='write')
! z_test = 0.0
! do
!     write(991,'(2ES26.16E3)') z_test, Moin_Problem_EOS(z_test)
!     if ( abs (z_test - 1.0) < 1.D-15 ) exit
!     z_test = z_test + 0.001
! end do
! if(this < 2) close(991)

max_stars_repo_name: palkinev/T-FlowS-old-compressible

max_issues_repo_name: palkinev/T-FlowS-old-compressible

max_forks_repo_name: palkinev/T-FlowS-old-compressible


!----------------------------------------------------------------------------------
!:sdoc+:
!
! CSEM_WaterIR_SfcOptics
!
! Module to compute the surface optical properties of Water surfaces at infrared
! frequencies, which is required for determining the Water surface contribution
! to the overall radiative transfer.
!
! This module provide a general container for developers to integrate individual
! models into the model repository, and a generic interface for
! the upper-level applications to access the model options in the repository.
!
! This module implementes the FWD, TL and AD functions for variational data
! assimilation application and retrieval applications. It replacess the similar
! functions as those in the original CRTM surface module "CRTM_WaterIR_SfcOptics",
! which was Written by Paul van Delst, 23-Jun-2005
!
!
! CREATION HISTORY:
!       Written by:     Ming Chen, 28-Feb-2016
!                       ming.chen@noaa.gov
!:sdoc-:
!-----------------------------------------------------------------------------------------------
!
!
!

MODULE CSEM_WaterIR_SfcOptics

  ! -----------------
  ! Environment setup
  ! -----------------
  ! Module use
  USE CSEM_Type_Kinds, ONLY: fp => CSEM_fp
  USE CSEM_Define
  USE CSEM_Model_Manager
  USE CSEM_Exception_Handler

  USE NPOESS_LUT_Module
  USE NESDIS_WaterIR_PhyModel, ONLY: IRSSEM_BRDF_Type =>iVar_type, &
                                NESDIS_IRSSEM_BRDF,&
                                NESDIS_IRSSEM_BRDF_TL,&
                                NESDIS_IRSSEM_BRDF_AD,&
                                NESDIS_IRSSEM_Setup, &
                                NESDIS_IRSSEM_Close, &
                                NESDIS_IRSSEM_Initialized
  USE NESDIS_WaterIR_PhyModel_V2, ONLY: IRSSEM_BRDF_V2_Type =>iVar_type, &
                                NESDIS_IRSSEM_BRDF_V2,&
                                NESDIS_IRSSEM_BRDF_V2_TL,&
                                NESDIS_IRSSEM_BRDF_V2_AD,&
                                NESDIS_IRSSEM_V2_Setup, &
                                NESDIS_IRSSEM_V2_Close, &
                                NESDIS_IRSSEM_V2_Initialized
  !Disable implicit typing
  IMPLICIT NONE

  ! ------------
  ! Visibilities
  ! ------------
  ! Everything private by default
  PRIVATE
  ! Data types
  ! Science routines
  PUBLIC :: CSEM_Compute_WaterIR_SfcOptics
  PUBLIC :: CSEM_Compute_WaterIR_SfcOptics_TL
  PUBLIC :: CSEM_Compute_WaterIR_SfcOptics_AD
  PUBLIC :: iVar_type

  REAL(fp), PARAMETER ::  ONE = 1.0_fp, ZERO = 0.0_fp
  REAL(fp), PARAMETER ::  PI  = 3.141592653589793238462643_fp
  REAL(fp), PARAMETER ::  D2R  = PI/180.0_fp
  INTEGER,  PARAMETER ::  MAX_n_Angles = 15
  ! --------------------------------------
  ! Structure definition to hold forward
  ! variables across FWD, TL, and AD calls
  ! --------------------------------------
  TYPE :: iVar_type
    PRIVATE
    INTEGER :: n_Angles
    ! Variables in routines rough sea BRDF
    TYPE(IRSSEM_BRDF_V2_type)   :: IRSSEM_BRDF_V2
    TYPE(IRSSEM_BRDF_type)      :: IRSSEM_BRDF
    CHARACTER(LEN=256)          :: AlgID
    LOGICAL                     :: VALID_RTTOV_ALG = .FALSE.
  END TYPE iVar_type

  TYPE(CSEM_MODEL_ID),SAVE :: MODEL

CONTAINS

!----------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       CSEM_Compute_WaterIR_SfcOptics
!
! PURPOSE:
!       Function to compute the surface emissivity and reflectivity at Infrared
!       frequencies over a Water surface.
!
!       This function is a wrapper for third party code.
!
! PURPOSE:
!       Function to compute the surface emissivity  at Ifrared
!       frequencies over a Water surface.
!
!       This function encapsulates all available  CSEM WaterIR emissivity models,and
!       provides a genereic interface for the upper-level user application.
!
! CALLING SEQUENCE:
!       IO_Status = CSEM_Compute_WaterIR_SfcOptics(
!                                        Surface                  ,&  ! Input
!                                        SfcOptics                ,&  ! Output
!                                        Options )                       ! OptionalInput
!
! INPUTS:
!
!       Surface:         CSEM Water Surface structure containing the surface state
!                        data.
!                        UNITS:      N/A
!                        TYPE:       CSEM_Water_Surface
!                        DIMENSION:  Scalar
!                        ATTRIBUTES: INTENT(IN)
!
!       Options:            CSEM input extension structure containing additional inputs,
!                        e.g., Gelocation/Time Metadata,  Sensor observations, et al,
!                        which may be used by emprirical and semi-empirical models.
!                        UNITS:      N/A
!                        TYPE:       INTEGER
!                        DIMENSION:  Scalar
!                        ATTRIBUTES: INTENT(IN)
!
!
! OUTPUTS:
!       SfcOptics:       CSEM output structure containing the surface optical
!                        properties required for the radiative transfer calculation,
!                        including wavelength and geometry structure as the inputs
!                        UNITS:      N/A
!                        TYPE:       CSEM_SfcOptics_Type
!                        DIMENSION:  Assumed-shape Array
!                        ATTRIBUTES: INTENT(IN OUT)
! FUNCTION RESULT:
!       IO_Status:    The return value is an integer defining the error status.
!                        The error codes are defined in the CSEM_Exception_Handler module.
!                        If == SUCCESS the computation was sucessful
!                           == FAILURE an unrecoverable error occurred
!                        UNITS:      N/A
!                        TYPE:       INTEGER
!                        DIMENSION:  Scalar
!
!
! COMMENTS:
!                       CSEM infrastructure data structures are defined in CSEM_DEFINE.f90
!
!
!:sdoc-:
!-----------------------------------------------------------------------------------------------

  FUNCTION CSEM_Compute_WaterIR_SfcOptics(  &
      Surface,                              &  ! Input
      SfcOptics,                            &  ! Output
      Options,                              &  ! Optional Input
      iVar)                                 &  ! Input
    RESULT (IO_Status)

    TYPE(CSEM_Water_Surface),  INTENT(IN)    ::  Surface
    TYPE(CSEM_SfcOptics_Type), INTENT(INOUT) ::  SfcOptics
    TYPE(CSEM_Options_Type),   INTENT(IN)    ::  Options
    TYPE(iVar_type),           INTENT(OUT)   ::  iVar
    ! Function result
    INTEGER ::  IO_Status

    ! Local parameters
    CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'CSEM_Compute_WaterIR_SfcOptics'
    CHARACTER(LEN=256) :: Message
    ! Local variables
    CHARACTER(LEN=256) :: DB_PATH, IRSSEM_File
    REAL(fp) ::  Emiss,  Direct_Refl
    REAL(fp) ::  Sensor_Zenith_Radian, Sensor_Azimuth_Radian
    REAL(fP) ::  Solar_Zenith_Radian,  Solar_Azimuth_Radian

    INTEGER  ::  i, nZ, stype
    CHARACTER(LEN=100)    ::   CRTM_Sensor_Id

    REAL(fP) ::  Emissivity(MAX_n_Angles), Reflectivity(MAX_n_Angles)
    REAL(fP) ::  Direct_Reflectivity(MAX_n_Angles)

    IO_Status  = SUCCESS

    Sensor_Zenith_Radian   =  D2R * SfcOptics%Sensor_Zenith_Angle
    Sensor_Azimuth_Radian  =  D2R * SfcOptics%Sensor_Azimuth_Angle
    Solar_Zenith_Radian    =  D2R * SfcOptics%Source_Zenith_Angle
    Solar_Azimuth_Radian   =  D2R * SfcOptics%Source_Azimuth_Angle
    Direct_Refl    =  ZERO

    nZ = SfcOptics%n_Angles

    MODEL = Inq_Model_Option("IR_WATER")
    ! use path in CSEM alg registor file
    DB_PATH = TRIM(MODEL%DATA_PATH)
    iVar%AlgID = TRIM(MODEL%NAME)

    CRTM_Sensor_Id  = TRIM(Options%SensorObs%Sensor_Id)

    IF(TRIM(MODEL%NAME) .EQ. 'NPOESS_LUT' ) THEN
        IF(Surface%Water_Type /= 1) THEN
          PRINT*,'NPOESS_LUT Water Type 1'
          IO_Status  = FAILURE
          RETURN
        ENDIF
        Stype =  Surface%Water_Type + 20
        IO_Status = NPOESS_LUT_Emiss(    &
            SfcOptics%Wavenumber,        & ! INPUT, wavelength in micrometer
            Emiss ,                      & ! OUTPUT, surface emissivity (0 - 1)
            Stype)                         ! INPUT, surface type (1)

        SfcOptics%Emissivity           =   Emiss
        SfcOptics%Reflectivity         =   ONE-Emiss
        SfcOptics%Direct_Reflectivity  =   Direct_Refl

    ELSE IF((TRIM(iVar%AlgID) .EQ. "NESDIS_IRW_NalliV2CM") .OR. &
          (TRIM(iVar%AlgID) .EQ. "NESDIS_IRW_NalliV2EK") ) THEN

       IF(.NOT. NESDIS_IRSSEM_V2_Initialized()) THEN
          IF(TRIM(iVar%AlgID) .EQ. "NESDIS_IRW_NalliV2CM") THEN
            IRSSEM_File = 'Nalli.IRwater.EmisCoeff.V2.CM.nc'
          ELSE
          !"NESDIS_IRW_WuSmith"
            IRSSEM_File = 'Nalli.IRwater.EmisCoeff.V2.EK.nc'
          END IF
          IO_Status = NESDIS_IRSSEM_V2_Setup(TRIM(DB_PATH)//'/'//TRIM(IRSSEM_File))
       END IF

       IF(SfcOptics%Is_Solar) THEN

          IO_Status = NESDIS_IRSSEM_BRDF_V2(               &
                  SfcOptics%Wavenumber                   , &  ! Input
                  Surface%Wind_Speed                     , &  ! Input
                  Surface%Water_Temperature              , &  ! Input
                  SfcOptics%Angle                        , &  ! Input
                  Sensor_Zenith_Radian                   , &  ! Input
                  Sensor_Azimuth_Radian                  , &  ! Input
                  Solar_Zenith_Radian                    , &  ! Input
                  Solar_Azimuth_Radian                   , &  ! Input
                  Emissivity(1:nZ)                       , &  ! Output
                  Reflectivity(1:nZ)                     , &  ! Output
                  Direct_Reflectivity (1:nZ)             , &  ! Output
                  iVar%IRSSEM_BRDF_V2 )
        ELSE
          IO_Status = NESDIS_IRSSEM_BRDF_V2( &
                  SfcOptics%Wavenumber                   , &  ! Input
                  Surface%Wind_Speed                     , &  ! Input
                  Surface%Water_Temperature              , &  ! Input
                  SfcOptics%Angle                        , &  ! Input
                  Emissivity(1:nZ)                       , &  ! Output
                  Reflectivity(1:nZ)                     , &  ! Output
                  iVar%IRSSEM_BRDF_V2)

       END IF

       DO I = 1, NZ
        SfcOptics%Emissivity(i,1)   = Emissivity(i)
        SfcOptics%Reflectivity(i,1,i,1) = Reflectivity(i)
        SfcOptics%Direct_Reflectivity(i,1) = Direct_Reflectivity(i)
       ENDDO

       IF ( IO_Status /= SUCCESS ) THEN
            Message = 'Error occurred in forward'
            CALL Display_Message( ROUTINE_NAME, Message, IO_Status );
       END IF

    ELSE
       IF((TRIM(MODEL%NAME) .NE. "NESDIS_IRW_WuSmith") .AND. &
          (TRIM(MODEL%NAME) .NE. "NESDIS_IRW_Nalli") ) THEN
         iVar%AlgID = "NESDIS_IRW_WuSmith"
         DB_PATH = TRIM(GET_DATA_PATH('IR_WATER','NESDIS_IRW_WuSmith'))
        ENDIF

       IF(.NOT. NESDIS_IRSSEM_Initialized()) THEN
          IF(TRIM(iVar%AlgID) .EQ. "NESDIS_IRW_Nalli") THEN
            IRSSEM_File = 'Nalli.IRwater.EmisCoeff.nc'
          ELSE
          !"NESDIS_IRW_WuSmith"
            IRSSEM_File = 'WuSmith.IRwater.EmisCoeff.nc'
          END IF
          IO_Status = NESDIS_IRSSEM_Setup(TRIM(DB_PATH)//'/'//TRIM(IRSSEM_File))
       END IF

       IF(SfcOptics%Is_Solar) THEN
          IO_Status = NESDIS_IRSSEM_BRDF(                  &
                  SfcOptics%Wavenumber                   , &  ! Input
                  Surface%Wind_Speed                     , &  ! Input
                  SfcOptics%Angle                        , &  ! Input
                  Sensor_Zenith_Radian                   , &  ! Input
                  Sensor_Azimuth_Radian                  , &  ! Input
                  Solar_Zenith_Radian                    , &  ! Input
                  Solar_Azimuth_Radian                   , &  ! Input
                  Emissivity(1:nZ)                       , &  ! Output
                  Reflectivity(1:nZ)                     , &  ! Output
                  Direct_Reflectivity (1:nZ)             , &  ! Output
                  iVar%IRSSEM_BRDF )
        ELSE
          IO_Status = NESDIS_IRSSEM_BRDF( &
                  SfcOptics%Wavenumber                   , &  ! Input
                  Surface%Wind_Speed                     , &  ! Input
                  SfcOptics%Angle                        , &  ! Input
                  Emissivity(1:nZ)                       , &  ! Output
                  Reflectivity(1:nZ)                     , &  ! Output
                  iVar%IRSSEM_BRDF)

       END IF

       DO I = 1, NZ
        SfcOptics%Emissivity(i,1)   = Emissivity(i)
        SfcOptics%Reflectivity(i,1,i,1) = Reflectivity(i)
        SfcOptics%Direct_Reflectivity(i,1) = Direct_Reflectivity(i)
       ENDDO

       IF ( IO_Status /= SUCCESS ) THEN
            Message = 'Error occurred in forward'
            CALL Display_Message( ROUTINE_NAME, Message, IO_Status );
       END IF

    END IF

  END FUNCTION CSEM_Compute_WaterIR_SfcOptics

!----------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       CSEM_Compute_WaterIR_SfcOptics_TL
!
! PURPOSE:
!       Function to compute the tangent-linear surface emissivity and
!       reflectivity at infrared frequencies over a Water surface.
!
!       This function is a wrapper for third party code.
!
!
! CALLING SEQUENCE:
!       IO_Status = CSEM_Compute_WaterIR_SfcOptics_TL( SfcOptics_TL )
!
! INPUTS:
!
!         Surface_TL:    Structure containing the tagent-linear surface state
!                        variables required for the adjoint radiative
!                        transfer calculation.
!                        *** COMPONENTS MODIFIED UPON OUTPUT ***
!                        UNITS:      N/A
!                        TYPE:       CSEM_SfcOptics_Type
!                        DIMENSION:  Scalar
!                        ATTRIBUTES: INTENT(IN OUT)
! OUTPUTS:
!
!        SfcOptics_TL:   Structure containing the tangent-linear surface
!                        optical properties required for the tangent-
!                        linear radiative transfer calculation.
!                        UNITS:      N/A
!                        TYPE:       CSEM_SfcOptics_Type
!                        DIMENSION:  Assumed-shape Array
!                        ATTRIBUTES: INTENT(IN OUT)
!
! FUNCTION RESULT:
!       IO_Status:       The return value is an integer defining the error status.
!                        The error codes are defined in the Message_Handler module.
!                        If == SUCCESS the computation was sucessful
!                           == FAILURE an unrecoverable error occurred
!                        UNITS:      N/A
!                        TYPE:       INTEGER
!                        DIMENSION:  Scalar
!
! COMMENTS:
!
!:sdoc-:
!----------------------------------------------------------------------------------

 FUNCTION CSEM_Compute_WaterIR_SfcOptics_TL(   &
       Surface_TL,                            &  ! Input
       SfcOptics_TL,                          &  ! Output
       iVar)                                  &  ! Internal variable input
   RESULT ( IO_Status  )
    ! Arguments
    TYPE(CSEM_Water_Surface),  INTENT(IN)     :: Surface_TL
    TYPE(CSEM_SfcOptics_Type), INTENT(INOUT)  :: SfcOptics_TL
    TYPE(iVar_type),           INTENT(IN)     :: iVar

   ! Function result
    INTEGER :: IO_Status
    ! Local parameters
    CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'CSEM_Compute_WaterIR_SfcOptics_TL'
    ! Local variables
    INTEGER :: i,nZ

    REAL(fp) :: Emissivity_TL(MAX_n_Angles), Reflectivity_TL(MAX_n_Angles)
    REAL(fp) :: Direct_Reflectivity_TL(MAX_n_Angles)

    ! Set up
    IO_Status  = SUCCESS

    nZ = SfcOptics_TL%n_Angles

    Emissivity_TL          =  ZERO
    Reflectivity_TL        =  ZERO
    Direct_Reflectivity_TL =  ZERO

    IF(TRIM(ivar%AlgID) .EQ. 'NPOESS_LUT' ) THEN

    ELSE IF((TRIM(iVar%AlgID) .EQ. "NESDIS_IRW_NalliV2CM") .OR. &
          (TRIM(iVar%AlgID) .EQ. "NESDIS_IRW_NalliV2EK") ) THEN
        IO_Status = NESDIS_IRSSEM_BRDF_V2_TL(            &
                        Surface_TL%Wind_Speed          , &  ! Input
                        Surface_TL%Water_Temperature   , &  ! Input
                        Emissivity_TL(1:nZ)            , &  ! Output
                        Reflectivity_TL(1:nZ)          , &  ! Output
                        Direct_Reflectivity_TL(1:nZ)   , &  ! output
                        iVar%IRSSEM_BRDF_V2        )  ! Internal variable input
        IF ( IO_Status /= SUCCESS ) THEN
           CALL Display_Message( ROUTINE_NAME, &
                           'Error computing Tangent_linear IR sea surface emissivity', &
                            IO_Status  )
           RETURN
        END IF

    ELSE
        !Compute tangent-linear IR sea surface emissivity
        IO_Status = NESDIS_IRSSEM_BRDF_TL(               &
                        Surface_TL%Wind_Speed          , &  ! Input
                        Emissivity_TL(1:nZ)            , &  ! Output
                        Reflectivity_TL(1:nZ)          , &  ! Output
                        Direct_Reflectivity_TL(1:nZ)   , &  ! output
                        iVar%IRSSEM_BRDF        )  ! Internal variable input
        IF ( IO_Status /= SUCCESS ) THEN
           CALL Display_Message( ROUTINE_NAME, &
                           'Error computing Tangent_linear IR sea surface emissivity', &
                            IO_Status  )
           RETURN
        END IF

    END IF
    DO i=1,nZ
      SfcOptics_TL%Emissivity(i,1)          =  Emissivity_TL(i)
      SfcOptics_TL%Reflectivity(i,1,i,1)    =  Reflectivity_TL(i)
      SfcOptics_TL%Direct_Reflectivity(i,1) =  Direct_Reflectivity_TL(i)
    END DO

  END FUNCTION CSEM_Compute_WaterIR_SfcOptics_TL

!----------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       CSEM_Compute_WaterIR_SfcOptics_AD
!
! PURPOSE:
!       Function to compute the adjoint surface emissivity and
!       reflectivity at infrared frequencies over a Water surface.
!
!       This function is a wrapper for third party code.
!
!       NB: CURRENTLY THIS IS A STUB FUNCTION AS THERE ARE NO AD
!           COMPONENTS IN THE IR Water SFCOPTICS COMPUTATIONS.
!
! CALLING SEQUENCE:
!       IO_Status = CSEM_Compute_WaterIR_SfcOptics_AD( SfcOptics_AD )
!
! INPUTS:
!       SfcOptics_AD:  Structure containing the adjoint surface optical
!                      properties required for the adjoint radiative
!                      transfer calculation.
!                      *** COMPONENTS MODIFIED UPON OUTPUT ***
!                      UNITS:      N/A
!                      TYPE:       CSEM_SfcOptics_Type
!                      DIMENSION:  Scalar
!                      ATTRIBUTES: INTENT(IN OUT)
! OUTPUTS:
!
!         Surface_AD:  Structure containing the adjoint surface state
!                      variables required for the adjoint radiative
!                      transfer calculation.
!                      *** COMPONENTS MODIFIED UPON OUTPUT ***
!                      UNITS:      N/A
!                      TYPE:       CSEM_SfcOptics_Type
!                      DIMENSION:  Scalar
!                      ATTRIBUTES: INTENT(IN OUT)
!
! FUNCTION RESULT:
!       IO_Status:  The return value is an integer defining the error status.
!                      The error codes are defined in the Message_Handler module.
!                      If == SUCCESS the computation was sucessful
!                      == FAILURE an unrecoverable error occurred
!                      UNITS:      N/A
!                      TYPE:       INTEGER
!                      DIMENSION:  Scalar
!
! COMMENTS:
!       Note the INTENT on the input adjoint arguments are IN OUT regardless
!       of their specification as "input" or "output". This is because these
!       arguments may contain information on input, or need to be zeroed on
!       output (or both).
!
!:sdoc-:
!----------------------------------------------------------------------------------

  FUNCTION CSEM_Compute_WaterIR_SfcOptics_AD(  &
       SfcOptics_AD,                           &  ! Input
       Surface_AD,                             &  ! Output
       iVar)                                   &  ! Internal variable input
   RESULT ( IO_Status  )
    ! Arguments
    TYPE(CSEM_Water_Surface),  INTENT(INOUT) :: Surface_AD
    TYPE(CSEM_SfcOptics_Type), INTENT(INOUT) :: SfcOptics_AD
    TYPE(iVar_type) :: iVar

   ! Function result
    INTEGER :: IO_Status
    ! Local parameters
    CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'CSEM_Compute_WaterIR_SfcOptics_AD'
    ! Local variables
    INTEGER :: i, nZ

    REAL(fp) :: Emissivity_AD(MAX_n_Angles), Reflectivity_AD(MAX_n_Angles)
    REAL(fp) :: Direct_Reflectivity_AD(MAX_n_Angles)

    ! Set up
    IO_Status = SUCCESS

    nZ = SfcOptics_AD%n_Angles

    !ALLOCATE(Emissivity_AD(nZ), Reflectivity_AD(nZ),Direct_Reflectivity_AD(nZ))
    DO i=1,nZ
      Emissivity_AD(i)          = SfcOptics_AD%Emissivity(i,1)
      Reflectivity_AD(i)        = SfcOptics_AD%Reflectivity(i,1,i,1)
      Direct_Reflectivity_AD(i) = SfcOptics_AD%Direct_Reflectivity(i,1)
    ENDDO

    IF(TRIM(iVar%AlgID) .EQ. 'NPOESS_LUT' ) THEN

       Surface_AD%Wind_Speed         =  Surface_AD%Wind_Speed + ZERO
       Surface_AD%Water_Temperature  = Surface_AD%Water_Temperature + ZERO

    ELSE IF((TRIM(iVar%AlgID) .EQ. "NESDIS_IRW_NalliV2CM") .OR. &
          (TRIM(iVar%AlgID) .EQ. "NESDIS_IRW_NalliV2EK") ) THEN
        IO_Status = NESDIS_IRSSEM_BRDF_V2_AD(            &
                       Emissivity_AD(1:nz)             , &  ! Input
                       Reflectivity_AD (1:nz)          , &  ! Input
                       Direct_Reflectivity_AD (1:nz)   , &  ! Input
                       Surface_AD%Wind_Speed           , &  ! Output
                       Surface_AD%Water_Temperature    , &  ! Outout
                       iVar%IRSSEM_BRDF_V2)
        IF ( IO_Status /= SUCCESS ) THEN
           CALL Display_Message( ROUTINE_NAME, &
                           'Error computing Tangent_linear IR sea surface emissivity', &
                            IO_Status  )
            Surface_AD%Wind_Speed = ZERO
            RETURN
        END IF

    ELSE
        !Compute tangent-linear IR sea surface emissivity
        IO_Status = NESDIS_IRSSEM_BRDF_AD(               &
                       Emissivity_AD(1:nz)             , &  ! Input
                       Reflectivity_AD (1:nz)          , &  ! Input
                       Direct_Reflectivity_AD (1:nz)   , &  ! Input
                       Surface_AD%Wind_Speed           , &  ! Output
                       iVar%IRSSEM_BRDF)
        IF ( IO_Status /= SUCCESS ) THEN
           CALL Display_Message( ROUTINE_NAME, &
                           'Error computing Tangent_linear IR sea surface emissivity', &
                            IO_Status  )
            Surface_AD%Wind_Speed = ZERO
            RETURN
        END IF

    END IF
    SfcOptics_AD%Emissivity    =  ZERO
    SfcOptics_AD%Reflectivity  =  ZERO
    SfcOptics_AD%Direct_Reflectivity =  ZERO

  END FUNCTION CSEM_Compute_WaterIR_SfcOptics_AD

END MODULE CSEM_WaterIR_SfcOptics


!
!     ------------------------------------------------------------------
!       A N A L Y S E 1
!     ------------------------------------------------------------------
!
      SUBROUTINE ANALY1(IREAD, IWRITE, NCLOSD, MAXORB, N, NCFG, LIST)
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY:  DOUBLE
!...Translated by Pacific-Sierra Research 77to90  4.3E  07:38:59  11/16/01
!...Switches:
!
!        This routine analyzes the format of the configuration input
!        data and determines a consistent ordering of the electrons
!
!     IMPLICIT INTEGER (Q)
      IMPLICIT NONE
!-----------------------------------------------
!   G l o b a l   P a r a m e t e r s
!-----------------------------------------------
      INTEGER, PARAMETER :: NWD = 128
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER , INTENT(IN) :: IREAD
      INTEGER , INTENT(IN) :: IWRITE
      INTEGER , INTENT(OUT) :: NCLOSD
      INTEGER , INTENT(OUT) :: MAXORB
      INTEGER , INTENT(IN) :: N
      INTEGER , INTENT(OUT) :: NCFG
      CHARACTER , INTENT(OUT) :: LIST(NWD)*3
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER , POINTER, DIMENSION(:,:) :: QAFTER
      INTEGER , ALLOCATABLE, TARGET, DIMENSION(:,:) :: AFTER
      INTEGER , DIMENSION(8) :: IEL
      INTEGER :: IERR, I, J, NCI, NWI, K, I1, I2, IORD
      REAL(DOUBLE) :: STAT
      CHARACTER :: LINE*72
      CHARACTER , DIMENSION(NWD) :: OF*3
      CHARACTER , DIMENSION(8) :: EL*3
      CHARACTER :: HEAD*30
!-----------------------------------------------
!      POINTER(QAFTER,AFTER((NWD),1))
!
    1 FORMAT(A72)
!
      !call alloc(qafter,nwd*nwd,4)
      ALLOCATE (AFTER(NWD,NWD), STAT=IERR)

!
      AFTER = 0

!
! --- Check format of configuration file
!
      REWIND IREAD
      READ (IREAD, '(A30,I3,I4)') HEAD, NCI, NWI
!
!  ---  Determine the number of common closed subshells
!
      READ (IREAD, '(A72)') LINE
      NCLOSD = 0
      J = 2
   10 CONTINUE
      IF (LINE(J:J+2) /= '   ') THEN
         NCLOSD = NCLOSD + 1
         J = J + 4
         IF (J < 72) GO TO 10
      ENDIF
!
! --- if not clist format
!
   12 CONTINUE
      IF (NWI > NCI) THEN
         READ (IREAD, '(A72)') LINE
         NWI = NWI - 20
         GO TO 12
      ENDIF
!
!  ---  Determine the number or configurations and electrons
!
!
      MAXORB = 0
      NCFG = N
   20 CONTINUE
      READ (IREAD, 1, END=55) LINE
      IF (LINE(1:1)/='*' .AND. LINE(2:2)/='*') THEN
!
!  ------  A new configuration has been read; find the electrons
!
         NCFG = NCFG + 1
         J = 2
         I = 0
   30    CONTINUE
         IF (LINE(J:J+2)/='   ' .AND. I<8) THEN
!
!  --------- An electron has been found; is it a new one?
!
            I = I + 1
            EL(I) = LINE(J:J+2)
            K = 1
   40       CONTINUE
            IF (K <= MAXORB) THEN
               IF (OF(K) /= EL(I)) THEN
                  K = K + 1
                  IF (K > NWD) THEN
                     WRITE (IWRITE, *) 'SET NWD Larger: NWD=', NWD
                     STOP
                  ENDIF
                  GO TO 40
               ELSE
                  IEL(I) = K
               ENDIF
            ELSE
!
!  ------------  A new electron has been found; add it to the list
!
               MAXORB = K
               OF(MAXORB) = EL(I)
               IEL(I) = K
            ENDIF
            J = J + 8
            GO TO 30
         ENDIF
!
!  ------  Add data to the AFTER matrix
!
         DO I1 = 2, I
            AFTER(IEL(I1),IEL(:I1-1)) = 1
         END DO
         READ (IREAD, *)
         IF (I > 8) READ (IREAD, *)
         GO TO 20
      ENDIF
!
!  ---  Check if the ordering of the electrons is inconsistent
!
   55 CONTINUE
      DO I = 1, MAXORB
         DO J = 1, MAXORB
            IF (AFTER(I,J)/=1 .OR. AFTER(J,I)/=1) CYCLE
            WRITE (IWRITE, *) ' The order of ', OF(I), ' and ', OF(J), &
               ' is inconsistent'
            STOP
         END DO
      END DO
!
!  ---  Reorder the electrons to satisfy the after relations found
!         in the different configurations
!
      IORD = 1
   70 CONTINUE
      IF (IORD <= MAXORB) THEN
!
!  ------  Search for a row with no 1's
!
         L71: DO I = 1, MAXORB
            DO J = 1, MAXORB
               IF (AFTER(I,J) /= 1) CYCLE
               CYCLE  L71
            END DO
!
!  ---------  The current row contains all 0's or 2's
!
            IF (AFTER(I,I) == 2) CYCLE  L71
!
!  ------------  We have the next electron; delete the corresponding
!                  rows and columns from the AFTER matrix
!
            LIST(IORD) = OF(I)
            IORD = IORD + 1
            AFTER(I,:MAXORB) = 2
            AFTER(:MAXORB,I) = 2
            GO TO 70
         END DO L71
      ENDIF
      IF (ALLOCATED(AFTER)) THEN
!
!      call dalloc(qafter,nwd*nwd)
         DEALLOCATE (AFTER)
      ENDIF
      RETURN
      END SUBROUTINE ANALY1


text: This is a list of all pages based upon the number of links on each page (links from the page to other pages).  Pages with few links are dead ends  you have few choices once youre there. (Note: redirect pages are filtered from this list.)  The dual of this page is Orphaned Pages  pages with no links to them.

ext: f

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


!PR fortran/32222
! { dg-do compile }

module splinemod
implicit none
integer, parameter :: dl = KIND(1.d0)
Type lSamples
  integer l(10)
end Type lSamples
end module splinemod

subroutine InterpolateClArr(lSet)
use splinemod
type (lSamples), intent(in) :: lSet
real(dl) xl(10)
xl = real(lSet%l,dl)
end subroutine InterpolateClArr


text:
!WRF:MODEL_LAYER:CONSTANTS
!

 MODULE module_model_constants

   !  2. Following are constants for use in defining real number bounds.

   !  A really small number.

   REAL    , PARAMETER :: epsilon         = 1.E-15

   !  4. Following is information related to the physical constants.

   !  These are the physical constants used within the model.

! JM NOTE -- can we name this grav instead?
   REAL    , PARAMETER :: g = 9.81  ! acceleration due to gravity (m {s}^-2)

!KiD
!#if ( NMM_CORE == 1 )
   REAL    , PARAMETER :: r_d          = 287.04
   REAL    , PARAMETER :: cp           = 1004.6
!#else
!   REAL    , PARAMETER :: r_d          = 287.
!   REAL    , PARAMETER :: cp           = 7.*r_d/2.
!#endif
!/KiD
   REAL    , PARAMETER :: r_v          = 461.6
   REAL    , PARAMETER :: cv           = cp-r_d
   REAL    , PARAMETER :: cpv          = 4.*r_v
   REAL    , PARAMETER :: cvv          = cpv-r_v
   REAL    , PARAMETER :: cvpm         = -cv/cp
   REAL    , PARAMETER :: cliq         = 4190.
   REAL    , PARAMETER :: cice         = 2106.
   REAL    , PARAMETER :: psat         = 610.78
   REAL    , PARAMETER :: rcv          = r_d/cv
   REAL    , PARAMETER :: rcp          = r_d/cp
   REAL    , PARAMETER :: rovg         = r_d/g
   REAL    , PARAMETER :: c2           = cp * rcv
   real    , parameter :: mwdry        = 28.966 ! molecular weight of dry air (g/mole)

   REAL    , PARAMETER :: p1000mb      = 100000.
   REAL    , PARAMETER :: t0           = 300.
   REAL    , PARAMETER :: p0           = p1000mb
   REAL    , PARAMETER :: cpovcv       = cp/(cp-r_d)
   REAL    , PARAMETER :: cvovcp       = 1./cpovcv
   REAL    , PARAMETER :: rvovrd       = r_v/r_d

   REAL    , PARAMETER :: reradius     = 1./6370.0e03

   REAL    , PARAMETER :: asselin      = .025
!   REAL    , PARAMETER :: asselin      = .0
   REAL    , PARAMETER :: cb           = 25.

   REAL    , PARAMETER :: XLV0         = 3.15E6
   REAL    , PARAMETER :: XLV1         = 2370.
   REAL    , PARAMETER :: XLS0         = 2.905E6
   REAL    , PARAMETER :: XLS1         = 259.532

   REAL    , PARAMETER :: XLS          = 2.85E6
   REAL    , PARAMETER :: XLV          = 2.5E6
   REAL    , PARAMETER :: XLF          = 3.50E5

   REAL    , PARAMETER :: rhowater     = 1000.
   REAL    , PARAMETER :: rhosnow      = 100.
   REAL    , PARAMETER :: rhoair0      = 1.28

   REAL    , PARAMETER :: DEGRAD       = 3.1415926/180.
   REAL    , PARAMETER :: DPD          = 360./365.

   REAL    , PARAMETER ::  SVP1=0.6112
   REAL    , PARAMETER ::  SVP2=17.67
   REAL    , PARAMETER ::  SVP3=29.65
   REAL    , PARAMETER ::  SVPT0=273.15
   REAL    , PARAMETER ::  EP_1=R_v/R_d-1.
   REAL    , PARAMETER ::  EP_2=R_d/R_v
   REAL    , PARAMETER ::  KARMAN=0.4
   REAL    , PARAMETER ::  EOMEG=7.2921E-5
   REAL    , PARAMETER ::  STBOLT=5.67051E-8

   REAL    , PARAMETER ::  prandtl = 1./3.0
                                         ! constants for w-damping option
   REAL    , PARAMETER ::  w_alpha = 0.3 ! strength m/s/s
   REAL    , PARAMETER ::  w_beta  = 1.0 ! activation cfl number

       REAL , PARAMETER ::  pq0=379.90516
       REAL , PARAMETER ::  epsq2=0.2
!      REAL , PARAMETER ::  epsq2=0.02
       REAL , PARAMETER ::  a2=17.2693882
       REAL , PARAMETER ::  a3=273.16
       REAL , PARAMETER ::  a4=35.86
       REAL , PARAMETER ::  epsq=1.e-12
       REAL , PARAMETER ::  p608=rvovrd-1.
!#if ( NMM_CORE == 1 )
       REAL , PARAMETER ::  climit=1.e-20
       REAL , PARAMETER ::  cm1=2937.4
       REAL , PARAMETER ::  cm2=4.9283
       REAL , PARAMETER ::  cm3=23.5518
!       REAL , PARAMETER ::  defc=8.0
!       REAL , PARAMETER ::  defm=32.0
       REAL , PARAMETER ::  defc=0.0
       REAL , PARAMETER ::  defm=99999.0
       REAL , PARAMETER ::  epsfc=1./1.05
       REAL , PARAMETER ::  epswet=0.0
       REAL , PARAMETER ::  fcdif=1./3.
       REAL , PARAMETER ::  fcm=0.00003
       REAL , PARAMETER ::  gma=-r_d*(1.-rcp)*0.5
       REAL , PARAMETER ::  p400=40000.0
       REAL , PARAMETER ::  phitp=15000.0
       REAL , PARAMETER ::  pi2=2.*3.1415926
       REAL , PARAMETER ::  plbtm=105000.0
       REAL , PARAMETER ::  plomd=64200.0
       REAL , PARAMETER ::  pmdhi=35000.0
       REAL , PARAMETER ::  q2ini=0.50
       REAL , PARAMETER ::  rfcp=0.25/cp
       REAL , PARAMETER ::  rhcrit_land=0.75
       REAL , PARAMETER ::  rhcrit_sea=0.80
       REAL , PARAMETER ::  rlag=14.8125
       REAL , PARAMETER ::  rlx=0.90
       REAL , PARAMETER ::  scq2=50.0
       REAL , PARAMETER ::  slopht=0.001
       REAL , PARAMETER ::  tlc=2.*0.703972477
       REAL , PARAMETER ::  wa=0.15
       REAL , PARAMETER ::  wght=0.35
       REAL , PARAMETER ::  wpc=0.075
       REAL , PARAMETER ::  z0land=0.10
       REAL , PARAMETER ::  z0max=0.008
       REAL , PARAMETER ::  z0sea=0.001
!#endif

   !  Earth

   !  The value for P2SI *must* be set to 1.0 for Earth
   !  Although, now we may not need this declaration here (see above)
   !REAL    , PARAMETER :: P2SI         = 1.0

   !  Orbital constants:

   INTEGER , PARAMETER :: PLANET_YEAR = 365
   REAL , PARAMETER :: OBLIQUITY = 23.5
   REAL , PARAMETER :: ECCENTRICITY = 0.014
   REAL , PARAMETER :: SEMIMAJORAXIS = 1.0 ! In AU
   ! Don't know the following values, so we'll fake them for now
   REAL , PARAMETER :: zero_date = 0.0   ! Time of perihelion passage
   !  Fraction into the year (from perhelion) of the
   !  occurrence of the Northern Spring Equinox
   REAL , PARAMETER :: EQUINOX_FRACTION= 0.0

 CONTAINS
   SUBROUTINE init_module_model_constants
   END SUBROUTINE init_module_model_constants
 END MODULE module_model_constants

max_stars_repo_name: Adehill/KiD-A

max_issues_repo_name: Adehill/KiD-A

max_forks_repo_name: Adehill/KiD-A


text:
c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine readxyz  --  input of Cartesian coordinates  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "readxyz" gets a set of Cartesian coordinates from
c     an external disk file
c
c
      subroutine readxyz (ixyz)
      implicit none
      include 'sizes.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'couple.i'
      include 'files.i'
      include 'inform.i'
      include 'iounit.i'
      include 'titles.i'
      integer i,j,k,m
      integer ixyz,nmax
      integer next,size
      integer first,last
      integer nexttext
      integer trimtext
      integer, allocatable :: list(:)
      logical exist,opened
      logical quit,reorder
      logical clash
      character*120 xyzfile
      character*120 record
      character*120 string
c
c
c     initialize the total number of atoms in the system
c
      n = 0
c
c     open the input file if it has not already been done
c
      inquire (unit=ixyz,opened=opened)
      if (.not. opened) then
         xyzfile = filename(1:leng)//'.xyz'
         call version (xyzfile,'old')
         inquire (file=xyzfile,exist=exist)
         if (exist) then
            open (unit=ixyz,file=xyzfile,status='old')
            rewind (unit=ixyz)
         else
            write (iout,10)
   10       format (/,' READXYZ  --  Unable to Find the Cartesian',
     &                 ' Coordinates File')
            call fatal
         end if
      end if
c
c     read first line and return if already at end of file
c
      quit = .false.
      abort = .true.
      size = 0
      do while (size .eq. 0)
         read (ixyz,20,err=70,end=70)  record
   20    format (a120)
         size = trimtext (record)
      end do
      abort = .false.
      quit = .true.
c
c     parse the title line to get the number of atoms
c
      i = 0
      next = 1
      call gettext (record,string,next)
      read (string,*,err=70,end=70)  n
c
c     extract the title and determine its length
c
      string = record(next:120)
      first = nexttext (string)
      last = trimtext (string)
      if (last .eq. 0) then
         title = ' '
         ltitle = 0
      else
         title = string(first:last)
         ltitle = trimtext (title)
      end if
c
c     check for too few or too many total atoms in the file
c
      if (n .le. 0) then
         write (iout,30)
   30    format (/,' READXYZ  --  The Coordinate File Does Not',
     &              ' Contain Any Atoms')
         call fatal
      else if (n .gt. maxatm) then
         write (iout,40)  maxatm
   40    format (/,' READXYZ  --  The Maximum of',i8,' Atoms',
     &              ' has been Exceeded')
         call fatal
      end if
c
c     initialize coordinates and connectivities for each atom
c
      do i = 1, n
         tag(i) = 0
         name(i) = '   '
         x(i) = 0.0d0
         y(i) = 0.0d0
         z(i) = 0.0d0
         type(i) = 0
         do j = 1, maxval
            i12(j,i) = 0
         end do
      end do
c
c     read the coordinates and connectivities for each atom
c
      do i = 1, n
         next = 1
         size = 0
         do while (size .eq. 0)
            read (ixyz,50,err=70,end=70)  record
   50       format (a120)
            size = trimtext (record)
         end do
         read (record,*,err=70,end=70)  tag(i)
         call getword (record,name(i),next)
         string = record(next:120)
         read (string,*,err=60,end=60)  x(i),y(i),z(i),type(i),
     &                                  (i12(j,i),j=1,maxval)
   60    continue
      end do
      quit = .false.
   70 continue
      if (.not. opened)  close (unit=ixyz)
c
c     an error occurred in reading the coordinate file
c
      if (quit) then
         write (iout,80)  i
   80    format (/,' READXYZ  --  Error in Coordinate File at Atom',i6)
         call fatal
      end if
c
c     for each atom, count and sort its attached atoms
c
      do i = 1, n
         n12(i) = 0
         do j = maxval, 1, -1
            if (i12(j,i) .ne. 0) then
               n12(i) = j
               goto 90
            end if
         end do
   90    continue
         call sort (n12(i),i12(1,i))
      end do
c
c     perform dynamic allocation of some local arrays
c
      nmax = 0
      do i = 1, n
         nmax = max(tag(i),nmax)
         do j = 1, n12(i)
            nmax = max(i12(j,i),nmax)
         end do
      end do
      allocate (list(nmax))
c
c     check for scrambled atom order and attempt to renumber
c
      reorder = .false.
      do i = 1, n
         list(tag(i)) = i
         if (tag(i) .ne. i)  reorder = .true.
      end do
      if (reorder) then
         write (iout,100)
  100    format (/,' READXYZ  --  Atom Labels not Sequential,',
     &              ' Attempting to Renumber')
         do i = 1, n
            tag(i) = i
            do j = 1, n12(i)
               i12(j,i) = list(i12(j,i))
            end do
            call sort (n12(i),i12(1,i))
         end do
      end if
c
c     perform deallocation of some local arrays
c
      deallocate (list)
c
c     check for atom pairs with identical coordinates
c
      clash = .false.
      if (n .le. 10000)  call chkxyz (clash)
c
c     make sure that all connectivities are bidirectional
c
      do i = 1, n
         do j = 1, n12(i)
            k = i12(j,i)
            do m = 1, n12(k)
               if (i12(m,k) .eq. i)  goto 120
            end do
            write (iout,110)  k,i
  110       format (/,' READXYZ  --  Check Connection of Atom',
     &                 i6,' to Atom',i6)
            call fatal
  120       continue
         end do
      end do
      return
      end

max_stars_repo_name: htna/HCsbLib

max_issues_repo_name: htna/HCsbLib

max_forks_repo_name: htna/HCsbLib


text:
subroutine fclaw3dx_clawpatch46_fort_timeinterp(mx,my,mz, mbc,meqn, &
        psize, qcurr,qlast,qinterp,alpha,ierror)
    implicit none

    integer :: mx,my,mz,mbc,meqn,psize, ierror
    double precision :: alpha
    double precision ::   qcurr(1-mbc:mx+mbc,1-mbc:my+mbc,1-mbc:mz+mbc,meqn)
    double precision ::   qlast(1-mbc:mx+mbc,1-mbc:my+mbc,1-mbc:mz+mbc,meqn)
    double precision :: qinterp(1-mbc:mx+mbc,1-mbc:my+mbc,1-mbc:mz+mbc,meqn)

    integer :: i,j,k,m,mint,count,count_final

    !! # Number of interior layers to compute.  Since we only
    !! # interpolate from time-interpolated levels, we only
    !! # need two layers.  If we were averaging, we'd need four.
    mint = mbc
    ierror = 0
    count = 1

    !! # Time interpolate only to the interior cells.

    do m = 1,meqn
        do k = 1,mz
            !! # Face 0
            do j = 1,my-mint
                do i = 1,mint
                    qinterp(i,j,k, m) = qlast(i,j,k,m) + &
                        alpha*(qcurr(i,j,k,m)-qlast(i,j,k,m))
                    count = count + 1
                end do
            end do

            !! # Face 2
            do j = 1,mint
                do i = mint+1,mx
                    qinterp(i,j,k,m) = qlast(i,j,k,m) + &
                        alpha*(qcurr(i,j,k,m)-qlast(i,j,k,m))
                    count = count + 1
                end do
            end do

            !! # Face 1
            do j = mint+1,my
                do i = mx-mint+1,mx
                    qinterp(i,j,k, m) = qlast(i,j,k,m) + &
                         alpha*(qcurr(i,j,k,m)-qlast(i,j,k,m))
                    count = count + 1
                end do
            end do

            !! # Face 3
            do j = my-mint+1,my
                do i = 1,mx-mint
                    qinterp(i,j,k,m) = qlast(i,j,k,m) + &
                         alpha*(qcurr(i,j,k,m)-qlast(i,j,k,m))
                    count = count + 1
                end do
            end do
        end do
    end do

    count_final = count-1
    if (count_final .ne. psize) then
       ierror = 2
    endif

end

max_stars_repo_name: ECLAIRWaveS/ForestClaw

max_issues_repo_name: ECLAIRWaveS/ForestClaw

max_forks_repo_name: ECLAIRWaveS/ForestClaw


text:
King Hall Phone on the Campus Payphones node

Phone Number: (530) 7569959

Location: in North south hallway on first floor.

Description: It has a wiki:WikiPedia:Telecommunications_device_for_the_deaf tdd.

Charge: 50 cents for local calls


text:
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
cc                                                                    cc
cc                 mncoco : concon test program                       cc
cc                                                                    cc
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      real x(16),y(16),w(16),v(16),sx(16),s2(16),t(20),c(20),wrk(550),
     * s(3)
      integer iwrk(450)
      logical bind(20)
      integer i,ier,iopt,is,j,j3,kwrk,lwrk,m,maxbin,maxtr,n,nest,n4,n6
      real sq
c  the absciss values of the data points.
      data x(1),x(2),x(3),x(4),x(5),x(6),x(7),x(8),x(9),x(10),x(11),
     * x(12),x(13),x(14),x(15),x(16)/0.1,0.3,0.5,0.7,0.9,1.25,1.75,
     * 2.25,2.75,3.5,4.5,5.5,6.5,7.5,8.5,9.5/
c  the ordinate values of the data points.
      data y(1),y(2),y(3),y(4),y(5),y(6),y(7),y(8),y(9),y(10),y(11),
     * y(12),y(13),y(14),y(15),y(16)/0.124,0.234,0.256,0.277,0.278,
     * 0.291,0.308,0.311,0.315,0.322,0.317,0.326,0.323,0.321,0.322,
     * 0.328/
c  m denotes the number of data points.
      m = 16
c  we set up the weights of the data points.
      do 10 i=1,m
         w(i) = 1.
  10  continue
      w(1) = 10.
      w(2) = 3.
      w(16) = 10.
c  we will determine concave approximations
      do 20 i=1,m
         v(i) = 1.
  20  continue
c  we set up the dimension information.
      nest = 20
      maxtr = 100
      maxbin = 10
      lwrk = 550
      kwrk = 450
c  we set up the different s-values.
      s(1) = 0.2
      s(2) = 0.04
      s(3) = 0.0002
c  initialization.
      iopt = 0
c  loop for the different spline approximations
      do 300 is=1,3
c  we determine the concave spline approximation.
         call concon(iopt,m,x,y,w,v,s(is),nest,maxtr,maxbin,n,t,c,sq,sx,
     *     bind,wrk,lwrk,iwrk,kwrk,ier)
c  printing of the results.
         write(6,900) s(is),ier
         write(6,905) sq
         write(6,910) n
         write(6,915)
         write(6,920) (t(i),i=1,n)
         write(6,925)
         n6 = n-6
         do 100 j=1,n6
            j3 = j+3
            if(bind(j)) write(6,930) t(j3)
 100     continue
         write(6,935)
         n4 = n-4
         write(6,940) (c(i),i=1,n4)
c  we evaluate the second order derivative of the spline.
         call splder(t,n,c,3,2,x,s2,m,wrk,ier)
         write(6,945)
         do 200 i=1,m
            write(6,950) i,x(i),y(i),sx(i),s2(i)
 200     continue
c  iopt=1 from the second call on.
         iopt = 1
 300  continue
      stop
c  format statements
 900  format(48h0upper limit for the sum of squared residuals s=,
     * e8.1,5x,15herror flag ier=,i2)
 905  format(1x,28hsum of squared residuals sq=,e10.3)
 910  format(1x,24htotal number of knots n=,i2)
 915  format(1x,21hposition of the knots)
 920  format(5x,8f7.2)
 925  format(1x,24hthe knots where s''(x)=0)
 930  format(5x,f7.2)
 935  format(1x,21hb-spline coefficients)
 940  format(5x,4f12.6)
 945  format(3h0 i,5x,4hx(i),6x,4hy(i),4x,7hs(x(i)),4x,9hs''(x(i)))
 950  format(1x,i2,5x,f4.2,5x,f5.3,5x,f5.3,5x,f8.4)
      end

max_issues_repo_name: tbeu/ApproxSpline


text:
module types

    !! In this module we define so-called "kind"-parameters, which can be used
    !! to control the precision of the floating point reals in the program.
    !!
    !! Also we define the value of some constants
    !!
    !! ** Note:  It is not necessary to alter in this module **

    ! Get "kind" parameters for single, double, and quad precision floating-point reals
    ! (ref: http://fortranwiki.org/fortran/show/Real+precision)
    integer, parameter ::                              &
        sp = kind(1.0),                                &
        dp = selected_real_kind(2*precision(1.0_sp)),  &
        qp = selected_real_kind(2*precision(1.0_dp))
    !
    ! Select working precision
    integer, parameter :: wp = dp

    ! Constants
!    real(wp), parameter ::  pi = 4*atan(1.0_wp) ! Fortran 2003+
    real(wp), parameter ::  pi = 3.14159265358979323848_wp ! Fortran 90/95

end module types

max_stars_repo_name: Sebastian-dm/finite-element

max_issues_repo_name: Sebastian-dm/finite-element

max_forks_repo_name: Sebastian-dm/finite-element


! { dg-do run }
! { dg-additional-options "-cpp" }

#define M 8
#define N 32

program main
  integer :: i
  integer :: a(N)
  integer :: b(M * N)

  do i = 1, N
    a(i) = 0
  end do

  !$acc parallel copy (a)
  !$acc loop seq
    do i = 1, N
      call seq (a)
    end do
  !$acc end parallel

  do i = 1, N
    if (a(i) .ne.N) call abort
  end do

  !$acc parallel copy (a)
  !$acc loop seq
    do i = 1, N
      call gang (a)
    end do
  !$acc end parallel

  do i = 1, N
    if (a(i) .ne. (N + (N * (-1 * i)))) call abort
  end do

  do i = 1, N
    b(i) = i
  end do

  !$acc parallel copy (b)
  !$acc loop seq
    do i = 1, N
      call worker (b)
    end do
  !$acc end parallel

  do i = 1, N
    if (b(i) .ne. N + i) call abort
  end do

  do i = 1, N
    a(i) = i
  end do

  !$acc parallel copy (a)
  !$acc loop seq
    do i = 1, N
      call vector (a)
    end do
  !$acc end parallel

  do i = 1, N
    if (a(i) .ne. 0) call abort
  end do

contains

subroutine vector (a)
  !$acc routine vector
  integer, intent (inout) :: a(N)
  integer :: i

  !$acc loop vector
  do i = 1, N
    a(i) = a(i) - a(i)
  end do

end subroutine vector

subroutine worker (b)
  !$acc routine worker
  integer, intent (inout) :: b(M*N)
  integer :: i, j

  !$acc loop worker
  do i = 1, N
  !$acc loop vector
    do j = 1, M
      b(j + ((i - 1) * M)) = b(j + ((i - 1) * M)) + 1
    end do
  end do

end subroutine worker

subroutine gang (a)
  !$acc routine gang
  integer, intent (inout) :: a(N)
  integer :: i

  !$acc loop gang
  do i = 1, N
    a(i) = a(i) - i
  end do

end subroutine gang

subroutine seq (a)
  !$acc routine seq
  integer, intent (inout) :: a(M)
  integer :: i

  do i = 1, N
    a(i) = a(i) + 1
  end do

end subroutine seq

end program main


text:
module Mod_Lev_MassCorrection
   use MPI
   use Mod_LevelSet
   use Mod_lev_BaseElmope
   use Mod_PointerSetter
   implicit none

   real(rp) :: MeanLevsetGradient, TotalFreeSurfaceArea, TotalVolume

   real(rp), allocatable :: PointLevsetGradient(:), PointPdSurf(:)

   type, extends(PointerSetter) :: SPMassCorrection
contains
      procedure :: SpecificSet => SpecificSetMassCorrection
   end type

   type(SPMassCorrection) :: SetPointersMassCorrection

contains

   subroutine SpecificSetMassCorrection(d)
      implicit none
      class(SPMassCorrection) :: d

      !a%kfl_MassCorrection = 1
      if (a%kfl_MassCorrection == 1) then
         call ConcatenateProcedures(ProcHook%Initializations,InitializationsMassCorrection)
         call ConcatenateProcedures(ProcHook%PostGaussElmats,PostGaussMassCorrection)
         call ConcatenateProcedures(ProcHook%Finalizations,FinalizationsMassCorrection)
      endif

   end subroutine

   subroutine InitializationsMassCorrection
      implicit none

      integer(ip) :: npoin

      TotalVolume = 0.0_rp
      MeanLevsetGradient = 0.0_rp
      TotalFreeSurfaceArea = 0.0_rp

      call a%Mesh%Getnpoin(npoin)

      call a%Memor%alloc(npoin,PointLevsetGradient,'PointLevsetGradient','MassCorrection')
      call a%Memor%alloc(npoin,PointPdSurf,'PointPdSurf','MassCorrection')

   end subroutine

   subroutine PostGaussMassCorrection
      implicit none

      real(rp) :: grlev(3), UnitOrthogonalVector(3)

      integer(ip) :: elemStatus, ngaus_total, ngauss_plus, ngauss_minus
      real(rp)    :: weigp(40)
      real(rp)    :: pdsurf, NormalLevsetGradient

      integer(ip) :: inode,ipoin,npoinLocal
      real(rp)    :: weightfactor

      !Count the number of nodes which are mine
      call a%Mesh%GetNpoinLocal(npoinLocal)
      weightfactor = 0.0_rp
      do inode = 1,e%pnode
         ipoin = e%lnods(inode)
         if (ipoin <= npoinLocal) then
            weightfactor = weightfactor + 1.0_rp
         endif
      enddo
      weightfactor = weightfactor/real(e%pnode,rp)

      call a%CutMesh%GetElementType(ielem,elemStatus)

      if (elemStatus == 1) then
         !TotalVolume
         TotalVolume = TotalVolume + weightfactor*sum(e%weigp(1:e%pgaus))*e%detjm

      elseif(elemStatus ==0)then

         ngaus_total=0

         call a%CutMesh%GetNgaussSide(ielem,ngauss_plus,ngauss_minus)
         call a%CutMesh%GetWeigpCut(ielem,e%ndime,weigp)

         !TotalVolume
         TotalVolume = TotalVolume + weightfactor*sum(weigp(ngauss_minus+1:ngauss_minus+ngauss_plus))*e%detjm

         call a%CutMesh%GetExternalNormal(ielem,e,UnitOrthogonalVector)
         call a%CutMesh%GetSurfaceIntersection(ielem,e,pdsurf)

         call e%gradient(1_ip,ellev(:,1),grlev)

         NormalLevsetGradient = dot_product(grlev(1:e%ndime),UnitOrthogonalVector(1:e%ndime))

         !PointLevsetGradient
         PointLevsetGradient(e%lnods(1:e%pnode)) = PointLevsetGradient(e%lnods(1:e%pnode)) + NormalLevsetGradient*pdsurf
         PointPdSurf(e%lnods(1:e%pnode)) = PointPdSurf(e%lnods(1:e%pnode)) + pdsurf

         !MeanLevsetGradient
         MeanLevsetGradient = MeanLevsetGradient + weightfactor*NormalLevsetGradient*pdsurf
         TotalFreeSurfaceArea = TotalFreeSurfaceArea + weightfactor*pdsurf

      end if
   end subroutine

   subroutine FinalizationsMassCorrection
      implicit none

      real(rp) :: CorrectionVolume, CorrectionLevset, PointCorrection,CorrectionDistance
      integer(ip) :: npoin,ipoin
      real(rp) :: auxTotalSurface, auxTotalVolume
      integer(ip) :: ierr

      !Communications, volume and surface
      auxTotalVolume = TotalVolume
      call  MPI_AllREDUCE( auxTotalVolume, TotalVolume, 1, MPI_REAL8, MPI_SUM,a%MPIcomm, ierr )

      auxTotalSurface = TotalFreeSurfaceArea
      call  MPI_AllREDUCE( auxTotalSurface, TotalFreeSurfaceArea, 1, MPI_REAL8, MPI_SUM,a%MPIcomm, ierr )

      !Ghost communcations
      call a%Mesh%ArrayCommunicator%GhostCommunicate(1,PointLevsetGradient)
      call a%Mesh%ArrayCommunicator%GhostCommunicate(1,PointPdSurf)

      !The first time we only count the volume
      if (a%ipass == 0) then
         a%ReferenceVolume = TotalVolume
         a%ipass = 1

      else
         CorrectionVolume = a%ReferenceVolume - TotalVolume

         CorrectionDistance = CorrectionVolume/TotalFreeSurfaceArea

         !call a%FilePostpr%postpr(a%level(:,1),'levelprecorrection',a%istep,a%ctime,a%Mesh)

         call a%Mesh%GetNPoin(npoin)

         do ipoin = 1,npoin
            if (PointPdSurf(ipoin) /= 0.0_rp) then
               PointCorrection = CorrectionDistance*PointLevsetGradient(ipoin)/PointPdSurf(ipoin)
               a%level(ipoin,1) = a%level(ipoin,1) - PointCorrection
            endif
         enddo

         write(*,*) 'CorrectionDistance: ', CorrectionDistance
         !call a%FilePostpr%postpr(a%level(:,1),'levelpostcorrection',a%istep,a%ctime,a%Mesh)

      endif

      call a%Mesh%GetNpoin(npoin)
      call a%Memor%dealloc(npoin,PointLevsetGradient,'PointLevsetGradient','MassCorrection')
      call a%Memor%dealloc(npoin,PointPdSurf,'PointPdSurf','MassCorrection')

   end subroutine

end module

max_stars_repo_name: ciaid-colombia/InsFEM

max_issues_repo_name: ciaid-colombia/InsFEM

max_forks_repo_name: ciaid-colombia/InsFEM


text:
! KGEN-generated Fortran source file
!
! Filename    : rrlw_kg07.f90
! Generated at: 2015-07-06 23:28:45
! KGEN version: 0.4.13

    MODULE rrlw_kg07
        USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check
        USE shr_kind_mod, ONLY: r8 => shr_kind_r8
        !      use parkind ,only : jpim, jprb
        IMPLICIT NONE
        !-----------------------------------------------------------------
        ! rrtmg_lw ORIGINAL abs. coefficients for interval 7
        ! band 7:  980-1080 cm-1 (low - h2o,o3; high - o3)
        !
        ! Initial version:  JJMorcrette, ECMWF, jul1998
        ! Revised: MJIacono, AER, jun2006
        !-----------------------------------------------------------------
        !
        !  name     type     purpose
        !  ----   : ----   : ---------------------------------------------
        !fracrefao: real
        !fracrefbo: real
        ! kao     : real
        ! kbo     : real
        ! kao_mco2: real
        ! kbo_mco2: real
        ! selfrefo: real
        ! forrefo : real
        !-----------------------------------------------------------------
        !-----------------------------------------------------------------
        ! rrtmg_lw COMBINED abs. coefficients for interval 7
        ! band 7:  980-1080 cm-1 (low - h2o,o3; high - o3)
        !
        ! Initial version:  JJMorcrette, ECMWF, jul1998
        ! Revised: MJIacono, AER, jun2006
        !-----------------------------------------------------------------
        !
        !  name     type     purpose
        !  ----   : ----   : ---------------------------------------------
        !fracrefa : real
        !fracrefb : real
        ! ka      : real
        ! kb      : real
        ! ka_mco2 : real
        ! kb_mco2 : real
        ! selfref : real
        ! forref  : real
        !
        ! absa    : real
        !-----------------------------------------------------------------
        INTEGER, parameter :: ng7  = 12
        REAL(KIND=r8), dimension(ng7) :: fracrefb
        REAL(KIND=r8) :: fracrefa(ng7,9)
        REAL(KIND=r8) :: absa(585,ng7)
        REAL(KIND=r8) :: absb(235,ng7)
        REAL(KIND=r8) :: ka_mco2(9,19,ng7)
        REAL(KIND=r8) :: kb_mco2(19,ng7)
        REAL(KIND=r8) :: selfref(10,ng7)
        REAL(KIND=r8) :: forref(4,ng7)
        PUBLIC kgen_read_externs_rrlw_kg07
    CONTAINS

    ! write subroutines

    ! module extern variables

    SUBROUTINE kgen_read_externs_rrlw_kg07(kgen_unit)
        INTEGER, INTENT(IN) :: kgen_unit
        READ(UNIT=kgen_unit) fracrefb
        READ(UNIT=kgen_unit) fracrefa
        READ(UNIT=kgen_unit) absa
        READ(UNIT=kgen_unit) absb
        READ(UNIT=kgen_unit) ka_mco2
        READ(UNIT=kgen_unit) kb_mco2
        READ(UNIT=kgen_unit) selfref
        READ(UNIT=kgen_unit) forref
    END SUBROUTINE kgen_read_externs_rrlw_kg07

    END MODULE rrlw_kg07

max_stars_repo_name: kammerdienerb/flang

max_issues_repo_name: kammerdienerb/flang

max_forks_repo_name: kammerdienerb/flang


text:
      subroutine   furlea(
     i                    spavac,time1,time0,
     m                    ii)
c
c     + + + PURPOSE + + +
c     This subprogram allows for lower end advance during the depletion
c     and recession phases.
c
c     Called from FURREC
c     Author(s): E. R. Kottwitz
c     Reference in User Guide: Chapter 12
c
c     NOTE:  THIS MODULE HAS NOT BEEN RECODED
c
c     + + + PARAMETERS + + +
      include 'pmxpln.inc'
      include 'pmxsrg.inc'
      include 'pxstep.inc'
c
c     + + + ARGUMENT DECLARATIONS + + +
      integer   ii
      real      spavac,time1,time0
c
c     + + + ARGUMENT DEFINITIONS + + +
c     ii     - primary kinematic wave calculation counter
c     spavac - space averaging coefficient for flow area for current
c              time
c     time1  - time of current set of calculations (s)
c     time0  - time of previous set of calculations (s)
c
c     + + + COMMON BLOCKS + + +
      include 'ciraflo.inc'
c       read: aqcnst,aqexp
c
      include 'cirfurr.inc'
c       read: spavz
c     modify: aflow(0:xsteps,2),infltr(0:xsteps,2),inoptm(0:xsteps),
c             tadvan(0:xsteps),xpostn(0:xsteps)
c
      include 'cirinfl.inc'
c       read: kosta,kostf,kostk
c
c     + + + LOCAL VARIABLES + + +
      real      deltax,ratio,tiavq
c
c     + + + LOCAL DEFINITIONS + + +
c     deltax - advance distance during the current time step (m)
c     ratio  - ratio of deltax to (location of next node - location of
c              current node) (m/m)
c     tiavq  - time averaging coefficient for flow rate
c
c     + + + DATA INITIALIZATIONS + + +
      data      tiavq/0.35/
c
c     + + + END SPECIFICATIONS + + +
c
c     Determine advance distance (deltax) and ratio of this distance to
c     the interval between the next node and the current node
c
c      ---- (WEPP Equation 12.14, solved for DELTAX)
      deltax = (1.0-tiavq)*qflow(ii,2)*(time1-time0)/
     1         (spavac*aflow(ii,2)+spavz*(infltr(ii,2)-infltr(ii,1)))
   10 ratio = deltax/(xpostn(ii+1)-xpostn(ii))
c
c     If next statement is true then shift current calculation
c     boundary downslope.  Linearly interpolate for inoptm(i) and
c     adjust aflow, infltr, tadvan, and xpostn arrays.
c
      if(ratio.le.0.5 .or. (ratio.lt.1.0 .and. ii.eq.xsteps-1))then
        inoptm(ii) = inoptm(ii)+(inoptm(ii+1)-inoptm(ii))*ratio
        xpostn(ii) = xpostn(ii)+deltax
        tadvan(ii) = time1
        aflow(ii,2) = 0.0
        qflow(ii,2) = 0.0
c
c        ---- (WEPP Equation 12.4, where tau=inoptm)
        infltr(ii,1) = kostk*inoptm(ii)**kosta+kostf*inoptm(ii)
        infltr(ii,2) = infltr(ii,1)
c
c     If next statement is true then shift next calculation boundary
c     upslope.  Linearly interpolate for inoptm(i+1), adjust aflow,
c     infltr, tadvan, and xpostn arrays.
c
      elseif(ratio.gt.0.5 .and. ratio.lt.1.0 .and. ii.lt.(xsteps-1))then
        ii = ii+1
        inoptm(ii) = inoptm(ii-1)+(inoptm(ii)-inoptm(ii-1))*ratio
        xpostn(ii) = xpostn(ii-1)+deltax
        tadvan(ii) = time1
        aflow(ii,2) = 0.0
        qflow(ii,2) = 0.0
c
c        ---- (WEPP Equation 12.4, where tau=inoptm)
        infltr(ii,1) = kostk*inoptm(ii)**kosta+kostf*inoptm(ii)
        infltr(ii,2) = infltr(ii,1)
c
c     If none of the above statements is true then increment i.
c     Linearly interpolate for tadvan(i) and aflow(i,2) and adjust
c     infltr array
c
      else
        ii = ii+1
        tadvan(ii) = time0+(time1-time0)/ratio
        aflow(ii,2) = aflow(ii-1,2)*(ratio-1.0)/ratio
        qflow(ii,2) = aqcnst*aflow(ii,2)**aqexp
c
c        ---- (WEPP Equation 12.4, where tau=inoptm+time1-tadvan)
        infltr(ii,2) = kostk*(inoptm(ii)+time1-tadvan(ii))**kosta+
     1                 kostf*(inoptm(ii)+time1-tadvan(ii))
c
c        ---- (WEPP Equation 12.4 where tau=inoptm)
        infltr(ii,1) = kostk*inoptm(ii)**kosta+kostf*inoptm(ii)
c
c       If the next statement is true then adjust deltax and make next
c       round of calculation boundary adjustments.
c
        if(ii.lt.xsteps)then
          deltax = deltax-(xpostn(ii)-xpostn(ii-1))
          goto 10
        endif
      endif
c
      return
      end

ext: for

max_stars_repo_name: jarad/dep

max_issues_repo_name: jarad/dep

max_forks_repo_name: akrherz/idep


text:
program NF
end program NF
subroutine mattest(nx,ny,nz,band1,band2,band3,stiffness,maxiter,targrms,method)
  integer,parameter :: dpkind=kind(1.0D0)
  character(*) :: method
  real(dpkind),allocatable,dimension(:) :: ad,au1,au2,au3,x,b
  allocate(ad(nxyz),au1(nxyz),au2(nxyz),au3(nxyz),x(nxyz),b(nxyz))
  au1(nx:nxyz:nx) = 0.0
  if ( method=='NFCG' ) then
  endif
end subroutine mattest

max_issues_repo_name: sujankh/rose-matlab

max_forks_repo_name: sujankh/rose-matlab


text:
      SUBROUTINE PRINT (X,Y,XYD,CHR,N,OPT)
C
C     (X,Y) = STARTING OR ENDING POINT OF THE LINE TO BE PRINTED (ALWAYS
C             LEFT-TO-RIGHT OR TOP-TO-BOTTOM).
C     CHR   = CHARACTERS TO BE PRINTED (4 PER WORD).
C     N     = NUMBER OF 4 CHARACTER WORDS.
C     XYD   = +/-1 IF X = STARTING OR ENDING POINT OF THE LINE.
C     ...   = +/-2 .. Y = ........ .. ...... ..... .. ... .....
C     OPT   = -1 TO INITIATE  THE TYPING MODE.
C     ...   = +1 .. TERMINATE ... ...... .....
C     ...   =  0 .. PRINT A LINE.
C
      EXTERNAL        ORF,KRSHFT,KLSHFT
      INTEGER         XYD,CHR(1),OPT,ORF,C(80),BLANK,BLNK,CHARX,D
      REAL            XY(2,2)
      COMMON /PLTDAT/ SKPPLT(20),SKPA(3),CNTCHR(2)
      COMMON /SYSTEM/ SKPSYS(40),NCPW
      DATA    BLANK / 1H /
C
      IF (OPT .NE. 0) GO TO 150
      BLNK = KRSHFT(KLSHFT(BLANK,1),1)
      D = MAX0(IABS(XYD),1)
      S = CNTCHR(D)
      IF (XYD.EQ.-1 .OR. XYD.EQ.2) S = -S
      XY(1,1) = X
      XY(2,1) = Y
      XY(1,2) = XY(1,1)
      XY(2,2) = XY(2,1)
C
C     SEPARATE 80 CHARACTERS AT A TIME.
C
      DO 130 J = 1,N,20
      IF (XYD .LT. 0) GO TO 105
      L1 = J
      L2 = L1 + 19
      IF (L2 .GT. N) L2 = N
      GO TO 106
  105 L2 = N - J + 1
      L1 = L2 - 19
      IF (L1 .LE. 0) L1 = 1
C
  106 NC = 0
      DO 120 L = L1,L2
      DO 110 I = 1,4
      CHARX = KRSHFT(CHR(L),NCPW-I)
      NC = NC + 1
      C(NC) = ORF(KLSHFT(CHARX,NCPW-1),BLNK)
  110 CONTINUE
  120 CONTINUE
C
C     TYPE THE -NC- CHARACTERS JUST SEPARATED.
C
      XY(D,2) = XY(D,1) + S*FLOAT(L1-1)
      CALL TIPE (XY(1,2),XY(2,2),XYD,C,NC,0)
  130 CONTINUE
      GO TO 200
C
C     OPT = +/-1
C
  150 CALL TIPE (0,0,0,0,0,OPT)
  200 RETURN
      END