C* SFSIN - INPUT MAIN LINE TO SFSFV C SUBROUTINE SFSIN C LOGICAL LSWON, LTTIN INCLUDE 'SFSCM.FTN/NOLIST' C COMMON /LT/ LOTEM(15,5), LNTEM(5), NTEM C DIMENSION ICNTRL(4,20), ICNLN(20), JBUF(40), INAME(3,102) DIMENSION IEXCD(40),ICOM(3), IDATE(5), IPNAM(4) DIMENSION IFSPEC(40,102), ILUN(6) BYTE BJBUF(80) EQUIVALENCE (IVARI(2001),IFSPEC), (IVARI(7000),INAME) EQUIVALENCE (JBUF, BJBUF), (ILUN,INAME) DATA NCNTRL/13/, ICNLN /8, 8, 8, 8, 8, 6, 8, 5, 1, 8, 8, 8, 5, $ 7*0 / DATA ICNTRL / '*I','NC','LU','DE', '*E','XC','LU','DE', 1 '*N','OP','RI','NT', '*N','ON','AL','PH', 2 '*N','ON','FO','RT', '*N','OE','ND',' ', 3 '*H','EA','DI','NG', '*O','NL','Y ',' ', 4 '@ ',' ',' ',' ', '*L','OG','FI','LE', 5 '*N','OL','IS','T ', '*G','EN','IN','FI', 6 '*S','TM','T ',' ', 28*' ' / DATA IEXCD / 'EX','P ','LI','NK',' E','XI','T ','IF','IX', 1 ' S','IN',' C','OS',' S','QR','T ','IA','BS', 2 ' A','BS',' A','LO','G ', 17*' '/ DATA NEXCD /1/ DATA ICOM/'CO','MM','ON'/, IBLNK/ 32/, ISTAR/'C*'/ DATA IPNAM/'VA','RI','SF','S '/, IDOTE /'.E'/, IBLKS/' '/ DATA NIN,NOUT/5,6/, NINF/5/ 501 FORMAT (1H , 'INPUT TO SFS - SEARCH FORTRAN SOURCE',86X,5A2 /) 505 FORMAT (' SFS> '$) 520 FORMAT (1H1, 6X, 'FILES', 7X, 'NO. OF', 5X, 'RECORD' / $ 1H , 4X, 'CONSIDERED', 4X, 'RECORDS', 4X, 'OFFSET' / ) 525 FORMAT ( 1H , I2, 4X, 3A2, 6X, I5, 6X, I5, 8X, 36A2) 530 FORMAT (40A2) 540 FORMAT (' ',40A2 / ) 545 FORMAT ('+',36A2) 550 FORMAT (' **ERROR** UNABLE TO CREATE TEMP FILE ,LUN 2') 570 FORMAT (' **ERROR** ','MORE THAN ', I3,' FILE NAME CARDS,', $ '-',3A2,'- IS LAST FILE'/11X'READ IN') 580 FORMAT (' FILE? '$) 585 FORMAT (' **ERROR** UNABLE TO OPEN INDIRECT FILE-NAME FILE -'/ $ 11X, 80A1) 587 FORMAT (' **ERROR** EOF ENCOUNTERED ON INPUT BEFORE ANY FILE', $ ' NAMES READ') IPRNT(1) = 1 IPRNT(2) = 1 NALPH = 0 NOFOR = 0 NOEND = 0 IONLY = 0 IFOFN = 0 ILGFL = 0 ILPGM = 1 INCMN = 1 NTEM = 0 ISTMT = 0 CALL SIVFL (IBLKS, IHVEC, 36) CALL SIVFL (IBLKS, IFSPEC(1,102), 40) KOUNT = 1 MXVAR = 12000 MXNFL = 100 NFILE = 0 NRTOT = 0 INDX = 1 NFID = 1 NAVS = 1 CALL SIVFL (0, FID, 6) CALL SIVFL (0, FIDWS, 6) DO 50 I = 1, 27 IVARI(I) = 0 IPVEC(I) = I 50 CONTINUE NAVSV = 28 CALL FDBSET (NOUT,,,,,22) CALL GETLUN (NIN, ILUN) LTTIN = ILUN(1) .EQ. 'TT' CALL DATE (IDATE) WRITE (NOUT, 501) IDATE C READ CONTROL CARDS AND PROCESS 80 CONTINUE IF (LTTIN) WRITE (NIN, 505) READ (NIN, 530, END=303) JBUF INCLD = -1 DO 90 I=1,NCNTRL J = I*8 - 7 ISTRT = JCCHR (JBUF, 1, 80, ICNTRL, J, J-1+ICNLN(I), 3) IF (ISTRT) 90, 90, 110 90 CONTINUE GO TO 192 110 ISTRT = ISTRT + ICNLN(I) WRITE (NOUT, 540) JBUF C DELIMIT NAMES ON '*' CONTROL CARDS 115 CALL ICFGS (80, JBUF, ISTRT, IP) 120 CALL GNXCH (ICHR) IF (ICHR .LE. 0) GO TO (80, 80, 80, 183, 185, 187, 189, 80, 80, $ 195, 196, 80, 188, 180), I IF (ICHR .EQ. IBLNK) GO TO 120 IFRST = ICHR ISP = IP - 1 IEP = JCCHR (JBUF, ISP, 80, IBLNK, 1, 1, 3) - 1 IF (IEP .LE. 0) IEP = 80 ILEN = IEP - ISP + 1 GO TO (140, 160, 165, 183, 185, 187, 189, 169, 191, 195, 196, $ 197, 188, 170), I C BLANK OUT FUNCTION NAMES IN IEXCD TO BE INCLUDED 140 ISF = JCCHR (IEXCD, 1, NEXCD*80, JBUF, ISP, IEP, 3) IF (ISF .GT. 0) CALL SFCHR (IEXCD, ISF, ILEN, IBLNK) 150 ISTRT = IEP + 1 GO TO 115 C SET FLAG IF COMMON TO BE EXCLUDED 160 IF (JCCHR (JBUF, ISP, IEP, ICOM, 1, 6, 1) .NE. 2) GO TO 170 CALL SFCHR (JBUF, ISP, 6, IBLNK) INCMN = - 1 GO TO 150 C CHECK *NOPRINT RECORD FOR 'VARI' AND/OR 'SFS' 165 DO 168 K = 1, 2 L = JCCHR( IPNAM, 1, 7, JBUF, ISP, IEP, 3) IF (L .LE. 0) GO TO 168 L = L/4 + 1 IPRNT(L) = 0 168 CONTINUE GO TO 150 C *ONLY OPTION WILL BE FLAGGED BY -NAVSV 169 INCLD = 0 IONLY = 1 C INSERT VARIABLE NAME OR FUNCTION NAME INTO LIST OF VARIABLE NAMES 170 CALL SMCHR (JBUF, ISP, IBUF, 2, ILEN) IP = MIN0 (ILEN + 2, 17) CALL SFSIV (IP, IFRST) IF (IONLY .EQ. 1) GO TO 140 GO TO 150 C MOVE SYSTEM FUNCTION NAMES TO INPUT BUFFER TO FLAG FOR EXCLUSION 180 IF (KOUNT .GT. NEXCD) GO TO (205, 200),IFOFN+1 J = KOUNT*40 - 39 CALL SIVMV (IEXCD(J), JBUF, 40) KOUNT = KOUNT + 1 ISTRT = 1 GO TO 115 183 NALPH = 1 GO TO 80 185 NOFOR = 1 GO TO 80 187 NOEND = 1 GO TO 80 188 ISTMT = 1 GO TO 80 189 CALL SIVFL (IBLKS, IHVEC, 36) J = IRNSC (JBUF, 1, 80) - ISTRT + 1 CALL SMCHR (JBUF, ISTRT, IHVEC, (72-J)/2, J) GO TO 80 C OPEN INDIRECT FILE FOR FILE-NAME INPUT 191 IFOFN = 1 CALL PUTXT (BJBUF(ISP), '.CMD') NINF = 1 OPEN (UNIT=NINF, NAME=BJBUF(ISP), TYPE='OLD', READONLY, $ ERR=301) GO TO 193 C C FIRST FILE NAME ALREADY READ IN C 192 CALL SMCHR (JBUF, 1, IFSPEC, 1, 80) 193 I = NCNTRL + 1 GO TO 180 195 ILGFL = 1 CALL SFSLT (ISTRT, JBUF) GO TO 80 196 ILPGM = 0 GO TO 80 197 CALL SMCHR (JBUF, ISP, IFSPEC(1,102), 1, MIN0(ILEN,80)) GO TO 80 200 CONTINUE IF (LTTIN) WRITE (NIN, 580) READ (NINF, 530, END=210) (IFSPEC(J,NFILE+1),J=1,40) IF (IRNSC(IFSPEC(1,NFILE+1), 1, 80) .LE. 0) GO TO 210 205 CONTINUE IF (IFOFN.EQ.1 .AND. LTTIN) WRITE (NIN, 545) $ (IFSPEC(J,NFILE+1),J=1,36) NFILE = NFILE + 1 IF (NFILE .GT. MXNFL) GO TO 295 GO TO 200 C SORT FILE NAMES 210 CONTINUE IF (IFOFN .EQ. 1) CLOSE (UNIT=NINF) CALL SFSLF IF (NFILE.EQ.1) GO TO 240 IF (NALPH.EQ.1) GO TO 240 N = NFILE - 1 DO 230 I=1, N K = NFILE - I DO 220 J = 1, K IF (JCCHR (INAME(1,J), 1, 6, INAME(1,J+1), 1, 6, 1) - 2) $ 220, 220, 215 215 CALL SIVMV (INAME(1,J), JBUF, 3) CALL SIVMV (INAME(1,J+1), INAME(1,J), 3) CALL SIVMV (JBUF, INAME(1,J+1), 3) ITEMP = NRFIL(J) NRFIL(J) = NRFIL(J+1) NRFIL(J+1) = ITEMP ITEMP = NROFS(J) NROFS(J) = NROFS(J+1) NROFS(J+1) = ITEMP 220 CONTINUE 230 CONTINUE 240 CONTINUE WRITE (NOUT, 520) NSKIP = 0 DO 260 I = 1, NFILE J = MIN0 (6, NRFIL(I)) NR = 1 + NROFS(I) DO 253 K = 1, J CALL SFS1DR (FID(1,1), NR, 40, JBUF) IF (ILGFL .EQ. 1) GO TO 255 IF (JBUF(1) .EQ. ISTAR) GO TO 255 253 CONTINUE CALL SIVFL (IBLKS, JBUF, 40) 255 WRITE (NOUT, 525) I, (INAME(J,I),J=1,3), NRFIL(I), NROFS(I), $ (JBUF(K),K=1,36) 260 CONTINUE C SET UP WS FILE FOR FILE NAMES + VARIABLE NAME LIST(TEMP FILE) OPEN (UNIT=2, TYPE='SCRATCH', INITIALSIZE=260, BUFFERCOUNT=-1) CALL SFS1LU (FIDWS, BUFWS, 08, , 0, 2, 2, NERC1) IF (NERC1.NE.0) GO TO 300 MXNAV = 32766 NW = 3*NFILE + MOD(NFILE,2) CALL SFS1DW (FIDWS, NAVS, NW, INAME) INCLD = 1 IF (IONLY .EQ. 1) NAVSV = -NAVSV IF (ILPGM .EQ. 1) CALL SFSLP (INAME) CTEMP IF (ILGFL.EQ.1 .AND. INAME(1,102).NE.IBLKS) CALL SFSLS(INAME) IF (IPRNT(1).EQ.0 .AND. IPRNT(2).EQ.0) GO TO 310 RETURN 295 WRITE (NIN, 570) MXNFL, (INAME(I,MXNFL),I=1,3) GO TO 310 300 WRITE (NIN, 550) GO TO 310 301 WRITE (NIN, 585) (BJBUF(J),J=ISP,80) GO TO 310 303 WRITE (NIN, 587) 310 CALL SFSEX END