text:
!
! Helper module containing the azimuth emissivity routines for the
! CRTM implementation of FASTEM4 and FASTEM5
!
!
! CREATION HISTORY:
!       Written by:     Original FASTEM1/2/3 authors
!
!       Modified by:    Quanhua Liu, Quanhua.Liu@noaa.gov
!                       Stephen English, Stephen.English@metoffice.gov.uk
!                       July, 2009
!
!       Refactored by:  Paul van Delst, December 2011
!                       paul.vandelst@noaa.gov
!

MODULE Azimuth_Emissivity_Module

  ! -----------------
  ! Environment setup
  ! -----------------
  ! Module use
  USE Type_Kinds     , ONLY: fp
  USE FitCoeff_Define, ONLY: FitCoeff_3D_type
  ! Disable implicit typing
  IMPLICIT NONE

  ! ------------
  ! Visibilities
  ! ------------
  PRIVATE
  ! Data types
  PUBLIC :: iVar_type
  ! Science routines
  PUBLIC :: Azimuth_Emissivity
  PUBLIC :: Azimuth_Emissivity_TL
  PUBLIC :: Azimuth_Emissivity_AD

  ! -----------------
  ! Module parameters
  ! -----------------
  REAL(fp), PARAMETER :: ZERO  = 0.0_fp
  REAL(fp), PARAMETER :: ONE   = 1.0_fp
  REAL(fp), PARAMETER :: TWO   = 2.0_fp
  REAL(fp), PARAMETER :: THREE = 3.0_fp
  REAL(fp), PARAMETER :: PI = 3.141592653589793238462643383279_fp
  REAL(fp), PARAMETER :: DEGREES_TO_RADIANS = PI / 180.0_fp

  ! Dimensions
  ! ...Number of component predictors for harmonic coefficients
  INTEGER, PARAMETER :: N_PREDICTORS = 10
  ! ...Number of Stokes parameters
  INTEGER, PARAMETER :: N_STOKES = 4
  ! ...The number of harmonics considered in the trignometric parameterisation
  INTEGER, PARAMETER :: N_HARMONICS = 3

  ! --------------------------------------
  ! Structure definition to hold internal
  ! variables across FWD, TL, and AD calls
  ! --------------------------------------
  TYPE :: iVar_type
    PRIVATE
    ! Direct inputs
    REAL(fp) :: wind_speed = ZERO
    REAL(fp) :: frequency  = ZERO
    ! Derived inputs
    REAL(fp) :: sec_z = ZERO
    ! Cosine and sine of the harmonic angle, m*phi
    REAL(fp) :: cos_angle(N_HARMONICS) = ZERO
    REAL(fp) :: sin_angle(N_HARMONICS) = ZERO
    ! Intermediate variables
    REAL(fp) :: trig_coeff(N_STOKES, N_HARMONICS) = ZERO
   END TYPE iVar_type

CONTAINS

  ! ===========================================================
  ! Compute emissivity as a function of relative azimuth angle.
  ! ===========================================================

  ! Forward model
  SUBROUTINE Azimuth_Emissivity( &
    AZCoeff      , &  ! Input
    Wind_Speed   , &  ! Input
    Azimuth_Angle, &  ! Input
    Frequency    , &  ! Input
    cos_z        , &  ! Input
    e_Azimuth    , &  ! Output
    iVar           )  ! Internal variable output
    ! Arguments
    TYPE(FitCoeff_3D_type), INTENT(IN)     :: AZCoeff
    REAL(fp)              , INTENT(IN)     :: Wind_Speed
    REAL(fp)              , INTENT(IN)     :: Azimuth_Angle
    REAL(fp)              , INTENT(IN)     :: Frequency
    REAL(fp)              , INTENT(IN)     :: cos_z
    REAL(fp)              , INTENT(OUT)    :: e_Azimuth(:)
    TYPE(iVar_type)       , INTENT(IN OUT) :: iVar
    ! Local variables
    INTEGER :: i, m
    REAL(fp) :: phi, angle
    REAL(fp) :: predictor(N_PREDICTORS)

    ! Initialise output
    e_Azimuth = ZERO

    ! Save inputs for TL and AD calls
    iVar%wind_speed = Wind_Speed
    iVar%frequency  = Frequency
    iVar%sec_z      = ONE/cos_z

    ! Convert angle
    phi = Azimuth_Angle * DEGREES_TO_RADIANS

    ! Compute the azimuth emissivity component predictors
    CALL Compute_Predictors( Wind_Speed, Frequency, iVar%sec_z, Predictor )

    ! Compute the azimuth emissivity vector
    Harmonic_Loop: DO m = 1, N_HARMONICS

      ! Compute the angles
      angle = REAL(m,fp) * phi
      iVar%cos_angle(m) = COS(angle)
      iVar%sin_angle(m) = SIN(angle)

      ! Compute the coefficients
      DO i = 1, N_STOKES
        CALL Compute_Coefficient( &
               AZCoeff%C(:,i,m), &
               Predictor, &
               iVar%trig_coeff(i,m) )
      END DO

      ! Compute the emissivities
      e_Azimuth(1) = e_Azimuth(1) + iVar%trig_coeff(1,m)*iVar%cos_angle(m) ! Vertical
      e_Azimuth(2) = e_Azimuth(2) + iVar%trig_coeff(2,m)*iVar%cos_angle(m) ! Horizontal
      e_Azimuth(3) = e_Azimuth(3) + iVar%trig_coeff(3,m)*iVar%sin_angle(m) ! +/- 45deg.
      e_Azimuth(4) = e_Azimuth(4) + iVar%trig_coeff(4,m)*iVar%sin_angle(m) ! Circular

    END DO Harmonic_Loop

    ! Apply frequency correction
    e_Azimuth = e_Azimuth * Azimuth_Freq_Correction(Frequency)

  END SUBROUTINE Azimuth_Emissivity

  ! Tangent-linear model
  SUBROUTINE Azimuth_Emissivity_TL( &
    AZCoeff         , &  ! Input
    Wind_Speed_TL   , &  ! Input
    Azimuth_Angle_TL, &  ! Input
    e_Azimuth_TL    , &  ! Output
    iVar              )  ! Internal variable input
    ! Arguments
    TYPE(FitCoeff_3D_type), INTENT(IN)  :: AZCoeff
    REAL(fp)              , INTENT(IN)  :: Wind_Speed_TL
    REAL(fp)              , INTENT(IN)  :: Azimuth_Angle_TL
    REAL(fp)              , INTENT(OUT) :: e_Azimuth_TL(:)
    TYPE(iVar_type)       , INTENT(IN)  :: iVar
    ! Local variables
    INTEGER :: i, m
    REAL(fp) :: phi_TL, angle_TL
    REAL(fp) :: predictor_TL(N_PREDICTORS)
    REAL(fp) :: trig_coeff_TL(N_STOKES)

    ! Initialise output
    e_Azimuth_TL = ZERO

    ! Compute angle perturbation in radians
    phi_TL = Azimuth_Angle_TL * DEGREES_TO_RADIANS

    ! Compute the azimuth emissivity component tangent-linear predictors
    CALL Compute_Predictors_TL( iVar%wind_speed, iVar%frequency, iVar%sec_z, Wind_Speed_TL, predictor_TL )

    ! Compute the tangent-linear azimuth emissivity vector
    Harmonic_Loop: DO m = 1, N_HARMONICS

      ! Compute the angles
      angle_TL = REAL(m,fp) * phi_TL

      ! Compute the coefficients
      DO i = 1, N_STOKES
        CALL Compute_Coefficient_TL( &
               AZCoeff%C(:,i,m), &
               predictor_TL, &
               trig_coeff_TL(i) )
      END DO

      ! Compute the tangent-linear emissivities
      ! ...Vertical polarisation
      e_Azimuth_TL(1) = e_Azimuth_TL(1) + iVar%cos_angle(m)*trig_coeff_TL(1) - &
                                          iVar%trig_coeff(1,m)*iVar%sin_angle(m)*angle_TL
      ! ...Horizontal polarisation
      e_Azimuth_TL(2) = e_Azimuth_TL(2) + iVar%cos_angle(m)*trig_coeff_TL(2) - &
                                          iVar%trig_coeff(2,m)*iVar%sin_angle(m)*angle_TL
      ! ...+/- 45deg. polarisation
      e_Azimuth_TL(3) = e_Azimuth_TL(3) + iVar%sin_angle(m)*trig_coeff_TL(3) + &
                                          iVar%trig_coeff(3,m)*iVar%cos_angle(m)*angle_TL
      ! ...Circular polarisation
      e_Azimuth_TL(4) = e_Azimuth_TL(4) + iVar%sin_angle(m)*trig_coeff_TL(4) + &
                                          iVar%trig_coeff(4,m)*iVar%cos_angle(m)*angle_TL
    END DO Harmonic_Loop

    ! Apply tangent-linear frequency correction
    e_Azimuth_TL = e_Azimuth_TL * Azimuth_Freq_Correction(iVar%frequency)

  END SUBROUTINE Azimuth_Emissivity_TL

  ! Adjoint model
  SUBROUTINE Azimuth_Emissivity_AD( &
    AZCoeff         , &  ! Input
    e_Azimuth_AD    , &  ! AD Input
    Wind_Speed_AD   , &  ! AD Output
    Azimuth_Angle_AD, &  ! AD Output
    iVar              )  ! Internal variable input
    ! Arguments
    TYPE(FitCoeff_3D_type), INTENT(IN)     :: AZCoeff
    REAL(fp)              , INTENT(IN OUT) :: e_Azimuth_AD(:)
    REAL(fp)              , INTENT(IN OUT) :: Wind_Speed_AD
    REAL(fp)              , INTENT(IN OUT) :: Azimuth_Angle_AD
    TYPE(iVar_type)       , INTENT(IN)     :: iVar
    ! Local variables
    INTEGER :: i, m
    REAL(fp) :: phi_AD, angle_AD
    REAL(fp) :: predictor_AD(N_PREDICTORS)
    REAL(fp) :: trig_coeff_AD(N_STOKES)

    ! Initialise local adjoints
    phi_AD       = ZERO
    predictor_AD = ZERO

    ! Adjoint of frequency correction
    e_Azimuth_AD = e_Azimuth_AD * Azimuth_Freq_Correction(iVar%frequency)

    ! Compute the azimuth emissivity vector adjoint
    Harmonic_Loop: DO m = 1, N_HARMONICS

      ! Compute the adjoint of the emissivities
      ! ...Circular polarisation
      angle_AD         = iVar%trig_coeff(4,m)*iVar%cos_angle(m)*e_Azimuth_AD(4)
      trig_coeff_AD(4) = iVar%sin_angle(m)*e_Azimuth_AD(4)
      ! ...+/- 45deg. polarisation
      angle_AD         = angle_AD + iVar%trig_coeff(3,m)*iVar%cos_angle(m)*e_Azimuth_AD(3)
      trig_coeff_AD(3) = iVar%sin_angle(m)*e_Azimuth_AD(3)
      ! ...Horizontal polarisation
      angle_AD         = angle_AD - iVar%trig_coeff(2,m)*iVar%sin_angle(m)*e_Azimuth_AD(2)
      trig_coeff_AD(2) = iVar%cos_angle(m)*e_Azimuth_AD(2)
      ! ...Vertical polarisation
      angle_AD         = angle_AD - iVar%trig_coeff(1,m)*iVar%sin_angle(m)*e_Azimuth_AD(1)
      trig_coeff_AD(1) = iVar%cos_angle(m)*e_Azimuth_AD(1)

      ! Compute the adjoint of the coefficients
      DO i = N_STOKES, 1, -1
        CALL Compute_Coefficient_AD( &
               AZCoeff%C(:,i,m), &
               trig_coeff_AD(i), &
               predictor_AD      )
      END DO

      ! Compute the angle adjoint
      phi_AD = phi_AD + REAL(m,fp)*angle_AD

    END DO Harmonic_Loop

    ! Compute the azimuth emissivity component predictor adjoint
    CALL Compute_Predictors_AD( iVar%wind_speed, iVar%frequency, iVar%sec_z, predictor_AD, Wind_Speed_AD )

    ! Adjoint of the angle perturbation in radians
    Azimuth_Angle_AD = Azimuth_Angle_AD + phi_AD*DEGREES_TO_RADIANS

  END SUBROUTINE Azimuth_Emissivity_AD

