PROGRAM CREATE_TTL ! Version 1.0, September 1990 C************************************************************************ C* This program creates a .TTL file from the .REF file * C* of an NBRF formatted database. * C* The programs access command line input is as follows * C* * C* CREATETTL 'database_name'/LENCODE * C* * C* default 'database_name' = PR$PIR1: * C* LENCODE may equal 6, 8, 10; default = 6 * C************************************************************************ C* * C* This is a limited-distribution, prototype version of * C* * C* the Experimental Query System (XQS) * C* * C* and associated software * C* * C* National Biomedical Research Foundation (NBRF) * C* Georgetown University Medical Center * C* 3900 Reservoir Road, N.W. * C* Washington, D.C. 20007 USA * C* Tel. (202) 687-2121 * C* * C* * C* We have made every effort to ensure proper functioning of the * C* programs and cannot be held responsible for the consequences * C* to users of any problems encountered during their operation. * C* * C* * C* Operating Environment: * C* Computer: Digital Equipment Corporation MicroVAX 3800 * C* System: VAX/VMS version 5.3 * C* Language: VAX-11 FORTRAN (a superset of ANSI FORTRAN-77) * C************************************************************************ C------------------------------------------------------------------------ CHARACTER DATA_BASE*80,LINE*500,LINE_2*500 CHARACTER KODE*10,CMD*132,LCODE*2 C ---Get input parameters--- DATA_BASE='PR$DATA_BASE:' LENCODE=6 CALL LIB$GET_FOREIGN(CMD) IF (CMD.GT.' ') THEN LE=LENGTH(CMD) LCODE=' ' M=INDEX(CMD,'/') IF (M.GT.0) THEN LE=M-1 LCODE=CMD(M+1:M+2) END IF IF (LE.GT.0) DATA_BASE=CMD(1:LE) ELSE WRITE (6,'(A)') '$Database: ' READ (5,'(A)') DATA_BASE CALL STR$UPCASE(DATA_BASE,DATA_BASE) WRITE (6,'(A)') '$Code Length (6, 8, or 10) [6]: ' READ (5,'(A)') LCODE END IF C ---Set code length--- IF (LCODE(1:1).EQ.'6') THEN LENCODE=6 ELSE IF (LCODE(1:1).EQ.'8') THEN LENCODE=8 ELSE IF (LCODE(1:2).EQ.'10') THEN LENCODE=10 ELSE LENCODE=6 WRITE (6,'(1X,A)') 'A code length of 6 will be assumed' END IF C ---Open reference file (.REF) and create title file (.TTL)--- OPEN (1,FILE=DATA_BASE//'.REF',STATUS='OLD',READONLY,SHARED, 1 ERR=999) OPEN (2,FILE=DATA_BASE//'.TTL',STATUS='NEW', 1 CARRIAGECONTROL='LIST',RECL=500,ERR=999) NENTRY=0 C ---Read header line--- 10 READ (1,'(Q,A)',END=90) LE,LINE 15 IF (LINE(1:1).NE.'>') GO TO 10 NENTRY=NENTRY+1 KODE=LINE(5:5+LENCODE-1) C ---Read Title line--- READ (1,'(Q,A)',END=990) LE,LINE LINE_2=KODE(1:LENCODE)//LINE(1:LE) L2=LE+LENCODE KODE=' ' C ---Search for N-lines--- 20 READ (1,'(Q,A)',END=990) LE,LINE IF (LINE(1:2).EQ.'N;') THEN C --Write continuation line-- WRITE (2,'(2A)') LINE_2(1:L2),'-' LINE_2=KODE(1:LENCODE)//LINE(3:LE) L2=LE+LENCODE GO TO 20 END IF C ---Write title of last N; line--- L2=MIN(L2,500) WRITE (2,'(A)') LINE_2(1:L2) GO TO 15 90 WRITE (6,'(1X,A,I6)') 'Number of entries processed: ',NENTRY STOP ' ' 990 CLOSE (2,DISP='DELETE') STOP ' abnormal end-of-file' 999 STOP ' Database file open error' END C********************************************************************** INTEGER FUNCTION LENGTH(LINE) CHARACTER LINE*(*) C C Purpose: C LENGTH locates the last non-blank character in the character C string represented in LINE. C C Input: C LINE a character string C C Output: C LENGTH the character position of the rightmost non-blank C character of the string in LINE. If LINE is blank, C then LENGTH is 0. C C Notes: C The ASCII control characters are treated as blanks. Therefore, C the test in the loop is CHAR > ' ' instead of CHAR .ne. ' '. C======================================================================= DO 10 LENGTH=LEN(LINE),1,-1 10 IF (LINE(LENGTH:LENGTH).GT.' ') RETURN LENGTH=0 END