text:
module params
  implicit none

!================================param.f95=============================================!
! contains all parameters that need to be defined globally, seems like there is a lot  !
! but it just makes everything a lot nice to look at and less confusing this way.	   !
!																					   !
!																					   !
! Look at this as a dictionary if you want to know what any parameter is for           !
!======================================================================================!

character(len=100),parameter :: homedir='../'
character(len=100),parameter :: mylimitsdir = '../data/WIMPlimits/mylimits'

!------------------------------Nelder Mead stuff---------------------------------------!
integer,parameter :: MAXFUNEVALS = 20000 ! Maximum function evaluations
integer,parameter :: IPRINT = -1 ! Print results from minimisaition
integer,parameter :: NLOOP = 2 ! Number of iterations before looping
integer,parameter :: IQUAD = 0
double precision,parameter :: SIMP = 0.1 ! Nor this
double precision,parameter :: STOPCR0 = 1.0d-10 ! Accuracy of max likelihood

!------------------------------Dark matter stuff---------------------------------------!
double precision :: sigma_p ! WIMP cross section
double precision :: m_chi ! WIMP mass

!--------------------------------------Backgrounds---------------------------------------!
integer :: n_bg ! Number of backgrounds
integer :: n_nu_tot
integer,parameter :: n_nu_tot_solar = 9
integer,dimension(:),allocatable :: solar
double precision,dimension(:),allocatable :: R_bg ! Background rate normalisations
double precision,dimension(:),allocatable :: R_bg_err ! Background rate uncertainties
double precision,dimension(:),allocatable :: NuUnc ! All neutrino uncertainties
double precision,dimension(:),allocatable  :: NuFlux ! All neutrino fluxes
double precision,dimension(:,:),allocatable :: Flux_all ! All neutrino fluxes
double precision,dimension(:,:),allocatable :: E_nu_all ! All neutrino energies

!------------------------------Experimental stuff---------------------------------------!
double precision :: Exposure ! Exposure in ton-years

!------------------------------Binning parameters---------------------------------------!
integer :: nE_bins ! Number of bins in Energy (from E_th to E_max)
integer :: nTot_bins ! Number of bins used for likelihood
integer :: nT_bins ! Number of bins in Time (from Jan 1 to Dec 31)
double precision,dimension(:),allocatable :: E_bin_centers ! Center of energy bins
double precision,dimension(:),allocatable :: E_bin_edges ! Edges of energy bins
double precision,dimension(:),allocatable :: T_bin_centers ! Center of time bins
!------------------------------------------------------------------------------------------!

!--------------------------Signal and background models----------------------------------!
double precision,dimension(:),allocatable :: RD_wimp ! Indiv WIMP Signal model
double precision,dimension(:,:),allocatable :: RD_bg,RD_sig ! Background/Signal model
double precision,dimension(:),allocatable :: N_obs ! N of observed events (for likelihood)
!------------------------------------------------------------------------------------------!

!--------------------------------------General constants----------------------------------!
double precision,parameter :: pi = 3.141592653589793

!-------------------------------- Needed for code timing ----------------------------------!
integer :: mytime(3)
real :: clock_start,clock_stop
!------------------------------------------------------------------------------------------!

end module params

max_stars_repo_name: ScottHaselschwardt/NeutrinoFog

max_issues_repo_name: ScottHaselschwardt/NeutrinoFog

max_forks_repo_name: ScottHaselschwardt/NeutrinoFog


text:
subroutine get_flow_fields (sif, fg, f2s, wavedata, sr, flowVelocityType)
!----- GPL ---------------------------------------------------------------------
!
!  Copyright (C)  Stichting Deltares, 2011-2016.
!
!  This program is free software: you can redistribute it and/or modify
!  it under the terms of the GNU General Public License as published by
!  the Free Software Foundation version 3.
!
!  This program is distributed in the hope that it will be useful,
!  but WITHOUT ANY WARRANTY; without even the implied warranty of
!  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
!  GNU General Public License for more details.
!
!  You should have received a copy of the GNU General Public License
!  along with this program.  If not, see <http://www.gnu.org/licenses/>.
!
!  contact: delft3d.support@deltares.nl
!  Stichting Deltares
!  P.O. Box 177
!  2600 MH Delft, The Netherlands
!
!  All indications and logos of, and references to, "Delft3D" and "Deltares"
!  are registered trademarks of Stichting Deltares, and remain the property of
!  Stichting Deltares. All rights reserved.
!
!-------------------------------------------------------------------------------
!  $Id: get_flow_fields.f90 5717 2016-01-12 11:35:24Z mourits $
!  $HeadURL: https://svn.oss.deltares.nl/repos/delft3d/tags/6686/src/engines_gpl/wave/packages/io/src/get_flow_fields.f90 $
!!--description-----------------------------------------------------------------
! NONE
!!--pseudo code and references--------------------------------------------------
! NONE
!!--declarations----------------------------------------------------------------
   use swan_flow_grid_maps
   use swan_input
   use flow_data
   use wave_data
   !
   implicit none
!
! Global variables
!
   integer              :: flowVelocityType
   type(input_fields)   :: sif              ! input fields defined on swan grid
   type(grid)           :: fg               ! flow grid
   type(grid_map)       :: f2s              ! flow to swn grid mapper
   type(input_fields)   :: fif              ! input fields defined on flow grid
   type(wave_data_type) :: wavedata
   type(swan)           :: sr               ! swan input structure
!
! Local variables
!
   integer        :: iprint    = 0
   real           :: alpb      = 0.0
   real           :: dummy     = -999.0
   logical        :: clbot     = .true.
   character(256) :: mudfilnam = ' '
!
!! executable statements -------------------------------------------------------
!
   ! Allocate memory swan input fields defined on flow grid
   !
   call alloc_input_fields(fg, fif, wavedata%mode)
   !
   if (sr%swmor) then
      !
      ! Read depth from com-file
      !
      call get_dep (fif%dps, fif%mmax, fif%nmax, &
                  & fg%grid_name)
      !
      ! Map depth to SWAN grid
      !
      call grmap (fif%dps      , fif%npts        , &
                & sif%dps      , sif%npts        , &
                & f2s%ref_table, f2s%weight_table, f2s%n_surr_points, &
                & iprint       )
   endif
   !
   ! Read polygons fixed structures
   !
   call dam_cod (fg%x, fg%y, fg%kcs, fg%mmax, fg%nmax)
   !
   if (sr%swwlt) then
      !
      ! Read water level from com-file
      !
      call get_lev (wavedata%time , &
                  & fif%s1, fif%mmax, fif%nmax, &
                  & fg%grid_name)
      !
      ! Map water level to SWAN grid
      !
      call grmap (fif%s1       , fif%npts        , &
                & sif%s1       , sif%npts        , &
                & f2s%ref_table, f2s%weight_table, f2s%n_surr_points, &
                & iprint       )
   endif
   !
   if (sr%swuvt) then
      !
      ! Read velocity from com-file
      !
      call get_cur (wavedata%time, &
                  & fif%kfu, fif%kfv, fif%u1, fif%v1, fif%mmax, fif%nmax, &
                  & fg%kmax, fg%grid_name, fg%layer_model, flowVelocityType, &
                  & fif%dps, fif%s1)
      !
      ! Convert to Cartesian, cell centres
      !
      call flow2wav (fif%u1  , fif%v1 , &
                   & fg%alfas, fg%guu , fg%gvv, fg%mmax, fg%nmax, fg%kcs, &
                   & fif%kfu , fif%kfv, alpb  , clbot  )
      !
      ! Map velocity to SWAN grid
      ! NOTE: mapping procedure only updates the part of SWAN grid covered by current FLOW domain
      !
      call grmap (fif%u1       , fif%npts        , &
                & sif%u1       , sif%npts        , &
                & f2s%ref_table, f2s%weight_table, f2s%n_surr_points, &
                & iprint       )
      call grmap (fif%v1       , fif%npts        , &
                & sif%v1       , sif%npts        , &
                & f2s%ref_table, f2s%weight_table, f2s%n_surr_points, &
                & iprint       )
   endif
   !
   if (sr%swwindt .and. sr%dom(1)%qextnd(q_wind) >= 1) then
      !
      ! Read wind from com-file
      !
      call get_wind (wavedata%time, &
                   & fif%windu, fif%windv, fif%mmax, fif%nmax, &
                   & fg%grid_name)
      !
      ! Map wind to SWAN grid
      !
      call grmap (fif%windu    , fif%npts        , &
                & sif%windu    , sif%npts        , &
                & f2s%ref_table, f2s%weight_table, f2s%n_surr_points, &
                & iprint       )
      call grmap (fif%windv    , fif%npts   , &
                & sif%windv    , sif%npts   , &
                & f2s%ref_table, f2s%weight_table, f2s%n_surr_points, &
                & iprint       )
   endif
   !
   if (wavedata%mode == flow_mud_online) then
      write(*,'(4x,a)') 'Mud:'
      write(mudfilnam,'(a,a)')'com-',trim(mudids(1))
      !
      ! Read mud parameters needed by SWAN
      !
      call get_params  (dummy, sr%rhomud, mudfilnam)
      call get_visc (wavedata%time , sr%viscmud, fif%mmax, fif%nmax, mudfilnam)
      !
      ! Read depth from mud-com-file
      ! ASSUMPTIONS:
      ! - Only one mud domain
      ! - Mud grid is identical to the grid of the only water domain
      !
      call get_dep (fif%dpsmud, fif%mmax, fif%nmax, &
                  & mudfilnam)
      !
      ! Map depth to SWAN grid
      !
      call grmap (fif%dpsmud   , fif%npts        , &
                & sif%dpsmud   , sif%npts        , &
                & f2s%ref_table, f2s%weight_table, f2s%n_surr_points, &
                & iprint       )
      !
      ! Read mud level from mud-com-file
      !
      call get_lev (wavedata%time , &
                  & fif%s1mud, fif%mmax, fif%nmax, &
                  & mudfilnam)
      !
      ! Map mud level to SWAN grid
      !
      call grmap (fif%s1mud    , fif%npts        , &
                & sif%s1mud    , sif%npts        , &
                & f2s%ref_table, f2s%weight_table, f2s%n_surr_points, &
                & iprint       )
   endif
   !
   ! Deallocate memory swan input fields defined on flow grid
   !
   call dealloc_input_fields(fif, wavedata%mode)
end subroutine get_flow_fields

max_stars_repo_name: liujiamingustc/phd

max_issues_repo_name: liujiamingustc/phd

max_forks_repo_name: liujiamingustc/phd


