text:
!*******************************************************************
!                                                                  *
      SUBROUTINE EL33INT(JJJA,JJJB,JA,JB,JC,IREZ,JJA,JJB,JJC,JJD   &
                                                 ,ICOLBREI,INTERACT)
!                                                                  *
!   --------------  SECTION METWO    SUBPROGRAM 08  -------------  *
!                                                                  *
!     THIS PACKAGE EVALUATED THE CASES - 2313, 3231, 3213, 2331    *
!                                                   ( + + - - ),   *
!     WHICH APPEARS IN CALCULATION MATRIX ELEMENTS BETWEEN         *
!     CONFIGURATIONS:                               N'1 = N1 - 1   *
!                                                   N'2 = N2 + 1   *
!                                                                  *
!     SUBROUTINE CALLED: COULOM,EILE,ITREXG,IXJTIK,                *
!                      JFAZE,PERKO2,RECO,REC3                      *
!                                                                  *
!   Written by  G. Gaigalas                   NIST, December 2015  *
!                                                                  *
!*******************************************************************
!
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY:  DOUBLE
      USE CONS_C
      USE m_C
      USE orb_C
      USE trk_C
!-----------------------------------------------
!   I n t e r f a c e   B l o c k s
!-----------------------------------------------
      USE eile_I
      USE reco_I
      USE rec3_I
      USE perko2_I
      USE itrexg_I
      USE itrig_I
      USE ixjtik_I
!      USE jfaze_I
      USE snrc_I
!      USE gg1233_I
      USE coulom_I
!      USE speak_I
!      USE cxk_I
!      USE talk_I
!      USE sixj_I
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER, INTENT(IN) :: JJJA,JJJB,JA,JB,JC,IREZ,JJA,JJB,JJC,JJD &
                                                        ,ICOLBREI
      INTEGER, INTENT(OUT) :: INTERACT
!      DIMENSION PMGG(30),RAGG(30),J(3)
!      DIMENSION CONE(12,20),S(12),IS(4),KAPS(4),KS(4)
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: IA,IB,IC,IAT,II,IIA,IIB,IIC,IID,IP1,IP2,IG1,IG2,   &
!                 IKK,INN,I1,I2,I3,I4,IBRD,IBRE,IFAZ,IFAZP,IFAZFRCS, &
                 IKK,INN,I1,I2,I3,I4,IBRD,IBRE,IFAZ,IFAZP, &
                 JAA,JBB,JCC,JB1,J12,KRA,KRA1,L1,L2,L3,ND1,ND2,NE1, &
                 NE2,N,NN,NU,NUP1,MU
      INTEGER :: INTERACT1, INTERACT2
      INTEGER, DIMENSION(3) :: J
      INTEGER, DIMENSION(4) :: IS,KAPS,KS
!      REAL(DOUBLE)          :: A1,AA,AB,BB,QM1,QM2,QM3,QM4,RAG,RECC,SI
      REAL(DOUBLE)          :: A1,AA,AB,BB,RAG,RECC,SI
      REAL(DOUBLE), DIMENSION(12) :: S
!      REAL(DOUBLE), DIMENSION(30) :: PMGG,RAGG
      REAL(DOUBLE), DIMENSION(30) :: PMGG
!      REAL(DOUBLE), DIMENSION(12,20) :: CONE
!-----------------------------------------------
      INTERACT = 0
      IF(NPEEL.LE.1)RETURN
      CALL EILE(JA,JB,JC,JAA,JBB,JCC)
      CALL RECO(JAA,JCC,JBB,JBB,2,IAT)
      IF(IAT.EQ.0)RETURN
      IA=JLIST(JA)
      IB=JLIST(JB)
      IC=JLIST(JC)
      IIA=JLIST(JJA)
      IIB=JLIST(JJB)
      IIC=JLIST(JJC)
      IID=JLIST(JJD)
!      QM1=HALF
!      QM2=-HALF
!      QM3=HALF
!      QM4=-HALF
      CALL PERKO2(JA,JB,JC,JA,3)
      J(1)=ID1(3)
      J(2)=ID2(3)
      J(3)=ID3(3)
      L1=(J(1)+1)/2
      L2=(J(2)+1)/2
      L3=(J(3)+1)/2
      IP1=ITREXG(J(2),J(1),J(3),J(3),IKK)+1
      IF(IKK.LE.0)RETURN
      IG1=IP1+IKK-1
      IF (ICOLBREI .EQ. 2) THEN
        IS(1)=IIA
        IS(2)=IIB
        IS(3)=IIC
        IS(4)=IID
        KAPS(1)=2*NAK(IS(1))
        KAPS(2)=2*NAK(IS(2))
        KAPS(3)=2*NAK(IS(3))
        KAPS(4)=2*NAK(IS(4))
        KS(1)=IABS(KAPS(1))
        KS(2)=IABS(KAPS(2))
        KS(3)=IABS(KAPS(3))
        KS(4)=IABS(KAPS(4))
        CALL SNRC(IS,KAPS,KS,ND1,ND2,NE1,NE2,IBRD,IBRE)
        IF(IBRD .LE. 0 .AND. IBRE .LE. 0)RETURN
!        DO II=1,20
!          CONE(1,II) =ZERO
!          CONE(2,II) =ZERO
!          CONE(3,II) =ZERO
!          CONE(4,II) =ZERO
!          CONE(5,II) =ZERO
!          CONE(6,II) =ZERO
!          CONE(7,II) =ZERO
!          CONE(8,II) =ZERO
!          CONE(9,II) =ZERO
!          CONE(10,II)=ZERO
!          CONE(11,II)=ZERO
!          CONE(12,II)=ZERO
!        END DO
      END IF
      DO I4=IP1,IG1,2
        KRA=(I4-1)/2
        KRA1=KRA+1
        IF(KRA1.GT.30)GO TO 10
        PMGG(KRA1)=ZERO
        CALL REC3(JB,JA,JC,J(2),J(1),KRA*2,0,IAT,RECC)
        IF(IAT.EQ.0) CYCLE
!        CALL GG1233(IK2,IK1,IK3,BK2,BK1,BK3,ID2,ID1,ID3,BD2,  &
!                    BD1,BD3,KRA,QM1,QM2,QM3,QM4,RAG)
!        IF(DABS(RAG).LT.EPS) CYCLE
!        RAGG(KRA1)=RAG
!        CALL REC3(JB,JA,JC,J(2),J(1),KRA*2,1,IAT,RECC)
!        PMGG(KRA1)=RECC
        PMGG(KRA1)=ONE
      END DO
!      IFAZP=JFAZE(JB,JA,JC,JC)
!
!     TRANSFORM FANO & RACAH PHASE CONVENTION
!     TO CONDON & SHORTLEY PHASE CONVENTION
!
!      IFAZFRCS=1
!      IFAZ=IK1(5)*IK1(4)+IK2(5)*IK2(4)-ID1(5)*ID1(4)-ID2(5)*ID2(4)
!      IF((IFAZ/4)*4.NE.IFAZ)IFAZFRCS=-IFAZFRCS
!
!      IF(JA.GT.JB) THEN
!        JAA=JB
!        JBB=JA
!      ELSE
!        JAA=JA
!        JBB=JB
!      END IF
!      NN=0
!      JB1=JBB-1
!      DO II=JAA,JB1
!        INN=JLIST(II)
!        NN=NQ1(INN)+NN
!      END DO
!      IF((NN/2)*2.EQ.NN)IFAZP=-IFAZP
      IF(IREZ.EQ.2)GO TO 5
! * * *                      * * *                      * * *
!     CASES 2313   + + - -        TRANSFORM TO  2133   + - + -
!           3231                                2133
!
    6 CONTINUE
      DO I1=IP1,IG1,2
        KRA=(I1-1)/2
        KRA1=KRA+1
        IF(KRA1.GT.30)GO TO 10
        IF (ICOLBREI .EQ. 1) THEN
          INTERACT1 = 0
          CALL COULOM(L2,L3,L1,L3,ID2(5),ID3(5),ID1(5),ID3(5),KRA,A1)
          IF(DABS(A1).LT.EPS) CYCLE
          INTERACT1 = 1
        END IF
        AA=PMGG(KRA1)
        IF(DABS(AA).LT.EPS) CYCLE
!        AA=AA*RAGG(KRA1)
!        IF(DABS(AA).LT.EPS) CYCLE
!        AA=AA/DSQRT(DBLE(I1))
!        AA=AA*DBLE(IFAZP)
        IF (ICOLBREI .EQ. 1) THEN
           INTERACT = INTERACT1
           IF(INTERACT .GT. 0) RETURN
!          BB=A1*AA*DBLE(IFAZFRCS)
!          CALL SPEAK(JJJA,JJJB,IIA,IIB,IIC,IID,KRA,BB)
        ELSE IF (ICOLBREI .EQ. 2) THEN
           INTERACT = 1
           RETURN
!          N=(KRA-ND1)/2+1
!          CALL CXK(S,IS,KAPS,KRA,KRA,2,1)
!          IF(DABS(S(1)).GT.EPS) THEN
!            BB=S(1)*AA
!            IF(DABS(BB).GT.EPS)                    &
!          CALL TALK(JJJA,JJJB,KRA,IS(1),IS(3),IS(2),IS(4),3,BB)
!          END IF
        END IF
      END DO
      IF(IREZ.EQ.2) GO TO 7
! * * *                      * * *                      * * *
!     CASES 3213   + + - -        TRANSFORM TO  2133   + - + -
!           2331                                2133
!
    5 IP2=ITREXG(J(3),J(1),J(2),J(3),IKK)+1
      IF(IKK.LE.0) RETURN
      IG2=IP2+IKK-1
      DO I2=IP2,IG2,2
        KRA=(I2-1)/2
        IF(KRA.GT.30)GO TO 10
        IF (ICOLBREI .EQ. 1) THEN
          INTERACT1 = 0
          CALL COULOM(L3,L2,L1,L3,ID3(5),ID2(5),ID1(5),ID3(5),KRA,A1)
          IF(DABS(A1).LT.EPS) CYCLE
          INTERACT1 = 1
        END IF
        AB=ZERO
        INTERACT2 = 0
        DO I3=IP1,IG1,2
          J12=(I3-1)/2
          KRA1=J12+1
          IF(KRA1.GT.30)GO TO 10
          AA=PMGG(KRA1)
          IF(DABS(AA).LT.EPS) CYCLE
!          AA=AA*RAGG(KRA1)
!          IF(DABS(AA).LT.EPS) CYCLE
          IF(IXJTIK(J(1),J(3),KRA*2,J(3),J(2),J12*2).EQ.0) CYCLE
          INTERACT2 = INTERACT2 + 1
!          CALL SIXJ(J(1),J(3),KRA*2,J(3),J(2),J12*2,0,SI)
!          AA=AA*SI*DSQRT(DBLE(I3))
!          AB=AB+AA
        END DO
        IF(INTERACT2 .EQ. 0) CYCLE
!        IF(DABS(AB).LT.EPS) CYCLE
!        AB=AB*DBLE(IFAZP)
        IF (ICOLBREI .EQ. 1) THEN
          INTERACT = INTERACT1
          IF(INTERACT .GT. 0) RETURN
!          BB=A1*AB*DBLE(IFAZFRCS)
!          CALL SPEAK(JJJA,JJJB,IIA,IIB,IID,IIC,KRA,BB)
        ELSE IF (ICOLBREI .EQ. 2) THEN
          INTERACT = 1
          RETURN
!          NU=KRA
!          IF(((NU-NE1)/2)*2 .EQ. (NU-NE1)) THEN
!            IF((ITRIG(KS(1),KS(4),NU+NU+1).NE.0) .AND.  &
!               (ITRIG(KS(2),KS(3),NU+NU+1).NE.0)) THEN
!              IF(NU .GT. 0) THEN
!                N=(NU-NE1)/2+1
!                CALL CXK(S,IS,KAPS,NU,KRA,1,2)
!                DO MU = 1,4
!                  CONE(MU,N)=CONE(MU,N)+AB*S(MU)
!                END DO
!              END IF
!            END IF
!          END IF
!          NU=KRA+1
!          IF(((NU-NE1)/2)*2 .EQ. (NU-NE1)) THEN
!            IF((ITRIG(KS(1),KS(4),NU+NU-1).NE.0) .AND.  &
!               (ITRIG(KS(2),KS(3),NU+NU-1).NE.0)) THEN
!              IF(NU .GE. 0) THEN
!                N=(NU-NE1)/2+1
!                IF(N .LE. NE2) THEN
!                  CALL CXK(S,IS,KAPS,NU,KRA,1,2)
!                  DO MU = 1,4
!                    CONE(MU,N)=CONE(MU,N)+AB*S(MU)
!                  END DO
!                END IF
!              END IF
!            END IF
!          END IF
!          NU=KRA-1
!          IF(((NU-NE1)/2)*2 .EQ. (NU-NE1)) THEN
!            IF((ITRIG(KS(1),KS(4),NU+NU+3).NE.0) .AND.  &
!               (ITRIG(KS(2),KS(3),NU+NU+3).NE.0)) THEN
!              IF(NU .GE. 0) THEN
!                N=(NU-NE1)/2+1
!                IF(N .LT. NE2) THEN
!                  CALL CXK(S,IS,KAPS,NU,KRA,1,2)
!                  DO MU = 1,12
!                    CONE(MU,N)=CONE(MU,N)+AB*S(MU)
!                  END DO
!                END IF
!              END IF
!            END IF
!          END IF
        END IF
      END DO
