text:
Marijuana Anonymous is a fellowship of men and women who share our experience, strength, and hope with each other that we may solve our common problem and help others to recover from marijuana addiction.

For those who think Marijuana  pot may be a problem, Marijuana Anonymous, aka MA, is a wiki:wikipedia:Twelvestep program 12 Step addiction recovery support group with open and closed meetings. All MA meetings in Sacramento and Davis are open meetings where nonaddicts are welcome. The main MA site has http://www.marijuanaanonymous.org/onlinemeetings.shtml online meetings

Other recovery options include medical treatment (talk to medical professional),  http://www.unhooked.com/faq/index.htm LifeRing, http://smartrecovery.org/ SMART Recovery. Other more inclusive 12 step programs, such as http://www.na.org/ Narcotics Anonymous or http://www.ca.org/ Cocaine Anonymous welcome potheads. Also, many churches have 12 Step programs which forgo the 12 Traditions.

As of April 2014, Marijuana Anonymous meetings are now being held at 1111 H street on Sunday mornings at 10:30 AM.

20080225 00:44:55 nbsp what the world REALLY needs is more Christians and less potheads. The world would be a MUCH better place then... Users/PxlAted

20080225 10:52:50 nbsp I always think of the scene in Half Baked, whenever marijuana addiction is brought up... Users/JamesSchwab

20090102 09:09:16 nbsp There is no such thing as marijuana addiction, any more than there is such a thing as fast food addiction. Users/OscarSabino
 Youve never met people who smoke their entire paycheck and feel the need to be stoned 24/7? Sure, it isnt a chemical addiction, but it certainly can be problematic.  wl

20100406 16:14:30 nbsp LOL at the comment about christians... i think youve got it backwards buddy! Users/Jake510

20100406 16:34:57 nbsp I used to hate this organization until I got high.   Users/ScottMeehleib


text:
C
C $Id: gageti.f,v 1.6 2008-07-27 00:17:13 haley Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
      SUBROUTINE GAGETI (PNAM,IVAL)
C
        CHARACTER*(*) PNAM
C
C The subroutine GAGETI may be used to get GRIDAL parameters which have
C values of type INTEGER.
C
C Check for an uncleared prior error.
C
        IF (ICFELL('GAGETI - UNCLEARED PRIOR ERROR',1).NE.0) RETURN
C
C Just convert the call into a call to the routine GAGETR.
C
        CALL GAGETR (PNAM,RVAL)
        IF (ICFELL('GAGETI',2).NE.0) RETURN
        IVAL=INT(RVAL)
C
C Done.
C
        RETURN
C
      END

ext: f

max_stars_repo_name: tenomoto/ncl

max_issues_repo_name: tenomoto/ncl

max_forks_repo_name: tenomoto/ncl


text:
MODULE Nonc_chisq
IMPLICIT NONE
INTEGER, PARAMETER  :: dp = SELECTED_REAL_KIND(12, 60)

! COMMON /qfcom/ aintl,ersm,pi,aln28,sigsq,almax,almin,amean,c,  &
!    icount,ir,ndtsrt,fail,lim
REAL (dp), SAVE  :: aintl, ersm
REAL, SAVE       :: pi, aln28, sigsq, almax, almin, amean, c
INTEGER, SAVE    :: icount, ir, lim
LOGICAL, SAVE    :: ndtsrt, fail

CONTAINS

FUNCTION iround(x) RESULT(ival)
IMPLICIT NONE

REAL, INTENT(IN)  :: x
INTEGER           :: ival

REAL, PARAMETER  :: half = 0.5

ival = INT(x + SIGN(half,x))
RETURN
END FUNCTION iround

FUNCTION qf(alb, anc, n, irr, sigma, cc, lim1, acc, ith, trace, ifault)  &
   RESULT(fn_val)

! Code converted using TO_F90 by Alan Miller
! Date: 2004-01-06  Time: 08:37:41

!     ALGORITHM AS 155  APPL. STATIST. (1980) VOL.29, NO.3

!     Distribution of a linear combination of non-central chi-squared
!     random variables.

IMPLICIT NONE
INTEGER, INTENT(IN)   :: irr
REAL, INTENT(IN)      :: alb(irr)
REAL, INTENT(IN)      :: anc(irr)
INTEGER, INTENT(IN)   :: n(irr)
REAL, INTENT(IN)      :: sigma
REAL, INTENT(IN)      :: cc
INTEGER, INTENT(IN)   :: lim1
REAL, INTENT(IN)      :: acc
INTEGER, INTENT(OUT)  :: ith(irr)
REAL, INTENT(OUT)     :: trace(7)
INTEGER, INTENT(OUT)  :: ifault
REAL                  :: fn_val

INTEGER  :: j, nj, nt, ntm
REAL     :: acc1, almx, xlim, xnt, xntm
REAL     :: utx, tausq, sd, aintv, aintv1, x, up, un, d1, d2, alj, ancj
REAL (dp) :: aintl, ersm
REAL     :: pi, aln28, sigsq, almax, almin, amean, c
INTEGER  :: icount, ir, lim
LOGICAL  :: ndtsrt, fail
REAL, PARAMETER  :: zero = 0.0, half = 0.5, one = 1.0, two = 2.0, four = 4.0, &
    sixtn = 16.0, fourp5 = 4.5, pt07 = 0.07, pt2 = 0.2, quart = 0.25,  &
    ten = 10.0, pt33 = 0.33, pt67 = 0.67, pt75 = 0.75, onept5 = 1.5,  &
    three = 3.0, onept1 = 1.1

!     Setting constants in COMMON.   ALN28 = ln(2) / 8.

pi = 3.14159265358979
aln28 = 0.0866

c = cc
ir = irr
lim = lim1
trace(1:7) = zero
ifault = 0
icount = 0
aintl = zero
ersm = zero
fn_val = -one
acc1 = acc
ndtsrt = .true.
fail = .false.

!     Find mean, sd, max & min of ALB.
!     Check that parameter values are valid.

xlim = lim
sigsq = sigma**2
sd = sigsq
almax = zero
almin = zero
amean = zero
j = 1

20 IF (.NOT.(j <= ir)) GO TO 60
nj = n(j)
alj = alb(j)
ancj = anc(j)
IF (.NOT.(nj < 0 .OR. ancj < zero)) GO TO 30
ifault = 3
GO TO 260

30 sd = sd + alj**2*(2*nj + four*ancj)
amean = amean + alj*(nj + ancj)
IF (.NOT.(almax < alj)) GO TO 40
almax = alj
GO TO 50

40 IF (.NOT.(almin > alj)) GO TO 50
almin = alj
50 j = j + 1
GO TO 20

60 IF (.NOT.(sd == zero)) GO TO 80
IF (.NOT.(c > zero)) GO TO 70
fn_val = one
GO TO 260

