text:
see public page: Ronald Payne

20070306 14:26:04 nbsp Rather than just deleting that paragraph, you might do better to join the discussion about it at {{{Steve Ostrowski/Talk}}}.  Presenting an argument (or in this case, a supporting argument, since there are already other people against it) would likely be far more productive and likely to achieve results than simply being stubborn. Users/JabberWokky jw

20070306 13:58:39 nbsp Ron, if you could call me, Id appreciate it.  Im not exactly a political enemy, as Ive been out of college for many many years, never attended any school in California, and I only care about trying to get things on this wiki moving smoothly and open communication lines.  Ive been calling Steve for the past day, and he has mentioned his cell battery was dead.  If you could let him know that Im still trying to talk to him, it would be appreciated.  Thank you.  615 5176900.   Evan Users/JabberWokky Edwards

20071010 21:01:23 nbsp Thats weird, Steve tells me his phone has been good all day.  I dont consider anyone an enemy.   Users/RonPayne

20071010 21:02:15 nbsp I just called him and he picked up.   Users/RonPayne

20071010 21:03:15 nbsp That comment was from some time ago, look at the edit history for the page. I just added the comment macro to the page while trying to figure out a comment to you. Users/JasonAller

20071010 21:03:46 nbsp Oh, I see. My bad.  Users/RonPayne

20071010 21:42:42 nbsp It would be in your best interest when drafting a serious document to not release an unreviewed and incomplete copy to the wiki. The {{{Eric Friedman Recall}}} is an example of how not to use the wiki. You cant collect signatures here so it doesnt make sense to create the page unless your desire is to make Eric look bad. All this will accomplish is to increase the level of negativity both surrounding ASUCD and on the wiki. Please dont. Users/JasonAller

20071010 21:46:04 nbsp Steve thought it was news and since he is about to give the final product to IAC within a few days he wanted some input.  But Senate candidates post their profiles but they cant collect signatures either.   Users/RonPayne

20071011 01:14:31 nbsp Hello Ronald. Two things. Firstly, Steven is banished from this community for a reason. I may disagree with banishment in general, because I am idealist and optimistic; however, he was banned for his own brand of asshattery^tm^ and in keeping with this, you are committing the same offense and thus should receive the same kind of treatment. That is to say, if you continue these actions, I will see to it that you are banished as well, though probably not on such a permanent basis as Steven was given a few warnings. Secondly, the page that we are disputing, it is wholly irrelevant to Davis, the community, and really any matter of ASUCD history, noting that Steve, yourself, and anyone else involved is simply earning the further dislike of the current members of the internal affairs commission as well as the ASUCD, so for the sake of your continued welcome in this and other communities, I suggest that you cease and desist these actions both on this website and additionally in the ASUCD. (I honestly care more about the former, you can make an ass of yourself there all you want). Users/DavidPoole

20071030 19:32:32 nbsp Either Ron is cloned or someone else is using Rons account.  I just spoke with Ron on campus, he was not using any computers. lol
Users/GregWebb

   I havent seen Greg Webb all day.  I didnt speak with him.  Lol.  Users/RonPayne

20071030 19:37:39 nbsp I edited a portion of your comment because I felt it was deliberately trying to get around it by cheating, so to say (which doesnt usually rank high on American values).  I think other people would agree, but we can wait and see what the talkpage says.  I left a lengthy comment there, took me a few minutes to type it.  But maliciously trying to expose someone is against wiki history and norms, and I doubt people will let you do it to try to strongarm someone. Users/EdWins

20071105 21:17:27 nbsp Do you know who painted all that graffiti on campus today? Users/JasonAller

20071105 21:49:56 nbsp Why are you asking me? Users/RonPayne

20071105 21:52:08 nbsp Because I want to know. Users/JasonAller

20071105 22:00:24 nbsp If I know something I will call the UCPD or DPD.   Users/RonPayne
  Wait, are you trying to say I was involved in this?  Users/RonPayne
   Wow, you are reading WAY TOO MUCH into my question. Users/JasonAller
   You are only asking me, on the whole wiki.   Users/RonPayne

20071106 06:27:52 nbsp I understand your passion regarding the USA entry, but constantly reverting is counterproductive.  Its like repeatedly screaming at a prospective romantic partner that they should go out with you.  If you have a good argument for keeping the entry long, make it.  USA says that they are interested in politics... but there are very few political concessions or proposals made by most members when theyve edited the wiki.  Youre dealing with a bunch of people.  If you have a good position, argue it.  If you examine the situation and honestly dont have a good argument against it, let the other edit go through.  I certainly dont agree with many of the edits that happen on the wiki, and I could probably strongarm them into place just by sheer persistence... and that applies to everybody else who is a regular editor.  However, there are some edits worth fighting for (by pleading your case), some that arent (so you grumble at the monitor and move on), and some where it simply isnt going to happen the way you envision it should.  Often in the third case you can examine the goals of all opposing arguments and come up with a new edit that satisfies everybodys intent.  Being social and conceding  even for a matter of hours, while you make your argument as to why an edit is wrong  gets you much farther than an antisocial tug o war on the revert button. Users/JabberWokky

20071106 14:29:58 nbsp I dont see a whole lot of reverts on my part, maybe it was someone else.  Users/RonPayne

20071115 04:15:36 nbsp Slowly you are growing that case title into a coded transmission, arent you?  When it is Court Case 4243444751535457627174798288949596102114119126, the Red Horde attacks? Users/JabberWokky

20071116 14:27:14 nbsp What?  Andrew Kim didnt file to win an office?  ;)  Thanks for the catch. Users/JabberWokky

20071116 14:34:54 nbsp It seems kind of harsh to put the word fail on all of the loser pages.  Perhaps didnt win or lost.  You wouldnt say a School Board candidate failed to win a seat.  Users/RonPayne
  Actually, that is http://daviswiki.org/Bob_Schelen?actiondiff&version28&version17 exactly what I said. It is a pretty common phrasing referring to an attempt to gain office (well, a failed attempt to gain office), and the word failed doesnt imply anything other than that the attempt did not succeed.  Nor does the word gain in gain office mean that they are associated in any way with a http://www.gainlaundry.com/ laundry detergent.  Jimmy Carter failed to be elected in his second term.  Its not exactly outrageous or uncommon wording.   Users/JabberWokky

20071117 11:30:20 nbsp I just wanted to say thanks for keeping us updated on who Steve talks to and what he thinks about stuff.  Users/EdWins

20080614 08:27:15 nbsp Can you update the Gamma Alpha Upsilon page? If it never bloomed, just note that. Users/JasonAller


text:
      SUBROUTINE APD12
C
      EXTERNAL        ORF
      LOGICAL         LS,LC,DLB
      INTEGER         AUSET(6,2),ORF,PSPA,UK,USA,IZ(1),NAM(2),
     1                EID,PID,CP,CIDBX,ACSID,SILB,SCR1,SCR2,SCR3,SCR4,
     2                SCR5,ECTA,BGPA,GPLA,USETA,SILA,CSTMA,ACPT,BUF10,
     3                BUF11,BUF12,IAX(20),
     4                CA2S,CA2E,CA3S,CA3E,CA4S,CA4E,
     5                PA2S,PA2E,PA3S,PA3E,PA4S,PA4E
      COMMON /SYSTEM/ SYSBUF,IUT
      COMMON /APD1C / EID,PID,CP,NSPAN,NCHORD,LSPAN,LCHORD,IGID,
     1                X1,Y1,Z1,X12,X4,Y4,Z4,X43,XOP,X1P,ALZO,MCSTM,
     2                NCST1,NCST2,CIDBX,ACSID,IACS,SILB,NCRD,SCR1,
     3                SCR2,SCR3,SCR4,SCR5,ECTA,BGPA,GPLA,USETA,SILA,
     4                CSTMA,ACPT,BUF10,BUF11,BUF12,NEXT,LEFT,ISILN,
     5                NCAM,NAEF1,NAEF2,NCA1,NCA2,CA2S,CA2E,CA3S,CA3E,
     6                CA4S,CA4E,NPA1,NPA2,PA2S,PA2E,PA3S,PA3E,PA4S,PA4E
      COMMON /APD12C/ KEY(5),AUSET,USA,UK,NCAM2,NASB,IPPC
      COMMON /BITPOS/ IBIT(64)
      COMMON /TWO   / ITWO(32)
      COMMON /ZZZZZZ/ Z(1)
      EQUIVALENCE    (Z(1),IZ(1)),(EID,IAX(1))
      DATA    NAM   /4HAPD1,4H2   /
C
      I17 = IBIT(17)
      I18 = IBIT(18)
      I19 = IBIT(19)
      I20 = IBIT(20)
      PSPA= ORF(ITWO(I17),ITWO(I20))
      USA = ORF(PSPA,ITWO(I18))
      UK  = ORF(ITWO(I19),ITWO(I20))
      DO 10 J = 1,2
      DO 10 I = 1,6
   10 AUSET(I,J) = USA
      AUSET(3,2) = UK
      AUSET(5,2) = UK
      NCAM = ((NCA2-NCA1)+1)/16
      IF (NCA1 .EQ. 0) NCAM = 0
      NCAM2 = ((CA2E-CA2S)+1)/16
      IF (CA2S .EQ. 0) NCAM2 = 0
      LCA = 16
C
C     CREATE IGID SEQUENCE ARRAY
C
      NIGID1 = NEXT
      IGID2  = NEXT
      NIGID  = NEXT
      NX = NCA1
      J  = NIGID1
      IF (NCAM .EQ. 0) GO TO 15
      DO 240 I = 1,NCAM
      IZ(J) = IZ(NX+7)
      J = J + 1
      IZ(J) = NX
      NX = NX + LCA
  240 J = J + 1
C
C     SORT IGID ARRAY ON IGID
C
      CALL SORT (0,0,2,1,IZ(NIGID1),2*NCAM)
   15 IF (NCAM2 .EQ. 0) GO TO 30
      NX = CA2S
      NIGID2 = J
      DO 20 I = 1,NCAM2
      IZ(J) = IZ(NX+7)
      J = J + 1
      IZ(J) = NX
      NX = NX + LCA
   20 J = J + 1
      CALL SORT (0,0,2,1,IZ(NIGID2),2*NCAM2)
      IGID2 = NIGID2
   30 NEXTC = J
      IF (NCAM .EQ. 0) GO TO 500
      NIGID = NIGID1
C
C     OUTTER LOOP PROCESSES CAERO1 CARDS
C
      DO 410 I = 1,NCAM
C
C     SET APD1 INPUT COMMON BLOCK
C
      NC = IZ(NIGID+1) - 1
C
C     MOVE CAERO TO COMMON
C
      DO 250 J = 1,16
      N1 = J + NC
  250 IAX(J) = IZ(N1)
      MCSTM  = MCSTM + 1
      IZ(NC+2) = MCSTM
C
C     FIND PAERO1 CARD
C
      IF (NPA1 .EQ. 0) GO TO 890
      DO 260 J = NPA1,NPA2,8
      IPPC = J
      IF (PID .EQ. IZ(J)) GO TO 270
  260 CONTINUE
      GO TO 890
  270 XOP  = .25
      X1P  = .75
      ALZO = 0.0
C
C     FIND AEFACT ARRAYS IF PRESENT
C
      JSPAN  = NSPAN
      JCHORD = NCHORD
      IF (LSPAN .EQ. 0) GO TO 280
      CALL APDOE (LSPAN,IZ,NAEF1,NAEF2,ISPAN,JSPAN)
      IF (ISPAN .EQ. 0) GO TO 850
      ISPAN = ISPAN + 1
      JSPAN = JSPAN - 1
  280 IF (LCHORD .EQ. 0) GO TO 350
      CALL APDOE (LCHORD,IZ,NAEF1,NAEF2,ICHORD,JCHORD)
      IF (ICHORD .EQ. 0) GO TO 860
      ICHORD = ICHORD + 1
      JCHORD = JCHORD - 1
  350 CONTINUE
C
C     CHECK IF FIRST OR LAST ENTRY IN IGID SET
C
      LS = .FALSE.
      IF (I .EQ. 1) GO TO 370
      IF (IZ(NIGID) .EQ. IZ(NIGID-2)) GO TO 380
  370 LS = .TRUE.
  380 LC = .FALSE.
      DLB= .FALSE.
      IF (I .EQ. NCAM) GO TO 390
      IF (IZ(NIGID) .EQ. IZ(NIGID+2)) GO TO 400
  390 LC = .TRUE.
