text:
************************************************************************
*     This is the W- routine                                           *
************************************************************************
      subroutine qqb_wm2jet_g(p,msq)
************************************************************************
*     Author: J. M. Campbell                                           *
*     July, 2001.                                                      *
************************************************************************
c---Matrix element squared averaged over initial colors and spins
c     q(-p1)+qbar(-p2) -->  g*  + W^+ + g(p7)
c                           |     |
c                           |     --> nu(p3)+e^+(p4)
c                           |
c                           ---> f(p5)+f(p6)
      implicit none
      include 'constants.f'
      include 'masses.f'
      include 'qcdcouple.f'
      include 'ckm.f'
      include 'sprods_com.f'
      include 'zprods_com.f'
      include 'ewcouple.f'
      include 'flags.f'
      include 'lc.f'
      include 'first.f'
      integer j,k,n1,n2
      double precision P(mxpart,4),msq(-nf:nf,-nf:nf)
      double precision mmsq_gg,mmsq_qqb,mmsq_qbq,mmsq_qg
      double precision mmsq_gq,mmsq_gqb,mmsq_qbg
      double precision fac,Vfac
      double precision propsq
      double precision
     . QQ_ud_dd,QQ_us_ds,QQ_uu_du,QQ_du_dd,QQ_su_sd,QQ_uu_ud,
     .QbQb_ds_us,QbQb_du_uu,QbQb_dd_ud,QbQb_sd_su,QbQb_ud_uu,QbQb_dd_du,
     . RRb_dd_du,RRb_ss_du,RRb_uu_du,RRb_ud_dd,RRb_ud_ss,RRb_ud_uu,
     . QQb_ud_dd,QQb_us_ds,QQb_ud_uu,QQb_du_dd,QQb_su_sd,QQb_uu_ud,
     . RbR_dd_du,RbR_ss_du,RbR_uu_du,RbR_ud_dd,RbR_ud_ss,RbR_ud_uu,
     . QbQ_ud_dd,QbQ_us_ds,QbQ_ud_uu,QbQ_du_dd,QbQ_su_sd,QbQ_uu_ud,
     . QG_d_ddu,QG_d_dsc,QG_u_ddd,QG_u_dcc,QG_u_duu,QG_u_udu,
     . GQ_d_ddu,GQ_d_dsc,GQ_u_ddd,GQ_u_dcc,GQ_u_duu,GQ_u_udu,
     . QbG_d_ddu,QbG_u_ucs,QbG_u_uud,QbG_d_uuu,QbG_d_ucc,QbG_d_udd,
     . GQb_d_ddu,GQb_u_ucs,GQb_u_uud,GQb_d_udd,GQb_d_ucc,GQb_d_uuu
      integer,parameter :: jj(-nf:nf)=(/-1,-2,-1,-2,-1,0,1,2,1,2,1/)
      integer,parameter :: kk(-nf:nf)=(/-1,-2,-1,-2,-1,0,1,2,1,2,1/)

      if (first) then
      first=.false.
        if ((Gflag) .or. (QandGflag)) then
          write(*,*) 'Using QQGG+G (REAL) matrix elements'
          write(*,*) '[LC is     N   ]'
          write(*,*) '[SLC is   1/N  ]'
          write(*,*) '[SSLC is 1/N**3]'
        endif
        if ((Qflag) .or. (QandGflag)) then
          write(*,*) 'Using QQBQQB+G (REAL) matrix elements'
          write(*,*) '[LC is   1 ]'
          write(*,*) '[SLC is 1/N]'
        endif
        if     (colourchoice .eq. 1) then
          write(*,*) 'Leading colour only in REAL'
        elseif (colourchoice .eq. 2) then
          write(*,*) 'Sub-leading colour only in REAL'
        elseif (colourchoice .eq. 3) then
          write(*,*) 'Sub-sub-leading colour only in REAL'
        elseif (colourchoice .eq. 0) then
          write(*,*) 'Total of all colour structures in REAL'
        else
          write(*,*) 'Bad colourchoice'
          stop
        endif
      endif

      do j=-nf,nf
      do k=-nf,nf
      msq(j,k)=0d0
      enddo
      enddo

      call spinoru(7,p,za,zb)
      propsq=s(3,4)**2/((s(3,4)-wmass**2)**2+(wmass*wwidth)**2)

      if (Gflag) then
************************************************************************
*     Calculate contributions from the QQGG matrix elements            *
************************************************************************

      call spinoru(7,p,za,zb)
      call xwqqggg(5,1,2,7,6,3,4,mmsq_gg)
      call xwqqggg(1,5,6,7,2,3,4,mmsq_qqb)
      call xwqqggg(2,5,6,7,1,3,4,mmsq_qbq)
      call xwqqggg(1,2,6,7,5,3,4,mmsq_qg)
      call xwqqggg(2,1,6,7,5,3,4,mmsq_gq)
      call xwqqggg(5,1,6,7,2,3,4,mmsq_gqb)
      call xwqqggg(5,2,6,7,1,3,4,mmsq_qbg)

      endif

      if (Qflag) then
************************************************************************
*     Calculate contributions from the QQBQQB matrix elements          *
************************************************************************

c--- basic Q-Q amplitudes
      call addhel(1,5,2,6,7,3,4,QQ_ud_dd,QQ_us_ds,QQ_uu_du)
      call addhel(2,6,1,5,7,3,4,QQ_du_dd,QQ_su_sd,QQ_uu_ud)
c--- basic Qb-Qb amplitudes
      call addhel(5,1,6,2,7,3,4,QbQb_dd_ud,QbQb_ds_us,QbQb_du_uu)
      call addhel(6,2,5,1,7,3,4,QbQb_dd_du,QbQb_sd_su,QbQb_ud_uu)
c--- basic Q-Qb amplitudes
c--- annihilation
      call addhel(6,5,1,2,7,3,4,RRb_dd_du,RRb_ss_du,RRb_uu_du)
      call addhel(1,2,6,5,7,3,4,RRb_ud_dd,RRb_ud_ss,RRb_ud_uu)
c--- scattering
      call addhel(1,5,6,2,7,3,4,QQb_ud_dd,QQb_us_ds,QQb_ud_uu)
      call addhel(6,2,1,5,7,3,4,QQb_du_dd,QQb_su_sd,QQb_uu_ud)
c--- basic Qb-Q amplitudes
c--- annihilation
      call addhel(6,5,2,1,7,3,4,RbR_dd_du,RbR_ss_du,RbR_uu_du)
      call addhel(2,1,6,5,7,3,4,RbR_ud_dd,RbR_ud_ss,RbR_ud_uu)
c--- scattering
      call addhel(2,5,6,1,7,3,4,QbQ_ud_dd,QbQ_us_ds,QbQ_ud_uu)
      call addhel(6,1,2,5,7,3,4,QbQ_du_dd,QbQ_su_sd,QbQ_uu_ud)
c--- basic Q-G amplitudes
      call addhel(7,6,1,5,2,3,4,QG_d_ddu,QG_d_dsc,QG_u_udu)
      call addhel(1,5,7,6,2,3,4,QG_u_ddd,QG_u_dcc,QG_u_duu)
c--- Notes added 28/5/09 (for checking u+g processes):
c---     QG_d_dsc corresponds to:     d + g -> d + c + sb
c---     QG_u_udu corresponds to:     d + g -> d + u + db
c---     QG_u_ddd corresponds to:     d + g -> u + u + ub
c---     QG_u_dcc corresponds to:     d + g -> u + c + cb

c--- basic QB-G amplitudes
      call addhel(6,7,5,1,2,3,4,QbG_d_ddu,QbG_u_ucs,QbG_u_uud)
      call addhel(5,1,6,7,2,3,4,QbG_d_udd,QbG_d_ucc,QbG_d_uuu)
c--- Notes added 28/5/09 (for checking db+g processes):
c---     QbG_u_ucs corresponds to:     ub + g -> ub + sb + c
c---     QbG_u_uud is NOT NEEDED:           db + g -> db + db + u
c---     QbG_d_ddu is used instead:    ub + g -> ub + db + u
c---     QbG_d_udd is NOT NEEDED:           ub + g -> db + ub + u
c---     QbG_d_uuu is used instead:    ub + g -> db + db + d
c---     QbG_d_ucc corresponds to:     ub + g -> db + sb + s

c--- basic G-Q amplitudes
      call addhel(7,5,2,6,1,3,4,GQ_d_ddu,GQ_d_dsc,GQ_u_udu)
      call addhel(2,6,7,5,1,3,4,GQ_u_ddd,GQ_u_dcc,GQ_u_duu)
c--- Notes added 28/5/09 (for checking g+u processes):
c---     GQ_d_dsc corresponds to:     g + d -> c + d + sb
c---     GQ_u_udu corresponds to:     g + d -> u + d + db
c---     GQ_u_ddd corresponds to:     g + d -> u + u + ub
c---     GQ_u_dcc corresponds to:     g + d -> c + u + cb

c--- basic G-QB amplitudes
      call addhel(5,7,6,2,1,3,4,GQb_d_udd,GQb_u_ucs,GQb_u_uud)
      call addhel(6,2,5,7,1,3,4,GQb_d_ddu,GQb_d_ucc,GQb_d_uuu)
c--- Notes added 28/5/09 (for checking g+db processes):
c---     GQb_u_ucs corresponds to:     g + ub -> sb + ub + c
c---     GQb_u_uud is NOT NEEDED     :     g + db -> db + db + u
c---     GQb_d_udd is used instead:    g + ub -> db + ub + u
c---     GQb_d_ddu is NOT NEEDED:          g + ub -> ub + db + u
c---     GQB_d_uuu is used instead:    g + ub -> db + db + d
c---     GQb_d_ucc corresponds to:     g + ub -> sb + db + s

      endif

c--- note the factor of 4d0*xw**2 relative to wbb
      fac=4d0*gsq**3*(gwsq/2d0)**2
c--- extra factor of 2**3=8 to compensate for Ta normalization
      fac=fac*8d0

      do j=-nf,nf
      do k=-nf,nf

      msq(j,k)=0d0

      if (Gflag) then
************************************************************************
*     Sum the contributions from the QQGG matrix elements              *
************************************************************************

c--- note the identical particle factor of 1/6 for the
c--- q-qb initial states, due to 3 gluons in the final state
      if     ((j .eq. 0) .and. (k .eq. 0)) then
        Vfac=0d0
        do n1=1,nf
          do n2=-nf,-1
            Vfac=Vfac+Vsq(n1,n2)
          enddo

        enddo
        msq(j,k)=propsq*mmsq_gg*Vfac*(gwsq**2/4d0/esq**2)
      elseif ((j .gt. 0) .and. (k .lt. 0)) then
        msq(j,k)=propsq*mmsq_qqb*Vsq(j,k)
     .            *(aveqq/avegg)*(gwsq**2/4d0/esq**2)/6d0
      elseif ((j .lt. 0) .and. (k .gt. 0)) then
        msq(j,k)=propsq*mmsq_qbq*Vsq(j,k)
     .            *(aveqq/avegg)*(gwsq**2/4d0/esq**2)/6d0
      elseif ((j .gt. 0) .and. (k .eq. 0)) then
        msq(j,k)=half*propsq*mmsq_qg
     .            *(aveqg/avegg)*(gwsq**2/4d0/esq**2)
     .            *(Vsq(j,-1)+Vsq(j,-2)+Vsq(j,-3)+Vsq(j,-4)+Vsq(j,-5))
      elseif ((j .lt. 0) .and. (k .eq. 0)) then
        msq(j,k)=half*propsq*mmsq_qbg
     .            *(aveqg/avegg)*(gwsq**2/4d0/esq**2)
     .            *(Vsq(j,+1)+Vsq(j,+2)+Vsq(j,+3)+Vsq(j,+4)+Vsq(j,+5))
      elseif ((j .eq. 0) .and. (k .gt. 0)) then
        msq(j,k)=half*propsq*mmsq_gq
     .            *(aveqg/avegg)*(gwsq**2/4d0/esq**2)
     .            *(Vsq(-1,k)+Vsq(-2,k)+Vsq(-3,k)+Vsq(-4,k)+Vsq(-5,k))
      elseif ((j .eq. 0) .and. (k .lt. 0)) then
        msq(j,k)=half*propsq*mmsq_gqb
     .            *(aveqg/avegg)*(gwsq**2/4d0/esq**2)
     .            *(Vsq(+1,k)+Vsq(+2,k)+Vsq(+3,k)+Vsq(+4,k)+Vsq(+5,k))
      endif
      endif

      if (Qflag) then
************************************************************************
*     Sum the contributions from the QQBQQB matrix elements            *
************************************************************************

c--- note the factor of 4d0*xw**2 relative to wbb
      fac=gsq**3*gwsq**2
c--- extra factor of 2**3=8 to compensate for Ta normalization
      fac=fac*8d0

      if     ((j .eq. 0) .and. (k .eq. 0)) then
c--- no glue-glue contribution here
      elseif ((j .gt. 0) .and. (k .gt. 0)) then
c--- Q Q --> Q Q
        if ((jj(j) .eq. 1) .and. (kk(k) .eq. 2)) then
          msq(j,k)=msq(j,k)+Vsq(j,-k)*QQ_ud_dd*0.5d0
     .           +(Vsum(j)-Vsq(j,-k))*QQ_us_ds
        elseif ((jj(j) .eq. 2) .and. (kk(k) .eq. 1)) then
          msq(j,k)=msq(j,k)+Vsq(k,-j)*QQ_du_dd*0.5d0
     .           +(Vsum(k)-Vsq(k,-j))*QQ_su_sd
        elseif ((jj(j) .eq. 1) .and. (kk(k) .eq. 1)) then
          if (j .eq. k) msq(j,k)=msq(j,k)+Vsum(j)*QQ_uu_du
          if (j .ne. k) msq(j,k)=msq(j,k)+Vsum(j)*QQ_us_ds
     .                                   +Vsum(k)*QQ_su_sd
        endif
      elseif ((j .lt. 0) .and. (k .lt. 0)) then