70 fn_val = zero
GO TO 260
80 IF (.NOT.(almin == zero .AND. almax == zero .AND. sigma == zero)) GO TO 90
ifault = 3
GO TO 260

90 sd = SQRT(sd)
IF (.NOT.(almax < -almin)) GO TO 100
almx = -almin
GO TO 110
100 almx = almax

!     Starting values for FINDU * CTFF.

110 utx = sixtn/sd
up = fourp5/sd
un = -up

!     Truncation point with no convergence factor.

CALL findu (n, alb, anc, utx, half*acc1)

!     Does convergence factor help ?

IF (.NOT.(c /= zero .AND. almx > pt07*sd)) GO TO 130
tausq = quart*acc1/cfe(n, alb, anc, ith, c)
IF (.NOT.(fail)) GO TO 120
fail = .false.
GO TO 130

120 IF (.NOT.(truncn(n, alb, anc, utx, tausq) < pt2*acc1)) GO TO 130
sigsq = sigsq + tausq
CALL findu (n, alb, anc, utx, quart*acc1)
trace(6) = SQRT(tausq)
130 trace(5) = utx
acc1 = half*acc1

!     Find 'range' of distribution, quit if outside of this.

140 d1 = ctff(n, alb, anc, acc1, up) - c
IF (.NOT.(d1 < zero)) GO TO 150
fn_val = one
GO TO 260
150 d2 = c - ctff(n, alb, anc, acc1, un)
IF (.NOT.(d2 < zero)) GO TO 160
fn_val = zero
GO TO 260

!     Find integration interval.

160 IF (.NOT.(d1 > d2)) GO TO 170
aintv = d1
GO TO 180
170 aintv = d2
180 aintv = two*pi/aintv

!     Calculate number of terms required for main & auxiliary
!     integrations.

xnt = utx/aintv
xntm = three/SQRT(acc1)
IF (.NOT.(xnt > xntm*onept5)) GO TO 220
IF (.NOT.(xntm > xlim)) GO TO 190
ifault = 1
GO TO 260

!     Parameters for auxiliary integration.

190 ntm = iround(xntm)
aintv1 = utx/xntm
x = two*pi/aintv1
IF (.NOT.(x <= ABS(c))) GO TO 200
GO TO 220

!     Calculate convergence factor.

200 tausq = cfe(n, alb, anc, ith, c - x) + cfe(n, alb, anc, ith, c + x)
tausq = pt33*acc1/(onept1*tausq)
IF (.NOT.(fail)) GO TO 210
GO TO 220
210 acc1 = pt67*acc1

!     Auxiliary integration.

CALL integr (n, alb, anc, ntm, aintv1, tausq, .false.)
xlim = xlim - xntm
sigsq = sigsq + tausq
trace(3) = trace(3) + 1
trace(2) = trace(2) + ntm + 1

!     Find truncation point with new convergence factor.

CALL findu (n, alb, anc, utx, quart*acc1)
acc1 = pt75*acc1
GO TO 140

!     Main integration.

220 trace(4) = aintv
IF (.NOT.(xnt > xlim)) GO TO 230
ifault = 1
GO TO 260

230 nt = iround(xnt)
CALL integr (n, alb, anc, nt, aintv, zero, .true.)
trace(3) = trace(3) + 1
trace(2) = trace(2) + nt + 1
fn_val = half - aintl
trace(1) = ersm
up = ersm

!     Test whether round-off error could be significant.
!     Allow for radix 8 or 16 machines.

x = up + acc/ten
j = 1
240 IF (.NOT.(j <= 8)) GO TO 260
IF (.NOT.(j*x == j*up)) GO TO 250
ifault = 2
250 j = j*2
GO TO 240

260 trace(7) = icount
RETURN
END FUNCTION qf

SUBROUTINE countr()

!     Count number of calls to ERRBD, TRUNCN & CFE.

IMPLICIT NONE
! COMMON /qfcom/ aintl,ersm,pi,aln28,sigsq,almax,almin,amean,c,  &
!    icount,ir,ndtsrt,fail,lim

icount = icount + 1
IF (.NOT.(icount > lim)) GO TO 20
WRITE (6, 10)
10 FORMAT (' qf: cannot locate integration parameters'/)
STOP
20 RETURN
END SUBROUTINE countr

FUNCTION alog1(x, first) RESULT(fn_val)

!     If FIRST then return ln(1 + x) else ln(1 + x) - x.

IMPLICIT NONE
REAL, INTENT(IN)     :: x
LOGICAL, INTENT(IN)  :: first
REAL                 :: fn_val

REAL    :: s, s1, term, y, ak
REAL, PARAMETER  :: pt1 = 0.1, one = 1.0, two = 2.0, three = 3.0

IF (.NOT.(ABS(x) > pt1)) GO TO 20
IF (.NOT.(first)) GO TO 10
fn_val = LOG(one + x)
GO TO 70

10 fn_val = LOG(one + x) - x
GO TO 70

20 y = x/(two + x)
term = two*y**3
ak = three
IF (.NOT.(first)) GO TO 30
s = two
GO TO 40

30 s = -x
40 s = s*y
y = y**2
s1 = s + term/ak

50 IF (.NOT.(s1 /= s)) GO TO 60
ak = ak + two
term = term*y
s = s1
s1 = s + term/ak
GO TO 50

60 fn_val = s
70 RETURN
END FUNCTION alog1

FUNCTION exp1(x) RESULT(fn_val)

IMPLICIT NONE
REAL, INTENT(IN)  :: x
REAL              :: fn_val

REAL, PARAMETER  :: zero = 0.0, neg50 = -50.0

IF (.NOT.(x < neg50)) GO TO 10
fn_val = zero
GO TO 20
10 fn_val = EXP(x)
20 RETURN
END FUNCTION exp1

SUBROUTINE order (alb, ith)

!     Find order of absolute values of ALB.

IMPLICIT NONE
REAL, INTENT(IN)         :: alb(*)
INTEGER, INTENT(IN OUT)  :: ith(*)

INTEGER  :: j, k, k1, ithk
REAL     :: alj
! COMMON /qfcom/ aintl,ersm,pi,aln28,sigsq,almax,almin,amean,c,  &
!    icount,ir,ndtsrt,fail,lim

j = 1
10 IF (.NOT.(j <= ir)) GO TO 60
alj = ABS(alb(j))
k = j - 1
20 IF (.NOT.(k > 0)) GO TO 40
ithk = ith(k)
k1 = k + 1
IF (.NOT.(alj > ABS(alb(ithk)))) GO TO 50
ith(k1) = ithk
k = k - 1
GO TO 20

40 k = 0
k1 = 1
50 ith(k1) = j
j = j + 1
GO TO 10

60 ndtsrt = .false.
RETURN
END SUBROUTINE order

