📄 ppp.for
字号:
IF (NEWREC .EQ.1) NEXREC = IREC 00006520
II = JJ + 1 00006530
IF (II.LE.LTOTAL) GOTO 200 00006540
***END:IBM,BUR*** 00006550
00006560
900 NWRITS = NWRITS + 1 00006570
RETURN 00006580
00006590
2000 FORMAT (48H ***ERROR: DATABASE WRITE ATTEMPT TO STORE MORE , 00006600
9 8HPHYSICAL, 00006610
1 /11X,33HRECORDS THAN THE MAX NO (NDAREC=,I6,10H) DEFINED 00006620
2 /11X,53HIN SUBROUTINE DBOPEN - PLEASE INCREASE NDAREC VALUE 00006630
3 /11X,34HOR PHYSICAL RECORD LENGTH (LDAREC=,I6,14H AND RECOMPILE)00006640
2030 FORMAT (38H ***ERROR: DBW INDEX OR INDXST INVALID) 00006650
2090 FORMAT (/15H ***DBW: LREAL=,I6,6H LINT=,I6, 00006660
1 8H INDXST=,I6,7H INDEX=,I6,7H DADDR=,I10,8H NEXREC=,I10) 00006670
END 00006680
***ADD:CDC*** 00006690
DECK DBINDX 00006700
***END:CDC*** 00006710
SUBROUTINE DBINDX (INDX,LINDX) 00006720
00006730
DIMENSION IA(1) 00006740
COMMON /DB/ IOPEN,NFDB,INDXST,IXTNOW,LGP,NWRITS,NREADS, 00006750
1 LDBC,LDBCTR,LDBCTI,IPHCHK,INSTRI,INRUSE,INSTRU, 00006760
2 MSUBF,MVIEW,MAXIS,MLINEN,MLINEE,MVAR,MRES,LSKEW,MIDSPL00006770
COMMON A(1) 00006780
EQUIVALENCE (A(1),IA(1)) 00006790
***ADD:CDC*** 00006800
IF (INDX.NE.INDXST) CALL STINDX (NFDB,IA(INDX),LINDX,0) 00006810
***END:CDC*** 00006820
INDXST = INDX 00006830
RETURN 00006840
END 00006850
***ADD:CDC*** 00006860
DECK DBREAD 00006870
***END:CDC*** 00006880
SUBROUTINE DBREAD (AA,IGP,ISGP,ITIME) 00006890
00006900
DIMENSION IA(1),AA(1) 00006910
COMMON /ERROR/ IERROR 00006920
COMMON /CNTRL/ IBATCH,NBSU,LSTC,LSTF,LSTDB,ISURL,ITWO,LINPAG,LINE 00006930
COMMON /FILES/ NFREAD,NFECHO,NFLOG,NFLIST,LUNODE,LUELEM 00006940
COMMON /DB/ IOPEN,NFDB,INDXST,IXTNOW,LGP,NWRITS,NREADS, 00006950
1 LDBC,LDBCTR,LDBCTI,IPHCHK,INSTRI,INRUSE,INSTRU, 00006960
2 MSUBF,MVIEW,MAXIS,MLINEN,MLINEE,MVAR,MRES,LSKEW,MIDSPL00006970
COMMON /DBC/ IHED(18),NDAREC,LDAREC,NRECS,NWORDS,NEXREC,NEXTIX, 00006980
1 LIX,LIXT,NSTRI,NSTRUC,NEGIT,NEGAT,NFREQ, 00006990
2 IXGP(50),MXSGP(50), 00007000
3 FILL1 00007010
COMMON /DIM/ I01,I02,I03,I04,I05,I06,I07,I08,I09,I010,I011, 00007020
1 I1,I2,I3,I4,I5,I6,I7,I8,I9,I10,I11,I12,I13,I14,I15, 00007030
2 I16,I17,I18,I19,I20, 00007040
3 N1,N2,N3,N4,N5,N6,N7,N8,N9,N10,N11,N12,N13,N14,N15, 00007050
4 N16,N17,N18,N19,N20 00007060
COMMON A(1) 00007070
EQUIVALENCE (A(1),IA(1)) 00007080
00007090
LREAL = 0 00007100
LINT = 0 00007110
IF (IOPEN.EQ.1) GOTO 100 00007120
WRITE (NFLOG,2000) 00007130
GOTO 800 00007140
100 CONTINUE 00007150
00007160
CHECK RECORD KEYS IGP, ISGP, ITIME 00007170
00007180
IF (IGP.LT.3.OR.IGP.GT.LGP) GOTO 150 00007190
IF (ISGP.LT.1.OR.ISGP.GT.MXSGP (IGP)) GOTO 150 00007200
IF (ITIME.LT.0.OR.ITIME.GE.LIXT) GOTO 150 00007210
GOTO 200 00007220
150 WRITE (NFLOG,2005) 00007230
GOTO 800 00007240
200 CONTINUE 00007250
00007260
DIRECT ACCRESS INDEX IXSGP IS NOW USED 00007270
00007280
IF (IXGP(IGP).NE.0) GOTO 250 00007290
WRITE (NFLOG,2030) 00007300
GOTO 150 00007310
250 IXIX = IXGP(IGP) + ISGP - 1 00007320
I01NOW = I01 + IXIX 00007330
I02NOW = I02 + IXIX 00007340
I03NOW = I03 + IXIX 00007350
I04NOW = I04 + IXIX 00007360
IF (IA(I03NOW).NE.0) GOTO 260 00007370
WRITE (NFLOG,2040) 00007380
GOTO 150 00007390
260 CALL DBINDX (I03,LIX) 00007400
00007410
GET LREAL, LINT FROM SUBGROUP ARRAYS 00007420
00007430
LREAL = IA(I01NOW) 00007440
LINT = IA(I02NOW) 00007450
IF (LSTDB.EQ.0) GOTO 300 00007460
IF (LSTDB.GT.2 .AND. LSTDB.NE.IGP) GOTO 300 00007470
WRITE (NFLOG,2090) IGP,ISGP,ITIME,LREAL,LINT 00007480
300 CONTINUE 00007490
00007500
ITIME = 0 00007510
00007520
IF (ITIME.GT.0) GOTO 400 00007530
INDEX = IXIX 00007540
IF (IA(I04NOW).EQ.0) GOTO 600 00007550
WRITE (NFLOG,2020) 00007560
GOTO 150 00007570
00007580
ITIME .GT. 0 - USE DIRECT ACCESS INDEX ITIME 00007590
IF OUR IXTIME NOT IN MEMORY NOW 00007600
- WRITE OLD IXTIME IF UPDATED (IXTNOW POSITIVE) 00007610
- READ OR INITIALIZE NEW IXTIME 00007620
00007630
400 CONTINUE 00007640
IF (IA(I04NOW).GT.0) GOTO 410 00007650
WRITE (NFLOG,2025) 00007660
GOTO 150 00007670
410 IF (IABS(IXTNOW).EQ.IXIX) GOTO 500 00007680
IF (IXTNOW.GT.0) CALL DBW (IA(I05),0,LIXT,IXTNOW) 00007690
IF (IERROR.NE.0) GOTO 900 00007700
CALL DBR (IA(I05),0,LIXT,IXIX) 00007710
IF (IERROR.NE.0) GOTO 900 00007720
IXTNOW = -IXIX 00007730
500 INDEX = ITIME 00007740
IF (IA(I05+ITIME).NE.0) GOTO 510 00007750
WRITE (NFLOG,2050) 00007760
GOTO 150 00007770
510 CALL DBINDX (I05,LIXT) 00007780
600 CONTINUE 00007790
00007800
READ 00007810
00007820
CALL DBR (AA,LREAL,LINT,INDEX) 00007830
IF (LSTDB.EQ.1 .OR. LSTDB.EQ.IGP) CALL DBLSTR (AA,LREAL,LINT) 00007840
GOTO 900 00007850
00007860
800 IERROR = 1 00007870
WRITE (NFLOG,2090) IGP,ISGP,ITIME,LREAL,LINT 00007880
900 RETURN 00007890
00007900
2000 FORMAT (28H ***ERROR: DATABASE NOT OPEN) 00007910
2005 FORMAT (29H ***ERROR: DBREAD KEY INVALID) 00007920
2020 FORMAT (37H ***ERROR: DBREAD ITIME MUST NOT BE 0) 00007930
2025 FORMAT (33H ***ERROR: DBREAD ITIME MUST BE 0) 00007940
2030 FORMAT (40H ***ERROR: DBREAD IGP NOT FOUND IN INDEX) 00007950
2040 FORMAT (41H ***ERROR: DBREAD ISGP NOT FOUND IN INDEX) 00007960
2050 FORMAT (42H ***ERROR: DBREAD ITIME NOT FOUND IN INDEX) 00007970
2090 FORMAT (/16H ***DBREAD: IGP=,I3,6H ISGP=,I5, 00007980
1 7H ITIME=,I6,7H LREAL=,I6,6H LINT=,I6) 00007990
END 00008000
***ADD:CDC*** 00008010
DECK DBR 00008020
***END:CDC*** 00008030
SUBROUTINE DBR (AA,LREAL,LINT,INDEX) 00008040
00008050
DIMENSION IA(1),AA(1) 00008060
COMMON /ERROR/ IERROR 00008070
COMMON /CNTRL/ IBATCH,NBSU,LSTC,LSTF,LSTDB,ISURL,ITWO,LINPAG,LINE 00008080
COMMON /FILES/ NFREAD,NFECHO,NFLOG,NFLIST,LUNODE,LUELEM 00008090
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -