C C THIS PROGRAM UNPACKS A DATA BASE WHICH IS IN THE IWGDE C EXCHANGE FORMAT. IT READS A CARD CONTAINING INPUT FILE C PARAMETERS, DUMPS THE DDF TO THE PRINTER, THEN DUMPS THE C FIRST FIVE DF RECORDS. C REAL*8 ITAG LOGICAL*1 IDATA(400),LBLNK DIMENSION IDBN(2), INFO(10), IVSNS(5) DIMENSION FILOT(4) C EQUIVALENCE (IDBN(1),INFO(1)), (MFID,INFO(3)) C DATA IVSNS /5*0/, INFO /10*0/ , LBLNK/' '/ C C READ PARAMETER CARD C C ILFN - LOCAL FILE NAME C C IVSNS(1) - TAPE REEL IDENTIFIER C C IDBN - DATA BASE NAME C C MFID - MULTIFILE SET IDENTIFIER C FILOT(4)=0.0 TYPE 5555 5555 FORMAT(' ENTER NUMBER OF RECORDS YOU WISH TO DUMP') ACCEPT 6666,NRDS 6666 FORMAT(I5) 11 FORMAT(3A4) TYPE 12 12 FORMAT(' DDF REPORT FILENAME (PRINT FILE): ',$) ACCEPT 11, (FILOT(I),I=1,3) OPEN(UNIT=2,NAME=FILOT,TYPE='NEW',CARRIAGECONTROL='LIST') IREC = 0 C C INITIALIZE FOR TAPE FILE C 140 CALL INITCN C C LOAD DDF C WRITE(2,9020) C C LIST DDF FIELDS C 200 CALL DMPDDF(ISTAT) IF (ISTAT .GE. 0) GO TO 1000 C C CHECK FOR END OF DDF C IF (ISTAT .EQ. -1) GO TO 1000 C C ERROR DUMPING DDF C 220 WRITE(2,9320) ISTAT C C DDF EXTRACTED, START ON DF C 1000 WRITE(2,9030) 1080 WRITE(2,9040) C C START OF RECORD UNPACK LOOP C 1100 IREC = IREC + 1 IF (IREC .GT. NRDS) GO TO 1300 CALL RDREC(ISTAT) IF (ISTAT .EQ. 0) GO TO 1120 IF(ISTAT.EQ.-1) STOP ' END OF DF' C C ERROR GETTING RECORD C WRITE(2,9300) ISTAT STOP ' ABORT' 1120 WRITE(2,9200) IREC C C UNPACK DATA FIELDS FROM RECORD C 1140 ICHCT = 400 DO 9876 I=1,ICHCT IDATA(I)=LBLNK 9876 CONTINUE CALL FETNXT(ISTAT,ITAG,IDATA,ICHCT) C C CHECK STATUS RETURN C 1160 IF (ISTAT .EQ. 0) GO TO 1200 IF (ISTAT .EQ. -1) GO TO 1100 IF (ISTAT .EQ. -2) GO TO 1200 WRITE(2,9310) ISTAT 1190 WRITE(2,9310) ISTAT C C PRINT FIELD C 1200 ILIM = ICHCT WRITE(2,9210) ITAG, (IDATA(I),I=1,ICHCT) IF (ISTAT .EQ. 0) GO TO 1140 C C GET REST OF DATA FIELD C 1220 ISTAT = 0 DO 6789 I=1,ICHCT IDATA(I)=LBLNK 6789 CONTINUE CALL FETMOR(ISTAT,ITAG,IDATA,ICHCT) WRITE(2,9220) (IDATA(I),I=1,ICHCT) IF (ISTAT .EQ. 0) GO TO 1140 IF (ISTAT .EQ. -1) GO TO 1100 IF (ISTAT .EQ. -2) GO TO 1220 GO TO 1190 C C EOF ENCOUNTERED C 1300 WRITE(2,9050) C C END OF DF PROCESSING C 8000 STOP C C FORMATS C 9020 FORMAT (13H STARTING DDF) 9030 FORMAT (24H END OF DDF, STARTING DF) 9040 FORMAT (25H 5 RECORDS WILL BE DUMPED) 9050 FORMAT (21H END OF DF, WILL STOP) C 9100 FORMAT (3A2,A1,3X,3A2,4X,13A2) 9110 FORMAT (3A2,A1) C 9200 FORMAT (25H1DATA FILE RECORD NUMBER ,I3) 9210 FORMAT ('0DATA FOR TAG ' ,A7,' IS ',5X,60A1,/,(26X,60A1)) 9220 FORMAT (26X,60A1) C 9300 FORMAT (7H ERROR ,I2,24H FROM RDREC, WILL ABORT ) 9310 FORMAT (7H ERROR ,I2,24H FROM FETNXT, WILL ABORT) 9320 FORMAT (7H ERROR ,I2,24H DUMPING DDF, WILL ABORT) C C END