FUNCTION errbd(n, alb, anc, uu, cx) RESULT(fn_val)

!     Find bound on tail probability using mgf.
!     Cut-off point returned to CX.

IMPLICIT NONE
INTEGER, INTENT(IN)  :: n(*)
REAL, INTENT(IN)     :: alb(*)
REAL, INTENT(IN)     :: anc(*)
REAL, INTENT(IN)     :: uu
REAL, INTENT(OUT)    :: cx
REAL                 :: fn_val

REAL     :: u
REAL     :: sum1, alj, ancj, x, y, const
INTEGER  :: j, nj
! COMMON /qfcom/ aintl, ersm, pi, aln28, sigsq, almax, almin, amean, c,  &
!    icount,ir,ndtsrt,fail,lim
REAL, PARAMETER  :: half = 0.5, one = 1.0, two = 2.0

CALL countr()
u = uu
const = u*sigsq
sum1 = u*const
u = two*u
j = ir
10 IF (.NOT.(j > 0)) GO TO 20
nj = n(j)
alj = alb(j)
ancj = anc(j)
x = u*alj
y = one - x
const = const + alj*(ancj/y + nj)/y
sum1 = sum1 + ancj*(x/y)**2
sum1 = sum1 + nj*(x**2/y + alog1(-x,.false.))
j = j - 1
GO TO 10
20 fn_val = exp1(-half*sum1)
cx = const
RETURN
END FUNCTION errbd

FUNCTION ctff(n, alb, anc, accx, upn) RESULT(fn_val)

!     Find CTFF so that P(QF > CTFF) < ACCX if UPN > 0;
!     P(QF < CTFF) < ACCX otherwise.

IMPLICIT NONE
INTEGER, INTENT(IN)   :: n(*)
REAL, INTENT(IN)      :: alb(*)
REAL, INTENT(IN)      :: anc(*)
REAL, INTENT(IN)      :: accx
REAL, INTENT(IN OUT)  :: upn
REAL                  :: fn_val

REAL     :: u1, u2, u, rb, const, c1, c2
! COMMON /qfcom/ aintl,ersm,pi,aln28,sigsq,almax,almin,amean,c,  &
!    icount,ir,ndtsrt,fail,lim
REAL, PARAMETER  :: zero = 0.0, one = 1.0, two = 2.0

u2 = upn
u1 = zero
c1 = amean
IF (.NOT.(u2 > zero)) GO TO 10
rb = almax
GO TO 20
10 rb = almin
20 rb = two*rb
u = u2/(one + u2*rb)
30 IF (.NOT.(errbd(n, alb, anc, u, c2) > accx)) GO TO 40
u1 = u2
c1 = c2
u2 = two*u2
u = u2/(one + u2*rb)
GO TO 30

40 u = (c1 - amean)/(c2 - amean)
50 IF (.NOT.(u < 0.9)) GO TO 80
u = (u1 + u2)/two
IF (.NOT.(errbd(n, alb, anc, u/(one + u*rb), const) > accx)) GO TO 60
u1 = u
c1 = const
GO TO 70

60 u2 = u
c2 = const
70 u = (c1 - amean)/(c2 - amean)
GO TO 50

80 fn_val = c2
upn = u2
RETURN
END FUNCTION ctff

FUNCTION truncn(n, alb, anc, uu, tausq) RESULT(fn_val)

!     Bound integration error due to truncation at U.

IMPLICIT NONE
INTEGER, INTENT(IN)  :: n(*)
REAL, INTENT(IN)     :: alb(*)
REAL, INTENT(IN)     :: anc(*)
REAL, INTENT(IN)     :: uu
REAL, INTENT(IN)     :: tausq
REAL                 :: fn_val

REAL     :: u
REAL     :: sum1, sum2, prod1, prod2, prod3, alj, ancj, x, y, err1, err2
INTEGER  :: j, nj, ns
! COMMON /qfcom/ aintl,ersm,pi,aln28,sigsq,almax,almin,amean,c,  &
!    icount,ir,ndtsrt,fail,lim
REAL, PARAMETER  :: zero = 0.0, quart = 0.25, half = 0.5, one = 1.0, two = 2.0

CALL countr()
u = uu
sum1 = zero
prod2 = zero
prod3 = zero
ns = 0
sum2 = (sigsq + tausq)*u**2
prod1 = two*sum2
u = two*u
j = 1

10 IF (.NOT.(j <= ir)) GO TO 40
alj = alb(j)
ancj = anc(j)
nj = n(j)
x = (u*alj)**2
sum1 = sum1 + ancj*x/(one + x)
IF (.NOT.(x > one)) GO TO 20
prod2 = prod2 + nj*LOG(x)
prod3 = prod3 + nj*alog1(x,.true.)
ns = ns + nj
GO TO 30

20 prod1 = prod1 + nj*alog1(x,.true.)
30 j = j + 1
GO TO 10

40 sum1 = half*sum1
prod2 = prod1 + prod2
prod3 = prod1 + prod3
x = exp1(-sum1 - quart*prod2)/pi
y = exp1(-sum1 - quart*prod3)/pi
IF (.NOT.(ns == 0)) GO TO 50
err1 = one
GO TO 60

50 err1 = x*two/ns
60 IF (.NOT.(prod3 > one)) GO TO 70
err2 = 2.5*y
GO TO 80

70 err2 = one
80 IF (.NOT.(err2 < err1)) GO TO 90
err1 = err2
90 x = half*sum2
IF (.NOT.(x <= y)) GO TO 100
err2 = one
GO TO 110

100 err2 = y/x
110 IF (.NOT.(err1 < err2)) GO TO 120
fn_val = err1
GO TO 130

120 fn_val = err2
130 RETURN
END FUNCTION truncn

SUBROUTINE findu (n, alb, anc, utx, accx)

!     Find U such that TRUNCN(U) < ACCX & TRUNCN(U / 1.2) > ACCX.

IMPLICIT NONE
INTEGER, INTENT(IN)   :: n(*)
REAL, INTENT(IN)      :: alb(*)
REAL, INTENT(IN)      :: anc(*)
REAL, INTENT(IN OUT)  :: utx
REAL, INTENT(IN)      :: accx

REAL     :: u, ut
INTEGER  :: i
! COMMON /qfcom/ aintl,ersm,pi,aln28,sigsq,almax,almin,amean,c,  &
!    icount,ir,ndtsrt,fail,lim
REAL, PARAMETER  :: divis(4) = (/ 2.0, 1.4, 1.2, 1.1 /)
REAL, PARAMETER  :: four = 4.0, zero = 0.0

ut = utx
u = ut/four
IF (.NOT.(truncn(n, alb, anc, u, zero) > accx)) GO TO 20
u = ut
10 IF (.NOT.(truncn(n, alb, anc, u, zero) > accx)) GO TO 40
ut = ut*four
u = ut
GO TO 10