text:
! { dg-do compile }
! { dg-options "-O2 -ffast-math -fdump-tree-pre" }

      subroutine foo(U,V,R,N,A)
      integer N
      real*8 U(N,N,N),V(N,N,N),R(N,N,N),A(0:3)
      integer I3, I2, I1
C
      do I3=2,N-1
       do I2=2,N-1
        do I1=2,N-1
         R(I1,I2,I3)=V(I1,I2,I3)
     *      -A(0)*( U(I1,  I2,  I3  ) )
     *      -A(1)*( U(I1-1,I2,  I3  ) + U(I1+1,I2,  I3  )
     *                 +  U(I1,  I2-1,I3  ) + U(I1,  I2+1,I3  )
     *                 +  U(I1,  I2,  I3-1) + U(I1,  I2,  I3+1) )
     *      -A(2)*( U(I1-1,I2-1,I3  ) + U(I1+1,I2-1,I3  )
     *                 +  U(I1-1,I2+1,I3  ) + U(I1+1,I2+1,I3  )
     *                 +  U(I1,  I2-1,I3-1) + U(I1,  I2+1,I3-1)
     *                 +  U(I1,  I2-1,I3+1) + U(I1,  I2+1,I3+1)
     *                 +  U(I1-1,I2,  I3-1) + U(I1-1,I2,  I3+1)
     *                 +  U(I1+1,I2,  I3-1) + U(I1+1,I2,  I3+1) )
     *      -A(3)*( U(I1-1,I2-1,I3-1) + U(I1+1,I2-1,I3-1)
     *                 +  U(I1-1,I2+1,I3-1) + U(I1+1,I2+1,I3-1)
     *                 +  U(I1-1,I2-1,I3+1) + U(I1+1,I2-1,I3+1)
     *                 +  U(I1-1,I2+1,I3+1) + U(I1+1,I2+1,I3+1) )
        enddo
       enddo
      enddo
      return
      end

! PRE shouldn't do predictive commonings job here (and in a bad way)
! ???  It still does but not as bad as it could.  Less prephitmps
! would be better, pcom does it with 6.
! { dg-final { scan-tree-dump-times "# prephitmp" 9 "pre" } }

ext: f


text:
!-----------------------------------
      subroutine rad_initialize                                         &
!...................................
!  ---  inputs:
     &     ( si,levr,ictm,isol,ico2,iaer,ialb,iems,ntcw,                &
     &       num_p3d,npdf3d,ntoz,iovr_sw,iovr_lw,isubc_sw,isubc_lw,     &
     &       crick_proof,ccnorm,norad_precip,                           &
     &       idate,iflip,me )
!  ---  outputs: ( none )

! =================   subprogram documentation block   ================ !
!                                                                       !
! subprogram:   rad_initialize - a subprogram to initialize radiation   !
!                                                                       !
! usage:        call rad_initialize                                     !
!                                                                       !
! attributes:                                                           !
!   language:  fortran 90                                               !
!                                                                       !
! program history:                                                      !
!   mar 2012  - yu-tai hou   create the program to initialize fixed     !
!                 control variables for radiaion processes.  this       !
!                 subroutine is called at the start of model run.       !
!   nov 2012  - yu-tai hou   modified control parameter through         !
!                 module 'physparam'.                                   !
!   mar 2014  - sarah lu  iaermdl is determined from iaer               !
!   jul 2014  - s moorthi add npdf3d for pdf clouds                     !
!                                                                       !
!  ====================  defination of variables  ====================  !
!                                                                       !
! input parameters:                                                     !
!   si               : model vertical sigma interface or equivalence    !
!   levr             : number of model vertical layers                  !
!   ictm             :=yyyy#, external data time/date control flag      !
!                     =   -2: same as 0, but superimpose seasonal cycle !
!                             from climatology data set.                !
!                     =   -1: use user provided external data for the   !
!                             forecast time, no extrapolation.          !
!                     =    0: use data at initial cond time, if not     !
!                             available, use latest, no extrapolation.  !
!                     =    1: use data at the forecast time, if not     !
!                             available, use latest and extrapolation.  !
!                     =yyyy0: use yyyy data for the forecast time,      !
!                             no further data extrapolation.            !
!                     =yyyy1: use yyyy data for the fcst. if needed, do !
!                             extrapolation to match the fcst time.     !
!   isol             := 0: use the old fixed solar constant in "physcon"!
!                     =10: use the new fixed solar constant in "physcon"!
!                     = 1: use noaa ann-mean tsi tbl abs-scale data tabl!
!                     = 2: use noaa ann-mean tsi tbl tim-scale data tabl!
!                     = 3: use cmip5 ann-mean tsi tbl tim-scale data tbl!
!                     = 4: use cmip5 mon-mean tsi tbl tim-scale data tbl!
!   ico2             :=0: use prescribed global mean co2 (old  oper)    !
!                     =1: use observed co2 annual mean value only       !
!                     =2: use obs co2 monthly data with 2-d variation   !
!   iaer             : 4-digit aerosol flag (dabc for aermdl,volc,lw,sw)!
!                     d: =0 or none, opac-climatology aerosol scheme    !
!                        =1 use gocart climatology aerosol scheme       !
!                        =2 use gocart progostic aerosol scheme         !
!                     a: =0 use background stratospheric aerosol        !
!                        =1 incl stratospheric vocanic aeros            !
!                     b: =0 no topospheric aerosol in lw radiation      !
!                        =1 include tropspheric aerosols for lw         !
!                     c: =0 no topospheric aerosol in sw radiation      !
!                        =1 include tropspheric aerosols for sw         !
!   ialb             : control flag for surface albedo schemes          !
!                     =0: climatology, based on surface veg types       !
!                     =1: modis retrieval based surface albedo scheme   !
!   iems             : ab 2-digit control flag                          !
!                     a: =0 set sfc air/ground t same for lw radiation  !
!                        =1 set sfc air/ground t diff for lw radiation  !
!                     b: =0 use fixed sfc emissivity=1.0 (black-body)   !
!                        =1 use varying climtology sfc emiss (veg based)!
!                        =2 future development (not yet)                !
!   ntcw             :=0 no cloud condensate calculated                 !
!                     >0 array index location for cloud condensate      !
!   num_p3d          :=3: ferrier's microphysics cloud scheme           !
!                     =4: zhao/carr/sundqvist microphysics cloud        !
!   npdf3d            =0 no pdf clouds                                  !
!                     =3 (when num_p3d=4) pdf clouds with zhao/carr/    !
!                        sundqvist scheme                               !
!   ntoz             : ozone data control flag                          !
!                     =0: use climatological ozone profile              !
!                     >0: use interactive ozone profile                 !
!   iovr_sw/iovr_lw  : control flag for cloud overlap (sw/lw rad)       !
!                     =0: random overlapping clouds                     !
!                     =1: max/ran overlapping clouds                    !
!   isubc_sw/isubc_lw: sub-column cloud approx control flag (sw/lw rad) !
!                     =0: with out sub-column cloud approximation       !
!                     =1: mcica sub-col approx. prescribed random seed  !
!                     =2: mcica sub-col approx. provided random seed    !
!   crick_proof      : control flag for eliminating CRICK               !
!   ccnorm           : control flag for in-cloud condensate mixing ratio!
!   norad_precip     : control flag for not using precip in radiation   !
!   idate(4)         : ncep absolute date and time of initial condition !
!                      (hour, month, day, year)                         !
!   iflip            : control flag for direction of vertical index     !
!                     =0: index from toa to surface                     !
!                     =1: index from surface to toa                     !
!   me               : print control flag                               !
!                                                                       !
!  subroutines called: radinit                                          !
!                                                                       !
!  ===================================================================  !
!
      use physparam, only : isolar , ictmflg, ico2flg, ioznflg, iaerflg,&
     &             iaermdl, laswflg, lalwflg, lavoflg, icldflg, icmphys,&
     &             iovrsw , iovrlw , lcrick , lcnorm , lnoprec,         &
     &             ialbflg, iemsflg, isubcsw, isubclw, ivflip , ipsd0,  &
     &             kind_phys

      use module_radiation_driver, only : radinit
!
      implicit   none

!  ---  input:
      integer,  intent(in) :: levr, ictm, isol, ico2, iaer,             &
     &       ntcw, ialb, iems, num_p3d, npdf3d, ntoz, iovr_sw, iovr_lw, &
     &       isubc_sw, isubc_lw, iflip, me, idate(4)

      real (kind=kind_phys), intent(in) :: si(levr+1)

      logical, intent(in) :: crick_proof, ccnorm, norad_precip

!  ---  output: ( none )

!  ---  local:
      integer :: icld
!
!===> ...  start here
!
!  ---  set up parameters for radiation initialization

      isolar = isol                     ! solar constant control flag

      ictmflg= ictm                     ! data ic time/date control flag
      ico2flg= ico2                     ! co2 data source control flag
      ioznflg= ntoz                     ! ozone data source control flag

      if ( ictm==0 .or. ictm==-2 ) then
        iaerflg = mod(iaer, 100)        ! no volcanic aerosols for clim hindcast
      else
        iaerflg = mod(iaer, 1000)
      endif
      laswflg= (mod(iaerflg,10) > 0)    ! control flag for sw tropospheric aerosol
      lalwflg= (mod(iaerflg/10,10) > 0) ! control flag for lw tropospheric aerosol
      lavoflg= (iaerflg >= 100)         ! control flag for stratospheric volcanic aeros
      iaermdl = iaer/1000               ! control flag for aerosol scheme selection
      if ( iaermdl < 0 .or.  iaermdl > 2) then
         print *, ' Error -- IAER flag is incorrect, Abort'
         stop 7777
      endif

      if ( ntcw > 0 ) then
        icldflg = 1                     ! prognostic cloud optical prop scheme
      else
        icldflg = 0                     ! diagnostic cloud optical prop scheme
      endif
      icmphys = 1                       ! default
      if ( num_p3d == 4 ) then
        if (npdf3d /= 3) then
          icmphys = 1                   ! zhao/moorthi's prognostic cloud scheme
        else
          icmphys = 3                   ! zhao+ pdf cloud & cnvc and cnvw
        endif
      elseif ( num_p3d == 3 ) then
        icmphys = 2                     ! ferrier's microphysics
      endif
!     if (ncld == 2) icmphys = 1        ! MG 2m Morrison scheme
!
      iovrsw = iovr_sw                  ! cloud overlapping control flag for sw
      iovrlw = iovr_lw                  ! cloud overlapping control flag for lw

      lcrick  = crick_proof             ! control flag for eliminating CRICK
      lcnorm  = ccnorm                  ! control flag for in-cld condensate
      lnoprec = norad_precip            ! precip effect on radiation flag (ferrier microphysics)
      isubcsw = isubc_sw                ! sub-column cloud approx flag in sw radiation
      isubclw = isubc_lw                ! sub-column cloud approx flag in lw radiation

      ialbflg= ialb                     ! surface albedo control flag
      iemsflg= iems                     ! surface emissivity control flag

      ivflip = iflip                    ! vertical index direction control flag

