Category : Files from Magazines
Archive   : DDJ0691.ZIP
Filename : FORTRAN.ASC

 
Output of file : FORTRAN.ASC contained in archive : DDJ0691.ZIP

_FORTRAN & GUIS_
by John L. Bradberry

[LISTING ONE]

C >**************************************************************
PROGRAM BELL
C **************************************************************
C AUTHOR: JOHN L. BRADBERRY CREATION DATE: FEB 15,1989
C UTILITY TO CREATE A BELL CURVE DATA 'PLOT' BY READING IN A SERIES
C OF NUMBERS IN THE RANGE OF 0-100. THE NUMBERS ARE USED TO CREATE
C THE GAUSSIAN DISTRIBUTION CONSTANTS. THE CONSTANTS ARE THEN USED TO
C CALCULATE A NORMAL DISTRIBUTION FROM 0 TO 100 IN STEPS OF 5. '*' ARE
C PLOTTED IN HISTOGRAM FORM TO SIMULATE BELL SHAPE.
C --------------------------------------------------------------
C
IMPLICIT NONE
C
INCLUDE 'BELLCOM.INC'
C
C
INTEGER*2 LU !LOGICAL UNIT NUMBER
C
LU=6
C
C INITIALIZE BELL CURVE DATA (CONTAINED IN COMMON)...
C
BCIDX=0
BCTOT=0
BCEX=0
BCEXS=0


C GET BELL CURVE VALUES FROM USER TO BE USED FOR CALCULATIONS...
C
CALL GET_BELL_DATA(LU)
C
C CALCULATE CONSTANTS FOR GAUSSIAN DISTRIBUTION AND PLOT BELL CURVE
C USING THE '*' CHARACTER...
C
CALL PLOT_BELL_DATA(LU)
C
C
END
C
C >**************************************************************
SUBROUTINE GET_BELL_DATA(LU)
C **************************************************************
C SUBROUTINE TO PROMPT USER FOR INTEGER VALUE...
C --------------------------------------------------------------
C AUTHOR: JOHN L. BRADBERRY CREATION DATE: FEB 8,1989
C
IMPLICIT NONE
C
INCLUDE 'BELLCOM.INC'
C
C
INTEGER*2 I !LOOP INDEX COUNTER
INTEGER*2 LU !LOGICAL UNIT NUMBER
INTEGER*2 BCCOUNT !BELL CURVE DATA POINT COUNT
C
C
BCCOUNT=1
DO WHILE (BCCOUNT.GT.0)
C
CALL IPROMPT(LU,'Enter Number Of Occurrences Next Data Point '//
+ 'Value (Or 0 To Exit).',BCCOUNT)

IF (BCCOUNT.GT.0) THEN
CALL DRPROMPT(LU,'Enter Data Point Value (Range 0-100):',
+ BCDAT)
END IF
C
IF (BCCOUNT.GT.0) THEN
DO I=1,BCCOUNT
BCIDX=BCIDX+1
BCTOT=BCTOT+BCDAT
END DO
BCEX=BCEX+BCCOUNT*BCDAT
BCEXS=BCEXS+BCCOUNT*BCDAT*BCDAT
END IF
END DO
C
C

RETURN
END
C
C >**************************************************************
SUBROUTINE PLOT_BELL_DATA(LU)
C **************************************************************
C SUBROUTINE TO PROMPT USER FOR INTEGER VALUE...
C --------------------------------------------------------------
C AUTHOR: JOHN L. BRADBERRY CREATION DATE: FEB 8,1989
C
IMPLICIT NONE
C
INCLUDE 'BELLCOM.INC'
C
C
INTEGER*2 LU !LOGICAL UNIT NUMBER
INTEGER*2 KX !LOOP INDEX COUNTER
INTEGER*2 STARCOUNT !NUMBER OF STARS TO OUTPUT IN BELL
INTEGER*2 MAXSTARS !MAXIMUM STARS IN CHARACTER STRING

PARAMETER (MAXSTARS=51)

CHARACTER STARS*51 !STRING 'STAR' ARRAY

