> From CUVMB.CC.COLUMBIA.EDU!JCHBN Thu Mar 10 17:45:17 1994 > From: "John F. Chandler" > Here it is. All simple Fortran. Complete with internal doc. John ---------------------- ttmatch ----------------------------- program ttmatch c c J.F. Chandler - 1994 - jchbn@cuvmb.cc.columbia.edu c c Read a list of names and soundex codes, each with a target year and c tolerance. Then match those names/codes against all the Tinytafels c in the input file (Fortran unit 1). Print a listing of all potential c matches. If the first record of the input file begins with the string c 'RSL ', the input is taken to be a copy of the ROOTS-L Surname list. c In that case, soundex codes are not supported. Further, if the file c begins with 'INDEX', the input is taken to be a list of surnames with c no dates at all. c c All comparisons are case-insensitive, but imbedded "punctuation" must c match exactly, as must any letters with diacritical marks, since the c case conversion works only for a-z. c c A Tinytafel entry may contain more than one surname, but this program c searches only the first 20 characters for multiple names. E.g., if c the entry has "Hinchley,Hinksley,Hinkly", the names checked would be c "Hinchley", "Hinksley", and "Hi". Long names are truncated to 20 c characters. c c Input control format: c year 1-4 c tolerance 5-7 c name 9-28 -OR- c code 9-12 c etc. 29-80 (ignored) c c Tinytafel format: (the headers must begin with "N" and end with "Z") c soundex 1-4 c start yr 6-9 c end yr 11-14 c name,etc. 16-80 (name\start-location/end-location) c Entries end at a "W" code. c c RSL format: c note 1-1 (ignored) c name 2-13 (or name - see other-name) c note 14-14 (reserved for "c" = circa, ignored) c start yr 15-18 c note 20-20 (also for circa) c end yr 21-24 c etc. 26-80 c implicit none c integer maxtst,maxhdr parameter (maxtst=300,maxhdr=30) c character*80 hdrs(maxhdr), card,xcard character*20 test(maxtst),name,sname character*4 scode integer*4 tyear(maxtst),tol(maxtst),year1,year2 logical soundex(maxtst),found integer*4 i,j,ncards,next,nhdrs,nmatch,ntest,numtt,numerr c character*4 upa/' A'/, lowa/' a'/ integer*4 iupa,ilowa,Upmlow equivalence (upa,iupa),(lowa,ilowa) common/chroff/ Upmlow c c compute offset between upper and lower case letters Upmlow=iupa-ilowa c i=1 90 read(5,100,end=200) tyear(i),tol(i),test(i) 100 format(i4,i3,1x,a20) call fixnam(test(i),next) soundex(i)= (test(i)(2:2).ge.'0' .and. test(i)(2:2).le.'9') i=i+1 if(i.le.maxtst) goto 90 write(6,110) maxtst 110 format('Warning! Filled up array of search names at',i4,'.'/ . 'Increase MAXTST??') c 200 ntest=i-1 write(6,210) ntest 210 format('---- Seeking',i4,' name entries in file 1...') ncards=0 nmatch=0 numerr=0 numtt=0 c c seek tt header. 'j=1' indicates looking for start. c 'j>1' indicates looking for end. c 250 j=0 c c get another header line 290 if(j.lt.maxhdr) j=j+1 c c read a tentative header line 300 read(1,310,end=999) hdrs(j) 310 format(a80) ncards=ncards+1 if(j.eq.1) then if(ncards.eq.1) then if(hdrs(1)(1:4).eq.'RSL ') goto 790 if(hdrs(1)(1:5).eq.'INDEX') goto 900 endif if(hdrs(j)(1:2).ne.'N ') goto 300 numtt=numtt+1 elseif(hdrs(j)(2:2).ne.' ') then numerr=numerr+1 goto 250 else if(hdrs(j)(1:1).eq.'Z') goto 400 endif goto 290 c c found end of header 400 nhdrs=j-1 found=.false. c c read a name entry 500 read(1,310,end=999) card ncards=ncards+1 if(card(1:2).eq.'R ' .or. card(1:2).eq.'Z ') goto 500 if(card(1:2).eq.'W ' .or. card(5:5).ne.' ') then if(found) write(6,510) numtt,card(2:50) 510 format('---- End of TT ',i5,': created',a49) if(card(1:2).ne.'W ') numerr=numerr+1 goto 250 endif xcard=card call fixdat(xcard(6:9),'0') call fixdat(xcard(11:14),'9') read(xcard,520) scode,year1,year2,name 520 format(a4,1x,i4,1x,i4,1x,a20) 525 sname=name call fixnam(name,next) do 600 i=1,ntest if(tyear(i)-tol(i).gt.year2 .or. tyear(i)+tol(i).lt.year1) . goto 600 if(soundex(i)) then if(scode.ne.test(i)(1:4)) goto 600 else if(name.ne.test(i)) goto 600 endif if(.not.found) then write(6,530) numtt,(hdrs(j),j=1,nhdrs) 530 format('---- matches for tt',i5/(a80)) if(nhdrs.eq.maxhdr) write(6,540) maxhdr 540 format('(Warning. Filled header array with',i3,' lines.', . ' Increase MAXHDR?)') found=.true. endif nmatch=nmatch+1 write(6,310) card goto 500 600 continue if(next.eq.0) goto 500 c Another name follows, try again name(1:21-next)=sname(next:20) name(22-next:22-next)='/' goto 525 c c use RSL input instead of TT 790 write(6,795) hdrs(1) 795 format('Using surname-list format:'/a72) c 800 read(1,310,end=999) card ncards=ncards+1 xcard=card call fixdat(xcard(15:18),'0') call fixdat(xcard(21:24),'9') read(xcard,810) name,year1,year2 810 format(1x,a12,1x,i4,2x,i4) call fixnam(name,next) do 830 i=1,ntest if(tyear(i)-tol(i).gt.year2 .or. tyear(i)+tol(i).lt.year1) . goto 830 if(name.ne.test(i)) goto 830 nmatch=nmatch+1 write(6,310) card goto 800 830 continue goto 800 c c just scan list of names 900 write(6,910) hdrs(1) 910 format('Scanning index of surnames:'/a72) c 920 read(1,310,end=999) card ncards=ncards+1 name=card(1:12) call fixnam(name,next) do 930 i=1,ntest if(name.ne.test(i)) goto 930 nmatch=nmatch+1 write(6,310) card goto 920 930 continue goto 920 c 999 write(6,1000) numtt,numerr,ncards,nmatch 1000 format('---- End of input after',i5,' tafels,',i5,' errors,', . i6,' total lines.'/ . '----',i5,' matches found.') stop end subroutine fixnam(name,next) implicit none c common/chroff/ Upmlow integer*4 Upmlow c c Parameters: name = character string containing a surname, possibly c with trailing garbage separated by slashes c next = returned index of a second surname found after c a comma in the array, or 0 if none found c character*20 name integer next integer i,j character*4 cj equivalence (cj,j) c next=0 do 100 i=1,20 cj(4:4)=name(i:i) if(cj(4:4).eq.'\' .or. . cj(4:4).eq.'/' .or. . cj(4:4).eq.',' .or. . (i.lt.19 .and. name(i:i+2).eq.' - ')) then do 50 j=i,20 name(j:j)=' ' 50 continue if(cj(4:4).eq.',') next=i+1 return endif if(cj(4:4).ge.'a' .and. cj(4:4).le.'z') then j=j+Upmlow name(i:i)=cj(4:4) endif 100 continue return end subroutine fixdat(date,def) implicit none character*4 date character*1 def integer i c do i=1,4 if(date(i:i).lt.'0' .or. date(i:i).gt.'9') date(i:i)=def end do return end c /end/