text:
module Mod_nsf_elmope_2ndnew
   use Mod_Mesh
   use Mod_Memor
   use Mod_nsFractionalStep
   use Mod_Element
   use Mod_NavierStokesElement
   use Mod_ConvectiveElement
   use Mod_TimeIntegrator
   use Mod_php_SetTimeIntegrator
   use Mod_nsm_elmdir
   use Mod_NSF_Element

   !For setting pointers
   use Mod_nsm_BaseElmope
   use Mod_nsm_TemperatureCoupling
   use Mod_nsm_ComputeAdvectionVelocity
   use Mod_nsm_NonLinearDerivatives
   use Mod_nsm_PhysicalProperties
   use Mod_nsm_ExternalForces
   use Mod_nsm_InterpolateGradients
   use Mod_nsm_TurbulenceModel
   use Mod_nsm_ComputeGpResidual
   use Mod_nsm_ComputeResidualProjection
   use Mod_nsm_InterpolateResidualProjection
   use Mod_nsm_SubgridSpaceResidual
   use Mod_nsm_ComputeTauSmoothing
   use Mod_nsm_ComputeTaus
   use Mod_nsm_ComputeTestf
   use Mod_nsm_ComputeSubscales
   use Mod_nsm_ComputeNonLinearSubscales
   use Mod_nsm_ComputeDissipation
   use Mod_nsf_DynSubsElmope
   use Mod_nsm_SwitchOff
   use Mod_nsm_LevelSetCoupling
   use Mod_nsm_FreeSurfaceMatrices2nd
   use Mod_nsm_HangingNodes
   use Mod_nsf_FreeSurfaceStabilization_elmope2nd
   implicit none

   class(nsFractionalStepProblem), pointer :: b => NULL()

   real(rp) :: gplapu(3)      !Velocity laplacian
   real(rp), allocatable :: elveloc(:,:)

   real(rp) :: divvel2

   logical :: IsCrankNicolson

   character(5) :: kfl_tsche_1st_current,kfl_tsche_2nd_current

   integer(ip) :: istep,elemStatus,inode,ipoin
   real(rp), allocatable :: divelvel(:,:)

contains

   !---------------------------------------------------
   !SetPointers
   subroutine SetPointers
      implicit none

      !External Procedures
      procedure() :: NULLSUB

      integer(ip) :: kfl_nonlinear, nelty

      call ResetProcedureComposition

      !------------------------------------------------
      !Defaults
      !Pointers
      ProcPointer_PostGaussElmats => PostGaussElmats

      !-------------------------------------------------------------------
      !Set All Pointers To NULLSUB (in Mod_nsm_BaseElmope)
      call SetPointersAndHooksToNULLSUB

      !------------------------------------------------------------------
      !Initialize the ProcedureFlags
      call SetPointersNonLinearDerivatives%Initialize
      call SetPointersExternalForces%Initialize
      call SetPointersAdvectionVelocity%Initialize
      call SetPointersComputeTaus%Initialize
      call SetPointersPhysicalProperties%Initialize
      call SetPointersTurbulenceModel%Initialize
      call SetPointersDynSubsElmope2nd(0)
      call SetPointersInterpolateResidualProjection%Initialize
      call SetPointersInterpolateGradients%Initialize
      call SetPointersSwitchOff%Initialize
      call SetPointersLevelSetCoupling%Initialize
      call SetPointersFreeSurfaceMatrices2nd(0)
      call SetPointersHangingNodes%Initialize
      call SetPointersFSS_Elmope2nd%Initialize

      !Now we set the pointers
      !------------------------------------------------------------------
      call SetPointersAdvectionVelocity%Set
      call SetPointersExternalForces%Set
      call SetPointersComputeTaus%Set
      call SetPointersTurbulenceModel%Set
      !We always need the gradients here
      call SetPointersInterpolateGradients%Set

      if (a%kfl_repro == 1) then
         call SetPointersInterpolateResidualProjection%Set
         call ConcatenateProcedures(ProcHook_InGaussElmats, InGaussElmrh2ndStep)
      elseif (a%kfl_repro == 2) then
         call SetPointersInterpolateResidualProjection%Set
         call ConcatenateProcedures(ProcHook_InGaussElmats, InGaussElmrh2ndStepSplit)
      else
         call runend('nsf_elmope2nd_onlyready for residual projection')
      endif

      !Repro Skip_FE type
      !-----------------------------------------------------------
      if(a%kfl_repro_SkipFE == 1)then

      elseif(a%kfl_repro_SkipFE == 2)then
         !The force is already in the residual projection, put it also in the regular residual
         call ConcatenateProcedures(ProcHook_InGaussElmats,ForceToelrhp)
      end if
      !-----------------------------------------------------------

      !Non-linear elements
      call a%Mesh%IsNonLinearElement(ielem,kfl_nonlinear)
      if (kfl_nonlinear == 1) then
         if ( a%fvins > zensi ) then
            !call runend('Only Laplacian form ready for nonlinear elements')
         endif
         call SetPointersNonLinearDerivatives%Set
         call ConcatenateProcedures(ProcHook_Interpolates,InterpolateLapU)
         call ConcatenateProcedures(ProcHook_InGaussElmats,InGaussElmatsNonLinear)
      endif

      if (kfl_nonlinear == 1 .or. a%kfl_colev==1) then
         call ConcatenateProcedures(ProcHook_InGauss,InGaussVolumesNonLinear)
         call ConcatenateProcedures(ProcHook_InGaussElmats,ProcPointer_PostGaussElmats)
         ProcPointer_PostGaussElmats => NULLSUB
      endif

      call SetPointersLevelSetCoupling%Set
      call SetPointersFreeSurfaceMatrices2nd(1)
      call SetPointersPhysicalProperties%SetTask('Elmope')
      call SetPointersPhysicalProperties%Set
      call SetPointersFSS_Elmope2nd%Set

      !Dynamic or non-linear subgrid scales
      if (a%kfl_tacsg /= 0) call SetPointersDynSubsElmope2nd(1)

      if (a%kfl_penal == 1) call ConcatenateProcedures(ProcHook_InGaussElmats,PenaltyPressure)

      !Hanging Nodes
      call SetPointersHangingNodes%Set

      !If more than one element type, then pointers should be reset when ielty changes!
      call a%Mesh%GetNelty(nelty)
      if (nelty > 1) ProcHook_OnIeltyChange => OnIeltyChange

      !-----------------------------------------------------------------------
      !Disconnection of elements
      if (a%kfl_SwitchOff == 1) call SetPointersSwitchOff%Set

      !-------------------------------------------------------------------
      !Finalize procedure flags so that we can use them again
      call SetPointersNonLinearDerivatives%Finalize
      call SetPointersAdvectionVelocity%Finalize
      call SetPointersExternalForces%Finalize
      call SetPointersComputeTaus%Finalize
      call SetPointersPhysicalProperties%Finalize
      call SetPointersTurbulenceModel%Finalize
      call SetPointersDynSubsElmope2nd(100)
      call SetPointersInterpolateResidualProjection%Finalize
      call SetPointersInterpolateGradients%Finalize
      call SetPointersSwitchOff%Finalize
      call SetPointersLevelSetCoupling%Finalize
      call SetPointersFreeSurfaceMatrices2nd(100)
      call SetPointersHangingNodes%Finalize
      call SetPointersFSS_Elmope2nd%Finalize

   end subroutine

   !----------------------------------------------------------
   !PostGauss Matrices
   subroutine PostGaussElmats
      implicit none

      ! Viscosity terms : we only consider mu*(grad q, grad p)
      call elmvis(e,dvolt0,1.0_rp,elmat)
   end subroutine

   !-------------------------------------------------------
   ! InGauss RHS contribution
   subroutine InGaussElmrh2ndStep
      implicit none
      call nsm_elmrhf_pre(e,dvol,acden,timom,LHSDtinv,divvel2,gprep,grpre,grvel,gpadv,elrhs)
   end subroutine

   subroutine InGaussElmrh2ndStepSplit
      implicit none
      call nsm_elmrhf_pre_split(e,dvol,acden,timom,LHSdtinv,divvel2,gprep(e%ndime+2),grpre,elrhs)
   end subroutine

   !----------------------------------------------------------
   !NonLinear Elements
   subroutine InGaussVolumesNonLinear
      implicit none
      !DvolsToZero
      dvolt0=0.0_rp
   end subroutine

   subroutine InterpolateLapU
      implicit none
      real(rp) :: aux1(e%pnode)
      integer(ip) :: inode
      integer(ip) :: idime

      do inode = 1,e%pnode
         aux1(inode) = sum(e%hessi(1:e%ndime,inode))
      enddo
      do idime = 1,e%ndime                              ! Contribution from the laplacian term
         gplapu(idime) = dot_product(aux1(1:e%pnode),elvel(idime,1:e%pnode,1))
      end do
   end subroutine

   subroutine InGaussElmatsNonLinear
      implicit none

      call nsf_elm2nd_reslap(e,dvol,timom,acvis,gplapu,elrhs)
   end subroutine

   subroutine OnIeltyChange
      implicit none

      if (e%ielty /= ielty0) then
         call SetPointers
         ielty0 = e%ielty
      endif
    end subroutine

    !For Skip_FE 2, the force term is put in the residual and its projection
    subroutine ForceToelrhp
       implicit none
       real(rp) :: eltemp(e%ndime)

       !Compute Elext
       elext=0.0_rp
       !Compute vector of external forces without rhs-temporal
       call ProcPointer_ExternalForces

       eltemp = 0.0_rp
       call nsm_elmrhp(e,timom,dvol,elext,eltemp,elrhs)
    end subroutine

   !PenaltyTerm
   subroutine PenaltyPressure
      implicit none
      integer(ip) :: inode

      do inode = 1,e%pnode
         elmat(1,inode,1,inode) = elmat(1,inode,1,inode) + a%penal*dvol
      enddo
   end subroutine

end module