!################################################################################
!################################################################################
!##                                                                            ##
!##                        ## PRIVATE MODULE ROUTINES ##                       ##
!##                                                                            ##
!################################################################################
!################################################################################

  ! =============================================
  ! Compute predictors for the azimuth components
  ! =============================================

  ! Forward model
  SUBROUTINE Compute_Predictors( &
    Wind_Speed, &  ! Input
    Frequency , &  ! Input
    sec_z     , &  ! Input
    Predictor   )  ! Output
    ! Arguments
    REAL(fp), INTENT(IN)  :: Wind_Speed
    REAL(fp), INTENT(IN)  :: Frequency
    REAL(fp), INTENT(IN)  :: sec_z
    REAL(fp), INTENT(OUT) :: Predictor(N_PREDICTORS)
    ! Compute the predictors.
    Predictor( 1) = ONE
    Predictor( 2) = Frequency
    Predictor( 3) = sec_z
    Predictor( 4) = sec_z * Frequency
    Predictor( 5) = Wind_Speed
    Predictor( 6) = Wind_Speed * Frequency
    Predictor( 7) = Wind_Speed**2
    Predictor( 8) = Frequency * Wind_Speed**2
    Predictor( 9) = Wind_Speed * sec_z
    Predictor(10) = Wind_Speed * sec_z * Frequency
  END SUBROUTINE Compute_Predictors

  ! Tangent-linear model
  SUBROUTINE Compute_Predictors_TL(  &
    Wind_Speed   , &  ! FWD Input
    Frequency    , &  ! FWD Input
    sec_z        , &  ! FWD Input
    Wind_Speed_TL, &  ! TL  Input
    Predictor_TL   )  ! TL  Output
    ! Arguments
    REAL(fp), INTENT(IN)  :: Wind_Speed
    REAL(fp), INTENT(IN)  :: Frequency
    REAL(fp), INTENT(IN)  :: sec_z
    REAL(fp), INTENT(IN)  :: Wind_Speed_TL
    REAL(fp), INTENT(OUT) :: Predictor_TL(N_PREDICTORS)
    ! Compute the tangent-linear predictors.
    Predictor_TL( 1) = ZERO
    Predictor_TL( 2) = ZERO
    Predictor_TL( 3) = ZERO
    Predictor_TL( 4) = ZERO
    Predictor_TL( 5) = Wind_Speed_TL
    Predictor_TL( 6) = Frequency * Wind_Speed_TL
    Predictor_TL( 7) = TWO * Wind_Speed * Wind_Speed_TL
    Predictor_TL( 8) = TWO * Frequency * Wind_Speed * Wind_Speed_TL
    Predictor_TL( 9) = sec_z * Wind_Speed_TL
    Predictor_TL(10) = sec_z * Frequency * Wind_Speed_TL
  END SUBROUTINE Compute_Predictors_TL

  ! Adjoint model
  SUBROUTINE Compute_Predictors_AD(  &
    Wind_Speed   , &  ! FWD Input
    Frequency    , &  ! FWD Input
    sec_z        , &  ! FWD Input
    Predictor_AD , &  ! AD  Input
    Wind_Speed_AD  )  ! AD  Output
    ! Arguments
    REAL(fp), INTENT(IN)     :: Wind_Speed
    REAL(fp), INTENT(IN)     :: Frequency
    REAL(fp), INTENT(IN)     :: sec_z
    REAL(fp), INTENT(IN OUT) :: Predictor_AD(N_PREDICTORS)
    REAL(fp), INTENT(IN OUT) :: Wind_Speed_AD
    ! Compute the predictor adjoints
    Wind_Speed_AD = Wind_Speed_AD + &
                    sec_z * Frequency            * Predictor_AD(10) + &
                    sec_z                        * Predictor_AD( 9) + &
                    TWO * Frequency * Wind_Speed * Predictor_AD( 8) + &
                    TWO             * Wind_Speed * Predictor_AD( 7) + &
                          Frequency              * Predictor_AD( 6) + &
                                                   Predictor_AD( 5)
    Predictor_AD = ZERO
  END SUBROUTINE Compute_Predictors_AD

  ! ==============================================================
  ! Compute the component coefficient from the regression equation
  ! ==============================================================

  ! Forward model
  SUBROUTINE Compute_Coefficient( &
    c           , &  ! Input
    X           , &  ! Input
    Coefficient   )  ! Output
    ! Arguments
    REAL(fp), INTENT(IN)  :: c(:)  ! regression coefficient
    REAL(fp), INTENT(IN)  :: X(:)  ! predictor
    REAL(fp), INTENT(OUT) :: Coefficient
    ! Local variables
    INTEGER :: i
    ! Compute component coefficient
    Coefficient = ZERO
    DO i = 1, N_PREDICTORS
      Coefficient = Coefficient + c(i)*X(i)
    END DO
  END SUBROUTINE Compute_Coefficient

  ! Tangent-linear model
  SUBROUTINE Compute_Coefficient_TL( &
    c             , &  ! Input
    X_TL          , &  ! Input
    Coefficient_TL  )  ! Output
    ! Arguments
    REAL(fp), INTENT(IN)  :: c(:)     ! regression coefficient
    REAL(fp), INTENT(IN)  :: X_TL(:)  ! predictor
    REAL(fp), INTENT(OUT) :: Coefficient_TL
    ! Local variables
    INTEGER :: i
    ! Compute tangent-linear component coefficient
    Coefficient_TL = ZERO
    DO i = 1, N_PREDICTORS
      Coefficient_TL = Coefficient_TL + c(i)*X_TL(i)
    END DO
  END SUBROUTINE Compute_Coefficient_TL

  ! Adjoint model
  SUBROUTINE Compute_Coefficient_AD( &
    c             , &  ! Input
    Coefficient_AD, &  ! Input
    X_AD            )  ! Output
    ! Arguments
    REAL(fp), INTENT(IN)     :: c(:)     ! regression coefficient
    REAL(fp), INTENT(IN OUT) :: Coefficient_AD
    REAL(fp), INTENT(IN OUT) :: X_AD(:)  ! predictor
    ! Local variables
    INTEGER :: i
    ! Compute adjoint of the component coefficient
    DO i = 1, N_PREDICTORS
      X_AD(i) = X_AD(i) + c(i)*Coefficient_AD
    END DO
    Coefficient_AD = ZERO
  END SUBROUTINE Compute_Coefficient_AD

  PURE FUNCTION  Azimuth_Freq_Correction( Frequency ) RESULT( Fre_C )
    IMPLICIT NONE
    REAL( fp ), INTENT(IN) :: Frequency
    REAL( fp ) :: Fre_C
    INTEGER :: i
      ! Data for the frequency correction
    REAL(fp), PARAMETER :: x(9) = (/ 0.0_fp, 1.4_fp, 6.8_fp, 10.7_fp, 19.35_fp, &
                                   37._fp, 89._fp, 150._fp, 200._fp/)
    REAL(fp), PARAMETER :: y(9) = (/ 0.0_fp, 0.1_fp, 0.6_fp, 0.9_fp, 1._fp, &
                                   1.0_fp, 0.4_fp, 0.2_fp, 0.0_fp/)
    !
    IF( Frequency <= ZERO .or. Frequency >= 200.0_fp ) THEN
      Fre_C = ZERO
      RETURN
    ELSE
      DO i = 1, 8
        IF( Frequency >= x(i) .and. Frequency <= x(i+1) ) THEN
          Fre_C = y(i) + (y(i+1)-y(i))/(x(i+1)-x(i))*(Frequency-x(i))
          RETURN
        END IF
      END DO
    END IF
    Fre_C = ZERO

  END FUNCTION  Azimuth_Freq_Correction

END MODULE Azimuth_Emissivity_Module

max_stars_repo_name: hsbadr/crtm

max_issues_repo_name: hsbadr/crtm

max_forks_repo_name: hsbadr/crtm


