! File: logical_gen.f90
! Public domain 2005 James Van Buskirk
program logical_gen
   implicit none
   integer l1,op,l2,k1,k2
   character, parameter :: l(2) = (/'T','F'/)
   character(5), parameter :: logv(2) = (/'TRUE ','FALSE'/)
   character(4), parameter :: o(4) = (/'AND ','OR  ','NEQV','EQV '/)
   character, parameter :: k(4) = (/'1','2','4','8'/)
   integer values(8)

   call date_and_time(values=values)
   open(10,file='logical_all.f90',status='replace')
   write(10,'(a)') '!File: logical_all.f90'
   write(10,'(a,i1,5(a,i2.2),a,i3.3)') '!Generated by logical_gen.f90 ', &
      values(2),'/',values(3),'/',mod(values(1),100),' ',values(5),':', &
      values(6),':',values(7),'.',values(8)
   write(10,'()')
   write(10,'(a)') 'module mykinds'
   write(10,'(a)') '   implicit none'
   write(10,'(a)') '   integer, parameter :: ik1 = selected_int_kind(2)'
   write(10,'(a)') '   integer, parameter :: ik2 = selected_int_kind(4)'
   write(10,'(a)') '   integer, parameter :: ik4 = selected_int_kind(9)'
   write(10,'(a)') '   integer, parameter :: ik8 = selected_int_kind(18)'
   write(10,'(a)') "   integer, parameter :: ck1 = kind('x')"
   write(10,'(a)') '   integer, parameter :: rk4 = selected_real_kind(6,37)'
   write(10,'(a)') '   integer, parameter :: rk8 = selected_real_kind(15,307)'
   write(10,'(a)') '   integer, parameter :: lk1 = ik1'
   write(10,'(a)') '   integer, parameter :: lk2 = ik2'
   write(10,'(a)') '   integer, parameter :: lk4 = ik4'
   write(10,'(a)') '   integer, parameter :: lk8 = ik8'
   write(10,'(a)') 'end module mykinds'
   write(10,'()')
   write(10,'(a)') 'module test_mod'
   write(10,'(a)') '   use mykinds'
   write(10,'(a)') '   implicit none'
   write(10,'(a)') '   contains'
   do op = 1, size(o)
      do l1 = 1, size(l)
         do l2 = 1, size(l)
            write(10,'(7a)') '      recursive subroutine ',l(l1),'_',trim(o(op)), &
               '_',l(l2),'(at1,af1,at2,af2,at4,af4,at8,af8)'
            do k1 = 1, 4
               write(10,'(6a)') '         logical(lk',k(k1), &
                  '), intent(in) :: at',k(k1),', af',k(k1)
            end do
            do k1 = 1, 4
               write(10,'(6a)') '         logical(lk',k(k1), &
                  '), parameter :: it',k(k1),' = .TRUE._lk',k(k1)
               write(10,'(6a)') '         logical(lk',k(k1), &
                  '), parameter :: if',k(k1),' = .FALSE._lk',k(k1)
            end do
            do k1 = 1, 4
               do k2 = 1, 4
                  write(10,'(11a)') '         character(kind(i', &
                    l(l1),k(k1),'.',trim(o(op)),'.i',l(l2),k(k2), &
                    ')), save :: ck',k(k1),k(k2)
                  write(10,'(13a)') '         character(merge(1,0,i', &
                     l(l1),k(k1),'.',trim(o(op)),'.logical(i',l(l2),k(k2), &
                     ',lk',k(k2),'))), save :: cv',k(k1),k(k2)
               end do
            end do
            do k1 = 1, 4
               do k2 = 1, 4
                  write(10,'(12a)') '         integer, parameter :: ik', &
                     k(k1),k(k2),' = kind(i',l(l1),k(k1),'.',trim(o(op)),'.i', &
                     l(l2),k(k2),')'
                  write(10,'(13a)') '         logical(lk',k(max(k1,k2)), &
                     '), parameter :: iv',k(k1),k(k2),' = i',l(l1),k(k1), &
                     '.',trim(o(op)),'.i',l(l2),k(k2)
               end do
            end do
            do k1 = 1, 4
               do k2 = 1, 4
                  write(10,'(11a)') '         character(kind(a',l(l1),k(k1), &
                     '.',trim(o(op)),'.a',l(l2),k(k2),')) sk',k(k1),k(k2)
                  write(10,'(13a)') '         character(merge(1,0,a',l(l1), &
                     k(k1),'.',trim(o(op)),'.logical(a',l(l2),k(k2),',lk',k(k2), &
                     '))) sv',k(k1),k(k2)
               end do
            end do
            do k1 = 1, 4
               do k2 = 1, 4
                  write(10,'(3a)') '         integer ek',k(k1),k(k2)
                  write(10,'(5a)') '         logical(lk',k(max(k1,k2)), &
                     ') ev',k(k1),k(k2)
               end do
            end do
            write(10,'(a)') '         integer i'
            write(10,'(a)') '         integer j'
            write(10,'()')
            do k1 = 1, 4
               do k2 = 1, 4
                  write(10,'(12a)') '         ek',k(k1),k(k2),' = kind(a', &
                     l(l1),k(k1),'.',trim(o(op)),'.a',l(l2),k(k2),')'
                  write(10,'(11a)') '         ev',k(k1),k(k2),' = a',l(l1), &
                     k(k1),'.',trim(o(op)),'.a',l(l2),k(k2)
               end do
            end do
            write(10,'()')
            write(10,'(7a)') "         write(*,'(/a)') ' .",trim(logv(l1)), &
               ". .",trim(o(op)),". .",trim(logv(l2)),".'"
            write(10,'(a)') "         write(*,'(a)') '   Expression   "// &
               "Constant Initialization Specification'"
            write(10,'(10a)') "         write(*,'(2x,4(2x,4(1x,i1):2x))')"// &
               " (",(k(k1),",",k1=1,size(k)),"j=1,4)"
            write(10,'(a)') "         write(*,'(i2,4(2x,4(1x,i1):2x))') "// &
               "1,ek11,ek12,ek14,ek18, &"
            write(10,'(36x,a)') 'len(ck11),len(ck12),len(ck14),len(ck18), &'
            write(10,'(36x,a)') 'ik11,ik12,ik14,ik18, &'
            write(10,'(36x,a)') 'len(sk11),len(sk12),len(sk14),len(sk18)'
            write(10,'(a)') "         write(*,'(i2,4(2x,4(1x,i1):2x))') "// &
               "2,ek21,ek22,ek24,ek28, &"
            write(10,'(36x,a)') 'len(ck21),len(ck22),len(ck24),len(ck28), &'
            write(10,'(36x,a)') 'ik21,ik22,ik24,ik28, &'
            write(10,'(36x,a)') 'len(sk21),len(sk22),len(sk24),len(sk28)'
            write(10,'(a)') "         write(*,'(i2,4(2x,4(1x,i1):2x))') "// &
               "4,ek41,ek42,ek44,ek48, &"
            write(10,'(36x,a)') 'len(ck41),len(ck42),len(ck44),len(ck48), &'
            write(10,'(36x,a)') 'ik41,ik42,ik44,ik48, &'
            write(10,'(36x,a)') 'len(sk41),len(sk42),len(sk44),len(sk48)'
            write(10,'(a)') "         write(*,'(i2,4(2x,4(1x,i1):2x))') "// &
               "8,ek81,ek82,ek84,ek88, &"
            write(10,'(36x,a)') 'len(ck81),len(ck82),len(ck84),len(ck88), &'
            write(10,'(36x,a)') 'ik81,ik82,ik84,ik88, &'
            write(10,'(36x,a)') 'len(sk81),len(sk82),len(sk84),len(sk88)'
            write(10,'(a)') "         write(*,'()')"
            write(10,'(a)') "         write(*,'(i2,4(2x,4(1x,l1):2x))') "// &
               "1,ev11,ev12,ev14,ev18, &"
            write(10,'(36x,a)') '(/len(cv11),len(cv12),len(cv14),len(cv18)/)==1, &'
            write(10,'(36x,a)') 'iv11,iv12,iv14,iv18, &'
            write(10,'(36x,a)') '(/len(sv11),len(sv12),len(sv14),len(sv18)/)==1'
            write(10,'(a)') "         write(*,'(i2,4(2x,4(1x,l1):2x))') "// &
               "2,ev21,ev22,ev24,ev28, &"
            write(10,'(36x,a)') '(/len(cv21),len(cv22),len(cv24),len(cv28)/)==1, &'
            write(10,'(36x,a)') 'iv21,iv22,iv24,iv28, &'
            write(10,'(36x,a)') '(/len(sv21),len(sv22),len(sv24),len(sv28)/)==1'
            write(10,'(a)') "         write(*,'(i2,4(2x,4(1x,l1):2x))') "// &
               "4,ev41,ev42,ev44,ev48, &"
            write(10,'(36x,a)') '(/len(cv41),len(cv42),len(cv44),len(cv48)/)==1, &'
            write(10,'(36x,a)') 'iv41,iv42,iv44,iv48, &'
            write(10,'(36x,a)') '(/len(sv41),len(sv42),len(sv44),len(sv48)/)==1'
            write(10,'(a)') "         write(*,'(i2,4(2x,4(1x,l1):2x))') "// &
               "8,ev81,ev82,ev84,ev88, &"
            write(10,'(36x,a)') '(/len(cv81),len(cv82),len(cv84),len(cv88)/)==1, &'
            write(10,'(36x,a)') 'iv81,iv82,iv84,iv88, &'
            write(10,'(36x,a)') '(/len(sv81),len(sv82),len(sv84),len(sv88)/)==1'
            write(10,'(6a)') '      end subroutine ',l(l1),'_',trim(o(op)),'_',l(l2)
         end do
      end do
   end do
   write(10,'(a)') 'end module test_mod'
   write(10,'()')
   write(10,'(a)') 'program test'
   write(10,'(a)') '   use mykinds'
   write(10,'(a)') '   use test_mod'
   write(10,'(a)') '   implicit none'
   do k1 = 1, size(k)
      write(10,'(6a)') '   logical(lk',k(k1),') t',k(k1),', f',k(k1)
   end do
   write(10,'()')
   do k1 = 1, size(k)
      do l1 = 1, size(l)
         write(10,'(7a)') '   ',l(l1),k(k1),' = .',trim(logv(l1)),'._lk',k(k1)
      end do
   end do
   do op = 1, size(o)
      do l1 = 1, size(l)
         do l2 = 1, size(l)
            write(10,'(7a)') '   call ',l(l1),'_',trim(o(op)),'_',l(l2), &
               '(t1,f1,t2,f2,t4,f4,t8,f8)'
         end do
      end do
   end do
   write(10,'(a)') 'end program test'
end program logical_gen