c
	program xcdks
c
c Extract header files (common decks) from update source (file_in),
c creating .h files, and create source for compiler with fortran
c include statements. (file_in created by update in mksrc script)
c   
c 5/96: Adapted from Ken Hansen's "lazy.f", to add .h suffix on end
c       of all header (common deck) files.
c
	character*100 in, out
	character*24 file_in, file_out
	character*16  name
	character*1 mc
        character*16 envname,envvalue
	integer unit,getenv,igetenv
	character*8 acc, fmt, fname
	logical nmd,ex, od,exists
c
        data envname/'XCDKS_NAME      '/
c
c Master character
	data mc /'*'/

c       data file_in  /'tgcm20.src'/
c       data file_out /'tgcm20.f'/
c
        igetenv = getenv(envname(1:lenstr(envname)),envvalue) 
        if (igetenv.ne.1) then
          write(6,"(/,'>>> xcdks: error from getenv for envname=',a)")
     +      envname(1:lenstr(envname))
          stop 'envname'
        endif
        file_in = envvalue(1:lenstr(envvalue))//'.src'
        file_out = envvalue(1:lenstr(envvalue))//'.f'
        write(6,"('xcdks: file_in=',a)") file_in
        write(6,"('xcdks: file_out=',a)") file_out
        inquire(file=file_in,exist=exists)
        if (.not.exists) then
          write(6,"('>>> xcdks: file_in (',a,') does not exist')")
          stop 'file_in'
        endif
c
	open(1,file = file_in, status = 'old')
	open(2,file = file_out)

	do i = 1, 100000
	  read(1,'(a)',end=100)in
	  irec = irec + 1
	  out(1:) = in(1:)

c Check for master character
	  if(in(1:1) .eq. mc)then

c Is a COMDK still open?  If so, close it.
	  inquire(3,   named=nmd, name=fname, exist=ex, opened=od,
     *    access=acc, form=fmt)

c**         write(6,201) nmd, ex, od, acc, fname, unit
	    if(od)then

c check for "*IF DEF" conditional
	      If(in(1:7).eq. mc // 'IF DEF')then
		elseif(in(1:11).eq. mc // 'ELSEIF DEF')then
		elseif(in(1:7) .eq. mc // 'ENDIF ')then
		elseif(in(1:7) .eq. mc // 'ELSE  ')then
	      else
		close(3)
		write(6,'(''comdeck - '',a,2x,i4)')name,krec
		krec = 0
	      endif
	    endif

c *CA
	    If(in(1:4).eq. mc // 'CA ')then
	      idx = index(in(5:),' ') + 3
	      out(1:) = '      include ''' // in(5:idx) // '.h' // ''''
	      out(70:100) = in(70:)
	      unit = 2
c**           write(6,'(a)')out

c *CALL
	    elseif(in(1:6).eq. mc // 'CALL ')then
c**           write(6,'(i6,3x,a,5x,a)')irec,in(1:20),in(70:100)
	      idx = index(in(7:),' ') + 5
	      out(1:) = '      include ''' // in(7:idx) // ''''
	      out(70:100) = in(70:)
	      unit = 2
c**           write(6,'(a)')out

c *CDK DK_NAME
	    elseif(in(1:5).eq. mc // 'CDK ')then
	      idx = index(in(6:),' ') + 4
	      name(1:) = in(6:idx) // '.h'
              write(6,'(a,i5,2x,''&'',a,''&'')')in(1:idx),idx,name(1:)
	      open (3, file=name)
	      unit = 3
	      krec = 0

c *COMDECK DK_NAME
c 12345678901234567890
	    elseif(in(1:9).eq. mc // 'COMDECK ')then
	      idx = index(in(10:),' ') + 8
	      name(1:) = in(10:idx)
              write(6,'(a,i5,2x,''&'',a,''&'')')in(1:idx),idx,name(1:)

	      open (3, file=name)
	      unit = 3
	      krec = 0

c *DK, DECK,..
	    elseif(in(1:6).eq. mc // 'DECK ')then
	      write(6,'(a)')out
	      unit = 2
	      krec = 0

	    elseif(in(1:4).eq. mc // 'DK ')then
	      write(6,'(a)')out(1:lenstr(out))
              call clearstr(out)
	      unit = 2
	      krec = 0

	      unit = 2
	      krec = 0

	    else
	      write(6,'('' Unsupported Directive '',a)')out(1:20)
	    endif

	  endif

	krec = krec + 1
        lenout = lenstr(out)
	if (lenout.gt.0) write(unit,'(a)') out(1:lenstr(out))

c        if(unit.eq.3)then
c          write(6,'(2i5)')unit,krec
c        endif

	enddo
	close(1)
	close(2)
	close(3)
	stop

100     print *,' EOF on input, irec ,',irec
	close(2)
	close(3)

201     format(1x,L8/1x,'     EXISTS ',l8/
     1               1x,'     OPENED ',l8/
     3               1x,'     ACCESS ',a/
     4               1x,'     F_NAME ',a/
     5               1x,'     UNIT   ',i3)
	end
c
      function lenstr(str)
      character*(*) str
c
c Return index to last non-blank char in str
c
      length = len(str)
      do i=length,1,-1
        if (str(i:i).ne.' ') then
          lenstr = i
          return
        endif
      enddo
      lenstr = 0
      return
      end
c
      subroutine clearstr(str)
c 
c Set given string to all blanks 
c 
      character*(*) str
      length = len(str)
      do i=1,length
        str(i:i) = ' '
      enddo
      return
      end
c