c--- Qb Qb --> Qb Qb
        if ((jj(j) .eq. -1) .and. (kk(k) .eq. -2)) then
          msQ(j,k)=msq(j,k)+Vsq(k,-j)*QbQb_ud_uu*0.5d0
     .           +(Vsum(k)-Vsq(k,-j))*QbQb_sd_su
        elseif ((jj(j) .eq. -2) .and. (kk(k) .eq. -1)) then
          msq(j,k)=msq(j,k)+Vsq(j,-k)*QbQb_du_uu*0.5d0
     .           +(Vsum(j)-Vsq(j,-k))*QbQb_ds_us
        elseif ((jj(j) .eq. -2) .and. (kk(k) .eq. -2)) then
          if (j .eq. k) msq(j,k)=msq(j,k)+Vsum(j)*QbQb_dd_ud
          if (j .ne. k) msq(j,k)=msq(j,k)+Vsum(j)*QbQb_ds_us
     .                                   +Vsum(k)*QbQb_sd_su
        endif
      elseif ((j .gt. 0) .and. (k .lt. 0)) then
c--- Q Qb --> Q Qb
        if ((jj(j).eq.1) .and. (kk(k).eq.-2)) then
          msq(j,k)=msq(j,k)+Vsq(j,k)*(RRb_ud_dd+RRb_ud_uu
     .                               +dfloat(nf-2)*RRb_ud_ss)
     .           +(Vsum(j)-Vsq(j,k))*QQb_us_ds
     .           +(Vsum(k)-Vsq(j,k))*QQb_su_sd
        elseif ((jj(j).eq.1) .and. (kk(k).eq.-1)) then
          if (j.eq.-k) then
            Vfac=0d0
            do n1=1,nf
            do n2=-nf,-1
            if ((n1 .ne. j) .and. (n2 .ne. k)) then
              Vfac=Vfac+Vsq(n1,n2)
            endif
            enddo
            enddo
            msq(j,k)=Vsum(j)*RRb_uu_du
     .                 +Vfac*RRb_ss_du
          else
            msq(j,k)=msq(j,k)+Vsum(j)*QQb_us_ds
          endif
        elseif ((jj(j).eq.2) .and. (kk(k).eq.-2)) then
          if (j.eq.-k) then
            Vfac=0d0
            do n1=1,nf
            do n2=-nf,-1
            if ((n1 .ne. j) .and. (n2 .ne. k)) then
              Vfac=Vfac+Vsq(n1,n2)
            endif
            enddo
            enddo
            msq(j,k)=Vsum(k)*RRb_dd_du
     .                 +Vfac*RRb_ss_du
          else
            msq(j,k)=msq(j,k)+Vsum(k)*QQb_su_sd
          endif
        endif
      elseif ((j .lt. 0) .and. (k .gt. 0)) then
c--- Qb Q --> Q Qb
        if ((jj(j).eq.-2) .and. (kk(k).eq.1)) then
          msq(j,k)=msq(j,k)+Vsq(j,k)*(RbR_ud_dd+RbR_ud_uu
     .                               +dfloat(nf-2)*RbR_ud_ss)
     .           +(Vsum(k)-Vsq(j,k))*QbQ_us_ds
     .           +(Vsum(j)-Vsq(j,k))*QbQ_su_sd
        elseif ((jj(j).eq.-1) .and. (kk(k).eq.1)) then
          if (j.eq.-k) then
            Vfac=0d0
            do n1=-nf,-1
            do n2=1,nf
            if ((n1 .ne. j) .and. (n2 .ne. k)) then
              Vfac=Vfac+Vsq(n1,n2)
            endif
            enddo
            enddo
            msq(j,k)=Vsum(k)*RbR_uu_du
     .                 +Vfac*RbR_ss_du
          else
            msq(j,k)=msq(j,k)+Vsum(k)*QbQ_us_ds
          endif
        elseif ((jj(j).eq.-2) .and. (kk(k).eq.2)) then
          if (j.eq.-k) then
            Vfac=0d0
            do n1=-nf,-1
            do n2=1,nf
            if ((n1 .ne. j) .and. (n2 .ne. k)) then
              Vfac=Vfac+Vsq(n1,n2)
            endif
            enddo
            enddo
            msq(j,k)=Vsum(j)*RbR_dd_du
     .                 +Vfac*RbR_ss_du
          else
            msq(j,k)=msq(j,k)+Vsum(j)*QbQ_su_sd
          endif
        endif
      elseif ((j .gt. 0) .and. (k .eq. 0)) then
c--- Q G --> Q q qb
        if( jj(j) .eq. 1) then
          if (j.eq. 5) then
            Vfac=0d0
          else
            Vfac=Vsq(j,-j-1)
          endif
              msq(j,k)=msq(j,k)+Vfac*(
     .                   (aveqg/aveqq)*QG_u_udu
     .                  +dfloat(nf-2)*(aveqg/aveqq)*QG_u_dcc
     .                  +(aveqg/aveqq)*QG_u_ddd*0.5d0)
     .                         +(2d0-Vfac)*
     .                   (aveqg/aveqq)*QG_d_dsc
        elseif( jj(j) .eq. 2) then
         msq(j,k)=msq(j,k)+Vsq(-j,j-1)*(aveqg/aveqq)*QG_d_ddu*0.5d0
     .                    +(2d0-Vsq(-j,j-1))*(aveqg/aveqq)*QG_d_dsc
        endif
      elseif ((j .lt. 0) .and. (k .eq. 0)) then
c--- QB G --> QB qb q
        if( jj(j) .eq. -2) then
         msq(j,k)=msq(j,k)+Vsq(j,-j-1)*(
     .              (aveqg/aveqq)*QbG_d_ddu
     .             +dfloat(nf-2)*(aveqg/aveqq)*QbG_d_ucc
     .             +(aveqg/aveqq)*QbG_d_uuu*0.5d0)
     .                    +(2d0-Vsq(j,-j-1))*
     .              (aveqg/aveqq)*QbG_u_ucs
        elseif( jj(j) .eq. -1) then
          if (j.eq. -5) then
            Vfac=0d0
          else
            Vfac=Vsq(-j,j-1)
          endif
         msq(j,k)=msq(j,k)+Vfac*(aveqg/aveqq)*QbG_u_uud*0.5d0
     .                    +(2d0-Vfac)*(aveqg/aveqq)*QbG_u_ucs
        endif
c--- G Q --> Q q qb
      elseif ((j .eq. 0) .and. (k .gt. 0)) then
        if( kk(k) .eq. 1) then
         if (k .eq. 5) then
           Vfac=0d0
         else
           Vfac=Vsq(k,-k-1)
         endif
         msq(j,k)=msq(j,k)+Vfac*(
     .             +dfloat(nf-2)*(aveqg/aveqq)*GQ_u_dcc
     .             +(aveqg/aveqq)*GQ_u_ddd*0.5d0
     .             +(aveqg/aveqq)*GQ_u_udu)
     .                         +(2d0-Vfac)*
     .            (aveqg/aveqq)*GQ_d_dsc
        elseif( kk(k) .eq. 2) then
         msq(j,k)=msq(j,k)+Vsq(-k,k-1)*(aveqg/aveqq)*GQ_d_ddu*0.5d0
     .                    +(2d0-Vsq(-k,k-1))*(aveqg/aveqq)*GQ_d_dsc
        endif
      elseif ((j .eq. 0) .and. (k .lt. 0)) then
c--- G QB --> QB qb q
        if( kk(k) .eq. -2) then
              msq(j,k)=msq(j,k)+Vsq(k,-k-1)*(
     .                   (aveqg/aveqq)*GQb_d_udd
     .                  +dfloat(nf-2)*(aveqg/aveqq)*GQb_d_ucc
     .                  +(aveqg/aveqq)*GQb_d_uuu*0.5d0)
     .                         +(2d0-Vsq(k,-k-1))*
     .                   (aveqg/aveqq)*GQb_u_ucs
        elseif( kk(k) .eq. -1) then
         if (k .eq. -5) then
           Vfac=0d0
         else
           Vfac=Vsq(-k,k-1)
         endif
         msq(j,k)=msq(j,k)+Vfac*(aveqg/aveqq)*GQb_u_uud*0.5d0
     .                    +(2d0-Vfac)*(aveqg/aveqq)*GQb_u_ucs
        endif
      endif

      endif

      enddo
      enddo

      return
      end

max_stars_repo_name: tmartini/JHUGen

max_issues_repo_name: tmartini/JHUGen

max_forks_repo_name: tmartini/JHUGen


text:
! This program is an example which illustrates how to read
! earthquake simulator input files.

program input_example

implicit none

integer :: section
integer :: vertex
integer :: element

! Container parameters

integer, parameter :: ctr_recl = 2504   ! Maximum record length

! Geometry summary record

integer, parameter :: gsum_kind = 200   ! Kind for geometry file, summary record
integer :: gsum_n_section               ! Total number of fault sections
integer :: gsum_n_vertex                ! Total number of vertices
integer :: gsum_n_triangle              ! Total number of triangles
integer :: gsum_n_rectangle             ! Total number of rectangles
real(8) :: gsum_lat_lo                  ! Lowest latitude
real(8) :: gsum_lat_hi                  ! Highest latitude
real(8) :: gsum_lon_lo                  ! Lowest longitude
real(8) :: gsum_lon_hi                  ! Highest longitude
real(8) :: gsum_depth_lo                ! Lowest depth
real(8) :: gsum_depth_hi                ! Highest depth

! Geometry section record

integer, parameter :: gsec_kind = 201   ! Kind for geometry file, section information record
integer :: gsec_sid                     ! Section identification number
character(100) :: gsec_name             ! Section name
integer :: gsec_n_vertex                ! Number of vertices within section
integer :: gsec_n_triangle              ! Number of triangles within section
integer :: gsec_n_rectangle             ! Number of rectangles within section
real(8) :: gsec_lat_lo                  ! Lowest latitude within section
real(8) :: gsec_lat_hi                  ! Highest latitude within section
real(8) :: gsec_lon_lo                  ! Lowest longitude within section
real(8) :: gsec_lon_hi                  ! Highest longitude within section
real(8) :: gsec_depth_lo                ! Lowest depth within section
real(8) :: gsec_depth_hi                ! Highest depth within section
real(8) :: gsec_das_lo                  ! Lowest distance along strike within section
real(8) :: gsec_das_hi                  ! Highest distance along strike within section
integer :: gsec_fault_id                ! Fault identification number

! Geometry vertex record

integer, parameter :: gver_kind = 202   ! Kind for geometry file, vertex record
integer :: gver_index                   ! Vertex index number (counts beginning with 1)
real(8) :: gver_lat                     ! Latitude (degrees, positive north)
real(8) :: gver_lon                     ! Longitude (degrees, positive east)
real(8) :: gver_depth                   ! Depth (meters, negative underground)
real(8) :: gver_das                     ! Distance along strike (meters)
integer :: gver_trace_flag              ! On-trace flag (0=not on trace, 1=on trace, 2=initial point of trace, 3=final point of trace)

! Geometry triangle record

integer, parameter :: gtri_kind = 203   ! Kind for geometry file, triangle record
integer :: gtri_index                   ! Element index number (counts beginning with 1)
integer :: gtri_vertex_1                ! Index number for vertex #1
integer :: gtri_vertex_2                ! Index number for vertex #2
integer :: gtri_vertex_3                ! Index number for vertex #3
real(8) :: gtri_rake                    ! Rake angle (degrees)
real(8) :: gtri_slip_rate               ! Slip rate (meters/second)
real(8) :: gtri_aseis_factor            ! Aseismicity factor
real(8) :: gtri_strike                  ! Strike angle (degrees)
real(8) :: gtri_dip                     ! Dip angle (degrees)

! Geometry rectangle record

integer, parameter :: grec_kind = 204   ! Kind for geometry file, rectangle record
integer :: grec_index                   ! Element index number (counts beginning with 1)
integer :: grec_vertex_1                ! Index number for vertex #1
integer :: grec_vertex_2                ! Index number for vertex #2
integer :: grec_vertex_3                ! Index number for vertex #3
integer :: grec_vertex_4                ! Index number for vertex #4
real(8) :: grec_rake                    ! Rake angle (degrees)
real(8) :: grec_slip_rate               ! Slip rate (meters/second)
real(8) :: grec_aseis_factor            ! Aseismicity factor
real(8) :: grec_strike                  ! Strike angle (degrees)
real(8) :: grec_dip                     ! Dip angle (degrees)
integer :: grec_perfect_flag            ! Perfect rectangle flag (0=not perfect, 1=perfect)

! Friction summary record

integer, parameter :: fsum_kind = 200   ! Kind for friction file, summary record
integer :: fsum_n_element               ! Total number of elements
integer :: fsum_elastic_flag            ! Elastic parameters flag (1=included, 0=not included)
integer :: fsum_strength_flag           ! Fault strength flag (1=included, 0=not included)
integer :: fsum_rate_state_flag         ! Rate-state initial state flag (1=included, 0=not included)

! Friction elastic parameter record

integer, parameter :: felp_kind = 201   ! Kind for friction file, elastic parameter record
real(8) :: felp_lame_lambda             ! Lame modulus lambda (Pascal)
real(8) :: felp_lame_mu                 ! Lame modulus mu, also known as the shear modulus (Pascal)

