!ego2cpl.for = this also writes a p-xxx.si* sibling set file see V:ater ! DEBUG ADDED to take out 1+ndim/2 ! DEBUG JAN 1999 TOOK THIS OUT C if (indiv (egoN,1).eq.2.and.ymale.eq.'X') then C write (*,'(3a)')' 2 Do you want to allow Male-Male ',malelink,'?' C ymale=getcharqq() C if (ymale.eq.'y') ymale='Y' C endif !Prototype: C blood kin in male line and daughters married in (wives and s-in-l) C labels Name BDate BH MH DDate C18540001V:Pipp, Andreas d:by WW I messn 1854h 77? 2#1908 C1854 M: 1858h 0 2 1935 Pipp, Ursula b Korpitch d:chi C1854 S:Pipp, Hans d:before WW I 188?h 2 -2 1914 C1854 S:Pipp, Franz d:before WW I 188?h 2 -2 190? C1854 SW 189?h 14 74 19?? Pipp, Agnes b Godec sister of C1854 S:Pipp, Johann messner & sddlma 1882h 2 1968 C1854 x 1891h 9 2 1959 Theresia b Godec da:smith God C1854 x2345678901234567890123456789012345678901234567890123456789012345678901234567890 C x2 29 x 4 x 4 + 4 + 4 x29=79 !write (1,'(A4,I4,A2,A29,1X,A,A4,A1,3A4,1x,A29) !avec(1,j) seq hname(j) avec(1,j) (2 (3 (4 !avec(1,j) seq avec(5,j) (6 (7 (8 wname(j) C for all par(i)=j !avec(1,j) seq hname(i) avec(1,i) (2 (3 (4 !avec(1,j) seq avec(5,i) (6 (7 (8 wname(i) !order of avec(1,j) is created by C (1) 4col date of avec(1,j) repeated C and (2) sequential record number of writing; SORT WHEN DONE! !ADD ALPHANUMERIC !avec(1 H BDate 4col (add 1st col="1") Male !avec(2 H BH 4col Birth-House Male !avec(3 H MH 4col Marriage-House Male !avec(4 H DDate 4col (add 1st col="1") Male !avec(5 W BDate 4col (add 1st col="1") Female !avec(6 W BH 4col Birth-House Female !avec(7 W MH 4col Marriage-House Female !avec(8 W DDate 4col (add 1st col="1") Female !ego2cpl- makes p-xxx.nad C J pvec(1 (2(7 (6 (5 (3 hname(j) (4 wname(j) C COUPL H-Pa W-Pa * mdec mh# Husband Wife C 8 6 0 3 88 2: 9 Pipp, Andreas d:by WW I mess 10 Pipp, Ursula b Korpitch d:ch C 9 8 0-2 90 2: 11 Pipp, Hans d:before WW I 0 C 10 8 11-2 91 2: 1253 Pipp, Franz d:before WW I 1262 Pipp, Agnes b Godec sister o C 12 8 13 1 91 2: 13 Pipp, Johann messner & sddlm 12 Pipp, Theresia b Godec da:sm C *$large: indiv !NOTE: THE GOTO 6 after error checking requires 1+ndim/2 dimensions !NOTE: IF YOU HAVE A PARENT LISTED WITHOUT SPOUSE, WILL CREATE NEW COUPLE !AND THIS COUPLE WILL NOT RECOGNIZE NAME OF SPOUSE C$pack:1 C$truncate C$large: hname, wname !$storage:2 !NOTE: DEC IS DECADE OF BIRTH indiv(..,4) , Pvec 6 decade of first child's birth !NOTE: I8,I9 are inher, purchase , Pvec 7 0,1,2 code below (Feistritz) INTEGER*2 SYSTEMQQ !ADDED NOV 1997: indiv (...,7) to capture EgoN c integer*1 couples (9998) integer*2 EgoN, SpoN, FaNo, MoNo, coupl, indiv (10900,7), dec integer*2 pvec (7,9998), jdec(30,8) ! Hpa Wpa HNo WNo integer*2 multwive (30), multhusb (30) integer*2 female (3,10900), male (3,10900) integer*2 h1,h2,h3,h4,w1,w2,w3,w4 character*60 format C see name=nam1(1:29) character*40 nam1 character*40 name, hname(9998), wname(9998), hnamej C character*29 nam1 C character*29 name, hname(9998), wname(9998), hnamej character*14 filenam, filedoc, filevec, filetxt, filename character*14 fileged character*14 filedes, malelink, femalink character*40 title character*3 ParentHH, ext character*4 av1, av2, av3, av4, avec(8,9998), avec1k, zero character*1 sex, ans, an1, an2, an3, an4, an5, an6, i8, i9, anF character*1 GETCHARQQ[EXTERN], xq, answ, e1, lab1, lab2 character*1 xsex, ymale, yfema, ysex character*65 text, lasttext ymale='X' yfema='X' ysex='X' xsex='X' malelink='"marriage"' femalink='"marriage"' !DEBUG C write (*,*) ' Will you want sibling set output?' C write (*,*) ' say NO to get error-free DOC file!' C write (*,*) ' use test.res to debug K: L:' C answ=getcharqq() C if (answ.eq.'y') answ='Y' zero=' ' ndim=9998 ! max number of couples C**************************** INITIALIZE NAME LENGTH idim=10900 ! max number of individuals do j=1,idim indiv(j,4)=0 ! DEC indiv(j,5)=0 ! enddo C*********** C ... is the LINE NUMBER NOT THE INDIVIDUAL NUMBER C indiv (...,1) = 1 male or 2 female -> =3 marr'd males =4 marr'd females C 3=1 male w 1 wife 5=2 7=3 etc C 4=1 fema w 1 husb 6=2 8=3 etc C indiv (...,2) = FaNo -> whether used C indiv (...,3) = MoNo -> reused for colors C indiv (...,4) = Dec Decade of Birth C indiv (...,5) = First couple number where individual appears C pvec(1 = h par (couple number) C pvec(2 = w par (couple number) C pvec(3 = h num (the original male id, but now for the couple) C pvec(4 = w num (the original female id, but now for the couple) C pvec(5 = group num ngr= postmar res, or premar if same C pvec(6 = decade of first child's birth C pvec(7 = -2=moved 0=neither 1=inheritance, 2=purchase do j=1,ndim pvec(5,j)=0 pvec(6,j)=444 pvec(7,j)=0 enddo C**************************** GET INPUT FILENAME AND FORMAT maxindv=0 write (*,'(a)') +' Ego2Cpl.for (c)1994-7 Douglas R. White, UC Irvine Ver 2.7 8/97', +' special thanks to Patricia Skyhorse for interface suggestions', +' This program reads an input file that contains kinship data', +' formatted in accordance with the manual.' write (*,'(a\)') ' filename? ' read (*,'(a)') filetxt open (4, file='dummies') open (1, file=filetxt) write (*,'(a\)') ' 3 letter extension or xxx for saving files? ' read (*,'(a)') ext iline=2 read (1,'(i4,a)',err=11) iform, title write (*,'(A)') ' This program will:', +' 1.flag and store errors in data entry. A person might, for', +' example, be listed once as a husband and again as a mother,', +' or might be listed as his or her own parent.', +' 2.if any individuals are multiply married but lack a reference', +' to a parent, a file of links to virtual parents is created', +' that can be inserted in the data file.', +' 3.create a standard genealogical *.GED (GEDCOM) file. ', +' 4.create a series of files for specialized use with P-graph', +' programs (*.ved, *.doc, *.nad, and sometimes *.crd files.', +' 5.create a standard *.NET (network) for use with Pajek.', +' For the last option:', +' WHAT DO YOU WANT TO MAKE ACCESSIBLE TO PAJEK from the NUMBERS an +d', +' NAMES (substrings up to 40 columns) you assigned to individuals? +', +' ', +' A. Make NAMES available for arcs, NUMBERS for Vertices', +' B. Make NAMES or substrings of names available for both', +' C. Make NUMBERS available for labeling both arcs and vertices', +' D. Make NUMBERS available for arcs, NAMES for Vertices', +' Now type one of these four letters -A B C D- and press RETURN' C23456789012345678901234567890123456789012345678901234567890123456789012 read (*,'(A)') answ if (answ.eq.'b') lab1='Y' if (answ.eq.'d') lab1='Y' if (answ.eq.'B') lab1='Y' if (answ.eq.'D') lab1='Y' C +' A. FOR PAJEK LABELS OF VERTICES' C write (*,'(a/,a)') ' Y) for names as labels? (Default=Individual', C +' N)umbers)' C read (*,'(A)') lab1 C if (lab1.eq.'y') lab1='Y' if (lab1.eq.'Y') then C23456789012345678901234567890123456789012345678901234567890123456789012 write(*,'(A)')' what will be put in the Pajek NET file to label', +' o o o o-> VERTICES <-o o o o', +' are those parts of the INDIVIDUAL NAMES in your file,', +' up to 40 columns, or whatever substring (e.g., 2-5) ', +' you specify here:', +' Press four times to use the entire name', +' but if you want substrings, then follow these instructions', +' and after entering each number' write (*,*) +" Use that part of the Husband's NAME starting in column?" !hname read (*,'(I4)') h1 write (*,*) +" Use that part of the Husband's NAME ending in column?" !hname read (*,'(I4)') h2 write (*,*) +" Use that part of the Wife's NAME starting in column?" !hname write (*,*) ' First chararacter in Wife Node Label? min=1' read (*,'(I4)') w1 write (*,*) +" Use that part of the Wife's NAME ending in column?" !hname read (*,'(I4)') w2 endif if (answ.eq.'a') lab2='Y' if (answ.eq.'b') lab2='Y' if (answ.eq.'A') lab2='Y' if (answ.eq.'B') lab2='Y' C write (*,*) C +' B. FOR PAJEK LABELS OF ARCS OR LINES' C write (*,'(a/,a)') ' Y) for names as labels? (Default=Individual', C +' N)umbers)' C read (*,'(A)') lab2 C if (lab2.eq.'y') lab2='Y' if (lab2.eq.'Y') then write(*,'(A)')' what will be put in the Pajek NET file to label', +' ---> ARCS <---', +' are those parts of the INDIVIDUAL NAMES in your file,', +' up to 40 columns, or whatever substring (e.g., 2-5) ', +' you specify here:', +' Press four times to use the entire name', +' but if you want substrings, then follow these instructions', +' and after entering each number' write (*,*) +" Use that part of the Husband's NAME starting in column?" !hname read (*,'(I4)') h3 write (*,*) +" Use that part of the Husband's NAME ending in column?" !hname read (*,'(I4)') h4 write (*,*) +" Use that part of the Wife's NAME starting in column?" !hname write (*,*) ' First chararacter in Wife Node Label? min=1' read (*,'(I4)') w3 write (*,*) +" Use that part of the Wife's NAME ending in column?" !hname read (*,'(I4)') w4 C write (*,*) ' First chararacter in Husband Line Label? min=1'!hname C read (*,'(I4)') h3 C write (*,*) ' Last chararacter in Husband Line Label? max-40' C read (*,'(I4)') h4 C write (*,*) ' First chararacter in Wife Line Label? min=1' C read (*,'(I4)') w3 C write (*,*) ' Last chararacter in Wife Line Label? max-40' C read (*,'(I4)') w4 endif if (h1.lt. 1) h1=1 if (h3.lt. 1) h3=1 if (w1.lt. 1) w1=1 if (w3.lt. 1) w3=1 if (h1.gt.40) h1=1 if (h3.gt.40) h3=1 if (w1.gt.40) w1=1 if (w3.gt.40) w3=1 if (h2.lt. 1) h2=40 if (h4.lt. 1) h4=40 if (w2.lt. 1) w2=40 if (w4.lt. 1) w4=40 if (h2.gt.40) h2=40 if (h4.gt.40) h4=40 if (w2.gt.40) w2=40 if (w4.gt.40) w4=40 goto 12 11 backspace (1) read (1,'(a)') title WRITE(*,'(1x,a)') title pause 12 if (iform.ge.1.and.iform.le.8) then write (*, '(/a,I3,a/)') ' Your data is in format #',iform,':' write (*,'(A\)') ' E)xpress run (skip on-screen error checking)? ' e1=getcharqq() if (e1.eq.'e') e1='E' write (*,'(A)') E1 else write (*, '(a)') ' Choose from these formats:' endif write (*, '(15(a/))') + ' FORMATS FOR GENERAL USE ', + ' 1. Ego#, name, sex, Fa#, Mo#, Spo#', + ' 2. Ego#, sex, name, Fa#, Mo#, Spo#', + ' 3. Ego#, name, sex, Spo#, Fa#, Mo#, DECades ', + ' 4. Ego#, sex, name, Spo#, Fa#, Mo#', + ' 5. Ego#, sex, Spo#, Fa#, Mo#, name', + ' ', + ' CASE-SPECIFIC FORMATS FOR SPECIALIZED USE (see D. White)', + ' 6. Ego#, sex, Spo#, Fa#, Mo#, Pre-Marital Residence, Decade of + Birth,', + ' Post-Marital Resididence, Name (example: Feistritz study)', + ' 7. Ego#, sex, Spo#, Fa#, Mo#, Pre-M Res, Inher, Decade of Bi +rth,', + ' Post-Marital Resid, Purchase, Name (example: Feistritz stud +y)', + ' 8. Ego#, sex, Spo#, Fa#, Mo#, Name, Decade of Birth,', + ' Post-Marital Res1, Post-Marital Res2 (e.g., Trukese study)' C + ' Post-Marital Resid, Purchase, Name (e.g., Feistritz study)', C + ' 8. Ego#, sex, Spo#, FaAd, MoAd, Fa#, Mo#, Name, Decade of Bir C +th,',' Post-Marital Res1, Post-Marital Res2 (e.g., Trukese study)' if (iform.ge.1.and.iform.le.8) goto 13 ! skip manual entry C if (iform.ge.1.and.iform.le.8.and.iread.ne.1) goto 13 ! skip manual entry write (*,'(A\)') ' Please enter the appropriate format number ' write (*,'(A\)') 'and press Enter/Return: ' read (*,*, err=11) IFORM 13 if (iform.lt.1.or.iform.gt.8) then goto 12 C iread=1 endif C write (*,'(a,i5,2a)') ' will read',ndim,' records from file ', C +filetxt, ':' ans='Y' C write (*,'(a\)') ' check for errors? ' C read (*,'(a)') ans C anF='Y' if (e1.ne.'E') then write (*,'(A/,A/)') ' Hopefully you remembered to create "dummy pa +rents"', +' for those individuals who have multiple spouses and no siblings' write (*,*) ' press Enter/Return ' C read (*,'(A)') anF if (anf.eq.'y') anf='Y' C if (anf.eq.'Y') then C write (*,*) ' Sorry, cant do that yet: info in errors file' C anf='N' C endif endif write (*,'(/,5(A,/))') ' Choose an Option: and then press +Enter/Return',' ', +' D)ata with no eliminations (default)', +' S)trip off nodes with no parents or no children ("strings")', +' C)ut off all layers of nodes with no multiple links ("core")' an2=getcharqq() if (an2.eq.'s') an2='S' if (an2.eq.'c') an2='C' an3='D' ! vector data default if (an2.eq.'S') an3='S' ! strings if (an2.eq.'C') an3='S' ! core=strings for an3 an4=an3 if (an2.eq.'C') an4='C' ! core if (an3.eq.'C'.or.an3.eq.'S') an5='Y' ! pare down the list if (an4.eq.'C') then write (*,'(A\)') ' expand core to all children of core?' read (*,'(A)') an6 if (an6.eq.'y') an6='Y' endif if (e1.ne.'E') then write (*,'(A\)') ' Number of records to list? (default=0) ' read (*,'(I4)') nlist endif C**************************** CHOOSE TYPE OF OUTPUT 743 an1='1' if (e1.ne.'E') then write (*,'(//A)') ' Type of output? (default=both) ' C write (*,'(3(A/),A\)') C +' 1. Output p-xxx.* p-graph files', filedoc='p-xxx.*' filedoc(3:5)=ext fileged='p-xxx.ged' fileged(3:5)=ext write (*,'(2(3a,/),A/,A\)') +' 1. Output ',filedoc,' p-graph files', +' 2. Output ',fileGED,' GED file' C +' 2. Output ',fileGED,' GED file', C +' 3. Both types',' ? ' an1='3' C read (*,'(A)') an1 if (ichar(an1).eq.32) an1='1' endif if (an1.ne.'1'.and.an1.ne.'2'.and.an1.ne.'3') goto 743 ! (repeat) C**************************** OPEN INDIVIDUAL NUMBER FILES AS INPUT C**************************** ERROR CHECKING if (ans.eq.'Y'.or. ans.eq.'y') then !error checking: C 1. number in spouse should be of the right sex C 2. parents should be of right sex length=0 read (1,'(a)') format WRITE(*,'(1x,a,a,i2)') format, 'type=',iform C**************************** OPEN P-XXX.VEC open (2, file='errors') do k=1,ndim ! READ DATA FIRST TIME malemale=0 femafema=0 if (iform.eq.1) +read (1, format,end=5,err=5) EgoN, nam1, sex, FaNo, MoNo, SpoN if (iform.eq.2) then read (1, format,end=5,err=5) EgoN, sex, nam1, FaNo, MoNo, SpoN write (*,format) EgoN, sex, nam1, FaNo, MoNo, SpoN endif if (iform.eq.3) +read (1, format,end=5,err=5) EgoN, nam1, sex, SpoN, FaNo, MoNo, +DEC if (iform.eq.4) +read (1, format,end=5,err=5) EgoN, sex, nam1, SpoN, FaNo, MoNo if (iform.eq.5) +read (1, format,end=5,err=5) EgoN, sex, SpoN, FaNo, MoNo, nam1 goto 54 55 continue write (2,'(a,I5)') ' 6 bad line', iline write (*,'(a,I5)') ' 6 bad line', iline write (*, '(A1\)') ' ' write (*, format) + EgoN, sex, SpoN, FaNo, MoNo, NG1, I8, DEC, NG2, I9, nam1 if (e1.ne.'E') then write (*,*) ' press Enter/Return ' xq=getcharqq() endif pause 54 if (iform.eq.6) then CC read (1, '( I4, A1, I4,1x,I4,1x,i4,6x,i3,2x,I2,5x,i3,2x,a)', read (1, format, + end=5,err=55) EgoN,sex,SpoN, FaNo, MoNo, NG1, DEC, NG2, nam1 endif if (iform.eq.7) then CCCCCCCCread (1, '(I4, A1, I4,1x,I4,1x,i4,6x,i3,A,1x,I2,5x,i3,A,1x,a)', iline=iline+1 read (1, format, end=5, err=57) + EgoN, sex, SpoN, FaNo, MoNo, NG1, I8, DEC, NG2, I9, nam1 goto 58 57 write (2,'(a,I5)') ' 7 bad line', iline write (*,'(a,I5)') ' 7 bad line', iline C(I4,A1,I4,2(1x,I4),8x,i3,A,1x,I2,5x,i3,A1,1x,a) write (*, '(A1\)') ' ' write (*, format) + EgoN, sex, SpoN, FaNo, MoNo, NG1, I8, DEC, NG2, I9, nam1 if (e1.ne.'E') then write (*,*) ' press Enter/Return ' xq=getcharqq() endif pause goto 54 58 if (EgoN.ge.idim) then write (*,'(a,I6)') ' a:exceeding', idim pause goto 5 endif c xxxxxxng1 C024M2025 0681 0680 80:60123*-938 80*!Leiler, Raimond tischlermeister near HN123 got half of HN80: C note 0681 0680 comes in first and a parent, later as a couple! C681M0680 1018 1027124:18 60*-905 123* Leiler, Valentine tischlermeister endif goto 60 59 continue write (2,'(a,I5)') ' 8bad line', iline write (*,'(a,I5)') ' 8bad line', iline write (*, '(A1\)') ' ' write (*, format) + EgoN, sex, SpoN, FaNo, MoNo, NG1, I8, DEC, NG2, I9, nam1 if (e1.ne.'E') then write (*,*) ' press Enter/Return ' xq=getcharqq() endif pause 60 if (iform.eq.8) then read (1, format, + end=5,err=59) EgoN,sex,SpoN, FaNo, MoNo, nam1, DEC, NG1, NG2 C + ' 8. EgoN, sex, SpoN, FaNo, MoNo, Name, Decade of Birth,', C +' Post-Marital Res1, Post-Marital Res2 (e.g., Trukese study)' C + ' 8. EgoN, sex, SpoN, FaAd, MoAd, FaNo, MoNo, Name, Decade of Bir C +th,',' Post-Marital Res1, Post-Marital Res2 (e.g., Trukese study)' endif if (sex.eq.'m'.and.ysex.eq.'X') then ! ysex write (*,*) +' Treat gender "m" as male-male links (default: ignore)?' ysex=getcharqq() if (ysex.eq.'y') ysex='Y' if (ysex.eq.'Y') then write (*,*) write (*,*) +' Enter word to describe the male-male links and Enter/Return' read (*,'(A)') malelink endif endif if (sex.eq.'f'.and.xsex.eq.'X') then ! xsex write (*,*) +' Treat gender "f" as female-female links (default: ignore)?' xsex=getcharqq() if (xsex.eq.'y') xsex='Y' if (xsex.eq.'Y') then write (*,*) write (*,*) +' Enter word describing female-female links and Enter/Return' read (*,'(A)') femalink endif endif C if (sex.eq.'m'.and.ysex.eq.'Y') sex='M' if (sex.eq.'m'.and.ysex.eq.'Y') malemale=1 if (sex.eq.'f'.and.xsex.eq.'Y') sex='F' if (sex.eq.'f'.and.xsex.eq.'Y') femafema=1 if (iform.ge.6) then if (sex.eq.'S') goto 5 if (EgoN.eq.last1.and.SpoN.eq.last2) goto 54 last1=EgoN last2=SpoN if (EgoN.le.0) goto 54 if (sex.ne.'M'.and.sex.ne.'F') goto 54 endif if (SpoN.lt.-3) goto 721 !husband/wife error checking if (sex.eq.'M'.and.EgoN.gt.0.and.SpoN.gt.0) then male (1,k)=EgoN !k= male (2,k)=SpoN endif if (sex.eq.'F'.and.EgoN.gt.0.and.SpoN.gt.0) then female (1,k)=EgoN female (2,k)=SpoN endif if (FaNo.gt.maxindv.and.FaNo.le.idim) maxindv=FaNo if (MoNo.gt.maxindv.and.MoNo.le.idim) maxindv=MoNo if (EgoN.gt.maxindv.and.EgoN.le.idim) maxindv=EgoN if (SpoN.gt.maxindv.and.SpoN.le.idim) maxindv=SpoN if (EgoN.gt.0.and.(EgoN.eq.FaNo.or.EgoN.eq.MoNo)) then write (*,'(I5,a,2i5)') EgoN,' is child? of', FaNo, MoNo stop endif name=nam1(1:40) if (EgoN.ne.0) then if (k.le.nlist) then C nlength=len(name) write (*,'(a\)') ' ' if (iform.eq.1) + write(*, format ) EgoN, name, sex, FaNo, MoNo, SpoN if (iform.eq.2) + write(*, format ) EgoN, sex, name, FaNo, MoNo, SpoN if (iform.eq.3) + write(*, format ) EgoN, name, sex, SpoN, FaNo, MoNo, DEC if (iform.eq.4) + write(*, format ) EgoN, sex, name, SpoN, FaNo, MoNo if (iform.eq.5) + write(*, format ) EgoN, sex, SpoN, FaNo, MoNo, name if (iform.eq.6) + write(*, format ) EgoN, sex, SpoN, FaNo, MoNo,NG1,DEC,Ng2,name if (iform.eq.7) + write(*, format) EgoN,sex,SpoN,FaNo,MoNo,NG1,I8,DEC,Ng2,I9,name if (iform.eq.8) + write(*, '(I5,A2,3I5,A,3i3)') + EgoN,sex,SpoN,FaNo,MoNo,name,DEC,NG1,Ng2 C + end=5,err=55) EgoN,sex,SpoN,FaNo,MoNo, nam1, DEC, NG1, NG2 C if (egoN.eq.0020) pause C if (egoN.eq.0021) pause endif 6 if (indiv(k,2).gt.0.and.FaNo.gt.0.and.FaNo.ne.indiv(k,2)) then write(2,'(A,2i6,A)')' Fa numbers',indiv(k,2), FaNo,' used twice1' ! write(*,'(A,2i6,A)')' Fa numbers',indiv(k,2), FaNo,' used twice1' ! endif if (indiv(k,2).eq.0) indiv(k,2)=FaNo if (indiv(k,3).eq.0) indiv(k,3)=MoNo if (indiv(EgoN,6).gt.0.and.FaNo.gt.0.and.FaNo.ne.indiv(EgoN,6)) +write(2,'(2(A,2i6))')' Fa numbers used twice:',indiv(EgoN,6),FaNo +,' for person ', EgoN if (indiv(EgoN,6).gt.0.and.FaNo.gt.0.and.FaNo.ne.indiv(EgoN,6)) +write(*,'(2(A,2i6))')' Fa numbers used twice:',indiv(EgoN,6),FaNo +,' for person ', EgoN indiv (EgoN,6)=FaNo if (indiv(EgoN,7).gt.0.and.MoNo.gt.0.and.MoNo.ne.indiv(EgoN,7)) +write(2,'(2(A,2i6))')' Mo numbers used twice:',indiv(EgoN,7),MoNo +,' for person ', EgoN if (indiv(EgoN,7).gt.0.and.MoNo.gt.0.and.MoNo.ne.indiv(EgoN,7)) +write(*,'(2(A,2i6))')' Mo numbers used twice:',indiv(EgoN,7),MoNo +,' for person ', EgoN indiv (EgoN,7)=MoNo if (FaNo.gt.maxindv.and.FaNo.le.idim) maxindv=FaNo if (MoNo.gt.maxindv.and.MoNo.le.idim) maxindv=MoNo changed gt. to ge. in Aug 95 if (iform.eq.3.or.iform.ge.6) then if (dec.gt.45) then indiv(EgoN,4)=DEC else if (dec.gt.0) then ! ie iform=6 write(*, '(i5,A,6I5,A)') + EgoN, sex, SpoN, FaNo, MoNo,NG1,DEC,Ng2,name C pause endif endif endif if (EgoN.gt.maxindv.and.EgoN.le.idim) maxindv=EgoN if (SpoN.gt.maxindv.and.SpoN.le.idim) maxindv=SpoN if (sex.eq.'M') THEN if (egoN.gt.0) then if (indiv (egoN,1).eq.2.and.ymale.eq.'X') then write (*,'(3a)')'1 Do you want to allow Male-Male ',malelink,'?' ymale=getcharqq() if (ymale.eq.'y') ymale='Y' endif if (yfema.ne.'Y') then if (indiv (egoN,1).eq.2) write (*,'(A,i5)') ' Two sexes for',egoN ! error if (indiv (egoN,1).eq.2) write (2,'(A,i5)') ' Two sexes for',egoN ! error indiv (egoN,1)=1 ! "male" endif endif if (ymale.ne.'Y') then if (SpoN.gt.0) then if (indiv (SpoN,1).eq.1) write (*,'(A,i5)') ' Two sexes for',SpoN ! error if (indiv (SpoN,1).eq.1) write (2,'(A,i5)') ' Two sexes for',SpoN ! error indiv (SpoN,1)=2 ! "female" endif if (SpoN.eq.MoNo.and.MoNo.gt.0) write (*,'(2(I5,A))') EgoN, + 'M marries Mother', MoNo ! error if (SpoN.eq.MoNo.and.MoNo.gt.0) write (2,'(2(I5,A))') EgoN, + 'M marries Mother', MoNo ! error endif else !NOTE: TREAT sex 'm' as if female for EgoN, male for SpoN if ymale.eq.'Y' if (sex.eq.'F'.or.malemale.eq.1) THEN if (egoN.gt.0) then !DEBUG JAN 1999 TOOK THIS OUT C if (indiv (egoN,1).eq.2.and.ymale.eq.'X') then C write (*,'(3a)')' 2 Do you want to allow Male-Male ',malelink,'?' C ymale=getcharqq() C if (ymale.eq.'y') ymale='Y' C endif if (indiv (egoN,1).eq.1.and.yfema.eq.'X') then write (*,'(3a)') + ' Do you want to allow Female-Female ',femalink,'?' yfema=getcharqq() if (yfema.eq.'y') yfema='Y' endif if (sex.eq.'F') then if (indiv (egoN,1).eq.1) write (*,'(A,i5)') ' Two sexes for',egoN ! error if (indiv (egoN,1).eq.1) write (2,'(A,i5)') ' Two sexes for',egoN ! error indiv (egoN,1)=2 ! "female" endif endif if (sex.eq.'F'.or.malemale.eq.1) then if (SpoN.gt.0) then if (indiv (SpoN,1).eq.2) write (*,'(A,i5)') ' Two sexes for',SpoN ! error if (indiv (SpoN,1).eq.2) write (2,'(A,i5)') ' Two sexes for',SpoN ! error indiv (SpoN,1)=1 ! "male" endif if (FaNo.gt.0) then if (SpoN.eq.FaNo) write (*,'(2(I5,A))') EgoN, 'F marries Father', + FaNo ! error if (SpoN.eq.FaNo) write (2,'(2(I5,A))') EgoN, 'F marries Father', + FaNo ! error endif endif endif endif if (ans.NE.'Y'.AND.ANS.NE.'y') goto 7 endif !REM: IF EGO = 0 THEN NOTHING 721 enddo ! reading large loop k=1,ndim ! END READ DATA FIRST TIME C**************************** ERROR CHECK WHETHER OR NOT ASKED 7 close (1) kk=k-1 open (1, file=filetxt) if (e1.ne.'E') then write (*,*) ' press Enter/Return ' xq=getcharqq() endif C write(*,'(i5,a)')maxindv,' highest number used for any individual' C write(2,'(i5,a)')maxindv,' highest number used for any individual' write(*,'(a)') ' ' write(2,'(a)') ' ' C do j=1,ndim C pvec(5,j)=0 C pvec(6,j)=444 C pvec(7,j)=0 C enddo !error checking: C 2. parents should be of right sex 1 if (kk.gt.idim) then write (*,'(i6,a,I6)') kk, ' c:exceeding', idim pause endif do k=1,kk ! kk set to number of records read first time malemale=0 femafema=0 !sex of fathers should be male if (indiv(k,2).gt.idim) then write (*,*) k, indiv(k,2) endif if (indiv(k,2).gt.0.and.indiv (indiv(k,2),1).eq.2) then write (*,'(A,i5)') ' Two sexes for father', indiv(k,2) ! error write (2,'(A,i5)') ' Two sexes for father', indiv(k,2) ! error ENDIF !sex of mothers should be female if (indiv(k,3).gt.0.and.indiv (indiv(k,3),1).eq.1) THEN write (*,'(A,i5)') ' Two sexes for mother', indiv(k,3) ! error write (2,'(A,i5)') ' Two sexes for mother', indiv(k,3) ! error ENDIF !parents should not be the same if (indiv(k,2).eq.indiv(k,3).and.indiv(k,2).gt.0) + write (*,'(A,i5)') ' Two parents the same', indiv(k,3) ! error if (indiv(k,2).eq.indiv(k,3).and.indiv(k,2).gt.0) + write (2,'(A,i5)') ' Two parents the same', indiv(k,3) ! error enddo if (e1.ne.'E') then write (*,*) ' press Enter/Return ' xq=getcharqq() endif endif C**************************** INITIALIZE NAME LENGTH do j=1,ndim hname(j) =' ' wname(j) =' ' C do k=1,nlength C hname(j)(K:K)=' ' C wname(j)(K:K)=' ' C enddo enddo C**************************** READ INPUT FOR ANALYSIS length=0 read (1,'(a)') title read (1,'(a)') format !now read data for real do k=1,ndim malemale=0 femafema=0 if (iform.eq.1) +read (1, format,end=21,err=21) EgoN, nam1, sex, FaNo, MoNo, SpoN if (iform.eq.2) +read (1, format,end=21,err=21) EgoN, sex, nam1, FaNo, MoNo, SpoN if (iform.eq.3) +read (1, format,end=21,err=21) EgoN, nam1, sex, SpoN, FaNo, MoNo if (iform.eq.4) +read (1, format,end=21,err=21) EgoN, sex, nam1, SpoN, FaNo, MoNo if (iform.eq.5) +read (1, format,end=21,err=21) EgoN, sex, SpoN, FaNo, MoNo, nam1 56 continue if (iform.eq.6) then C55 read (1, '( I4, A1, I4,1x,I4,1x,i4,6x,i3,2x,I2,5x,i3,2x,a)', read (1, format, + end=21,err=56) EgoN,sex,SpoN, FaNo, MoNo, NG1, DEC, NG2, nam1 endif if (iform.eq.7) then C + err=56,end=21) EgoN,sex,SpoN, FaNo, MoNo, NG1, DEC, NG2, nam1 read (1, format, + end=21,err=56) EgoN,sex,SpoN, FaNo, MoNo, NG1,I8,DEC,NG2,I9,nam1 c ego29cpl makes p-xxx.nad C J pvec(1 (2(7 (6 (5 (3 hname(j) (4 wname(j) C COUPL H-Pa W-Pa * mdec mh# Husband Wife C 8 6 0 3 88 2: 9 Pipp, Andreas d:by WW I mess 10 Pipp, Ursula b Korpitch d:ch C 9 8 0-2 90 2: 11 Pipp, Hans d:before WW I 0 C 10 8 11-2 91 2: 1253 Pipp, Franz d:before WW I 1262 Pipp, Agnes b Godec sister o C 12 8 13 1 91 2: 13 Pipp, Johann messner & sddlm 12 Pipp, Theresia b Godec da:sm C C253M1262 0009 0010 15:37b 2 -88?d0? Pipp, Franz d:before WWI Deacon C262F1253 0240 0237 15:36b 15 -89?d 74 Pipp, Agnes b Godec sister of 0244 C av-2av-1av-4av-3 backspace(1) av1=' ' av2=' ' av3=' ' av4=' ' ! BH BD DD MH read (1, '(I4,A1,I4,2(1x,i4),8x, 4A4)', + end=21,err=56) EgoN,sex,SpoN, FaNo, MoNo, av2,av1,av4,av3 !ADD ALPHANUMERIC !avec(1 H BDate 4col (add 1st col="1") Male !avec(2 H BH 4col Birth-House Male !avec(3 H MH 4col Marriage-House Male !avec(4 H DDate 4col (add 1st col="1") Male !avec(5 W BDate 4col (add 1st col="1") Female !avec(6 W BH 4col Birth-House Female !avec(7 W MH 4col Marriage-House Female !avec(8 W DDate 4col (add 1st col="1") Female C NG1xxDEcxxxxNG2xx C681M0680 1018 1027 124:18 60*-905 123* Leiler, Valentine tischlermeister C024M2025 0681 0680 80:60 123*-938 80*!Leiler, Raimond tischlermeister near HN123 got half of HN80: if (EgoN.ge.idim) then write (*,'(a,I6)') ' b:exceeding', idim goto 21 endif if (nam1.eq.'END') then write (*,*) 'END' goto 21 endif endif C if (sex.eq.'m'.and.ysex.eq.'Y') sex='M' if (sex.eq.'m'.and.ysex.eq.'Y') malemale=1 if (sex.eq.'f'.and.xsex.eq.'Y') sex='F' if (sex.eq.'f'.and.xsex.eq.'Y') femafema=1 if (SpoN.lt.-3) goto 722 checking husband/wife reciprocity C if (sex.eq.'M'.and.EgoN.gt.0.and.SpoN.gt.0) then C male (1,k)=EgoN C male (2,k)=SpoN C endif if (FaNo.gt.0.and.MoNo.gt.0) then do ik=1,kk ! kk set to number of records read first time if (male (1, ik).eq.FaNo.and.male (2, ik).eq.MoNo) goto 662 ! male (1 ) was previously set to FaNo for a male ego ! male (2 ) was previously set to MoNo for a male ego enddo if (itog.eq.0) then write (*,'(i6,a)') kk, ' records searched checking errors' itog=1 pause endif write (*,'(2(A, I5))') ' No Matching hu report for FaNo', FaNo, + ' and MoNo', MoNo write (2,'(2(A, I5))') ' No Matching hu report for FaNo', FaNo, + ' and MoNo', MoNo endif 662 if ((sex.eq.'F'.or.malemale.eq.1).and.EgoN.gt.0.and.SpoN.gt.0) + then do ik=1,kk if (male (1, ik).eq.SpoN.and.male (2, ik).eq.EgoN) goto 663 enddo write (*,'(2(A, I5))') ' No Matching hu report for wife', EgoN, + ' having husband', SpoN write (2,'(2(A, I5))') ' No Matching hu report for wife', EgoN, + ' having husband', SpoN endif 663 if (sex.eq.'M'.and.EgoN.gt.0.and.SpoN.gt.0) then C if (indiv (SpoN,1).eq.1) malemale=1 do ik=1,kk if (female (1, ik).eq.SpoN.and.female (2, ik).eq.EgoN) goto 664 enddo write (*,'(2(A, I5))') ' No Matching wife report for hu', EgoN, + ' having wife', SpoN write (2,'(2(A, I5))') ' No Matching wife report for hu', EgoN, + ' having wife', SpoN endif 664 if (iform.eq.8) then read (1, format, + end=21,err=56) EgoN,sex,SpoN, FaNo, MoNo, nam1, DEC, NG1, NG2 C + ' 8. EgoN, sex, SpoN, FaNo, MoNo, Name, Decade of Birth,', C +' Post-Marital Res1, Post-Marital Res2 (e.g., Trukese study)' C + ' 8. EgoN, sex, SpoN, FaAd, MoAd, FaNo, MoNo, Name, Decade of Bir C +th,',' Post-Marital Res1, Post-Marital Res2 (e.g., Trukese study)' endif if (iform.ge.6) then if (sex.eq.'S') goto 21 !STOP if (EgoN.eq.last1.and.SpoN.eq.last2) goto 56 last1=EgoN last2=SpoN if (EgoN.le.0) goto 56 if (sex.ne.'M'.and.sex.ne.'F') goto 56 last=EgoN endif name=nam1(1:40) if (EgoN.gt.0.and.egoN.le.ndim) then !OLD read (1, format,end=4,err=21) EgoN, nam1, sex, SpoN, FaNo, MoNo C read (1, '(i5,a40,1x,A1,3I5)',end=4,err=5) EgoN, name, sex, C + SpoN, FaNo, MoNo !Num Name S Spou Fath Moth Ch M C1 Victoria Hanover F 2 133 138 9 1 C2 Albert Augustus Charles M 1 139 140 9 1 C 13 C 3 0 0 0 1 0 1 0 0 1 1 0 0 C 2 0 0 1 13 1 0 1 1 0 0 1 0 C 1 2 3 4 5 6 7 8 9 10 11 12 13 C 2 133 139 20 4 22 6 117 201 9 10 25 225 C 1 138 140 3 12 5 94 7 8 120 23 11 226 C**************************** FIND COUPLE NUMBER (EGO AND SPOUSE) if (sex.eq.'M'.and.EgoN.gt.0) THEN C if (SpoN.gt.0.and.indiv (SpoN,1).eq.1) malemale=1 do j=1,length ! get coupl number from list of length=0 if first time if (pvec (3,j).eq.EgoN.and.pvec (4,j).eq.SpoN) then if (hname(j).eq.' '.and.name(1:7).ne.' ') + hname(j)=name ! couple # already there (came in as parent or wife ! : add name goto 2 ! skip rest endif enddo ! j !not found on list if (length.le.0) j=1 if (pvec(3,j).eq.0) pvec(3,j)=EgoN ! add new couple to list: husband's side if (pvec(4,j).eq.0) pvec(4,j)=SpoN ! j is a couple index if (EgoN.gt.maxindv.and.EgoN.le.idim) maxindv=EgoN if (SpoN.gt.maxindv.and.SpoN.le.idim) maxindv=SpoN !DEBUG !DEBUG if (EgoN.eq.111) then !DEBUG write (*,'(3a)') ' 2 Husband:', name, hname(j) ! ok !DEBUG if (hname(j)(1:1).eq.' ') WRITE (*,*) ' HNAME BLANK' !DEBUG if (name(1:7).ne.' ') WRITE (*,*) ' NAME NOT BLANK' ! NOT TRUE !DEBUG pause !DEBUG endif if (hname(j)(1:1).eq.' '.and.name(1:7).ne.' ')hname(j)=name ! have to get the partner's name from HIS record C if (SpoN.gt.0.and.indiv (SpoN,1).eq.1) malemale=1 if(malemale.eq.1.and.ymale.eq.'Y')wname(j)=malelink if(malemale.eq.1.and.ymale.eq.'Y')wname(j)(15:24)=':male-male' !DEBUG !DEBUG if (EgoN.eq.111) then !DEBUG write (*,'(3a)') ' 3 Husband:', hname(j), name ! ok !DEBUG pause !DEBUG endif !note: will be missing wife's name if wife only entered under another husband length=j goto 2 ENDIF if ((sex.eq.'F'.or.malemale.eq.1).and.EgoN.gt.0) THEN do j=1,length ! get coupl number if (pvec (4,j).eq.EgoN.and.pvec (3,j).eq.SpoN) then if (wname(j).eq.' '.and.name(1:7).ne.' ') + wname(j)=name ! couple # already there (came in as parent!): add name goto 2 ! skip rest endif enddo ! j !not found on list if (length.le.0) j=1 if (pvec(4,j).eq.0) pvec(4,j)=EgoN ! add new couple to list: wife's side if (pvec(3,j).eq.0) pvec(3,j)=SpoN if (EgoN.gt.maxindv.and.EgoN.le.idim) maxindv=EgoN if (SpoN.gt.maxindv.and.SpoN.le.idim) maxindv=SpoN if (wname(j).eq.' '.and.name(1:7).ne.' ') wname(j)=name ! have to get the partner's name from HIS record C if(malemale.eq.1.and.ymale.eq.'Y')wname(j)=malelink ! have to get the partner's name from HER record if (SpoN.gt.0.and.indiv (SpoN,1).eq.2) femafema=1 if (femafema.eq.1.and.yfema.eq.'Y')hname(j)=femalink if (femafema.eq.1.and.yfema.eq.'Y')hname(j)(15:24)= + ':female-female' ! dyslexic if(malemale.eq.1) hname(j)=malelink if(malemale.eq.1) hname(j)(15:24)=':male-male' !note: will be missing husband's name if husband only entered under another wife length=j ENDIF 2 coupl=j if (iform.ge.6) then *****FEISTRITZ CCCCCCCCif (I8.eq.'*'.or.I9.eq.'*') pvec(7,j)= 1 ! INHERITANCE (takes precedence) if (I8.eq.'*') pvec(7,j)= 1 ! INHERITANCE (takes precedence) if (ng2.eq.-2.and.pvec(7,j).ne.1) pvec(7,j)=-2 ! MOVED AWAY if (I9.eq.'g'.and.pvec(7,j).ne.1) pvec(7,j)= 2 ! SALE or buyer CCCCCCCCif (I8.eq.'#'.or.I9.eq.'#') pvec(7,j)= 3 ! OWNER (sale or heir?) if (I9.eq.'#'.and.pvec(7,j).ne.1) pvec(7,j)= 3 ! OWNER (sale or heir?) !MAY95: keep residential heirs in their houses! if (I8.eq.'*'.and.ng1.gt.0) pvec(7,j) =1 ! override for heirs if (I8.eq.'*'.and.ng1.gt.0) pvec(5,j) =Ng1 ! override for heirs C write (*,'(2I5\)') ng1, ng2 if (Ng2.le.0.and.Ng1.gt.0) Ng2=Ng1 ! Take 2nd or 1st if 2nd blank if (pvec(5,j).le.0.and.ng2.gt.0) pvec(5,j) =Ng2 C if (pvec(3,j).eq.410) write (*,*) pvec(3,j), ng2, pvec(5,j) C if (pvec(3,j).eq.410) pause C write (*,*) ng2, pvec(5,j) !*****FEISTRITZ endif if (iform.eq.7) then if (av2(1:3).eq.' ') av2(1:3)=' ?' if (av2(1:3).eq.' 0') av2(1:3)=' ?' if (av2(1:3).eq.' 0 ') av2(1:3)=' ?' if (av2(1:3).eq.' ? ') av2(1:3)=' ?' if (av2(1:3).eq.' ??') av2(1:3)=' ?' if (av3(1:3).eq.' 0') av3(1:3)=' ?' if (av3(1:3).eq.' 0 ') av3(1:3)=' ?' if (av3(1:3).eq.' ? ') av3(1:3)=' ?' if (av3(1:3).eq.' ??') av3(1:3)=' ?' if (av4(1:1).eq.'d') then av4(3:4)=av4(2:3) if (av4(4:4).eq.' ') av4(4:4)='?' if (av4(3:3).eq.' ') av4(3:3)='?' av4(1:2)='1 ' av4(2:2)=av1(2:2) if (av1(3:3).gt.av4(3:3)) then av4(2:2)=char(ichar(av1(2:2))+1) endif endif if (sex.eq.'M') then avec(1,j)=av1 avec(1,j)(1:1)='1' avec(2,j)=av2 avec(3,j)=av3 avec(4,j)=av4 endif if (sex.eq.'F') then avec(5,j)=av1 avec(5,j)(1:1)='1' avec(6,j)=av2 avec(7,j)=av3 avec(8,j)=av4 endif endif !*****FEISTRITZ if (FaNo.le.0.and.MoNo.le.0) then parnt=0 goto 33 ! do not assign new new number to unknown parents CC goto 22 ! assign new number to unknown parents endif C**************************** FIND PARENTAL COUPLE do j=1,length ! get parental coupl number as original numbers if (pvec (3,j).eq.FaNo.and.pvec (4,j).eq.MoNo) THEN goto 3 endif enddo ! j !not found in list of parental couples if (length.le.0) j=1 !THESE ARE NEW AS OF MARCH 24 1994 pvec(1,j)=0 ! don't know the h parents pvec(2,j)=0 ! don't know the w parents if (pvec(3,j).gt.0.and.FaNo.ne.pvec(3,j)) then write (2,'(A,2i6,A)')' Fa numbers', pvec(3,j), FaNo,' used twice3' ! write (*,'(A,2i6,A)')' Fa numbers', pvec(3,j), FaNo,' used twice3' ! endif if (pvec(3,j).le.0) pvec(3,j)=FaNo ! add this father as new j if (pvec(4,j).gt.0.and.MoNo.ne.pvec(4,j)) + write (2,'(A,2i6,A)')' Mo numbers',pvec(4,j), MoNo,' used twice' ! if (pvec(4,j).le.0) pvec(4,j)=MoNo ! add this mother as new j length=j goto 3 C**************************** NEW NUMBER TO UNKNOWN PARENTS 22 length=length+1 ! assign new number to new parents j=length ! assign new number to new parents if (pvec(3,j).gt.0.and.FaNo.ne.pvec(3,j)) then write (2,'(A,2i6,A)')' Fa numbers', pvec(3,j), FaNo,' used twice4' ! write (*,'(A,2i6,A)')' Fa numbers', pvec(3,j), FaNo,' used twice4' ! endif if (pvec(3,j).le.0) pvec(3,j)=FaNo if (pvec(4,j).gt.0.and.MoNo.ne.pvec(4,j)) + write (2,'(A,2i6,A)')' Mo numbers',pvec(4,j), MoNo,' used twice' ! if (pvec(4,j).le.0) pvec(4,j)=MoNo 3 parnt=j if (FaNo.gt.Maxindv.and.FaNo.le.idim) maxindv=FaNo if (MoNo.gt.maxindv.and.MoNo.le.idim) maxindv=MoNo if (FaNo.gt.0) indiv (FaNo,1)=1 ! male if (MoNo.gt.0) indiv (MoNo,1)=2 ! male 33 if (sex.eq.'M'.and.pvec(1,coupl).le.0) pvec(1,coupl)=parnt ! of male ego if (sex.eq.'F'.and.pvec(2,coupl).le.0) pvec(2,coupl)=parnt ! of female ego endif ! end big if 722 enddo ! end big k=1, ... reading large loop k=1,ndim !didnt hit end or idim write (*,*) ' warning: false no matchings will result' write (*,*) ' you must increase NDIM in compiling ego2cpl-' write (2,*) ' warning: false no matchings will result' write (2,*) ' you must increase NDIM in compiling ego2cpl-' goto 23 C**************************** WHERE SPOUSE'S PARENT KNOWN FROM ELSEWHERE !i.e. husband was entered under only one wife or wife under one husband 21 continue pause 23 continue C pvec(1 = h par (couple number) C pvec(2 = w par (couple number) C pvec(3 = h num (indiv number) C pvec(4 = w num do j=1,length if (pvec(1,j).eq.pvec(2,j).and.pvec(2,j).gt.0) + write (*,'(A,2i5)') ' Br-Si marriage', pvec(3,j), pvec(4,j) ! error if (pvec(1,j).eq.pvec(2,j).and.pvec(2,j).gt.0) + write (2,'(A,2i5)') ' Br-Si marriage', pvec(3,j), pvec(4,j) ! error if (hname(j).eq.' ') then ! no name for husband C write (*,*) ' a man-name is missing' C if (FaNo.gt.0.and.FaNo.le.ndim) then if (pvec(3,j).gt.0.and.pvec(3,j).le.ndim) then ! if couple has H num do m=1,length ! and he's somewhere else if (pvec(3,j).eq.pvec(3,m).and.hname(m).ne.' ' + .and.hname(m)(1:3).ne.' ') + hname(j)=hname(m) ! record Fa Name C if (FaNo.eq.pvec(3,m)) hname(j)=hname(m) ! record Fa Name enddo endif endif if (wname(j).eq.' ') then ! no name for wife C write (*,*) ' a woman-name is missing' C if (MoNo.gt.0.and.MoNo.le.ndim) then if (Pvec(4,j).gt.0.and.Pvec(4,j).le.ndim) then ! couple has W num do m=1,length ! and she's somewhere else if( Pvec(4,j).eq.pvec(4,m).and.wname(m).ne.' ') + wname(j)=wname(m) ! record Mo Name C if( MoNo.eq.pvec(4,m)) wname(j)=wname(m) ! record Mo Name enddo endif endif enddo if (iform.ge.6.or.iform.eq.3) then !DEC check do j=1,length if (pvec(3,j).gt.0) then i3=indiv(pvec(3,j),4) !hbdate else i3=0 endif if (pvec(1,j).gt.0.and.pvec(4,pvec(1,j)).gt.0) then i1=indiv(pvec(4,pvec(1,j)),4) !hmbdate else i1=0 endif if (i3-i1.gt.5.and.i3.gt.50.and.i1.gt.50) write (2, +'(2(i5,a),i4,a)') pvec(3,j), 'Ms mother', pvec(4,pvec(1,j)),' is', +10*(i3-i1), ' years old' if (i3-i1.lt.1.and.i3.gt.50.and.i1.gt.50.and.pvec(4,pvec(1,j)).ne. +8224) write (2, +'(2(i5,a),i4,a)') pvec(3,j), 'Ms mother', pvec(4,pvec(1,j)),' is', +10*(i3-i1), ' years old' if (pvec(4,j).gt.0) then i4=indiv(pvec(4,j),4) !wbdate else i4=0 endif if (pvec(2,j).gt.0.and.pvec(4,pvec(2,j)).gt.0) then i2=indiv(pvec(4,pvec(2,j)),4) !wmbdate else i2=0 endif if (i4-i2.gt.5.and.i4.gt.50.and.i2.gt.50) write (2, +'(2(i5,a),i4,a)') pvec(4,j), 'Fs mother', pvec(4,pvec(2,j)),' is', +10*(i4-i2), ' years old' if (i4-i2.lt.1.and.i4.gt.50.and.i2.gt.50.and.pvec(4,pvec(2,j)).ne. +8224) write (2, +'(2(i5,a),i4,a)') pvec(4,j), 'Fs mother', pvec(4,pvec(2,j)),' is', +10*(i4-i2), ' years old' C +'(i6,a,i4,a)') pvec(4,j), 'Fs mother is', 10*(i4-i2), ' years old' enddo endif C close (2) if (iform.ge.6) then if (e1.ne.'E') then write (*,*) ' press Enter/Return ' xq=getcharqq() endif endif !??? C**************************** COMPUTE DATES FOR FEISTRITZ AS LAST STEP if (iform.eq.3.or.iform.ge.6) THEN do j=1,length !Give this sons bdate to parents as marr date if he is youngest j3=0 if (pvec(1,j).gt.0) j3=pvec(3,j) ! has parents, j3=male ID if (j3.gt.0.and.indiv(j3,4).gt.0.and.indiv(j3,4).lt. ! j3 has bdate + pvec(6,pvec(1,j))) ! oldest son confers mar + pvec(6,pvec(1,j))=indiv(j3,4) !! WRONG ! date to HUSB'S parents j4=0 if (pvec(2,j).gt.0) j4=pvec(4,j) ! has parents, j4=female ID !Give this daughters bdate to parents as marr date if she is youngest if (j4.gt.0.and.indiv(j4,4).gt.0.and.indiv(j4,4).lt. + pvec(6,pvec(2,j))) ! oldest da confers mar + pvec(6,pvec(2,j))=indiv(j4,4) !! WRONG ! date to WIFE'S parents enddo C******UNDATED MARRIAGE ESTIMATE OF TWENTY YEARS AFTER BIRTH OF YOUNGER HU,WI do j=1,length if (pvec(6,j).eq.444) then ns1=0 ns2=0 if (pvec(3,j).gt.0.and.indiv(pvec(3,j),4).gt.48) + ns1=indiv(pvec(3,j),4) ! Hu Date if (pvec(4,j).gt.0.and.indiv(pvec(4,j),4).gt.48) + ns2=indiv(pvec(4,j),4) ! Wi Date if (ns1.gt.ns2) ns2=ns1 ! ns2 the later born (younger) if (ns2.ne.444) pvec(6,j)=ns2+2 C if (ns2.eq.0) pvec(6,j)=0 endif enddo C******UNDATED MARRIAGE ESTIMATE OF FIFTY YEARS AFTER BIRTH OF YOUNGER HUPA,WIPA do j=1,length if (pvec(6,j).eq.2.or.pvec(6,j).eq.444) then! !if parents dated pvec(6,j)=2 if (pvec(1,j).gt.2.and.pvec(6,pvec(1,j)).gt.48) + pvec(6,j)=pvec(6,pvec(1,j))+2 if (pvec(2,j).gt.2.and.pvec(6,pvec(2,j)).gt.48) + pvec(6,j)=pvec(6,pvec(2,j))+2 endif !if children dated if (pvec(6,j).gt.48) then if (pvec(1,j).gt.0.and.pvec(6,pvec(1,j)).eq.2) + pvec(6,pvec(1,j))=pvec(6,j)-2 if (pvec(2,j).gt.0.and.pvec(6,pvec(2,j)).eq.2) + pvec(6,pvec(2,j))=pvec(6,j)-2 endif enddo do j=1,length if (pvec(6,j).le.2) pvec(6,j)=-1 !May95 if (pvec(6,j).le.2) pvec(5,j)=-1 enddo C*****check that parents are married earlier than children close (1) open (1, file='error') do j=1,length if (pvec(1,j).gt.0.and.pvec(6,pvec(1,j)).lt.444) then !HUPA if (pvec(6,j).lt.pvec(6,pvec(1,j))+0) write (1,'(I5,A)') + pvec(3,j), ' M is younger than his child !' endif if (pvec(2,j).gt.0.and.pvec(6,pvec(2,j)).lt.444) then !WIPA if (pvec(6,j).lt.pvec(6,pvec(2,j))+0) write (1,'(I5,A)') + pvec(4,j), ' F is younger than her child !' endif enddo endif ! for iform=3 or iform=6/7 C close (1) C*************FIX MULTIPLE ENTRIES C write (*,'(a,i4)') ' Debug 1 Length=', length do i=1,length do j=1,length !WHEN TWO ENTRIES HAVE SAME MALE ID, GIVE SAME PARENT if (pvec(3,i).eq.pvec(3,j) + .and.pvec(1,i).gt.0.and.pvec(1,j).le.0) pvec(1,j)=pvec(1,i) !WHEN TWO ENTRIES HAVE SAME FEMALE ID, GIVE SAME PARENT if (pvec(4,i).eq.pvec(4,j) + .and.pvec(2,i).gt.0.and.pvec(2,j).le.0) pvec(2,j)=pvec(2,i) enddo enddo C close (1) C close (2) CCCC goto 999 C**************************** WRITE NAMES FILE FOR .NAM AND .DOC FILES CCCC open (2, file='p-xxx.nam') CCCC write (2,*) ' COUPL H-Pa W-Pa Husband Wife' CCCC do j=1,length CCCC write (2, '(I5,2x,2I5,2(I5,1x,a))') j, pvec(1,j), pvec(2,j), CCCC +pvec(3,j), hname(j), pvec(4,j), wname(j) CCCC enddo CCCC close (2) CCCC open (2, file='p-xxx.doc') CCCC write (2,'(A)') ' ' CCCC write (2,'(A)') '*******' CCCC do j=1,length CCCC write (2, '(2i4,2a))') pvec(3,j), pvec(4,j), CCCC +hname(j), wname(j) CCCC enddo CCCC write (2,'(A)') '*******' CCCC close (2) C999 INDEX=LENGTH if (an1.eq.'2') goto 997 C********Plural marriage males=0 nfmls=0 malesin=0 nfmlsin=0 !first write (*,'( i5,a)') maxindv, ' maxindv ' !first write (2,'( i5,a)') maxindv, ' maxindv ' newmax=maxindv do j=1,maxindv ! maxindv if (indiv(j,1).eq.1.or.indiv(j,1).eq.3) then males=males+1 if (indiv(j,1).ne.1) malesin=malesin+1 endif if (indiv(j,1).eq.2.or.indiv(j,1).eq.4) then nfmls=nfmls+1 if (indiv(j,1).ne.2) nfmlsin=nfmlsin+1 ! indiv(j,1).ge.4 she is married endif enddo write (*,'(/i5,a)') males+nfmls, ' individuals: ' write (2,'(/i5,a)') males+nfmls, ' individuals: ' !moved here: write (*,'(2(i6,a))') index, ' nodes ', maxindv, +' highest number used for any individual' write (2,'(2(i6,a))') index, ' nodes ', maxindv, +' highest number used for any individual' write (*,'(1x,2(i5,a))') males, ' males ', nfmls,' females ' write (2,'(1x,2(i5,a))') males, ' males ', nfmls,' females ' c write (2,'(2(i5,a))') malesin,' single ',nfmlssin,' single ' c write (*,'(2i5,a)') index, ' couples' maxindv, c +' highest number used for any individual' c write (2,'(2i5,a)') index, ' couples' maxindv, c +' highest number used for any individual' do j=1,index if (pvec(3,j).gt.0.and.pvec(4,j).gt.0) then ! TWO IN COUPLE C indiv(MALE---ID,1)=ODD indiv(pvec(3,j),1)=indiv(pvec(3,j),1)+2 !3,5,7=1,2,3 wives C indiv(FEMALE-ID,1)=even indiv(pvec(4,j),1)=indiv(pvec(4,j),1)+2 !4,6,8=1,2,3 husb endif enddo males=0 nfmls=0 do j=1,maxindv !maxindv if (mod(indiv(j,1),2).eq.1) then !its a male if ( indiv(j,1) .ge.3) then !he's married males=males+1 !write whether a multiply married man lacks parents: below endif endif if (mod(indiv(j,1),2).eq.0) then !its a female if ( indiv(j,1) .ge.4) then !she's married nfmls=nfmls+1 !write whether a multiply married woman lacks parents: below endif endif enddo write (*,'(1x,i5,a,i4,a)') +males, ' coupled males', nfmls, ' coupled females ' write (2,'(1x,i5,a,i4,a)') +males, ' coupled males', nfmls, ' coupled females ' c write (2,'(2(i5,a))') males, ' coupled males', c + nfmls, ' coupled females ' do j=1,30 multwive(j)=0 multhusb(j)=0 enddo do j=1,maxindv !maxindv !multiple wife frequency count if (indiv(j,1).le.30.and.indiv(j,1).gt.0.and. + mod(indiv(j,1),2).eq.1) then multwive (indiv(j,1))=multwive (indiv(j,1))+1 CC if (indiv(j,1).ge.7) write (*,'(2(I5,A))') CC + j, ' has', indiv(j,1)/2, ' non-sororal wives' CC if (indiv(j,1).ge.7) write (2,'(2(I4,A))') CC + j, ' has', indiv(j,1)/2, ' non-sororal wives' endif !multiple husb frequency count if (indiv(j,1).le.30.and.indiv(j,1).gt.0.and. + mod(indiv(j,1),2).eq.0) then multhusb (indiv(j,1))=multhusb (indiv(j,1))+1 CC if (indiv(j,1).ge.7) write (*,'(2(I5,A))') CC + j, ' has', indiv(j,1)/2, ' non-leviratic husbands' CC if (indiv(j,1).ge.7) write (2,'(2(I4,A))') CC + j, ' has', indiv(j,1)/2, ' non-leviratic husbands' endif enddo indexPa=Index newdummy=maxindv do j=1,index if (pvec(3,j).gt.0.and.indiv(pvec(3,j),1).ge.5) then !write whether a multiply married man lacks parents if (pvec(1,j).le.0) then write (2,'(i5,a)') + pvec(3,j), 'M multiply married man lacks parents' male (3,pvec(3,j))=male (3,pvec(3,j))+1 if (male (3,pvec(3,j)).eq.1) then newdummy=newdummy+1 EgoN=pvec(3,j) Nam1=hname(j) sex='M' MoNo=0 SpoN=pvec(4,j) if (iform.eq.1) + write (4, format) EgoN, nam1, sex, Newdummy, MoNo, SpoN if (iform.eq.2) + write (4, format) EgoN, sex, nam1, Newdummy, MoNo, SpoN if (iform.eq.3) + write (4, format) EgoN, nam1, sex, SpoN, Newdummy, MoNo, + DEC if (iform.eq.4) + write (4, format) EgoN, sex, nam1, SpoN, Newdummy, MoNo if (iform.eq.5) + write (4, format) EgoN, sex, SpoN, Newdummy, MoNo, nam1 endif C 5 DUMMY FILE format C(I1,1x,A1,3i4,A) C1 M 2 C2 F 1 C1 M 3 C3 F 1 !END C 1M multiply married man lacks parents C 1M multiply married man lacks parents C1 M 2 4 if (AnF.eq.'Y') then !index =problem with 1) increase of dimensions !index =problem with 2) gave same man different parents in different marriages indexPa=indexPa+1 pvec (1,j)=indexPa endif endif endif !still doing in same do loop if (pvec(4,j).gt.0.and.indiv(pvec(4,j),1).ge.6) then !write whether a multiply married woman lacks parents if (pvec(2,j).le.0) then write (2,'(i5,a)') + pvec(4,j), 'F multiply married woman lacks parents' female (3,pvec(4,j))=female (3,pvec(4,j))+1 if (female (3,pvec(4,j)).eq.1) then newdummy=newdummy+1 EgoN=pvec(4,j) Nam1=wname(j) sex='F' MoNo=0 SpoN=pvec(3,j) if (iform.eq.1) + write (4, format) EgoN, nam1, sex, Newdummy, MoNo, SpoN if (iform.eq.2) + write (4, format) EgoN, sex, nam1, Newdummy, MoNo, SpoN if (iform.eq.3) + write (4, format) EgoN, nam1, sex, SpoN, Newdummy, MoNo, + DEC if (iform.eq.4) + write (4, format) EgoN, sex, nam1, SpoN, Newdummy, MoNo if (iform.eq.5) + write (4, format) EgoN, sex, SpoN, Newdummy, MoNo, nam1 endif C 5 DUMMY FILE C(I1,1x,A1,3i4,A) C1 M 2 C2 F 1 C1 M 3 C3 F 1 !END C 1F multiply married woman lacks parents C 1F multiply married woman lacks parents C1 M 2 4 if (AnF.eq.'Y') then !index =problem with 1) increase of dimensions !index =problem with 2) gave same man different parents in different marriages indexPa=indexPa+1 pvec (2,j)=indexPa endif endif endif enddo create write (*,'(3(A,I4))') ' assuming ego2cpl coded unmarried children c +(parents of spouse for a singleton are -1)' do i=1, index if (pvec(3,i).eq.0) pvec(1,i)=-1 if (pvec(4,i).eq.0) pvec(2,i)=-1 enddo !now cancel this if they have a child (i.e., single parent!) do j=1, index if (pvec(1,j).gt.0) then i=pvec(1,j) if (pvec(1,i).eq.-1) pvec(1,i)=0 if (pvec(2,i).eq.-1) pvec(2,i)=0 endif if (pvec(2,j).gt.0) then i=pvec(2,j) if (pvec(1,i).eq.-1) pvec(1,i)=0 if (pvec(2,i).eq.-1) pvec(2,i)=0 endif enddo if (an1.eq.'2') goto 997 isum1=0 isum2=0 isum3=0 write (*,*) ' ' write (2,*) ' ' write (*,*) ' Statistics for males:' write (2,*) ' Statistics for males:' marrmale=0 do j=2,30 marrmale=marrmale+multwive(j) enddo maletot=marrmale+multwive(1) do j=1,30 k=j/2 if (multwive(j).gt.0) then CC write (*,*) multwive(j), k if (j.eq.1) write (2,*) ' Percentage of all men' percent=100*real(multwive(j))/real(maletot) write (*,'(i6,a,i3,a,i5,a,i2,a,i5)') multwive (j), + ' males have',k,' marriages ', multwive (j),'*',k,'=', + k*multwive (j) if (j.eq.1.or.marrmale.eq.0) then write (2,'(i6,a,i3,a,i5,a,i2,a,i5,F5.1,a)') multwive (j), + ' males have',k,' marriages ', multwive (j),'*',k,'=', + k*multwive (j), percent,'%' if (j.eq.1) write (2,*) ' Percentages of married men' else percent=100*real(multwive(j))/real(marrmale) write (2,'(i6,a,i3,a,i5,a,i2,a,i5,F5.1,a)')multwive(j),' males h +ave', k,' marriages ', multwive (j),'*',k,'=',k*multwive (j), +percent, '%' endif isum1= isum1+ multwive (j) isum2= isum2+k*multwive (j) if (k.gt.0) + isum3= isum3+ multwive (j) endif enddo C write (*,'(a,i5,i6)') ' totals', isum1, isum2 C write (2,'(a,i5,i6)') ' totals', isum1, isum2 C*********Plural marriage: polygamy or serial marriage if (isum3.gt.0) then write (*,'(i5,A,I5,A,F4.2,A)') isum2, ' marriages by ', isum3, + ' married males =',real(isum2)/real(isum3),' marriages per male' write (2,'(i5,A,I5,A,F4.2,A)') isum2, ' marriages by ', isum3, + ' married males =',real(isum2)/real(isum3),' marriages per male' else write (*,*) ' ISUM3 = 0 for male marriages ' endif isum1=0 isum2=0 isum3=0 write (*,'(/,a)') ' Statistics for females:' write (2,'(/,a)') ' Statistics for females:' marrfema=0 do j=3,30 marrfema=marrfema+multhusb(j) enddo maletot=marrfema+multhusb(1)+multhusb(2) do j=1,30 k=(j-2)/2 if (multhusb(j).gt.0) then if (j.eq.2) write (2,*) ' Percentage of all women' write(*,'(i6,a,i3,a,i5,a,i2,a,i5)')multhusb (j),' females have', + k,' marriages ', multhusb (j),'*',k,'=', k*multhusb (j) if (j.le.2.or.marrfema.eq.0) then percent=100*real(multhusb(j))/real(maletot) write(2,'(i6,a,i3,a,i5,a,i2,a,i5,F5.1,a)')multhusb (j), + ' females have',k,' marriages ', multhusb (j),'*',k,'=', + k*multhusb (j), percent, '%' if (j.eq.2) write (2,*) ' Percentage of married women' else percent=100*real(multhusb(j))/real(marrfema) write (2,'(i6,a,i3,a,i5,a,i2,a,I5,F5.1,a)')multhusb(j), +' females have',k,' marriages ', multhusb (j),'*',k,'=', + k*multhusb (j), percent, '%' endif isum1= isum1+ multhusb (j) isum2= isum2+k*multhusb (j) if (k.gt.0) + isum3= isum3+ multhusb (j) endif enddo C write (*,'(a,i5,i6)') ' totals', isum1, isum2 C write (2,'(a,i5,i6)') ' totals', isum1, isum2 C*********Plural marriage: polygamy or serial marriage if (isum3.gt.0) then write (*,'(i5,A,I5,A,F4.2,A)') isum2, ' marriages by ', isum3,' +married females =',real(isum2)/real(isum3),' marriages per female' write (2,'(i5,A,I5,A,F4.2,A)') isum2, ' marriages by ', isum3,' +married females =',real(isum2)/real(isum3),' marriages per female' else write (*,'(i5,A,I5,A,F4.2,A)') isum2, ' marriages by ', isum3, ' + females =' write (2,'(i5,A,I5,A,F4.2,A)') isum2, ' marriages by ', isum3, ' + females =' endif C*********Sororal Polygyny do j=1,maxindv if (mod(indiv(j,1),2).eq.1) indiv(j,1)=1 ! 1 male if (mod(indiv(j,1),2).eq.0) indiv(j,1)=2 ! 2 female enddo do j=1,index-1 do jj=j+1,index if (pvec(1,j).eq.pvec(1,jj).and.pvec(2,j).eq.pvec(2,jj) + .and.pvec(1,j).gt.0.and.pvec(2,j).gt.0) then ! (2 bros w 2 sis) if (pvec(3,j).gt.0.and.pvec(3,j).eq.pvec(3,jj)) then ! SORORAL POLYGYNY !two couples with same male number = one man, two sisters C indiv(MALE-ID,1)=even indiv(pvec(3,j),1)=indiv(pvec(3,j),1)+2 !3,5,7=1,2,3 male sor wives endif if (pvec(4,j).gt.0.and.pvec(4,j).eq.pvec(4,jj)) then ! LEVIRATIC POLYANDRY !two couples with same female number = one man, two sisters C indiv(FEMALE---ID,1)=ODD indiv(pvec(4,j),1)=indiv(pvec(4,j),1)+2 !4,6,8=1,2,3 f has lev husb endif endif enddo enddo write (*,*) ' ' write (2,*) ' ' do j=1,maxindv !maxindv !multiple wife frequency count if (indiv(j,1).le.30.and.indiv(j,1).gt.0.and. + mod(indiv(j,1),2).eq.1) then ! MALE ! CC multwive (indiv(j,1))=multwive (indiv(j,1))+1 if (indiv(j,1).ge.3) write (*,'(2(I5,A))') + j, ' has sororal wives' if (indiv(j,1).ge.3) write (2,'(2(I4,A))') + j, ' has sororal wives' C if (indiv(j,1).ge.3) write (*,'(2(I5,A))') C + j, ' has', indiv(j,1)/2, ' sororal wives' C if (indiv(j,1).ge.3) write (2,'(2(I4,A))') C + j, ' has', indiv(j,1)/2, ' sororal wives' ! subtract this number from census endif !multiple husb frequency count if (indiv(j,1).le.30.and.indiv(j,1).gt.0.and. + mod(indiv(j,1),2).eq.0) then CC multhusb (indiv(j,1))=multhusb (indiv(j,1))+1 if (indiv(j,1).ge.3) write (*,'(2(I5,A))') + j, ' has leviratic husbands' ! 2 fem if (indiv(j,1).ge.3) write (2,'(2(I4,A))') + j, ' has leviratic husbands' ! C if (indiv(j,1).ge.3) write (*,'(2(I5,A))') C + j, ' has', -1+indiv(j,1)/2, ' leviratic husbands' ! 2 fem C if (indiv(j,1).ge.3) write (2,'(2(I4,A))') C + j, ' has', -1+indiv(j,1)/2, ' leviratic husbands' ! subtract this number from census endif enddo c c write (*,'(a)') ' ' c write (*,'(a)') c +' Since the impetus for this work is alliance theory, consider' c +,' marriages with siblings to be duplicates and adjust figures' c +,' above accordingly to get distribution of alliances.',' ' c write (2,'(a)') ' ' c write (2,'(a)') c +' Since the impetus for this work is alliance theory, consider' c +,' marriages with siblings to be duplicates and adjust figures' c +,' above accordingly to get distribution of alliances.',' ' check whether any numbers for parents of multiply-married children used twice c if (e1.ne.'E') then c write (*,*) ' press Enter/Return ' c xq=getcharqq() C endif if (e1.ne.'E') then write (*,'(A)') ' ' write (*,'(A)')' Error checking Routine: This is eliminating dupli +cation of "dummy parents"', +' for those individuals who have multiple spouses and no siblings. + ',' ', +' Do you want error checking (yes/no)? (default=no)' read (*,'(A)') answ endif if (answ.ne.'y'.and.answ.ne.'Y') goto 997 C +' OTHERWISE ENTER the lowest number and the highest number.' C write (*,'(A)') ' check for duplicate use of numbers in range:' C write (*,'(A\)') ' (example: 800,900 for) "dummy parents"' C write (*,'(A)') ' of multiply married persons' 666 write (*,'(/A/,A\)') ' Lowest number used for "dummy parents" for +those individuals ',' who have multiple spouses and no siblings?' read (*,*,err=666) MLO if (MLO.le.0) MLO=1 667 write (*,'(/A/,A\)') ' Highest number used for "dummy parents" for + those individuals ',' who have multiple spouses and no siblings?' read (*,*,err=667) MHI if (MHI.le.0) MHI=1 DO i=MLO,MHI indiv(i,5)=0 enddo DO i=MLO,MHI if (indiv(i,2).ge.mlo.and.indiv(i,2).le.mhi) +indiv(indiv(i,2),1)=indiv(indiv(i,2),1)+1 if (indiv(i,3).ge.mlo.and.indiv(i,3).le.mhi) +indiv(indiv(i,3),1)=indiv(indiv(i,3),1)+1 enddo DO i=MLO,MHI if (indiv(i,5).gt.1) write (*,'(A,I5,A)') ' dummy Parent', i, +' has more than one child' if (indiv(i,5).gt.1) write (2,'(A,I5,A)') ' dummy Parent', i, +' has more than one child' enddo C close (2) 997 if (an5.eq.'Y') then C**************************** PARE DOWN THE LIST OF COUPLES WITH NO PAR OR CHILD write (*,*) ' PARE DOWN THE LIST OF COUPLES IN SAME ORDER' ! CORE IEND=1 if (an4.eq.'C') iend=100 DO I=1,LENGTH indiv (i,2)=3 enddo DO KKK=1,IEND DO I=1,LENGTH indiv (i,5)=indiv (i,2) ! >2 if in last core indiv (i,2)=0 ! indx as to whether element used (was i,1) ENDDO DO I=1,LENGTH if (an3.eq.'S') then CORE GOES THROUGH HERE! WOULD WORK FINE FOR COMMENTED STATEMENTS C if (pvec(1,i).gt.0) then !PROBLEM IS WITH ALGORITHM FOR INDIV ( ,5)=LAST ROUND OF INDIV ( ,2)! if (pvec(1,i).gt.0.and.indiv(pvec(1,i),5).gt.2.and. + indiv(i,5).gt.2) then indiv (i ,2)=indiv (i ,2)+1 ! has parent in core indiv (pvec(1,i),2)=indiv (pvec(1,i),2)+1 ! has child endif C if (pvec(2,i).gt.0) then if (pvec(2,i).gt.0.and.indiv(pvec(2,i),5).gt.2.and. + indiv(i,5).gt.2) then indiv (i ,2)=indiv (i ,2)+1 ! has parent indiv (pvec(2,i),2)=indiv (pvec(2,i),2)+1 ! has child endif else C if (pvec(1,i).gt.0) then if (pvec(1,i).gt.0.and.indiv(pvec(1,i),5).gt.2) then indiv (i ,2)=1 ! has parent indiv (pvec(1,i),2)=1 ! has child endif C if (pvec(2,i).gt.0) then if (pvec(2,i).gt.0.and.indiv(pvec(2,i),5).gt.2) then indiv (i ,2)=1 ! has parent indiv (pvec(2,i),2)=1 ! has child endif endif enddo !note: core members have indiv #=2 or greater do i=1,length if (indiv(i,2).ge.2) indiv(i,2)=3 enddo if (an6.eq.'Y') then ! EXPAND CORE TO INCLUDE ALL CHILDREN! do i=1,length if (pvec(1,i).gt.0.and.indiv(pvec(1,i),2).ge.3.and. + indiv(i,2).lt.2) indiv(i,2)=2 if (pvec(2,i).gt.0.and.indiv(pvec(2,i),2).ge.3.and. + indiv(i,2).lt.2) indiv(i,2)=2 enddo endif DO I=1,LENGTH indiv (i,5)=0 ! indx as to whether element used (was i,3) enddo INDX=0 DO I=1,LENGTH if (indiv (i,2).gt.0) then ! indx as to whether element used if (an3.ne.'S'.or.indiv (i,2).gt.1) then ! indx as to whether element used indx=indx+1 indiv (i,5)=indx ! make numbers into smaller series endif endif Cdebug write (*,*) i,indx enddo INDX=0 DO I=1,LENGTH if (indiv (i,2).gt.0) then ! indx as to whether element used if (an3.ne.'S'.or.indiv (i,2).gt.1) then ! indx as to whether element used indx=indx+1 C bigger smaller or equal if (pvec(1,i).le.0) pvec(1,indx)=0 if (pvec(1,i).gt.0) pvec(1,indx)= indiv( pvec(1,i),5) ! Scale down G if (pvec(2,i).le.0) pvec(2,indx)=0 if (pvec(2,i).gt.0) pvec(2,indx)= indiv( pvec(2,i),5) ! Scale down F if (an1.ne.'2') then !NON-GED C if (indiv(i,2).gt.0) indiv(indx,2)=indiv(indiv(i,2),5) ! scale down C if (indiv(i,2).gt.0) indiv(indx,2)=indiv(indiv(i,2),5) ! scale down indiv(indx,2)=indiv(i,2) endif pvec(3,indx)= pvec(3,i) ! keep as is pvec(4,indx)= pvec(4,i) ! keep as is hname (indx)= hname( i) ! keep as is wname (indx)= wname( i) ! keep as is if (iform.ge.6) pvec(5,indx)= pvec(5,i) ! keep as is if (iform.eq.3) pvec(6,indx)= pvec(6,i) ! keep as is if (iform.ge.6) pvec(6,indx)= pvec(6,i) ! keep as is if (iform.ge.6) pvec(7,indx)= pvec(7,i) ! keep as is if (iform.eq.7) avec(1,indx)= avec(1,i) ! keep as is if (iform.eq.7) avec(2,indx)= avec(2,i) ! keep as is if (iform.eq.7) avec(3,indx)= avec(3,i) ! keep as is if (iform.eq.7) avec(4,indx)= avec(4,i) ! keep as is if (iform.eq.7) avec(5,indx)= avec(5,i) ! keep as is if (iform.eq.7) avec(6,indx)= avec(6,i) ! keep as is if (iform.eq.7) avec(7,indx)= avec(7,i) ! keep as is if (iform.eq.7) avec(8,indx)= avec(8,i) ! keep as is if (pvec(1,indx).eq.indx.or.pvec(2,indx).eq.indx) then write (*,'(I5,a,2i5)') indx,' is child? of',pvec(1,indx), + pvec(2,indx) write (2,'(I5,a,2i5)') indx,' is child? of',pvec(1,indx), + pvec(2,indx) if (e1.ne.'E') then write (*,*) ' press Enter/Return ' xq=getcharqq() ENDIF ! for 'E' index=indx-1 goto 99 endif C write (*,*) indx,indiv(indx,2) ! an6 ok 1st time (indx 2), 0, 0 2nd endif endif enddo C pause ! an6 INDEX=INDX !NEEDED FOR CORE: PARENTS MAY NOT BE IN CORE! CC if (an1.ne.'2') then DO I=1,LENGTH if (pvec(1,i).gt.index) pvec(1,i)=0 if (pvec(2,i).gt.index) pvec(2,i)=0 enddo CC endif if (index.ge.length) goto 99 length=index enddo ! kkk endif ! an4 99 continue C write (*,'(1x,A,i6)') an1, maxindv C write (2,'(1x,A,i6)') an1, maxindv if (e1.ne.'E') then write (*,*) ' press Enter/Return ' xq=getcharqq() endif if (an1.eq.'2') goto 998 ! DID NOT REDUCE ARRAYS C*********initialize jdec = has to do with decades! do i=1,30 do j=1,8 jdec(i,j)=0 enddo enddo C****** !fill in parents of second member of male-male links if (ysex.eq.'Y') then !take parental couple number for male individuals, put in index DO j=1,maxindv indiv(j,2)=0 ENDDO DO j=1,index ! ID H-parents if (pvec(1,j).gt.0.and.pvec(3,j).gt.0)indiv(pvec(3,j),2)=pvec(1,j) ENDDO !transfer anywhere these males appear as female id (Pvec(4,j) DO j=1,index ! THIS WILL APPLY ONE IF INDIV IS MALE if (pvec(4,j).gt.0.and.pvec(2,j).eq.0.and.indiv(pvec(4,j),2).gt.0) + pvec(2,j) =indiv(pvec(4,j),2) ENDDO endif C**************************** WRITE NAMES FILE FOR .NAM FILES filenam='p-xxx.nam' filenam(3:5)=ext C if (an4.eq.'D'.or.an4.eq.'S') filenam(9:9)=an4 close (1) open (1, file=filenam) write (1,*) ' COUPL H-Pa W-Pa I P Res Husband + Wife (I:1=Inh 2=Bot 3=? -2 moved) P:#Pa Heirs' do j=1,index if (iform.ge.6) then np=0 if (pvec(1,j).gt.0.and.pvec(1,j).le.9998.and. + pvec(7,pvec(1,j)).eq.1) np=np+1 if (pvec(2,j).gt.0.and.pvec(2,j).le.9998.and. + pvec(7,pvec(2,j)).eq.1) np=np+1 write (1, '(I5,2x,2I5,2I2,I3,I4,a,2(I5,1x,a40))') j, pvec(1,j), +pvec(2,j), pvec(7,j), np, pvec(6,j), pvec(5,j), ':', pvec(3,j), +hname(j), pvec(4,j), wname(j) else if (iform.eq.3) then ! DECades only write (1, '(I5,2x,2I5,I4,a,2(I5,1x,a40))') j, pvec(1,j), + pvec(2,j), pvec(6,j), ':', pvec(3,j), + hname(j), pvec(4,j), wname(j) else write (1, '(I5,2x,2I5, 2(I5,1x,a40))') j, pvec(1,j), +pvec(2,j), pvec(3,j), +hname(j), pvec(4,j), wname(j) endif endif C*************WRITE VECTOR MARKED FOR COUPLES c open (1,file='couples.clu') c do i=1,length c if (pvec(3,i).gt.0.and.pvec(4,i).gt.0) then c write (1,'(i2)') 1 c else c write (1,'(i2)') 0 c endif c enddo c close (1) C**************************** WRITE TAB FOR FEISTRITZ if (iform.ge.6) then jhp =pvec(1,j) jwp =pvec(2,j) jres=pvec(5,j) idec=pvec(6,j)-70 inh =pvec(7,j) ! jdec(idec,1) bt ! jdec(idec,2) 1h ! jdec(idec,3) 1w ! jdec(idec,4) 2h ! jdec(idec,5) 2w ! jdec(idec,6) mg if (idec.gt.0) then if (inh.eq.2) jdec(idec,1)=jdec(idec,1)+1 if (inh.eq.1.and.jhp.gt.0.and.pvec(5,jhp).eq.jres) + jdec(idec,2)=jdec(idec,2)+1 if (inh.eq.1.and.jwp.gt.0.and.pvec(5,jwp).eq.jres) + jdec(idec,3)=jdec(idec,3)+1 if (inh.eq.0.and.jhp.gt.0.and.pvec(5,jhp).eq.jres) + jdec(idec,4)=jdec(idec,4)+1 if (inh.eq.0.and.jwp.gt.0.and.pvec(5,jwp).eq.jres) + jdec(idec,5)=jdec(idec,5)+1 if (inh.eq.-2) jdec(idec,6)=jdec(idec,6)+1 if (pvec(1,j).gt.0.and.pvec(2,j).gt.0) + jdec(idec,7)=jdec(idec,7)+1 if (pvec(1,j).gt.0.or.pvec(2,j).gt.0) + jdec(idec,8)=jdec(idec,8)+1 endif endif enddo write (1,'(A)') +' Inheritance 30yr Stay in House Left Endo ' write (1,'(A)') +' Date B-ght Son Dau. % Son Dau. Town gamy Denom %' do i=1,29 den=jdec(i,2)+jdec(i,3) if (i.gt.1) den=den+jdec(i-1,2)+jdec(i-1,3) if (i.gt.2) den=den+jdec(i-2,2)+jdec(i-2,3) ddd=jdec(i,3) if (i.gt.1) ddd=ddd+jdec(i-1,3) if (i.gt.2) ddd=ddd+jdec(i-2,3) dens=0 if (den.gt.0) dens=100*ddd/den endo1=jdec(i,7) if (i.gt.1) endo1=endo1+jdec(i-1,7) if (i.gt.2) endo1=endo1+jdec(i-2,7) endo2=jdec(i,8) if (i.gt.1) endo2=endo1+jdec(i-1,8) if (i.gt.2) endo2=endo1+jdec(i-2,8) endog=0 if (endo2.gt.0) endog=100*endo1/endo2 write (1,'(4i6,F6.2,5i6,F7.2)') 1700+i*10, (jdec(i,j),j=1,3), + dens,(jdec(i,j),j=4,8), endog enddo !DEBUG if (answ.ne.'Y') goto 919 if (iform.eq.7) then C**************************** WRITE SIBLING SET FILES .SIB filenam(7:8)='SI' close (1) open (1, file=filenam) ! NUCLEAR FAMILY OR SIBLING SET FILE write (1,'(A)') ' PER + HSE TO DDate LINKED' write (1,'(A)') 'DATE HSE FAM SON Name +BDate HEIR NAME' write (1,'(A)') ' V:Father + * V:Fa of Fa' write (1,'(A)') ' M:Mother + V:Fa of Mo' write (1,'(A)') ' S:Son ' write (1,'(A)') ' S+ + Wife of Son' write (1,'(A)') ' D:Da ' write (1,'(A)') ' D+ + Husband of Da' write (1,'(A)') ' 999X*END OF HOUSEHOLD RECORD' C write (1,*) ' COUPL H-Pa W-Pa Husband Wife' C912 33 9 9V:Abuja, Valentine II landwirt 1912h 33* 19??..V: C912 33 9 10M: 1924h 26 33*! 95V Abuja, Christine b Moser brou C912 33 9 11S:Abuja, Gerhardt ???? 1954h 33 ! C912 9 ( 0 members raised in other households) C inhh=father's household where children raised C indxx = father's number, repeated Cavec(1,j)father's birth data avec(1,j) C household of origin avec(2,j) A4 C household of destination avec(3,j)A4 indxx=0 do j=1,index !V:ater NofHHs=0 ! begin an inventory of HH A4 ids ParentHH=' 0' if (pvec(3,j).gt.0) then ! there IS a father's number indxx=indxx+1 if (indxx.eq.1000) indxx=0 inxxx=indxx k=pvec(1,j) ! index number of father avec1k=' ' if (k.gt.0) avec1k=avec(1,k) if (avec(2,j)(1:3).ne.' '.and.avec(2,j)(1:3).ne.' ?') + ParentHH=avec(2,j)(1:3) if (avec(3,j)(1:3).ne.' '.and.avec(3,j)(1:3).ne.' ?') + ParentHH=avec(3,j)(1:3) if (ParentHH.eq.' ?') ParentHH=' 0' if (hname(j)(1:4).eq.' ') then hname(j)(1:4)='died' ParentHH=' 0' avec(1,j)='----' C if (ParentHH.eq.' ') ParentHH=' 0' endif if (k.gt.0) then write (1,'(A4,1x,A3,1x,I4,I3,A2,A40,1X,a4,A1,2A4,A1,4A)') + avec(1,j), ParentHH, inxxx, indxx, 'V:', hname(j), + avec(1,j), 'h', avec(2,j), avec(3,j),'d', avec(4,j), + avec1k(3:4),'V:', hname(k) else write (1,'(A4,1x,A3,1x,I4,I3,A2,A40,1X,a4,A1,2A4,A1,4A)') + avec(1,j), ParentHH, inxxx, indxx, 'V:', hname(j), + avec(1,j), 'h', avec(2,j), avec(3,j),'d', avec(4,j), + avec1k(3:4),'V:' endif else avec(1,j)='----' endif !M:utter !M: 0 57 57V:died ....h............ V: !M: 57 58M:died ....h............ V !M: 57 59S:Leitner, Andreas h:1948(litig 1922h 36* ? ! !M: 57 60S+ 1928h ? 36 ! Leitner, Magdalena b Schume v if (pvec(4,j).gt.0) then if (ParentHH.eq.' 0') then if (avec(6,j)(1:3).ne.' '.and.avec(6,j)(1:3).ne.' ?') + ParentHH=avec(6,j)(1:3) if (avec(7,j)(1:3).ne.' '.and.avec(7,j)(1:3).ne.' ?') + ParentHH=avec(7,j)(1:3) if (ParentHH.eq.' ?'.or.ParentHH.eq.' '.or.ParentHH.eq.' ') + ParentHH=' 0' if (wname(j)(1:4).eq.' ') ParentHH=' 0' endif indxx=indxx+1 if (indxx.eq.1000) indxx=0 k=pvec(2,j) ! index number of wife's father avec1k=' ' if (k.gt.0) avec1k=avec(1,k) if (wname(j)(1:4).eq.' ') then wname(j)(1:4)='died' endif write (1,'(A4,1x,A3,1x,I4,I3,A2, A40,1X, A4, A1,2A4,A1, + A4,A2,A1,1x,a40)') + avec(1,j), ParentHH, inxxx, indxx, 'M:', wname(j), + avec(5,j), 'h', avec(6,j), avec(7,j), 'd', avec(8,j), + avec1k(3:4), 'V', avec1k endif do i=1,index !S:ohn if (pvec(1,i).eq.j) then if (pvec(3,i).gt.0) then indxx=indxx+1 if (ParentHH.eq.' 0') then if (avec(2,i)(1:3).ne.' '.and.avec(2,i)(1:3).ne.' ?') + ParentHH=avec(2,i)(1:3) if (ParentHH.eq.' ?'.or.ParentHH.eq.' '.or + .ParentHH.eq.' ') ParentHH=' 0' if (hname(i)(1:4).eq.' ') then hname(i)(1:4)='died' ParentHH=' 0' endif endif if (indxx.eq.1000) indxx=0 write (1,'(A4,1x,A3,1x,I4,I3,A2,A40,1X,A4,A1,2A4,A1, + A4,1x,a40)') + avec(1,j), ParentHH, inxxx, indxx, 'S:', hname(i), + avec(1,i), 'h', avec(2,i), avec(3,i),'d',avec(4,i) endif !S+:Sohn's Frau if (pvec(4,i).gt.0) then indxx=indxx+1 if (indxx.eq.1000) indxx=0 hnamej=' ' write (1,'(A4,1x,A3,1x,I4,I3,A2,A40,1X,A4,A1,2A4,A1, + A4,1x,a40)') + avec(1,j), ParentHH, inxxx, indxx, 'S+', hnamej, + avec(5,i), 'h', zero, avec(6,i),'d',avec(8,i), wname(i) C + avec(5,i), 'h', avec(6,i),avec(7,i), avec(8,i), wname(i) endif endif !T:ochter if (pvec(2,i).eq.j) then ! this is a daughter if (pvec(4,i).gt.0) then ! she has an ID number indxx=indxx+1 ! increment family member number if (ParentHH.eq.' 0') then ! assign HH number if none if (avec(6,i)(1:3).ne.' '.and.avec(6,i)(1:3).ne.' ?') + ParentHH=avec(6,i)(1:3) if (ParentHH.eq.' ?'.or.ParentHH.eq.' ' + .or.ParentHH.eq.' ') ParentHH=' 0' if (wname(i)(1:4).eq.' ') then wname(i)(1:4)='died' ParentHH=' 0' endif endif if (indxx.eq.1000) indxx=0 write (1,'(A4,1x,A3,1x,I4,I3,A2,A40,1X,A4,A1,2A4,A1, + A4,1x,A40)') ! <--this last bit not used + avec(1,j), ParentHH, inxxx, indxx, 'T:', wname(i), + avec(5,i),'h',avec(6,i), avec(7,i),'d',avec(8,i) !PROGRAM ERROR C NO X* BETWEEN C--- 7 493 497M:Perchinig, Maria volkschule 1951h 7 ? 21V 1921 C--- 7 493 498M:Perchinig, Angela student 1952h 7 ? 21V 1921 C THES ARE DEATH DATES dVVVV C--- 8 506 508T:Melchior, Theresa b Cezar=Zae 1898h 8* d1972 C--- 8 506 509T+ 1897h 6 d1972 Melchior, Georg bauer burgerm C--- 8 506 x* C--- 9 75 77S:Godec, Ferdinand aus HN9:smit 1924h 9 138 1959 C--- 9 75 78S+ 1934h ? ! Godec, Maria b Moser von Acho C--- 9 75 x* endif !T+:Tochter's Mann if (pvec(3,i).gt.0) then indxx=indxx+1 if (indxx.eq.1000) indxx=0 hnamej=' ' write (1,'(A4,1x,A3,1x,I4,I3,A2,A40,1X,A4,A1,2A4,A1, + A4,1x,a40)') + avec(1,j), ParentHH, inxxx, indxx, 'T+', hnamej, + avec(1,i), 'h', zero, avec(2,i),'d',avec(4,i),hname(i) C + avec(1,i), 'h', avec(2,i),avec(3,i),'d',avec(4,i),hname(i) endif endif enddo write (1,'(A4,1x,A3,1x,I4,I3,A)') avec(1,j), ParentHH, inxxx, + 999, 'X*' enddo endif C**************************** WRITE NAMES FILE FOR .DOC FILES 919 filedoc='p-xxx.doc' filedoc(3:5)=ext C if (an4.eq.'D'.or.an4.eq.'S') filedoc(9:9)=an4 close (1) open (1, file=filedoc) write (1,'(A)') ' ' write (1,'(A)') '*******' C do j=1,length !DEAD BY HERE do j=1,index if (pvec(4,j).eq.0) then write (1, '(2i4,2a40))') pvec(3,j), pvec(4,j), +hname(j) else write (1, '(2i4,2a40))') pvec(3,j), pvec(4,j), +hname(j), wname(j) endif enddo write (1,'(A)') '*******' C close (1) C !GEDCOM NOTE THAT MALE (2,idim) and FEMALE (2,idim) are free do i=1,idim male (1,i)=0 female (1,i)=0 male (2,i)=0 female (2,i)=0 enddo close (1) filename='p-xxx.ged' filename(3:5)=ext open (1, file=filename) write (1, '(A)') +'0 HEAD', +'1 SOUR PAF 2.2', +'1 DEST PAF', +'1 DATE 03 MAR 95' write (1, '(4A)') +'1 FILE ',filename,' from ',filetxt C p-***.txt', write (1, '(A)') +'1 CHAR ANSEL', +'0 @S1@ SUBM', +'1 NAME Doug White', +'1 ADDR School Social Science', +'2 CONT UC Irvine 92717', +'2 CONT Internet Email address: drwhite@uci.edu', +'1 PHON 714-824-5893' do i=1,index ! BY FAMILIES !for male individual if (pvec(3,i).gt.0.and.male(1,pvec(3,i)).eq.0) then male(2,pvec(3,i)) = i ! position in array if (pvec(3,i).gt.0.and.pvec(3,i).le.9) + write (1,'(A,I1,A)') '0 @I',pvec(3,I),'@ INDI' if (pvec(3,i).gt.9.and.pvec(3,i).le.99) + write (1,'(A,I2,A)') '0 @I',pvec(3,I),'@ INDI' if (pvec(3,i).gt.99.and.pvec(3,i).le.999) + write (1,'(A,I3,A)') '0 @I',pvec(3,I),'@ INDI' if (pvec(3,i).gt.999.and.pvec(3,i).le.idim) + write (1,'(A,I4,A)') '0 @I',pvec(3,I),'@ INDI' !PRINT NAME AND SEX write (1,'(A,A)') '1 NAME ', hname(i) write (1,'(A)') '1 SEX M' !PRINT FAMS - family number as SPOUSE if (i.gt.0.and.i.le.9) + write (1,'(A,I1,A)') '1 FAMS @F',i,'@' if (i.gt.9.and.i.le.99) + write (1,'(A,I2,A)') '1 FAMS @F',i,'@' if (i.gt.99.and.i.le.999) + write (1,'(A,I3,A)') '1 FAMS @F',i,'@' if (i.gt.999.and.i.le.idim) + write (1,'(A,I4,A)') '1 FAMS @F',i,'@' if (male(1,pvec(3,i)).eq.0) then do j=1,index ! BY FAMILIES !PRINT OTHER FAMS - family number as SPOUSE if (pvec(3,j).eq.pvec(3,i).and.male(2,pvec(3,j)).ne.j) then if (j.gt.0.and.j.le.9) + write (1,'(A,I1,A)') '1 FAMS @F',j,'@' if (j.gt.9.and.j.le.99) + write (1,'(A,I2,A)') '1 FAMS @F',j,'@' if (j.gt.99.and.j.le.999) + write (1,'(A,I3,A)') '1 FAMS @F',j,'@' if (j.gt.999.and.j.le.idim) + write (1,'(A,I4,A)') '1 FAMS @F',j,'@' endif enddo endif if (male(1,pvec(3,i)).eq.0) male(1,pvec(3,i)) = 1 !PRINT FAMC - male's family number as CHILD if (pvec(1,i).gt.0) then If (pvec(1,i).le.9) + write (1,'(A,I1,A)') '1 FAMC @F',pvec(1,i),'@' if (pvec(1,i).gt.9.and.pvec(1,i).le.99) + write (1,'(A,I2,A)') '1 FAMC @F',pvec(1,i),'@' if (pvec(1,i).gt.99.and.pvec(1,i).le.999) + write (1,'(A,I3,A)') '1 FAMC @F',pvec(1,i),'@' if (pvec(1,i).gt.999.and.pvec(1,i).le.idim) + write (1,'(A,I4,A)') '1 FAMC @F',pvec(1,i),'@' endif endif !for female individual if (pvec(4,i).gt.0.and.female(1,pvec(4,i)).eq.0) then female(2,pvec(4,i)) = i ! position in array if (pvec(4,i).gt.0.and.pvec(4,i).le.9) + write (1,'(A,I1,A)') '0 @I',pvec(4,I),'@ INDI' if (pvec(4,i).gt.9.and.pvec(4,i).le.99) + write (1,'(A,I2,A)') '0 @I',pvec(4,I),'@ INDI' if (pvec(4,i).gt.99.and.pvec(4,i).le.999) + write (1,'(A,I3,A)') '0 @I',pvec(4,I),'@ INDI' if (pvec(4,i).gt.999.and.pvec(4,i).le.idim) + write (1,'(A,I4,A)') '0 @I',pvec(4,I),'@ INDI' !PRINT NAME AND SEX write (1,'(A,A)') '1 NAME ', wname(i) write (1,'(A)') '1 SEX F' !PRINT FAMS - female's family number as SPOUSE if (i.gt.0.and.i.le.9) + write (1,'(A,I1,A)') '1 FAMS @F',i,'@' if (i.gt.9.and.i.le.99) + write (1,'(A,I2,A)') '1 FAMS @F',i,'@' if (i.gt.99.and.i.le.999) + write (1,'(A,I3,A)') '1 FAMS @F',i,'@' if (i.gt.999.and.i.le.idim) + write (1,'(A,I4,A)') '1 FAMS @F',i,'@' if (female(1,pvec(4,i)).eq.0) then do j=1,index ! BY FAMILIES !PRINT OTHER FAMS - family number as SPOUSE if (pvec(4,j).eq.pvec(4,i).and.female(2,pvec(4,j)).ne.j) then if (j.gt.0.and.j.le.9) + write (1,'(A,I1,A)') '1 FAMS @F',j,'@' if (j.gt.9.and.j.le.99) + write (1,'(A,I2,A)') '1 FAMS @F',j,'@' if (j.gt.99.and.j.le.999) + write (1,'(A,I3,A)') '1 FAMS @F',j,'@' if (j.gt.999.and.j.le.idim) + write (1,'(A,I4,A)') '1 FAMS @F',j,'@' endif enddo endif if (female(1,pvec(4,i)).eq.0) female(1,pvec(4,i)) = 1 !PRINT FAMC - female's family number as CHILD if (pvec(2,i).gt.0) then if (pvec(2,i).le.9) + write (1,'(A,I1,A)') '1 FAMC @F',pvec(2,i),'@' if (pvec(2,i).gt.9.and.pvec(2,i).le.99) + write (1,'(A,I2,A)') '1 FAMC @F',pvec(2,i),'@' if (pvec(2,i).gt.99.and.pvec(2,i).le.999) + write (1,'(A,I3,A)') '1 FAMC @F',pvec(2,i),'@' if (pvec(2,i).gt.999.and.pvec(2,i).le.idim) + write (1,'(A,I4,A)') '1 FAMC @F',pvec(2,i),'@' endif endif enddo do i=1,idim male (1,i)=0 female (1,i)=0 male (2,i)=0 female (2,i)=0 enddo !NOW BUILD FAMILY NUMBERS: do i=1,index ! BY FAMILIES !ONLY IF FAMILY IN CORE! C if (indiv(i,2).gt.0) then if (i.gt.0.and.i.le.9) write (1,'(A,I1,A)') '0 @F',I,'@ FAM' if (i.gt.0.and.i.le.9) write (1,'(A,I1,A)') '1 REFN F',I if (i.gt.9.and.i.le.99) write (1,'(A,I2,A)') '0 @F',I,'@ FAM' if (i.gt.9.and.i.le.99) write (1,'(A,I2,A)') '1 REFN F',I if (i.gt.99.and.i.le.999) write (1,'(A,I3,A)') '0 @F',I,'@ FAM' if (i.gt.99.and.i.le.999) write (1,'(A,I3,A)') '1 REFN F',I if (i.gt.999.and.i.le.idim) write (1,'(A,I4,A)') '0 @F',I,'@ FAM' if (i.gt.999.and.i.le.idim) write (1,'(A,I4,A)') '1 REFN F',I !HUSB NO IF (pvec(3,i).gt.0) then if (pvec(3,i).gt.0.and.pvec(3,i).le.9) + write (1,'(A,I1,A)') '1 HUSB @I',PVEC(3,i),'@' if (pvec(3,i).gt.9.and.pvec(3,i).le.99) + write (1,'(A,I2,A)') '1 HUSB @I',PVEC(3,i),'@' if (pvec(3,i).gt.99.and.pvec(3,i).le.999) + write (1,'(A,I3,A)') '1 HUSB @I',PVEC(3,i),'@' if (pvec(3,i).gt.999.and.pvec(3,i).le.idim) + write (1,'(A,I4,A)') '1 HUSB @I',PVEC(3,i),'@' ENDIF !WIFE NO IF (pvec(4,i).gt.0) then if (pvec(4,i).gt.0.and.pvec(4,i).le.9) + write (1,'(A,I1,A)') '1 WIFE @I',PVEC(4,I),'@' if (pvec(4,i).gt.9.and.pvec(4,i).le.99) + write (1,'(A,I2,A)') '1 WIFE @I',PVEC(4,I),'@' if (pvec(4,i).gt.99.and.pvec(4,i).le.999) + write (1,'(A,I3,A)') '1 WIFE @I',PVEC(4,I),'@' if (pvec(4,i).gt.999.and.pvec(4,i).le.idim) + write (1,'(A,I4,A)') '1 WIFE @I',PVEC(4,I),'@' endif do j=1,index ! BY FAMILIES !MALE CHILD COUPLE J if (pvec(1,j).eq.i.and.pvec(3,j).gt.0.and.male(1,pvec(3,j)).eq.0) + then if (pvec(3,j).le.9) + write (1,'(A,I1,A)') '1 CHIL @I',pvec(3,j),'@' if (pvec(3,j).gt.9.and.pvec(3,j).le.99) + write (1,'(A,I2,A)') '1 CHIL @I',pvec(3,j),'@' if (pvec(3,j).gt.99.and.pvec(3,j).le.999) + write (1,'(A,I3,A)') '1 CHIL @I',pvec(3,j),'@' if (pvec(3,j).gt.999.and.pvec(3,j).le.idim) + write (1,'(A,I4,A)') '1 CHIL @I',pvec(3,j),'@' male(1,pvec(3,j))=1 endif !FEMALE CHILD COUPLE J if (pvec(2,j).eq.i.and.pvec(4,j).gt.0.and.female(1,pvec(4,j)).eq.0 +) then if (pvec(4,j).le.9) + write (1,'(A,I1,A)') '1 CHIL @I',pvec(4,j),'@' if (pvec(4,j).gt.9.and.pvec(4,j).le.99) + write (1,'(A,I2,A)') '1 CHIL @I',pvec(4,j),'@' if (pvec(4,j).gt.99.and.pvec(4,j).le.999) + write (1,'(A,I3,A)') '1 CHIL @I',pvec(4,j),'@' if (pvec(4,j).gt.999.and.pvec(4,j).le.idim) + write (1,'(A,I4,A)') '1 CHIL @I',pvec(4,j),'@' female(1,pvec(4,j))=1 endif enddo C ENDIF enddo !END! write (1,'(A)') '0 TRLR' close (1) C---------GEDCOM C**************************** WRITE .VEC FILE 4 write (*, '(I4,3x,A)') Index, title write (*, '(1000(20I5/) )') (pvec(1,j), j=1, index) ! Hu Pa write (*, '(1000(20I5/) )') (pvec(2,j), j=1, index) ! Wi Pa write (*, '(1000(20I5/) )') (pvec(3,j), j=1, index) ! Hu Id write (*, '(1000(20I5/) )') (pvec(4,j), j=1, index) ! Wi Id write (*, '(1000(20I5/) )') ( j , j=1, index) ! Index !pg2pajek close(3) filename='p-xxx.net' filename(3:5)=ext C WRITE (*,*) ' WRITE NET FILE', filename C pause open (3, file=filename) C write (*,'(3a/,a)') ' Y) for names as labels? for ',filename, C +' (Default=Individual',' N)umbers)' C read (*,*) lab1 C if (lab1.eq.'y') lab1='Y' C*************WRITE VECTOR MARKED FOR COUPLES open (51,file='couples.clu') c do i=1,length c enddo WRITE (3,'(a,i4)') '*Vertices ', index WRITE (51,'(a,i4)') '*Vertices ', index do i=1,index i3=pvec(3,i) i4=pvec(4,i) C pvec(3 = h num (the original male id, but now for the couple) C pvec(4 = w num (the original female id, but now for the couple) if (i3.gt.0.and.i4.gt.0) write (51,'(i2)') 3 ! couple if (i3.eq.0.and.i4.gt.0) write (51,'(i2)') 2 ! female if (i3.gt.0.and.i4.eq.0) write (51,'(i2)') 1 ! male if (lab1.eq.'Y') then lh=40 do j=40,1,-1 if (hname(i)(j:j).ne.' ') goto 834 enddo 834 continue ! lh=j if (h2.lt.lh) lh=h2 lw=40 do j=40,1,-1 if (wname(i)(j:j).ne.' ') goto 835 enddo 835 lw=j if (w2.lt.lw) lw=w2 write (3, '(I4,1x,2a,1x,2a)') i, '"',hname(i)(h1:lh), + wname(i)(w1:lw),'"' else i3=pvec(3,i) i4=pvec(4,i) if (i3.le.9) then if (i4.le.9) then write (3, '(I4,1x,a,i1,i2,a)') i, '"',i3, i4,'"' else if (i4.le.99) then write (3, '(I4,1x,a,i1,i3,a)') i, '"',i3, i4,'"' else if (i4.le.999) then write (3, '(I4,1x,a,i1,i4,a)') i, '"',i3, i4,'"' else write (3, '(I4,1x,a,i1,i5,a)') i, '"',i3, i4,'"' endif endif endif else ! i3 > 9 if (i3.le.99) then if (i4.le.9) then write (3, '(I4,1x,a,i2,i2,a)') i, '"',i3, i4,'"' else if (i4.le.99) then write (3, '(I4,1x,a,i2,i3,a)') i, '"',i3, i4,'"' else if (i4.le.999) then write (3, '(I4,1x,a,i2,i4,a)') i, '"',i3, i4,'"' else write (3, '(I4,1x,a,i2,i5,a)') i, '"',i3, i4,'"' endif endif endif else ! i3 > 99 if (i3.le.999) then if (i4.le.9) then write (3, '(I4,1x,a,i3,i2,a)') i, '"',i3, i4,'"' else if (i4.le.99) then write (3, '(I4,1x,a,i3,i3,a)') i, '"',i3, i4,'"' else if (i4.le.999) then write (3, '(I4,1x,a,i3,i4,a)') i, '"',i3, i4,'"' else write (3, '(I4,1x,a,i3,i5,a)') i, '"',i3, i4,'"' endif endif endif else ! i3 > 999 if (i4.le.9) then write (3, '(I4,1x,a,i4,i2,a)') i, '"',i3, i4,'"' else if (i4.le.99) then write (3, '(I4,1x,a,i4,i3,a)') i, '"',i3, i4,'"' else if (i4.le.999) then write (3, '(I4,1x,a,i4,i4,a)') i, '"',i3, i4,'"' else write (3, '(I4,1x,a,i4,i5,a)') i, '"',i3, i4,'"' endif endif endif endif endif endif endif enddo close (51) j1=1 j2=2 WRITE (3,'(a)') '*Arcs' C A)rcs for sons->parents, daughters->parents' ib=0 do i=1,index i1=pvec(1,i) i3=pvec(3,i) if (lab2.eq.'Y') then !WRITE NAMES (HUSBANDS) do j=40,1,-1 if (hname(i)(j:j).ne.' ') goto 836 enddo 836 lh=j if (h4.lt.lh) lh=h4 C if (ib.eq.0.and.i1.gt.0) then if (ib.ne.-999.and.i1.gt.0) then write (3,'(I4,i5,i2,3a)') I, i1, j1, + ' c Black p Solid l "', hname(i)(h3:lh),'"' ib=1 else if (i1.gt.0) write (3,'(i4,i5,i2,3a)') I, i1, j1, + ' l "',hname(i)(h3:lh),'"' endif else C i1=pvec(1,i) C i3=pvec(3,i) !WRITE NUMBERS (NOT JUST) FIRST TIME (BUT ALL THE TIME!!) if (i1.gt.0) then if (ib.ne.-999) then ib=1 if (i3.le.9) then ! write (3,'(I4,i5,i2,a,i1,a)') I, i1, ! + j1, ' c Black p Solid l "', i3,'"' ! else ! if (i3.le.99) then ! write (3,'(I4,i5,i2,a,i2,a)') I, i1, ! + j1, ' c Black p Solid l "', i3,'"' ! else ! if (i3.le.999) then ! write (3,'(I4,i5,i2,a,i3,a)') I, i1, ! + j1, ' c Black p Solid l "', i3,'"' ! else ! write (3,'(I4,i5,i2,a,i4,a)') I, i1, ! + j1, ' c Black p Solid l "', i3,'"' ! endif ! endif ! endif ! C write (3,'(I4,i5,i2,a,i4,a)') I, i1, C + j1, ' c Black p Solid l "', i3,'"' else !WRITE NUMBERS REST OF TIME if (i3.le.9) then ! write (3,'(I4,i5,i2,a,i1,a)') I, i1, ! + j1, ' l "',i3,'"' ! else ! if (i3.le.99) then ! write (3,'(I4,i5,i2,a,i2,a)') I, i1, ! + j1, ' l "',i3,'"' ! else ! if (i3.le.999) then ! write (3,'(I4,i5,i2,a,i3,a)') I, i1, ! + j1, ' l "',i3,'"' ! else ! write (3,'(I4,i5,i2,a,i4,a)') I, i1, ! + j1, ' l "',i3,'"' ! endif ! endif ! endif ! C if (i1.gt.0) write (3,'(i4,i5,i2,a,i4,a)') I, i1, C + j1, ' l "',i3,'"' endif endif endif enddo ib=0 do i=1,index i1=pvec(2,i) i3=pvec(4,i) if (lab2.eq.'Y') then !WRITE NAMES (WIVES) lw=40 do j=40,1,-1 if (wname(i)(j:j).ne.' ') goto 837 enddo 837 lw=j if (w4.lt.lw) lw=w4 C if (ib.eq.0.and.PVEC(2,i).gt.0) then if (ib.ne.-999.and.PVEC(2,i).gt.0) then if (PVEC(2,i).gt.0) write (3,'(i4,i5,i2,3a)') I, PVEC(2,i), j2, + ' c Red p Dots l "', wname(i)(w3:lw),'"' ib=1 else if (PVEC(2,i).gt.0) write (3,'(i4,i5,i2,3a)') I, PVEC(2,i), j2, + ' p Dots l "', wname(i)(w3:lw),'"' endif else !WRITE NUMBERS (NOT JUST) FIRST TIME (BUT ALL THE TIME!!) if (i1.gt.0) then C if (ib.eq.0) then if (ib.ne.-999) then !! ALL THE TIME !! ib=1 if (i3.le.9) then ! write (3,'(I4,i5,i2,a,i1,a)') I, i1, ! + j2, ' c Red p Dots l "', i3,'"' ! else ! if (i3.le.99) then ! write (3,'(I4,i5,i2,a,i2,a)') I, i1, ! + j2, ' c Red p Dots l "', i3,'"' ! else ! if (i3.le.999) then ! write (3,'(I4,i5,i2,a,i3,a)') I, i1, ! + j2, ' c Red p Dots l "', i3,'"' ! else ! write (3,'(I4,i5,i2,a,i4,a)') I, i1, ! + j2, ' c Red p Dots l "', i3,'"' ! endif ! endif ! endif ! C write (3,'(I4,i5,i2,a,i4,a)') I, i1, C + j2, ' c Red p Dots l "', i3,'"' else !WRITE NUMBERS REST OF TIME if (i3.le.9) then ! write (3,'(I4,i5,i2,a,i1,a)') I, i1, ! + j2, ' l "',i3,'"' ! else ! if (i3.le.99) then ! write (3,'(I4,i5,i2,a,i2,a)') I, i1, ! + j2, ' l "',i3,'"' ! else ! if (i3.le.999) then ! write (3,'(I4,i5,i2,a,i3,a)') I, i1, ! + j2, ' l "',i3,'"' ! else ! write (3,'(I4,i5,i2,a,i4,a)') I, i1, ! + j2, ' l "',i3,'"' ! endif ! endif ! endif ! endif endif C if (ib.eq.0.and.pvec(2,i).gt.0) then C if (pvec(2,i).gt.0) write (3,'(I4,i5,i2,a,i4,a)') I, pvec(2,i), C + j2, ' c Red p Dots l "', pvec(4,i),'"' C ib=1 C else C if (pvec(2,i).gt.0) write (3,'(i4,i5,i2,a,i4,a)') I, pvec(2,i), C + j2, ' p Dots l "', pvec(4,i),'"' C endif endif enddo close(3) if (iform.ge.6) +write (*, '(1000(20I5/) )') (pvec(5,j), j=1, index) ! Couple Residence if (iform.eq.3.or.iform.ge.6) +write (*, '(1000(20I5/) )') (pvec(6,j), j=1, index) ! Marriage Dates filevec='p-xxx.vec' filevec(3:5)=ext C if (an4.eq.'D'.or.an4.eq.'S') filevec(9:9)=an4 close (1) open (1, file=filevec) COMPUTE HIGHEST INDIVIDUAL LABEL FOR PRINT FORMATS maxlab=0 do j=1,index if (pvec(1,j).gt.maxlab) maxlab=pvec(1,j) if (pvec(2,j).gt.maxlab) maxlab=pvec(2,j) if (pvec(3,j).gt.maxlab) maxlab=pvec(3,j) if (pvec(4,j).gt.maxlab) maxlab=pvec(4,j) enddo C************* write p-xxx files !JUNK write (*,'(A,i5)') ' Maxlab=', maxlab write (1, '(I4,3x,A)') Index, title if (maxlab.ge.1000) then write (1, '(2000(20I5/) )') (pvec(1,j), j=1, index) write (1, '(2000(20I5/) )') (pvec(2,j), j=1, index) write (1, '(2000(20I5/) )') (pvec(3,j), j=1, index) write (1, '(2000(20I5/) )') (pvec(4,j), j=1, index) write (1, '(2000(20I5/) )') ( j , j=1, index) if (iform.ge.6) +write (1, '(2000(20I5/) )') (pvec(5,j), j=1, index) ! Couple Residence CC if (iform.ge.6) CC +write (1, '(2000(20I5/) )') (pvec(6,j), j=1, index) ! Marriage dates else write (1, '(2000(20I4/) )') (pvec(1,j), j=1, index) write (1, '(2000(20I4/) )') (pvec(2,j), j=1, index) write (1, '(2000(20I4/) )') (pvec(3,j), j=1, index) write (1, '(2000(20I4/) )') (pvec(4,j), j=1, index) write (1, '(2000(20I4/) )') ( j , j=1, index) !DRW debug Jan 15, 1996 if (iform.eq.3.or.iform.ge.6) CC if (iform.ge.6) +write (1, '(2000(20I4/) )') (pvec(5,j), j=1, index) ! Couple Residence CC if (iform.ge.6) CC +write (1, '(2000(20I4/) )') (pvec(6,j), j=1, index) ! Marriage dates endif if (iform.ge.6) then filedes='p-xxx.des' filedes(3:5)=ext filedes (9:9)=an4 close (1) open (1, file=filedes) write (1, '(I4,3x,2A)') Index, title, ' couple residence' write (1, '(1000(20I5/) )') (pvec(5,j), j=1, index) ! Couple Residence C close (1) endif goto 8 5 write (*,'(a,I4)') ' END or invalid input line=', k !DEBUG Kk=k-1 write(*, '(i5,a40,1x,A1,3I5)') EgoN, name, sex, SpoN, FaNo, MoNo !DEBUG: TAKE THESE OUT JAN 1999 C pause C k=3001 ! 3001 C k=1+ndim/2 if (ans.eq.'Y'.or.ans.eq.'y') then ans='N' close (1) goto 6 endif goto 4 8 if (iform.eq.7) write (*,*) filenam, ' is sibling set file ' c if (iform.eq.7) write (2,*) filenam, ' is sibling set file ' filenam(7:8)='na' write (*,*) filenam, ' is documentation file for P-Graphs' !NAC write (*,*) filedoc, ' is graphic label file for P-Graphs'!DOD write (*,*) filevec, ' is vector output file for P-Graphs' filename='p-xxx.ged' filename(3:5)=ext write (*,*) filename,' is GEDCOM output file ' filename='p-xxx.net' filename(3:5)=ext write (*,*) filename,' is PAJEK network file ' c write (2,*) filenam, ' is documentation file for user' !NAC c write (2,*) filedoc, ' is graphic labels file ' !DOD c write (2,*) filevec, ' is vector output file ' !DRW debug Jan 15, 1996 if (iform.eq.3.or.iform.ge.6) then CC if (iform.ge.6) then write (*,*) filedes, ' is residence group numbers file' c write (2,*) filedes, ' is residence group numbers file' filename='p-xxx-1.crd' filename(3:5)=ext if (an2.eq.'S'.or.an2.eq.'C') filename (11:11)=an2 write (*,'(1x,2a)') filename, ' is household graph output file ' write (*,'(1x,2a)') filename, ' : erase in options < 6 !' c write (2,'(1x,2a)') filename, ' is household graph output file ' c write (2,'(1x,2a)') filename, ' : erase in options < 6 !' endif C write (*,*) ' errors file also given ' if (iform.eq.3.or.iform.ge.6) then if (iform.eq.3) then do j=1,index pvec(5,j)=j enddo endif min=99 do j=1,index if (pvec(6,j).lt.min.and.pvec(6,j).gt.0) min=pvec(6,j) enddo do j=1,index if (pvec(6,j).gt.0) pvec(6,j)=pvec(6,j)-min+1 enddo write(*,'(3A,I3/,I5,A)')' the marriage-decade rows in ', filename, +' file are minus ',min,min*10+1010,' is earliest marriage date' write(2,'(3A,I3/,I5,A)')' the marriage-decade rows in ', filename, +' file are minus ',min,min*10+1010,' is earliest marriage date' write (*,*) filename, 'xxx' ! filename is blank! close (1) open (1, file=filename) write (*,*) filename, 'xxx' write (1, '(I4,A,A)') Index, ' 1', title write (1, '(1000(20I5/) )') (pvec(6,j), j=1, index) ! gen-levels write (1, '(1000(20I5/) )') (pvec(5,j), j=1, index) ! Couple Residence write (1, '(1000(20I5/) )') ( j , j=1, index) ! .CRD INDEX write (1, '(1000(20I5/) )') (pvec(5,j), j=1, index) ! Couple Residence endIF if (iform.le.6) then do j=1,index indiv(j,5)=1 enddo else write (1, '(1000(20I5/) )') (pvec(7,j), j=1, index) ! inheritnc colors endIF write (1, '(1000(20I5/) )') (indiv(j,5), j=1, index) ! colors if (iform.eq.3.or.iform.ge.6) then write (*,*) ' error is a file listing parents too young to have + children' c write (2,*) ' error is a file listing parents too young to have c + children' endif write (*,*) +'errors contains marriage statistics and a list of errors' c write (2,*) c +'errors contains marriage statistics and a list of errors' cc write (*,*) ' type "par-dup" to eliminate duplicate lines in the cc + "errors" file' c write (2,*) ' type "par-dup" to eliminate duplicate lines in the c + "errors" file' if (iform.eq.7) then write (*,*) ' p-xxx-2.crd is inheritance graph file ' write (2,*) ' p-xxx-2.crd is inheritance graph file ' do j=1,index if (pvec(1,j).gt.0.and. pvec(7,j).ge.1. + .and.pvec(7,pvec(1,j)).le.0) pvec(7,pvec(1,j))=1 enddo do j=1,index if (pvec(7,j).le.0) pvec(6,j)=0 if (pvec(7,j).le.0) pvec(5,j)=0 enddo filename='p-xxx-2.crd' filename(3:5)=ext if (an2.eq.'S'.or.an2.eq.'C') filename (11:11)=an2 close (1) open (1, file=filename) write (1, '(I4,A,A)') Index, ' 1', title write (1, '(1000(20I5/) )') (pvec(6,j), j=1, index) ! gen-levels write (1, '(1000(20I5/) )') (pvec(5,j), j=1, index) ! Couple Residence write (1, '(1000(20I5/) )') ( j , j=1, index) ! .CRD INDEX write (1, '(1000(20I5/) )') (pvec(5,j), j=1, index) ! Couple Residence write (1, '(1000(20I5/) )') (pvec(7,j), j=1, index) ! inheritnc Colors endIF 998 if (an1.eq.'1') then C goto 991 lasttext='---' close (1) close (2) close (3) open (1,file='errors') open (2,file='errors1') C write (*,*) ' eliminate duplicate lines in ERRORS file' C write (*,*) ' and writes results to ERRORS1 file' i=0 989 i=i+1 C write (*,*) i C read (1,'(a)',err=991,end=991) text read (1,'(a)',end=991) text C write (*,'(a)') text C if (text.ne.lasttext) write (*,'(a)') text if (text.ne.lasttext) write (2,'(a)') text lasttext=text goto 989 991 close (1) pause close (2) IK = SYSTEMQQ ( 'DEL ERRORS'C ) IK = SYSTEMQQ ( 'RENAME ERRORS1 ERRORS'C ) ! WRITE p-YYY.VED for Individual Number pgraph format open (1,file='p-yyy.ved') write (1, '(I4,3x,A)') MaxIndv, title C indiv (...,1) = 1 male or 2 female -> =3 marr'd males =4 marr'd females C indiv (...,2) = FaNo -> whether used C indiv (...,3) = MoNo -> reused for colors C indiv (...,4) = Dec Decade of Birth C indiv (...,5) = First couple number where individual appears CNEW indiv (...,6) = EgoN=EgoNumber CNEW indiv (...,6) = FaNo by EgoNumber CNEW indiv (...,7) = MoNo by EgoNumber !MOVE ALL INDIV NUMBERS INTO EGONUMBER FORMAT write (1, '(2000(20I4/) )') (indiv(j,6), j=1, maxindv) write (1, '(2000(20I4/) )') (indiv(j,7), j=1, maxindv) do i=1,maxindv indiv (i,5)=i if (indiv (i,1).ne.1) indiv (i,5)=0 enddo write (1, '(2000(20I4/) )') (indiv(j,5), j=1, maxindv) do i=1,maxindv indiv (i,5)=i if (indiv (i,1).ne.2) indiv (i,5)=0 enddo write (1, '(2000(20I4/) )') (indiv(j,5), j=1, maxindv) write (1, '(2000(20I4/) )') ( j , j=1, maxindv) C write (1, '(2000(20I4/) )') (indiv(j,3), j=1, maxindv) C write (1, '(2000(20I4/) )') (indiv(j,4), j=1, maxindv) close (1) write (*,'(a)') ' DUMMIES contains dummy parent records fo +r inserting', +' directly into your original text file' write (*,*) ' your processing is complete!' stop 990 write (*,*) ' error in par-dup file' C write (*,*) ' no duplicate lines' endif write (*, '(3I6)') index, maxindv, newmax write (2, '(3I6)') index, maxindv, newmax !NOT CORE OR STRINGS : THEN NOTHING ELIMINATED C if (an5.ne.'Y'.and.an1.ne.'2'.and.an1.ne.'3') then if (an5.ne.'Y') then write (*, *) ' NOTHING ELIMINATED' if (e1.ne.'E') then write (*,*) ' press Enter/Return ' xq=getcharqq() endif do j=1,index indiv(j,2)=1 enddo endif end