C
C     CHECK FOR CAERO2 ELEMENT
C
      IF (NCAM2 .EQ. 0) GO TO 400
      IF (NIGID2 .GT. NEXTC) GO TO 50
   40 IF (IZ(NIGID2) .GT. IZ(NIGID)) GO TO 50
      IF (IZ(NIGID) .EQ. IZ(NIGID2)) DLB = .TRUE.
      IF (DLB) GO TO 50
      NIGID2 = NIGID2 + 2
      IF (NIGID2 .GT. NEXTC) GO TO 50
      GO TO 40
   50 CONTINUE
      IF (DLB) LC = .FALSE.
C
C     CALL APD1 TO MANUFACTURE BOXES
C
  400 CALL APD1 (Z(ISPAN),JSPAN,Z(ICHORD),JCHORD,LS,LC)
      NCHORD = JCHORD
      NSPAN  = JSPAN
      IZ(NC+4) = NSPAN
      IZ(NC+5) = NCHORD
      IZ(NC+8) = 1
      IF (.NOT.DLB) GO TO 410
C
C     PROCESS CAERO2 WITH CAERO1
C
      CALL APD2 (1,IZ(NEXT),IZ(IGID2 ),NEXTC,IZ(NIGID))
  410 NIGID = NIGID + 2
C
C     PROCESS CAERO2 CARDS NOT PROCESSED YET
C
  500 IF (NCAM2 .EQ. 0) GO TO 1000
      CALL APD2 (0,IZ(NEXT),IZ(IGID2 ),NEXTC,IZ(NIGID))
 1000 RETURN
C
C     ERROR MESSAGES
C
  812 CALL MESAGE (-61,0,NAM)
  850 CALL EMSG (0,2326,1,2,0)
      WRITE  (IUT,851) EID,LSPAN
  851 FORMAT (10X,19HCAERO1 ELEMENT NO. ,I8,28H REFERENCES AEFACT CARD N
     1O. ,I8,22H WHICH DOES NOT EXIST.)
      GO TO 812
  860 CALL EMSG (0,2327,1,2,0)
      WRITE (IUT,851) EID,LCHORD
      GO TO 812
  890 CALL EMSG (0,2323,1,2,0)
      WRITE  (IUT,891) PID,EID
  891 FORMAT (10X,16HPAERO1 CARD NO. , I8,31H REFERENCED BY CAERO1 CARD
     1NO. ,I8,20H BUT DOES NOT EXIST.)
      GO TO 812
      END

ext: f


text:
      subroutine imppro
c
c     + + + PURPOSE + + +
c
c     Channel water surface profile analysis subroutine.
c     SR IMPPRO uses the standard step method to obtain
c     the water surface profile and energy slopes at each
c     node in the channel.
c
c     Called from: IMPINT
c     Author(s): A. Fogel
c     Reference in User Guide:
c
c     Version:
c     Date recoded:
c     Recoded by:
c
c     + + + KEYWORDS + + +
c
c     + + + PARAMETERS + + +
c
c     + + + ARGUMENT DECLARATIONS + + +
c
c     + + + ARGUMENT DEFINITIONS + + +
c
c     + + + COMMON BLOCKS + + +
c
      include 'cimrou.inc'
c     read: b,ss,n,pypos,z,mdwit,dwt,rfrac,yc,frt,ncross
c     write: depth
c
c     + + + LOCAL VARIABLES + + +
c
      real area, hrad, cntrdp, v, vhead, theadc, y1, y2, hr23, r23, s1,
     1    chr, dz, yy1, yy2, dy, ddx, stage, thead1, s2, sfavg, floss,
     1    thdif, hhead, thead2, g, b, frt, ss, z(30), n, ydif
      integer iup, icsec, numnp1, nod, i, iter
c
c     + + + LOCAL DEFINITIONS + + +
c
c     area     - the flow area of the channel
c     b        - channel bottom width
c     chr      - channel roughness coefficient
c     cntrdp   - depth at the control section
c     ddx      - distance downstream
c     dy       - incremental change in depth
c     dz       - incremental change in downstream distance
c     floss    - friction loss
c     frt      - flow rate
c     g        - gravitational constant
c     hhead    - head variable
c     hr23     - hydraulic radius ** 2/3
c     hrad     - hydraulic radius
c     icsec    - number of cross sections
c     iter     - number of iterations
c     iup      - upstream routing flag
c     n        - manning's n
c     nod      - normal depth counter
c     numnp1   - number of points in cross section
c     r23      - 2/3 in manning's n equation
c     s1       - friction slope
c     s2       - friction slope
c     sfavg    - friction slope
c     ss       - side slopes
c     stage    - stage of the flow depth
c     thdif    - convergence head difference
c     thead1   - total head
c     thead2   - total head
c     theadc   - total head
c     v        - average flow velocity
c     vhead    - velocity head
c     y1       - flow depth
c     y2       - flow depth
c     ydif     - flow depth difference
c     yy1      - control section position
c     yy2      - control section position + 1
c     z(i)     - horizontal location
c
c     + + + SAVES + + +
c
c     + + + SUBROUTINES CALLED + + +
c
c     + + + DATA INITIALIZATIONS + + +
c
c     + + + END SPECIFICATIONS + + +
c
c     calculate the hydraulic radius for the control section
c
      b = bwes
      ss = sses
      n = nes
c
      do 10 i = 1, ncross
        z(i) = zes(i)
   10 continue
c
      frt = qesr
      iup = 0
      cntrdp = yc
      g = 32.2
c
      if (iup.eq.0) then
        icsec = ncross
        depth(icsec) = cntrdp
        area = b * depth(icsec) + ss * depth(icsec) ** 2
        hrad = area / (b+2.*depth(icsec)*(ss**2+1)**0.5)
      else
        icsec = 1
        depth(icsec) = cntrdp
        area = b * depth(icsec) + ss * depth(icsec) ** 2
        hrad = area / (b+2.*depth(icsec)*(ss**2+1)**0.5)
      end if
c
c     calculate the velocity head and the total head for the control
c     section
c
      v = frt / area
      vhead = v * v / (2.0*g)
      theadc = pypos(icsec) + depth(icsec) + vhead
      y1 = depth(icsec)
      y2 = y1
c
c     calculate the friction slope using manning's equation
c
      r23 = 2.0 / 3.0
      chr = n / 1.486
      hr23 = hrad ** r23
      s1 = (v*chr/hr23) ** 2.0
c
c     begin loop over the cross sections and set up point to change depth
c     toward normal depth
c
      numnp1 = ncross - 1
c
      do 30 nod = 1, numnp1
c
        if (iup.eq.0) then
          icsec = ncross - nod
        else
          icsec = nod + 1
        end if
c
c       calculate the distance downstream (or upstream)
c
        if (iup.eq.0) then
          dz = z(icsec+1) - z(icsec)
          yy1 = pypos(icsec)
          yy2 = pypos(icsec+1)
          dy = yy2 - yy1
          ddx = sqrt(dy*dy+dz*dz)
        else
          dz = z(icsec) - z(icsec-1)
          yy1 = pypos(icsec-1)
          yy2 = pypos(icsec)
          dy = yy2 - yy1
          ddx = sqrt(dy*dy+dz*dz)
        end if
c
c       set first guess at the stage to that of the previous cross section
c       and set the depth equal to that of the previous cross section
c
        iter = 0
c
   20   iter = iter + 1
c
        if (iter.gt.mdwit) then
          write (6,1000) iter, mdwit, icsec
          stop
        end if
c
        stage = pypos(icsec) + y2
        y1 = y2
c
c       calculate the cross sectional area, hydraulic radius, and velocity
c       and total head at the cross section
c
        area = b * y1 + ss * y1 ** 2.
        hrad = area / (b+2.*y1*(ss**2.+1)**0.5)
c
        v = frt / area
        vhead = v * v / (2.0*g)
        thead1 = stage + vhead
c
c       calculate the friction slope using manning's equation
c
        hr23 = hrad ** r23
        s2 = (v*chr/hr23) ** 2.0
c
c       calculate the average friction slope over the reach and
c       the friction loss
c
        sfavg = 0.5 * (s1+s2)
        floss = sfavg * ddx
c
c       calculate the new total head
c
        if (iup.eq.0) then
          thead2 = theadc + floss
        else
          thead2 = theadc - floss
        end if
c
c       check for convergence
c
        thdif = thead2 - thead1
c
        if (abs(thdif).lt.dwt) then
          theadc = thead2
          s1 = s2
          depth(icsec) = thead2 - vhead - pypos(icsec)
          y2 = yc
          go to 30
c
        else
c
          hhead = 0.5 * (thead1+thead2)
c
c         y2 = y1*(thead2/thead1)
c
          y2 = hhead - pypos(icsec) - vhead
          ydif = y2 - y1
c
          if (abs(ydif).gt.rfrac*y1) then
            if (ydif.ge.0.0) then
              y2 = y1 + rfrac * y1
            else
              y2 = y1 - rfrac * y1
            end if
          end if
c
          go to 20
        end if
c
   30 continue
c
      return
c
 1000 format (//12x,'!!!!!!!!!!!!!!     E R R O R     !!!!!!!!!!!!!!',//
     1    7x,'WATER SURFACE PROFILE ITERATIONS (',i3,
     1    ') EXCEEDED MAXIMUM (',i3,')',/28x,'PROGRAM HALTED'/19x,
     1    'AT CROSS SECTION ',i2//12x,
     1    '!!!!!!!!!!!!!!     E R R O R     !!!!!!!!!!!!!!')
      end

ext: for

max_stars_repo_name: jarad/dep

max_issues_repo_name: jarad/dep

max_forks_repo_name: akrherz/idep