20 ut = u
u = u/four
30 IF (.NOT.(truncn(n, alb, anc, u, zero) <= accx)) GO TO 40
ut = u
u = u/four
GO TO 30

40 DO  i = 1,4
  u = ut/divis(i)
  IF (.NOT.(truncn(n, alb, anc, u, zero) <= accx)) CYCLE
  ut = u
END DO
utx = ut
RETURN
END SUBROUTINE findu

SUBROUTINE integr (n, alb, anc, nterm, aintrv, tausq, main)

!     Carry out integration with NTERM terms, at interval AINTRV.
!     If not MAIN then multiply integrand by  1 - exp(-0.5 * TAUSQ * U**2).

IMPLICIT NONE
INTEGER, INTENT(IN)  :: n(*)
REAL, INTENT(IN)     :: alb(*)
REAL, INTENT(IN)     :: anc(*)
INTEGER, INTENT(IN)  :: nterm
REAL, INTENT(IN)     :: aintrv
REAL, INTENT(IN)     :: tausq
LOGICAL, INTENT(IN)  :: main

REAL      :: ainpi, u, sum1, sum2, sum3, x, y, z
INTEGER   :: k, j, nj
! COMMON /qfcom/ aintl,ersm,pi,aln28,sigsq,almax,almin,amean,c,  &
!    icount,ir,ndtsrt,fail,lim
REAL, PARAMETER  :: quart = 0.25, half = 0.5, one = 1.0, two = 2.0

ainpi = aintrv/pi
k = nterm
10 IF (.NOT.(k >= 0)) GO TO 50
u = (k + half)*aintrv
sum1 = -two*u*c
sum2 = ABS(sum1)
sum3 = -half*sigsq*u**2
j = ir

20 IF (.NOT.(j > 0)) GO TO 30
nj = n(j)
x = two*alb(j)*u
y = x**2
sum3 = sum3 - quart*nj*alog1(y,.true.)
y = anc(j)*x/(one + y)
z = nj*ATAN(x) + y
sum1 = sum1 + z
sum2 = sum2 + ABS(z)
sum3 = sum3 - half*x*y
j = j - 1
GO TO 20

30 x = ainpi*exp1(sum3)/u
IF (.NOT.(.NOT.main)) GO TO 40
x = x*(one - exp1(-half*tausq*u**2))
40 sum1 = SIN(half*sum1)*x
sum2 = half*sum2*x
aintl = aintl + sum1
ersm = ersm + sum2
k = k - 1
GO TO 10

50 RETURN
END SUBROUTINE integr

FUNCTION cfe(n, alb, anc, ith, x) RESULT(fn_val)

!     Coefficient of TAUSQ in error when convergence factor of
!     exp(-0.5 * TAUSQ * U**2) is used when df is evaluated at X.

IMPLICIT NONE
INTEGER, INTENT(IN)   :: n(*)
REAL, INTENT(IN)      :: alb(*)
REAL, INTENT(IN)      :: anc(*)
INTEGER, INTENT(OUT)  :: ith(*)
REAL, INTENT(IN)      :: x
REAL                  :: fn_val

REAL      :: axl, axl1, axl2, sxl, sum1, alj
INTEGER   :: j, k, it, itk
! COMMON /qfcom/ aintl,ersm,pi,aln28,sigsq,almax,almin,amean,c,  &
!    icount,ir,ndtsrt,fail,lim
REAL, PARAMETER  :: zero = 0.0, one = 1.0, four = 4.0, hundrd = 100.0

CALL countr()
IF (.NOT.(ndtsrt)) GO TO 10
CALL order (alb, ith)
10 axl = ABS(x)
sxl = SIGN(one,x)
sum1 = zero
j = ir

20 IF (.NOT.(j > 0)) GO TO 70
it = ith(j)
IF (.NOT.(alb(it)*sxl > zero)) GO TO 60
alj = ABS(alb(it))
axl1 = axl - alj*(n(it) + anc(it))
axl2 = alj/aln28
IF (.NOT.(axl1 > axl2)) GO TO 30
axl = axl1
GO TO 60

30 IF (.NOT.(axl > axl2)) GO TO 40
axl = axl2
40 sum1 = (axl - axl1)/alj
k = j - 1
50 IF (.NOT.(k > 0)) GO TO 70
itk = ith(k)
sum1 = sum1 + (n(itk) + anc(itk))
k = k - 1
GO TO 50

60 j = j - 1
GO TO 20

70 IF (.NOT.(sum1 > hundrd)) GO TO 80
fn_val = one
fail = .true.
GO TO 90
80 fn_val = 2**(sum1/four)/(pi*axl**2)
90 RETURN
END FUNCTION cfe

END MODULE Nonc_chisq

max_stars_repo_name: agforero/FTFramework

max_issues_repo_name: agforero/fortran-testing-framework

max_forks_repo_name: agforero/fortran-testing-framework


text:
*dk, cr_add
       subroutine cr_add(n, isink, isource, mask, mask2)
C
C #####################################################################
C
C     PURPOSE -
C
C        None
C
C     INPUT ARGUMENTS -
C
C        None
C
C     OUTPUT ARGUMENTS -
C
C        None
C
C     CHANGE HISTORY -
C
C        $Log: cr_add.f,v $
C        Revision 2.00  2007/11/05 19:45:51  spchu
C        Import to CVS
C
CPVCS
CPVCS       Rev 1.5   14 Mar 2001 13:18:12   dcg
CPVCS    get rid of upper case
CPVCS
CPVCS       Rev 1.4   14 Mar 2001 13:03:06   dcg
CPVCS    use implicit none
CPVCS
CPVCS       Rev 1.3   Mon Apr 14 16:43:00 1997   pvcs
CPVCS    No change.
CPVCS
CPVCS       Rev 1.2   11/07/95 17:15:52   dcg
CPVCS    change flag to 2 in mmgetblk calls
CPVCS
CPVCS       Rev 1.1   06/27/95 11:10:10   dcg
CPVCS    remove second literal argument in memory management calls
CPVCS
CPVCS       Rev 1.0   11/10/94 12:11:28   pvcs
CPVCS    Original version.
C
C ######################################################################
C
       implicit none
C$$$
C
C
C$$$
      integer n
       integer isink(n), isource(n)
       logical mask(n), mask2(n)
       pointer (ipitemp, itemp)
       integer itemp(n)
      integer i,isum,indx_max,length,icscode,indx,j
      character*8 isubname

      isubname='cr_add'
       length=n
       call mmgetblk('itemp',isubname,ipitemp,length,2,icscode)
       indx = 1
       do i=1,n
          if (mask(i)) then
             itemp(indx) = i
            indx = indx + 1
          endif
       enddo

       indx_max = indx
       itemp(indx) = n + 1

       do 20 i=1,indx_max-1
        isum=0
         do 10 j=itemp(i),itemp(i+1)-1
            if (mask2(j)) then
             isum=isum+isource(j)
            isink(j) = isum
            endif
 10      continue
 20     continue

       goto 9999
 9999  continue
       call mmrelblk('itemp',isubname,ipitemp,icscode)
       return
       end