! Friction fault strength record

integer, parameter :: fstr_kind = 202   ! Kind for friction file, fault strength record
integer :: fstr_index                   ! Element index number
real(8) :: fstr_static_strength         ! Static yield strength (Pascal)
real(8) :: fstr_dynamic_strength        ! Dynamic sliding strength (Pascal)

! Friction rate-state parameter record

integer, parameter :: frsp_kind = 203   ! Kind for friction file, rate-state parameter record
integer :: frsp_index                   ! Element index number
real(8) :: frsp_A                       ! Rate-state parameter A
real(8) :: frsp_B                       ! Rate-state parameter B
real(8) :: frsp_L                       ! Rate-state critical distance L (meters)
real(8) :: frsp_f0                      ! Rate-state friction coefficient
real(8) :: frsp_V0                      ! Rate-state reference velocity (meters/second)

! Initial condition summary record

integer, parameter :: csum_kind = 200   ! Kind for initial condition file, summary record
integer :: csum_n_element               ! Total number of elements
integer :: csum_stress_flag             ! Initial stress flag (1=included, 0=not included)
integer :: csum_state_flag              ! Initial state flag (1=included, 0=not included)

! Initial condition stress record

integer, parameter :: csts_kind = 201   ! Kind for initial condition file, initial stress record
integer :: csts_index                   ! Element index number
real(8) :: csts_shear_stress            ! Initial shear stress (Pascal)
real(8) :: csts_normal_stress           ! Initial normal stress (Pascal)

! Initial condition state record

integer, parameter :: crst_kind = 202   ! Kind for initial condition file, initial state record
integer :: crst_index                   ! Element index number
real(8) :: crst_rs_theta                ! Initial rate-state variable theta (seconds)

! In this simple example we will just write out a summary of the input.
! A real simulator would use the input to build up a data structure in memory.
! This is our output file.

open(10, file='input_example_result.dat', status='replace', recl=ctr_recl)

! Open geometry file, and check the signature.
! Note we use spec level 2, for file format version 0.4.

open(7, file='NCA_Ward_Geometry.dat', status='old', recl=ctr_recl)
call check_signature (7, 'EQSim_Input_Geometry_2', 2)

! Read the fault geometry summary record

call find_record (7, gsum_kind)
read(7,*) gsum_n_section, gsum_n_vertex, gsum_n_triangle, gsum_n_rectangle,    &
          gsum_lat_lo, gsum_lat_hi, gsum_lon_lo, gsum_lon_hi, gsum_depth_lo, gsum_depth_hi

if (gsum_n_triangle .ne. 0) then
    write(6,*) 'Geometry file contains triangles, but we only support rectangles in this example.'
    stop
endif

write(10,*) 'Geometry summary, sections=', gsum_n_section, ', vertices=', gsum_n_vertex, ', rectangles=', gsum_n_rectangle

! Open friction file, and check the signature

open(8, file='NCA_Ward_Friction.dat', status='old', recl=ctr_recl)
call check_signature (8, 'EQSim_Input_Friction_2', 1)

! Read the friction summary record

call find_record (8, fsum_kind)
read(8,*) fsum_n_element, fsum_elastic_flag, fsum_strength_flag, fsum_rate_state_flag

if (fsum_elastic_flag .eq. 0) then
    write(6,*) 'Friction file does not contain elastic parameters, but we require it in this example.'
    stop
endif

if (fsum_strength_flag .eq. 0) then
    write(6,*) 'Friction file does not contain fault strangth, but we require it in this example.'
    stop
endif

if (fsum_n_element .ne. gsum_n_triangle + gsum_n_rectangle) then
    write(6,*) 'Friction file element count does not match geometry file.'
    stop
endif

write(10,*) 'Friction summary, elements=', fsum_n_element

! Read the elastic parameter record from the friction file

call find_record (8, felp_kind)
read(8,*) felp_lame_lambda, felp_lame_mu

write(10,*) 'Elastic parameters, lame lambda=', felp_lame_lambda, 'lame mu=', felp_lame_mu

! Open initial condition file, and check the signature

open(9, file='NCA_Ward_Condition.dat', status='old', recl=ctr_recl)
call check_signature (9, 'EQSim_Input_Condition_2', 1)

! Read the initial condition summary record

call find_record (9, csum_kind)
read(9,*) csum_n_element, csum_stress_flag, csum_state_flag

if (csum_stress_flag .eq. 0) then
    write(6,*) 'Initial condition file does not contain stress, but we require it in this example.'
    stop
endif

if (csum_n_element .ne. gsum_n_triangle + gsum_n_rectangle) then
    write(6,*) 'Initial condition file element count does not match geometry file.'
    stop
endif

write(10,*) 'Initial condition summary, elements=', fsum_n_element

! Loop over all fault sections

do section = 1,gsum_n_section

    ! Read the section information record from the geometry file

    call find_record (7, gsec_kind)
    read(7,*) gsec_sid, gsec_name, gsec_n_vertex, gsec_n_triangle, gsec_n_rectangle,    &
              gsec_lat_lo, gsec_lat_hi, gsec_lon_lo, gsec_lon_hi,                       &
              gsec_depth_lo, gsec_depth_hi, gsec_das_lo, gsec_das_hi, gsec_fault_id

    write(10,*) 'Fault section, id=', gsec_sid, ', name=', gsec_name(1:len_trim(gsec_name)),    &
                ', vertices=', gsec_n_vertex, ', rectangles=', gsec_n_rectangle

    ! Loop over all vertices within the section

    do vertex = 1,gsec_n_vertex

        ! Read the vertex record from the geometry file

        call find_record (7, gver_kind)
        read(7,*) gver_index, gver_lat, gver_lon, gver_depth, gver_das, gver_trace_flag

        write(10,*) 'Vertex, index=', gver_index, ', depth=', gver_depth, ', das=', gver_das

    enddo

    ! Loop over all elements within the section

    do element = 1,gsec_n_rectangle

        ! Read the element record from the geometry file, which is a rectangle because we checked above there are no triangles

        call find_record (7, grec_kind)
        read(7,*) grec_index, grec_vertex_1, grec_vertex_2, grec_vertex_3, grec_vertex_4,   &
                  grec_rake, grec_slip_rate, grec_aseis_factor,                             &
                  grec_strike, grec_dip, grec_perfect_flag

        ! Read the fault strength record from the friction file

        call find_record (8, fstr_kind)
        read(8,*) fstr_index, fstr_static_strength, fstr_dynamic_strength

        ! Read the initial stress record from the initial condition file

        call find_record (9, csts_kind)
        read(9,*) csts_index, csts_shear_stress, csts_normal_stress

        write(10,*) 'Rectangle, index=', grec_index, ', rake=', grec_rake,          &
                    ', strike=', grec_strike,                                       &
                    ', dip=', grec_dip,                                             &
                    ', slip rate=', grec_slip_rate,                                 &
                    ', strength=', fstr_static_strength - fstr_dynamic_strength,    &
                    ', shear stress=', csts_shear_stress

    enddo

enddo

stop
end program input_example

! This subroutine scans a file until it finds a record
! of the desired kind.  If end-of-file is encountered,
! write an error message and terminate the program.

subroutine find_record (file_unit, record_kind)

implicit none
integer :: file_unit                    ! Fortran unit number
integer :: record_kind                  ! Kind of record to search for

integer :: current_kind                 ! Kind of the current line in the file
integer, parameter :: eof_kind = 999    ! Kind for end-of-file record

do
    read(file_unit,'(i3)',advance='no') current_kind    ! Non-advancing I/O reads just the 3-digit record kind

    if (current_kind .eq. record_kind) exit     ! Found our kind of record, stop searching

    if (current_kind .eq. eof_kind) then        ! Found end-of-file, it's an error
        write(6,*) 'Found end-of-file when searching for record kind=', record_kind, ', in unit=', file_unit
        stop
    endif

    read(file_unit,*)           ! Skip this record
enddo

return
end subroutine find_record

! This subroutine reads the first record of a file, and
! checks that it is a signature record with the desired
! signature keyword and specification level.

subroutine check_signature (file_unit, desired_keyword, desired_spec_level)

implicit none
integer :: file_unit                ! Fortran unit number
character(*) :: desired_keyword     ! Expected signature keyword
integer :: desired_spec_level       ! Expected specification level

integer :: current_kind             ! Kind of the current line in the file

! Signature record

integer, parameter :: sig_kind = 101
character(100) :: sig_keyword
integer :: sig_spec_level

! Read the kind of the first record, and check it

read(file_unit,'(i3)',advance='no') current_kind    ! Non-advancing I/O reads just the 3-digit record kind

if (current_kind .ne. sig_kind) then
    write(6,*) 'First line of file is not a signature record, in unit=', file_unit
    stop
endif

! Read the contents of the signature record

read(file_unit,*) sig_keyword, sig_spec_level

! Check signature keyword

if (sig_keyword .ne. desired_keyword) then
    write(6,*) 'Incorrect file signature, in unit=', file_unit
    stop
endif

! Check specification level

if (sig_spec_level < desired_spec_level) then
    write(6,*) 'Incompatible file specification level, in unit=', file_unit
    stop
endif

return
end subroutine check_signature

max_stars_repo_name: pmpowers-usgs/opensha

max_issues_repo_name: pmpowers-usgs/opensha

max_forks_repo_name: GNS-Science/opensha-core


text:
	SUBROUTINE SFXLOC  ( iloc, ptype, yval, iret )
C************************************************************************
C* SFXLOC								*
C*									*
C* This subroutine returns the y value on the graph for all the		*
C* characters or symbols to be drawn in SFGRAM.				*
C*									*
C* SFXLOC  ( ILOC, PTYPE, YVAL, IRET )					*
C*									*
C* Input parameters:							*
C*	ILOC		INTEGER		Location (1,2,3)		*
C*	PTYPE		CHAR*		Parameter type			*
C*									*
C* Output parameters:							*
C*	YVAL		REAL		Value on y axis			*
C*	IRET		INTEGER		Return code			*
C*					  0 = normal return		*
C**									*
C* Log:									*
C* M. desJardins/GSFC	 5/90						*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
C*
	CHARACTER*(*)	ptype
C------------------------------------------------------------------------
	iret = 0
C
C*	Query the bounds of the graphics region.
C
	CALL GQGRAF  ( ixt, iyt, yxz, x1, y1, x2, y2, ier )
	IF  ( iloc .eq. 1 )  THEN
	    yval = y1 + ( y2 - y1 ) * .075
	  ELSE IF  ( iloc .eq. 2 )  THEN
	    yval = y1 + ( y2 - y1 ) * 0.5
	  ELSE
	    yval = y1 + ( y2 - y1 ) * 0.85
	END IF
C*
	RETURN
	END

ext: f

max_stars_repo_name: oxelson/gempak

max_issues_repo_name: oxelson/gempak

max_forks_repo_name: oxelson/gempak


! { dg-do compile }
! { dg-options "-std=legacy" }
!
! PR23843
! Make sure derived type I/O with PRIVATE components works where it's allowed
module m1
  type t1
     integer i
  end type t1
end module m1

module m2
  use m1

  type t2
     private
     type (t1) t
  end type t2

  type t3
     private
     integer i
  end type t3

contains
  subroutine test
    character*20 c
    type(t2) :: a
    type(t3) :: b

    a % t % i = 31337
    b % i = 255

    write(c,*) a
    if (trim(adjustl(c)) /= "31337") call abort
    write(c,*) b
    if (trim(adjustl(c)) /= "255") call abort
  end subroutine test
end module m2

use m2
call test
end


text:
program i
  integer ::b
  integer ::a
  a = 3
  b = 20
  print *, (a + b)
end program i

max_stars_repo_name: clementval/fc

max_issues_repo_name: clementval/fc

max_forks_repo_name: clementval/fc


text:
!----------------------------------------------------------------------------
! This file is part of UCLALES.
!
! UCLALES is free software; you can redistribute it and/or modify
! it under the terms of the GNU General Public License as published by
! the Free Software Foundation; either version 3 of the License, or
! (at your option) any later version.
!
! UCLALES is distributed in the hope that it will be useful,
! but WITHOUT ANY WARRANTY; without even the implied warranty of
! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
! GNU General Public License for more details.
!
! You should have received a copy of the GNU General Public License
! along with this program.  If not, see <http://www.gnu.org/licenses/>.
!
! Copyright 1999-2007, Bjorn B. Stevens, Dep't Atmos and Ocean Sci, UCLA
!----------------------------------------------------------------------------
!
module thrm

  implicit none

contains

!
! -------------------------------------------------------------------------
! THERMO: calculates thermodynamics quantities according to level.  Level
! is passed in to allow level of diagnosis to be determined by call rather
! than by runtype
!
  subroutine thermo (level)

    use grid, only : a_rc, a_rv, a_theta, a_pexnr, a_press, a_scr1,  &
         a_scr2, a_rp, a_tp, nxp, nyp, nzp, th00, pi0, pi1,a_rpp

    integer, intent (in) :: level

    select case (level)
    case default
       call drythrm(nzp,nxp,nyp,a_pexnr,a_press,a_tp,a_theta,a_scr1,pi0,   &
            pi1,th00,a_rp,a_rv)
    case (2)
       call satadjst(nzp,nxp,nyp,a_pexnr,a_press,a_tp,a_theta,a_scr1,pi0,  &
            pi1,th00,a_rp,a_rv,a_rc,a_scr2)
    case (3)
       call satadjst3(nzp,nxp,nyp,a_pexnr,a_press,a_tp,a_theta,a_scr1,pi0, &
            pi1,th00,a_rp,a_rv,a_rc,a_scr2,a_rpp)
    case (4)
       stop 'level not supported'
    end select

  end subroutine thermo
