Google Groups no longer supports new Usenet posts or subscriptions. Historical content remains viewable.
Dismiss
flags for derivative sign c
0 views
Skip to first unread message
http://alexslemonade.org
Oct 11, 2009, 8:07:11 AM10/11/09
to
http://alexslemonade.org
PROGRAM DBASE1
INTEGER STOCK, NERR
REAL PRICE
CHARACTER NAME*10
*Assume record length in storage units holding 4 chars each.
OPEN(UNIT=1, FILE='STOCKS', STATUS='OLD',
$ ACCESS='DIRECT', RECL=5)
100 CONTINUE
*Ask user or part number which will be used as record number.
WRITTE(UNIT=*,FMT=*)'Enter part number (or zero to quit):
READ(UNIT=*,FMT=*) NPART
IF(NPART .LE. 0) STOP
READ(UNIT=1, REC=NPART, IOSTAT=NERR) NAME, STOCK, PRICE
IF(NERR .NE. 0) THEN
WRITE(UNIT=*, FMT=*)'Unknown part number, re-enter'
GO TO 100
END IF
WRITE(*,115)STOCK, NAME, PRICE
115 FORMAT(1X,'Stock is', I4, 1X, A,' at=@ ', F8.2, ' each')
GOT TO 100
END
Stock is 144 widgets @ 555.55 at http://meami.org
• M. MICHAEL MUSATOV
• Computer Engineering Section
• Data Mining Engineering Department
* College of Earth
• The State University
* Universal City. Caliornia
• M.S. thesis
• Copywrite=(C) 2009. Copyright. All Rights Reserved.
• http://meami.org 'Search for the People!'
• Advisor. Dr. Walter C. Christie
* Program ALPHATEST (FORTRAN 77)
• This program calculates values of the vapor fraction,
• given equilibrium ratios, Ki, and feed mole fractions,
* zi. It can be used to reproduce experimental results of
• equilibrium flashes.
• ALPHATEST calls ALPHACOEFF, BUDAN, ALPHAPLOT, and
* ALPHAROOT
• ALPHACOEFF calls subroutine SYMFUNCTION
• SYMFUNCTION calls subroutine DETERM and function FACTOR
• VARIABLES: alpha = calculated system vapor fraction
• beta = experimental system liquid fraction
• coefficient = coefficient of alpha polynomial
Ki = equilibrium ratio for component i
molefrac = feed mole fraction of component i
• Ncomp = number of components in feed
* Npress = number of data sets to be evaluated
Pi = system pressure, psia
Ti = system temperature. F
• xalpha = experimental system vapor fraction
• It is formatted to input zi, temperature, pressure, liquid
* mole fraction, and Ki
IMPLICIT REAL*8(a-h,o-z)
REAL*8 Ki(500,100),molefrac(0:100)
PARAMETER(Npress= 16,Ncomp=l 10)
DIMENSION alpha(500), beta(500), coefficient(0:100),
@ Pi(500), Ti(500), tarray(2), xalpha(500)
• Data Input
* The number of components (Ncomp) and the number of data sets
• to be run (Npress) are specified as PARAMETERs'
* Open and Rewind Input and Output Files
OPEN(unit=-I ,file='indata',status= 'old')
OPEN(uniit-=7,file='table',status:='unknown')
OPEN(unit=-8,file= 'plot',status=-'unknown')
REWINlD(unit= 1)
REWTND~unit=7)
REWIND(unit=8)
read(l,*) (znolefrac(i), i = 1, Ncornp)
do 1000 j = 1, Npress
read(1,*) (KiU,i), i = 1, Ncomp)
xalphaoj) = lIdO - betaoj)
1000 continue
* Choose between single or multiple runs
wrt(,)Taut n aast ne
write(6,*) 'Evaluate one data set? enter 1'
read(5,*) numsets
if(numsets EQ. 1) then
wnite(6,*) 'Enter number of data set for this run'
read(5,*) j
go to 2 100
end if
do 2000 j = 1, Npress
2100 write(7,*)
write(7,*)
write(7,*) 'RUN '
write(6,*) 7J=- j
write(7,2500) Pioj),Tioj),betaoj)
2500 formatCPressure = ',f6.1,' psia Temperature = ,f6.1,' F
@Liquid Mole Fraction = ',f6.4)
* Call subroutines
* Calculate coefficients of polynomial
call ALPHACOEFF(NcompNpressjmolefrac,Ki,coefficient)
* Predict the number of roots on [0,11 by Fourier-Budan theorem
89
call BUDAN(jNcomp,coefficientnumroot)
* Solve for the roots by Newton-Raphson method
call ALPHAROOT(j,Ncomp,coefficientxalphanumroot,alpha)
* Generate various plots (EDIT the file to remove comments for
specific
* options)
call ALPHAPLOT(Ncompjjnolefac,alpha,coefficient, i)
* ALPHAROOT has internal output section to compile a table
* listing statistics on the determination of alpha
2000 continue
* Produce this format to plot data points as dots:
* (PLOTFAT=20)
* 2
* x(l) y(l)
* x(I) y(l)
* 2
* x(2) y(2)
x(2) y(2)
* etc.
do 3000 j = 1, Npress
write(8,3500) alphao),xalpha(j),alpha(j),xalpha(j)
3500 formnat('2 j,e 16.9,10x,el 6.9j,e 16.9,10x,e 16.9)
3000 continue
CLOSE(unit=l)
CLOSE(unit=7)
CLOSE(unit=8)
stop
end
• M. MICHAEL MUSATOV
• Computer Engineering Section
• Data Mining Engineering Department
* College of Earth
• The State University
* Universal City. Caliornia
• M.S. thesis
• Copywrite=(C) 2009. Copyright. All Rights Reserved.
• http://meami.org 'Search for the People!'
• Advisor. Dr. Walter C. Christie
* SUBROUTINE ALPHACOEFF
* This subroutine calculates the coefficient for each term in
* the general polynomial for the vapor fraction, alpha:
* P(alpha) = cO + cl*alpha + c2*alpha**2 + ... +
* c(Ncomp- 1)*alpha**(Ncomp- 1)
* Equation 4.29 in the thesis.
SUBROUTINE ALPHACOEFF(NcompNpressdjmolefrac,Ki,coefficient)
IMPLICIT REAL* 8(a-h,o-z)
REAL*8 Ki(500,100), molefrac(0:100)
INTEGER p
DIMENSION coefficient(0:100), c(100)
OPEN(unit= 14,f'de='coeff',status='unknown)
OPEN(unit= 15,file='coeff.plot',status='unknown')
if(Ncomp .LT. 2) then
write(6,*)You cannot flash this system'
stop
end if
* Calculate Ci = Ki - 1
do 0500 k = 1, Ncomp
c(k) = Ki(jjk) - 1.d00
0500 continue
* p-loop increments the power of alpha
C write(15,*)Ncomp
do 1000 p = 1, Ncomp
temporary = 0.d00
do 2000 j = 1, p
* Zero-order elementary symmetric function, aO[l/Ci], defined as I
if(p-j EQ. 0) then
apj = 1.dO0
go to 2500
end if
* Call subroutine to calculate the elementary symmetric
* function, apj
call SYMFUNCTION(Ncompj,p,c,apj)
2500 ratio = 0.dOO
do 3000 i = 1, Ncomp
ratio = ratio + molefrac(i)/(c(i)**(j-l))
3000 continue
temporary = temporary + ((-1.d0)**(j+l))*apj*ratio
2000 continue
coefficient(Ncomp-p) = temporary
C write(14,*)'Coefficient(',Ncomp-p,') = ',coefficient(Ncomp-p)
C write( 15,*)Ncomp-p,coefficient(Ncomp-p)
1000 continue
return
end
• M. MICHAEL MUSATOV
• Computer Engineering Section
• Data Mining Engineering Department
* College of Earth
• The State University
* Universal City. Caliornia
• M.S. thesis
• Copywrite=(C) 2009. Copyright. All Rights Reserved.
• http://meami.org 'Search for the People!'
• Advisor. Dr. Walter C. Christie
* SUBROUTINE SYMFUNCTION
* This subroutine calculates the elementary symmetric function
* a(p-j)( I/Ci)
***************************************i i***************************
SUBROUTINE SYMFUNCTION(Ncompj,pc,apj)
IMPLICIT REAL*8(a-ho--z)
REAL*8 mmatrix(100,100)
INTEGER factor,p
DIMENSION c(100), s(100)
* Compute the power-sum series: s = sigma[ (1/Ci)**lambda ]
n=p -j
do 100 lambda = 1, n
sum = O.dOO
do 2000 i = 1, Ncomp
sum = sum + (1.dO/c(i))**lambda
2000 continue
s(lambda) = sum
1000 continue
Build the matrix MMATRIX
do 3000 k = 1, n
do 4000 1 = 1, n
if(1 .LE. k) mmatrix(kj) = s(k-1+1)
if(1 .EQ. k+l) mmatrix(kl) = DFLOAT(k)
if(l .GT. k+l) mmatrix(k,l) = O.d00
4000 continue
3000 continue
* Since al(1/Ci) forms a [lxl] matrix, its determinant is the
* element itself
if(p-j .EQ. 1) then
det = mmatrix(l,l)
go to 5000
end if
* Compute the determinant of MMATRIX
call DETERM(mmatrix,n,det)
* Compute the elementary symmetric function
5000 apj = det/factor(n)
retum
end
* Function to compute the factorial
***********************************
FUNCTION factor(n)
INTEGER factor,i,n
factor = 1
if(n .GT. 0) then
do 6000 i - 2.n
factor - factor*i
6000 continue
end if
end
• M. MICHAEL MUSATOV
• Computer Engineering Section
• Data Mining Engineering Department
* College of Earth
• The State University
* Universal City. Caliornia
• M.S. thesis
• Copywrite=(C) 2009. Copyright. All Rights Reserved.
• http://meami.org 'Search for the People!'
• Advisor. Dr. Walter C. Christie
* SUBROUTINE DETERM
* This program calculates the determinant of an NxN matrix.
* First, partial pivoting is performed on a nonsingular matrix by
* Gaussian elimination. This produces a triangular matrix whose
* determinant can be calculated by computing the product of all
* the diagonal entries.
* The augmented matrix does not contain the normal last column
which represents the right-hand side of a system 'of linear
* equations; AUG is the same as the original matrix.
* VARIABLES:
* N = dimension of matrix
* AUG = augmented matrix
* IJ,K = indices
* MULT = multiplier used to eliminate an unknown
* PIVOT = used to find nonzero diagonal entry
SUBROUTINE DETERM(aug,n,det)
IMPLICIT REAL*8(a-h,o-z)
REAL*8 mult
INTEGER pivot
DIMENSION aug(100,100)
* Gaussian elimination
* l n Ii|I
do 7000 i = 1, n
* Locate nonzero entry
if(aug(i,i) .EQ. 0) then
pivot = 0
j=i+ 1
3000 if((pivot .EQ. 0) .AND. (j .LE. n)) then
if(aug(j,i) .NE. 0) pivot = j
j=j+ 1
go to 3000
end if
if(pivot .EQ. 0) then
print *,'Matrix is singular'
stop
else
* Interchange rows I and PIVOT
do 4000 j = i, n
temp = aug(ij)
aug(ij) = aug(pivotj)
aug(pivotj) = temp
4000 continue
end if
end if
* Eliminate l-th unknown from equations I+, .... N
do 6000 j = i+l1, n
mult = -aug(ji) / aug(i,i)
do 5000 k = i, n
aug(j,k) - aug(j,k) + mult * aug(ik)
5000 continue
6000 continue
7000 continue
* Calculate the determinant of matrix AUG by computing the
* product of the diagonal elements
prod = EdO
do 8000 i = 1, n
95
do 9000 j = 1, n
if(i .EQ. j) prod = prod * aug(i,j)
9000 continue
8000 continue
det = prod
return
end
• M. MICHAEL MUSATOV
• Computer Engineering Section
• Data Mining Engineering Department
* College of Earth
• The State University
* Universal City. Caliornia
• M.S. thesis
• Copywrite=(C) 2009. Copyright. All Rights Reserved.
• http://meami.org 'Search for the People!'
• Advisor. Dr. Walter C. Christie
• SUBROUTINE ALPHAROOT
• Subroutine uses an interval-halving technique to find
* the best root value to initialize the Newton-Raphson (N-R)
• iterative calculaions which determine the real root of
• the alpha polynomial on the interval [0,11.
• PARAMETERS: delta = alpha increment
• epsilon = alpha convergence criterion
• VARIABLES: alower = lower bound of alpha increment
• aupper = upper bound of alpha increment
• falpha = the alpha polynomial
• fprime = first derivative of alpha polynomial
• guess = iterative variable for alpha
• guessO = initial estimate for N-R
• intcount = # of intervals until sign change
• iter = # of iterations until N-R converged
• isign,isign2 = flags for function sign change
• isign.isign2 = flags for function sign change
• numroot = flag for # of zeros (from BUDAN)
SUBROUTINE ALPHAROOT(j'NcomnpcoefficienLxalphanumroot,
@ alpha)
IMPLICIT REAL*8(a-h,o-z)
INTEGER p
DIMENSION alpha(500), coefficient(0:100), xalpha(500)
PARAMETER(delta = 0.01idO, epsilon = l.d--06)
* Write table heading
write(7,*)Ihe Fourier-Budan Theorem yields ",numroot,' roots on
@this interval'
write(7,3500)
3500 format('Intervals',4x, 'Initial Guess',4x,'Iterations',4x,'Calc.
@Alpha',4x,Exp. Alpha')
* Check flag NUMROOT provided by subroutine BUDAN to determine
* root-search scheme
if(numroot EQ. 0) then
write(6,*) "No root on the interval [0,1] for data set "j
intcount = 0
write(7,3900) intcount,xalpha(j)
3900 format(i4,61 x,f5.3)
write(7,*)'No root on the interval [0,1]'
return
end if
if(nummot .EQ. 1) then
ilower = 0
iupper = 0
end if
if(numroot .GE. 2) then
ilower = 0
iupper = 1
end if
* Use incremental search to determine initial guess
* Interval Endpoint DO-Loop
do 0400 jroot = ilower, iupper
intcount = 0
* Test the polynomial at endpoint for initial sign value
ifjroot. EQ. lower) then
guess - DFLOAT(ilower)
alower = guess
aupper = alower + delta
end if
if(jroot. EQ. iupper) then
guess = DFLOAT(iupper)
aupper = guess
alower = aupper - delta
end if
ichange = 0
0600 falpha = O.dO
do 1500 p = 1, Ncomp
term = coefficient(Ncomp-p)*guess**(Ncomp-p)
if( (Ncomp-p) .EQ. 0 ) term = coefficient(0)
falpha = falpha + term
1500 continue
* Initialize ISIGN2 on first pass with endpoint
if(ichange .EQ. 0) then
if(falpha .GE. 0.) then
isign2 = 1
else
isign2 = 0
end if
end if
* Note the sign of the function
if(falpha .GE. 0.) then
isign = I
else
isign = 0
end if
* Test function for sign change and increment or decrement the
* search variable as appropriate
if(isign2 .EQ. isign) then
if(jroot .EQ. lower) then
alower = aupper
aupper = aupper + delta
guess = aupper
else iffjroot .EQ. iupper) then
aupper = alower
alower = aupper - delta
guess = alower
end if
end if
* Exit subroutine if no sign change is detected on interval [0,1]
if( (guess .GT. 1.) .OR. (guess .LT. 0.) ) then
write(6,*) 'No root on the interval [0,1]"
write(7,3800) intcount,xalpha(j)
3800 format(i4,61x,f5.3)
write(7,*)No root on the interval [0,1]'
return
end if
* If NO sign change but still within interval, repeat the sequence
if(isign .EQ. isign2) then
isign2 = isign
intcount = intcount + 1
ichange = I
go to 0600
else
* If there IS a sign change:
* Halve the interval where the function crosses the x axis
guessO = (alower + aupper) / 2.dO
end if
* Provide this guess to Newton-Raphson to begin calculations
guess = guessO
* N-R is limited to 1000 iterations for convergence
iter = 0
do 1000 iterlimit = 1, 1000
iter = iter + I
falpha = O.d00
fprime = 0.d00
do 2000 p = 1, Ncomp
fapha = falpha + coefficient(Ncomp-p)
@ *guess**(Ncomp-p)
fprime = fprime + (Ncomp--p)*coefficient(Ncomp-p)
@ *guess**(Ncomp-p- 1)
2000 continue
calc = guess - falpha/fprime
error = DABS((calc - guess)/calc)
guess =calc
if(erncr .LE. epsilon) go to 3000
1000 continue
print *,'N-R method failed to converge after 1000 iterations'
* Output results to file "TABLE"
*
3000 write(7,3600) intcount,guess0,iter,guess,xalpha(j)
3600 forrnat(i4,13x,f5.3,10x,i4,13xf9.6,7x,f5.3)
alpha(j) = guess
* Begin search for root from opposite end of interval
0400 continue
return
end
• M. MICHAEL MUSATOV
• Computer Engineering Section
• Data Mining Engineering Department
* College of Earth
• The State University
* Universal City. Caliornia
• M.S. thesis
• Copywrite=(C) 2009. Copyright. All Rights Reserved.
• http://meami.org 'Search for the People!'
• Advisor. Dr. Walter C. Christie
* SUBROUTINE ALPHAPLOT
*
* This subroutine is used for several purposes:
* 1. Plotting F(alpha) vs alpha [Rachford-Rice obj function]
* 2. Plotting F(alpha) vs alpha (polynomial]
* 3. Plotting Fprime vs alpha [polynomial]
SUBROUTINE ALPHAPLOT(Ncompj,molefrac,alphacoefficient,Ki)
IMPLICIT REAL*8 (a-h,o-z)
REAL*8 Ki(500,100),molefrac(100)
DIMENSION alpha(500),coefficient(0:100)
INTEGER p
PARAMETER(start = 0.OdO, end = 2.OdO, stepsize = 0.0005d0)
OPEN(unit= 11 ,file=f'"a. plot ',status= 'unknown )
OPEN(unit= 12,f ie= 'fprime .plot',status= 'unknown')
* Number of data points for plotting
number = IDINT((end - start + stepsize)/stepsize)
* F(alpha) vs alpha [polynomial]
* F(alpha) vs alpha [polynomial]
* Adjust Ncomp.Npress in PARAMETR
write(I1.*) number
do 1000 phase = start,end,stepsize
falpha = 0.dOO
fprime = 0.dOO
do 2000 p = I,Ncomp
falpha = faipha + coefficient(Ncomp-p)*
@ phase* *(Ncomp-p)
C fprine = fprime + (Ncomp-p)*coefficienINcomp-p)*
C @phase**(Ncomp-p-1)
2000 continue
write(I 1,3600) phase ,falpha
C write(11,3600) phase/prime
3600 fbrmat(f 7.3,2x,f25.12)
1000 continue
C* Rachford-Rice objective function
C
C do 4500 k = I ,Npress
C k =6
C write(11,*) number
C do 3000 phase = start,endstepsize
C falpha = 0400
C do 4000 i = I Ncomp
C faipha = faipha + (molefrac(i)*(Ki(kJi) - 140))I
C @(1400O + phase*(Ki(k,i) - .d0))
C* End of i loop
C 4000 continue
C
C write(]1,3500) phase/alpha
C 3500 formattl 7.25.12)
C* -End of phase loop
C 3000 continue
C* ~ End qofk loop
C 4500 continue
CLOSE(unit=- 11)
CLOSE(unit= 12)
return
end
• M. MICHAEL MUSATOV
• Computer Engineering Section
• Data Mining Engineering Department
* College of Earth
• The State University
* Universal City. Caliornia
• M.S. thesis
• Copywrite=(C) 2009. Copyright. All Rights Reserved.
• http://meami.org 'Search for the People!'
• Advisor. Dr. Walter C. Christie
* SUBROUTINE BUDAN
* Subroutine uses the Fourier-Budan Theorem to determipe
* the number of roots that the alpha polynomial has on tn,
* interval [u,v].
,
* PARAMETERS: iu = lower bound of alpha interval
* iv = uppper bound of alpha interval
* VARIABLES: coefficient = coefficient of alpha polynomial
* dcoeff = coefficient of polynomial derivatives
* deriv = derivatives of alpha polynomial
* fvapor = the alpha polynomial
* ia,ib = # of sign changes for derivative series
* ivapor = alpha = vapor fraction
* jsign,ksign = flags for derivative sign change
* numroot = number of zeros on the interval
SUBROUTINE BUDAN(J,Ncomp,coefficientnwnroot)
IMPLICIT REAL*8(a--ho-z)
INTrEGER p
DIMENSION dcoeff(0:100,0:100), coefficient(0:100), deriv(0:100)
PARAMETER(iu = 0, iv = 1)
C DATA (coefficient(l), I = ONcomp-l) /-j.,I.,-2.,3.,-4.,5. /
OPEN(unit=2,file="test",status= unknown)
REWIND(Unit=2)
ia = 0
ib = 0
do 0500 ivapor = iu, iv, 1
* Evaluate the polynomial function at the endpoints iu and iv
fvapor = OdO
do 0600 p = 1, Ncomp
fvapor = fvapor + coefficient(Ncomp-p)*ivapor**(Ncomp-p)
0600 continue
write(2,*) fvapor = ",fvapor
write(2,*) - -
* Calculate coefficients of first derivative
do 1000 n = Ncomp-1, 0, -1
dcoeff(0,n) = coefficient(n)
write (2,*) "dcoeff(0,',n,') = ",dcoeff(0,n)
1000 continue
write(2,*) " "
* Calculate coefficients of 2nd- and higher-order derivatives
* as multiples of those of the first derivative
do 1500 m = 1, Ncomp-I
do 2000 n = Ncomp-m, 1, -1
dcoeff(mn-1) = n*dcoeff(m-l,n)
write (2,*) "dcoeff(',m,',n-1,) = ",
@dcoeff(m,n-1)
2000 continue
write(2,*) " "
1500 continue
* Evaluate the derivative series at the endpoints iu and iv
do 3000 n = 1, Ncomp-1
deriv(m) = 0.dO
do 4000 n = Ncomp-m, 1, -1
term = dcoeff(m,n-1)*ivapor**(n-1)
if( (n-I) .EQ. 0 ) term = dcoeff(mn-1)
deriv(m) = deriv(m) + term
write(2,*) 'inter deriv(°,m, ") = ",deriv(m)
4000 continue
write(2,*) 'total deriv(',m,) = ",deriv(m)
write(2,*) " "
3000 continue
* Count the sign changes between the terms of the series
if(fvapor. LT. 0.) then
ksign = 0
else
ksign = 1
end if
write(2,*) 1csign = ',ksign,' for fvapor'
do 5000 i = 1, Ncomp-l
if(deriv(i) .LT. 0.) then
jsign = 0
else
jsign = 1
end if
write(2,*) 'jsign = ',jsign,' for deriv(',i,T'
* Increment A or B, depending upon the endpoint under evaluation
iffivapor EQ. iu) then
if(ksign .NE. jsign) then
ia = ia + I
write(2,*) 'ia = ',ia,' for deriv(',,'
end if
end if
iffivapor .EQ. iv) then
if(ksign .NE. jsign) then
ib = ib + I
write(2,*) -ib = -,ib,' for derivC',i,')'
end if
end if
ksign = jsign
write(2,*) lcsign = ',ksign,' after deriv(',i,2Y
write(2,*)
5000 continue
0500 continue
* Pass a flag to calling program to indicate root conditions
write(2,*) 'ia =',ia,' and ib = 'ib
numroot = ia -ib
write(2,*) 'numroot = ',numroot
write(2,6000) Ncomp-I, numroot, iu, iv, J
6000 formnat(This polynomial of order 'j3,' has 'i3,' zeros on the in
@terval [',i2,',ij2,'J for J = 'i3)
CLOSE(unit=2)
return
endAC_PROG_F77(fl32 f77 fort77 xlf g77 f90 xlf90)
#ifdef F77_DUMMY_MAIN
# ifdef __cplusplus
extern "C"
# endif
int F77_DUMMY_MAIN() { return 1; }
#endif
subroutine foobar(x,y)
double precision x, y
y = 3.14159 * x
return
end
#define FOOBAR_F77 F77_FUNC(foobar,FOOBAR)
#ifdef __cplusplus
extern "C" /* prevent C++ name mangling */
#endif
void FOOBAR_F77(double *x, double *y);
PROGRAM DBASE1
INTEGER STOCK, NERR
REAL PRICE
CHARACTER NAME*10
*Assume record length in storage units holding 4 chars each.
OPEN(UNIT=1, FILE='STOCKS', STATUS='OLD',
$ ACCESS='DIRECT', RECL=5)
100 CONTINUE
*Ask user or part number which will be used as record number.
WRITTE(UNIT=*,FMT=*)'Enter part number (or zero to quit):
READ(UNIT=*,FMT=*) NPART
IF(NPART .LE. 0) STOP
READ(UNIT=1, REC=NPART, IOSTAT=NERR) NAME, STOCK, PRICE
IF(NERR .NE. 0) THEN
WRITE(UNIT=*, FMT=*)'Unknown part number, re-enter'
GO TO 100
END IF
WRITE(*,115)STOCK, NAME, PRICE
115 FORMAT(1X,'Stock is', I4, 1X, A,' at=@ ', F8.2, ' each')
GOT TO 100
END
Stock is 144 widgets @ 555.55 at http://meami.org
• M. MICHAEL MUSATOV
• Computer Engineering Section
• Data Mining Engineering Department
* College of Earth
• The State University
* Universal City. Caliornia
• M.S. thesis
• Copywrite=(C) 2009. Copyright. All Rights Reserved.
• http://meami.org 'Search for the People!'
• Advisor. Dr. Walter C. Christie
* Program ALPHATEST (FORTRAN 77)
• This program calculates values of the vapor fraction,
• given equilibrium ratios, Ki, and feed mole fractions,
* zi. It can be used to reproduce experimental results of
• equilibrium flashes.
• ALPHATEST calls ALPHACOEFF, BUDAN, ALPHAPLOT, and
* ALPHAROOT
• ALPHACOEFF calls subroutine SYMFUNCTION
• SYMFUNCTION calls subroutine DETERM and function FACTOR
• VARIABLES: alpha = calculated system vapor fraction
• beta = experimental system liquid fraction
• coefficient = coefficient of alpha polynomial
Ki = equilibrium ratio for component i
molefrac = feed mole fraction of component i
• Ncomp = number of components in feed
* Npress = number of data sets to be evaluated
Pi = system pressure, psia
Ti = system temperature. F
• xalpha = experimental system vapor fraction
• It is formatted to input zi, temperature, pressure, liquid
* mole fraction, and Ki
IMPLICIT REAL*8(a-h,o-z)
REAL*8 Ki(500,100),molefrac(0:100)
PARAMETER(Npress= 16,Ncomp=l 10)
DIMENSION alpha(500), beta(500), coefficient(0:100),
@ Pi(500), Ti(500), tarray(2), xalpha(500)
• Data Input
* The number of components (Ncomp) and the number of data sets
• to be run (Npress) are specified as PARAMETERs'
* Open and Rewind Input and Output Files
OPEN(unit=-I ,file='indata',status= 'old')
OPEN(uniit-=7,file='table',status:='unknown')
OPEN(unit=-8,file= 'plot',status=-'unknown')
REWINlD(unit= 1)
REWTND~unit=7)
REWIND(unit=8)
read(l,*) (znolefrac(i), i = 1, Ncornp)
do 1000 j = 1, Npress
read(1,*) (KiU,i), i = 1, Ncomp)
xalphaoj) = lIdO - betaoj)
1000 continue
* Choose between single or multiple runs
wrt(,)Taut n aast ne
write(6,*) 'Evaluate one data set? enter 1'
read(5,*) numsets
if(numsets EQ. 1) then
wnite(6,*) 'Enter number of data set for this run'
read(5,*) j
go to 2 100
end if
do 2000 j = 1, Npress
2100 write(7,*)
write(7,*)
write(7,*) 'RUN '
write(6,*) 7J=- j
write(7,2500) Pioj),Tioj),betaoj)
2500 formatCPressure = ',f6.1,' psia Temperature = ,f6.1,' F
@Liquid Mole Fraction = ',f6.4)
* Call subroutines
* Calculate coefficients of polynomial
call ALPHACOEFF(NcompNpressjmolefrac,Ki,coefficient)
* Predict the number of roots on [0,11 by Fourier-Budan theorem
89
call BUDAN(jNcomp,coefficientnumroot)
* Solve for the roots by Newton-Raphson method
call ALPHAROOT(j,Ncomp,coefficientxalphanumroot,alpha)
* Generate various plots (EDIT the file to remove comments for
specific
* options)
call ALPHAPLOT(Ncompjjnolefac,alpha,coefficient, i)
* ALPHAROOT has internal output section to compile a table
* listing statistics on the determination of alpha
2000 continue
* Produce this format to plot data points as dots:
* (PLOTFAT=20)
* 2
* x(l) y(l)
* x(I) y(l)
* 2
* x(2) y(2)
x(2) y(2)
* etc.
do 3000 j = 1, Npress
write(8,3500) alphao),xalpha(j),alpha(j),xalpha(j)
3500 formnat('2 j,e 16.9,10x,el 6.9j,e 16.9,10x,e 16.9)
3000 continue
CLOSE(unit=l)
CLOSE(unit=7)
CLOSE(unit=8)
stop
end
• M. MICHAEL MUSATOV
• Computer Engineering Section
• Data Mining Engineering Department
* College of Earth
• The State University
* Universal City. Caliornia
• M.S. thesis
• Copywrite=(C) 2009. Copyright. All Rights Reserved.
• http://meami.org 'Search for the People!'
• Advisor. Dr. Walter C. Christie
* SUBROUTINE ALPHACOEFF
* This subroutine calculates the coefficient for each term in
* the general polynomial for the vapor fraction, alpha:
* P(alpha) = cO + cl*alpha + c2*alpha**2 + ... +
* c(Ncomp- 1)*alpha**(Ncomp- 1)
* Equation 4.29 in the thesis.
SUBROUTINE ALPHACOEFF(NcompNpressdjmolefrac,Ki,coefficient)
IMPLICIT REAL* 8(a-h,o-z)
REAL*8 Ki(500,100), molefrac(0:100)
INTEGER p
DIMENSION coefficient(0:100), c(100)
OPEN(unit= 14,f'de='coeff',status='unknown)
OPEN(unit= 15,file='coeff.plot',status='unknown')
if(Ncomp .LT. 2) then
write(6,*)You cannot flash this system'
stop
end if
* Calculate Ci = Ki - 1
do 0500 k = 1, Ncomp
c(k) = Ki(jjk) - 1.d00
0500 continue
* p-loop increments the power of alpha
C write(15,*)Ncomp
do 1000 p = 1, Ncomp
temporary = 0.d00
do 2000 j = 1, p
* Zero-order elementary symmetric function, aO[l/Ci], defined as I
if(p-j EQ. 0) then
apj = 1.dO0
go to 2500
end if
* Call subroutine to calculate the elementary symmetric
* function, apj
call SYMFUNCTION(Ncompj,p,c,apj)
2500 ratio = 0.dOO
do 3000 i = 1, Ncomp
ratio = ratio + molefrac(i)/(c(i)**(j-l))
3000 continue
temporary = temporary + ((-1.d0)**(j+l))*apj*ratio
2000 continue
coefficient(Ncomp-p) = temporary
C write(14,*)'Coefficient(',Ncomp-p,') = ',coefficient(Ncomp-p)
C write( 15,*)Ncomp-p,coefficient(Ncomp-p)
1000 continue
return
end
• M. MICHAEL MUSATOV
• Computer Engineering Section
• Data Mining Engineering Department
* College of Earth
• The State University
* Universal City. Caliornia
• M.S. thesis
• Copywrite=(C) 2009. Copyright. All Rights Reserved.
• http://meami.org 'Search for the People!'
• Advisor. Dr. Walter C. Christie
* SUBROUTINE SYMFUNCTION
* This subroutine calculates the elementary symmetric function
* a(p-j)( I/Ci)
***************************************i i***************************
SUBROUTINE SYMFUNCTION(Ncompj,pc,apj)
IMPLICIT REAL*8(a-ho--z)
REAL*8 mmatrix(100,100)
INTEGER factor,p
DIMENSION c(100), s(100)
* Compute the power-sum series: s = sigma[ (1/Ci)**lambda ]
n=p -j
do 100 lambda = 1, n
sum = O.dOO
do 2000 i = 1, Ncomp
sum = sum + (1.dO/c(i))**lambda
2000 continue
s(lambda) = sum
1000 continue
Build the matrix MMATRIX
do 3000 k = 1, n
do 4000 1 = 1, n
if(1 .LE. k) mmatrix(kj) = s(k-1+1)
if(1 .EQ. k+l) mmatrix(kl) = DFLOAT(k)
if(l .GT. k+l) mmatrix(k,l) = O.d00
4000 continue
3000 continue
* Since al(1/Ci) forms a [lxl] matrix, its determinant is the
* element itself
if(p-j .EQ. 1) then
det = mmatrix(l,l)
go to 5000
end if
* Compute the determinant of MMATRIX
call DETERM(mmatrix,n,det)
* Compute the elementary symmetric function
5000 apj = det/factor(n)
retum
end
* Function to compute the factorial
***********************************
FUNCTION factor(n)
INTEGER factor,i,n
factor = 1
if(n .GT. 0) then
do 6000 i - 2.n
factor - factor*i
6000 continue
end if
end
• M. MICHAEL MUSATOV
• Computer Engineering Section
• Data Mining Engineering Department
* College of Earth
• The State University
* Universal City. Caliornia
• M.S. thesis
• Copywrite=(C) 2009. Copyright. All Rights Reserved.
• http://meami.org 'Search for the People!'
• Advisor. Dr. Walter C. Christie
* SUBROUTINE DETERM
* This program calculates the determinant of an NxN matrix.
* First, partial pivoting is performed on a nonsingular matrix by
* Gaussian elimination. This produces a triangular matrix whose
* determinant can be calculated by computing the product of all
* the diagonal entries.
* The augmented matrix does not contain the normal last column
which represents the right-hand side of a system 'of linear
* equations; AUG is the same as the original matrix.
* VARIABLES:
* N = dimension of matrix
* AUG = augmented matrix
* IJ,K = indices
* MULT = multiplier used to eliminate an unknown
* PIVOT = used to find nonzero diagonal entry
SUBROUTINE DETERM(aug,n,det)
IMPLICIT REAL*8(a-h,o-z)
REAL*8 mult
INTEGER pivot
DIMENSION aug(100,100)
* Gaussian elimination
* l n Ii|I
do 7000 i = 1, n
* Locate nonzero entry
if(aug(i,i) .EQ. 0) then
pivot = 0
j=i+ 1
3000 if((pivot .EQ. 0) .AND. (j .LE. n)) then
if(aug(j,i) .NE. 0) pivot = j
j=j+ 1
go to 3000
end if
if(pivot .EQ. 0) then
print *,'Matrix is singular'
stop
else
* Interchange rows I and PIVOT
do 4000 j = i, n
temp = aug(ij)
aug(ij) = aug(pivotj)
aug(pivotj) = temp
4000 continue
end if
end if
* Eliminate l-th unknown from equations I+, .... N
do 6000 j = i+l1, n
mult = -aug(ji) / aug(i,i)
do 5000 k = i, n
aug(j,k) - aug(j,k) + mult * aug(ik)
5000 continue
6000 continue
7000 continue
* Calculate the determinant of matrix AUG by computing the
* product of the diagonal elements
prod = EdO
do 8000 i = 1, n
95
do 9000 j = 1, n
if(i .EQ. j) prod = prod * aug(i,j)
9000 continue
8000 continue
det = prod
return
end
• M. MICHAEL MUSATOV
• Computer Engineering Section
• Data Mining Engineering Department
* College of Earth
• The State University
* Universal City. Caliornia
• M.S. thesis
• Copywrite=(C) 2009. Copyright. All Rights Reserved.
• http://meami.org 'Search for the People!'
• Advisor. Dr. Walter C. Christie
• SUBROUTINE ALPHAROOT
• Subroutine uses an interval-halving technique to find
* the best root value to initialize the Newton-Raphson (N-R)
• iterative calculaions which determine the real root of
• the alpha polynomial on the interval [0,11.
• PARAMETERS: delta = alpha increment
• epsilon = alpha convergence criterion
• VARIABLES: alower = lower bound of alpha increment
• aupper = upper bound of alpha increment
• falpha = the alpha polynomial
• fprime = first derivative of alpha polynomial
• guess = iterative variable for alpha
• guessO = initial estimate for N-R
• intcount = # of intervals until sign change
• iter = # of iterations until N-R converged
• isign,isign2 = flags for function sign change
• isign.isign2 = flags for function sign change
• numroot = flag for # of zeros (from BUDAN)
SUBROUTINE ALPHAROOT(j'NcomnpcoefficienLxalphanumroot,
@ alpha)
IMPLICIT REAL*8(a-h,o-z)
INTEGER p
DIMENSION alpha(500), coefficient(0:100), xalpha(500)
PARAMETER(delta = 0.01idO, epsilon = l.d--06)
* Write table heading
write(7,*)Ihe Fourier-Budan Theorem yields ",numroot,' roots on
@this interval'
write(7,3500)
3500 format('Intervals',4x, 'Initial Guess',4x,'Iterations',4x,'Calc.
@Alpha',4x,Exp. Alpha')
* Check flag NUMROOT provided by subroutine BUDAN to determine
* root-search scheme
if(numroot EQ. 0) then
write(6,*) "No root on the interval [0,1] for data set "j
intcount = 0
write(7,3900) intcount,xalpha(j)
3900 format(i4,61 x,f5.3)
write(7,*)'No root on the interval [0,1]'
return
end if
if(nummot .EQ. 1) then
ilower = 0
iupper = 0
end if
if(numroot .GE. 2) then
ilower = 0
iupper = 1
end if
* Use incremental search to determine initial guess
* Interval Endpoint DO-Loop
do 0400 jroot = ilower, iupper
intcount = 0
* Test the polynomial at endpoint for initial sign value
ifjroot. EQ. lower) then
guess - DFLOAT(ilower)
alower = guess
aupper = alower + delta
end if
if(jroot. EQ. iupper) then
guess = DFLOAT(iupper)
aupper = guess
alower = aupper - delta
end if
ichange = 0
0600 falpha = O.dO
do 1500 p = 1, Ncomp
term = coefficient(Ncomp-p)*guess**(Ncomp-p)
if( (Ncomp-p) .EQ. 0 ) term = coefficient(0)
falpha = falpha + term
1500 continue
* Initialize ISIGN2 on first pass with endpoint
if(ichange .EQ. 0) then
if(falpha .GE. 0.) then
isign2 = 1
else
isign2 = 0
end if
end if
* Note the sign of the function
if(falpha .GE. 0.) then
isign = I
else
isign = 0
end if
* Test function for sign change and increment or decrement the
* search variable as appropriate
if(isign2 .EQ. isign) then
if(jroot .EQ. lower) then
alower = aupper
aupper = aupper + delta
guess = aupper
else iffjroot .EQ. iupper) then
aupper = alower
alower = aupper - delta
guess = alower
end if
end if
* Exit subroutine if no sign change is detected on interval [0,1]
if( (guess .GT. 1.) .OR. (guess .LT. 0.) ) then
write(6,*) 'No root on the interval [0,1]"
write(7,3800) intcount,xalpha(j)
3800 format(i4,61x,f5.3)
write(7,*)No root on the interval [0,1]'
return
end if
* If NO sign change but still within interval, repeat the sequence
if(isign .EQ. isign2) then
isign2 = isign
intcount = intcount + 1
ichange = I
go to 0600
else
* If there IS a sign change:
* Halve the interval where the function crosses the x axis
guessO = (alower + aupper) / 2.dO
end if
* Provide this guess to Newton-Raphson to begin calculations
guess = guessO
* N-R is limited to 1000 iterations for convergence
iter = 0
do 1000 iterlimit = 1, 1000
iter = iter + I
falpha = O.d00
fprime = 0.d00
do 2000 p = 1, Ncomp
fapha = falpha + coefficient(Ncomp-p)
@ *guess**(Ncomp-p)
fprime = fprime + (Ncomp--p)*coefficient(Ncomp-p)
@ *guess**(Ncomp-p- 1)
2000 continue
calc = guess - falpha/fprime
error = DABS((calc - guess)/calc)
guess =calc
if(erncr .LE. epsilon) go to 3000
1000 continue
print *,'N-R method failed to converge after 1000 iterations'
* Output results to file "TABLE"
*
3000 write(7,3600) intcount,guess0,iter,guess,xalpha(j)
3600 forrnat(i4,13x,f5.3,10x,i4,13xf9.6,7x,f5.3)
alpha(j) = guess
* Begin search for root from opposite end of interval
0400 continue
return
end
• M. MICHAEL MUSATOV
• Computer Engineering Section
• Data Mining Engineering Department
* College of Earth
• The State University
* Universal City. Caliornia
• M.S. thesis
• Copywrite=(C) 2009. Copyright. All Rights Reserved.
• http://meami.org 'Search for the People!'
• Advisor. Dr. Walter C. Christie
* SUBROUTINE ALPHAPLOT
*
* This subroutine is used for several purposes:
* 1. Plotting F(alpha) vs alpha [Rachford-Rice obj function]
* 2. Plotting F(alpha) vs alpha (polynomial]
* 3. Plotting Fprime vs alpha [polynomial]
SUBROUTINE ALPHAPLOT(Ncompj,molefrac,alphacoefficient,Ki)
IMPLICIT REAL*8 (a-h,o-z)
REAL*8 Ki(500,100),molefrac(100)
DIMENSION alpha(500),coefficient(0:100)
INTEGER p
PARAMETER(start = 0.OdO, end = 2.OdO, stepsize = 0.0005d0)
OPEN(unit= 11 ,file=f'"a. plot ',status= 'unknown )
OPEN(unit= 12,f ie= 'fprime .plot',status= 'unknown')
* Number of data points for plotting
number = IDINT((end - start + stepsize)/stepsize)
* F(alpha) vs alpha [polynomial]
* F(alpha) vs alpha [polynomial]
* Adjust Ncomp.Npress in PARAMETR
write(I1.*) number
do 1000 phase = start,end,stepsize
falpha = 0.dOO
fprime = 0.dOO
do 2000 p = I,Ncomp
falpha = faipha + coefficient(Ncomp-p)*
@ phase* *(Ncomp-p)
C fprine = fprime + (Ncomp-p)*coefficienINcomp-p)*
C @phase**(Ncomp-p-1)
2000 continue
write(I 1,3600) phase ,falpha
C write(11,3600) phase/prime
3600 fbrmat(f 7.3,2x,f25.12)
1000 continue
C* Rachford-Rice objective function
C
C do 4500 k = I ,Npress
C k =6
C write(11,*) number
C do 3000 phase = start,endstepsize
C falpha = 0400
C do 4000 i = I Ncomp
C faipha = faipha + (molefrac(i)*(Ki(kJi) - 140))I
C @(1400O + phase*(Ki(k,i) - .d0))
C* End of i loop
C 4000 continue
C
C write(]1,3500) phase/alpha
C 3500 formattl 7.25.12)
C* -End of phase loop
C 3000 continue
C* ~ End qofk loop
C 4500 continue
CLOSE(unit=- 11)
CLOSE(unit= 12)
return
end
• M. MICHAEL MUSATOV
• Computer Engineering Section
• Data Mining Engineering Department
* College of Earth
• The State University
* Universal City. Caliornia
• M.S. thesis
• Copywrite=(C) 2009. Copyright. All Rights Reserved.
• http://meami.org 'Search for the People!'
• Advisor. Dr. Walter C. Christie
* SUBROUTINE BUDAN
* Subroutine uses the Fourier-Budan Theorem to determipe
* the number of roots that the alpha polynomial has on tn,
* interval [u,v].
,
* PARAMETERS: iu = lower bound of alpha interval
* iv = uppper bound of alpha interval
* VARIABLES: coefficient = coefficient of alpha polynomial
* dcoeff = coefficient of polynomial derivatives
* deriv = derivatives of alpha polynomial
* fvapor = the alpha polynomial
* ia,ib = # of sign changes for derivative series
* ivapor = alpha = vapor fraction
* jsign,ksign = flags for derivative sign change
* numroot = number of zeros on the interval
SUBROUTINE BUDAN(J,Ncomp,coefficientnwnroot)
IMPLICIT REAL*8(a--ho-z)
INTrEGER p
DIMENSION dcoeff(0:100,0:100), coefficient(0:100), deriv(0:100)
PARAMETER(iu = 0, iv = 1)
C DATA (coefficient(l), I = ONcomp-l) /-j.,I.,-2.,3.,-4.,5. /
OPEN(unit=2,file="test",status= unknown)
REWIND(Unit=2)
ia = 0
ib = 0
do 0500 ivapor = iu, iv, 1
* Evaluate the polynomial function at the endpoints iu and iv
fvapor = OdO
do 0600 p = 1, Ncomp
fvapor = fvapor + coefficient(Ncomp-p)*ivapor**(Ncomp-p)
0600 continue
write(2,*) fvapor = ",fvapor
write(2,*) - -
* Calculate coefficients of first derivative
do 1000 n = Ncomp-1, 0, -1
dcoeff(0,n) = coefficient(n)
write (2,*) "dcoeff(0,',n,') = ",dcoeff(0,n)
1000 continue
write(2,*) " "
* Calculate coefficients of 2nd- and higher-order derivatives
* as multiples of those of the first derivative
do 1500 m = 1, Ncomp-I
do 2000 n = Ncomp-m, 1, -1
dcoeff(mn-1) = n*dcoeff(m-l,n)
write (2,*) "dcoeff(',m,',n-1,) = ",
@dcoeff(m,n-1)
2000 continue
write(2,*) " "
1500 continue
* Evaluate the derivative series at the endpoints iu and iv
do 3000 n = 1, Ncomp-1
deriv(m) = 0.dO
do 4000 n = Ncomp-m, 1, -1
term = dcoeff(m,n-1)*ivapor**(n-1)
if( (n-I) .EQ. 0 ) term = dcoeff(mn-1)
deriv(m) = deriv(m) + term
write(2,*) 'inter deriv(°,m, ") = ",deriv(m)
4000 continue
write(2,*) 'total deriv(',m,) = ",deriv(m)
write(2,*) " "
3000 continue
* Count the sign changes between the terms of the series
if(fvapor. LT. 0.) then
ksign = 0
else
ksign = 1
end if
write(2,*) 1csign = ',ksign,' for fvapor'
do 5000 i = 1, Ncomp-l
if(deriv(i) .LT. 0.) then
jsign = 0
else
jsign = 1
end if
write(2,*) 'jsign = ',jsign,' for deriv(',i,T'
* Increment A or B, depending upon the endpoint under evaluation
iffivapor EQ. iu) then
if(ksign .NE. jsign) then
ia = ia + I
write(2,*) 'ia = ',ia,' for deriv(',,'
end if
end if
iffivapor .EQ. iv) then
if(ksign .NE. jsign) then
ib = ib + I
write(2,*) -ib = -,ib,' for derivC',i,')'
end if
end if
ksign = jsign
write(2,*) lcsign = ',ksign,' after deriv(',i,2Y
write(2,*)
5000 continue
0500 continue
* Pass a flag to calling program to indicate root conditions
write(2,*) 'ia =',ia,' and ib = 'ib
numroot = ia -ib
write(2,*) 'numroot = ',numroot
write(2,6000) Ncomp-I, numroot, iu, iv, J
6000 formnat(This polynomial of order 'j3,' has 'i3,' zeros on the in
@terval [',i2,',ij2,'J for J = 'i3)
CLOSE(unit=2)
return
endAC_PROG_F77(fl32 f77 fort77 xlf g77 f90 xlf90)
#ifdef F77_DUMMY_MAIN
# ifdef __cplusplus
extern "C"
# endif
int F77_DUMMY_MAIN() { return 1; }
#endif
subroutine foobar(x,y)
double precision x, y
y = 3.14159 * x
return
end
#define FOOBAR_F77 F77_FUNC(foobar,FOOBAR)
#ifdef __cplusplus
extern "C" /* prevent C++ name mangling */
#endif
void FOOBAR_F77(double *x, double *y);
{
double x = 2.7183, y;
FOOBAR_F77(&x, &y);
}
===FORTRAN 77===
After the release of the FORTRAN 66 standard, compiler vendors
introduced a number of extensions to "Standard Fortran", prompting
ANSI in 1969 to begin work on revising the 1966 standard. Final
drafts of this revised standard circulated in 1977, leading to formal
approval of the new FORTRAN standard in April 1978. The new standard,
known as ''FORTRAN 77'', added a number of significant features to
address many of the shortcomings of FORTRAN 66:
* Block <code>IF</code> and <code>END IF</code> statements, with
optional <code>ELSE</code> and <code>ELSE IF</code> clauses, to
provide improved language support for [[structured programming]]
* DO loop extensions, including parameter expressions, negative
increments, and zero trip counts
* <code>OPEN</code>, <code>CLOSE</code>, and <code>INQUIRE</code>
statements for improved I/O capability
* Direct-access file I/O
* <code>IMPLICIT</code> statement
* <code>CHARACTER</code> data type, with vastly expanded facilities
for character input and output and processing of character-based data
* <code>PARAMETER</code> statement for specifying constants
* <code>SAVE</code> statement for persistent local variables
* Generic names for intrinsic functions
* A set of intrinsics (<CODE>LGE, LGT, LLE, LLT</CODE>) for
<U>lexical</U> comparison of strings, based upon the [[ASCII]]
collating sequence.
: ''(ASCII functions were demanded by the U. S. [[United States
Department of Defense|Department of Defense]], in their conditional
approval vote.) ''
In this revision of the standard, a number of features were removed or
altered in a manner that might invalidate previously standard-
conforming programs.
''(Removal was the only allowable alternative to X3J3 at that time,
since the concept of "deprecation" was not yet available for ANSI
standards.)''
While most of the 24 items in the conflict list (see Appendix A2 of
X3.9-1978) addressed loopholes or pathological cases permitted by the
previous standard but rarely used, a small number of specific
capabilities were deliberately removed, such as:
* [[Hollerith constant]]s and [[Herman Hollerith|Hollerith]] data,
such as:
:: <TT> GREET = 12HHELLO THERE! </TT>
* Reading into a H edit (Hollerith field) descriptor in a FORMAT
specification.
* Overindexing of array bounds by subscripts.
:: <CODE>DIMENSION A(10,5)</CODE>
:: <CODE>Y= A(11,1)</CODE>
* Transfer of control into the range of a DO loop (also known as
"Extended Range").
An important practical extension to FORTRAN 77 was the release of MIL-
STD-1753 in 1978. This specification, developed by the U. S. [[United
States Department of Defense|Department of Defense]], standardized a
number of features implemented by most FORTRAN 77 compilers but not
included in the ANSI FORTRAN 77 standard. These features would
eventually be incorporated into the Fortran 90 standard.
* <code>DO WHILE</code> and <code>END DO</code> statements
* <code>INCLUDE</code> statement
* <code>IMPLICIT NONE</code> variant of the <code>IMPLICIT</code>
statement
* [[Bit manipulation]] intrinsic functions, based on similar functions
included in [[Industrial Real-Time Fortran|Industrial Real-Time
Fortran (ANSI/ISA S61.1 (1976))]]
The [[Institute of Electrical and Electronics Engineers|IEEE]] 1003.9
[[POSIX]] Standard, released in 1991, provided a simple means for
Fortran-77 programmers to issue POSIX system calls. Over 100 calls
were defined in the document — allowing access to POSIX-compatible
process control, signal handling, file system control, device control,
procedure pointing, and stream I/O in a portable manner.
The development of a revised standard to succeed FORTRAN 77 would be
repeatedly delayed as the standardization process struggled to keep up
with rapid changes in computing and programming practice. In the
meantime, as the "Standard FORTRAN" for nearly fifteen years, FORTRAN
77 would become the historically most important dialect.
[[Control Data Corporation]] computers had another version of FORTRAN
77, called Minnesota FORTRAN, with variations in output constructs,
special uses of COMMONs and DATA statements, optimizations code levels
for compiling, and detailed error listings, extensive warning
messages, and debugs.<ref>[http://www.chilton-computing.org.uk/acd/
literature/reports/p008.htm Chilton Computing with FORTRAN]</ref>
• M. MICHAEL MUSATOV
• Computer Engineering Section
• Data Mining Engineering Department
* College of Earth
• The State University
* Universal City. Caliornia
• M.S. thesis
• Copywrite=(C) 2009. Copyright. All Rights Reserved.
• http://meami.org 'Search for the People!'
• Advisor. Dr. Walter C. Christie
• Support a cure for childhood cancer
• http://AlexsLemonade.org
Feynman
Oct 28, 2009, 8:54:23 AM10/28/09
to
On Oct 11, 5:07 am, "http://alexslemonade.org"
<marty.musa...@gmail.com> wrote:
> http://alexslemonade.org
> PROGRAM DBASE1
> INTEGER STOCK, NERR
> REAL PRICE
> CHARACTER NAME*10
> *Assume record length in storage units holding 4 chars each.
> OPEN(UNIT=1, FILE='STOCKS', STATUS='OLD',
> $ ACCESS='DIRECT', RECL=5)
> 100 CONTINUE
> *Ask user or part number which will be used as record number.
> WRITTE(UNIT=*,FMT=*)'Enter part number (or zero to quit):
> READ(UNIT=*,FMT=*) NPART
> IF(NPART .LE. 0) STOP
> READ(UNIT=1, REC=NPART, IOSTAT=NERR) NAME, STOCK, PRICE
> IF(NERR .NE. 0) THEN
> WRITE(UNIT=*, FMT=*)'Unknown part number, re-enter'
> GO TO 100
> END IF
> WRITE(*,115)STOCK, NAME, PRICE
> 115 FORMAT(1X,'Stock is', I4, 1X, A,' at=@ ', F8.2, ' each')
> GOT TO 100
> END
> Stock is 144 widgets @ 555.55 athttp://meami.org
<marty.musa...@gmail.com> wrote:
> http://alexslemonade.org
> PROGRAM DBASE1
> INTEGER STOCK, NERR
> REAL PRICE
> CHARACTER NAME*10
> *Assume record length in storage units holding 4 chars each.
> OPEN(UNIT=1, FILE='STOCKS', STATUS='OLD',
> $ ACCESS='DIRECT', RECL=5)
> 100 CONTINUE
> *Ask user or part number which will be used as record number.
> WRITTE(UNIT=*,FMT=*)'Enter part number (or zero to quit):
> READ(UNIT=*,FMT=*) NPART
> IF(NPART .LE. 0) STOP
> READ(UNIT=1, REC=NPART, IOSTAT=NERR) NAME, STOCK, PRICE
> IF(NERR .NE. 0) THEN
> WRITE(UNIT=*, FMT=*)'Unknown part number, re-enter'
> GO TO 100
> END IF
> WRITE(*,115)STOCK, NAME, PRICE
> 115 FORMAT(1X,'Stock is', I4, 1X, A,' at=@ ', F8.2, ' each')
> GOT TO 100
> END
0 new messages