!-------------------------------------------------------------------------------
program simple_color
!(LICENSE:PD)
! @(#) Simple color text program using ncurses(3c) from Fortran
   use M_ncurses
   implicit none
   integer :: ierr
   stdscr=initscr() ! Start curses mode

   ! KLUDGE: LINES and COLS are not being set properly yet
   call getmaxyx(stdscr,LINES,COLS)                            ! get the number of rows and columns

   if(has_colors() .eqv. FALSE)then
      ierr=endwin()
      write(*,*)"Your terminal does not support color"
      stop 1
   endif

   ierr=start_color()       ! Start color
   !! NOTE
   !!    NAME IS COLOR_RED, NOT COLOR_RED
   !!    HAD TO CAST EVERYTHING TO TYPE C_SHORT
   ierr=init_pair(1_C_SHORT, COLOR_RED, COLOR_BLACK)

   ierr=attron(COLOR_PAIR(1))
   call print_in_middle(stdscr, LINES / 2, 0, 0, "Viola !!! In color ...")
   ierr=attroff(COLOR_PAIR(1))
   ierr=getch()
   ierr=endwin()
end program simple_color
!-------------------------------------------------------------------------------
subroutine print_in_middle(win, starty, startx, width0, string)
   use M_ncurses
   use ncurses_types
   implicit none
   integer(C_INT)                          :: ierr
   type(C_PTR)                             :: win
   integer,intent(in)                      :: starty, startx
   integer(C_INT)                          :: width0
   integer(C_INT)                          :: width
   character(len=*,KIND=C_CHAR),intent(in) :: string
   integer(C_INT)                          :: length, x=30, y=20
   integer(C_INT)                          :: temp

   width=width0  ! make mutable copy

  !if(win == C_NULL_PTR)then
  if (.not.c_associated(win)) then
      win = stdscr
   endif

   call getyx(win, y, x)

   if(startx /= 0)then
      x = startx
   endif

   if(starty /= 0)then
      y = starty
   endif
   if(width == 0)then
      width = 80
   endif

   length = len_trim(string)
   temp = (width - length)/ 2
   x = startx + temp
   ierr=mvwaddstr(win, y, x, string//C_NULL_CHAR)
   ierr=refresh()

end subroutine print_in_middle
!-------------------------------------------------------------------------------


text:
	SUBROUTINE VG_USIN  ( iret )
C************************************************************************
C* VG_USIN								*
C*									*
C* This subroutine gets the input parameters for the vertical interpo-	*
C* lation program VI.  The GEMPAK user interface is used.		*
C*									*
C* VG_USIN  ( IRET )							*
C*									*
C* Input parameters							*
C*									*
C* Output parameters:							*
C*	IRET		INTEGER		Return code			*
C*					 -2 = invalid input		*
C**									*
C* Log:									*
C* K. Brill/NMC		06/92						*
C* K. Brill/NMC		08/92	Added area for subsetting		*
C* K. Brill/NMC		10/92	Added SFVC				*
C* G. Hull/SAIC         04/08   Use common variables instead of params  *
C************************************************************************
	INCLUDE		'vicmn.cmn'
C*
C------------------------------------------------------------------------
	CALL IP_STR  ( 'GDFILE',  gdfile,  ier1 )
	CALL IP_STR  ( 'GDOUTF',  gdoutf,  ier2 )
	CALL IP_STR  ( 'GDATTIM', gdattm, ier3 )
	CALL IP_STR  ( 'GVCORD',  gvcord,  ier4 )
	CALL IP_STR  ( 'GLEVEL',  glevel, ier5 )
	CALL IP_STR  ( 'MAXGRD',  maxgrd, ier6 )
	CALL IP_STR  ( 'GAREA',   area, ier7 )
	CALL IP_STR  ( 'VCOORD',  vcoord, ier8 )

	iret = ier1 + ier2 + ier3 + ier4 + ier5 + ier6 + ier7 + ier8

	IF  ( iret .ne. 0 )  iret = -2

	RETURN
	END

ext: f

max_stars_repo_name: oxelson/gempak

max_issues_repo_name: oxelson/gempak

max_forks_repo_name: oxelson/gempak


text:
      SUBROUTINE DPO2FT( UPLO, N, A, LDA, C, LDC, INFO )
*
*  -- Iain Murray, January 2016. Derived in part from DPOTF2, which is a  --
*  -- LAPACK routine (version 3.3.1)                                      --
*  -- LAPACK is a software package provided by Univ. of Tennessee,        --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*  -- April 2011                                                          --
*
*     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            INFO, LDA, LDC, N
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * )
      DOUBLE PRECISION   C( LDC, * )
*     ..
*
*  Purpose
*  =======
*
*  DPO2FT computes the reverse mode sensitivity of DPOTF2, the Cholesky
*  factorization A of a real symmetric positive definite matrix X.
*
*  The original factorization had the form
*     X = A**T * A ,  if UPLO = 'U', or
*     X = A  * A**T,  if UPLO = 'L',
*  where A is an upper or lower triangular matrix respectively.
*
*  The triangular matrix C provides sensitivities of a scalar cost
*  function with respect to X, the output of the Cholesky algorithm A.
*  This routine transforms C into a triangular matrix of sensitivities
*  with respect to the input matrix X.
*
*  This is the unblocked version of the algorithm, calling Level 2 BLAS.
*
*  Arguments
*  =========
*
*  UPLO    (input) CHARACTER*1
*          Specifies whether the upper or lower triangular part of the
*          matrices A and C are to be used.
*          = 'U':  Upper triangular
*          = 'L':  Lower triangular
*
*  N       (input) INTEGER
*          The order of the matrices A and C.  N >= 0.
*
*  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
*          A contains a Cholesky decomposition of a matrix, usually from
*          a previous call to DPOTF2. If UPLO = 'U', the leading n by n
*          upper triangular part of A is used, and the strictly lower
*          triangular part of A is not referenced.  If UPLO = 'L', the
*          leading n by n lower triangular part of A is used, and the
*          strictly upper triangular part of A is not referenced.
*
*  LDA     (input) INTEGER
*          The leading dimension of the array A.  LDA >= max(1,N).
*
*  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
*
*          On exit, if INFO = 0, the sensitivity of the cost function
*          with respect to the full matrix X = A**T *A  or X = A*A**T.
*
*  LDC     (input) INTEGER
*          The leading dimension of the array C.  LDC >= max(1,N).
*
*  INFO    (output) INTEGER
*          = 0: successful exit
*          < 0: if INFO = -k, the k-th argument had an illegal value
*               or if INFO = -8, we hit a not-implemented error, NI_ERR
*          > 0: if INFO = k, A( k, k ) was found to be -ve, and so
*               cannot have been returned from DPOTF2.
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
      INTEGER            ONE_I, NI_ERR
      PARAMETER          ( ONE_I = 1, NI_ERR = -8 )
*     ..
*     .. Local Scalars ..
      LOGICAL            UPPER
      INTEGER            J
      DOUBLE PRECISION   AJJ
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DDOT
      EXTERNAL           LSAME, DDOT
*     ..
*     .. External Subroutines ..
      EXTERNAL           DGEMV, DSCAL, XERBLA, DGER
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      INFO = 0
      UPPER = LSAME( UPLO, 'U' )
      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( ONE_I, N ) ) THEN
         INFO = -4
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DPO2FT', -INFO )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( N.EQ.0 )
     $   RETURN
*
      IF( UPPER ) THEN
*
*        Assume A is from a factorization X = A**T *A.
*
         DO 10 J = N, 1, -1
*           NOT IMPLEMENTED YET.
            CALL XERBLA( 'DPO2FT', NI_ERR )
            RETURN
   10    CONTINUE
      ELSE
*
*        Assume A is from a factorization X = A*A**T.
*
         DO 20 J = N, 1, -1
            AJJ = A( J, J )
            IF( AJJ.LE.ZERO ) THEN
               GO TO 30
            END IF
*           C(J,J) = C(J,J) - A(J+1:N,J)'*C(J+1:N,J) / A(J,J);
            C( J, J ) = C( J, J ) - DDOT(
     $            N-J, A( J+1, J ), ONE_I, C( J+1, J ), ONE_I ) / AJJ
*           C(J:N,J) = C(J:N,J) / A(J,J);
            CALL DSCAL( N-J+1, ONE / AJJ, C( J, J ), ONE_I )
*           C(J,1:J-1) = C(J,1:J-1) - C(J:N,J)'*A(J:N,1:J-1);
            CALL DGEMV( 'Transpose', N-J+1, J-1, -ONE, A( J, 1 ), LDA,
     $            C( J, J ), ONE_I, ONE, C( J, 1 ), LDC )
*           C(J+1:N,1:J-1) = C(J+1:N,1:J-1) - C(J+1:N,J)*A(J,1:J-1);
            CALL DGER( N-J, J-1, -ONE, C( J+1, J ), ONE_I, A( J, 1 ),
     $            LDA, C( J+1, 1 ), LDC)
*           %C(J,J) = 0.5 * C(J,J); % can take out of loop if like.
            C( J, J ) = 0.5D+0 * C( J, J )
   20    CONTINUE
      END IF
      GO TO 40
*
   30 CONTINUE
      INFO = J
*
   40 CONTINUE
      RETURN
*
*     End of DPO2FT
*
      END

max_stars_repo_name: imurray/chol-rev

max_issues_repo_name: imurray/chol-rev

max_forks_repo_name: imurray/chol-rev


! ##################################################################################################################################
! Begin MIT license text.
! _______________________________________________________________________________________________________

! Copyright 2019 Dr William R Case, Jr (dbcase29@gmail.com)

! Permission is hereby granted, free of charge, to any person obtaining a copy of this software and
! associated documentation files (the "Software"), to deal in the Software without restriction, including
! without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to
! the following conditions:

! The above copyright notice and this permission notice shall be included in all copies or substantial
! portions of the Software and documentation.

! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
! OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
! THE SOFTWARE.
! _______________________________________________________________________________________________________

! End MIT license text.

      SUBROUTINE BD_NLPARM ( CARD, CC_NLSID_FND )

! Processes NLPARM Bulk Data Cards.

      USE PENTIUM_II_KIND, ONLY       :  BYTE, LONG
      USE IOUNT1, ONLY                :  WRT_LOG, ERR, F04, F06
      USE SCONTR, ONLY                :  BLNK_SUB_NAM, FATAL_ERR, IERRFL, JCARD_LEN, JF, LSUB
      USE TIMDAT, ONLY                :  TSEC
      USE NONLINEAR_PARAMS, ONLY      :  NL_MAXITER, NL_NUM_LOAD_STEPS, NL_SID
      USE SUBR_BEGEND_LEVELS, ONLY    :  BD_NLPARM_BEGEND

      USE BD_NLPARM_USE_IFs

      IMPLICIT NONE

      CHARACTER(LEN=LEN(BLNK_SUB_NAM)):: SUBR_NAME = 'BD_NLPARM'
      CHARACTER(LEN=*),INTENT(IN)     :: CARD              ! A Bulk Data card
      CHARACTER( 1*BYTE),INTENT(INOUT):: CC_NLSID_FND(LSUB)! 'Y' if B.D NLPARM card w/ same set ID (SID) as C.C. NLPARM = SID
      CHARACTER(LEN=JCARD_LEN)        :: JCARD(10)         ! The 10 fields of characters making up CARD
      CHARACTER(LEN(JCARD))           :: CARD_NAME         ! Field 1 of CARD
      CHARACTER(LEN(JCARD))           :: CHAR_SID          ! Field 2 of CARD

      INTEGER(LONG)                   :: I                 ! DO loop index
      INTEGER(LONG)                   :: I4INP             ! An integer value read from GRAV entry
      INTEGER(LONG)                   :: SETID             ! NLPARM set id
      INTEGER(LONG), PARAMETER        :: SUBR_BEGEND = BD_NLPARM_BEGEND

! **********************************************************************************************************************************
      IF (WRT_LOG >= SUBR_BEGEND) THEN
         CALL OURTIM
         WRITE(F04,9001) SUBR_NAME,TSEC
 9001    FORMAT(1X,A,' BEGN ',F10.3)
      ENDIF

! **********************************************************************************************************************************
! NLPARM Bulk Data Card routine

!   FIELD   ITEM                VARIABLE
!   -----   ------------        -------------
!     2     NL_SID              Set ID
!     3     NL_NUM_LOAD_STEPS   Number of increments into which the load is to be subdivided
!     7     NL_MAXITER          Maximum number of iterations for convergence in any 1 load step

! Make JCARD from CARD

      CALL MKJCARD ( SUBR_NAME, CARD, JCARD )

! Initialize

      NL_NUM_LOAD_STEPS = 1

! Read and check data

      CARD_NAME = JCARD(1)
      CHAR_SID  = JCARD(2)

      CALL I4FLD ( JCARD(2), JF(2), SETID )
      IF (IERRFL(2) == 'N') THEN
         DO I=1,LSUB
            IF (SETID == NL_SID(I)) THEN
               CC_NLSID_FND(I) = 'Y'
            ENDIF
         ENDDO
      ENDIF

      CALL I4FLD ( JCARD(3), JF(3), I4INP )
      IF (IERRFL(3) == 'N') THEN
         IF (I4INP >= 0) THEN
            NL_NUM_LOAD_STEPS = I4INP
         ELSE
            FATAL_ERR = FATAL_ERR + 1
            WRITE(ERR,1156) JF(3), CARD_NAME, CHAR_SID, I4INP
            WRITE(F06,1156) JF(3), CARD_NAME, CHAR_SID, I4INP
         ENDIF
      ENDIF

      IF (JCARD(7)(1:) /= ' ') THEN
         CALL I4FLD ( JCARD(7), JF(7), I4INP )
         IF (IERRFL(7) == 'N') THEN
            IF (I4INP >= 0) THEN
               NL_MAXITER = I4INP
            ELSE
               FATAL_ERR = FATAL_ERR + 1
               WRITE(ERR,1156) JF(7), CARD_NAME, CHAR_SID, I4INP
               WRITE(F06,1156) JF(7), CARD_NAME, CHAR_SID, I4INP
            ENDIF
         ENDIF
      ENDIF

      CALL BD_IMBEDDED_BLANK ( JCARD,2,3,0,0,0,7,0,0 )     ! Make sure that there are no imbedded blanks in fields 2-3
      CALL CARD_FLDS_NOT_BLANK ( JCARD,0,0,4,5,6,0,8,9 )   ! Issue warning if fields 4,5,6,8,9 not blank
      CALL CRDERR ( CARD )                                 ! CRDERR prints errors found when reading fields

! **********************************************************************************************************************************
      IF (WRT_LOG >= SUBR_BEGEND) THEN
         CALL OURTIM
         WRITE(F04,9002) SUBR_NAME,TSEC
 9002    FORMAT(1X,A,' END  ',F10.3)
      ENDIF

      RETURN

! **********************************************************************************************************************************
 1156 FORMAT(' *ERROR  1156: ILLEGAL ENTRY IN FIELD ',I2,' OF ',A,A,' CARD. ENTRY MUST BE > 0 BUT WAS = ',I8)

! **********************************************************************************************************************************

      END SUBROUTINE BD_NLPARM