max_forks_repo_name: daniellivingston/LaGriT


text:
This is a summary of the ASUCD Budget proposal for FY 20062007.  None of the values are adjusted to the final approved values yet, though discussion of the high points is below.

 The ASUCD Budget/20052006 prior years budget is also available.

 The ASUCD Website has individual units http://asucd.ucdavis.edu/government/govdocuments/budget/ budgets available online.

Blue rows are selfsufficient units. Red rows are subsidized units:

 Income

The Coffee House does indeed make a large amount of money for ASUCD, but it is budgeted to break even  as a nonprofit organization, ASUCD isnt supposed to be making any money.  In actuality, a few parts of it make money and the other parts spend money.

 Critical points

The 2006 Budget brings its share of critical points.  Noteworthy are:

  El Rodeo was cut completely.
  The Office of External Affairs, created two years ago by Brian McInnis, is being dissolved back into its constituent units:  State and National Affairs Office, City/County Affairs Office, and Lobby Corps.  The Director of External Affairs is moving to the Presidents staff, where he will serve as Secretary of External Affairs or somesuch title.  The total spent on External Affairs across these four units has decreased by $1,812. (The subsidy has actually decreased more, since the Secretary of External Affairs stipend was reduced.)
  UCSA is asking for a minimum fee increase for the third year in a row, at a cost of $0.10 per student.  However, the Senate decided not to grant the increase of $2,178, but instead focusing on reform and improving the leadership of UCSA.  UCSAs budget was moved to General Programs (from Grants) so that it could be modified later in the year if needed.
  AS PAPERs is asked for $7,500 more than their current subsidy, which is $5,350 more than the Presidents proposed budget  some of this would have made the staff be paid hourly.  However, this was rejected, as well as their request  for a web archivist (which is Creative Media Creative Medias job anyway).  Note that AS PAPERs received more than $8,000 in new computer equipment this year, primarily in the form of new computer equipment, and as a form of compensation for the loss of their archives.
  Tipsy Taxi will be combined with Specialized Transportation Services as their budgets were somewhat shared last year, anyway.  The Tipsy Taxi fee will increase to $2 per ride, which isnt unreasonable considering the high demand for the service, the increasing minimum wage, and the high fuel costs.  The subsidy for Tipsy Taxi was increased over $7,000 in hearings, due to an unexpected rise in costs.
  Unitrans is losing money, but they received a $6 million federal grant this year, which will enable ASUCD to avoid worrying about it for a little while.
  A lot of cuts were made to the units, in the interest of letting the Senate decide where more funding would go.  $24,291 remained available for subsidy at the beginning of the budget hearing.
  The Office of the President, Vice President, and Student Government were all trimmed back this year.
  Aggie Pack Aggie Packs budget received a boost of $4,000, putting them on par with what they received last year through the Money from Nowhere Act of 2005FootNote(Aggie Packs funding was slated to be cut for 20052006 until the Presidential Office allocated money from their slush reserves to cover and give a little extra to the organization.).
  Cal Aggie Camp got money for their Tshirts.
  KDVS got a bit more money to start their record label.

20060509 23:41:04 nbsp To say the least, I think itd be ridiculous to pay well over 20k to UCSA and not be able to vote because this senate doesnt come up with the extra 2k required to be a full member.  All or nothing guys, and frankly the current ASUCD lacks the experience necessary to really put up a strong argument why we should fault UCSA and choose the latter. Users/ThomasLloyd
  20060509 23:46:57 nbsp Tho, were we really taking an active role with our vote before? Users/JosephBleckman
  Just because you want to be Student Regent isnt a good reason to fully fund UCSA, Thomas.  And if they deny us our vote, Im going to push as hard as possible for leaving UCSA.  They may not like $1.30 per student, but if we give them less can they really afford a $26,000 hole in their budget? The summary of UCSAs activities last year goes like this:  a bunch of http://www.californiaaggie.com/media/storage/paper981/news/2005/05/10/FrontPage/A.Future.Of.Empty.Seats1320487.shtml?norewrite200605100956&sourcedomainwww.californiaaggie.com empty chairs, http://www.californiaaggie.com/media/storage/paper981/news/2005/10/27/Opinion/VoteNo.On.Asucd1321522.shtml?norewrite200605100955&sourcedomainwww.californiaaggie.com pass resolutions against ballot propositions on which ASUCD felt they should not take a stance, rallied to keep student fees constant the day after they were already raised, and increased member campus fees.  What do they do http://www.californiaaggie.com/media/storage/paper981/news/2005/11/01/Opinion/Editorial.Uc.Student.Associationmembership.In.Organization.Lacks.Concrete.Benefi1321573.shtml?norewrite200605100955&sourcedomainwww.californiaaggie.com for us?  Users/BrentLaabs
   First of all, youre first comment made me laugh a bit.  Student Regent is far from being my top priority (kind of have to get through my first year of Boalt first...).  Second, the whole approach being taken is ridiculous.  Whahh Whahh UCSA isnt doing anything, crying louder and louder with each iteration. Were always expecting to treat UCSA as a service organization.  We ignore that its a COALITION.  Theres nobody who we can blame so we blame it all.  If its not being effective, its because we are failing ourselves.  UCSA doesnt take positions, each school votes and a position is taken to match the interests of those who choose to turn out.  This type of relationship is akin to the United Nations and the United States.  You dont see Bush seriously considering pulling out of the UN just because he couldnt get his security resolution he wanted.  Hes still a member for all the other reasons its important to be a member.  If theres some area lacking, we can address that ourselves and go at it alone (gee, just like Bush did) or work within UCSA to fix it.

  I think that this negative attitude stems from the fact that youd be hard pressed to find many on the third floor who have ever put in the time lobbying and working on UCSA activities.  We look like a bunch of spoiled children who couldnt get along with the other children in the playground and were taking our ball and going home.  UCSA is a coalition.  A coalition we always say were going to be a bigger part of, but one we have yet to really hold our weight.  When I was working as Lobby Corps director, I had other organizing directors phone numbers programmed into my phone.  When UC Irvine, or UCSD, etc wanted to throw a lobby day, we scrambled the troops and got down there.  That type of connection/ forum for discussion wouldnt have existed without a structure such as UCSA.  We had a professional office in Sacramento, a common name, and a professional lobbyist to help us coordinate our efforts.  When I wanted a meeting time with a legislator, I called Amalia and she got me one.  Just because we choose to go at it alone (and trust me  were not being any more effective) doesnt mean that UCSA isnt still a resource that is there for us to take advantage of.  Were just neglecting to use it as an opportunity to actually come through on behalf of the students in the areas weve been promising for years.

  Oh, and PS: our fees ARENT going up next year.  Why do you really think that is?  I can tell you it doesnt have anything to do with any activity on behalf of members of ASUCD. Users/thomaslloyd
    Thomas, have you been to a UCSA meeting recently?  Theres a difference between a coalition and a money sink.  Coalitions seek to organize their members for the common good.  However, the UCSA staff who are paid a salary to visit campuses only managed to come all the way from Berkeley twice this year:  once to ask us not to leave them, and once to ask for more money.  And its not just that.  The stances they take on behalf of students seem rather weak, and the meetings are very disorganized.  One of the lobby goals is free higher education  are we actually supposed to lobby for that?  The United Nations actually produces something: resolutions, international law, tribunals, and meetings of economic, environmental, and health groups.  Show me something of political value that UCSA produced in the last year.  Anything.  And the words Access Yearbook had better not be there because that thing was an expensive piece of bad propanganda. Users/BrentLaabs
    Might I just point out:
