C*********************************************************************** C***** FORTRAN 77 C***** FM912 C***** DIRAF3 - (412) C***** THIS PROGRAM CALLS SUBROUTINE SN913 IN FILE FM913 C*********************************************************************** C***** TESTING OF DIRECT ACCESS FILES ANS REF C***** FORMATTED, WITH BOTH SEQUENTIAL AND DIRECT 12.5 C***** ACCESS TO THE SAME FILE C***** C***** USES SUBROUTINE SN913 FAQ C***** C***** S P E C I F I C A T I O N S SEGMENT 412 C*********************************************************************** DIMENSION F1S(10), G1S(10) CHARACTER*20 A20VK, B20VK, C20VK, A201K(10), B201K(10) CHARACTER*47 A47VK, B47VK, C47VK CHARACTER*51 A51VK CHARACTER*12 A12VK CHARACTER A120VK*120, B120VK*120, A1VK*1, A4VK*4 CHARACTER*31 REMK,REMK1,REMK2,REMK3,REMK4,REMK5,REMK45 LOGICAL AVB, BVB, CVB, C1B(10), D1B(10) DOUBLE PRECISION AVD, BVD, CVD, DVD, D1D(10), B1D(15) C***** C***** BELOW CHARACTER STATEMENT ESTABLISHES THE FILE NAME VARIABLES. CX20 REPLACED BY FEXEC X-20 CONTROL CARD. X-20 IS FOR REPLACING CHARACTER*15 CDIR C THE CHARACTER STATEMENT FOR FILE NAMES ASSOCIATED WITH X-130 C (PROGRAM VARIABLE CDIR) IF NOT VALID FOR THE PROCESSOR. CBB** ********************** BBCINITA ********************************** C**** SPECIFICATION STATEMENTS C**** CHARACTER ZVERS*13, ZVERSD*17, ZDATE*17, ZPROG*5, ZCOMPL*20, 1 ZNAME*20, ZTAPE*10, ZPROJ*13, REMRKS*31, ZTAPED*13 CBE** ********************** BBCINITA ********************************** CBB** ********************** BBCINITB ********************************** C**** INITIALIZE SECTION DATA ZVERS, ZVERSD, ZDATE 1 /'VERSION 2.0 ', '82/08/02*18.33.46', '*NO DATE*TIME'/ DATA ZCOMPL, ZNAME, ZTAPE 1 /'*NONE SPECIFIED*', '*NO COMPANY NAME*', '*NO TAPE*'/ DATA ZPROJ, ZTAPED, ZPROG 1 /'*NO PROJECT*', '*NO TAPE DATE', 'XXXXX'/ DATA REMRKS /' '/ C**** THE FOLLOWING 9 COMMENT LINES (CZ01, CZ02, ...) CAN BE REPLACED C**** FOR IDENTIFYING THE TEST ENVIRONMENT C**** CZ01 ZVERS = 'VERSION OF THE COMPILER VALIDATION SYSTEM' CZ02 ZVERSD = 'CREATION DATE/TIME OF THE COMPILER VALIDATION SYSTEM' CZ03 ZPROG = 'PROGRAM NAME' ZDATE = ' DEC. 1983 ' ZCOMPL = ' ICL VME FORTRAN77 ' ZPROJ = ' LANG. CENTRE' ZNAME = 'ICL ' ZTAPE = 'M999 ' ZTAPED = '831005 ' C IVPASS = 0 IVFAIL = 0 IVDELE = 0 IVINSP = 0 IVTOTL = 0 IVTOTN = 0 ICZERO = 0 C C I01 CONTAINS THE LOGICAL UNIT NUMBER FOR THE CARD READER. I01 = 05 C I02 CONTAINS THE LOGICAL UNIT NUMBER FOR THE PRINTER. I02 = 06 C CX010 REPLACED BY FEXEC X-010 CONTROL CARD (CARD-READER UNIT NUMBER). C THE CX010 CARD IS FOR OVERRIDING THE PROGRAM DEFAULT I01 = 5 CX011 REPLACED BY FEXEC X-011 CONTROL CARD. CX011 IS FOR SYSTEMS C REQUIRING ADDITIONAL STATEMENTS FOR FILES ASSOCIATED WITH CX010. C CX020 REPLACED BY FEXEC X-020 CONTROL CARD (PRINTER UNIT NUMBER). C THE CX020 CARD IS FOR OVERRIDING THE PROGRAM DEFAULT I02= 6 CX021 REPLACED BY FEXEC X-021 CONTROL CARD. CX021 IS FOR SYSTEMS C REQUIRING ADDITIONAL STATEMENTS FOR FILES ASSOCIATED WITH CX020. C CBE** ********************** BBCINITB ********************************** C***** C***** THE FOLLOWING STATEMENT MUST BE CHANGED IF THE C***** UNITS GIVEN ARE NOT CAPABLE OF BEING OPENED AS SPECIFIED. C***** C I13 CONTAINS THE UNIT NUMBER FOR A NAMED DIRECT ACCESS FILE. I13 = 24 CX130 REPLACED BY FEXEC X-130 CONTROL CARD (DIR. FILE UNIT NUMBER). C SPECIFYING I13 = NN OVERRIDES THE DEFAULT I13 = 24. C C***** THE FOLLOWING STATEMENT MUST BE CHANGED IF THE NAME C***** GIVEN IS NOT A VALID FILE SPECIFIER FOR A DIRECT, C***** FORMATTED FILE. C***** C CDIR CONTAINS THE FILE NAME FOR UNIT I13. CDIR = 'DIRFILE' C CX201 REPLACED BY FEXEC X-201 CONTROL CARD. CX201 IS FOR SYSTEMS C REQUIRING A DIFFERENT FILE SPECIFIER FOR FILES ASSOCIATED WITH C X-130 THAN THE DEFAULT CDIR = ' DIRFILE'. C C***** FILE NUMBER AND NAME ASSIGNMENT NUVI = I02 KUVI = I13 IVTOTL = 26 ZPROG = 'FM912' C***** C***** FILE NUMBER AND NAME ASSIGNMENT C***** REMK1='RECORD 1 - ERR PATH TAKEN' REMK2='RECORD 2 - ERR PATH TAKEN' REMK3='RECORD 3 - ERR PATH TAKEN' REMK4='RECORD 4 - ERR PATH TAKEN' REMK5='RECORD 5 - ERR PATH TAKEN' REMK45='RECORD 4 + 5 - ERR PATH TAKEN' CBB** ********************** BBCHED0A ********************************** C**** C**** WRITE REPORT TITLE C**** WRITE (I02, 90002) WRITE (I02, 90006) WRITE (I02, 90007) WRITE (I02, 90008) ZVERS, ZVERSD WRITE (I02, 90009) ZPROG, ZPROG WRITE (I02, 90010) ZDATE, ZCOMPL CBE** ********************** BBCHED0A ********************************** WRITE(NUVI,41200) 41200 FORMAT( 1H ,/45H DIRAF3 - (412) DIRECT ACCESS FORMATTED FILE/ 1 42H WITH OPTION TO OPEN AS A SEQUENTIAL FILE/ 2 17H ANS REF. - 12.5) CBB** ********************** BBCHED0B ********************************** C**** WRITE DETAIL REPORT HEADERS C**** WRITE (I02,90004) WRITE (I02,90004) WRITE (I02,90013) WRITE (I02,90014) WRITE (I02,90015) IVTOTL CBE** ********************** BBCHED0B ********************************** C***** C***** PLUS OR MINUS VALUES C***** CVS = 0.0001 CVD = 0.0001D0 C***** C***** INITIALIZE DATA ARRAYS C***** CALL SN913(F1S,G1S,C1B,D1B,D1D,B1D,A201K,B201K) C***** C***** OPEN DIRECT ACCESS FILE - STATUS=NEW C***** OPEN(FILE=CDIR, UNIT=KUVI, ACCESS='DIRECT',RECL=120, 1 FORM='FORMATTED',STATUS='NEW',nrec=500) C***** CT001* TEST 1 - CHECKS RECL AND NEXTREC C***** FOR JUST OPENED DIRECT ACCESS FILE C***** IVTNUM=1 INQUIRE(UNIT=KUVI, RECL=IVI, NEXTREC=KVI) IF (IVI .NE. 120) GO TO 33020 IF (KVI .NE. 1) GO TO 33020 WRITE(NUVI,80002)IVTNUM IVPASS=IVPASS+1 GO TO 33030 33020 REMK='ERROR IN INQUIRE' WRITE(NUVI,55010)IVTNUM,REMK 55010 FORMAT(1H ,5HTEST ,I3,1X,5H FAIL,34X,A31) IVFAIL=IVFAIL+1 WRITE(NUVI,55020)IVI,KVI 55020 FORMAT(1H ,/,11X,16HCOMPUTED: RECL=,I6,5X,8HNEXTREC=,I6) WRITE(NUVI,55030) 55030 FORMAT(1H ,10X,22HCORRECT: RECL= 120,5X,14HNEXTREC= 1/) C***** CT002* TEST 2 - WRITES RECORD 1 C***** 33030 IVTNUM=2 IVI = 1 AVS = F1S (IVI) BVS = F1S(IVI + 1) A20VK = A201K (IVI) AVB = C1B (IVI) AVD = D1D (IVI) WRITE(UNIT=KUVI,REC=1,FMT=41204,ERR=33040) IVI, AVS, BVS, AVD, 1 AVB, A20VK 41204 FORMAT(I5, F10.5, E14.6, D14.8, L10, A20, 35X, ' LAST RECORD') WRITE(NUVI,80002)IVTNUM IVPASS=IVPASS+1 GO TO 33050 33040 WRITE(NUVI,55010)IVTNUM,REMK1 IVFAIL=IVFAIL+1 C***** CT003* TEST 3 - WRITES RECORD 2 C***** 33050 IVTNUM=3 IVI = IVI + 1 AVS = F1S (IVI) BVS = F1S(IVI + 1) A20VK = A201K (IVI) AVB = C1B (IVI) AVD = D1D (IVI) WRITE(UNIT=KUVI,REC=2,FMT=41205,ERR=33060) BVS, AVD, IVI, AVS, 1 AVB, A20VK 41205 FORMAT(E12.6, D15.7, I4, F11.5, L2, A25, 30X, ' LASTS RECORD') WRITE(NUVI,80002)IVTNUM IVPASS=IVPASS+1 GO TO 33070 33060 WRITE(NUVI,55010)IVTNUM,REMK2 IVFAIL=IVFAIL+1 C***** CT004* TEST 4 - WRITES RECORD 3 C***** 33070 IVTNUM=4 IVI = IVI + 1 AVS = F1S (IVI) BVS = F1S(IVI + 1) A20VK = A201K (IVI) AVB = C1B (IVI) AVD = D1D (IVI) WRITE(UNIT=KUVI,REC=3,FMT=41206,ERR=33080) IVI, BVS, AVS, AVD, 1 AVB, A20VK 41206 FORMAT(I5, F10.5, E14.6, D14.8, L10, A20, 30X, 'THE LAST REC') WRITE(NUVI,80002)IVTNUM IVPASS=IVPASS+1 GO TO 33090 33080 WRITE(NUVI,55010)IVTNUM,REMK3 IVFAIL=IVFAIL+1 C***** CT005* TEST 5 - WRITES RECORDS 4 AND 5 WITH ONE WRITE C***** 33090 IVTNUM=5 IVI = IVI + 1 AVS = F1S (IVI) BVS = F1S(IVI + 1) A20VK = A201K (IVI) AVB = C1B (IVI) AVD = D1D (IVI) WRITE(UNIT=KUVI,REC=4,FMT=41207,ERR=33100) IVI, AVS, AVD, AVB, 1 A20VK, BVS, BVS, AVD, AVB, IVI, AVS, A20VK 41207 FORMAT(I5, F10.5, D14.8, L10, A20, E14.6, 35X, 'NEXT TO LAST',/ 1 E12.6, D15.7, L2, I4, F11.5, A25, 30X, 'THE END') WRITE(NUVI,80002)IVTNUM IVPASS=IVPASS+1 GO TO 33290 33100 WRITE(NUVI,55010)IVTNUM,REMK45 IVFAIL=IVFAIL+1 C***** CT006* TEST 6 - CHECK RECL AND NEXTREC ON OPENED FILE C***** 33290 IVTNUM=6 INQUIRE(UNIT=KUVI, RECL=IVI, NEXTREC=KVI) IF (IVI .NE. 120)GO TO 33300 IF(KVI .NE. 6)GO TO 33300 WRITE(NUVI,80002)IVTNUM IVPASS=IVPASS+1 GO TO 33110 33300 REMK='ERROR IN INQUIRE' WRITE(NUVI,55010)IVTNUM,REMK IVFAIL=IVFAIL+1 WRITE(NUVI,55020)IVI,KVI WRITE(NUVI,55040) 55040 FORMAT(1H ,10X,22HCORRECT: RECL= 120,5X,14HNEXTREC= 6/) C***** CT007* TEST 7 - READS RECORD 1 C***** 33110 IVTNUM=7 IVI = 1 READ(UNIT=KUVI,REC=IVI,FMT=41210,ERR=33120) KVI, AVS, BVS, AVD, 1 AVB, A20VK, A47VK 41210 FORMAT(I5, F10.5, E14.6, D14.8, L10, A20, A47) ISWT=1 GO TO 33220 33120 WRITE(NUVI,55010)IVTNUM,REMK1 IVFAIL=IVFAIL+1 C***** CT008* TEST 8 - READS RECORD 2 C***** 33130 IVTNUM=8 IVI = 2 READ(UNIT=KUVI,REC=IVI,FMT=41238,ERR=33140) BVS, AVD, KVI, AVS, 1 AVB, A20VK, A51VK 41238 FORMAT(E12.6, D15.7, I4, F11.5, L2, A25, A51) ISWT=2 GO TO 33230 33140 WRITE(NUVI,55010)IVTNUM,REMK2 IVFAIL=IVFAIL+1 C***** CT009* TEST 9 - READS RECORD 3 C***** 33150 IVTNUM=9 IVI = 3 READ(UNIT=KUVI,REC=IVI,FMT=41210,ERR=33160) LVI, DVS, GVS, BVD, 1 BVB, B20VK, B47VK ISWT=3 GO TO 33240 33160 WRITE(NUVI,55010)IVTNUM,REMK3 IVFAIL=IVFAIL+1 C***** CT010* TEST 10 - READS RECORD 4 C***** 33170 IVTNUM=10 IVI = 4 READ(UNIT=KUVI,REC=IVI,FMT=41241,ERR=33180) NVI, EVS, DVD, CVB, 1 C20VK, FVS, C47VK 41241 FORMAT(I5, F10.5, D14.8, L10, A20, E14.6, A47) ISWT=4 GO TO 33250 33180 WRITE(NUVI,55010)IVTNUM,REMK4 IVFAIL=IVFAIL+1 C***** CT011* TEST 11 - READS RECORD 5 C***** 33190 IVTNUM=11 IVI = 5 JVI = 4 READ(UNIT=KUVI,REC=IVI,FMT=41218,ERR=33200) BVS, AVD, AVB, KVI, 1 AVS, A20VK, A51VK 41218 FORMAT(E12.6, D15.7, L2, I4, F11.5, A25, A51) ISWT=5 GO TO 33260 33200 WRITE(NUVI,55010)IVTNUM,REMK5 IVFAIL=IVFAIL+1 C***** CT012* TEST 12 - OVERWRITES RECORD 3 C***** 33210 IVTNUM=12 IVI = 3 AVS = G1S (IVI) BVS = G1S(IVI + 1) A20VK = B201K (IVI) AVB = D1B (IVI) AVD = B1D (IVI) WRITE(UNIT=KUVI,REC=3,FMT=41251,ERR=33310) IVI, AVS, BVS, AVD, 1 A20VK, AVB 41251 FORMAT(I5, F11.5, E13.6, D14.8, A20, L10, 35X, 'NEW RECORD ') WRITE(NUVI,80002)IVTNUM IVPASS=IVPASS+1 GO TO 33320 33310 WRITE(NUVI,55010)IVTNUM,REMK3 IVFAIL=IVFAIL+1 C***** CT013* TEST 13 - OVERWRITES RECORD 5 C***** 33320 IVTNUM=13 IVI = 5 AVS = G1S (IVI) BVS = G1S(IVI - 1) A20VK = B201K (IVI) AVB = D1B (IVI) AVD = B1D (IVI) WRITE(UNIT=KUVI,REC=5,FMT=41252,ERR=33330) AVS, IVI, A20VK, AVD, 1 BVS, AVB 41252 FORMAT(F10.5, I5, A20, D14.8, E14.6, L10, 35X, 'STOP RECORD') WRITE(NUVI,80002)IVTNUM IVPASS=IVPASS+1 GO TO 33340 33330 WRITE(NUVI,55010)IVTNUM,REMK5 IVFAIL=IVFAIL+1 C***** C***** CLOSE AND REOPEN DIRECT ACCESS FILE C***** 33340 CLOSE(UNIT=KUVI) OPEN(FILE=CDIR, UNIT=KUVI, ACCESS='DIRECT',STATUS='OLD', 1 FORM='FORMATTED',RECL=120) C***** CT014* TEST 14 - READS RECORD 4 C***** IVTNUM=14 IVI = 4 READ(UNIT=KUVI,REC=IVI,FMT=41241,ERR=33350) NVI, EVS, DVD, CVB, 1 C20VK, FVS, C47VK ISWT=6 GO TO 33250 33350 WRITE(NUVI,55010)IVTNUM,REMK4 IVFAIL=IVFAIL+1 C***** CT015* TEST 15 - READS THE CHANGED RECORD 5 C***** 33360 IVTNUM=15 IVI = 5 READ(UNIT=KUVI,REC=IVI,FMT=41254,ERR=33370) AVS, KVI, A20VK, 1 AVD, BVS, AVB, A47VK 41254 FORMAT(F10.5, I5, A20, D14.8, E14.6, L10, A47) ISWT=7 IF (KVI .NE. IVI) GOTO 41221 IF (AVS .LT. G1S(IVI)-CVS .OR. AVS .GT. G1S(IVI)+CVS) GOTO 41223 IF (BVS.LT.G1S(IVI-1)-CVS .OR. BVS.GT.G1S(IVI-1)+CVS) GOTO 41225 IF (A20VK .NE. B201K(IVI)) GOTO 41229 IF ((AVB .AND. .NOT. D1B(IVI)) .OR. 1 (.NOT. AVB .AND. D1B(IVI))) GOTO 41233 IF (AVD .LT. B1D(IVI)-CVD .OR. AVD .GT. B1D(IVI)+CVD) GOTO 41227 IF (A47VK .NE. 1 ' STOP RECORD') GOTO 41231 WRITE(NUVI,80002)IVTNUM IVPASS=IVPASS+1 GO TO 33380 33370 WRITE(NUVI,55010)IVTNUM,REMK5 IVFAIL=IVFAIL+1 C***** CT016* TEST 16 - READS RECORD 2 C***** 33380 IVTNUM=16 IVI = 2 READ(UNIT=KUVI,REC=IVI,FMT=41238,ERR=33390) BVS, AVD, KVI, AVS, 1 AVB, A20VK, A51VK ISWT=8 GO TO 33230 33390 WRITE(NUVI,55010)IVTNUM,REMK2 IVFAIL=IVFAIL+1 C***** CT017* TEST 17 - READS THE CHANGED RECORD 3 C***** 33400 IVTNUM=17 IVI = 3 READ(UNIT=KUVI,REC=3,FMT=41256,ERR=33410) KVI, AVS, BVS, AVD, 1 A20VK, AVB, A47VK 41256 FORMAT(I5, F11.5, E13.6, D14.8, A20, L10, A47) ISWT=9 IF (KVI .NE. IVI) GOTO 41221 IF (AVS .LT. G1S(IVI)-CVS .OR. AVS .GT. G1S(IVI)+CVS) GOTO 41223 IF (BVS.LT.G1S(IVI+1)-CVS .OR. BVS.GT.G1S(IVI+1)+CVS) GOTO 41225 IF (A20VK .NE. B201K(IVI)) GOTO 41229 IF ((AVB .AND. .NOT. D1B(IVI)) .OR. 1 (.NOT. AVB .AND. D1B(IVI))) GOTO 41233 IF (AVD .LT. B1D(IVI)-CVD .OR. AVD .GT. B1D(IVI)+CVD) GOTO 41227 IF (A47VK .NE. 1 ' NEW RECORD ') GOTO 41231 WRITE(NUVI,80002)IVTNUM IVPASS=IVPASS+1 GO TO 33420 33410 WRITE(NUVI,55010)IVTNUM,REMK3 IVFAIL=IVFAIL+1 C***** CT018* TEST 18 - READS RECORD 1 C***** 33420 IVTNUM=18 IVI = 1 READ(UNIT=KUVI,REC=IVI,FMT=41210,ERR=33430) KVI, AVS, BVS, AVD, 1 AVB, A20VK, A47VK ISWT=10 GO TO 33220 33430 WRITE(NUVI,55010)IVTNUM,REMK1 IVFAIL=IVFAIL+1 C***** CT019* TEST 19 - OVERWRITES RECORD 4 C***** 33440 IVTNUM=19 41258 IVI = 4 KVI = IVI + 1 AVS = F1S (IVI) BVS = F1S(IVI + 1) EVS = F1S(IVI) + 2.34 AVD = D1D (IVI) WRITE(UNIT=KUVI,REC=4,FMT=41259,ERR=33450) IVI, KVI, AVS, BVS, 1 EVS, AVD 41259 FORMAT(I5, I5.3, F10.5, E14.6, E20.1E4, D14.8) WRITE(NUVI,80002)IVTNUM IVPASS=IVPASS+1 GO TO 33460 33450 WRITE(NUVI,55010)IVTNUM,REMK4 IVFAIL=IVFAIL+1 C***** CT020* TEST 20 - OVERWRITES RECORDS 1, 2, AND 3 C***** 33460 IVTNUM=20 IVI = 1 A1VK = 'A' A4VK = A201K (IVI) (1:4) AVB = C1B (IVI) AVD = D1D (IVI) BVD = D1D (IVI) + 3.234D2 WRITE(UNIT=KUVI,REC=1,FMT=41260,ERR=33470) AVD, BVD, AVB, A1VK, 1 A4VK 41260 FORMAT(G14.8, G20.2E4, L2, A, A4, 'TSAL DROCER',//, 1 10HHOLLERITH , T15, 'ONE', 10X, TL5, 'TWO', TR5, 2 'THREE', :, 'LAST') WRITE(NUVI,80002)IVTNUM IVPASS=IVPASS+1 GO TO 33480 33470 WRITE(NUVI,55010)IVTNUM,REMK1 IVFAIL=IVFAIL+1 C***** CT021* TEST 21 - OVERWRITES RECORD 5 C***** 33480 IVTNUM=21 IVI = 5 BVS = F1S(IVI - 1) AVD = B1D (4) WRITE(UNIT=KUVI,REC=5,FMT=41261,ERR=33490) IVI, BVS, IVI, AVD 41261 FORMAT(SP, I5, S, F10.5, SS, I5, 3PE14.6E2) WRITE(NUVI,80002)IVTNUM IVPASS=IVPASS+1 GO TO 33500 33490 WRITE(NUVI,55010)IVTNUM,REMK5 IVFAIL=IVFAIL+1 C***** C***** CLOSE AND REOPEN DIRECT ACCESS FILE C***** 33500 CLOSE(UNIT=KUVI) OPEN(FILE=CDIR, UNIT=KUVI, ACCESS='DIRECT',STATUS='OLD', 1 FORM='FORMATTED',RECL=120) C***** CT022* TEST 22 - READS RECORD 1 C***** IVTNUM=22 IVI = 1 READ(UNIT=KUVI,REC=IVI,FMT=41262,ERR=33510) AVD, A20VK, AVB, 1 A1VK, A4VK, A12VK 41262 FORMAT(G14.8, A20, L2, A, A4, A12) ISWT=1 IF (AVD .LT. D1D(IVI)-CVD .OR. AVD .GT. D1D(IVI)+CVD) GOTO 41277 IF (A20VK(12:20) .NE. '.34E+0003') GOTO 41279 IF ((A1VK .NE. 'A') .OR. 1 (A4VK .NE. A201K(IVI)(1:4)) .OR. 2 (A12VK .NE. 'TSAL DROCER')) GOTO 41279 WRITE(NUVI,80002)IVTNUM IVPASS=IVPASS+1 GO TO 33520 33510 WRITE(NUVI,55010)IVTNUM,REMK1 IVFAIL=IVFAIL+1 C***** RECORD 4 CT023* TEST 23 - READS RECORD 4 C***** 33520 IVTNUM=23 IVI = 4 READ(UNIT=KUVI,REC=IVI,FMT=41266,ERR=33530) KVI, A20VK, AVS, 1 BVS, B20VK, AVD 41266 FORMAT(I5, A5, F10.5, E14.6, A20, D14.8) ISWT=2 IF (A20VK(3:5) .NE. '005') GOTO 41293 IF ((AVS .LT. F1S(IVI)-CVS .OR. AVS .GT. F1S(IVI)+CVS) .OR. 1 (BVS.LT.F1S(IVI+1)-CVS .OR. BVS.GT.F1S(IVI+1)+CVS) .OR. 2 (B20VK(13:20) .NE. '.6E+0001')) GOTO 41293 WRITE(NUVI,80002)IVTNUM IVPASS=IVPASS+1 GO TO 33540 33530 WRITE(NUVI,55010)IVTNUM,REMK4 IVFAIL=IVFAIL+1 C***** CT024* TEST 24 - READS RECORD 2 TESTS FOR BLANK RECORD C***** 33540 IVTNUM=24 B120VK = ' ' IVI = 2 READ(UNIT=KUVI,REC=IVI,FMT=41269,ERR=33550) A120VK 41269 FORMAT(A120) ISWT=3 IF (A120VK .NE. B120VK) GOTO 41281 WRITE(NUVI,80002)IVTNUM IVPASS=IVPASS+1 GO TO 33560 33550 WRITE(NUVI,55010)IVTNUM,REMK2 IVFAIL=IVFAIL+1 C***** CT025* TEST 25 - READS RECORD 5 C***** 33560 IVTNUM=25 IVI = 5 READ(UNIT=KUVI,REC=IVI,FMT=41271,ERR=33570) A20VK(1:5), AVS, 1 B20VK, C20VK 41271 FORMAT(A5, F10.5, BZ, A5, BN, A20) ISWT=4 IF (A20VK(1:5) .NE. ' +5') GOTO 41283 IF (B20VK(1:5) .NE. ' 5') GOTO 41285 IF (C20VK(1:14) .NE. ' 625.0000E-03') GOTO 41287 WRITE(NUVI,80002)IVTNUM IVPASS=IVPASS+1 GO TO 33580 33570 WRITE(NUVI,55010)IVTNUM,REMK5 IVFAIL=IVFAIL+1 C***** CT026* TEST 26 - READS RECORD 3 C***** 33580 IVTNUM=26 IVI = 3 READ(UNIT=KUVI,REC=IVI,FMT=41275,ERR=33590) A120VK 41275 FORMAT(A120) ISWT=5 IF (A120VK(1:10) .NE. 'HOLLERITH') GOTO 41289 IF (A120VK(11:40) .NE. 1 ' ONE TWO THREE ') GOTO 41291 WRITE(NUVI,80002)IVTNUM IVPASS=IVPASS+1 GO TO 33600 33590 WRITE(NUVI,55010)IVTNUM,REMK3 IVFAIL=IVFAIL+1 C***** C***** CLOSE DIRECT ACCESS FILE C***** 33600 CLOSE(UNIT=KUVI,STATUS='DELETE') GO TO 33610 C***** C***** CHECKING RECORD 1 C***** 33220 IF (KVI .NE. IVI) GOTO 41221 IF (AVS .LT. F1S(IVI)-CVS .OR. AVS .GT. F1S(IVI)+CVS) GOTO 41223 IF (BVS.LT.F1S(IVI+1)-CVS .OR. BVS.GT.F1S(IVI+1)+CVS) GOTO 41225 IF (A20VK .NE. A201K(IVI)) GOTO 41229 IF (A47VK .NE. 1 ' LAST RECORD') GOTO 41231 IF ((AVB .AND. .NOT. C1B(IVI)) .OR. 1 (.NOT. AVB .AND. C1B(IVI))) GOTO 41233 IF (AVD .LT. D1D(IVI)-CVD .OR. AVD .GT. D1D(IVI)+CVD) GOTO 41227 WRITE(NUVI,80002)IVTNUM IVPASS=IVPASS+1 IF (ISWT .EQ. 10)GO TO 33440 GO TO 33130 41221 WRITE(NUVI,41222)IVTNUM,IVI IVFAIL=IVFAIL+1 GO TO (33130,33150,33170,33190,33210,33360,33380,33400, 1 33420,33440)ISWT 41223 WRITE(NUVI,41224)IVTNUM,IVI IVFAIL=IVFAIL+1 GO TO (33130,33150,33170,33190,33210,33360,33380,33400, 1 33420,33440)ISWT 41225 WRITE(NUVI,41226)IVTNUM,IVI IVFAIL=IVFAIL+1 GO TO (33130,33150,33170,33190,33210,33360,33380,33400, 1 33420,33440)ISWT 41227 WRITE(NUVI,41228)IVTNUM,IVI IVFAIL=IVFAIL+1 GO TO (33130,33150,33170,33190,33210,33360,33380,33400, 1 33420,33440)ISWT 41229 WRITE(NUVI,41230)IVTNUM,IVI IVFAIL=IVFAIL+1 GO TO (33130,33150,33170,33190,33210,33360,33380,33400, 1 33420,33440)ISWT 41231 WRITE(NUVI,41232)IVTNUM,IVI IVFAIL=IVFAIL+1 GO TO (33130,33150,33170,33190,33210,33360,33380,33400, 1 33420,33440)ISWT 41233 WRITE(NUVI,41234)IVTNUM,IVI IVFAIL=IVFAIL+1 GO TO (33130,33150,33170,33190,33210,33360,33380,33400, 1 33420,33440)ISWT C***** C***** CHECKING RECORD 2 C***** 33230 IF (KVI .NE. IVI) GOTO 41221 IF (AVS .LT. F1S(IVI)-CVS .OR. AVS .GT. F1S(IVI)+CVS) GOTO 41223 IF (BVS.LT.F1S(IVI+1)-CVS .OR. BVS.GT.F1S(IVI+1)+CVS) GOTO 41225 IF (A20VK .NE. A201K(IVI)) GOTO 41229 IF ((AVB .AND. .NOT. C1B(IVI)) .OR. 1 (.NOT. AVB .AND. C1B(IVI))) GOTO 41233 IF (AVD .LT. D1D(IVI)-CVD .OR. AVD .GT. D1D(IVI)+CVD) GOTO 41227 IF (A51VK .NE. 1 ' LASTS RECORD ')GOTO 41231 WRITE(NUVI,80002)IVTNUM IVPASS=IVPASS+1 IF (ISWT .EQ. 8)GO TO 33400 GO TO 33150 C***** C***** CHECKING RECORD 3 C***** 33240 IF (LVI .NE. IVI) GOTO 41221 IF (GVS .LT. F1S(IVI)-CVS .OR. GVS .GT. F1S(IVI)+CVS) GOTO 41223 IF (DVS.LT.F1S(IVI+1)-CVS .OR. DVS.GT.F1S(IVI+1)+CVS) GOTO 41225 IF (B20VK .NE. A201K(IVI)) GOTO 41229 IF ((BVB .AND. .NOT. C1B(IVI)) .OR. 1 (.NOT. BVB .AND. C1B(IVI))) GOTO 41233 IF (BVD .LT. D1D(IVI)-CVD .OR. BVD .GT. D1D(IVI)+CVD) GOTO 41227 IF (B47VK .NE. 1 ' THE LAST REC ') GOTO 41231 WRITE(NUVI,80002)IVTNUM IVPASS=IVPASS+1 GO TO 33170 C***** C***** CHECKING RECORD 4 C***** 33250 IF (NVI .NE. IVI) GOTO 41221 IF (EVS .LT. F1S(IVI)-CVS .OR. EVS .GT. F1S(IVI)+CVS) GOTO 41223 IF (FVS.LT.F1S(IVI+1)-CVS .OR. FVS.GT.F1S(IVI+1)+CVS) GOTO 41225 IF (C20VK .NE. A201K(IVI)) GOTO 41229 IF ((CVB .AND. .NOT. C1B(IVI)) .OR. 1 (.NOT. CVB .AND. C1B(IVI))) GOTO 41233 IF (DVD .LT. D1D(IVI)-CVD .OR. DVD .GT. D1D(IVI)+CVD) GOTO 41227 IF (C47VK .NE. 1 ' NEXT TO LAST') GOTO 41231 WRITE(NUVI,80002)IVTNUM IVPASS=IVPASS+1 IF (ISWT .EQ. 6)GO TO 33360 GO TO 33190 C***** C***** CHECKING RECORD 5 C***** 33260 IF (KVI .NE. JVI) GOTO 41221 IF (AVS .LT. F1S(JVI)-CVS .OR. AVS .GT. F1S(JVI)+CVS) GOTO 41223 IF (BVS.LT.F1S(JVI+1)-CVS .OR. BVS.GT.F1S(JVI+1)+CVS) GOTO 41225 IF (A20VK .NE. A201K(JVI)) GOTO 41229 IF ((AVB .AND. .NOT. C1B(JVI)) .OR. 1 (.NOT. AVB .AND. C1B(JVI))) GOTO 41233 IF (AVD .LT. D1D(JVI)-CVD .OR. AVD .GT. D1D(JVI)+CVD) GOTO 41227 IF (A51VK .NE. 1 ' THE END ') GOTO 41231 WRITE(NUVI,80002)IVTNUM IVPASS=IVPASS+1 GO TO 33210 C***** C***** C***** 41277 WRITE(NUVI,41278)IVTNUM,IVI IVFAIL=IVFAIL+1 GO TO(33520,33540,33560,33580,33600)ISWT 41279 WRITE(NUVI,41280)IVTNUM,IVI IVFAIL=IVFAIL+1 GO TO(33520,33540,33560,33580,33600)ISWT 41281 WRITE(NUVI,41282)IVTNUM,IVI IVFAIL=IVFAIL+1 GO TO(33520,33540,33560,33580,33600)ISWT 41283 WRITE(NUVI,41284)IVTNUM,IVI IVFAIL=IVFAIL+1 GO TO(33520,33540,33560,33580,33600)ISWT 41285 WRITE(NUVI,41286)IVTNUM,IVI IVFAIL=IVFAIL+1 GO TO(33520,33540,33560,33580,33600)ISWT 41287 WRITE(NUVI,41288)IVTNUM,IVI IVFAIL=IVFAIL+1 GO TO(33520,33540,33560,33580,33600)ISWT 41289 WRITE(NUVI,41290)IVTNUM,IVI IVFAIL=IVFAIL+1 GO TO(33520,33540,33560,33580,33600)ISWT 41291 WRITE(NUVI,41292)IVTNUM,IVI IVFAIL=IVFAIL+1 GO TO(33520,33540,33560,33580,33600)ISWT 41293 WRITE(NUVI,41294)IVTNUM,IVI IVFAIL=IVFAIL+1 GO TO(33520,33540,33560,33580,33600)ISWT C***** C***** C***** 41222 FORMAT(1H ,5HTEST ,I3,6H FAIL,34X,6HRECORD,I2, 1 14H - ON I FORMAT) 41224 FORMAT(1H ,5HTEST ,I3,6H FAIL,34X,6HRECORD,I2, 1 14H - ON F FORMAT) 41226 FORMAT(1H ,5HTEST ,I3,6H FAIL,34X,6HRECORD,I2, 1 14H - ON E FORMAT) 41228 FORMAT(1H ,5HTEST ,I3,6H FAIL,34X,6HRECORD,I2, 1 14H - ON D FORMAT) 41230 FORMAT(1H ,5HTEST ,I3,6H FAIL,34X,6HRECORD,I2, 1 14H - ON A FORMAT) 41232 FORMAT(1H ,5HTEST ,I3,6H FAIL,34X,6HRECORD,I2, 1 20H - ON X AND ' FORMAT) 41234 FORMAT(1H ,5HTEST ,I3,6H FAIL,34X,6HRECORD,I2, 1 14H - ON L FORMAT) 41278 FORMAT(1H ,5HTEST ,I3,6H FAIL,34X,6HRECORD,I2, 1 17H - ON GW.D FORMAT) 41280 FORMAT(1H ,5HTEST ,I3,6H FAIL,34X,6HRECORD,I2, 1 19H - ON GW.DEN FORMAT) 41282 FORMAT(1H ,5HTEST ,I3,6H FAIL,34X,6HRECORD,I2, 1 19H - ON BLANK RECORD ) 41284 FORMAT(1H ,5HTEST ,I3,6H FAIL,34X,6HRECORD,I2, 1 19H - ON SP FORMAT ) 41286 FORMAT(1H ,5HTEST ,I3,6H FAIL,34X,6HRECORD,I2, 1 21H - ON BZ OR SS FORMAT) 41288 FORMAT(1H ,5HTEST ,I3,6H FAIL,34X,6HRECORD,I2, 1 19H - ON NP FORMAT ) 41290 FORMAT(1H ,5HTEST ,I3,6H FAIL,34X,6HRECORD,I2, 1 19H - ON H FORMAT ) 41292 FORMAT(1H ,5HTEST ,I3,6H FAIL,34X,6HRECORD,I2, 1 23H - ON TR, TLC, T FORMAT) 41294 FORMAT(1H ,5HTEST ,I3,6H FAIL,34X,6HRECORD,I2, 1 19H - ON IN.N FORMAT ) C***** C***** END OF TEST SEGMENT 412 C***** 33610 CONTINUE CBB** ********************** BBCSUM0 ********************************** C**** WRITE OUT TEST SUMMARY C**** IVTOTN = IVPASS + IVFAIL + IVDELE + IVINSP WRITE (I02, 90004) WRITE (I02, 90014) WRITE (I02, 90004) WRITE (I02, 90020) IVPASS WRITE (I02, 90022) IVFAIL WRITE (I02, 90024) IVDELE WRITE (I02, 90026) IVINSP WRITE (I02, 90028) IVTOTN, IVTOTL CBE** ********************** BBCSUM0 ********************************** CBB** ********************** BBCFOOT0 ********************************** C**** WRITE OUT REPORT FOOTINGS C**** WRITE (I02,90016) ZPROG, ZPROG WRITE (I02,90018) ZPROJ, ZNAME, ZTAPE, ZTAPED WRITE (I02,90019) CBE** ********************** BBCFOOT0 ********************************** CBB** ********************** BBCFMT0A ********************************** C**** FORMATS FOR TEST DETAIL LINES C**** 80000 FORMAT (1H ,2X,I3,4X,7HDELETED,32X,A31) 80002 FORMAT (1H ,2X,I3,4X,7H PASS ,32X,A31) 80004 FORMAT (1H ,2X,I3,4X,7HINSPECT,32X,A31) 80008 FORMAT (1H ,2X,I3,4X,7H FAIL ,32X,A31) 80010 FORMAT (1H ,2X,I3,4X,7H FAIL ,/,1H ,15X,10HCOMPUTED= , 1I6,/,1H ,15X,10HCORRECT= ,I6) 80012 FORMAT (1H ,2X,I3,4X,7H FAIL ,/,1H ,16X,10HCOMPUTED= , 1E12.5,/,1H ,16X,10HCORRECT= ,E12.5) 80018 FORMAT (1H ,2X,I3,4X,7H FAIL ,/,1H ,16X,10HCOMPUTED= , 1A21,/,1H ,16X,10HCORRECT= ,A21) 80020 FORMAT (1H ,16X,10HCOMPUTED= ,A21,1X,A31) 80022 FORMAT (1H ,16X,10HCORRECT= ,A21,1X,A31) 80024 FORMAT (1H ,16X,10HCOMPUTED= ,I6,16X,A31) 80026 FORMAT (1H ,16X,10HCORRECT= ,I6,16X,A31) 80028 FORMAT (1H ,16X,10HCOMPUTED= ,E12.5,10X,A31) 80030 FORMAT (1H ,16X,10HCORRECT= ,E12.5,10X,A31) 80050 FORMAT (1H ,48X,A31) CBE** ********************** BBCFMT0A ********************************** CBB** ********************** BBCFMAT1 ********************************** C**** FORMATS FOR TEST DETAIL LINES - FULL LANGUAGE C**** 80031 FORMAT (1H ,2X,I3,4X,7H FAIL ,/,1H ,16X,10HCOMPUTED= , 1D17.10,/,1H ,16X,10HCORRECT= ,D17.10) 80033 FORMAT (1H ,16X,10HCOMPUTED= ,D17.10,10X,A31) 80035 FORMAT (1H ,16X,10HCORRECT= ,D17.10,10X,A31) 80037 FORMAT (1H ,16X,10HCOMPUTED= ,1H(,E12.5,2H, ,E12.5,1H),6X,A31) 80039 FORMAT (1H ,16X,10HCORRECT= ,1H(,E12.5,2H, ,E12.5,1H),6X,A31) 80041 FORMAT (1H ,16X,10HCOMPUTED= ,1H(,F12.5,2H, ,F12.5,1H),6X,A31) 80043 FORMAT (1H ,16X,10HCORRECT= ,1H(,F12.5,2H, ,F12.5,1H),6X,A31) 80045 FORMAT (1H ,2X,I3,4X,7H FAIL ,/,1H ,16X,10HCOMPUTED= , 11H(,F12.5,2H, ,F12.5,1H)/,1H ,16X,10HCORRECT= , 21H(,F12.5,2H, ,F12.5,1H)) CBE** ********************** BBCFMAT1 ********************************** CBB** ********************** BBCFMT0B ********************************** C**** FORMAT STATEMENTS FOR PAGE HEADERS C**** 90002 FORMAT (1H1) 90004 FORMAT (1H ) 90006 FORMAT (1H ,20X,31HFEDERAL SOFTWARE TESTING CENTER) 90007 FORMAT (1H ,19X,34HFORTRAN COMPILER VALIDATION SYSTEM) 90008 FORMAT (1H ,21X,A13,A17) 90009 FORMAT (1H ,/,2H *,A5,6HBEGIN*,12X,15HTEST RESULTS - ,A5,/) 90010 FORMAT (1H ,8X,16HTEST DATE*TIME= ,A17,15H - COMPILER= ,A20) 90013 FORMAT (1H ,8H TEST ,10HPASS/FAIL ,6X,17HDISPLAYED RESULTS, 1 7X,7HREMARKS,24X) 90014 FORMAT (1H ,46H----------------------------------------------, 1 33H---------------------------------) 90015 FORMAT (1H ,48X,17HTHIS PROGRAM HAS ,I3,6H TESTS,/) C**** C**** FORMAT STATEMENTS FOR REPORT FOOTINGS C**** 90016 FORMAT (1H ,/,2H *,A5,4HEND*,14X,14HEND OF TEST - ,A5,/) 90018 FORMAT (1H ,A13,13X,A20,7H * ,A10,1H/, 1 A13) 90019 FORMAT (1H ,26HFOR OFFICIAL USE ONLY ,35X,15HCOPYRIGHT 1982) C**** C**** FORMAT STATEMENTS FOR RUN SUMMARY C**** 90020 FORMAT (1H ,21X,I5,13H TESTS PASSED) 90022 FORMAT (1H ,21X,I5,13H TESTS FAILED) 90024 FORMAT (1H ,21X,I5,14H TESTS DELETED) 90026 FORMAT (1H ,21X,I5,25H TESTS REQUIRE INSPECTION) 90028 FORMAT (1H ,21X,I5,4H OF ,I3,15H TESTS EXECUTED) CBE** ********************** BBCFMT0B ********************************** STOP END C********************************************************************** C***** FORTRAN 77 C***** FM913 C***** SN913 FAQ - (807) C***** THIS SUBROUTINE IS CALLED BY PROGRAM FM912 C********************************************************************** SUBROUTINE SN913(FW1S, GW1S, CW1B, DW1B, DW1D, BW1D, 1 A20W1K, B20W1K) C***** C***** SUBROUTINE USED WITH SEGMENT DIRAF3 (412) TO SUPPLY VALUES C***** TO ARRAYS THRU THE DUMMY ARGUMENT LIST C***** REAL FT1S(5),FW1S(5),GT1S(5),GW1S(5) LOGICAL CT1B(5),CW1B(5),DT1B(5),DW1B(5) DOUBLE PRECISION DT1D(5),DW1D(5),BT1D(5),BW1D(5) CHARACTER*20 A20T1K(5),A20W1K(5),B20T1K(5),B20W1K(5) DATA FT1S /1.0, 2.0, 3.0, 4.0, 5.0/ DATA GT1S /1.2, 2.3, 3.5, 4.45, 45.0/ DATA A20T1K / 'AAAALKJHGFASERTYUIOP', 'KDJFLKJEOITMNV E CJF', 1 'CDFEJHFKLM CNB FHGDC', 'LKJHNHBJMVK,FIJ NVHD', 2 'JHGFKDJJSLDKFJDKJFSL'/ DATA B20T1K / 'AAAALSDEFCASERTYUIOP', 'KDDFFEJEOITMNV E CJF', 1 'CDFEJHFKLM DHGDC', 'L...NHBJMVK,FIJ NVHD', 2 'LKJHDNMVHNEUYHBDGHCJ'/ DATA CT1B /.TRUE., .FALSE., .TRUE., .TRUE., .FALSE./ DATA DT1B /.FALSE., .TRUE., .FALSE., .TRUE., .TRUE./ DATA DT1D /1.23D1, 2.34D1, 3.45D3, 5.602D3, 5.602D0/ DATA BT1D /23.1D1, 34.1D1, 23.45D3, .625D0, 109.384D0/ C***** C***** C***** DO 1 IVI = 1, 5 FW1S(IVI) = FT1S(IVI) GW1S(IVI) = GT1S(IVI) CW1B(IVI) = CT1B(IVI) DW1B(IVI) = DT1B(IVI) DW1D(IVI) = DT1D(IVI) BW1D(IVI) = BT1D(IVI) A20W1K(IVI) = A20T1K(IVI) B20W1K(IVI) = B20T1K(IVI) 1 CONTINUE C***** C***** C***** RETURN END