OiU_3 fourth version

module OiU3
    integer, parameter :: ASCII_const = 48
    contains
    !
    subroutine numbers(array, n, y)
        integer :: n, i, y
        integer :: array(n)
        write (0,fmt = '(a4$)') '| \ '
        do i = 1,n,1
            if (i==y) then
                write (0, fmt = '(a$)') '| '
                write (0, fmt='(a$)') achar(27)//'[4m'//achar(27)//'[91m'//&
                achar(ASCII_const + array(i))//':'//achar(27)//'[0m'
            else
                write (0, fmt = '(a,i3$)') '|', array(i)
            end if
            !write (0,fmt='(i2$)') array(i)
        end do
        write (0,fmt = '(a1)') '|'
    end subroutine
    !
    subroutine cap(n)
        integer :: n, i
        do i =1,n
            write (0,fmt = '(a$)') '+---'
        end do
        write (0,fmt = '(a)') '+'
    end subroutine
    !
    subroutine write_array(stolbec_count,array,n)
        integer :: n, i
        integer :: array(n), stolbec_count(n)
        write (0,*)
        call cap(n+1)
        call numbers(stolbec_count,n,0)
        call cap(n+1)
        write (0,fmt = '(a$)') '| / '
        do i = 1,n
            write (0,fmt = '(a,i3$)') '|', array(i)
        end do
        write (0,fmt = '(a)') '|'
        call cap(n+1)
        write (0,*)
    end subroutine
    !
    subroutine write_matrix(matrix, stroka_count, stolbec_count, n, x, y)
        integer :: n, x, y, k, l
        integer :: matrix(n,n), stolbec_count(n), stroka_count(n)
        !
        call execute_command_line('')
        write (0,*)
        call cap(n+1)
        call numbers(stolbec_count,n,y)
        do k = 1,n
            call cap(n+1)
            if (k==x) then
                write (0, fmt='(a$)') '| '
                write (0, fmt='(a$)') achar(27)//'[4m'//achar(27)//'[91m'&
                //achar( ASCII_const + stroka_count(k) )//':'//achar(27)//'[0m'
            else
                write (0, fmt='(a,i2,a$)') '|', stroka_count(k), ':'
            end if
            do l = 1,n
                if ( matrix(k,l)>10000 ) then
                    if (k==x .or. l==y) then
                        write (0,fmt = '(a$)') '|'
                        write (0,fmt = '(a$)') achar(27)//'[4m'//achar(27)//'[91m'//'inf'//achar(27)//'[0m'
                    else
                        write (0, fmt = '(a$)') '|inf'
                    end if
                else
                    if (k==x .or. l==y) then
                        write (0,fmt='(a$)') '|'
                        write (0,fmt = '(1x,a$)') achar(27)//'[4m'//achar(27)//'[91m'//&
                        achar(ASCII_const + (matrix(k,l)/10) )//&
                        achar(ASCII_const + (matrix(k,l)-matrix(k,l)/10*10))//achar(27)//'[0m'
                    else
                        write (0,fmt='(a,i3$)') '|',matrix(k,l)
                    end if
                end if
            end do
            write (0,fmt='(a)') '|'
        end do
        call cap(n+1)
        write (0,*)
    end subroutine
    !
    integer function minimum(array,n) result(res_index)
        integer :: n, i
        integer :: array(n)
        res_index = 1
        do i =1,n,1
            if( array(i)<array(res_index) ) then
                res_index = i
            end if
        end do
    end function
    !
    subroutine min_stroka(matrix,n,stroka_min)
        integer :: n, i
        integer :: matrix(n,n), stroka_min(n),temp_array(n)
        do i =1,n
            temp_array = matrix(i,:)
            stroka_min(i) = matrix(i, minimum(temp_array,n))
        end do
    end subroutine
    !
    subroutine min_stolbec(matrix,n,stolbec_min)
        integer :: n, i
        integer :: matrix(n,n), stolbec_min(n),temp_array(n)
        do i =1,n
            temp_array = matrix(:,i)
            stolbec_min(i) = matrix(minimum(temp_array,n), i)
        end do
    end subroutine
    !
    subroutine transform(matrix, n, summa)
        integer :: n,i, summa_1, summa_2, summa
        integer :: matrix(n,n), temp_matrix(n,n), stroka_min(n), stolbec_min(n)
        ! 1 sequence of actions
        temp_matrix = matrix
        !
        call min_stroka(temp_matrix,n,stroka_min)
        !write (0,fmt = '(a$)') 'Massiv strok: '
        do i = 1,n
            temp_matrix(i,:) = temp_matrix(i,:) - stroka_min(i)
        end do
        call min_stolbec(temp_matrix,n,stolbec_min)
        do i = 1,n
            temp_matrix(:,i) = temp_matrix(:,i) - stolbec_min(i)
        end do
        !write (0,fmt = '(a$)') 'Massiv stolbcov: '
        summa_1 = sum(stroka_min) + sum(stolbec_min)
        ! 2 sequence of actions
        temp_matrix = matrix
        !
        call min_stolbec(temp_matrix,n,stolbec_min)
        do i = 1,n
            temp_matrix(:,i) = temp_matrix(:,i) - stolbec_min(i)
        end do
        !write (0,fmt = '(a$)') 'Massiv stolbcov: '
        call min_stroka(temp_matrix,n,stroka_min)
        do i = 1,n
            temp_matrix(i,:) = temp_matrix(i,:) - stroka_min(i)
        end do
        !write (0,fmt = '(a$)') 'Massiv strok: '
        summa_2 = sum(stroka_min) + sum(stolbec_min)
        !
        write (0,fmt = '(a,i3)') 'Sum when stroki first then stolbcy:',summa_1
        write (0,fmt = '(a,i3)') 'Sum when stolbcy first then stroki:',summa_2
        if (summa_1>summa_2) then
            summa = summa_1
            !do i =1,n
                !temp_array = matrix(i,:)
                !stroka_min(i) = matrix(i, minimum(temp_array,n))
            !end do
            call min_stroka(matrix,n,stroka_min)
            do i = 1,n
                matrix(i,:) = matrix(i,:) - stroka_min(i)
            end do
            call min_stolbec(matrix,n,stolbec_min)
            do i = 1,n
                matrix(:,i) = matrix(:,i) - stolbec_min(i)
            end do
        else
            summa = summa_2
            call min_stolbec(matrix,n,stolbec_min)
            do i = 1,n
                matrix(:,i) = matrix(:,i) - stolbec_min(i)
            end do
            call min_stroka(matrix,n,stroka_min)
            do i = 1,n
                matrix(i,:) = matrix(i,:) - stroka_min(i)
            end do
        end if
    end subroutine
    !
    integer function summ_of_minimums_in_zero(matrix,n,i,j)
        integer :: i,j,n
        integer :: matrix(n,n), stroka_min(n), stolbec_min(n)
        integer :: copy(n,n)
        copy = matrix
        copy(i,j) = 100000
        call min_stroka(copy,n,stroka_min)
        call min_stolbec(copy,n,stolbec_min)
        summ_of_minimums_in_zero = stroka_min(i) + stolbec_min(j)
    end function
    !
    subroutine zero_choose(matrix,n,k,l)
        integer :: i,j,n,k,l
        integer :: matrix(n,n)
        do i =n,1,-1
            do j =n,1,-1
                if (matrix(i,j)==0) then
                    k = i
                    l = j
                end if
            end do
        end do
        do i =n,1,-1
            do j =n,1,-1
                if (matrix(i,j)==0) then
                    if ( summ_of_minimums_in_zero(matrix,n,i,j) > summ_of_minimums_in_zero(matrix,n,k,l) )  then
                        k = i
                        l = j
                    end if
                end if
            end do
        end do
    end subroutine
    !
    subroutine matrix_rewrite(matrix_1,matrix_2,n,k,l)
        integer :: n,k,l,i,j,x,y
        integer :: matrix_1(n,n), matrix_2(n-1,n-1)
        do i =1,n-1
            do j = 1,n-1
                x = i
                y = j
                if (x >= k) then
                    x = x + 1
                end if
                if (y >= l) then
                    y = y + 1
                end if
                matrix_2(i,j) = matrix_1(x,y)
            end do
        end do
    end subroutine
    !
    subroutine array_rewrite(array_1,array_2,n,m)
        integer :: n,m,i,temp
        integer :: array_1(n), array_2(n-1)
        do i = 1,n-1
            temp = i
            if (temp >= m) then
                temp = temp + 1
            end if
            array_2(i) = array_1(temp)
        end do
    end subroutine
    !
    subroutine add_infinity(matrix,n)
        integer :: n, i, j, x, y
        integer :: matrix(n,n)
        k = 0
        l = 0
        do i = 1, n
            j = 1
            do while ((j <= n) .and. (matrix(i, j)  <= 10000))
                if (j == n) then
                    x = i
                end if
                j = j + 1
            end do
        end do
        do j = 1, n
            i = 1
            do while ((i <= n) .and. (matrix(i, j)  <= 10000))
                if (i == n) then
                    y = j
                end if
                i = i + 1
            end do
        end do
        matrix(x,y) = 100000
    end subroutine
