(c) 1997 Douglas R White pg2pajek takes a p-***.ved file and converts it to a ***-?.net file that also incorporates the p-***.dod file as well integer*2 G(5000), F(5000), GLVL(5000), C1(5000), NEW(5000) integer*2 GG(5000), FF(5000) character*1 let1, yn, y1 character*3 let3, scan character*14 filename, fileout character*5 text1(5000), text2(5000) character*11 text (5000) write (*,*) ' 3 Letter p-xxx.ved mnemonic' filename='p-xxx.ved' read (*,'(a)') let3 filename(3:5)=let3 INPUT FILES open (1,file=filename) filename(7:8)='do' open (2,file=filename) write (*,*) filename do i=1,3000 read (2,'(A3)') scan if (scan.eq.'***') goto 1 enddo 1 read (1,'(I4)') NMAR C write(*,'(1x,I4)') NMAR do i=1,nmar glvl(i)=1 read (2,'(8x,a5,35x,A5)') text1(i), text2(i) C write(*,'(8x,a5,35x,A5)') text1(i), text2(i) text(i)(1:5)=text1(i) text(i)(6:6)='&' text(i)(7:11)=text2(i) enddo read (1,*) (G(i),i=1,nmar) C write(*,*) (G(i),i=1,nmar) read (1,*) (F(i),i=1,nmar) write (*,*)' A)rcs for sons->parents, daughters->parents' write (*,*)' R)everse Arcs for parents->sons, parents->daughters' write (*,*)' U)ndirected edges, sons->parents, daughters->parents' write (*,*)' E)dgelist as above, not distinguished by type' write (*,*)' D)aughters->parents edges, sons->parent arcs' write (*,*)' S)ons->parent arcs, da-parent->so-parents edges' read (*,*) let1 C======== Option to Extract the Core2 do i=1,nmar gg(i)=g(i) FF(i)=f(i) enddo CALL CORE2 (gg, ff, c1, nmar, glvl) ! used in pgraph-2.for write (*,'(A)') ' Membership in core:' do i=1,nmar if (C1(i).gt.0.and.i.le.999) write (*,'(I4\)') i if (C1(i).gt.0.and.i.gt.999) write (*,'(I5\)') i enddo write(*,*)'Extract Core Only (Y) or Whole dataset (default/N)?' read (*,'(A)') yn if (yn.eq.'y') yn='Y' C=== write (*,'(2A,/6A)') ' Do you want to convert the generational lev34567890 +els in ', filename, ' to a Pajek ', fileout, ' file?' read (*,'(A)') y1 if (y1.eq.'y') y1='Y' if (y1.eq.'Y') then if (YN.eq.'Y') then fileout='xxxcorex.clu' fileout(1:3)=let3 fileout(8:8)=let1 else fileout='xxx-x.clu' fileout(1:3)=let3 fileout(5:5)=let1 endif filename='p-xxx-1.crd' filename(3:5)=let3 open (4,file=filename) NOLD=NMAR read (4,'(I4)') NMAR C write(*,'(1x,I4)') NMAR if (nmar.ne.nold) write(*,'(A)') +' warning: your p-xxx.ved and your p-xxx-1.crd files are of differ34567890 +ent dimension' read (4,*) (GLVL(i),i=1,nmar) endif C======== Option to Extract the Core2 if (yn.eq.'Y') then ired=0 do i=1,nmar if (c1(i).gt.0) then ired=ired+1 glvl(ired)=glvl(i) text(ired)=text(i) text1(ired)=text1(i) text2(ired)=text2(i) new(i)=ired endif enddo ired=0 do i=1,nmar if (c1(i).gt.0) then ired=ired+1 G(ired)=new(G(i)) F(ired)=new(F(i)) endif enddo Nmar=ired endif C======== if (y1.eq.'Y') then C fileout='xxx-x.clu' C fileout(1:3)=let3 C fileout(5:5)=let1 open (5,file=fileout) write (*,*) fileout do i=1,nmar write (5,'(I4)') GLVL(I) enddo endif C======== if (yn.eq.'Y') then fileout='xxxcorex.net' fileout(1:3)=let3 fileout(8:8)=let1 else fileout='xxx-x.net' fileout(1:3)=let3 fileout(5:5)=let1 endif open (3,file=fileout) write (*,*) fileout write (3,'(A, I5)') '*Vertices', Nmar do i=1,nmar write (3,'(I4, 3A)') i, ' "', text(i), '"' enddo C pause i0=0 i1=1 i2=2 if (let1.eq.'d'.or.let1.eq.'D') then WRITE (3,'(a)') '*Arcs' do i=1,nmar if (G(i).gt.0) write (3,'(3I5,3a)') I, G(i), i1, + ' p Solid c Black l "', text1(i),'"' enddo WRITE (3,'(a)') '*Edges' do i=1,nmar if (F(i).gt.0) write (3,'(3i5,3a)') I, F(i), i2, + ' c Red l "', text2(i),'"' enddo endif if (let1.eq.'s'.or.let1.eq.'S') then WRITE (3,'(a)') '*Arcs' do i=1,nmar if (G(i).gt.0) write (3,'(3i5,3a)') I, G(i), i1, ' c Black l "', + text1(i),'"' enddo WRITE (3,'(a)') '*Edges' do i=1,nmar if (G(i).gt.0.and.F(i).gt.0) write (3,'(3i5,3a)') G(I), F(i), i2, + ' c Red l "', text2(i),'"' enddo endif if (let1.eq.'a'.or.let1.eq.'A') then WRITE (3,'(a)') '*Arcs' ib=0 do i=1,nmar if (ib.eq.0.and.G(i).gt.0) then if (G(i).gt.0) write (3,'(3i5,3a)') I, G(i), i1, + ' c Black p Solid l "', text1(i),'"' ib=1 else if (G(i).gt.0) write (3,'(3i5,3a)') I, G(i), i1, ' l "', + text1(i),'"' endif enddo ib=0 do i=1,nmar if (ib.eq.0.and.F(i).gt.0) then if (F(i).gt.0) write (3,'(3i5,3a)') I, F(i), i2, + ' c Red p Dots l "', text2(i),'"' ib=1 else if (F(i).gt.0) write (3,'(3i5,3a)') I, F(i), i2, ' p Dots l "', + text2(i),'"' endif enddo endif if (let1.eq.'r'.or.let1.eq.'R') then WRITE (3,'(a)') '*Arcs' ib=0 do i=1,nmar if (ib.eq.0.and.G(i).gt.0) then if (G(i).gt.0) write (3,'(3i5,3a)') G(i), I, i1, + ' c Black p Solid l "', text1(i),'"' ib=1 else if (G(i).gt.0) write (3,'(3i5,3a)') G(i), I, i1, ' l "', + text1(i),'"' endif enddo ib=0 do i=1,nmar if (ib.eq.0.and.F(i).gt.0) then if (F(i).gt.0) write (3,'(3i5,3a)') F(i), I, i2, + ' c Red p Dots l "', text2(i),'"' ib=1 else if (F(i).gt.0) write (3,'(3i5,3a)') F(i), I, i2, ' p Dots l "', + text2(i),'"' endif enddo endif if (let1.eq.'u'.or.let1.eq.'U') then WRITE (3,'(a)') '*Edges' do i=1,nmar if (G(i).gt.0) write (3,'(3i5,3a)') I, G(i), i1, ' c Black l "', + text1(i),'"' if (F(i).gt.0) write (3,'(3i5,3a)') I, F(i), i2, ' c Red l "', + text2(i),'"' enddo endif if (let1.eq.'e'.or.let1.eq.'E') then WRITE (3,'(a)') '*Edgeslist' do i=1,nmar if (G(i).gt.0.and.F(i).gt.0) write (3,'(3i5)') I, G(i), F(i) enddo endif close(1) close(3) end SUBROUTINE CORE2 (gg, ff, c1, n, glvl) ! used in pgraph-2.for INTEGER*2 FF(n), GG(n), C1(n), GLVL(n) do kk=1,100 do i=1,n c1(i)=0 enddo ichange=0 C write (*,*) ' Kinship cycles core2' sum links for each point do i=1,N if (glvl(i).gt.0) then if (FF(i).gt.0.and.glvl(FF(i)).gt.0) then c1(i)=c1(i)+1 c1(FF(i))=c1(FF(i))+1 endif if (GG(i).gt.0.and.glvl(GG(i)).gt.0) then c1(i)=c1(i)+1 c1(GG(i))=c1(GG(i))+1 endif endif enddo if not in blok (=1) then delete FF, GG links to them do i=1,N if (c1(i).eq.1) then if (FF(i).gt.0.and.glvl(FF(i)).gt.0) then FF(i)=0 ichange=1 endif if (GG(i).gt.0.and.glvl(GG(i)).gt.0) then GG(i)=0 ichange=1 endif endif if (FF(i).gt.0.and.c1(FF(i)).eq.1.and.glvl(FF(i)).gt.0) then FF(i)=0 ichange=1 endif if (GG(i).gt.0.and.c1(GG(i)).eq.1.and.glvl(GG(i)).gt.0) then GG(i)=0 ichange=1 endif enddo if (ichange.eq.0) return enddo ! the kk to 100 change loop end