!
! -------------------------------------------------------------------------
! update_pi1:  this routine updates a pressure associated with the
! subtraction of a mean acceleration, only incrementing it for dynamic and
! thermal effects for layers above the surface
!
  subroutine update_pi1(n1,awtbar,pi1)

    use grid, only : th00, zt

    integer, intent (in) :: n1
    real, intent (in) , dimension (n1) :: awtbar
    real, intent (inout), dimension (n1) :: pi1

    integer :: k

    do k=2,n1
       pi1(k) = pi1(k-1) + awtbar(k-1)*(zt(k)-zt(k-1))/th00
    end do

  end subroutine update_pi1
!
! -------------------------------------------------------------------------
! DRYTHRM:  this routine calculates theta, and pressure for
! the case when no moisture is present
!
  subroutine drythrm(n1,n2,n3,pp,p,thil,theta,t,pi0,pi1,th00,rt,rv)

  use defs, only : cp, cpr, p00

  integer, intent (in) :: n1,n2,n3
  real, intent (in)    :: pi0(n1),pi1(n1),th00
  real, intent (in)    :: pp(n1,n2,n3),thil(n1,n2,n3),rt(n1,n2,n3)
  real, intent (out)   :: p(n1,n2,n3),theta(n1,n2,n3),rv(n1,n2,n3),t(n1,n2,n3)

  integer :: i,j,k
  real    :: exner

  do j=3,n3-2
    do i=3,n2-2
      do k=1,n1
        exner  = (pi0(k)+pi1(k)+pp(k,i,j))/cp
        p(k,i,j) = p00 * (exner)**cpr
        theta(k,i,j)=thil(k,i,j)+th00
        t(k,i,j)=theta(k,i,j)*exner
        rv(k,i,j)=rt(k,i,j)
      enddo
    enddo
  enddo

  end subroutine drythrm
!
! -------------------------------------------------------------------------
! SATADJST:  this routine calculates theta, and pressure and diagnoses
! liquid water using a saturation adjustment for warm-phase systems
!
  subroutine satadjst(n1,n2,n3,pp,p,tl,th,tk,pi0,pi1,th00,rt,rv,rc,rs)

    use defs, only : cp, cpr, alvl, ep, Rm, p00

    integer, intent (in) ::  n1,n2,n3

    real, intent (in), dimension (n1,n2,n3)    :: pp, tl, rt
    real, intent (in), dimension (n1)          :: pi0, pi1
    real, intent (in)                          :: th00
    real, intent (out), dimension (n1,n2,n3)   :: rc,rv,rs,th,tk,p

    integer :: k, i, j, iterate
    real    :: exner,til,x1,xx,yy,zz

    do j=3,n3-2
       do i=3,n2-2
          do k=1,n1
             exner = (pi0(k)+pi1(k)+pp(k,i,j))/cp
             p(k,i,j) = p00 * (exner)**cpr
             til=(tl(k,i,j)+th00)*exner
             xx=til
             yy=rslf(p(k,i,j),xx)
             zz=max(rt(k,i,j)-yy,0.)
             if (zz > 0.) then
                do iterate=1,3
                   x1=alvl/(cp*xx)
                   xx=xx - (xx - til*(1.+x1*zz))/(1. + x1*til                &
                        *(zz/xx+(1.+yy*ep)*yy*alvl/(Rm*xx*xx)))
                   yy=rslf(p(k,i,j),xx)
                   zz=max(rt(k,i,j)-yy,0.)
                enddo
             endif
             rc(k,i,j)=zz
             rv(k,i,j)=rt(k,i,j)-rc(k,i,j)
             rs(k,i,j)=yy
             tk(k,i,j)=xx
             th(k,i,j)=tk(k,i,j)/exner
          enddo
       enddo
    enddo

  end subroutine satadjst
!
! -------------------------------------------------------------------------
! SATADJST3:  this routine calculates theta, and pressure and diagnoses
! liquid water using a saturation adjustment for warm-phase systems; in
! addition, takes in the account the precipitable water when present
!
  subroutine satadjst3(n1,n2,n3,pp,p,tl,th,tk,pi0,pi1,th00,rt,rv,rc,rs,rp)

    use defs, only : cp, cpr, alvl, ep, Rm, p00
    use mpi_interface, only : myid, appl_abort

    integer, intent (in) ::  n1,n2,n3

    real, intent (in), dimension (n1,n2,n3)  :: pp, tl, rt, rp
    real, intent (in), dimension (n1)        :: pi0, pi1
    real, intent (in)                        :: th00
    real, intent (out), dimension (n1,n2,n3) :: rc, rv, rs, th, tk, p

    integer :: k, i, j, iterate
    real    :: exner, tli, tx, txi, rsx, rcx, rpc, tx1, dtx
    real, parameter :: epsln = 1.e-4

    do j=3,n3-2
       do i=3,n2-2
          do k=1,n1
             exner=(pi0(k)+pi1(k)+pp(k,i,j))/cp
             p(k,i,j) = p00 * (exner)**cpr
             tli=(tl(k,i,j)+th00)*exner
             tx=tli
             rsx=rslf(p(k,i,j),tx)
             rcx=max(rt(k,i,j)-rsx,0.)
             rpc = rp(k,i,j)
             if (rcx > 0. .or. rpc > 0.) then
                iterate = 1
                dtx = 1.
                if (rcx < rpc) then
                   do while (dtx > epsln .and. iterate < 10)
                      txi = alvl*rpc/(cp*tx)
                      tx1 = tx - (tx - tli*(1+txi)) / (1+txi*tli/tx)
                      dtx = abs(tx1-tx)
                      tx  = tx1
                      iterate = iterate+1
                   end do
                   rsx=rslf(p(k,i,j),tx)
                   rcx=max(rt(k,i,j)-rsx,0.)
                else
                   do while(dtx > epsln .and. iterate < 10)
                      txi=alvl/(cp*tx)
                      tx1=tx - (tx - tli*(1.+txi*rcx))/(1. + txi*tli         &
                           *(rcx/tx+(1.+rsx*ep)*rsx*alvl/(Rm*tx*tx)))
                      dtx = abs(tx1-tx)
                      tx  = tx1
                      rsx=rslf(p(k,i,j),tx)
                      rcx=max(rt(k,i,j)-rsx,0.)
                      iterate = iterate+1
                   enddo
                endif

                if (dtx > epsln) then
                   if (myid == 0) print *, '  ABORTING: thrm', dtx, epsln
                   call appl_abort(0)
                endif
             endif
             rc(k,i,j)=rcx
             rv(k,i,j)=rt(k,i,j)-rc(k,i,j)
             rs(k,i,j)=rsx
             tk(k,i,j)=tx
             th(k,i,j)=tk(k,i,j)/exner
          enddo
       enddo
    enddo

  end subroutine satadjst3
!
! ---------------------------------------------------------------------
! This function calculates the liquid saturation vapor mixing ratio as
! a function of temperature and pressure
!
  real function rslf(p,t)

  real, intent (in) :: p, t
  real, parameter :: c0=0.6105851e+03, c1=0.4440316e+02,    &
                     c2=0.1430341e+01, c3=0.2641412e-01,    &
                     c4=0.2995057e-03, c5=0.2031998e-05,    &
                     c6=0.6936113e-08, c7=0.2564861e-11,    &
                     c8=-.3704404e-13

  real ::  esl, x

  x=max(-80.,t-273.16)

  ! esl=612.2*exp(17.67*x/(t-29.65))
  esl=c0+x*(c1+x*(c2+x*(c3+x*(c4+x*(c5+x*(c6+x*(c7+x*c8)))))))
  rslf=.622*esl/(p-esl)

  end function rslf
!
! ---------------------------------------------------------------------
! This function calculates the ice saturation vapor mixing ratio as a
! function of temperature and pressure
!
  real function rsif(p,t)

  real, intent (in) :: p, t
  real, parameter :: c0=0.6114327e+03, c1=0.5027041e+02,    &
                     c2=0.1875982e+01, c3=0.4158303e-01,    &
                     c4=0.5992408e-03, c5=0.5743775e-05,    &
                     c6=0.3566847e-07, c7=0.1306802e-09,    &
                     c8=0.2152144e-12

  real  :: esi, x

  x=max(-80.,t-273.16)
  esi=c0+x*(c1+x*(c2+x*(c3+x*(c4+x*(c5+x*(c6+x*(c7+x*c8)))))))
  rsif=.622*esi/(p-esi)

  end function rsif
!
! -------------------------------------------------------------------------
! FLL_TKRS: Updates scratch arrays with temperature and saturation mixing
! ratio
!
  subroutine fll_tkrs(n1,n2,n3,th,pp,pi0,pi1,dn0,th00,tk,rs)

  use defs, only : cp, R

  integer, intent (in) :: n1,n2,n3
  real, intent (in)    :: th(n1,n2,n3), pp(n1,n2,n3)
  real, intent (in)    :: pi0(n1), pi1(n1), dn0(n1), th00
  real, intent (out)   :: tk(n1,n2,n3)
  real, optional, intent (out)   :: rs(n1,n2,n3)

  integer :: i, j, k
  real    :: exner

  do j=3,n3-2
    do i=3,n2-2
      do k=1,n1
        !print *, pi0(k), pi1(k), pp(k,i,j), k, i, j
        exner=(pi0(k)+pi1(k)+pp(k,i,j))/cp
        tk(k,i,j)=th(k,i,j)*exner
        if (present(rs)) rs(k,i,j)=rslf(R*exner*th00*dn0(k),tk(k,i,j))
      end do
    end do
  end do

  end subroutine fll_tkrs
!
! -------------------------------------------------------------------------
! BRUVAIS:  Cacluates the brunt-vaisaila frequency in accordance with the
! thermodynamic level
!
  subroutine bruvais(n1,n2,n3,level,th,tl,rt,rs,en2,dzm,th00)

  use defs, only : g, R, cp, alvl, ep, ep2

  integer, intent (in) ::  n1, n2, n3, level
  real, intent (in)    ::  th(n1,n2,n3), tl(n1,n2,n3), rt(n1,n2,n3),         &
                           rs(n1,n2,n3), dzm(n1), th00
  real, intent (out)   ::  en2(n1,n2,n3)

  integer :: i, k, j, kp1
  real    :: c1, c2, c3, tvk, tvkp1, rtbar, rsbar, aa, bb

  c1=(1.+ep*alvl/R/th00)/ep
  c2=ep*alvl*alvl/(R*cp*th00*th00)
  c3=alvl/(cp*th00)

  do j=3,n3-2
     do i=3,n2-2
        do k=1,n1-1
           select case(level)
           case (0)
              en2(k,i,j)=g*dzm(k)*((th(k+1,i,j)-th(k,i,j))/th00)
           case (1)
              tvk=th(k,i,j)*(1.+ep2*rt(k,i,j))
              tvkp1=th(k+1,i,j)*(1.+ep2*rt(k+1,i,j))
              en2(k,i,j)=g*dzm(k)*(tvkp1-tvk)/th00
           case (2)
              rtbar=0.5*(rt(k,i,j)+rt(k+1,i,j))
              rsbar=0.5*(rs(k,i,j)+rs(k+1,i,j))
              kp1=min(n1-1,k+1)
              if (rt(k,i,j) > rs(k,i,j) .and. rt(kp1,i,j) > rs(kp1,i,j)) then
                 aa=(1. - rtbar + rsbar*c1)/(1. + c2*rsbar)
                 bb=(c3*aa - 1.)
              else
                 aa=(1.00 + ep2*rtbar)
                 bb=ep2
              end if
              en2(k,i,j)=g*dzm(k)*(aa*(tl(k+1,i,j)-tl(k,i,j))/th00        &
                   + bb*(rt(k+1,i,j)-rt(k,i,j)))
           case (3)
              rtbar=0.5*(rt(k,i,j)+rt(k+1,i,j))
              rsbar=0.5*(rs(k,i,j)+rs(k+1,i,j))
              kp1=min(n1-1,k+2)
              if (rt(k,i,j) > rs(k,i,j) .and. rt(kp1,i,j) > rs(kp1,i,j)) then
                 aa=(1. - rtbar + rsbar*c1)/(1. + c2*rsbar)
                 bb=(c3*aa - 1.)
              else
                 aa=(1.00 + ep2*rtbar)
                 bb=ep2
              end if
              en2(k,i,j)=g*dzm(k)*(aa*(tl(k+1,i,j)-tl(k,i,j))/th00        &
                   + bb*(rt(k+1,i,j)-rt(k,i,j)))
           case default
              stop 'level not supported in bruvais'
           end select
        end do
        en2(n1,i,j)=en2(n1-1,i,j)
     end do
  end do

  end subroutine bruvais

end module thrm

max_stars_repo_name: waqarnabi/tybec

max_issues_repo_name: waqarnabi/tybec

max_forks_repo_name: waqarnabi/tybec


text:
5th Street Fifth Street through downtown Davis for several decades had four lanes, two in each direction. This was changed on August 4, 2014 to one through lane in each direction, middle turn lanes, and space for bike lanes. In the old configuration, the four lanes comprised the entire width of the street between B Street B and L Street L Streets, with no space on the shoulder for bike lanes, or cars to Parking park, and no separate turn lanes. After many years of controversy and setbacks, the the 5th Street Redesign, approved by the City Council in 2009 has been implemented.

On September 8, 2009, the Davis City Council voted unanimously ...that a road diet should be implemented on the Fifth Street Corridor providing for the reconfiguration of two traffic lanes with center left turns lanes and onstreet bicycle lanes between A and L Streets and directing staff to undertake implementing actions. On April 27, 2010, the Council voted unanimously to approve the project description for the redesign, which allows the city to begin an environmental analysis.