end module
!
!
!
!
!
!
program main
    use OiU3
    implicit none
    integer :: k, l, summa, n, j, valuation
    integer, allocatable :: c(:,:), temp(:,:),roads(:,:),temp_2(:,:)
    integer, allocatable :: stolbec_count(:), stroka_count(:), stolbec_count_temp(:), stroka_count_temp(:)
    integer :: i
    !read (*,*) n
    call execute_command_line('')
    n = 7
    summa = 0
    valuation = 0
    allocate(c(n,n))
    allocate(temp(n,n))
    allocate(temp_2(n,n))
    allocate(roads(1:2,n))
    allocate(stolbec_count(n))
    allocate(stroka_count(n))
    allocate(stolbec_count_temp(n))
    allocate(stroka_count_temp(n))
    roads(:,:) = -1
    stolbec_count_temp = [(k, k =1,n)]
    stroka_count_temp = [(k, k =1,n)]
    stolbec_count = stolbec_count_temp
    stroka_count = stroka_count_temp
    write (0,fmt = '(a$)') 'Enter your i: '
    read (*,*) i
    do k = 1,n
        do l = 1,n
            if (k == l) then
                c(k,l) = 100000
            else if ( mod( (i + 3*k + 5*l), 17) == 0 ) then
                c(k,l) = 17
            else
                c(k,l) = mod( (i + 3*k + 5*l), 17)
            end if
        end do
    end do
    !stolbec_count = stolbec_count_temp
    !stroka_count = stroka_count_temp
    !stolbec_count(3) = 0
    temp_2 = c
    write (0,fmt='(a,i2)') 'Road 1 to 2: ',c(1,2)
    write (0, fmt='(a$)') achar(27)//'[96m'//'First matrix:'//achar(27)//'[0m'
    call write_matrix(c,stroka_count,stolbec_count,n,0,0)
    write (0, fmt='(a)') achar(27)//'[96m'//'Enter the cycle: '//achar(27)//'[0m'
    do j = n,2,-1
        write (0, fmt='(/a/)') achar(27)//'[96m'//achar(ASCII_const + (n-j+1) )//achar(27)//'[0m'
        deallocate(stolbec_count)
        deallocate(stroka_count)
        allocate(stolbec_count(j))
        allocate(stroka_count(j))
        stolbec_count = stolbec_count_temp
        stroka_count = stroka_count_temp
        deallocate(stolbec_count_temp)
        deallocate(stroka_count_temp)
        allocate(stolbec_count_temp(j-1))
        allocate(stroka_count_temp(j-1))
        !
        deallocate(temp)
        allocate(temp(j,j))
        temp = temp_2
        deallocate(temp_2)
        allocate(temp_2(j-1,j-1))
        !
        call transform(temp, j, summa)
        !
        !
        write (0,fmt = '(//////i2///////)') summa
        valuation = valuation + summa
        !
        !
        write (0, fmt='(/a)') achar(27)//'[96m'//'Write after transform:'//achar(27)//'[0m'
        call write_matrix(temp, stroka_count, stolbec_count, j, 0, 0)
        write (0,fmt = '(a,i3)') 'Then we choose better summa:', summa
        call zero_choose(temp,j,k,l)
        !
        roads(1,(n-j+1) ) = stroka_count(k)
        roads(2,(n-j+1) ) = stolbec_count(l)
        !
        write (0,fmt = '(a,i1,/,a,i1,/,a,i10)') 'k:', stroka_count(k), 'l:', stolbec_count(l),&
        'Summ in this zero:', summ_of_minimums_in_zero(temp,j,k,l)
        call write_matrix(temp, stroka_count, stolbec_count, j, k, l)
        !rewrite arrays and matrix, using k, l
        write (0, fmt='(/a)') achar(27)//'[96m'//'Rewrite arrays and matrix, using k, l'//achar(27)//'[0m'
        call matrix_rewrite(temp, temp_2, j, k, l)
        call array_rewrite(stroka_count, stroka_count_temp, j, k)
        call array_rewrite(stolbec_count, stolbec_count_temp, j, l)
        call write_matrix(temp_2,stroka_count_temp,stolbec_count_temp, j-1,0,0)
        !add infinity
        write (0, fmt='(/a)') achar(27)//'[96m'//'Add infinity'//achar(27)//'[0m'
        call add_infinity(temp_2, j-1)
        call write_matrix(temp_2,stroka_count_temp,stolbec_count_temp, j-1,0,0)
        !
        !end if
    end do
    !
    roads(1,n) = stroka_count_temp(1)
    roads(2,n) = stolbec_count_temp(1)
    !
    call write_array(roads(1,:),roads(2,:),n)
    write (0,fmt = '(//////i2///////)') valuation
    !
    deallocate(c)
    deallocate(roads)
end program main