text:
c     --------------------------------------------------------------------
c     RBOOK -- A simple fortran interface to ROOT histogramming
c
c     This file implements the FORTRAN front-end functions that call
c     the C++ back-end functions
c
c     (C) 31/08/2006 NIKHEF / Wouter Verkerke
c     -------------------------------------------------------------------
c
c Modified on 22/11/2013 by SF to use double precision
c
c The following routines allow booking and filling of histograms
c
c - rinit(filename)
c    character*(*) filename
c      Opens a file with name filename; this is were root stuff will go
c
c - rwrit()
c      Writes to root file opened with rinit
c
c - rclos()
c      Closes the root file; frees memory
c
c - rbook(id,histname,binsize,xlo,xhi)
c    character*(*) histname
c    integer id
c    double precision binsize,xlo,xhi
c      Books a one-dimensional histogram, identified by integer id and
c      tagged with name histname. The x axis ranges from xlo to xhi, with
c      bin size equal to binsize
c
c - rbook2(id,histname,xbinsize,xlo,xhi,ybinsize,ylo,yhi)
c    character*(*) histname
c    integer id
c    double precision xbinsize,xlo,xhi,ybinsize,ylo,yhi
c      Analogous to rbook(), but relevant to a two-dimensional histogram
c
c - rfill(id,xval,wgt)
c    integer id
c    double precision xval,wgt
c      Fills one-dimensional histogram identified by id [opened with
c      rbook(id,...)]; x value equal to xval, weight equal to wgt
c
c - rfill2(id,xval,yval,wgt)
c    integer id
c    double precision xval,yval,wgt
c      Analogous to rfill(), but relevant to a two-dimensional histogram
c

c      ----------------------------------------------------
c      RINIT front end -- Open a ROOT file with given name
c      ----------------------------------------------------
       subroutine rinit(name)
       character*(*) name

c      -- Call C++ back end function --
       call rinit_be_(name,len(name))

       return
       end

c      --------------------------------------
c      RWRIT front end -- Write to ROOT file
c      --------------------------------------
       subroutine rwrit()

c      -- Call C++ back end function --
       call rwrit_be_

       return
       end

c      --------------------------------------
c      RCLOSE front end -- Close the ROOT file
c      --------------------------------------
       subroutine rclos()

c      -- Call C++ back end function --
       call rclos_be_

       return
       end

c      --------------------------------------------
c      RBOOK front end -- Create ROOT TH1 histogram
c      --------------------------------------------
       subroutine rbook(id,name,xbin,xlo,xhi)
       character*(*) name
       integer id,nbin
       double precision xbin,xlo,xhi

c      PineAPPL commons
       include "reweight_pineappl.inc"
       include "pineappl_common.inc"
       logical pineappl
       common /for_pineappl/ pineappl

       nbin = int((xhi-xlo)/(xbin*0.9999d0))

c      Initialize the grids only if the switch "pineappl" is different from zero
c      and if the title string containes the word "central" and does not contain
c      the word "Born".
       if(pineappl.and.index(name,"central").ne.0.and.
     1                   index(name,"Born").eq.0)then
c      Observable parameters
          appl_obs_nbins = nbin
          appl_obs_min   = xlo
          appl_obs_max   = xhi
c      Initialize PineAPPL routines
          call APPL_init
c      Keep track of the position of this histogram
          nh_obs = nh_obs + 1
          ih_obs(nh_obs) = id
       endif

c      -- Call C++ back end function --
       call rbook_be_(id,name,len(name),nbin,xlo,xhi)

       return
       end

c      --------------------------------------------
c      RBOOK2 front end -- Create ROOT TH2 histogram
c      --------------------------------------------
       subroutine rbook2(id,name,xbin,xlo,xhi,ybin,ylo,yhi)
       character*(*) name
       integer id,nbinx,nbiny
       double precision xbin,xlo,xhi,ybin,ylo,yhi

       nbinx = int((xhi-xlo)/(xbin*0.9999d0))
       nbiny = int((yhi-ylo)/(ybin*0.9999d0))
c      -- Call C++ back end function --
       call rbook2_be_(id,name,len(name),nbinx,xlo,xhi,nbiny,ylo,yhi)

       return
       end

c      ------------------------------------------
c      RFILL front end -- Fill ROOT TH1 histogram
c      ------------------------------------------
       subroutine rfill(ihisto,xval,wgt)
       integer ihisto
       double precision xval,wgt

c      PineAPPL commons
       include "reweight_pineappl.inc"
       include "pineappl_common.inc"
       logical pineappl
       common /for_pineappl/ pineappl
       integer j
c
       if(pineappl)then
          do j=1,nh_obs
             if(ihisto.eq.ih_obs(j))then
                appl_obs_num   = j
                appl_obs_histo = xval
c      Fill the reference PineAPPL histograms
c      Fill the PineAPPL files
                call APPL_fill
             endif
          enddo
       endif

c      -- Call C++ back end function --
       call rfill_be_(ihisto,xval,wgt)

       return
       end

c      ------------------------------------------
c      RFILL2 front end -- Fill ROOT TH2 histogram
c      ------------------------------------------
       subroutine rfill2(ihisto,xval,yval,wgt)
       integer ihisto
       double precision xval,yval,wgt

c      -- Call C++ back end function --
       call rfill2_be_(ihisto,xval,yval,wgt)

       return
       end

c     -------------------------------------------
c     ROPERA frond end -- Manipulate histograms
c     ------------------------------------------
      subroutine ropera(ih1,oper,ih2,ih3,x,y)
      integer ih1,ih2,ih3
      character*(*) oper
      double precision x,y

c     PineAPPL commons
      include "reweight_pineappl.inc"
      include "pineappl_common.inc"
      logical pineappl
      common /for_pineappl/ pineappl
      integer j
      if(pineappl)then
         do j=1,nh_obs
            if(ih1.eq.ih_obs(j))then
               appl_obs_num = j
               call APPL_term
            endif
         enddo
      endif

c     -- Call C++ back end function --
      call ropera_be_(ih1,oper,len(oper),ih2,ih3,x,y)

      return
      end

c     -------------------------------------------
c     ROPERA frond end -- Copy histograms
c     ------------------------------------------
      subroutine rcopy(ih1,ih2)
      integer ih1,ih2

c     -- Call C++ back end function --
      call rcopy_be_(ih1,ih2)

      return
      end

C This is a dummy subroutine that is called during integration, but
C should not do anything when ROOT is linked.
      subroutine accum(incl)
      logical incl
      end
      subroutine addfil(string)
      character*(*) string
      end


text:
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++!
!                          Futility Development Group                          !
!                             All rights reserved.                             !
!                                                                              !
! Futility is a jointly-maintained, open-source project between the University !
! of Michigan and Oak Ridge National Laboratory.  The copyright and license    !
! can be found in LICENSE.txt in the head directory of this repository.        !
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++!
PROGRAM testGeom_Line
#include "UnitTest.h"
USE ISO_FORTRAN_ENV
USE UnitTest
USE IntrType
USE Constants_Conversion
USE ParameterLists
USE Geom

IMPLICIT NONE

TYPE(PointType) :: point,point2,point3
TYPE(PointType) :: points(2),points2(2),points3(2)
TYPE(LineType) :: line1,line2,lines(2),dis
INTEGER(SIK) :: ldim(2)
REAL(SRK) :: d,mu1,mu2,s(2)
LOGICAL(SBK) :: bool

CREATE_TEST('Test Geom')
CALL eParams%setQuietMode(.TRUE.)
CALL eParams%setStopOnError(.FALSE.)

REGISTER_SUBTEST('Test Lines',TestLine)

FINALIZE_TEST()
!
!===============================================================================
CONTAINS
!
!-------------------------------------------------------------------------------
SUBROUTINE TestLine
!The LineType constructor allocates sp and ep, care should
!be taken not to code memory leaks. This is why clearPoints() exists.
  COMPONENT_TEST('%clear()')
  !Initialize by hand
  CALL line1%p1%init(DIM=2,X=0.0_SRK,Y=0.0_SRK)
  CALL line1%p2%init(DIM=2,X=1.0_SRK,Y=1.0_SRK)
!
!Test clear
  CALL line1%clear()
  bool=.NOT.(line1%p1%dim /= 0 .OR. line1%p2%dim /= 0 .OR. &
      ALLOCATED(line1%p1%coord) .OR. ALLOCATED(line1%p2%coord))
  ASSERT(bool, 'line1%clear()')

  !Redundant call to clear
  CALL line1%clear()
!
!Test init
  COMPONENT_TEST('%init()')
  CALL point2%init(DIM=3,X=0.1_SRK,Y=0.2_SRK,Z=0.3_SRK)
  CALL point3%init(DIM=3,X=0.4_SRK,Y=0.5_SRK,Z=0.6_SRK)
  CALL line1%set(point2,point3)
  bool=.NOT.(line1%p1%dim /= 3 .OR. line1%p2%dim /= 3 .OR. &
      line1%p1%coord(1) /= 0.1_SRK .OR. line1%p1%coord(2) /= 0.2_SRK .OR. &
      line1%p1%coord(3) /= 0.3_SRK .OR. line1%p2%coord(1) /= 0.4_SRK .OR. &
      line1%p2%coord(2) /= 0.5_SRK .OR. line1%p2%coord(3) /= 0.6_SRK)
  ASSERT(bool, 'line1%set(...)')
  CALL line1%clear()

  !Redundant call to test input error
  CALL line1%set(point,point2)
  bool = .NOT.(line1%p1%dim /= 0 .OR. line1%p2%dim /= 0 .OR. &
      ALLOCATED(line1%p1%coord) .OR. ALLOCATED(line1%p2%coord))
  ASSERT(bool, 'line1%set(...)')
  CALL line1%clear()
!
!Test getDim
  COMPONENT_TEST('%getDim()')
  CALL line1%set(point2,point3)
  ASSERT(line1%getDim() == 3, 'line1%getDim()')
  CALL line1%clear()

  !Redundant call to test input error
  ASSERT(line1%getDim() == 0, 'line1%getDim()')
!
!Test length
  COMPONENT_TEST('%length()')
  CALL line1%set(point2,point3)
  d=line1%length()
  ASSERT(d .APPROXEQ. 0.519615242270663_SRK, 'line1%length()')
!
!Test midpoint
  COMPONENT_TEST('%midpoint()')
  point=line1%midpoint()
  bool = .NOT.(point%dim /= 3 .OR. .NOT.(point%coord(1) .APPROXEQ. 0.25_SRK) .OR. &
      .NOT.(point%coord(2) .APPROXEQ. 0.35_SRK) .OR. &
      .NOT.(point%coord(3) .APPROXEQ. 0.45_SRK))
  ASSERT(bool, 'line1%midpoint()')
