C PROTEIN DATA BANK SOURCE CODE DRCTRY C AUTHOR. E.ABOLA C ENTRY DATE. 1/84 SUPPORTED C LAST REVISION. 7/86 C PURPOSE. PDB DISTRIBUTION TAPE DIRECTORY C LANGUAGE. FORTRAN 77,RSX11M VERSION 4.0 C C C C C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C DRCTRY.FTN C C AUTHOR- ENRIQUE E. ABOLA C PROTEIN DATA BANK C CHEMISTRY DEPARTMENT C BROOKHAVEN NATIONAL LABORATORY C UPTON, N.Y. 11973 C C DATE- 01/05/84 C C COPYRIGHT, BROOKHAVEN NATIONAL LABORATORY C C THE PROTEIN DATA BANK IS SUPPORTED BY GRANTS FROM THE C U.S. NATIONAL SCIENCE FOUNDATION AND THE U.S. NATIONAL C INSTITUTES OF HEALTH. BROOKHAVEN NATIONAL LABORATORY IS C OPERATED UNDER CONTRACT WITH THE U.S. DEPARTMENT OF ENERGY. C C PURPOSE- C PROGRAM DRCTRY WILL PRODUCE A DIRECTORY OF A PROTEIN DATA C BANK DISTRIBUTION TAPE. C C I/O FILES- C C UNIT NUMBER FILE USAGE C C 1 PDB ENTRY FILES C 3 INTERMEDIATE DIRECTORY FILE C 5 CONSOLE MESSAGE FILE C 5 CONSOLE INPUT C 6 PRINT FILE C C INPUT PARAMETERS- C C FILNAM FILE NAME TO BE USED FOR INTERMEDIATE C DIRECTORY FILE C DIRTYP TYPE OF DIRECTORY LISTING (BRIEF OR FULL) C RDUNT TAPE DRIVE UNIT NUMBER (0/1) C TAPLAB TAPE VISUAL LABEL C C OUTPUT- C C TWO OUTPUT DIRECTORY FILES ARE PRODUCED BY DRCTRY. C THE FILE DRCTRYOUT.LST IS A LINE-PRINTER LISTING OF C THE DIRECTORY. A BRIEF AND A FULL LISTING OF THE DIRECTORY C IS POSSIBLE. AN INTERMEDIATE DIRECTORY FILE IS STORED C UNDER THE USER-PROVIDED NAME, FILNAM. THIS FILE IS C USED TO SAVE ALL THE PARAMETERS NEEDED BY THE PRINT C ROUTINE. IT ALSO COULD BE USED AS A DIRECTORY FILE FOR C INPUT TO APPLICATION PROGRAMS WHICH REQUIRE THE CONTENTS C OF THE DISTRIBUTION TAPE. C C CONTENTS OF THE PRINT FILE- C C A. BRIEF LISTINGS (80 COLUMNS)- C EACH LINE CONTAINS THE FOLLOWING: C FILE NUMBER C IDCODE C ENTRY NAME (EITHER PROGRAM OR COMPOUND NAME) C NUMBER OF RECORDS IN THE FILE C C B. FULL LISTINGS (132 COLUMNS)- C EACH LINE CONTAINS THE FOLLOWING: C FILE NUMBER C IDCODE C ENTRY NAME (EITHER PROGRAM OR COMPOUND NAME) C NUMBER OF RECORDS IN THE FILE C ACCESSION DATE C DATE OF LAST MAJOR REVISION C MODIFICATION TYPE DONE ON THE LAST MAJOR REVISION C TYPE (2) IS FOR CORRECTIONS ON CONECT RECORDS. C TYPE (3) IS FOR CORRECTIONS AFFECTING THE C COORDINATES OR THEIR TRANSFORMS. C TYPE BLANK IS USED TO INDICATE THAT NO MAJOR C REVISIONS HAVE BEEN NEEDED, AND C THAT THE DATE OF LAST MAJOR REVISION C IS THE DATE THE ENTRY WAS RELEASED C FOR DISTRIBUTION. C C COMMENTS- C C THIS IS A PRELIMINARY RELEASE OF DRCTRY. C THE PROGRAM RUNS INTERACTIVELY AND WAS WRITTEN FOR A C PDP 11 RUNNING UNDER RSX11M VERSION 4.0 USING THE C FORTRAN 77 COMPILER. C C EXTENSIVE CHECKING ON OTHER MACHINES HAS NOT BEEN DONE. C ANY ERRORS SHOULD BE REPORTED AS SOON AS POSSIBLE. C THE CODE IN THE TAPE UTILITY PORTION OF THE PROGRAM C IS MACHINE SPECIFIC. C C A PRINT FILE IS PRODUCED IN SUBROUTINE PRNDIR AND IS C STORED IN THE FILE DRCTRYOUT.LST. AN ASCII FORMATTED FILE C IS ALSO PRODUCED AND IS STORED WITH THE NAME GIVEN AS AN C INPUT PARAMETER. C C TASK BUILD DIRECTIVES (FOR RSX11M)- C C IN THE FOLLOWING THE STRING $( SHOULD BE REPLACED BY LEFT SQUARE C BRACKET AND THE STRING $) BY RIGHT SQUARE BRACKET. C C DRCTRY/FP/CP,DRCTRY/-SP=DRCTRY,$(1,1$)F77OTS/LB C / C ASG=TI:5,SY:3:6 C // C C REVISIONS- C C CORRECTION TO PROPERLY OPEN AND CLOSE *FOREIGN* TAPE FILES C 31-MAY-84 C C CORRECTION. INSERT MISSING ENTRY POINT. C C C--------------------------------------------------------------------- C PROGRAM DRCTRY C C PDB RECORD C CHARACTER*80 IBUF C C ENTRY IDCODE C CHARACTER*4 IDCODE C C COMPOUND/PROGRAM NAME C CHARACTER*86 ENTNAM C C MODIFICATION TYPE C CHARACTER*1 REVTYP C C ACCESSION DATE AND REVISION DATE C CHARACTER*9 ACCDAT,REVDAT C C IDCODE FOR NON-COORDINATE ENTRY C CHARACTER*4 SOURCE DATA SOURCE/'SRCE'/ C C RETURN CODE C INTEGER IRTN C C FILE SIZE IN RECORDS C INTEGER*4 ISIZE C C OUTPUT DIRECTORY FILE NAME C CHARACTER*40 FILNAM C C NUMBER OF FILES C INTEGER NUMFLE C C FIRST RECORD FLAG C LOGICAL FIRST C C HVCHSN TO BE USED FOR PICKING THE LATEST REVDAT C LOGICAL HVCHSN C C DIRECTORY TYPE (BRIEF/FULL) C CHARACTER*5 DIRTYP C C TAPE CHARACTERISTICS C C LOGICAL UNIT NUMBER (LUN) TO BE USED FOR TAPE C AND A TAPE LABEL (FOR VISUAL IDENTIFICATION AND SHOULD NOT C BE CONFUSED WITH INTERNAL TAPE LABELS. THE PDB DISTRIBUTION TAPE IS C UNLABELLED). C INTEGER RDLUN DATA RDLUN/1/ CHARACTER*8 TAPLAB DATA TAPLAB/' '/ C C RECORD AND MAXIMUM BLOCK SIZE C INTEGER RECSIZ,BLKSIZ DATA RECSIZ/80/,BLKSIZ/4800/ C C SET TO READ FOREIGN FILE C CHARACTER*6 FILTYP DATA FILTYP/'FOREGN'/ C C WHICH TAPE UNIT C INTEGER RDUNIT C C TAPE STATUS CODES C INTEGER IEEOF,IEEOV DATA IEEOF/-10/,IEEOV/-11/ C INTEGER MESSG,INPT DATA MESSG/5/,INPT/5/ C WRITE(MESSG,1000) 1000 FORMAT(' PROTEIN DATA BANK DIRECTORY PROGRAM....') WRITE(MESSG,1010) 1010 FORMAT('$ENTER OUTPUT DIRECTORY FILENAME-') READ(INPT,'(A)') FILNAM C C ASK FOR FULL OR BRIEF DIRECTORY C WRITE(MESSG,1012) 1012 FORMAT('$ENTER DIRECTORY TYPE- (BR)IEF/(FU)LL-') READ(INPT,'(A)')DIRTYP C OPEN(UNIT=6,FILE='DRCTRYOUT.LST',FORM='FORMATTED',STATUS='NEW') OPEN(UNIT=3,FILE=FILNAM,STATUS='NEW',FORM='FORMATTED') C C SET THE TAPE TO BE READ C WRITE(MESSG,1015) 1015 FORMAT('$ENTER TAPE UNIT NUMBER (0/1)-') READ(INPT,*)RDUNIT C WRITE(MESSG,1016) 1016 FORMAT('$ENTER A TAPE LABEL TO BE USED IN THE TITLE (8-CHAR.)-') READ(INPT,'(A)') TAPLAB CALL SETRFL(RDLUN,FILTYP,RDUNIT,RECSIZ,BLKSIZ) CALL OPEN(' ',1,IRTN) C C LOOP UNTIL THE END OF VOLUME HAS BEEN REACHED C NUMFLE=0 C C RESET FILE PARAMETERS FOR EACH NEW FILE C 5 ISIZE=0 FIRST=.TRUE. HVCHSN=.FALSE. ACCDAT=' ' REVDAT=' ' ENTNAM=' ' ILFT=86 IST=1 C C LOOP UNTIL AN EOF HAS BEEN REACHED C 10 IF(NXTLNE(IBUF,IRTN) .LT. 0 ) GO TO 100 IF(FIRST) THEN FIRST=.FALSE. IF(IBUF(1:6).EQ.'HEADER') THEN C C WE HAVE A COORDINATE/BIB ENTRY C NUMFLE=NUMFLE+1 IDCODE=IBUF(63:) ACCDAT=IBUF(51:) ELSE C C LOOK FOR THE FIRST NON-BLANK CHARACTER C NUMFLE=NUMFLE +1 IDCODE=SOURCE DO 12 J=2,80 IF(IBUF(J:J).NE. ' ') GO TO 14 12 CONTINUE 14 IFIN=MIN0(80,J+39) ENTNAM(1:40)=IBUF(J:IFIN) END IF END IF C IF(IBUF(1:6).EQ.'COMPND'.AND. ILFT .GT. 0 .AND. 1 IDCODE .NE. SOURCE)THEN C C SAVE THE COMPOUND NAME C J=71 16 J=J-1 IF(IBUF(J:J).EQ.' ') GO TO 16 LEN=MIN0((J-11)+1,ILFT) ILST=(11+LEN)-1 ENTNAM(IST:)=IBUF(11:ILST) IST=IST+LEN ILFT=86-IST+1 C ELSE IF(IBUF(1:6).EQ.'REVDAT'.AND. .NOT. HVCHSN)THEN C C SAVE THE LATEST REVISION DATE C IF(IBUF(32:32).NE.'1')THEN REVDAT=IBUF(14:) REVTYP=IBUF(32:32) HVCHSN=.TRUE. END IF END IF C C KEEP TRACK OF THE FILE SIZE C ISIZE=ISIZE + 1 C C LOOP BACK C GO TO 10 C C EOF OR END OF VOLUME C 100 IF(IRTN .EQ. IEEOF) THEN CALL WRTDIR(NUMFLE,IDCODE,ENTNAM,ACCDAT,REVDAT,REVTYP,ISIZE) CALL CLOSE(IRTN) C C POSITION THE TAPE TO THE NEXT FILE C CALL OPEN(' ',-1,IRTN) GO TO 5 C ELSE IF (IRTN .EQ. IEEOV) THEN C C END OF VOLUME C CALL PRNDIR(6,DIRTYP,TAPLAB) STOP C ELSE C C WAS NOT EOF OR END OF VOLUME. C TELL THE USER ABOUT IT AND QUIT. C WRITE(MESSG,1020)IRTN 1020 FORMAT(' ERROR WHILE READING THE TAPE ---',I5) STOP END IF END SUBROUTINE PRNDIR(LUN,DIRTYP,TAPLAB) C C ROUTINE TO PRODUCE A LINEPRINTER DIRECTORY LISTING C C TYPE OF LISTING (BRIEF OR FULL) C CHARACTER*5 DIRTYP C C A TAPE LABEL FOR IDENTIFICATION C NOT TO BE CONFUSED WITH INTERNAL TAPE LABELS C THE PROTEIN DATA BANK DISTRIBUTION TAPE IS UNLABELLED C CHARACTER*8 TAPLAB C C ACCESSION AND REVISION DATES C AND THE DATE THIS JOB WAS RUN C CHARACTER*9 ACCDAT,REVDAT CHARACTER*9 IDTE CHARACTER*1 REVTYP C C UNIT NUMBER TO BE USED FOR WRITING THE PRINT FILE C THIS IS NORMALLY SET TO 6 C INTEGER LUN C C ENTRY NAME AND ITS IDCODE C CHARACTER*86 ENTNAM,CURID*4 C C NUMBER OF RECORDS IN THE FILE C INTEGER*4 NUMREC DATA IOUT/3/ C C LOCAL VARIABLE TO BE USED FOR SKIPPING A LINE C BETWEEN PROGRAM SOURCE AND BIB ENTRIES C LOGICAL INBIB C INBIB=.FALSE. C C SYSTEM SUPPLIED DATE FUNCTION C THIS ROUTINE RETURNS A 9-CHARACTER DATE OF THE FORM DD-MON-YY C CALL DATE (IDTE) C REWIND IOUT C C PRINT THE LISTING HEADERS C IF(DIRTYP(1:2).EQ.'BR')THEN WRITE(LUN,110)TAPLAB,IDTE 110 FORMAT(1H1,'TABLE OF CONTENTS FOR PROTEIN DATA BANK' 1 ' DISTRIBUTION TAPE',2X,A8, 1 T71,A9,//,' FILE' 2 T7,'IDCODE',T42,'DESCRIPTION',T73, 3 'NO. OF',/,' NO.',T73,'RECORDS',//) C ELSE IF (DIRTYP(1:2).EQ.'FU')THEN WRITE(LUN,112)TAPLAB,IDTE 112 FORMAT(1H1,'TABLE OF CONTENTS FOR PROTEIN DATA BANK' 1 ' DISTRIBUTION TAPE',2X,A8, 1 T124,A9,//,' FILE' 2 T7,'IDCODE',T51,'DESCRIPTION',T100,'NO. OF ', 3 T109,'ACCESSION',T120,'LAST REVISION',/, 4 ' NO.',T100,'RECORDS',T112,'DATE',T120,'(MODIFICATION', 5 /,T125,'TYPE)',/) END IF C C LOOP THROUGH THE INTERMEDIATE DIRECTORY FILE, READ ITS C CONTENTS AND REFORMAT IT FOR PRINTING C 5 READ(3,150,END=140)IPG,CURID,ENTNAM,NUMREC,ACCDAT,REVDAT,REVTYP 150 FORMAT(I,A,A,I,A,A,A) C C SKIP A LINE BETWEEN PROGRAM SOURCE AND BIB ENTRIES, AND C BETWEEN BIB ENTIRES AND COORDINATE ENTRIES C IF(CURID(1:1).EQ.'0' .AND. .NOT.INBIB) THEN INBIB=.TRUE. WRITE(LUN,'(1X)') ELSE IF(CURID(1:1).NE.'0'.AND.INBIB)THEN INBIB=.FALSE. WRITE(LUN,'(1X)') END IF C C TWO TYPES OF DIRECTORY LISTING CAN BE PRODUCED C EITHER A BRIEF OR A FULL LISTING. C C BRIEF LISTING USES ONLY 80 COLUMNS C IF(DIRTYP(1:2).EQ.'BR')THEN WRITE(LUN,120)IPG,CURID,ENTNAM(1:58),NUMREC 120 FORMAT(1X,I3,'.',T7,A4,T12,A58,T72,I8) C C FULL LISTING USES 132 COLUMNS C ELSE IF(DIRTYP(1:2).EQ.'FU')THEN C C IF THE MODIFICATION TYPE IS 0, WHICH MEANS THAT REVDAT REFERS TO C RELEASE DATE, THEN A MODIFICATION TYPE IS NOT PRINTED. C IF(REVTYP .EQ.'0'.OR. REVDAT .EQ.' ')THEN WRITE(LUN,124)IPG,CURID,ENTNAM,NUMREC,ACCDAT,REVDAT 124 FORMAT(1X,I3,'.',T8,A4,T14,A86,T102,I5,T109,A9,T120,A9) ELSE WRITE(LUN,122)IPG,CURID,ENTNAM,NUMREC,ACCDAT,REVDAT,REVTYP 122 FORMAT(1X,I3,'.',T8,A4,T14,A86,T102,I5,T109,A9,T120,A9, . ' (',A1,')') END IF C END IF C C LOOP BACK C GO TO 5 C C A FOOTNOTE TO EXPLAIN THE MODIFICATION TYPES C 140 IF(DIRTYP(1:2).EQ.'FU')THEN WRITE(LUN,126) 126 FORMAT(///, 1 ' MODIFICATION TYPE (2) IS FOR CORRECTIONS ON', 1 ' CONECT RECORDS.',/,' MODIFICATION TYPE (3) IS FOR', 2 ' CORRECTIONS AFFECTING THE COORDINATES OR THEIR', 3 ' TRANSFORMS.',//, 4 ' WHEN THE MODIFICATION TYPE IS NOT PRINTED --', 5 ' CORRESPONDS TO MODIFICATION TYPE (0) -- THE LAST', 6 ' REVISION DATE IS THE DATE THE',/,' DATA WERE', 7 ' RELEASED FOR DISTRIBUTION.',//,' MODIFICATION TYPE', 8 ' (1) -- FOR WHICH NEITHER LAST REVISION DATE NOR', 9 ' MODIFICATION TYPE IS PRINTED -- IS', 1 ' RESERVED FOR MISCELLANEOUS',/,' CORRECTIONS, MAINLY', 2 ' TYPOGRAPHICAL IN NATURE.',//, 3 ' FOR FULL DETAILS, SEE THE PROTEIN DATA BANK', 4 ' ATOMIC COORDINATE ENTRY FORMAT DESCRIPTION', 5 ' DOCUMENT.') END IF RETURN END SUBROUTINE WRTDIR(CURPGE,CURID,ENTNAM,ACCDAT, 1 REVDAT,REVTYP,NUMREC) C C ROUTINE TO PRODUCE AN INTERMEDIATE DIRECTORY FILE C C C MODIFICATION TYPE C CHARACTER*1 REVTYP C C ACCESSION AND REVISION DATES C CHARACTER*9 ACCDAT,REVDAT C C NUMBER OF RECORDS IN A FILE C INTEGER*4 NUMREC C C IDCODE AND ENTRY NAME C CHARACTER*4 CURID,ENTNAM*86 C C FILE NUMBER C INTEGER CURPGE C WRITE(3,100)CURPGE,CURID,ENTNAM,NUMREC,ACCDAT,REVDAT,REVTYP 100 FORMAT(I,A,A,I,A,A,A) RETURN END C C A COLLECTION OF ROUTINES TO READ AND WRITE PDB ENTRIES C THESE ROUTINES CAN BE USED TO FACILITATE I/O ON THE PDB C DISTRIBUTION TAPE C C THESE ROUTINES HAVE BEEN WRITTEN IN FORTRAN-77. C THE SYSTEM DEPENDENT CODE IS FOR RSX11M V 4.0. C CONVERSION FOR USE IN A VAX/VMS ENVIRONMENT SHOULD BE TRIVIAL. C SEE THE FORTRAN USER'S MANUAL FOR DETAILS. (CHAPTER 6 AND C APPENDIX D) C C USE OF COMMON AREAS TO COMMUNICATE PARAMETERS BETWEEN MODULES C HAS BEEN AVOIDED AS MUCH AS POSSIBLE. ALTERNATIVELY, A NUMBER OF C ENTRY POINTS HAVE BEEN PROVIDED TO EITHER EXAMINE OR SET REQUIRED C PARAMETERS. C C ROUTINES WITH NAMES STARTING WITH SET ARE USED TO SET A PARAMETER C AND THOSE STARTING WITH SHW ARE USED TO EXAMINE THE C PARAMETERS. C C THE USE OF THE FORTRAN CONSTRUCT ENTRY HAS BEEN USED FOR EASE IN C PROGRAMMING. THESE ENTRIES COULD BE CHANGED TO SEPARATE SUBROUTINES, C IF DESIRED, AND THE REQUIRED PARAMETERS COULD BE SET OR EXAMINED BY C THE SET/SHW ROUTINES. C C THE ENTRY POINTS IN THE SUBROUTINE REDUTL COMMUNICATE DIRECTLY TO THE C SYSTEM I/O PROCESSOR BYPASSING THE FILE CONTROL SERVICES (FCS). C THIS ALLOWS ONE TO READ UNKNOWN FILE STRUCTURES. THE ROUTINE C SETRFL MUST BE CALLED PRIOR TO ANY ACTUAL I/O TO THE DATA TAPE. C THE PURPOSE OF SETRFL IS TO SET THE FILE STRUCTURE. C SUBROUTINE SETRFL(ILUN,WANTYP,RDUNT,ISIZ,KSIZ) C C SET THE READ-FILE PARAMETERS AND MAINTAIN THE RDLUN, FILTYP C C PARAMETERS C C ILUN -INTEGER - LOGICAL UNIT NUMBER TO BE USED IN READING C (E.G. READ(ILUN,100) IBUF) C WANTYP-CHARACTER*6 - SET THIS PARAMETER TO EITHER FILE11 (FOR C FILES-11 FILES) OR FOREGN FOR THE UNLABELLED C DISTRIBUTION TAPE C RDUNT -INTEGER - UNIT NUMBER IN CASE OF MULTIPLE TAPE DRIVES C ISIZ -INTEGER - RECORD SIZE (NORMALLY 80) C KSIZ -INTEGER - BLOCK SIZE (MAXIMUM ALLOWED IS 4800) C C LOGICAL UNIT NUMBER FOR READING (FILE11 OR FOREGN) C INTEGER RDLUN C C IS IT A FILES-11 OR FOREIGN-TYPE FILE C CHARACTER*6 FILTYP C C READ UNIT NUMBER (I.E. 0 FOR MT0:) C INTEGER RDUNT C C DUMMY CHARACTER VARIABLE FOR USE BY ENTRY POINT SHWTYP C CHARACTER*6 WANTYP INTEGER ILUN,ISIZ,KSIZ C BLKSIZ=KSIZ RECSIZ=ISIZ RDLUN=ILUN FILTYP=WANTYP IF(FILTYP .EQ. 'FILE11')THEN C C WE DO NOT HAVE TO DO ANYTHING HERE. C ITS PURPOSE IS TO SET THE FILE TYPE. C RETURN C ELSE IF(FILTYP .EQ. 'FOREGN') THEN C C UNLABELLED TAPE WILL BE USED C GET THE DEVICE NAME C CALL ASNLUN(RDLUN,'MT',RDUNT) CALL SETRDS RETURN C ELSE C C NO OTHER FILE TYPE IS ALLOWED C WRITE(5,10)FILTYP 10 FORMAT(' THE FILE TYPE --',A,' IS NOT ALLOWED') STOP ' ERROR IN SETRFL' END IF C****************************************************************** C * C USER WANTS TO KNOW WHAT THE FILTYP HAS BEEN SET TO * C * C****************************************************************** ENTRY SHWTYP(WANTYP) WANTYP=FILTYP RETURN C****************************************************************** C * C USER WANTS TO KNOW THE READ LUN * C * C****************************************************************** ENTRY SHWRLN(ILUN) ILUN=RDLUN RETURN C****************************************************************** C * C USER WANTS TO KNOW RECORD AND BLOCK SIZE * C * C****************************************************************** ENTRY SHWSZE(ISIZ,KSIZ) ISIZ=RECSIZ KSIZ=BLKSIZ RETURN C END SUBROUTINE REDUTL C C ENTRY POINTS FOR ROUTINES THAT TALK DIRECTLY TO THE DEVICE C WITHOUT USING THE SERVICES OF FCS C C THIS CODE IS SYSTEM-SPECIFIC FOR RSX11M V 4.0 AND SHOULD BE C REPLACED TO RUN ON OTHER SYSTEMS. C C A POINTER IS MAINTAINED TO THE FILE NUMBER TO WHICH THE C TAPE HAS BEEN MOVED. C C SETRDS -- SET THE TAPE CHARACTERISTICS C AND ATTACH IT FOR READING C SKPFLS(NFILES,RTC) -- SKIP NFILES TAPE MARKS C GETBUF(BUFPTR,BUFFER,NBYTES,RTC) -- GRAB A BUFFER FULL OF C DATA C CLSRTP(RTC) -- UPDATE FILNUM AND IF NECESSARY C SKIP TO THE NEXT TAPE MARK TO C POSITION TO THE NEXT FILE C REDDMO -- REWIND AND DISMOUNT A READ TAPE C THIS ROUTINE ALSO ISSUES AN IODET C DIRECTIVE C SHWFLN(INUM) -- SHOW THE CURRENT FILE NUMBER C C READ DEVICE PARAMETERS TO BE USED BY THE QIO CALLS C C STATUS OF LAST I/O CALL C INTEGER RDSTAT(2) C C ERROR CODE IS IN RDERR(1) C THROUGH EQUIVALENCE C BYTE RDERR(2) EQUIVALENCE(RDSTAT(1),RDERR(1)) C C DEVICE PARAMETERS, SEE TAPE I/O REFERENCE MANUAL FOR CONTENTS C INTEGER RDDVC(6) C C QIO DIRECTIVE RETURN CODE C INTEGER ISW INTEGER RDLUN,RECSIZ,BLKSIZ,FILNUM C C KEEP TRACK OF EOF-MARKS ON READ OPERATIONS C INTEGER NUMMRK C C EVENT FLAGS TO BE USED FOR TASK SYNCHRONIZATION C INTEGER EVNFLG(2) DATA EVNFLG/1,2/ C C WHICH BUFFER AND ITS ADDRESS. MAX-BLK-SIZE IS 4800. USE TWO BUFFERS. C INTEGER BUFPTR,BUFADR(2) BYTE BUFFER(4800,2) C C LOCAL VARIABLES FOR USE IN RETURN OR BRANCHING C LOGICAL INIT C C RETURN CODE C BYTE RTC C C INPUT BUFFER FOR READ C INTEGER IPND C C MAGTAPE DIRECTIVES C C SET TAPE CHARACTERISTICS INTEGER IOSTC DATA IOSTC/ 1344/ C REWIND TAPE INTEGER IORWD DATA IORWD/ 1280/ C ATTACH LUN INTEGER IOATT DATA IOATT/ 768 / C SPACE TAPE MARKS INTEGER IOSPF DATA IOSPF/ 1312/ C READ LOGICAL BLOCK INTEGER IORLB DATA IORLB/ 512 / C SPACE BLOCKS INTEGER IOSPB DATA IOSPB/ 1296/ C REWIND AND UNLOAD INTEGER IORWU DATA IORWU/1376/ C DETACH A DEVICE INTEGER IODET DATA IODET/1024/ C C ERROR DIRECTIVES C C END OF FILE INTEGER IEEOF DATA IEEOF/ -10/ C END OF VOLUME INTEGER IEEOV DATA IEEOV/ -11/ C SUCCESS INTEGER ISSUC DATA ISSUC/ 1/ C****************************************************************** C * C SET TAPE CHARACTERISTICS, MOUNT AND ATTACH TAPE * C * C****************************************************************** ENTRY SETRDS CALL SHWRLN(RDLUN) CALL SHWSZE(RECSIZ,BLKSIZ) INIT=.TRUE. FILNUM=1 NUMMRK=0 RDDVC(1)=0 RDDVC(2)=BLKSIZ C CALL WTQIO(IOSTC,RDLUN,,,RDSTAT,RDDVC,ISW) IF(ISW .LT.0 .OR. RDERR(1) .LT.0) THEN WRITE(5,1000) ISW,RDERR(1) 1000 FORMAT(' ERROR IN SETTING TAPE CHARACTERISTICS-ISW,RTC',2I5) STOP ' ERROR IN IOSTC' END IF C C REWIND TAPE TO BOT C CALL WTQIO(IORWD,RDLUN,,,RDSTAT,,ISW) IF(ISW .LT.0 .OR. RDERR(1).LT.0)THEN WRITE(5,1000)ISW,RDERR(1) STOP ' ERROR IN IORWD' END IF CALL WTQIO(IOATT,RDLUN) C C SET THE EVENT FLAG JUST IN CASE SOMEONE FORGOT TO DO SO AT THE C START OF A NEW RUN C CALL SETEF(EVNFLG(1)) CALL SETEF(EVNFLG(2)) RDERR(1)=ISSUC RETURN C****************************************************************** C * C REWIND AND UNLOAD A TAPE * C C****************************************************************** ENTRY REDDMO C C MAKE SURE THAT THERE ARE NO PENDING I/O C CALL WAITFR(EVNFLG(1)) CALL WAITFR(EVNFLG(2)) C CALL WTQIO(IORWU,RDLUN) CALL WTQIO(IODET,RDLUN) RETURN C****************************************************************** C * C SKIP TAPE MARKS * C * C****************************************************************** ENTRY SKPFLS(NFILES,RTC) C C NFILES- NUMBER OF TAPE MARKS TO SKIP C RTC - RETURN CODE, SET TO A NEGATIVE NUMBER ON ERROR C C MAKE SURE NO I/O IS PENDING C CALL WAITFR(EVNFLG(1)) CALL WAITFR(EVNFLG(2)) C C MAKE SURE THAT THE LAST I/O CALL DID NOT RESULT IN AN C END OF VOLUME C IF(RDERR(1) .EQ. IEEOV) THEN RTC=IEEOV WRITE(5,1010) 1010 FORMAT( ' CANNOT SKIP PAST END OF VOLUME TAPE MARKS') RETURN END IF C RDDVC(1)=NFILES CALL WTQIO(IOSPF,RDLUN,,,RDSTAT,RDDVC,ISW) FILNUM=FILNUM + NFILES RTC=RDERR(1) INIT=.TRUE. RETURN C****************************************************************** C * C READ A BUFFER-FULL OF BYTES * C * C****************************************************************** ENTRY GETBUF(BUFPTR,BUFFER,NBYTES,RTC) C C BUFPTR - INTEGER VARIABLE POINTING TO THE BUFFER C IN WHICH THE DATA ARE TO BE DEPOSITED C BUFFER - CHARACTER BUFFER. THIS ROUTINE MAINTAINS TWO C 4800-CHARACTER BUFFERS. C NBYTES - NUMBER OF CHARACTERS READ BY THE LAST OPERATION C RTC - RETURN CODE (-10 FOR EOF) C IF(INIT)THEN INIT=.FALSE. CALL SETEF(EVNFLG(1)) CALL SETEF(EVNFLG(2)) IPND=1 C C USE SYSTEM PROVIDED ROUTINE TO GET THE BUFFER ADDRESSES NEEDED C BY THE READ QIO DIRECTIVE C CALL GETADR(BUFADR(1),BUFFER(1,1)) CALL GETADR(BUFADR(2),BUFFER(1,2)) RDDVC(1)=BUFADR(1) CALL QIO(IORLB,RDLUN,EVNFLG(IPND),,RDSTAT,RDDVC,ISW) IF (ISW .LT.0) THEN WRITE(5,1020)ISW,RDERR 1020 FORMAT(' QIO DIRECTIVE FAILED IN IORLB, ISW,RTC--',2I5) STOP ' ERROR IN IORLB' END IF END IF C CALL WAITFR(EVNFLG(IPND)) IF(RDERR(1).LT. 0) THEN INIT=.TRUE. RTC=RDERR(1) C C DEBUG STATEMENTS. C C WRITE(5,1015)RTC C1015 FORMAT(' RETURN-CODE OF LAST UNSUCCESFUL READ-',I) IF(RTC .EQ.IEEOF) THEN C C MAKE SURE THAT THE END OF VOLUME MARKER HAS NOT BEEN REACHED C IORLB DOES NOT RECOGNIZE IT C NUMMRK=NUMMRK + 1 IF (NUMMRK .EQ. 2) THEN RDERR(1)=IEEOV RTC=RDERR(1) END IF END IF RETURN C ELSE NUMMRK=0 BUFPTR=IPND NBYTES=RDSTAT(2) RTC=RDERR(1) IPND= MOD(IPND,2)+1 RDDVC(1)=BUFADR(IPND) CALL QIO(IORLB,RDLUN,EVNFLG(IPND),,RDSTAT,RDDVC,ISW) IF (ISW .LT.0) THEN WRITE(5,1020)ISW,RDERR(1) STOP ' DIRECTIVE FAILURE IN IORLB' END IF RETURN END IF C****************************************************************** C * C CLOSE THE CURRENT FILE * C * C****************************************************************** ENTRY CLSRTP(RTC) C C RTC - RETURN CODE C C MAKE SURE ALL EVENTS ARE DONE C CALL WAITFR(EVNFLG(1)) CALL WAITFR(EVNFLG(2)) C C HAS A MARK JUST BEEN READ. C IF(RDERR(1).EQ.IEEOF.OR.RDERR(1).EQ.IEEOV)THEN FILNUM=FILNUM + 1 RTC=RDERR(1) ELSE C C POSITION TO THE NEXT EOF MARK C CALL WTQIO(IOSPF,RDLUN,,,RDSTAT,1,ISW) FILNUM=FILNUM+1 RTC=RDERR(1) END IF INIT=.TRUE. RETURN C****************************************************************** C * C AT WHICH FILE NUMBER IS THE FILE POSITIONED * C * C****************************************************************** ENTRY SHWFLN(INUM) C C INUM - RETURNED AS THE CURRENT FILE NUMBER C INUM=FILNUM RETURN C END SUBROUTINE CLOSE(RTC) C C ROUTINE TO CLOSE FILES C FOR A FILES-11 FILE, THIS ROUTINE WILL ISSUE AN FCS CLOSE C FOR FOREIGN-TYPE FILE, THIS ROUTINE WILL SKIP TO THE NEAREST C TAPE MARK IF ONE HAS NOT YET BEEN REACHED C BYTE RTC CHARACTER*6 FILTYP INTEGER RDLUN LOGICAL FIRST DATA FIRST/.TRUE./ INTEGER IEEOF,IEEOV DATA IEEOF/-10/,IEEOV/-11/ C IF(FIRST) THEN FIRST=.FALSE. CALL SHWTYP(FILTYP) CALL SHWRLN(RDLUN) END IF C IF(FILTYP .EQ.'FILE11') THEN CLOSE(UNIT=RDLUN) C ELSE IF(FILTYP .EQ.'FOREGN') THEN CALL CLSRTP(RTC) IF(RTC .EQ. IEEOV) THEN WRITE(5,1000) 1000 FORMAT(' END-OF-VOLUME HAS BEEN REACHED') END IF CALL CLRBFS CALL CLRFLS C END IF C RETURN END INTEGER FUNCTION NXTLNE(IBUF,IRTN) C C THIS ROUTINE RETURNS A PDB RECORD C A LOOK-AHEAD BUFFER IS MAINTAINED IN OLDBUF TO ALLOW C RETURN OF A RECORD IF IT IS NOT WANTED C CHARACTER*80 IBUF,OLDBUF INTEGER IRTN C C READ LUN C INTEGER RDLUN C C TYPE OF FILE TO BE ACCESSED C CHARACTER*6 FILTYP C C FOR USE BY THE LOOK-AHEAD MECHANISM C LOGICAL IHVIT DATA IHVIT/.FALSE./ C LOGICAL FIRST DATA FIRST/.TRUE./ C IF(FIRST)THEN FIRST=.FALSE. CALL SHWTYP(FILTYP) CALL SHWRLN(RDLUN) END IF C IF(IHVIT) THEN IHVIT=.FALSE. IRTN=0 NXTLNE=0 IBUF=OLDBUF RETURN END IF C C MUST DO A READ... DETERMINE FILE C IF(FILTYP .EQ. 'FILE11') THEN READ(RDLUN,'(A)',END=10)IBUF IRTN=0 NXTLNE=0 RETURN C 10 IRTN=-10 NXTLNE=-10 RETURN C ELSE IF(FILTYP .EQ. 'FOREGN') THEN CALL TAPREC(IBUF,IRTN) NXTLNE=IRTN RETURN C ELSE WRITE(5,1000)FILTYP 1000 FORMAT(' ILLEGAL FILE TYPE--',A,' MAKE SURE SETRFL WAS FIRST', 1 ' CALLED') RETURN END IF C****************************************************************** C * C SAVE A RECORD TO BE REREAD * C * C****************************************************************** ENTRY PTBKBF(IBUF) C C PUT IBUF INTO THE LOOK-AHEAD BUFFER C OLDBUF=IBUF IHVIT=.TRUE. RETURN C END SUBROUTINE TAPREC(IBUF,IRTN) C C ROUTINE TO RETURN A RECORD FROM THE MAG-TAPE C THIS ROUTINE DOES THE DEBLOCKING C C MAG-TAPE BUFFERS C BYTE BUFFER(4800,2) INTEGER IRTN C C DETERMINE BUFFER TO READ C INTEGER BUFPTR C C NUMBER OF CHARACTERS READ C INTEGER NBYTES C C MAG-TAPE ROUTINES RETURN A BYTE RETURN ERROR CODE. C BYTE RTC LOGICAL FIRST DATA FIRST/.TRUE./ C C LOCAL VARIABLES FOR USE IN DEBLOCKING C C NUMBER OF RECORDS READ C INTEGER NREAD INTEGER RECSIZ,BLKSIZ BYTE IBUF(80) C C INPUT BUFFER STATUS SET TO DO A PHYSICAL READ C LOGICAL INPBFS DATA INPBFS/.FALSE./ C IF (FIRST) THEN FIRST=.FALSE. CALL SHWSZE(RECSIZ,BLKSIZ) END IF C IF(.NOT.INPBFS) THEN C C A BUFFER IS REQUIRED FROM THE TAPE HANDLER C CALL GETBUF(BUFPTR,BUFFER,NBYTES,RTC) IRTN=RTC IF(IRTN .LT.0 ) THEN RETURN ELSE NREAD=0 NRECS=NBYTES/RECSIZ INPBFS=.TRUE. END IF END IF C C DEBLOCK THE BUFFER C K=NREAD*RECSIZ +1 DO 10 J=1,RECSIZ IBUF(J)=BUFFER(K,BUFPTR) K=K+1 10 CONTINUE IRTN=0 NREAD=NREAD+1 IF (NREAD .EQ. NRECS) INPBFS=.FALSE. RETURN C C C RESET I/O BUFFER STATUS C ENTRY CLRBFS INPBFS=.FALSE. RETURN END SUBROUTINE OPEN(FILNAM,FILNUM,RTC) C C ROUTINE TO OPEN FILES C IF FILTYP IS FILES-11 THEN FILENAM HAS THE VALID FILES-11 FILE NAME C IF FILTYP IS FOREIGN THEN INUM HAS THE FILE NUMBER TO BE POSITIONED C INTEGER INUM,FILNUM CHARACTER*40 FILNAM BYTE RTC C C LOCAL VARIABLES C CHARACTER*6 FILTYP INTEGER RDLUN,IFLS LOGICAL FIRST DATA FIRST /.TRUE./ INTEGER IEEOF,IEEOV DATA IEEOF/-10/,IEEOV/-11/ LOGICAL FLSTAT DATA FLSTAT/.FALSE./ C IF(FIRST) THEN CALL SHWTYP(FILTYP) CALL SHWRLN(RDLUN) FIRST=.FALSE. END IF C IF (FILTYP .EQ. 'FILE11') THEN OPEN(UNIT=RDLUN,FILE=FILNAM,READONLY,STATUS='OLD', 1 FORM='FORMATTED') C ELSE IF(FILTYP .EQ. 'FOREGN') THEN C IF(FLSTAT) THEN WRITE(5.1030) 1030 FORMAT('LAST FILE WAS NOT CLOSED') STOP ENDIF C C DETERMINE PRESENT FILE NUMBER C C C CLEAR THE RETURN CODE C IF(FILNUM.GT.0) THEN RTC=1 CALL SHWFLN(INUM) C WRITE (5,1010)INUM C1010 FORMAT(' FILE NUMBER-',I) IFLS =FILNUM-INUM C WRITE (5,1020)IFLS C1020 FORMAT(' NUMBER OF TAPE MARKS TO SKIP-',I) IF(IFLS .GT. 0) THEN CALL SKPFLS(IFLS,RTC) END IF ENDIF FLSTAT=.TRUE. END IF RETURN ENTRY CLRFLS FLSTAT=.FALSE. RETURN END