The first phase of construction (curb cuts for new crosswalks at several intersections) occurred in November 2013. The second phase of construction, installation of new traffic signals, was completed in April 2014. The third phase, removal of old signals and reconfiguring street lanes, is still underway (as of August 2014). http://traffic.cityofdavis.org/fifthstreetcorridorimprovements Current project information can be found on City of Davis website.

 Project specifics and reasons pro and con

Fifth Street and Russell Boulevard are the main eastwest thoroughfare through Central Davis. Two car lanes in each direction extend from Arlington in West Davis to B Street, and from L Street to east of Pole Line Road in East Davis. Prior to implementation of the redesign, the same number of lanes continued through downtown Davis between B and L Streets. Bike paths run along the south side of the street west of A Street and east of L Street. Prior to the redesign, there were no bike lanes between A and L Streets.

The following description, saved here for historical interest, explained the new street configuration before it was constructed.

This redesign will change the four lanes to:

  one vehicle lane in each direction between B and L Streets
  a middle lane dedicated to left turns (alternating between the two directions)
  bike lanes on both sides of the street between A and L Streets.
  a faster, eightphase cycle for stoplights where F and G Streets cross: less wait time because both directions of Fifth will have a green light for part of the cycle, with a leftturn only phase typical of most major intersections.
  streetscape improvements: curb cuts, crosswalks, median islands adjoining crosswalks on one side of the middle turn lane, to be converted to landscaped medians in some locations
  between A and B Streets (Russell Blvd.), the addition of bike lanes, and changes in stoplight cycle at A Street to better accommodate westbound bicycles turning left going to the campus.

In addition to adding bike lanes, the redesign will make the street safer by placing left turning cars in left turn lanes, out of the way of through traffic. At present in the fourlane configuration, cars turning left at intersections without stoplights (C, D, E, I, J, and K Streets) block traffic in the left lane.
This lane reconfiguration is commonly called a road diet.

 Cost

The City was awarded $836,000 in federal grants to construct the project, according to the http://fifthstreetdavis.org/ project website. In 2009, before the project was officially adopted by the City, proponents gave the following cost breakdown:

  $25,000 for changing the lane stripes on the street
  up to $500,000 for new or modified traffic lights and associated triggering mechanisms at the F and G Street intersections

(Costs for the simple project without medians or changes to the curbs may have increased, or the $836,000 may include those extra features.)

 Pro and con, when the project was being debated
Proponents claimed:

  The accident rate is high on this part of Fifth, indicating a need for traffic calming  specifically, that theres a public safety crisis ... on 5th Street
  bike lanes are needed to make Fifth Street a complete street
  traffic studies have found that the redesigned street can still handle the same amount of traffic, with slight improvement in traffic flow
  stoplights at F and G Streets have a cycle 30 seconds longer than necessary, because all traffic in each direction has to wait for the opposing direction traffic, regardless of how few leftturning cars there are (known as splitphase timing)
  on average, cars will encounter fewer delays, due to improved stoplight timing, and fewer hazards caused by turning cars, thus most travel times will improve slightly
  through traffic channeled into a single line greatly reduces the temptation for motorists to speed, in attempts to pass turning cars or beat the stoplights
  B Street between Fifth and First Streets has almost the same amount of traffic with only one lane in each direction
  this road diet and bike lanes along Fifth Street are specified in the adopted Davis General Plan.

Opponents claimed:
  Bike lanes are not needed, because bicyclists can ride on parallel streets
  four lanes are needed for travel to and from downtown, and across town
  a loss of capacity on Fifth Street will result in more cars on Eighth Street and other parallel streets
  traffic flow will be unacceptably slowed for cars crossing or turning on Fifth at some intersections.
  those turning left at the intersections of C, D, E, I, J, and K Streets do so just as drivers do on countless streets configured this way
  the city would save money by leaving these intersections and Fifth Street as is.

 History of the Fifth Street Redesign

 1990s2005: proposal considered, rejected by city
The redesigned street, essentially as described above, was written into the City of Davis General Plan circa 1993.

In 2003 the Old North Davis Neighborhood Association presented the plan to the City Council and asked that the reconfigured street be implemented, as described in the General Plan. Splitphase signal timing at F and G Streets was implemented in Feb. 2005. That allows cars to turn left free of oncoming traffic, but it requires opposing traffic to wait through a longer red light phase and increases the wait time in all directions.

The road diet was studied by the city between 2003 and 2005. In the end, city public works staff recommended against the redesign to the city council. The city council voted to direct public works to continue to work on ways to make the street safer. Only very minor improvements to the street resulted, despite a conspicuous lack of crosswalks at most intersections.

 20082010: redesign considered again, council decides in favor
In June 2008, the city council asked that city departments address the issue again. In September 2008, the Public Works and Planning Departments began a lengthy process to thoroughly study all the problems with this stretch of street (the Fifth Street corridor), gather input from all concerned community members and organizations, devise alternatives, present these alternatives, and gather input again from the community.

However, at the city council meeting on May 5, 2009, after many addressed the council asking that the process be shortened, the council voted to narrow the alternatives to only two: a four lane alternative with possible safety enhancements, and the road diet alternative, as described in the Davis General Plan.

During the summer of 2009, Davis Bicycles! and the Old North Davis Neighborhood Association took their message directly to the citizens of Davis that the redesign was needed: with a http://www.facebook.com/group.php?gid105676916834#/group.php?gid105676916834 Facebook group, tabling at the Farmers Market and a petition drive. They actively lobbied the City Council to apply for funding through the SACOG Community Design Grant Program. The application for funding would prove successful.

At the City Council meeting on September 8, 2009, redesign supporters presented over 2,000 petition signatures to the council. (Months earlier, opponents of the redesign presented an opposing petition to the council with a few hundred signatures.) By a 50 vote, the council endorsed the proposed redesign. The resolution endorsed the redesign, rather than calling for its construction, because the community review process initiated by staff the previous year was still not finished.

On April 27, 2010, the Council voted unanimously to approve the project description for the redesign, allowing the city to begin an environmental analysis.

 20102013: long gestation period
The project reached an important milestone in October 2012 when city staff, the City Council, and bike/pedestrian advocates of the neighborhoods along the street arrived at a specific design with exact lane widths, and pedestrian safety features: median islands and crosswalks at the C, D, I, J, and K Street intersections (which dont have stoplights). This design was approved by the City Council (item H on consent calendar) on Oct. 23.

In 2011 the city named A.D. Anderson as the consulting firm in charge of creating the specific street design, with http://www.altaplanning.com/ Alta Planning + Design as a subcontractor in charge of community outreach. A.D. Anderson is a firm specializing in large, multilane street thoroughfare and highway projects with minimal bicycling and pedestrian amenities.

The first community workshop under Alta Planning + Design was held on December 12th, 2011.
Project website: http://fifthstreetdavis.org/ (Use the link above for current information from the city.)
This site includes information presented at the Dec. 12 workshop, and a form for submitting comments.

Construction began in late 2013, as described in the introduction at the top.

 More information and links

Some news articles from 201113
  http://www.davisenterprise.com/localnews/city/counciloksfifthstreetredesignplansconstructionlikelytostartinlatesummer/ Council OKs Fifth Street redesign plans; construction likely to start in late summer, Davis Enterprise, 20130529
  http://davisvanguard.org/index.php?optioncom_content&viewarticle&id7335:commentarylongtimecomingonfifthstreet Long Time Coming on Fifth Street, DavisVanguard.org, 20130529
  http://davisvanguard.org/index.php?optioncom_content&viewarticle&id7331:willfifthstreetprojectfinallycommence Will Fifth Street Project Finally Commence?, DavisVanguard.org, 20130528
  http://davisvanguard.org/index.php?optioncom_content&viewarticle&id5759 Council and Community Continue to Wrestle with Specifics on 5th St Redesign, DavisVanguard.org, 20121010
  http://davisvanguard.org/index.php?optioncom_content&viewarticle&id4776:concernsaboutfifthstreetimpactsnearlyderailprojectbeforegettingbackoncourse Concerns About Fifth Street Impacts Nearly Derail Project Before Getting Back on Course, DavisVanguard.org, 20111019
  http://davisvanguard.org/index.php?optioncom_content&viewarticle&id4608:questioningcitystaffscommitmenttofifthstreetredesign&catid53:landuseopenspace&Itemid86 Questioning City Staffs Commitment to Fifth Street Redesign, DavisVanguard.org, 20110812
  http://davisvanguard.org/index.php?optioncom_content&viewarticle&id4166:isthecityslowplayingthefifthstreetredesign Is the City SlowPlaying the Fifth Street Redesign?, DavisVanguard.org, 20110309

The following links date from from 2009

 Facebook group: http://www.facebook.com/group.php?gid105676916834#/group.php?gid105676916834 Supporters of the Fifth Street Redesign
 http://www.ipetitions.com/petition/5thstreet online petition
 http://www.davisbicycles.org/wordpress/projects/5thstreet Davis Bicycles! web page in favor of 5th Street road diet
 http://cityofdavis.org/cdd/pressreleases/repository/20120208.cfm Fifth St. Corridor Neighborhood Meeting
 http://www.oldnorthdavis.net/FifthStreetProposal/fifth_st.htm Old North Davis presentation (in favor of 5th Street road diet)
 http://www.davisbicycles.org/projects/5thstreet/study_findings.html Summary of traffic engineering studies (generally in favor)
 http://davisvanguard.org/index.php?optioncom_content&viewarticle&id2776:citydelaysonfifthstreetcompromisepublicsafety&catid53:landuseopenspace&Itemid86 Steve Tracys Guest Commentary on the Vanguard
 http://davisvanguard.org/index.php?optioncom_content&viewarticle&id2644:guestcommentaryaddressingsafetyconcernsanddesignchangestofifthstcorridor&catid53:landuseopenspace&Itemid86 More Steve Tracy Commentary on the Vanguard
 http://davisvanguard.org/index.php?optioncom_content&viewarticle&id2940:modelshowsfifthstreetredesignimprovestrafficflowthroughcorridor&catid53:landuseopenspace&Itemid86 Article on 2009 UC Davis traffic engineering study, and comparison to previous studies
 http://cityofdavis.org/5thstreetcorridor Fifth Street Corridor, City of Davis website (as of 8/27/09, information at this link is several months out of date)
 http://web.me.com/jlofland Photo essays on ten crashes at 5th and E and 5th and F by E500s resident John Lofland
Videos of simulation models from 2009 UCD Traffic Engineering study
 http://www.youtube.com/watch?vRcqzTBRww8 Simulation of road diet (PM peak traffic, 25% higher than current volume)
 http://www.youtube.com/watch?vkZbNf1f14QE Simulation of existing fourlane traffic (also PM peak traffic, 25% higher than current volume)
Background reading on road diets
 http://en.wikipedia.org/wiki/Road_diet Wikipedia article
 http://www.streetsblog.org/2007/05/03/thebenefitsofaroaddiet Streetsblog article on road diet benefits

20090801 01:40:51 nbsp Good page, though this is the kind of thing that will draw lots of comments.  So to start off, does anyone know how bus traffic and bus stops along Fifth would be handled under a narrow design?  Would busses stop in the middle of traffic to pick up passengers, or would the road have to be expanded to accommodate another lane for the bus?

Also, has any consideration been given to an atgrade crossing of the railroad tracks on L Street to Olive Drive?  Im guessing it could absorb some eastbound traffic, at the very least, from the Olive freeway exit. Users/BrentLaabs
  20090801 18:05:15 nbsp Under the redesigned street, buses would pull part way out of the stream of traffic into the bike lane. Cars would be able to pass by merging left part way into the middle turn lane. Exactly the same as on other streets in Davis with similar configurations, such as Anderson Road and F Street. The way it works now, buses completely block the right lane when they stop. Yes, there would a conflict between buses and bikes on the redesigned street, but its no different from how it works on countless other streets with bike lanes. Users/RussellReagan
  20090804 15:31:44 nbsp Upon closer examination of the proposal, I realize that the bike lanes will be 7 to 8 ft. wide, so buses will have enough space to pull almost all the way out of the lane, leaving enough width for regular size vehicles to pass them in the travel lane, near the edge of the left turn lane. Users/RussellReagan
  20100421 06:52:28 nbsp City of Davis would LOVE to put such a crossing at OliveL. Problem being that Union Pacific, who owns the tracks, wont let them. They have a great deal of issues with grade crossings, etc. So we get schoolkids crossing the tracks illegally, and the occasional fatality, instead. Users/Flynn

20090801 02:56:03 nbsp This might be under the universitys jurisdiction; but the right turn the buses take from Russell Blvd to Howard Way (MU) needs to be fixed. By adding either a right lane must turn right or a dedicated right slip road would allow faster transit times, Ive seen buses and cars wait at this right turn for a while. Users/mperkel
  That side of the street is on the University campus and not part of the city of Davis. Last time I checked, nearby Howard Way had some huge historic potholes, so its all a mess. Users/BrentLaabs

20090801 18:30:54 nbsp This is definitely a needed change. The lights at F and G Sts are horrible and soooo inefficient.  Users/JesseUnger