!
!Test intersect
  !2D
  COMPONENT_TEST('%intersectLine()')
  CALL line1%clear()
  CALL line1%p1%init(DIM=2,X=0.0_SRK,Y=0.0_SRK)
  CALL line1%p2%init(DIM=2,X=0.0_SRK,Y=1.0_SRK)
  CALL line2%p1%init(DIM=2,X=1.0_SRK,Y=0.0_SRK)
  CALL line2%p2%init(DIM=2,X=1.0_SRK,Y=1.0_SRK)
  !Overlap
  point=line1%intersectLine(line1)
  ASSERT(point%dim == -2, 'line1%intersectLine(...)')
  !disjoint
  point=line1%intersectLine(line2)
  ASSERT(point%dim == -3, 'line1%intersectLine(...)')
  !Normal
  CALL line1%clear()
  CALL line2%clear()
  CALL line1%p1%init(COORD=(/0.0_SRK,0.0_SRK/))
  CALL line1%p2%init(COORD=(/0.0_SRK,1.0_SRK/))
  CALL line2%p1%init(COORD=(/-0.5_SRK,0.5_SRK/))
  CALL line2%p2%init(COORD=(/1.0_SRK,0.5_SRK/))
  point=line1%intersectLine(line2)
  bool = .NOT.(point%dim /= 2 .OR. .NOT.(point%coord(1) .APPROXEQ. 0.0_SRK) .OR. &
      .NOT.(point%coord(2) .APPROXEQ. 0.5_SRK))
  ASSERT(bool, 'line1%intersectLine(...)')

  !Test for within rounding error of intersect
  CALL line1%clear()
  CALL line2%clear()
  CALL line1%p1%init(COORD=(/0.23706666666670007_SRK,-0.3041650000000002_SRK/))
  CALL line1%p2%init(COORD=(/0.23706666666670007_SRK, 0.64833499999999977_SRK/))
  CALL line2%p1%init(COORD=(/-0.11302999999999996_SRK,-0.30416500000000024_SRK/))
  CALL line2%p2%init(COORD=(/0.93725999999999998_SRK,-0.30416500000000024_SRK/))
  point=line1%intersectLine(line2)
  ASSERT(point%dim == 2,'line1%intersectLine(...)')
  bool=ALL(point%coord .APPROXEQ. (/0.23706666666670007_SRK,-0.3041650000000002_SRK/))
  ASSERT(bool,'%coord')
  !3D
  CALL line1%clear()
  CALL line2%clear()
  CALL line1%p1%init(COORD=(/0.0_SRK,0.0_SRK,0.0_SRK/))
  CALL line1%p2%init(COORD=(/1.0_SRK,1.0_SRK,1.0_SRK/))
  CALL line2%p1%init(COORD=(/0.0_SRK,0.0_SRK,1.0_SRK/))
  CALL line2%p2%init(COORD=(/1.0_SRK,0.0_SRK,1.0_SRK/))
  !Overlap
  point=line1%intersectLine(line1)
  ASSERT(point%dim == -2, 'line1%intersectLine(...)')
  !disjoint
  point=line1%intersectLine(line2)
  ASSERT(point%dim == -3, 'line1%intersectLine(...)')
  !Normal
  CALL line1%clear()
  CALL line2%clear()
  CALL line1%p1%init(COORD=(/0.0_SRK,0.0_SRK,0.0_SRK/))
  CALL line1%p2%init(COORD=(/1.0_SRK,1.0_SRK,1.0_SRK/))
  CALL line2%p1%init(COORD=(/1.0_SRK,0.0_SRK,0.0_SRK/))
  CALL line2%p2%init(COORD=(/0.0_SRK,1.0_SRK,1.0_SRK/))
  point=line1%intersectLine(line2)
  bool = .NOT.(point%dim /= 3 .OR. .NOT.(point%coord(1) .APPROXEQ. 0.5_SRK) .OR. &
      .NOT.(point%coord(2) .APPROXEQ. 0.5_SRK) .OR. &
      .NOT.(point%coord(3) .APPROXEQ. 0.5_SRK))
  ASSERT(bool, 'line1%intersectLine(...)')

  !Redundant calls to test error checking.
  CALL line2%clear()
  point=line1%intersectLine(line2) !mismatched dimensions
  ASSERT(point%dim == -1, 'point=line1%intersectLine(line2)')
  CALL line1%clear()
  CALL line1%p1%init(DIM=1,X=0.5_SRK)
  CALL line1%p2%init(DIM=1,X=0.0_SRK)
  point=line1%intersectLine(line1)
  ASSERT(point%dim == -2, '1-D line1%intersectLine(...)')

  CALL line1%clear()
  CALL line2%clear()
  CALL line1%p1%init(COORD=(/0.0_SRK,0.0_SRK/))
  CALL line1%p2%init(COORD=(/0.0_SRK,1.0_SRK/))
  CALL line2%p1%init(COORD=(/-0.5_SRK,2.5_SRK/))
  CALL line2%p2%init(COORD=(/1.0_SRK,2.5_SRK/))
  point=line1%intersectLine(line2)
  ASSERT(point%dim == -3, 'line1%intersectLine(...)')

!Test for %distance2Line(...)
  COMPONENT_TEST('%distance2Line()')
  !Line dimension error check
  CALL line1%clear()
  CALL line2%clear()
  CALL dis%clear()
  CALL line1%p1%init(COORD=(/0.0_SRK,0.0_SRK/))
  CALL line1%p2%init(COORD=(/0.0_SRK,1.0_SRK/))
  CALL line2%p1%init(COORD=(/0.0_SRK,0.0_SRK,-1.0_SRK/))
  CALL line2%p2%init(COORD=(/1.0_SRK,0.0_SRK,-1.0_SRK/))
  CALL line2%distance2Line(line1,dis,mu1,mu2)
  bool = .NOT.(dis%p1%dim /= -1 .AND. dis%p2%dim /= -1)
  ASSERT(bool, 'line2%distance2Line(...)')
  !Line input check
  CALL line1%clear()
  CALL line2%clear()
  CALL dis%clear()
  CALL line1%p1%init(COORD=(/0.0_SRK,0.0_SRK,0.0_SRK/))
  CALL line1%p2%init(COORD=(/0.0_SRK,0.0_SRK,0.0_SRK/))
  CALL line2%p1%init(COORD=(/0.0_SRK,0.0_SRK,-1.0_SRK/))
  CALL line2%p2%init(COORD=(/1.0_SRK,0.0_SRK,-1.0_SRK/))
  CALL line2%distance2Line(line1,dis,mu1,mu2)
  bool = .NOT.(dis%p1%dim /= -1 .AND. dis%p2%dim /= -1)
  ASSERT(bool, 'line2%distance2Line(...)')
  !Overlap
  CALL line1%clear()
  CALL dis%clear()
  CALL line1%p1%init(COORD=(/0.0_SRK,0.0_SRK,-1.0_SRK/))
  CALL line1%p2%init(COORD=(/1.0_SRK,0.0_SRK,-1.0_SRK/))
  CALL line2%distance2Line(line1,dis,mu1,mu2)
  bool = .NOT.(dis%p1%dim /= -2 .AND. dis%p2%dim /= -2)
  ASSERT(bool, 'line2%distance2Line(...)')
  !Parallel
  CALL line1%clear()
  CALL line2%clear()
  CALL dis%clear()
  CALL line1%p1%init(COORD=(/0.0_SRK,0.0_SRK,0.0_SRK/))
  CALL line1%p2%init(COORD=(/1.0_SRK,0.0_SRK,0.0_SRK/))
  CALL line2%p1%init(COORD=(/0.0_SRK,0.0_SRK,-1.0_SRK/))
  CALL line2%p2%init(COORD=(/1.0_SRK,0.0_SRK,-1.0_SRK/))
  CALL line2%distance2Line(line1,dis,mu1,mu2)
  bool = .NOT.(dis%p1%dim /= -3 .AND. dis%p2%dim /= -3)
  ASSERT(bool, 'line2%distance2Line(...)')
  !Normal with interscetion
  CALL line1%clear()
  CALL line2%clear()
  CALL dis%clear()
  CALL line1%p1%init(COORD=(/0.0_SRK,0.0_SRK,0.0_SRK/))
  CALL line1%p2%init(COORD=(/0.0_SRK,0.0_SRK,1.0_SRK/))
  CALL line2%p1%init(COORD=(/0.0_SRK,0.0_SRK,-1.0_SRK/))
  CALL line2%p2%init(COORD=(/1.0_SRK,0.0_SRK,-1.0_SRK/))
  CALL line2%distance2Line(line1,dis,mu1,mu2)
  bool = .NOT.(dis%getDim() /= 3 .OR. mu1 /= 0._SRK .OR. mu2 /= -1._SRK &
      .OR. dis%p1 /= line2%p1 .OR. dis%length() > EPSREAL)
  ASSERT(bool, 'line2%distance2Line(...)')
  !Normal without interscetion
  CALL line1%clear()
  CALL line2%clear()
  CALL dis%clear()
  CALL line1%p1%init(COORD=(/0.0_SRK,0.0_SRK,0.0_SRK/))
  CALL line1%p2%init(COORD=(/0.0_SRK,1.0_SRK,0.0_SRK/))
  CALL line2%p1%init(COORD=(/0.0_SRK,0.0_SRK,-1.0_SRK/))
  CALL line2%p2%init(COORD=(/1.0_SRK,0.0_SRK,-1.0_SRK/))
  CALL line2%distance2Line(line1,dis,mu1,mu2)
  bool = .NOT.(dis%getDim() /= 3 .OR. mu1 /= 0._SRK .OR. mu2 /= 0._SRK &
      .OR. dis%p1 /= line2%p1 .OR. dis%p2 /= line1%p1)
  ASSERT(bool, 'line2%distance2Line(...)')

!Test for %distance2Point(...)
  COMPONENT_TEST('%distance2Point()')
  CALL line1%clear()
  CALL point%clear()
  CALL line1%p1%init(COORD=(/0.0_SRK/))
  CALL line1%p2%init(COORD=(/1.0_SRK/))
  CALL point%init(COORD=(/-0.5_SRK/))
  bool = line1%distance2Point(point) .APPROXEQ. 0.25_SRK
  ASSERT(bool, '1-D line1%distance2Point(...)')
  CALL point%clear()
  CALL point%init(COORD=(/0.5_SRK/))
  bool = line1%distance2Point(point) .APPROXEQ. 0.0_SRK
  ASSERT(bool, '1-D line1%distance2Point(...)')
  CALL point%clear()
  CALL point%init(COORD=(/1.5_SRK/))
  bool = line1%distance2Point(point) .APPROXEQ. 0.25_SRK
  ASSERT(bool, '1-D line1%distance2Point(...)')

  CALL line1%clear()
  CALL point%clear()
  CALL line1%p1%init(COORD=(/0.0_SRK,0.0_SRK/))
  CALL line1%p2%init(COORD=(/1.0_SRK,1.0_SRK/))
  CALL point%init(COORD=(/-0.5_SRK/))
  ASSERT(line1%distance2Point(point) == -1.0_SRK, '2-D line1%distance2Point(...)')
  CALL point%clear()
  CALL point%init(COORD=(/0.5_SRK,0.5_SRK/))
  ASSERT(line1%distance2Point(point) .APPROXEQ. 0.0_SRK, '2-D line1%distance2Point(...)')
  CALL point%clear()
  CALL point%init(COORD=(/0.0_SRK,0.5_SRK/))
  bool = line1%distance2Point(point) .APPROXEQ. 0.125_SRK
  ASSERT(bool, '2-D line1%distance2Point(...)')
  CALL point%clear()
  CALL point%init(COORD=(/2.0_SRK,0.5_SRK/))
  bool = line1%distance2Point(point) .APPROXEQ. 1.25_SRK
  ASSERT(bool, '2-D line1%distance2Point(...)')
  CALL point%clear()
  CALL point%init(COORD=(/-0.5_SRK,-1.0_SRK/))
  bool = line1%distance2Point(point) .APPROXEQ. 1.25_SRK
  ASSERT(bool, '2-D line1%distance2Point(...)')

  CALL line1%clear()
  CALL point%clear()
  CALL line1%p1%init(COORD=(/0.0_SRK,0.0_SRK,0.0_SRK/))
  CALL line1%p2%init(COORD=(/1.0_SRK,1.0_SRK,1.0_SRK/))
  CALL point%init(COORD=(/0.5_SRK,0.5_SRK,0.5_SRK/))
  bool = line1%distance2Point(point) .APPROXEQ. 0.0_SRK
  ASSERT(bool, '3-D line1%distance2Point(...)')
  CALL point%clear()
  CALL point%init(COORD=(/0.5_SRK,0.5_SRK,0.0_SRK/))
  bool = line1%distance2Point(point) .APPROXEQ. 0.1666666666666667_SRK
  ASSERT(bool, '3-D line1%distance2Point(...)')
  CALL point%clear()
  CALL point%init(COORD=(/1.0_SRK,1.0_SRK,2.0_SRK/))
  bool = line1%distance2Point(point) .APPROXEQ. 1.0_SRK
  ASSERT(bool, '3-D line1%distance2Point(...)')
  CALL point%clear()
  CALL point%init(COORD=(/0.0_SRK,0.0_SRK,-1.0_SRK/))
  bool = line1%distance2Point(point) .APPROXEQ. 1.0_SRK
  ASSERT(bool, '3-D line1%distance2Point(...)')

