Modern Fortran Explained -2018- p.495
Modern Fortran Explained ~ Fortran 2018 対応版は赤い表紙なので赤本としておきます。前の版の Modern Fortran Explained は緑でした。
- 作者: Michael Metcalf,John Reid,Malcolm Cohen
- 出版社/メーカー: Oxford Univ Pr
- 発売日: 2018/11/06
- メディア: ハードカバー
- この商品を含むブログを見る
Modern Fortran Explained (Numerical Mathematics and Scientific Computation)
- 作者: Michael Metcalf,John Reid,Malcolm Cohen
- 出版社/メーカー: Oxford University Press, U.S.A.
- 発売日: 2011/05/08
- メディア: ペーパーバック
- この商品を含むブログを見る
その章末問題 9-1 に二次方程式の解を求めるものがあるのですが、巻末（pp.494-495）に解答が与えられています。
その脚注に、1963 年の E. Organick の FORTRAN Primer の解答例を参照するもよしとあって、さらにそれを採録し FORTRAN66 および FORTRAN77 でも書き直した M. Metcalf の記事も参照するもよしとあるので、見てみることにします。
MFE の解答例では、桁落ち対処がなされていますが、Organick/Metcalf は二次方程式の解の公式そのまま使っています。
以下では基本的にプログラムは M. Matcalf が Encyclopedia of Physical Science and Technology, Vol.5 に書いた記事中のプログラムを微修正して、入力データは E. Organick のものを用いることにします。
今日は FORTRAN II と IV のプログラムを IBM7090 エミュレータで実行した結果を示します。FORTRAN IV のプログラムの方は標準的 FORTRAN66 で書かれているので、今のコンパイラでも一応コンパイル＆実行できます。（正確にいえば FORTRAN66 とは細かな仕様差があるのですが、基本的な使い方ならまま行けます。） 明日以降に FORTRAN77 と Fortran90 の結果を示すことにします。
JOB CARD は私が適当にいじりました。
参考：
www.frobenius.com
驚くべきことに、Intel Visual Fortran では Visual Studio 2017 でシンタックス・カラリングがホレリス型に対応していて、ホレリス型の桁数分だけ色を変えてくれます。さすが２１世紀！
FORTRAN II
参考ページ
fortran66.hatenablog.com
入力
$JOB QUADRATIC EQUATION $EXECUTE FORTRAN * ID QUAD * XEQ C SOLUTION OF QUADRATIC EQUATION C (P. 122 OF A FORTRAN PRIMER BY E. ORGANICK) 1 READ INPUT TAPE 5, 51, ANAME, N 51 FORMAT(A6,I2) WRITE OUTPUT TAPE 6, 52, ANAME 52 FORMAT(1H1,33HROOTS OF QUADRATIC EQUATIONS FROM A6) DO 21 I = 1, N READ INPUT TAPE 5, 53, A, B, C 53 FORMAT(3F10.2) WRITE OUTPUT TAPE 6, 54, I, A, B, C 54 FORMAT(1H0,8HSET NO. I2/5H A = F8.2,12X,4HB = F8.2,12X,4HC = F8.2) IF (A) 10, 7, 10 7 RLIN = -C/B WRITE OUTPUT TAPE 6, 55, RLIN 55 FORMAT(7H LINEAR,25X,4HX = F10.3) GO TO 21 10 D = B**2 - 4.*A*C IF (D) 12, 17, 17 12 COMPR = -B/(2.*A) COMP1 = SQRTF(-D)/(2.*A) COMP2 = -COMP1 WRITE OUTPUT TAPE 6, 56, COMPR, COMP1, COMPR, COMP2 56 FORMAT(8H COMPLEX,21X,7HR(X1)= F10.3,11X,7HI(X1)= F10.3,/1H ,28X, 17HR(X2)= F10.3,11X,7HI(X2)= F10.3) 16 GO TO 21 17 REAL1 = (-B + SQRTF(D))/(2.*A) REAL2 = (-B - SQRTF(D))/(2.*A) 20 WRITE OUTPUT TAPE 6, 57, REAL1, REAL2 57 FORMAT(6H REAL 25X,5HX1 = F10.3,13X,5HX2 = F10.3) 21 CONTINUE WRITE OUTPUT TAPE 6, 58, ANAME 58 FORMAT(8H0END OF A6) GOTO 1 END * DATA J.DOE 4 2. 4. 1. 2. 4. 3. 0. 5.67 -11.83 536.28 -275.61 2.11
sim> do do_ibsys.txt quad.job out
date.txt
quad.job
eof.dat
ibsys.ctl
1 個のファイルをコピーしました。
CDR: unit is read only
CDP: creating new file
LPT: creating new file
MTA: creating new file
MTA: creating new file
MTA: creating new file
MTA: creating new file
MTA: creating new file
MTA: creating new file
MTA: creating new file
HALT instruction, PC: 07465 (SXA 7510,4)
sim>
出力（核心部分）
入力の J.DOE (John Doe) は英語版「名無しの権兵衛」「山田太郎」式の名前です。Organick の入力麗そのままです。結果は Organick のものを再現しています。
ROOTS OF QUADRATIC EQUATIONS FROM J.DOE
SET NO. 1
A = 2.00 B = 4.00 C = 1.00
REAL X1 = -0.293 X2 = -1.707
SET NO. 2
A = 2.00 B = 4.00 C = 3.00
COMPLEX R(X1)= -1.000 I(X1)= 0.707
R(X2)= -1.000 I(X2)= -0.707
SET NO. 3
A = 0. B = 5.67 C = -11.83
LINEAR X = 2.086
SET NO. 4
A = 536.28 B = -275.61 C = 2.11
REAL X1 = 0.506 X2 = 0.008
END OF J.DOE
全出力
$LIST
$DATE 051819
$JOB QUADRATIC EQUATION
$EXECUTE FORTRAN
* ID QUAD
* XEQ
SOLUTION OF QUADRATIC EQUATION 5/18/19 PAGE 1
C (P. 122 OF A FORTRAN PRIMER BY E. ORGANICK)
1 READ INPUT TAPE 5, 51, ANAME, N
51 FORMAT(A6,I2)
WRITE OUTPUT TAPE 6, 52, ANAME
52 FORMAT(1H1,33HROOTS OF QUADRATIC EQUATIONS FROM A6)
DO 21 I = 1, N
READ INPUT TAPE 5, 53, A, B, C
53 FORMAT(3F10.2)
WRITE OUTPUT TAPE 6, 54, I, A, B, C
54 FORMAT(1H0,8HSET NO. I2/5H A = F8.2,12X,4HB = F8.2,12X,4HC = F8.2)
IF (A) 10, 7, 10
7 RLIN = -C/B
WRITE OUTPUT TAPE 6, 55, RLIN
55 FORMAT(7H LINEAR,25X,4HX = F10.3)
GO TO 21
10 D = B**2 - 4.*A*C
IF (D) 12, 17, 17
12 COMPR = -B/(2.*A)
COMP1 = SQRTF(-D)/(2.*A)
COMP2 = -COMP1
WRITE OUTPUT TAPE 6, 56, COMPR, COMP1, COMPR, COMP2
56 FORMAT(8H COMPLEX,21X,7HR(X1)= F10.3,11X,7HI(X1)= F10.3,/1H ,28X,
17HR(X2)= F10.3,11X,7HI(X2)= F10.3)
16 GO TO 21
17 REAL1 = (-B + SQRTF(D))/(2.*A)
REAL2 = (-B - SQRTF(D))/(2.*A)
20 WRITE OUTPUT TAPE 6, 57, REAL1, REAL2
57 FORMAT(6H REAL 25X,5HX1 = F10.3,13X,5HX2 = F10.3)
21 CONTINUE
WRITE OUTPUT TAPE 6, 58, ANAME
58 FORMAT(8H0END OF A6)
GOTO 1
END(1,0,0,0,0,0,1,0,0,1,0,0,0,0,0)
SOLUTION OF QUADRATIC EQUATION 5/18/19 PAGE 2
STORAGE NOT USED BY PROGRAM
DEC OCT DEC OCT
228 00344 32561 77461
STORAGE LOCATIONS FOR VARIABLES NOT APPEARING IN COMMON, DIMENSION, OR EQUIVALENCE STATEMENT
DEC OCT DEC OCT DEC OCT DEC OCT DEC OCT
ANAME 227 00343 A 226 00342 B 225 00341 COMP1 224 00340 COMP2 223 00337
COMPR 222 00336 C 221 00335 D 220 00334 I 219 00333 N 218 00332
REAL1 217 00331 REAL2 216 00330 RLIN 215 00327
SYMBOLS AND LOCATIONS FOR SOURCE PROGRAM FORMAT STATEMENTS
EFN LOC EFN LOC EFN LOC EFN LOC EFN LOC
8)1J 51 00323 8)1K 52 00321 8)1L 53 00311 8)1M 54 00307 8)1N 55 00275
8)1O 56 00270 8)1P 57 00250 8)1Q 58 00240
LOCATIONS FOR OTHER SYMBOLS NOT APPEARING IN SOURCE PROGRAM
DEC OCT DEC OCT DEC OCT DEC OCT DEC OCT
1) 212 00324 2) 146 00222 3) 150 00226 4) 32767 77777 6) 152 00230
C)200 214 00326 E)5 80 00120
LOCATIONS OF NAMES IN TRANSFER VECTOR
DEC OCT DEC OCT DEC OCT DEC OCT DEC OCT
SQRT 5 00005 (FIL) 4 00004 (FPT) 0 00000 (RTN) 2 00002 (STH) 3 00003
(TSH) 1 00001
ENTRY POINTS TO SUBROUTINES NOT OUTPUT FROM LIBRARY
SQRT (FIL) (FPT) (RTN) (STH) (TSH)
EXTERNAL FORMULA NUMBERS WITH CORRESPONDING INTERNAL FORMULA NUMBERS AND OCTAL LOCATIONS
EFN IFN LOC EFN IFN LOC EFN IFN LOC EFN IFN LOC EFN IFN LOC
1 10 00013 7 20 00070 10 24 00104 12 26 00121 16 31 00156
17 32 00157 20 34 00200 21 36 00210
LIBRARY ENTRY POINTS,
(FPT) (TSHM) (RTN) (STHM) (FIL) SQRT
LOGICAL MACHINE TOTAL TOTAL NOISE RECORDS TOTAL REDUNDANCIES POSITIONING
TAPE TAPE WRITES READS WRITING READING WRITING READING ERRORS
1 A1 0 31 0 0 0 0 0
2 A6 69 66 0 0 0 0 0
3 A9 15 15 0 0 0 0 0
4 A5 45 46 0 0 0 0 0
5 A3 0 39 0 0 0 0 0
6 A4 56 1 0 0 0 0 0
7 A8 16 13 0 0 0 0 0
EXECUTION
ROOTS OF QUADRATIC EQUATIONS FROM J.DOE
SET NO. 1
A = 2.00 B = 4.00 C = 1.00
REAL X1 = -0.293 X2 = -1.707
SET NO. 2
A = 2.00 B = 4.00 C = 3.00
COMPLEX R(X1)= -1.000 I(X1)= 0.707
R(X2)= -1.000 I(X2)= -0.707
SET NO. 3
A = 0. B = 5.67 C = -11.83
LINEAR X = 2.086
SET NO. 4
A = 536.28 B = -275.61 C = 2.11
REAL X1 = 0.506 X2 = 0.008
END OF J.DOE
93 LINES OUTPUT THIS JOB.
FORTRAN MONITOR RETURNING TO IBSYS
$STOP
PERIPHERAL UNIT POSITIONS AT END OF JOBS
SYSPP1 IS A8 REC. 00000, FILE 00002
SYSOU1 IS A4 REC. 00083, FILE 00000
SYSIN1 IS A3 REC. 00002, FILE 00001
END OF JOBS
EOF END OF OUTPUT
FORTRAN IV
こちらはジョブカードの最後に EOF をつけなければならないのですが、勘違いで苦労しました。エミュレータ付属のファイル中に、eof.dat というファイルがあるので、これからコピペすればおｋです。
入力
ここでは EOF は見えません。メモ帳ではスペードマークに見えてます。
$JOB QUADRATIC EQUATION $EXECUTE IBJOB $IBJOB GO $IBFTC QUADRA C SOLUTION OF QUADRATIC EQUATION C (BASED ON CODE IN FORTRAN II) COMPLEX COMP(2) 1 READ(5, 51) ANAME, N 51 FORMAT(A6, I2) WRITE(6, 52) ANAME 52 FORMAT(1H1,33HROOTS OF QUADRATIC EQUATIONS FROM A6) DO 21 I = 1, N READ(5, 53) A, B, C 53 FORMAT(3F10.2) WRITE(6, 54) I, A, B, C 54 FORMAT(1H0,8HSET NO. I2/5H A = F8.2,12X,4HB = F8.2,12X,4HC = + F8.2) IF (A.NE.0.) GO TO 10 IF (B.NE.0.) GO TO 7 WRITE(6, 59) 59 FORMAT(9H NO ROOTS) GO TO 21 7 RLIN = -C/B WRITE(6, 55) RLIN 55 FORMAT(7H LINEAR,25X,4HX = F10.3) GO TO 21 10 D = B**2 - 4.*A*C IF (D.GE.0.) GO TO 17 COMP(1) = CMPLX(-B/(2.*A), SQRT(-D)/(2.*A)) COMP(2) = CONJG(COMP(1)) WRITE(6, 56) COMP 56 FORMAT(8H COMPLEX,21X,7HR(X1)= F10.3,11X,7HI(X1)= F10.3,/1H , + 28X,7HR(X2)= F10.3,11X,7HI(X2)= F10.3) GO TO 21 17 SQRTD = SQRT(D) REAL1 = (-B + SQRTD)/(2.*A) REAL2 = (-B - SQRTD)/(2.*A) WRITE(6, 57) REAL1, REAL2 57 FORMAT(6H REAL 25X,5HX1 = F10.3,13X,5HX2 = F10.3) 21 CONTINUE WRITE(6, 58) ANAME 58 FORMAT(8H0END OF A6) GO TO 1 END $DATA J.DOE 4 2. 4. 1. 2. 4. 3. 0. 5.67 -11.83 536.28 -275.61 2.11
出力（核心部分）
ROOTS OF QUADRATIC EQUATIONS FROMJ.DOE
SET NO. 1
A = 2.00 B = 4.00 C = 1.00
REAL X1 = -0.293 X2 = -1.707
SET NO. 2
A = 2.00 B = 4.00 C = 3.00
COMPLEX R(X1)= -1.000 I(X1)= 0.707
R(X2)= -1.000 I(X2)= -0.707
SET NO. 3
A = 0. B = 5.67 C = -11.83
LINEAR X = 2.086
SET NO. 4
A = 536.28 B = -275.61 C = 2.11
REAL X1 = 0.506 X2 = 0.008
END OF J.DOE
全出力
$LIST
$DATE 051819
$JOB QUADRATIC EQUATION
$EXECUTE IBJOB
IBJOB VERSION 5 HAS CONTROL.
$IBJOB GO
$IBFTC QUADRA
05/18/19 PAGE 1
QUADRA - EFN SOURCE STATEMENT - IFN(S) -
C SOLUTION OF QUADRATIC EQUATION
C (BASED ON CODE IN FORTRAN II)
COMPLEX COMP(2)
1 READ(5, 51) ANAME, N 1
51 FORMAT(A6, I2)
WRITE(6, 52) ANAME 3
52 FORMAT(1H1,33HROOTS OF QUADRATIC EQUATIONS FROM A6)
DO 21 I = 1, N
READ(5, 53) A, B, C 6
53 FORMAT(3F10.2)
WRITE(6, 54) I, A, B, C 7
54 FORMAT(1H0,8HSET NO. I2/5H A = F8.2,12X,4HB = F8.2,12X,4HC =
+ F8.2)
IF (A.NE.0.) GO TO 10
IF (B.NE.0.) GO TO 7
WRITE(6, 59) 13
59 FORMAT(9H NO ROOTS)
GO TO 21
7 RLIN = -C/B
WRITE(6, 55) RLIN 16
55 FORMAT(7H LINEAR,25X,4HX = F10.3)
GO TO 21
10 D = B**2 - 4.*A*C
IF (D.GE.0.) GO TO 17
COMP(1) = CMPLX(-B/(2.*A), SQRT(-D)/(2.*A)) 22
COMP(2) = CONJG(COMP(1))
WRITE(6, 56) COMP 23
56 FORMAT(8H COMPLEX,21X,7HR(X1)= F10.3,11X,7HI(X1)= F10.3,/1H ,
+ 28X,7HR(X2)= F10.3,11X,7HI(X2)= F10.3)
GO TO 21
17 SQRTD = SQRT(D) 27
REAL1 = (-B + SQRTD)/(2.*A)
REAL2 = (-B - SQRTD)/(2.*A)
WRITE(6, 57) REAL1, REAL2 28
57 FORMAT(6H REAL 25X,5HX1 = F10.3,13X,5HX2 = F10.3)
21 CONTINUE
WRITE(6, 58) ANAME 31
58 FORMAT(8H0END OF A6)
GO TO 1
END
05/18/19 PAGE 2
QUADRA STORAGE MAP
MAIN PROGRAM
DIMENSIONED PROGRAM VARIABLES
SYMBOL LOCATION TYPE SYMBOL LOCATION TYPE SYMBOL LOCATION TYPE
COMP 00001 C
UNDIMENSIONED PROGRAM VARIABLES
SYMBOL LOCATION TYPE SYMBOL LOCATION TYPE SYMBOL LOCATION TYPE
ANAME 00005 R N 00006 I I 00007 I
A 00010 R B 00011 R C 00012 R
RLIN 00013 R D 00014 R SQRTD 00015 R
REAL1 00016 R REAL2 00017 R
ENTRY POINTS
...... SECTION 2
SUBROUTINES CALLED
.FRDD. SECTION 3 .FWRD. SECTION 4 SQRT SECTION 5
.FSLO. SECTION 6 .UN05. SECTION 7 .FRTN. SECTION 8
.FCNV. SECTION 9 .UN06. SECTION 10 .FFIL. SECTION 11
E.1 SECTION 12 E.2 SECTION 13 E.3 SECTION 14
E.4 SECTION 15 SYSLOC SECTION 16
EFN IFN CORRESPONDENCE
EFN IFN LOCATION EFN IFN LOCATION EFN IFN LOCATION
1 1A 00130 51 FORMAT 00035 52 FORMAT 00037
21 29A 00376 53 FORMAT 00047 54 FORMAT 00051
10 18A 00251 7 15A 00233 59 FORMAT 00064
55 FORMAT 00067 17 26A 00335 56 FORMAT 00074
57 FORMAT 00115 58 FORMAT 00125
THE FIRST LOCATION NOT USED BY THIS PROGRAM IS 00427.
05/18/19 PAGE 3
$DATA
IBLDR 05/18/19 PAGE 4
* MEMORY MAP *
SYSTEM 00000 THRU 02717
FILE BLOCK ORIGIN 02720
FILES 1. UNIT05
2. UNIT06
FILE LIST ORIGIN 02750
PRE-EXECUTION INITIALIZATION 02754
CALL ON OBJECT PROGRAM 02777
OBJECT PROGRAM 03004 THRU 16374
DECK ORIGIN CONTROL SECTIONS (/NAME/=NON 0 LENGTH, (LOC)=DELETED, 'LOC'=MOVED, *=NOT REFERENCED)
1. QUADRA 03004 ...... 03417 *
2. .LXCON 03433 .LXSTR 03433 * .LXSTP 03436 .LXOUT 03504 * .LXERR 03513 .LXCAL 03516 *
.LXRTN 03516 IBEXIT 03516 * .DBCLS 03700 * .LXARG 04047 * .L0 04072 *
.CLSE 04100 .LFBL 04101 * .LUNB 04102 .DFOUT 04103
3. .IODEF 04107 .DEFIN 04107 .ATTAC 04113 * .CLOSE 04115 .OPEN 04117 .READ 04121
.WRITE 04123 .BSR 04133 * .READR 04143 .RELES 04145 * .LAREA 04156
.LFBLK 04174 .LTSX 04177 * .RLHLD 04207 * .AREA1 04212 .LUNBL 04220
.ENTRY 04224 .GOA 04261 .GO 04265 .DERR 04301 .NOPXI 04302
.COMXI 04304 .EX34 04326
4. .LXSL 04333 .LXSLB 04333 * .LXSEL 04334 .LXSL1 04335 .LXTST 04340 * .LXOVL 04403 *
.LXMOD 04445 * .LXIND 04471 * .LXDIS 04474 * .LXFLG 04475 * .LTCH 04476
5. .FPTRP 04505 .FFPT. 04505 * .FPOUT 04634 * .FPARG 04642 * /.COUNT/ 04644 * OVFLOW 04710 *
6. .ERAS. 04715 E.1 04715 E.2 04716 E.3 04717 E.4 04720
7. FXEM 04721 .FXEM. 04721 TRACE 04727 * /.OPTW./ 05264 *
8. FCOM 05300 .FCOM. 05300 /FORCOM/ 05403 *
9. FRDD 05415 .FRDD. 05415 .FWRD. 05420
10. FIOS 05532 .FIOS. 05532 .FSEL. 05721 .FRTB. 05736 .FRTD. 05753 /.FBF1./ 06205 *
11. FIOH 06211 .FIOH. 06211 .FCNV. 06770 .FFIL. 07065 .FRTN. 07065
12. FCNV 07204 .FCON. 07204
13. FIOT 12272 .FIOT. 12272 .FIOE. 12363
14. UN05 12411 .UN05. 12411
15. UN06 12412 .UN06. 12412 ..UN06 12412 *
16. FSQR 12413 SQRT 12413
17. FSLDO 12466 .FSLO. 12504 .FSDO. 12512 *
18. FSLO 12523 .SLO. 12523 .SLO2. 12531 .SDO. 12536 .SDO2. 12550
19. .IOCS 12562 .L(0) 12562 .MONSW 12602 .TEOR 12651 .DEFI. 12731 .JOINX 12775 *
.CLOS. 13014 .ATTC. 13027 .SH1 13241 * .SH9 13303 * .OPEN. 13324
.OP4 13352 * .OP7 13403 * .OP9.2 13417 * .RLSE. 13471 .RER2. 13471
.READ. 13472 .RER1. 13515 .WRIT. 13517 .MNT1A 13707 * .EOFEX 13770 *
.FEEIT 14040 .GTIOX 14061 .RW7 14177 * .RE7 14616 * .ENDTR 15257
.SEL59 15261 * .BSR. 15700 .EOTOF 16025 .ETOF3 16033 * .SWITC 16062
.TCHEX 16367 .BASIO 16372 *
20. .IOCSM 16375
I/O BUFFERS 16375 THRU 77764
UNUSED CORE 77765 THRU 77777
ROOTS OF QUADRATIC EQUATIONS FROMJ.DOE
SET NO. 1
A = 2.00 B = 4.00 C = 1.00
REAL X1 = -0.293 X2 = -1.707
SET NO. 2
A = 2.00 B = 4.00 C = 3.00
COMPLEX R(X1)= -1.000 I(X1)= 0.707
R(X2)= -1.000 I(X2)= -0.707
SET NO. 3
A = 0. B = 5.67 C = -11.83
LINEAR X = 2.086
SET NO. 4
A = 536.28 B = -275.61 C = 2.11
REAL X1 = 0.506 X2 = 0.008
END OF J.DOE
141 LINES OUTPUT.
$STOP
PERIPHERAL UNIT POSITIONS AT END OF JOBS
SYSPP1 IS A8 REC. 00022, FILE 00000
SYSOU1 IS A4 REC. 00149, FILE 00000
SYSIN1 IS A3 REC. 00005, FILE 00001
END OF JOBS
EOF END OF OUTPUT