UCSA Charter, Article IV: Composition and Membership, Section F: Membership in Good Standing
    In order to maintain membership in good standing i.e. a vote on the UCSA Board of Directors and UCSA councils, a campus student government must submit at least one third of its annual minimum membership fee by November 1...
    Therefore, we retain voting rights until November, including the right to vote in the July Congress.  If UCSA takes meaningful steps to reform by that date, we can give them one third of their proposed fee increase through the Senate Reserve.

     Personally, I wanted to cut off UCSA completely, but I do not have the political support to do that. However, Brent Laabs, James Schwab and other people said we should not give them their extra funding until they either produce some better results or we (ASUCD) take a greater role within UCSA. However, if anything happens over the year, we now can stop their funds because UCSA is now under General Programs. So, at this time, the best solution was to not give UCSA their extra $2000. Also, I think the comment frankly the current ASUCD lacks the experience is not appropriate for a person who did not go to any of the budget hearings or has not yet been to a current Senate meeting. You should not judge a persons character without knowing them. The Reality of the situation is LEAD dominates and they control all the decisions in this senate and if I disagree, one vote cannot stop the other 69 people that usually vote against me. That included budget hearings too. And that is the reality: LEAD dictates, even if I have a voting block. Experience may create a great leader, but a person who is willing to stand strong for what he or she believes, even against opposition defines a great leader. Molnar
      Experience: Noun. Active participation in events or activities, leading to the accumulation of knowledge or skill.

      I wasnt intending to personally attack and I wasnt talking about anyones character  I was talking about experience.  The thing that decisions are made on behalf of.  Simply: what person willing to stand strong has been to Sacramento and lobbied on behalf of students?  The gauge of a good senator is not merely whats done in a meeting.  Especially in this case, its what that senator does outside of that meeting the effort made to represent the students interests. Can you name a senator who routinely behaves in this manner? If not, then Id say its a fair assertion that the current senate lacks experience necessary to be making funding decisions concerning that type of activity.

      Good to hear well still have the vote (thanks P.Money).  I just have a fundamental problem with not paying our fair share that everyone else does.

      Hopefully youll all prove me wrong and get involved.  According to your statement Molnar, then the whole thing would become moot youd be more involved and ASUCD would be more linked with UCSA.  Then youd all pony up the rest of the cash to pay the minimum. Users/thomaslloyd
       Er...heres the funny part: contrary to the clear language of UCSA Charter Article IV Section F, the UCSA Executive Director says that we lose our vote at the end of May.  I find this disturbing. Users/PaulHarms PMoney

20060509 23:52:47 nbsp I DO NOT SUPPORT GIVING A SUBSIDY TO THE UNITED STATES POST OFFICE. Either that becomes a break even unit or we make better use of the space. DO NOT GIVE USPS MONEY. Users/RobRoy

20060510 11:25:58 nbsp Where will the final information on the completed budget come from?  Will there be a bill at the next Senate meeting we can copy information from? Users/PhilipNeustrom

     It will come through the senate the Thursday after this Thursday (May 18th). Molnar

20060510 23:30:29 nbsp The Senate also decided to cut the budget and pay of the Elections Committee. Last year, when the pay was higher, it took 56 months for four people to apply for four positions. This may be a Critical Point if no one applies again this year. Users/JonathonLeathers

20060511 00:44:15 nbsp Where do salaries for Mark Champagne and the ASUCD Student Government Advisor come from? Is this why the Senate subsidy is almost as big as the KDVS subsidy? Users/ArlenAbraham
  20080907 14:09:00 nbsp Admin General is where Marks salary comes from, but the Advisors is from Student Government.  Student Government is huge because they want to give themselves and their friends some money, and they dont make income like other units.  Yeah, that makes about 25% overhead costs, even excluding commission programs in this budget year.  Users/BrentLaabs

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


text:
!
! The Laboratory of Algorithms
!
! The MIT License
!
! Copyright 2011-2015 Andrey Pudov.
!
! Permission is hereby granted, free of charge, to any person obtaining a copy
! of this software and associated documentation files (the 'Software'), to deal
! in the Software without restriction, including without limitation the rights
! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is
! furnished to do so, subject to the following conditions:
!
! The above copyright notice and this permission notice shall be included in
! all copies or substantial portions of the Software.
!
! THE SOFTWARE IS PROVIDED 'AS IS', WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
! THE SOFTWARE.
!

module MFCircle

    use MFShape

    implicit none
    private

    type, extends(TFShape), public :: TFCircle
    contains
        procedure :: getArea
    end type

    interface TFCircle
        module procedure init
    end interface
contains
    function init(radius) result(circle)
        real, intent(in) :: radius
        type(TFCircle)   :: circle

        circle%width = radius
    end function

    function getArea(this) result(area)
        class(TFCircle), intent(in) :: this
        real :: area

        area = this%width * this%width * 3.14159265 / 4.0
    end function
end module

max_stars_repo_name: andreypudov/Algorithms

max_issues_repo_name: jlokimlin/Algorithms

max_forks_repo_name: jlokimlin/Algorithms


text:
program with_c_app
use with_c
implicit none

write(*,*) "isdir('app') = ", system_isdir('app')
write(*,*) "isdir('src') = ", system_isdir('src')
write(*,*) "isdir('test') = ", system_isdir('test')
write(*,*) "isdir('bench') = ", system_isdir('bench')

end program with_c_app

max_stars_repo_name: LKedward/fpm-haskell

max_issues_repo_name: LKedward/fpm-haskell

max_forks_repo_name: LKedward/fpm-haskell


text:
       subroutine hallne(dx,dy,dz,nlines,n1,n2,nclust,nlndr,g,tol,ityp)