!Test pointIsLeft
  COMPONENT_TEST('%pointIsLeft()')
  CALL point%clear()
  CALL point%init(COORD=(/0.0_SRK,1.0_SRK,-1.0_SRK/))
  ASSERT(line1%pointIsLeft(point),'Point (0.0,1.0,-1.0)')
  CALL point%clear()
  CALL point%init(COORD=(/2.0_SRK,1.0_SRK,-10.0_SRK/))
  ASSERT(.NOT.line1%pointIsLeft(point),'Point (2.0,1.0,-10.0)')
  CALL point%clear()
  CALL point%init(COORD=(/0.5_SRK,0.5_SRK,0.5_SRK/))
  ASSERT(.NOT.line1%pointIsLeft(point),'Point (0.5,0.5,0.5)')

!Test pointIsLeft
  CALL point%clear()
  CALL point%init(COORD=(/2.0_SRK,1.0_SRK,-10.0_SRK/))
  COMPONENT_TEST('%pointIsRight()')
  ASSERT(line1%pointIsRight(point),'Point (2.0,1.0,-10.0)')
  CALL point%clear()
  CALL point%init(COORD=(/0.0_SRK,1.0_SRK,-1.0_SRK/))
  ASSERT(.NOT.line1%pointIsRight(point),'Point (0.0,1.0,-1.0)')
  CALL point%clear()
  CALL point%init(COORD=(/0.5_SRK,0.5_SRK,0.5_SRK/))
  ASSERT(.NOT.line1%pointIsLeft(point),'Point (0.5,0.5,0.5)')

  !Test for equivalence operation
  COMPONENT_TEST('OPERATOR(==)')
  line2=line1
  ASSERT(line1 == line2,'3-D line equivalence')
  CALL line1%clear()
  CALL line2%clear()
  CALL line1%p1%init(COORD=(/0.0_SRK,0.0_SRK/))
  CALL line1%p2%init(COORD=(/1.0_SRK,1.0_SRK/))
  line2=line1
  ASSERT(line1 == line2,'2-D line equivalence')
  CALL line2%clear()
  CALL line2%p1%init(COORD=(/0.0_SRK,0.0_SRK,0.0_SRK/))
  CALL line2%p2%init(COORD=(/1.0_SRK,1.0_SRK,1.0_SRK/))
  ASSERT(.NOT.(line1 == line2),'2-D and 3-D line non-equivalence')

  CALL points2%clear()
  CALL points3%clear()
  CALL points2(1)%init(DIM=3,X=0.5_SRK,Y=0.6_SRK,Z=0.7_SRK)
  CALL points2(2)%init(DIM=2,X=0.5_SRK,Y=0.6_SRK)
  points3=points2
  points3(1)%coord=points3(1)%coord+0.1_SRK
  points3(2)%coord=points3(2)%coord+0.1_SRK
!This no longer works with Intel 12
  COMPONENT_TEST('Elemental %set()')
  CALL lines%set(points2,points3)
!      CALL lines(1)%set(points2(1),points3(1))
!      CALL lines(2)%set(points2(2),points3(2))
  bool = .NOT.(lines(1)%p1%dim /= 3 .OR. lines(1)%p2%dim /= 3 .OR. &
      ANY(.NOT.(lines(1)%p1%coord .APPROXEQ. (/0.5_SRK,0.6_SRK,0.7_SRK/))) .OR. &
      ANY(.NOT.(lines(1)%p2%coord .APPROXEQ. (/0.6_SRK,0.7_SRK,0.8_SRK/))) .OR. &
      lines(2)%p1%dim /= 2 .OR. lines(2)%p2%dim /= 2 .OR. &
      ANY(.NOT.(lines(2)%p1%coord .APPROXEQ. (/0.5_SRK,0.6_SRK/))) .OR. &
      ANY(.NOT.(lines(2)%p2%coord .APPROXEQ. (/0.6_SRK,0.7_SRK/))))
  ASSERT(bool, 'lines%set(...)')

  COMPONENT_TEST('Elemental %getDim()')
  ldim=lines%getDim()
  bool = .NOT.(ldim(1) /= 3 .OR. ldim(2) /= 2)
  ASSERT(bool, 'lines%getDim()')

  COMPONENT_TEST('Elemental %length()')
  s=lines%length()
  bool = .NOT.(.NOT.(s(1) .APPROXEQ. 0.173205080756888_SRK) .OR. &
      .NOT.(s(2) .APPROXEQ. 0.141421356237309_SRK))
  ASSERT(bool, 'lines%length()')

  COMPONENT_TEST('Elemental %midPoint()')
  points=lines%midPoint()
  bool = .NOT.(ANY(.NOT.(points(1)%coord .APPROXEQ. (/0.55_SRK,0.65_SRK,0.75_SRK/))) .OR. &
      ANY(.NOT.(points(2)%coord .APPROXEQ. (/0.55_SRK,0.65_SRK/))))
  ASSERT(bool, 'lines%midPoint()')

  COMPONENT_TEST('Elemental %intersectLine()')
  points=lines%intersectLine(lines)
  bool = .NOT.(points(1)%dim /= -2 .OR. points(2)%dim /= -2)
  ASSERT(bool, 'lines%intersectLine(...)')

 !diss=lines%distance2Line(lines)
 ! IF(diss(1)%p(1)%dim /= -2 .OR. diss(2)%p(1)%dim /= -2) THEN
 !   WRITE(*,*) 'lines%distance2Line(...) FAILED!'
 !   STOP 666
 ! ELSE
 !   WRITE(*,*) '  Passed: lines%distance2Line(...)'
 ! ENDIF
 !
  COMPONENT_TEST('Elemental %distance2Point()')
  points=lines%midPoint()
  s=lines%distance2Point(points)
  bool = .NOT.(ANY(.NOT.(s .APPROXEQ. 0.0_SRK)))
  ASSERT(bool, 'lines%distance2Point(...)')

  COMPONENT_TEST('Elemental %clear()')
  CALL lines%clear()
  bool = .NOT.((lines(1)%p1%dim /= 0) .OR. (lines(1)%p2%dim /= 0) .OR. &
      (lines(2)%p1%dim /= 0) .OR. (lines(2)%p2%dim /= 0) .OR. &
      ALLOCATED(lines(1)%p1%coord) .OR. ALLOCATED(lines(1)%p2%coord) .OR. &
      ALLOCATED(lines(2)%p1%coord) .OR. ALLOCATED(lines(2)%p2%coord))
  ASSERT(bool, 'lines%clear(...)')
ENDSUBROUTINE TestLine

ENDPROGRAM testGeom_Line

max_stars_repo_name: wgurecky/Futility

max_issues_repo_name: wgurecky/Futility

max_forks_repo_name: wgurecky/Futility


text:
	 Function ReadF(String)
	 Implicit Real*8 (A-H,O-Z)

	 Character(*) String
	 Character(len=Len(String)) buf
	 Character(1) bf

     ll=Len_Trim(String)
	 ls=Len(String)
     buf=repeat(' ',ls)
	 bf=' '
	 iSgn=1
	 Do i=1,ll
	    If (string(i:i)==' ') Cycle
	    If (string(i:i)=='.') Exit
		If (string(i:i)=='-') Then
		   iSgn=-1
		   cycle
		Endif
		buf(i:i)=string(i:i)
	 enddo
	 buf=ADJUSTR(buf)
	 Read(buf,'(i<ls>)')Ibuf
	 ReadF=Dble(Ibuf)

     If (i+1<=ll) Then
	    k=0
	    Do j=i+1,ll
		   If (string(j:j)==' ') Exit
		   k=k+1
		   bf=string(j:j)
		   Read(bf,'(i1)')Ibuf
		   ReadF=ReadF+Dble(Ibuf)*10.d0**(-k)
		enddo
	 endif
	 If (iSgn<0) ReadF=-ReadF
	 Return
end

max_stars_repo_name: skignatov/ReadExcitedStates

max_issues_repo_name: skignatov/ReadExcitedStates

max_forks_repo_name: skignatov/ReadExcitedStates


text:
// openssl rand -hex 64
// change random value for better security.
DefConst('kNVSeedInitValue, SetClass("\u0ec3f2862d8225ccc10b3769b4c5f9a889196ca264026d1b07393a1d1d381d8f25595f2d3946043af8aa6d2c7a5b5ae0beea1576949eca519e3cd4c2f19afc8e", 'binary));

max_stars_repo_path: NTK Projects/seed.f

max_stars_repo_name: pguyot/mbedtls-NewtonOS

max_issues_repo_path: NTK Projects/seed.f

max_issues_repo_name: pguyot/mbedtls-NewtonOS

max_forks_repo_path: NTK Projects/seed.f

max_forks_repo_name: pguyot/mbedtls-NewtonOS


text:
	INCLUDE 'VICMAIN_FOR'
	SUBROUTINE MAIN44
C
C     2  MAY 89   ...REA...    INITIAL RELEASE
C    12  AUG 93   ...REA...    PORT TO UNIX
C
	REAL BUF(800)
	CHARACTER*80 PR
C								open input
	CALL XVUNIT(INUNIT,'INP',1,ISTAT,' ')
	CALL XVOPEN(INUNIT,ISTAT,'OPEN_ACT','SA','IO_ACT','SA',
     +		    'U_FORMAT','REAL',' ')
C
	CALL XVMESSAGE(' ',' ')
	CALL XVMESSAGE(
     +	'Tiepoint  New Line   New Sample     Old Line   Old Sample',' ')
	CALL XVMESSAGE(
     +	'--------  --- ----   --- ------     --- ----   --- ------',' ')
C
	DO I=1,10
	    CALL XVREAD(INUNIT,BUF,ISTAT,' ')
	    DO N=1,200
		J = 4*N-3
C
		IF (BUF(J) .EQ. 0.0 .AND. BUF(J+1) .EQ. 0.0) GO TO 100
		WRITE (PR,50) N,BUF(J),BUF(J+1),BUF(J+2),BUF(J+3)
   50		FORMAT(I6,F11.2,F12.2,F14.2,F12.2)
		CALL XVMESSAGE(PR,' ')
	    END DO
	END DO
C
  100	CONTINUE
	CALL XVMESSAGE(' ',' ')
	RETURN
	END

max_stars_repo_name: NASA-AMMOS/VICAR

max_issues_repo_name: NASA-AMMOS/VICAR

max_forks_repo_name: NASA-AMMOS/VICAR


text:
This list was compiled by members of the City of Davis Davis Climate Action Team and concerned citizens who want to live more responsibly. We have created a list of suggestions for a greener holiday celebration. The following ideas are just to get you started. Get two for one this holiday season: give a gift to your loved ones that’s also a gift to the planet.

What a relief not to face traffic and crowds in unfamiliar shopping malls.  Limit yourself to friendly Davis and Yolo County for your gift shopping this year. Reduce stress, lower your carbon footprint and help the local economy.

 Give the gift of sustainable living