!  ---  assign initial permutation seed for mcica cloud-radiation
      if ( isubc_sw>0 .or. isubc_lw>0 ) then
!       ipsd0 = 17*idate(1)+43*idate(2)+37*idate(3)+23*idate(4) + ipsd0
        ipsd0 = 17*idate(1)+43*idate(2)+37*idate(3)+23*idate(4)
      endif

      if ( me == 0 ) then
        print *,'  In rad_initialize, before calling radinit'
        print *,' si =',si
        print *,' levr=',levr,' ictm=',ictm,' isol=',isol,' ico2=',ico2,&
     &          ' iaer=',iaer,' ialb=',ialb,' iems=',iems,' ntcw=',ntcw
        print *,' np3d=',num_p3d,' ntoz=',ntoz,' iovr_sw=',iovr_sw,     &
     &          ' iovr_lw=',iovr_lw,' isubc_sw=',isubc_sw,              &
     &          ' isubc_lw=',isubc_lw,' iflip=',iflip,'  me=',me
        print *,' crick_proof=',crick_proof,                            &
     &          ' ccnorm=',ccnorm,' norad_precip=',norad_precip
      endif

      call radinit                                                      &
!  ---  inputs:
     &     ( si, levr, me )
!  ---  outputs:
!          ( none )

      if ( me == 0 ) then
        print *,'  Radiation sub-cloud initial seed =',ipsd0,           &
     &          ' IC-idate =',idate
        print *,' return from rad_initialize - after calling radinit'
      endif
!
      return
!...................................
      end subroutine rad_initialize
!-----------------------------------

max_stars_repo_name: cacraigucar/ccpp-physics

max_issues_repo_name: cacraigucar/ccpp-physics

max_forks_repo_name: cacraigucar/ccpp-physics


! This subroutine is used to caculate Hamiltonian for
! ribbon system .

! History
!        4/15/2010 by Quansheng Wu
  subroutine ham_ribbon(k,Hamk_ribbon)

     use para
     implicit none

! loop index
     integer :: i1,j1,i2,j2

! wave vector in 2d
     real(Dp) :: k

! Hamiltonian of slab system
     complex(Dp),intent(out) :: Hamk_ribbon(Num_wann*nslab1*nslab2, &
        Num_wann*nslab1*nslab2)

! the factor 2 is induced by spin
     complex(Dp) :: Hij(-ijmax:ijmax,-ijmax:ijmax,Num_wann,Num_wann)

     call ham_qlayer2qlayerribbon(k,Hij)

     Hamk_ribbon=0.0d0

! i1,j1 row index
     do i1=1,nslab1
     do j1=1,nslab2
! i2,j2 column index
     do i2=1,nslab1
     do j2=1,nslab2
       if (abs(i2-i1).le.ijmax.and.abs(j2-j1).le.ijmax)then
         Hamk_ribbon((i1-1)*nslab2*Num_wann+(j1-1)*Num_wann+1: &
                     (i1-1)*nslab2*Num_wann+(j1-1)*Num_wann+Num_wann,&
                     (i2-1)*nslab2*Num_wann+(j2-1)*Num_wann+1: &
                     (i2-1)*nslab2*Num_wann+(j2-1)*Num_wann+Num_wann )&
         = Hij(i2-i1,j2-j1,1:Num_wann,1:Num_wann)

       endif
     enddo
     enddo
     enddo
     enddo

  return
  end


text: Following a high speed chase three years ago, a Yolo County Sheriff was killed.  Earlier Topetes vehicle was reported to the police after he was seen leaving a Davis party alcohol intoxicated.

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


text:
Blackmon & Associates was a criminal defense firm located in downtown Sacramento.  The closed in March 2012.  They were located in Sacramentos old Hall of Justice, across the street from the new federal courthouse.  The firms principal, Clyde Blackmon has been practicing for more than 40 years, having graduated from Boalt Hall (UC Berkeley School of Law) in 1964.  He has a fairly impressive http://www.blackmonassociates.com/attorneyprofiles/clydemblackmon/ record of published appellate and state Supreme Court successes.

Blackmon & Associates has received a top tier rating for both white collar and nonwhite collar criminal defense from USNews.  This listing will appear in the upcoming Money edition of the magazine which should hit news stands in November 2011.

The firm takes on criminal cases and appeals of all sorts in Yolo County, Sacramento County, and beyond.  They practice in both state and federal courts.  They also take on professional licensing administrative law cases that can arise from criminal matters (usually handled by Jonathan Turner).

To get there, take Business 80/50 east, exit I5 north, and exit J street.  Its about 3 blocks down on your right.  Street parking is sparse, so youre better off using the public parking beneath the building.  If you enter at 7th Street, just south of J (right next to the 24 Hour Fitness; you cant miss the driveway), the elevator for 660 J is feet away on your right.  Its also within 13 blocks of the downtown/old town Amtrak station, downtown light rail, and numerous bus lines.

  wiki:calbar:36280    Clyde M. Blackmon CalBar Profile  Admitted to the bar on 1965112
  wiki:calbar:191540    Jonathan C. Turner CalBar Profile, of counsel  Admitted to the bar on 1997129
  wiki:calbar:269158 Thomas M. Garberson CalBar Profile  Admitted to the bar on 2010310

Up the creek without a paddle?  Check out the Legal Services page.


      MODULE CFUNI
!=======================================================================
!     LATEST CORRECTION BY
!
!     PURPOSE
!            Module defining unit numbers used on the internal files
!
!     PROGRAMMED BY:  bjorn.melhus@akersolutions.com
!     CREATED......:  10.05.2021
!=======================================================================
      INTEGER IBIF,IBIB,IBIK,IBIU,ibi2,IBIM,IBIR,IBIO
      PARAMETER (IBI2=101)                 ! Ascii file holding original slave file ---> .dat
      PARAMETER (IBIM=102)                 ! Binary file holding moordyn channels and units ---> cana//'_KEYS.BIN'
      PARAMETER (IBIF=103)                 ! Ascii file holding openfast/moordyn result file ---> .out
      PARAMETER (IBIB=104)                 ! Binary file holding openfast results --> cana//'_FAST.BIN'
      PARAMETER (IBIK=105)                 ! Binary file holding openfast channels and units ---> cana//'_KEYS.BIN'
      PARAMETER (IBIU=106)                 ! Binary file holding user defined input ---> cana//'_USER.BIN'
      PARAMETER (IBIR=107)                 ! Binary file holding moordyn results ---> cana//'_MOOR.BIN'
      PARAMETER (IBIO=108)                 ! Ascii file for output results
      END MODULE
!


text:
This editor can edit this entry and tell us a bit about themselves by clicking the Edit icon.

20100521 17:54:57 nbsp Welcome to the Wiki, Mr. Gutierrez! A fellow wiki editor has http://daviswiki.org/Verizon?actiondiff&version225&version124 restored the comments you deleted from the Verizon page. Generally, comments (both positive and negative) are kept for historical purposes. I also noticed that you may have been involved in http://wikispot.org/Templates/Wiki_Directory_entry?actiondiff&version288&version187 creating the page. If you are the business owner, please see Welcome to the Wiki/Business Owner.

That said, the revert was not intended for the bit about the discount. Ive taken the liberty of adding it back. In the future, feel free to integrate whatever information you may have directly into the article  youre part of the community too! (Just leave comments be.) Happy editing! Users/EBT

20100521 18:07:39 nbsp Thank you...still about the discount it seems a bit rude. Every one can recieve a 25% discount on accessories or more, its on the back of our business cards, so there is no supposedly about it. If I can I will edit that to read the way we want it to, and will not touch the comments. Thank You, Ricardo Users/RicardoGutierrez

20100521 18:09:16 nbsp Feel free to do so! I included the supposedly bit because I was not yet sure of your identity at the time, therefore could not confirm the information. PS, regarding the townies are not as cool bit: Some editors tend to insert their own dash of dry humor when writing. Most readers are well aware that any biases on the page dont necessarily come from the business owners themselves, and know to take it with a grain of salt. In any case, statements like those are fair game for removal if you feel that they are inappropriate. Users/EBT


text:
needs date/sedra
with~ ~date