C ****************************************
C   haloed line effect with "devide plane" clusters (but without manual
C   clusters).
C ****************************************
       dimension dx(2,nlines),dy(2,nlines),dz(2,nlines)
      dimension nclust(nlndr)
C  ==========================================================
C   transform from 3d "world" to 3d "view plane" coord.system.
C   and then sort the end points of lines.
C  ==========================================================
       call coordt(dx,dy,dz,nlines,n1,n2,nclust,nlndr,ityp)
C  ==============================
C      use haloed line effect :
C  ==============================
       call haloed(dx,dy,dz,nlines,n1,n2,n1,n2,nclust,nlndr,g,tol,ityp)
       return
       end

max_stars_repo_name: sergev/grafor

max_issues_repo_name: sergev/grafor

max_forks_repo_name: sergev/grafor


text:
program cantilever

	use solver
	use mesher
	use mesh_object

	implicit none

	integer, parameter :: Nele = 5
	integer, parameter :: order = 1
	integer, parameter :: Ngauss = 1
	integer, dimension (1), parameter :: Nsteps = (/ 1 /)
	double precision, parameter :: L = 1.0D0
	double precision, parameter :: PI = 4 * atan (1.0D0), Q0 = 8 * PI
	integer, parameter :: MAXITER = 20
	double precision, parameter :: TOLER = 1D-10
	double precision, dimension (6), parameter :: material = (/ 1.0D0, 1.0D0, 1.0D0, 1.0D0, 2.0D0, 1.0D0 /)
	character (len = *), parameter :: folder = 'cantilever'
	character (len = *), parameter :: fname_format = '("step", I0.3, ".dat")'

	type (ElementMesh) :: mesh
	integer, parameter :: Nno = Nele * order + 1
	double precision, dimension (3, Nno) :: X, U
	double precision, dimension (6, 6) :: C
	logical, dimension (6, Nno) :: DOF
	double precision, dimension (6, Nno) :: dU, Q
	double precision, dimension (Nele, 6, Ngauss) :: p, f
	double precision, dimension (Nele, 3, Ngauss) :: om
	double precision, dimension (Nele, Ngauss, 3, 3) :: rot
	double precision, dimension (6, Nno) :: R
	integer :: i, j, st, Niter, info
	character (len = 255) :: fname_long
	character (len = :), allocatable :: fname
	character (len = :), allocatable :: relpath
	character (len = 255) :: wdir_long
	character (len = :), allocatable :: wdir
	character (len = 255) :: command
	logical :: did_dir

	! =================================================
	! MESH
	mesh%Nno = Nno
	mesh%Nele = Nele
	mesh%order = order
	call lmsh (L, mesh)
	do i = 1, Nele
		do j = 1, Ngauss
			rot (i, j, 1, :)= (/ 1.0D0, 0.0D0, 0.0D0 /)
			rot (i, j, 2, :)= (/ 0.0D0, 1.0D0, 0.0D0 /)
			rot (i, j, 3, :)= (/ 0.0D0, 0.0D0, 1.0D0 /)
		end do
	end do

	! =================================================
	! ELASTIC MODULI MATRIX
	C = 0.0D0  ! add material
	do i = 1, 6
		C (i, i) = material (i)
	end do

	! =================================================
	! DATA INITIALIZATION
	U = 0.0D0
	p = 0.0D0
	f = 0.0D0
	om = 0.0D0

	st = getcwd (wdir_long)
	wdir = trim (wdir_long)

	write (command, '("if exist", X, A, "\", A, X, "rmdir", X, "/S", X, "/Q", X, A, "\" A)') wdir, folder, wdir, folder
	call execute_command_line (command, .TRUE.)

	write (command, '("mkdir", X, A, "\" A)') wdir, folder
	call execute_command_line (command, .TRUE.)

	! =================================================
	! BOUNDARY CONDITIONS
	DOF = .TRUE.
	DOF (:, 1) = .FALSE.
	dU = 0.0D0
	Q = 0.0D0

	! =================================================
	! FORCE CONTROL ROUTINE
	if (Nsteps (1) .ne. 0) then
		do j = 0, Nsteps (1)
			if (j > 0) then
				write (6, '(/, "Step", X, I3)') j
				Q (5, Nno) = Q (5, Nno) + Q0 / nsteps (1)
				call newton_iter (mesh%ele, mesh%X0, U, C, DOF, dU, Q, p, rot, om, f, R, TOLER, MAXITER, 'RSD', Niter, info, .TRUE.)
			end if

			X (1, :) = mesh%X0 (1, :) + U (1, :)
			X (2, :) = mesh%X0 (2, :) + U (2, :)
			X (3, :) = mesh%X0 (3, :) + U (3, :)

			write (fname_long, fname_format) j
			fname = trim (fname_long)
			relpath = folder//'/'//fname
			open (unit = 12, file = relpath, status = 'unknown', action = 'write')
			write (12, '("node", 19X, "X1", 19X, "X2", 19X, "X3", 19X, "U1", 19X, "U2", 19X, "U3", 19X, "R1", 19X, "R2", 19X, &
				"R3", 19X, "M1", 19X, "M2", 19X, "M3")')
			do i = 1, Nno
				write (12, '(I0.4, X, ES20.11E3, X, ES20.11E3, X, ES20.11E3, X, ES20.11E3, X, ES20.11E3, X, ES20.11E3, X, ES20.11E3, X, &
					ES20.11E3, X, ES20.11E3, X, ES20.11E3, X, ES20.11E3, X, ES20.11E3)') i, X (1, i), X (2, i), X (3, i), U (1, i), &
					U (2, i), U (3, i), R (1, i), R (2, i), R (3, i), R (4, i), R (5, i), R (6, i)
			end do
			close(12)

		end do
	end if

end program cantilever

max_stars_repo_name: tomecj/THREAD

max_issues_repo_name: tomecj/BEAM-App

max_forks_repo_name: tomecj/BEAM-App


text:
      SUBROUTINE XLNKHD