subroutine nsf_elmope_2ndNew(NSProblem)
   use typre
   use Mod_nsf_elmope_2ndnew
   use Mod_nsFractionalStep
   use Mod_NSF_Element
   implicit none
   class(NSFractionalStepProblem), target :: NSProblem

   !real(rp) :: divvel2

   a => NSProblem%NavierStokesProblem
   b => NSProblem

   !Set Pointers for Execution
   ielem = 1
   call SetPointers

   call a%Mesh%ElementAlloc(e,a%Memor,'DefaultRule','nsm_elmope')

   !Matrix Allocate
   call a%Memor%alloc(1,e%mnode,1,e%mnode,elmat,'elmat','nsf_elmope_2nd')
   call a%Memor%alloc(1,e%mnode,elrhs,'elrhs','nsf_elmope_2nd')
   call a%Memor%alloc(1,e%mnode,1,e%mnode,elmpq,'elmpq','nsf_elmope_2nd')
   call a%Memor%alloc(1,e%mnode,elrhp,'elrhp','nsf_elmope_2nd')
   call a%Memor%alloc(e%mnode,e%mnode,wrmat1,'wrmat1','nsf_elmope_2nd')
   call a%Memor%alloc(e%ndime,e%mnode,divelvel,'divelvel','nsf_elmope2nd')

   !Arrays Allocate
   call AllocateBaseElmopeArrays

   !Initializations
   call ProcHook_Initializations

   if (a%kfl_tsche_1st_current == 'CN   ') then
      IsCrankNicolson = .true.

      !The second step of the fractional step is solved as BDF1
      kfl_tsche_1st_current = 'BDF1 '
      call Integrator%Init(kfl_tsche_1st_current)
      call Integrator%GetLHSDtinv(a%dtinv,LHSdtinv)
      call Integrator%GetNumberOfTimeSteps(nsteps)
   else
      IsCrankNicolson = .false.
   endif

   call a%Mesh%GetNelem(nelem)
   elements : do ielem = 1,nelem
      !Load Element
      call a%Mesh%ElementLoad(ielem,e)

      !Hook
      call ProcHook_OnIeltyChange
      !Cartesian derivatives and Jacobian at center of gravity
      call e%elmdcg
      !Element length at center of gravity
      call e%elmlen

      !ElmatsToZero
      elmat=0.0_rp
      elrhs=0.0_rp

      !Gathers
      if (IsCrankNicolson) then
        call e%gather(e%ndime,elvel(:,:,1),a%veloc(:,:,2)) !int.u_n+1/2
      else
        call e%gather(e%ndime,elvel(:,:,1),a%veloc(:,:,1)) !int.u_n+1
      end if
      call e%gather(1_ip,elpre(1:e%pnode,1),a%press(1:e%pnode,1))         ! p_n
      do istep=2,nsteps !bdf2 and others
         call e%gather(1_ip,elpre(:,istep),a%press(:,istep+1))
      enddo
      call e%gather(e%ndime,divelvel,a%veloc(:,:,1))
      !Hook
      call ProcHook_Gathers

      ! Compute the characteristic length chale
      call elmchl(e,a%kfl_advec,elvel,chale,a%kfl_hdifumin)

      !DvolsToZero
      dvolt0=0.0_rp

      !Hook
      call ProcHook_PreGauss

      !Gauss Point Loop
      gauss_points : do igaus=1,e%pgaus
         e%igaus = igaus

         !Hook
         call ProcHook_InGauss

         dvol = e%weigp(e%igaus)*e%detjm

         !Interpolate
         call InterpolateGpVelocities

         call e%divergence(elvel(:,:,1),divvel)
         call e%divergence(divelvel,divvel2)
         !Hook
         call ProcHook_Interpolates

         !Physical Properties
         call a%GetPhysicalParameters(imat,acden,acvis)
         !Hook
         call ProcHook_PhysicalProp

         !Advection velocity
         call ProcPointer_ComputeAdvectionVelocity

         !Advection velocity norm
         call vecnor(gpadv,e%ndime,gpvno,2)
         !write(*,*) 'nsf_elmope_2ndNew: ','gpadv=',gpadv
         !Compute the stability parameters
         !Hook
         call ProcHook_ComputeTaus

         !Compute Dvols
         dvolt0 = dvolt0 + (timom + 1.0_rp/(acden*LHSdtinv))*dvol

         !Hook
         call ProcHook_InGaussElmats

      enddo gauss_points

      !Post Gauss Matrices
      !Pointer
      call ProcPointer_PostGaussElmats

      !PreDirichlet
      call ProcHook_PreDirichlet

      !Dirichlet Boundary conditions
      call nsf_elmdir_press(b,e,elmat,elrhs)

      do inode=1,e%pnode
         if(abs(elmat(1,inode,1,inode)) <1e-14 .and. abs(elmat(1,inode,1,inode)) > 0.0_rp) then
            ipoin=e%lnods(inode)
            write(*,*) ielem,inode,ipoin,'2nd','pivot_zero'
         endif
      end do

      !Assembly
      call b%LinearSystemP%Assembly(e,elmat,elrhs)

   enddo elements

   !Initializations
   call ProcHook_Finalizations

   !Matrix Deallocate
   call a%Memor%dealloc(1,e%mnode,1,e%mnode,elmat,'elmat','nsf_elmope_2nd')
   call a%Memor%dealloc(1,e%mnode,elrhs,'elrhs','nsf_elmope_2nd')
   call a%Memor%dealloc(1,e%mnode,1,e%mnode,elmpq,'elmpq','nsf_elmope_2nd')
   call a%Memor%dealloc(1,e%mnode,elrhp,'elrhp','nsf_elmope_2nd')
   call a%Memor%dealloc(e%mnode,e%mnode,wrmat1,'wrmat1','nsf_elmope_2nd')
   call a%Memor%dealloc(e%ndime,e%mnode,divelvel,'divelvel','nsf_elmope2nd')

   !Arrays DeAllocate
   call DeallocateBaseElmopeArrays

   !Element Deallocation
   call a%Mesh%ElementDealloc(e,a%Memor,'DefaultRule','nsm_elmope')
end subroutine

max_stars_repo_name: ciaid-colombia/InsFEM

max_issues_repo_name: ciaid-colombia/InsFEM

max_forks_repo_name: ciaid-colombia/InsFEM


 !***********************************************************************************
    subroutine Convolution(num1,xtmp,ytmp,ztmp,den,speed,rarry)
    !c----------------------------------------------------------------------
    !c
    !c----------------------------------------------------------------------
    use varmod
    implicit none
    integer::num1
    integer::i,j,k,xtmp,ytmp,ztmp
    real::dt,f0,sinang
    real,dimension(0:nz-1)::reflect
    real,dimension(MAXZ)::den,speed,speeds,EI,kk
    real,dimension(0:nz+NumSampledWalve-1)::sny
    real,dimension(num1)::rarry

    sny(0:nz+NumSampledWalve-1)=0.0
    reflect(0)=0.0
    EI(1)=den(1)*speed(1)
    do k=1,nz-1
        EI(k+1)=den(k+1)*speed(k+1)
        reflect(k)=(EI(k+1)-EI(k))/(EI(k+1)+EI(k))
    end do

    if(NumSampledWalve.gt.nz)then
        do i=0,nz+NumSampledWalve-1
            if(i.lt.nz)then
                sny(i)=0.0
                do j=0,i
                    sny(i)=sny(i)+wavelet(j)*reflect(i-j)
                end do
            else if(i.ge.nz.and.i.lt.NumSampledWalve)then
                sny(i)=0.0
                do j=i-nz+1,i
                    sny(i)=sny(i)+wavelet(j)*reflect(i-j)
                end do
            else if(i.ge.NumSampledWalve)then
                sny(i)=0.0
                do j=i-nz+1,NumSampledWalve
                    sny(i)=sny(i)+wavelet(j)*reflect(i-j)
                end do
            end if
        end do
    else
        do i=0,nz+NumSampledWalve-1
            if(i.lt.NumSampledWalve)then
                sny(i)=0.0
                do j=0,i
                    sny(i)=sny(i)+wavelet(j)*reflect(i-j)
                end do
            else if(i.ge.NumSampledWalve.and.i.lt.nz-1)then
                sny(i)=0.0
                do j=0,NumSampledWalve
                    sny(i)=sny(i)+wavelet(j)*reflect(i-j)
                end do
            else if(i.ge.nz-1)then
                sny(i)=0.0
                do j=i-nz+1,NumSampledWalve
                    sny(i)=sny(i)+wavelet(j)*reflect(i-j)
                end do
            end if
        end do
    end if

    do i=1,num1
        rarry(i)=sny(i+HalfNumSampledWalve+ztmp)
    end do
    sny(0:num1+NumSampledWalve-1)=0.0
    end subroutine Convolution
    !***********************************************************************************


text:
Avni Patel is a Sociology with an emphasis in Law and Society and Political Science double major with a minor in African American and African Studies minor.

Avni Patel was the ViceChair and Recorder for the External Affairs Commission.  She is also currently serving as the Special Events Coordinator for the Caliph Assagai ASUCD Executive Office.  Her current projects consist of hosting an ASUCD sponsored Canned Food Drive (Nov. 1517th); she is also helping to coordinate a Presidents Forum, a chance for anyone to come and ask the ASUCD President questions, and/or make comments and suggestions. She was also the 20062007 campus organizer for Teach for America.

Avni was a Fall 2005 ASUCD Election Fall 2005 Senatorial Candidate for L.E.A.D..

And on a fun side note, she used to live in Tercero D Building Hamm House in Fall of 2003, which was when she first started volunteering with L.E.A.D..

 Candidate Statement

Hello to all my fellow Aggie readers
Listen to why we call ourselves L.E.A.D.ers:
Leadership, Empowerment, Activism and Determination
Im running to help build up the future generation
To eliminate tensions between the city and UCD
Read this as a guide to why you should vote for AVNI.
I currently serve as the External Affairs Commission Vice Chair
We look over and pass only legislation that seems fair
As the Special Events Coordinator for the Executive Staff
I help plan and organize events on President Caliphs behalf
My freshman year I was one of Senator Darnell Holloways interns
I went to senate meetings and learned how the senate governs.
Our slate is experienced and we have a solid platform
We are running as a progressive slate in hopes to reform
To better allocate the $9.2 million that ASUCD controls
Making sure the money is spent well is one of our goals.
Outreach to local high schools and create shadow days
To work with them and introduce them to our governing ways
Talk to local city businesses and look at the ASUCD budget
To see where a 24hour student friendly coffee shop could fit.
This was just to give all you readers a little taste
To let you know voting for AVNI will not be a waste
Dont forget to tell your friends and your roommates
To place a #1 vote for AVNI and the rest of the LEAD slate!

ext: f

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


text:
subroutine ale_turnon(a)
   !-----------------------------------------------------------------------
   !> This routine sets the mesh to ALE. The displacement and velocity pointers
   !! of the mesh are also initialized.
   !-----------------------------------------------------------------------
   use typre
   use Mod_Alemov
   implicit none

   class(AlemovProblem)  :: a
   integer(ip):: npoin,ipoin,idime,ndime

   call a%Mesh%GetNpoin(npoin)

   call a%Mesh%SetALE(1_ip)
   call a%Mesh%SetDisplacements(a%Displacement)
   call a%Mesh%SetVelocities(a%Velocity)

   a%kfl_fixno0=a%kfl_fixno
   call a%deferredTurnon

end subroutine ale_turnon


text:
      subroutine multav(array1,nmax,avalue,array2)
c
c     This subroutine multiplies the first nmax elements of the real*8
c     array array1 by the real*8 value avalue. The result is placed
c     in the real*8 array array2. Normally, nmax would be the dimension
c     of both arrays. However, nmax could be less than the true
c     dimension. Also, the arrays could actually have more than one
c     dimension. For example, if array1 and array2 are really a and b,
c     respectively, having common dimensions of i1 and i2, this
c     subroutine could be used by calling it in the following manner:
c     call multav(a,(i1*i2),avalue,b). Use this subroutine with caution
c     if the two arrays do not have identical dimensioning or nmax is
c     not the product of the true (declared) dimensions.
c
c     This subroutine is called by:
c
c       Any
c
c-----------------------------------------------------------------------
c
c     Input:
c
c       array1 = the first array
c       nmax   = dimension or pseudo-dimension of array1 and array2
c       avalue = the value by which to multipy array1
c
c     Output:
c
c       array2 = the second array, the product of avalue and array1
c
c-----------------------------------------------------------------------
c
      implicit none
c
c-----------------------------------------------------------------------
c
c     Calling sequence variable declarations.
c
      integer nmax
c
      real*8 array1(nmax),array2(nmax)
c
      real*8 avalue
c
c-----------------------------------------------------------------------
c
c     Local variable declarations.
c
      integer i,ileft
c
      real*8 av
c
c-----------------------------------------------------------------------
c
c     Note the assignment of the value to a local variable.
c     Note also that the loop is unrolled.
c
      av = avalue
      ileft = (nmax/8)*8
c
      do i = 1,ileft,8
        array2(i) = av*array1(i)
        array2(i + 1) = av*array1(i + 1)
        array2(i + 2) = av*array1(i + 2)
        array2(i + 3) = av*array1(i + 3)
        array2(i + 4) = av*array1(i + 4)
        array2(i + 5) = av*array1(i + 5)
        array2(i + 6) = av*array1(i + 6)
        array2(i + 7) = av*array1(i + 7)
      enddo
c
      do i = ileft + 1,nmax
        array2(i) = av*array1(i)
      enddo
c
      end


