C PROTEIN DATA BANK SOURCE CODE BRUKTP C AUTHOR. H.BOSSHARD BRUKTP C ENTRY DATE. 8/85 UNSUPPORTED .NO.ID. C LAST REVISION. 8/85 .NO.ID. C PURPOSE. MAKE VAX FILES FROM PDB TAPE BRUKTP C LANGUAGE. FORTRAN 77, VAX VMS BRUKTP C BRUKTP C BRUKTP C BRUKTP C BRUKTP C BRUKTP.FOR -------- HEINZ E. BOSSHARD, EMBL, HEIDELBERG, FRG BRUKTP C BRUKTP C VAX/VMS FORTRAN-77 VERSION FOR RELEASE TO BRUKTP C F. BERNSTEIN, BROOKHAVEN NATIONAL LABORATORY. BRUKTP C BRUKTP C VERSION: F77-01.01 HEB 15-DEC-1983 BRUKTP C FIRST F77 SOURCE. BRUKTP C F77-01.02 HEB/CNC 30-JAN-1985 BRUKTP C ADDED FACILITY TO READ INPUT TAP BRUKTP C IN SECTIONS. BRUKTP C F77-01.03 HEB 23-APR-1985 BRUKTP C MODIFICATIONS FOR VMS-4 (MAINLY BRUKTP C AFFECTS FILE NAMES). BRUKTP C BRUKTP C THIS IS A REWRITE OF THE, NOW DEFUNCT, EMBL-RATMAC CODE BRUKTP C OF 3-MAR-82 BY HEB. BRUKTP C BRUKTP C NOTE: THIS PROGRAM IS SPECIFIC TO VAX/VMS FORTRAN, USES RUNTIME LIBRAR BRUKTP C AND SYSTEM SERVICES AND THUS IS NOT PORTABLE WITHOUT MODIFICATIO BRUKTP C BRUKTP C ********************************************************************** BRUKTP C BRUKTP C 'BRUKTP' IS A UTILITY TO READ AN UNFORMATTED BROOKHAVEN PROTEIN DATA BRUKTP C BANK TAPE IN EITHER ASCII OR EBCDIC ENCODING. THE HEADER LINE OF EACH BRUKTP C FILE ON THE INPUT TAPE IS INSPECTED AND YIELDS A UNIQUE PORTION OF BRUKTP C THE FILENAME ASSIGNED. BRUKTP C BRUKTP C DEST. DEVICE/DIR: AS SPECIFIED BY USER, ELSE DEFAULT DIRECTORY. BRUKTP C DATA FILE NAMES: USER-PREFIX//PDB-4-LETTER-CODE//.USER-(DEFAULT)-TYPE BRUKTP C PROG. FILE NAMES: PROG.-NAME//.FOR BRUKTP C OTHER FILE NAMES: TXTNNNN.TXT NNNN CORRESPONDS TO N-TH FILE BRUKTP C BRUKTP C THE PROGRAM IS SELF-EXPLANATORY TO THE USER - HENCE USER DOCUMENTATION BRUKTP C IS UNNECESSARY. BRUKTP C BRUKTP C ---------------------------------------------------------------------- BRUKTP C BECAUSE OF THE NECESSITY OF SINGLE-FILE PROGRAM SOURCES FOR DISTRIBUTI BRUKTP C THE SET OF PARAMETERS IS REPEATED IN EVERY FUNCTION ( RATHER THAN USIN BRUKTP C 'INCLUDE'-FILES ) - THEY ARE STILL EASY TO FIND AND MODIFY. BRUKTP C BRUKTP C PATH/FILE-NAMES ARE RESTRICTED TO 255 CHARACTERS. FILE NAMES AND TYPES BRUKTP C SUPPORT VAX VMS-4. BRUKTP C ---------------------------------------------------------------------- BRUKTP C ********************************************************************** BRUKTP BRUKTP BRUKTP C MAIN PROGRAM BRUKTP BRUKTP BRUKTP PROGRAM BRUKTP BRUKTP BRUKTP BRUKTP IMPLICIT NONE BRUKTP BRUKTP C PARAMETER DECLARATIONS BRUKTP BRUKTP PARAMETER PDBBLK = 4800 ! BLOCK SIZE FOR TAPE I/O BRUKTP PARAMETER PIOBUF = 24 ! NUM. I/O BUFFERS USED BRUKTP PARAMETER PDBREC = 80 ! RECORD SIZE OF PDB INPUT TAP BRUKTP PARAMETER IDLEN = 4 ! LENGTH OF UNIQUE ID STRING I BRUKTP PARAMETER IDBEG = 63 ! START OF ID STRING IN HEADER BRUKTP PARAMETER IDEND = IDBEG+IDLEN-1 ! END OF ID STRING IN HEADER BRUKTP PARAMETER LEXTN = 40 ! LENGTH OF FILE EXTENSION (IN BRUKTP PARAMETER LFNAME = 255 ! LENGTH OF FILNENAME STRINGS BRUKTP PARAMETER LPNAME = 6 ! LENGTH OF PDB PROGRAM NAME F BRUKTP PARAMETER PNBEG = 65 ! START OF PROGNAME STRING IN BRUKTP PARAMETER PNEND = PNBEG+LPNAME-1 ! END OF PROGNAME IN HEADER BRUKTP PARAMETER LTDEV = 40 ! LENGTH OF INPUT TAPE DEVICE BRUKTP PARAMETER IN = 10 ! LOGICAL INPUT UNIT BRUKTP PARAMETER OUT = 11 ! LOGICAL OUTPUT UNIT BRUKTP BRUKTP BRUKTP C PROGRAM FUNCTIONS BRUKTP BRUKTP LOGICAL NEXT_FILE BRUKTP BRUKTP C EXTERNAL VARIABLES BRUKTP BRUKTP CHARACTER NAME*(LFNAME),ABUF*(PDBREC),PREFIX*(LFNAME) BRUKTP CHARACTER INTAPE*(LTDEV),EXTEN*(LEXTN),DEVDIR*(LFNAME) BRUKTP INTEGER NFILES/0/,NRECORDS/0/,NFOR/0/,NDATA/0/,NJUNK/0/ BRUKTP INTEGER PREFLEN/0/,DDLEN/0/,FIRSTFILE/0/,LASTFILE/0/ BRUKTP INTEGER*4 TRECS BRUKTP LOGICAL EBCDIC/.FALSE./,STATISTICS BRUKTP BRUKTP COMMON/CBRKTC/ NAME,ABUF,PREFIX,EXTEN,INTAPE,DEVDIR BRUKTP COMMON/CBRKTI/ NFILES,NRECORDS,NFOR,NDATA,NJUNK,PREFLEN,EBCDIC, BRUKTP $ DDLEN,FIRSTFILE,LASTFILE,TRECS,STATISTICS BRUKTP BRUKTP C LOCAL VARIABLES BRUKTP BRUKTP BRUKTP C EXECUTABLE CODE ====================================================== BRUKTP BRUKTP BRUKTP BRUKTP CALL USR_INFO ! GET INFORMATION FROM THE USER BRUKTP BRUKTP BRUKTP BRUKTP C SKIP OVER FILES PRECEEDING THE FIRST FILE TO BE READ BRUKTP BRUKTP CALL SKIP_FILES BRUKTP BRUKTP C THE MAIN LOOP OVER ALL INPUT FILES - GET INPUT FILES WHILE STILL MORE BRUKTP BRUKTP DO WHILE(NEXT_FILE()) BRUKTP BRUKTP CALL MAKE_NAME ! CONSTRUCT A FILE NAME FROM 1ST RECORD BRUKTP BRUKTP CALL COPY_FILE ! COPY THE FILE TO THE NAMED FILE BRUKTP BRUKTP END DO BRUKTP BRUKTP BRUKTP BRUKTP C ALL OF THE TAPE IS TRANSFERRED BRUKTP BRUKTP CALL PRINT_STAT BRUKTP BRUKTP WRITE(*,'(//'' REWINDING TAPE.''//)') BRUKTP REWIND( UNIT = IN ) BRUKTP CLOSE( IN ) BRUKTP BRUKTP END BRUKTP BRUKTP C SUBROUTINE USR_INFO ------- HEINZ E. BOSSHARD, EMBL, HEIDELBERG, FRG BRUKTP C THIS SUBROUTINE PROMPTS THE USER AND RETRIEVES NECESSARY INFOR- BRUKTP C MATION FROM HIM. BRUKTP BRUKTP BRUKTP SUBROUTINE USR_INFO BRUKTP BRUKTP BRUKTP IMPLICIT NONE BRUKTP BRUKTP C PARAMETER DECLARATIONS BRUKTP BRUKTP PARAMETER PDBBLK = 4800 ! BLOCK SIZE FOR TAPE I/O BRUKTP PARAMETER PIOBUF = 24 ! NUM. I/O BUFFERS USED BRUKTP PARAMETER PDBREC = 80 ! RECORD SIZE OF PDB INPUT TAP BRUKTP PARAMETER IDLEN = 4 ! LENGTH OF UNIQUE ID STRING I BRUKTP PARAMETER IDBEG = 63 ! START OF ID STRING IN HEADER BRUKTP PARAMETER IDEND = IDBEG+IDLEN-1 ! END OF ID STRING IN HEADER BRUKTP PARAMETER LEXTN = 40 ! LENGTH OF FILE EXTENSION (IN BRUKTP PARAMETER LFNAME = 255 ! LENGTH OF FILNENAME STRINGS BRUKTP PARAMETER LPNAME = 6 ! LENGTH OF PDB PROGRAM NAME F BRUKTP PARAMETER PNBEG = 65 ! START OF PROGNAME STRING IN BRUKTP PARAMETER PNEND = PNBEG+LPNAME-1 ! END OF PROGNAME IN HEADER BRUKTP PARAMETER LTDEV = 40 ! LENGTH OF INPUT TAPE DEVICE BRUKTP PARAMETER IN = 10 ! LOGICAL INPUT UNIT BRUKTP PARAMETER OUT = 11 ! LOGICAL OUTPUT UNIT BRUKTP BRUKTP C VAX/VMS RUNTIME LIBRARY FUNCTIONS BRUKTP BRUKTP INTEGER STR$UPCASE, STR$TRIM BRUKTP BRUKTP C VAX/VMS FORTRAN FUNCTIONS BRUKTP BRUKTP INTEGER MIN BRUKTP BRUKTP C EXTERNAL VARIABLES BRUKTP BRUKTP CHARACTER NAME*(LFNAME),ABUF*(PDBREC),PREFIX*(LFNAME) BRUKTP CHARACTER INTAPE*(LTDEV),EXTEN*(LEXTN),DEVDIR*(LFNAME) BRUKTP INTEGER NFILES/0/,NRECORDS/0/,NFOR/0/,NDATA/0/,NJUNK/0/ BRUKTP INTEGER PREFLEN/0/,DDLEN/0/,FIRSTFILE/0/,LASTFILE/0/ BRUKTP INTEGER*4 TRECS BRUKTP LOGICAL EBCDIC/.FALSE./,STATISTICS BRUKTP BRUKTP COMMON/CBRKTC/ NAME,ABUF,PREFIX,EXTEN,INTAPE,DEVDIR BRUKTP COMMON/CBRKTI/ NFILES,NRECORDS,NFOR,NDATA,NJUNK,PREFLEN,EBCDIC, BRUKTP $ DDLEN,FIRSTFILE,LASTFILE,TRECS,STATISTICS BRUKTP BRUKTP C LOCAL VARIABLES BRUKTP BRUKTP CHARACTER ANSWER*1,CTEMP*(LFNAME) BRUKTP INTEGER STAT,I BRUKTP BRUKTP C EXECUTABLE CODE ====================================================== BRUKTP BRUKTP C SEE IF THE USER NEEDS EXPLANATIONS BRUKTP BRUKTP WRITE(*,1) BRUKTP BRUKTP 1 FORMAT(//, BRUKTP $ ' HELLO - THIS IS BRUKTP FROM EMBL - F77-01.02'//, BRUKTP $ '$DO YOU NEED HELP ? THEN TYPE : ') BRUKTP BRUKTP READ(*,'(A)')ANSWER ! GET HIS ANSWER BRUKTP STAT = STR$UPCASE(ANSWER,ANSWER) ! CONVERT TO UPPER CASE BRUKTP BRUKTP IF (ANSWER .EQ. 'Y') THEN BRUKTP CALL EXPLAIN BRUKTP ELSE BRUKTP WRITE(*,'(///)') BRUKTP END IF BRUKTP BRUKTP C NOW WE START WITH THE PROMPTS BRUKTP BRUKTP BRUKTP INTAPE(1:1) = ' ' BRUKTP BRUKTP DO WHILE(INTAPE(1:1) .EQ. ' ') BRUKTP WRITE(*,'(A/A)') BRUKTP $ ' ON WHICH DEVICE IS THE DATA BANK TAPE MOUNTED ?', BRUKTP $ '$> ' BRUKTP READ(*,'(A)')INTAPE BRUKTP END DO BRUKTP BRUKTP C MAKE SURE THE COLON IS THERE BRUKTP BRUKTP STAT = STR$TRIM(INTAPE,INTAPE,I) BRUKTP IF (INTAPE(I:I) .NE. ':') THEN BRUKTP I = MIN(I+1,LTDEV) BRUKTP INTAPE(I:I) = ':' BRUKTP END IF BRUKTP BRUKTP C ASK FOR THE ENCODING OF THE TAPE BRUKTP BRUKTP ANSWER = ' ' BRUKTP BRUKTP DO WHILE((ANSWER .NE. 'A') .AND. (ANSWER .NE. 'E')) BRUKTP WRITE(*,'(A/A)') BRUKTP $ ' IS THE TAPE ENCODED ASCII OR EBCDIC ( OR ) ?', BRUKTP $ '$> ' BRUKTP READ(*,'(A)')ANSWER BRUKTP STAT = STR$UPCASE(ANSWER,ANSWER) BRUKTP END DO BRUKTP BRUKTP EBCDIC = ANSWER .EQ. 'E' BRUKTP BRUKTP C ASK IF HE WANTS STATISTICS - FILES, RECORDS, MEGABYTES - BRUKTP C THIS WILL CAUSE A DRY RUN WITHOUT COPYING ALLOWING TO DECIDE BRUKTP C WHICH FILES TO COPY IN ONE GO IF STORAGE IS SPARSE. BRUKTP BRUKTP STATISTICS = .FALSE. BRUKTP WRITE(*,'(/A/A)') BRUKTP $ ' DO YOU WANT A STATISTICS PASS ? ( DEFAULT: N )', BRUKTP $ '$> ' BRUKTP READ(*,'(A)') ANSWER BRUKTP STAT = STR$UPCASE( ANSWER, ANSWER ) BRUKTP IF (ANSWER .EQ. 'Y' )THEN BRUKTP TRECS = 0 BRUKTP EXTEN = ' ' BRUKTP PREFIX = ' ' BRUKTP CALL DO_STATISTICS BRUKTP END IF BRUKTP BRUKTP TRECS = 0 ! AND TOTAL NUMBER OF RECORDS TO 0 BRUKTP BRUKTP C ASK FOR DEVICE:[DIRECTORY] BRUKTP BRUKTP WRITE(*,'(/A/A)') BRUKTP $ ' SPECIFY THE ''DEVICE:[DIRECTORY]'' TO WRITE FORMATTED FILES:', BRUKTP $ '$> ' BRUKTP READ(*,'(A)')DEVDIR BRUKTP STAT = STR$TRIM(DEVDIR,DEVDIR,DDLEN) ! GET LENGTH OF STRING BRUKTP BRUKTP C ASK FOR THE FILENAME PREFIX BRUKTP BRUKTP WRITE(*,'(/A/A)') BRUKTP $ ' WHAT PREFIX SHOULD OUTPUT DATA FILES HAVE ?', BRUKTP $ '$> ' BRUKTP READ(*,'(A)')PREFIX BRUKTP STAT = STR$TRIM(PREFIX,PREFIX,PREFLEN) ! GET LENGTH OF PREFIX S BRUKTP BRUKTP C ASK FOR THE DATA FILE TYPE (EXTENSION) BRUKTP BRUKTP WRITE(*,'(/A/A)') BRUKTP $ ' WHAT TYPE SHOULD THE DATA FILES HAVE (DEFAULT: .BRK) ?', BRUKTP $ '$> ' BRUKTP READ(*,'(A)')CTEMP BRUKTP STAT = STR$UPCASE(CTEMP,CTEMP) BRUKTP BRUKTP IF (CTEMP(1:4) .EQ. ' ') THEN BRUKTP EXTEN = '.BRK' ! NONE SPECIFIED, USE DE BRUKTP ELSE IF (CTEMP(1:1) .NE. '.') THEN BRUKTP EXTEN = '.' // CTEMP ! INSERT PERIOD IF NOT G BRUKTP ELSE BRUKTP EXTEN = CTEMP BRUKTP END IF BRUKTP BRUKTP C GET THE FIRST AND LAST FILE NUMBERS BRUKTP BRUKTP WRITE(*,'(/A/A)') BRUKTP $ ' NUMBERS OF FIRST, LAST FILES TO READ (DEFAULT: ALL FILES) ?', BRUKTP $ '$> ' BRUKTP READ(*,'(2I8)')FIRSTFILE,LASTFILE BRUKTP FIRSTFILE = MAX(FIRSTFILE,1) BRUKTP IF (LASTFILE.EQ.0) LASTFILE = 32767 BRUKTP BRUKTP WRITE(*,'(/////)') BRUKTP BRUKTP RETURN BRUKTP END BRUKTP BRUKTP C SUBROUTINE EXPLAIN --- HEINZ E. BOSSHARD, EMBL, HEIDELBERG, FRG BRUKTP C EXPLAIN TO THE USER HOW THE PROGRAM WORKS BRUKTP BRUKTP BRUKTP SUBROUTINE EXPLAIN BRUKTP BRUKTP BRUKTP IMPLICIT NONE BRUKTP BRUKTP C LOCAL VARIABLES BRUKTP BRUKTP CHARACTER ANSWER*1 BRUKTP BRUKTP BRUKTP BRUKTP C EXECUTABLE CODE ===================================================== BRUKTP BRUKTP WRITE(*,1) ! TELL THE USER WHAT THIS PROGRAM IS ALL ABOUT. BRUKTP BRUKTP 1 FORMAT(//, BRUKTP $ ' ************************************************************'/ BRUKTP $ ' THE PROGRAM READS ALL OR PORTIONS OF AN UNLABELLED BROOKHAVEN' BRUKTP $ /' PROTEIN DATA BANK TAPE, CODED IN ASCII OR EBCDIC.'/, BRUKTP $ ' COPYING CAN BE TAPE-TO-DISK OR TAPE-TO-TAPE.'//, BRUKTP $ ' OUTPUT FILES ARE CODED ASCII AND NAMED ''D:[D]PREFIDEN.TYP'':' BRUKTP $ /' WHERE: ''D:[D]'' IS THE DESTINATION DEVICE-DIRECTORY PATH''' BRUKTP $ /' ''PREF'' IS THE PREFIX YOU CHOOSE (DATA FILES ONLY),' BRUKTP $ /' ''IDEN'' IS THE UNIQUE 4-LETTER CODE OF EACH ENTRY' BRUKTP $ /' IN THE DATA BANK,' BRUKTP $ /' ''TYP'' IS THE FILE TYPE (EXTENSION) YOU CHOOSE.'// BRUKTP $ ' PROGRAM FILES ARE NAMED ''PROGNAME.FOR'',' BRUKTP $ /' WHERE: ''PROGNAME'' IS RETRIEVED FROM THE FILE.'// BRUKTP $ ' OTHER FILES ARE NAMED ''TXTNNNN.TXT''' BRUKTP $ /' WHERE: ''NNNN'' IS THE NUMBER OF THE FILE.'// BRUKTP $ ' MOUNT THE BROOKHAVEN TAPE /FOREIGN WITH PROPER DENSITY,', BRUKTP $ ' ************************************************************' BRUKTP $ ///'$TYPE TO CONTINUE.') BRUKTP BRUKTP READ(*,'(A)')ANSWER BRUKTP WRITE(*,'(/////)') ! SPACE OUT BRUKTP BRUKTP RETURN BRUKTP END BRUKTP BRUKTP C SUBROUTINE DO_STATISTICS ---- HEINZ E. BOSSHARD, EMBL, HEIDELBERG, FRG BRUKTP C TRAVERSE THE INPUT TAPE, COLLECT AND OUTPUT INFORMATION ABOUT BRUKTP C ENTRIES, NUMBER OF RECORDS, MEGABYTES. THE TAPE IS REWOUND BRUKTP C AT THE END. BRUKTP BRUKTP BRUKTP SUBROUTINE DO_STATISTICS BRUKTP BRUKTP IMPLICIT NONE BRUKTP BRUKTP C PARAMETER DECLARATIONS BRUKTP BRUKTP PARAMETER PDBBLK = 4800 ! BLOCK SIZE FOR TAPE I/O BRUKTP PARAMETER PIOBUF = 24 ! NUM. I/O BUFFERS USED BRUKTP PARAMETER PDBREC = 80 ! RECORD SIZE OF PDB INPUT TAP BRUKTP PARAMETER IDLEN = 4 ! LENGTH OF UNIQUE ID STRING I BRUKTP PARAMETER IDBEG = 63 ! START OF ID STRING IN HEADER BRUKTP PARAMETER IDEND = IDBEG+IDLEN-1 ! END OF ID STRING IN HEADER BRUKTP PARAMETER LEXTN = 40 ! LENGTH OF FILE EXTENSION (IN BRUKTP PARAMETER LFNAME = 255 ! LENGTH OF FILNENAME STRINGS BRUKTP PARAMETER LPNAME = 6 ! LENGTH OF PDB PROGRAM NAME F BRUKTP PARAMETER PNBEG = 65 ! START OF PROGNAME STRING IN BRUKTP PARAMETER PNEND = PNBEG+LPNAME-1 ! END OF PROGNAME IN HEADER BRUKTP PARAMETER LTDEV = 40 ! LENGTH OF INPUT TAPE DEVICE BRUKTP PARAMETER IN = 10 ! LOGICAL INPUT UNIT BRUKTP PARAMETER OUT = 11 ! LOGICAL OUTPUT UNIT BRUKTP BRUKTP BRUKTP C EXTERNAL VARIABLES BRUKTP BRUKTP CHARACTER NAME*(LFNAME),ABUF*(PDBREC),PREFIX*(LFNAME) BRUKTP CHARACTER INTAPE*(LTDEV),EXTEN*(LEXTN),DEVDIR*(LFNAME) BRUKTP INTEGER NFILES/0/,NRECORDS/0/,NFOR/0/,NDATA/0/,NJUNK/0/ BRUKTP INTEGER PREFLEN/0/,DDLEN/0/,FIRSTFILE/0/,LASTFILE/0/ BRUKTP INTEGER*4 TRECS BRUKTP LOGICAL EBCDIC/.FALSE./,STATISTICS BRUKTP BRUKTP COMMON/CBRKTC/ NAME,ABUF,PREFIX,EXTEN,INTAPE,DEVDIR BRUKTP COMMON/CBRKTI/ NFILES,NRECORDS,NFOR,NDATA,NJUNK,PREFLEN,EBCDIC, BRUKTP $ DDLEN,FIRSTFILE,LASTFILE,TRECS,STATISTICS BRUKTP BRUKTP C VAX/VMS RTL FUNCTION BRUKTP BRUKTP INTEGER*4 STR$UPCASE BRUKTP BRUKTP C PROGRAM FUNCTIONS BRUKTP BRUKTP LOGICAL NEXT_FILE BRUKTP BRUKTP C LOCAL VARIABLES BRUKTP BRUKTP INTEGER*4 STAT BRUKTP CHARACTER TOTBYTES*16 ! STRING TO HOLD 'FORMATTED' N B BRUKTP CHARACTER*1 ANSWER BRUKTP BRUKTP C EXECUTABLE CODE ====================================================== BRUKTP BRUKTP BRUKTP WRITE(*,1) BRUKTP 1 FORMAT(//, BRUKTP $ ' THE STATISTICS PASS WILL TRAVERSE THE ENTIRE INPUT TAPE,'/, BRUKTP $ ' GIVING YOU INFORMATION ON THE DATA BASE ENTRIES, THEIR'/, BRUKTP $ ' NUMBERS, THEIR SIZE IN RECORDS AND BYTES AND A RUNNING'/, BRUKTP $ ' TOTAL THEREOF.'//, BRUKTP $ ' PROCEED WITH STATISTICS ? ( DEFAULT: Y )'/, BRUKTP $ '$> ' ) BRUKTP BRUKTP READ(*,'(A)') ANSWER BRUKTP STAT = STR$UPCASE( ANSWER, ANSWER ) BRUKTP WRITE(*,'()') BRUKTP BRUKTP IF( ANSWER .EQ. 'N' )THEN BRUKTP STATISTICS = .FALSE. BRUKTP RETURN BRUKTP END IF BRUKTP BRUKTP FIRSTFILE = 1 BRUKTP LASTFILE = 32767 BRUKTP STATISTICS = .TRUE. BRUKTP BRUKTP DO WHILE( NEXT_FILE() ) BRUKTP BRUKTP CALL MAKE_NAME ! GET THE ENTRY TYPE AND NAME BRUKTP CALL SCAN_FILE ! SCAN THE FILE BRUKTP BRUKTP END DO BRUKTP BRUKTP CALL PRINT_STAT BRUKTP STATISTICS = .FALSE. BRUKTP BRUKTP WRITE(*,'(//'' REWINDING TAPE.''//)') BRUKTP REWIND( UNIT = IN ) BRUKTP CLOSE( UNIT = IN ) BRUKTP BRUKTP RETURN BRUKTP END BRUKTP BRUKTP C LOGICAL FUNCTION NEXT_FILE ---- HEINZ E. BOSSHARD, EMBL, HEIDELBERG, F BRUKTP C OPEN THE NEXT FILE ON THE INPUT TAPE AND READ THE FIRST RECORD BRUKTP C IN ORDER TO ESTABLISH THAT THE FILE IS NOT EMPTY. IF IT IS BRUKTP C EMPTY, RETURN .FALSE., .TRUE. OTHERWISE. RETURN .FALSE. IF THE N BRUKTP C OF THE NEXT FILE IS GREATER THAN 'LASTFILE'. BRUKTP BRUKTP BRUKTP LOGICAL FUNCTION NEXT_FILE BRUKTP BRUKTP BRUKTP IMPLICIT NONE BRUKTP BRUKTP C PARAMETER DECLARATIONS BRUKTP BRUKTP PARAMETER PDBBLK = 4800 ! BLOCK SIZE FOR TAPE I/O BRUKTP PARAMETER PIOBUF = 24 ! NUM. I/O BUFFERS USED BRUKTP PARAMETER PDBREC = 80 ! RECORD SIZE OF PDB INPUT TAP BRUKTP PARAMETER IDLEN = 4 ! LENGTH OF UNIQUE ID STRING I BRUKTP PARAMETER IDBEG = 63 ! START OF ID STRING IN HEADER BRUKTP PARAMETER IDEND = IDBEG+IDLEN-1 ! END OF ID STRING IN HEADER BRUKTP PARAMETER LEXTN = 40 ! LENGTH OF FILE EXTENSION (IN BRUKTP PARAMETER LFNAME = 255 ! LENGTH OF FILNENAME STRINGS BRUKTP PARAMETER LPNAME = 6 ! LENGTH OF PDB PROGRAM NAME F BRUKTP PARAMETER PNBEG = 65 ! START OF PROGNAME STRING IN BRUKTP PARAMETER PNEND = PNBEG+LPNAME-1 ! END OF PROGNAME IN HEADER BRUKTP PARAMETER LTDEV = 40 ! LENGTH OF INPUT TAPE DEVICE BRUKTP PARAMETER IN = 10 ! LOGICAL INPUT UNIT BRUKTP PARAMETER OUT = 11 ! LOGICAL OUTPUT UNIT BRUKTP BRUKTP C EXTERNAL VARIABLES BRUKTP BRUKTP CHARACTER NAME*(LFNAME),ABUF*(PDBREC),PREFIX*(LFNAME) BRUKTP CHARACTER INTAPE*(LTDEV),EXTEN*(LEXTN),DEVDIR*(LFNAME) BRUKTP INTEGER NFILES/0/,NRECORDS/0/,NFOR/0/,NDATA/0/,NJUNK/0/ BRUKTP INTEGER PREFLEN/0/,DDLEN/0/,FIRSTFILE/0/,LASTFILE/0/ BRUKTP INTEGER*4 TRECS BRUKTP LOGICAL EBCDIC/.FALSE./,STATISTICS BRUKTP BRUKTP COMMON/CBRKTC/ NAME,ABUF,PREFIX,EXTEN,INTAPE,DEVDIR BRUKTP COMMON/CBRKTI/ NFILES,NRECORDS,NFOR,NDATA,NJUNK,PREFLEN,EBCDIC, BRUKTP $ DDLEN,FIRSTFILE,LASTFILE,TRECS,STATISTICS BRUKTP BRUKTP C LOCAL VARIABLES BRUKTP BRUKTP INTEGER*4 RECS BRUKTP BRUKTP C EXECUTABLE CODE ====================================================== BRUKTP BRUKTP NRECORDS = 0 BRUKTP RECS = ( PDBREC + 3 ) / 4 BRUKTP BRUKTP C OPEN THE NEXT FILE ON THE INPUT TAPE, EVEN IF IT IS THE LAST FILE BRUKTP C SPECIFIED ( SO WE CAN REWIND ). BRUKTP BRUKTP OPEN(UNIT=IN,FILE=INTAPE,RECL=RECS,RECORDTYPE='FIXED', BRUKTP $ FORM='UNFORMATTED',ACCESS='SEQUENTIAL',READONLY,STATUS='OLD', BRUKTP $ ORGANIZATION='SEQUENTIAL',BLOCKSIZE=PDBBLK,BUFFERCOUNT=PIOBUF) BRUKTP BRUKTP C HAS THE LAST FILE BEEN READ? BRUKTP BRUKTP IF (NFILES .EQ. LASTFILE) GOTO 10 BRUKTP BRUKTP C READ THE FIRST RECORD - IF END, WE'VE REACHED THE END OF THE INPUT TAP BRUKTP BRUKTP READ( IN ,END=10 ) ABUF BRUKTP NFILES = NFILES + 1 ! COUNT THE FILE NUMBERS BRUKTP BRUKTP NEXT_FILE = .TRUE. BRUKTP RETURN BRUKTP BRUKTP 10 CONTINUE BRUKTP NEXT_FILE = .FALSE. ! INPUT EXHAUSTED BRUKTP RETURN BRUKTP BRUKTP END BRUKTP BRUKTP C SUBROUTINE SKIP_FILES ---- CHRIS CARLSON, EMBL, HEIDELBERG, FRG BRUKTP C SKIP FILES PRECEEDING THE FIRST FILE TO BE READ. BRUKTP BRUKTP BRUKTP SUBROUTINE SKIP_FILES BRUKTP BRUKTP IMPLICIT NONE BRUKTP BRUKTP INCLUDE '($IODEF)' BRUKTP INCLUDE '($SSDEF)' BRUKTP BRUKTP C PARAMETER DECLARATIONS BRUKTP BRUKTP PARAMETER PDBBLK = 4800 ! BLOCK SIZE FOR TAPE I/O BRUKTP PARAMETER PIOBUF = 24 ! NUM. I/O BUFFERS USED BRUKTP PARAMETER PDBREC = 80 ! RECORD SIZE OF PDB INPUT TAP BRUKTP PARAMETER IDLEN = 4 ! LENGTH OF UNIQUE ID STRING I BRUKTP PARAMETER IDBEG = 63 ! START OF ID STRING IN HEADER BRUKTP PARAMETER IDEND = IDBEG+IDLEN-1 ! END OF ID STRING IN HEADER BRUKTP PARAMETER LEXTN = 40 ! LENGTH OF FILE EXTENSION (IN BRUKTP PARAMETER LFNAME = 255 ! LENGTH OF FILNENAME STRINGS BRUKTP PARAMETER LPNAME = 6 ! LENGTH OF PDB PROGRAM NAME F BRUKTP PARAMETER PNBEG = 65 ! START OF PROGNAME STRING IN BRUKTP PARAMETER PNEND = PNBEG+LPNAME-1 ! END OF PROGNAME IN HEADER BRUKTP PARAMETER LTDEV = 40 ! LENGTH OF INPUT TAPE DEVICE BRUKTP PARAMETER IN = 10 ! LOGICAL INPUT UNIT BRUKTP PARAMETER OUT = 11 ! LOGICAL OUTPUT UNIT BRUKTP BRUKTP C EXTERNAL VARIABLES BRUKTP BRUKTP CHARACTER NAME*(LFNAME),ABUF*(PDBREC),PREFIX*(LFNAME) BRUKTP CHARACTER INTAPE*(LTDEV),EXTEN*(LEXTN),DEVDIR*(LFNAME) BRUKTP INTEGER NFILES/0/,NRECORDS/0/,NFOR/0/,NDATA/0/,NJUNK/0/ BRUKTP INTEGER PREFLEN/0/,DDLEN/0/,FIRSTFILE/0/,LASTFILE/0/ BRUKTP INTEGER*4 TRECS BRUKTP LOGICAL EBCDIC/.FALSE./,STATISTICS BRUKTP BRUKTP COMMON/CBRKTC/ NAME,ABUF,PREFIX,EXTEN,INTAPE,DEVDIR BRUKTP COMMON/CBRKTI/ NFILES,NRECORDS,NFOR,NDATA,NJUNK,PREFLEN,EBCDIC, BRUKTP $ DDLEN,FIRSTFILE,LASTFILE,TRECS,STATISTICS BRUKTP BRUKTP C VAX/VMS SYSTEM SERVICE FUNCTIONS BRUKTP BRUKTP INTEGER SYS$ASSIGN, SYS$QIOW, SYS$DASSGN BRUKTP BRUKTP C LOCAL VARIABLES BRUKTP BRUKTP INTEGER*2 CHAN BRUKTP INTEGER NSKIP, RETSTAT BRUKTP BRUKTP C EXECUTABLE CODE ====================================================== BRUKTP BRUKTP NSKIP = FIRSTFILE - 1 BRUKTP IF (NSKIP .GT. 0) THEN BRUKTP RETSTAT = SYS$ASSIGN(INTAPE, CHAN,,) BRUKTP IF (RETSTAT .NE. SS$_NORMAL) CALL LIB$STOP(%VAL(RETSTAT)) BRUKTP RETSTAT = SYS$QIOW(,%VAL(CHAN),%VAL(IO$_SKIPFILE),,,, BRUKTP $ %VAL(NSKIP),,,,,) BRUKTP IF (RETSTAT .NE. SS$_NORMAL) CALL LIB$STOP(%VAL(RETSTAT)) BRUKTP CALL SYS$DASSGN(CHAN) BRUKTP NFILES = NSKIP BRUKTP ELSE BRUKTP NFILES = 0 BRUKTP END IF BRUKTP BRUKTP RETURN BRUKTP END BRUKTP BRUKTP C SUBROUTINE MAKE_NAME ---- HEINZ E. BOSSHARD, EMBL, HEIDELBERG, FRG BRUKTP C INSPECT THE FIRST LINE OF THE NEW FILE AND CONSTRUCT A BRUKTP C FILE NAME. BRUKTP BRUKTP BRUKTP SUBROUTINE MAKE_NAME BRUKTP BRUKTP BRUKTP IMPLICIT NONE BRUKTP BRUKTP C VAX/VMS RUNTIME LIBRARY RETURN-CODE DEFINITIONS BRUKTP BRUKTP INCLUDE '($SSDEF)' BRUKTP BRUKTP C PARAMETER DECLARATIONS BRUKTP BRUKTP PARAMETER PDBBLK = 4800 ! BLOCK SIZE FOR TAPE I/O BRUKTP PARAMETER PIOBUF = 24 ! NUM. I/O BUFFERS USED BRUKTP PARAMETER PDBREC = 80 ! RECORD SIZE OF PDB INPUT TAP BRUKTP PARAMETER IDLEN = 4 ! LENGTH OF UNIQUE ID STRING I BRUKTP PARAMETER IDBEG = 63 ! START OF ID STRING IN HEADER BRUKTP PARAMETER IDEND = IDBEG+IDLEN-1 ! END OF ID STRING IN HEADER BRUKTP PARAMETER LEXTN = 40 ! LENGTH OF FILE EXTENSION (IN BRUKTP PARAMETER LFNAME = 255 ! LENGTH OF FILNENAME STRINGS BRUKTP PARAMETER LPNAME = 6 ! LENGTH OF PDB PROGRAM NAME F BRUKTP PARAMETER PNBEG = 65 ! START OF PROGNAME STRING IN BRUKTP PARAMETER PNEND = PNBEG+LPNAME-1 ! END OF PROGNAME IN HEADER BRUKTP PARAMETER LTDEV = 40 ! LENGTH OF INPUT TAPE DEVICE BRUKTP PARAMETER IN = 10 ! LOGICAL INPUT UNIT BRUKTP PARAMETER OUT = 11 ! LOGICAL OUTPUT UNIT BRUKTP BRUKTP C VAX/VMS RUNTIME LIBRARY FUNCTIONS BRUKTP BRUKTP INTEGER LIB$TRA_EBC_ASC, LIB$TRA_ASC_EBC, STR$TRIM, STR$UPCASE BRUKTP BRUKTP C EXTERNAL VARIABLES BRUKTP BRUKTP CHARACTER NAME*(LFNAME),ABUF*(PDBREC),PREFIX*(LFNAME) BRUKTP CHARACTER INTAPE*(LTDEV),EXTEN*(LEXTN),DEVDIR*(LFNAME) BRUKTP INTEGER NFILES/0/,NRECORDS/0/,NFOR/0/,NDATA/0/,NJUNK/0/ BRUKTP INTEGER PREFLEN/0/,DDLEN/0/,FIRSTFILE/0/,LASTFILE/0/ BRUKTP INTEGER*4 TRECS BRUKTP LOGICAL EBCDIC/.FALSE./,STATISTICS BRUKTP BRUKTP COMMON/CBRKTC/ NAME,ABUF,PREFIX,EXTEN,INTAPE,DEVDIR BRUKTP COMMON/CBRKTI/ NFILES,NRECORDS,NFOR,NDATA,NJUNK,PREFLEN,EBCDIC, BRUKTP $ DDLEN,FIRSTFILE,LASTFILE,TRECS,STATISTICS BRUKTP BRUKTP BRUKTP C LOCAL VARIABLES BRUKTP BRUKTP CHARACTER CTEMP*(LFNAME),SUBN*(4),EXT*(LEXTN),TBUF*(PDBREC) BRUKTP INTEGER STAT,ILEN,I BRUKTP LOGICAL JUNKFILE BRUKTP BRUKTP C EXECUTABLE CODE ====================================================== BRUKTP BRUKTP C IF TAPE ENCODED EBCDIC, TRANSLATE ABUF CONTENTS TO ASCII BRUKTP BRUKTP IF ( EBCDIC ) THEN BRUKTP STAT = LIB$TRA_EBC_ASC(ABUF,ABUF) ! TRANSLATE TO ASCII BRUKTP ELSE BRUKTP STAT = LIB$TRA_ASC_EBC(ABUF,TBUF) ! TRANS. TO EBCDIC TO CH BRUKTP END IF BRUKTP IF ( STAT .NE. SS$_NORMAL) BRUKTP $ CALL TRA_ERR(STAT,NFILES,' ?????',1,EBCDIC) BRUKTP BRUKTP C CONSTRUCT A FILE NAME NOW --- BRUKTP C IF WE DON'T HAVE THE 'HEADER' PREFIX, WE FOUND A PROGRAM OR BRUKTP C AN UNIDENTIFIABLE FILE TYPE BRUKTP BRUKTP IF ( ABUF(1:6) .NE. 'HEADER' ) THEN BRUKTP BRUKTP CTEMP = ABUF(PNBEG:PNEND) BRUKTP STAT = STR$UPCASE(CTEMP,CTEMP) BRUKTP STAT = STR$TRIM(CTEMP,CTEMP,ILEN) BRUKTP JUNKFILE = .FALSE. ! PRESET FLAG BRUKTP BRUKTP IF ( ILEN .LE. 0 ) THEN BRUKTP JUNKFILE = .TRUE. ! ALL BLANK - WE HAVE A JUNK FILE BRUKTP ELSE BRUKTP DO I = 1,ILEN BRUKTP IF ((CTEMP(I:I).LT.'0' .AND. CTEMP(I:I).GT.'9') .AND. BRUKTP $ (CTEMP(I:I).LT.'A' .AND. CTEMP(I:I).GT.'Z')) BRUKTP $ JUNKFILE = .TRUE. ! IF NOT ALPHANUMERIC, HAVE JU BRUKTP END DO BRUKTP END IF BRUKTP BRUKTP IF (JUNKFILE) THEN BRUKTP WRITE(SUBN,'(I4.4)') NFILES ! WRITE FILE NUMBER INTO BRUKTP CTEMP = 'TXT' // SUBN // '.TXT' ! AND CONSTRUCT TXTNNN.T BRUKTP NJUNK = NJUNK + 1 BRUKTP ELSE BRUKTP CTEMP = CTEMP(1:ILEN) // '.FOR' ! ELSE NAME AS .FOR PRO BRUKTP NFOR = NFOR + 1 BRUKTP END IF BRUKTP BRUKTP C ELSE WE HAVE THE HEADER PREFIX, SO CONSTRUCT A DATA FILE NAME FROM BRUKTP C THE USER PREFIX, THE UNIQUE 4-LETTER ID CODE AND THE USER (DEFAULT) TY BRUKTP BRUKTP ELSE BRUKTP BRUKTP NDATA = NDATA + 1 BRUKTP CTEMP = ABUF(IDBEG:IDEND) BRUKTP STAT = STR$TRIM(CTEMP,CTEMP,ILEN) ! JUST IN CASE BRUKTP BRUKTP IF (PREFLEN .GT. 0) THEN BRUKTP CTEMP = PREFIX(1:PREFLEN) // CTEMP(1:ILEN) // EXTEN BRUKTP ELSE BRUKTP CTEMP = CTEMP(1:ILEN) // EXTEN BRUKTP END IF BRUKTP END IF BRUKTP BRUKTP C FINALIZE THE FILE NAME BY PREFIXING IT WITH 'DEVDIR' SPECIFICA BRUKTP BRUKTP IF (DDLEN .GT. 0) THEN BRUKTP NAME = DEVDIR(1:DDLEN) // CTEMP BRUKTP ELSE IF( .NOT. STATISTICS )THEN BRUKTP NAME = '[]' // CTEMP BRUKTP ELSE BRUKTP NAME = CTEMP BRUKTP END IF BRUKTP BRUKTP BRUKTP C NOTIFY USER ABOUT THIS FILE BRUKTP BRUKTP STAT = STR$UPCASE(NAME,NAME) ! FOLD TO UPPER, FOR LOO BRUKTP STAT = STR$TRIM(NAME,NAME,ILEN) ! GET LENGTH OF FILE NAM BRUKTP BRUKTP IF (STATISTICS) THEN BRUKTP WRITE(*,'(/A,I6,/,5X,A,A)') BRUKTP $ ' ''BRUKTP'' STATISTICS ON FILE NUMBER',NFILES, BRUKTP $ ' ENTRY NAME: ',NAME(1:ILEN) BRUKTP ELSE BRUKTP WRITE(*,'(/A,I6,/,5X,A,A)') BRUKTP $ ' ''BRUKTP'' CREATING FILE NUMBER',NFILES,'NAME: ', BRUKTP $ NAME(1:ILEN) BRUKTP END IF BRUKTP BRUKTP RETURN BRUKTP END BRUKTP BRUKTP C SUBROUTINE COPY_FILE ---- HEINZ E. BOSSHARD, EMBL, HEIDELBERG, FRG BRUKTP C OPEN AN OUTPUT FILE USING 'NAME' AND THEN COPY THE ENTIRE BRUKTP C FILE FROM IN TO OUT BRUKTP BRUKTP BRUKTP SUBROUTINE COPY_FILE BRUKTP BRUKTP BRUKTP IMPLICIT NONE BRUKTP BRUKTP C VAX/VMS RUNTIME LIBRARY RETURN-CODE DEFINITIONS BRUKTP BRUKTP INCLUDE '($SSDEF)' BRUKTP BRUKTP C PARAMETER DECLARATIONS BRUKTP BRUKTP PARAMETER PDBBLK = 4800 ! BLOCK SIZE FOR TAPE I/O BRUKTP PARAMETER PIOBUF = 24 ! NUM. I/O BUFFERS USED BRUKTP PARAMETER PDBREC = 80 ! RECORD SIZE OF PDB INPUT TAP BRUKTP PARAMETER IDLEN = 4 ! LENGTH OF UNIQUE ID STRING I BRUKTP PARAMETER IDBEG = 63 ! START OF ID STRING IN HEADER BRUKTP PARAMETER IDEND = IDBEG+IDLEN-1 ! END OF ID STRING IN HEADER BRUKTP PARAMETER LEXTN = 40 ! LENGTH OF FILE EXTENSION (IN BRUKTP PARAMETER LFNAME = 255 ! LENGTH OF FILNENAME STRINGS BRUKTP PARAMETER LPNAME = 6 ! LENGTH OF PDB PROGRAM NAME F BRUKTP PARAMETER PNBEG = 65 ! START OF PROGNAME STRING IN BRUKTP PARAMETER PNEND = PNBEG+LPNAME-1 ! END OF PROGNAME IN HEADER BRUKTP PARAMETER LTDEV = 40 ! LENGTH OF INPUT TAPE DEVICE BRUKTP PARAMETER IN = 10 ! LOGICAL INPUT UNIT BRUKTP PARAMETER OUT = 11 ! LOGICAL OUTPUT UNIT BRUKTP BRUKTP C VAX/VMS RUNTIME LIBRARY FUNCTIONS BRUKTP BRUKTP INTEGER LIB$TRA_EBC_ASC,LIB$TRA_ASC_EBC BRUKTP BRUKTP C PROGRAM FUNCTION BRUKTP BRUKTP INTEGER*4 OUTFORM BRUKTP BRUKTP C EXTERNAL VARIABLES BRUKTP BRUKTP CHARACTER NAME*(LFNAME),ABUF*(PDBREC),PREFIX*(LFNAME) BRUKTP CHARACTER INTAPE*(LTDEV),EXTEN*(LEXTN),DEVDIR*(LFNAME) BRUKTP INTEGER NFILES/0/,NRECORDS/0/,NFOR/0/,NDATA/0/,NJUNK/0/ BRUKTP INTEGER PREFLEN/0/,DDLEN/0/,FIRSTFILE/0/,LASTFILE/0/ BRUKTP INTEGER*4 TRECS BRUKTP LOGICAL EBCDIC/.FALSE./,STATISTICS BRUKTP BRUKTP COMMON/CBRKTC/ NAME,ABUF,PREFIX,EXTEN,INTAPE,DEVDIR BRUKTP COMMON/CBRKTI/ NFILES,NRECORDS,NFOR,NDATA,NJUNK,PREFLEN,EBCDIC, BRUKTP $ DDLEN,FIRSTFILE,LASTFILE,TRECS,STATISTICS BRUKTP BRUKTP BRUKTP C LOCAL VARIABLES BRUKTP BRUKTP INTEGER*4 STAT,RECS BRUKTP CHARACTER*(PDBREC) TBUF BRUKTP BRUKTP C EXECUTABLE CODE ====================================================== BRUKTP BRUKTP BRUKTP C OPEN THE OUTPUT FILE - 'NAME' CONTAINS THE APPLICABLE FILE NAME BRUKTP BRUKTP RECS = ( PDBREC + 3 ) / 4 BRUKTP BRUKTP OPEN(UNIT=OUT,FILE=NAME,STATUS='NEW',ACCESS='SEQUENTIAL', BRUKTP $ ORGANIZATION='SEQUENTIAL',RECORDTYPE='FIXED',RECL=RECS, BRUKTP $ FORM='UNFORMATTED',BLOCKSIZE=PDBBLK,BUFFERCOUNT=PIOBUF) BRUKTP BRUKTP BRUKTP C AND NOW COPY THE REST OF THIS FILE, THE END-OF-FILE GETS US OUT OF THE BRUKTP C NOTE: THE FIRST RECORD HAS BEEN READ BY NEXT_FILE AND IS IN 'ABUF' BRUKTP BRUKTP DO WHILE(.TRUE.) BRUKTP BRUKTP WRITE(OUT) ABUF ! ZAP OUT THE RECORD BRUKTP NRECORDS = NRECORDS + 1 ! AND COUNT BRUKTP READ(IN,END=10)ABUF ! READ A NEW RECORD BRUKTP IF (EBCDIC) THEN BRUKTP STAT = LIB$TRA_EBC_ASC(ABUF,ABUF) ! TRANSLATE IF EBCDIC BRUKTP ELSE BRUKTP STAT = LIB$TRA_ASC_EBC(ABUF,TBUF) ! TRANS. TO EBCDIC TO CH BRUKTP END IF BRUKTP IF ( STAT .NE. SS$_NORMAL ) BRUKTP $ CALL TRA_ERR(STAT,NFILES,NAME,NRECORDS,EBCDIC) BRUKTP BRUKTP END DO BRUKTP BRUKTP C THIS FILE IS TRANSFERRED, CLOSE IN AND OUT BRUKTP BRUKTP 10 CLOSE(OUT) BRUKTP CLOSE(IN) BRUKTP BRUKTP TRECS = TRECS + NRECORDS BRUKTP BRUKTP C TELL THE USER HOW MANY RECORDS WERE TRANSFERRED BRUKTP BRUKTP CALL TELL_HIM BRUKTP BRUKTP RETURN BRUKTP END BRUKTP BRUKTP C SUBROUTINE TRA_ERR ---- HEINZ E. BOSSHARD, EMBL, HEIDELBERG, FRG BRUKTP C INFORM THE USER ABOUT AN EBCDIC TO ASCII TRANSLATION ERROR BRUKTP BRUKTP SUBROUTINE TRA_ERR(STAT,FNO,FNAME,RECORD,EBCDIC) BRUKTP BRUKTP BRUKTP IMPLICIT NONE BRUKTP BRUKTP BRUKTP BRUKTP C VAX/VMS RUNTIME LIBRARY RETURN-CODE DEFINITIONS BRUKTP BRUKTP INCLUDE '($LIBDEF)' BRUKTP BRUKTP C PARAMETER DECLARATIONS BRUKTP BRUKTP PARAMETER PDBBLK = 4800 ! BLOCK SIZE FOR TAPE I/O BRUKTP PARAMETER PIOBUF = 24 ! NUM. I/O BUFFERS USED BRUKTP PARAMETER PDBREC = 80 ! RECORD SIZE OF PDB INPUT TAP BRUKTP PARAMETER IDLEN = 4 ! LENGTH OF UNIQUE ID STRING I BRUKTP PARAMETER IDBEG = 63 ! START OF ID STRING IN HEADER BRUKTP PARAMETER IDEND = IDBEG+IDLEN-1 ! END OF ID STRING IN HEADER BRUKTP PARAMETER LEXTN = 40 ! LENGTH OF FILE EXTENSION (IN BRUKTP PARAMETER LFNAME = 255 ! LENGTH OF FILNENAME STRINGS BRUKTP PARAMETER LPNAME = 6 ! LENGTH OF PDB PROGRAM NAME F BRUKTP PARAMETER PNBEG = 65 ! START OF PROGNAME STRING IN BRUKTP PARAMETER PNEND = PNBEG+LPNAME-1 ! END OF PROGNAME IN HEADER BRUKTP PARAMETER LTDEV = 40 ! LENGTH OF INPUT TAPE DEVICE BRUKTP PARAMETER IN = 10 ! LOGICAL INPUT UNIT BRUKTP PARAMETER OUT = 11 ! LOGICAL OUTPUT UNIT BRUKTP BRUKTP C ARGUMENTS BRUKTP BRUKTP INTEGER STAT,RECORD,FNO BRUKTP LOGICAL EBCDIC BRUKTP CHARACTER FNAME*(*) BRUKTP BRUKTP C RUNTIME LIBRARY FUNCTIONS BRUKTP BRUKTP INTEGER STR$UPCASE,STR$TRIM BRUKTP BRUKTP C LOCAL VARIABLES BRUKTP BRUKTP CHARACTER ANSWER*1,TYPE*6,NAME*(LFNAME) BRUKTP INTEGER ILEN,L,JUNK BRUKTP BRUKTP BRUKTP C EXECUTABLE CODE ====================================================== BRUKTP BRUKTP BRUKTP IF (EBCDIC) THEN BRUKTP TYPE = 'EBCDIC' BRUKTP ELSE BRUKTP TYPE = 'ASCII' BRUKTP END IF BRUKTP BRUKTP NAME = FNAME BRUKTP JUNK = STR$TRIM(NAME,NAME,ILEN) BRUKTP JUNK = STR$TRIM(TYPE,TYPE,L) BRUKTP BRUKTP IF ( STAT .EQ. LIB$_INVCHA) THEN BRUKTP WRITE(*,'(/A/A/A,A,A//A,I5/,A,I5/A,A/A///A/A)') BRUKTP $ ' ************************* ERROR *************************', BRUKTP $ ' UNDEFINED CHARACTERS - - -', BRUKTP $ ' TAPE IS NOT ENCODED ',TYPE(1:L),', NONSTANDARD, OR BAD.', BRUKTP $ ' LINE: ',RECORD, BRUKTP $ ' FILE: ',FNO, BRUKTP $ ' NAME: ',NAME(1:ILEN), BRUKTP $ ' ***********************************************************', BRUKTP $ ' DO YOU WANT TO CONTINUE ANYWAY ( OR ) ?', BRUKTP $ '$> ' BRUKTP BRUKTP READ(*,'(A)')ANSWER BRUKTP JUNK = STR$UPCASE(ANSWER,ANSWER) BRUKTP IF ( ANSWER .NE. 'Y') THEN BRUKTP STOP ' B Y E' BRUKTP ELSE BRUKTP WRITE(*,'(//)') BRUKTP RETURN BRUKTP END IF BRUKTP BRUKTP ELSE BRUKTP BRUKTP WRITE(*,'(A/A//)') BRUKTP $ ' TERMINAL ERROR IN LIB$TRA_EBC_ASC, CAN''T HAPPEN !!', BRUKTP $ ' NOTIFY THE AUTHOR OF THE PROGRAM, PLEASE !!' BRUKTP BRUKTP STOP ' THE PROGRAM DID CRASH' BRUKTP END IF BRUKTP BRUKTP END BRUKTP BRUKTP C FUNCTION OUTFORM ---- HEINZ E. BOSSHARD, EMBL, HEIDELBERG, FRG BRUKTP C FORMAT THE NUMBER NUM INTO AN EASILY BRUKTP C READ FORM, DEPOSIT STRING IN CNUM, LEFT ADJUSTED, RETURN BRUKTP C ITS LENGTH. BRUKTP BRUKTP BRUKTP INTEGER*4 FUNCTION OUTFORM( NUM, CNUM ) BRUKTP BRUKTP BRUKTP IMPLICIT NONE BRUKTP BRUKTP C ARGUMENTS BRUKTP BRUKTP INTEGER*4 NUM ! THE NUMBER OF BYTES BRUKTP CHARACTER*(*) CNUM ! THE OUTPUT STRING BRUKTP BRUKTP C FUNCTIONS BRUKTP BRUKTP INTEGER*4 LEN, JMOD, SQUISH_STR BRUKTP BRUKTP C LOCAL VARIABLES BRUKTP BRUKTP INTEGER*4 N, J, GROUP, STAT BRUKTP CHARACTER*1 BLANK/' '/ BRUKTP BRUKTP BRUKTP C EXECUTABLE CODE ====================================================== BRUKTP BRUKTP BRUKTP C BREAK THE NUMBER OF BYTES DOWN INTO GROUPS OF THOUSANDS, MILLIONS, ETC BRUKTP C ( SUPPORTED NUMBERS: AS MANY 4-CHARACTER SUBSTRINGS AS CAN BE BRUKTP C STORED IN 'CNUM' - ON OVERFLOW A STRING OF '*' IS RETURNED ) . BRUKTP BRUKTP BRUKTP CNUM = ' ' BRUKTP N = NUM BRUKTP J = LEN( CNUM ) BRUKTP BRUKTP BRUKTP DO WHILE( N .GT. 0 ) BRUKTP IF( J-3 .GT. 0 )THEN BRUKTP GROUP = JMOD( N, 1000 ) BRUKTP N = N / 1000 BRUKTP WRITE( CNUM( J-3:J ), '('','',I3.3)') GROUP BRUKTP J = J - 4 BRUKTP ELSE BRUKTP CNUM = ',********' BRUKTP GOTO 10 BRUKTP END IF BRUKTP END DO BRUKTP BRUKTP 10 CONTINUE BRUKTP BRUKTP J = SQUISH_STR( CNUM, BLANK, 1 ) BRUKTP CNUM(1:1) = BLANK BRUKTP J = SQUISH_STR( CNUM, BLANK, 1 ) BRUKTP BRUKTP ! REMOVE LEADING BLANKS BRUKTP BRUKTP N = 1 BRUKTP DO WHILE( (CNUM(N:N).EQ.'0') .AND. (CNUM(N:N).NE.BLANK) ) BRUKTP N = N + 1 BRUKTP END DO BRUKTP CNUM( 1:J ) = CNUM( N:J ) BRUKTP J = J - N + 1 BRUKTP BRUKTP IF( J.EQ.0 )THEN BRUKTP J = 1 BRUKTP CNUM(1:1) = '0' BRUKTP END IF BRUKTP BRUKTP OUTFORM = J BRUKTP BRUKTP RETURN BRUKTP END BRUKTP BRUKTP C SUBROUTINE SCAN_FILE ---- HEINZ E. BOSSHARD, EMBL, HEIDELBERG, FRG BRUKTP C JUST COUNT THE NUMBER OF RECORDS IN CURRENTLY OPEN FILE BRUKTP C CONNECTED TO LOGICAL UNIT IN. BRUKTP BRUKTP BRUKTP SUBROUTINE SCAN_FILE BRUKTP BRUKTP IMPLICIT NONE BRUKTP BRUKTP C PARAMETER DECLARATIONS BRUKTP BRUKTP PARAMETER PDBBLK = 4800 ! BLOCK SIZE FOR TAPE I/O BRUKTP PARAMETER PIOBUF = 24 ! NUM. I/O BUFFERS USED BRUKTP PARAMETER PDBREC = 80 ! RECORD SIZE OF PDB INPUT TAP BRUKTP PARAMETER IDLEN = 4 ! LENGTH OF UNIQUE ID STRING I BRUKTP PARAMETER IDBEG = 63 ! START OF ID STRING IN HEADER BRUKTP PARAMETER IDEND = IDBEG+IDLEN-1 ! END OF ID STRING IN HEADER BRUKTP PARAMETER LEXTN = 40 ! LENGTH OF FILE EXTENSION (IN BRUKTP PARAMETER LFNAME = 255 ! LENGTH OF FILNENAME STRINGS BRUKTP PARAMETER LPNAME = 6 ! LENGTH OF PDB PROGRAM NAME F BRUKTP PARAMETER PNBEG = 65 ! START OF PROGNAME STRING IN BRUKTP PARAMETER PNEND = PNBEG+LPNAME-1 ! END OF PROGNAME IN HEADER BRUKTP PARAMETER LTDEV = 40 ! LENGTH OF INPUT TAPE DEVICE BRUKTP PARAMETER IN = 10 ! LOGICAL INPUT UNIT BRUKTP PARAMETER OUT = 11 ! LOGICAL OUTPUT UNIT BRUKTP BRUKTP BRUKTP C EXTERNAL VARIABLES BRUKTP BRUKTP CHARACTER NAME*(LFNAME),ABUF*(PDBREC),PREFIX*(LFNAME) BRUKTP CHARACTER INTAPE*(LTDEV),EXTEN*(LEXTN),DEVDIR*(LFNAME) BRUKTP INTEGER NFILES/0/,NRECORDS/0/,NFOR/0/,NDATA/0/,NJUNK/0/ BRUKTP INTEGER PREFLEN/0/,DDLEN/0/,FIRSTFILE/0/,LASTFILE/0/ BRUKTP INTEGER*4 TRECS BRUKTP LOGICAL EBCDIC/.FALSE./,STATISTICS BRUKTP BRUKTP COMMON/CBRKTC/ NAME,ABUF,PREFIX,EXTEN,INTAPE,DEVDIR BRUKTP COMMON/CBRKTI/ NFILES,NRECORDS,NFOR,NDATA,NJUNK,PREFLEN,EBCDIC, BRUKTP $ DDLEN,FIRSTFILE,LASTFILE,TRECS,STATISTICS BRUKTP BRUKTP BRUKTP BRUKTP C EXECUTABLE CODE ====================================================== BRUKTP BRUKTP BRUKTP DO WHILE(.TRUE.) BRUKTP BRUKTP NRECORDS = NRECORDS + 1 ! COUNT THE RECORDS BRUKTP READ( IN, END=10 ) ! AND SKIP TO NEXT ONE - OR END BRUKTP BRUKTP END DO BRUKTP BRUKTP 10 CONTINUE BRUKTP CLOSE( IN ) BRUKTP BRUKTP TRECS = TRECS + NRECORDS BRUKTP BRUKTP C TELL HIM ABOUT SIZE ETC. BRUKTP BRUKTP CALL TELL_HIM BRUKTP BRUKTP RETURN BRUKTP END BRUKTP BRUKTP C SUBROUTINE PRINT_STAT ---- HEINZ E. BOSSHARD, EMBL, HEIDELBERG, FRG BRUKTP C PRINT OUT THE STATISTICS VALUES. BRUKTP BRUKTP BRUKTP BRUKTP SUBROUTINE PRINT_STAT BRUKTP BRUKTP IMPLICIT NONE BRUKTP BRUKTP C PARAMETER DECLARATIONS BRUKTP BRUKTP PARAMETER PDBBLK = 4800 ! BLOCK SIZE FOR TAPE I/O BRUKTP PARAMETER PIOBUF = 24 ! NUM. I/O BUFFERS USED BRUKTP PARAMETER PDBREC = 80 ! RECORD SIZE OF PDB INPUT TAP BRUKTP PARAMETER IDLEN = 4 ! LENGTH OF UNIQUE ID STRING I BRUKTP PARAMETER IDBEG = 63 ! START OF ID STRING IN HEADER BRUKTP PARAMETER IDEND = IDBEG+IDLEN-1 ! END OF ID STRING IN HEADER BRUKTP PARAMETER LEXTN = 40 ! LENGTH OF FILE EXTENSION (IN BRUKTP PARAMETER LFNAME = 255 ! LENGTH OF FILNENAME STRINGS BRUKTP PARAMETER LPNAME = 6 ! LENGTH OF PDB PROGRAM NAME F BRUKTP PARAMETER PNBEG = 65 ! START OF PROGNAME STRING IN BRUKTP PARAMETER PNEND = PNBEG+LPNAME-1 ! END OF PROGNAME IN HEADER BRUKTP PARAMETER LTDEV = 40 ! LENGTH OF INPUT TAPE DEVICE BRUKTP PARAMETER IN = 10 ! LOGICAL INPUT UNIT BRUKTP PARAMETER OUT = 11 ! LOGICAL OUTPUT UNIT BRUKTP BRUKTP BRUKTP C EXTERNAL VARIABLES BRUKTP BRUKTP CHARACTER NAME*(LFNAME),ABUF*(PDBREC),PREFIX*(LFNAME) BRUKTP CHARACTER INTAPE*(LTDEV),EXTEN*(LEXTN),DEVDIR*(LFNAME) BRUKTP INTEGER NFILES/0/,NRECORDS/0/,NFOR/0/,NDATA/0/,NJUNK/0/ BRUKTP INTEGER PREFLEN/0/,DDLEN/0/,FIRSTFILE/0/,LASTFILE/0/ BRUKTP INTEGER*4 TRECS BRUKTP LOGICAL EBCDIC/.FALSE./,STATISTICS BRUKTP BRUKTP COMMON/CBRKTC/ NAME,ABUF,PREFIX,EXTEN,INTAPE,DEVDIR BRUKTP COMMON/CBRKTI/ NFILES,NRECORDS,NFOR,NDATA,NJUNK,PREFLEN,EBCDIC, BRUKTP $ DDLEN,FIRSTFILE,LASTFILE,TRECS,STATISTICS BRUKTP BRUKTP C PROGRAM FUNCTIONS BRUKTP INTEGER*4 OUTFORM BRUKTP BRUKTP C LOCAL VARIABLES BRUKTP BRUKTP CHARACTER*20 TOTFILES,TOTFOR,TOTDATA,TOTRECS,TOTBYTES, BRUKTP $ TOTJUNK BRUKTP CHARACTER*1 BLANK/' '/ BRUKTP INTEGER*4 LFILES,LFORS,LDATA,LRECS,LJUNK,LBYTES BRUKTP BRUKTP BRUKTP C EXECUTABLE CODE ====================================================== BRUKTP BRUKTP BRUKTP ! SETUP THE OUTPUT STRINGS BRUKTP BRUKTP LFILES = OUTFORM( NFILES-FIRSTFILE+1, TOTFILES ) BRUKTP LFORS = OUTFORM( NFOR, TOTFOR ) BRUKTP LDATA = OUTFORM( NDATA, TOTDATA ) BRUKTP LRECS = OUTFORM( TRECS, TOTRECS ) BRUKTP LJUNK = OUTFORM( NJUNK, TOTJUNK ) BRUKTP LBYTES = OUTFORM( TRECS*PDBREC, TOTBYTES ) BRUKTP BRUKTP WRITE(*,'(//1X,A/5(4X,2A/)/,1X,3A//)') BRUKTP $ 'TOTALS ---', BRUKTP $ 'TOTAL FILES: ',TOTFILES(1:LFILES), BRUKTP $ 'DATA FILES: ',TOTDATA(1:LDATA), BRUKTP $ 'FORTRAN FILES: ',TOTFOR(1:LFORS), BRUKTP $ 'UNIDENTIFIED FILES: ',TOTJUNK(1:LJUNK), BRUKTP $ 'NUMBER OF RECORDS: ',TOTRECS(1:LRECS), BRUKTP $ 'TOTAL SIZE: ',TOTBYTES(1:LBYTES), BRUKTP $ ' BYTES ( EXCL. SYSTEM OVERHEAD )' BRUKTP BRUKTP BRUKTP RETURN BRUKTP END BRUKTP BRUKTP C FUNCTION SQUISH_STR --- HEINZ E. BOSSHARD, EMBL, HEIDELBERG, FRG BRUKTP C SQUISH OUT LEADING AND INTERVENING CHARACTERS FROM SOURCE STRING BRUKTP C STR. NCHARS CHARACTERS TO BE REMOVED ARE SPECIFIED IN OUTCHARS. BRUKTP C RETURNS: NEW LENGTH WITHOUT TRAILING WHITE CODE. BRUKTP C BRUKTP C NOTE: RTL FUNCTIONS ARE USED SO ANY STRING TYPE WILL BE OK. BRUKTP BRUKTP BRUKTP INTEGER*4 FUNCTION SQUISH_STR( STR, OUTCHARS, NCHARS ) BRUKTP BRUKTP IMPLICIT NONE BRUKTP BRUKTP BRUKTP C ARGUMENTS BRUKTP BRUKTP CHARACTER STR*(*) ! THE SOURCE STRING BRUKTP INTEGER NCHARS ! THE NUMBER OF CHARS TO SQUIS BRUKTP CHARACTER OUTCHARS(NCHARS) ! THE LIST OF CHARS TO BE SQUI BRUKTP BRUKTP C VAX/VMS RTL FUNCTION BRUKTP BRUKTP INTEGER*4 STR$POSITION BRUKTP BRUKTP C USED AS SUBROUTINES: STR$TRIM, STR$CONCAT BRUKTP BRUKTP C LOCAL VARIABLES BRUKTP BRUKTP INTEGER*4 L, I, N BRUKTP CHARACTER BLANK/' '/ BRUKTP BRUKTP BRUKTP C EXECUTABLE CODE ================================================== BRUKTP BRUKTP BRUKTP CALL STR$TRIM( STR, STR, L ) BRUKTP BRUKTP DO N = 1, NCHARS BRUKTP I = STR$POSITION( STR(1:L), OUTCHARS(N)) BRUKTP DO WHILE( I .NE. 0 ) BRUKTP CALL STR$CONCAT( STR(I:L), STR(I+1:L), BLANK ) BRUKTP L = L - 1 BRUKTP I = STR$POSITION( STR(1:L), OUTCHARS(N), I ) BRUKTP END DO BRUKTP END DO BRUKTP BRUKTP SQUISH_STR = L BRUKTP BRUKTP RETURN BRUKTP END BRUKTP BRUKTP C SUBROUTINE TELL_HIM --- HEINZ E. BOSSHARD, EMBL, HEIDELBERG, FRG BRUKTP C OUTPUT THE VALUES OF SIZE OF THE CURRENT FILE AS WELL AS THE BRUKTP C RUNNING TOTALS. BRUKTP BRUKTP BRUKTP SUBROUTINE TELL_HIM BRUKTP BRUKTP IMPLICIT NONE BRUKTP BRUKTP C PARAMETER DECLARATIONS BRUKTP BRUKTP PARAMETER PDBBLK = 4800 ! BLOCK SIZE FOR TAPE I/O BRUKTP PARAMETER PIOBUF = 24 ! NUM. I/O BUFFERS USED BRUKTP PARAMETER PDBREC = 80 ! RECORD SIZE OF PDB INPUT TAP BRUKTP PARAMETER IDLEN = 4 ! LENGTH OF UNIQUE ID STRING I BRUKTP PARAMETER IDBEG = 63 ! START OF ID STRING IN HEADER BRUKTP PARAMETER IDEND = IDBEG+IDLEN-1 ! END OF ID STRING IN HEADER BRUKTP PARAMETER LEXTN = 40 ! LENGTH OF FILE EXTENSION (IN BRUKTP PARAMETER LFNAME = 255 ! LENGTH OF FILNENAME STRINGS BRUKTP PARAMETER LPNAME = 6 ! LENGTH OF PDB PROGRAM NAME F BRUKTP PARAMETER PNBEG = 65 ! START OF PROGNAME STRING IN BRUKTP PARAMETER PNEND = PNBEG+LPNAME-1 ! END OF PROGNAME IN HEADER BRUKTP PARAMETER LTDEV = 40 ! LENGTH OF INPUT TAPE DEVICE BRUKTP PARAMETER IN = 10 ! LOGICAL INPUT UNIT BRUKTP PARAMETER OUT = 11 ! LOGICAL OUTPUT UNIT BRUKTP BRUKTP BRUKTP C EXTERNAL VARIABLES BRUKTP BRUKTP CHARACTER NAME*(LFNAME),ABUF*(PDBREC),PREFIX*(LFNAME) BRUKTP CHARACTER INTAPE*(LTDEV),EXTEN*(LEXTN),DEVDIR*(LFNAME) BRUKTP INTEGER NFILES/0/,NRECORDS/0/,NFOR/0/,NDATA/0/,NJUNK/0/ BRUKTP INTEGER PREFLEN/0/,DDLEN/0/,FIRSTFILE/0/,LASTFILE/0/ BRUKTP INTEGER*4 TRECS BRUKTP LOGICAL EBCDIC/.FALSE./,STATISTICS BRUKTP BRUKTP COMMON/CBRKTC/ NAME,ABUF,PREFIX,EXTEN,INTAPE,DEVDIR BRUKTP COMMON/CBRKTI/ NFILES,NRECORDS,NFOR,NDATA,NJUNK,PREFLEN,EBCDIC, BRUKTP $ DDLEN,FIRSTFILE,LASTFILE,TRECS,STATISTICS BRUKTP BRUKTP C FUNCTION BRUKTP BRUKTP INTEGER*4 OUTFORM BRUKTP BRUKTP C LOCAL VARIABLES BRUKTP BRUKTP CHARACTER*(20) C1,C2,C3,C4 BRUKTP INTEGER*4 L1,L2,L3,L4 BRUKTP BRUKTP BRUKTP C EXECUTABLE CODE ====================================================== BRUKTP BRUKTP BRUKTP BRUKTP L1 = OUTFORM( NRECORDS, C1 ) BRUKTP L2 = OUTFORM( NRECORDS*PDBREC, C2 ) BRUKTP L3 = OUTFORM( TRECS, C3 ) BRUKTP L4 = OUTFORM( TRECS*PDBREC, C4 ) BRUKTP BRUKTP WRITE(*,'(2(3X,5A/))') BRUKTP $ 'THIS FILE: ',C1(1:L1),' RECORDS, ', BRUKTP $ C2(1:L2),' BYTES', BRUKTP $ 'RUNNING TOTAL: ',C3(1:L3),' RECORDS, ', BRUKTP $ C4(1:L4),' BYTES' BRUKTP BRUKTP RETURN BRUKTP END BRUKTP