! mc_chain_nvt_sw.f90
! Monte Carlo, single chain, NVT, square wells
PROGRAM mc_chain_nvt_sw

  !------------------------------------------------------------------------------------------------!
  ! This software was written in 2016/17                                                           !
  ! by Michael P. Allen <m.p.allen@warwick.ac.uk>/<m.p.allen@bristol.ac.uk>                        !
  ! and Dominic J. Tildesley <d.tildesley7@gmail.com> ("the authors"),                             !
  ! to accompany the book "Computer Simulation of Liquids", second edition, 2017 ("the text"),     !
  ! published by Oxford University Press ("the publishers").                                       !
  !                                                                                !
  ! LICENCE                                                                                !
  ! Creative Commons CC0 Public Domain Dedication.                                                 !
  ! To the extent possible under law, the authors have dedicated all copyright and related         !
  ! and neighboring rights to this software to the PUBLIC domain worldwide.                        !
  ! This software is distributed without any warranty.                                             !
  ! You should have received a copy of the CC0 Public Domain Dedication along with this software.  !
  ! If not, see <http://creativecommons.org/publicdomain/zero/1.0/>.                               !
  !                                                                                !
  ! DISCLAIMER                                                                                !
  ! The authors and publishers make no warranties about the software, and disclaim liability       !
  ! for all uses of the software, to the fullest extent permitted by applicable law.               !
  ! The authors and publishers do not recommend use of this software for any purpose.              !
  ! It is made freely available, solely to clarify points made in the text. When using or citing   !
  ! the software, you should not imply endorsement by the authors or publishers.                   !
  !------------------------------------------------------------------------------------------------!

  ! Takes in a configuration of atom positions in a linear chain
  ! NO periodic boundary conditions, no box
  ! Conducts Monte Carlo, NVT ensemble using various moves
  ! such as CBMC regrowth, pivot, crankshaft
  ! Uses no special neighbour lists

  ! Reads several variables and options from standard input using a namelist nml
  ! Leave namelist empty to accept supplied defaults

  ! Input configuration, output configuration, all calculations, and all results
  ! are given in simulation units defined by the model:
  ! atomic core diameter sigma = 1, well-depth epsilon=1
  ! Potential energy is -q, where q is the total number of attractive well interactions
  ! This is a negative integer, but for convenience we refer to q as energy
  ! Configurational weights are calculated on the basis of the athermal interactions
  ! only, i.e. weight=1 if no overlap, weight=0 if any overlap

  USE, INTRINSIC :: iso_fortran_env,  ONLY : input_unit, output_unit, error_unit, iostat_end, iostat_eor
  USE               config_io_module, ONLY : read_cnf_atoms, write_cnf_atoms
  USE               averages_module,  ONLY : run_begin, run_end, blk_begin, blk_end, blk_add
  USE               mc_module,        ONLY : introduction, conclusion, allocate_arrays, deallocate_arrays, &
       &                                     regrow, crank, pivot, qcount, weight, n, r

  IMPLICIT NONE

  ! Most important variables
  REAL    :: temperature    ! temperature (specified, in units of well depth)
  REAL    :: bond           ! bond length (in units of core diameter)
  REAL    :: range          ! range of attractive well (specified, same units)
  INTEGER :: m_max          ! maximum atoms in regrow
  INTEGER :: k_max          ! number of random tries per atom in regrow
  REAL    :: crank_max      ! maximum move angle in crankshaft
  REAL    :: crank_fraction ! fraction of atoms to try in crankshaft per step
  INTEGER :: n_crank        ! number of crankshaft tries per step
  REAL    :: pivot_max      ! maximum move angle in pivot
  REAL    :: pivot_fraction ! fraction of atoms to try in pivot per step
  INTEGER :: n_pivot        ! number of pivot tries per step
  INTEGER :: q              ! total attractive interaction (negative of energy)
  INTEGER :: q_min          ! min value of q seen in simulation (maximum energy)
  INTEGER :: q_max          ! max value of q seen in simulation (minimum energy)
  INTEGER :: nq             ! Maximum anticipated q

  ! Histograms and tables
  REAL, DIMENSION(:), ALLOCATABLE :: h ! Histogram of q values (0:nq)
  REAL, DIMENSION(:), ALLOCATABLE :: s ! Entropy histogram used in acceptance (0:nq)
  REAL, DIMENSION(:), ALLOCATABLE :: e ! Energy histogram

  INTEGER :: blk, stp, nstep, nblock, ioerr, try, n_acc
  LOGICAL :: accepted
  REAL    :: r_ratio, c_ratio, p_ratio

  CHARACTER(len=4), PARAMETER :: cnf_prefix = 'cnf.'
  CHARACTER(len=4), PARAMETER :: his_prefix = 'his.'
  CHARACTER(len=3), PARAMETER :: inp_tag    = 'inp'
  CHARACTER(len=3), PARAMETER :: out_tag    = 'out'
  CHARACTER(len=3)            :: sav_tag    = 'sav' ! May be overwritten with block number

  NAMELIST /nml/ nblock, nstep, m_max, k_max, crank_max, crank_fraction, pivot_max, pivot_fraction, &
       &         temperature, range

  WRITE ( unit=output_unit, fmt='(a)' ) 'mc_chain_nvt_sw'
  WRITE ( unit=output_unit, fmt='(a)' ) 'Monte Carlo, constant-NVT ensemble, chain molecule, square wells'
  CALL introduction

  CALL RANDOM_SEED () ! Initialize random number generator

  ! Set sensible default run parameters for testing
  nblock         = 10     ! Number of blocks
  nstep          = 100000 ! Number of sweeps per block
  m_max          = 3      ! Maximum atoms in regrow
  k_max          = 32     ! Number of random tries per atom in regrow
  crank_max      = 0.5    ! Maximum move angle in crankshaft
  crank_fraction = 0.5    ! Fraction of atoms to try in crank moves
  pivot_max      = 0.5    ! Maximum move angle in pivot
  pivot_fraction = 0.2    ! Fraction of atoms to try in pivot moves
  temperature    = 1.0    ! Temperature (in units of well depth)
  range          = 1.5    ! Range of attractive well

  ! Read run parameters from namelist
  ! Comment out, or replace, this section if you don't like namelists
  READ ( unit=input_unit, nml=nml, iostat=ioerr )
  IF ( ioerr /= 0 ) THEN
     WRITE ( unit=error_unit, fmt='(a,i15)') 'Error reading namelist nml from standard input', ioerr
     IF ( ioerr == iostat_eor ) WRITE ( unit=error_unit, fmt='(a)') 'End of record'
     IF ( ioerr == iostat_end ) WRITE ( unit=error_unit, fmt='(a)') 'End of file'
     STOP 'Error in mc_chain_nvt_sw'
  END IF

  ! Write out run parameters
  WRITE ( unit=output_unit, fmt='(a,t40,i15)'   ) 'Number of blocks',                nblock
  WRITE ( unit=output_unit, fmt='(a,t40,i15)'   ) 'Number of steps per block',       nstep
  WRITE ( unit=output_unit, fmt='(a,t40,i15)'   ) 'Max atoms in regrow',             m_max
  WRITE ( unit=output_unit, fmt='(a,t40,i15)'   ) 'Random tries per atom in regrow', k_max
  WRITE ( unit=output_unit, fmt='(a,t40,f15.6)' ) 'Max move angle in crankshaft',    crank_max
  WRITE ( unit=output_unit, fmt='(a,t40,f15.6)' ) 'Crank fraction',                  crank_fraction
  WRITE ( unit=output_unit, fmt='(a,t40,f15.6)' ) 'Max move angle in pivot',         pivot_max
  WRITE ( unit=output_unit, fmt='(a,t40,f15.6)' ) 'Pivot fraction',                  pivot_fraction
  WRITE ( unit=output_unit, fmt='(a,t40,f15.6)' ) 'Temperature/well depth',          temperature
  WRITE ( unit=output_unit, fmt='(a,t40,f15.6)' ) 'Attractive well range',           range
  IF ( range < 1.0 ) THEN
     WRITE ( unit=output_unit, fmt='(a)' ) 'Warning, range < core diameter (1.0)'
  END IF

  ! Read in initial configuration and allocate necessary arrays
  CALL read_cnf_atoms ( cnf_prefix//inp_tag, n, bond ) ! First call is just to get n and bond
  WRITE ( unit=output_unit, fmt='(a,t40,i15)'   ) 'Number of particles',          n
  WRITE ( unit=output_unit, fmt='(a,t40,f15.6)' ) 'Bond length (in sigma units)', bond
  CALL allocate_arrays
  nq = 6*n ! Anticipated maximum number of pair interactions within range
  ALLOCATE ( h(0:nq), s(0:nq), e(0:nq) )
  CALL read_cnf_atoms ( cnf_prefix//inp_tag, n, bond, r ) ! Second call gets r

  ! Set number of crankshaft and pivot moves per step
  n_crank = NINT(crank_fraction*REAL(n))
  n_pivot = NINT(pivot_fraction*REAL(n))
  WRITE ( unit=output_unit, fmt='(a,t40,i15)'   ) 'Number of crankshaft tries per step', n_crank
  WRITE ( unit=output_unit, fmt='(a,t40,i15)'   ) 'Number of pivot tries per step',      n_pivot

  ! Calculate energy histogram and Boltzmann exponents, s(q), which are just values of E/kT
  e = [ ( -REAL(q), q = 0, nq ) ]
  s = e /temperature

  ! Initial energy calculation plus overlap check
  IF ( weight() == 0 ) THEN
     WRITE ( unit=error_unit, fmt='(a)') 'Overlap in initial configuration'
     STOP 'Error in mc_chain_nvt_sw'
  END IF
  q = qcount ( range )
  WRITE ( unit=output_unit, fmt='(a,t40,i15)' ) 'Initial energy', q
  q_min = q ! Min q seen so far
  q_max = q ! Max q seen so far

  ! Initialize arrays for averaging and write column headings
  r_ratio = 0.0
  p_ratio = 0.0
  c_ratio = 0.0
  CALL run_begin ( calc_variables() )
  h(:) = 0.0

  DO blk = 1, nblock ! Begin loop over blocks

     CALL blk_begin

     DO stp = 1, nstep ! Begin loop over steps

        r_ratio = 0.0
        CALL regrow ( s, m_max, k_max, bond, range, q, accepted )
        IF ( accepted ) r_ratio = 1.0
        CALL update_histogram

        p_ratio = 0.0
        IF ( n_pivot > 0 ) THEN
           n_acc = 0
           DO try = 1, n_pivot
              CALL pivot ( s, pivot_max, range, q, accepted )
              IF ( accepted ) n_acc = n_acc + 1
              CALL update_histogram
           END DO
           p_ratio = REAL(n_acc) / REAL(n_pivot)
        END IF

        c_ratio = 0.0
        IF ( n_crank > 0 ) THEN
           n_acc = 0
           DO try = 1, n_crank
              CALL crank ( s, crank_max, range, q, accepted )
              IF ( accepted ) n_acc = n_acc + 1
              CALL update_histogram
           END DO
           c_ratio = REAL(n_acc) / REAL(n_crank)
        END IF

        ! Calculate and accumulate variables for this step
        CALL blk_add ( calc_variables() )

     END DO ! End loop over steps

     CALL blk_end ( blk )                                     ! Output block averages
     IF ( nblock < 1000 ) WRITE(sav_tag,'(i3.3)') blk         ! Number configuration by block
     CALL write_cnf_atoms ( cnf_prefix//sav_tag, n, bond, r ) ! Save configuration

  END DO ! End loop over blocks

  CALL run_end ( calc_variables() ) ! Output run averages

  ! Final overlap check
  IF ( weight() == 0 ) THEN
     WRITE ( unit=error_unit, fmt='(a)') 'Overlap in final configuration'
     STOP 'Error in mc_chain_nvt_sw'
  END IF

  CALL write_cnf_atoms ( cnf_prefix//out_tag, n, bond, r )
  CALL write_histogram ( his_prefix//out_tag )

  CALL deallocate_arrays
  DEALLOCATE ( h, s, e )
  CALL conclusion

CONTAINS

  FUNCTION calc_variables () RESULT ( variables )
    USE averages_module, ONLY : variable_type, msd
    IMPLICIT NONE
    TYPE(variable_type), DIMENSION(6) :: variables ! The 6 variables listed below

    ! This function returns all variables of interest in an array, for use in the main program

    TYPE(variable_type) :: r_r, c_r, p_r, e_x, r_g, c_x
    REAL, DIMENSION(3)  :: rcm
    REAL                :: rsq

    ! Preliminary calculations
    rcm = SUM ( r, dim=2 ) / REAL(n)                                 ! Centre of mass
    rsq = SUM ( ( r - SPREAD(rcm,dim=2,ncopies=n) ) ** 2 ) / REAL(n) ! Mean-squared distance from COM

    ! Variables of interest, of type variable_type, containing three components:
    !   %val: the instantaneous value
    !   %nam: used for headings
    !   %method: indicating averaging method
    ! If not set below, %method adopts its default value of avg
    ! The %nam and some other components need only be defined once, at the start of the program,
    ! but for clarity and readability we assign all the values together below

    ! Acceptance ratios for regrowth, crankshaft, and pivot moves
    r_r = variable_type ( nam = 'Regrow ratio', val = r_ratio, instant = .FALSE. )
    c_r = variable_type ( nam = 'Crank ratio',  val = c_ratio, instant = .FALSE. )
    p_r = variable_type ( nam = 'Pivot ratio',  val = p_ratio, instant = .FALSE. )

    ! Total potential energy of system per atom
    ! PE=negative of the number of square-well contacts divided by N
    e_x = variable_type ( nam = 'PE/N', val = -REAL(q)/REAL(n) )

    ! Radius of gyration
    r_g = variable_type ( nam = 'Rg', val = SQRT(rsq) )

    ! Heat Capacity (excess, without ideal gas contribution)
    ! MSD of total PE / (sqrt(N)*T)
    ! PE=negative of the number of square-well contacts
    c_x = variable_type ( nam = 'Cv(ex)/N', val = -REAL(q)/(SQRT(REAL(n))*temperature), &
         &                method = msd, instant = .FALSE. )

    ! Collect together for averaging
    variables = [ r_r, c_r, p_r, e_x, r_g, c_x ]

  END FUNCTION calc_variables

  SUBROUTINE update_histogram
    IMPLICIT NONE

    IF ( q > nq .OR. q < 0 ) THEN
       WRITE ( unit=error_unit, fmt='(a,2i15)' ) 'q out of range ', q, nq
       STOP 'Error in update_histogram'
    END IF

    h(q)  = h(q) + 1.0
    q_min = MIN ( q, q_min )
    q_max = MAX ( q, q_max )

  END SUBROUTINE update_histogram

  SUBROUTINE write_histogram ( filename )
    USE, INTRINSIC :: iso_fortran_env, ONLY : iostat_end, iostat_eor
    IMPLICIT NONE

    CHARACTER(len=*), INTENT(in) :: filename

    INTEGER :: q, ioerr, his_unit
    REAL    :: norm

    OPEN ( newunit=his_unit, file=filename, status='replace', action='write', iostat=ioerr )
    IF ( ioerr /= 0 ) THEN
       WRITE ( unit=error_unit, fmt='(a,a,i15)' ) 'Error opening ', filename, ioerr
       STOP 'Error in write_histogram'
    END IF

    norm = SUM ( h )
    h    = h / norm
    DO q = q_min, q_max
       WRITE ( unit=his_unit, fmt='(f10.0,es20.8)') e(q), h(q)
    END DO

    CLOSE ( unit=his_unit )

  END SUBROUTINE write_histogram

END PROGRAM mc_chain_nvt_sw


text:
Brian Barbier Remodeling is a small, fullservice residential Home Improvement & Repair remodeling company that specializes in Sustainability Green/Energyefficient housing modifications. They specialize in Kitchens and bathrooms but also do whole house renovations and small additions. They have been servicing the Davis community for a bit over 6 years.

They are a member in good standing with the Better Business Bureau.  They tout that they work with their clients from design through completion to create a space that meets all of the clients needs, and in doing so, achieve the latest standards in Green Building and Energy Performance.

Brian is no longer doing remodels (as of 7/2012).

 Custom Tilework

  As always on the wiki, click any thumbnail to view full size.

  Want to improve your house?  Davis has many Home Improvement & Repair services!

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


text:
C*********************************************************************

C...PYRHAD
C...Initialize stop_1 R-hadron data, like names (for event listing)
C...and charges. So far nothing but the minimum required.
C...Feel free to choose between hadron-like names or
C...flavour-content-based ones.

      SUBROUTINE PYSTRHAD

C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
C...Parameter statement to help give large particle numbers
C...(left- and righthanded SUSY, excited fermions).
      PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
C...Commonblocks.
      COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
      COMMON/PYDAT4/CHAF(500,2)
      CHARACTER CHAF*16
      SAVE /PYDAT2/,/PYDAT4/

C...Local R-hadron data arrays, to fill into the global ones.
      DIMENSION KFRH(20),KCHGRH(20),KANTRH(20)
      CHARACTER*16 CHRHA(20),CHRHB(20)
C...Codes.
      DATA KFRH/1000612,1000622,1000632,1000642,1000652,1006113,
     &1006211,1006213,1006223,1006311,1006313,1006321,1006323,
     &1006333,6*0/
C...Three times charge.
      DATA KCHGRH/3,0,3,0,3,0,3,3,6,0,0,3,3,0,6*0/
C...Existence of a distinct antiparticle.
      DATA KANTRH/14*1,6*0/
C...One possibility: hadron-like names.
      DATA CHRHA/'~T+','~T0','~T_s+','~T_c0','~T_b+','~T_dd10',
     &'~T_ud0+','~T_ud1+','~T_uu1++','~T_sd00','~T_sd10',
     &'~T_su0+','~T_su1+','~T_ss10',6*' '/
      DATA CHRHB/'~Tbar-','~Tbar0','~Tbar_s-','~Tbar_c0','~Tbar_b-',
     &'~Tbar_dd10','~Tbar_ud0-','~Tbar_ud1-','~Tbar_uu1--',
     &'~Tbar_sd00','~Tbar_sd10','~Tbar_su0-','~Tbar_su1-',
     &'~Tbar_ss10',6*' '/
C...Another possibility: flavour-contents-based names.
C      DATA CHRHA/'~t dbar','~t ubar','~t sbar','~t cbar','~t bbar',
C     &'~t dd1','~t ud0','~t ud1','~t uu1','~t sd0','~t sd1','~t su0',
C     &'~t su1','~t ss1',6*' '/
C      DATA CHRHB/'~tbar d','~tbar u','~tbar s','~tbar c','~tbar b',
C     &'~tbar dd1bar','~tbar ud0bar','~tbar ud1bar','~tbar uu1bar',
C     &'~tbar sd0bar','~tbar sd1bar','~tbar su0bar','~tbar su1bar',
C     &'~tbar ss1bar',6*' '/

C...Fill in data.
      DO 100 I=1,14
        KC=400+I
        KCHG(KC,1)=KCHGRH(I)
        KCHG(KC,2)=0
        KCHG(KC,3)=KANTRH(I)
        KCHG(KC,4)=KFRH(I)
        CHAF(KC,1)=CHRHA(I)
        CHAF(KC,2)=CHRHB(I)
  100 CONTINUE

      RETURN
      END

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

C...PYSTFR
C...Fragments the string near to a stop, to form a stop-hadron,
C...by producing a new q-qbar pair.

      SUBROUTINE PYSTFR(IERR)

C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      INTEGER PYCOMP
C...Parameter statement to help give large particle numbers
C...(left- and righthanded SUSY, excited fermions).
      PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000)
C...Commonblocks.
      COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
      COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
      COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
C...Note that dimensions below grew from 4000 to 8000 in Pythia 6.2!
      COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
      COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
      COMMON/PYINT1/MINT(400),VINT(400)
      COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
      SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,
     &/PYINT2/
C...Local array.
      DIMENSION PSUM(5),PSAV(5),IPOSST(10)

C...Default is no error.
      IERR=0

C...Free parameter: max kinetic energy in gluino-hadron.
      PMKIN=0.5D0

C...Free parameter: part of stop mass that does not participate
C...in weak decay.
      PMINAC=0.5D0

C...Switch off popcorn baryon production. (Not imperative, but more
C...failed events when popcorn is allowed.)
      MSTJ12=MSTJ(12)
      MSTJ(12)=1

C...Convenient shorthand.
      KFST=KSUSY1+6
      KCST=PYCOMP(KFST)
      KFGL=KSUSY1+21

C...Loopback point for serious problems, with new try.
      LOOP=0
      CALL PYEDIT(21)
      CHGSAV=PYP(0,6)
   90 LOOP=LOOP+1
      IF(LOOP.GT.1) CALL PYEDIT(22)

C...Give up when too much problems.
      IF(LOOP.GT.5) THEN
        WRITE(*,*) ' Problematical event skipped'
        IERR=1
        RETURN
      ENDIF

C...Take copy of string system(s).
      NOLD=N
      NSTOP=0
      DO 120 I=1,NOLD
        ICOPY=0
        IF(K(I,1).EQ.2) ICOPY=1
        IF(K(I,1).EQ.1.AND.I.GE.2) THEN
          IF(K(I-1,1).EQ.12) ICOPY=1
        ENDIF
        IF(ICOPY.EQ.1) THEN
          N=N+1
          DO 100 J=1,5
            K(N,J)=K(I,J)
            P(N,J)=P(I,J)
            V(N,J)=V(I,J)
  100     CONTINUE
          K(I,1)=K(I,1)+10
          K(I,4)=N
          K(I,5)=N
          K(N,3)=I
          IF(IABS(K(I,2)).EQ.KFST) THEN
            NSTOP=NSTOP+1
            IPOSST(NSTOP)=N
          ENDIF
        ENDIF
  120 CONTINUE
      NTMP=N

C...Loop over (up to) two stops per event.
C...Identify position of stop (randomize order of treatment).
      IRNST=INT(1.5D0+PYR(0))
      DO 300 ISTOP=1,NSTOP
        IST=IPOSST(1)
        IF(NSTOP.EQ.2.AND.ISTOP.NE.IRNST) IST=IPOSST(2)

C...Identify range of partons on string the stop belongs to.
        IMIN=IST+1
  140   IMIN=IMIN-1
        IF(K(IMIN-1,1).EQ.2) GOTO 140
        IMAX=IST-1
  150   IMAX=IMAX+1
        IF(K(IMAX,1).EQ.2) GOTO 150
        IOTHER=IMAX
        IF(IST.EQ.IMAX) IOTHER=IMIN

C...Find mass of this stop-string.
        DO 170 J=1,5
          PSUM(J)=0D0
          DO 160 I=IMIN,IMAX
            PSUM(J)=PSUM(J)+P(I,J)
  160     CONTINUE
  170   CONTINUE
        PSUM(5)=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-
     &  PSUM(3)**2))

C...If low-mass, then consider stop-hadron already formed.
        IF(PSUM(5).LE.P(IST,5)+P(IOTHER,5)+PMKIN) THEN
          DO 180 I=IMIN,IMAX
            K(I,1)=2
            IF(I.EQ.IMAX) K(I,1)=1
            IF(I.NE.IST) THEN
              DO 175 J=1,5
                P(IST,J)=P(IST,J)+P(I,J)
                P(I,J)=0D0
  175         CONTINUE
            ENDIF
  180     CONTINUE
          P(IST,5)=SQRT(MAX(0D0,P(IST,4)**2-P(IST,1)**2-P(IST,2)**2-
     &    P(IST,3)**2))
          GOTO 300
        ENDIF

C...Else break string by production of new qqbar pair.
C...(Also diquarks allowed, but not popcorn.)
        INFLAV=ISIGN(4,K(IST,2))
        CALL PYDCYK(INFLAV,0,KFSAV,KFDUM)
        KFSAV=ISIGN(MOD(IABS(KFSAV),10000),KFSAV)
        MSTJ(93)=1
        PMSAV=PYMASS(KFSAV)

C...Mass of stop-hadron.
        PMSSAV=P(IST,5)
        PMSHAD=P(IST,5)+PMSAV

C...Pick momentum sharing according to fragmentation function as if bottom.
        PMBSAV=PARF(105)
        PARF(105)=PMSSAV
        CALL PYZDIS(5,0,PMSHAD**2,ZST)
        PARF(105)=PMBSAV
        ZST=MAX(0.9D0,MIN(0.9999D0,ZST))
        DO 190 J=1,5
          PSAV(J)=(1D0-ZST)*P(IST,J)
          P(IST,J)=ZST*P(IST,J)
  190  CONTINUE

C...Recoiling parton from which to shuffle momentum. System momentum.
        IF(IST.EQ.IMIN) IREC=IST+1
        IF(IST.EQ.IMAX) IREC=IST-1
  200   DO 210 J=1,4
          PSUM(J)=P(IST,J)+P(IREC,J)
  210   CONTINUE

C...Boost to rest frame of system, and align stop along +z axis.
        CALL PYROBO(IST,IST,0D0,0D0,-PSUM(1)/PSUM(4),
     &  -PSUM(2)/PSUM(4),-PSUM(3)/PSUM(4))
        CALL PYROBO(IREC,IREC,0D0,0D0,-PSUM(1)/PSUM(4),
     &  -PSUM(2)/PSUM(4),-PSUM(3)/PSUM(4))
        PHI=PYANGL(P(IST,1),P(IST,2))
        CALL PYROBO(IST,IST,0D0,-PHI,0D0,0D0,0D0)
        CALL PYROBO(IREC,IREC,0D0,-PHI,0D0,0D0,0D0)
        THETA=PYANGL(P(IST,3),P(IST,1))
        CALL PYROBO(IST,IST,-THETA,0D0,0D0,0D0,0D0)
        CALL PYROBO(IREC,IREC,-THETA,0D0,0D0,0D0,0D0)

C...Calculate new kinematics in this frame, for desired stop hadron mass.
        ETOT=P(IST,4)+P(IREC,4)
        PMREC=P(IREC,5)
        IF(K(IREC,2).NE.21.AND.IABS(K(IREC,2)).NE.KFST) THEN
          MSTJ(93)=1
          PMREC=PYMASS(K(IREC,2))
        ENDIF
        IF(ETOT.GT.PMSHAD+PMREC) THEN
          IFAIL=0
          PZNEW=0.5D0*SQRT(MAX(0D0,(ETOT**2-PMSHAD**2-PMREC**2)**2-
     &    4D0*PMSHAD**2*PMREC**2))/ETOT
          P(IST,3)=PZNEW
          P(IST,4)=SQRT(PZNEW**2+PMSHAD**2)
          P(IST,5)=PMSHAD
          P(IREC,3)=-PZNEW
          P(IREC,4)=SQRT(PZNEW**2+PMREC**2)
          P(IREC,5)=PMREC

C...If not enough momentum, take what can be taken.
        ELSE
          IFAIL=1
          P(IST,3)=0D0
          P(IST,4)=ETOT-PMREC
          P(IST,5)=P(IST,4)
          P(IREC,3)=0D0
          P(IREC,4)=PMREC
          P(IREC,5)=PMREC
        ENDIF

C...Bost back to lab frame.
        CALL PYROBO(IST,IST,THETA,PHI,PSUM(1)/PSUM(4),
     &  PSUM(2)/PSUM(4),PSUM(3)/PSUM(4))
        CALL PYROBO(IREC,IREC,THETA,PHI,PSUM(1)/PSUM(4),
     &  PSUM(2)/PSUM(4),PSUM(3)/PSUM(4))

C...Loop back when not enough momentum could be shuffled.
C...(As long as there is something left.)
        IF(IFAIL.EQ.1) THEN
          IF(IST.EQ.IMIN.AND.IREC.LT.IMAX) THEN
            IREC=IREC+1
            GOTO 200
          ELSEIF(IST.EQ.IMAX.AND.IREC.GT.IMIN) THEN
            IREC=IREC-1
            GOTO 200
          ENDIF
        ENDIF

C...Particle code for stop-hadron.
        KFSTHD=0
        IF(K(IST,2).GT.0) THEN
          IF(KFSAV.LE.-1.AND.KFSAV.GE.-5) KFSTHD=KSUSY1+600-10*KFSAV+2
          IF(KFSAV.GE.1103.AND.KFSAV.LE.3303) KFSTHD=KSUSY1+6000+
     &    (KFSAV/10)+MOD(KFSAV,10)
        ELSE
          IF(KFSAV.GE.1.AND.KFSAV.LE.5) KFSTHD=KSUSY1+600+10*KFSAV+2
          IF(KFSAV.LE.-1103.AND.KFSAV.GE.-3303) KFSTHD=KSUSY1+6000+
     &    (IABS(KFSAV)/10)+MOD(IABS(KFSAV),10)
          KFSTHD=-KFSTHD
        ENDIF
        IF(KFSTHD.EQ.0) THEN
          WRITE(*,*) ' Failed to find R-hadron code from ',
     &    K(IST,2),KFSAV
          IERR=1
          RETURN
        ENDIF

C...New slot at end of record for stop-hadron
        DO 230 J=1,5
          K(N+1,J)=0
          P(N+1,J)=P(IST,J)
          V(N+1,J)=V(IST,J)
  230   CONTINUE
        K(N+1,1)=5+ISTOP
        K(N+1,2)=KFSTHD
        K(N+1,3)=K(IST,3)
        N=N+1

C...Code and momentum of new string endpoint.
        K(IST,2)=-KFSAV
        DO 240 J=1,5
          P(IST,J)=PSAV(J)
  240   CONTINUE

C...End of loop over two stops.
  300 CONTINUE

C...Cleanup: remove zero-energy gluons.
      NNOW=N
      N=NOLD
      DO 330 I=NOLD+1,NNOW
        IF(K(I,2).EQ.21.AND.P(I,4).LT.1D-10) THEN
        ELSEIF(I.EQ.N+1) THEN
          N=N+1
        ELSE
          N=N+1
          DO 320 J=1,5
            K(N,J)=K(I,J)
            P(N,J)=P(I,J)
            V(N,J)=V(I,J)
  320     CONTINUE
        ENDIF
  330 CONTINUE
      NNOW=N

C...Check that no low-mass system of diquark-antidiquark kind,
C...or very low-mass of any kind.
      KFBEG=0
      DO 332 J=1,5
        PSUM(J)=0D0
  332 CONTINUE
      DO 338 I=NOLD+1,NNOW
        DO 334 J=1,4
          PSUM(J)=PSUM(J)+P(I,J)
  334   CONTINUE
        IF(KFBEG.EQ.0) THEN
          KFBEG=IABS(K(I,2))
          MSTJ(93)=1
          PSUM(5)=PSUM(5)+PYMASS(K(I,2))
        ELSEIF(K(I,1).EQ.1) THEN
          KFEND=IABS(K(I,2))
          MSTJ(93)=1
          PSUM(5)=PSUM(5)+PYMASS(K(I,2))
          DELTA=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-
     &    PSUM(3)**2))-PSUM(5)
          IF(KFBEG.GT.10.AND.KFBEG.LT.10000.AND.KFEND.GT.10.AND.
     &    KFEND.LT.10000.AND.DELTA.LT.PARJ(32).AND.(KFBEG.NE.21
     &    .AND.KFEND.NE.21)) GOTO 90
          IF(DELTA.LT.0D0) GOTO 90
          KFBEG=0
          DO 336 J=1,5
            PSUM(J)=0D0
  336     CONTINUE
        ENDIF
  338 CONTINUE