20090801 20:00:58 nbsp I disagree with Jesse, and think the lights at F and G Streets have been working well since they were put on a splitphase program (with left turn arrows) in 2005.
There are a number of very good points about how a road diet has worked for different streets in different communities. When I heard the presentation this spring from a road diet expert, there were a few things that did NOT work for me. He mentioned the positive effects for businesses, but none of the examples given seemed at all like Hibbert Lumber and their yard. There are a lot of trucks that deliver to them, and a lot of purchases that will never be made from them by bicyclists or pedestrians. He also said that right turners on Fifth would simply find a way to interface with bikes streaming to or from the University during rush hour  and that traffic would be held up if they had to wait.
I dont know that these are crippling flaws, but they made me feel VERY uncomfortable with the demands on 5/5/09 that the process be dispensed with or shortened. I really would like to hear described what the criteria would be for success after making the changes, and what the criteria would be for failure (and reversing the process). Id also like to hear a muchbroader spectrum of opinion about the changes. My concern is that some people who drive everywhere will decide to avoid downtown and patronize businesses on the periphery instead, never expressing their reservations about the diet. Users/DougWalter

20090801 21:42:36 nbsp I am very much in favor of the road diet.  As it is now, I avoid 5th St when I am on a bicycle OR in a car.  I take 8th St instead.  And I think many others do this as well.  So, the argument that putting 5th on a road diet will increase traffic on 8th doesnt really work for me.  Users/CovertProfessor

20090803 11:11:14 nbsp My concern: What would be the length of the backup in a onelane system with the occasional holdups due to the train crossing?  Right now, I have seen a lot of backup in the two lanes and am not sure it would not backup all the way to L street if confined to a single lane.  Does this proposal address this situation that happens daily? Users/JeffWood

20090803 18:24:37 nbsp Im indifferent to a change, since I avoid 5th street like the plague, but the amount of traffic flow on 5th street versus other parallel streets is very different. At 5 pm, it is VERY busy on 5th street with two lanes. How will this change if we reduce it to one lane? People arent going to change their habbits, just look at B st betweem 5th and 1st. I stopped biking that way because I felt unsafe with the crazy drivers at rush hour. The amount of cars has grown too large for the city to handle in its current state and reducing lanes on 5th street will make it worse.

Has anyone consulted with an applied mathematician or engineer about traffic flow? After all, this would be a good project for someone to evaluate.  Users/BrandonBarrette
 Davis Municipal Code/22 Chapter 22, section 22.02.0 of the Davis Municipal Code establishes and describes the duties of the office of city traffic engineer, who is also the Director of Public Works. We should go through the Davis Enterprise on Newsbank and find out what city staff have actually said about this. Users/NickSchmalenberger
  20090804 15:41:46 nbsp Yes, there have been at least two traffic engineering studies specifically about Fifth Street. The first was by Fehr & Peers consultants in 2005, the second by http://cee.engr.ucdavis.edu/faculty/zhang/default.htm Dr. Michael Zhang of the UCD Civil and Environmental Engineering Dept. A postdoc and graduate student from this research group presented their findings to the Bicycle Advisory Commission on July 6. Both studies found that the road diet would have only minor negative effects on traffic, mainly on a small number of vehicles approaching 5th Street from the cross streets. In both cases they found that traffic flow actually would improve in one direction during the peak traffic times, with more cars than are using the street today. Users/RussellReagan

 Do you know if either or both of those studies are available online? As a mathematician myself Im always intrigued to see how math helps real world situations. Users/BrandonBarrette

20090804 06:03:55 nbsp Possible SACOG money for project approved by council http://davisvanguard.org/index.php?optioncom_content&viewarticle&id2931:fifthstreetprojectcouldgetsacogmoney&catid53:landuseopenspace&Itemid86 Fifth Street Project Could Get SACOG Money Users/DavidGreenwald

20090805 16:32:07 nbsp Video simulations from the recent UCD study are now on YouTube; I added the links them (see More information) above. Users/RussellReagan

20090814 19:39:08 nbsp I dont think we should be selectively bikefriendly: if Davis is going to be 100% bike friendly, then all streets should have bike lanes, or at least should be accessible without fear of being hit by the crazy drivers on fifth.  And as someone who lives off of 5th, a bike lane would definitely encourage people to bike downtown rather than drive, which equals decreased emissions.  The only thing that would suck would be the actual construction.  If they do it, I hope its a quick process!! Users/JesBisagno

20090815 17:48:21 nbsp As nice as it would be to have bike lanes on 5th from A to L. But as a person who lives on 8th street I have been very much bombarded with a lot of speeding cars and noise from the traffic on 8th. So limiting the lanes on 5th would only cause more aches in other places. I also bike around town and to work in downtown Davis. And have found better routes to avoid bad streets without bike lanes.    Users/MinhTran

20090815 18:30:38 nbsp Bike lanes on 5th street are absolutely needed.  Ive occasionally found myself biking along that street, not realizing that there were no bike lanes, or not realizing that I had just turned onto 5th.  It was very dangerous.  Bikes are mixed in with traffic there, and it is hard to turn.

If traffic flow is a problem, perhaps the city could try synchronizing the traffic lights, so that cars dont have to stop at every block on many streets. Users/IDoNotExist
  That sounds counterproductive to all of the traffic calming measures Davis has implemented.  Traffic flow isnt the solution, its the problem!  Users/BrentLaabs
  As it says earlier in this page, the traffic lights at F and G street are synchronized. See http://cityofdavis.org/meetings/councilpackets/20041012/05E_Fifth_St_Traffic_Signal_PS&E.pdf for the plans and specification. http://cityofdavis.org/meetings/councilpackets/20060502/09_Fifth_Street_Improvements.pdf has some information about the results and more general information about issues with this section of 5th Street. Users/NickSchmalenberger

20090816 00:39:52 nbsp I feel bad for anyone who will try to continue down 5th street outside of BL streets as there will be no bike lanes on that part of 5th/Russell. Im actually not sure about 5th street east of L, but I know west of A street that there is only a path on the south side of the road, which, if you are traveling west, means you have to cross traffic to get to the path. This seems like a tease to bikers. Why not just make all of 5th street like 8th street and keep the fast moving cars on Covell where they belong instead of right down the middle of town.  Users/BrandonBarrette

20090816 01:49:41 nbsp There are bike paths on 5th east of L Street, and the one on the south side of 5th west of A street also works well. I rode to school on my bike down 5th from West Davis for several years using the bike path and didnt have trouble. I usually rode through the City Hall Parking lot. Most of the trouble I had was between B and L Street, like at G street a car turning right ran into me. I do support the bike lanes, because the street is already a bad situation. I have seen cars backed up from F street in front of the Fire Stations driveway, and this was in 2007. Users/NickSchmalenberger

20090820 14:01:09 nbsp For the time being, I wish the City of Davis would prohibit biking on 5th street, until a decision is made. Someone is going to get seriously hurt, most likely a freshman.
I cant think of a more dangerous spot in Davis to either bike or drive. Ive been in Davis for many years, both as a biker and a driver and there is nothing that annoys me more than driving down 5th street at night and having to change lanes to pass two bikers without lights leisurely riding side by side. I rode on 5th once as a frosh and was scared out of my wits. If youre biking, just take 3rd or 8th until the mess on 5th street clears up.
 Users/ct

  Bicyclists have a right to ride on the road too. However those who choose not to ride with lights at night should be banished all together. My issue with 5th street is those who treat it like a highway through downtown. The speed limit should be reduced to 25 mph when in the heart of Davis, its getting much too dangerous for bikers and pedestrians alike. Users/BrandonBarrette

20090822 06:16:48 nbsp I would like to see the actual study  as I am not convinced this will not create even more dangerous scenerios. Even in the video, which uses 25% increased traffic as peak traffic, I am not sure represents the real peak traffic load.  Further, I see no train tracks in that simulation.  My worry is that even in this short simulation, you see repeated areas where the left turn traffic backs up to block the traffic that would be going straight.  In order to keep the single lane of traffic moving, the left turns will have to be reduced in length, and that just spells people running that light repeatedly  and that is foreseeable and dangerous  for bicyclists, pedestrians, etc.  You are also going to have people going around that left turn lane by entering the bicycle lane.  Given the traffic that the road supports (and other roads are not going to be viable substitutes), this plan seems highly unlikely to have the desired effect  outside of a dedicated bicycle lane.  I am open to being convinced otherwise. Users/IdeasAsOpiates

20090822 07:41:46 nbsp Dear IdeasAsOpiates.  In the case of a public safety crisis like the one we have on 5th Street, I will take facts and real world examples as my opiates.  That said, to find the written summary of the model, please click on the link to summary report after you go to:

http://www.davisbicycles.org/projects/5thstreet/study_findings.html

I would direct you in particular to the information and conclusions that begin on page 7.

As to the traffic volumes in the study, yes, they do represent a significant increase OVER the current traffic volumes.  The UCD engineers used vehicle numbers in the model that are 25% higher than the current volumes during an evening commute when UCD is in full session.  You are correct that this doesnt represent the real peak traffic load because it is in fact significantly HIGHER.  And the road diet street still outperforms the current 4lane street.

You are correct the model shows no train tracks.  They were omitted in the model the City commissioned as well.  It isnt possible to reflect the few random trains that appear in a week on these tracks, rarely during peak hour.  We shouldnt compromise the safety of our street because of those rare events, anyway.

If you saw left turn traffic backing up in the video simulations, I think you were either looking at the video of the current 5th Street design, or focusing on F and G Streets.  This simulation software is designed to evaluate through traffic on the primary corridor, in this case 5th Street.  These videos were prepared using the existing signal setup for northbound and southbound traffic on F and G.  Once this street is reconfigured, traffic on these cross streets should get the more conventional signals where the left turn arrows come on for a short time IF there are cars waiting in the left turn pockets.  This is a very low volume of vehicles, by the way.  The highest left turn count off of F or G is northbound G Street traffic turning left onto westbound 5th Street, 99 cars in the entire peak hour.  1 1/2 cars a minute will not cause much backup, or hold up oncoming southbound traffic much.  The F Street left turn volume is 64 cars in the peak hour, about 1 a minute.

You also have a concern about cars hanging out of the left turn pockets when the light is red.  You may have picked up this idea from the misguided Chamber of Commerce representative who ridiculed our schematic drawing of an intersection at a hearing a few months ago.  He was looking at our image of the intersection of 5th and D, where the TOTAL number of cars turning left off of 5th Street in both directions during the peak hour is 27–less than one car every two minutes.  I dont think that level of traffic will back up out of the left turn lane under any scenario.  The highest volume of peak hour traffic turning left off of 5th Street at the F and G Street intersections is westbound G Street turning on to southbound G Street–69 vehicles in the entire hour.  Again, with the light timing restored to roughly one minute for the full cycle, this is not a situation that will have vehicles hanging out of the turn pockets and blocking the single through lane.

I appreciate your last comment, Ideas, that you are open to input.  You have nothing to fear from this proposed improvement to safety, traffic flow, and pedestrian and bicycle access.  As hundreds of other cities have learned, there are no losers with this design.  Steve Tracy. Users/stracy

20090823 06:44:34 nbsp Brian (or someone else who opposes this thing)  you may want to reword and/or expand the section I moved your argument to.  I happen to be a proponent of complete streets in general, and this redesign seems a really good idea to me based on the abovementioned studies and relative low cost, so my current motivation for actively seeking counterarguments is low.  As Mr. or Ms. Opiates says above, Im open to being convinced to go to the other side, but I tend to be convinced by facts (for example I dont see how the quoted $25,000 for repainting and <$500,000 for lights could reach the untold millions from that addition, so sources or further explanation would be good there). Users/BrettHall

20090912 01:49:02 nbsp Does anyone know what happened at the City Hall meeting on Tuesday?  Any progress? Users/JesBisagno

20090912 03:47:24 nbsp There is currently road work on 5th street / Russell.  Is this the same thing as the 5th street widening, or just regular repaving work?  (There seems to be substantial repaving work going on all over the city...) Users/IDoNotExist

20090912 08:32:43 nbsp Yes, there http://www.davisvanguard.org/index.php?optioncom_content&viewarticle&id2983:councilmovesgrantprocessforwardwithresolutionofsupportforfifthstreetredesign&catid53:landuseopenspace&Itemid86 has been progress!  And no, the paving is separate. Users/CovertProfessor

20100501 16:12:21 nbsp Looks like theyre going to go ahead with the Road Diet. Users/Flynn
  Yep  as I noted above, the Council voted unanimously to approve the project description for the redesign, which allows the city to begin an environmental analysis.  Users/CovertProfessor
   Any word on the Analysis at this time? Users/WesP

20110324 16:49:37 nbsp Great. Traffic is slow enough..lets slow it down even further. The cops have NEVER issued a ticket for riding on the sidewalk through here...no problem....Hey Davis, how about fixing the storm drains instead of wasting money on shit like this?  The flooding roads and potholes need immediate attention.... Users/JoshLawson

20110921 21:48:04 nbsp We have ongoing speeding and exhibition of speed problems along the entire E. 8th Street corridor. E. 8th St. is a MAJOR bicycle corridor which connects at least five elementary, middle, and high school communities, the Davis Public Library, plus many UC Davis students heading to A St. in designated bike lanes. The posted limit is 25mph which is seldom adhered to. Motorists, commercial vehicles, contractors pulling trailers, garbage trucks, buses and SPEEDING emergency vehicles are all problematic as are some unpredictable cyclists navigating this mess.  E. 8th St. between B and F is especially narrow, complicated by dozens of recycling bins, garbage toters and waste receptacles, some of which are left in the bike lane for days at a time.  (I routinely call Code Enforcement).

A recent DUI fatality at E. 8th & Miller plus other accidents at E. 8th and B Streets necessitate speed enforcement. Is there signage residents can post on their front lawns? (i.e. Stay Alive at 25mph?) Or are there Safe Route to School Funds to ensure the safety of this vital yet dangerous motor, cycling and pedestrian corridor?

Im procyclist (been riding since 1973) and procommonsense. I believe in complete streets wherever possible.  However, E. 8th St. is a an unofficial bicycle boulevard for hundreds of nonmotorists and motorists alike.