!      IF (ICOLBREI .EQ. 2) THEN
!        DO N = 1,NE2
!          NU=NE1+2*(N-1)
!          CALL TALK(JJJA,JJJB,NU,IS(1),IS(4),IS(2),IS(3),1,CONE(1,N))
!          CALL TALK(JJJA,JJJB,NU,IS(4),IS(1),IS(3),IS(2),1,CONE(2,N))
!          CALL TALK(JJJA,JJJB,NU,IS(1),IS(4),IS(3),IS(2),1,CONE(3,N))
!          CALL TALK(JJJA,JJJB,NU,IS(4),IS(1),IS(2),IS(3),1,CONE(4,N))
!          IF(N.EQ.NE2) CYCLE
!          NUP1=NU+1
!          CALL TALK(JJJA,JJJB,NUP1,IS(1),IS(4),IS(2),IS(3),2,CONE(5,N))
!          CALL TALK(JJJA,JJJB,NUP1,IS(2),IS(3),IS(1),IS(4),2,CONE(6,N))
!          CALL TALK(JJJA,JJJB,NUP1,IS(4),IS(1),IS(3),IS(2),2,CONE(7,N))
!          CALL TALK(JJJA,JJJB,NUP1,IS(3),IS(2),IS(4),IS(1),2,CONE(8,N))
!          CALL TALK(JJJA,JJJB,NUP1,IS(1),IS(4),IS(3),IS(2),2,CONE(9,N))
!          CALL TALK(JJJA,JJJB,NUP1,IS(3),IS(2),IS(1),IS(4),2,CONE(10,N))
!          CALL TALK(JJJA,JJJB,NUP1,IS(4),IS(1),IS(2),IS(3),2,CONE(11,N))
!          CALL TALK(JJJA,JJJB,NUP1,IS(2),IS(3),IS(4),IS(1),2,CONE(12,N))
!        END DO
!      END IF
      IF(IREZ.EQ.2)GO TO 6
    7 CONTINUE
      RETURN
   10 WRITE(99,100)
  100 FORMAT(5X,'ERRO IN EL33INT  PMGG RAGG')
      STOP
      END SUBROUTINE EL33INT

max_stars_repo_name: sylas/grasp-continuum

max_issues_repo_name: sylas/grasp-continuum

max_forks_repo_name: sylas/grasp-continuum


text:
map requestwhere is the Main Lounge?

Address(Tercero, 38.536265, 121.757394) is one of three Dorms housing areas for freshman students and is managed by Student Housing and is located on the south side of campus. The nearest lecture hall is Warren and Leta Giedt Hall and The Silo is nearby.

Communities and Buildings

  Leach Hall Lysle Leach Hall consists primarily of single rooms connected via a hallway, but may include some double occupancy rooms as increasing demands are placed on the existing campus housing system.  There can be anywhere from two to five rooms, all of which share a common bathroom.

  Tercero South Residence Halls Tercero South consists of two buildings, Laben Hall and Kearney Hall. There are four floors and an elevator in each building. The room doors are unlocked via card swipe instead of keys.

  Tercero South Phase II Tercero South II consists of three buildings (similar to Laben and Kearney) named Wall Hall, Campbell Hall, and Potter Hall. Each building also houses four floors and an elevator. T.S.II opened to its first class Fall 2010. Davis Honors Challenge is located on the second floor of Wall.

  Buildings AM of dorms. Demolished, Spring 2011  There ws no building I, probably because it might have been confused with the number one.  Each building was three stories tall, with one singlesex shared bathroom on each floor (e.g floor one is the womens bathroom, floor two is the mens bathroom, and floor three is the womens bathroom again). These buildings were divided into two groupings, identified as Thille Hall and Pierce Hall.

     Thille Hall Thille was made up of 6 buildings Tercero A Building A Tercero B Building B Tercero C Building C Tercero D Building D Tercero E Building E and Tercero F Building F
     Pierce Hall Pierce was made up of 6 buildings Tercero G Building G Tercero H Building H Tercero J Building J Tercero K Building K Tercero L Building L and Tercero M Building M
     Various dorms within Thille & Pierce Halls were specialty communities, such as: A (ChicanoLatino theme house), D (Hammarskjold House), F (Communication in the 21st Century), G (Substance Free), H (Health and Wellness), K (Engineering), L (Womens Community), and M (Asian Pacific American Theme House).

   Tercero Tercero Area Phase III (Scheduled to Open Fall 2014) http://www.housing.ucdavis.edu/capitalprojects/projects/tercero_phase_three.asp web
        Pine
        Scrub Oak
        Currant
        Live Oak
        Sequoia
        Mahogany
        Hawthorne

These buildings usually compete in the annual Tercero Hall Cup.

Tercero Living

One of the benefits of living in Tercero is its proximity to the Arboretum  only about a five minute walk until you reach Putah Creek Lodge.

Though debatable, the Tercero Dining Commons Tercero DC is supposedly the best of the four dining commons operated by Sodexho, and was expanded and renovated in 2005. It is far less busy than the Segundo Dining Commons, which was rebuilt in 2004. One can easily walk into the Tercero DC at 6pm, get their food quickly and find a seat... you wont have that same luck at the Segundo DC!

Tercero is also a hot spot for tree climbing, so if you are a monkey at heart, Tercero is the place to be!

Warning: Some people complain about the Essence of Davis cow smell in Tercero. This is because of Terceros proximity to the The Dairy Dairy Cattle Facility, just one street west and a small parking lot away.  Under certain weather conditions the smell can intensify and definitely be disturbing, usually in the early morning or late night hours. On most days, however, it wont be a problem at all. To combat this smell, acquire a potion of Olfactory Suppression, one of the Magic Items of Davis.  But, as much as some people complain about the smell, its usually not that intense and entirely tolerable.

Proximity to the cow barns is convenient for several reasons: a) You can sleep on the hay stacks if your roommate wants to be alone with his/her boyfriend or girlfriend, or you can bring yours out there, b) there is a refrigerator in a lit room that always seems to be unoccupied by any people and that seems to be open all night... it contains a various assortment of food... c) cows are nice and make for good alternatives to humans if your friends are getting on your nerves (and they are less resistant to giving milk).

ext: f

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


text:
program unity
     real, parameter :: pi = 3.141592653589793
     complex, parameter :: i = (0, 1)
     complex, dimension(0:7-1) :: unit_circle
     integer :: n, j

     do n = 2, 7
          !!!! KEY STEP, does all the calculations in one statement !!!!
        unit_circle(0:n-1) = exp(2*i*pi/n * (/ (j, j=0, n-1) /) )

        write(*,"(i1,a)", advance="no") n, ": "
        write(*,"(sp,2f7.4,a)", advance="no") (unit_circle(j), "j  ", j = 0, n-1)
        write(*,*)
     end do
 end program unity

max_issues_repo_name: seanwallawalla-forks/RosettaCodeData

max_forks_repo_name: seanwallawalla-forks/RosettaCodeData