C...Finished with stop hadronization. Restore baryon production model.
      MSTJ(12)=MSTJ12

C...Now hadronize everything else. Some cheating to allow sensible
C...momentum shuffling.
      MSTJ16=MSTJ(16)
      MSTJ(16)=0
      CALL PYEXEC
      MSTJ(16)=MSTJ16
      IF(MSTU(24).NE.0) THEN
        WRITE(*,*) ' Event to be skipped'
        IERR=1
      ENDIF

      RETURN
      END

max_stars_repo_name: ckamtsikis/cmssw

max_issues_repo_name: ckamtsikis/cmssw

max_forks_repo_name: ckamtsikis/cmssw


text:
 module Mod_sld_ExternalForces
   use typre
   use Mod_sld_BaseElmope
   implicit none
   private
   public SetPointersExternalForces

   integer(ip), allocatable :: kfl_IsSet

contains

   !----------------------------------------------------------------------------
   !Setting Pointers

   subroutine SetPointersExternalForces(itask)
      implicit none
      integer(ip) :: itask
      select case (itask)

      case(0)
         allocate(kfl_IsSet)
         call a%Memor%allocObj(0,'kfl_IsSet','InitProcedurePointer',1)
         kfl_IsSet = -1

      case(1)
         if (kfl_IsSet == -1) then
            kfl_IsSet = 1

            ProcPointer%ExternalForces  => sldForces
         endif

      case(100)
         deallocate(kfl_IsSet)
         call a%Memor%deallocObj(0,'kfl_IsSet','InitProcedurePointer',1)

      end select
   end subroutine

   !---------------------------------------------------------------------------
   !Computation Subroutines
   subroutine  sldForces
      implicit none
      !Compute vector of external forces
      call sld_ComputeExternalForces(e,densi,a%grnor,a%gravi,a%traction,elext,dvol,a%force_factor)
   end subroutine

