********************************************************************************
*                                                                              *
*  2DHF version 1-2003                                                         *
*  Copyright (C) 1996  Jacek Kobus, Leif Laaksonen, Dage Sundholm              *
*                                                                              *
*  This software may be used and distributed according to the terms            *
*  of the GNU General Public License, see README and COPYING.                  *
*                                                                              *
********************************************************************************
c ### card ### 
c
c     This routine reads a data card and scans it for nonspace fields.
c     The number of fields is stored in jump, the starting point of a
c     field in istrt(i) and the number of characters in that field
c     in inumb(i).
c     If the routine finds an exclamation mark anything following it
c     is considered as a comment.
c
      subroutine card
      implicit integer*4 (i-n)
      implicit real*8 (a-h,o-z)
      character*1 ia,iexm,iblnk
      character*1 iatmp(80)
      common/iochan/ iinp5,iinp11,iinp12,iinp13,iinp14,
     &               iout6,iout21,iout22,iout23,iout24
      common/work/jrec,jump,istrt(40),inumb(40),ia(80)
      data iblnk/' '/,iexm/'!'/

      do i=1,80
         ia(i)=' '
      enddo

c     read a line 

      jump = 0
      jrec = 0
      isw = 0
 1    read(iinp5,100,end=40) ia
 100  format(80a1)
 101  format(2x,80a1)

      do i=1,80
         iatmp(i)=ia(i)
      enddo

c     set into lower case 

      call lowcas(iatmp,80)

c     check for tabs, and replace it by a blank

      call tabchk(iatmp,80)

c     check for blanks at left and remove them, fill with blanks at the end  

      call lftpos(iatmp,80) 

      do i=1,80
         ia(i)=iatmp(i)
      enddo

c     echo the slightly modified input data

      write(iout6,101) ia 

c     check for the exclamation mark
      
      do ike=1,80
         ile=ike
         if (ia(ile).eq.iexm) go to 910
      enddo 

 910  if(ile.eq.1) go to 1
      if(ia(ile).eq.iexm) ile=ile-1

      do i = 1,ile
         if (ia(i).eq.iblnk) goto 25
         if (isw) 15,15,20
 15      jump = jump +1
         istrt(jump) = i
         inumb(jump) = 0
         isw=1
 20      inumb(jump) = inumb(jump) + 1
         go to 30
 25      isw = 0
 30      continue
      enddo
      if (jump.eq.0) goto 1
      return

 40   write(iout6,45)
 45   format(//1x,'******* end of input file *******'//)
      stop 'card'
      end

c ### lftpos ###
c
c Eliminates blanks to the left and left position chararcter string card.
c 
      subroutine lftpos(line,length)
      character*1 line(length)

      ieff = 0
      do ipos = 1, length
         if(ieff.gt.0) then
            ieff=ieff+1
            line(ieff) = line(ipos)
         end if
         if(line(ipos).ne.' '.and.ieff.eq.0) then
            ieff=1
            line(ieff) = line(ipos)
         end if 
      end do  

c     fill end with trailing blanks

      do ipos = ieff+1,length 
         line(ipos) = ' '
      end do 

      ntest = 0
      if(ntest.ne.0) then
         write(6,*) ' Left adjusted character string '
         write(6,'(1H ,A)') line
      end if

      return
      end

c ### lowcas ### 
c
c Converts letters in a character string line to the lower case.
c
      subroutine lowcas(line,length)
      character*1 line(length)
      character*1 lower(26)
      character*1 upper(26)

      data lower/'a','b','c','d','e',
     &           'f','g','h','i','j',
     &           'k','l','m','n','o',
     &           'p','q','r','s','t',
     &           'u','v','w','x','y',
     &           'z'/
      data upper/'A','B','C','D','E',
     &           'F','G','H','I','J',
     &           'K','L','M','N','O',
     &           'P','Q','R','S','T',
     &           'U','V','W','X','Y',
     &           'Z'/

      do icha = 1, length
         do i = 1,26
            if(line(icha).eq.upper(i))
     &           line(icha) = lower(i)
         end do  
      end do  
      return 
      end 

c ### tabchk ###
c
c     Searches for a tab in the string line and replace it by a space.
c
      subroutine tabchk(line,length)
      implicit integer*4 (i-n)
      implicit real*8 (a-h,o-z)
      character*1 itab
      character*1 line(length)

      itab=char(9)
      do i=1,length
         if(line(i).eq.itab) then
            line(i)=' '
         end if
      end do
      return
      end