C CONVERTED BY CONVRT: TSCON.01B 00100 PROGRAM RDINV 00110 C 00120 C ****************************************************************** 00130 C 00140 C PURPOSE - READ PACKED INVENTORIES FOR PRE-70'S OR 00150 C 70'S DATA MADE BY PROGRAM DUPELIM 00160 C 00170 C WRITTEN BY - JANE HISCOX 00180 C 00190 C ****************************************************************** 00200 C -----------REVISION HISTORY--------------------------------------- 00210 C LEVEL AUTHOR DATE DESCRIPTION 00220 C ===== ====== ========== ==================== 00230 C .01B. SL 85/01/30. REVISED COMMENTS; CONVERT FROM 00240 C TIMESHARING FORTRAN. 00250 C ------------------------------------------------------------------ 00260 C 00270 IMPLICIT INTEGER (A-Z) 00280 CHARACTER*4 LEVEL 00290 C 00300 DIMENSION STORE (5000), CARD (50) 00310 C 00320 COMMON /QC/ INVNF (14,11) 00330 C 00340 DATA LEVEL /'.01B'/, NSTORE, NSID, NCD, NDS/ 5000, 24, 50, 8/ 00350 DATA RQC, CQC/ 14, 11/, BITBOX, BITYR, BITIOD, BITGT / 10, 8, 15, 00360 +20/ 00370 DATA IU, JU, OU / 1, 2, 5/ 00380 DATA CARD / 110, 116, 117, 118, 119, 128, 143, 150, 151, 152, 155, 00390 + 156, 184, 185, 186, 187, 188, 189, 192, 193, 194, 195, 00400 + 196, 197, 281, 555, 666, 849, 850, 876, 877, 878, 879, 00410 + 880, 881, 882, 888, 889, 891, 897, 898, 899, 900, 901, 00420 + 902, 926, 927, 928, 999, 50/ 00430 C 00440 REWIND IU 00450 REWIND JU 00460 REWIND OU 00470 C 00480 DTE = DATE (K) 00490 TME = TIME (K) 00500 READ (JU,*,END=900) BOX 00510 WRITE (5,5) BOX, LEVEL, DTE, TME 00520 5 FORMAT ('1 INVENTORIES FOR BOX ',I3,T60,'BY RDINV',A,2X,2A10) 00530 C 00540 100 BUFFER IN (IU,0) (STORE(1), STORE(NSTORE)) 00550 IF (UNIT(IU) .LT. 0) THEN 00560 OFF = 0 00570 NWORD = 1 00580 CALL GBYTE (STORE(NWORD), BOX10, OFF, BITBOX) 00590 IF (BOX10 .EQ. BOX) THEN 00600 OFF = OFFSET (OFF,NWORD,BITBOX) 00610 175 CALL GBYTE (STORE(NWORD), YEAR, OFF, BITYR) 00620 OFF = OFFSET (OFF,NWORD,BITYR) 00630 IF (YEAR .NE. 0) THEN 00640 YEAR = YEAR + 1799 00650 WRITE (5,200) YEAR 00660 200 FORMAT (//' YEAR = ',I4,/1X, 00670 + 'MO. IN OUT UNCERTAIN', /1X,26('=')) 00680 SUMI = 0 00690 SUMO = 0 00700 SUMD = 0 00710 DO 225 MO = 1,12 00720 CALL GETNUM (STORE, IMO, OFF, NWORD, BITIOD) 00730 CALL GETNUM (STORE, OMO, OFF, NWORD, BITIOD) 00740 CALL GETNUM (STORE, DMO, OFF, NWORD, BITIOD) 00750 IF (IMO .NE. 0) WRITE (5,210) MO, IMO, OMO, DMO 00760 210 FORMAT (1X,I2,1X,2I6,3X,I6) 00770 SUMI = SUMI + IMO 00780 SUMO = SUMO + OMO 00790 SUMD = SUMD + DMO 00800 225 CONTINUE 00810 WRITE (5,250) SUMI, SUMO, SUMD 00820 250 FORMAT (1X,26('=')/4X,2I6,3X,I6) 00830 C 00840 C -----------UNPACK YEARLY TOTALS FOR SOURCE IDS 00850 WRITE (5,260) 00860 260 FORMAT (//' TOTALS BY SID',/ 00870 + 1X,'SID IN OUT UNCERTAIN',/1X, 00880 + 36('=')) 00890 SUMI = 0 00900 SUMO = 0 00910 SUMD = 0 00920 DO 300 JR = 1,NSID 00930 CALL GETNUM (STORE, ISID, OFF, NWORD, BITIOD) 00940 CALL GETNUM (STORE, OSID, OFF, NWORD, BITIOD) 00950 CALL GETNUM (STORE, DSID, OFF, NWORD, BITIOD) 00960 IF (ISID .NE. 0) WRITE (5,275) JR, ISID, OSID, DSID 00970 275 FORMAT (1X,I3,3(3X,I7)) 00980 SUMI = SUMI + ISID 00990 SUMO = SUMO + OSID 01000 SUMD = SUMD + DSID 01010 300 CONTINUE 01020 WRITE (5,325) SUMI, SUMO, SUMD 01030 325 FORMAT (1X,36('='),/4X,3(3X,I7)) 01040 GO TO 175 01050 ENDIF 01060 C 01070 C -----------UNPACK GRAND TOTALS BY SID 01080 WRITE (5,350) BOX10 01090 350 FORMAT ('1 GRAND TOTALS FOR BOX ',I3,// 01100 + 1X,' SID IN OUT UNCERTAIN',/1X, 01110 + 36('=')) 01120 SUMI = 0 01130 SUMO = 0 01140 SUMD = 0 01150 DO 400 JR = 1,NSID 01160 CALL GETNUM (STORE, ISID, OFF, NWORD, BITGT) 01170 CALL GETNUM (STORE, OSID, OFF, NWORD, BITGT) 01180 CALL GETNUM (STORE, DSID, OFF, NWORD, BITGT) 01190 IF (ISID .NE. 0) WRITE (5,275) JR, ISID, OSID, DSID 01200 SUMI = SUMI + ISID 01210 SUMO = SUMO + OSID 01220 SUMD = SUMD + DSID 01230 400 CONTINUE 01240 WRITE (5,325) SUMI, SUMO, SUMD 01250 C 01260 C -----------UNPACK GRAND TOTALS BY CARD DECK 01270 WRITE (5,500) 01280 500 FORMAT (///,1X,' CD IN OUT UNCERTAIN',/1X, 01290 + 36('=')) 01300 SUMI = 0 01310 SUMO = 0 01320 SUMD = 0 01330 DO 600 JR = 1,NCD 01340 CALL GETNUM (STORE, ICD, OFF, NWORD, BITGT) 01350 CALL GETNUM (STORE, OCD, OFF, NWORD, BITGT) 01360 CALL GETNUM (STORE, DCD, OFF, NWORD, BITGT) 01370 IF (ICD .NE. 0) WRITE (5,275) CARD(JR), ICD, OCD, DCD 01380 SUMI = SUMI + ICD 01390 SUMO = SUMO + OCD 01400 SUMD = SUMD + DCD 01410 600 CONTINUE 01420 WRITE (5,325) SUMI, SUMO, SUMD 01430 C 01440 C -----------UNPACK GRAND TOTALS 01450 WRITE (5,625) 01460 625 FORMAT (///' GRAND TOTALS') 01470 CALL GETNUM (STORE, IGT, OFF, NWORD, BITGT) 01480 CALL GETNUM (STORE, OGT, OFF, NWORD, BITGT) 01490 CALL GETNUM (STORE, DGT, OFF, NWORD, BITGT) 01500 WRITE (5,650) IGT, OGT, DGT 01510 650 FORMAT (/' TOTAL IN = ',I7,', TOTAL OUT = ',I7, 01520 + ', NUMBER OF UNCERTAIN IN OUT = ',I7) 01530 C 01540 C -----------UNPACK TOTALS BY DS 01550 WRITE (5,675) 01560 675 FORMAT (///' TOTALS BY DUPLICATE STATUS',//5X, 01570 + ' DS TOTAL',/5X,12('=')) 01580 SUMDS = 0 01590 DO 700 JR = 1,NDS 01600 CALL GETNUM (STORE, ODS, OFF, NWORD, BITGT) 01610 J = JR - 1 01620 WRITE (5,685) J, ODS 01630 685 FORMAT (5X,I3,I7) 01640 SUMDS = SUMDS + ODS 01650 700 CONTINUE 01660 WRITE (5,725) SUMDS 01670 725 FORMAT (5X,12('='),/8X,I7) 01680 C 01690 C -----------UNPACK QC INVENTORIES 01700 DO 800 JC = 1,CQC 01710 DO 775 JR = 1,RQC 01720 CALL GETNUM (STORE, INVNF(JR,JC), OFF, NWORD, BITGT) 01730 775 CONTINUE 01740 800 CONTINUE 01750 C CALL PRINVN (BOX10) 01760 GO TO 900 01770 ENDIF 01780 GO TO 100 01790 ENDIF 01800 900 REWIND IU 01810 REWIND JU 01820 REWIND OU 01830 END 01840 C 01850 C ****************************************************************** 01860 C 01870 SUBROUTINE GETNUM (STORE, NUM, OFF, NWORD, BITS) 01880 C 01890 C -----------UNPACK NUMBER, UPDATE OFFSET. IF THE UNPACKED NUMBER 01900 C IS THE MAXIMUM SIZE FOR NUMBER OF BITS, UNPACK THE NEXT 01910 C NUMBER AND SUM THEM. 01920 C STORE - ARRAY TO UNPACK NUMBER FROM 01930 C NUM - RESULTANT NUMBER 01940 C OFF - OFFSET 01950 C NWORD - WORD OF ARRAY STORE TO UNPACK FROM 01960 C BITS - NUMBER OF BITS TO UNPACK FROM STORE 01970 C 01980 IMPLICIT INTEGER (A-Z) 01990 C 02000 DIMENSION STORE (*) 02010 C 02020 NUM = 0 02030 100 CALL GBYTE (STORE(NWORD), N, OFF, BITS) 02040 OFF = OFFSET (OFF, NWORD, BITS) 02050 NUM = NUM + N 02060 IF (N .GE. (2**BITS - 1)) GO TO 100 02070 END 02080 C 02090 C ****************************************************************** 02100 C 02110 INTEGER FUNCTION OFFSET (OFF, NWORD, BITS) 02120 C 02130 C -----------UPDATE OFFSET AND NWORD BY BITS 02140 C 02150 IMPLICIT INTEGER (A-Z) 02160 DATA WRDSIZ / 60/ 02170 C 02180 OFFSET = OFF + BITS 02190 IF (OFFSET .GE. WRDSIZ) THEN 02200 OFFSET = OFFSET - WRDSIZ 02210 NWORD = NWORD + 1 02220 ENDIF 02230 END 02240 C 02250 C ****************************************************************** 02260 C 02270 SUBROUTINE PRINVN (BOX10) 02280 C 02290 C -----------PRINT QC INVENTORIES 02300 C 02310 IMPLICIT INTEGER (A-Z) 02320 CHARACTER FLAG (14)*8 02330 C 02340 COMMON /QC/ INVNF (14,11) 02350 C 02360 DATA FLAG /'SHIP POS','WIND ','VIS ','PRES WX ','PAST WX ', 02370 + 'PRESSURE','DRY BULB','WET BULB','DEW PT ','SEA TEMP', 02380 + 'CLOUDS ','WAVES ','SWELLS ','P TEND '/ 02390 C 02400 WRITE (5,10) BOX10 02410 10 FORMAT (///,' QUALITY CONTROL FLAGS, BOX10 = ',I3, 02420 + /1X,'FLAG/VALUE',3X,'MISSING',7X,'R',9X,'A',9X,'B',9X, 02430 + 'J',9X,'K',9X,'L',9X,'M',9X,'N',9X,'Q',9X,'S',5X, 02440 + 'TOTAL') 02450 DO 230 JR = 1,14 02460 TOTAL = 0 02470 DO 220 JC = 1,11 02480 TOTAL = TOTAL + INVNF(JR,JC) 02490 220 CONTINUE 02500 WRITE (5,225) FLAG(JR),(INVNF(JR,JC),JC=1,11),TOTAL 02510 225 FORMAT (1X,A,12I10) 02520 230 CONTINUE 02530 END 02540