end module

max_stars_repo_name: ciaid-colombia/InsFEM

max_issues_repo_name: ciaid-colombia/InsFEM

max_forks_repo_name: ciaid-colombia/InsFEM


text:
      SUBROUTINE CBALEV1
C
C CHANGE RECORD
C **  SUBROUTINES CBALEV CALCULATE GLOBAL VOLUME, MASS, MOMENTUM,
C **  AND ENERGY BALANCES
C
      USE GLOBAL
      IF(NBALE.GT.1) RETURN
C
C **  INITIALIZE VOLUME, SALT MASS, DYE MASS, MOMENTUM, KINETIC ENERGY
C **  AND POTENTIAL ENERGY, AND ASSOCIATED FLUXES
C
      VOLBEGE=0.
      SALBEGE=0.
      DYEBEGE=0.
      UMOBEGE=0.
      VMOBEGE=0.
      UUEBEGE=0.
      VVEBEGE=0.
      PPEBEGE=0.
      BBEBEGE=0.
      VOLOUTE=0.
      SALOUTE=0.
      DYEOUTE=0.
      UMOOUTE=0.
      VMOOUTE=0.
      UUEOUTE=0.
      VVEOUTE=0.
      PPEOUTE=0.
      BBEOUTE=0.
      DO L=2,LA
        LN=LNC(L)
        VOLBEGE=VOLBEGE+SPB(L)*DXYP(L)*H1P(L)
        UMOBEGE=UMOBEGE+SPB(L)*0.5*DXYP(L)*H1P(L)
     &      *(DYIU(L)*UHDY1E(L)/H1U(L)+DYIU(LEAST(L))*UHDY1E(LEAST(L))/H1U(LEAST(L)))
        VMOBEGE=VMOBEGE+SPB(L)*0.5*DXYP(L)*H1P(L)
     &      *(DXIV(L)*VHDX1E(L)/H1V(L)+DXIV(LN)*VHDX1E(LN)/H1V(LN))
        PPEBEGE=PPEBEGE+SPB(L)*0.5*DXYP(L)
     &      *(GI*P1(L)*P1(L)-G*BELV(L)*BELV(L))
      ENDDO
      AMOBEGE=SQRT(UMOBEGE*UMOBEGE+VMOBEGE*VMOBEGE)
      DO K=1,KC
        DO L=2,LA
          LN=LNC(L)
          SALBEGE=SALBEGE+SCB(L)*DXYP(L)*H1P(L)*SAL1(L,K)*DZC(K)
          DYEBEGE=DYEBEGE+SCB(L)*DXYP(L)*H1P(L)*DYE1(L,K)*DZC(K)
          UUEBEGE=UUEBEGE+SPB(L)*0.125*DXYP(L)*H1P(L)*DZC(K)
     &        *( (U1(L,K)+U1(LEAST(L),K))*(U1(L,K)+U1(LEAST(L),K)) )
          VVEBEGE=VVEBEGE+SPB(L)*0.125*DXYP(L)*H1P(L)*DZC(K)
     &        *( (V1(L,K)+V1(LN,K))*(V1(L,K)+V1(LN,K)) )
          BBEBEGE=BBEBEGE+SPB(L)*GP*DXYP(L)*H1P(L)*DZC(K)*( BELV(L)
     &        +0.5*H1P(L)*(Z(K)+Z(K-1)) )*B1(L,K)
        ENDDO
      ENDDO
      RETURN
      END