: skip-to-shabbat ( fixed -- fixed' )
    dup fixed>dow 6 swap - + ;

variable hebrew-year
variable greg-year

: .2 ( nr -- s d ) 2 '0 (p.r) type space ;
: date-format ( mm dd yyyy -- )
	3dup gregorian>fixed fixed>hebrew
		-rot
		.2 hebrew-month-name type
		dup hebrew-year @ <>if
			dup space hebrew-year ! .
		else drop then
    -rot
	." ,("   .
	1-	monthname type
	dup greg-year @ <>if
		."  "
		dup greg-year ! (.) type
	else  drop then
	." )"
;

: chag? ( date -- date )
	dup fixed>hebrew drop
	15 23 between if
		dup 1 =if ."  PESACH" then
		7 =if ."  SUCCOT" then
	then
	drop
	;

: mevarchim? ( date -- flag )
	dup rosh-chodesh? if ;; then
	dup
	7 + fixed>hebrew drop nip
	| in range: 2-7
	dup
	1 7 between  swap | if ." *" then
	30 = or if ." *" then
;

: comma ', emit ;
: rh? dup rosh-chodesh? if ." [RH]" then ;
: print-one-shabbat ( date -- date )
    >r
    r@ fixed>gregorian date-format comma
    r> dup sedra type space
	rh? mevarchim? chag? cr
;

: calc ( -- )
    today>fixed skip-to-shabbat
	dup fixed>hebrew 1+ hebrew>fixed 1- swap
    do i print-one-shabbat 6 skip loop ;

: main ." Shabbat calculator v3 " cr true in-israel calc cr bye ;
with~ ~sys
' main is appstart

." This application will print one year of shabbatot and parasha readings" cr
." Rosh-Hodesh is denoted by [RH].  Shabbat mevarchim by *.  Holidays as appropriate" cr
cr
" mevarchim" makeexename (save) bye

max_stars_repo_name: ronaaron/reva

max_issues_repo_name: ronaaron/reva

max_forks_repo_name: ronaaron/reva


! RUN: %S/test_errors.sh %s %t %flang_fc1 -fopenmp
! REQUIRES: shell
! OpenMP Version 4.5
! Various checks with the nesting of SIMD construct

SUBROUTINE NESTED_GOOD(N)
  INTEGER N, I, J, K, A(10), B(10)
  !$OMP SIMD
  DO I = 1,N
    !$OMP ATOMIC
    K =  K + 1
    IF (I <= 10) THEN
      !$OMP ORDERED SIMD
      DO J = 1,N
        A(J) = J
      END DO
      !$OMP END ORDERED
    ENDIF
  END DO
  !$OMP END SIMD

  !$OMP SIMD
  DO I = 1,N
    IF (I <= 10) THEN
      !$OMP SIMD
      DO J = 1,N
        A(J) = J
      END DO
      !$OMP END SIMD
    ENDIF
  END DO
  !$OMP END SIMD
END SUBROUTINE NESTED_GOOD

SUBROUTINE NESTED_BAD(N)
  INTEGER N, I, J, K, A(10), B(10)

  !$OMP SIMD
  DO I = 1,N
    IF (I <= 10) THEN
      !$OMP ORDERED SIMD
      DO J = 1,N
        print *, "Hi"
        !ERROR: The only OpenMP constructs that can be encountered during execution of a 'SIMD' region are the `ATOMIC` construct, the `LOOP` construct, the `SIMD` construct and the `ORDERED` construct with the `SIMD` clause.
        !ERROR: TEAMS region can only be strictly nested within the implicit parallel region or TARGET region
        !$omp teams
         DO K = 1,N
        print *, 'Hello'
        END DO
        !$omp end teams
      END DO
      !$OMP END ORDERED
    ENDIF
  END DO
  !$OMP END SIMD

  !$OMP SIMD
  DO I = 1,N
    !$OMP ATOMIC
    K =  K + 1
    IF (I <= 10) THEN
      !ERROR: The only OpenMP constructs that can be encountered during execution of a 'SIMD' region are the `ATOMIC` construct, the `LOOP` construct, the `SIMD` construct and the `ORDERED` construct with the `SIMD` clause.
      !$omp task
      do J = 1, N
        K = 2
      end do
      !$omp end task
      !ERROR: The only OpenMP constructs that can be encountered during execution of a 'SIMD' region are the `ATOMIC` construct, the `LOOP` construct, the `SIMD` construct and the `ORDERED` construct with the `SIMD` clause.
      !$omp target
      do J = 1, N
        K = 2
      end do
      !$omp end target
      !ERROR: The only OpenMP constructs that can be encountered during execution of a 'SIMD' region are the `ATOMIC` construct, the `LOOP` construct, the `SIMD` construct and the `ORDERED` construct with the `SIMD` clause.
      !$OMP DO
      DO J = 1,N
        A(J) = J
      END DO
      !$OMP END DO
      !ERROR: The only OpenMP constructs that can be encountered during execution of a 'SIMD' region are the `ATOMIC` construct, the `LOOP` construct, the `SIMD` construct and the `ORDERED` construct with the `SIMD` clause.
      !$OMP PARALLEL DO
      DO J = 1,N
        A(J) = J
      END DO
      !$OMP END PARALLEL DO
    ENDIF
  END DO
  !$OMP END SIMD

  !$OMP DO SIMD
  DO I = 1,N
    !$OMP ATOMIC
    K =  K + 1
    IF (I <= 10) THEN
      !ERROR: The only OpenMP constructs that can be encountered during execution of a 'SIMD' region are the `ATOMIC` construct, the `LOOP` construct, the `SIMD` construct and the `ORDERED` construct with the `SIMD` clause.
      !$omp task
      do J = 1, N
        K = 2
      end do
      !$omp end task
      !ERROR: The only OpenMP constructs that can be encountered during execution of a 'SIMD' region are the `ATOMIC` construct, the `LOOP` construct, the `SIMD` construct and the `ORDERED` construct with the `SIMD` clause.
      !$omp target
      do J = 1, N
        K = 2
      end do
      !$omp end target
      !ERROR: The only OpenMP constructs that can be encountered during execution of a 'SIMD' region are the `ATOMIC` construct, the `LOOP` construct, the `SIMD` construct and the `ORDERED` construct with the `SIMD` clause.
      !ERROR: A worksharing region may not be closely nested inside a worksharing, explicit task, taskloop, critical, ordered, atomic, or master region
      !$OMP DO
      DO J = 1,N
        A(J) = J
      END DO
      !$OMP END DO
      !ERROR: The only OpenMP constructs that can be encountered during execution of a 'SIMD' region are the `ATOMIC` construct, the `LOOP` construct, the `SIMD` construct and the `ORDERED` construct with the `SIMD` clause.
      !$OMP PARALLEL DO
      DO J = 1,N
        A(J) = J
      END DO
      !$OMP END PARALLEL DO
    ENDIF
  END DO
  !$OMP END DO SIMD

  !$OMP PARALLEL DO SIMD
  DO I = 1,N
    !$OMP ATOMIC
    K =  K + 1
    IF (I <= 10) THEN
      !ERROR: The only OpenMP constructs that can be encountered during execution of a 'SIMD' region are the `ATOMIC` construct, the `LOOP` construct, the `SIMD` construct and the `ORDERED` construct with the `SIMD` clause.
      !$omp task
      do J = 1, N
        K = 2
      end do
      !$omp end task
      !ERROR: The only OpenMP constructs that can be encountered during execution of a 'SIMD' region are the `ATOMIC` construct, the `LOOP` construct, the `SIMD` construct and the `ORDERED` construct with the `SIMD` clause.
      !$omp target
      do J = 1, N
        K = 2
      end do
      !$omp end target
      !ERROR: The only OpenMP constructs that can be encountered during execution of a 'SIMD' region are the `ATOMIC` construct, the `LOOP` construct, the `SIMD` construct and the `ORDERED` construct with the `SIMD` clause.
      !ERROR: A worksharing region may not be closely nested inside a worksharing, explicit task, taskloop, critical, ordered, atomic, or master region
      !$OMP DO
      DO J = 1,N
        A(J) = J
      END DO
      !$OMP END DO
      !ERROR: The only OpenMP constructs that can be encountered during execution of a 'SIMD' region are the `ATOMIC` construct, the `LOOP` construct, the `SIMD` construct and the `ORDERED` construct with the `SIMD` clause.
      !$OMP PARALLEL DO
      DO J = 1,N
        A(J) = J
      END DO
      !$OMP END PARALLEL DO
    ENDIF
  END DO
  !$OMP END PARALLEL DO SIMD

  !$OMP TARGET SIMD
  DO I = 1,N
    !$OMP ATOMIC
    K =  K + 1
    IF (I <= 10) THEN
      !ERROR: The only OpenMP constructs that can be encountered during execution of a 'SIMD' region are the `ATOMIC` construct, the `LOOP` construct, the `SIMD` construct and the `ORDERED` construct with the `SIMD` clause.
      !$omp task
      do J = 1, N
        K = 2
      end do
      !$omp end task
      !ERROR: The only OpenMP constructs that can be encountered during execution of a 'SIMD' region are the `ATOMIC` construct, the `LOOP` construct, the `SIMD` construct and the `ORDERED` construct with the `SIMD` clause.
      !$omp target
      do J = 1, N
        K = 2
      end do
      !$omp end target
      !ERROR: The only OpenMP constructs that can be encountered during execution of a 'SIMD' region are the `ATOMIC` construct, the `LOOP` construct, the `SIMD` construct and the `ORDERED` construct with the `SIMD` clause.
      !$OMP DO
      DO J = 1,N
        A(J) = J
      END DO
      !$OMP END DO
      !ERROR: The only OpenMP constructs that can be encountered during execution of a 'SIMD' region are the `ATOMIC` construct, the `LOOP` construct, the `SIMD` construct and the `ORDERED` construct with the `SIMD` clause.
      !$OMP PARALLEL DO
      DO J = 1,N
        A(J) = J
      END DO
      !$OMP END PARALLEL DO
    ENDIF
  END DO
  !$OMP END TARGET SIMD

END SUBROUTINE NESTED_BAD


text:
! SUMMA - Structure for Unifying Multiple Modeling Alternatives
! Copyright (C) 2014-2015 NCAR/RAL
!
! This file is part of SUMMA
!
! For more information see: http://www.ral.ucar.edu/projects/summa
!
! This program is free software: you can redistribute it and/or modify
! it under the terms of the GNU General Public License as published by
! the Free Software Foundation, either version 3 of the License, or
! (at your option) any later version.
!
! This program is distributed in the hope that it will be useful,
! but WITHOUT ANY WARRANTY; without even the implied warranty of
! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
! GNU General Public License for more details.
!
! You should have received a copy of the GNU General Public License
! along with this program.  If not, see <http://www.gnu.org/licenses/>.

module indexState_module

! data types
USE nrtype

! missing data
USE globalData,only:integerMissing  ! missing integer

! named variables for domain types
USE globalData,only:iname_cas       ! canopy air space
USE globalData,only:iname_veg       ! vegetation
USE globalData,only:iname_snow      ! snow
USE globalData,only:iname_soil      ! soil

! named variables to describe the state variable type
USE globalData,only:iname_nrgCanair ! named variable defining the energy of the canopy air space
USE globalData,only:iname_nrgCanopy ! named variable defining the energy of the vegetation canopy
USE globalData,only:iname_watCanopy ! named variable defining the mass of total water on the vegetation canopy
USE globalData,only:iname_liqCanopy ! named variable defining the mass of liquid water on the vegetation canopy
USE globalData,only:iname_nrgLayer  ! named variable defining the energy state variable for snow+soil layers
USE globalData,only:iname_watLayer  ! named variable defining the total water state variable for snow+soil layers
USE globalData,only:iname_liqLayer  ! named variable defining the liquid  water state variable for snow+soil layers
USE globalData,only:iname_matLayer  ! named variable defining the matric head state variable for soil layers
USE globalData,only:iname_lmpLayer  ! named variable defining the liquid matric potential state variable for soil layers

! provide access to the derived types to define the data structures
USE data_types,only:var_ilength     ! data vector with variable length dimension (i4b)

! provide access to the metadata
USE globalData,only:indx_meta       ! metadata for the variables in the index structure

! provide access to indices that define elements of the data structures
USE var_lookup,only:iLookINDEX      ! named variables for structure elements

! provide access to the missing f2008 functions
USE f2008funcs_module,only:findIndex              ! finds the index of the first value within a vector

! provide access to the numerical recipes utility modules
USE nr_utility_module,only:arth                           ! creates a sequence of numbers (start, incr, n)

implicit none
private
public::indexState
public::indexSplit
contains

 ! **********************************************************************************************************
 ! public subroutine indexState: define list of indices for each state variable
 ! **********************************************************************************************************
 subroutine indexState(computeVegFlux,          & ! intent(in):    flag to denote if computing the vegetation flux
                       nSnow,nSoil,nLayers,     & ! intent(in):    number of snow and soil layers, and total number of layers
                       indx_data,               & ! intent(inout): indices defining model states and layers
                       err,message)               ! intent(out):   error control
 ! --------------------------------------------------------------------------------------------------------------------------------
 ! --------------------------------------------------------------------------------------------------------------------------------
 ! input
 logical(lgt),intent(in)         :: computeVegFlux         ! flag to denote if computing the vegetation flux
 integer(i4b),intent(in)         :: nSnow,nSoil,nLayers    ! number of snow and soil layers, and total number of layers
 type(var_ilength),intent(inout) :: indx_data              ! indices defining model states and layers
 ! output: error control
 integer(i4b),intent(out)        :: err                    ! error code
 character(*),intent(out)        :: message                ! error message
 ! --------------------------------------------------------------------------------------------------------------------------------
 ! general local variables
 character(len=256)              :: cmessage               ! message of downwind routine
 integer(i4b),parameter          :: nVarSnowSoil=2         ! number of state variables in the snow and soil domain (energy and total water/matric head)
 ! indices of model state variables
 integer(i4b)                    :: ixTopNrg               ! index of upper-most energy state in the snow-soil subdomain
 integer(i4b)                    :: ixTopWat               ! index of upper-most total water state in the snow-soil subdomain
 ! --------------------------------------------------------------------------------------------------------------------------------
 ! make association with variables in the data structures
 associate(&
 ! number of state variables of different type
 nCasNrg       => indx_data%var(iLookINDEX%nVegNrg)%dat(1)   , & ! number of energy state variables for the canopy air space
 nVegNrg       => indx_data%var(iLookINDEX%nVegNrg)%dat(1)   , & ! number of energy state variables for the vegetation canopy
 nVegMass      => indx_data%var(iLookINDEX%nVegMass)%dat(1)  , & ! number of hydrology states for vegetation (mass of water)
 nVegState     => indx_data%var(iLookINDEX%nVegState)%dat(1) , & ! number of vegetation state variables
 nNrgState     => indx_data%var(iLookINDEX%nNrgState)%dat(1) , & ! number of energy state variables
 nWatState     => indx_data%var(iLookINDEX%nWatState)%dat(1) , & ! number of "total water" states (vol. total water content)
 nMatState     => indx_data%var(iLookINDEX%nMatState)%dat(1) , & ! number of matric head state variables
 nMassState    => indx_data%var(iLookINDEX%nMassState)%dat(1), & ! number of hydrology state variables (mass of water)
 nState        => indx_data%var(iLookINDEX%nState)%dat(1)    , & ! total number of model state variables
 ! vectors of indices for specfic state types within specific sub-domains IN THE FULL STATE VECTOR
 ixNrgCanair   => indx_data%var(iLookINDEX%ixNrgCanair)%dat  , & ! indices IN THE FULL VECTOR for energy states in canopy air space domain
 ixNrgCanopy   => indx_data%var(iLookINDEX%ixNrgCanopy)%dat  , & ! indices IN THE FULL VECTOR for energy states in the canopy domain
 ixHydCanopy   => indx_data%var(iLookINDEX%ixHydCanopy)%dat  , & ! indices IN THE FULL VECTOR for hydrology states in the canopy domain
 ixNrgLayer    => indx_data%var(iLookINDEX%ixNrgLayer)%dat   , & ! indices IN THE FULL VECTOR for energy states in the snow+soil domain
 ixHydLayer    => indx_data%var(iLookINDEX%ixHydLayer)%dat   , & ! indices IN THE FULL VECTOR for hydrology states in the snow+soil domain
 ! indices for model state variables
 ixSoilState   => indx_data%var(iLookINDEX%ixSoilState)%dat  , & ! list of indices for all soil layers
 ixLayerState  => indx_data%var(iLookINDEX%ixLayerState)%dat   & ! list of indices for all model layers
 ) ! association to variables in the data structures
 ! --------------------------------------------------------------------------------------------------------------------------------
 ! initialize error control
 err=0; message='indexState/'

 ! -----
 ! * define the number of state variables...
 ! -----------------------------------------

 ! define the number of vegetation state variables (defines position of snow-soil states in the state vector)
 if(computeVegFlux)then
  nCasNrg   = 1
  nVegNrg   = 1
  nVegMass  = 1
  nVegState = nCasNrg + nVegNrg + nVegMass
 else
  nCasNrg   = 0
  nVegNrg   = 0
  nVegMass  = 0
  nVegState = 0
 end if

 ! define the number state variables of different type
 nNrgState  = nCasNrg + nVegNrg + nLayers  ! number of energy state variables
 nWatState  = nSnow                        ! number of "total water" state variables -- will be modified later if using primary variable switching
 nMatState  = nSoil                        ! number of matric head state variables -- will be modified later if using primary variable switching
 nMassState = nVegMass                     ! number of mass state variables -- currently restricted to canopy water

 ! define the number of model state variables
 nState = nVegState + nLayers*nVarSnowSoil   ! *nVarSnowSoil (both energy and total water)

 ! -----
 ! * define the indices of state variables WITHIN THE FULL STATE VECTOR...
 ! -----------------------------------------------------------------------

 ! define indices in the vegetation domain
 if(computeVegFlux)then
  ixNrgCanair = 1 ! indices IN THE FULL VECTOR for energy states in canopy air space domain  (-)
  ixNrgCanopy = 2 ! indices IN THE FULL VECTOR for energy states in the canopy domain        (-)
  ixHydCanopy = 3 ! indices IN THE FULL VECTOR for hydrology states in the canopy domain     (-)
 else
  ixNrgCanair = integerMissing
  ixNrgCanopy = integerMissing
  ixHydCanopy = integerMissing
 end if

 ! define the index of the top layer
 ! NOTE: local variables -- actual indices defined when building the state subset
 ixTopNrg = nVegState + 1                       ! energy
 ixTopWat = nVegState + 2                       ! total water (only snow)

 ! define the indices within the snow+soil domain
 ixNrgLayer = arth(ixTopNrg,nVarSnowSoil,nLayers)  ! energy
 ixHydLayer = arth(ixTopWat,nVarSnowSoil,nLayers)  ! total water

 ! -----
 ! * define the type of model states...
 ! ------------------------------------

 ! re-allocate index vectors for the full state vector (if needed)...
 call resizeIndx( (/iLookINDEX%ixMapFull2Subset, iLookINDEX%ixControlVolume, iLookINDEX%ixDomainType, iLookINDEX%ixStateType, iLookINDEX%ixAllState/), & ! desired variables
                  indx_data,  & ! data structure
                  nState,     & ! vector length
                  err,cmessage) ! error control
 if(err/=0)then; message=trim(message)//trim(cmessage); return; endif

 ! make an association to the ALLOCATABLE variables in the data structures
 ! NOTE: we need to do this here since the size may have changed above
 associate(&
 ixControlVolume => indx_data%var(iLookINDEX%ixControlVolume)%dat , & ! index of control volume for different domains (veg, snow, soil)
 ixDomainType    => indx_data%var(iLookINDEX%ixDomainType)%dat    , & ! indices defining the type of the domain (iname_veg, iname_snow, iname_soil)
 ixStateType     => indx_data%var(iLookINDEX%ixStateType)%dat     , & ! indices defining the type of the state (iname_nrgLayer...)
 ixAllState      => indx_data%var(iLookINDEX%ixAllState)%dat        & ! list of indices for all model state variables
 )  ! making an association to variables in the data structures

 ! define indices for state variables
 ixAllState   = arth(1,1,nState)
 ixSoilState  = arth(1,1,nSoil)
 ixLayerState = arth(1,1,nLayers)

 ! define the state type for the vegetation canopy
 if(computeVegFlux)then
  ixStateType(ixNrgCanair) = iname_nrgCanair
  ixStateType(ixNrgCanopy) = iname_nrgCanopy
  ixStateType(ixHydCanopy) = iname_watCanopy
 endif

 ! define the state type for the snow+soil domain (energy)
 ixStateType(ixNrgLayer) = iname_nrgLayer

 ! define the state type for the snow+soil domain (hydrology)
 if(nSnow>0) ixStateType( ixHydLayer(      1:nSnow)   ) = iname_watLayer
             ixStateType( ixHydLayer(nSnow+1:nLayers) ) = iname_matLayer ! refine later to be either iname_watLayer or iname_matLayer

 ! define the domain type for vegetation
 if(computeVegFlux)then
  ixDomainType(ixNrgCanair) = iname_cas
  ixDomainType(ixNrgCanopy) = iname_veg
  ixDomainType(ixHydCanopy) = iname_veg
 endif

 ! define the domain type for snow
 if(nSnow>0)then
  ixDomainType( ixNrgLayer(1:nSnow) ) = iname_snow
  ixDomainType( ixHydLayer(1:nSnow) ) = iname_snow
 endif

 ! define the domain type for soil
 ixDomainType( ixNrgLayer(nSnow+1:nLayers) ) = iname_soil
 ixDomainType( ixHydLayer(nSnow+1:nLayers) ) = iname_soil

 ! define the index of each control volume in the vegetation domains
 if(computeVegFlux)then
  ixControlVolume(ixNrgCanair) = 1  ! NOTE: assumes scalar
  ixControlVolume(ixNrgCanopy) = 1
  ixControlVolume(ixHydCanopy) = 1
 endif

 ! define the index of the each control volume in the snow domain
 if(nSnow>0)then
  ixControlVolume( ixNrgLayer(1:nSnow) ) = ixLayerState(1:nSnow)
  ixControlVolume( ixHydLayer(1:nSnow) ) = ixLayerState(1:nSnow)
 endif

 ! define the index of the each control volume in the soil domain
 ixControlVolume( ixNrgLayer(nSnow+1:nLayers) ) = ixSoilState(1:nSoil)
 ixControlVolume( ixHydLayer(nSnow+1:nLayers) ) = ixSoilState(1:nSoil)

 !print*, 'ixControlVolume = ', ixControlVolume
 !print*, 'ixDomainType    = ', ixDomainType
 !print*, 'ixStateType     = ', ixStateType

 ! end association to the ALLOCATABLE variables in the data structures
 end associate

 ! --------------------------------------------------------------------------------------------------------------------------------
 ! --------------------------------------------------------------------------------------------------------------------------------

 end associate  ! end association to variables in the data structures
 end subroutine indexState

 ! **********************************************************************************************************
 ! public subroutine indexSplit: define list of indices for each state variable
 ! **********************************************************************************************************
 subroutine indexSplit(stateSubsetMask,             & ! intent(in)    : logical vector (.true. if state is in the subset)
                       nSnow,nSoil,nLayers,nSubset, & ! intent(in)    : number of snow and soil layers, and total number of layers
                       indx_data,                   & ! intent(inout) : index data structure
                       err,message)                   ! intent(out)   : error control
 ! --------------------------------------------------------------------------------------------------------------------------------
 ! input
 logical(lgt),intent(in)         :: stateSubsetMask(:)          ! logical vector (.true. if state is in the subset)
 integer(i4b),intent(in)         :: nSnow,nSoil,nLayers,nSubset ! number of snow and soil layers, total number of layers, and number of states in the subset
 type(var_ilength),intent(inout) :: indx_data                   ! indices defining model states and layers
 ! output
 integer(i4b),intent(out)        :: err                         ! error code
 character(*),intent(out)        :: message                     ! error message
 ! --------------------------------------------------------------------------------------------------------------------------------
 ! local variables
 integer(i4b)                    :: iVar                        ! variable index
 integer(i4b)                    :: ixVegWat                    ! index of total water in the vegetation canopy
 integer(i4b)                    :: ixVegLiq                    ! index of liquid water in the vegetation canopy
 integer(i4b)                    :: ixTopWat                    ! index of upper-most total water state in the snow-soil subdomain
 integer(i4b)                    :: ixTopLiq                    ! index of upper-most liquid water state in the snow-soil subdomain
 integer(i4b)                    :: ixTopMat                    ! index of upper-most total water matric potential state in the soil subdomain
 integer(i4b)                    :: ixTopLMP                    ! index of upper-most liquid water matric potential state in the soil subdomain
 integer(i4b),dimension(nSubset) :: ixSequence                  ! sequential index in model state vector
 logical(lgt),dimension(nSubset) :: stateTypeMask               ! mask of state vector for specific state subsets
 logical(lgt),dimension(nLayers) :: volFracWat_mask             ! mask of layers within the snow+soil domain
 logical(lgt),dimension(nSoil)   :: matricHead_mask             ! mask of layers within the soil domain
 character(len=256)              :: cmessage                    ! error message of downwind routine
 ! ------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
 ! ------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
 ! make association to variables in the data structures
 fullState: associate(&

 ! indices of model state variables for the vegetation domain
 ixCasNrg         => indx_data%var(iLookINDEX%ixCasNrg)%dat(1)      ,& ! intent(in):    [i4b]    index of canopy air space energy state variable
 ixVegNrg         => indx_data%var(iLookINDEX%ixVegNrg)%dat(1)      ,& ! intent(in):    [i4b]    index of canopy energy state variable
 ixVegHyd         => indx_data%var(iLookINDEX%ixVegHyd)%dat(1)      ,& ! intent(in):    [i4b]    index of canopy hydrology state variable (mass)

 ! indices of the top model state variables in the snow+soil system
 ixTopNrg         => indx_data%var(iLookINDEX%ixTopNrg)%dat(1)      ,& ! intent(in):    [i4b]    index of upper-most energy state in the snow-soil subdomain
 ixTopHyd         => indx_data%var(iLookINDEX%ixTopHyd)%dat(1)      ,& ! intent(in):    [i4b]    index of upper-most hydrology state in the snow-soil subdomain

 ! indices of model state variables
 ixMapFull2Subset => indx_data%var(iLookINDEX%ixMapFull2Subset)%dat ,& ! intent(in):    [i4b(:)] list of indices in the state subset (missing for values not in the subset)
 ixDomainType     => indx_data%var(iLookINDEX%ixDomainType)%dat     ,& ! intent(in):    [i4b(:)] indices defining the domain of the state (iname_veg, iname_snow, iname_soil)
 ixStateType      => indx_data%var(iLookINDEX%ixStateType)%dat      ,& ! intent(in):    [i4b(:)] indices defining the type of the state (ixNrgState...)
 ixAllState       => indx_data%var(iLookINDEX%ixAllState)%dat       ,& ! intent(in):    [i4b(:)] list of indices for all model state variables (1,2,3,...nState)
 ixNrgLayer       => indx_data%var(iLookINDEX%ixNrgLayer)%dat       ,& ! intent(in):    [i4b(:)] indices IN THE FULL VECTOR for energy states in the snow+soil domain
 ixHydLayer       => indx_data%var(iLookINDEX%ixHydLayer)%dat       ,& ! intent(in):    [i4b(:)] indices IN THE FULL VECTOR for hydrology states in the snow+soil domain
 ixHydType        => indx_data%var(iLookINDEX%ixHydType)%dat        ,& ! intent(in):    [i4b(:)] index of the type of hydrology states in snow+soil domain

 ! indices of the entire state vector, all model layers, and soil layers
 ixSoilState      => indx_data%var(iLookINDEX%ixSoilState)%dat      ,& ! intent(in):    [i4b(:)] list of indices for all soil layers
 ixLayerState     => indx_data%var(iLookINDEX%ixLayerState)%dat     ,& ! intent(in):    [i4b(:)] list of indices for all model layers

 ! vector of energy indices for the snow and soil domains
 ! NOTE: states not in the subset are equal to integerMissing
 ixSnowSoilNrg    => indx_data%var(iLookINDEX%ixSnowSoilNrg)%dat    ,& ! intent(in):    [i4b(:)] index in the state subset for energy state variables in the snow+soil domain
 ixSnowOnlyNrg    => indx_data%var(iLookINDEX%ixSnowOnlyNrg)%dat    ,& ! intent(in):    [i4b(:)] index in the state subset for energy state variables in the snow domain
 ixSoilOnlyNrg    => indx_data%var(iLookINDEX%ixSoilOnlyNrg)%dat    ,& ! intent(in):    [i4b(:)] index in the state subset for energy state variables in the soil domain

 ! vector of hydrology indices for the snow and soil domains
 ! NOTE: states not in the subset are equal to integerMissing
 ixSnowSoilHyd    => indx_data%var(iLookINDEX%ixSnowSoilHyd)%dat    ,& ! intent(in):    [i4b(:)] index in the state subset for hydrology state variables in the snow+soil domain
 ixSnowOnlyHyd    => indx_data%var(iLookINDEX%ixSnowOnlyHyd)%dat    ,& ! intent(in):    [i4b(:)] index in the state subset for hydrology state variables in the snow domain
 ixSoilOnlyHyd    => indx_data%var(iLookINDEX%ixSoilOnlyHyd)%dat    ,& ! intent(in):    [i4b(:)] index in the state subset for hydrology state variables in the soil domain

 ! number of state variables of a specific type
 nSnowSoilNrg     => indx_data%var(iLookINDEX%nSnowSoilNrg )%dat(1) ,& ! intent(in):    [i4b]    number of energy state variables in the snow+soil domain
 nSnowOnlyNrg     => indx_data%var(iLookINDEX%nSnowOnlyNrg )%dat(1) ,& ! intent(in):    [i4b]    number of energy state variables in the snow domain
 nSoilOnlyNrg     => indx_data%var(iLookINDEX%nSoilOnlyNrg )%dat(1) ,& ! intent(in):    [i4b]    number of energy state variables in the soil domain
 nSnowSoilHyd     => indx_data%var(iLookINDEX%nSnowSoilHyd )%dat(1) ,& ! intent(in):    [i4b]    number of hydrology variables in the snow+soil domain
 nSnowOnlyHyd     => indx_data%var(iLookINDEX%nSnowOnlyHyd )%dat(1) ,& ! intent(in):    [i4b]    number of hydrology variables in the snow domain
 nSoilOnlyHyd     => indx_data%var(iLookINDEX%nSoilOnlyHyd )%dat(1)  & ! intent(in):    [i4b]    number of hydrology variables in the soil domain

 ) ! association to variables in the data structures

 ! ------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
 ! initialize error control
 err=0; message='indexSplit/'

 ! -----
 ! - preliminaries...
 ! ------------------

 ! define the type of variable in the snow+soil domain
 ixHydType(1:nLayers) = ixStateType( ixHydLayer(1:nLayers) )

 ! get the mapping between the full state vector and the state subset
 ixMapFull2Subset( pack(ixAllState,      stateSubsetMask) ) = arth(1,1,nSubset)  ! indices in the state subset
 ixMapFull2Subset( pack(ixAllState, .not.stateSubsetMask) ) = integerMissing

 ! -----
 ! - get vectors of different state subsets...
 ! -------------------------------------------

 ! get different masks
 volFracWat_mask = (ixHydType==iname_watLayer .or. ixHydType==iname_liqLayer)
 matricHead_mask = (ixHydType(nSnow+1:nLayers)==iname_matLayer .or. ixHydType(nSnow+1:nLayers)==iname_lmpLayer)

 ! get state subsets for desired variables
 do iVar=1,size(indx_data%var)   ! loop through index variables

  ! get the subset of indices
  ! NOTE: indxSubset(subset, fullVector, mask), provides subset of fullVector where mask==.true.
  select case(iVar)
   case(iLookINDEX%ixMapSubset2Full);     call indxSubset(indx_data%var(iVar)%dat, ixAllState,   stateSubsetMask, err, cmessage)
   case(iLookINDEX%ixStateType_subset);   call indxSubset(indx_data%var(iVar)%dat, ixStateType,  stateSubsetMask, err, cmessage)
   case(iLookINDEX%ixDomainType_subset);  call indxSubset(indx_data%var(iVar)%dat, ixDomainType, stateSubsetMask, err, cmessage)
   case(iLookINDEX%ixVolFracWat);         call indxSubset(indx_data%var(iVar)%dat, ixLayerState, volFracWat_mask, err, cmessage)
   case(iLookINDEX%ixMatricHead);         call indxSubset(indx_data%var(iVar)%dat, ixSoilState,  matricHead_mask, err, cmessage)
   case default; cycle ! only need to process the above variables
  end select  ! iVar
  if(err/=0)then; message=trim(message)//trim(cmessage)//'[varname='//trim(indx_meta(ivar)%varname)//']'; return; endif

 end do  ! looping through variables in the data structure

 ! make association to variables in the data structures
 subsetState: associate(ixStateType_subset => indx_data%var(iLookINDEX%ixStateType_subset)%dat) ! named variables defining the states in the subset

 ! -----
 ! - get indices for the (currently) scalar states in the vegetation domain...
 ! ---------------------------------------------------------------------------

 ! check the number of state variables in the vegetation canopy
 if(count(ixStateType_subset==iname_nrgCanair)>1)then; err=20; message=trim(message)//'expect count(iname_nrgCanair)=1 or 0'; return; endif
 if(count(ixStateType_subset==iname_nrgCanopy)>1)then; err=20; message=trim(message)//'expect count(iname_nrgCanopy)=1 or 0'; return; endif
 if(count(ixStateType_subset==iname_watCanopy)>1)then; err=20; message=trim(message)//'expect count(iname_watCanopy)=1 or 0'; return; endif

 ! define indices for energy states for the canopy air space and the vegetation canopy
 ! NOTE: finds first index of named variable within stateType (set to integerMissing if not found)
 ixCasNrg = findIndex(ixStateType_subset, iname_nrgCanair, integerMissing)   ! energy of the canopy air space
 ixVegNrg = findIndex(ixStateType_subset, iname_nrgCanopy, integerMissing)   ! energy of the vegetation canopy

 ! define indices for hydrology states for the vegetation canopy
 ! NOTE: local variables -- ixVegHyd defined next
 ixVegWat = findIndex(ixStateType_subset, iname_watCanopy, integerMissing)   ! total water in the vegetation canopy
 ixVegLiq = findIndex(ixStateType_subset, iname_liqCanopy, integerMissing)   ! liquid water in the vegetation canopy
 ixVegHyd = merge(ixVegWat, ixVegLiq, ixVegWat/=integerMissing)

 ! define index for the upper-most energy state variables in the snow+soil domain
 ixTopNrg = findIndex(ixStateType_subset, iname_nrgLayer, integerMissing)    ! upper-most energy state in the snow+soil system

 ! define index for the upper-most hydrology state variables in the snow+soil domain
 ! NOTE: local variables -- ixTopHyd defined next
 ixTopWat = findIndex(ixStateType_subset, iname_watLayer, integerMissing)    ! upper-most total water state variable in the snow+soil system
 ixTopLiq = findIndex(ixStateType_subset, iname_liqLayer, integerMissing)    ! upper-most liquid water state variable in the snow+soil system
 ixTopMat = findIndex(ixStateType_subset, iname_matLayer, integerMissing)    ! upper-most total water matric potential state
 ixTopLMP = findIndex(ixStateType_subset, iname_lmpLayer, integerMissing)    ! upper-most liquid water matric potential state

 ! define index for the upper most hydrology state in the snow+soil system
 if(ixTopWat==integerMissing .and. ixTopLiq==integerMissing)then
  ixTopHyd = merge(ixTopMat, ixTopLMP, ixTopMat/=integerMissing)      ! no water state, so upper-most hydrology state is the upper-most matric head state (if it exists)
 else
  ixTopHyd = merge(ixTopWat, ixTopLiq, ixTopWat/=integerMissing)      ! ixTopWat is used if it is not missing
 endif

 ! -----
 ! - get vector of indices within the state subset state variables of a given type...
 ! ----------------------------------------------------------------------------------

 ! define index in full state vector
 ixSequence = arth(1,1,nSubset)

 ! get state subsets for desired variables
 do iVar=1,size(indx_data%var)   ! loop through index variables

  ! define the mask
  select case(iVar)
   case(iLookINDEX%ixNrgOnly);     stateTypeMask = (ixStateType_subset==iname_nrgCanair .or. ixStateType_subset==iname_nrgCanopy .or. ixStateType_subset==iname_nrgLayer)  ! list of indices for all energy states
   case(iLookINDEX%ixHydOnly);     stateTypeMask = (ixStateType_subset==iname_watLayer  .or. ixStateType_subset==iname_liqLayer  .or. ixStateType_subset==iname_matLayer .or. ixStateType_subset==iname_lmpLayer)   ! list of indices for all hydrology states
   case(iLookINDEX%ixMatOnly);     stateTypeMask = (ixStateType_subset==iname_matLayer  .or. ixStateType_subset==iname_lmpLayer)   ! list of indices for matric head state variables
   case(iLookINDEX%ixMassOnly);    stateTypeMask = (ixStateType_subset==iname_watCanopy)   ! list of indices for hydrology states (mass of water)
   case default; cycle ! only need to process the above variables
  end select  ! iVar

  ! get the subset of indices
  ! NOTE: indxSubset(subset, fullVector, mask), provides subset of fullVector where mask==.true.
  call indxSubset(indx_data%var(iVar)%dat,ixSequence,stateTypeMask,err,cmessage)
  if(err/=0)then; message=trim(message)//trim(cmessage)//'[varname='//trim(indx_meta(ivar)%varname)//']'; return; endif

 end do  ! looping through variables in the data structure

 ! -----
 ! - get vector of indices of the state subset for layers in the snow+soil domain...
 ! ---------------------------------------------------------------------------------

 ! get list of indices for energy
 ! NOTE: layers not in the state subset will be missing
 ixSnowSoilNrg = ixMapFull2Subset(ixNrgLayer)                    ! both snow and soil layers
 ixSnowOnlyNrg = ixMapFull2Subset(ixNrgLayer(      1:nSnow  ))   ! snow layers only
 ixSoilOnlyNrg = ixMapFull2Subset(ixNrgLayer(nSnow+1:nLayers))   ! soil layers only

 ! get list of indices for hydrology
 ! NOTE: layers not in the state subset will be missing
 ixSnowSoilHyd = ixMapFull2Subset(ixHydLayer)                    ! both snow and soil layers
 ixSnowOnlyHyd = ixMapFull2Subset(ixHydLayer(      1:nSnow  ))   ! snow layers only
 ixSoilOnlyHyd = ixMapFull2Subset(ixHydLayer(nSnow+1:nLayers))   ! soil layers only

 ! get the number of valid states for energy
 nSnowSoilNrg = count(ixSnowSoilNrg/=integerMissing)
 nSnowOnlyNrg = count(ixSnowOnlyNrg/=integerMissing)
 nSoilOnlyNrg = count(ixSoilOnlyNrg/=integerMissing)

 ! get the number of valid states for hydrology
 nSnowSoilHyd = count(ixSnowSoilHyd/=integerMissing)
 nSnowOnlyHyd = count(ixSnowOnlyHyd/=integerMissing)
 nSoilOnlyHyd = count(ixSoilOnlyHyd/=integerMissing)

 ! end association to data in structures
 end associate subsetState
 end associate fullState

 end subroutine indexSplit

 ! **********************************************************************************************************
 ! private subroutine indxSubset: get a subset of indices for a given mask
 ! **********************************************************************************************************
 subroutine indxSubset(ixSubset,ixMaster,mask,err,message)
 implicit none
 ! input-output: subset of indices for allocation/population
 integer(i4b),intent(inout),allocatable :: ixSubset(:)           ! subset of indices
 ! input
 integer(i4b),intent(in)                :: ixMaster(:)           ! full list of indices
 logical(lgt),intent(in)                :: mask(:)               ! desired indices
 ! error control
 integer(i4b),intent(out)               :: err                   ! error code
 character(*),intent(out)               :: message               ! error message
 ! -----------------------------------------------------------------------------------------------------------------------------------
 ! local variables
 integer(i4b)                           :: nSubset               ! length of the subset
 ! -----------------------------------------------------------------------------------------------------------------------------------
 ! initialize errors
 err=0; message="indxSubset/"

 ! check size match
 if(size(ixMaster)/=size(mask))then
  message=trim(message)//'size mismatch'
  err=20; return
 endif

 ! get the number of variables
 nSubset = count(mask)

 ! check if we need to reallocate space
 if(size(ixSubset)/=nSubset) then

  ! deallocate space
  deallocate(ixSubset,stat=err)
  if(err/=0)then; message=trim(message)//'unable to deallocate space for variable'; err=20; return; endif

  ! allocate space
  allocate(ixSubset(nSubset),stat=err)
  if(err/=0)then; message=trim(message)//'unable to deallocate space for variable'; err=20; return; endif

 endif  ! allocating space

 ! define indices for variable types in specific sub-domains
 if(nSubset>0) ixSubset = pack(ixMaster, mask)

 end subroutine indxSubset

 ! **********************************************************************************************************
 ! private subroutine resizeIndx: re-size specific index vectors
 ! **********************************************************************************************************
 subroutine resizeIndx(ixDesire,indx_data,nVec,err,message)
 ! input
 integer(i4b)     ,intent(in)    :: ixDesire(:)            ! variables needing to be re-sized
 type(var_ilength),intent(inout) :: indx_data              ! indices defining model states and layers
 integer(i4b)     ,intent(in)    :: nVec                   ! desired vector length
 ! output
 integer(i4b)     ,intent(out)   :: err                    ! error code
 character(*)     ,intent(out)   :: message                ! error message
 ! local variables
 integer(i4b)                    :: jVar,iVar              ! vatiable index
 ! initialize error control
 err=0; message='resizeIndx/'

 ! loop through variables
 do jVar=1,size(ixDesire)

  ! define index in index array
  iVar = ixDesire(jVar)

  ! check iVar is within range
  if(iVar<1 .or. iVar>size(indx_data%var))then
   message=trim(message)//'desired variable is out of range'
   err=20; return
  endif

  ! check if we need to reallocate space
  if(size(indx_data%var(iVar)%dat) == nVec) cycle

  ! deallocate space
  deallocate(indx_data%var(iVar)%dat,stat=err)
  if(err/=0)then
   message=trim(message)//'unable to deallocate space for variable '//trim(indx_meta(ivar)%varname)
   err=20; return
  endif

  ! allocate space
  allocate(indx_data%var(iVar)%dat(nVec),stat=err)
  if(err/=0)then
   message=trim(message)//'unable to allocate space for variable '//trim(indx_meta(ivar)%varname)
   err=20; return
  endif

  ! set to missing
  indx_data%var(iVar)%dat = integerMissing

 end do  ! looping through variables

 end subroutine resizeIndx

end module indexState_module

max_stars_repo_name: KathyNie/LISF

max_issues_repo_name: dmocko/LISF

max_forks_repo_name: dmocko/LISF


text:
      SUBROUTINE G1ERMS
C
C          ------------------------------------------------
C          ROUTINE NO. (1006)   VERSION (A8.5)    14:NOV:90
C                         === FORTRAN-77 ===
C          ------------------------------------------------
C
C          THIS PRINTS OUT THE APPROPRIATE POST-PROCESSOR
C          ERROR MESSAGE AFTER THE OCCURRENCE OF A FAULT.
C
C
      LOGICAL   ERRON
      CHARACTER MESSAG(8)*36
C
      COMMON /T3CHAM/ KMESGI,KMESGO
      COMMON /T3ERRS/ ERRON,NUMERR
C
      SAVE MESSAG
      DATA MESSAG /'ATTEMPT TO SET LOG. MAP THROUGH ZERO',
     &             'ATTEMPT TO MOVE OUTSIDE LOG. SPACE  ',
     &             'WORK SPACE COMPLETELY FULL          ',
     &             'CHARACTER-DEFINITION SPACE FULL     ',
     &             'UNABLE TO OPEN CHARACTER FONT FILE  ',
     &             'UNABLE TO READ CHARACTER FONT FILE  ',
     &             'DEVICE I/O SUSPENDED                ',
     &             'ERROR READING COMMAND LINE          '/
C
C
      MSGNO= NUMERR-1000
      WRITE(KMESGO,201) '*** DEVICE-OUTPUT ERROR: ',
     &                   MESSAG(MSGNO),' ***'
  201 FORMAT(/,5X,3A)
C
      RETURN
      END

max_stars_repo_name: ZedThree/GHOST

max_issues_repo_name: ZedThree/GHOST

max_forks_repo_name: ZedThree/GHOST


text:
module dump_module
   ! overloading interface
   ! dump data arrays of various types
   interface dump
      module procedure dump_integers
      module procedure dump_reals
      module procedure dump_strings
   end interface dump
contains
   subroutine dump_integers(n, x)
      implicit none
      ! dummy arguments
      integer, intent(in) :: n
      integer, intent(in), dimension(n) :: x
      ! local data
      integer :: i
      ! processing
      do i = 1, n
         write (*,*) x(i)
      end do
   end subroutine dump_integers

   subroutine dump_reals(n, x)
      implicit none
      ! dummy arguments
      integer, intent(in) :: n
      double precision, intent(in), dimension(n) :: x
      ! local data
      integer :: i
      ! processing
      do i = 1, n
         write (*,*) x(i)
      end do
   end subroutine dump_reals

   subroutine dump_strings(n, str)
      implicit none
      ! dummy arguments
      integer, intent(in) :: n
      character (len = *), intent(in), dimension(n) :: str
      ! local data
      integer :: i
      ! processing
      do i = 1, n
         write (*,*) TRIM(str(i))
      end do
   end subroutine dump_strings
end module dump_module

max_stars_repo_name: joshroybal/mergesort-fortran

max_issues_repo_name: joshroybal/mergesort-fortran

max_forks_repo_name: joshroybal/mergesort-fortran


text:
      SUBROUTINE STRUCTP(Xi,Scale2,P2,Ip2,Uv,Dv,Us,Ds,Ss,Cs,Bs,Ts,Gl)
      IMPLICIT NONE
      DOUBLE PRECISION Bs , Cs , Ds , Dv , Gl , P2 , Scale2 , Ss , Ts ,
     &                 Us , Uv , Xi
      INTEGER Ip2
      END SUBROUTINE

max_stars_repo_name: pzhristov/DPMJET

max_issues_repo_name: pzhristov/DPMJET

max_forks_repo_name: pzhristov/DPMJET


text:
! { dg-do run }
! Program to test terminators in list-directed input
program list_read_1
  character(len=5) :: s

  open (unit=11, status="SCRATCH")
  ! The / terminator was causing the next value to be skipped.
  write (11, '(a)') " 42 /"
  write (11, '(a)') " 43"
  write (11, '(a)') " 44"

  rewind(11)

  read (11, *) i
  if (i .ne. 42) call abort
  read (11, *) i
  if (i .ne. 43) call abort
  read (11, *) i
  if (i .ne. 44) call abort
  close (11)
end

max_stars_repo_name: maurizioabba/rose

max_issues_repo_name: sujankh/rose-matlab

max_forks_repo_name: sujankh/rose-matlab


text:
! ===========================================================================================================
module xx_kinds      ! stolen from thorsten's vamp_bundle.f90
  implicit none
  integer, parameter, public :: &
       double = selected_real_kind (precision (1.0) + 1, range (1.0) + 1)
  character(len=*), public, parameter :: KINDS_RCS_ID = &
       "$Id: kinds.nw,v 1.17 1998/05/07 10:43:48 ohl Exp $"
end module xx_kinds

! ===========================================================================================================
module xx_pass_integ     ! transfer variable values past vegas
  use xx_kinds
  implicit none

  integer, dimension(-1:30):: dim                        ! set in INIT_GLOBAL : dimensionality of integrals
  integer, dimension(-2:30):: ii_done                    ! set in IFCT_**_X12 : keep track of partonic channels
  integer                  :: ipart1, ipart2             ! set in INIT_SUSY   : internal variable for final state particles
  integer                  :: icoll                      ! set in PROSPINO    : Tevatron vs. LHC
  integer                  :: isq_ng                     ! set in PROSPINO    : use mass degenerate squarks
  integer                  :: i_ngtest                   ! set in PROSPINO    : go into testing mode (not recommended)
  integer                  :: isquark1,isquark2          ! set in PROSPINO    : squark flavor kept for LO results
  integer                  :: ii                         ! set in PROSPINO    : LO-NLO partonic channels
  integer                  :: idub                       ! set in INIT_GLOBAL : doublet structure of incoming quarks
  integer                  :: isca                       ! set in INIT_GLOBAL : scale choice
  integer                  :: imx                        ! set in INIT_GLOBAL : complex neutralino mixing vs. negative mass
  integer                  :: iscaling                   ! set in INIT_GLOBAL : scaling functions option [only for test use]
  integer                  :: ifla_le                    ! set in PROSPINO    : incoming flavor for LQ+lepton production
  integer                  :: n_faulty                   ! set in PROSPINO    : counts the number of non-valid calls

  character(len=2)         :: final_state                ! set in PROSPINO

  real(kind=double)        :: cut,eps_sli,ewi,eps_sub    ! set in INIT_GLOBAL

  real(kind=double)                  :: sc               ! set in PROSPINO
  real(kind=double)                  :: mg,ms            ! set in INIT_SUSY
  real(kind=double)                  :: mh1,mh2,mch      ! set in INIT_SUSY
  real(kind=double)                  :: sin_a,cos_a      ! set in INIT_SUSY
  real(kind=double)                  :: mu_susy,tan_b    ! set in INIT_SUSY
  real(kind=double)                  :: a_b,a_t          ! set in INIT_SUSY
  real(kind=double), dimension(-6:6) :: msq              ! set in INIT_SUSY
  real(kind=double), dimension(1:8)  :: smass_n,mass_n   ! set in INIT_SUSY
  real(kind=double), dimension(2,2)  :: uu,vv            ! set in INIT_SUSY
  real(kind=double), dimension(2,2)  :: mst,msb,msl      ! set in INIT_SUSY
  real(kind=double), dimension(4,4)  :: bw               ! set in INIT_SUSY
  real(kind=double), dimension(1:4)  :: mass_s           ! set in INIT_SUSY
  real(kind=double), dimension(1:4)  :: mass_x           ! set in INIT_SUSY
  real(kind=double)                  :: mg_orig,ms_orig  ! set in INIT_SUSY
  real(kind=double)                  :: scafac           ! set in PROSPINO
  real(kind=double)                  :: eta              ! set in INIT_GLOBAL

  complex(kind=double), dimension(4,4) :: zz             ! set in INIT_SUSY
end module xx_pass_integ

! ===========================================================================================================
module xx_public_variables   ! all kind of public sm and mssm parameters, used everywhere
   use xx_kinds
   implicit none

   real(kind=double), parameter, public :: gf=1.1663e-5                 ! set all kinds of
   real(kind=double), parameter, public :: pi=3.1415926                 ! public parameters
   real(kind=double), parameter, public :: gevpb=389379660.0
   real(kind=double), parameter, public :: mz=91.187, mw=80.41
   real(kind=double), parameter, public :: mb=4.6,    mt=172.0

   logical, parameter, public           :: ldebug=.false.

end module xx_public_variables

max_stars_repo_name: sliem/docker-hep

max_issues_repo_name: sliem/docker-hep

max_forks_repo_name: sliem/docker-hep


text:
      SUBROUTINE ZDROT( N, CX, INCX, CY, INCY, C, S )
*
*     .. Scalar Arguments ..
      INTEGER            INCX, INCY, N
      DOUBLE PRECISION   C, S
*     ..
*     .. Array Arguments ..
      COMPLEX*16         CX( * ), CY( * )
*     ..
*
*  Purpose
*  =======
*
*  Applies a plane rotation, where the cos and sin (c and s) are real
*  and the vectors cx and cy are complex.
*  jack dongarra, linpack, 3/11/78.
*
*  Arguments
*  ==========
*
*  N        (input) INTEGER
*           On entry, N specifies the order of the vectors cx and cy.
*           N must be at least zero.
*           Unchanged on exit.
*
*  CX       (input) COMPLEX*16 array, dimension at least
*           ( 1 + ( N - 1 )*abs( INCX ) ).
*           Before entry, the incremented array CX must contain the n
*           element vector cx. On exit, CX is overwritten by the updated
*           vector cx.
*
*  INCX     (input) INTEGER
*           On entry, INCX specifies the increment for the elements of
*           CX. INCX must not be zero.
*           Unchanged on exit.
*
*  CY       (input) COMPLEX*16 array, dimension at least
*           ( 1 + ( N - 1 )*abs( INCY ) ).
*           Before entry, the incremented array CY must contain the n
*           element vector cy. On exit, CY is overwritten by the updated
*           vector cy.
*
*  INCY     (input) INTEGER
*           On entry, INCY specifies the increment for the elements of
*           CY. INCY must not be zero.
*           Unchanged on exit.
*
*  C        (input) DOUBLE PRECISION
*           On entry, C specifies the cosine, cos.
*           Unchanged on exit.
*
*  S        (input) DOUBLE PRECISION
*           On entry, S specifies the sine, sin.
*           Unchanged on exit.
*
* =====================================================================
*
*     .. Local Scalars ..
      INTEGER            I, IX, IY
      COMPLEX*16         CTEMP
*     ..
*     .. Executable Statements ..
*
      IF( N.LE.0 )
     $   RETURN
      IF( INCX.EQ.1 .AND. INCY.EQ.1 )
     $   GO TO 20
*
*        code for unequal increments or equal increments not equal
*          to 1
*
      IX = 1
      IY = 1
      IF( INCX.LT.0 )
     $   IX = ( -N+1 )*INCX + 1
      IF( INCY.LT.0 )
     $   IY = ( -N+1 )*INCY + 1
      DO 10 I = 1, N
         CTEMP = C*CX( IX ) + S*CY( IY )
         CY( IY ) = C*CY( IY ) - S*CX( IX )
         CX( IX ) = CTEMP
         IX = IX + INCX
         IY = IY + INCY
   10 CONTINUE
      RETURN
*
*        code for both increments equal to 1
*
   20 CONTINUE
      DO 30 I = 1, N
         CTEMP = C*CX( I ) + S*CY( I )
         CY( I ) = C*CY( I ) - S*CX( I )
         CX( I ) = CTEMP
   30 CONTINUE
      RETURN
      END

max_stars_repo_name: pkeuchel/oomph-lib

max_issues_repo_name: pkeuchel/oomph-lib

max_forks_repo_name: pkeuchel/oomph-lib