C
C     THE PURPOSE OF XLNKHD IS TO GENERATE THE LINK HEADER SECTION FOR
C     AN OSCAR ENTRY
C
      IMPLICIT INTEGER (A-Z)
      EXTERNAL        LSHIFT,RSHIFT,ANDF,ORF
      DIMENSION       MED(1),OSCAR(1),OS(5)
      COMMON /SYSTEM/ ISYS(81),CPFLG
      COMMON /XGPIC / ICOLD,ISLSH,IEQUL,NBLANK,NXEQUI,
     1                NDIAG,NSOL,NDMAP,NESTM1,NESTM2,NEXIT,
     2                NBEGIN,NEND,NJUMP,NCOND,NREPT,NTIME,NSAVE,NOUTPT,
     3                NCHKPT,NPURGE,NEQUIV,
     4                NCPW,NBPC,NWPC,
     5                MASKHI,MASKLO,ISGNON,NOSGN,IALLON,MASKS(1)
      COMMON /ZZZZZZ/ CORE(1)
      COMMON /XGPI2 / LMPL,MPLPNT,MPL(1)
      COMMON /XGPI4 / IRTURN,INSERT,ISEQN,DMPCNT,
     1                IDMPNT,DMPPNT,BCDCNT,LENGTH,ICRDTP,ICHAR,NEWCRD,
     2                MODIDX,LDMAP,ISAVDW,DMAP(1)
      COMMON /XGPI5 / IAPP,START,ALTER(2),SOL,SUBSET,IFLAG,IESTIM,
     1                ICFTOP,ICFPNT,LCTLFL,ICTLFL(1)
      COMMON /XGPI6 / MEDTP,FNMTP,CNMTP,MEDPNT,LMED,DUMMY(5),IFIRST
      COMMON /XMDMSK/ NMSKCD,NMSKFL,NMSKRF,MEDMSK(7)
      COMMON /XOLDPT/ XX(4),SEQNO
      COMMON /AUTOHD/ IHEAD
      COMMON /XGPID / ICST,IUNST,IMST,IHAPP,IDSAPP,IDMAPP
      EQUIVALENCE     (CORE(1),OS(1),LOSCAR),(OS(2),OSPRC),
     1                (OS(3),OSBOT),(OS(4),OSPNT),
     2                (OSCAR(1),MED(1),OS(5))
      DATA    XCHK  / 4HXCHK   /
C
      OR (I,J) = ORF(I,J)
      AND(I,J) = ANDF(I,J)
      MPLER = MPL(MPLPNT+3)
      IF (IHEAD .EQ. 1) MPLER = 4
C
C     CHECK FOR DECLARATIVE INSTRUCTION
C
      IF (IHEAD .EQ. 1) GO TO 20
      IF (MPLER .NE. 5) GO TO 10
      OSPNT = OSCAR(OSBOT) + OSBOT
      GO TO 20
C
C     UPDATE OSCAR PARAMETERS
C
   10 OSPRC = OSBOT
      OSBOT = OSCAR(OSBOT) + OSBOT
      OSPNT = OSBOT
      ISEQN = OSCAR(OSPRC+1) + 1
C
C     LOAD LINK HEADER INFORMATION
C
      OSCAR(OSPNT    ) = 6
      OSCAR(OSPNT + 1) = ISEQN
      OSCAR(OSPNT + 2) = MPLER + LSHIFT(MODIDX,16)
      OSCAR(OSPNT + 3) = DMAP(DMPPNT    )
      OSCAR(OSPNT + 4) = DMAP(DMPPNT + 1)
      OSCAR(OSPNT + 5) = DMPCNT
C
      MPLPNT = MPLPNT + 4
   20 OSCAR(OSPNT+5) = OR(ISGNON,OSCAR(OSPNT+5))
C
C     ALWAYS RAISE EXECUTE FLAG FOR COLD START RUNS
C
      IF (START .EQ. ICST)  GO TO 70
C
C     COMPARE SEQ NO. WITH REENTRY SEQ NO.
C
      IF (DMPCNT .LT. RSHIFT(SEQNO,16)) GO TO 30
C
C     WE ARE BEYOND REENTRY POINT - EXECUTE ALL MODULES HERE ON OUT.
C
      IF (ANDF(MASKHI,SEQNO).EQ.0 .AND. MPLER.NE.5)
     1    SEQNO = OR(ISEQN,AND(MASKLO,SEQNO))
      GO TO 70
C
C     WE ARE BEFORE REENTRY POINT - CHECK APPROACH AND TYPE OF RESTART
C     ALWAYS RAISE EXECUTE FLAG FOR INSERT FOR MODIFIED RESTARTS.
C
   30 IF (INSERT.NE.0 .AND. START.EQ.IMST) GO TO 70
      IF (START .EQ. IMST) GO TO 40
C
C     LOWER EXECUTE FLAG FOR UNMODIFIED RESTART RUNS.
C
      OSCAR(OSPNT+5) = AND(NOSGN,OSCAR(OSPNT+5))
      IF (MPLER .EQ. 5) GO TO 90
      RETURN
C
C     FOR RIGID FORMAT - CHECK DECISION TABLE FOR MODIFIED RESTART
C
   40 I = MED(MEDTP+1)
      DO 50 J = 1,I
      K = MEDPNT + J - 1
      IF (AND(MED(K),MEDMSK(J)) .NE. 0) GO TO 70
   50 CONTINUE
      OSCAR(OSPNT+5) = AND(NOSGN,OSCAR(OSPNT+5))
   70 IF (OSCAR(OSPNT+3).EQ.XCHK .AND. CPFLG.EQ.0)
     1    OSCAR(OSPNT+5) = AND(NOSGN,OSCAR(OSPNT+5))
      IF (OSCAR(OSPNT+5).GE.0 .AND. MPLER.NE.5) RETURN
C
C     PRINT COMPILE/EXECUTE FLAG FOR RESTART
C
   90 IF (START.EQ.ICST   .OR.  IFIRST.EQ.0) RETURN
      IF (DMPCNT.EQ.IFLAG .AND. INSERT.EQ.0) RETURN
      IFLAG = DMPCNT
      I = 7
      IF (MPLER .EQ. 5) I = 10
      CALL XGPIMW (I,0,0,0)
      RETURN
      END


text:
/* Examples for testing */

x/;
x;

lambda x. x;
(lambda x. x) (lambda x. x x);

(\x.x) ((\x.x) (\z.(\x.x)z));
(\x.\y.\z.x z (y z)) (\x.\y.x) (\x.\y.x);

(\m n f.m (n f));
(\m n f.m (n f)) (\f.\x.f (f x)) (\f.\x.f (f (f x)));
(\b.\e. e b) (\f.\x.f (f x)) (\f.\x.f (f (f x)));

/* infinite */
(\a. a a) (\a. a a);

/* works only on call-by-name strategy */
(\x y. y) ((\a. a a) (\a. a a));

(\x y. y) ((\a. a) (\b. b b));

max_stars_repo_name: null-lambda/TAPL-hs

max_issues_repo_name: null-lambda/TAPL-hs

max_forks_repo_name: null-lambda/TAPL-hs


text:
module base
  implicit none
  private

  type, public, abstract :: typeBase
    private
  contains
    procedure( BaseProcedureX ), deferred :: BaseProcedure
  end type typeBase

  abstract interface
    subroutine BaseProcedureX( this, anInteger )
      import typeBase
      implicit none

      class( typeBase ) :: this
      integer, intent( in ) :: anInteger
    end subroutine BaseProcedureX
  end interface

end module base

max_stars_repo_name: DanielEIlie/Patterns

max_issues_repo_name: DanielEIlie/Patterns

max_forks_repo_name: DanielEIlie/Patterns