! These modules are needed by the program ref90.f. The files one.f
! and two.f in this directory contain the modules. They must be
! compiled separately using the command xlf90 -c module_name.f
! and the object files, one.o and two.o, linked when ref90.f is
! compiled. See Usage, below.
Module one ! This module is used to share global data with
! a subroutine. RS/6K users see note below.
Implicit None
Real :: Alpha = 3.0, Beta = 3.0, Gamma = 2.0, Delta
End Module one
Module two ! This module is used to share global data with
! a subroutine. RS/6K users see note below.
Implicit None
Real :: Epsilon=4.0, Zeta=3.0, Eta=2.0, Theta=1.0
End Module Two
Program ref90a
! A pastiche of FORTRAN 90 structures in one long program. It
! was adapted from the Watfor 77 program FORTREF.FOR. Certain
! constructs, e.g., overloading, are not yet included and what
! is included here must be considered somewhat preliminary.
! Everything included here compiles and runs under Salford/NAG
! FTN90 Compiler Version 2.1 - in BOTH fixed and free format.
! (You use the .for extension for fixed and the .f for free.)
! This program works with the xlf90 compiler on the RS/6000;
! then the extension is .f
! It was also modified in late 1997, early 1998 to work
! using the Lahey ELF90 compiler - which is NOT backwardly
! compatible with Fortran 77. Numerous, but small changes
! were required at that time.
! Ampersands have been positioned in column 73 to indicate
! continuation. These aren't read in NAG Fortran 90 with
! fixed format, but are necessary when this program is run on
! the RS/6000 under xlf90.
!***********************************************************************
! R.J.Ribando, 310 MEC, Univ. of Virginia, December 1994.
! Copyright (c) 1994, 1997 All rights reserved.
! This program may be distributed freely for instructional purposes
! only providing: (1.) The file be distributed in its entirety
! including disclaimer and copyright notices. (2.) No part of it
! may be incorporated into any commercial product.
!**********************************************************************
! DISCLAIMER
! The author shall not be responsible for losses of any kind
! resulting from the use of the program or of any documentation
! and can in no way provide compensation for any losses sustained
! including but not limited to any obligation, liability, right,
! or remedy for tort nor any business expense, machine downtime
! or damages caused to the user by any deficiency, defect or
! error in the program or in any such documentation or any
! malfunction of the program or for any incidental or consequential
! losses, damages or costs, however caused.
!***********************************************************************
! References:
! G. Coschi and J.B.Schueler, WATFOR-77 Language Reference Manual,
! WATCOM Publications Limited, Waterloo, Canada (1985).
! L. Nyhoff and S. Leestma, Introduction to FORTRAN 90 for
! Engineers and Scientists, Prentice-Hall (1997).
! J.M.Ortega, An Introduction to Fortran 90 for Scientific
! Computing, Saunders (1994).
! W.E. Mayo and M. Cwiakala, Introduction to Computing for
! Engineers, McGraw-Hill, NY (1991)
! W.S. Brainerd, C.H.Goldberg, and J.C. Adams, Programmer's
! Guide to Fortran 90, 2nd Ed., Unicomp, Albuquerque (1994)
! J.F.Kerrigan, Migrating to Fortran 90, O'Reilly & Associates,
! Sebastopol, CA (1993)
! Nagware FTN90 User's Guide, Salford Software (1995).
! Elf90 Essential Lahey Fortran, Revision B, Lahey Computer
! Systems, 1996
! W.H.Press, S.A.Teukolsky, W.T.Vetterling, B.P.Flannery,
! M.Metcalf, Numerical Recipes in Fortran 90, The Art of Scientific
! Computing, Vol. 2 of Fortran Numerical Recipes, Cambridge University
! Press, New York (1996).
!***********************************************************************
! Sources:
! Numerical Algorithms Group (NAG), Inc.
! (630) 971-2337
! http://nag.com
! Lahey Computer Systems, Inc.
! 865 Tahoe Blvd., P.O.,Box 6091
! Incline Village, NV 89450-6091
! (800) 548-4778
! sales@lahey.com
! http://www.lahey.com
!
! Digital (what used to be Microsoft Fortran)
! http://www.digital.com/fortran/dvf-spd.html
!
! Absoft
! http://www.absoft.com
!***********************************************************************
! Revisions:
! 6/ 9/94: Added some array operations.
! 12/23/94: Added disclaimer, internal recursive subroutine, etc.
! 12/28/94: Added allocatable arrays, derived types, etc.
! 1/ 5/95: Added module
! 4/26/96: Added intent in and out
! 4/28/96: Added cshift and eoshift and some housekeeping.
! 5/ 3/96: Added tab descriptor, use of masks
! 5/28/96: Added Concatenation and Trim and fixed up data structure.
! 5/29/96: Fixing up to run on RS/6000. Changed all * in column
! 1 to ! and put a continuation (&) out beyond column 72.
! 6/ 5/96: Works on RS/6000!
! 5/ 5/97: Switching to work under ELF90. Remove x descriptors
! (for skipping spaces) in all Format statements, added
! double colons in all declaration statements, added
! explicit interfaces for the external subprograms,
! removed all unused variables, removed print*, removed
! commons, data statements, etc. Literally hundreds of
! minor changes were required because ELF90 is not backwardly
! compatible with Fortran 77.
! 11/1/97: Section on Pointers and Targets added by Mark Fisher.
! 1/14/98: Housekeeping
!***********************************************************************
! Usage:
! xlf90 compiler on the IBM RS/6000:
!
! First cut off and compile the module one.f with the command
! xlf90 -c one.f
! which will produce the files one.o and one.mod
! Do same with second module.
! Then compile this program, ref90.f with the command
! xlf90 ref90.f one.o
! which will produce an executable file named a.out
!
! To run the program, type a.out
!
! Salford/NAG (PC) Users:
! ftn90 ref90.f/lgo (free format)
! or
! ftn90 ref90.for/lgo (fixed format)
!***********************************************************************
Use One ! Here is where the modules for sharing data are put.
Use Two
Implicit None
! Declarations:
Integer:: I, j, K=3, Caseno, Badnum, n, L=4, M=5
Integer:: mg1, ng1
Integer, Parameter::Imax = 10, Jmax =10
Real :: Array(Imax, Jmax)
Real :: Barray(3, 3), Carray(3, 3), Darray(3, 3)
Real, Target :: Earray(2, 2), Farray(3, 3)
Real :: Ashft(4,4), Bshft(4,4)
Real :: Vec(10), Vect1(-4:5)
Real :: vector1(5), vector2(5)
Real, Dimension (:,:), Allocatable :: G1 ! The array G1 is set
! up for dynamic redimensioning
Real :: A= .7132, B = .532, Numgrad, Magnit, Diam = 4.2, Circum, &
& Area ! Declare and initialize on same line.
Real :: Dotprod, Top_of_the_line
Real :: Angle, Xval = -1.0, Yval = -1.0
! WARNING: kind = 2 may be used for double precision on some compilers.
Real (kind = 8) :: Pidoub
Real, Pointer :: Apoint(:,:)
Character (len=20) :: Name
Character (len=50) :: Warning
Character (len=10) :: Strng
Character (len=1) :: Ltrgrad
Character (len=8) :: date
Character (len=10) :: time
Character (len=80) :: Linetext
Character (len=1) :: Aselect
Complex :: Z
Logical :: Mask(Imax, Jmax)
Logical :: Check = .true.
! Set up a derived data type and then declare a variable of that type:
Type :: Person
Character (len =20) :: Full_Name
Character (len = 7) :: Sex
Integer :: Age, Weight
Character (len = 20) :: Occupation
End Type Person
Type (Person) :: Flintstone(4)
! Note: COMMON and DATA statements are not allowed in ELF90, nor
! are statement functions.
! Explicit interfaces are needed for all external subprograms (in ELF90)
Interface
Function Hypot(L,M)
Implicit None
Integer, Intent(IN) :: L, M
Real :: Hypot
End Function Hypot
Subroutine Circle(Diam, Circum, Area)
Implicit None
Real, Intent (IN) :: Diam
Real, Intent (OUT) :: Circum, Area
End Subroutine Circle
End Interface
Write(6,*) ! Now the executable statements
write(6,*) 'This program (REF90.FOR) demonstrates a pastiche of '
write(6,*) ' Fortran 90 features. All the statements were written'
write(6,*) ' originally in fixed (Fortran77) format, so the .FOR'
write(6,*) ' extension was used on the filename. As it stands'
write(6,*) ' now, it can be run under the NAG compiler in EITHER'
write(6,*) ' fixed (.for) or free (.f) format. On the RS/6K'
write(6,*) ' you would use .f as the extension.'
write(6,*) ' It will also run under the ELF90 compiler.'
write(6,*)
! Assignment statements:
Epsilon = 3.0 ! Multiple statements are allowed on one line
Zeta = 0.5 ! in some Fortran 90's, but not ELF90
Eta = Alpha + Beta + Gamma &
& + Epsilon + Zeta ! A continued statement.
Top_of_the_line = 17.0 ! Variables having up to 31 alphanumeric
! characters and underlines.
Write(6,100,advance='no') ! Non-advancing IO (this seems
100 format(' Please input your name:') ! to be automatic with ELF90)
Read(5,fmt=1020) Name
Write(6,fmt=1030) Name
Write(6,*) 'Top of the line = ',Top_of_the_line
!************************************************
! Repetition *
!************************************************
! Simple Do loop (Line numbered loops not allowed in Elf90):
write(6,*) 'Next is output from simple DO LOOP:'
read(5,*) ! These read(5,*) are to stop the program.
! The "pause" statement is considered obsolescent.
Do J = 1,10
! Use an intrinsic (library) function (Sin) and
! a user-defined function (Square):
Vec(J) = Sin(Real(J)) + Square(J)
Vect1(J-5) = Real(J)
! Use list-directed output:
Write(6,*) Vec(J),Vect1(J-5)
End Do
Write(6,*)
! Nested Do loop (without line numbers, but with names):
write(6,*) 'Next is output from Nested DO LOOP:'
read(5,*)
Fred : Do J = Jmax,1,-2 ! Note named loops
Barney : Do I = 1,Imax,2
array(I,J) = Hypot(I,J)
Write(6,fmt=1000) I,J,array(I,J)
end do Barney
Write(6,fmt=1010) (array(I,J), I = 1,Imax,2) ! Note implied Do Loop
end do Fred
Write(6,*)
! Do While - (Pretest Loop):
write(6,*) 'Next is output from DO WHILE:'
read(5,*)
do while (k .lt. 10) ! Note that in WATFOR77 this
K = K + 1 ! would be: While ( ) do
Write (6,*) K ! ....
end do ! end while
Write(6,*)
! Do - End Do with an EXIT. This allows the stopping criterion
! to be placed anywhere in the loop and is preferred over previous.
write(6,*) 'Next is output from DO - END DO with an EXIT:'
Do
if (k > 20) Exit
k = k + 1
Write(6,*) k
End do
write(6,*)
!************************************************
! Selection *
!************************************************
! Logical IF statement:
Read(5,*)
write(6,*) 'Next is output from LOGICAL IF statement:'
IF (K .GE. 0) Write(6,1040) Name
Write(6,*)
! Block If statement with compound logical operator:
! Note use of symbolic representation for relational operator.
Read(5,*)
write(6,*) 'Next is output from BLOCK IF statement:'
If (Jmax <= 100 .and. Imax >= 0 .and. k > -20) Then
Do J = 1,3
Vec(J) = 0.0
Do I = 2,4
Vec(J) = Vec(J) + Real(I)**3
end do
end do
Write(6,fmt=1050) J, Vec(J), Vec(J)
End If
Write(6,*)
! Multialternative selection structure - IF - Else IF:
Write(6,*) 'Next is output from IF - ELSE IF:'
Write(6,*) 'Input your numerical grade, please. (0. - 100.)'
! "Iostat" will be used to trap input errors:
Read(5,*,Iostat = Badnum) Numgrad
do While (Badnum .GT. 0) ! Here we're getting the number grade
Badnum = 0
Write(6,*) 'Bad Data, Try again.'
Write(6,*) 'Input your numerical grade, please. (0. -100.)'
Read(5,*,Iostat = Badnum) Numgrad
END do
Grade_Assign: IF (Numgrad .LT. 60.) Then
Ltrgrad = 'F'
Else IF (Numgrad .LT. 70.) Then
Ltrgrad = 'D'
Else IF (Numgrad .LT. 80.) Then
Ltrgrad = 'C'
Else IF (Numgrad .LT. 90.) Then
Ltrgrad = 'B'
Else
Ltrgrad = 'A'
End If Grade_Assign
Write(6,fmt=1060) Numgrad, Ltrgrad
If (Numgrad < 65 ) Then
Warning = 'Shape up, '
Write(6,*) Trim(Warning)//' '//Trim(Name)//'!'
End If
Write(6,*)
! Select Case - End Select construct
Write(6,*) 'Next is output from SELECT - END SELECT:'
Write(6,*) 'Input an integer, please:'
Read(5,*,Iostat = Badnum) Caseno
do while (badnum .gt. 0)
Badnum = 0
Write(6,*) 'Bad Data, Try again.'
Write(6,*) 'Input an integer, please:'
Read(5,*,Iostat = Badnum) Caseno
end do
Select Case(Caseno)
Case (-1000 : 0)
Write(6,*) 'This is Case 1'
Case (1 : 4)
Write(6,*) 'This is Case 2'
Case (5, 7, 9)
Write(6,*) 'This is Case 3'
Case (6, 8, 10:1000)
Write(6,*) 'This is Case 4'
Case Default
Write(6,*) 'This is everything else'
End Select
Write (6,*)
!*************************************************
! Miscellaneous *
!*************************************************
! Subroutines
write(6,*) 'Next is output from SUBROUTINE:'
read (5,*)
Call Circle(Diam, Circum, Area)
Write(6,fmt=1100) Diam, Circum, Area
! Note Delta is shared through a module and Theta is passed via module.
Write(6,*) 'Delta = ', Delta
Write(6,*) 'Theta = ', Theta
Write(6,*)
! Recursive Functions
Write(6,*) 'RECURSIVE FUNCTIONS.'
Write(6,*) '(Handled as an internal function)'
Write(6,*) 'Input the value of an integer less than or equal '
Write(6,*) 'to 12 that you want to compute the factorial of:'
Read(5,*) n
write(6,fmt=1130) n, F(n)
If (n > 12) Then
Write(6,*) 'WARNING!'
Write(6,*) 'The computed value is WRONG! The correct value is'
Write(6,*) 'greater than the biggest integer allowed!'
End if
write(6,*)
Write(6,*) 'Hypotenuse = ', Hypot(L,M) ! Use an external function
! Complex numbers
write(6,*) 'Next is output from COMPLEX ARITHMETIC:'
read(5,*)
Z = Cmplx(A, B)
Magnit = abs(Z)
Write(6,*) Z
Write(6,fmt=1080) Real(Z)
Write(6,fmt=1090) Aimag(Z), Magnit
Write(6,*)
! Logical variables
IF (Check) Write (6,*) 'Check was True'
Write(6,*)
! Integer arithmetic
write(6,*) 'Next is output based on INTEGER ARITMETIC:'
read(5,*)
Do K = 1,100
IF (K/10*10 == K) Write(6,*) K ! Only true if K is a multiple
end do ! of 10.
Write(6,*)
write(6,*) 'Next is "DOUBLE PRECISION" (Real*8 - 15-16 significant&
& figures.)'
Write(6,*) '(and shows how to find pi from inverse cosine.)'
read(5,*)
! Double precision (Real*8)
Pidoub = acos(-1.0)
Write(6,*) Pidoub
Write(6,*)
! Atan2 vs. Atan. Atan runs between -pi/2 and pi/2; Atan2 runs
! between -pi and +pi.
Angle = Atan(Yval/Xval)
Write(6,*) 'Angle using Atan function = ', Angle
Angle = Atan2(Yval,Xval)
Write(6,*) 'Angle using Atan2 function = ', Angle
Write(6,*)
write(6,*) 'Next gives the DATE and TIME:'
read(5,*)
Call date_and_time(date,time)
Write(6,*) 'date = ',date
Write(6,*) 'time = ',time
write(6,*)
! Use of internal Write statement to change an integer or real to
! a character variable so that it can be used in a legend or label.
write(6,*) 'Next is output from INTERNAL WRITE section:'
read(5,*)
Write(Strng,'(I10)') I
Write(6,fmt=1021) 'I =', Strng
Write(Strng,'(F5.2)') Alpha
Write(6,fmt=1021) 'Alpha =', Strng
Write(Strng,'(1PE9.2)') Alpha
Write(6,fmt=1021) 'Alpha =', Strng
write(6,*)
Write(6,*) 'Use of DATA STRUCTURE:'
write(6,*)
Flintstone(1) = Person("Fred_Flintstone","male",38,190,"quarryman"&
&)
Flintstone(2) = Person("Wilma_Flintstone","female",36,120,"systems&
& analyst")
Flintstone(3) = Person("Pebbles_Flintstone","female",8,75,"student&
&")
Flintstone(4) = Person("Dino_Flintstone","male",3,120,"pet")
! Use of Concatenation and Trim
Do k = 1, 4
Write(Strng, '(I2)') Flintstone(k)%Age
If (Strng(1:1) == '8' .or. Strng(1:2) == ' 8') Then
Write(6,*) Trim(Flintstone(k)%full_name)//' is an ' &
& //Trim(Strng)//'-year-old, '//Trim(Flintstone(k)%Sex)// &
& ' '//Trim(Flintstone(k)%Occupation)//'.'
Else
Write(6,*) Trim(Flintstone(k)%full_name)//' is a ' &
& //Trim(Strng)//'-year-old, '//Trim(Flintstone(k)%Sex)// &
& ' '//Trim(Flintstone(k)%Occupation)//'.'
End if
end do
write(6,*)
Linetext = Flintstone(1)%Full_name
If (Flintstone(1)%Weight > Flintstone(2)%Weight) then
Write(6,*) Trim(Linetext)//' weighs more than '// &
& Trim(Flintstone(2)%Full_Name)//'.'
Else if (Flintstone(1)%Weight < Flintstone(2)%weight) then
Write(6,*) Trim(Linetext)//' weighs less than '// &
& Trim(Flintstone(2)%full_name)//'.'
Else
Write(6,*) Trim(Linetext)//' and '// &
& Trim(Flintstone(2)%full_name)//'weigh the same.'
end if
write(6,*)
!***********************************************************************
! Simplified Array operations: *
! (Very useful in finite-difference/volume/element calculations)*
!***********************************************************************
Barray = 3. ! Initialize both arrays here (because Data
Carray = 4. ! statements are forbidden.)
write(6,*) 'Next is an ARRAY ADDITION:'
read(5,*)
darray = barray + carray ! No Do Loops needed!
do i = 1,3
write(6, fmt=1010) (darray(i,j), j =1,3)
end do
write(6,*)
carray(1:2,3) = 0.0 ! Work on just a section of an array.
mask = .true. ! Set up masks.
mask(1, 1:jmax) = .false. ! Left side.
mask(imax,1:jmax) = .false. ! Right side.
mask(1:imax,1 ) = .false. ! Bottom
mask(1:imax,jmax) = .false. ! Top
write(6,*) 'Next is use of the WHERE construct:'
read (5,*)
array = 9.9 ! Initialize whole array here, then reset part
Where (.not. mask) ! in this statement.
array = 0.0
End where
do j = 10,1,-1
write(6, fmt=1010) (array(i,j), i=1,10)
end do
Read(5,*)
Write(6,*) 'Next is use of CSHIFT/EOSHIFT operators - Original arr&
&ay:'
! Use of Cshift and Eoshift to access neighbors without having to
! use the i,j subscripts (along with do loops).
Write(6,fmt=119) 'Label1', 'Label2', 'Label3', 'Label4'
119 Format(t12, A6, t32, A6, t52, A6, t72, A6) ! Note use of T (Tab) descriptor
Do J = 1,4
Do I = 1,4
Ashft(i,j) = 10*i + j ! This is just to initialize the array.
End Do
End do
Do J = 4, 1, -1
Write(6,fmt=120) (Ashft(i,j), i = 1,4)
End do
120 Format(t10, f8.3, t30, f8.3, t50, f8.3, t70, f8.3) ! Note Tab descriptor
Bshft = Cshift(Ashft, 1, Dim = 2)
Write(6,*)
Write(6,*) 'Array shifted down 1 using CSHIFT (circular shift)'
Do J = 4, 1, -1
Write(6,120) (Bshft(i,j), i = 1,4)
End do
Bshft = Eoshift(Ashft, -1, Dim = 1)
Write(6,*)
Write(6,*) 'Array shifted to right using EOSHIFT (end-off shift)'
Do J = 4, 1, -1
Write(6,fmt=120) (Bshft(i,j), i = 1,4)
End do
Read(5,*)
Write(6,*) 'Next is use of DYNAMIC REDIMENSIONING.'
Write(6,*) 'Input dimensions of a 2-D array separated by comma.'
Write(6,*) '(It would be preferrable to keep the integers less'
Write(6,*) 'than 10 or so to minimize the printing later.)'
Read(5,*) mg1, ng1
Allocate (G1(mg1,ng1)) ! Allocate the desired memory
Do J = 1, NG1
Do I = 1, mg1
G1(i,j) = i-j ! Assign some values.
End do
Write(6,1150) (G1(i,j), i = 1, mg1)
End do
Deallocate (G1) ! Return the memory.
write(6,*)
write(6,*) 'Next is use of an INTRINSIC FUNCTION for vectors:'
read(5,*)
call random_seed() ! Use the supplied random number
call random_number(vector1) ! generator to get some values.
call random_number(vector2)
dotprod = dot_product(vector1,vector2)
write(6,fmt=1120) dotprod
write(6,*)
write(6,*)
write(6,*) 'Next is use of POINTERS and TARGETS for arrays:'
read(5,*)
Earray = 5. ! Initialize Earray
Farray = 7. ! Initialize Farray
write(6,*) 'Chose the array you would like to display, Earray or F&
&array'
write(6,*) 'Enter e or f (it must be lower case)'
read(5,*) Aselect
if (Aselect == 'e') Apoint => Earray ! Assign Apoint to Earray
if (Aselect == 'f') Apoint => Farray ! Assign Apoint to Farray
write(6,*) Apoint
nullify (Apoint)
write(6,*)
!***************************
! File processing *
!***************************
! All data is written to "Scratch" files, so no files will be
! left when the job is done.
! List directed
Write(6,*) 'Next is output from file processing section (LIST-DIRE&
&CTED):'
Read(5,*)
Open (Unit = 12, Status = 'Scratch')
Write(12,*) Vec
Rewind(12)
Read(12,*) Vec
Write(6,*) Vec
Close(12)
! Formatted
Write(6,*)
Write(6,*) 'Next is output from the file processing section (FORMA&
&TTED): '
read(5,*)
Open(unit = 15, status = 'scratch')
Write(15, fmt=1140) vec
rewind(15)
! read(15, fmt=1140) vec
write(6,*) 'got here'
write(6, fmt=1140) vec
close(15) ! Files should be closed at end.
! Unformatted: Default record length might have to be increased
! to handle longer vectors. The file is written, then read
! unformatted, then printed list-directed.
Write(6,*) 'Next is output from file processing section, written a&
&nd read unformatted, then printed list-directed.'
read(5,*)
Open (Unit = 13, Form = 'Unformatted', Status = 'Scratch')
Write(13) Vec
Rewind(13)
Read(13) Vec
Write(6,*) Vec
Close(13)
! Use of "End =" when exact number of entries in a file are not known.
Open(Unit = 14, Status = 'Scratch')
Write(6,*)
Write(6,*) 'Next is when you do not know the exact number of entri&
&es in a file'
Do I = 1,7
Write(14,*) Vec(I)
end do
Rewind(14)
Do I = 1, 10
Read(14,*,End = 420) Vec(I)
Write(6,*) I, Vec(I)
end do
420 I = I-1
Write(6,fmt=1110) I
Close(14)
!************************************************************************
! Format statments *
! Note that the use of _x to give blanks is forbidden in ELF90. *
! Use ' ' instead. *
!************************************************************************
1000 Format(' ','I = ',I3,' J = ',I3,' array(I,J) = ',F9.2)
1010 Format(5(' ',EN10.3)) ! Note multiple!
1020 Format(A20)
1021 Format(2A10)
1030 Format(//,' You are in for the thrill of your life, ',A20,/)
1040 Format(' We''re doing well, ',A20)
1050 Format(' ',I5,' ',E15.8,' ',EN11.4)
1060 Format(' ','Number Grade =', F8.1,' ', 'Letter Grade =',A2)
1080 Format(' ','Magnitude of a complex number whose real part is',F6.&
&2)
1090 Format(' ','and imaginary part is', F6.2, ' is:',F6.2)
1100 Format(' ','Diameter = ',F6.2,' Area = ',F6.2,' Circumferen&
&ce = ',F9.2)
1110 Format(' ','There were ',I2,' entries in the file.',/)
1120 Format(' ','Dotproduct of the two vectors = ', f10.4)
1130 Format(' ','The factorial of ',I3, ' = ', I20)
1140 Format(4(' ',e15.8))
1150 Format(5g15.8)
stop '**** O.K.'
contains
! Internal Subprograms:
Function Square(J)
Implicit None
Real:: Square
Integer, Intent(In) :: J
Square = Real(J**2)
Return
End Function Square
Recursive Function F(n) Result(Fac)
! Function for the factorial.
! This is treated as an internal function here.
! Note that it calls itself!
! WARNING: This gives a wrong answer for n > 12 !!
Implicit None
Integer, Intent(In) :: N
Integer :: Fac
If (n == 1) then
Fac = 1
Else
Fac = N*f(n-1)
end if
Return
end function f
end program ref90a
! External subprograms
Function Hypot(L,M)
! This is an example of a function subprogram
Implicit None
Integer, Intent(IN) :: L, M
Real :: Hypot
Real :: Square2
Square2 = Real(L)**2 + Real(M)**2
Hypot = Sqrt(Square2)
Return
End function hypot
Subroutine Circle(Diam, Circum, Area)
Use one ! Use of a module to share data
Use two
! An example of a subroutine subprogram
Implicit None
! INTENT(IN) causes the compiler to balk if you try to change
! a variable that is only supposed to be input to the subroutine.
! INTENT(OUT) means the variable is an output. INOUT can be either.
! Great when several programmers working on same job!
Real, Intent(In) :: Diam
Real, Intent(Out) :: Circum, Area
Real :: PI, H
Pi = Acos(-1.0)
Circum = Pi * Diam
Area = Pi * Diam**2 / 4.0
Delta = Alpha + Beta + Gamma
h = epsilon + zeta + theta
Area = h*area
! Diam = 3.0 ! The compiler would choke if this weren't commented out.
Return
End Subroutine Circle