Q: Will the reduction of lanes on 5th Street increase motorists and commercial traffic on parallel streets like E. 8th making them more unsafe?  Would a new configuration of E. 8th St. be appropriate, perhaps following the model of Santa Cruz, Palo Alto and San Francisco which make motorists drive oneway, yet provide cyclists with bidirectional access?  Comments welcome. Users/fknochenhauer
  Speaking for myself  I often take 8th to avoid 5th.  So, if 5th were improved  which is, after all, the goal of the redesign  I would take it more often, not less.   Users/CovertProfessor

20110922 14:18:02 nbsp New NPR article and audio story about Complete Streets for all users of our city streets and expressways.  A worthy article:  http://www.npr.org/2011/05/24/136585282/asseniorsincreaseapushtomakestreetssafer Users/fknochenhauer

20110922 14:54:15 nbsp Good read about Complete Streets as an urban transportation design philosophy:  http://www.completestreets.org/ Users/fknochenhauer

20111130 02:30:40 nbsp The thought seems astounding to me that after adding bike lanes on the street and reducing the motorized trafic lanes from four to two, the traffic flow will increase.  Wouldnt the traffic flow increase even more if there werent bike lanes and the street was resigned?  Of course people would say, We want bike lanes!  Has any consideration been given to having elevated bike lanes?  Users/BruceHansen

20111206 16:10:36 nbsp Ouch.  If theres such a thing as a good time to do construction anywhere downtown, its summer.  Moving it to the fall of 2012 is sad. Users/TomGarberson

20121101 09:21:38 nbsp I live on 5th Street between B and L and I can attest to the high number of accidents that occur in this corridor. Anyone who thinks cyclists do not use 5th because there are no bike lanes is incorrect.  Often they use the sidewalk making walking along 5th Street dangerous.  Given the safety concerns I have from observing traffic flow, I believe this project is necessary.  Safety trumps travel time. Users/rachelmesser

20130107 12:44:45 nbsp This is one of the worst ideas the inept, out of touch city council has approved. Whats next putting bike lanes on I80. This embarrassing idea will create so much gridlock at the peak traffic times. There are already various alternate routes that are very close by, screwing up one of the main arteries in Davis isnt a solution at all. In this economy with the already ridiculous rate of taxes we pay to reside in this city it is absolutely irresponsible of this city council to approve spending on this. WHAT A WASTE OF TIME AND MONEY. Impeach the council.  Users/PublicEnemyNumberOne

20130612 10:29:01 nbsp City Council approves Fifth Street Road Diet. Whether you like it or not, its coming this August, 2013. During construction, well see traffic impacts on other parallel streets, especially 8th St. After that, who really knows.  http://www.davisenterprise.com/localnews/city/counciloksfifthstreetredesignplansconstructionlikelytostartinlatesummer/ Users/fknochenhauer

20130718 15:04:19 nbsp Not sure how this will all turn out. I personally avoid 5th street when biking and will continue to do so as I like the less trafficked routes downtown. :)

P.S. To PublicEnemyNumberOne, there is a bike lane on I80...
 Users/jenb

20131226 09:30:25 nbsp To jenb, The only bike lane on I80 is on the causeway and is a complete separate entity that does not effect traffic. This catering to bicyclists is a joke. Maybe the city should fix the parking crisis, or allow other businesses to open shop in Davis so all of us dont have to venture to West Sac, Vacaville or dreaded Woodland. Idiots!!! Users/PublicEnemyNumberOne

20140505 13:02:17 nbsp Wow! Did the City Council miss on this one! I completely agree with PublicEnemyNumberOne! What a waste of money!

History shows that reducing the number of lanes always causes congestion. Just look at East bound I80 between 113 and Richards. It goes from 5 lanes to 3. Quite often it is a source of congestion, even on the weekends.

The other day, I counted eight cars in each of the West bound 5th St lanes waiting for Gst light to turn. After the construction is complete, those eight cars in each lane will become sixteen cars in one lane, thus backing up way past the R/R Tracks.

Is Davis no longer green? The additional congestion will certainly cause more pollution from idling vehicles!
 Users/FrankP

20140716 14:59:38 nbsp Any idea when this project is supposed to be completed?  Users/Tricia
  The http://traffic.cityofdavis.org/fifthstreetcorridorimprovements project web site (linked above) says the final phase will begin 7/21 and be finished in August. Users/DougWalter

20140810 03:41:30 nbsp
This video is about Fifth Street in Davis, CA  . . . today, August 9, 2014

YouTube  5th Street: New Bike Lanes, Crosswalks & Street Lighting! (w/ Bonus Nighttime Clip)
https://www.youtube.com/watch?v6zqLxJnSp4

If youve been out of town: this street was just completely redesigned!  In the evening, after cooling down from a hot summer day, people were stepping out with the evening breezes, walking, running, and riding bikes on the newly redesigned 5th Street.  We jumped out of our car for about 10 min to take upclose shots of some of the new features, and by chance the new lampposts came on, too.  The new striping reconfigured 4 car lanes to 2 (see 8/4/2014 video), plus 1 center leftturn lane . . . both directions did not have bike lanes until a few days ago (see other video to compare the before / after).  Bonus footage: at ~8min, there is also a clip added for what it looks like at night driving when its dark . . .

Enjoy the ride!

 Users/JasonBundy

20140811 20:07:22 nbsp this redesign is working out better than anticipated. It was nice to have a non timed light heading N/S thru 5th. Also the protected turn pockets & bike lanes seem nice. Im just interested to see how 5th street handles excessive loads (peak times, farmar, big events). Also the turning bulb out do give some dead space in the roadway that just does nothing now, perhaps an island or a tree? Users/StevenDaubert

20140813 11:54:07 nbsp Made an account just to comment on this. It aggravated me beyond belief, when one day I needed to drive crosstown and realized that one of the few streets that allowed to do that relatively fast, is now done for. TO put it bluntly, any design that creates dead space is inherently bad. Now, what do you do when youre driving behind a 15 mph Prius? Exactly, swear profusely, because that is the only thing left to do now. I have seen a traffic jam on 5th a few days ago, with no train to attribute to that. It was rush hour, which to my observation has never produced anything like this when the street had two lanes. To anyone complaining that this is somehow unsafe, i say this: LEARN TO DRIVE. Lets take a look: preciously, the 2lane street became a 1lane when the bus pulled over, or when someone needed to make a left turn. Now it is a one lane street 100% of the time. Well done. Try doing something like this in, say, NYC, youd get lynched. I have never voted on anything Davisrelated, but now I will. I really dont care who for, as long as it is AGAINST whoever voted for this redesign. Ill make sure all of my friends do the same. Users/CombatWombat

20140813 12:41:24 nbsp Well, I just drove it (by car) and my first impression is: (very) confusing. Too much. Clearly of good will, but: too much.
PS: https://www.youtube.com/watch?v6zqLxJnSp4 the YT clip doesnt show the current (of today: 8/13/2014) and definitive filling; its much more painted now.  Users/ConstantiaOomen

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


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

! Simple tests for structured ordered loops with loop-control.
! Tests the structure of the loop, storage to index variable and return and
! storage of the final value of the index variable.

! Test a simple loop with the final value of the index variable read outside the loop
! CHECK-LABEL: simple_loop
subroutine simple_loop
  ! CHECK: %[[I_REF:.*]] = fir.alloca i32 {bindc_name = "i", uniq_name = "_QFsimple_loopEi"}
  integer :: i

  ! CHECK: %[[C1:.*]] = arith.constant 1 : i32
  ! CHECK: %[[C1_CVT:.*]] = fir.convert %c1_i32 : (i32) -> index
  ! CHECK: %[[C5:.*]] = arith.constant 5 : i32
  ! CHECK: %[[C5_CVT:.*]] = fir.convert %c5_i32 : (i32) -> index
  ! CHECK: %[[C1:.*]] = arith.constant 1 : index
  ! CHECK: %[[LI_RES:.*]] = fir.do_loop %[[LI:.*]] = %[[C1_CVT]] to %[[C5_CVT]] step %[[C1]] -> index {
  do i=1,5
  ! CHECK:   %[[LI_CVT:.*]] = fir.convert %[[LI]] : (index) -> i32
  ! CHECK:   fir.store %[[LI_CVT]] to %[[I_REF]] : !fir.ref<i32>
  ! CHECK:   %[[LI_NEXT:.*]] = arith.addi %[[LI]], %[[C1]] : index
  ! CHECK:  fir.result %[[LI_NEXT]] : index
  ! CHECK: }
  end do
  ! CHECK: %[[LI_RES_CVT:.*]] = fir.convert %[[LI_RES]] : (index) -> i32
  ! CHECK: fir.store %[[LI_RES_CVT]] to %[[I_REF]] : !fir.ref<i32>
  ! CHECK: %[[I:.*]] = fir.load %[[I_REF]] : !fir.ref<i32>
  ! CHECK: %{{.*}} = fir.call @_FortranAioOutputInteger32(%{{.*}}, %[[I]]) : (!fir.ref<i8>, i32) -> i1
  print *, i
end subroutine

! Test a 2-nested loop with a body composed of a reduction. Values are read from a 2d array.
! CHECK-LABEL: nested_loop
subroutine nested_loop
  ! CHECK: %[[ARR_REF:.*]] = fir.alloca !fir.array<5x5xi32> {bindc_name = "arr", uniq_name = "_QFnested_loopEarr"}
  ! CHECK: %[[ASUM_REF:.*]] = fir.alloca i32 {bindc_name = "asum", uniq_name = "_QFnested_loopEasum"}
  ! CHECK: %[[I_REF:.*]] = fir.alloca i32 {bindc_name = "i", uniq_name = "_QFnested_loopEi"}
  ! CHECK: %[[J_REF:.*]] = fir.alloca i32 {bindc_name = "j", uniq_name = "_QFnested_loopEj"}
  integer :: asum, arr(5,5)
  integer :: i, j
  asum = 0
  ! CHECK: %[[S_I:.*]] = arith.constant 1 : i32
  ! CHECK: %[[S_I_CVT:.*]] = fir.convert %[[S_I]] : (i32) -> index
  ! CHECK: %[[E_I:.*]] = arith.constant 5 : i32
  ! CHECK: %[[E_I_CVT:.*]] = fir.convert %[[E_I]] : (i32) -> index
  ! CHECK: %[[ST_I:.*]] = arith.constant 1 : index
  ! CHECK: %[[I_RES:.*]] = fir.do_loop %[[LI:.*]] = %[[S_I_CVT]] to %[[E_I_CVT]] step %[[ST_I]] -> index {
  do i=1,5
    ! CHECK: %[[LI_CVT:.*]] = fir.convert %[[LI]] : (index) -> i32
    ! CHECK: fir.store %[[LI_CVT]] to %[[I_REF]] : !fir.ref<i32>
    ! CHECK: %[[S_J:.*]] = arith.constant 1 : i32
    ! CHECK: %[[S_J_CVT:.*]] = fir.convert %[[S_J]] : (i32) -> index
    ! CHECK: %[[E_J:.*]] = arith.constant 5 : i32
    ! CHECK: %[[E_J_CVT:.*]] = fir.convert %[[E_J]] : (i32) -> index
    ! CHECK: %[[ST_J:.*]] = arith.constant 1 : index
    ! CHECK: %[[J_RES:.*]] = fir.do_loop %[[LJ:.*]] = %[[S_J_CVT]] to %[[E_J_CVT]] step %[[ST_J]] -> index {
    do j=1,5
      ! CHECK: %[[LJ_CVT:.*]] = fir.convert %[[LJ]] : (index) -> i32
      ! CHECK: fir.store %[[LJ_CVT]] to %[[J_REF]] : !fir.ref<i32>
      ! CHECK: %[[ASUM:.*]] = fir.load %[[ASUM_REF]] : !fir.ref<i32>
      ! CHECK: %[[I:.*]] = fir.load %[[I_REF]] : !fir.ref<i32>
      ! CHECK: %[[I_CVT:.*]] = fir.convert %[[I]] : (i32) -> i64
      ! CHECK: %[[C1_I:.*]] = arith.constant 1 : i64
      ! CHECK: %[[I_INDX:.*]] = arith.subi %[[I_CVT]], %[[C1_I]] : i64
      ! CHECK: %[[J:.*]] = fir.load %[[J_REF]] : !fir.ref<i32>
      ! CHECK: %[[J_CVT:.*]] = fir.convert %[[J]] : (i32) -> i64
      ! CHECK: %[[C1_J:.*]] = arith.constant 1 : i64
      ! CHECK: %[[J_INDX:.*]] = arith.subi %[[J_CVT]], %[[C1_J]] : i64
      ! CHECK: %[[ARR_IJ_REF:.*]] = fir.coordinate_of %[[ARR_REF]], %[[I_INDX]], %[[J_INDX]] : (!fir.ref<!fir.array<5x5xi32>>, i64, i64) -> !fir.ref<i32>
      ! CHECK: %[[ARR_VAL:.*]] = fir.load %[[ARR_IJ_REF]] : !fir.ref<i32>
      ! CHECK: %[[ASUM_NEW:.*]] = arith.addi %[[ASUM]], %[[ARR_VAL]] : i32
      ! CHECK: fir.store %[[ASUM_NEW]] to %[[ASUM_REF]] : !fir.ref<i32>
      asum = asum + arr(i,j)
      ! CHECK: %[[LJ_NEXT:.*]] = arith.addi %[[LJ]], %[[ST_J]] : index
      ! CHECK: fir.result %[[LJ_NEXT]] : index
    ! CHECK: }
    end do
    ! CHECK: %[[J_RES_CVT:.*]] = fir.convert %[[J_RES]] : (index) -> i32
    ! CHECK: fir.store %[[J_RES_CVT]] to %[[J_REF]] : !fir.ref<i32>
    ! CHECK: %[[LI_NEXT:.*]] = arith.addi %[[LI]], %[[ST_I]] : index
    ! CHECK: fir.result %[[LI_NEXT]] : index
  ! CHECK: }
  end do
  ! CHECK: %[[I_RES_CVT:.*]] = fir.convert %[[I_RES]] : (index) -> i32
  ! CHECK: fir.store %[[I_RES_CVT]] to %[[I_REF]] : !fir.ref<i32>