text:
      SUBROUTINE WRITSA(LUNXX,MSGT,MSGL)

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C
C SUBPROGRAM:    WRITSA
C   PRGMMR: WOOLLEN          ORG: NP20       DATE: 1994-01-06
C
C ABSTRACT: THIS SUBROUTINE SHOULD ONLY BE CALLED WHEN LOGICAL UNIT
C   ABS(LUNXX) HAS BEEN OPENED FOR OUTPUT OPERATIONS.
C
C   WHEN LUNXX IS GREATER THAN ZERO, IT PACKS UP THE CURRENT SUBSET
C   WITHIN MEMORY AND THEN TRIES TO ADD IT TO THE BUFR MESSAGE THAT IS
C   CURRENTLY OPEN WITHIN MEMORY FOR ABS(LUNXX).  THE DETERMINATION AS
C   TO WHETHER OR NOT THE SUBSET CAN BE ADDED TO THE MESSAGE IS MADE
C   VIA AN INTERNAL CALL TO ONE OF THE BUFR ARCHIVE LIBRARY SUBROUTINES
C   WRCMPS OR MSGUPD, DEPENDING UPON WHETHER OR NOT THE MESSAGE IS
C   COMPRESSED.  IF IT TURNS OUT THAT THE SUBSET CANNOT BE ADDED TO THE
C   CURRENTLY OPEN MESSAGE, THEN THAT MESSAGE IS FLUSHED TO ABS(LUNXX)
C   AND A NEW ONE IS CREATED IN ORDER TO HOLD THE SUBSET.  AS LONG AS
C   LUNXX IS GREATER THAN ZERO, WRITSA FUNCTIONS EXACTLY LIKE BUFR
C   ARCHIVE LIBRARY SUBROUTINE WRITSB, EXCEPT THAT WRITSA ALSO RETURNS
C   A COPY OF EACH COMPLETED BUFR MESSAGE TO THE APPLICATION PROGRAM
C   IN THE FIRST MSGL WORDS OF ARRAY MSGT.
C
C   ALTERNATIVELY, WHEN LUNXX IS LESS THAN ZERO, THIS IS A SIGNAL TO
C   FORCE ANY CURRENT MESSAGE IN MEMORY TO BE FLUSHED TO ABS(LUNXX) AND
C   RETURNED IN ARRAY MSGT.  IN SUCH CASES, ANY CURRENT SUBSET IN MEMORY
C   IS IGNORED.  THIS OPTION IS NECESSARY BECAUSE ANY MESSAGE RETURNED
C   IN MSGT FROM A CALL TO THIS ROUTINE NEVER CONTAINS THE ACTUAL SUBSET
C   THAT WAS PACKED UP AND STORED DURING THE SAME CALL TO THIS ROUTINE.
C   THEREFORE, THE ONLY WAY TO ENSURE THAT EVERY LAST BUFR SUBSET IS
C   RETURNED WITHIN A BUFR MESSAGE IN MSGT BEFORE, E.G., EXITING THE
C   APPLICATION PROGRAM, IS TO DO ONE FINAL CALL TO THIS ROUTINE WITH
C   LUNXX LESS THAN ZERO IN ORDER TO FORCIBLY FLUSH OUT AND RETURN ONE
C   FINAL BUFR MESSAGE.
C
C PROGRAM HISTORY LOG:
C 1994-01-06  J. WOOLLEN -- ORIGINAL AUTHOR
C 1998-07-08  J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE
C                           "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB
C                           ROUTINE "BORT"
C 2000-09-19  J. WOOLLEN -- MAXIMUM MESSAGE LENGTH INCREASED FROM
C                           10,000 TO 20,000 BYTES
C 2003-11-04  S. BENDER  -- ADDED REMARKS/BUFRLIB ROUTINE
C                           INTERDEPENDENCIES
C 2003-11-04  D. KEYSER  -- UNIFIED/PORTABLE FOR WRF; ADDED
C                           DOCUMENTATION (INCLUDING HISTORY); OUTPUTS
C                           MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE
C                           TERMINATES ABNORMALLY
C 2004-08-18  J. ATOR    -- ADD POST-MSGUPD CHECK FOR AND RETURN OF
C                           MESSAGE WITHIN MSGT IN ORDER TO PREVENT
C                           LOSS OF MESSAGE IN CERTAIN SITUATIONS;
C                           MAXIMUM MESSAGE LENGTH INCREASED FROM
C                           20,000 TO 50,000 BYTES
C 2005-03-09  J. ATOR    -- ADDED CAPABILITY FOR COMPRESSED MESSAGES
C DART $Id$
C
C USAGE:    CALL WRITSA (LUNXX, MSGT, MSGL)
C   INPUT ARGUMENT LIST:
C     LUNXX    - INTEGER: ABSOLUTE VALUE IS FORTRAN LOGICAL UNIT NUMBER
C                FOR BUFR FILE {IF LUNXX IS LESS THAN ZERO, THEN ANY
C                CURRENT MESSAGE IN MEMORY WILL BE FORCIBLY FLUSHED TO
C                ABS(LUNXX) AND TO ARRAY MSGT}
C
C   OUTPUT ARGUMENT LIST:
C     MSGT     - INTEGER: *-WORD PACKED BINARY ARRAY CONTAINING BUFR
C                MESSAGE (FIRST MSGL WORDS FILLED)
C     MSGL     - INTEGER: NUMBER OF WORDS FILLED IN MSGT
C                       0 = no message was returned
C
C REMARKS:
C    THIS ROUTINE CALLS:        BORT     CLOSMG   MSGUPD   STATUS
C                               WRCMPS   WRTREE
C    THIS ROUTINE IS CALLED BY: WRITCA
C                               Also called by application programs.
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 77
C   MACHINE:  PORTABLE TO ALL PLATFORMS
C
C$$$

      INCLUDE 'bufrlib.prm'

      COMMON /BUFRMG/ MSGLEN,MSGTXT(MXMSGLD4)
      COMMON /MSGCMP/ CCMF

      CHARACTER*1 CCMF

      DIMENSION MSGT(*)

C----------------------------------------------------------------------
C----------------------------------------------------------------------

      LUNIT = ABS(LUNXX)

C  CHECK THE FILE STATUS
C  ---------------------

      CALL STATUS(LUNIT,LUN,IL,IM)
      IF(IL.EQ.0) GOTO 900
      IF(IL.LT.0) GOTO 901
      IF(IM.EQ.0) GOTO 902

C  IF LUNXX < 0, FORCE MEMORY MSG TO BE WRITTEN (W/O ANY CURRENT SUBSET)
C  ---------------------------------------------------------------------

      IF(LUNXX.LT.0) CALL CLOSMG(LUNIT)

C  IS THERE A COMPLETED BUFR MESSAGE TO BE RETURNED?
C  -------------------------------------------------

      IF(MSGLEN.GT.0) THEN
         MSGL = MSGLEN
         DO N=1,MSGL
         MSGT(N) = MSGTXT(N)
         ENDDO
         MSGLEN = 0
      ELSE
         MSGL = 0
      ENDIF

      IF(LUNXX.LT.0) GOTO 100

C  PACK UP THE SUBSET AND PUT IT INTO THE MESSAGE
C  ----------------------------------------------

      CALL WRTREE(LUN)
      IF( CCMF.EQ.'Y' ) THEN
          CALL WRCMPS(LUNIT)
      ELSE
          CALL MSGUPD(LUNIT,LUN)
      ENDIF

C  IF THE JUST-COMPLETED CALL TO WRCMPS OR MSGUPD FOR THIS SUBSET CAUSED
C  A PREVIOUS MESSAGE TO BE FLUSHED TO ABS(LUNXX), THEN RETRIEVE AND
C  RETURN THAT MESSAGE NOW.  OTHERWISE, WE RUN THE RISK THAT THE NEXT
C  CALL TO OPENMB OR OPENMG MIGHT CAUSE A NEWER MESSAGE (WHICH WOULD
C  CONTAIN THE CURRENT SUBSET!) TO BE FLUSHED AND THUS OVERWRITE THE
C  PREVIOUS MESSAGE WITHIN ARRAY MSGTXT BEFORE WE HAD THE CHANCE TO
C  RETRIEVE IT DURING THE NEXT CALL TO WRITSA!

C  NOTE ALSO THAT, IF THE MOST RECENT CALL TO OPENMB OR OPENMG HAD
C  CAUSED A MESSAGE TO BE FLUSHED, IT WOULD HAVE DONE SO IN ORDER TO
C  CREATE A NEW MESSAGE TO HOLD THE CURRENT SUBSET.  THUS, IN SUCH
C  CASES, IT SHOULD NOT BE POSSIBLE THAT THE JUST-COMPLETED CALL TO
C  WRCMPS OR MSGUPD (FOR THIS SAME SUBSET!) WOULD HAVE ALSO CAUSED A
C  MESSAGE TO BE FLUSHED, AND THUS IT SHOULD NOT BE POSSIBLE TO HAVE
C  TWO (2) SEPARATE BUFR MESSAGES RETURNED FROM ONE (1) CALL TO WRITSA!

      IF(MSGLEN.GT.0) THEN
         IF(MSGL.NE.0) GOTO 903
         MSGL = MSGLEN
         DO N=1,MSGL
         MSGT(N) = MSGTXT(N)
         ENDDO
         MSGLEN = 0
      ENDIF

C  EXITS
C  -----

100   RETURN
900   CALL BORT('BUFRLIB: WRITSA - OUTPUT BUFR FILE IS CLOSED, IT '//
     . 'MUST BE OPEN FOR OUTPUT')
901   CALL BORT('BUFRLIB: WRITSA - OUTPUT BUFR FILE IS OPEN FOR '//
     . 'INPUT, IT MUST BE OPEN FOR OUTPUT')
902   CALL BORT('BUFRLIB: WRITSA - A MESSAGE MUST BE OPEN IN OUTPUT '//
     . 'BUFR FILE, NONE ARE')
903   CALL BORT('BUFRLIB: WRITSA - TWO BUFR MESSAGES WERE RETRIEVED '//
     . 'BY ONE CALL TO THIS ROUTINE')
      END

max_stars_repo_name: hkershaw-brown/feature-preprocess

max_issues_repo_name: hkershaw-brown/feature-preprocess

max_forks_repo_name: hkershaw-brown/feature-preprocess


text:
       subroutine dkinp
c read inputs for diffkk program from 'diffkk.inp'
c
       include "dkcom.f"
       integer  i, mfil, maxwrd,nwords, iwrds
       parameter(maxwrd = 30, mfil = 10)
       character*70   words(maxwrd), wrdsor(maxwrd), keywrd
       character*70   prompt*20,key*3,stat*10, string,str,comfil(mfil)
       integer   istrln,icom(mfil), nfil, iinp, ier, iex, ilen, nline
       external   istrln
c     initialization
c initialize  stuff in common
       active = .false.
       isfeff = .true.
       f2tof1 = .true.
       inpfil = 'diffkk.inp'
       xmufil = 'xmu.dat'
       outfil = 'dk.out'
       iatz   = -1
       iprint = 0
       imucol = 2
       iencol = 1
       egrid  = 1
       elow   = 200
       ehigh  = 500
       ewidth = -1.0
c note: pre1/pre2 will be set in f2fit according
c       to whether data is from feff or not
       epad   = 5
       npad   = 20
       ntitle = 0
       label =' e         f1         f2         f1_cl         f2_cl'
       do 10 i = 1, mtitle
          title(i) = ' '
 10    continue