REAL*8 RVAL1 !TEMPORARY
REAL*8 RVAL2 !TEMPORARY
REAL*8 DEGRAD !DEGREES TO RADIAN CONVERSION
C
C
STARS='***************************************************'
C
DEGRAD=3.141592654D0/180D0
C
IF (BCIDX.GT.0) THEN
BCEX=BCEX/BCIDX
BCEXS=BCEXS/BCIDX
BCMEAN=BCEX
BCVAR=BCEXS-BCEX*BCEX
BCSIGMA=SQRT(BCVAR)
END IF
C
C BELL CURVE FORMULA...
C
C 1/(SIGMA(SQRT(2PI)))*EXP(-(X-MEAN)**2/(2*SIGMA))
C
RVAL1=1.0/(BCSIGMA*SQRT(2*3.141592654))
DO KX=0,100,5
RVAL2=RVAL1*EXP(-1.0*((KX-BCMEAN)**2)/(2.0*BCSIGMA*BCSIGMA))
RVAL2=1000*RVAL2

STARCOUNT=MIN(NINT(RVAL2),MAXSTARS)
WRITE(LU,*)KX,' |',STARS(1:STARCOUNT)
END DO
C
WRITE(LU,'(/,1X,A10,I2,2X,3(A10,F8.3,2X))')
+ '# POINTS= ',BCIDX,'MEAN= ',BCMEAN,'VARIANCE= ',
+ BCVAR,' SIGMA= ',BCSIGMA
C
C
RETURN
END
C
C >**************************************************************
SUBROUTINE IPROMPT(LU,PROMPT,IVAL)
C **************************************************************
C SUBROUTINE TO PROMPT USER FOR INTEGER VALUE...
C --------------------------------------------------------------
C AUTHOR: JOHN L. BRADBERRY CREATION DATE: FEB 8,1989
C
IMPLICIT NONE
C
INTEGER*2 IVAL !INTEGER VALUE RETURNED
INTEGER*2 LU !LOGICAL UNIT NUMBER
C
CHARACTER*(*) PROMPT !STRING PROMPT TO BE ISSUED
C
C
WRITE(LU,*)PROMPT
READ(LU,*)IVAL
C
C
RETURN
END
C
C
C >**************************************************************
SUBROUTINE DRPROMPT(LU,PROMPT,DRVAL)
C **************************************************************
C SUBROUTINE TO PROMPT USER FOR DOUBLE PRECISION REAL VALUE...
C --------------------------------------------------------------
C AUTHOR: JOHN L. BRADBERRY CREATION DATE: FEB 8,1989
C
IMPLICIT NONE
C
INTEGER*2 LU !LOGICAL UNIT NUMBER
C
CHARACTER*(*) PROMPT !STRING PROMPT TO BE ISSUED

C
REAL*8 DRVAL !REAL VALUE RETURNED
C
C
WRITE(LU,*)PROMPT
READ(LU,*)DRVAL
C
C
RETURN
END
C

[LISTING TWO]


C -----------------------------------------------------------
C BELL CURVE CONTROL COMMON ...
C -----------------------------------------------------------
C
INTEGER*2 BCIDX !BELL CURVE INDEX
C
REAL*8 BCMEAN !BELL CURVE MEAN
REAL*8 BCEX !BELL CURVE EX TERM
REAL*8 BCEXS !BELL CURVE EX TERM SQUARED
REAL*8 BCTOT !BELL CURVE TOTAL
REAL*8 BCDAT !BELL CURVE DATA
REAL*8 BCVAR !BELL CURVE VARIANCE
REAL*8 BCSIGMA !BELL CURVE SIGMA
C
C
COMMON /BELLCURVE/
C
+BCIDX,
+BCMEAN,
+BCEX,
+BCEXS,
+BCTOT,
+BCDAT,
+BCVAR,
+BCSIGMA
C



[Example 1]

C
INTEGER GLU !LOGICAL UNIT NUMBER
C
GLU=10
OPEN (UNIT=GLU, FILE = 'USER')
.
. (see listings 1-2 for rest of body)
.
C
CLOSE (GLU, STATUS = 'KEEP')
C