end subroutine

! Test a downcounting loop
! CHECK-LABEL: down_counting_loop
subroutine down_counting_loop()
  integer :: i
  ! CHECK: %[[I_REF:.*]] = fir.alloca i32 {bindc_name = "i", uniq_name = "_QFdown_counting_loopEi"}

  ! CHECK: %[[C5:.*]] = arith.constant 5 : i32
  ! CHECK: %[[C5_CVT:.*]] = fir.convert %[[C5]] : (i32) -> index
  ! CHECK: %[[C1:.*]] = arith.constant 1 : i32
  ! CHECK: %[[C1_CVT:.*]] = fir.convert %[[C1]] : (i32) -> index
  ! CHECK: %[[CMINUS1:.*]] = arith.constant -1 : i32
  ! CHECK: %[[CMINUS1_STEP_CVT:.*]] = fir.convert %[[CMINUS1]] : (i32) -> index
  ! CHECK: %[[I_RES:.*]] = fir.do_loop %[[LI:.*]] = %[[C5_CVT]] to %[[C1_CVT]] step %[[CMINUS1_STEP_CVT]] -> index {
  do i=5,1,-1
  ! CHECK: %[[LI_CVT:.*]] = fir.convert %[[LI]] : (index) -> i32
  ! CHECK: fir.store %[[LI_CVT]] to %[[I_REF]] : !fir.ref<i32>
  ! CHECK: %[[LI_NEXT:.*]] = arith.addi %[[LI]], %[[CMINUS1_STEP_CVT]] : index
  ! CHECK: fir.result %[[LI_NEXT]] : index
  ! CHECK: }
  end do
  ! CHECK: %[[I_RES_CVT:.*]] = fir.convert %[[I_RES]] : (index) -> i32
  ! CHECK: fir.store %[[I_RES_CVT]] to %[[I_REF]] : !fir.ref<i32>
end subroutine

! Test a general loop with a variable step
! CHECK-LABEL: loop_with_variable_step
! CHECK-SAME: (%[[S_REF:.*]]: !fir.ref<i32> {fir.bindc_name = "s"}, %[[E_REF:.*]]: !fir.ref<i32> {fir.bindc_name = "e"}, %[[ST_REF:.*]]: !fir.ref<i32> {fir.bindc_name = "st"}) {
subroutine loop_with_variable_step(s,e,st)
  integer :: s, e, st
  ! CHECK: %[[S:.*]] = fir.load %[[S_REF]] : !fir.ref<i32>
  ! CHECK: %[[S_CVT:.*]] = fir.convert %[[S]] : (i32) -> index
  ! CHECK: %[[E:.*]] = fir.load %[[E_REF]] : !fir.ref<i32>
  ! CHECK: %[[E_CVT:.*]] = fir.convert %[[E]] : (i32) -> index
  ! CHECK: %[[ST:.*]] = fir.load %[[ST_REF]] : !fir.ref<i32>
  ! CHECK: %[[ST_CVT:.*]] = fir.convert %[[ST]] : (i32) -> index
  ! CHECK: %[[I_RES:.*]] = fir.do_loop %[[LI:.*]] = %[[S_CVT]] to %[[E_CVT]] step %[[ST_CVT]] -> index {
  do i=s,e,st
  ! CHECK:  %[[LI_CVT:.*]] = fir.convert %[[LI]] : (index) -> i32
  ! CHECK:  fir.store %[[LI_CVT]] to %[[I_REF]] : !fir.ref<i32>
  ! CHECK:  %[[LI_NEXT:.*]] = arith.addi %[[LI]], %[[ST_CVT]] : index
  ! CHECK:  fir.result %[[LI_NEXT]] : index
  ! CHECK: }
  end do
  ! CHECK: %[[I_RES_CVT:.*]] = fir.convert %[[I_RES]] : (index) -> i32
  ! CHECK: fir.store %[[I_RES_CVT]] to %[[I_REF]] : !fir.ref<i32>
end subroutine

! Test usage of pointer variables as index, start, end and step variables
! CHECK-LABEL: loop_with_pointer_variables
! CHECK-SAME: (%[[S_REF:.*]]: !fir.ref<i32> {fir.bindc_name = "s", fir.target}, %[[E_REF:.*]]: !fir.ref<i32> {fir.bindc_name = "e", fir.target}, %[[ST_REF:.*]]: !fir.ref<i32> {fir.bindc_name = "st", fir.target}) {
subroutine loop_with_pointer_variables(s,e,st)
! CHECK:  %[[E_PTR_REF:.*]] = fir.alloca !fir.ptr<i32> {uniq_name = "_QFloop_with_pointer_variablesEeptr.addr"}
! CHECK:  %[[I_REF:.*]] = fir.alloca i32 {bindc_name = "i", fir.target, uniq_name = "_QFloop_with_pointer_variablesEi"}
! CHECK:  %[[I_PTR_REF:.*]] = fir.alloca !fir.ptr<i32> {uniq_name = "_QFloop_with_pointer_variablesEiptr.addr"}
! CHECK:  %[[S_PTR_REF:.*]] = fir.alloca !fir.ptr<i32> {uniq_name = "_QFloop_with_pointer_variablesEsptr.addr"}
! CHECK:  %[[ST_PTR_REF:.*]] = fir.alloca !fir.ptr<i32> {uniq_name = "_QFloop_with_pointer_variablesEstptr.addr"}
  integer, target :: i
  integer, target :: s, e, st
  integer, pointer :: iptr, sptr, eptr, stptr

! CHECK:  %[[I_PTR:.*]] = fir.convert %[[I_REF]] : (!fir.ref<i32>) -> !fir.ptr<i32>
! CHECK:  fir.store %[[I_PTR]] to %[[I_PTR_REF]] : !fir.ref<!fir.ptr<i32>>
! CHECK:  %[[S_PTR:.*]] = fir.convert %[[S_REF]] : (!fir.ref<i32>) -> !fir.ptr<i32>
! CHECK:  fir.store %[[S_PTR]] to %[[S_PTR_REF]] : !fir.ref<!fir.ptr<i32>>
! CHECK:  %[[E_PTR:.*]] = fir.convert %[[E_REF]] : (!fir.ref<i32>) -> !fir.ptr<i32>
! CHECK:  fir.store %[[E_PTR]] to %[[E_PTR_REF]] : !fir.ref<!fir.ptr<i32>>
! CHECK:  %[[ST_PTR:.*]] = fir.convert %[[ST_REF]] : (!fir.ref<i32>) -> !fir.ptr<i32>
! CHECK:  fir.store %[[ST_PTR]] to %[[ST_PTR_REF]] : !fir.ref<!fir.ptr<i32>>
  iptr => i
  sptr => s
  eptr => e
  stptr => st

! CHECK:  %[[I_PTR:.*]] = fir.load %[[I_PTR_REF]] : !fir.ref<!fir.ptr<i32>>
! CHECK:  %[[S_PTR:.*]] = fir.load %[[S_PTR_REF]] : !fir.ref<!fir.ptr<i32>>
! CHECK:  %[[S:.*]] = fir.load %[[S_PTR]] : !fir.ptr<i32>
! CHECK:  %[[S_CVT:.*]] = fir.convert %[[S]] : (i32) -> index
! CHECK:  %[[E_PTR:.*]] = fir.load %[[E_PTR_REF]] : !fir.ref<!fir.ptr<i32>>
! CHECK:  %[[E:.*]] = fir.load %[[E_PTR]] : !fir.ptr<i32>
! CHECK:  %[[E_CVT:.*]] = fir.convert %[[E]] : (i32) -> index
! CHECK:  %[[ST_PTR:.*]] = fir.load %[[ST_PTR_REF]] : !fir.ref<!fir.ptr<i32>>
! CHECK:  %[[ST:.*]] = fir.load %[[ST_PTR]] : !fir.ptr<i32>
! CHECK:  %[[ST_CVT:.*]] = fir.convert %[[ST]] : (i32) -> index
! CHECK:  %[[I_RES:.*]] = fir.do_loop %[[LI:.*]] = %[[S_CVT]] to %[[E_CVT]] step %[[ST_CVT]] -> index {
  do iptr=sptr,eptr,stptr
! CHECK:    %[[LI_CVT:.*]] = fir.convert %[[LI]] : (index) -> i32
! CHECK:    fir.store %[[LI_CVT]] to %[[I_PTR]] : !fir.ptr<i32>
! CHECK:    %[[LI_NEXT:.*]] = arith.addi %[[LI]], %[[ST_CVT]] : index
! CHECK:    fir.result %[[LI_NEXT]] : index
  end do
! CHECK:  }
! CHECK:  %[[I_RES_CVT:.*]] = fir.convert %[[I_RES]] : (index) -> i32
! CHECK:  fir.store %[[I_RES_CVT:.*]] to %[[I_PTR]] : !fir.ptr<i32>
end subroutine

! Test usage of non-default integer kind for loop control and loop index variable
! CHECK-LABEL: loop_with_non_default_integer
! CHECK-SAME: (%[[S_REF:.*]]: !fir.ref<i64> {fir.bindc_name = "s"}, %[[E_REF:.*]]: !fir.ref<i64> {fir.bindc_name = "e"}, %[[ST_REF:.*]]: !fir.ref<i64> {fir.bindc_name = "st"}) {
subroutine loop_with_non_default_integer(s,e,st)
  ! CHECK: %[[I_REF:.*]] = fir.alloca i64 {bindc_name = "i", uniq_name = "_QFloop_with_non_default_integerEi"}
  integer(kind=8):: i
  ! CHECK: %[[S:.*]] = fir.load %[[S_REF]] : !fir.ref<i64>
  ! CHECK: %[[S_CVT:.*]] = fir.convert %[[S]] : (i64) -> index
  ! CHECK: %[[E:.*]] = fir.load %[[E_REF]] : !fir.ref<i64>
  ! CHECK: %[[E_CVT:.*]] = fir.convert %[[E]] : (i64) -> index
  ! CHECK: %[[ST:.*]] = fir.load %[[ST_REF]] : !fir.ref<i64>
  ! CHECK: %[[ST_CVT:.*]] = fir.convert %[[ST]] : (i64) -> index
  integer(kind=8) :: s, e, st

  ! CHECK: %[[I_RES:.*]] = fir.do_loop %[[LI:.*]] = %[[S_CVT]] to %[[E_CVT]] step %[[ST_CVT]] -> index {
  do i=s,e,st
    ! CHECK: %[[LI_CVT:.*]] = fir.convert %[[LI]] : (index) -> i64
    ! CHECK: fir.store %[[LI_CVT]] to %[[I_REF]] : !fir.ref<i64>
    ! CHECK: %[[LI_NEXT:.*]] = arith.addi %[[LI]], %[[ST_CVT]] : index
    ! CHECK: fir.result %[[LI_NEXT]] : index
  end do
  ! CHECK: }
  ! CHECK: %[[I_RES_CVT:.*]] = fir.convert %[[I_RES]] : (index) -> i64
  ! CHECK: fir.store %[[I_RES_CVT]] to %[[I_REF]] : !fir.ref<i64>
end subroutine

max_stars_repo_name: ornata/llvm-project

max_issues_repo_name: ornata/llvm-project

max_forks_repo_name: ornata/llvm-project


text:
*
*     --------------------------------------------------------------
*     R L S P 4 A
*     --------------------------------------------------------------
*                                                                  *
*
      SUBROUTINE RLSP4A(K,JA1,JA2,JA3,K1,K2,K3,IRE,IAT,REC)
      IMPLICIT DOUBLEPRECISION (A-H,O-Z)
      COMMON/CONSTS/ZERO,TENTH,HALF,ONE,TWO,THREE,FOUR,SEVEN,ELEVEN,EPS
      COMMON/MEDEFN/IHSH,NJ(16),LJ(16),NOSH1(16),NOSH2(16),J1QN1(31,3),
     :     J1QN2(31,3),IJFUL(16)
*
      REC=ONE/DSQRT(DBLE(J1QN1(JA1,K)*J1QN1(JA2,K)*J1QN1(JA3,K)))
      ISKR=JA3-JA2
      IF(ISKR.GT.1) THEN
        IAT=0
        CALL DLSA3(K,JA2,JA3,K3,IRE,IAT,RE)
        IF(IAT.EQ.0)RETURN
        REC=RE*REC
      ENDIF
*
      IAT=0
      CALL DLSA4(K,JA1,JA2,K1,K2,K3,IRE,IAT,RE)
      IF(IAT.EQ.0)RETURN
      REC=RE*REC
*
      IF(JA1.EQ.1.AND.JA2.EQ.2)RETURN
*
      IAT=0
      CALL DLSA1(K,JA1,K1,IRE,IAT,RE)
      IF(IAT.EQ.0)RETURN
      REC=RE*REC
*
      ISKR=JA2-JA1
      IF(JA1.EQ.1)ISKR=JA2-1-JA1
      IF(ISKR.LE.1)RETURN
      IAT=0
      CALL DLSA3(K,JA1,JA2,K1,IRE,IAT,RE)
      REC=RE*REC
      RETURN
      END