c initialize  local stuff
       prompt = 'f'
       stat   = 'old'
       nline  = 0
       nfil   = 0
       ier    = 0
       iex    = 0
       iinp   = 1
       do 20 i = 1, mfil
          icom(i)   = 0
 20    continue

       call get_inpfile('diffkk.inp',inpfil, ier)
       call openfl(iinp,  inpfil, stat, iex, ier)
       if (iex.lt.0)  then
          ilen = istrln( inpfil)
          call messag( ' '// inpfil(:ilen)// ' not found')
          stop
          return
       endif
       if ((iex.lt.0).or.(ier.ne.0)) go to 1990
c
c  read in next line
 100   continue
       keywrd = ' '
       key    = ' '
       call getcom(prompt, iinp, string, comfil, icom, mfil, nfil)
       nline  = nline + 1
c
       call fixstr(string,str,ilen,words,wrdsor,maxwrd,nwords)
       if ((ilen.le.2).or.(str.eq.'getcom_eof')) go to 100
       if ((words(1).eq.'end').or.(str.eq.'getcom_end')) go to 1000
       if (str.eq.'getcom_error') go to 1990
c      parse current set of keywords from line
 150   continue
       keywrd  = words(1)
       key     = keywrd(1:3)
       iwrds   = 2
c      inpfil,outfil,imucol,egrid,iatz
       if (keywrd.eq.'title') then
          ntitle  = ntitle + 1
          call strclp(string,wrdsor(1),wrdsor(2),title(ntitle))
          iwrds = maxwrd + 1
       else if (key.eq.'out') then
          outfil = wrdsor(2)
       else if (key.eq.'xmu') then
          xmufil = wrdsor(2)
       else if (keywrd.eq.'isfeff') then
          call str2lg(words(2),isfeff,ier)
       else if (keywrd.eq.'f2_to_f1') then
          call str2lg(words(2),f2tof1,ier)
       else if (keywrd.eq.'f1_to_f2') then
          call str2lg(words(2),f2tof1,ier)
          f2tof1 = .not.f2tof1
       else if (keywrd.eq.'iz') then
          call str2in(words(2),iatz,ier)
       else if (keywrd.eq.'mucol') then
          call str2in(words(2),imucol,ier)
       else if (keywrd.eq.'encol') then
          call str2in(words(2),iencol,ier)
       else if (keywrd.eq.'egrid') then
          call str2dp(words(2),egrid,ier)
       else if (keywrd.eq.'e0') then
          call str2dp(words(2),e0,ier)
       else if (keywrd.eq.'ewidth') then
          call str2dp(words(2),ewidth,ier)

       else if (keywrd.eq.'elow') then
          call str2dp(words(2),elow,ier)
       else if (keywrd.eq.'ehigh') then
          call str2dp(words(2),ehigh,ier)
       else if (keywrd.eq.'epad') then
          call str2dp(words(2),epad,ier)
       else if (keywrd.eq.'npad') then
          call str2in(words(2),npad,ier)
       else if (key.eq.'iz') then
          call str2at(words(2),iatz)
       else if (key.eq.'iprint') then
          call str2at(words(2),iprint)
       end if
       if (nwords.gt.iwrds) then
          do 450 i = 1, nwords
             words(i)  = words(i+iwrds)
             wrdsor(i) = wrdsor(i+iwrds)
 450      continue
          nwords = nwords - iwrds
          go to 150
       end if
       go to 100

 1000  continue
       return
 1990  continue
       call messag(' weird, fatal error trying to open file.')
       stop
       end

max_stars_repo_name: keechul/ifeffit

max_stars_repo_licenses: Naumen Condor-1.1 MS-PL

max_issues_repo_name: bruceravel/ifeffit

max_issues_repo_licenses: Naumen Condor-1.1 MS-PL

max_forks_repo_name: bruceravel/ifeffit

max_forks_repo_licenses: Naumen Condor-1.1 MS-PL


text:
C
C**************************  TETPIC ************************************
C
C  set up TETJA for symmetric case, nel caso in cui nella matrice
C  TETRA i # dei nodi all'interno di ogni elemento siano gia' stati
C  riordinati ( subroutine riord.f ) in ordine crescente
C
C***********************************************************************
C
      SUBROUTINE TETPIC(NT,TETRA,JA,TOPOL,TETJA)
C
      IMPLICIT NONE
      INTEGER  I,J,II,JJ,IEL,IND
      INTEGER  NT
      INTEGER  TETRA(5,*),TETJA(4,4,*),JA(*),TOPOL(*)
C
      DO IEL=1,NT
         DO I=1,4
            II=TETRA(I,IEL)
            DO J=I,4
               JJ=TETRA(J,IEL)
               IND=TOPOL(II)-1
  100          IND=IND+1
               IF (JA(IND) .NE. JJ) GO TO 100
               TETJA(I,J,IEL)=IND
            END DO
         END DO
      END DO
C
      RETURN
      END


text:
Allure Beauty Salon is now out of business and has been replaced by Ninas Studio.

To learn about other businesses in Davis that provide professional aesthetic services, visit our Beauty Salons and Barber Shops page.

 Prices
Haircut: $35 december 2006

20060121 19:34:12 nbsp Jessica, the owner of the salon, does an amazing haircut job!  If you have wavy or curly hair (like me), shell do an incredible job!  In addition to the haircut itself, the way she styled it afterward (which seemed simple enough) was great!  Other places that have done my hair dont really seem to ever get layers right, much less make it look nice when its dry.  I definitely recommend the place!  Its a good investment, especially if you dont get you hair cut much and dont mind splurging on yourself (and who doesnt). Users/AndreaPasiliao

20060303 11:25:12 nbsp I went there about two weeks ago and they did a horrible job. For those who have straight and fine hair, dont go here! they cant cut for shit. They dont know how to layer and they sure as hell dont know how to cut evenly! It is not worth it to pay 30 bucks and come out looking like a complete idiot!! i had to get my hair recut because it was so bad! Users/WalnutNg

20060511 13:25:16 nbsp I have been in before to get my eyebrows done and was satisfied with their service, but I have to say that today I got the worst leg wax of my life. They use cheap wax that didnt pull the hair out instead just broke it. My legs feel just as stubbly as they would if I had shaved about 5 days ago. I was so upset that I asked for a refund. I will not be patronizing their establishment again. Users/HannahReff

20060516 19:33:13 nbsp I used to go tanning here and Ive gotten a facial and eyebrow threading job (which I highly recommend over waxing) here. I love this place :) Its like a girls best friend. I have yet to get a haircut here someday! Users/KrystalVillanueva

20060628 17:13:43 nbsp I went here for a Brazilian wax, after not getting one in almost 2 years.  The lady did a great job and it didnt even hurt that bad.  She was a little more talkative than I would have liked, I mean I dont really feel like talking when youre ripping hair off of me, but she was still a sweetheart and knows what shes doing. Users/HillaryLaFever

20060808 14:33:05 nbsp I called for an appointment and was able to get in the next day. I didnt know specifically what cut I wanted, but I did know what kind of effect I wanted from the cut. I relayed this to Jessica, and she did a great job. She was with me every step of the way and I got a great haircut. The only downside was having her leave me to answer a question a customer had about shampoo, but its understandable because this woman really, really knows her stuff.  Users/HelenDahlberg

20060912 11:21:17 nbsp I went back for another Brazilian and Back Facial and the skinny Persian girl was my attendant this time.  I was a little sad about not having my previous attendant, but this girl also did an outstanding job and customized the facial after asking my more questions than Ive known other salons to ask.  Jessica obviously has a strict policy in who she hires, because everyone who works here is great at their job! Users/HillaryLaFever

20060918 23:12:35 nbsp I got my hair fixed after a different salon didnt do my hair exactly like I wanted. She really knows her stuff, especially with wavy hair, and is very intent and through. The only bummer was that they charged me full even though she just trimmed the back of my hair completely dry in about 15 minutes.  Users/ChristyMarsden

20060923 22:54:19 nbsp I got my back waxed by Jessica. She was so quick and gentle. I didn’t even feel any pain. I have gotten it done from other spas in past but this was the best experience. I highly recommend this place and will definitely go back.   Users/NaveenJaunk

I went to Allure Beauty Salon for the first time and got my hair colored and hi lited.  They did an awesome job, I love the way my hair looks.  I highly recommend them.  Oh yah... I got my eyebrows waxed and it barely hurt and eyebrows have nice arch.  I will go back again soon.

20070213 23:00:51 nbsp I hate this place! they absolutely do not know how to wax eyebrows!!! I have been there before and It was not that great and I thought i would give them another chance....and to my surprise it was even worst than the eyebrow waxing that i had gotten done by jessica. I got it done by some new girl there and she sucks! I am never going back to them again until they can hire people who can actually wax eyebrows! I am so pissed and wished that i never paid them for their crappy job! Users/ChristinaLor

20070402 20:34:24 nbsp I went in today to try the standing tanning booth. I expected to talk to a lady about tanning since ive never been and to my surprise a middle aged man was running the register/main counter! it was a bit weird and he seemed to have some trouble understanding/answering my questions. good thing another worker (a lady) came up to me and was able to answer my questions and give me advice about tanning. I paid $14 for these stupid eye protecting stickers that the guy basically made me buy and for 5 mintues of tanning. the lady told me that for a first time tan no one should tan more than 5mins. they have a flat rate of $12.99 for the stand up tanning booth. the maximum amount of mins. is 12. in the end i felt ripped off, 5 mins of tanning with minimal results. they do have a built in radio in the tanning booth which i thought was cool. overall the people there were friendly.  Users/AmyYang

20070516 04:23:21 nbsp DO NOT recommend. One of the worst hair cuts EVER.  At first I thought this place was a godsend because of the eyebrow threading, but the hairs grow right back within days...so unless you have a special occasion youre better off plucking/waxing.  They use very cheap products...99cents stuff... so dont expect quality when you come here.  I asked for their advertised lash enhacement and I was expecting something new and exciting, only to have the owner Jessica pull out a box of those drugstore fake eyelash singles and try to charge 30 bucks, so I said no thanks! Users/christinegallo

20070625 21:38:21 nbsp Their pedicures are more sanitary than those at other salons because they use a bowl that is sterilized for each person. But at $35 and in a plastic chair, its not worth it.  Users/MandiPeterson

20070707 01:38:29 nbsp Very bad experiences.  Went in for eyebrow waxing and no one could do it even though they were sitting around drinking soda, so I made an apppointment and went back in 2 days later.  They kept me waiting while they sat in the back room chatting and walking out occasionally to see if I was still there.  After 15 minutes of this, I told the receptionist/cashier to let them know that my time was valuable and that I would not be backnot to purchase products, not for services, not for anything.  She just looked at me.  Honestly, I dont know how these business in Davis manage to stay open at all.  Dont bother with this place.  For eyebrow waxing, go to the beauty supply and buy your own for a fraction of the price and for a much more sanitary experience. Users/trma

20070716 15:09:59 nbsp Please do NOT get your eyebrows threaded here. I only get mine threaded and was looking for a place in Davis. I thought it was amazing to find a place so quick, but the lady here ruined my eyebrows. She didnt even get all the hairs around my eyebrows, and thinned my eyebrows SO much. Also didnt care to match my eyebrows so they each looked different. I now drive over an hour to go home to the Bay Area to get my eyebrows done instead of ever returning here. Absolutely terrible and disappointing! Users/CAkita

20070807 17:32:45 nbsp I was in here today to buy some shampoo and was surprised to see that it is totally remodeled, under new ownership and now called Ninas Studio. It looks a lot better and the girls working were really nice and helpful! Users/MPeterson