Many folks appreciate a practical gift that also helps Mother Earth.  Why not go the next step—shop locally and buy products that save energy and promote healthy living?

 Energy Efficiency

   Give the gift of a light bulb  compact fluorescent lights (with the potential energy savings of 75%)
   Give a gift of LED holiday lights with timers (save up to 25% in electricity costs)
   Give a gift of Smart’ power strips (Reducing “phantom load” saves 10% or more of home electricity consumption)
   Give a torchiere light (can now be purchased with CFL bulbs)
   Give a gift of occupancy sensors (sensor turns on light with motion and turns light off after set number of minutes).
   Give a books book on energy efficiency.
    Even better, give http://ourchoicethebook.com/ Our Choice: A Plan to Solve the Climate Crisis
   Give an Iphone solar charger
   Give a solar cooker
   Give green cleaning products
   Give a reusable http://www.chicobag.com/ Chico Bag available at B & L Bike Shop & Davis Food Coop
   Give a http://www.kleankanteen.com/ Klean Kanteen or http://www.camelbak.com/en/sportsrecreation/bottles.aspx CamelBak Bottle available at Davis Food Coop, B & L Bike Shop & Davis Outdoor
   Give a clothesline and clothes pins or a drying rack
   Give the gift of a cooler home and save water by planting a tree, building a trellis, growing droughttolerant plants, or installing awnings.
   Give an electric, push or reel lawn mower.
   Give a gift of duct sealing or insulation
   Give a gift of natural light with installation of a solar tubular skylight
   Give a gift of a composter, rain barrel or worm bin
   http://treedavis.org/dedicate.php Dedicate a tree through Tree Davis!
   Or if you want to give a bigger ticket item,: energy efficient water heaters, windows, solar thermal, solar photovoltaic,  whole house fan, energy star appliances, computers and tvs (Check for rebates at www.pge.com/rebates/ )
   Give a gift of Contraception birth control. wiki:WikiPedia:Overpopulation may be http://www.sciencedaily.com/releases/2009/04/090418075752.htm the worst environmental problem on Earth.

To get more ideas from the City of Davis/ Valley Climate Action Center 2009 Energy Efficiency Forum: experts from UC Davis, Davis Energy Group , Verve Solar and the City of Davis identify energy efficiency actions you can take at home.
http://eec1.ucdavis.edu/news/Cooling%20the%20Earth%20%20Summary.pdf

 Transportation
  Give a gift of a bus pass
  Give a bicycle or bicycle equipment
  Give a bike tune up
  Give a gift of walking shoes
  Give bicycle panniers and shopping bags
  Give a membership to Zipcar
  Or if you are looking for a bigger ticket item, give the gift of an all electric vehicle or hybrid vehicle

 Shop local

  Give a gift from downtown Davis.
  Give a gift from Yolo County.
  Regift at a Thrift Stores thrift store
  Find local resources at Front Page DavisWiki.
  Find local businesses at Davis Chamber of Commerce.
  Find local downtown business at Davis Downtown Business Association.

You’ll find fresh and unique gifts while you save time and fuel when you purchase from local vendors.  Don’t miss out on these special products.  Add your own to the list below.

  Give a gift from a local seller at the Davis Farmers Market or the Davis Flea Market.
  Give a subscription to a Community Supported Agriculture box from a local farm.
  Give a work of art.
  Give a one of a kind gift from The Artery
  Give olive oil or wine from Yolo County.
  Give a membership to Slow Food Yolo
  Give a gift from the Davis Art Center Holiday Sale

 Give a local experience

