📄 ppp.for
字号:
00004890
INITIALIZE IF FIRST WRITE FOR THIS IGP 00004900
00004910
IF (IXGP(IGP).GT.0) GOTO 300 00004920
IXGP(IGP) = NEXTIX 00004930
NEXTIX = NEXTIX + MXSGP (IGP) 00004940
IF (NEXTIX.LE.LIX) GOTO 300 00004950
WRITE (NFLOG,2010) 00004960
GOTO 800 00004970
300 CONTINUE 00004980
00004990
DIRECT ACCRESS INDEX IXSGP IS NOW USED 00005000
00005010
00005020
IXIX = IXGP(IGP) + ISGP - 1 00005030
I01NOW = I01 + IXIX 00005040
I02NOW = I02 + IXIX 00005050
I03NOW = I03 + IXIX 00005060
I04NOW = I04 + IXIX 00005070
CALL DBINDX (I03,LIX) 00005080
00005090
UPDATE OR CHECK LREAL LINT ARRAYS 00005100
00005110
IF (IA(I01NOW).EQ.0) IA(I01NOW) = LREAL 00005120
IF (IA(I02NOW).EQ.0) IA(I02NOW) = LINT 00005130
IF (LREAL.NE.IA(I01NOW)) GOTO 350 00005140
IF (LINT .NE.IA(I02NOW)) GOTO 350 00005150
IF (LINT.LT.0.OR.LREAL.LT.0) GOTO 350 00005160
L = LREAL + LINT 00005170
IF (L.LE.0 .OR. L.GT.1000000) GOTO 350 00005180
IF (LSTDB.EQ.0) GOTO 390 00005190
IF (LSTDB.GT.2 .AND. LSTDB.NE.IGP) GOTO 390 00005200
WRITE (NFLOG,2090) IGP,ISGP,ITIME,LREAL,LINT 00005210
IF (LSTDB.NE.2) CALL DBLSTR (AA,LREAL,LINT) 00005220
GOTO 390 00005230
350 WRITE (NFLOG,2030) 00005240
GOTO 800 00005250
00005260
ITIME = 0 00005270
00005280
390 CONTINUE 00005290
IF (ITIME.GT.0) GOTO 400 00005300
INDEX = IXIX 00005310
IF (IA(I04NOW).EQ.0) GOTO 700 00005320
WRITE (NFLOG,2020) 00005330
GOTO 150 00005340
00005350
ITIME .GT. 0 - USE INDEX IXTIME 00005360
IF OUR IXTIME NOT NOW IN MEMORY 00005370
- WRITE OLD IXTIME IF IT IS UPDATED (IXTNOW POSITIVE) 00005380
- READ OR INITIALIZE NEW IXTIME 00005390
00005400
400 CONTINUE 00005410
IF (IA(I04NOW).GT.0.OR.IA(I03NOW).EQ.0) GOTO 410 00005420
WRITE (NFLOG,2025) 00005430
GOTO 150 00005440
410 CONTINUE 00005450
IF (IABS(IXTNOW).EQ.IXIX) GOTO 500 00005460
IF (IXTNOW.GT.0) CALL DBW (IA(I05),0,LIXT,IXTNOW) 00005470
IF (IERROR.NE.0) GOTO 900 00005480
IF (IA(I03NOW).GT.0) GOTO 450 00005490
DO 420 I=1,LIXT 00005500
420 IA(I05+I-1) = 0 00005510
CALL DBW (IA(I05),0,LIXT,IXIX) 00005520
IF (IERROR.NE.0) GOTO 900 00005530
GOTO 460 00005540
450 CALL DBR (IA(I05),0,LIXT,IXIX) 00005550
IF (IERROR.NE.0) GOTO 900 00005560
460 CONTINUE 00005570
IXTNOW = IXIX 00005580
500 CONTINUE 00005590
INDEX = ITIME 00005600
IF (IA(I04NOW).LT.ITIME) IA(I04NOW) = ITIME 00005610
CALL DBINDX (I05,LIXT) 00005620
00005630
WRITE 00005640
00005650
700 CONTINUE 00005660
CALL DBW (AA,LREAL,LINT,INDEX) 00005670
GOTO 900 00005680
00005690
800 IERROR = 1 00005700
WRITE (NFLOG,2090) IGP,ISGP,ITIME,LREAL,LINT 00005710
900 RETURN 00005720
00005730
2000 FORMAT (28H ***ERROR: DATABASE NOT OPEN) 00005740
2005 FORMAT (29H ***ERROR: DBWRIT KEY INVALID 00005750
1 6H ISGP=,I5,7H ITIME=,I5) 00005760
2010 FORMAT (31H ***ERROR: DBWRIT LIX TOO SMALL) 00005770
2020 FORMAT (37H ***ERROR: DBWRIT ITIME MUST NOT BE 0) 00005780
2025 FORMAT (33H ***ERROR: DBWRIT ITIME MUST BE 0) 00005790
2030 FORMAT (34H ***ERROR: DBWRIT LINT LREAL CHECK) 00005800
2090 FORMAT (/16H ***DBWRIT: IGP=,I3,6H ISGP=,I4, 00005810
1 7H ITIME=,I6,7H LREAL=,I6,6H LINT=,I6) 00005820
END 00005830
***ADD:CDC*** 00005840
DECK DBW 00005850
***END:CDC*** 00005860
SUBROUTINE DBW (AA,LREAL,LINT,INDEX) 00005870
DIMENSION IA(1),AA(1) 00005880
COMMON /ERROR/ IERROR 00005890
COMMON /CNTRL/ IBATCH,NBSU,LSTC,LSTF,LSTDB,ISURL,ITWO,LINPAG,LINE 00005900
COMMON /FILES/ NFREAD,NFECHO,NFLOG,NFLIST,LUNODE,LUELEM 00005910
COMMON /DB/ IOPEN,NFDB,INDXST,IXTNOW,LGP,NWRITS,NREADS, 00005920
1 LDBC,LDBCTR,LDBCTI,IPHCHK,INSTRI,INRUSE,INSTRU, 00005930
2 MSUBF,MVIEW,MAXIS,MLINEN,MLINEE,MVAR,MRES,LSKEW,MIDSPL00005940
COMMON /DBC/ IHED(18),NDAREC,LDAREC,NRECS,NWORDS,NEXREC,NEXTIX, 00005950
1 LIX,LIXT,NSTRI,NSTRUC,NEGIT,NEGAT,NFREQ, 00005960
2 IXGP(50),MXSGP(50), 00005970
3 FILL1 00005980
COMMON A(1) 00005990
EQUIVALENCE (A(1),IA(1)) 00006000
00006010
COMPUTE LENGTH TO BE WRITTEN 00006020
AND UPDATE STATISTICS IF NEW RECORD 00006030
00006040
LTOTAL = LREAL + ((LINT - 1) / ISURL + 1) 00006050
I = INDXST + INDEX 00006060
IF (IA(I).NE.0) GOTO 5 00006070
NRECS = NRECS + 1 00006080
NWORDS = NWORDS + LTOTAL 00006090
IF (INDXST.EQ.I05) IXTNOW = IABS(IXTNOW) 00006100
5 CONTINUE 00006110
00006120
CHECK INDEX VALUE 00006130
00006140
IF (INDEX.GT.0.AND.INDXST.GT.0) GOTO 10 00006150
WRITE (NFLOG,2030) 00006160
IERROR = 1 00006170
GOTO 15 00006180
10 CONTINUE 00006190
IF (LSTDB.NE.2) GOTO 20 00006200
15 WRITE (NFLOG,2090) LREAL, LINT, INDXST, INDEX,IA(I),NEXREC 00006210
CALL DBLSTR (AA,LREAL,LINT) 00006220
20 CONTINUE 00006230
***ADD:CDC*** 00006240
CALL WRITMS (NFDB,AA,LTOTAL,INDEX,-1) 00006250
***END:CDC*** 00006260
***ADD:IBM,BUR*** 00006270
* IF ADD SET RECORD ADDRESS IN INDEX ARRAY TO NEXT FREE RECORD 00006280
* IF REPLACE PICK UP DISK RECORD ADDRESS FROM INDEX ARRAY 00006290
* AND REWRITE IN SAME RECORD(S) 00006300
* 00006310
NEWREC = 0 00006320
IF (IA(I).NE.0) GOTO 100 00006330
IA(I) = NEXREC 00006340
NEWREC = 1 00006350
100 CONTINUE 00006360
IREC = IA(I) 00006370
* 00006380
* SPLIT RECORD INTO ONE OR MORE DISK RECORDS OF FIX LENGTH 00006390
* IF ADD AND NOT REPLACE - UPDATE NEXT FREE RECORD (NEXREC) 00006400
* 00006410
II = 1 00006420
200 JJ = II - 1 + LDAREC 00006430
IF (JJ.GT.LTOTAL) JJ = LTOTAL 00006440
IF (IREC.LE.NDAREC) GOTO 300 00006450
WRITE (NFLOG,2000) NDAREC, LDAREC 00006460
IERROR = 1 00006470
GOTO 900 00006480
300 IDUM = IREC 00006490
WRITE (NFDB'IDUM) (AA(I),I=II,JJ) 00006500
IREC = IREC + 1 00006510
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -