CATTEMPTED ZERO, line 874, 791 C$storage:2 C$INCLUDE: 'EXEC.FI' C GC1, FC1 = siblings C GC2, FC2 = years C ***************************** C * PROGRAM PAIRCALC * C ***************************** INTEGER*2 BK[allocatable](:), rsum(11), csum(11), rcsum(11) INTEGER*2 fq6(7,2), fq8(7,2), rs1, rc1, cs INTEGER*4 fq5(7,2), fq7(7,2) INTEGER*2 F [allocatable](:), G [allocatable](:), ks(7), ke(7) INTEGER*2 ID2 [allocatable](:), ID [allocatable](:), error INTEGER*2 NB [allocatable](:), MN [allocatable](:) C INTEGER*2 HI [allocatable](:), WI [allocatable](:) INTEGER*2 TROLD [allocatable](:), TD [allocatable](:) C INTEGER*2 TD0 [allocatable](:) INTEGER*2 FC [allocatable](:,:), GC [allocatable](:,:) INTEGER*2 GTREE [allocatable](:,:), FTREE [allocatable](:,:) INTEGER*2 FRQ (11,11), YEAR (20), GD [allocatable](:) INTEGER*2 FRP (11,11) C INTEGER*2 PERCENT [allocatable](:,:) INTEGER*2 VG [allocatable](:), VF [allocatable](:) INTEGER*2 SYSTEMQQ, GF [allocatable](:), SUMXY (21,21) LOGICAL EXX CHARACTER*1 EMPTY, CARE, ANSS, ans CHARACTER*1 TD2[allocatable](:), TOTAL [allocatable](:) CHARACTER*14 FILEUSED, FILENAME, JTEST, KTEST, FILEE C CHARACTER*11 CTIME C CHARACTER*8 CDATE CHARACTER*40 B, TITLE CHARACTER*30 T, FORMAT CHARACTER*79 TEXT CHARACTER*4 FR [allocatable](:) CHARACTER*3 EXTENSION (300), EXT, XXT ICP0=0 ICM0=0 ICP1=0 ICM1=0 MOIETYP=1 MOIETYM=1 nmp=0 nmm=0 notp=0 notm=0 ISW=0 C IDIM=9000 C IDPTH=22 CARE='Y' YEAR (19)=1 C C--+---LT1----+-T--2----T----3--T-+----4T---+---T5----+-T--6----T----R C PROGRAM PAIRCALC computes all prior kin connections among C marriages numbered 1 to N given as input data vectors of C marriage numbers of husband J's parents (read into G(J)) and C of marriage numbers of wife J's parents (read into F(J)). C C After reading the genealogy data, The algorithm computes C genealogical vectors (through F()emale and G()male ancestors) C for each ancestral type in the husband's (G's) family tree and C if a vector is nonempty computes similar genealogical vectors C for each ancestral type in the wife's (F's) family tree. The C two outcome vectors are compared for convergence and the C results are printed and saved in three different formats. C C Written by D.R.White July 1991 and described by White and C Jorion 1991 "Marriage and Kinship Networks: Computation and C Application," based on the idea of vectorial genealogy C developed in Jorion and Lalle 1983, "An Algorithm for the C Analysis of Genealogies as to prior kin connection between C spouses." C C The demonstration version of this program uses as input the C file KINVECTS with the following format: C NMAR C H1P H2P H3P H4P H5P H6P H7P H8P H9P refer to consecutive numbers C W1P W2P W3P W4P W5P W6P W7P W8P W9P C ... ... ... order of husband in his sibling set (optional) C ... ... ... order of wife in her sibling set (optional C 1 2 3 4 ... consecutive OR arbitrary numbers (optional) 1 close (1) C94 write (*,'(21(6X,A/))') 94 write (*,'(14(6X,A/))') +' PROGRAM PAR-CALC (Parent-Graph Genealogical Calculation)', +' Version 2.3 May 1996', +'computes PRIOR KIN CONNECTIONS among marriages numbered 1 to N', +'given as input marriage numbers of husband Js parents in G(J)', +' and marriage numbers of wife Js parents in F(J).', +' ', +' (c) 1992-96 D.R.White and described by White and Jorion 1992 ', +'"Representing and Computing Kinship: A Network Approach" in', +' CURRENT ANTHROPOLOGY ', +'based on the idea of vectorial genealogy developed in Jorion', +'and Lalle 1983, "An Algorithm for the Analysis of Genealogies', +'as to prior kin connection between spouses."', +' ', +' Option for files of type P-___.VE* (will be listed below)' C +' that have the following data format:', C +'NMAR (title optional) = number of couples in list', C +' H1P H2P H3P H4P H5P H6P H7P H8P H9P.. numbers of hu pa in list', C +' W1P W2P W3P W4P W5P W6P W7P W8P W9P.. numbers of wi pa in list', C +' ... ... ... order of husband in his sibling set (optional)', C +' ... ... ... order of wife in her sibling set (optional)', C +' 1 2 3 4 ... consecutive OR relabel numbers (optional)' C +' After reading the genealogy data, the algorithm computes', C +'genealogical vectors (through F()emale and G()male ancestors)', C +'for each ancestral type in the husbands (Gs) family tree; ', C +'if a vector is nonempty computes similar genealogical vectors', C +'for each ancestral type in the wifes (Fs) family tree. The', C +'two outcome vectors are compared for convergence and the', C +'results are printed and saved in three different formats.', 121 WRITE (*,'(A\)') ' Vector format D/S/C/B/M/K No=Demographic? ' READ (*,'(A)') EMPTY IF (EMPTY.eq.'d') EMPTY='D' IF (EMPTY.eq.'s') EMPTY='S' IF (EMPTY.eq.'c') EMPTY='C' IF (EMPTY.eq.'b') EMPTY='B' IF (EMPTY.eq.'m') EMPTY='M' ANSS=EMPTY IF (EMPTY.eq.'D'.or.EMPTY.eq.'S'.or.EMPTY.eq.'C'.or.EMPTY.eq.'B' +.or.EMPTY.eq.'M') EMPTY='Y' WRITE (*,*) empty IF (EMPTY.eq.'k') EMPTY='K' IF (EMPTY.EQ.'Y'.OR.EMPTY.EQ.'K') THEN C=========================== replace routine WRITE (*,*) ' vector format ' ext='VEC' ext (3:3)=ANSS idjust=0 call getfile (ext, extension, fileused, numbr, isw, *94, + idjust, xxt) ! PAR-GRA0 WRITE (*,*) fileused C PAUSE COLD Call getfile (ext, extension, fileused, stp, numbr, isw, xxt) C IF (ISET.EQ.4) ext='vec' ! slide retrieval p-???-1.crd C IF (ISET.EQ.5) ext='vem' ! slide retrieval p-???-1.crm OPEN (1, file=FILEUSED) ! .vec file READ (1,'(I4,A)') NMAR, TITLE filename=fileused filename(7:9)='doc' inquire (file=filename, exist=exx) if (exx) then OPEN (9, file=FILENAME) read (9, '(A)', end=73) text WRITE (*,'(1x,A)') text 72 DO kk=1,22 read (9, '(A)', end=73) text if (text(1:4).eq.'****') goto 73 WRITE (*,'(1x,A)') text enddo WRITE (*,'(1x,A)') text goto 72 73 continue endif CCC WRITE (*,'(A\)') ' Three letter xxx in P-xxx.VEC ? ' CCC FILEUSED='P-xxx.VEC' CCC READ (*,'(A)') THR CCC FILEUSED(3:5)=THR CCC OPEN (1, file=FILEUSED) CCC READ (1,'(I4,A)') NMAR, TITLE ELSE IF (EMPTY.eq.'n') EMPTY='N' IF (EMPTY.eq.'N') goto 121 write (*,'(24(6X,A/),6X,A\)') +' P-___.DEM files (will be listed below) have separate lines', +'for the man and woman in each couple, with the following', +'DATA FORMATS for each card, 1 (man or Hu), and 2 (woman or Wi)', +' 1-6 7-8 9-13 14-15 16-20 21-25 26-30 31-79 ', +' MarNo 01 HuPa# Hsib# HuDaB MaDaB HuDaD HuId+Name', +' MarNo 02 WiPa# Wsib# WiDaB MaDaE WiDaD WiID+Name', +' EXPLANATIONS FOR THESE COLUMNS ARE AS FOLLOWS:', +' MarNo: Marriage Number (cards need not be in this order)', +' HuPa#: Marriage Number of Parents of Husband', +' WiPa#: Marriage Number of Parents of Wife', +' sib#s: Sib # for sibling set, same parents -- you might number', +' all sibs but strictly necessary only with multiple marriages', +' HuDaB: Birth Date of Husband', +' WiDaB: Birth Date of Wife', +' MaDaB: Beginning Date of Marriage', +' MaDaE: Ending Date of Marriage', +' HuDaD: Death Date of Husband', +' WiDaD: Death Date of Wife', +' HuName: Name of Husband', +' WiName: Name of Wife', +' data in this format are preceded by a format statement', +' (I6,I2,I5,I2,3I5,A)', +' which may be altered if the order of the variables is kept', +' ', +' Do you want to use this format? ' READ (*,'(A)') EMPTY IF (EMPTY.eq.'y'.OR.EMPTY.eq.'Y'.OR.EMPTY.eq.' ') EMPTY='D' IF (EMPTY.NE.'D') GOTO 1 ext='dem' call getfile (ext, extension, fileused, numbr, isw, *94, + idjust, xxt)! PAR-GRA0 C-old Call getfile (ext, extension, fileused, stp, numbr, isw, xxt) READ (1,'(I4,A,/,A)') NMAR, TITLE, FORMAT ENDIF ALLOCATE( F ( NMAR ), G ( NMAR ), ID( NMAR ), STAT = error ) IF( error .NE. 0 ) WRITE (*, '(A)') ' Allocation error nmar 1*' ALLOCATE( ID2( NMAR ), NB( NMAR ), TD( NMAR+120 ), STAT = error ) IF( error .NE. 0 ) WRITE (*, '(A)') ' Allocation error nmar 2*' C ALLOCATE( HI ( NMAR ), WI( NMAR ), STAT = error ) C IF( error .NE. 0 ) WRITE (*, '(A)') ' Allocation error nmar 2+' ALLOCATE( TOTAL ( NMAR ), STAT = error ) IF( error .NE. 0 ) WRITE (*, '(A)') ' Allocation error nmar 3*' C ALLOCATE( TD0 ( NMAR+120 ), STAT = error ) C IF( error .NE. 0 ) WRITE (*, '(A)') ' Allocation error nmar 3*' ALLOCATE( MN ( NMAR ), TROLD ( NMAR ), STAT = error ) IF( error .NE. 0 ) WRITE (*, '(A)') ' Allocation error nmar 4*' ALLOCATE( FC ( NMAR,2 ), GC ( NMAR,2 ), STAT = error ) IF( error .NE. 0 ) WRITE (*, '(A)') ' Allocation error nmar,2*' 3 IF (EMPTY.EQ.'Y'.or.EMPTY.EQ.'K') THEN NPERIODS=1 YEAR(19)=1 C READ PAR NUMBERS READ (1, *) (G(J), J=1, NMAR) READ (1, *) (F(J), J=1, NMAR) DO J=1, NMAR GC(J,1)=0 FC(J,1)=0 ENDDO C READ SIB NUMBERS or HU/WI IDENTIFIERS READ (1, *, ERR=2,END=2) (GC(J,1), J=1, NMAR)! C READ (1, *, ERR=2,END=2) (HI(J), J=1, READ (1, *, ERR=2,END=2) (FC(J,1), J=1, NMAR)! C READ (1, *, ERR=2,END=2) (WI(J), J=1, C READ LABEL NUMBERS READ (1, *, ERR=2,END=2) (NB(J), J=1, NMAR) C READ (1, *, ERR=2,END=2) (NB(J), J=1, NMAR) C READ (1, *, ERR=2,END=2) (NB(J), J=1, NMAR) do i=1,nmar MN (i)=NB (i) enddo C CHECK CONSISTENCY OF MARRIAGE DATA 4 ISTOP=0 DO 20 J=1, NMAR IF (F(J).LT.-1.OR.F(J).GT.NMAR) GOTO 11 10 IF (G(J).LT.-1.OR.G(J).GT.NMAR) GOTO 13 GOTO 20 11 WRITE (*,12) ' Error in wifes parents data, marriage =',J,F (J) 12 FORMAT(A, 2I4) ISTOP=1 GOTO 10 13 WRITE (*,12) ' Error in husbands parents data, marriage=',J,G(J) ISTOP=1 20 CONTINUE IF (ISTOP.EQ.1) PAUSE C WRITE(*,'(I4)') NMAR C WRITE(*,'(20I4)') (G(J), J=1, NMAR) C WRITE(*,'(20I4)') (F(J), J=1, NMAR) C WRITE(*,'(20I4)') (NB(J), J=1, NMAR) C P-VECTRS? C CHECK IF GC1 OR FC1 HAVE BEEN READ IN PLACE OF NB 2 MAXG1=0 MAXF1=0 do i=1,nmar MN (i)=NB(i) enddo write (*, '(A,I6)') ' NMar=', NMAR CCC DO J=1,NMAR CCC IF (GC(J,1).GT.MAXG1) MAXG1=GC(J,1) CCC IF (FC(J,1).GT.MAXF1) MAXF1=FC(J,1) CCC ENDDO CCC IF (MAXG1.GE.NMAR) THEN CCC DO J=1,NMAR CCC NB (J)=GC (J,1) CCC GC (J,1)=0 CCC ENDDO CCC ELSE CCC IF (MAXF1.GE.NMAR) THEN CCC DO J=1,NMAR CCC NB (J)=FC (J,1) CCC GC (J,1)=0 CCC ENDDO CCC ELSE C GC AND FC HAVE BEEN READ BUT NOT NB CCC DO J=1,NMAR CCC NB (J)=J CCC ENDDO CCC ENDIF CCC ENDIF C END OF P-VECTORS READ ROUTINE IF (EMPTY.EQ.'K') THEN CLOSE (1) FILEE='P-DEMOG' CALL READONLY (FILEE, ISW, 1) C OPEN (1, file='P-DEMOG') WRITE (1, '(I4)') NMAR C* ' 1-6 7-8 9-13 14-15 16-20 21-25 26-30 31-79 ', C* ' MarNo 01 HuPa# Hsib# HuDaB MaDaB HuDaD HuId+Name', C* ' MarNo 02 WiPa# Wsib# WiDaB MaDaE WiDaD WiID+Name', C* ' Explanations for the columns are as follows:', C* ' MarNo: Marriage Number (cards need not be in this order)', C* ' HuPa#: Marriage Number of Parents of Husband', C* ' WiPa#: Marriage Number of Parents of Wife', C* ' sib#s: Sib # for sibling set, same parents -- you might number', C* ' all sibs but strictly necessary only with multiple marriages', M1=1 M2=2 DO I=1,NMAR WRITE (1, '(I6,I2,I5,I2)') NB(I), M1, G(I), GC(I,1) WRITE (1, '(I6,I2,I5,I2)') NB(I), M2, F(I), FC(I,1) ENDDO EMPTY='N' CLOSE (1) OPEN (1, file='P-DEMOG') FILEUSED=' P-DEMOG' READ (1,'(I4,A)') NMAR, TITLE GOTO 3 ENDIF ELSE C DEMOGRAPHIC FORMAT YEAR (1)=9999 LASTYR=0 MAX=0 C FORMAT='(I6,I2,I5,I2,3I5,A)' C ID# / 1or2 / PA# / SB# / Bdate C MN() N1or2 G() GC(,1) GC(,2) DO 60 J=1,NMAR READ (1,FMT=FORMAT,END=58) MN(J), N1, G(J), (GC(J,K),K=1,2) READ (1,FMT=FORMAT,END=58) N0, N2, F(J), (FC(J,K),K=1,2) C WRITE (*, '(3I6)') J, GC(J,2), FC(J,2) GOTO 59 58 write (*, '(A,I4)') ' Hit End of P-DEMOG AFTER CARDPAIR', J STOP 59 IF (GC(J,2).GT.0.AND.GC(J,2).LT.YEAR (1)) YEAR (1)=GC(J,2) IF (GC(J,2).GT.0.AND.FC(J,2).LT.YEAR (1)) YEAR (1)=FC(J,2) IF (GC(J,2).GT.0.AND.GC(J,2).GT.LASTYR) LASTYR=GC(J,2) IF (GC(J,2).GT.0.AND.FC(J,2).GT.LASTYR) LASTYR=FC(J,2) IF (N2-N1.NE.1.AND.N1.GT.0.AND.N2.GT.0) + WRITE (*, '(A)') ' Problem with data' IF (MN(J).NE.N0) + WRITE (*, '(A)') ' Problem with data' IF (MN(J).GT.MAX) MAX=MN(J) IF (G(J).GT.MAX) MAX=G(J) IF (F(J).GT.MAX) MAX=F(J) 60 CONTINUE IF (MAX.LE.NMAR) THEN DO I=1,NMAR NB (I) = MN (I) ENDDO ELSE C IF (MAX.GT.IDIM) THEN C WRITE (*, '(A,I4,A)') ' Cant process:ID', MAX, ' exceeds dim' C STOP C ENDIF WRITE (*, '(A,I4,A)') ' Max= ', Max C DEALLOCATE (HI, WI, STAT = error ) C IF( error .NE. 0 ) WRITE (*, '(A)') ' Deallocation error 2' DEALLOCATE ( ID2,NB, STAT = error ) IF( error .NE. 0 ) WRITE (*, '(A)') ' Deallocation error 2+' DEALLOCATE ( TD,TOTAL,MN,TROLD,FC,GC,GD,GF, STAT = error ) IF( error .NE. 0 ) WRITE (*, '(A)') ' Deallocation error 3' ALLOCATE( F ( MAX ), G ( MAX ), ID( MAX ), STAT = error ) IF( error .NE. 0 ) WRITE (*, '(A)') ' Allocation error MAX*' ALLOCATE( ID2( MAX ), NB( MAX ), STAT = error ) IF( error .NE. 0 ) WRITE (*, '(A)') ' Allocation error MAX*' C ALLOCATE( HI ( MAX ), WI (MAX ), STAT = error ) C IF( error .NE. 0 ) WRITE (*, '(A)') ' Allocation error MAX+' ALLOCATE( TD ( MAX+120 ), STAT = error ) IF( error .NE. 0 ) WRITE (*, '(A)') ' Allocation error MAX+ 5*' ALLOCATE( TOTAL ( MAX ), STAT = error ) IF( error .NE. 0 ) WRITE (*, '(A)') ' Allocation error nmar 3*' C ALLOCATE( TD0( MAX+120 ), STAT = error ) C IF( error .NE. 0 ) WRITE (*, '(A)') ' Allocation error MAX+ 6*' ALLOCATE( MN( MAX ), TROLD ( MAX ), STAT = error ) IF( error .NE. 0 ) WRITE (*, '(A)') ' Allocation error MAX*' ALLOCATE( FC ( MAX,2 ), GC ( MAX,2 ), STAT = error ) IF( error .NE. 0 ) WRITE (*, '(A)') ' Allocation error MAX,2*' DO J=1,MAX ID (J)=0 ID2 (J)=0 ENDDO DO J=1,NMAR IF (MN(J).GT.0.and.MN(J).le.max) ID2 (MN(J)) =1 IF ( G(J).GT.0.and. G(J).le.max) ID2 (G (J)) =1 IF ( F(J).GT.0.and. F(J).le.max) ID2 (F (J)) =1 ENDDO NEWNO=0 DO JOLD=1,MAX IF (ID2(JOLD).EQ.1) THEN NEWNO=NEWNO+1 ID (JOLD)= NEWNO CC TROLD (NEWNO)= JOLD ENDIF C ID IS TAKES OLD MN AND RETURNS VECTOR POSITION IN NEW ARRAY ENDDO DO I=1,NMAR C GO THROUGH EACH ORIGINAL CARD TO RECODE IN NEW NUMBER SERIES (ID) TROLD (I)= 0 TD (I)= 0 ID2 (I)= 0 IF (MN(I).GT.0) TROLD(I)= ID (MN(I)) IF ( G(I).GT.0) TD (I)= ID (G (I)) IF ( F(I).GT.0) ID2 (I)= ID (F (I)) C TROLD IS THE NEW SERIES NUMBER OF THE MarNo IN THE I-th CARD ENDDO CREATE A NEW PSEUDO ARRAY 1 to NEWNO so that #s correspond DO I=1,NMAR NB ( TROLD (I)) = MN (I) G ( TROLD (I)) = TD (I) F ( TROLD (I)) = ID2 (I) C HAVE TO GET SOME NB NUMBERS OFF NEW LIST IF ( TD(I).GT.0) + NB ( TD(I) ) = G(I) IF ( ID2(I).GT.0) + NB ( ID2(I) ) = F(I) ENDDO C G,F orig, MN, NB reversed C WRITE(*,'(20I4)') (G(J), J=1, NMAR) C WRITE(*,'(20I4)') (F(J), J=1, NMAR) C WRITE(*,'(20I4)') (MN(J), J=1, NMAR) C WRITE(*,'(20I4)') (NB(J), J=1, NMAR) C PAUSE NMAR=NEWNO DO I=1,NMAR MN (I) = I ENDDO ENDIF C END OF MAX>NMAR IN DATA ENTRY ROUTINE WRITE(*,'(20I4)') (G(J), J=1, NMAR) WRITE(*,'(20I4)') (F(J), J=1, NMAR) WRITE(*,'(20I4)') (GC(J,1), J=1, NMAR) WRITE(*,'(20I4)') (FC(J,1), J=1, NMAR) WRITE(*,'(20I4)') (MN(J), J=1, NMAR) WRITE(*,'(20I4)') (NB(J), J=1, NMAR) IF (YEAR (1).NE.0.AND.LASTYR.NE.0) THEN WRITE (*, '(2(A,I6)/,A\)') ' Birth Dates range between ', +YEAR (1), ' and ', LASTYR, ' Pick a starting date for cohort: ' READ (*, '(I5)') YEAR (1) IF (YEAR (1).EQ.0) THEN NPERIODS=1 YEAR(19)=1 GOTO 67 ENDIF DO I=1,17 64 WRITE (*, '(A,I2,A\))') ' Pick period', I,' end date: ' READ (*, '(I5)') YEAR (I+1) IF (YEAR (I+1).LE.YEAR(I)) GOTO 64 IF (YEAR (I+1).GE.LASTYR) GOTO 66 ENDDO 66 NPERIODS=I YEAR(19)=I 67 CONTINUE ENDIF ENDIF C END OF TWO ALTERNATE DATA ENTRY ROUTINES C INITIALIZE TD AND TOTAL DO I=1,NMAR TD (I)=0 TOTAL (I)='.' ENDDO CLOSE (1) 44 WRITE (*,'(A)') ' Choose a Depth of Genealogical Search', + ' that will identify blood marriages up to:', + ' 1=sibling marriages', + ' 2=cousin marriages', + ' 3=2nd cousin marriages', + ' 4=3rd cousin marriages', + ' 5=4th cousin marriages', + ' 6=5th cousin marriages', + ' 7=6th cousin marriages' write (*,'(A\)') ' : ' READ (*,'(I4)',err=44) KLEV IF (KLEV.EQ.0) KLEV=7 IF (KLEV.LT.1) THEN WRITE (*,'(A)') ' Depth must be greater than 0 ' GOTO 44 ENDIF IDPTH=KLEV C IF (KLEV.GT.IDPTH) THEN C WRITE (*,'(A,I3)') ' Too Deep for Current Dimension of ', IDPTH C GOTO 5 C ENDIF C THIS IDEA WONT WORK BECAUSE YOU HAVE TO COMPUTE THESE ANYWAY! C write (*,'(A)') ' Is there a depth less than', klev, C +' above which you want to exclude in the analysis?' C write (*,'(A\)') ' : ' C READ (*,'(I4)',err=44) LLEV IDIM=NMAR ALLOCATE( FR ( IDPTH+1 ),STAT = error) IF( error .NE. 0 ) WRITE (*, '(A)') ' Allocation error IDPTH' ALLOCATE( GTREE (IDIM,IDPTH+1), FTREE (IDIM,IDPTH+1),STAT = error) IF( error .NE. 0 ) WRITE (*, '(A)') ' Allocation error idim IDPTH' ALLOCATE( TD2 ( NMAR ), GD (NMAR), GF (NMAR), STAT = error ) IF( error .NE. 0 ) WRITE (*, '(A)') ' Allocation error NMAR 1' C ALLOCATE( PERCENT( IDIM, 10 ), STAT = error ) C IF( error .NE. 0 ) WRITE (*, '(A)') ' Allocation error NMAR 1' ALLOCATE( VG ( IDPTH ), VF ( IDPTH ), STAT = error ) IF( error .NE. 0 ) WRITE (*, '(A)') ' Allocation error IDIM 2' DO I=1,IDPTH+1 FR(I)='Freq' ENDDO WRITE (*,'(A\)') +' Is there some marriage path to test? 0=No or Number: ' READ (*,'(I4)',err=15) ITEST c WRITE (*,'(A\)') c +' Is there some type of marriage to test? 0=No 1=Yes ' c READ (*,'(I6)',err=15) JJTEST c IF (JJTEST.GT.0) THEN c WRITE (*,'(A\)') c WRITE (*,'(A\)') c +' Enter two numbers, e.g., 100, 001 for HuMoMoPa=WiMoFaPa c +' (MoMoBrDaDa ) on seperate lines:' c READ (*,'(A10)') JTEST c READ (*,'(A10)') KTEST c ENDIF 15 EMPTY='N' C pause 0 C I9=100 C OPEN (4, file='P-FREQS', carriage control="FORTRAN") write (*, *) ' Deleting file p-freqs:' IK = SYSTEMQQ ( 'DEL P-FREQS'C ) IF( IK .EQ. -1 ) STOP 'Could not run COMMAND.COM' FILEE='P-XXX.FRQ' CALL READONLY (FILEE, ISW, 4) C OPEN (4, file='P-XXX.FRQ', status='unknown') FILEE='P-TYPES' CALL READONLY (FILEE, ISW, 5) C OPEN (5, file='P-TYPES', status='unknown') C REWIND (5) if (nmar.le.100) then FILEE='P-GRAPH' CALL READONLY (FILEE, ISW, 6) CDEBUG OPEN (6, file='P-GRAPH', status='unknown') REWIND (6) endif FILEE='SCRATCH' CALL READONLY (FILEE, ISW, 7) CDEBUG OPEN (7, file='SCRATCH', status='unknown') REWIND (7) FILEE='SCRATCH2' CALL READONLY (FILEE, ISW, 8) C OPEN (8, file='SCRATCH2', status='unknown') REWIND (8) CLOSE (9) FILEE='SCRATCH3' CALL READONLY (FILEE, ISW, 9) C OPEN (9, file='SCRATCH3', status='unknown') REWIND (9) C CALL TIME (CTIME) C CALL DATE (CDATE) WRITE (7, '(5A)') TITLE C WRITE (7, '(5A)') CDATE, ' ', CTIME, FILEUSED WRITE (7,'(A,I4)') ' Depth of Genealogical Search: ', KLEV IL=11 IF (KLEV.LT.11) IL = KLEV+1 C DO LL=1,IL-1 C DO LL=1,KLEV C DO I=1,NMAR C* Debug dim (idim=NMAR, 10) C PERCENT (I, LL)=0 C ENDDO C ENDDO DO i=1,11 DO j=1,11 FRQ (I,J)=0 FRP (I,J)=0 ENDDO ENDDO DO i=1,7 DO j=1,2 FQ5 (I,J)=0 FQ6 (I,J)=0 FQ7 (I,J)=0 FQ8 (I,J)=0 ENDDO ENDDO C C C C REDUCE TO CORE THEN COMPUTE call core (F, G, NMar) C C C C BINARY TREE ALGORITHM: FINDS PARENTAL (FA MO) KINSHIP PATHS C C TO SEARCH A BINARY TREE 0=G=GMALE 1=F=FEMALE 00000000... TO 1111111... C V=VECTOR OF 0/1 DENOTING THE LAST WORD OF LENGTH L, E.G. L=3 V=010, NOW C FACED WITH CHOICE 0/1 IF M=1 LAST MOVE WAS UP IF M=0 LAST MOVE WAS DOWN C GTREE stores the Gmale Ancestral Marriage vector for level L ancestor V DO 1000 IPERIOD=1,YEAR(19) YEAR (20)=IPERIOD C INITIALIZE DO I=1,NMAR DO J=1,KLEV+1 GTREE(I,J)=0 FTREE(I,J)=0 ENDDO ENDDO DO I=1,NMAR IF (YEAR(19).EQ.1) THEN GTREE(I,1)=G(I) FTREE(I,1)=F(I) ELSE IF (GC(I,2).LE.YEAR(IPERIOD+1).AND.GC(I,2).GT.0) GTREE(I,1)=G(I) IF (GC(I,2).LE.YEAR(IPERIOD+1).AND.GC(I,2).GT.0) FTREE(I,1)=F(I) ENDIF ENDDO C write (*,'(A,180(20i4))') ' Marriage ',(I,I=1,NMAR) C write (*,'(A,20A)') ' -------- ',('----',I=1,NMAR) C write (*,'(A,180(20i4))') ' G=Hu Par ',(GTREE(I,1),I=1,NMAR) C write (*,'(A,180(20i4))') ' F=Wi Par ',(FTREE(I,1),I=1,NMAR) C write (*,'(A)') ' ' FILEE='P-LINKGG' NUMG=0 LENG=0 NUMF=0 LENF=0 CALL READONLY (FILEE, ISW, 3) FILEE='P-LINKFF' C OPEN (2, file='P-LINKFF', status='unknown') CALL READONLY (FILEE, ISW, 2) C OPEN (3, file='P-LINKGG', status='unknown') ICOUNT=0 L=1 VG(L)=0 C use G=0 in subroutines below IF (CARE.EQ.'Y') CALL CHECK (IDIM,IDPTH,G,GTREE,L,NMAR, CARE,MN) C parent link CALL LINKGG (L, GTREE, NMAR, IDIM, IDPTH, VG, 3, NUMG, LENG, +GD, GF) CALL FEMALE (VG,VF,G,F,GTREE,FTREE,IDIM,IDPTH,NMAR,L,ID,ID2, +TD,KLEV,ICOUNT, FC, GC, YEAR, ITEST, NB, CARE, TROLD, FRQ, FRP, +NUMF,LENF, GD, GF) 30 L=L+1 IF (L.GT.KLEV) THEN L=L-1 GOTO 40 ENDIF VG(L)=0 C use G=0 in subroutines below CALL NEXT (EMPTY,IDIM,IDPTH,G,GTREE,L,NMAR) IF (CARE.EQ.'Y') CALL CHECK (IDIM,IDPTH,G,GTREE,L,NMAR, CARE,MN) C IF EMPTY THEN BACKTRACK TO 40; IF NOT EMPTY THEN FORWARD TO 30 IF (EMPTY.EQ.'Y') GOTO 40 C NONEMPTY SO WRITE TO P-LINKGG AND TEST CALL LINKGG (L, GTREE, NMAR, IDIM, IDPTH, VG, 3, NUMG, LENG, +GD, GF) CALL FEMALE (VG,VF,G,F,GTREE,FTREE,IDIM,IDPTH,NMAR,L,ID,ID2, +TD,KLEV,ICOUNT, FC, GC, YEAR, ITEST, NB, CARE, TROLD, FRQ, FRP, +NUMF,LENF, GD, GF) GOTO 30 C FORETRACK C BACKTRACK IF EMPTY OR LIMIT REACHED 40 CONTINUE IF (VG(L).EQ.1) THEN L=L-1 IF (L.LE.1) GOTO 50 GOTO 40 ENDIF VG(L)=1 C use F in subroutines below IF (L.LE.1) GOTO 50 CALL NEXT (EMPTY,IDIM,IDPTH,F,GTREE,L,NMAR) IF (CARE.EQ.'Y') CALL CHECK (IDIM,IDPTH,F,GTREE,L,NMAR,CARE,MN) IF (EMPTY.EQ.'Y') THEN L=L-1 IF (L.LE.1) GOTO 50 GOTO 40 C BACKTRACK ELSE C NONEMPTY SO WRITE TO P-LINKGG AND TEST CALL LINKGG (L, GTREE, NMAR, IDIM, IDPTH, VG, 3, NUMG, LENG, +GD, GF) CALL FEMALE (VG,VF,G,F,GTREE,FTREE,IDIM,IDPTH,NMAR,L,ID,ID2, +TD,KLEV,ICOUNT, FC, GC, YEAR, ITEST, NB, CARE, TROLD, FRQ, FRP, +NUMF,LENF, GD, GF) GOTO 30 C FORETRACK ENDIF C END TREE 50 CONTINUE C ================================================================= C SIDEWAYS: IF ANCESTERAL VECTORS OVERLAP, and IF MARRIED then chain !! C easy with binary vectors C! CC TRY TO COMPUTE man's WZHB = FfGg CC GTREE(I,1)=G(I) C EMPTY='Y' C DO 49 L=2,2 C IH=0 C ITOT=0 C DO 48 I=1,NMAR C IF (GTREE(I,L-1).EQ.0) GOTO 48 C DO 47 J=1,NMAR C IF (FTREE(J,L-1).EQ.GTREE(I,L-1)) THEN CCMan's Sister + Husband = J wrt I C IF (GTREE(J,L-1).EQ.0) GOTO 47 C DO 46 K=1,NMAR C IF (GTREE(K,L-1).EQ.0) GOTO 46 C IF (GTREE(K,L-1).EQ.GTREE(J,L-1)) ITOT=ITOT+1 CCMan's Sister's Husband's Brother exists C IF (I.EQ.K) THEN CCMan's Sister's Husband's Brother is same as ego CC GTREE(I,L)=K C IH=IH+1 C ID(IH)=K C EMPTY='N' C ENDIF C 46 CONTINUE C ENDIF C 47 CONTINUE C 48 CONTINUE C IF (EMPTY.EQ.'N') THEN C B='H=WZHB' C IP=0 C IF (ITOT.GT.0) IP=100*IH/ITOT C WRITE (*, '(1X,A,I4,I5,A,I5,9000i4)') B, IH, IP, '%', C + (ID(I),I=1,IH) C WRITE (4, '(1X,A,I4,I5,A,I5,9000i4)') B, IH, IP, '%', C + (ID(I),I=1,IH) CC + (ID(I),I=1,IH), (ID2(I),I=1,NMAR) C ENDIF C 49 CONTINUE CC CALL CONVERGE (VG, VF, FTREE,GTREE,NMAR,IDIM,IDPTH,L,LL,ID, CC +ID2,TD,KLEV,ICOUNT, FC, GC, YEAR, ITEST, NB, TROLD, FRQ) CC================================================================= 1000 CONTINUE WRITE (*, '(1X,3A)') ' ' C WRITE (5, '(1X,3A)') ' ' C WRITE (*, '(1X,3A)') CDATE, ' ', CTIME C WRITE (5, '(3A)') CDATE, ' ', CTIME CALL GRAPH (G,F,IDIM,NMAR,ID,TD,TROLD,NEWNUM,NB) Cwrite the number of couples WRITE (5, '(I4)') NewNum WRITE (5, '(100000I4)') (TROLD(I),I=1,NEWNUM) WRITE (5, '(A)') TITLE WRITE (*, '(A)') ' ' REWIND (4) WRITE (*, '(A)') ' ' write (*,'(A,A)') ' Kinship Kin ', +' Freq of Poss Per- List of ' write (*,'(A,A)') ' Equations Types ', +' Couples ible cents Couples' DO I=1,20 DO J=1,20 sumxy (I,J)=0 ENDDO ENDDO filename(7:9)='lst' open (9, file=filename, status='unknown') DO 100 J=1,10000 C IF (IHH.GT.0)WRITE(4, C '(1X,A,I1,I4,2(I5, A),i5,9000i4)')G,IYEAR20, CG=FG BD 0 0 CG=FG ^D 0 3/ 8 37% 11 7 12 -1 -1 -1 -1 0 -1 1 - READ (4, '(1X,A,I1,I4,1x,2i4,1x,i5,9000i4)',END=101) B, IPERD, + IH, IH3, IP, (ID(I),I=1,IH), (ID2(I),I=1,NMAR) DO I=1,NMAR C: DEFAULT: NOTHING ELSE FOUND IF (ID2(I).EQ.-3) TD2(I)='.' IF (ID2(I).EQ.-2) TD2(I)=' ' C: DEFINITELY NO DATA IF (ID2(I).EQ.-1) TD2(I)='.' IF (ID2(I).EQ. 0) TD2(I)='0' IF (ID2(I).EQ. 1) TD2(I)='1' IF (ID2(I).EQ. 8) TD2(I)='-' IF (ID2(I).EQ. 9) TD2(I)='a' COMPUTE TOTAL FROM TD2 IF (TD2(I).EQ.'1') TOTAL(I)='1' IF (TOTAL(I).NE.'1'.AND.(TD2(I).EQ.'a'.OR.TD2(I).EQ.'-'.OR. +TD2(I).EQ.'0')) TOTAL(I)='0' ENDDO if (ih.gt.0) then IF (iperd.eq.0) THEN WRITE (*, '(1X,A,1x,2I4,A,180(20I4))') B, IH, IP, '%', + (NB(ID(I)),I=1,IH) ELSE WRITE (*, '(1X,A,I1,2I4,A,180(20I4))') B, IPERD, IH, IP, '%', + (NB(ID(I)),I=1,IH) ENDIF else WRITE (*, '(1X,A,1x,2I4,A,180(20I4))') B, IH3 ENDIF do i=1,IH write (9, *) ID(I), NB(ID(I)) enddo DO I=1,30 IF (I.GT.NMAR) THEN T(I:I)=' ' ELSE T(I:I)=TD2(I) ENDIF ENDDO C* DEBUG CNX COUNTS THE NUMBER OF SEX CROSSOVERS (X DISTINCTION) IN BLOOD MARRIAGE C if (IH.GT.0) then NX = 0 ! matrilineal moieties NY = 0 ! patrilineal moieties DO I=2,40 IF (B(I-1:I-1).NE.'G'.AND.B(I-1:I-1).NE.'F') GOTO 99 IF (B(I :I ).NE.'G'.AND.B(I :I ).NE.'F') GOTO 99 IF (B(I:I).EQ.'G') NX=NX+1 ! EVERY MALE LINK ADD ONE ML IF (B(I:I).EQ.'F') NY=NY+1 ! EVERY FEMALE LINK ADD ONE PL 99 IF (B(I:I).EQ.' ') GOTO 97 ENDDO CIF X OR Y IS ALWAYS ODD THEN THERE IS A MOIETY SYSTEM = 97 if (IH.GT.0) then IF (MOD(NX,2).EQ.0) then MOIETYM=0 notm=notm+ih else nmm=nmm+ih endif IF (MOD(NY,2).EQ.0) then MOIETYP=0 notp=notp+ih else nmp=nmp+ih endif sumxy (ny+1,nx+1) = sumxy (ny+1,nx+1) + IH CWRITING SCRATCH2 files then sorted to P-FREQS.SRT below CTHIS IS USED IN THE C FINAL OUTPUT FILE DO I=1,38 IF (B(I:I+2).eq.' ^D') B(I:I+2)=' D ' IF (B(I:I+2).eq.'F^S') B(I:I+2)='p-B' IF (B(I:I+2).eq.'F^D') B(I:I+2)='p-Z' IF (B(I:I+2).eq.'M^S') B(I:I+2)='m-B' IF (B(I:I+2).eq.'M^D') B(I:I+2)='m-Z' ENDDO C IF (IHH.GT.0)WRITE(4,'(1X,A,I1,I4,A,2i4,A,i5,9000i4)')G,IYEAR20, do i=1,IH F(I)= FC(ID(I),1) if (FC(ID(I),1).lt.1000) F(I)=-FC(ID(I),1) enddo izero=0 WRITE (8, '(1X,A,2I2,1X,I1,I4,A,2I4,A,1X,1800I4)') B, NY+1, +NX+1, IPERD, IH, '/', IH3, IP, '%', (ID(I),I=1,IH), izero, +(GC(ID(I),1),F(I),I=1,IH) ! ZERO CC WRITE (8, '(1X,A,2I2,1X,I1,I4,A,2I4,A,1X,A,1800I4)') B, NY+1, CC +NX+1, IPERD, IH, '/', IH3, IP, '%', T, (ID(I),I=1,IH), izero, CC +(GC(ID(I),1),F(I),I=1,IH) ! ZERO C +NX+1, IPERD, IH, '/', IH3, IP, '%', T, (NB(ID(I)),I=1,IH) C write (*,*) (ID(I),I=1,IH) C write (*,*) (NB(ID(I)),I=1,IH) C pause else ! IH.eq.0 NO BLOOD MARRIAGES WITH THIS RELATIVE C IF (IP.GT.0) WRITE (8, '(1X, A, I4, A, I4)') B, IH, '/' ,IP WRITE (8, '(1X, A, 2i2,1x,i1, I4, A, I4)') B, NY+1, +NX+1, IPERD, IH, '/', IH3 endif do k=2,klev if (B(k:k).eq.'=') goto 977 if (B(k:k).eq.'G') fq7(k-1,1)=fq7(k-1,1)+ih3-ih if (B(k:k).eq.'F') fq7(k-1,2)=fq7(k-1,2)+ih3-ih if (B(k:k).eq.'G') fq8(k-1,1)=fq8(k-1,1)+ih if (B(k:k).eq.'F') fq8(k-1,2)=fq8(k-1,2)+ih goto 979 977 if (B(2:2).eq.'G'.and.B(K+2:K+2).eq.'F') then ! Patri Iroq Cross C write (*,'(2a)') B, ' Iroquois patri-cross' C write (7,'(2a)') B, ' Iroquois patri-cross' ICP1=ICP1+IH else ! Patri Iroq Parallel ICP0=ICP0+IH endif if (B(2:2).eq.'F'.and.B(K+2:K+2).eq.'G') then ! Matri Iroq Cross C write (*,'(2a)') B, ' Iroquois matri-cross' C write (7,'(2a)') B, ' Iroquois matri-cross' ICM1=ICM1+IH else ! Matri Iroq Parallel ICM0=ICM0+IH endif do kk=k+2,2*klev+1 if (B(kk:kk).eq.' ') goto 978 if (B(kk:kk).eq.'G') fq5(kk-k-1,1)=fq5(kk-k-1,1)+ih3-ih if (B(kk:kk).eq.'F') fq5(kk-k-1,2)=fq5(kk-k-1,2)+ih3-ih if (B(kk:kk).eq.'G') fq6(kk-k-1,1)=fq6(kk-k-1,1)+ih if (B(kk:kk).eq.'F') fq6(kk-k-1,2)=fq6(kk-k-1,2)+ih enddo goto 978 979 enddo 978 DO K=1,40 IF (B(K:K).EQ.' ') GOTO 98 IF (B(K:K).EQ.'^') GOTO 100 ENDDO 98 if (ih.gt.0) then CCC WRITE (*, '(A,5X,100000A1/))') '&', (TD2(I),I=1,NMAR) CWRITING P-TYPES FILES WRITE (5, '(A,I1,1X,100000A1)') B, IPERD, +(TD2(TROLD(I)),I=1,NEWNUM) ENDIF 100 CONTINUE Cnever reached here! write (8, '(A,A)') ' STOP' C CALL GRAPH (G,F,IDIM,NMAR,ID,TD,TROLD,NEWNUM,NB) write (8, '(A,A)') ' total marriage vector', (TOTAL(I),I=1,NMAR) 101 KTOT=0 pause " press Enter/Return (or to see p-xxx.frq files hit control- +break)" JTOT=0 KDEN=0 DO I=1,NMAR C IF (TOTAL(I).NE.'.') THEN IF (F(I).gt.0.and.G(I).gt.0) then KDEN=KDEN+1 ENDIF CHANGED THIS FROM INSIDE IF THEN IF (TOTAL(I).EQ.'1') KTOT=KTOT+1 ENDDO CLOSE (8) ! CLOSE SCRATCH2 C IK = SYSTEMQQ ( 'SORT/R/+46 P-FREQS.SRT'C ) IK = SYSTEMQQ ( 'SORTF SCRATCH2 P-FREQS.SRT /R /+46 'C ) IF( IK .EQ. -1 ) STOP 'Could not run COMMAND.COM' write (*, '(a/a)')' For this program to run, the SORTF.COM program + must be on the path',' If program stops here REBOOT and COPY SORT +F.COM from another subdirectory' WRITE (5, '(I4,A,I4,A)') J-1, ' Kin Type Marriage Vectors for', + NEWNUM, ' Consanguineally Linked Couples' WRITE (9, '(I4,A,I4,A)') J-1, ' Kin Type Marriage Vectors for', + NEWNUM, ' Consanguineally Linked Couples' CLOSE (4) FILEE='P-XXX.FRQ' CUSED TO BE THE OPEN WAS COMMENTED, THE CALL WAS NOT!! C CALL READONLY (FILEE, ISW, 4) ! OPENS FILE AS 4 writes ' test' C OPEN (4, file='P-xxx.FRQ', status='unknown') C CALL READONLY (FILEE, ISW, 4) ! OPENS FILE AS 4 writes ' test' OPEN (4, file='P-xxx.FRQ', status='unknown') DO J=1,10000 CREADS P-FREQS CG=F Z 0 0/ 3 CG=FG BD 0 0/ 1 CGF=F MZ 0 0/ 1 CGF=FG MBD 0 1/ 1 100% 1 1 -1 -1 -1 -1 CX1234567890123456789012345678901234567890I1234x12341234X12345 C READ (4, '(1X,A,I1,I4,2(I5,1X),I5,9000i4)',END=152) B, IPERD, IH, READ (4, '(1X,A,I1,I4,1x,2I4,1x,I5,9000i4)',END=152) B, IPERD, IH, +IH3, IP, (ID(I),I=1,IH), (ID2(I),I=1,NMAR) DO I=1,NMAR IF (ID2(I).EQ.-3) TD2(I)='?' IF (ID2(I).EQ.-2) TD2(I)=' ' IF (ID2(I).EQ.-1) TD2(I)='.' IF (ID2(I).EQ. 0) TD2(I)='0' IF (ID2(I).EQ. 1) TD2(I)='1' IF (ID2(I).EQ. 8) TD2(I)='-' IF (ID2(I).EQ. 9) TD2(I)='a' ENDDO IPERD=YEAR(19)-IPERD CWRITING P-TYPES WRITE (5, '(A,I1,1X,30A1/,100000A1))') + B, IPERD, (TD2(I), I=1, NMAR) ENDDO 152 CLOSE (4) if (nmar.le.100) then WRITE (6, '(3A)') ' ' C WRITE (6, '(3A)') CDATE, ' ', CTIME CLOSE (6) WRITE (*, '(A)') ' ' ENDIF WRITE (5, '(I4,A,I4,A)') J-1, ' Kin Type Marriage Vectors for', + NMAR, ' All Couples' CLOSE (5) ! P-TYPES WRITE (9, '(I4,A,I4,A)') J-1, ' Kin Type Marriage Vectors for', + NMAR, ' All Couples' WRITE (9, '(a)') TITLE CLOSE (9) IF (KDEN.GT.0) JTOT=100*(real(ktot)/real(kden)) write (7,'(2(I4,A),I4,A)') KTOT, '(',JTOT, '%) of', kden, +' endogamous couples in blood marriages ' write (*,'(2(I4,A),I4,A)') KTOT, '(',JTOT, '%) of', kden, +' endogamous couples in blood marriages ' write (*,'(I4,a,I4,a/)') ktot, ' blood marriages ', + int(100*real(ktot)/real(nmar)), '% of all marriages' write (7,'(I4,a,I4,a/)') ktot, ' blood marriages ', + int(100*real(ktot)/real(nmar)), '% of all marriages' CHANGED THIS IF (KTOT.GT.0) THEN ITOT=0 ITER=10 IF (KLEV.LT.10) ITER=KLEV C LL=male degree write (7,'(A )') ' Generational Degree (Distance to Common' write (7,'(A )') ' Ancestor): on the wife*s side' write (7,'(A )') ' on Hu*s' write (7,'(A,11I5)') ' Side', (I, I=1,ITER), nmar write (*,'(A )') ' Generational Degree (Distance to Common' write (*,'(A )') ' Ancestor): on the wife*s side' write (*,'(A )') ' on Hu*s' C write (*,'(A,I4)') ' Side 1 2 3 4 5 6 7 N=', C + nmar write (*,'(A,11I5)') ' Side', (I, I=1,ITER), nmar WRITE (7, '(5X,13A5)') (FR(J),J=1,ITER), 'Total',' %' WRITE (*, '(5X,13A5)') (FR(J),J=1,ITER), 'Total',' %' CTD0 DIMENSIONED KLEV+120 ILL=31 IF (KLEV.LT.ILL) ILL=KLEV C DO LL=21,21+KLEV C IF (LL.LT.NMAR+120) TD0(LL)=0 C ENDDO IIPER=0 C ITER < 11 - FOR EACH LEVEL LL rs1=0 rc1=0 rs2=0 rc2=0 DO I=1,iter DO J=1,iter FRQ( I,11)=FRQ( I,11)+FRQ(I,J) FRQ(11, J)=FRQ(11, J)+FRQ(I,J) ITOT =ITOT +FRQ(I,J) if (j.lt.i) rc1=rc1+FRQ(I,J)+FRQ(J,I) if (j.eq.i) rc1=rc1+FRQ(i,j) if (j.lt.i) ks(i)=ks(i)+FRQ(I,J)+FRQ(J,I) if (j.eq.i) ke(i)=ke(i)+FRQ(i,j) FRP( I,11)=FRP( I,11)+FRP(I,J) FRP(11, J)=FRP(11, J)+FRP(I,J) ITOT =ITOT +FRP(I,J) if (j.lt.i) rc2=rc2+FRP(I,J)+FRP(J,I) if (j.eq.i) rc2=rc2+FRP(i,j) if (j.lt.i) ks(i)=ks(i)+FRP(I,J)+FRP(J,I) if (j.eq.i) ke(i)=ke(i)+FRP(i,j) ENDDO rs1=rs1+frq(I,11)! rs1 cum row sums rsum(i)=rs1 ! rs1 keeps growing !! good! rcsum(i)=rc1 ! rc1 keeps growing cum upper left corner rs2=rs2+frp(I,11)! rs2 cum row sums rsum(i)=rs2 ! rs2 keeps growing !! good! rcsum(i)=rc2 ! rc2 keeps growing cum upper left corner ENDDO if (itot.le.0) then WRITE (*,*) ' (NO BLOOD MARRIAGES TO ANALYZE!' else cs=0 DO J=1,iter cs=cs+frq(11,j) ! cs cum col sums csum(j)=cs ! cs keeps growing ENDDO DO LL=1,ITER C DO L=1,IL C TD0(L)=0 C ENDDO C TD0(11)=0 C DO I=1,NMAR CIP IS THE LEVEL FROM 0 to KLEV (1 TO ITER) C IP=PERCENT (I,LL) C IF (IP.GT.0.AND.IP.LE.ITER) THEN C TD0(IP)=TD0(IP)+1 C TD0(IP+20)=TD0(IP+20)+1 C TD0(11)=TD0(11)+1 C ITOT = ITOT + 1 C ENDIF C ENDDO XT=0 C IF (NMAR.GT.0) XT=100*TD0(11)/NMAR IF (ITOT.GT.0) XT=100*(real(FRQ(LL,11))/real(itot)) IPER=INT(XT+.5) IIPER=IIPER+IPER C WRITE (7, '(13I5)') LL , (TD0(J),J=1,ITER), TD0(11), IPER C WRITE (*, '(13I5)') LL , (TD0(J),J=1,ITER), TD0(11), IPER WRITE (7, '(13I5)') LL , (FRQ(LL,J),J=1,ITER), FRQ(LL,11), IPER WRITE (*, '(13I5)') LL , (FRQ(LL,J),J=1,ITER), FRQ(LL,11), IPER ENDDO C WRITE (7, '(A5,13I5)') ' Tot ', (TD0(J),J=21,20+ITER),ITOT, IIPER C WRITE (*, '(A5,13I5)') ' Tot ', (TD0(J),J=21,20+ITER),ITOT, IIPER WRITE (7, '(A5,13I5)') ' Tot ', (FRQ(11,J),J=1,ITER),ITOT, IIPER WRITE (*, '(A5,13I5)') ' Tot ', (FRQ(11,J),J=1,ITER),ITOT, IIPER C DO J=21,20+KLEV C XT=0 C IF (NMAR.GT.0) XT=100*TD0(J)/NMAR C TD0(J)=INT(XT) C ENDDO DO J=1,KLEV XT=0 IF (ITOT.GT.0) XT=100*(real(FRQ(11,J))/real(itot)) FRQ(11,J)=INT(XT+.5) ENDDO XT=0 C IF (NMAR.GT.0) XT=100*ITOT/itot C IPER=INT(XT) IPER=100 C WRITE (7, '(A5,13I5)') ' % ', (TD0(J),J=21,20+ITER), IPER, IPER WRITE (7, '(A5,13I5)') ' % ', (FRQ(11,J),J=1,ITER), IPER, IPER WRITE (7, '(A)') ' ' C WRITE (*, '(A5,13I5)') ' % ', (TD0(J),J=21,20+ITER), IPER, IPER WRITE (*, '(A5,13I5)') ' % ', (FRQ(11,J),J=1,ITER), IPER, IPER WRITE (*, '(A)') ' ' ENDIF ! KTOT>0 ibex=0 imax=1 if (kden.gt.0) then DO I=1,iter if (100*rcsum(i)/kden.le.5) imax=i if (100*rcsum(i)/kden.le.10) jmax=i ENDDO ibex=0 icex=0 if (kden.gt.0.and.imax.gt.0.and.imax.le.11) then ibex=int(100*(kden-rcsum(imax))/kden) endif if (kden.gt.0.and.jmax.gt.0.and.jmax.le.11) then icex=int(100*(kden-rcsum(jmax))/kden) endif endif ipex=9999 imex=9999 ip=99 im=99 write (*,'(a)') ' Question 1: are there patterns of exogamy?' write (7,'(a)') ' Question 1: are there patterns of exogamy?' write (*,'(I4,a,i1,a)') ibex,'% bilateral exogamy of degree ',imax write (7,'(I4,a,i1,a)') ibex,'% bilateral exogamy of degree ',imax write (*,'(2(I4,a))') rcsum(imax), ' exceptions over', + kden,' endogamous marriages' write (7,'(2(I4,a))') rcsum(imax), ' exceptions over', + kden,' endogamous marriages' if (jmax.gt.imax) then write (*,'(I4,a,i1,a)') icex,'% bilateral exogamy of degree ',jmax write (7,'(I4,a,i1,a)') icex,'% bilateral exogamy of degree ',jmax write (*,'(2(I4,a))') rcsum(jmax), ' exceptions over', + kden,' endogamous marriages' write (7,'(2(I4,a))') rcsum(jmax), ' exceptions over', + kden,' endogamous marriages' endif C write (*,'(I4,a,i1,a)') ipex, '% patri- exogamy of degree ',ip C write (7,'(I4,a,i1,a)') ipex, '% patri- exogamy of degree ',ip C write (*,'(I4,a,i1,a)') imex, '% matri- exogamy of degree ',im C write (7,'(I4,a,i1,a)') imex, '% matri- exogamy of degree ',im write (*,'(a)') ' __% patri- exogamy of degree _ (compute by h +and from qn3 data below)' write (7,'(a)') ' __% patri- exogamy of degree _ (compute by hand +and from qn3 data below)' write (*,'(a)') ' __% matri- exogamy of degree _ (compute by hand +and from qn3 data below)' write (7,'(a)') ' __% matri- exogamy of degree _ (compute by hand +and from qn3 data below)' CWRITE LINKS TABLE maxi=0 maxj=0 DO I=1,20 DO J=1,20 if (sumxy (I,J).gt.0.and.i.gt.maxi) maxi=i if (sumxy (I,J).gt.0.and.j.gt.maxj) maxj=j ENDDO ENDDO DO I=1,maxi+1 ! for each row FRQ(I,11)=0 ENDDO DO J=1,maxj csum(j)=0 FRQ(11,J)=0 ENDDO DO I=1,maxi ! rows of links table DO J=1,maxj ! cols of links table FRQ(I,11)=FRQ(I,11)+SUMxy (i,J) ! row sums FRQ(11,J)=FRQ(11,J)+SUMxy (i,J) ! col sums ENDDO ENDDO write (*,*) write (7,*) write (*,'(a)') ' Press Enter/Return to continue' read (*,'(a)') ans write (*,'(a)') ' Question 2: Are blood marriages generationally s +kewed within various degrees?' write (7,'(a)') ' Question 2: Are blood marriages generationally s +kewed within various degrees?' write (*,*) write (7,*) write (*,'(a)') ' degree : percent skewed' write (7,'(a)') ' degree : percent skewed' do i=2,iter ipp=0 if (ks(i)+ke(i).gt.0) ipp=ks(i)*100/(ks(i)+ke(i)) write (*, '(i10,a,I10,a)') i, ':', ipp, '%' write (7, '(i10,a,I10,a)') i, ':', ipp, '%' enddo write (*,*) write (7,*) write (*,'(a)') ' Press Enter/Return to continue' read (*,'(a)') ans write (*,'(a)') ' Question 3: In blood marriages, are there linkin +g relatives of certain sex or', +' generation? (F,M = ancestral Fa/Mo certain generations back)' write (7,'(a)') ' Question 3: In blood marriages, are there linkin +g relatives of certain sex or', +' generation? (F,M = ancestral Fa/Mo certain generations back)' write (*,*) write (7,*) write (*,'(a)') ' frequency of linking relative on th +e husbands side by gender' write (*,'(a)') ' F vs M F vs M F vs M F vs M + F vs M F vs M F vs M' write (*,'(a)') ' at various' write (*,'(a)') ' generations 1 2 3 4 + 5 6 7' write (*,'(a)') ' removal for' write (*,'(a,7(i5,i4))') ' RELATIVES ', ((fq7(i,j),j=1,2),i=1,7) write (*,'(a)') ' versus blood' write (*,'(a,7(i5,i4))') ' MARRIAGES ', ((fq8(i,j),j=1,2),i=1,7) write (*,'(a\)') ' GAMMA= ' write (7,'(a)') ' frequency of linking relative on th +e husbands side by gender' write (7,'(a)') ' F vs M F vs M F vs M F vs M + F vs M F vs M F vs M' write (7,'(a)') ' at various' write (7,'(a)') ' generations 1 2 3 4 + 5 6 7' write (7,'(a)') ' removal for' write (7,'(a,7(i5,i4))') ' RELATIVES ', ((fq7(i,j),j=1,2),i=1,7) write (7,'(a)') ' versus blood' write (7,'(a,7(i5,i4))') ' MARRIAGES ', ((fq8(i,j),j=1,2),i=1,7) write (7,'(a\)') ' GAMMA= ' do i=1,7 a1=fq8(i,1) b1=fq8(i,2) c1=fq7(i,1) d1=fq7(i,2) denom = a1*d1 + b1*c1 if (denom.gt.0) then write (*,'(F9.3\)') -(a1*d1-b1*c1)/denom write (7,'(F9.3\)') -(a1*d1-b1*c1)/denom else x=0 write (*,'(F9.3\)') X write (7,'(F9.3\)') X endif enddo write (*,'(A,/)') ' ' write (7,'(A,/)') ' ' write (*,'(a)') ' frequency of linking relative on th +e wifes side by gender' write (7,'(a)') ' frequency of linking relative on th +e wifes side by gender' write (*,'(a)') ' removal for' write (*,'(a,7(i5,i4))') ' RELATIVES ', ((fq5(i,j),j=1,2),i=1,7) write (*,'(a)') ' versus blood' write (*,'(a,7(i5,i4))') ' MARRIAGES ', ((fq6(i,j),j=1,2),i=1,7) write (*,'(a\)') ' GAMMA= ' write (7,'(a)') ' removal for' write (7,'(a,7(i5,i4))') ' RELATIVES ', ((fq5(i,j),j=1,2),i=1,7) write (7,'(a)') ' versus blood' write (7,'(a,7(i5,i4))') ' MARRIAGES ', ((fq6(i,j),j=1,2),i=1,7) write (7,'(a\)') ' GAMMA= ' do i=1,7 a1=fq6(i,1) b1=fq6(i,2) c1=fq5(i,1) d1=fq5(i,2) denom = a1*d1 + b1*c1 if (denom.gt.0) then write (*,'(F9.3\)') -(a1*d1-b1*c1)/denom write (7,'(F9.3\)') -(a1*d1-b1*c1)/denom else x=0 write (*,'(F9.3\)') X write (7,'(F9.3\)') X endif enddo write (*,'(A,/)') ' ' write (7,'(A,/)') ' ' write (*,'(A)') ' (+) gamma female link more likely for spouse tha +n for relative' write (*,'(A)') ' (-) gamma male link more likely for spouse tha +n for relative' write (7,'(A)') ' (+) gamma female link more likely for spouse tha +n for relative' write (7,'(A)') ' (-) gamma male link more likely for spouse tha +n for relative' write (*,'(A)') ' ' write (7,'(A)') ' ' c frequency of linking relative on the husbands side by gender c F vs M F vs M F vs M F vs M F vs M F vs M F vs M Cat various Cgenerations 1 2 3 4 5 6 7 Cremoval for CRELATIVES 333 333 333 333 Cversus blood CMARRIAGES CGAMMA write (*,*) write (7,*) write (*,'(a)') ' number of male links (counting ego):' write (*,'(a/,a,I4,19i5)') ' female',' links', (J-1,J=2,maxj+1) write (7,'(a)') ' number of male links:' write (7,'(a/,a,I4,19i5)') ' female',' links', (J-1,J=2,maxj+1) DO I=1,maxi write (*,'(21i5)') i , (sumxy (I,J), J=1,maxj), frq(I,11) write (7,'(21i5)') i , (sumxy (I,J), J=1,maxj), frq(I,11) ENDDO WRITE (7, '(A5,13I5)') ' Tot ', (FRQ(11,J),J=1,MAXJ) WRITE (*, '(A5,13I5)') ' Tot ', (FRQ(11,J),J=1,MAXJ) write (*,*) write (7,*) write (*,'(a)') ' Press Enter/Return to continue' read (*,'(a)') ans write (*,'(a)') ' Question 4: Is there evidence of dual organizati +on',' (sidedness) in the marriages?' write (7,'(a)') ' Question 4: Is there evidence of dual organization +on',' (sidedness) in the marriages?' write (*,*) write (7,*) IF (MOIETYP.EQ.1) then WRITE (7, *) ' Viri-Sided (Dravidian) Blood Marriages (100%)' WRITE (*, *) ' Viri-Sided (Dravidian) Blood Marriages (100%)' ELSE ix=int(100*real(nmp)/(real(notp+nmp))) WRITE (7,'(i4,2i3,A)') NMP, NOTP+NMP, ix , +'% (Dravidian) Viri-Sided Blood Marriages ' WRITE (*,'(i4,2i3,A)') NMP, NOTP+NMP, ix , +'% (Dravidian) Viri-Sided Blood Marriages ' ENDIF IF (MOIETYM.EQ.1) THEN WRITE (7, *) ' UxoriSided (Dravidian) Blood Marriages (100%)' WRITE (*, *) ' UxoriSided (Dravidian) Blood Marriages (100%)' ELSE ix=int(100*real(nmm)/(real(notm+nmm))) WRITE (7,'(i4,2i3,A)') NMM, NOTm+NMm, ix , +'% (Dravidian) Uxori-Sided Blood Marriages ' WRITE (*,'(i4,2i3,A)') NMM, NOTm+NMm, ix , +'% (Dravidian) Uxori-Sided Blood Marriages ' ENDIF write (*,*) write (7,*) write (*,'(a)') ' Press Enter/Return to continue' read (*,'(a)') ans write (*,'(a)') ' Question 5: Is there a pattern of marriage with +Iroquois-cross relatives?', ' that is, where the linking parents o +f the bride and groom are opposite sex?' write (7,'(a)') ' Question 5: Is there a pattern of marriage with +Iroquois-cross relatives?', ' that is, where the linking parents o +f the bride and groom are opposite sex?' write (*,*) write (7,*) write (*,*) ' In terms of Iroquois (not Dravidian) crossness:' write (7,*) ' In terms of Iroquois (not Dravidian) crossness:' icp=0 if (icp0+icp1.gt.0) ICP=(100*ICP1)/(ICP0+ICP1) write (*,'(i4,a)') ICP, '% of blood marriages are patri-cross (Fa +of husband related to Mo of wife)' write (7,'(i4,a)') ICP, '% of blood marriages are patri-cross (Fa +of husband related to Mo of wife)' icm=0 if (icm0+icm1.gt.0) ICM=(100*ICM1)/(ICM0+ICM1) write (*,'(i4,a)') ICM, '% of blood marriages are matri-cross (Mo +of husband related to Fa of wife)' write (7,'(i4,a)') ICM, '% of blood marriages are matri-cross (Mo +of husband related to Fa of wife)' write (*,*) write (7,*) write (*,'(a)') ' Press Enter/Return to continue' read (*,'(a)') ans write (7,'(a)') ' Question 6: What are the particular types and fr +equencies of blood marriage', +' compared to relatives not married?' write (*,*) write (7,*) write (7,'(A,A)') ' Kinship Kin X ', +' P M Poss Per- List of ' write (7,'(A,A)') ' Equations Types # ', +' #F#G Gn Frq ible cent Couples' CLOSE (7) DEallOCATE ( F,G,ID, STAT = error ) IF( error .NE. 0 ) WRITE (*, '(A)') ' Deallocation error 1' DEallOCATE ( ID2,NB,TD, STAT = error ) IF( error .NE. 0 ) WRITE (*, '(A)') ' Deallocation error 2' DEallOCATE ( MN,TROLD,FC,GC, STAT = error ) IF( error .NE. 0 ) WRITE (*, '(A)') ' Deallocation error 3' DEallOCATE ( TD2, STAT = error ) IF( error .NE. 0 ) WRITE (*, '(A)') ' Deallocation error 11 ' DEallOCATE ( GTREE, STAT = error ) IF( error .NE. 0 ) WRITE (*, '(A)') ' Deallocation error 12' DEallOCATE ( FTREE, STAT = error ) IF( error .NE. 0 ) WRITE (*, '(A)') ' Deallocation error 13' IK = SYSTEMQQ ( 'COPY SCRATCH+P-FREQS.SRT P-XXX.FRQ'C ) IF( IK .EQ. -1 ) STOP 'Could not run COMMAND.COM' C IK = SYSTEMQQ ( 'DEL P-FREQS.SRT'C ) IF( IK .EQ. -1 ) STOP 'Could not run COMMAND.COM' C pause 2 pause " press Enter/Return (or to see scratch files hit control & *pause-break)" write (*,'(a)') ' Question 6: What are the particular types and fr +equencies of blood marriage', +' compared to relatives not married? (see data file)' C IK = SYSTEMQQ ( 'DEL SCRATCH'C) IF( IK .EQ. -1 ) STOP 'Could not run COMMAND.COM' write (*,*) ' (note: to run par-comp comparison tests of actual an +d simulated data' write (*,*) ' Copy scratch2 to p-actual or ' write (*,*) ' Copy scratch2 to p-simul depending on which you are +running) ' write (*,*) C IK = SYSTEMQQ ( 'DEL SCRATCH2'C ) C IF( IK .EQ. -1 ) STOP 'Could not run COMMAND.COM' C DEBUG GRAPH C IK = SYSTEMQQ ( 'PAIRPATH'C ) C IF( IK .EQ. -1 ) STOP 'Could not run COMMAND.COM' IK = SYSTEMQQ ( 'COPY EX.RAW EX.DAT'C ) IF( IK .EQ. -1 ) STOP 'Could not run COMMAND.COM' C IK = SYSTEMQQ ( 'PROFILE'C ) C IF( IK .EQ. -1 ) STOP 'Could not run COMMAND.COM' C IK = SYSTEMQQ ( 'REDUCE'C ) C IF( IK .EQ. -1 ) STOP 'Could not run COMMAND.COM' C IK = SYSTEMQQ ( 'COPY EX.NRD EX.RED'C ) C IF( IK .EQ. -1 ) STOP 'Could not run COMMAND.COM' C IK = SYSTEMQQ ( 'KINLAT'C ) C IF( IK .EQ. -1 ) STOP 'Could not run COMMAND.COM' ENDIF ! WRITE (*,*) ' (NO BLOOD MARRIAGES TO ANALYZE!' CLOSE (4) FILEE='P-PARAM' CP-param file CALL READONLY (FILEE, ISW, 4) WRITE (4, '(5I6)') NUMG, LENG, NUMF, LENF, NMAR IF (MOIETYP.EQ.1.AND.KTOT.GT.0) +WRITE (*, *) ' Could be Viri-Sided System' IF (MOIETYM.EQ.1.AND.KTOT.GT.0) +WRITE (*, *) ' Could be Uxorisided System' write (*,'(I4,a,I4,a)') ktot, ' blood marriages ', + int(100*real(ktot)/real(nmar)), '%' DO i=1,9 CLOSE (i) ENDDO Cdeallocate DEallOCATE ( F, G, ID, ID2, NB, MN, STAT = error ) IF( error .NE. 0 ) WRITE (*, '(A)') ' Deallocation error 99' write (*,*) NMAR ALLOCATE( BK (2* NMAR ), STAT = error ) IF( error .NE. 0 ) WRITE (*, '(A)') ' Allocation error nmar*2 ' ALLOCATE( F ( NMAR ), G ( NMAR ), ID( NMAR ), STAT = error ) IF( error .NE. 0 ) WRITE (*, '(A)') ' Allocation error nmar 1*' ALLOCATE( ID2( NMAR ), NB( NMAR ), MN( NMAR ), STAT = error ) IF( error .NE. 0 ) WRITE (*, '(A)') ' Allocation error nmar 2*' call par_cull (F, G, ID, ID2, BK, MN, NB, xxt, nmar, anss) WRITE (*, *) ' Blood Marriage Core on P-XXX.VEB' WRITE (*, *) ' Blood Marriage Freqs on P-XXX.FRQ' END subroutine getfile (ext, extension, fileused, numbr, isw, *, + idjust, xxt) CHARACTER*14 FILEUSED, FILEE CHARACTER*3 EXTENSION (300), EXT, xxt CHARACTER*2 STP INTEGER*2 SYSTEMQQ filee='files' CALL READONLY (filee, isw, 4) CLOSE (4) IF (ISW.EQ.1) THEN if (ext.eq.'sli') + IK = SYSTEMQQ ( 'DIR P-???-1.crd >a:files'C ) if (ext.eq.'slm') + IK = SYSTEMQQ ( 'DIR P-???-1.crm >a:files'C ) if (ext.eq.'vem') + IK = SYSTEMQQ ( 'DIR P-*.vem >a:files'C ) if (ext.eq.'vec'.or.ext.eq.'VEC') + IK = SYSTEMQQ ( 'DIR P-*.vec >a:files'C ) if (ext.eq.'dem'.OR.ext.eq.'DEM') + IK = SYSTEMQQ ( 'DIR P-*.dem >a:files'C ) IK = SYSTEMQQ ( 'sortf a:files a:filesort'C ) OPEN (4, file='a:filesort') ELSE if (ext.eq.'sli') + IK = SYSTEMQQ ( 'DIR P-???-1.crd >files'C ) if (ext.eq.'slm') + IK = SYSTEMQQ ( 'DIR P-???-1.crm >files'C ) if (ext.eq.'VED') + IK = SYSTEMQQ ( 'DIR P-*.ved >files'C ) if (ext.eq.'VEC') + IK = SYSTEMQQ ( 'DIR P-*.vec >files'C ) if (ext.eq.'VES') + IK = SYSTEMQQ ( 'DIR P-*.ves >files'C ) if (ext.eq.'VEM') + IK = SYSTEMQQ ( 'DIR P-*.vem >files'C ) if (ext.eq.'dem'.OR.ext.eq.'DEM') + IK = SYSTEMQQ ( 'DIR P-*.dem >files'C ) IK = SYSTEMQQ ( 'sortf files filesort'C ) OPEN (4, file='filesort') ENDIF if (ext.eq.'sli') ext='vec' if (ext.eq.'slm') ext='vem' WRITE (*, *) ' ' KOUNT=0 DO I=1,300 READ (4,'(39x,A2,A3,4x,A3)',END=41) STP, EXTENSION (I) write (*,*) STP, EXTENSION (I) C 0 Dir(s) 3,544,555,520 bytes free C 2 File(s) 16,400 bytes CDirectory of D:\FTP\Denham\Genea\par CVolume Serial Number is 1860-10FB CVolume in drive D has no label. C2/16/2001 04:40a 8,559 p-yyy.ved C2/16/2001 04:40a 7,841 p-aly.veD C23456789012345678901234567890123456789 C 441344 bytes free C 3 file(s) 13512 bytes CDirectory of B:\ CVolume in drive B is TEDSCUDDER CVolume Serial Number is 1C1D-10D0 idjust=7 CP-CAN-1 CRD 1246 11-25-92 8:55a CP-MAZ-1 CRD 6268 10-05-92 1:32p CP-MUS-1 CRD 5998 12-12-92 12:38p I=10 C I=11 if (STP(1:1).eq.'p') STP(1:1)='P' IF (I.LT.10.AND.STP.NE.'P-') idjust=I IF (I.GT.idjust.AND.STP.EQ.'P-') + WRITE (*, '(i4, 1x, A3,6x\)') I-idjust, EXTENSION (I) KOUNT=KOUNT+1 IF (I.GT.idjust. AND .KOUNT.EQ.idjust) THEN KOUNT=0 WRITE (*, *) ' ' ENDIF ENDDO 41 NFILES=I-idjust-1 WRITE (*, '(i4,A)') NFILES+1, 'MENU' CLOSE (4) 42 if (ext.eq.'vec') THEN WRITE (*,'(/A\)') + ' Which P-_?_.VEC data file to use (Number: then )? ' ENDIF if (ext.eq.'vem') THEN WRITE (*,'(/A\)') + ' Which P-_?_.VEM models file to use (Number: then )? ' ENDIF if (ext.eq.'dem') WRITE (*,'(/A\)') +' Which P-_?_.DEM file to use ? ' READ (*,'(I4)',err=42) NUMBR IF (numbr.eq.nfiles+1) THEN numbr=0 RETURN1 ENDIF if (numbr.lt.1.or.numbr.gt.nfiles) goto 42 FILEUSED(1:6)='P-EXT.' FILEUSED(7:9)=EXT FILEUSED(3:5)=EXTENSION (NUMBR+idjust) XXT=EXTENSION (NUMBR+idjust) end