C* SMCHR - MOVE CHARACTERS C SUBROUTINE SMCHR (IV1, IS1, IV2, IS2, NCH) C LOGICAL*1 IV1(1), IV2(1) IF (NCH .LE. 0) RETURN DO 10 I=1, NCH IV2(IS2+I-1) = IV1(IS1+I-1) 10 CONTINUE RETURN END C* SFCHR - CHARACTER FILL C SUBROUTINE SFCHR (IV, IS, NCH, ICHR) C LOGICAL*1 IV(1), ICHR(2) IF (NCH .LE. 0) RETURN DO 10 I=1, NCH IV(IS+I-1) = ICHR(1) 10 CONTINUE RETURN END FUNCTION NIWIJ (I, J) C INTEGER*4 LOCF C NIWIJ - NUMBER OF INTEGER WORDS FROM I TO J C NIWIJ = (LOCF(J) - LOCF(I))/2 RETURN END C* ISPC - DETERMINE SPECIAL CHARACTER C C DETERMINE IF CHARACTER IS NUMBER, SPECIAL, OR LETTER C ICH IS GNXCH FORMAT. LEFT BYTE 0, RIGHT BYTE CHARACTER TO CHECK C VALUES RETURNED C -1 = ICH IS 0-9 C 0 = ICH IS A SPECIAL CHARACTER (*, &, ^ ETC.) C +1 = ICH IS A-Z C FUNCTION ISPC (ICH) ISPC = 1 IF (ICH.GE.48 .AND. ICH.LE.57) ISPC = -1 IF (ICH.GE.65 .AND. ICH.LE.90) ISPC = 0 RETURN END C PUTXT.FTN 13-SEP-77 15:20 SUBROUTINEPUTXT(BNAME,BEXT) PARAMETERDARTH=36,VADER=4 BYTEBNAME(DARTH),BEXT(VADER) LOGICALLDOT LDOT=.FALSE. NSEM=0 CONTINUE I=1 23000 IF(.NOT.(I.LE.DARTH))GOTO 23002 NEND=I IF(.NOT.(BNAME(I).EQ.1H ))GOTO 23003 GOTO 23002 23003 CONTINUE IF(.NOT.(BNAME(I).EQ.1H.))GOTO 23005 LDOT=.TRUE. GOTO 23006 23005 CONTINUE IF(.NOT.(BNAME(I).EQ.1H;))GOTO 23007 NSEM=I 23007 CONTINUE 23006 CONTINUE 23001 I=I+1 GOTO 23000 23002 CONTINUE IF(.NOT.(.NOT.LDOT))GOTO 23009 MEND=0 CONTINUE J=1 23011 IF(.NOT.(J.LE.VADER))GOTO 23013 IF(.NOT.(BEXT(J).EQ.1H ))GOTO 23014 GOTO 23013 23014 CONTINUE MEND=J 23012 J=J+1 GOTO 23011 23013 CONTINUE IF(.NOT.(MEND.GT.0))GOTO 23016 KPUT=NEND-1 IF(.NOT.(NSEM.GT.0))GOTO 23018 CONTINUE K=MIN(KPUT,DARTH-MEND) 23020 IF(.NOT.(K.GE.NSEM))GOTO 23022 BNAME(K+MEND)=BNAME(K) 23021 K=K-1 GOTO 23020 23022 CONTINUE KPUT=NSEM-1 23018 CONTINUE CONTINUE M=1 23023 IF(.NOT.(M.LE.MIN(MEND,DARTH-KPUT)))GOTO 23025 BNAME(KPUT+M)=BEXT(M) 23024 M=M+1 GOTO 23023 23025 CONTINUE NEND=MIN(MEND+NEND,DARTH) 23016 CONTINUE 23009 CONTINUE BNAME(NEND)=0 RETURN END C* RVB - READ VIRTUAL BLOCK FROM DISK C SUBROUTINE RVB (ILUN, IBUF, NBLKS, NB, NERR) C C ILUN = LOGICAL UNIT NUMBER C IBUF = DATA BUFFER C NBLKS= NUMBER OF BLOCKS TO READ C NB = INTEGER*2 BLOCK NUMBER TO BEGIN TRANSFER C NERR = ERROR CODE +1 OK, ELSE BAD C DIMENSION IPARM(6), IOSTAT(2) BYTE BSTAT(4) EQUIVALENCE (IOSTAT, BSTAT) DATA IORVB/"10400/ C CALL GETADR (IPARM, IBUF) ! BUFFER ADDRESS IPARM(2) = NBLKS*512 ! NO. BYTES TO TRANSFER IPARM(4) = 0 ! HIGH BLOCK HALF IPARM(5) = NB ! LOW BLOCK HALF C CALL WTQIO (IORVB, ILUN, 1, , IOSTAT, IPARM, IDSW) C C CHECK ERROR CODES C IF (IDSW .GT. 0) GO TO 100 WRITE (6, 505) IDSW 505 FORMAT (' *** ERROR *** DSW =',I3) CALL EXIT C 100 CONTINUE NERR = BSTAT(1) NB = NB + NBLKS C RETURN END C* WVB - WRITE VIRTUAL BLOCK FROM DISK C SUBROUTINE WVB (ILUN, IBUF, NBLKS, NB, NERR) C C ILUN = LOGICAL UNIT NUMBER C IBUF = DATA BUFFER C NBLKS= NUMBER OF BLOCKS TO READ C NB = INTEGER*2 BLOCK NUMBER TO BEGIN TRANSFER C NERR = ERROR CODE +1 OK, ELSE BAD C DIMENSION IPARM(6), IOSTAT(2), IBUF(1) BYTE BSTAT(4) EQUIVALENCE (IOSTAT, BSTAT) DATA IOWVB/"11000/ C CALL GETADR (IPARM, IBUF) ! BUFFER ADDRESS IPARM(2) = NBLKS*512 ! NO. BYTES TO TRANSFER IPARM(4) = 0 ! HIGH BLOCK HALF IPARM(5) = NB ! LOW BLOCK HALF C CALL WTQIO (IOWVB, ILUN, 1, , IOSTAT, IPARM, IDSW) C C CHECK ERROR CODES C IF (IDSW .GT. 0) GO TO 100 WRITE (6, 505) IDSW 505 FORMAT (' *** ERROR *** DSW =',I3) CALL EXIT C 100 CONTINUE NERR = BSTAT(1) NB = NB + NBLKS C RETURN END C* CLRTAB - CLEAR TABS TO CORRECT COLUMNS + NOTE ! TYPE COMMENTS C SUBROUTINE CLRTAB (BUFIN, LFORT) C C -CALL CLRTAB (BUFIN, LFORT) C BUFIN - INPUT BUFFER OF 40 WORD LENGTH C LFORT - .TRUE. = USE FORTRAN TYPE TABS C .FALSE. = USE MOD 8 TABBING C C **NOTES** C 1) IF LFORT IS .TRUE. THEN C TAB FOLLOWED BY 0-9 IN COLS<=5 CONSTITUTES A C CONTINUATION AND IS MOVED TO COL 6. C TABS IN COMMENT CARDS USE MOD 8 ALGORITHM. C ALL OTHER TABS COME OUT AS 1 BLANK. C C BUFIN IS OVERLAYED WITH BLANK PADDED IMAGE C LFORT IS INPUT C IMPLICIT LOGICAL (L) IMPLICIT BYTE (B) C DIMENSION BUFF(80), BUFIN(80) DATA BTAB/9/ C J = 1 NEX = 0 CALL SFCHR (BUFF, 1, 80, ' ') LCMT = BUFIN(1) .EQ. 'C' .AND. LFORT LCMT = LCMT .OR. .NOT.LFORT C C SCAN INPUT RECORD C NC = IRNSC (BUFIN, 1, 80) DO 200 I=1, NC IF (.NOT.LCMT .AND. BUFIN(I).EQ.'!') GO TO 150 LTAB = BUFIN(I) .EQ. BTAB LCONT = BUFIN(I+1).GE.'1' .AND. BUFIN(I+1).LE.'9' .AND. J.LE.5 LCONT = LCONT .AND. .NOT.LCMT IF (.NOT.LTAB) GO TO 100 IF (LCMT) J = (J+7)/8*8 J = J + 1 IF (.NOT.LCMT .AND. J.LE.8) J = 7 IF (LCONT) J = 6 GO TO 200 C 100 CONTINUE IF (J .LE. 80) GO TO 120 WRITE (5, 520) BUFIN 520 FORMAT (' ATTEMPT TO EXPAND BEYOND 80 COLS'/' ',80A1, 1 /' [TERMINATING SCAN ON THIS RECORD]') GO TO 220 120 BUFF(J) = BUFIN(I) GO TO 190 C 150 CONTINUE LCMT = .TRUE. NEX = J 190 J = J + 1 200 CONTINUE C C ! TYPE COMMENTS ARE OVERLAYED WITH BLANKS C 220 IF (NEX .EQ. 0) GO TO 250 CALL SFCHR (BUFF, NEX, 81-NEX, ' ') C 250 CONTINUE CALL SMCHR (BUFF, 1, BUFIN, 1, 80) RETURN END C* INDIRECT FILE OPEN C SUBROUTINE INDOP (NIN, BSTR, NCH, IRCOD) C C NIN = LUN FOR INDIRECT FILE, AN ATTEMP WILL BE MADE TO CLOSE C ANYTHING PRESENTLY OPEN ON THIS LUN. C BSTR = FILENAME STRING TO CHECK (@). C NCH = NUMBER OF CHARACTERS IN STRING, MAX. C IRCOD = RETURN CODE, 1 IF INDIRECT OPENED, 0 IF NOT C IMPLICIT BYTE (B) BYTE BSTR(30), BTEMP(35) C DATA BTEMP/'S','Y','0',':',31*' '/ DATA BAT/'@'/, BCOL/':'/ C IRCOD = 0 IP = 5 IS = 0 DO 10 I = 1, NCH IF (BSTR(I) .EQ. BAT) IS = I IF (BSTR(I) .EQ. BCOL) IP = 1 10 CONTINUE IF (IS .LE. 0) RETURN C CALL SMCHR (BSTR, IS+1, BTEMP, IP, 35-IP) CALL PUTXT (BTEMP, '.CMD') CALL CLOSE (NIN) CALL FDBSET (NIN, 'READONLY') CALL ASSIGN (NIN, BTEMP) C IRCOD = 1 RETURN END SUBROUTINE LSTBV (IB, IV) C C LSTBV - SET BIT VECTOR (BIT SET TO 1) C DIMENSION IV(1) DATA NBPW/16/, MASK/1/ INDEX = IB/NBPW + 1 IBIT = IB - (INDEX-1)*NBPW IV(INDEX) = IOR(IV(INDEX), ISHFT(MASK,IBIT)) RETURN END