f90: Create an incidence matrix from a vector of integer codes for effects. *.exe and *.out are the Windows and Linux executables.

incidm.exe

incidm.f90

PROGRAM incidm

IMPLICIT NONE

! Declarations

INTEGER:: i, j, k, level, n, r, error
INTEGER,DIMENSION(:,:),ALLOCATABLE:: a, b
INTEGER,DIMENSION(:),ALLOCATABLE:: c
 CHARACTER(20):: infile, outfile, exiit

! Opening prints

PRINT*,
PRINT*,
PRINT*, 'This program is written by Mohammad A. Nilforooshan.'
PRINT*, 'All rights reserved.'
PRINT*, 'http://sites.google.com/site/mannprofile/'

! Ask for the input file, open and check it

PRINT*,
PRINT*,
PRINT*, 'Type the name of the input file.'
READ*, infile
OPEN(UNIT=10, FILE=infile, STATUS='OLD', IOSTAT=error)

IF (error/=0) THEN
    PRINT*,
    PRINT*,
    PRINT*, 'Error reading file.'
    STOP
END IF

! Ask for the number of elements in the file

PRINT*,
PRINT*,
PRINT*, 'Insert the number of elements.'
READ*, n

! Read the file and add a vector of row number

ALLOCATE(a(n,2))

r=0

DO i=1,n
    a(i,1)=r+1
    r=r+1
END DO

READ(10,*) (a(i,2),i=1,n)

! Sort the data by the vector of effect

ALLOCATE(c(2))

DO i=2,n
    DO k=1,2
        c(k)=a(i,k)
    END DO
    DO j=i-1,1,-1
        IF (a(j,2)<=c(2)) GO TO 70
        DO k=1,2
            a(j+1,k)=a(j,k)
        END DO
    END DO
    j=0
70  DO k=1,2
        a(j+1,k)=c(k)
    END DO
END DO

ALLOCATE(b(n,2))
b=a

! Add a vector for the deviation of effect from the previous row

DEALLOCATE(a)
ALLOCATE(a(n,3))

DO i=1,n
    DO j=1,2
        a(i,j)=b(i,j)
    END DO
END DO

a(1,3)=1

DO i=2,n
    a(i,3)=a(i,2)-a(i-1,2)
    IF (a(i,3)>0) THEN
        a(i,3)=1
    END IF
END DO

DEALLOCATE(b)
ALLOCATE(b(n,3))
b=a

! Create a new matrix with (number of effect levels) extra columns

level=SUM(a(:,3))

DEALLOCATE(a)
ALLOCATE(a(n,3+level))

DO i=1,n
    DO j=1,3+level
        IF (j>3) THEN
            a(i,j)=0
            ELSE
            a(i,j)=b(i,j)
        END IF
    END DO
END DO

! Fill the incidence matrix

j=4
a(1,j)=1

DO i=2,n
    IF (a(i,3)==0) THEN
        a(i,j)=1
        ELSE
        j=j+1
        a(i,j)=1
    END IF
END DO

! Sort the matrix by the row number

DEALLOCATE(c)
ALLOCATE(c(3+level))

DO i=2,n
    DO k=1,3+level
        c(k)=a(i,k)
    END DO
    DO j=i-1,1,-1
        IF (a(j,1)<=c(1)) GO TO 149
        DO k=1,3+level
            a(j+1,k)=a(j,k)
        END DO
    END DO
    j=0
149 DO k=1,3+level
        a(j+1,k)=c(k)
    END DO
END DO

! Ask for the name of the output file

PRINT*,
PRINT*,
PRINT*, 'Type the name of the input file.'
READ*, outfile

! Write the incidence matrix in the output file

OPEN(UNIT=11, FILE=outfile, STATUS='UNKNOWN')
DO i=1,n
    WRITE(11,*) (a(i,j), j=4,3+level)
END DO

! Finished

PRINT*,
PRINT*,
PRINT*, 'Press any key to exit.'
READ*, exiit

IF (exiit=='a') THEN
GO TO 179
END IF

179 END PROGRAM incidm

incidm.out