text:
C    @(#)mergtx.f	20.5 2/26/96
      subroutine mergtx

      include 'ipfinc/parametr.inc'

      include 'ipfinc/alpha.inc'
      include 'ipfinc/arcntl.inc'
      include 'ipfinc/area.inc'
      include 'ipfinc/blank.inc'
      include 'ipfinc/branch.inc'
      include 'ipfinc/bus.inc'
      include 'ipfinc/data.inc'
      include 'ipfinc/dc2t.inc'
      include 'ipfinc/dcmt.inc'
      include 'ipfinc/ikk.inc'
      include 'ipfinc/merge.inc'
      include 'ipfinc/prt.inc'
      include 'ipfinc/red2.inc'

      integer znsrch, arsrch, bsrch2, find_bus, ldata(500), ptr
      external kpzone, spzone, kparea, sparea, kpbase, spbase,
     &         kpbrch, spbrch
      character zn*2

C     Set "DELETED BUS" flag

      kerrsw = 0
      bus(ntot+1)=srtlst

C     Establish connection matrix: add 2-terminal dc to y-matrix

      do i = 1, kdtot
         k1 = dc2t(1,i)
         k2 = dc2t(3,i)
         kt = inp2opt(k1)
         mt = inp2opt(k2)

C        Add branch (KT,MT) to y-matrix

         do isw = 1, 2
            ln = km(kt) - 1
            ls = kmlen(kt)
            do l = 1, ls
               if (ikmu(l+ln) .eq. mt) go to 102
            enddo
c
c           Appending an entity to km() requires relocating branch
c           list to end of km().
c
            if (yptr + ls + 1 .ge. MAXYE) then
               write (errbuf(1), 100) MAXYE
  100          format(' More than ', i5, ' Y-matrix entities')
               call prterx ('F',1)
               kerrsw = kerrsw + 1
               go to 9000
            endif

            do l = 1, ls
               ikmu(l+yptr) = ikmu(l+ln)
            enddo
            ikmu(ls+yptr+1) = mt
            km(kt) = yptr + 1
            kmlen(kt) = ls + 1
            yptr = yptr + ls + 1

  102       continue
            kt = inp2opt(k2)    ! swap kt and mt
            mt = inp2opt(k1)
         enddo
      enddo

C     Add N-terminal d-c to y-matrix

      do i = 1, mtdcln
         k1 = dcmtln(1,i)
         k2 = dcmtln(2,i)
         kt = inp2opt(k1)
         mt = inp2opt(k2)

         do isw = 1, 2
            ln = km(kt) - 1
            ls = kmlen(kt)
            do l = 1, ls
               if (ikmu(l+ln) .eq. mt) go to 104
            enddo
c
c           Appending an entity to km() requires relocating branch
c           list to end of km().
c
            if (yptr + ls + 1 .ge. MAXYE) then
               write (errbuf(1), 100) MAXYE
               call prterx ('F',1)
               kerrsw = kerrsw + 1
               go to 9000
            endif

            do l = 1, ls
               ikmu(l+yptr) = ikmu(l+ln)
            enddo
            ikmu(ls+yptr+1) = mt
            km(kt) = yptr + 1
            kmlen(kt) = ls + 1
            yptr = yptr + ls + 1

  104       continue
            kt = inp2opt(k2)    ! swap kt and mt
            mt = inp2opt(k1)
         enddo
      enddo
C
C     DESCRIPTION OF "IKK" ARGUMENTS
C
C     ARGUMENT  ATTRIBUTES  DEFINITION
C
C        1         -1       BUS IS SPECIFICALLY IGNORED
C        1          0       BUS IS IN ELIMINATED SUBSYSTEM
C                   1       BUS IS IN RETAINED SUBSYSTEM
C
C        2         0/1      BUS IS NOT/IS SPECIFICALLY CLASSIFIED
C
C        3        IFCSW     INTERFACE LEVEL:
C                             0 - NONE
C                             1 - CONDITIONAL
C                             2 - UNCONDITIONAL
C
C        4        ISYSTM    BUS CLASSIFIED BY SAVE COMMAND SUBSYSTEM
C                           NUMBER
C
C     DESCRIPTION OF "IKKIND" ARGUMENTS
C
C     ARGUMENT ATTRIBUTE DEFINITIONS
C
C        1         IS       STARTING BRANCH INDEX
C        2         IL       BRANCH STRING LENGTH
C
      itot=1
      do kt=1,ntot
         k=inp2opt(kt)
         jtot=0
         if (kmlen(k) .gt. 0) then
            do l = km(k), km(k)-1+kmlen(k)
               mt = ikmu(l)
               kolum(itot+jtot)=opt2inp(mt)
               jtot=jtot+1
            enddo
         endif
         if (bus(kt) .eq. '~~~~~~~~') then
            ikk(1,kt)=-1
         else
            ikk(1,kt)=0
         endif
         ikk(2,kt)=0
         ikk(3,kt)=0
         ikk(4,kt)=0
         ikkind(1,kt)=itot
         ikkind(2,kt)=jtot
         itot=itot+jtot
      enddo

      if (itot .gt. MAXYE) then
         write (errbuf(1),122) itot,MAXYE
  122    format ('TOTAL BRANCHES ( INCLUDING TRANSPOSES ) IN',
     1        'SYSTEM IS ',i5,'.  LIMIT IS ',i5,'. ')
         call prterx ('F',1)
         kerrsw = kerrsw + 1
         go to 9000
      endif
C
C     BEGIN TEXT COMMAND LOOP
C
      itface = 0
      itname = 0
      isystm = 0
      ifcsw = 1
C
C     Read next record
C
      inptls = 1
      call readtx
      inptls = 0
      call systxt

      do while (islnsw .gt. 0)
         go to (140,270,150,210,400,460,520,580,810,10580) islnsw
C
C        PROCESS "SAVE INTERFACE"
C
  140    ifcsw=savbas(1)
         go to 900
C
C        PROCESS "SAVE ZONES"
C
  150    if (idat .gt. 1) call qiksrt (1,idat,kpzone,spzone)
         isystm=isystm+1
         do i=1,idat
            ldata(i)=0
         enddo
         do kt=1,ntot
            zn=zone(kt)
            i=znsrch(zn)
            if (i .gt. 0 .and. ikk(1,kt) .ge. 0) then
               ikk(1,kt)=1
               ikk(2,kt)=1
               ikk(3,kt)=ifcsw
               ikk(4,kt)=isystm
               ldata(i)=ldata(i)+1
            endif
         enddo
         write (outbuf,180) isystm,ifcsw
  180    format ('0 SUBSYSTEM ',i2,'INTERFACE LEVEL ',i2,' ',
     1        '- "SAVE ZONES" WITH COMPOSITE POPULATIONS:')
         call prtout(1)
         call space(1)
         do i=1,idat,10
            n=min0(10,idat-i+1)
            write (outbuf,190) (savzns(i+j-1),ldata(i+j-1),j=1,n)
  190       format (10(4x,a2,' -',i4))
            call prtout(1)
         enddo
         call space(1)
         do i = 1,idat
            if (ldata(i) .eq. 0) then
               write (errbuf(1),202) savzns(i)
  202          format ('0 DATA ERROR -- ZONE (',a2,
     &            ') IS NOT IN SYSTEM. ZONE IGNORED. ')
               call prterx ('W',1)
            endif
         enddo
         go to 900
C
C        PROCESS "SAVE BASES"
C
  210    if (idat .gt. 1) call qiksrt (1,idat,kpbase,spbase)
         isystm=isystm+1
         do i=1,idat
            ldata(i)=0
         enddo
         do kt=1,ntot
            i=bsrch2(base(kt))
            if (i .gt. 0 .and. ikk(1,kt) .ge. 0) then
               ikk(1,kt)=1
               ikk(2,kt)=1
               ikk(3,kt)=ifcsw
               ikk(4,kt)=isystm
               ldata(i)=ldata(i)+1
            endif
         enddo
         write (outbuf,240) isystm,ifcsw
  240    format ('0 SUBSYSTEM ',i2,'INTERFACE LEVEL ',i2,' ',
     1        ' -"SAVE BASES" WITH COMPOSITE POPULATIONS:')
         call prtout(1)
         call space(1)
         do i=1,idat,8
            n=min0(8,idat-i+1)
            write (outbuf,250) (savbas(i+j-1),ldata(i+j-1),j=1,n)
  250       format (8(4x,f6.1,' -',i4))
            call prtout(1)
         enddo
         call space(1)
         do i = 1,idat
            if (ldata(i) .eq. 0) then
               write (errbuf(1),262) savbas(i)
  262          format ('BASE (',f6.1,') IS NOT IN SYSTEM. BASE IGNORED.
     &')
               call prterx ('W',1)
            endif
         enddo
         go to 900
C
C        PROCESS "SAVE AREAS"
C
  270    if (idat .gt. 1) call qiksrt (1,idat,kparea,sparea)
         isystm=isystm+1
         if (ntotc .gt. 0) go to 290
         write (errbuf(1),280)
  280    format ('BASE SYSTEM HAS NO AREA INTERCHANGE DATA.')
         call prterx ('W',1)
         kerrsw = kerrsw + 1
         go to 390

  290    do i=1,idat
            ldata(i)=0
         enddo
         do kt=1,ntot
            j=jarzn(kt)
            i = arsrch (arcnam(j))
            if (i .gt. 0 .and. ikk(1,kt) .ge. 0) then
               ikk(1,kt)=1
               ikk(2,kt)=1
               ikk(3,kt)=ifcsw
               ikk(4,kt)=isystm
               ldata(i)=ldata(i)+1
            endif
         enddo

         write (outbuf,360) isystm,ifcsw
  360    format ('0 SUBSYSTEM ',i2,' INTERFACE LEVEL ',i2,' ',
     1        ' -"SAVE AREAS" WITH COMPOSITE POPULATIONS:')
         call prtout(1)
         call space(1)
         do i=1,idat,6
            n=min0(6,idat-i+1)
            write (outbuf,370) (savare(i+j-1),ldata(i+j-1),j=1,n)
  370       format (6(4x,a10,' -',i4))
            call prtout(1)
         enddo
         call space(1)
         do i = 1,idat
            if (ldata(i) .eq. 0) then
               write (errbuf(1),382) savare(i)
  382          format ('AREA (',a10,') IS NOT IN SYSTEM. AREA IGNORED. '
     &)
               call prterx ('W',1)
            endif
         enddo
  390    continue
         go to 900
C
C        PROCESS "SAVE BUSES"
C
  400    isystm=isystm+1
         do l=1,idat
            kt = find_bus(savbus(l),savbas(l))
            if (kt .le. 0) then
               write (errbuf(1),410) savbus(l),savbas(l)
  410          format ('0 "SAVE BUS" (',a8,f6.1,
     &            ') IS NOT IN SYSTEM. BUS IGNORED.')
               call prterx ('W',1)
            else
               if (ikk(1,kt) .eq. -1) then
                  write (errbuf(1),420) savbus(l),savbas(l)
  420             format ('0 "SAVE BUS" (',a8,f6.1,
     &              ') IS SPECIFICALLY "EXCLUDED" BUS IGNORED.')
                  call prterx ('W',1)
               else
                  if (ikk(1,kt) .eq. 1 .and. ikk(4,kt) .ne. isystm) then
                     write (errbuf(1),430) savbus(l),savbas(l)
  430                format ('0 REDUNDANT DATA: "SAVE BUS" (',a8,f6.1,
     &                 ') IS ALREADY RETAINED. ')
                     call prterx ('W',1)
                  endif
               endif
               ikk(1,kt)=1
               ikk(2,kt)=1
               ikk(3,kt)=ifcsw
               ikk(4,kt)=isystm
            endif
         enddo
         go to 900
C
C        PROCESS "INCLUDE BUSES"
C
  460    do l=1,idat
            kt = find_bus (savbus(l),savbas(l))
            if (kt .le. 0) then
               write (errbuf(1),470) savbus(l),savbas(l)
  470          format (' "INCLUDE BUS" (',a8,f6.1,
     &           ') IS NOT IN SYSTEM.  BUS IGNORED.')
               call prterx ('W',1)
            else
               if (ikk(1,kt) .eq. -1) then
                  write (errbuf(1),480) savbus(l),savbas(l)
  480             format ('0 "INCLUDE BUS" (',a8,f6.1,
     &              ') IS SPECIFICALLY "EXCLUDED". BUS IGNORED.')
                  call prterx ('W',1)
               else
                  if (ikk(1,kt) .eq. 1 .and. ikk(4,kt) .ne. isystm)
     &                then
                     write (errbuf(1),490) savbus(l),savbas(l)
  490                format ('0 REDUNDANT DATA: "INCLUDE BUS" (',a8,
     &                  f6.1, ') IS ALREADY RETAINED.')
                     call prterx ('W',1)
                  endif
                  ikk(1,kt)=1
                  ikk(2,kt)=1
                  ikk(3,kt)=ifcsw
                  ikk(4,kt)=isystm
               endif
            endif
         enddo
         go to 900
C
C        PROCESS "EXCLUDE BUSES"
C
  520    do l=1,idat
            kt = find_bus(savbus(l),savbas(l))
            if (kt .le. 0) then
               write (errbuf(1),530) savbus(l),savbas(l)
  530          format (' "EXCLUDE BUS" (',a8,f6.1,
     &           ') IS NOT IN SYSTEM.  BUS IGNORED.')
               call prterx ('W',1)
            else
               if (ikk(1,kt) .eq. -1) then
                  write (errbuf(1),550) savbus(l),savbas(l)
  550             format ('0 DUPLICATE DATA: "EXCLUDE BUS" (',a8,f6.1,
     &               ').')
                  call prterx ('W',1)
               endif
               ikk(1,kt) = -1
               ikk(2,kt)=1
               ikk(3,kt)=ifcsw
               ikk(4,kt)=isystm
            endif
         enddo
         go to 900
C
C        PROCESS "INTERFACE BRANCHES"
C
  580    isystm=isystm+1
         ksw=0
         do 800 l=1,idat
            kt = find_bus (facbus(1,l),facbas(1,l))
            if (kt .le. 0) then
               write (errbuf(1),590) (facbus(i,l),facbas(1,l),i=1,2),
     &            'BUS1'
  590          format (' "INTERFACE BRANCH" (',a8,f6.1,2x,a8,f6.1,
     &            ') has non-existent ',a,'. ')
               call prterx ('W',1)
            else if (ikk(1,kt) .eq. 0 .and. ikk(2,kt) .eq. 1) then
               write (errbuf(1),610) 'BUS1',(facbus(i,l),facbas(1,l),
     &            i=1,2)
  610          format (' "INTERFACE BRANCH" ',a,' (',a8,f7.1,
     &           ') is in both systems.  Branch ignored.')
               call prterx ('W',1)
               kerrsw=kerrsw+1
               kt=0
            else if (ikk(1,kt) .eq. -1) then
               write (errbuf(1),620) 'BUS1',facbus(1,l),facbas(1,l)
  620          format (' "INTERFACE BRANCH" ',a,' (',a8,f6.1,
     &           ') is specifically excluded. ')
               call prterx ('W',1)
               kt = 0
            else
               if (ikk(2,kt) .eq. 1 .and. ikk(4,kt) .ne. isystm) then
                  write (errbuf(1),630) 'BUS1',facbus(1,l),facbas(1,l)
  630             format (' "INTERFACE BRANCH" ',a,' (',a8,f6.1,
     &              ') may be redundant. ')
                  call prterx ('W',1)
               endif
               ikk(1,kt)=1
               ikk(2,kt)=1
               ikk(3,kt)=ifcsw
               ikk(4,kt)=isystm
            endif

            mt = find_bus(facbus(2,l),facbas(2,l))
            if (mt .le. 0) then
               write (errbuf(1),590) (facbus(i,l),facbas(1,l),i=1,2),
     &            'BUS2'
               call prterx ('W',1)
            else if (ikk(1,mt) .eq. 1) then
               write (errbuf(1),610) 'BUS2',(facbus(i,l),facbas(1,l),
     &            i=1,2)
               call prterx ('W',1)
               kerrsw=kerrsw+1
               mt=0
            else if (ikk(1,mt) .eq. -1) then
               write (errbuf(1),620) 'BUS2',facbus(2,l),facbas(2,l)
               call prterx ('W',1)
               mt = 0
            else
               if (ikk(2,mt) .eq. 1 .and. ikk(4,mt) .ne. isystm) then
                  write (errbuf(1),630) 'BUS2',facbus(2,l),facbas(2,l)
                  call prterx ('W',1)
               endif
               ikk(1,mt)=0
               ikk(2,mt)=1
               ikk(3,mt)=ifcsw
               ikk(4,mt)=isystm
            endif

            if (kt .gt. 0 .and. mt .gt. 0) then
               i5=ikkind(1,kt)
               i6=ikkind(2,kt)+i5-1
               do j=i5,i6
                  if (kolum(j) .eq. mt) go to 750
               enddo
               write (errbuf(1),740) (facbus(i,l),facbas(1,l),i=1,2)
  740          format ('0 "INTERFACE BRANCH" (',a8,f6.1,2x,a8,f6.1,')',
     1            ' is not in system. branch ignored.')
               call prterx ('W',1)
               go to 800

  750          if (ksw .eq. 0) then
                  itface=itface+1
                  if (itface .gt. 200) then
                     write (errbuf(1),760)
  760                format ('More than 200 "interface branches".  Remai
     &ning data items ignored.')
                     call prterx ('W',1)
                     itface=200
                     ksw=1
                  endif
                  write (outbuf,780) (facbus(i,l),facbas(1,l),i=1,2)
  780             format (' "INTERFACE BRANCH" IGNORED :(',a8,f6.1,2x,
     1               a8,f6.1,')')
                  call prterx ('W',1)
                  go to 800
               endif

               face(1,itface)=kt
               face(2,itface)=mt
               face(3,itface)=ifcsw
               face(4,itface)=0
            endif
  800    continue
         go to 900
C
C        PROCESS "EXCLUDE BRANCHES"
C
10580    ndbr = 0
         ksw = 0
         do 10800 l=1,idat
            kt = find_bus (facbus(1,l),facbas(1,l))
            if (kt .le. 0) then
               write (errbuf(1),10590) (facbus(i,l),facbas(i,l),i=1,2),
     &            'BUS1'
10590          format (' "EXCLUDE BRANCH" (',a8,f6.1,2x,a8,f6.1,
     &           ') has non-existent ',a,'.')
               call prterx ('W',1)
            endif
            mt = find_bus(facbus(2,l),facbas(2,l))
            if (mt .le. 0) then
               write (errbuf(1),10590) (facbus(i,l),facbas(i,l),i=1,2),
     &            'BUS2'
               call prterx ('W',1)
            endif
            if (kt .gt. 0 .and. mt .gt. 0) then
               if (ikk(1,kt) .eq. 0 .and. ikk(1,mt) .eq. 0) then
                  write (errbuf(1),10672) (facbus(i,l),facbas(i,l),
     &               i=1,2)
10672             format ('0 "EXCLUDE BRANCH" (',a8,f6.1,2x,a8,f6.1,
     &               ') is entirely in eliminated subsystem.')
                  call prterx ('W',1)
               endif
               k1 = kt
               k2 = mt
               do lsw = 1, 2
                  i5=ikkind(1,k1)
                  i6=ikkind(2,k1)+i5-1
                  do j=i5,i6
                     if (k2 .eq. kolum(j)) go to 10750
                  enddo
                  write (errbuf(1),10740) (facbus(i,l),facbas(i,l),
     &               i=1,2)
10740             format (' "EXCLUDE BRANCH" (',a8,f6.1,2x,a8,f6.1,
     &               ') is not in system.  branch ignored.')
                  call prterx ('W',1)
                  go to 10800

10750             if (j .ne. i6) then
                     do k=j+1,i6
                        kolum(k-1)=kolum(k)
                     enddo
                  endif
                  ikkind(2,k1)=ikkind(2,k1)-1
                  if (ksw .eq. 0) then
                     ndbr = ndbr + 1
                     if (ndbr .gt. 200) then
                        write (errbuf(1),10760)
10760                   format ('More than 200 "EXCLUDE BRANCHES".  Rema
     &ining data items ignored.')
                        call prterx ('W',1)
                        ndbr=200
                        ksw=1
                     else
                        ndelbr(1,ndbr) = k1
                        ndelbr(2,ndbr) = k2
                     endif
                  endif
                  if (ksw .eq. 1) then
                     write (errbuf(1),10780) (facbus(i,l),facbas(i,l),
     &                   i=1,2)
10780                format ('0 "EXCLUDE BRANCH" not processed: (',a8,
     &                  f6.1,2x,a8,f6.1,')')
                     call prterx ('W',1)
                     go to 10800
                  endif

                  k1 = mt             ! Swap terminals for second loop
                  k2 = kt
               enddo
            endif
10800    continue

         if (ndbr .eq. 0) go to 900
         call qiksrt (1,ndbr,kpbrch,spbrch)
         do i = 1,ndbr
            kt = ndelbr(1,i)
            mt = ndelbr(2,i)
            ptr = kbsdta(16,kt)
            do while (ptr .gt. 0)
               k2 = ky(ptr)
               if (k2 .eq. mt) then
                  ky(ptr) = ntot + 1
                  write (outbuf,10850) i, bus(k1), base(k1), bus(k2),
     &               base(k2), brid(ptr), brsect(ptr), brtype(ptr)
10850             format (' "BRANCH EXCLUDED" ',i2,2x,a8,f6.1,2x,a8,
     &               f6.1,2x,a1,2i3)
                  call prtout(1)
               endif
               ptr = brnch_nxt(ptr)
            enddo
         enddo
         go to 900
C
C        PROCESS "RENAME BUSES"
C
  810    ksw=0
         do 890 l=1,idat
            kt = find_bus(facbus(1,l),facbas(1,l))
            if (kt .le. 0) then
               write (errbuf(1),820) (facbus(i,l),facbas(i,l),i=1,2)
  820          format ('0 "RENAME BUS" (',a8,f6.1,2x,a8,f6.1,
     &            ') - bus1 - is not in system.  bus ignored.')
               call prterx ('W',1)
               go to 890
            endif
            mt = find_bus(facbus(2,l),facbas(2,l))
            if (mt .gt. 0) then
               write (errbuf(1),840) (facbus(i,l),facbas(i,l),i=1,2)
  840          format ('0 "RENAMED BUS" (',a8,f6.1,2x,a8,f6.1
     1            ,') is not unique.  new name ignored. ')
               call prterx ('W',1)
               go to 890
            endif
            if (ikk(1,kt) .eq. -1) then
               write (errbuf(1),850) savbus(l),savbas(l)
  850          format ('0 "RENAME BUS" (',a8,f6.1,
     &            ') is specifically "excluded". bus ignored.')
               call prterx ('W',1)
               go to 890
            endif
            if (ksw .eq. 0) then
               itname=itname+1
               if (itname .gt. 100) then
                  write (errbuf(1),860)
  860             format ('0 MORE THAN 100 "RENAME BUSES".  REMAINING ',
     1              'data items ignored.')
                  call prterx ('W',1)
               ksw=1
            else
               irname(itname)=kt
               renamc(itname)=facbus(2,l)
               rename(itname)=facbas(2,l)
            endif
         else
            write (errbuf(1),880) (facbus(i,l),facbas(i,l),i=1,2)
  880       format ('0 "RENAME BUS" IGNORED: (',
     1          a8,f6.1,2x,a8,f6.1,')')
            call prterx ('W',1)
         endif
  890    continue
C
C        END TEXT COMMAND LOOP
C
  900    call systxt
      enddo

 9000 if (kerrsw .eq. 0) go to 9020
      write (errbuf(1), 9010) kerrsw
 9010 format ('0 ',i2,' ERRORS ENCOUNTERED.')
      call prterx ('W',1)
 9020 continue
      return
      end

max_stars_repo_name: mbheinen/bpa-ipf-tsp

max_issues_repo_name: cuihantao/bpa-ipf-tsp

max_forks_repo_name: mbheinen/bpa-ipf-tsp


text:
INTERFACE
END INTERFACE
INTERFACE
END INTERFACE
INTERFACE
END INTERFACE
INTERFACE
END INTERFACE
END PROGRAM

max_stars_repo_name: ouankou/rose

max_issues_repo_name: sujankh/rose-matlab

max_forks_repo_name: sujankh/rose-matlab


text:
Students in Free Enterprise. We are the go to student organizations student organization on campus. Our team is project oriented and our unique membership structure gives us the potential to grow our organization exponentially. All of our projects are constructed with the economic, social, and environmental impact in mind. We believe that our model allows for UC Davis students to ultimately have a more optimal positive impact on the local community. By being project oriented and managing projects virtually, we are able to leverage our resources to the fullest. Our UC Davis SIFE team is part of a 48,000 student network–the largest collegiate business club in the world.  We are one of 1500 teams that represent SIFE headquarters. For more information about SIFE headquarters visit SIFE.org .

This year we have focused our efforts on three areas:

1) Teaching financial literacy to youth,
2) Contribution towards the development of our community,
3) Creating a strong business network on campus through events and activities.

Enjoy visiting our home and project management pages. We encourage all students to contact us if they have any projects that they would like to lead or partner on. Also please contact us if you’re an outside organization and are interested in working with our team.

20112012 Sponsors:
Liberty Mutual


module ZoneModule

  use KindModule
  use SimVariablesModule, only: iout
  use SimModule, only: store_error, store_error_unit, ustop
  use ConstantsModule, only: LINELENGTH, DEP20
  use BlockParserModule, only: BlockParserType
  use SortModule, only: unique_values

  implicit none
  private
  public :: zone_init
  public :: clear_accumulators
  public :: flowja_accumulate
  public :: flowiaja_accumulate
  public :: flow_accumulate
  public :: flowch_setich
  public :: flowch_accumulate
  public :: zone_finalize
  public :: maxzone
  public :: iuniqzone
  public :: nmznfl, vbvl, vbznfl

  integer(I4B) :: ncells
  integer(I4B) :: maxzone
  integer(I4B), dimension(:), allocatable :: izoneuser
  integer(I4B), dimension(:), allocatable :: iuniqzone
  integer(I4B), dimension(:), allocatable :: izone
  integer(I4B), dimension(:), allocatable :: ich
  integer(I4B), dimension(:, :), allocatable :: nmznfl
  real(DP), dimension(:, :, :), allocatable :: vbznfl
  real(DP), dimension(:, :, :), allocatable :: vbvl
  character(len=LINELENGTH) :: errmsg, keyword

  contains

  subroutine zone_init(inunit, nbudterms, ncr, mshape)
! ******************************************************************************
! zone_init
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    use ArrayReadersModule, only: ReadArray
    type(BlockParserType) :: parser
    integer(I4B), intent(in) :: inunit
    integer(I4B), intent(in) :: nbudterms
    integer(I4B), intent(inout) :: ncr
    integer(I4B), dimension(:), intent(in) :: mshape
    integer(I4B) :: nlay, ncpl, istart, istop, k
    character(len=24) :: aname = '                   IZONE'
    integer(I4B) :: ierr
    integer(I4B) :: i
    integer(I4B) :: n
    integer(I4B) :: iminval
    integer(I4B) :: imaxval
    integer(I4B), dimension(:), allocatable :: izonecount
    logical :: isfound, endOfBlock
! ------------------------------------------------------------------------------
    !
    ! -- Read DIMENSIONS block, set NCELLS
    call parser%Initialize(inunit, iout)
    call parser%GetBlock('DIMENSIONS', isfound, ierr)
    if(isfound) then
      write(iout,'(/, a)') 'Processing zone dimensions'
      do
        call parser%GetNextLine(endOfBlock)
        if (endOfBlock) exit
        call parser%GetStringCaps(keyword)
        select case (keyword)
          case ('NCELLS')
            ncells = parser%GetInteger()
            write(iout,'(4x,a,i0)') 'NCELLS = ', ncells
          case default
            write(errmsg,'(4x,a,a)')'ERROR. UNKNOWN DIMENSIONS ENTRY: ',       &
                                      trim(keyword)
            call store_error(errmsg)
            call parser%StoreErrorUnit()
            call ustop()
          end select
      end do
      write(iout,'(a)') 'End processing zone dimensions'
    else
      write(errmsg,'(1x,a)')'ERROR.  REQUIRED ZONE DIMENSIONS BLOCK NOT FOUND.'
      call store_error(errmsg)
      call parser%StoreErrorUnit()
      call ustop()
    end if
    !
    ! -- Validate size and allocate arrays
    if (ncr > 0) then
      if (ncells /= ncr) then
        write(errmsg, '(a,i0)') 'GRB FILE INDICATES NUMBER OF CELLS OR ' //   &
          'REACHES IS ', ncr
        call store_error(errmsg)
        write(errmsg, '(a,i0)') 'INSTEAD ZONE ARRAY SPECIFIED AS SIZE ', ncells
        call store_error(errmsg)
        write(errmsg, '(a,i0)') 'CHANGE SIZE OF ZONE ARRAY TO  ', ncr
        call store_error(errmsg)
        call store_error_unit(inunit)
        call ustop()
      endif
    else
      ! -- Number of cells/reaches not available in grb or no grb specified
      !    Setting ncr to ncells
      ncr = ncells
    endif
    allocate(izoneuser(ncells))
    allocate(izone(ncells))
    allocate(ich(ncells))
    !
    ! -- get griddata block
    call parser%GetBlock('GRIDDATA', isfound, ierr)
    if(isfound) then
      write(iout,'(/, a)') 'Processing zone griddata'
      do
        call parser%GetNextLine(endOfBlock)
        if (endOfBlock) exit
        call parser%GetStringCaps(keyword)
        select case (keyword)
          case ('IZONE')
            call parser%GetStringCaps(keyword)
            if (keyword .EQ. 'LAYERED') then
              if (size(mshape) > 1) then
                nlay = mshape(1)
              else
                write(errmsg,'(4x,a)') 'ERROR. LAYERED INPUT NOT SUPPORTED &
                  &FOR IZONE.  LAYERED INPUT CAN ONLY BE USED FOR IZONE &
                  &WHEN A BINARY GRID FILE IS PROVIDED AND THE MODEL IS LAYERED'
                call store_error(errmsg)
                call parser%StoreErrorUnit()
                call ustop()
              endif
              ncpl = ncells / nlay
              write(iout, '(4x, a, i0)') 'LAYERED detected.  Using NLAY = ', nlay
              write(iout, '(4x, a, i0, a)') 'Reading ', ncpl, ' values per layer'
              istart = 1
              istop = ncpl
              do k = 1, nlay
                call ReadArray(inunit, izoneuser(istart:istop), aname, 1, ncpl, iout, k)
                istart = istop + 1
                istop = istart + ncpl - 1
              enddo
            else
              call ReadArray(inunit, izoneuser, aname, 1, ncells, iout, 0)
            endif
          case default
            write(errmsg,'(4x,a,a)')'ERROR. UNKNOWN ZONE GRIDDATA TAG: ',      &
                                     trim(keyword)
            call store_error(errmsg)
            call parser%StoreErrorUnit()
            call ustop()
        end select
      end do
    else
      call store_error('ERROR.  REQUIRED GRIDDATA BLOCK NOT FOUND.')
      call parser%StoreErrorUnit()
      call ustop()
    end if
    !
    ! -- Write messages
    close(inunit)
    !
    ! -- Find max and min values
    iminval = HUGE(iminval)
    imaxval = -HUGE(imaxval)
    do n = 1, size(izoneuser)
      izone(n) = izoneuser(n)
      if (izoneuser(n) /= 0) then
        if (izoneuser(n) < iminval) then
          iminval = izoneuser(n)
        end if
        if (izoneuser(n) > imaxval) then
          imaxval = izoneuser(n)
        end if
      end if
    end do
    !
    ! -- write minimum and maximum zone numbers
    write(iout, '(/, 4x, a, i0)') 'Successfully read zone array with NCELLS = ', ncells
    write(iout, '(4x, a, i0)') 'Minimum user-specified zone number is ', iminval
    write(iout, '(4x, a, i0)') 'Maximum user-specified zone number is ', imaxval
    !
    ! -- find unique zones
    call unique_values(izone, iuniqzone)
    !
    ! -- pop off a zero zone value
    call pop_zero_zone(iuniqzone)
    !
    ! -- set max zone number
    maxzone = size(iuniqzone)
    !
    ! -- allocate and initialize izonecount
    allocate(izonecount(0:maxzone))
    do i = 0, maxzone
      izonecount(i) = 0
    end do
    !
    ! -- fill izonemap with uniqzone number
    do n = 1, size(izone)
      if (izoneuser(n) == 0) then
        izone(n) = 0
        izonecount(0) = izonecount(0) + 1
      else
        do i = 1, maxzone
          if (izoneuser(n) == iuniqzone(i)) then
            izone(n) = i
            izonecount(i) = izonecount(i) + 1
            exit
          end if
        end do
      end if
    end do
    !
    ! -- write zone mapping
    write(iout, '(//,4x,3(a20,1x))') 'USER ZONE', 'ZONE NUMBER', 'CELL COUNT'
    write(iout, '(4x,62("-"))')
    write(iout, '(4x,3(i20,1x))') 0, 0, izonecount(0)
    do i = 1, maxzone
      write(iout, '(4x,3(i20,1x))') iuniqzone(i), i, izonecount(i)
    end do
    write(iout, '(4x,62("-"),/)')

    !
    !maxzone = maxval(izone)
    write(iout,'(a)') 'End processing zone griddata'
    !
    ! -- nmznfl is map showing connections between two zones.  If 1, then
    !    there is flow between zones, and zone to zone flow will be written.
    allocate(nmznfl(0:maxzone, 0:maxzone))
    allocate(vbznfl(2, 0:maxzone, 0:maxzone))
    allocate(vbvl(2, 0:maxzone, nbudterms))
    !
    ! -- deallocate local variables
    deallocate(izonecount)
    !
    ! -- close the zone file
    close(inunit)
    !
    ! -- return
    return
  end subroutine zone_init

  subroutine clear_accumulators()
! ******************************************************************************
! clear_accumulators
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
! ------------------------------------------------------------------------------
    ich(:) = 0
    nmznfl(:, :) = 0
    vbvl(:, :, :) = 0.d0
    vbznfl(:, :, :) = 0.d0
    !
    ! -- return
    return
  end subroutine clear_accumulators

  subroutine flowja_accumulate(nodesrc, nodedst, flowdata)
! ******************************************************************************
! flowja_accumulate
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    ! -- dummy
    integer(I4B), dimension(:), intent(in) :: nodesrc
    integer(I4B), dimension(:), intent(in) :: nodedst
    real(DP), dimension(:, :), intent(in) :: flowdata
    ! -- local
    integer(I4B) :: i, n, m, iz1, iz2
    real(DP) :: q
! ------------------------------------------------------------------------------
    !
    ! -- add up flowja terms
    do i = 1, size(nodesrc)
      n = nodesrc(i)
      m = nodedst(i)
      q = flowdata(1, i)
      iz1 = izone(n)
      iz2 = izone(m)
      nmznfl(iz1, iz2) = 1
      if (q < 0.d0) then
        vbznfl(2, iz1, iz2) = vbznfl(2, iz1, iz2) - q
      else
        vbznfl(1, iz1, iz2) = vbznfl(1, iz1, iz2) + q
      endif
    enddo
    !
    ! -- return
    return
  end subroutine flowja_accumulate

  subroutine flowiaja_accumulate(ia, ja, flowja)
! ******************************************************************************
! flowiaja_accumulate
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    ! -- dummy
    integer(I4B), dimension(:), intent(in) :: ia
    integer(I4B), dimension(:), intent(in) :: ja
    real(DP), dimension(:), intent(in) :: flowja
    ! -- local
    integer(I4B) :: ipos, n, m, iz1, iz2
    real(DP) :: q
! ------------------------------------------------------------------------------
    !
    ! -- add up flowja terms
    do n = 1, ncells
      do ipos = ia(n), ia(n + 1) - 1
        m = ja(ipos)
        if (n == m) cycle
        q = flowja(ipos)
        iz1 = izone(n)
        iz2 = izone(m)
        nmznfl(iz1, iz2) = 1
        if (q < 0.d0) then
          vbznfl(2, iz1, iz2) = vbznfl(2, iz1, iz2) - q
        else
          vbznfl(1, iz1, iz2) = vbznfl(1, iz1, iz2) + q
        endif
      enddo
    enddo
    !
    ! -- return
    return
  end subroutine flowiaja_accumulate

  subroutine flow_accumulate(ibudterm, nodesrc, flowdata)
! ******************************************************************************
! flow_accumulate
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    ! -- dummy
    integer(I4B), intent(in) :: ibudterm
    integer(I4B), dimension(:), intent(in) :: nodesrc
    real(DP), dimension(:, :), intent(in) :: flowdata
    ! -- local
    integer(I4B) :: i, n, iz1
    real(DP) :: q
! ------------------------------------------------------------------------------
    !
    ! -- accumulate flow terms
    do i = 1, size(nodesrc)
      n = nodesrc(i)
      q = flowdata(1, i)
      iz1 = izone(n)
      if (q < 0.d0) then
        vbvl(2, iz1, ibudterm) = vbvl(2, iz1, ibudterm) - q
      else
        vbvl(1, iz1, ibudterm) = vbvl(1, iz1, ibudterm) + q
      endif
    enddo
    !
    ! -- return
    return
  end subroutine flow_accumulate

  subroutine flowch_setich(ibudterm, nodesrc)
! ******************************************************************************
! Set ICH equal to ibudterm for all constant head cells
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    ! -- dummy
    integer(I4B), intent(in) :: ibudterm
    integer(I4B), dimension(:), intent(in) :: nodesrc
    ! -- local
    integer(I4B) :: i, n
! ------------------------------------------------------------------------------
    !
    ! -- accumulate flow terms
    do i = 1, size(nodesrc)
      n = nodesrc(i)
      ich(n) = ibudterm
    enddo
    !
    ! -- return
    return
  end subroutine flowch_setich

  subroutine flowch_accumulate(ia, ja, flowja)
! ******************************************************************************
! flowiaja_accumulate
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    ! -- dummy
    integer(I4B), dimension(:), intent(in) :: ia
    integer(I4B), dimension(:), intent(in) :: ja
    real(DP), dimension(:), intent(in) :: flowja
    ! -- local
    integer(I4B) :: ipos, n, m, iz, ibudterm
    real(DP) :: q
! ------------------------------------------------------------------------------
    !
    ! -- add up flowja terms
    do n = 1, ncells
      do ipos = ia(n), ia(n + 1) - 1
        !
        ! -- skip if cell is not constant head
        ibudterm = ich(n)
        if (ibudterm == 0) cycle
        !
        ! -- skip if adjacent cell is a constant head cell
        m = ja(ipos)
        if (n == m) cycle
        if (ich(m) > 0) cycle
        !
        ! -- accumulate constant head flows
        q = flowja(ipos)
        iz = izone(n)
        if (q < 0.d0) then
          vbvl(2, iz, ibudterm) = vbvl(2, iz, ibudterm) - q
        else
          vbvl(1, iz, ibudterm) = vbvl(1, iz, ibudterm) + q
        endif
      enddo
    enddo
    !
    ! -- return
    return
  end subroutine flowch_accumulate

  subroutine pop_zero_zone(ia)
    ! -- dummy arguments
    integer(I4B), dimension(:), allocatable, intent(inout) :: ia
    ! -- local variables
    integer(I4B) :: i
    integer(I4B) :: n
    integer(I4B) :: nlen
    integer(I4B) :: ipop
    integer(I4B), dimension(:), allocatable :: ib
! ------------------------------------------------------------------------------
    nlen = size(ia)
    ipop = 0
    !
    ! -- determine if there is a zero value in the integer attay
    do i = 1, nlen
      if (ia(i) == 0) then
        ipop = i
        exit
      end if
    end do
    !
    ! -- remove zero value from ia
    if (ipop /= 0) then
      !
      ! -- allocate ib
      allocate(ib(nlen-1))
      !
      ! -- fill itmp with everything in ia except 0
      n = 1
      do i = 1, nlen
        if (i == ipop) then
          cycle
        end if
        ib(n) = ia(i)
        n = n + 1
      end do
      !
      ! -- deallocate ia
      deallocate(ia)
      !
      ! -- allocate ia and fill with ib
      allocate(ia(size(ib)))
      do i = 1, size(ib)
        ia(i) = ib(i)
      end do
      !
      ! -- deallocate ib
      deallocate(ib)
    end if
    !
    ! -- return
    return
  end subroutine pop_zero_zone

  subroutine zone_finalize()
! ******************************************************************************
! zone_finalize
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
! ------------------------------------------------------------------------------
    deallocate(izone)
    deallocate(ich)
    deallocate(nmznfl)
    deallocate(vbznfl)
    deallocate(vbvl)
    !
    ! -- return
    return
  end subroutine zone_finalize

end module ZoneModule


text:
The Horticulture and Agronomy Graduate Group is found under the department of Plant Sciences and includes a diverse collection of interests. Study includes the production, management and utilization of horticultural and agronomic plants and the post harvest handling of horticultural commodities. Fields of study include agronomy, environmental horticulture, pomology, vegetable crops, viticulture and weed science with further specialization available in agroecology, biotechnology, breeding and crop improvement, crop physiology, crop production, mineral nutrition, modeling and quantitative horticulture, pest management, plant growth and development, postharvest physiology, revegetation/restoration, and water relations.

The graduate group is unique in that it offers both a Masters by exam and Masters by thesis option  see the website for information on requirements for each option.

The affiliated social group SHAG (Society of Horticulture and Agronomy Graduates) holds social BBQs, Happy Hours, and potluck dinners upon occasion and is lead by Users/ChristyMarsden Christy Marsden for the 20102011 academic year.

Want more information?
Information regarding the graduate group, class requirements, current seminars offered and application requirements can be found at the http://ggha.ucdavis.edu/ Horticulture and Agronomy website
Information regarding the academic advisors and application deadlines can be found through the http://gradstudies.ucdavis.edu/programs/program_detail.cfm?id52 graduate studies website.


text:
program logistic_map
    use, intrinsic :: iso_fortran_env, only : DP => REAL64
    implicit none
    integer, parameter :: nr_x_values = 100, nr_r_values = 200, nr_iterations = 10000
    real, parameter :: x_min = 0.0_DP, x_max = 1.0_DP, &
                       r_min = 0.5_DP, r_max = 4.0_DP
    real(kind=DP), dimension(nr_x_values, nr_r_values) :: X, R, result
    real :: delta_x, delta_r
    integer :: i, j

    ! initialize X
    delta_x = (x_max - x_min)/nr_x_values
    X(:, 1) = [ (x_min + i*delta_x, i=1, nr_x_values) ]
    do i = 2, nr_r_values
        X(:, i) = X(:, 1)
    end do

    ! initialize R
    delta_r = (r_max - r_min)/nr_r_values
    R(1, :) = [ (r_min + i*delta_r, i=1, nr_r_values) ]
    do i = 2, nr_x_values
        R(i, :) = R(1, :)
    end do

    ! compute result
    result = iterate_map(X, R, nr_iterations)
    do i = 1, nr_x_values
        do j = 1, nr_r_values
            print *, R(i, j), result(i, j)
        end do
    end do

contains

    elemental function iterate_map(x0, r, nr_steps) result(xn)
        implicit none
        real(kind=DP), value :: x0, r
        integer, value :: nr_steps
        real(kind=DP) :: xn
        integer :: i

        xn = x0
        do i = 1, nr_steps
            xn = r*xn*(1.0_DP - xn)
        end do
    end function iterate_map

end program logistic_map

max_stars_repo_name: caguerra/Fortran-MOOC

max_issues_repo_name: caguerra/Fortran-MOOC

max_forks_repo_name: caguerra/Fortran-MOOC


text:
	!> Element that solves the trivial diagonal problem of incrementing variables
	!! @param CommonPar = ( a , a*[bi,ci,di,ei] , dummy ) where :
	!! @param Nvar = CommonPar(1) ==> a
	!! @param iShiftUi = CommonPar(see structure) ===> bi
	!! @param iShiftDeltaUi = CommonPar(see structure) ===> ci
	!! @param nodei (for each material = see structure) ===> ei
	!! @author Rocha, Felipe Figueredo

!! last update: lenU given by parameter and not by difference between iShiftU and iShiftDeltaU. NodMax is given, rather than assumed
Subroutine computeIncrementEstimation(AE, BE, MaxLRows, XLL, NDim, iDofT, NodELT, Sol0, &
									Sol1, CommonPar, Param, JParam, DelT, DTm, Time)
!     ------------------------------------------------------------------

	use funcAux
	use globalVariables, only : NdimE
	use ptsGaussLib
	use TIME_STEP_ITER

	implicit none

	!   ===== SUBROUTINE ARGUMENTS  =======
	integer :: MaxLRows,Ndim,iDofT,NodELT ! all integers
	Real*8 :: DelT, DTm,Time ! all reals
	Real*8 :: AE(MaxLRows,MaxLRows), BE(MaxLRows), XLL(*), Sol0(*), Sol1(*), Param(*), JParam(*), CommonPar(*)

	!   =====   END ARGUMENTS  =======
    integer :: i, ip
	integer :: 	iShift_c1, iShift_c2 , iShift_c3 , iShift_dUf_Star, iShift_dUf_Bar, &
				iShift_DUf_acc, iShift_dLarcLength_acc, iShift_AngleEst1 , iShift_AngleEst2, &
				iFEMtype
	integer :: NodG,pOrder,NGP,iSimplex,iBubble, nG, sizeSolU
	real*8 :: c1,c2,c3, dLarcLength_acc, dlambdaIncrement1 , dlambdaIncrement2, AngleEst1, AngleEst2
	real*8, allocatable, dimension(:) :: Sol_DUf_acc, Sol_DUf_acc_old, Sol_dUf_Bar, Sol_dUf_Star, Sol_dUf , Xel
	real*8 :: Gbar(NdimE,NdimE), y(NdimE), Nmat(NdimE, NdimE*NodElt), dV

	type(ptGaussClass) :: PtG

	iShift_c1 = nint(CommonPar(1))
	iShift_c2 = nint(CommonPar(2))
	iShift_c3 = nint(CommonPar(3))
	iShift_dUf_Star = nint(CommonPar(4))
	iShift_dUf_Bar = nint(CommonPar(5))
	iShift_DUf_acc = nint(CommonPar(6))
	iShift_dLarcLength_acc = nint(CommonPar(7))
	iShift_AngleEst1 = nint(CommonPar(8))
	iShift_AngleEst2 = nint(CommonPar(9))
	iFEMtype = nint(CommonPar(10))

	call setFEMtype(iFEMtype,NodG,pOrder,NGP,iSimplex,iBubble)

	ip = NodG*idofT + 1
	c1 = Sol1(iShift_c1 + ip)
	c2 = Sol1(iShift_c2 + ip)
	c3 = Sol1(iShift_c3 + ip)
	dLarcLength_acc = Sol1(iShift_dLarcLength_acc + ip)

	dlambdaIncrement1 = solveQuadraticEquation(c1,c2,c3,1) !! choose that have to change
	dlambdaIncrement2 = solveQuadraticEquation(c1,c2,c3,-1) !! choose that have to change

	call getSliceAllocate(Sol_DUf_acc,Sol1,1,NodG, iShift_DUf_acc + 1 , iShift_DUf_acc + NdimE, iDofT)
	call getSliceAllocate(Sol_DUf_acc_old,Sol0,1,NodG, iShift_DUf_acc + 1 , iShift_DUf_acc + NdimE, iDofT)
	call getSliceAllocate(Sol_dUf_Star,Sol1,1,NodG, iShift_dUf_Star + 1 , iShift_dUf_Star + NdimE, iDofT)
	call getSliceAllocate(Sol_dUf_Bar,Sol1,1,NodG, iShift_dUf_Bar + 1 , iShift_dUf_Bar + NdimE, iDofT)
	call getSliceAllocate(Xel,XLL,1,NodG,1 ,NdimE, Ndim)

	allocate(Sol_dUf(NodG*NdimE))

	call PtG%init(Xel,NodG,NdimE,NGP,pOrder,iBubble, iSimplex)

	Gbar = 0.0d0
	Gbar(2,2) = 1.0d0

	sizeSolU = NodG*NdimE

	AngleEst1 = 0.0d0
	AngleEst2 = 0.0d0

	if(Nconverg == 1) then ! in this case compute estimative for the signal in AngleEst1
		AngleEst1 = dot_product(Sol_dUf_Bar, Sol_DUf_acc_old)
		AngleEst2 = 0.0d0
	else
		Sol_dUf = Sol_dUf_Star + dlambdaIncrement1*Sol_dUf_Bar
		AngleEst1 = dot_product(Sol_DUf_acc + Sol_dUf, Sol_DUf_acc) ! it is possible to be the old

		Sol_dUf = Sol_dUf_Star + dlambdaIncrement2*Sol_dUf_Bar
		AngleEst2 = dot_product(Sol_DUf_acc + Sol_dUf, Sol_DUf_acc)   ! it is possible to be the old

	end if

	ip = NodG*idofT + 1
	AE(iShift_AngleEst1 + ip, iShift_AngleEst1 + ip) = 1.0d0
	AE(iShift_AngleEst2 + ip, iShift_AngleEst2 + ip) = 1.0d0

	BE(iShift_AngleEst1 + ip) = AngleEst1
	BE(iShift_AngleEst2 + ip) = AngleEst2

end subroutine

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
Subroutine computeIncrementEstimationS(Coupling,CommonPar,iDofT,Ndim,MaxLRows,iAdd)
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	use ptsGaussLib, only : setNodG
	IMPLICIT NONE
	Integer :: MaxLRows,Ndim,iDofT, iAdd, ipRow
	Integer   Coupling(MaxLRows,MaxLRows)
	Real*8 CommonPar(*)

    integer	:: iShift_AngleEst1, iShift_AngleEst2, ip, NodG, iFEMtype

	iShift_AngleEst1 = nint(CommonPar(8))
	iShift_AngleEst2 = nint(CommonPar(9))
	iFEMtype = nint(CommonPar(10))

	call setNodG(iFEMtype,NodG)

	ip = NodG*idofT + 1
	Coupling(iShift_AngleEst1 + ip, iShift_AngleEst1 + ip) = 1
	Coupling(iShift_AngleEst2 + ip, iShift_AngleEst2 + ip) = 1

!~ 	call numprint(Coupling)
!~ 	pause
end Subroutine

max_stars_repo_name: felipefr/gpmaterials

max_issues_repo_name: felipefr/gpmaterials

max_forks_repo_name: felipefr/gpmaterials


program problem_3

!! how many trees would you encounter?

use aoc_utilities
use iso_fortran_env

implicit none

integer:: iunit, istat, n_lines, i, j, n_cols, col
character(len=1000) :: line
logical,dimension(:,:),allocatable :: data
integer,dimension(5),parameter :: right = [1,3,5,7,1]
integer,dimension(5),parameter :: down  = [1,1,1,1,2]
integer(int64) :: n_trees, product ! to avoid overflow

! read into a logical array (true=true)
open(newunit=iunit, file='input.txt', iostat=istat)
if (istat /= 0) error stop ' error reading file'
n_lines = number_of_lines_in_file(iunit)
do i = 1, n_lines
    read(iunit, '(A1000)', iostat=istat) line
    if (is_iostat_end(istat)) exit
    if (i==1) then
        n_cols = len_trim(line)
        allocate(data(n_lines, n_cols))
    end if
    do j = 1, n_cols
        data(i,j) = line(j:j) == '#'
    end do
end do

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

write(*,*) ''
write(*,*) 'part a:'

col = 0
n_trees = 0
do i = 1, n_lines
    if (data(i,col+1)) n_trees = n_trees + 1
    col = mod(col + 3, n_cols)
end do

write(*,*) 'n_trees = ', n_trees

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

write(*,*) ''
write(*,*) 'part b:'

product = 1
do j = 1, 5
    col = 0
    n_trees = 0
    do i = 1, n_lines, down(j)
        if (data(i,col+1)) n_trees = n_trees + 1
        col = mod(col + right(j), n_cols)
    end do
    product = product * n_trees
end do
write(*,*) 'product = ', product

end program problem_3


text: #redirect Cellular Wireless Internet Speeds


!================================================================================
!
! Modules:
!
! (1) intrinsics_m      Originally By DAS      Created 9/21/2011
!
!     Some compiler-dependent module usages and external definitions,
!     regarding accessing system calls. There is no actual code here.
!     These are preprocessor symbols defined in f_defs.h.
!
!================================================================================

#include "f_defs.h"

module intrinsics_m

  USEHOSTNAMEMOD
  USEOMPLIB
  SYSTEMMOD

  implicit none

  public

! note: these are split into two lines because ifort for some reason decrees of
! 'end interface' : "END statement must be only statement on line".

  HOSTNAME_INTERFACE
  HOSTNAME_INTERFACE2

  MCLOCK_INTERFACE
  MCLOCK_INTERFACE2

  IARGC_INTERFACE
  IARGC_INTERFACE2

  FTELL_INTERFACE
  FTELL_INTERFACE2

end module intrinsics_m


text:
      SUBROUTINE GRF_CNTR_LINE
     &          (xmin,xscale,ymin,yscale,
     &           line,color)

c***********************************************************************

c  Function:
c     This routine draws contour lines found by GRF_CNTR.

c  Parameters passed:
c     parameter    [t,n]         description {t is type, n is dimension}
c     xmin         [r]           minimum value along X axis
c     xscale       [r]           scale         along X axis
c     ymin         [r]           minimum value along Y axis
c     yscale       [r]           scale         along Y axis
c     line         [i]           line type to use
c     color        [c]           name or RGB sequence of color to use

c  Parameters returned:
c     parameter    [t,n]         description {t is type, n is dimension}

c  Common blocks referenced:
c     grf$cntr

c  Functions and subroutines referenced:
c     grf_color
c     grf_curve

c  References:

c  Change History:

c*******************!***************************************************

      IMPLICIT      NONE

      character*(*) color

      include      'grf_cntr.cmn'

      integer       line
      integer       n1
      integer       nh
      integer       nrp

      real          xmin
      real          xscale
      real          ymin
      real          yscale

      if (nrpts(nrholes) .lt. 3) RETURN

c     Set the color
      call GRF_COLOR (color)

c     Draw curve for each contour
      n1=1
      do nh=0,nrholes

         nrp=nrpts(nh)-n1+1

         call GRF_CURVE
     &       (cntrpx(n1),cntrpy(n1),nrp,
     &        xmin,ymin,xscale,yscale,line,20)

         n1=nrpts(nh)+1
      end do
      RETURN
      END      ! GRF_CNTR_LINE

ext: for

max_stars_repo_name: spinorkit/LWPC

max_issues_repo_name: spinorkit/LWPC

max_forks_repo_name: spinorkit/LWPC


text:
      PROGRAM ADVECT3D
      IMPLICIT NONE
      INTEGER nx, ng, tt

      parameter (nx = 256)
      parameter (ng = 9)
      parameter (tt = 1)
        REAL x(1-ng:nx+ng), y(1-ng:nx+ng), z(1-ng:nx+ng)
	REAL dx, dis
	REAL pi, Ad1, Ad2
	REAL  A0(1-ng:nx+1+ng, 1-ng:nx+1+ng)
	REAL  An(1-ng:nx  +ng, 1-ng:nx+  ng,1-ng:nx+  ng)
	REAL  Ao(1-ng:nx  +ng, 1-ng:nx+  ng,1-ng:nx+  ng)
        REAL  Ai(1-ng:nx  +ng, 1-ng:nx+  ng,1-ng:nx+  ng)
	REAL   u(1-ng:nx  +ng, 1-ng:nx+1+ng,1-ng:nx+  ng)
	REAL   v(1-ng:nx  +ng, 1-ng:nx+  ng,1-ng:nx+1+ng)
	REAL   w(1-ng:nx+1+ng, 1-ng:nx+  ng,1-ng:nx+  ng)
	REAL  u0(1-ng:nx  +ng, 1-ng:nx+1+ng,1-ng:nx+  ng)
	REAL  v0(1-ng:nx  +ng, 1-ng:nx+  ng,1-ng:nx+1+ng)
	REAL  w0(1-ng:nx+1+ng, 1-ng:nx+  ng,1-ng:nx+  ng)
	REAL  ut(1-ng:nx  +ng, 1-ng:nx+1+ng,1-ng:nx+  ng)
	REAL  vt(1-ng:nx  +ng, 1-ng:nx+  ng,1-ng:nx+1+ng)
	REAL  wt(1-ng:nx+1+ng, 1-ng:nx+  ng,1-ng:nx+  ng)
	REAL  uh(1-ng:nx  +ng, 1-ng:nx+1+ng,1-ng:nx+  ng)
	REAL  vh(1-ng:nx  +ng, 1-ng:nx+  ng,1-ng:nx+1+ng)
	REAL  wh(1-ng:nx+1+ng, 1-ng:nx+  ng,1-ng:nx+  ng)
        REAL X0, Y0, Z0, rad
        REAL dt
        REAL maxi
	INTEGER i,j,k,t,m, imgT
        INTEGER iloc, jloc, kloc
	real xl, yl, zl, third, half
        PARAMETER (dt = 0.005)
        PARAMETER (pi = 3.1415926)
        PARAMETER (X0 = 0.00)
	PARAMETER (Y0 = 0.00)
	PARAMETER (Z0 = 0.00)
        PARAMETER (rad = 0.15)
        imgT = Tt/4
        dx = 1./REAL(nx)
        maxi = 0.0
	third = 1./3.
	half = 0.5

	do i=1-ng,nx+ng
	   x(i) = -.5 + dx*REAL(i)
	   y(i) = -.5 + dx*REAL(i)
	   z(i) = -.5 + dx*REAL(i)
	end do
	xl = REAL(nx) * dx * .5
	yl = REAL(nx) * dx * .5
	zl = REAL(nx) * dx * .5

        do j=1,nx
          do i=1,nx
            do k=1,nx
              u0(k,i,j) =  1.0 * (x(k) - 0.5*dx)
              v0(k,i,j) = 0.
              w0(k,i,j) = -1.0 * (z(i) - 0.5*dx)
            end do
          end do
        end do

        Ad1 = 0.
	 do j=1,nx
           do i=1,nx
	     do k=1,nx
	     dis = SQRT( (x(i) -.5*dx - X0)**2 +
     +                   (y(j) -.5*dx - Y0)**2 +
     +                   (z(k) -.5*dx - Z0)**2)
                Ao(k,i,j) = (20. * 0.5 * (1. + COS(dis*pi/rad)))*
     +                    (.5+sign(.5,rad-dis))
              Ai(k,i,j) = Ao(k,i,j)
              An(k,i,j) = 0.0
              Ad1 = Ad1 + Ao(k,i,j)
	    end do
	  end do
	end do
	do i=1-ng,nx+ng
           do k=1-ng,nx+ng
              do m = 0, 1-ng
                 Ao(k,i,m) = Ao(k,i,1)
              enddo
              do m = nx + 1, nx + ng
                 Ao(k,i,m) = Ao(k,i,nx)
              enddo
           enddo
        enddo
        do j=1-ng,nx+ng
           do k=1-ng,nx+ng
	   do m = 0, 1-ng
              Ao(k,m,j) = Ao(k,1 ,j)
	   enddo
           do m = nx+1, nx+ng
              Ao(k,m,j) = Ao(k,nx,j)
           enddo
        enddo

           do i=1,nx
	   do k=1-ng,nx+ng
              maxi = MAX(maxi,Ao(k,i,j))
	      if(Ao(k,i,j) .EQ. maxi) then
		 iloc = i
		 jloc = j
		 kloc = k
	      endif
           end do
           end do
        end do
         write(*,*) maxi, 'max val start ',iloc,jloc,kloc
        maxi = 0.0
	print *, '( nx, ng, tt ) = ', '(', nx, ',', ng, ',', tt, ')'
        write (*,*) Tt
        do t=1, 5
            call twostages(Ao, An, u0, v0, w0, u0, v0, w0,
     &                      dt, dx, dx, dx, nx, nx, nx, ng)

            do j = 1, nx
               do i = 1, nx
                  do k = 1, nx
                     Ao(k,i,j) = An(k,i,j)
                  enddo
               enddo
            enddo
        end do
        write(*,*) An(kloc,jloc,iloc), ' val @ finish for initial max '
        Ad2 = 0.
        do j=1,nx
          do i=1,nx
	   do k=1-ng,nx+ng
              maxi = MAX(maxi,Ao(k,i,j))
	      if(Ao(k,i,j) .EQ. maxi) then
		 iloc = i
		 jloc = j
		 kloc = k
	      endif
	      Ad2 = Ad2 + An(k,i,j)
           end do
          end do
        end do
        write(*,*) maxi, 'max val finish ',iloc,jloc
        maxi = 0.0
        do j = 1, nx
           do i = 1, nx
              do k = 1, nx
                 Ai(k, i, j) = An(k, i, k) - Ai(k, i, j)
              enddo
           enddo
        enddo
        do j=1,nx
          do i=1,nx
	    do k=1-ng,nx+ng
              maxi = MAX(maxi,Ai(k,i,j))
	      if(Ai(k,i,j) .EQ. maxi) then
		 iloc = i
		 jloc = j
		 kloc = k
	      endif
           end do
          end do
        end do
         write(*,*) 'max error finish: ',maxi,iloc,jloc
         write(*,*) 'Starting amount:  ',Ad1
         write(*,*) 'Finishing amount: ',Ad2
         write(*,*) 'Percent conserved: ',Ad2/Ad1 * 100.

       END


text:
subroutine foo()

integer :: i
volatile :: i

end subroutine

max_stars_repo_name: maurizioabba/rose


PROGRAM Feritas

   USE PrecTypes     !  Types of variables are defined
   USE GlobalData    !  All the global variables are defined
   IMPLICIT NONE
   ! -------------------------------------------------------------------------
   ! NAME:   Feritas
   ! STATUS: Current
   ! OWNER:  Toshiro Matsumoto
   !         Department of Mechanical Science and Engineering
   !         Nagoya Univerisity
   !         Furo-cho, Chikusa-ku, Nagoya 464-8603, Japan
   !         E-mail: t.matsumoto@nuem.nagoya-u.ac.jp
   !         Copyright 2009 Toshiro Matsumoto. All rights reserved.
   ! TEXT:   Main program of FEM code Feritas for solutions of two-dimensional
   !         steady-state heat conduction problems and linear elastostatic and
   !         thermo-elastostatic problems.
   ! REVISION DATE: 16-Jul-2009
   ! -------------------------------------------------------------------------

   INTEGER :: i,j
   REAL :: stime,etime,ctime

   ! Show a starting message
   CALL StartingMessage

   ! Show the starting time
   stime = 0.0
   CALL CheckTime(stime,etime,ctime)

   ! Read input data
   WRITE(*,'(/,A)') '* Entry to [Input]'
   CALL Input
   CALL CheckTime(stime,etime,ctime)

   IF (meshCheck==1) THEN

      WRITE(*,'(/,A)') '* Entry to [EPSoutput] for generating mesh diagram'
      CALL EPSoutput

   ELSE

      ! Presprocessing (setting up flags, allocation of stiffness matrix, etc.)
      WRITE(*,'(/,A)') '* Entry to [Preprocess]'
      CALL Preprocess
      CALL CheckTime(stime,etime,ctime)

     ! Calculate the band width
      WRITE(*,'(/,A)') '* Entry to [BandWidth]'
      CALL BandWidth
      CALL CheckTime(stime,etime,ctime)

      ! Construct the stiffness matrix
      WRITE(*,'(/,A)') '* Entry to [Matrix]'
      CALL Matrix
      CALL CheckTime(stime,etime,ctime)

      ! Solve the system of linear algebraic equations
      WRITE(*,'(/,A)') '* Entry to [Solve]'
      CALL Solve
      CALL CheckTime(stime,etime,ctime)

      ! Output the solutions
      WRITE(*,'(/,A)') '* Entry to [Output]'
      CALL Output
      CALL CheckTime(stime,etime,ctime)

      ! Graphical results are outputted to EPS files
      IF (dim==2) THEN
         WRITE(*,'(/,A)') '* Entry to [EPSoutput]'
         CALL EPSoutput
         CALL CheckTime(stime,etime,ctime)
      END IF

   END IF

   ! Show an ending message
   CALL EndingMessage

END PROGRAM Feritas


text: A Davis townie. One of the founders of the Davis Music Scene. A good portion of the debt is owed to this man for his contributions to DMS. He played sporatically with a number of bands that he wrote nearly all the material for, including: False Dawn, Shots Were Fired and Carl and Company. The core of most of these bands consisted of Carl, Alex Stupakov, and Users/AndrewMatey. Carl currently resides in wiki:santacruz Santa Cruz.


text:
      LOGICAL FUNCTION ZGENND (M, N, A, LDA)
      IMPLICIT NONE
*
*  -- LAPACK test routine (version 3.1) --
*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
*     February 2008
*
*     .. Scalar Arguments ..
      INTEGER M, N, LDA
*     ..
*     .. Array Arguments ..
      COMPLEX*16 A( LDA, * )
*     ..
*
*  Purpose
*  =======
*
*     ZGENND tests that its argument has a real, non-negative diagonal.
*
*  Arguments
*  =========
*
*  M       (input) INTEGER
*          The number of rows in A.
*
*  N       (input) INTEGER
*          The number of columns in A.
*
*  A       (input) COMPLEX*16 array, dimension (LDA, N)
*          The matrix.
*
*  LDA     (input) INTEGER
*          Leading dimension of A.
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ZERO
      PARAMETER          ( ZERO = 0.0E0 )
*     ..
*     .. Local Scalars ..
      LOGICAL OUT
      INTEGER I, K
      COMPLEX*16 AII
*     ..
*     .. Intrinsics ..
      INTRINSIC MIN, DBLE, DIMAG
*     ..
*     .. Executable Statements ..
      K = MIN( M, N )
      DO I = 1, K
         AII = A( I, I )
         IF( DBLE( AII ).LT.ZERO.OR.DIMAG( AII ).NE.ZERO ) THEN
            ZGENND = .FALSE.
            RETURN
         END IF
      END DO
      ZGENND = .TRUE.
      RETURN
      END


text:
program bits_03
    implicit none
    integer(4) :: from, to
    integer(8) :: from8, to8
    from = 10
    to = 4
    from8 = 10_8
    to8 = 4_8
    call mvbits(from, 2, 2, to, 0)
    if (from /= 10) error stop
    if (to /= 6) error stop
    call mvbits(from8, 2, 2, to8, 0)
    if (from8 /= 10) error stop
    if (to8 /= 6_8) error stop
    call mvbits(from, 0, 2, to, 2)
    if (from /= 10) error stop
    if (to /= 10) error stop
    call mvbits(from8, 0, 2, to8, 2)
    if (from8 /= 10) error stop
    if (to8 /= 10_8) error stop
    from  = -20
    to = 4
    from8 = -20_8
    to8 = 4_8
    call mvbits(from, 29, 2, to, 2)
    if (from /= -20) error stop
    if (to /= 12) error stop
    call mvbits(from8, 29, 2, to8, 2)
    if (from8 /= -20) error stop
    if (to8 /= 12_8) error stop
    call mvbits(from, 2, 2, to, 29)
    if (from /= -20) error stop
    if (to /= 1610612748) error stop
    call mvbits(from8, 2, 2, to8, 29)
    if (from8 /= -20) error stop
    if (to8 /= 1610612748_8) error stop
end program

max_stars_repo_name: Thirumalai-Shaktivel/lfortran

max_issues_repo_name: Thirumalai-Shaktivel/lfortran

max_forks_repo_name: Thirumalai-Shaktivel/lfortran


text:
c=======================================================================
c== readhb =============================================================
c=======================================================================

c-----------------------------------------------------------------------
c UMFPACK Copyright (c) 2005-2012 by Timothy A. Davis,
c http://www.suitesparse.com.  All Rights Reserved.
c See ../Doc/License.txt for License.
c-----------------------------------------------------------------------

c readhb:
c       read a sparse matrix in the Harwell/Boeing format and
c       output a matrix in triplet format.
c
c usage (for example):
c
c       in a Unix shell:
c       readhb < HB/arc130.rua > tmp/A
c
c       Then, in MATLAB, you can do the following:
c       >> load tmp/A
c       >> A = spconvert (A) ;
c       >> spy (A)

        integer nzmax, nmax
        parameter (nzmax = 20000000, nmax = 250000)
        integer Ptr (nmax), Index (nzmax), n, nz, totcrd, ptrcrd,
     $          indcrd, valcrd, rhscrd, ncol, nrow, nrhs, row, col, p
        character title*72, key*30, type*3, ptrfmt*16,
     $          indfmt*16, valfmt*20, rhsfmt*20
        logical sym
        double precision Value (nzmax), skew
        character rhstyp*3
        integer nzrhs, nel

        integer ne, nnz

c-----------------------------------------------------------------------

c       read header information from Harwell/Boeing matrix

        read (5, 10, err = 998)
     $          title, key,
     $          totcrd, ptrcrd, indcrd, valcrd, rhscrd,
     $          type, nrow, ncol, nz, nel,
     $          ptrfmt, indfmt, valfmt, rhsfmt
        if (rhscrd .gt. 0) then
c          new Harwell/Boeing format:
           read (5, 20, err = 998) rhstyp,nrhs,nzrhs
           endif
10      format (a72, a8 / 5i14 / a3, 11x, 4i14 / 2a16, 2a20)
20      format (a3, 11x, 2i14)

        skew = 0.0
        if (type (2:2) .eq. 'Z' .or. type (2:2) .eq. 'z') skew = -1.0
        if (type (2:2) .eq. 'S' .or. type (2:2) .eq. 's') skew =  1.0
        sym = skew .ne. 0.0

        write (0, 31) key
31      format ('Matrix key: ', a8)

        n = max (nrow, ncol)

        if (n .ge. nmax .or. nz .gt. nzmax) then
           write (0, *) 'Matrix too big!'
           write (0, *) '(recompile readhb.f with larger nzmax, nmax)'
           stop
        endif

        read (5, ptrfmt, err = 998) (Ptr (p), p = 1, ncol+1)
        read (5, indfmt, err = 998) (Index (p), p = 1, nz)

        do 55 col = ncol+2, n+1
           Ptr (col) = Ptr (ncol+1)
55      continue

c       read the values
        if (valcrd .gt. 0) then
           read (5, valfmt, err = 998) (Value (p), p = 1, nz)
        else
           do 50 p = 1, nz
              Value (p) = 1
50         continue
        endif

c  create the triplet form of the input matrix

        ne = 0
        nnz = 0
        do 100 col = 1, n
           do 90 p = Ptr (col), Ptr (col+1) - 1
              row = Index (p)

              ne = ne + 1
                  nnz = nnz + 1
                  write (6, 200) row, col, Value (p)

              if (sym .and. row .ne. col) then
                 ne = ne + 1
                 if (Value (p) .ne. 0) then
                    nnz = nnz + 1
                    write (6, 200) col, row, skew * Value (p)
                 endif
              endif

90            continue
100        continue
200     format (2i7, e30.18e3)

c       write (0,*) 'Number of entries: ',ne,' True nonzeros: ', nnz
        stop

998     write (0,*) 'Read error: Harwell/Boeing matrix'
        stop
        end

max_stars_repo_name: gabrielfougeron/SuiteSparse

max_issues_repo_name: gabrielfougeron/SuiteSparse

max_forks_repo_name: gabrielfougeron/SuiteSparse


text:
! free.f90 -- generates a "free(): invalid pointer" error
program free
  integer, dimension(:), allocatable :: data
  integer :: i

  allocate(data(5))
  do i = 1, 5
     data(i-1) = i
  end do
  deallocate(data)
end program free

max_stars_repo_name: jrblevin/scicomp

max_issues_repo_name: jrblevin/scicomp

max_forks_repo_name: jrblevin/scicomp


text: Phi Beta Sigma is a service Fraternities fraternity founded at Howard University on January 9, 1914.  It is historically AfricanAmericans African American.


text:
      program t
      integer a
      integer :: b
      integer c,d
      integer::e,f
      integer(kind=4) g
      integer(kind=8)::h,i
      integer::j=0
      integer::k=1,l=2+3
      integer,pointer::m
      integer,target::n
      integer,external::o
      integer(kind=4),parameter::q=4
      integer(kind=8),allocatable,dimension(:,:)::r
      a=-1
      b=-2
      c=-3
      d=-4*1
      e=a*b
      f=c**e
      g=a-b*c
      print '(i0)',a
      print '(i0)',b
      print '(i0)',c
      print '(i0)',d
      print '(i0)',e
      print '(i0)',f
      print '(i0)',g
      print '(i0)',j
      print '(i0)',k
      print '(i0)',l
      print '(i0)',q
      end program t

max_stars_repo_name: maddenp/ppp

max_issues_repo_name: maddenp/ppp

max_forks_repo_name: maddenp/ppp


text:
!> @brief Test the parallel distribution of a mesh's points.
!
!> @description A mesh of size N should have its points distributed in parallel such that
!!              \f$\sum_p n_p = N\f$.
program test_mesh_point_distribution

  use testing_lib
  use mesh_utils, only : build_square_mesh

  implicit none

  type(ccs_mesh) :: mesh

  integer(ccs_int) :: n

  integer(ccs_int) :: n_expected
  integer(ccs_int) :: n_global

  call init()

  do n = 1, 100
    mesh = build_square_mesh(par_env, n, 1.0_ccs_real)

    associate(nlocal => mesh%nlocal)
      if (nlocal < 0) then
        ! XXX: Zero cells on a PE is not necessarily invalid...
        ! ? exit
        ! select type(par_env)
        ! type is(parallel_environment_mpi)
        !   call MPI_Allreduce(nlocal, n_global, 1, MPI_INT, MPI_SUM, par_env%comm, ierr)
        ! class default
        !   write (message,*) "ERROR: Unknown parallel environment!"
        !   call stop_test(message)
        ! end select
      end if

      n_expected = n**2

      if (nlocal > n_expected) then
        write (message,*) "FAIL: Local number of cells ", nlocal, &
             " exceeds requested total!", n
        call stop_test(message)
      end if

      select type(par_env)
      type is(parallel_environment_mpi)
        call MPI_Allreduce(nlocal, n_global, 1, MPI_INT, MPI_SUM, par_env%comm, ierr)
      class default
        write (message,*) "ERROR: Unknown parallel environment!"
        call stop_test(message)
      end select
    end associate

    if (n_global /= n_expected) then
      write (message,*) "FAIL: expected ", n_expected, " got ", n_global, &
           " (test_mesh:test_mesh_point_distribution/1)"
      call stop_test(message)
    end if

    call assert_equal(n_expected, mesh%nglobal, &
         '("FAIL: expected ", i0, " got ", i0, " (test_mesh:test_mesh_point_distribution/2)")')

  end do

  call fin()

end program test_mesh_point_distribution

max_stars_repo_name: asimovpp/asimov-ccs

max_issues_repo_name: asimovpp/asimov-ccs

max_forks_repo_name: asimovpp/asimov-ccs


text:
c
c  This is a function used when IMSL is not available
c
c
c***********************************************
c
      logical function invert4(R,S)
c
c***********************************************
c
c    calculates the inverse matrix of the 4x4 real matrix R
c
c    11/6/95 by J. Dwyer
c
      real R(4,4)    ! input matrix
      real  S(4,4)    ! inverse matrix of R
      real Q(3,3)     ! submatrix
      real  detR, det3      ! determinant of R and Q
      integer  indexk, indexl
c
      detR = 0.0
      i = 1
      do 30 j=1,4
          indexk = 1
          do 20 k=1,4
              indexl = 1
              do 10 l=1,4
                  if ((k.ne.i).and.(l.ne.j)) then
                       Q(indexk,indexl)=R(k,l)
                  end if
                 if (l.ne.j) indexl = indexl+1
10    continue
              if (k.ne.i) indexk = indexk+1
20    continue
           detR = detR+((-1.0)**(i+j))*R(i,j)*det3(Q)
30    continue

c
      if (detR.ne.0.0) then
         invert4 = .true.
         do 100 i=1,4
            do 100 j=1,4
               indexk = 1
               do 60 k=1,4
                  indexl = 1
                   do 50 l=1,4
                       if ((k.ne.i).and.(l.ne.j)) then
                           Q(indexk,indexl)=R(k,l)
                       end if
                       if (l.ne.j) indexl = indexl+1
50               continue
                   if (k.ne.i) indexk = indexk+1
60           continue
               S(i,j) = ((-1.0)**(i+j))*det3(Q)/detR
100       continue
c
c        call check_inverse(R,S)
c
         return  ! successful
      end if
c
      invert4 = .false.  ! no inverse possible
      return
      end  ! end invert4
c
c
c
c
c************************************************
c
      real function det3(Q)
c
c************************************************
c
c  calculates the determinent of the 3x3 real matrix Q
c
      real  Q(3,3)
c
      det3 = Q(1,1)*(Q(2,2)*Q(3,3)-Q(3,2)*Q(2,3))-
     1          Q(2,1)*(Q(1,2)*Q(3,3)-Q(1,3)*Q(3,2))+
     1          Q(3,1)*(Q(1,2)*Q(2,3)-Q(1,3)*Q(2,2))
c
      return
      end  ! end det3
c
c
c
c
c***********************************************
c
      subroutine check_inverse(R,S)
c
c***********************************************
c
c    calculates the inverse matrix of the 4x4 real matrix R
c
c    11/6/95 by J. Dwyer
c         fixed U(4,4)  5/1/96
c
      real  R(4,4)    ! input matrix
      real  S(4,4)    ! inverse matrix of R
      real  U(4,4)

      do 100 i=1,4
         do 100 j=1,4
             U(i,j) = 0.0
100     continue
c
      do 300 i=1,4
         do 300 j=1,4
             do 200 k=1,4
                 U(i,j) = U(i,j)+R(i,k)*S(k,j)
200     continue
300     continue
c
      print *, ' '
      do 500 i=1,4
            print *, U(i,1), U(i,2), U(i,3), U(i,4)
500     continue
c
      return
      end  ! check_inverse
c

max_stars_repo_path: EPACE_STEP_code/2_sdf_rom_spikes/sdf_rom_spikes_source/files in vax dir but not used/INVERT.f95


     program demo_newpen
     use M_calcomp
     character(len= 4)  :: ICHR3='ANG='
     character(len= 4)  :: ICHR4=', H='
     character(len= 19) :: ICHR5='ANGULAR LETTER TEST'
     call plots(0.0,10.0,0.0,10.0)
     ! PLOT ANGULAR LETTER TEST
     call plot(4.5,5.5,-3)
     angle=0.0
     height=0.105
     do i=1,8
        call newpen(i)
        rad=0.0174533*angle
        xx=0.5*cos (rad)
        yy=0.5*sin (rad)
        call symbol( xx  , yy  ,height,ichr3,inteq,angle, 4)
        call number(999.0,999.0,height,angle ,angle,-1)
        call symbol(999.0,999.0,height,ichr4,inteq,angle, 4)
        call number(999.0,999.0,height,height,angle, 3)
        height=height+0.035
        angle=angle+45.0
     enddo
     call newpen(1)
     call symbol(-1.4,4.0,0.14,ichr5,inteq,0.0,19)
     call plot( 4.5, 5.0,3)
     call plot(-4.5, 5.0,2)
     call plot(-4.5,-5.5,2)
     call plot( 4.5,-5.5,2)
     call plot( 4.5, 5.0,2)
     !call plot( 6.5,-5.5,-3)
     call plot(0.0,0.0,999)
     end program demo_newpen