We all get too busy with our lives, but the gifts below help us slow down and enjoy quality time together.  The hardest part will be deciding which activity to give—this list is just the beginning of many local possibilities.

  Give a membership to a Museums museum.
  Give the gift of a class (such as at the Davis Art Center: www.davisartcenter.org/classes.html, Experimental College: http://asucd.ucdavis.edu/experimentalcollege, Yolo Master Gardeners  http://ceyolo.ucdavis.edu/
  Give a play at Davis Musical Theatre Company.
  Give the arts from http://theatredance.ucdavis.edu UC Davis Theatre and Dance
  Give a concert from the http://music.ucdavis.edu/events UC Davis Music Department
  Give a performance from the Mondavi Center
  Give a ticket to Acme Theatre Co. Acme Theatre Company
  Give the gift of a movie ticket at a local theatre: http://www.davisvarsity.net Varsity Theatre or http://www.fandango.com/95616_movietheatershowtimes?tidaafzc link to show times
  Give an adventure at Outdoor Adventures
  Give a class at the UC Davis Craft Center
  Give a climb at Rocknasium.
  Give a tee time at a local golf golf course
  Give a ticket to the http://www.cmssacto.org Chamber Music Society of Sacramento  Davis concert series
  Give yoga, dance or fitness lessons
  Give tickets to a romantic ballroom dance:  www.dancingtonight.com,
  Give a cooking class: http://www.davisfood.coop/classes.html
  Give a spa, beauty treatment or message
  Give a meal at a local restaurant.
  Give a Tuleyome or Stebbins Hiking and Backpacking outing: http://yolohiker.org/
  Give a bird watching walk:  http://www.yoloaudubon.org/
  Give a ticket to a film festival
  Give a gift of a visit to a gallery or a museum
  Give a gift of sports sports camps

 Support a local nonprofit

Many folks don’t want any more “things” to clutter their homes, so a gift that helps others is perfect.   Match your gift to the interests of the recipient.  This list provides a start.
For a list of Yolo County nonprofits, see: http://webiii.yolocounty.org:81/

  Give to a local treasure at the UC Davis Arboretum.
  Give to families in need at STEAC.
  Give to those in need at Food Bank of Yolo County.
  Give to global understanding at the International House.
  Give to the wildlife refuge at Yolo Basin Foundation
  Give to a healthy creek at the Putah Creek Council
  Give to protecting the wild heritage of Yolo County at Tuleyome
  Give a gift to Davis Schools: http://www.davis.k12.ut.us/district/foundation/
  Give a gift to help women and children: http://www.sadvc.org/
  Give a gift of health: http://www.communicarehc.org/

 Give a handmade or recycled gift

Nothing is more touching than something made especially for you by hand.  Challenge yourself to use local and recycled materials in your crafts.  There’s no end to what you can create.

  Give a gift of a food basket (try Fruit and Vegetable Stands local foods!)
  Give a gift of homemade food including mixes, bread, jams and meal coupons
  Give a gift of dress up clothes from the thrift store
  Give a gift of handmade jewelry
  Give a gift of homemade craft items (candles, holiday cards, quilts, wreaths)
  Give a gift of coupons (babysitting, gardening, making dinner)
  Give a gift of a homemade book of memories, family history, or an original story
  Give a gift of recorded bedtime stories
  Give a gift of music
  Give a gift from a Thrift Stores thrift store
  Give a book from the Friends of the Davis Public Library book sale
  Give a gift of cloth bags for vegetables at the grocery and in the refrigerator
  Give a gift of homemade wrapping papers and gift bags

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


module replace_range_test
    use iso_varying_string, only: replace, var_str
    use veggies, only: result_t, test_item_t, assert_equals, describe, it

    implicit none
    private
    public :: &
            test_replace_character_in_character_range, &
            test_replace_character_in_string_range, &
            test_replace_string_in_character_range, &
            test_replace_string_in_string_range
contains
    function test_replace_character_in_character_range() result(tests)
        type(test_item_t) :: tests

        tests = describe( &
                "Sec. 3.7.4: REPLACE in character with character in range", &
                [ it( &
                        "The characters in the copy of string between positions start" &
                        // " and finish, including those at start and finish, are" &
                        // " deleted and replaced by characters of substring.", &
                        check_replace_character_in_character) &
                , it( &
                        "If start is less than one, the value one is used for start.", &
                        check_replace_character_in_character_start_lt_one) &
                , it( &
                        "If finish is greater than len(string), the value len(string)" &
                        // " is used for finish.", &
                        check_replace_character_in_character_start_gt_end) &
                , it( &
                        "If finish is less than start, the characters of substring" &
                        // " are inserted before the character at start and no" &
                        // " characters are deleted.", &
                        check_replace_character_in_character_start_gt_finish) &
                ])
    end function

    function test_replace_character_in_string_range() result(tests)
        type(test_item_t) :: tests

        tests = describe( &
                "Sec. 3.7.4: REPLACE in string with character in range", &
                [ it( &
                        "The characters in the copy of string between positions start" &
                        // " and finish, including those at start and finish, are" &
                        // " deleted and replaced by characters of substring.", &
                        check_replace_character_in_string) &
                , it( &
                        "If start is less than one, the value one is used for start.", &
                        check_replace_character_in_string_start_lt_one) &
                , it( &
                        "If finish is greater than len(string), the value len(string)" &
                        // " is used for finish.", &
                        check_replace_character_in_string_start_gt_end) &
                , it( &
                        "If finish is less than start, the characters of substring" &
                        // " are inserted before the character at start and no" &
                        // " characters are deleted.", &
                        check_replace_character_in_string_start_gt_finish) &
                ])
    end function

    function test_replace_string_in_character_range() result(tests)
        type(test_item_t) :: tests

        tests = describe( &
                "Sec. 3.7.4: REPLACE in character with string in range", &
                [ it( &
                        "The characters in the copy of string between positions start" &
                        // " and finish, including those at start and finish, are" &
                        // " deleted and replaced by characters of substring.", &
                        check_replace_string_in_character) &
                , it( &
                        "If start is less than one, the value one is used for start.", &
                        check_replace_string_in_character_start_lt_one) &
                , it( &
                        "If finish is greater than len(string), the value len(string)" &
                        // " is used for finish.", &
                        check_replace_string_in_character_start_gt_end) &
                , it( &
                        "If finish is less than start, the characters of substring" &
                        // " are inserted before the character at start and no" &
                        // " characters are deleted.", &
                        check_replace_string_in_character_start_gt_finish) &
                ])
    end function

    function test_replace_string_in_string_range() result(tests)
        type(test_item_t) :: tests

        tests = describe( &
                "Sec. 3.7.4: REPLACE in string with string in range", &
                [ it( &
                        "The characters in the copy of string between positions start" &
                        // " and finish, including those at start and finish, are" &
                        // " deleted and replaced by characters of substring.", &
                        check_replace_string_in_string) &
                , it( &
                        "If start is less than one, the value one is used for start.", &
                        check_replace_string_in_string_start_lt_one) &
                , it( &
                        "If finish is greater than len(string), the value len(string)" &
                        // " is used for finish.", &
                        check_replace_string_in_string_start_gt_end) &
                , it( &
                        "If finish is less than start, the characters of substring" &
                        // " are inserted before the character at start and no" &
                        // " characters are deleted.", &
                        check_replace_string_in_string_start_gt_finish) &
                ])
    end function

    pure function check_replace_character_in_character() result(result_)
        type(result_t) :: result_

        result_ = assert_equals( &
                "THAT WAS CRAZY", &
                replace("THAT IS CRAZY", 6, 7, "WAS"))
    end function

    pure function check_replace_character_in_character_start_lt_one() result(result_)
        type(result_t) :: result_

        result_ = assert_equals( &
                "WAS CRAZY", &
                replace("THAT IS CRAZY", -1, 7, "WAS"))
    end function

    pure function check_replace_character_in_character_start_gt_end() result(result_)
        type(result_t) :: result_

        result_ = assert_equals( &
                "THAT WAS", &
                replace("THAT IS CRAZY", 6, 15, "WAS"))
    end function

    pure function check_replace_character_in_character_start_gt_finish() result(result_)
        type(result_t) :: result_

        result_ = assert_equals( &
                "THAT WASIS CRAZY", &
                replace("THAT IS CRAZY", 6, 1, "WAS"))
    end function

    pure function check_replace_character_in_string() result(result_)
        type(result_t) :: result_

        result_ = assert_equals( &
                "THAT WAS CRAZY", &
                replace(var_str("THAT IS CRAZY"), 6, 7, "WAS"))
    end function

    pure function check_replace_character_in_string_start_lt_one() result(result_)
        type(result_t) :: result_

        result_ = assert_equals( &
                "WAS CRAZY", &
                replace(var_str("THAT IS CRAZY"), -1, 7, "WAS"))
    end function

    pure function check_replace_character_in_string_start_gt_end() result(result_)
        type(result_t) :: result_

        result_ = assert_equals( &
                "THAT WAS", &
                replace(var_str("THAT IS CRAZY"), 6, 15, "WAS"))
    end function

    pure function check_replace_character_in_string_start_gt_finish() result(result_)
        type(result_t) :: result_

        result_ = assert_equals( &
                "THAT WASIS CRAZY", &
                replace(var_str("THAT IS CRAZY"), 6, 1, "WAS"))
    end function

    pure function check_replace_string_in_character() result(result_)
        type(result_t) :: result_

        result_ = assert_equals( &
                "THAT WAS CRAZY", &
                replace("THAT IS CRAZY", 6, 7, var_str("WAS")))
    end function

    pure function check_replace_string_in_character_start_lt_one() result(result_)
        type(result_t) :: result_

        result_ = assert_equals( &
                "WAS CRAZY", &
                replace("THAT IS CRAZY", -1, 7, var_str("WAS")))
    end function

    pure function check_replace_string_in_character_start_gt_end() result(result_)
        type(result_t) :: result_

        result_ = assert_equals( &
                "THAT WAS", &
                replace("THAT IS CRAZY", 6, 15, var_str("WAS")))
    end function

    pure function check_replace_string_in_character_start_gt_finish() result(result_)
        type(result_t) :: result_

        result_ = assert_equals( &
                "THAT WASIS CRAZY", &
                replace("THAT IS CRAZY", 6, 1, var_str("WAS")))
    end function

    pure function check_replace_string_in_string() result(result_)
        type(result_t) :: result_

        result_ = assert_equals( &
                "THAT WAS CRAZY", &
                replace(var_str("THAT IS CRAZY"), 6, 7, var_str("WAS")))
    end function

    pure function check_replace_string_in_string_start_lt_one() result(result_)
        type(result_t) :: result_

        result_ = assert_equals( &
                "WAS CRAZY", &
                replace(var_str("THAT IS CRAZY"), -1, 7, var_str("WAS")))
    end function

    pure function check_replace_string_in_string_start_gt_end() result(result_)
        type(result_t) :: result_

        result_ = assert_equals( &
                "THAT WAS", &
                replace(var_str("THAT IS CRAZY"), 6, 15, var_str("WAS")))
    end function

    pure function check_replace_string_in_string_start_gt_finish() result(result_)
        type(result_t) :: result_

        result_ = assert_equals( &
                "THAT WASIS CRAZY", &
                replace(var_str("THAT IS CRAZY"), 6, 1, var_str("WAS")))
    end function
end module


text:
! { dg-do run }
! { dg-options "-fbounds-check" }
! PR fortran/19777
      implicit none
      integer          npts
      parameter        (npts=10)
      double precision v(npts)
      double precision w(npts,npts,npts)
      external         init1
      external         init2

      call init1 (npts, v)
      call init2 (npts, w)
      end

      subroutine init1 (npts, v)
      implicit none
      integer          npts
      double precision v(*)

      integer          i

      do 10 i = 1, npts
         v(i) = 0
 10   continue
      end

      subroutine init2 (npts, w)
      implicit none
      integer          npts
      double precision w(npts,npts,*)

      integer          i

      do 20 i = 1, npts
         w(i,1,1) = 0
         w(1,npts,i) = 0
 20   continue
      end

max_issues_repo_name: sujankh/rose-matlab

max_forks_repo_name: sujankh/rose-matlab


text:
      subroutine qdthin(dtrans,dcod,nord,al,ak,
     $     k1,idp,dx,dy,theta,iv,nut)
      use ffs
      use ffs_pointer
      use tffitcode
      use multa, only:fact
      implicit none
      integer*4 ,intent(in):: nut,k1,idp,iv,nord
      integer*4 kord
      real*8 ,intent(inout):: dtrans(4,5),dcod(6)
      real*8 ,intent(in):: al,ak,dx,dy
      real*8 trans1(4,5),cod(6),
     $     theta,ala,alb,pr,aki,daki,
     $     a21,a23,a41,a43,a26,a46,
     $     da21,da23,da41,da43,da26,da46
      complex*16 cx,cx1,cx0
      if(iv .eq. 4)then
        call qdrotate(dtrans,dcod,k1,itwissp(k1),idp,dx,dy,nut)
      else
        call qtentu(trans1,cod,utwiss(1,idp,itwissp(k1)),.true.)
        call qchg(trans1,cod,-dx,-dy,theta,.true.)
c     begin initialize for preventing compiler warning
        ala=0.d0
        alb=0.d0
c     end   initialize for preventing compiler warning
        if(al .ne. 0.d0)then
          ala=al/6.d0
          alb=al/1.5d0
          cod(1)=cod(1)+cod(2)*ala
          cod(3)=cod(3)+cod(4)*ala
          trans1(1,:)=trans1(1,:)+trans1(2,:)*ala
          trans1(3,:)=trans1(3,:)+trans1(4,:)*ala
        endif
        pr=1.d0+cod(6)
        kord=nord/2-1
        daki=merge(1.d0,0.5d0,al .eq. 0.d0)/fact(kord)/pr
        aki=ak*daki
        cx0=dcmplx(cod(1),-cod(3))
        cx=merge((1.d0,0.d0),cx0**kord,kord .le. 0)
        cod(2)=cod(2)-aki*dble(cx)
        cod(4)=cod(4)-aki*imag(cx)
        dcod(1)=0.d0
        dcod(2)=-daki*dble(cx)
        dcod(3)=0.d0
        dcod(4)=-daki*imag(cx)
        if(kord .gt. 0)then
          cx1=merge(kord*cx0**(kord-1),(1.d0,0.d0),
     $         kord .gt. 1)
          a21=-aki*dble(cx1)
          a23=-aki*imag(cx1)
          a41=-aki*imag(cx1)
          a43= aki*dble(cx1)
          a26=aki/pr*dble(cx)
          a46=aki/pr*imag(cx)
          da21=-daki*dble(cx1)
          da23=-daki*imag(cx1)
          da41=-daki*imag(cx1)
          da43= daki*dble(cx1)
          da26=daki/pr*dble(cx)
          da46=daki/pr*imag(cx)
          dtrans(1,:)=0.d0
          dtrans(2,:)=da21*trans1(1,:)+da23*trans1(3,:)
          dtrans(3,:)=0.d0
          dtrans(4,:)=da41*trans1(1,:)+da43*trans1(3,:)
          trans1(2,:)=trans1(2,:)+ a21*trans1(1,:)+ a23*trans1(3,:)
          trans1(4,:)=trans1(4,:)+ a41*trans1(1,:)+ a43*trans1(3,:)
          dtrans(2,5)=dtrans(2,5)+da26
          dtrans(4,5)=dtrans(4,5)+da46
          trans1(2,5)=trans1(2,5)+a26
          trans1(4,5)=trans1(4,5)+a46
        endif
        if(al .eq. 0.d0)then
          go to 3000
        endif
        cod(1)=cod(1)+cod(2)*alb
        cod(3)=cod(3)+cod(4)*alb
        dcod(1)=dcod(1)+dcod(2)*alb
        dcod(3)=dcod(3)+dcod(4)*alb
        trans1(1,:)=trans1(1,:)+trans1(2,:)*alb
        trans1(3,:)=trans1(3,:)+trans1(4,:)*alb
        dtrans(1,:)=dtrans(1,:)+dtrans(2,:)*alb
        dtrans(3,:)=dtrans(3,:)+dtrans(4,:)*alb
        cx0=dcmplx(cod(1),-cod(3))
        cx=merge((1.d0,0.d0),cx0**kord,kord .le. 0)
        dcod(2)=dcod(2)-daki*dble(cx)
        dcod(4)=dcod(4)-daki*imag(cx)
        if(kord .gt. 0)then
          cx1=merge(kord*cx0**(kord-1),(1.d0,0.d0),
     $         kord .gt. 1)
          a21=-aki*dble(cx1)
          a23=-aki*imag(cx1)
          a41=-aki*imag(cx1)
          a43= aki*dble(cx1)
          da21=-daki*dble(cx1)
          da23=-daki*imag(cx1)
          da41=-daki*imag(cx1)
          da43= daki*dble(cx1)
          da26=daki/pr*dble(cx)
          da46=daki/pr*imag(cx)
          dtrans(2,:)=dtrans(2,:)+ a21*dtrans(1,:)+ a23*dtrans(3,:)
     1         +da21*trans1(1,:)+da23*trans1(3,:)
          dtrans(4,:)=dtrans(4,:)+ a41*dtrans(1,:)+ a43*dtrans(3,:)
     1         +da41*trans1(1,:)+da43*trans1(3,:)
          dtrans(2,5)=dtrans(2,5)+da26
          dtrans(4,5)=dtrans(4,5)+da46
          dcod(2)=dcod(2)+a21*dcod(1)+a23*dcod(3)
          dcod(4)=dcod(4)+a41*dcod(1)+a43*dcod(3)
        endif
        dcod(1)=dcod(1)+dcod(2)*ala
        dcod(3)=dcod(3)+dcod(4)*ala
        dtrans(1,:)=dtrans(1,:)+dtrans(2,:)*ala
        dtrans(3,:)=dtrans(3,:)+dtrans(4,:)*ala
 3000   continue
        call qchg(dtrans,dcod,0.d0,0.d0,-theta,.false.)
      endif
      return
      end

max_stars_repo_name: noboruatkek/SAD

max_issues_repo_name: noboruatkek/SAD

max_forks_repo_name: noboruatkek/SAD


! RUN: %B/test/Semantics/test_errors.sh %s %flang %t
subroutine s
  !ERROR: 'a' does not follow 'b' alphabetically
  implicit integer(b-a)
end


text:
        !COMPILER-GENERATED INTERFACE MODULE: Wed Feb 11 21:15:05 2015
        MODULE DIGIT__genmod
          INTERFACE
            FUNCTION DIGIT(STRING,ISTART)
              CHARACTER(*), INTENT(IN) :: STRING
              INTEGER(KIND=4), INTENT(IN) :: ISTART
              REAL(KIND=8) :: DIGIT
            END FUNCTION DIGIT
          END INTERFACE
        END MODULE DIGIT__genmod

max_stars_repo_name: openmopac/MOPAC-archive

max_issues_repo_name: openmopac/MOPAC-archive

max_forks_repo_name: openmopac/MOPAC-archive


text:
      integer function omatch (lin, i, pat, j)
      integer lin (128), pat (128)
      integer i, j
      integer bump
      integer locate
      omatch = 0
      if (.not.(lin (i) .eq. -2))goto 23000
      return
23000 continue
      bump = -1
      if (.not.(pat (j) .eq. 97))goto 23002
      if (.not.(lin (i) .eq. pat (j + 1)))goto 23004
      bump = 1
23004 continue
      goto 23003
23002 continue
      if (.not.(pat (j) .eq. 37))goto 23006
      if (.not.(i .eq. 1))goto 23008
      bump = 0
23008 continue
      goto 23007
23006 continue
      if (.not.(pat (j) .eq. 63))goto 23010
      if (.not.(lin (i) .ne. 10))goto 23012
      bump = 1
23012 continue
      goto 23011
23010 continue
      if (.not.(pat (j) .eq. 36))goto 23014
      if (.not.(lin (i) .eq. 10))goto 23016
      bump = 0
23016 continue
      goto 23015
23014 continue
      if (.not.(pat (j) .eq. 91))goto 23018
      if (.not.(locate (lin (i), pat, j + 1) .eq. 1))goto 23020
      bump = 1
23020 continue
      goto 23019
23018 continue
      if (.not.(pat (j) .eq. 110))goto 23022
      if (.not.(lin (i) .ne. 10 .and. locate (lin (i), pat, j + 1) .eq.
     *0))goto 23024
      bump = 1
23024 continue
      goto 23023
23022 continue
      call error (24Hin omatch: can't happen.)
23023 continue
23019 continue
23015 continue
23011 continue
23007 continue
23003 continue
      if (.not.(bump .ge. 0))goto 23026
      i = i + bump
      omatch = 1
23026 continue
      return
      end

max_stars_repo_name: ysBach/irafdocgen

max_issues_repo_name: kirxkirx/iraf

max_forks_repo_name: kirxkirx/iraf