text:
C    Copyright(C) 2008 Sandia Corporation.  Under the terms of Contract
C    DE-AC04-94AL85000 with Sandia Corporation, the U.S. Government retains
C    certain rights in this software
C
C    Redistribution and use in source and binary forms, with or without
C    modification, are permitted provided that the following conditions are
C    met:
C
C    * Redistributions of source code must retain the above copyright
C       notice, this list of conditions and the following disclaimer.
C
C    * Redistributions in binary form must reproduce the above
C      copyright notice, this list of conditions and the following
C      disclaimer in the documentation and/or other materials provided
C      with the distribution.
C
C    * Neither the name of Sandia Corporation nor the names of its
C      contributors may be used to endorse or promote products derived
C      from this software without specific prior written permission.
C
C    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
C    "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
C    LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
C    A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
C    OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
C    SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
C    LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
C    DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
C    THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
C    (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
C    OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
C
C=======================================================================
      SUBROUTINE RDSTEP (NDB, NCSTEP,
     &     NUMELB, IDELB, ISEVOK,
     &     TIME, VARGL, VARNP, VAREL,
     $     neldm)
C=======================================================================

C   --*** RDSTEP *** (GROPE) Read current database variables
C   --
C   --RDSTEP reads the variable data for the next time step from the
C   --database.
C   --
C   --Parameters:
C   --   NDB - IN - the database number
C   --   NCSTEP - IN/OUT - the current step number
C   --   NVARGL - IN - the number of global variables
C   --   NVARNP - IN - the number of nodal variables
C   --   NVAREL - IN - the number of element variables
C   --   NUMELB - IN - the number of elements per block
C   --   ISEVOK - IN - the element block variable truth table;
C   --      variable i of block j exists iff ISEVOK(i,j) is NOT 0
C   --   TIME - OUT - the time step time
C   --   VARGL - OUT - the global variables for the time step
C   --   VARNP - OUT - the nodal variables for the time step
C   --   VAREL - OUT - the element variables for the time step

      include 'exodusII.inc'
      include 'gr_dbnums.blk'

      INTEGER NUMELB(*)
      INTEGER IDELB(*)
      INTEGER ISEVOK(nvarel,*)
      REAL VARGL(*)
      REAL VARNP(numnp, *)
      REAL VAREL(numel, *)

      CHARACTER*80 ERRMSG

C ... Initialize variables to known value in case error on read
      TIME = -999.9
      CALL INIREA (NVARGL, -999.9, VARGL)
      CALL INIREA (NVARNP * NUMNP, -999.9, VARNP)
      CALL INIREA (NVAREL * NUMEL, -999.9, VAREL)

C ... Read the time for the specified step
      call exgtim(ndb, ncstep, time, ierr)
      if (ierr .ne. 0) go to 150

C ... Read the global variables (if any)
      if (nvargl .gt. 0) then
         call exggv (ndb, ncstep, nvargl, vargl, ierr)
         if (ierr .ne. 0) go to 170
      end if

C ... Read the nodal variables (if any)
      DO 120 I = 1, NVARNP
        call exgnv (ndb, ncstep, i, numnp, varnp(1,i), ierr)
        if (ierr .ne. 0) go to 180
 120  CONTINUE

C ... Read the element variables (if any)
      DO 140 I = 1, NVAREL
        IEL0 = 1
        DO 130 IELB = 1, NELBLK
          IF (ISEVOK(I,IELB) .NE. 0 .AND. numelb(ielb) .GT. 0) THEN
             call exgev (ndb, ncstep, i, idelb(ielb),
     &            numelb(ielb), varel(iel0,i), ierr)
             if (ierr .ne. 0) go to 190
          END IF
          IEL0 = IEL0 + NUMELB(IELB)
 130    CONTINUE
 140  CONTINUE

      RETURN

  150 CONTINUE
      WRITE (ERRMSG, 10000, IOSTAT=IDUM)
     &   'TIME on step', NCSTEP
      GOTO 200
  170 CONTINUE
      WRITE (ERRMSG, 10000, IOSTAT=IDUM)
     &   'GLOBAL VARIABLES on step', NCSTEP
      GOTO 200
  180 CONTINUE
      WRITE (ERRMSG, 10000, IOSTAT=IDUM)
     &   'NODAL VARIABLE', I, ' on step', NCSTEP
      GOTO 200
  190 CONTINUE
      WRITE (ERRMSG, 10000, IOSTAT=IDUM)
     &   'ELEMENT VARIABLE', I, ' in block', IELB, ' on step', NCSTEP
      GOTO 200
  200 CONTINUE
      CALL WDBERR (IERR, ERRMSG)

      RETURN

10000  FORMAT (5 (A, I10))
      END

max_stars_repo_name: milljm/seacas

max_issues_repo_name: milljm/seacas

max_forks_repo_name: milljm/seacas


! { dg-do compile }
!
! PR 56081: [4.7/4.8 Regression] Segfault ICE on select with bad case
!
! Contributed by Richard L Lozes <richard@lozestech.com>

  implicit none
  integer :: a(4)
  select case(a)   ! { dg-error "must be a scalar expression" }
  case (0)
  end select
end


text:
subroutine add(a, b, res)
  ! Example Fortran subroutine.
  ! Listing 3.13 in the book.
  integer, intent(in) :: a, b
  integer, intent(out) :: res
  res = a + b
end subroutine add

max_stars_repo_name: wilsonify/c-consumer

max_issues_repo_name: wilsonify/c-consumer

max_forks_repo_name: wilsonify/c-consumer


text:
!##############################################################################
!     ________  _____  ______________
!    / ____/  |/  / / / /_  __/  _/ /
!   / /_  / /|_/ / / / / / /  / // /
!  / __/ / /  / / /_/ / / / _/ // /___
! /_/   /_/  /_/\____/ /_/ /___/_____/
!
! Copyright 2020 Bharat Mahajan
!
! Licensed under the Apache License, Version 2.0 (the "License");
! you may not use this file except in compliance with the License.
! You may obtain a copy of the License at
!
!    http://www.apache.org/licenses/LICENSE-2.0
!
! Unless required by applicable law or agreed to in writing, software
! distributed under the License is distributed on an "AS IS" BASIS,
! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
! See the License for the specific language governing permissions and
! limitations under the License.
!
!> \brief       Vector module
!! \details     This module provides the Vector data structure (similar to
!!              C++ STL Vector) represented internally using an array of
!!              buckets, which is again an array.
!! \author      Bharat Mahajan
!! \date        Created: 05/27/2020
!
!##############################################################################

module Vectors

    use FMUTILBase

    implicit none

    private

    !> Default capacity of internal buckets
    integer, parameter :: DEFAULT_BKTCAP = 3

    !> Default number of buckets to create on vector capacity increase
    integer, parameter :: DEFAULT_NEWBKTSALLOCATED = 2

    !> Abstract vector element type that must be extended by user to
    !! define the type for the Vector elements
    type, abstract, public :: VecElem
    contains
        !> user must override this procedure to define the assignment operator
        !! for thir Vector element type
        procedure(assign_vecelem), deferred :: AssignVecElem
        !> Assignment operator for Vector Element type
        generic, public :: assignment(=) => AssignVecElem
    end type VecElem

    abstract interface
    !> Interface for the procedure invoked during assignment of VecElem
    subroutine assign_vecelem(lhs, rhs)
        import :: VecElem
        implicit none
        class(vecElem), intent(out) :: lhs
        class(VecElem), intent(in) :: rhs
    end subroutine assign_vecelem
    end interface

    !> Invalid Vector element type that is returned in case of an exception
    type, public, extends(VecElem) :: InvalidVecElem
        private
        !> This internal flag will be set true when there is any error in
        !! element query functions
        logical :: Invalid = .TRUE.
    contains
        private
        procedure, public :: AssignVecElem => assign_invalidelem
    end type InvalidVecElem

    !> Internal Bucket sturcture. Each bucket can contain a number of elements.
    type, private :: Bkt
        private
        !> Allocatable array to data in this bucket
        class(VecElem), dimension(:), allocatable :: BktData
        !> Flags indicating free slots in the bucket
        logical, dimension(:), allocatable :: SlotFree
    contains
        private
        !> Initializes the bucket struct
        procedure :: bktinit
        !> Clears the conrents of the bucket
        procedure :: bktclear
        !> Adds a new element to the bucket
        procedure :: add_bktelem
        !> Deletes an element from the bucket
        procedure :: del_bktelem
        !> Returns a pointer to the element
        procedure :: bktelem
        !> Returns a pointer to the slice of the bucket data
        procedure :: bktsliceptr
        !> Checks if the bucket is empty
        procedure :: is_bktempty
        !> Returns the current size of the bucket
        procedure :: bktsz
    end type Bkt

    !> Pointer to a single bucket
    type :: BktPtr
        type(Bkt), pointer :: pBkt => null()
    end type BktPtr

    !> Vector type
    type, public :: Vector

        private

        !> Status: 0-success, any negative value-exception condition
        integer, public :: status = 0

        !> Flag to indicate Vector storage has been allocated
        logical :: StorageAllocated = .FALSE.

        !> Number of new buckets to create on Vector capacity increase
        integer :: NewBktsToAllocate = DEFAULT_NEWBKTSALLOCATED

        !> Each bucket capacity
        integer :: BktCap = DEFAULT_BKTCAP

        !> Number of buckets that currently contain data
        integer :: UsedBkts = 0

        !> Number of buckets that are currently allocated
        integer :: AllocatedBkts = 0

        !> Mold element to be used for memory allocation
        class(VecElem), allocatable :: MoldElem

        !> Array of bucket pointers
        type(BktPtr), dimension(:), allocatable :: VecData

    contains

        private

        procedure :: AssignVector

        !> Assignment operator for the Vector type, this enables
        !! copying of RHS vector contents to LHS vector. Note that
        !! after this operation, LHS Vector will be an exact copy
        !! of the RHS vector including data and internal state.
        generic, public :: assignment(=) => AssignVector

        ! Internal procedures
        procedure :: create_newbkts
        procedure :: Index2Bkt

        !> Initialize the vector with different options and allocates memory
        procedure, public :: Init => initialize

        !> Returns size of the vector or number of elements stored
        procedure, public :: Size => vec_size

        !> Returns the current capacity of the vector
        procedure, public :: Capacity

        !> Returns number of non-empty internal buckets
        procedure, public :: NUsedBkts

        !> Reserve the requested storage minimum capacity by allocating
        !! new buckets if needed
        procedure, public :: Reserve

        !> Shrink the capacity by deallocating unused buckets if needed.
        !! It tries to make Capacity as close to Size as possible
        procedure, public :: ShrinkToFit

        !> Push one element at the back of the vector
        procedure, public :: PushBack => push_back

        !> Pop one element from the back of the vector
        procedure, public :: PopBack => pop_back

        !> Returns a pointer to the element with the given index (1-based)
        procedure, public :: ElemAt => elem_at

        !> Returns the element with the index-1
        procedure, public :: Front => elem_front

        !> Returns the element with the last index
        procedure, public :: Back => elem_back

        !> Returns an array containing vector elements within the
        !! requested lower and upper bounds. This is inefficient as it
        !! copies the requested contents in a new array and returns it
        procedure, public :: Slice => vec_slice

        !> Returns the pointer to the element array starting from the
        !! user-specified lower bound. If the upper bound is beyond the
        !! extent of the current data bucket, then the array is truncated
        !! at the the current bucket boundary. This is an efficient method
        !! as no copying of data is performed.
        procedure, public :: BktSlice => bkt_slice

        !> Inserts the element/elements at the given index and relocate
        !! elements at the later indices
        procedure, public :: Insert => elem_insert

        !> Delete the element/elements at the given index and relocate
        !! the elements at the later indices
        procedure, public :: Erase => elem_erase

        !> Clear the contents of the Vector but memory is not deallocated
        procedure, public :: Clear

        !> Frees up all the memory allocated
        final :: Destroy

    end type Vector

    contains

    !> Optional procedure to initialize Vector type and allocate internal
    !! storage. It can be used to modify the default settings for storage
    !! allocation. If Init is not called first, Vector is initialized
    !! using the default settings and storage is allocated on the first call to
    !! push data in the Vector. This procedure will only change the number
    !! of new buckets to create on Vector capacity increase if it is invoked
    !! after the first call to push data in the Vector.
    subroutine initialize(me, NewBktsToAllocate, BktCap, MoldElem)
        implicit none

        class(vector), intent(inout) :: me
        !> Number of new buckets to allocate on Vector's capacity expansion
        integer, intent(in), optional :: NewBktsToAllocate
        !> Each bucket capacity. Note that providing a value for the bucket capacity
        !! will have effect only if Vector is not already initialized.
        integer, intent(in), optional :: BktCap
        !> Element mold to use for allocating bucket's memory
        class(VecElem), intent(in), optional :: MoldElem

        ! Set the number of new buckets to allocate when last bucket is full
        if (present(NewBktsToAllocate)) me%NewBktsToAllocate = NewBktsToAllocate

        ! If Vector is already initialized, we are done
        if (me%StorageAllocated) return

        if (present(BktCap)) me%BktCap = BktCap

        ! if mold_elem is provided, then allocate initial buckets
        if (present(MoldElem)) then
            allocate(me%MoldElem, source=MoldElem)
            call me%create_newbkts(me%NewBktsToAllocate)
        end if
        ! If successful, start using the first bucket
        if (me%status == 0) then
            me%StorageAllocated = .TRUE.
            me%UsedBkts = 1
        end if
    end subroutine initialize

    !> Returns the total number of allocated elements in the Vector
    pure function vec_size(me)
        implicit none
        class(Vector), intent(in) :: me
        integer :: vec_size

        vec_size = 0
        ! if not allocated size is 0
        if ((.NOT. me%StorageAllocated) .OR. me%UsedBkts == 0) return

        ! N-1 full bkts and Nth partial filled bkts
        vec_size = (me%UsedBkts-1)*me%BktCap &
                    + me%VecData(me%UsedBkts)%pBkt%bktsz()
    end function vec_size

    !> Returns the total number of elements that can be saved in the Vector
    !! without any need for increasing the memory footprint
    pure function Capacity(me)
        implicit none
        class(Vector), intent(in) :: me
        integer :: Capacity

        Capacity = me%AllocatedBkts*me%BktCap
    end function Capacity

    !> Returns the total number of internal data buckets allocated
    !! by the Vector. Each bucket can contain multiple elements
    !! defined by its capacity
    pure function NUsedBkts(me)
        implicit none
        class(Vector), intent(in) :: me
        integer :: NUsedBkts

        NUsedBkts = me%UsedBkts
    end function NUsedBkts

    !> Increases the capcity of Vector to 'n' if the current capacity is smaller than 'n'
    subroutine Reserve(me, n)
        implicit none
        class(Vector), intent(inout) :: me
        !> Reserve space of the minimum 'n' elements
        integer, intent(in) :: n

        integer :: NumBkts

        real :: fracbkts

        ! required number of new bkts
        fracbkts = n
        NumBkts = ceiling(fracbkts/me%BktCap) - me%AllocatedBkts

        if (NumBkts > 0) then
            call me%create_newbkts(NumBkts)
        end if
    end subroutine Reserve

    !> Deallocate unused buckets to make Capacity as close to Size as possible
    subroutine ShrinkToFit(me)
        implicit none
        class(Vector), intent(inout) :: me

        type(BktPtr), dimension(:), allocatable :: tmp
        integer :: ctr

        ! deallocate if used bkts are less than allocated bkts
        if (me%UsedBkts < me%AllocatedBkts) then
            do ctr = me%Size()+1, me%AllocatedBkts
                if (associated(me%VecData(ctr)%pBkt)) deallocate(me%VecData(ctr)%pBkt)
                me%VecData(ctr)%pBkt => null()
            end do
            me%AllocatedBkts = me%UsedBkts
        end if

        if (me%AllocatedBkts < 1) then
            ! if all storage deallocated, then set the flag
            me%StorageAllocated = .FALSE.
            if (allocated(me%VecData)) deallocate(me%VecData, stat=me%status)
        else
            ! shrink the bucket pointer array
            allocate(tmp(1:me%AllocatedBkts), stat=me%status)
            if (me%status == 0) then
                tmp = me%VecData(1:me%AllocatedBkts)
                call move_alloc(from=tmp, to=me%VecData)
            end if
        end if
    end subroutine ShrinkToFit

    !> Returns a pointer to the element with the requested index (1-based)
    !! Pointer will not be associated in case of an exception
    function elem_at(me, Index) result(elem)
        implicit none
        class(Vector), intent(inout) :: me
        !> Index of the requested element
        integer, intent(in) :: Index
        !> pointer to the requested element
        class(VecElem), pointer :: elem

        integer :: BktNum, Offset

        ! compute bucket number and offset
        call me%Index2Bkt(Index, BktNum, Offset)

        if (BktNum > 0 .AND. BktNum <= me%UsedBkts &
            .AND. Offset > 0 .AND. Offset <= me%BktCap) then
            elem => me%VecData(BktNum)%pBkt%bktelem(Offset)
        else
            ! incorrect index
            elem => null()
        end if
    end function elem_at

    !> Returns the element with the index=1
    function elem_front(me) result(elem)
        implicit none
        class(Vector), intent(inout) :: me
        class(VecElem), allocatable :: elem

        allocate(elem, source=me%ElemAt(1))
    end function elem_front

    !> Returns the last element in the Vector
    function elem_back(me) result(elem)
        implicit none
        class(Vector), intent(inout) :: me
        class(VecElem), allocatable :: elem

        integer :: Index
        Index = (me%UsedBkts-1)*me%BktCap &
                        + me%VecData(me%UsedBkts)%pBkt%bktsz()
        allocate(elem, source=me%ElemAt(Index))
    end function elem_back

    !> Returns the element array within the requested lower and upper
    !! bounds. This is inefficient as it copies the requested slice of
    !! the Vector in an array and returns it. If bounds result in
    !! zero-length slice, an empty array of VecElem type is returned.
    function vec_slice(me, lower, upper, stride) result(arr)
        implicit none
        class(Vector), intent(inout) :: me

        !> Lower bound as m in MATLAB-like syntax Vector(m:n)
        integer, intent(in) :: lower
        !> Upper bound as n in MATLAB-like syntax Vector(m:n)
        !! + Can be a negative integer as '-|a|' where |a| < Vector size
        integer, intent(in) :: upper
        !> stride as in MATLAB-like syntax Vector(m:stride:n)
        !! + Default is 1
        integer, intent(in), optional :: stride
        !> Array of VecElem type containing the subsection of Vector
        class(VecElem), dimension(:), allocatable :: arr

        integer :: step, ctr, sz, vecsz
        integer, dimension(:), allocatable :: ElemIndices

        if (present(stride)) then
            step = stride
        else
            step = 1
        end if

        ! create indices of the requested elements
        ElemIndices = [(ctr, ctr = lower, upper, step)]

        ! allocate memory
        sz = size(ElemIndices)
        vecsz = me%Size()
        if (sz < 1 .OR. vecsz < 1 &
            .OR. ElemIndices(1) < 1 .OR. ElemIndices(1) > vecsz &
            .OR. ElemIndices(sz) < 1 .OR. ElemIndices(sz) > vecsz) then
            ! If Vector is empty or requested slice is 0 size then
            ! return 0-sized array
            allocate(InvalidVecElem:: arr(0), stat=me%status)
            return
        else
            allocate(arr(sz), mold=me%VecData(1)%pBkt%bktelem(1), &
                                                stat=me%status)
        end if

        ! fill the array with data to return
        do ctr = 1, sz
        block
            integer :: Bkt, Offset
            call me%Index2Bkt(ElemIndices(ctr), Bkt, Offset)
            arr(ctr) = me%VecData(Bkt)%pBkt%bktelem(Offset)
        end block
        end do
    end function vec_slice

    !> Returns a pointer to the Vector slice specified using the
    !! user-specified lower and upper bounds. If the requested slice
    !! is beyond the extent of the data bucket that contains the element
    !! corresponding to the lower bound, then the data array is truncated
    !! at the bucket boundary and the upper bound is updated to indicate the
    !! actual upper bound of data that can be referenced using the returned
    !! pointer. This is an efficient method as no copying of data is done.
    !! In case of an exception, the returned pointer will not be associated.
    function bkt_slice(me, lower, upper) result(ptr)
        implicit none
        class(Vector), intent(inout) :: me

        !> Lower bound as m in MATLAB-like syntax Vector(m:n)
        integer, intent(in) :: lower
        !> Upper bound as n in MATLAB-like syntax Vector(m:n)
        !! + Can be a negative integer as '-|a|' where |a| < Vector size
        !! + It is updated to return the index of the last element that
        !! can be referenced using the returned pointer if the Vector slice
        !! is not entirely contained in a single bucket.
        integer, intent(inout) :: upper
        !> Array of VecElem type containing the subsection of Vector
        class(VecElem), dimension(:), pointer :: ptr

        integer :: Bktl, Offsetl, Bktu, Offsetu, ub, vecsz, ctr
        logical :: BoundsValid

        ptr => null()

        ! check for bounds
        vecsz = me%Size()
        BoundsValid = .TRUE.
        if (lower < 1 .OR. lower > vecsz) BoundsValid = .FALSE.
        if ((upper > lower .AND. upper > vecsz) &
                .OR. upper < lower .AND. upper < 1) BoundsValid = .FALSE.

        if (BoundsValid) then
            call me%Index2Bkt(lower, Bktl, Offsetl)
            call me%Index2Bkt(upper, Bktu, Offsetu)
            ! check whether the both bounds lie in the same bucket
            if (Bktl /= Bktu) then
                ! truncate the slice to bucket boundary
                if (upper < lower) then
                    ! slice is from lower bound to start of the bucket
                    upper = (Bktl-1)*me%BktCap + 1
                    ptr => me%VecData(Bktl)%pBkt%bktsliceptr(Offsetl,1)
                else
                    ! slice is from lower bound to end of the bucket
                    upper = Bktl*me%BktCap
                    ptr => me%VecData(Bktl)%pBkt%bktsliceptr(Offsetl,me%BktCap)
                end if
            else
                ! slice is from lower to upper bound
                ptr => me%VecData(Bktl)%pBkt%bktsliceptr(Offsetl,Offsetu)
            end if
        end if
    end function bkt_slice

    !> Function to add an element at the back of the vector
    function push_back(me, velem) result(Index)
        implicit none
        class(Vector), intent(inout) :: me
        !> Element to add to the vector
        class(VecElem), intent(in) :: velem
        !> 0 on error, otherwise returns the position of the element
        integer :: Index

        integer :: offset

        Index = 0
        if (.NOT. me%StorageAllocated) then
            ! allocate buckets for the first time
            allocate(me%MoldElem, source=velem)
            call me%create_newbkts(me%NewBktsToAllocate)
            if (me%status /= 0) return
            ! use the newly created first bucket
            me%UsedBkts = 1
        end if

        ! extract the index of the last occupied slot in bucket
        if (me%AllocatedBkts > 0 .AND. me%UsedBkts < 1) me%UsedBkts = 1
        offset = me%VecData(me%UsedBkts)%pBkt%bktsz() + 1

        ! if bucket is full then allocate more buckets
        if (offset > me%BktCap) then
            ! allocate new buckets
            call me%create_newbkts(me%NewBktsToAllocate)
            if (me%status /= 0) return
            ! use the newly created bucket
            me%UsedBkts = me%UsedBkts + 1
            offset = 1
        end if

        ! copy the elem at the back of the bucket
        call me%VecData(me%UsedBkts)%pBkt%add_bktelem(offset, velem)
        Index = offset + (me%UsedBkts-1)*me%BktCap

    end function push_back

    !> Function to extract the last element of the vector
    function pop_back(me) result(velem)
        implicit none
        class(vector), intent(inout) :: me
        class(VecElem), allocatable :: velem

        integer :: bktind

        ! get the last element
        bktind = me%vecdata(me%UsedBkts)%pBkt%bktsz()
        allocate(velem, source=me%VecData(me%UsedBkts)%pBkt%bktelem(bktind))

        ! delete this element
        call me%VecData(me%UsedBkts)%pBkt%del_bktelem(bktind)

        ! if this bucket is empty, then update used bucket counter
        if (me%vecdata(me%UsedBkts)%pBkt%is_bktempty()) then
            me%UsedBkts = me%UsedBkts - 1
        end if
    end function pop_back

    !> Inserts the element/elements at the given index and relocate
    !! existing elements at the later indices. Very inefficient way
    !! to add elements to Vector unless elements are inserted after
    !! the last element.
    subroutine elem_insert(me, pos, NewElems, count)
        implicit none
        class(Vector), intent(inout) :: me
        !> Position at which the new elements are inserted (1-based index)
        !! Must be >= 1 and <= vector size
        integer, intent(in) :: pos
        !> Array of New Elements to be inserted
        class(VecElem), dimension(:), intent(in) :: NewElems
        !> If provided, NewElems are repeated count times before inserted
        !! Total number of elements inserted=count*size(NewElems)
        !! Default value is 1. Must be >= 1
        integer, intent(in), optional :: count

        integer :: countval, reqdslots, emptyslots, newbkts, ctr, sz, vecsz
        integer :: Bkt0, Offset0, Bkt1, Offset1, ctr1, ctr2
        real :: tmp

        countval = 1
        if (present(count)) countval = count

        ! if empty array is passed, nothing to be done
        sz = size(NewElems)
        vecsz = me%Size()
        if (sz < 1) return

        ! if vector is not already allocated, do it now
        if (.NOT. me%StorageAllocated) then
            ! allocate buckets for the first time
            allocate(me%MoldElem, source=NewElems(1))
            call me%create_newbkts(me%NewBktsToAllocate)
            if (me%status /= 0) return
            ! use the newly created first bucket
            me%UsedBkts = 1
        end if

        ! check for parameters
        if (pos < 1 .OR. countval < 1 .OR. ((pos-vecsz) > 1)) then
            me%status = -1
            return
        end if

        ! Expand Vector for new elements
        reqdslots = countval*sz
        emptyslots = me%Capacity() - me%Size()
        tmp = reqdslots - emptyslots
        newbkts = ceiling(tmp/me%BktCap)

        if (newbkts > 0) then
            ! allocate new buckets
            call me%create_newbkts(newbkts)
        end if

        ! First Bucket for the new elements
        call me%Index2Bkt(pos, Bkt0, Offset0)
        ! First Bucket for the moved elements
        call me%Index2Bkt(pos+countval*sz, Bkt1, Offset1)

        ! Move old element to the new empty locations
        reqdslots = me%Size() - pos + 1
        ctr1 = Bkt0
        ctr2 = Offset0
        do ctr = 1, reqdslots
            ! Move old element to the new empty location

            call me%VecData(Bkt1)%pBkt%add_bktelem(Offset1, &
                    me%VecData(Bkt0)%pBkt%bktelem(Offset0))

            call me%VecData(Bkt0)%pBkt%del_bktelem(Offset0)

            ! increment counters
            Offset0 = Offset0 + 1
            Offset1 = Offset1 + 1
            if (Offset0 > me%BktCap) then
                Offset0 = 1
                Bkt0 = Bkt0 + 1
            end if
            if (Offset1 > me%BktCap) then
                Offset1 = 1
                Bkt1 = Bkt1 + 1
            end if
        end do

        ! copy the new element in the old location
        Bkt0 = ctr1
        Offset0 = ctr2
        ctr1 = 1
        do ctr = 1, countval*sz
            ! copy the new element in the old location
            call me%VecData(Bkt0)%pBkt%add_bktelem(Offset0, NewElems(ctr1))
            ! increment counters
            ctr1 = ctr1 + 1
            if (ctr1 > sz) ctr1 = 1
            Offset0 = Offset0 + 1
            if (Offset0 > me%BktCap) then
                Offset0 = 1
                Bkt0 = Bkt0 + 1
            end if
        end do

        ! update the buckets used
        me%UsedBkts = me%usedBkts + newbkts

    end subroutine elem_insert

    !> Delete the element/elements between and including lower and upper
    !! bounds. The elements are moved to fill up empty locations. Very
    !! inefficient way to delete elements from Vector.
    subroutine elem_erase(me, lower, upper)
        implicit none
        class(Vector), intent(inout) :: me

        integer, intent(In) :: lower !< Lower bound
        !> Upper bound. All the elements witin lower and upper bounds
        !! are deleted. If upper is omitted only a single element with
        !! index=lower is deleted.
        integer, intent(In), optional :: upper

        integer :: sz, ctr, upperval
        integer :: Bkt0, Offset0, Bkt1, Offset1

        ! parameter checks
        sz = me%Size()
        if (lower < 1 .OR. lower > sz .OR. sz < 1) return

        if (present(upper)) then
            if (lower > upper) return
        end if

        ! Location of the first element to be deleted
        call me%Index2Bkt(lower, Bkt0, Offset0)

        ! Location of the element just after the last element to be deleted
        if (present(upper)) then
            upperval = upper + 1
            call me%Index2Bkt(upperval, Bkt1, Offset1)
        else
            upperval = lower + 1
            Bkt1 = Bkt0
            Offset1 = Offset0 + 1
            if (Offset1 > me%BktCap) then
                Offset1 = 1
                Bkt1 = Bkt1 + 1
            end if
        end if

        ! shift the other elements one by one
        do ctr = 1, (sz - upperval + 1)
            ! shift
            call me%VecData(Bkt0)%pBkt%add_bktelem(Offset0, &
                            me%VecData(Bkt1)%pBkt%bktelem(Offset1))

            ! increment counters
            Offset0 = Offset0 + 1
            Offset1 = Offset1 + 1
            if (Offset0 > me%BktCap) then
                Offset0 = 1
                Bkt0 = Bkt0 + 1
            end if
            if (Offset1 > me%BktCap) then
                Offset1 = 1
                Bkt1 = Bkt1 + 1
            end if
        end do

        ! Clear the empty slots in the last partially filled bkt
        if (Offset0 /= 1) then
            do ctr = Offset0, me%BktCap
                call me%VecData(Bkt0)%pBkt%del_bktelem(ctr)
            end do
            Bkt0 = Bkt0 + 1
        end if
        ! clear the extra buckets starting from Bkt0+1
        do ctr = Bkt0, Bkt1
            call me%VecData(ctr)%pBkt%bktclear()
        end do
        ! update number of used buckets
        me%UsedBkts = Bkt0 - 1

    end subroutine elem_erase

    !> Clear the contents of Vector but the bucket memory is not deallocated
    subroutine Clear(me)
        implicit none
        class(Vector), intent(inout) :: me

        integer :: ctr
        ! clear bucket slots
        do ctr = 1, me%UsedBkts
            call me%VecData(ctr)%pBkt%bktclear()
        end do
        ! used buckets are 0 now
        me%UsedBkts = 0
    end subroutine Clear

    !> Subroutine to allocate storage for a new bucket
    subroutine create_newbkts(me, NumBkts)
        implicit none
        class(Vector), intent(inout) :: me

        integer, intent(in) :: NumBkts

        type(BktPtr), dimension(:), allocatable :: tmp
        integer :: ctr

        ! allocate new bucket array
        allocate(tmp(me%AllocatedBkts+NumBkts), stat=me%status)

        if (me%status == 0) then
            ! if vector already has buckets
            if (me%StorageAllocated) then
                ! copy the previous bucket pointers
                tmp(1:me%AllocatedBkts) = me%VecData
            end if

            ! expand the bucket array
            call move_alloc(from=tmp, to=me%VecData)

            ! allocate storage for new buckets
            do ctr = 1, NumBkts
                allocate(me%VecData(me%AllocatedBkts+ctr)%pBkt, stat=me%status)
                call me%VecData(me%AllocatedBkts+ctr)%pbkt%bktinit(me%status, &
                                                me%BktCap, me%MoldElem)
                if (me%status /= 0) exit
            end do

            ! If the intended number of buckets are not allocated, init failed
            if (ctr > NumBkts) then
                me%AllocatedBkts = me%AllocatedBkts + ctr - 1
                me%StorageAllocated = .TRUE.
            else
                me%status = -1
            end if
        end if
    end subroutine create_newbkts

    !> Converts Vector index to bucket number and offset into the bucket
    pure subroutine Index2Bkt(me, Index, Bkt, BktOffset)
        implicit none
        class(Vector), intent(in) :: me

        integer, intent(in) :: Index        !< Given index
        integer, intent(out) :: Bkt         !< Bucket number
        integer, intent(out) :: BktOffset   !< Offset into a bucket

        real :: frac

        ! Bucket to which this index belongs
        frac = Index
        frac = frac/me%BktCap
        Bkt = ceiling(frac)

        ! Offset into the bucket
        BktOffset = Index - (Bkt-1)*me%BktCap
    end subroutine

    ! Do nothing for the invalid element assignement
    subroutine assign_invalidelem(lhs, rhs)
        implicit none
        class(InvalidVecElem), intent(out) :: lhs
        class(VecElem), intent(in) :: rhs
    end subroutine assign_invalidelem

    !> Subroutine for Vector assignment operator
    subroutine AssignVector(lhs, rhs)
        implicit none
        class(Vector), intent(out) :: lhs
        class(Vector), intent(in) :: rhs

        integer :: ctr

        ! we assign the contents by moving all the buckets of rhs to lhs

        ! allocate memory for buckets array
        allocate(lhs%VecData(size(rhs%VecData)))

        ! create buckets and mold elem
        allocate(lhs%MoldElem, source=rhs%MoldElem)
        do ctr = 1, rhs%AllocatedBkts
            allocate(lhs%VecData(ctr)%pBkt, source=rhs%VecData(ctr)%pBkt)
        end do

        ! copy Vector state
        lhs%status              = rhs%status
        lhs%StorageAllocated    = rhs%StorageAllocated
        lhs%NewBktsToAllocate   = rhs%NewBktsToAllocate
        lhs%BktCap              = rhs%BktCap
        lhs%UsedBkts            = rhs%UsedBkts
        lhs%AllocatedBkts       = rhs%AllocatedBkts

    end subroutine AssignVector

    !> Destructor
    subroutine Destroy(me)
        implicit none
        type(Vector), intent(inout) :: me

        integer :: ctr

        ! free up memory held up by all the buckets
        do ctr = 1, size(me%VecData)
            if (associated(me%VecData(ctr)%pBkt)) deallocate(me%VecData(ctr)%pBkt)
            me%VecData(ctr)%pBkt => null()
        end do
    end subroutine Destroy

    !> Bucket Type Methods

    subroutine bktinit(me, status, cap, mold_elem)
        implicit none
        class(Bkt), intent(inout) :: me
        integer, intent(out) :: status
        integer, intent(in) :: cap
        class(VecElem), intent(in) :: mold_elem

        allocate(me%SlotFree(cap), stat=status)
        allocate(me%BktData(cap), stat=status, mold=mold_elem)
        me%SlotFree = .TRUE.
    end subroutine bktinit

    subroutine add_bktelem(me, offset, elem)
        implicit none
        class(Bkt), intent(inout) :: me
        integer, intent(in) :: offset
        class(VecElem), intent(in) :: elem

        me%BktData(offset) = elem
        me%SlotFree(offset) = .FALSE.
    end subroutine add_bktelem

    subroutine del_bktelem(me, offset)
        implicit none
        class(Bkt), intent(inout) :: me
        integer, intent(in) :: offset

        me%SlotFree(offset) = .TRUE.
    end subroutine del_bktelem

    subroutine bktclear(me)
        implicit none
        class(Bkt), intent(inout) :: me

        me%SlotFree = .TRUE.
    end subroutine bktclear

    function bktelem(me, offset)
        implicit none
        class(Bkt), intent(in), target :: me
        integer, intent(in) :: offset
        class(VecElem), pointer :: bktelem

        if (.NOT. me%SlotFree(offset)) then
            bktelem => me%BktData(offset)
        else
            bktelem => null()
        end if
    end function bktelem

    function bktsliceptr(me, start_ind, end_ind)
        implicit none
        class(Bkt), intent(in), target :: me
        integer, intent(in) :: start_ind, end_ind
        class(VecElem), dimension(:), pointer :: bktsliceptr

        integer :: stride

        bktsliceptr => null()

        stride = 1
        if (start_ind > end_ind) stride = -1

        if (any(me%SlotFree(start_ind:end_ind:stride))) return

        bktsliceptr => me%BktData(start_ind:end_ind:stride)
    end function bktsliceptr

    pure function is_bktempty(me)
        implicit none
        class(Bkt), intent(in) :: me
        logical :: is_bktempty

        is_bktempty = .FALSE.
        if (all(me%SlotFree)) is_bktempty = .TRUE.
    end function is_bktempty

    pure function bktsz(me)
        implicit none
        class(Bkt), intent(in) :: me
        integer :: bktsz
        bktsz = count(.NOT. me%SlotFree)
    end function bktsz

end module Vectors

max_stars_repo_name: princemahajan/FMUTIL

max_issues_repo_name: princemahajan/FMUTIL

max_forks_repo_name: princemahajan/FMUTIL


text:
program allocatable_function

    use utils

    implicit none

    type particles_type
        real(rk), allocatable :: pos(:,:)
        real(rk), allocatable :: vel(:,:)
        real(rk), allocatable :: mass(:)
    end type particles_type

    type(particles_type) :: particles

    call initParticles(particles, 1000)

    print*, shape(particles % pos)
    print*, shape(particles % vel)
    print*, shape(particles % mass)

    call deallocateParticles(particles)

contains

subroutine initParticles(particles, n)

    type(particles_type), intent(inout) :: particles
    integer, intent(in) :: n

    allocate(particles % pos(3,n))
    allocate(particles % vel(3,n))
    allocate(particles % mass(n))

end subroutine initParticles

subroutine deallocateParticles(particles)

    type(particles_type), intent(inout) :: particles

    deallocate(particles % pos)
    deallocate(particles % vel)
    deallocate(particles % mass)

end subroutine deallocateParticles

end program allocatable_function

max_stars_repo_name: jonaslindemann/compute-course-public

max_issues_repo_name: jonaslindemann/compute-course-public

max_forks_repo_name: jonaslindemann/compute-course-public


text:
Hotwire is a Davis Music Scene rock group consisting of three 7th graders and one 9th grader.

Band Members: (from left to right)
  Theo  Grade 7 (Bass Guitar, Backup Vocals)
  Cole  Grade 7 (Lead Guitar, Backup Vocals)
  Brady  Grade 7 (Lead Vocals, Rhythm Guitar)
  Tyler  Grade 9 (Drums, Vocals)

Websites:
 http://www.myspace.com/hotwiredavis MySpace
 http://www.youtube.com/Corky2014 Facebook

 http://www.youtube.com/user/HotwireDavis YouTube

Upcoming Events:
Sept 11 2010: St Anthonys Fall Festival, 660 Florin Road, Sacramento CA 5.306:00pm

Previous Events:
Saturday Jun 2010:  Concert on the Green, Davis, CA
Saturday, April 17   PicnicStock, Davis, CA 	 234 Second St, 12:15  1pm
Saturday, April 17  Picnic Day, Davis, CA    Wellman Stage, 3:30pm  3:50pm,  http://picnicday.ucdavis.edu/content/welcome
Saturday, April 24  Schoolapooloza, Davis, CA  12:00  12:45pm, Varsity Theater, https://www.davisschoolsfoundation.org/index.php?pageSchoolapalooza_2010
Thursday, May 13  Celebrate Davis, Community Park, 4  8pm
Saturday, June 5th  Concert on the Green, Davis Blue & White Foundation Golf Tournament, 7:50  8:30pm, Wildhorse Golf Course http://www.golfdigestplanner.com/14820blueandwhitegolf/
March 5, 2010  Sacramento News & Review JAMMIES finals, Crest Theater Sacramento, CA
January 2010  Battle of the Bands, JAMMIES, Sacramento, Ca
December 2009  The Graduate, Davis CA
December  2009  The Refuge, Sacramento, Ca
October 2009  Concert on the Green, Davis, Ca
September 2009  HardRock Cafe, Sacramento, Ca
August 2009  Yolo County Fair, Woodland, Ca
August 2009  The Refuge, Sacramento, Ca
July 2009  St James School, Davis, Ca
May 2009   Schoolapalooza, Davis, Ca
June 2009  Harper Jr High, Davis, Ca
April 2009  Picnicstock, Davis, Ca
March 2009  Emerson Junior High Carnival, Davis, Ca
February 2009 Battle for the Bus (Natomas Charter School Benvenuti Auditorium), http://www.newsreview.com/sacramento/2009_jammies/event, Sacramento, Ca
February 2009  The Jammies Finals, Crest Theatre, http://www.newsreview.com/sacramento/2009_jammies/event, Sacramento, Ca
February 2009  Good Day Sacramento News Show
January 2009  Jammies Battle of the Band, Davis High School, http://www.newsreview.com/sacramento/2009_jammies/event, Davis, Ca

Original Songs:
Go, Super Sonic Sound, In the Darkness,
Peace Bomb,
No More Promises,
Into Your Mind,
The United Nations, Camilo, and others

Style and Comparable To:
Rock/Indie Rock: GreenDay, Buzzcocks, Weezer, Jet

Influences:
Green Day, The Who, AC/DC, Weezer, Jet, U2, Guns ‘N Roses

Recording Projects:
Check out Hotwires myspace page for recordings of latest songs.

Brief History:
Started in May 2008, Hotwire rocks each and every venue with an exciting and energetic set list of originals and covers. The rockin is far beyond the bands Junior High years, and their music and talents excites audiences whenever they play. The band has played multiple gigs over the last three years, including competing at the 2009 and 2010 Sacramento News and Review Jammies competition at the historic Crest Theater in Sacramento, with au audience of a thousand people. The band has also played on Good Morning Sacramento news show along with gigs at UCD Picnic Day, Yolo County Fair, and a host of other venues in the Sacramento area. Currently, the band is recording their second song with David Stevenson Fisher.

Hotwire Press & Accolades:
  http://www.sacbee.com/entertainment/story/2173975.html Sac Bee
  http://www.davisvoice.com/2009/08/rnrvirusstrikesfourdaviskids.html Davis Voice
  http://search.davisenterprise.com/display.php?id50238 Davis Enterprise

Contact Information:
acorcoran1@live.com