20071005 15:10:54 nbsp Im sad they closed :( I always had my brows threaded there and Jessica did a wonderful job! If anyone knows anywhere else to have threading done in Davis, please let me know!  Users/Rachelottlinger

20071005 15:24:44 nbsp if you call ninas studio, ask for Marjan, she does excellent threading Users/NinasStudio

20071005 15:28:11 nbsp Oh thank you! Users/Rachelottlinger


text:
The Wildhorse Agricultural Buffer is protected Open Space open space between the Wildhorse development in northeast Davis and adjacent Yolo County farmland. Most of the buffers acreage borders the Wildhorse Golf Club. You can see lots of ground squirrels, owls, and Rabbits bunnies here. This is a good Places to Walk or Run place to walk or run, providing that you stay on the gravel path. You can enter the path just north of East Covell Boulevard, east of the Wildhorse subdivision. The horse ranch property on the left as you enter the buffer is located on the site of the illfated Wildhorse Ranch planned development project, which was rejected by voters threetoone (under Measure J) in November 2009.

 Pictures


text:
recursive subroutine symplify(num, den, symplified)
use PENF, only : I_P
implicit none

integer(I_P), intent(inout) :: num, den
logical,      intent(inout) :: symplified

if (.not.(symplified)) then
  if (mod(num,8_I_P)/=0_I_P) then
    if (mod(num,4_I_P)/=0_I_P) then
      if (mod(num,2_I_P)/=0_I_P) then
        symplified=.true.
      else
        if ((abs(num)>=2_I_P).and.(abs(den)>=2_I_P)) then
          num = num / 2_I_P
          den = den / 2_I_P
          symplified=.true.
        endif
      endif
    else
      if (mod(den,4_I_P)==0_I_P.and.(abs(num)>=4_I_P).and.(abs(den)>=4_I_P)) then
        num = num / 4_I_P
        den = den / 4_I_P
      elseif (mod(den,2_I_P)==0_I_P.and.(abs(num)>=2_I_P).and.(abs(den)>=2_I_P)) then
        num = num / 2_I_P
        den = den / 2_I_P
        symplified=.true.
      else
        symplified=.true.
      endif
    endif
  else
    if (mod(den,8_I_P)==0_I_P.and.(abs(num)>=8_I_P).and.(abs(den)>=8_I_P)) then
      num = num / 8_I_P
      den = den / 8_I_P
    elseif (mod(den,4_I_P)/=0_I_P) then
      if (mod(num,2_I_P)==0_I_P.and.(abs(num)>=2_I_P).and.(abs(den)>=2_I_P)) then
        num = num / 2_I_P
        den = den / 2_I_P
        symplified=.true.
      else
        symplified=.true.
      endif
    else
      if ((abs(num)>=4_I_P).and.(abs(den)>=4_I_P)) then
        num = num / 4_I_P
        den = den / 4_I_P
      endif
    endif
  endif
  call symplify(num, den, symplified)
endif
endsubroutine symplify

program lagrange_interpolation
!< Program for computing Lagrange coefficients and interpolation(s).

use follia
#ifdef r16p
use penf, only: I_P, str, RPP=>R16P
#else
use penf, only: I_P, str, RPP=>R8P
#endif

implicit none

interface
  subroutine symplify(num, den, symplified)
    use PENF, only : I_P
    integer(I_P), intent(inout) :: num, den
    logical,      intent(inout) :: symplified
  endsubroutine
endinterface

type(lagrange_interpolator) :: interp
integer(I_P), allocatable   :: den(:,:)
integer(I_P)                :: i, j, S
integer(I_P)                :: file_unit
logical                     :: symp
integer(I_P), allocatable   :: int_coef(:,:)

print *, 'Insert stencil dimension and number'
read *, S

call interp%initialize_interpolator(S,-0.5_RPP)

call interp%compute_coefficients
call interp%compute_interpolations

interp%coef(:,:) = interp%coef(:,:) * (2._RPP**20._RPP)

allocate(int_coef(1:interp%S,1:interp%S))
allocate(den(1:interp%S,1:interp%S))

int_coef=nint(interp%coef)

den(:,:) = 2_I_P**20_I_P

symp=.false.

associate(coef=>int_coef)
  do j=1,interp%S
    do i=1,interp%S
      call symplify(coef(i,j),den(i,j),symp)
      symp=.false.
    enddo
  enddo
endassociate

open(newunit=file_unit, file='coefficients_S-'//trim(str(interp%S))//'.dat')
write(file_unit,"(A)") 'LEFT INTERFACE'

do j=1,interp%S
  do i=1,interp%S
    write(file_unit,"(A,I1,A,I1,A,I7,A,I7,A)") 'c(1,', i-1_I_P,',', j-1_I_P,')= ', int_coef(i,j),'._RPP /', den(i,j),'._RPP'
  enddo
enddo

call interp%initialize_interpolator(S,0.5_RPP)

call interp%compute_coefficients
call interp%compute_interpolations

interp%coef(:,:) = interp%coef(:,:) * (2._RPP**20._RPP)

int_coef=nint(interp%coef)

den(:,:) = 2_I_P**20_I_P

symp=.false.

associate(coef=>int_coef)
  do j=1,interp%S
    do i=1,interp%S
      call symplify(coef(i,j),den(i,j),symp)
      symp=.false.
    enddo
  enddo
endassociate

write(file_unit,"(A)") 'RIGHT INTERFACE'

do j=1,interp%S
  do i=1,interp%S
    write(file_unit,"(A,I1,A,I1,A,I7,A,I7,A)") 'c(2,', i-1_I_P,',', j-1_I_P,')= ', int_coef(i,j),'._RPP /', den(i,j),'._RPP'
  enddo
enddo

close(unit=file_unit)
endprogram lagrange_interpolation

max_stars_repo_name: giacrossi/FOLLIA

max_issues_repo_name: giacrossi/FOLLIA

max_forks_repo_name: giacrossi/FOLLIA


text:
** Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
** See https://llvm.org/LICENSE.txt for license information.
** SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception

*   Optimizer tests of converting while loops to "do while"

	program ka01
	parameter(N=7)
	common iresult(N), iexpect(N)
	data iresult /N*0/
	call test1_2
        call test3_7
        call check(iresult, iexpect, N)
	data iexpect /
     +    4, 5,                         ! tests 1-2
     +    4, 4, 4, 4, 4                 ! tests 3-7
     +  /
	end

	subroutine incr(i)
	parameter(N=7)
	common iresult(N), iexpect(N)
	iresult(i) = iresult(i) + 1
	end

	subroutine test1_2()
	i = 1
	do 100 while (i .le. 4)
	    call incr(1)
	    i = i + 1
100	continue
	do while (i .gt. 0)
	    call incr(2)
	    i = i - 1
	enddo
	end

	subroutine test3_7()
	i = 4
	do 100 while (i .ge. 1)
	    k = 4
	    call incr(3)
	    do while (k .gt. 0)
		j = k
		call incr(3 + j)
		k = k - 1
	    enddo
	    i = i - 1
100     continue
	end

max_stars_repo_name: abrahamtovarmob/flang

max_issues_repo_name: abrahamtovarmob/flang

max_forks_repo_name: abrahamtovarmob/flang


text:
module CalcLS

  use fsystem
  use genoutput
  use storage
  use linearsolver
  use boundary
  use bilinearformevaluation
  use linearformevaluation
  use cubature
  use matrixfilters
  use vectorfilters
  use bcassembly
  use triangulation
  use spatialdiscretisation
  use ucd
  use pprocerror
  use genoutput

  use ccbasic
  use timestepping
  use trilinearformevaluation
  use convection
  use cccallback
  use levelset

  implicit none

!<types>

!<typeblock description="Type block defining all information about one level">

  type t_level

    ! A system matrix for that specific level. The matrix will receive the
    ! discrete Laplace operator.
    type(t_matrixBlock) :: rmatrix

    ! A variable describing the discrete boundary conditions.
    type(t_discreteBC) :: rdiscreteBC

    type(t_blockDiscretisation) :: rdiscretisationStabil

  end type

!</typeblock>

!</types>

contains

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

!<subroutine>

  subroutine calcls_mg(rproblem,rvector,&
                 rvectorVelocity,rtimestepping)

    type(t_problem), intent(in) :: rproblem
    type(t_vectorBlock),intent(in) :: rvectorVelocity
    TYPE(t_explicitTimeStepping),intent(in)  :: rtimestepping

    type(t_vectorBlock),intent(inout) :: rvector

    type(t_blockDiscretisation),pointer :: p_rdiscretisation

    ! An object for saving the domain:
    type(t_level),dimension(:),allocatable,target :: rlevels

    ! A bilinear and linear form describing the analytic problem to solve
    type(t_trilinearForm) :: rtriform

    type(t_vectorBlock) :: rrhsBlock,rtempBlock

    ! A variable that is used to specify a region on the boundary.
    type(t_boundaryRegion) :: rboundaryRegion

    ! A solver node that accepts parameters for the linear solver
    type(t_linsolNode), pointer :: p_rsolverNode,p_rcoarseGridSolver,p_rsmoother

    ! An array for the system matrix(matrices) during the initialisation of
    ! the linear solver.
    type(t_matrixBlock), dimension(:), allocatable :: Rmatrices

    ! A filter chain that describes how to filter the matrix/vector
    ! before/during the solution process. The filters usually implement
    ! boundary conditions.
    type(t_filterChain), dimension(1), target :: RfilterChain
    type(t_filterChain), dimension(:), pointer :: p_RfilterChain

    ! An interlevel projection structure for changing levels
    type(t_interlevelProjectionBlock) :: rprojection

    ! One level of multigrid
    type(t_linsolMGLevelInfo), pointer :: p_rlevelInfo

    ! NLMIN receives the level of the coarse grid.
    integer :: NLMIN

    ! NLMAX receives the level where we want to solve.
    integer :: NLMAX

    ! Error indicator during initialisation of the solver
    integer :: ierror

    ! Error of FE function to reference function
    real(DP) :: derror

    real(DP), dimension(:), pointer :: p_Ddata

    type(t_jumpStabilisation) :: rjumpstabil
    type(t_vectorblock) :: rvectortemp

    ! Some temporary variables
    integer :: i

    ! Ok, let's start.
    !
    ! We want to solve our Poisson problem on level...
    NLMIN = rproblem%NLMIN
    NLMAX = rproblem%NLMAX

    ! Allocate memory for all levels
    allocate(Rlevels(NLMIN:NLMAX))

   call lsysbl_copyvector (rvectorvelocity,rvectortemp)

    do i = NLMAX, NLMIN,-1

      p_rdiscretisation => rproblem%rlevelinfo(i)%rdiscretisationLS

      call spdiscr_deriveBlockDiscr (p_rdiscretisation,&
               rlevels(i)%rdiscretisationStabil)

      ! Initialise the block matrix with default values based on
      ! the discretisation.
      call lsysbl_createMatBlockByDiscr (&
          p_rdiscretisation,Rlevels(i)%rmatrix)

      CALL lsyssc_duplicateMatrix (rproblem%rlevelinfo(i)%rmatrixLS,&
              Rlevels(i)%rmatrix%RmatrixBlock(1,1),LSYSSC_DUP_SHARE,LSYSSC_DUP_copy)

      call lsysbl_updateMatStrucInfo (Rlevels(i)%rmatrix)

      rtriform%itermcount=1
      rtriform%BconstantCoeff= .true.
      rtriform%ballcoeffconstant = .true.
      rtriform%Dcoefficients(1)= rtimestepping%dtstep
      rtriform%Idescriptors(1,1)=DER_FUNC
      rtriform%Idescriptors(2,1)=DER_DERIV_X
      rtriform%Idescriptors(3,1)=DER_FUNC

     CALL trilf_buildMatrixScalar (rtriform,.FALSE.,Rlevels(i)%rmatrix%RmatrixBlock(1,1),&
                                   rvectortemp%rvectorBlock(1))

     rtriform%Idescriptors(2,1)=DER_DERIV_Y

     CALL trilf_buildMatrixScalar (rtriform,.FALSE.,Rlevels(i)%rmatrix%RmatrixBlock(1,1),&
                              rvectortemp%rvectorBlock(2))

     rjumpstabil%dnu = 0.0_DP
     rjumpstabil%dgamma = 0.01_DP
     rjumpstabil%dgammastar = 0.01_DP
     rjumpstabil%dtheta = rtimestepping%dtstep

     !call conv_JumpStabilisation2d ( &
     !  rjumpstabil, conv_modmatrix, rlevels(i)%rmatrix%rmatrixBlock(1,1),&
     !    rdiscretisation=rlevels(i)%rdiscretisationStabil%RspatialDiscr(1))

    IF(i.GT.rproblem%NLMIN) &
        CALL prjF2C(rvectorTemp,rproblem%rlevelinfo(i-1)%rdiscretisationLS)

    end do

    !call lsysbl_createVecBlockIndMat (Rlevels(NLMAX)%rmatrix,rrhsBlock, .true.)
    call lsysbl_createVecBlockIndirect (rvector, rrhsBlock, .true.)

    CALL lsyssc_scalarMatVec (rproblem%rlevelinfo(nlmax)%rmatrixLS, &
                                   rvector%rvectorBlock(1),rrhsBlock%rvectorBlock(1),1.0_DP, rtimestepping%dtstep)

    do i = NLMIN, NLMAX

      ! Initialise the discrete BC structure
      call bcasm_initDiscreteBC(Rlevels(i)%rdiscreteBC)

     CALL boundary_createRegion(rproblem%rboundary,1,4,rboundaryRegion)
     CALL bcasm_newDirichletBConRealBD (rproblem%rlevelinfo(i)%rdiscretisationLS,1,&
                                       rboundaryRegion,Rlevels(i)%rdiscreteBC,&
                                      getBoundaryValues_trace)

      ! Hang the pointer into the matrix. That way, these
      ! boundary conditions are always connected to that matrix.
      Rlevels(i)%rmatrix%p_rdiscreteBC => Rlevels(i)%rdiscreteBC

      ! Also implement the boundary conditions into the matrix.
      call matfil_discreteBC (Rlevels(i)%rmatrix)

    end do

    ! Our right-hand-side also needs to know the boundary conditions.
    rrhsBlock%p_rdiscreteBC => Rlevels(NLMAX)%rdiscreteBC

    !call lsysbl_createVecBlockIndirect (rrhsBlock, rvectorBlock, .true.)
    call lsysbl_createVecBlockIndirect (rrhsBlock, rtempBlock, .false.)

    call vecfil_discreteBCrhs (rrhsBlock)
    call vecfil_discreteBCsol (rvector)

    RfilterChain(1)%ifilterType = FILTER_DISCBCDEFREAL

    ! Now we have to build up the level information for multigrid.
    !
    ! At first, initialise a standard interlevel projection structure. We
    ! can use the same structure for all levels.
    call mlprj_initProjectionMat (rprojection,Rlevels(NLMAX)%rmatrix)

    ! Create a Multigrid-solver. Attach the above filter chain
    ! to the solver, so that the solver automatically filters
    ! the vector during the solution process.
    p_RfilterChain => RfilterChain
    call linsol_initMultigrid (p_rsolverNode,p_RfilterChain)

    ! Set up a coarse grid solver.
    call linsol_initUMFPACK4 (p_rcoarsegridSolver)

    ! Add the coarse grid level.
    call linsol_addMultiGridLevel(p_rlevelInfo,p_rsolverNode,rprojection,&
                                  null(), null(), p_rcoarseGridSolver)

    ! Now set up the other levels...
    do i = NLMIN+1, NLMAX

      ! Create a Jacobi smoother
      !CALL linsol_initJacobi(p_rsmoother)

      ! Create an ILU(0) smoother
      call linsol_initMILUs1x1 (p_rsmoother,0,0.0_DP)

      ! We will use 4 smoothing steps with damping parameter 0.7
      call linsol_convertToSmoother(p_rsmoother, 4, 0.7_DP)

      ! And add this multi-grid level. We will use the same smoother
      ! for pre- and post-smoothing.
      call linsol_addMultiGridLevel(p_rlevelInfo,p_rsolverNode,rprojection,&
                                    p_rsmoother, p_rsmoother, null())

    end do

    ! Set the output level of the solver to 2 for some output
    p_rsolverNode%ioutputLevel = 2

    ! Attach the system matrices to the solver.
    !
    ! We copy our matrices to a big matrix array and transfer that
    ! to the setMatrices routines. This intitialises then the matrices
    ! on all levels according to that array. Note that this does not
    ! allocate new memory, we create only 'links' to existing matrices
    ! into Rmatrices(:)!
    allocate(Rmatrices(NLMIN:NLMAX))
    do i = NLMIN, NLMAX
      call lsysbl_duplicateMatrix (Rlevels(i)%rmatrix,&
          Rmatrices(i),LSYSSC_DUP_SHARE,LSYSSC_DUP_SHARE)
    end do

    call linsol_setMatrices(p_RsolverNode,Rmatrices(NLMIN:NLMAX))

    ! We can release Rmatrices immediately -- as long as we don't
    ! release Rlevels(i)%rmatrix!
    do i=NLMIN,NLMAX
      call lsysbl_releaseMatrix (Rmatrices(i))
    end do
    deallocate(Rmatrices)

    ! Initialise structure/data of the solver. This allows the
    ! solver to allocate memory / perform some precalculation
    ! to the problem.
    call linsol_initStructure (p_rsolverNode, ierror)
    if (ierror .ne. LINSOL_ERR_NOERROR) stop
    call linsol_initData (p_rsolverNode, ierror)
    if (ierror .ne. LINSOL_ERR_NOERROR) stop

    ! Finally solve the system. As we want to solve Ax=b with
    ! b being the real RHS and x being the real solution vector,
    ! we use linsol_solveAdaptively. If b is a defect
    ! RHS and x a defect update to be added to a solution vector,
    ! we would have to use linsol_precondDefect instead.
    call linsol_solveAdaptively (p_rsolverNode,rvector,rrhsBlock,rtempBlock)

    ! Calculate the error to the reference function.
    !call pperr_scalar (rvector%RvectorBlock(1),PPERR_L2ERROR,derror,&
    !                   getReferenceFunction_2D)
    !call output_line ('L2-error: ' // sys_sdEL(derror,10) )

    !call pperr_scalar (rvector%RvectorBlock(1),PPERR_H1ERROR,derror,&
    !                   getReferenceFunction_2D)
    !call output_line ('H1-error: ' // sys_sdEL(derror,10) )

    call linsol_doneData (p_rsolverNode)
    call linsol_doneStructure (p_rsolverNode)

    ! Release the interlevel projection structure
    call mlprj_doneProjection (rprojection)

    ! Release the solver node and all subnodes attached to it (if at all):
    call linsol_releaseSolver (p_rsolverNode)

    ! Release the block matrix/vectors
    call lsysbl_releaseVector (rtempBlock)
    call lsysbl_releaseVector (rrhsBlock)

    do i = NLMAX, NLMIN, -1
      call lsysbl_releaseMatrix (Rlevels(i)%rmatrix)
      call spdiscr_releaseBlockDiscr (Rlevels(i)%rdiscretisationstabil)
    end do

    ! Release our discrete version of the boundary conditions
    do i = NLMAX, NLMIN, -1
      call bcasm_releaseDiscreteBC (Rlevels(i)%rdiscreteBC)
    end do

    ! Release the discretisation structure and all spatial discretisation
    ! structures in it.
    !do i = NLMAX, NLMIN, -1
    !  call spdiscr_releaseBlockDiscr(Rlevels(i)%rdiscretisation)
    !end do

    ! Release the triangulation.
    !do i = NLMAX, NLMIN, -1
    !  call tria_done (Rlevels(i)%rtriangulation)
    !end do

    deallocate(Rlevels)

    call lsysbl_releasevector(rvectortemp)

  end subroutine

! *********************************************************************
!  <subroutine>
  subroutine CalcLS_simple(rproblem,rvector,&
             rvectorvelocity_new,rvectorvelocity_old,rtimestepping)

  type(t_problem), intent(in),target :: rproblem
  type(t_vectorBlock), intent(in), target :: rvectorvelocity_new,rvectorvelocity_old
  type(t_explicitTimeStepping),intent(in)  :: rtimestepping
  type(t_vectorBlock), intent(inout) :: rvector

  type(t_vectorBlock),target :: rrhsblock,rtempBlock
  type(t_matrixBlock) :: rmatrix,rmatrix2
! type(t_convStreamlineDiffusion) :: rstreamline
! type(t_convUpwind) :: rupwind
  type(t_jumpStabilisation) :: rjumpstabil
  type(t_matrixBlock), DIMENSION(1) :: Rmatrices
  type(t_matrixScalar), POINTER :: rmatrixMass
  type(t_Blockdiscretisation), POINTER :: p_rdiscretisation
  type(t_blockDiscretisation) :: rdiscretisationStabil
  type(t_discreteBC),TARGET :: rdiscreteBC
  type(t_linsolNode), POINTER :: p_rsolverNode,p_rpreconditioner
  type(t_filterChain), DIMENSION(1), TARGET :: RfilterChain
  type(t_filterChain), DIMENSION(:), POINTER :: p_RfilterChain
  type(t_boundaryRegion) :: rboundaryRegion
  integer :: i
  integer :: ierror
  type(t_trilinearForm) :: rtriform

     i = rproblem%nlmax
     p_rdiscretisation => rproblem%RlevelInfo(i)%rdiscretisationLS
     rmatrixMass => rproblem%RlevelInfo(i)%rmatrixLS

     call lsysbl_createMatBlockByDiscr (p_rdiscretisation,rmatrix)
     call lsyssc_duplicateMatrix (rmatrixMass,&
              rmatrix%RmatrixBlock(1,1),LSYSSC_DUP_SHARE,LSYSSC_DUP_copy)
     call lsysbl_updateMatStrucInfo (rmatrix)

     rtriform%itermcount=1
     rtriform%BconstantCoeff= .true.
     rtriform%ballcoeffconstant = .true.
     rtriform%Dcoefficients(1)= rtimestepping%dweightMatrixLHS
     rtriform%Idescriptors(1,1)=DER_FUNC
     rtriform%Idescriptors(2,1)=DER_DERIV_X
     rtriform%Idescriptors(3,1)=DER_FUNC

     call trilf_buildMatrixScalar (rtriform,.FALSE.,&
         rmatrix%RmatrixBlock(1,1), rvectorvelocity_new%rvectorBlock(1))

     rtriform%Idescriptors(2,1)=DER_DERIV_Y
     call trilf_buildMatrixScalar (rtriform,.FALSE.,&
         rmatrix%RmatrixBlock(1,1), rvectorvelocity_new%rvectorBlock(2))

     call spdiscr_deriveBlockDiscr (p_rdiscretisation,rdiscretisationStabil)
     rjumpstabil%dnu = 0.0_DP
     rjumpstabil%dgamma = 0.01_DP
     rjumpstabil%dgammastar = 0.01_DP
     rjumpstabil%dtheta = rtimestepping%dweightMatrixLHS

     !call conv_JumpStabilisation2d ( &
     !     rjumpstabil, conv_modmatrix, rmatrix%rmatrixBlock(1,1),&
     !         rdiscretisation=rdiscretisationStabil%RspatialDiscr(1))

     call lsysbl_createMatBlockByDiscr (p_rdiscretisation,rmatrix2)
     call lsyssc_duplicateMatrix (rmatrixMass,&
              rmatrix2%RmatrixBlock(1,1),LSYSSC_DUP_SHARE,LSYSSC_DUP_copy)
     rtriform%Dcoefficients(1)= rtimestepping%dweightMatrixRHS
     call trilf_buildMatrixScalar (rtriform,.false.,&
         rmatrix2%RmatrixBlock(1,1), rvectorvelocity_old%rvectorBlock(2))
     rtriform%Idescriptors(2,1)=DER_DERIV_X
     call trilf_buildMatrixScalar (rtriform,.FALSE.,&
         rmatrix2%RmatrixBlock(1,1), rvectorvelocity_old%rvectorBlock(1))

     call lsysbl_createVecBlockIndirect (rvector, rrhsBlock, .true.)
     !call lsyssc_scalarMatVec (rmatrixMass,rvector%rvectorBlock(1),&
     !           rrhsBlock%rvectorBlock(1),1.0_DP, rtimestepping%dtstep)

     call lsyssc_scalarMatVec (rmatrix2%rmatrixblock(1,1),rvector%rvectorBlock(1),&
                rrhsBlock%rvectorBlock(1),1.0_DP, rtimestepping%dtstep)

 ! BC
     CALL bcasm_initDiscreteBC(rdiscreteBC)

     CALL boundary_createRegion(rproblem%rboundary,1,4,rboundaryRegion)
     CALL bcasm_newDirichletBConRealBD (p_rdiscretisation,1,&
                                       rboundaryRegion,rdiscreteBC,&
                                      getBoundaryValues_trace)

     rmatrix%p_rdiscreteBC =>  rdiscreteBC
     rrhsblock%p_rdiscreteBC => rdiscreteBC
     rvector%p_rdiscreteBC =>  rdiscreteBC

     call vecfil_discreteBCrhs (rrhsblock)
     call vecfil_discreteBCsol (rvector)

     call matfil_discreteBC (rmatrix)

     RfilterChain(1)%ifilterType = FILTER_DISCBCDEFREAL
     p_RfilterChain => RfilterChain
     NULLIFY(p_rpreconditioner)
     call linsol_initUMFPACK4 (p_rsolverNode)
     p_rsolverNode%ioutputLevel = 2
     Rmatrices = (/rmatrix/)
     call linsol_setMatrices(p_rsolverNode, Rmatrices)
     call linsol_initStructure(p_rsolverNode, ierror)
     call linsol_initData (p_rsolverNode,ierror)

     if (ierror .NE. LINSOL_ERR_NOERROR) stop
        call linsol_initData (p_rsolverNode, ierror)
     if (ierror .NE. LINSOL_ERR_NOERROR) stop

     call lsysbl_duplicateVector (rvector,rtempblock,&
                            LSYSSC_DUP_COPY,LSYSSC_DUP_EMPTY)

     call linsol_solveAdaptively (p_rsolverNode,rvector,rrhsblock,rtempBlock)

     call linsol_doneData (p_rsolverNode)
     call linsol_doneStructure (p_rsolverNode)
     call linsol_releaseSolver (p_rsolverNode)

     call lsysbl_releaseVector (rrhsblock)
     call lsysbl_releaseVector (rtempBlock)

     call lsysbl_releaseMatrix (rmatrix)
     call lsysbl_releaseMatrix (rmatrix2)
     call bcasm_releaseDiscreteBC (rdiscreteBC)

  END SUBROUTINE

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

end module

max_stars_repo_licenses: Intel Unlicense

max_issues_repo_licenses: Intel Unlicense

max_forks_repo_licenses: Intel Unlicense


text:
The Northern Coast Range looms west of Davis as a low mountain wall which stretches to the north past the point of visibility.  To the south it runs to San Francisco Bay.  It forms the West western border of the Sacramento Valley.  It is almost always visible and is generally easier to see than the Sierra Nevada Mountains on the east side of the Valley.

Due west of Davis you may have noticed a distinct gap in the ridge known as Berryessa Gap.  Thats where Monticello Dam keeps Lake Berryessa from turning most of Davis into a giant wading pool.  Its also where youll find Stebbins Cold Canyon Reserve, Mix Canyon, Long Canyon, Pleasants Ridge, and Blue Ridge/Rocky Ridge which starts at the right of the gap.  The area is fairly low and dry, with many Oaks oak and Bay Laurel bay trees. It is popular for bicycling, camping, fishing, and so on.

Highway 128 offers a scenic drive into the Napa Valley Napa/Sonoma County Sonoma Valley area going from Winters along Putah Creek.  When you first meet up with Lake Berryessa theres a nice overlook where you can see the Morning Glory Spillway.  You can also make it into a gorgeous bicycle rides bike ridejust be careful, since there are a lot of blind corners with little or no shoulder.  This scenic route is an an alternative to Interstate 80 to the Bay Area which also runs through these mountains.

The Northern Coast Ranges actually consist of a number of distinct ranges.  The portion visible from Davis is the more inland of two long parallel ranges.  The Coast Range in its entirety runs 600 miles from the southern end of the Klamath Mountains in Oregon to the Santa Barbara area.  San Francisco Bay marks a rough division between the northern and southern portions of the Coastal Range.  Just east of the San Francisco Bay rises lone Mount Diablo, a sight which is visible from Davis when not blocked by clouds or hazy skies.  Its part of the Southern Coast Range.

Further north Clear Lake drains into Cache Creek.

Many Adventures Outside of Davis can be found in the Northern Coast Range.

Fun Fact: UCD Professor Edward Teller once proposed using nuclear explosions on the Coast Range to help build an aqueduct into the Sacramento Valley.

See wiki:wikipedia:North_Coast_Ranges

20110603 18:54:41 nbsp What and where are the ridges north of Blue Ridge/Rocky Ridge?  Is there a map avaiable? Users/BruceHansen
  Apparently Clark Ridge is one, according to Google Maps. Play around with google maps and see for yourself. You also might request the California index map of 7.5 topos from the USGS (they will send it to you for free), and order some of the topos of areas that interest you.  Users/NickSchmalenberger


text:
C **********************************************************
C library of functions used in calculation of currents
C references:
C [1]   arXiv:0911.4436 (hep-ph)  D. Gomez Dumm et al. (tau -> 3pi nu)
C [2]   arXiv:0911.2640 (hep-ph) D. Gomezz Dumm et al. (tau -> KKpi nu)
C [3]   arXiv:0807.4883 (hep-ph) D. R. Boito et al. (tau -> Kpi nu)
C [4]   P. Roig, talk at (tau -> 2 pi nu)
C [5]   arXiv:0803.2039  (hep-ph) E. Arganda et al., Appendix B (tau -> KK nu)
C **********************************************************
      FUNCTION GRHO_RCHT(XS,XMMM)
      IMPLICIT NONE
      REAL               XS
      DOUBLE PRECISION      XMMM
C **********************************************************
C     REAL FUNCTION Gamma Rho ; energy-dependent width of  rho meson
c     in SU(2) limit mpi=mpi0, mk=mk0;
C     formula (14) of REF [1]
C **********************************************************
       include '../parameter.inc'
      include '../funct_declar.inc'

       REAL MMPI_AV2,MMK_2

      MMPI_AV2 = MMPI_AV**2
      MMK_2 = MMK**2

      IF(XS.GE.(4.*MMK_2)) THEN
           GRHO_RCHT=XMMM*XS*((1.-4.*MMPI_AV2/XS)**1.5
     $              +0.5*(1.-4.*MMK_2/XS)**1.5)
     $                  /(96.*PI*FPI_RPT**2)
      ELSE IF((XS.GE.(4.*MMPI_AV2)).AND.(XS.LE.(4.*MMK_2))) THEN
        GRHO_RCHT=XMMM*XS*(1.-4.*MMPI_AV2/XS)**1.5
     $            /(96.*PI*FPI_RPT**2)
      ELSE
        GRHO_RCHT = 0.
      ENDIF

      RETURN

      END

      FUNCTION GRHO1_RCHT(XS,XMMM,XGGG)
      IMPLICIT NONE
      REAL                XS
      DOUBLE PRECISION       XMMM,XGGG
C **********************************************************
C     REAL FUNCTION Gamma Rho1 ; energy-dependent width of  rho1 meson;
c     in SU(2) limit mpi=mpi0; only rho' -> 2pi loop;
C     formula (33) of REF [1]
C **********************************************************
      include '../parameter.inc'
      include '../funct_declar.inc'

       REAL MMPI_AV2
      MMPI_AV2 = MMPI_AV**2

      IF (XS.GE.(4.*MMPI_AV2)) THEN
        GRHO1_RCHT=XGGG*SQRT(XMMM**2/XS)*
     &      ((XS-4.*MMPI_AV2)/(XMMM**2-4.*MMPI_AV2))**1.5
      ELSE
        GRHO1_RCHT = 0.
      ENDIF

      RETURN
      END

      FUNCTION SIGP(SS)
      IMPLICIT NONE
      DOUBLE PRECISION               SS
C***********************************************************
C     DOUBLRE PRECISION FUNCTION
c     of two body phase space threshold: equal mass scalars
C***********************************************************
      REAL TT
      include '../parameter.inc'
      include '../funct_declar.inc'

      TT = 1. - 4.*MMPI_AV**2/SS

      IF (TT.GE.0) THEN
      SIGP = SQRT(TT)
      ELSE
      SIGP = 0.
      ENDIF

      RETURN
      END

      FUNCTION LAMB_RCHT(X1,X2,X3)
      IMPLICIT NONE
      REAL               X1,X2,X3,ARG_RCHT
C***********************************************************
C     REAL FUNCTION LAMDA of three body phase space
C***********************************************************
      include '../funct_declar.inc'

      ARG_RCHT = (X1-X2-X3)**2 - 4.*X3*X2
      IF(ARG_RCHT.GE.0.) THEN
      LAMB_RCHT = ARG_RCHT
      ELSE
      LAMB_RCHT = 0.
      ENDIF

      RETURN
      END

C******************** FUNCTIONS FOR 2 SCALAR MODES ***********************

C****************************************************************
      FUNCTION R0SCAL_3PI(QX,SX)
C****************************************************************
C     Complex Function: R_0 function (Pablo notes)
C     for the scalar contribution for three pion modes
C     Called by f3pi_rcht.f
C **********************************************************
      IMPLICIT NONE
      REAL            QX,SX,delta0_3piscal,xsx,xst
      DOUBLE PRECISION    XM1,XM2,DSX
      include '../funct_declar.inc'
       include '../parameter.inc'
c$$$      a00_3piscal = 0.220
c$$$      b00_3piscal = 0.268/mmpi_av**2
c$$$      c00_3piscal = -0.0139/mmpi_av**4
c$$$      d00_3piscal = -0.00139/mmpi_av**6
c$$$      x00_3piscal = 36.77*mmpi_av**2
c$$$c      MMF0 = 0.98
c$$$
      dsx = sx
      xsx = sx/4.*sigp(dsx)**2
      xst = sqrt(sx)

      if(sx.le.0.7) then
      delta0_3piscal = sigp(dsx)*(a00_3piscal + b00_3piscal*xsx +
     &               c00_3piscal*xsx**2 + d00_3piscal*xsx**3)

      delta0_3piscal = delta0_3piscal*
     &         (4*mmpi_av**2 - x00_3piscal)/(sx-x00_3piscal)
      else if (xst.le.1.21) then
      delta0_3piscal = -10572.0+50658.0*xst-87903.0*xst**2+66886.0*xst**3
     & -18699.0*xst**4
      delta0_3piscal = delta0_3piscal*pi/180.0
      else
      delta0_3piscal = 255.0*pi/180.0
      endif

      delta0_3piscal = atan(delta0_3piscal)

      R0SCAL_3PI = ALPHA0_3PI/QX +
     &          ALPHA1_3PI/QX**2*(SX - MMF0**2)

      R0SCAL_3PI = R0SCAL_3PI*(cos(delta0_3piscal) +
     &              i*sin(delta0_3piscal))

      RETURN
      END

C****************************************************************
      FUNCTION R2SCAL_3PI(QX,SX)
C****************************************************************
C     Complex Function: R_2 function (Pablo notes)
C     for the scalar contribution for three pion modes
C     Called by f3pi_rcht.f
C **********************************************************
      IMPLICIT NONE
      REAL            QX,SX,delta2_3piscal,xsx,xst
      DOUBLE PRECISION    XM1,XM2,DSX
      include '../funct_declar.inc'
       include '../parameter.inc'
c$$$      a02_3piscal = -0.0444
c$$$      b02_3piscal = -0.0857/mmpi_av**2
c$$$      c02_3piscal = -0.00221/mmpi_av**4
c$$$      d02_3piscal = -0.000129/mmpi_av**6
c$$$      x02_3piscal = -21.62*mmpi_av**2
c$$$c      MMF0 = 0.98

      dsx = sx
      xsx = sx/4.*sigp(dsx)**2
      xst = sqrt(sx)

      if(sx.le.0.7) then
      delta2_3piscal = sigp(dsx)*(a02_3piscal + b02_3piscal*xsx +
     &               c02_3piscal*xsx**2 + d02_3piscal*xsx**3)

      delta2_3piscal = delta2_3piscal*
     &         (4*mmpi_av**2 - x02_3piscal)/(sx-x02_3piscal)
      else if(xst.le.1.21) then
      delta2_3piscal = 282.9-1314.9*xst+2153.4*xst**2-1574.5d0*xst**3+
     & 428.06d0*xst**4
      delta2_3piscal = delta2_3piscal*pi/180.0
      else
      delta2_3piscal = -27.0*pi/180.0
      endif

      delta2_3piscal = atan(delta2_3piscal)

      R2SCAL_3PI = GAMMA0_3PI/QX +
     &          GAMMA1_3PI/QX**2*(SX - MMF0**2)

      R2SCAL_3PI = R2SCAL_3PI*(cos(delta2_3piscal) +
     &              i*sin(delta2_3piscal))

      RETURN
      END

C*************************************************************************
C         Functions for sigma contributions
C*************************************************************************
      FUNCTION FFsig(QX,XX)
C **********************************************************
C     Complex Function:
C     Called by f3pi_rcht.f
C **********************************************************
      IMPLICIT NONE
      REAL            QX,XX,mm2
      DOUBLE PRECISION    XM1,XM2,xphi
      include '../funct_declar.inc'
      include '../parameter.inc'

      mm2 = MMPI_AV**2

      xphi = - rsigma**2* LAMB_RCHT(QX,XX,mm2)/(8.*QX)

      FFsig = dexp(xphi)

       RETURN
       END

C*************************************************************************
      FUNCTION BWsig(XM,XG,XQ)
C **********************************************************
C     Complex Function: S-wave Breit-Wigner
C     Called by f3pi_rcht.f
C **********************************************************
      IMPLICIT NONE
      REAL            XQ
      DOUBLE PRECISION    XM,XG,XM2,XXQ,GAMMA
      include '../funct_declar.inc'
      include '../parameter.inc'

      XXQ = XQ
      XM2 = XM**2
      GAMMA = XG*SIGP(XXQ)/SIGP(XM2)
      BWsig = XM*XM/CMPLX(XM*XM-XQ, -XM*GAMMA)

       RETURN
       END

C*************************************************************************
      FUNCTION DECOUL(mm1,mm3,ss2)
C **********************************************************
C     Real Function: Coulomb interaction effects of two particles
C                    with mm1 and mm2
C     Called by f3pi_rcht.f
C **********************************************************
      IMPLICIT NONE
      REAL            ss2
      DOUBLE PRECISION    mm1,mm3,betam1m3

      include '../funct_declar.inc'
      include '../parameter.inc'
C*******************************************
C   COMMON  block fixed in SUBROUTINE INIPHY
c*******************************************
      COMMON / QEDPRM /ALFINV,ALFPI,XK0
      REAL*8           ALFINV,ALFPI,XK0
      betam1m3 = 1.d0 - (mm1 +mm3)**2/ss2
      betam1m3 = dsqrt(betam1m3)

      if(ss2.gt.(mm1+mm3)**2)
     &    decoul = pi/2.d0/betam1m3/ALFINV

       RETURN
       END

C*************************************************************************
      FUNCTION COUL3PART(mm1,mm2,mm3,ss1,ss2,ss3)
C **********************************************************
C     Real Function: Coulomb interaction effects of two particles
C                    with mm1 and mm2
C     Called by f3pi_rcht.f
C **********************************************************
      IMPLICIT NONE
      REAL            ss3,ss2,ss1
      DOUBLE PRECISION    mm1,mm2,mm3
      include '../funct_declar.inc'
      include '../parameter.inc'

      coul3part = decoul(mm1,mm3,ss2) + decoul(mm2,mm3,ss1)
     &          - decoul(mm1,mm2,ss3)

       coul3part = exp(coul3part)

       RETURN
       END
C*************************************************************************
      FUNCTION fattcoul(mm1,mm3,ss2)
C **********************************************************
C     Real Function: Coulomb attraction of two particles
C                    with mm1 and mm3
C     Called by f3pi_rcht.f
C **********************************************************
      IMPLICIT NONE
      REAL            ss2
      DOUBLE PRECISION    mm1,mm3,betam1m3

      include '../funct_declar.inc'
      include '../parameter.inc'
C*******************************************
C   COMMON  block fixed in SUBROUTINE INIPHY
c*******************************************
      COMMON / QEDPRM /ALFINV,ALFPI,XK0
      REAL*8           ALFINV,ALFPI,XK0
      if(ss2.gt.(mm1+mm3)**2) then
      betam1m3 = 2.*dsqrt(1.d0 - (mm1 +mm3)**2/ss2)
     &            /(1.+ (1.d0 - (mm1 +mm3)**2/ss2))

         fattcoul = 2.*pi/betam1m3/ALFINV
     &               /(1.-exp(-2.*pi/betam1m3/ALFINV))
       else
         fattcoul = 1
          endif

       RETURN
       END

C*************************************************************************
C*************************************************************************
      FUNCTION frepcoul(mm1,mm3,ss2)
C **********************************************************
C     Real Function: Coulomb repuslcion of two particles
C                    with mm1 and mm3
C     Called by f3pi_rcht.f
C **********************************************************
      IMPLICIT NONE
      REAL            ss2
      DOUBLE PRECISION    mm1,mm3,betam1m3

      include '../funct_declar.inc'
      include '../parameter.inc'
C*******************************************
C   COMMON  block fixed in SUBROUTINE INIPHY
c*******************************************
      COMMON / QEDPRM /ALFINV,ALFPI,XK0
      REAL*8           ALFINV,ALFPI,XK0
        if(ss2.gt.(mm1+mm3)**2) then
      betam1m3 = 2.*dsqrt(1.d0 - (mm1 +mm3)**2/ss2)
     &           /(1.+ (1.d0 - (mm1 +mm3)**2/ss2))

         frepcoul = 2.*pi/betam1m3/ALFINV
     &               /(-1.+exp(2.*pi/betam1m3/ALFINV))
       else
         frepcoul = 1
          endif
       RETURN
       END

C*************************************************************************

max_stars_repo_name: AllaMaevskaya/AliRoot

max_issues_repo_name: AllaMaevskaya/AliRoot

max_forks_repo_name: AllaMaevskaya/AliRoot


text:
subroutine derv(neqn,t,u,ut)
!
! Subroutine derv computes the derivative vector
! of the 2 x 2 ODE problem
!
! Double precision coding is used
implicit double precision(a-h,o-z)
!
! Size the arrays
dimension u(neqn), ut(neqn)
!
! Problem parameters
call par(a,b)
!
! Derivative vector
ut(1)=-a*u(1)+b*u(2)
ut(2)= b*u(1)-a*u(2)
return
!
! End of derv
end

max_stars_repo_name: cunyizju/Runge-Kutta-ODE-FORTRAN

max_issues_repo_name: cunyizju/Runge-Kutta-ODE-FORTRAN

max_forks_repo_name: cunyizju/Runge-Kutta-ODE-FORTRAN


text:
(* USCI-A SPI on P2 of MSP430FR59x9

        IN   OUT  DIR  REN  SEL0 SEL1
P1      200  202  204  206  20A  20C
P2      201  203  205  207  20B  20D
P3      220  222  224  226  22A  22C
P4      221  223  225  227  22B  22D
PJ      320  322  324  326  32A  32C

      UCxyCTLW  UCxyBRW  UCx0ySTAT UCxyIFG  UCxyTXBUF  UCxyRXBUF
UCA0    5C0       5C6      5C8      5DC      5CE        5CC
UCA1    5E0       5E6      5E8      5FC      5EE        5EC
UCB0    640       646      648      66C      64E        64C

P2 is used for interfacing the SPI with eUSCI-A1
P2.3  - CS                      \ SPI enable low      x1=Select
P2.4  - CLOCKPULSE              \ Clock               x1=Clock
P2.5  - MOSI                    \ Data bitstream out  x1=Mosi
P2.6  - MISO                    \ Data bitstream in   x0=Miso

  More SPI info on page 794ff of SLAU367O.PDF
  Configuration of the pins on page 94ff of SLAS704G.PDF

*)

                    ( eUSCI-A1 SPI interface )

hex
: SPI-ON        ( -- )
    01 5E0 **bis    \ UCA1CTLW  Reset eUSCI
    08 205 *bis     \ P2DIR     P2.3 is CS output
    70 20B *bic     \ P2SEL0    P2.4 P2.5 P2.6 is SPI
    70 20D *bis     \ P2SEL1    3-wire SPI on
    A981 5E0 !      \ UCA1CTLW  Clk=low, MSB first, Master, Synch, 3-wire, SMClk
    08 5E6 !        \ UCA1BRW   Clock is 16Mhz/4 = 2 MHz
    01 5E0 **bic    \ UCA1CTLW  Free eUSCI
    08 203 *bis ;   \ PJOUT     CS high

code SPI-I/O    ( b1 -- b2 )            \ Read and write at SPI-bus
    tos 5EE & .b mov        \ UCA1TXBUF
    begin,  #2 5FC & bit    \ UCA1IFG
    cs? until,
    begin,  #1 5FC & bit    \ UCA1IFG
    cs? until,
    5EC & tos .b mov  next  \ UCA1RXBUF
    next
end-code

: SPI-OUT       ( b -- )    spi-i/o drop ;  \ Write b to SPI-bus
: SPI-IN        ( -- b )    0 spi-i/o ;     \ Read b from SPI
: SPI}          ( -- )      8 203 *bis ;    \ P2OUT  SPI off CS=high
: {SPI          ( -- )      8 203 *bic ;    \ P2OUT  SPI on, CS=low

spi-on
shield spi\  freeze

max_stars_repo_path: Communication-Protocols/SPI/MSP430/noForth/eUSCI-A1 SPI MSP v100.f

max_stars_repo_name: embeddingforth/embeddinForth

max_issues_repo_name: embeddingforth/embeddinForth

max_forks_repo_name: embeddingforth/embeddinForth


text:
This user exists somewhere in California, as it has been driven out of the village of Davis for having exceeded 225 educational units. Rejoice!

It prefers warm, dry conditions in all seasons.
Its native food source is anything edible, cheap, and hopefully delicious.
It probably would eat green eggs and ham.
It really likes fruit.
If you encounter a wild Amy, try waving your arms and appearing large, as that will frighten it.

And the nonnative food source? jw

20090910 22:10:32 nbsp Expensive food. Users/AmyOhe

20100311 16:53:24 nbsp You have guts. I got flack for calling them crybabies and I was holding back. Users/hankim


text:
Lies that Teaching Assistants TAs tell students:

 1. Im not going to grant any extensions.
 1. Call me or email me any time.  Im always available.
 1. It doesnt matter what I, or the professor, think.  Write what you believe.
 1. Think of the midterm as a diagnostic tool.
 1. My other section is much better prepared than you guys.
 1. My other section is much worse than you guys.
 1. Its imperative you do the reading to get a good grade in this course.
 1. When grading, were not concerned about grammar and style; its the message that counts.
 1. Im not attracted to you.
 1. You dont need to email me about your grade; Ill get it back to you on Monday.
 1. My office is easy to find.
 1. I have a great interest TAing in this subject and I had many options to chose from.
 1. Everything I say is correct and you should believe all that I say.

See also: Things that piss off TAs

20070219 12:38:43 nbsp Oh my god, is there a TA that claims everything they say is correct? I preface everything I say in the classroom with this is probably wrong.... Users/AmyGoogenspa

20070219 18:01:05 nbsp I tell my students I go to bed at 9 pm.  And I dont give out my phone number. Users/DavidGreenwald