C************************************************************************** C THIS PROGRAM IS WRITTEN IN VAX 4.2 FORTRAN 77 SOURCE. ITS PURPOSE IS C TO CONVERT BETWEEN REGULAR ASCII FORMAT AND COMPRESSED ASCII FORMAT. C PROGRAM IGES C C PROGRAM ORIGINALLY WRITTEN BY J. M. SPAETH 7-24-84 C GENERAL ELECTRIC CORP. RE. & DEV. C RE-WRITTEN BY LEE KLEIN 9-20-84 C GENERAL DYNAMICS CAD/CAM POMONA DIV. C REVISED BY LEE KLEIN 7-28-86 C GENERAL DYNAMICS CAD/CAM POMONA DIV. C REVISED BY LEE KLEIN 8-1-86 C GENERAL DYNAMICS CAD/CAM POMONA DIV. C REVISED BY LEE KLEIN 8-7-86 C GENERAL DYNAMICS CAD/CAM POMONA DIV. C REVISED BY ROBERT COLSHER 22 AUG 1986 C IGES DATA ANALYSIS COMPANY C C PURPOSE: C TO CONVERT NEW FORM OF IGES OUTPUT TO OLD FORM AND C OLD FORM TO NEW. C C INPUT: C YOU MUST GIVE THE NAME (INCLUDING DIRECTORY IF DIFFERENT) OF C THE FILE CONTAINING THE NEW FORM OF OUTPUT. YOU MUST ALSO C GIVE THE NAME OF THE FILE TO CONTAIN THE CONVERTED OUTPUT. C C************************************************************************** C SPECIAL NOTES: C C 1. THE DOLLAR SIGN IN I/O FORMAT STATEMENTS IS THERE TO SUPPRESS C THE CARRIAGE RETURN AT THE END OF THE PROMPT LINE. C 2. IN COMPILERS THAT DO NOT ACCEPT A VARIABLE LENGTH OUTPUT FORMAT, C SOME MEANS OF COMPRESSING BLANK PADDED LINES MUST BE USED. C 3. SEE CHANGE NOTES THROUGHOUT THE CODE C C************************************************************************** CHARACTER * 80 LINE1 CHARACTER * 60 INFILE,OUTFIL C C PROMPT AND GET FILE NAMES... C GOTO 1010 1000 WRITE(*,1900) 1010 WRITE(*,1910) WRITE(*,1920) READ(*,1930)INFILE WRITE(*,1940) READ(*,1930)OUTFIL C C READ THE FIRST LINE... C OPEN(UNIT=10,FILE=INFILE,STATUS='OLD',ERR=1000) READ(10,1950)LINE1 CLOSE(10) C C CHECK TO SEE WHICH FORM THE INPUT IS IN... C C ONLY A 'C'OMPRESS RECORD CAN OCCUR AT BEGINNING OF 'NEW' FILE C ONLY A 'S'TART RECORD CAN OCCUR AT BEGINNING OF 'OLD' FILE C IF (LINE1(73:73).EQ.'C') THEN CALL OLDFRM(INFILE,OUTFIL) ELSE IF (LINE1(73:73).EQ.'S') THEN CALL NEWFRM(INFILE,OUTFIL) ELSE WRITE(*,1960)' File contains ILLEGAL record format' CLOSE(10) STOP ENDIF WRITE(*,1960)' ' WRITE(*,1960)' IGES conversion complete' WRITE(*,1960)' ' C C FORMATS C 1900 FORMAT(/1X,'Error in filename. Try again.') 1910 FORMAT(/1X,'*** IGES FILE CONVERSION PROGRAM ***'/) 1920 FORMAT($,' Enter input file name: ') 1930 FORMAT(A60) 1940 FORMAT($,' Enter output file name: ') 1950 FORMAT(A80) 1960 FORMAT(A) C END C************************************************************************** C SUBROUTINE OLDFRM(INFILE,OUTFIL) C C OLD FORM CONVERSION C C PROGRAM ORIGANALLY WRITTEN BY J. M. SPAETH 7-24-84 C GENERAL ELECTRIC CORP. RE. & DEV. C RE-WRITTEN BY LEE KLEIN 9-20-84 C GENERAL DYNAMICS CAD/CAM POMONA DIV. C REVISED BY ROBERT COLSHER 22 AUG 1986 C IGES DATA ANALYSIS COMPANY C C PURPOSE: C TO CONVERT NEW FORM OF IGES OUTPUT TO OLD FORM... C C VARIABLE DECLARATIONS... C CHARACTER * (*) INFILE,OUTFIL CHARACTER * 8 BLNK,INARR(20),NEWARR(20) CHARACTER * 80 INLINE CHARACTER * 160 OUTARR INTEGER ICNT1,ICNT2,ICNT3,IA,IB,IC INTEGER IJ,IK,IL,IT C C INITIALIZE OUTARR TO BLANKS... C OUTARR(1:160)=' ' C C OPEN INPUT AND TEMP FILES... C OPEN(UNIT=1,FILE='FILE1.TMP',STATUS='NEW',CARRIAGECONTROL='LIST') OPEN(UNIT=2,FILE='FILE2.TMP',STATUS='NEW',CARRIAGECONTROL='LIST') OPEN(UNIT=3,FILE='FILE3.TMP',STATUS='NEW',CARRIAGECONTROL='LIST') OPEN(UNIT=4,FILE='FILE4.TMP',STATUS='NEW',CARRIAGECONTROL='LIST') OPEN(UNIT=9,FILE=OUTFIL,STATUS='NEW',CARRIAGECONTROL='LIST') OPEN(UNIT=10,FILE=INFILE,STATUS='OLD') C C INITIALIZE COUNTERS... C ICNT1 = -1 ICNT2 = 1 ICNT3 = 0 C C READ THE FILE AND SEPARATE INTO PARTS... C 2000 READ(10,2900,END=2090)INLINE IF ((INLINE(73:73).EQ.'S').OR.(INLINE(73:73).EQ.'G')) GOTO 2010 IF (INLINE(73:73).EQ.'T') GOTO 2020 IF ((INLINE(1:1).EQ.'@').OR.(INLINE(1:1).EQ.'D')) GOTO 2040 C C IF IT IS AN C THAN DELETE IT OFF BY READING THE NEXT LINE C IF (INLINE(73:73).EQ.'C') GOTO 2000 C C PUT THE PARAMETER DATA INTO FILE4.TMP... C WRITE(4,2910) (INLINE(1:64),ICNT1,'P',ICNT2) ICNT2 = ICNT2 + 1 GOTO 2000 C C WRITE HEADER LINES INTO FILE1.TMP... C 2010 WRITE(1,2900)INLINE GOTO 2000 C C WRITE TERMINATION LINE INTO FILE2.TMP... C 2020 WRITE(2,2900)INLINE GOTO 2000 C C WRITE DIRECTORY ENTRY LINES INTO FILE3.TMP... C 2030 WRITE(3,2920) (OUTARR(1:8),ICNT2,OUTARR(17:80)) WRITE(3,2900) OUTARR(81:160) ICNT1 = ICNT1 + 2 GOTO 2000 C C REWRITE TO DE LINES IN THE NEW FORM... C C GO THRU INLINE ONE CHAR. AT A TIME LOOKING FOR THE C DELIMETER (@, ,_)... C 2040 IL = 1 2050 IF (IL.GT.80) GOTO 2000 IF (INLINE(IL:IL).EQ.';') GOTO 2030 IF (INLINE(IL:IL).NE.'@') GOTO 2080 C C DETERMINE IF THE FIELD IS ONE OR TWO CHARACTERS... C IF (INLINE(IL+2:IL+2).EQ.'_') THEN IC=ICHAR(INLINE(IL+1:IL+1))-48 IL=IL+2 ELSE IA=ICHAR(INLINE(IL+1:IL+1))-48 IB=ICHAR(INLINE(IL+2:IL+2))-48 IC=10*IA+IB IL=IL+3 ENDIF C C AT THIS POINT IC IS THE NUMBER OF THE RECORD FIELD BEING C PROCESSED, AND INLINE(IL)=USCORE C IT=0 IK=0 IJ=(IC-1)*8+1 C C RESET THE FIELD TO BE CHANGED TO ALL BLANKS IN ORDER TO CREATE C A COMPLETELY NEW FILED... C OUTARR(IJ:IJ+7)=' ' C C WE WILL NOW CONTINUE THRU THE LINE PICKING OFF THE CHAR. C OF THE RECORD FIELD ONE AT A TIME UNTIL A DELIMETER IS HIT... C 2060 IK=IK+1 IF (INLINE(IL+IK:IL+IK).EQ.'@') GOTO 2070 IF (INLINE(IL+IK:IL+IK).EQ.' ') THEN IF (INLINE(IL+IK+1:IL+IK+1).EQ.' ') GOTO 2070 ENDIF IF (INLINE(IL+IK:IL+IK).EQ.';') GOTO 2070 IT=IT+1 IJ=(IC-1)*8+IT OUTARR(IJ:IJ)=INLINE(IL+IK:IL+IK) IF (IC.EQ.1) THEN OUTARR(IJ+80:IJ+80)=INLINE(IL+IK:IL+IK) ENDIF GOTO 2060 2070 IL=IL+IT 2080 IL = IL + 1 GOTO 2050 C C REWIND ALL FILES BEFORE WE WRITE THEM TO OUTPUT... C 2090 REWIND 1 REWIND 2 REWIND 3 REWIND 4 C C WRITE START AND GLOBAL RECORDS TO OUTPUT FILE... C 2100 READ(1,2900,END=2110) INLINE WRITE(9,2900) INLINE GOTO 2100 C C WRITE THE DE RECORDS TO OUTPUT FILE. THEY NOW BECOME RE-FORMATTED... C 2110 READ(3,2930,END=2140) (INARR(I),I=1,10) READ(3,2930) (INARR(I),I=11,20) DO 2130 IP=1,20 IF ((IP.NE.9).AND.(IP.NE.18)) GOTO 2120 NEWARR(IP)=INARR(IP) GOTO 2130 C C CHANGE THOSE FIELDS THAT MUST BE RIGHT JUSTIFIED C 2120 NEWARR(IP)=BLNK(INARR(IP)) 2130 CONTINUE ICNT3=ICNT3+1 WRITE(9,2940) ((NEWARR(J),J=1,9),'D',ICNT3) ICNT3=ICNT3+1 WRITE(9,2940) ((NEWARR(J),J=11,19),'D',ICNT3) GOTO 2110 C C WRITE THE PD LINES TO THE OUTPUT FILE... C 2140 READ(4,2900,END=2150) INLINE WRITE(9,2900) INLINE GOTO 2140 C C WRITE THE TERMINATE LINES TO THE OUTPUT FILE... C 2150 READ(2,2900,END=2160) INLINE WRITE(9,2900) INLINE GOTO 2150 C C NOW CLOSE THE FILES AND DELETE THE TEMP ONES... C 2160 CONTINUE CLOSE(UNIT=1,STATUS='DELETE') CLOSE(UNIT=2,STATUS='DELETE') CLOSE(UNIT=3,STATUS='DELETE') CLOSE(UNIT=4,STATUS='DELETE') CLOSE(9) CLOSE(10) RETURN C C FORMATS C 2900 FORMAT(A80) 2910 FORMAT(A64,1I8,1A1,1I7) 2920 FORMAT(A8,I8,A64) 2930 FORMAT(10A8) 2940 FORMAT(9A8,A,I7) C END C************************************************************************** C CHARACTER*(*) FUNCTION BLNK(BUF) C C START FUNCTION BLNK HERE C C WRITTEN BY P. R. KENNICOTT 9-29-83. C GENERAL ELECTRIC CORP. RE. & DEV. C RE-WRITTEN BY LEE KLEIN 9-2-84. C GENERAL DYNAMICS CAD/CAM POMONA DIV. C REVISED BY LEE KLEIN 8-7-86 C GENERAL DYNAMICS CAD/CAM POMONA DIV. C REVISED BY ROBERT COLSHER 22 AUG 1986 C IGES DATA ANALYSIS COMPANY C C PURPOSE: C TO REMOVE BLANKS FROM END OF A CHARACTER STRING (RIGHT JUSTIFY) C C INPUT: C BUF STRING WITH TRAILING BLANKS C C OUTPUT: C BLNK STRING WITH TRAILING BLANKS REMOVED C C METHOD: C FIND FIRST BLANK, THEN TRANSLATE OUTPUT STRING C C RESTRICTIONS: C 1. BUF <= 512 CHARACTERS. C 2. LENGTHS OF BUF & BLNK MUST BE =. C 3. FIRST CHARACTER MUST NOT BE BLANK OR NO CONVERSION. C C C VARIABLE DECLARATIONS... C CHARACTER*(*) BUF INTEGER I CHARACTER*512 IBUF C C SET UP COUNTERS... C N=INDEX(BUF(1:),' ')-1 M=LEN(BUF) C C CHECK FOR SIZE TOO BIG... C IF (M.GT.512) STOP 'Buffer too big at function BLNK' C C CHECK FOR FIRST CHAR A BLANK... C IF (BUF(1:1).EQ.' '.OR.BUF(M:M).NE.' ') THEN BLNK=BUF RETURN ENDIF C C OK PROCESS STRING... C DO 3000 I=1,N 3000 IBUF(M-I+1:M-I+1)=BUF(N-I+1:N-I+1) IBUF(1:M-N)=' ' BLNK=IBUF RETURN END C************************************************************************** C SUBROUTINE NEWFRM(INFILE,OUTFIL) C C START NEW SUBROUTINE HERE C C PROGRAM ORIGANALLY WRITTEN BY J. M. SPAETH 7-24-84 C GENERAL ELECTRIC CORP. RE. & DEV. C RE-WRITTEN BY LEE KLEIN 9-20-84 C GENERAL DYNAMICS CAD/CAM POMONA DIV. C REVISED BY LEE KLEIN 8-7-86 C GENERAL DYNAMICS CAD/CAM POMONA DIV. C REVISED BY ROBERT COLSHER 22 AUG 1986 C IGES DATA ANALYSIS COMPANY C C PURPOSE: C TO CONVERT OLD FORM OF IGES OUTPUT TO NEW FORM... C C VARIABLE DECLARATIONS... C INTEGER PDRCD CHARACTER * 80 INLINE CHARACTER * (*) INFILE,OUTFIL C C OPEN THE INPUT AND TEMP FILES... C OPEN(UNIT=10,FILE=INFILE,STATUS='OLD') OPEN(UNIT=1,FILE='TEST.TMP',STATUS='NEW',CARRIAGECONTROL='LIST') OPEN(UNIT=2,FILE='FILE2.TMP',STATUS='NEW',RECL=80, + ACCESS='DIRECT',FORM='FORMATTED') OPEN(UNIT=3,FILE='FILE3.TMP',STATUS='NEW') OPEN(UNIT=7,FILE='FILE5.TMP',STATUS='NEW') C C WRITE THE HEADER WITH A "C" TO SHOW COMPRESSED ASCII FORM... C WRITE(1,4900)'C',1 C C SEPERATE THE PD AND DE RECORDS, WHILE WRITING G,S, &T LINES C TO THE OUTPUT FILE... C 4000 READ(10,4910,END=4040) INLINE IF (INLINE(73:73).EQ.'D') GOTO 4010 IF (INLINE(73:73).EQ.'P') GOTO 4020 IF (INLINE(73:73).EQ.'T') GOTO 4030 C C WRITE HEADER LINES INTO A TEST.TMP... C WRITE (1,4910) INLINE GOTO 4000 C C WRITE DIRECTORY LINES INTO FILE3.TMP... C 4010 WRITE (3,4910) INLINE GOTO 4000 C C WRITE PARAMETER DATA INTO FILE2.TMP... C 4020 READ (INLINE(74:80),4920) PDRCD WRITE (2,REC=PDRCD,FMT=4910) INLINE GOTO 4000 C C WRITE TERMINATE RECORD INTO FILE5.TMP... C 4030 WRITE (7,4910) INLINE 4040 CALL XPD REWIND 7 4050 READ(7,4910,END=4060) INLINE WRITE (1,4910) INLINE GOTO 4050 4060 CALL CMPRES(OUTFIL) C C CLOSE FILES AND DELETE TEMP ONES... C CLOSE(UNIT=1,STATUS='DELETE') CLOSE(UNIT=2,STATUS='DELETE') CLOSE(UNIT=3,STATUS='DELETE') CLOSE(UNIT=4) CLOSE(UNIT=7,STATUS='DELETE') CLOSE(UNIT=10) RETURN C C FORMATS C 4900 FORMAT(72X,A,I7) 4910 FORMAT(A80) 4920 FORMAT(I7) C END C************************************************************************** C SUBROUTINE XPD C C PROGRAM ORIGINALLY WRITTEN BY J. M. SPAETH 7-24-84 C GENERAL ELECTRIC CORP. RE. & DEV. C REVISED BY LEE KLEIN 8-7-86 C GENERAL DYNAMICS CAD/CAM POMONA DIV. C REVISED BY ROBERT COLSHER 22 AUG 1986 C IGES DATA ANALYSIS COMPANY C C PURPOSE: C TO TRANSFER ALL PD & DE RECORDS FORM TEMPORY FILES TO C OUTPUT FILE IN MERGED FORM... C C VARIABLE DECLARATIONS... C CHARACTER * 1 SCOLN/';'/ CHARACTER * 8 BLNK,LSTDAT(20),NEWDAT(20),NUDAT CHARACTER * 80 PDLINE,DELIN1,DELIN2 CHARACTER * 160 NEWDE INTEGER LFLD(20),FLDNUM,FLDBEG,FLDEND INTEGER CHRPTR,NEWPTR,PDPTR,PDCNT C C REWIND THE FILES... C REWIND 3 C C INITIALIZE LAST DATA SO AS NOT TO EQUAL NEXT DATA... C DO 5000 FLDNUM=1,20 LSTDAT(FLDNUM) = 'XXXXXXXX' 5000 CONTINUE C C GET NEW DE RECORD C 5010 READ(3,5900,END=5100) DELIN1 READ(3,5900) DELIN2 READ(DELIN1(9:16),5910) PDPTR READ(DELIN2(25:32),5910) PDCNT DELIN1(73:73)=' ' DELIN2(73:73)=' ' C C CLEAR OUT THE DE RECORD BUFFER... C NEWDE(1:160) = ' ' C C GET THE DATA FROM EACH FIELD OF THE DE RECORD SET... C FLDBEG = -7 FLDEND = 0 DO 5020 FLDNUM=1,10 FLDBEG=FLDBEG + 8 FLDEND=FLDEND + 8 READ(DELIN1(FLDBEG:FLDEND),5920) NEWDAT(FLDNUM) READ(DELIN2(FLDBEG:FLDEND),5920) NEWDAT(FLDNUM+10) 5020 CONTINUE C C FIELD 9 MUST BE ZERO FILLED C DO 5030 I = 1,8 IF (NEWDAT(9)(I:I).EQ.' ')NEWDAT(9)(I:I) = '0' 5030 CONTINUE C C FIELD 18 MUST BE RIGHT JUSTIFIED... C NEWDAT(18)=BLNK(NEWDAT(18)) C C DETERMINE THE LENGTH OF THE DATA WITHIN EACH FIELD C DO 5050 FLDNUM=1,20 DO 5040 I=1,8 IF (NEWDAT(FLDNUM)(I:I).NE.' ') THEN LFLD(FLDNUM)= 9 - I GOTO 5050 ENDIF 5040 CONTINUE 5050 CONTINUE C C WRITE THE DE SEQUENCE NUMBER AT THE BEGINNING OF THE OUTPUT DE RECORD C NUDAT=NEWDAT(10) ENCODE(LFLD(10)+1,5930,NEWDE(1:LFLD(10)+1)) NUDAT(9-LFLD(10):8) CHRPTR = LFLD(10) + 2 C C SEARCH NEW DE RECORD SET FOR CHANGED DATA; WHEN FOUND WRITE CHANGED C DATA TO OUTPUT DE RECORD... C DO 5060 FLDNUM=1,20 C C SKIP FIELDS THAT NO LONGER NEED PROCESSING... C IF ((FLDNUM.EQ. 2).OR. + (FLDNUM.EQ.10).OR. + (FLDNUM.EQ.11).OR. + (FLDNUM.EQ.20)) GOTO 5060 IF (NEWDAT(FLDNUM).NE.LSTDAT(FLDNUM)) THEN IF (FLDNUM.GT.9) THEN ENCODE(4,5940,NEWDE(CHRPTR:CHRPTR+3)) FLDNUM CHRPTR=CHRPTR+4 ELSE ENCODE(3,5950,NEWDE(CHRPTR:CHRPTR+2)) FLDNUM CHRPTR=CHRPTR+3 ENDIF IF (LFLD(FLDNUM).NE.0) THEN IF (FLDNUM.NE.9) THEN READ(NEWDAT(FLDNUM)(9-LFLD(FLDNUM):8),5960) + NEWDE(CHRPTR:CHRPTR-1+LFLD(FLDNUM)) CHRPTR=CHRPTR+LFLD(FLDNUM) ELSE C C FIELD 9 IS A SPECIAL CASE... C READ(NEWDAT(9)(1:8),5960) NEWDE(CHRPTR:CHRPTR+7) CHRPTR=CHRPTR+8 ENDIF ENDIF ENDIF C C STORE DATA FROM CURRENT DE RECORD SET TO COMPARE WITH NEXT SET C LSTDAT(FLDNUM)=NEWDAT(FLDNUM) 5060 CONTINUE NEWDE(CHRPTR:CHRPTR) = SCOLN C C IF OUTPUT DE RECORD > 80 CHAR'S, WRITE 2 LINES... C IF (CHRPTR.GT.80) THEN DO 5070 I=1,11 IF (NEWDE(82-I:82-I).EQ.'@') GOTO 5080 5070 CONTINUE 5080 WRITE(1,5970)NEWDE(1:81-I) NEWDE(1:80)=NEWDE(82-I:161-I) ENDIF WRITE(1,5900) NEWDE(1:80) C C ERASE UNNECESSARY DATA FROM PD RECORD AND WRITE TO OUTPUT FILE; C DO 5090 IL=1,PDCNT READ (2,5900,REC=PDPTR) PDLINE PDPTR = PDPTR+1 PDLINE(65:80) = ' ' WRITE(1,5900) PDLINE 5090 PDLINE(1:80) = ' ' C C END OF LOOP GET NEXT DE RECORD... C GOTO 5010 5100 CONTINUE RETURN C C FORMATS C 5900 FORMAT(A80) 5910 FORMAT(I8) 5920 FORMAT(A8) 5930 FORMAT ('D',A) 5940 FORMAT('@',I2,'_') 5950 FORMAT('@',I1,'_') 5960 FORMAT(A) 5970 FORMAT(A<81-I>) C END C************************************************************************** C SUBROUTINE CMPRES(OUTFIL) C C START OF SUBROUTINE C C PROGRAM ORIGINALLY WRITTEN BY J. M. SPAETH 7-24-84 C GENERAL ELECTRIC CORP. RE. & DEV. C REVISED BY LEE KLEIN 8-7-86 C GENERAL DYNAMICS CAD/CAM POMONA DIV. C REVISED BY ROBERT COLSHER 22 AUG 1986 C IGES DATA ANALYSIS COMPANY C C PURPOSE: C TO CLEAR AWAY ALL TRAILING BLANKS FROM THE OUTPUT FILE C C VARIABLE DECLARATIONS... C CHARACTER * 80 TEXT CHARACTER * (*) OUTFIL INTEGER LENGTH C C REWIND THE INPUT FILE AND OPEN THE OUTPUT FILE C REWIND 1 OPEN (UNIT=4,NAME=OUTFIL,STATUS='NEW',CARRIAGECONTROL='LIST', + ERR=6000) GOTO 6010 C C GETS HERE IF THERE IS AN ERROR IN THE OUTPUT FILE NAME... C 6000 WRITE(*,6900)'Error in OUTPUT file name. Output written to file', + ' IGES.OUT' OPEN (UNIT=4,NAME='IGES.OUT',STATUS='NEW',CARRIAGECONTROL='LIST') C C READ RECORD LINES INTO BUFFER ONE AT A TIME... C 6010 READ(1,6910,END=6999) TEXT LENGTH = 80 C C GO THRU EACH LINE DELETING TRAILING BLANKS C 6020 IF (TEXT(LENGTH:LENGTH).NE.' ') GOTO 6030 LENGTH=LENGTH-1 IF (LENGTH.GT.1) GOTO 6020 C C WRITE PROCESSED LINES TO THE OUTPUT FILE C 6030 WRITE(4,6920) TEXT(1:LENGTH) C GOTO 6010 C 6999 CONTINUE RETURN C C FORMATS C 6900 FORMAT(1X,A,A) 6910 FORMAT(A80) 6920 FORMAT(A) C END