program lab_1_2
    use Environment


    implicit none

    integer, parameter                 :: NAME_LEN = 15, DATE_LEN = 4,&
                                          SERV_LEN = 3, REG_LEN = 1, SEX = 1
    integer, parameter                 :: len = 6

    character(kind=CH_), allocatable   :: chName(:,:), Date(:,:),&
                                          Serv(:,:), Reg(:,:), Gen(:,:)
    character(kind=CH_), allocatable  :: s(:), p(:), yes(:)
    allocate(s(1), p(1), yes(3))
    s = "S"
    p = "P"
    yes = "yes"
    allocate(chname(len, Name_len), Date(len, Date_len),&
             serv(len, serv_len), reg(len, reg_len), gen(len, sex))

    call Read_list(input, chname, date, serv, reg, gen)

    call Write_list(output, chname, date, serv, reg, gen,&
                     "list before", "rewind", len)
    call Sort_list (chname, date, serv, reg, gen)

    contains
       subroutine Read_list(input, chname, date, serv, reg, gen)
         character(*) input
         character(kind=CH_), allocatable   :: chName(:,:), Date(:,:),&
                                          Serv(:,:), Reg(:,:), Gen(:,:)
         intent(in) input
         intent(inout) chname, date, serv, reg, gen

         integer in, IO, i
         character(:), allocatable :: format

         open( file = input, encoding=E_, newunit=in)
            format = "(15A, 4A, 1X, 3A, 1X, 1A1, 1X, 1A1)"
            read(in, format) (chName(i,:), Date(i,:), Serv(i,:), Reg(i,:), Gen(i,:), i=1, 6)
         close(in)
        end subroutine Read_list

        subroutine Write_list ( output, chname, date, serv, reg, gen, comment, pos, len)
            character(*)      output, comment, pos
            character(kind=CH_)   :: chName(:,:), Date(:,:),&
                                     Serv(:,:), Reg(:,:), Gen(:,:)
            intent(in) output, comment, pos
            integer, intent(in)  :: len
            intent(inout) chname, date, serv, reg, gen
            integer        :: out, i , io
            character(:), allocatable :: format
            open(file=output, encoding=E_, position=pos, newunit=out)
               write(out, '(/a)') comment
               format = "(15A, 4A, 1X, 3A, 1X, 1A1, 1X, 1A1)"
               do i=1, len
                  write(out, format) chName(i,:), Date(i,:), Serv(i,:),&

                                         Reg(i,:), Gen(i,:)
               end do
            close(out)
         end subroutine Write_list


         subroutine Sort_list(chname, date, serv, reg, gen)
            character(kind=CH_) chname(:,:), date(:,:), serv(:,:),&
                                 reg(:,:), gen(:,:)
            character(kind=CH_), allocatable  :: cpname(:,:), cpdate(:,:),&
                                                 cpserv(:,:), cpreg(:,:),&
                                                 cpgen(:,:), tmp(:)
            logical, allocatable              :: mask(:)

            integer              i, j, amount
            integer, parameter   :: INDEXES(*) = [(i, i = 1, len)]
            integer, allocatable :: pos(:)

            mask =   ( (reg(:, 1) .eq. s(1)) .and. (serv(:, 1) .eq. yes(1)))
            amount = count(mask)
            pos = pack(INDEXES, mask)
            allocate(cpname(amount, 15), cpdate(amount, 4),&
                     cpserv(amount, 3), cpreg(amount, 1), cpgen(amount, 1))

            do concurrent (i = 1:amount)

               cpname(i, :) = chname(pos(i), :)
               cpdate(i, :) = date(pos(i), :)
               cpserv(i, :) = serv(pos(i), :)
               cpreg(i, :) = reg(pos(i), :)
               cpgen(i, :) = gen(pos(i), :)

            end do

            do i = amount, 2, -1
            do j = 1, i-1
               if(GT(cpname(j, :),cpname(j+1, :))) then
                  tmp = cpname(j+1, :)
                  cpname(j+1, :) = cpname(j, :)
                  cpname(j, :) = tmp

                  tmp =  cpdate(j+1, :)
                  cpdate(j+1, :) = cpdate(j, :)
                  cpdate(j, :) = tmp

                  tmp =  cpserv(j+1, :)
                  cpserv(j+1, :) = cpserv(j, :)
                  cpserv(j, :) = tmp

                  tmp =  cpreg(j+1, :)
                  cpreg(j+1, :) = cpreg(j, :)
                  cpreg(j, :) = tmp

                  tmp =  cpgen(j+1, :)
                  cpgen(j+1, :) = cpgen(j, :)
                  cpgen(j, :) = tmp

               end if
            end do
            end do
            mask =   ( (reg(:, 1) .eq. p(1)) .and. (serv(:, 1) .eq. yes(1)))
            amount = count(mask)
            pos = pack(INDEXES, mask)

            do concurrent (i = 1:amount)

               cpname(i, :) = chname(pos(i), :)
               cpdate(i, :) = date(pos(i), :)
               cpserv(i, :) = serv(pos(i), :)
               cpreg(i, :) = reg(pos(i), :)
               cpgen(i, :) = gen(pos(i), :)

            end do

            do i = amount, 2, -1
            do j = 1, i-1
               if(GT(cpname(j, :),cpname(j+1, :))) then
                  tmp = cpname(j+1, :)
                  cpname(j+1, :) = cpname(j, :)
                  cpname(j, :) = tmp

                  tmp =  cpdate(j+1, :)
                  cpdate(j+1, :) = cpdate(j, :)
                  cpdate(j, :) = tmp

                  tmp =  cpserv(j+1, :)
                  cpserv(j+1, :) = cpserv(j, :)
                  cpserv(j, :) = tmp

                  tmp =  cpreg(j+1, :)
                  cpreg(j+1, :) = cpreg(j, :)
                  cpreg(j, :) = tmp

                  tmp =  cpgen(j+1, :)
                  cpgen(j+1, :) = cpgen(j, :)
                  cpgen(j, :) = tmp

               end if
            end do
            end do

            call Write_list(output, cpname, cpdate, cpserv, cpreg, cpgen,&
                     "First sort", "append", amount)
            call Write_list(output, cpname, cpdate, cpserv, cpreg, cpgen,&
                     "second sort", "append", amount)


         end subroutine
      pure logical function GT(arr1, arr2)
          character(kind=CH_), intent(in) :: arr1(:), arr2(:)

          integer :: i

          do i = 1, Min(Size(arr1), Size(arr2)) - 1
             if (arr1(i) /= arr2(i)) &
             exit
          end do
          GT = arr1(i) > arr2(i)
      end function GT
end program lab_1_2