'Teapro program rpgtoc.tea to translate RPG to C
'rpgtoc.tea begun on 17-MAR-2003.
'This program is written in the programming language Teapro 
'which utilizes the OpenTea technology and which
'runs on the Teapro interpreter teapro.exe for
'Windows 95 and later.
'There is no warranty of any kind on this program.
'This program is only intended to work with a very small subset
'of what is commonly known as RPG II.
'People need computer software that actually works.

vari dg_pass1, dg_pass2, dg_pass3, dg_pass4, dg_pass5
vari dg_pass6, dg_pass7
vari sg_pass1, sg_pass2, sg_pass3, sg_pass4, sg_pass5
vari sg_pass6, sg_pass7
vari sg_inpfile, sg_outfile, dg_process, dg_indent
vari sg_nothing, sg_20blanks, sg_20zeros, sg_queue
vari dg_record, sg_record, dg_rpglinenumber
vari dg_filebyte, sg_subroutine, sg_build
vari dg_progkind, sg_progkind
vari dg_error, dg_errnumber, dg_showerror
vari dg_tdebug, dg_operatingsystem
vari dg_fullcdebug1, dg_fullcdebug2
vari sg_badcommands, sg_goodcommands
vari sg_filenames, sg_filedevs, sg_fileinfos, sg_filekeys
vari sg_rpgvarnames, sg_rpgvarsizes
vari sg_bottomarray1, sg_bottomarray2
vari sg_rpgtabnames1, sg_rpgtabnames2
vari sg_indicatset, sg_indicatuse
vari sg_readfile, sg_readpfile, sg_chainfile
vari sg_slashaster, sg_asterslash, sg_csubrname
vari dg_clinecount, dg_ccommentcount
vari sg_prevdividefactor1, sg_prevdividefactor2
vari sg_ifindicators, dg_yesifindicators
vari dg_yeslinedone

sub_main
endp


subr sub_main
'updated 2008/02/25, 2007/11/12
'2007/07/17, 2006/09/25, 2006/09/15, 2006/04/25
'2005/10/07, 2005/04/03, 2005/02/26, 2005/02/24, 2004/11/06
    vari d_any, s_any, d_dot, s_dot, s_out
    vari d_loop, d_good, d_number, s_aster
    vari d_seconds1, d_seconds2

    $sys sg_subroutine, 2
    dift dg_tdebug = 1
	  sg_pass1 = sg_subroutine
	  sub_return
    endi
    $ch$ s_aster, "*", 70

    d_loop = 1
    dwhi d_loop = 1
	  d_good = 1
	  $out s_aster

        sg_build = "Program: rpgtoc.tea, build=518, 2009/10/25"	 
	  $out sg_build
	  $out "Written in Teapro utilizing the OpenTea technology"
	  $out "Written to be run on teapro.exe"
        $out "This program was begun on 2003/03/17"
	  $out "This program, rpgtoc.tea, in in the public domain."
	  $out "This program is without warranty of any kind."
	  $out "People need computer software that actually works."
        dsec d_any
        ded$ s_out, d_any, 0, 0
        $out "seconds=" + s_out
        $out s_out
        $dat s_out
        $out s_out
        $sys s_out, 1
        $out s_out

	  $out s_aster
	  sub_path_memory_lines  
	  sub_initialize

	  'dg_operatingsystem:1=MPE,2=Unix,3=C90
	  $out s_aster
	  dg_operatingsystem = 0

	  sub_speedquick

	  $out "1=MPE operating system"
	  $out "2=Unix/Linux operating system"
	  $out "3=C90 only"
	  $out "99=sub_speed_test " + dg_pass1 
	  $inp s_any, "choose, * to end"

	  $ift s_any = "99": sub_speed_test
	  $isd d_any, s_any
	  dift d_any = 1: $tod dg_operatingsystem, s_any
	  dift d_any <> 1: dinc d_good
	  $ift s_any = "*": dinc d_good

	  dift d_good = 1
	      $out s_aster
		dg_tdebug = 2
		$inp s_any, "1=Teapro debug mode = tdebug mode"
		$ift s_any = "1": dg_tdebug = 1
		$ift s_any = "*": dinc d_good
	  endi
	  dift d_good = 1
	      $out s_aster
		'fullcdebug is activated by C* CDEBUG ON
		'and turned off by C* CDEBUG OFF if
		'dg_fullcdebug1=1
		dg_fullcdebug1 = 2
		dg_fullcdebug2 = 2
		$inp s_any, "1=Add fullcdebug1 lines to program"
		$ift s_any = "1": dg_fullcdebug1 = 1
		$ift s_any = "*": dinc d_good
		'dg_fullcdebug1=1 also sets tig_cdebug=1 at begin
	  endi
	  dift d_good = 1
		$inp s_dot, "enter filename of program to translate"
		$ift s_dot = "*": dinc d_good
	  endi
	  dift d_good = 1
		$tup sg_inpfile, s_dot
		$lok d_dot, sg_inpfile, 1, "."
		dift d_dot > 2
		    ddec d_dot
		    $cut s_any, sg_inpfile, 1, d_dot
		    sg_outfile = s_any + ".CPP"		    
		else
		    sg_outfile = sg_inpfile + ".CPP"
		endi
	  endi
	  dift d_good = 1
		flen d_any, sg_outfile
		dift d_any >= 0
	  	    $inp s_any, "1=purge old file=" + sg_outfile
	  	    $ift s_any = "1"
			  fdel d_any, sg_outfile
	  	    else
			  dinc d_good
	  	    endi
		endi
	  endi
	  dift d_good = 1
	      $out s_aster
		dg_process = 1

		dsec d_seconds1

		'validate the rpg program
		dift dg_process = 1: sub_rpg_validate

		'create program in C
		dift dg_process = 1: sub_c_create

		dsec d_seconds2

		dift dg_process <> 1
		    $inp s_any, "a serious error occurred"
		endi

		dsys d_any, 2
		ded$ s_any, d_any, 0, 0
		$out "lines of Teapro done=" + s_any

		'output file information
		finp s_any, sg_outfile
		$len d_any, s_any
		$hsh d_dot, s_any
		s_any = "file=" + sg_outfile + " length=" + d_any
		$app s_any, " hash=" + d_dot
		$out s_any

		d_any = d_seconds2 - d_seconds1
		$out "seconds=" + d_any + ", progkind=" + sg_progkind
		sub_path_memory_lines

		$out "use CCPK to compile this"
	      $inp s_any, "return, * to end"
	      $ift s_any = "*": dinc d_good
	  endi

	  dift d_good <> 1: dinc d_loop
    endw
ends sub_main


subr sub_initialize
'updated 2004/10/07
    $trb sg_nothing, " "
    $ch$ sg_20blanks, " ", 20
    $ch$ sg_20zeros, "0", 20
    dg_progkind = 0
    sg_progkind = sg_nothing
    dg_indent = 0
    sg_slashaster = "/* "
    sg_asterslash = " */"
    sg_queue = sg_nothing
    arrb
    arrz
ends sub_initialize


subr sub_rpg_validate
'updated 2006/11/01, 2006/04/25, 2005/04/03, 2004/12/23
    vari s_any, d_any, s_dot, d_dot, s_tap

'fline    1 eline   2 iline   3 cline   4 oline   5         6
'123456789012345678901234567890123456789012345678901234567890
'    .FTERMIN  ID  F      80            $STDIN
'    .FTERMOUT O   F      80            $STDLST
'    .E                    ZZ      1  80  1 2
'    .IFILEINP AA
'    .I                                       10  20 VARIAB
'    .CSR 01 02 03FACTOR1   COMMDFACTOR2   RESULT  92H919293
'    .OFILENAMEE 12     01 02 03OLINE
'    .O        E        01 02 03VARIABJB 132 "HEADING LINE  "

    $sys sg_subroutine, 2
    dift dg_tdebug = 1
	  sg_pass1 = sg_subroutine
	  sub_return
    endi

    'begin rpgtoc.log file
    fdel d_any, "rpgtoc.log"
    s_dot = "input file=" + sg_inpfile
    $dat s_any
    $app s_dot, " " + s_any
    s_tap = "rpgtoc.log"
    fapp d_any, s_tap, s_dot

    dg_errnumber = 0
    dg_error = 2
    dg_showerror = 1
    'dg_process was set to 1 before this subr was called

    'rpg valid initialize
    dift dg_process = 1: sub_rpg_valid_initialize

    'rpg valid byte 6 continuity
    dift dg_process = 1: sub_rpg_valid_continuity

    'rpg filenames and filesizes
    dift dg_process = 1: sub_rpg_valid_files

    'rpg gotos, tags, exsrs, begsr, endsr, excpts
    dift dg_process = 1: sub_rpg_valid_tags

    'rpg valid variables get size from lines
    dift dg_process = 1: sub_rpg_valid_varsize_lines

    'rpg valid variables sizes stored in 
    'sg_rpgvarnames, sg_rpgvarsizes
    dift dg_process = 1: sub_rpg_valid_varsize_strings

    'rpg valid variables in all lines
    dift dg_process = 1: sub_rpg_valid_var_all

    'rpg valid indicators
    dift dg_process = 1: sub_rpg_valid_indicators

    'rpg valid format
    dift dg_process = 1: sub_rpg_valid_format
ends sub_rpg_validate


subr sub_rpg_valid_initialize
'updated 2005/01/01
'initialize for the rpg validation
    $sys sg_subroutine, 2
    dift dg_tdebug = 1
	  sg_pass1 = sg_subroutine
	  sub_return
    endi

    sg_filenames = sg_nothing
    sg_filedevs = sg_nothing
    sg_fileinfos = sg_nothing
    sg_filekeys = sg_nothing

    'strings of filenames with read,readp,chain
    sg_readfile = sg_nothing
    sg_readpfile = sg_nothing
    sg_chainfile = sg_nothing

    sg_rpgvarnames = "*BLANK   ,*ZEROS   ,"
    sg_rpgvarsizes = "600009990,600009990,"
    sg_bottomarray1 = sg_nothing
    sg_bottomarray2 = sg_nothing

    sg_rpgtabnames1 = sg_nothing
    sg_rpgtabnames2 = sg_nothing
 
    sg_indicatset = sg_nothing
    sg_indicatuse = sg_nothing

    sg_badcommands = sg_nothing
    sg_goodcommands = sg_nothing

    sg_prevdividefactor1 = sg_nothing
    sg_prevdividefactor2 = sg_nothing
ends sub_rpg_valid_initialize


subr sub_rpg_valid_continuity
'updated 2006/08/14, 2003/11/18
'validate rpg program record types HFEICSO
    vari s_any, d_any, s_dot, d_dot, s_out
    vari d_loop, d_filebyte, s_newrecord, d_good, d_count
    vari s_oldrecord, s_allcodes, s_oldcode, s_newcode
    vari d_hcount, d_fcount, d_ecount, d_icount
    vari d_ccount, d_scount, d_ocount
    vari d_old, d_new, s_fromsubr, d_error

    $sys sg_subroutine, 2
    s_fromsubr = sg_subroutine
    dift dg_tdebug = 1
	  sg_pass1 = sg_subroutine
	  sub_return
    endi

    s_allcodes = "HFEICSO"
    s_oldrecord = "12345H"

    d_error = 2
    d_hcount = 0
    d_fcount = 0
    d_ecount = 0
    d_icount = 0
    d_ccount = 0
    d_scount = 0
    d_ocount = 0

    dg_record = 0

    d_loop = 1
    dwhi d_loop = 1
	  d_good = 1

	  'read a record skipping comment records
	  sg_pass1 = s_fromsubr
	  sub_rpg_read_record
	  s_newrecord = sg_pass1

	  dift dg_record = 0
		dinc d_good
		dinc d_loop
	  endi
	  dift d_good = 1
		'we have a non-comment record to examine in s_newrecord
		'get previous 6code in s_oldcode,d_old
		$cut s_oldcode, s_oldrecord, 6, 1
		$ift s_oldcode = "C"
		    $cut s_any, s_oldrecord, 7, 1
		    $ift s_any = "S": s_oldcode = "S"
		endi
		$lok d_old, s_allcodes, 1, s_oldcode
		dift d_old < 1: d_error = 1

		'get new 6code in s_newcode,d_new
		$cut s_newcode, s_newrecord, 6, 1
		$ift s_newcode = "C"
		    $cut s_any, s_newrecord, 7, 1
		    $ift s_any = "S": s_newcode = "S"
		endi
		$lok d_new, s_allcodes, 1, s_newcode
		dift d_new < 1: d_error = 1

		dift d_old > d_new: d_error = 1

		dift d_error = 1	 
		    sg_pass1 = "6code continuity error"
		    sub_error
		    dinc d_loop
		endi

		'HFEICSO		
		$ift s_newcode = "H": dinc d_hcount	 
		$ift s_newcode = "F": dinc d_fcount	 
		$ift s_newcode = "E": dinc d_ecount	 
		$ift s_newcode = "I": dinc d_icount	 
		$ift s_newcode = "C": dinc d_ccount	 
		$ift s_newcode = "S": dinc d_scount	 
		$ift s_newcode = "O": dinc d_ocount	 

		s_oldrecord = s_newrecord
	  endi
    endw

    'HFEICSO
    $out "H lines=" + d_hcount
    $out "F lines=" + d_fcount
    $out "E lines=" + d_ecount
    $out "I lines=" + d_icount
    $out "C lines=" + d_ccount
    $out "S lines=" + d_scount
    $out "O lines=" + d_ocount
    d_any = d_hcount + d_fcount + d_ecount + d_icount 
    d_any = d_any + d_ccount + d_scount + d_ocount
    $out "total  =" + d_any

    $sys sg_subroutine, 2
    dift dg_tdebug = 1
	  sg_pass1 = sg_subroutine
	  sub_return
    endi
ends sub_rpg_valid_continuity


subr sub_rpg_valid_files
'updated 2004/10/07
'get sg_filenames,sg_filedevs,sg_fileinfos,sg_filekeys
    vari s_any, d_any, s_dot, d_dot, s_out
    vari d_loop1, d_loop2, d_filebyte, s_record, d_good
    vari s_6byte, d_filect, s_fromsubr

    $sys sg_subroutine, 2
    s_fromsubr = sg_subroutine
    dift dg_tdebug = 1
	  sg_pass1 = sg_subroutine
	  sub_return
    endi

'sg_filenames
'12345678
'aaaaaaaa=filename

'sg_filedevs
'aaaaaaaa=filedev

'sg_fileinfos
'12345678
'aabbbbcd
'aa=file type: ID,UD,IC,O
'bbbb=file record length
'c=file is F=fixed or V=variable
'd=file is F=flat or K=KSAM

'sg_filekeys
'12345678
'aaaabbbb
'aaaa=file key begin
'bbbb=file key length

    d_filect = 0
    dg_record = 0

    d_loop1 = 1
    dwhi d_loop1 = 1
	  d_good = 1

	  sg_pass1 = s_fromsubr
	  sub_rpg_read_record
	  s_record = sg_pass1

	  dift dg_record = 0
		dinc d_good
		dinc d_loop1
	  endi
	  dift d_good = 1	  
		'get the code in byte 6
		$cut s_6byte, s_record, 6, 1
		$ift s_6byte = "F"
		    $cut s_any, s_record, 7, 1
		    $ift s_any <> " "
			  dinc d_filect
		        sg_pass1 = s_record
		        sub_rpg_valid_files_fline
		    endi
		endi
		$ift s_6byte = "I"
	          sg_pass1 = s_record
	          sub_rpg_valid_files_iline
		endi
		$ift s_6byte = "C"
		    sg_pass1 = s_record
		    sub_rpg_valid_files_cline
		endi
		$ift s_6byte = "O"
	          sg_pass1 = s_record
	          sub_rpg_valid_files_oline
		endi

		$cut s_any, s_record, 7, 1
		$ift s_any = "*": dinc d_good
	  endi
    endw
    $out "file ct=" + d_filect

    $sys sg_subroutine, 2
    dift dg_tdebug = 1
	  sg_pass1 = sg_subroutine
	  sub_return
    endi
ends sub_rpg_valid_files


subr sub_rpg_valid_files_fline
'updated 2005/04/03, 2004/10/07
'fline into sg_filenames,sg_filedevs,sg_fileinfos,sg_filekey
    vari s_any, d_any, s_dot, d_dot, s_tap, s_out
    vari s_record, s_filename, s_filetype, s_filedevice
    vari s_reclong, s_keybeg, s_keylong, s_filefixed, s_fileksam
    vari d_filereclong, d_filekeybeg, d_filekeylong
    vari d_error, s_error

'sg_filenames
'12345678
'aaaaaaaa=filename

'sg_filedevs
'aaaaaaaa=filedev

'sg_fileinfos
'12345678
'aabbbbcd
'aa=file type: ID,UD,IC,O
'bbbb=file record length
'c=file is F=fixed or V=variable
'd=file is F=flat or K=KSAM

'sg_filekeys
'12345678
'aaaabbbb
'aaaa=file key begin
'bbbb=file key length

'fline    1         2         3         4         5         6
'123456789012345678901234567890123456789012345678901234567890
'     FKRMASTR UD  F    1024R09AI     5 DISC
'     FZRMASTR IC  F    1024R  ID     5 DISC
'    .FTERMIN  ID  F      80            $STDIN
'    .FTERMOUT O   F      80            $STDLST
'column 28 is R or L for KSAM and R for chain
'column 31 is A for KSAM and I for chain
'column 32 is I for KSAM amd D pr C for chain
     s_record = sg_pass1

    'beg dg_errnumber,d_error,1000    
    d_error = 0
    s_error = sg_nothing

    'get the file name
    $cut s_filename, s_record, 7, 8

    'get the file type
    $cut s_filetype, s_record, 15, 2

    'get the s_filefixed
    $cut s_filefixed, s_record, 19, 1

    'get the s_fileksam K or F for flat
    $cut s_any, s_record, 31, 1
    s_fileksam = "F"
    $ift s_any = "A": s_fileksam = "K"

    'get the device
    $cut s_filedevice, s_record, 40, 8

    'get the record length
    $cut s_reclong, s_record, 24, 4

    'get the keybeg
    $cut s_keybeg, s_record, 35, 4

    'get the keylong    
    $cut s_keylong, s_record, 29, 2

'dg_progkind values
'10=input demand
'20=input chain
'30=update demand
'40=input ksam
'50=update ksam
'60=screen
    $ift s_filetype = "ID"
	  dift dg_progkind < 10
		dg_progkind = 10
		sg_progkind = "input demand"
	  endi
    endi
    $ift s_filetype = "IC"
	  dift dg_progkind < 20
		dg_progkind = 20
		sg_progkind = "input chain"
	  endi
    endi
    $ift s_filetype = "UD"
	  dift dg_progkind < 30
		dg_progkind = 30
	 	sg_progkind = "update demand"
	  endi
    endi
    $ift s_fileksam = "K"
	  $ift s_filetype = "ID"
		dift dg_progkind < 40
		    dg_progkind = 40
		    sg_progkind = "ksam input demand"
	 	endi
	  endi
	  $ift s_filetype = "UD"
		dift dg_progkind < 50
		    dg_progkind = 50
		    sg_progkind = "ksam update demand"
		endi
	  endi
    endi
    $ift s_filefixed = "V"
	  dift dg_progkind < 60
		dg_progkind = 60
		sg_progkind = "vplus"
	  endi
    endi

'sg_filenames
'12345678
'aaaaaaaa=filename

'sg_filedevs
'aaaaaaaa=filedev

'sg_fileinfos
'12345678
'aabbbbcd
'aa=file type: ID,UD,IC,O
'bbbb=file record length
'c=file is F=fixed or V=variable
'd=file is F=flat or K=KSAM


'sg_filekeys
'12345678
'aaaabbbb
'aaaa=file key begin
'bbbb=file key length

    'sg_filenames
    'is name proper name
    sg_pass1 = s_filename
    sub_rpg_valid_identifier

    $lok d_any, sg_filenames, 1, s_filename
    dift d_any > 0
	  s_error = "dup filename=" + s_filename
	  d_error = 1001
    endi
    $app sg_filenames, s_filename + ","

    'sg_filedevs
    $app sg_filedevs, s_filedevice + ","

    'sg_fileinfos
    $cut s_filetype, s_filetype, 1, 2
    s_tap = "ID,UD,IC,O ,"
    $lok d_any, s_tap, 1, s_filetype
    dift d_any = 0
	  s_error = "bad file type=" + s_record
	  d_error = 1002
    endi 

    'make record length s_reclong 4 long
    $trl s_reclong, s_reclong
    s_reclong = sg_20zeros + s_reclong
    $off s_reclong, s_reclong, 4

    'is record length s_reclong numeric and > 1
    $isd d_dot, s_reclong
    dift d_dot = 1
	  $tod d_filereclong, s_reclong
	  dift d_filereclong < 1: dinc d_dot
    endi
    dift d_dot <> 1
	  s_error = "bad rec length=" + s_record
	  d_error = 1003
    endi

    'put fileinfos together
    'X means not used here
    $app sg_fileinfos, s_filetype + s_reclong
    $app sg_fileinfos, s_filefixed + s_fileksam + ","

    'key s_keybeg
    $trl s_keybeg, s_keybeg
    s_keybeg = sg_20zeros + s_keybeg
    $off s_keybeg, s_keybeg, 4
    $isd d_dot, s_keybeg
    dift d_dot = 1
	  $tod d_filekeybeg, s_keybeg
	  dift d_filekeybeg < 0: dinc d_dot
    endi
    dift d_dot <> 1
	  s_error = "bad keybeg=" + s_record
	  d_error = 1004
    endi

    'key length s_keylong
    $trl s_keylong, s_keylong
    s_keylong = sg_20zeros + s_keylong
    $off s_keylong, s_keylong, 4

    $isd d_dot, s_keylong
    dift d_dot = 1
	  $tod d_filekeylong, s_keylong
	  dift d_filekeylong < 0: dinc d_dot
    endi
    dift d_dot <> 1
	  s_error = "bad keybeg=" + s_record
	  d_error = 1005
    endi

    s_dot = s_keybeg + s_keylong
    $isd d_any, s_dot
    dift d_any <> 1
	  s_error = "bad key info=" + s_dot
	  d_error = 1006
    endi
    $app sg_filekeys, s_keybeg + s_keylong + "," 

    'validate d_filereclong, d_filekeybeg, d_filekeylong
    d_any = d_filekeybeg + d_filekeylong - 1
    dift d_any > d_filereclong
	  s_error = "bad key pos=" + s_record
	  d_error = 1007
    endi    

    dift dg_tdebug = 1
	  s_any = "file=" + s_filename 
	  $app s_any, ",dev=" + s_filedevice
	  $app s_any, ",type=" + s_filetype
	  $out s_any

	  s_any = ",filefixed=" + s_filefixed
	  $app s_any, ",fileksam=" + s_fileksam
	  $app s_any, ",reclong=" + d_filereclong
	  $app s_any, ",keybeg=" + d_filekeybeg 
	  $app s_any, ",keylong=" + d_filekeylong
	  $out s_any
    endi

    dift d_error > 0
	  'end dg_errnumber,d_error,1000
	  dg_errnumber = d_error
	  sg_pass1 = "file_error: " + s_error
	  sub_error
    endi
ends sub_rpg_valid_files_fline


subr sub_rpg_valid_files_iline
'updated 2004/12/29
'iline into sg_filenames,sg_filedevs,sg_fileinfos,sg_filekey
    vari s_any, d_any, s_dot, d_dot, s_tap, s_out
    vari s_record, s_filename, d_varbeg, d_varend, d_error
    vari s_filedevice, s_filetype
    vari s_filefixed, s_fileksam
    vari d_filereclong, d_filekeybeg, d_filekeylong

'sg_filenames
'12345678
'aaaaaaaa=filename

'sg_filedevs
'aaaaaaaa=filedev

'sg_fileinfos
'12345678
'aabbbbcd
'aa=file type: ID,UD,IC,O
'bbbb=file record length
'c=file is F=fixed or V=variable
'd=file is F=flat or K=KSAM

'sg_filekeys
'12345678
'aaaabbbb
'aaaa=file key begin
'bbbb=file key length

'iline    1         2         3         4         5         6
'123456789012345678901234567890123456789012345678901234567890
'    .IFILEINP AA
'    .I                                       10  20 VARIAB
    s_record = sg_pass1
    'beg dg_errnumber,d_error,1200
    d_error = 0

    'which type of iline do we have
    $cut s_filename, s_record, 7, 8
    $ch$ s_any, " ", 8
    $ift s_any = s_filename
	  'we have a variable definition iline
	  'get d_varbeg and d_varend
	  $cut s_any, s_record, 44, 4
	  $isd d_any, s_any
	  dift d_any <> 1: s_any = "0"
	  $tod d_varbeg, s_any

	  $cut s_any, s_record, 48, 4
	  $isd d_any, s_any
	  dift d_any <> 1: s_any = "0"
	  $tod d_varend, s_any

        'get the record length from the array
        itod d_filereclong, 1

        'validate d_varbeg and d_varend
        dift d_varbeg < 1: d_error = 1201
        dift d_varend < d_varbeg: d_error = 1202
        dift d_varend > d_filereclong: d_error = 1203 
    else
	  'we have a filename iline get file information
	  sg_pass1 = s_filename
	  sub_rpg_file_info_return
	  s_filedevice = sg_pass1
	  s_filetype = sg_pass2
	  s_filefixed = sg_pass3
	  s_fileksam = sg_pass4
	  d_filereclong = dg_pass2
	  d_filekeybeg = dg_pass3
	  d_filekeylong = dg_pass4

	  'save d_filereclong for the variable definition lines
	  dtoi 1, d_filereclong

	  s_tap = "ID,UD,IC"
	  $lok d_any, s_tap, 1, s_filetype
	  dift d_any = 0: d_error = 1204
    endi

    'do we have an error
    dift d_error > 0
	  'end dg_errnumber,d_error,1200
	  dg_errnumber = d_error
	  sg_pass1 = "bad input"
	  sub_error
    endi
ends sub_rpg_valid_files_iline


subr sub_rpg_valid_files_cline
'updated 2005/04/03, 2004/10/24
'cline into sg_filenames,sg_fileinfos,sg_filekey
    vari s_any, d_any, s_dot, d_dot, s_tap, s_out
    vari s_record, s_filename, s_command, s_all
    vari s_filedevice, s_filetype, d_filereclong
    vari s_filefixed, s_fileksam
    vari d_filekeybeg, d_filekeylong

'cline    1         2         3         4         5         6
'123456789012345678901234567890123456789012345678901234567890
'    .CSR 01 02 03FACTOR1   COMMDFACTOR2   RESULT  92H919293

    s_record = sg_pass1

    s_all = "READ ,READP,CHAIN,SETLL,LOCK ,UNLCK,"
    $cut s_command, s_record, 28, 5
    $lok d_any, s_all, 1, s_command
    dift d_any > 0
	  'we have a filename cline get file information
	  $cut s_filename, s_record, 33, 8
	  sg_pass1 = s_filename
	  sub_rpg_file_info_return
	  s_filedevice = sg_pass1
	  s_filetype = sg_pass2
	  s_filefixed = sg_pass3
	  s_fileksam = sg_pass4
	  d_filereclong = dg_pass2
	  d_filekeybeg = dg_pass3
	  d_filekeylong = dg_pass4

	  's_filetype must be ID,UD,IC
	  s_tap = "ID,UD,IC,"
	  $lok d_any, s_tap, 1, s_filetype
	  dift d_any = 0
		sg_pass1 = "not ID,UD,IC"
		sub_error
	  endi
	  $ift s_command = "READ "
		$lok d_any, sg_readfile, 1, s_filename
		dift d_any = 0: $app sg_readfile, s_filename + ","	

		s_tap = "ID,UD"
		$lok d_any, s_tap, 1, s_filetype
		dift d_any = 0
		    sg_pass1 = "not ID,UD"
		    sub_error
		endi
	  endi
	  $ift s_command = "READP"
		$lok d_any, sg_readpfile, 1, s_filename
		dift d_any = 0: $app sg_readpfile, s_filename + ","	

		s_tap = "ID,UD"
		$lok d_any, s_tap, 1, s_filetype
		dift d_any = 0
		    sg_pass1 = "not ID,UD"
		    sub_error
		endi
	  endi
	  $ift s_command = "CHAIN"
		$lok d_any, sg_chainfile, 1, s_filename
		dift d_any = 0: $app sg_chainfile, s_filename + ","	

		$ift s_filetype <> "IC"
		    sg_pass1 = "not IC"
		    sub_error
		endi
	  endi
	  $ift s_command = "SETLL"
		$ift s_fileksam <> "K"
		    sg_pass1 = "not KSAM"
		    sub_error
		endi
	  endi
	  $ift s_command = "LOCK "
		$ift s_fileksam <> "K"
		    sg_pass1 = "not KSAM"
		    sub_error
		endi
	  endi
	  $ift s_command = "UNLCK"
		$ift s_fileksam <> "K"
		    sg_pass1 = "not KSAM"
		    sub_error
		endi
	  endi
    endi    
ends sub_rpg_valid_files_cline


subr sub_rpg_valid_files_oline
'updated 2005/04/03, 2003/10/16
'oline into sg_filenames,sg_fileinfos,sg_filekey
    vari s_any, d_any, s_dot, d_dot, s_tap, s_out
    vari s_record, s_filename, s_command, s_all
    vari s_filedevice, s_filetype
    vari s_filefixed, s_fileksam
    vari d_filereclong, d_filekeybeg, d_filekeylong
'    .OFILENAMEE 12     01 02 03OLINE
'    .O        E        01 02 03VARIABJB 132 "HEADING LINE  "

    s_record = sg_pass1

    $cut s_filename, s_record, 7, 8
    $ch$ s_any, " ", 8
    $ift s_filename <> s_any
	  'we have a filename oline get file information
	  sg_pass1 = s_filename
	  sub_rpg_file_info_return
	  s_filedevice = sg_pass1
	  s_filetype = sg_pass2
	  s_filefixed = sg_pass3
	  s_fileksam = sg_pass4
	  d_filereclong = dg_pass2
	  d_filekeybeg = dg_pass3
	  d_filekeylong = dg_pass4

	  's_filetype must be ID or UD for an oline
	  s_tap = "UD,O "
	  $lok d_any, s_tap, 1, s_filetype
	  dift d_any = 0
		sg_pass1 = "not ID or UD"
		sub_error
	  endi
    endi    
ends sub_rpg_valid_files_oline


subr sub_rpg_file_info_return
'updated 2004/10/07
'return file info from sg_filenames,sg_filedevs,sg_fileinfos
    vari s_any, d_any, s_dot, d_dot, s_out
    vari s_filename, s_filetype, s_filedevice, d_filereclong
    vari d_filekeybeg, d_filekeylong, s_filefixed, s_fileksam
    vari s_infos, s_keys, d_byte

'sg_filenames
'12345678
'aaaaaaaa=filename

'sg_filedevs
'aaaaaaaa=filedev

'sg_fileinfos
'12345678
'aabbbbcd
'aa=file type: ID,UD,IC,O
'bbbb=file record length
'c=file is F=fixed or V=variable
'd=file is F=flat or K=KSAM

'sg_filekeys
'12345678
'aaaabbbb
'aaaa=file key begin
'bbbb=file key length

    s_filename = sg_pass1

    s_filedevice = sg_nothing
    s_filetype = sg_nothing
    s_filefixed = sg_nothing
    s_fileksam = sg_nothing

    d_filereclong = 0
    d_filekeybeg = 0
    d_filekeylong = 0

    'make name 8 long uppercase
    $app s_filename, sg_20blanks
    $cut s_filename, s_filename, 1, 8
    $cup s_filename, s_filename

    $lok d_byte, sg_filenames, 1, s_filename
    dift d_byte = 0
	  sg_pass1 = "no info file name=" + s_filename
	  sub_error
    else
	  'get from sg_filedevs
	  $cut s_filedevice, sg_filedevs, d_byte, 8

	  'get from sg_fileinfos
        $cut s_infos, sg_fileinfos, d_byte, 8

	  $cut s_filetype, s_infos, 1, 2

	  'record length d_filereclong
        $cut s_any, s_infos, 3, 4
	  $tod d_filereclong, s_any

	  'get s_filefixed
	  $cut s_filefixed, s_infos, 7, 1

	  'get s_fileksam
	  $cut s_fileksam, s_infos, 8, 1

	  'get from sg_filekeys  
        $cut s_keys, sg_filekeys, d_byte, 8

        $cut s_any, s_keys, 1, 4
	  $tod d_filekeybeg, s_any

        $cut s_any, s_keys, 5, 4
	  $tod d_filekeylong, s_any

	  'dg_tdebug
	  dift dg_tdebug = 1
		s_out = "file=" + s_filename + ", dev=" + s_filedevice
		$app s_out, ",type=" + s_filetype
		$app s_out, ",fixed=" + s_filefixed
		$app s_out, ",ksam=" + s_fileksam
		$out s_out
	 
		s_out = ",reclong=" + d_filereclong
		$app s_out, ",keybeg=" + d_filekeybeg 
		$app s_out, ",keylong=" + d_filekeylong
		$out s_out
	  endi
    endi

    sg_pass1 = s_filedevice
    sg_pass2 = s_filetype
    sg_pass3 = s_filefixed
    sg_pass4 = s_fileksam

    dg_pass2 = d_filereclong
    dg_pass3 = d_filekeybeg
    dg_pass4 = d_filekeylong
ends sub_rpg_file_info_return


subr sub_rpg_valid_identifier
'updated 2004/04/07
'identifier validate for filenames and variable names
    vari s_any, d_any, s_dot, d_dot, s_out
    vari s_chars, s_identifier, d_long, d_error

    s_identifier = sg_pass1
    s_chars = "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789"
    'beg dg_errnumber,d_error,1100
    d_error = 0

    $trr s_identifier, s_identifier     
    $len d_long, s_identifier
    d_dot = 1
    dwhi d_dot <= d_long
	  $cut s_dot, s_identifier, d_dot, 1
	  $lok d_any, s_chars, 1, s_dot
	  dift d_any = 0: d_error = 1101

	  'the first char must be a letter
	  dift d_dot = 1
		dift d_any > 26: d_error = 1102
	  endi

	  dinc d_dot
    endw
    dift d_error > 0
	  'end dg_errnumber,d_error,1100
	  dg_errnumber = d_error
	  sg_pass1 = "bad identifier=" + s_identifier
	  sub_error
    endi
ends sub_rpg_valid_identifier


subr sub_rpg_valid_tags
'updated 2005/01/15, 2003/11/18
'validate tag,goto,begsr,endsr
    vari s_any, d_any, s_dot, d_dot, s_out
    vari d_loop1, d_loop2, d_filebyte, s_record, d_good
    vari s_tag7, s_goto7, s_exsr7, s_begsr7, s_alltagbegsr7
    vari s_cexcpt7, s_oexcpt7
    vari d_tag, d_goto, d_exsr, d_begsr, d_cexcpt, d_oexcpt
    vari s_comm, s_fact1, s_fact2, s_result
    vari s_blank6, d_big, s_fromsubr
    vari d_insubroutine, s_insubroutine

    $sys sg_subroutine, 2
    s_fromsubr = sg_subroutine
    dift dg_tdebug = 1
	  sg_pass1 = sg_subroutine
	  sub_return
    endi

'cline    1         2         3         4         5         6
'123456789012345678901234567890123456789012345678901234567890
'    .CSR 01 02 03FACTOR1   COMMDFACTOR2   RESULT  92H919293

    s_tag7 = sg_nothing
    s_goto7 = sg_nothing
    s_exsr7 = sg_nothing
    s_begsr7 = sg_nothing
    s_alltagbegsr7 = sg_nothing
    s_cexcpt7 = sg_nothing
    s_oexcpt7 = sg_nothing

    d_tag = 0
    d_goto = 0
    d_exsr = 0
    d_begsr = 0
    d_cexcpt = 0
    d_oexcpt = 0

    d_insubroutine = 2
    s_insubroutine = sg_nothing

    $ch$ s_blank6, " ", 6
    dpow d_big, 10, 9

    dg_record = 0

    d_loop1 = 1
    dwhi d_loop1 = 1
	  d_good = 1

	  sg_pass1 = s_fromsubr
	  sub_rpg_read_record
	  s_record = sg_pass1

	  dift dg_record = 0
		dinc d_good
		dinc d_loop1
	  endi
	  dift d_good = 1
		$cut s_any, s_record, 6, 1
		$ift s_any = "O"
		    'get excpt tags in output into s_oexcpt7
		    $cut s_any, s_record, 15, 1
		    $ift s_any = "E"
			  $cut s_dot, s_record, 32, 6
			  $isc d_any, s_dot, " "
			  dift d_any = 1
				dg_errnumber = 1600
				sg_pass1 = "excpt no tag"
				sub_error
			  else	
			      $lok d_any, s_oexcpt7, 1, s_dot
			      dift d_any = 0
				    dinc d_oexcpt
				    $app s_oexcpt7, s_dot + ","
				endi
			  endi
		    endi
		endi

		$cut s_any, s_record, 6, 1
		$ift s_any <> "C": dinc d_good

		$cut s_any, s_record, 7, 1
		$ift s_any = "*": dinc d_good
	  endi
	  dift d_good = 1
		'only clines below
		$cut s_fact1, s_record, 18, 6
		$cut s_comm, s_record, 28, 5
		$cut s_fact2, s_record, 33, 6
		$cut s_result, s_record, 43, 6

		$ift s_comm = "TAG  "
		    'validate the name
		    sg_pass1 = s_fact1
		    sub_rpg_valid_identifier

		    $ift s_fact1 = s_blank6
			  dg_errnumber = 1601
			  sg_pass1 = "blank TAG"
			  sub_error
		    else
			  'have we this tag already
			  $lok d_any, s_alltagbegsr7, 1, s_fact1
			  dift d_any > 0
				dg_errnumber = 1602
				sg_pass1 = "dup TAG=" + s_fact1
				sub_error
			  endi
			  dinc d_tag
		        $app s_tag7, s_fact1 + ","
		        $app s_alltagbegsr7, s_fact1 + ","
		    endi
		endi
		$ift s_comm = "GOTO "
		    $ift s_fact2 = s_blank6
			  dg_errnumber = 1603
			  sg_pass1 = "blank GOTO"
			  sub_error
		    else
			  dinc d_goto
		        $app s_goto7, s_fact2 + ","
		    endi
		endi
		$ift s_comm = "EXSR "
		    $ift s_fact2 = s_blank6
			  dg_errnumber = 1604
			  sg_pass1 = "blank EXSR"
			  sub_error
		    else
			  dinc d_exsr
		        $app s_exsr7, s_fact2 + ","
		    endi
		endi
		$ift s_comm = "BEGSR"
		    'validate the name
		    sg_pass1 = s_fact1
		    sub_rpg_valid_identifier

		    $ift s_fact1 = s_blank6
			  dg_errnumber = 1605
			  sg_pass1 = "blank BEGSR"
			  sub_error
		    else
			  'have we this begsr already
			  $lok d_any, s_alltagbegsr7, 1, s_fact1
			  dift d_any > 0
				dg_errnumber = 1606
				sg_pass1 = "duplicate TAGBEGSR"
				sub_error
			  endi
			  dinc d_begsr
		        $app s_begsr7, s_fact1 + ","
		        $app s_alltagbegsr7, s_fact1 + ","
		    endi

		    dift d_insubroutine = 1
			  'we are already in s_insubroutine
			  dg_errnumber = 1607
			  sg_pass1 = "already in " + s_insubroutine
			  sub_error
		    endi

		    'we are now in subroutine s_fact1
		    d_insubroutine = 1
		    s_insubroutine = s_fact1

		    'find each GOTO in s_tag7
		    d_loop2 = 1			  
		    $len d_any, s_goto7
		    dift d_any < 7: dinc d_loop2

		    dwhi d_loop2 = 1
			  $cut s_dot, s_goto7, 1, 7
			  $cut s_goto7, s_goto7, 8, d_big
			  $lok d_dot, s_tag7, 1, s_dot
			  dift d_dot = 0
				dg_errnumber = 1608
			      sg_pass1 = "bad GOTO=" + s_dot
			      sub_error
			  endi
			  $len d_any, s_goto7
			  dift d_any < 7: dinc d_loop2
		    endw
		    s_goto7 = sg_nothing
		    s_tag7 = sg_nothing
		endi
		$ift s_comm = "ENDSR"
		    'validate the name
		    sg_pass1 = s_fact1
		    sub_rpg_valid_identifier

		    $ift s_fact1 <> s_blank6
			  'have we this tagbegsr already
			  $lok d_any, s_alltagbegsr7, 1, s_fact1
			  dift d_any > 0
				dg_errnumber = 1609
				sg_pass1 = "dup TAGBEGSR=" + s_fact1
				sub_error
			  endi
			  dinc d_goto
		        $app s_tag7, s_fact1 + ","
		        $app s_alltagbegsr7, s_fact1 + ","
		    endi

		    dift d_insubroutine <> 1
			  'we are not in any subroutine
			  dg_errnumber = 1610
			  sg_pass1 = "not in a subroutine"
			  sub_error
		    endi

		    'we are now not in a subroutine
		    d_insubroutine = 2
		    s_insubroutine = sg_nothing
		
		    'find each s_goto7 in s_tag7
		    d_loop2 = 1			  
		    $len d_any, s_goto7
		    dift d_any < 7: dinc d_loop2

		    dwhi d_loop2 = 1
			  $cut s_dot, s_goto7, 1, 7
			  $cut s_goto7, s_goto7, 8, d_big
			  $lok d_dot, s_tag7, 1, s_dot
			  dift d_dot = 0
				dg_errnumber = 1611
			      sg_pass1 = "bad GOTO=" + s_dot
			      sub_error
			  endi
			  $len d_any, s_goto7
			  dift d_any < 7: dinc d_loop2
		    endw
		    s_goto7 = sg_nothing
		    s_tag7 = sg_nothing
		endi
		$ift s_comm = "EXCPT"
		    $trb s_any, s_result
		    $len d_any, s_any
		    dift d_any > 0
			  dinc d_cexcpt
			  $app s_cexcpt7, s_result + ","
		    endi
		endi
	  endi
    endw

    'find each EXSR in s_exsr7 in s_begsr7
    d_loop2 = 1			  
    $len d_any, s_exsr7
    $len d_dot, s_begsr7
    d_any = d_any + d_dot
    dift d_any = 0: dinc d_loop2

    dwhi d_loop2 = 1
	  $cut s_dot, s_exsr7, 1, 7
	  $cut s_exsr7, s_exsr7, 8, d_big
	  $lok d_dot, s_begsr7, 1, s_dot
	  dift d_dot = 0
		dg_errnumber = 1612
	      sg_pass1 = "bad EXSR='" + s_dot + "'"
	      sub_error
	  endi
	  $len d_any, s_exsr7
	  dift d_any < 7: dinc d_loop2
    endw

    'match s_oexcpt7 with s_cexcpt7
    s_dot = s_oexcpt7
    d_loop2 = 1			  
    dwhi d_loop2 = 1
	  $cut s_any, s_dot, 1, 7
	  $cut s_dot, s_dot, 8, d_big
	  $lok d_any, s_cexcpt7, 1, s_any
	  dift d_any = 0
		dg_errnumber = 1613
	      sg_pass1 = "bad oline excpt tag='" + s_any + "'"
	      sub_error
	  endi
	  $len d_any, s_dot
	  dift d_any < 7: dinc d_loop2
    endw

    'match s_cexcpt7 with s_oexcpt7
    s_dot = s_cexcpt7
    d_loop2 = 1			  
    dwhi d_loop2 = 1
	  $cut s_any, s_dot, 1, 7
	  $cut s_dot, s_dot, 8, d_big
	  $lok d_any, s_oexcpt7, 1, s_any
	  dift d_any = 0
		dg_errnumber = 1614
	      sg_pass1 = "bad excpt cline tag='" + s_any + "'"
	      sub_error
	  endi
	  $len d_any, s_dot
	  dift d_any < 7: dinc d_loop2
    endw
    $out "ct goto=" + d_goto
    $out "ct tag=" + d_tag
    $out "ct cexcpt=" + d_cexcpt
    $out "ct oexcpt=" + d_oexcpt
    $out "ct exsr=" + d_exsr
    $out "ct begsr=" + d_begsr

    $sys sg_subroutine, 2
    dift dg_tdebug = 1
	  sg_pass1 = sg_subroutine
	  sub_return
    endi
ends sub_rpg_valid_tags


subr sub_rpg_valid_varsize_lines
'updated 2004/06/21
'rpg validate var size by reading through the lines
    vari s_any, d_any, s_dot, d_dot, s_out
    vari d_loop, d_filebyte, s_record, d_good, d_count
    vari s_6code, s_varname, s_varsize, s_fromsubr

    $sys sg_subroutine, 2
    s_fromsubr = sg_subroutine
    dift dg_tdebug = 1
	  sg_pass1 = sg_subroutine
	  sub_return
    endi

    d_count = 0
    dg_record = 0

    d_loop = 1
    dwhi d_loop = 1
	  d_good = 1

	  sg_pass1 = s_fromsubr
	  sub_rpg_read_record
	  s_record = sg_pass1

	  dift dg_record = 0
		dinc d_good
		dinc d_loop
	  endi
	  s_6code = "X"
	  dift d_good = 1
		$cut s_6code, s_record, 6, 1
		$cut s_any, s_record, 7, 1
		$ift s_any = "*": s_6code = "X"
	  endi
	  $ift s_6code = "E"
		sg_pass1 = s_record
		sub_rpg_valid_varsize_eline
	  endi
	  $ift s_6code = "I"
		sg_pass1 = s_record
		sub_rpg_valid_varsize_iline
	  endi
'fline    1 eline   2 iline   3         4         5         6
'123456789012345678901234567890123456789012345678901234567890
'    .FTERMIN  ID  F      80            $STDIN
'    .FTERMOUT O   F      80            $STDLST
'    .E                    ZZ      1  80  1 2
'    .IFILEINP AA
'    .I                                       10  20 VARIAB
'cline    1 oline   2         3         4         5         6
'123456789012345678901234567890123456789012345678901234567890
'    .CSR 01 02 03FACTOR1   COMMDFACTOR2   RESULT  92H919293
'    .OFILENAMEE 12     01 02 03OLINE
'    .O        E        01 02 03VARIABJB 132 "HEADING LINE  "
' var size = 99998887, 9999=how many, 888=length, 7=decimals
	  $ift s_6code = "C"
		sg_pass1 = s_record
		sub_rpg_valid_varsize_cline
	  endi
    endw

    $sys sg_subroutine, 2
    dift dg_tdebug = 1
	  sg_pass1 = sg_subroutine
	  sub_return
    endi
ends sub_rpg_valid_varsize_lines


subr sub_rpg_valid_varsize_eline
'updated 2006/10/31, 2004/12/27
'var in eline
    vari s_any, d_any, s_dot, d_dot, s_out, d_error
    vari s_varname, s_varindexct, s_varlongct, s_vardecimalct
    vari s_varsize, s_perlinect
    vari s_tabname, s_tablongct, s_tabdecimalct
    vari d_good, s_comm, s_line

'eline    1         2         3         4         5
'123456789012345678901234567890123456789012345678901234567890
'    .E                    ZZ      1  80  1 2
'    .E                    TAB1    1  80  1 2 TAB2    6 4

'123456789 sg_rpgvarnames 9 long
'abbbbcccd sg_rpgvarsizes 9 long
'a    = d_vartype: 1=numeric,2=numeric array,6=alpha,7=alpha array
'bbbb = d_varindexct: index count
'ccc  = d_varlongct: length max=256
'd    = d_vardecimalct: decimals

    s_line = sg_pass1
    's_line is 70 long

    'beg dg_errnumber,d_error,3100
    d_error = 0
    $cut s_varname, s_line, 27, 6
    $cut s_perlinect, s_line, 33, 3
    $cut s_varindexct, s_line, 36, 4
    $cut s_varlongct, s_line, 40, 3
    $cut s_vardecimalct, s_line, 44, 1
    $cut s_tabname, s_line, 46, 6
    $cut s_tablongct, s_line, 52, 3
    $cut s_tabdecimalct, s_line, 55, 2

    'sg_bottomarray1,sg_bottomarray2 are used for bottom arrays
    $isc d_any, s_perlinect, " "
    dift d_any <> 1
        'store in sg_bottomarray1, sg_bottomarray2 for bottom arrays
        'sg_bottomarray1, csv with array names 6 long
        'sg_bottomarray2, csv with perlinect 6 long
        $app sg_bottomarray1, s_varname + ","
        $app sg_bottomarray2, "   " + s_perlinect + ","
    endi

'123456789 sg_rpgvarnames 9 long
'abbbbcccd sg_rpgvarsizes 9 long
'a    = d_vartype: 1=numeric,2=numeric array,6=alpha,7=alpha array
'bbbb = d_varindexct: index count
'ccc  = d_varlongct: length max=256
'd    = d_vardecimalct: decimals
    'do we have an alpha array
    $ift s_vardecimalct = " "
	  s_varsize = "7" + s_varindexct + s_varlongct + s_vardecimalct
    else
	  s_varsize = "2" + s_varindexct + s_varlongct + s_vardecimalct
    endi

    'store in sg_rpgvarnames,sg_rpgvarsizes
    sg_pass1 = s_varname
    sg_pass2 = s_varsize
    sg_pass3 = "E"
    sub_rpg_variable_info_collect

    'do we have a table1, table2
    $cut s_any, s_varname, 1, 3
    $ift s_any = "TAB"
	  'table2 must also start with TAB
	  $cut s_any, s_tabname, 1, 3
	  $ift s_any <> "TAB": d_error = 3101

	  'cannot have numeric table1
	  $isc d_any, s_vardecimalct, " "
	  dift d_any <> 1: d_error = 3102

	  'cannot have numeric table2
	  $isc d_any, s_tabdecimalct, " "
	  dift d_any <> 1: d_error = 3103

	  'cannot already have these names already
	  $lok d_any, sg_rpgtabnames1, 1, s_varname
	  dift d_any > 0: d_error = 3104
	  $lok d_any, sg_rpgtabnames2, 1, s_tabname
	  dift d_any > 0: d_error = 3105

	  'store in sg_rpgtabnames1,sg_rpgtabnames2 to connect them
	  $app sg_rpgtabnames1, s_varname + ","
	  $app sg_rpgtabnames2, s_tabname + ","

'123456789 sg_rpgvarnames 9 long
'abbbbcccd sg_rpgvarsizes 9 long
'a    = d_vartype: 1=numeric,2=numeric array,6=alpha,7=alpha array
'bbbb = d_varindexct: index count
'ccc  = d_varlongct: length max=256
'd    = d_vardecimalct: decimals

	  s_varsize = "60001" + s_tablongct + " "

	  'store table2 in sg_rpgvarnames,sg_rpgvarsizes
        sg_pass1 = s_tabname
        sg_pass2 = s_varsize
        sg_pass3 = "E"
        sub_rpg_variable_info_collect
    endi

    dift d_error > 0
        'end dg_errnumber,d_error,3100
	  dg_errnumber = d_error
	  sg_pass1 = "E line error"
	  sub_error
    endi
ends sub_rpg_valid_varsize_eline


subr sub_rpg_valid_varsize_iline
'updated 2006/10/31, 2003/09/30
'variables from ilines
    vari s_any, d_any, s_dot, d_dot, s_out
    vari s_line, s_varname, s_varsize
    vari d_beg, d_end
    vari d_process, d_good
    vari s_vartype, s_varindexct, s_varlongct, s_vardecimalct

'iline    1         2         3         4         5         6
'123456789012345678901234567890123456789012345678901234567890
'    .IFILEINP AA
'    .I                                       10  20 VARIAB
'123456789 sg_rpgvarnames 9 long
'abbbbcccd sg_rpgvarsizes 9 long
'a    = d_vartype: 1=numeric,2=numeric array,6=alpha,7=alpha array
'bbbb = d_varindexct: index count
'ccc  = d_varlongct: length max=256
'd    = d_vardecimalct: decimals

    s_line = sg_pass1
    d_process = 1

    'do we have a variable definition line
    $cut s_any, s_line, 7, 8
    $ch$ s_dot, " ", 8
    $ift s_any <> s_dot: dinc d_process

    dift d_process = 1
        $cut s_varname, s_line, 53, 6

	  'was this s_varname done earlier on an eline
	  s_any = s_varname + sg_20blanks
	  $cut s_any, s_any, 1, 9
	  $lok d_any, sg_rpgvarnames, 1, s_any
	  dift d_any > 0: dinc d_process
    endi
    dift d_process = 1
	  s_varindexct = "0001"

	  'get s_varlongct
        $cut s_any, s_line, 44, 4
	  $tod d_beg, s_any

        $cut s_any, s_line, 48, 4
	  $tod d_end, s_any

	  d_dot = d_end - d_beg + 1
	  s_varlongct = d_dot

	  s_varlongct = sg_20blanks + s_varlongct
	  $off s_varlongct, s_varlongct, 3

	  'get s_vardecimalct
	  $cut s_vardecimalct, s_line, 52, 1

	  'numeric variable = 1
	  s_vartype = "1"
	  $ift s_vardecimalct = " "
		'alpha variable = 6
		s_vartype = "6"
		s_vardecimalct = "0"
	  endi
	  s_varsize = s_vartype + s_varindexct + s_varlongct 
	  $app s_varsize, s_vardecimalct

	  'zero fill
	  $swp s_varsize, " ", "0"

	  'store in sg_rpgvarnames,sg_rpgvarsizes
	  sg_pass1 = s_varname
	  sg_pass2 = s_varsize
	  sg_pass3 = "I"
	  sub_rpg_variable_info_collect
    endi    
ends sub_rpg_valid_varsize_iline


subr sub_rpg_valid_varsize_cline
'updated 2005/04/03, 2003/06/05
'get varsize in cline variables
    vari s_any, d_any, s_dot, d_dot, s_tap, s_out
    vari s_record, s_varname, s_varsize
    vari d_process, d_good, s_command
    vari s_vartype, s_varindexct, s_varlongct, s_vardecimalct

'cline    1         2         3         4         5         6
'123456789012345678901234567890123456789012345678901234567890
'    .CSR 01 02 03FACTOR1   COMMDFACTOR2   RESULT  92H919293

'123456789 sg_rpgvarnames 9 long
'abbbbcccd sg_rpgvarsizes 9 long
'a    = d_vartype: 1=numeric,2=numeric array,6=alpha,7=alpha array
'bbbb = d_varindexct: index count
'ccc  = d_varlongct: length
'd    = d_vardecimalct: decimals

    s_record = sg_pass1
    's_record is 70 long

    d_process = 1
    $cut s_varname, s_record, 43, 6
    $cut s_varlongct, s_record, 49, 3
    $cut s_vardecimalct, s_record, 52, 1
    $cut s_command, s_record, 28, 5

    'skip if certain commands
    s_tap = "EXCPT,TAG  ,GOTO ,BEGSR,ENDSR,"
    $lok d_dot, s_tap, 1, s_command
    dift d_dot > 0: dinc d_process

    'skip if empty field
    $ch$ s_any, " ", 6
    $ift s_varname = s_any: dinc d_process

    'skip if containing a comma
    $lok d_any, s_varname, 1, ","
    dift d_any > 0: dinc d_process

    'skip if no s_varlongct
    $ch$ s_any, " ", 3
    $ift s_varlongct = s_any: dinc d_process

    dift d_process = 1
'123456789 sg_rpgvarnames 9 long
'abbbbcccd sg_rpgvarsizes 9 long
'a    = d_vartype: 1=numeric,2=numeric array,6=alpha,7=alpha array
'bbbb = d_varindexct: index count
'ccc  = d_varlongct: length
'd    = d_vardecimalct: decimals

	  'do we have a numeric field=1 or alpha=6
	  s_vartype = "1"
	  $ift s_vardecimalct = " ": s_vartype = "6"

	  'put s_varsize together
	  s_varindexct = "0001"
	  s_varsize = s_vartype + s_varindexct + s_varlongct 
	  $app s_varsize, s_vardecimalct

	  'zero fill
	  $swp s_varsize, " ", "0"

	  'store in sg_rpgvarnames,sg_rpgvarsizes
	  sg_pass1 = s_varname
	  sg_pass2 = s_varsize
	  sg_pass3 = "C"
	  sub_rpg_variable_info_collect
    endi
ends sub_rpg_valid_varsize_cline


subr sub_rpg_valid_var_all
'updated 2003/11/18
'rpg validate var all
    vari s_any, d_any, s_dot, d_dot, s_out
    vari d_loop, d_filebyte, s_record, d_good, d_count
    vari s_6code, s_varname, s_varsize, s_fromsubr

    $sys sg_subroutine, 2
    s_fromsubr = sg_subroutine
    dift dg_tdebug = 1
	  sg_pass1 = sg_subroutine
	  sub_return
    endi

    d_count = 0
    dg_record = 0

    d_loop = 1
    dwhi d_loop = 1
	  d_good = 1

	  sg_pass1 = s_fromsubr
	  sub_rpg_read_record
	  s_record = sg_pass1

	  dift dg_record = 0
		dinc d_good
		dinc d_loop
	  endi
	  dift d_good = 1
		'get code in byte 6
		$cut s_6code, s_record, 6, 1

		'skip if not C or O
		d_any = 2
		$ift s_6code = "C": d_any = 1
		$ift s_6code = "O": d_any = 1
		dift d_any <> 1: dinc d_good
	  endi
	  dift d_good <> 1: s_6code = "X"

	  $ift s_6code = "C"
		sg_pass1 = s_record
		sub_rpg_valid_var_all_cline
	  endi
	  $ift s_6code = "O"
		sg_pass1 = s_record
		sub_rpg_valid_var_all_oline
	  endi
    endw
'fline    1 eline   2 iline   3         4         5         6
'123456789012345678901234567890123456789012345678901234567890
'    .FTERMIN  ID  F      80            $STDIN
'    .FTERMOUT O   F      80            $STDLST
'    .E                    ZZ      1  80  1 2
'    .IFILEINP AA
'    .I                                       10  20 VARIAB
'cline    1 oline   2         3         4         5         6
'123456789012345678901234567890123456789012345678901234567890
'    .CSR 01 02 03FACTOR1   COMMDFACTOR2   RESULT  92H919293
'    .OFILENAMEE 12     01 02 03OLINE
'    .O        E        01 02 03VARIABJB 132 "HEADING LINE  "
' var size = 99998887, 9999=how many, 888=length, 7=decimals
    $sys sg_subroutine, 2
    dift dg_tdebug = 1
	  sg_pass1 = sg_subroutine
	  sub_return
    endi
ends sub_rpg_valid_var_all


subr sub_rpg_valid_var_all_cline
'updated 2004/12/31
'rpg validate all variables in c-line
    vari s_any, d_any, s_dot, d_dot, s_out
    vari s_record, d_process, d_good
    vari s_comm, s_field, s_var1, s_var2

'cline    1         2         3         4         5         6
'123456789012345678901234567890123456789012345678901234567890
'    .CSR 01 02 03FACTOR1   COMMDFACTOR2   RESULT  92H919293
    s_record = sg_pass1

    d_process = 1
    s_dot = "ADD  ,BITOF,BITON,COMP ,DIV  ,FNDJW,"
    $app s_dot, "LOKUP,MOVE ,MOVEA,MOVEL,MULT ,MVR  ,"
    $app s_dot, "PUTJW,SETOF,SETON,SORTA,SQRT ,SUB  ,"
    $app s_dot, "TESTN,TIME ,TIME2,XFOOT,Z-ADD,Z-SUB,"

    'others
    'TAG,GOTO,EXSR,BEGSR,ENDSR,READ,READP,CHAIN
    'LOCK,UNLCK,SETLL,EXCPT

    $cut s_comm, s_record, 28, 5
    $lok d_any, s_dot, 1, s_comm
    dift d_any = 0: dinc d_process

    dift d_process = 1
	  'validate the variable and get the type
	  $cut s_field, s_record, 18, 10

	  'cannot have *BLANK in field1
	  $trr s_any, s_field
	  $ift s_any = "*BLANK"
		sg_pass1 = "*BLANK in field1"
		sub_error
	  endi

	  sg_pass1 = s_field
	  sub_field_info_return
	  'not interested in actual fields from above

        'validate the variable and get the type
	  $cut s_field, s_record, 33, 10
	  sg_pass1 = s_field
	  sub_field_info_return
	  'not interested in actual fields from above

	  'validate the variable and get the type
	  $cut s_field, s_record, 43, 6
	  sg_pass1 = s_field
	  sub_field_info_return
	  'not interested in actual fields from above
    endi    
ends sub_rpg_valid_var_all_cline


subr sub_rpg_valid_var_all_oline
'updated 2005/04/03, 2003/04/09
'validate variables in o-line
    vari s_any, d_any, s_dot, d_dot, s_tap, s_out
    vari s_record, d_good, d_process, s_field

'oline    1         2         3         4         5         6
'123456789012345678901234567890123456789012345678901234567890
'    .O                 01 02 03VARIABJB 132 "HEADING LINE  "
    s_record = sg_pass1
    d_process = 1

    $cut s_any, s_record, 7, 9
    $trb s_any, s_any
    $len d_any, s_any
    dift d_any > 0: dinc d_process

    dift d_process = 1
	  $cut s_field, s_record, 32, 6
	  s_tap = "PAGE  ,UDATE ,"
	  $lok d_any, s_tap, 1, s_field
	  dift d_any > 0: dinc d_process
    endi
    dift d_process = 1
	  'validate the variable and get the type
	  sg_pass1 = s_field
	  sub_field_info_return
	  'not interested in actual fields from above
    endi
ends sub_rpg_valid_var_all_oline


subr sub_variable_info_return
'updated 2005/04/09, 2005/04/08, 2003/11/25
'from sg_rpgvarnames and sg_rpgvarsizes return variable info
    vari s_any, d_any, s_dot, d_dot, s_out
    vari d_vartype, d_varindexct, d_varlongct, d_vardecimalct
    vari s_varname, s_varsize

'123456789 sg_rpgvarnames 9 long
'abbbbcccd sg_rpgvarsizes 9 long
'a    = d_vartype: 1=numeric,2=numeric array,6=alpha,7=alpha array
'bbbb = d_varindexct: index count
'ccc  = d_varlongct: length
'd    = d_vardecimalct: decimals

    s_varname = sg_pass1

    dift dg_tdebug = 1
	  $sys s_any, 2
	  $out s_any
	  $out "sg_pass1='" + s_varname + "'"
	  sub_return
    endi

    $app s_varname, sg_20blanks
    $cut s_varname, s_varname, 1, 9
    $cup s_varname, s_varname

    d_vartype = 0
    d_varindexct = 0
    d_varlongct = 0
    d_vardecimalct = 0

    'find s_varname in sg_rpgvarnames
    $lok d_dot, sg_rpgvarnames, 1, s_varname

    dift d_dot > 0
	  $cut s_varsize, sg_rpgvarsizes, d_dot, 9
	  $ch$ s_any, "9", 9
	  $isp d_any, s_varsize, s_any
        dift d_any = 1
		'variable type
	      $cut s_any, s_varsize, 1, 1
		$tod d_vartype, s_any

		'index count
	      $cut s_any, s_varsize, 2, 4
		$tod d_varindexct, s_any

		'long count
	      $cut s_any, s_varsize, 6, 3
		$tod d_varlongct, s_any

		'decimal count
	      $cut s_any, s_varsize, 9, 1
		$tod d_vardecimalct, s_any
	  else
		sg_pass1 = s_varname + " is " + s_varsize
		sub_error
        endi
    endi

    dift dg_tdebug = 1
	  s_any = "vartype=" + d_vartype
	  $app s_any, ", varindexct=" + d_varindexct
	  $app s_any, ", varlongct=" + d_varlongct
	  $app s_any, ", vardecimalct=" + d_vardecimalct
	  sg_pass1 = s_any
	  sub_return
    endi

    dg_pass1 = d_vartype
    dg_pass2 = d_varindexct
    dg_pass3 = d_varlongct
    dg_pass4 = d_vardecimalct    

    sg_pass1 = s_varsize
ends sub_variable_info_return


subr sub_variable_lookup
'updated 2006/11/01, 2006/04/25, 2003/11/24
    vari s_any, d_any, s_dot, d_dot, s_out
    vari d_loop, s_varname, s_varsize, s_vartype
    vari d_vartype, d_indexct, d_longct, d_decimalct

    d_loop = dg_process
    dwhi d_loop = 1
	  $inp s_varname, "enter variable name or return"
	  $ift s_varname = "*": s_varname = sg_nothing
	  $ift s_varname = sg_nothing
		dinc d_loop
	  else
'123456789 sg_rpgvarnames 9 long
'abbbbcccd sg_rpgvarsizes 9 long
'a    = d_vartype: 1=numeric,2=numeric array,6=alpha,7=alpha array
'bbbb = d_varindexct: index count
'ccc  = d_varlongct: length max=256
'd    = d_vardecimalct: decimals
		sg_pass1 = s_varname
		sub_variable_info_return
		d_vartype = dg_pass1
		d_indexct = dg_pass2
		d_longct = dg_pass3
		d_decimalct = dg_pass4
		s_varsize = sg_pass1

		s_vartype = "none"
		dift d_vartype = 1: s_vartype = "numeric variable"
		dift d_vartype = 2: s_vartype = "numeric array"
		dift d_vartype = 6: s_vartype = "alpha variable"
		dift d_vartype = 7: s_vartype = "alpha array"

		$out s_vartype
		s_out = "vartype=" + d_vartype
		$app s_out, ", indexct=" + d_indexct
		$app s_out, ", longct=" + d_longct
		$app s_out, ", decimalct=" + d_decimalct
		$app s_out, ", size=" + s_varsize
		$out s_out
 	  endi
    endw
ends sub_variable_lookup


subr sub_field_info_return
'updated 2005/04/08, 2005/01/02
'validate the variable and get type and return parts
    vari s_any, d_any, s_dot, d_dot, s_out, d_action
    vari d_process, d_error, d_byte
    vari s_expfieldtype, d_comma
    vari s_testfield, s_var1, s_var2
    vari d_vartype1, d_indexct1, d_longct1, d_decimalct1
    vari d_vartype2, d_indexct2, d_longct2, d_decimalct2
    vari d_expfieldtype1, d_expfieldtype2
    vari s_expfieldvar1, s_expfieldvar2
    vari s_expcfield, s_expcindex
    vari s_lowtestfield1, s_lowtestfield2
    vari s_expvarsize1, s_expvarsize2
'd_fieldtype
'1=bad field
'2=blank
'6=*BLANK
'7=*ZEROS
'8=UDATE
'11=numeric literal
'12=numeric var
'13=numeric array with index
'14=numeric array no index
'21=alpha literal
'22=alpha var
'23=alpha array with index
'24=alpha array no index

    s_testfield = sg_pass1

    dift dg_tdebug = 1
	  $sys s_any, 2
	  $out s_any
	  $out "sg_pass1='" + s_testfield + "'"
	  sub_return
    endi

    $trb s_testfield, s_testfield

    'beg dg_errnumber,d_error,3200
    d_error = 0
    d_process = 1
    d_action = 0

    'initialize out fields
    d_expfieldtype1 = 2
    d_expfieldtype2 = 2
    s_expfieldvar1 = sg_nothing
    s_expfieldvar2 = sg_nothing
    s_expfieldtype = "none"
    s_expcfield = sg_nothing
    s_expcindex = sg_nothing
    s_expvarsize1 = sg_nothing
    s_expvarsize2 = sg_nothing

    d_indexct1 = 0
    d_longct1 = 0
    d_decimalct1 = 0
    d_longct2 = 0
    d_decimalct2 = 0

    'do we have nothing, s_testfield has been trimmed
    $len d_any, s_testfield
    dift d_any = 0
	  d_expfieldtype1 = 2
	  s_expfieldtype = "blank"
	  dinc d_process
    endi

    'do we have *BLANK
    $ift s_testfield = "*BLANK"
	  d_expfieldtype1 = 6
	  s_expfieldtype = s_testfield
	  dinc d_process
    endi
    'do we have *ZEROS
    $ift s_testfield = "*ZEROS"
	  d_expfieldtype1 = 7
	  s_expfieldtype = s_testfield
	  dinc d_process
    endi
    'do we have UDATE
    $ift s_testfield = "UDATE"
	  d_expfieldtype1 = 8
	  s_expfieldtype = s_testfield
	  dinc d_process
    endi

    dift d_process = 1
        'do we have a string literal
        $cut s_any, s_testfield, 1, 1
        $ift s_any = #"#
	      $off s_any, s_testfield, 1
	      $ift s_any = #"#
		    'get d_longct1
		    $len d_any, s_testfield
		    d_longct1 = d_any - 2
		    d_indexct1 = 1

		    s_expfieldvar1 = s_testfield
		    d_expfieldtype1 = 21
		    s_expfieldtype = "string literal"
		    s_expcfield = s_testfield
		    dinc d_process
	      else
		    d_error = 3201
		    dinc d_process
	      endi
        endi
    endi
    dift d_process = 1
	  'do we have a numeric literal
	  $isd d_any, s_testfield
	  dift d_any = 1
		'take off leading zeros
		sg_pass1 = s_testfield
		sub_take_off_leading_zeros
		s_testfield = sg_pass1

		'we cannot have a comma
		$lok d_any, s_testfield, 1, ","
		dift d_any > 0
		    d_error = 3203
		else
		    'get d_decimalct
		    $lok d_dot, s_testfield, 1, "."
		    $len d_any, s_testfield
		    dift d_dot > 0
			  d_decimalct1 = d_any - d_dot
		    else
			  d_decimalct1 = 0
		    endi
			  
		    s_expfieldvar1 = s_testfield
		    d_expfieldtype1 = 11
		    s_expfieldtype = "numeric literal"
		    s_expcfield = s_testfield
		    dinc d_process
		endi
	  endi
    endi
    dift d_process = 1
	  'do we have an index
	  $lok d_comma, s_testfield, 1, ","
	  dift d_comma = 0: d_action = 1
    endi
    dift d_action = 1
	  'no index
	  sg_pass1 = s_testfield
	  sub_variable_info_return
	  d_vartype1 = dg_pass1
	  d_indexct1 = dg_pass2
	  d_longct1 = dg_pass3
	  d_decimalct1 = dg_pass4
	  s_expvarsize1 = sg_pass1

	  s_var1 = s_testfield
	  $clo s_lowtestfield1, s_testfield

'123456789 sg_rpgvarnames 9 long
'abbbbcccd sg_rpgvarsizes 9 long
'a    = d_vartype: 1=numeric,2=numeric array,6=alpha,7=alpha array
'bbbb = d_varindexct: index count
'ccc  = d_varlongct: length
'd    = d_vardecimalct: decimals

	  dift d_vartype1 = 0
	      d_error = 3204
	  else
	      dift d_vartype1 = 1
		    'numeric variable
	          s_expfieldvar1 = s_testfield
		    d_expfieldtype1 = 12
		    s_expfieldtype = "numeric variable"
		    s_expcfield = "dg_" + s_lowtestfield1
	      endi
	      dift d_vartype1 = 2		    
		    'numeric array with no index
	          s_expfieldvar1 = s_testfield
		    d_expfieldtype1 = 14
		    s_expfieldtype = "numeric array"
		    s_expcfield = "dga_" + s_lowtestfield1
	      endi
	      dift d_vartype1 = 6
		    'alpha variable
	          s_expfieldvar1 = s_testfield
		    d_expfieldtype1 = 22
 		    s_expfieldtype = "alpha variable"
		    s_expcfield = "sg_" + s_lowtestfield1
	      endi
	      dift d_vartype1 = 7
		    'alpha array
	          s_expfieldvar1 = s_testfield
		    d_expfieldtype1 = 24
		    s_expfieldtype = "alpha array"
		    s_expcfield = "sga_" + s_lowtestfield1
	      endi
	  endi
	  dinc d_process
    endi

'123456789 sg_rpgvarnames 9 long
'abbbbcccd sg_rpgvarsizes 9 long
'a    = d_vartype: 1=numeric,2=numeric array,6=alpha,7=alpha array
'bbbb = d_varindexct: index count
'ccc  = d_varlongct: length
'd    = d_vardecimalct: decimals

    dift d_process = 1
	  'we have an index comma at d_comma
        $par s_var1, s_testfield, ",", 1
        $par s_var2, s_testfield, ",", 2

	  $tlo s_lowtestfield1, s_var1
	  $tlo s_lowtestfield2, s_var2

	  'validate s_var1
	  sg_pass1 = s_var1
	  sub_variable_info_return
	  d_vartype1 = dg_pass1
	  d_indexct1 = dg_pass2
	  d_longct1 = dg_pass3
	  d_decimalct1 = dg_pass4
	  s_expvarsize1 = sg_pass1

	  'd_vartype1 can only be 2 or 7
	  d_any = d_vartype1
	  dift d_any = 7: d_any = 2
	  dift d_any <> 2
		d_error = 3205
		dinc d_process
	  endi
    endi
    dift d_process = 1
	  'for s_var1 remembering we have an index
        dift d_vartype1 = 2		    
	      'numeric array with index
		s_expfieldvar1 = s_lowtestfield1
	      d_expfieldtype1 = 13
	      s_expfieldtype = "numeric array with index"

		'put the index on later
		s_expcfield = "dga_" + s_lowtestfield1
        endi
        dift d_vartype1 = 7
	      'alpha array with index
		$trb s_expfieldvar1, s_var1
	      d_expfieldtype1 = 23
	      s_expfieldtype = "alpha array with index"

		'put the index on later
		s_expcfield = "sga_" + s_lowtestfield1
        endi
    endi
    dift d_process = 1
        'is index s_lowtestfield2 a numeric literal
        $ist d_any, s_lowtestfield2, "9"
        dift d_any = 1
		'get rid of leading zeros
		$tod d_dot, s_lowtestfield2
		s_lowtestfield2 = d_dot

		'validate the number as an index
		d_any = 2
		dift d_dot < 1: d_any = 1
		dift d_dot > d_indexct1: d_any = 1
		dift d_any = 1: d_error = 3207

		s_expfieldvar2 = s_lowtestfield2
		d_expfieldtype2 = 11
		$app s_expfieldtype, " literal index"

		dift d_vartype1 = 2
		    'numeric array, put on the numeric literal index
		    $app s_expcfield, "[" + s_lowtestfield2 + " - 1]"
		endi

		dift d_vartype1 = 7
		    'alpha array, put on the numeric literal index
		    $app s_expcfield, "[(" + s_lowtestfield2 
		    $app s_expcfield, " - 1) * " + d_longct1 + "]"
		endi

		dinc d_process
	  endi
    endi
    dift d_process = 1
	  'validate s_lowtestfield2 as a numeric variable
	  sg_pass1 = s_lowtestfield2
	  sub_variable_info_return
	  d_vartype2 = dg_pass1
	  d_indexct2 = dg_pass2
	  d_longct2 = dg_pass3
	  d_decimalct2 = dg_pass4
	  s_expvarsize2 = sg_pass1

	  'do we have an error
	  d_dot = 2
	  dift d_vartype2 <> 1: d_dot = 1
	  dift d_indexct2 <> 1: d_dot = 1
	  dift d_decimalct2 <> 0: d_dot = 1

	  dift d_dot = 1
		d_error = 3208
	  else
	      s_expfieldvar2 = s_lowtestfield2
	      d_expfieldtype2 = 12
	      $app s_expfieldtype, " variable index"
		s_expcindex = "dg_" + s_lowtestfield2
		
		dift d_vartype1 = 2
		    'numeric array, put on the numeric variable index
		    $app s_expcfield, "[tfni_index(dg_"
		    $app s_expcfield, s_lowtestfield2 + ") - 1]"
		endi

		dift d_vartype1 = 7
		    'alpha array, put on the numeric variable index
		    $app s_expcfield, "[(tfni_index(dg_"
		    $app s_expcfield, s_lowtestfield2 + ") - 1) * "
		    $app s_expcfield, d_longct1 + "]"
		endi
	  endi
    endi
    dift d_error > 0
        'end dg_errnumber,d_error,3200
	  dg_errnumber = d_error
'out	  d_expfieldtype1 = 0
'out	  d_expfieldtype2 = 0
	  s_any = "sub_field_info_return, bad field="
	  $app s_any, s_testfield
	  sg_pass1 = s_any
	  sub_error
    endi

    dift dg_tdebug = 1
	  $out "s_testfield=" + s_testfield
	  sg_pass1 = "s_expcfield=" + s_expcfield
	  sub_return
    endi

'd_expfieldtype1
'1=error
'2=blank
'6=*BLANK
'7=*ZEROS
'8=UDATE
'11=number
'12=numeric var
'13=numeric array with index
'14=numeric array no index
'21=alpha literal
'22=alpha var
'23=alpha array with index
'24=alpha array no index

    dg_pass1 = d_expfieldtype1
    dg_pass2 = d_expfieldtype2
    dg_pass3 = d_indexct1
    dg_pass4 = d_longct1
    dg_pass5 = d_decimalct1
    dg_pass6 = d_longct2
    dg_pass7 = d_decimalct2
   
    sg_pass1 = s_expfieldvar1
    sg_pass2 = s_expfieldvar2
    sg_pass3 = s_expfieldtype
    sg_pass4 = s_expcfield
    sg_pass5 = s_expvarsize1
    sg_pass6 = s_expvarsize2
    sg_pass7 = s_expcindex
ends sub_field_info_return


subr sub_rpg_variable_info_collect
'updated 2006/11/01, 2006/10/31, 2005/04/07, 2004/08/05
'save var info in sg_rpgvarnames,sg_rpgvarsizes
'var in sg_pass1, size in sg_pass2, line code in sg_pass3
    vari s_any, d_any, s_dot, d_dot, s_out
    vari s_varname, s_varsize, d_byte, d_good
    vari s_oldname, s_oldsize, s_linecode, s_error
    vari d_vartype, d_varindexct, d_varlongct, d_vardecimalct

'123456789 sg_rpgvarnames 9 long
'abbbbcccd sg_rpgvarsizes 9 long
'a    = d_vartype: 1=numeric,2=numeric array,6=alpha,7=alpha array
'bbbb = d_varindexct: index count
'ccc  = d_varlongct: length
'd    = d_vardecimalct: decimals

    s_varname = sg_pass1
    s_varsize = sg_pass2
    s_linecode = sg_pass3

    $sys sg_subroutine, 2
    dift dg_tdebug = 1
	  s_out = "s_varname=" + s_varname
	  $app s_out, ", s_varsize=" + s_varsize
	  $app s_out, ", s_linecode=" + s_linecode
	  $out s_out
	  sg_pass1 = sg_subroutine
	  sub_return
    endi

    d_good = 1

    'is s_varname a valid name
    sg_pass1 = s_varname
    sub_rpg_valid_identifier
    dift dg_error = 1
	  s_error = "bad identifier"
	  dinc d_good
    endi

    's_varname is 6 long
    's_varsize is 9 long
    's_linecode is 1 long

    'make sure both are 9 long
    $app s_varname, sg_20blanks
    $cut s_varname, s_varname, 1, 9

    $app s_varsize, sg_20blanks
    $cut s_varsize, s_varsize, 1, 9

    'upper case s_varname, zero filled s_varsize
    $cup s_varname, s_varname
    $swp s_varsize, " ", "0"

    $ch$ s_any, "9", 9
    $isp d_any, s_varsize, s_any
    dift d_any <> 1
	  s_error = "s_varsize not numeric"
	  dinc d_good
    endi

'123456789 sg_rpgvarnames 9 long
'abbbbcccd sg_rpgvarsizes 9 long
'a    = d_vartype: 1=numeric,2=numeric array,6=alpha,7=alpha array
'bbbb = d_varindexct: index count
'ccc  = d_varlongct: length max=256
'd    = d_vardecimalct: decimals
    dift d_good = 1
        $cut s_any, s_varsize, 1, 1
        $tod d_vartype, s_any

        $cut s_any, s_varsize, 2, 4
        $tod d_varindexct, s_any

        $cut s_any, s_varsize, 6, 3
        $tod d_varlongct, s_any

        $cut s_any, s_varsize, 9, 1
        $tod d_vardecimalct, s_any

	  'max d_varlongct is 256
	  dift d_varlongct > 256
		s_error = "d_varlongct > 256"
		dinc d_good
	  endi

        'do we have s_varname already
        $lok d_byte, sg_rpgvarnames, 1, s_varname
    endi

    dift d_good <> 1: d_byte = -1

    dift d_byte > 0
	  'we have s_varname already get s_oldname,s_oldsizes
	  $cut s_oldname, sg_rpgvarnames, d_byte, 9
	  $cut s_oldsize, sg_rpgvarsizes, d_byte, 9

	  'is s_oldsize made up of just spaces put in s_varsize
	  $isc d_any, s_oldsize, " "
	  dift d_any = 1
		'we need to put s_varsize in for s_varname
		dift dg_tdebug = 1
	          s_out = "old var=" + s_oldname
		    $app s_out, ", size=" + s_oldsize
		    $out s_out

	          s_out = "new var=" + s_varname
		    $app s_out, ", size=" + s_varsize
		    $out s_out
		endi

		$rep sg_rpgvarsizes, d_byte, s_varsize
	  else
'123456789 sg_rpgvarnames 9 long
'abbbbcccd sg_rpgvarsizes 9 long
'a    = d_vartype: 1=numeric,2=numeric array,6=alpha,7=alpha array
'bbbb = d_varindexct: index count
'ccc  = d_varlongct: length max=256
'd    = d_vardecimalct: decimals
		'we have an earlier s_oldsize
		$ift s_linecode = "I"
		    'if previous an array we do not need s_varsize
		    $cut s_any, s_oldsize, 1, 1
		    $ift s_any = "7": $ch$ s_varsize, " ", 9	    
		endi

		'if s_varsize not blanks
		$isc d_any, s_varsize, " "
		dift d_any <> 1 
		    $ift s_oldsize <> s_varsize
		        s_out = "old var=" + s_oldname
			  $app s_out, ", size=" + s_oldsize
			  $out s_out

		        s_out = "new var=" + s_varname
			  $app s_out, ", size=" + s_varsize
			  $out s_out

		        sg_pass1 = "redefined variable"
			  sub_error
		    endi
		endi
	  endi	  
    endi

    dift d_byte = 0
	  'we do not have s_varname, so store in strings
        $app sg_rpgvarnames, s_varname + ","
        $app sg_rpgvarsizes, s_varsize + ","
    endi

    dift d_good <> 1
	  $out s_error
	  sg_pass1 = "bad var=" + s_varname
	  $app sg_pass1, ", varsize=" + s_varsize
	  sub_error
    endi
ends sub_rpg_variable_info_collect


subr sub_rpg_valid_indicators
'updated 2004/04/02
'rpg validate indicators
    vari s_any, d_any, s_dot, d_dot, s_out
    vari d_loop, d_filebyte, s_record, d_good, d_count
    vari s_6code, d_byte, d_long
    vari s_clinecommand, s_fromsubr
    vari s_commands1, s_commands2

    $sys sg_subroutine, 2
    s_fromsubr = sg_subroutine
    dift dg_tdebug = 1
	  sg_pass1 = sg_subroutine
	  sub_return
    endi

    's_commands1 must have set in 54/60
    s_commands1 = "SETON,SETOF,COMP ,"

    's_commands2 must have set in 58/59
    s_commands2 = "LOKUP,FNDJW,SETJW,READ ,READP,"
    $app s_commands2, "LOCK ,UNLCK,"

    d_count = 0
    dg_record = 0

    d_loop = 1
    dwhi d_loop = 1
	  d_good = 1

	  sg_pass1 = s_fromsubr
	  sub_rpg_read_record
	  s_record = sg_pass1

	  dift dg_record = 0
		s_6code = "X"
		dinc d_good
		dinc d_loop
	  endi
	  dift d_good = 1
		'get code in byte 6
		$cut s_6code, s_record, 6, 1

		'skip if not C or O
		d_any = 2
		$ift s_6code = "C": d_any = 1
		$ift s_6code = "O": d_any = 1
		dift d_any <> 1: s_6code = "X"
	  endi
	  $ift s_6code = "C"
		'calculation indicators
'cline    1         2         3         4         5         6
'123456789012345678901234567890123456789012345678901234567890
'    .CSR 01 02 03FACTOR1   COMMDFACTOR2   RESULT  92H919293
		'do the use indicators
		$cut sg_pass1, s_record, 9, 3
		dg_pass1 = 3
		sub_rpg_valid_indicators_proc

		$cut sg_pass1, s_record, 12, 3
		dg_pass1 = 3
		sub_rpg_valid_indicators_proc

		$cut sg_pass1, s_record, 15, 3
		dg_pass1 = 3
		sub_rpg_valid_indicators_proc

		'do the set indicators
	      $cut sg_pass1, s_record, 54, 2
	      dg_pass1 = 3
	      sub_rpg_valid_indicators_proc

	      $cut sg_pass1, s_record, 56, 2
	      dg_pass1 = 3
	      sub_rpg_valid_indicators_proc

	      $cut sg_pass1, s_record, 58, 2
	      dg_pass1 = 3
	      sub_rpg_valid_indicators_proc

		$cut s_clinecommand, s_record, 28, 5

		'CHAIN,
		$ift s_clinecommand = "CHAIN"
		    $cut s_any, s_record, 54, 2
		    $ist d_any, s_any, "9"
		    dift d_any <> 1
			  sg_pass1 = "error=CHAIN"
			  sub_error
		    endi		    
		endi

		'SETON,SETOF,COMP ,
		$lok d_any, s_commands1, 1, s_clinecommand
		dift d_any > 0
		    $cut s_any, s_record, 54, 6
		    $isc d_any, s_any, " "
		    dift d_any = 1
			  sg_pass1 = "error=" + s_commands1
			  sub_error
		    endi		    
		endi

		'LOKUP,FNDJW,SETJW,READ ,READP,LOCK ,UNLCK,
		$lok d_any, s_commands2, 1, s_clinecommand
		dift d_any > 0
		    $cut s_any, s_record, 58, 2
		    $ist d_any, s_any, "9"
		    dift d_any <> 1
			  sg_pass1 = "error=" + s_commands2
			  sub_error
		    endi		    
		endi
	  endi
	  $ift s_6code = "O"
		'output indicators
'oline    1         2         3         4         5         6
'123456789012345678901234567890123456789012345678901234567890
'    .O                 01 02 03VARIABJB 132 "HEADING LINE  "
		$cut sg_pass1, s_record, 23, 3
		dg_pass1 = 3
		sub_rpg_valid_indicators_proc

		$cut sg_pass1, s_record, 26, 3
		dg_pass1 = 3
		sub_rpg_valid_indicators_proc

		$cut sg_pass1, s_record, 29, 3
		dg_pass1 = 3
		sub_rpg_valid_indicators_proc
	  endi
    endw

    'make sure all indicators used are set somewhere
    $len d_long, sg_indicatuse
    d_byte = 1
    dwhi d_byte < d_long
	  $cut s_dot, sg_indicatuse, d_byte, 1
	  $lok d_dot, sg_indicatset, 1, s_dot
	  dift d_dot = 0: $out "undefined indicator=" + s_dot

	  d_byte = d_byte + 3
    endw

    'indicator LR should be set somewhere ig_LR which is 1 or 2
    $lok d_any, sg_indicatset, 1, "LR"
    dift d_any = 0: $out "no LR indicator set"

    dift dg_tdebug = 1
	  'show the indicators
	  $sor s_dot, sg_indicatuse, 3
	  d_dot = 1
	  dwhi d_dot <= d_long
		$cut s_any, s_dot, d_dot, 72
		$out s_any
		d_dot = d_dot + 72
	  endw
    endi

    d_any = d_long \ 3
    $out "indicators set/used=" + d_any

    $sys sg_subroutine, 2
    dift dg_tdebug = 1
	  sg_pass1 = sg_subroutine
	  sub_return
    endi
ends sub_rpg_valid_indicators


subr sub_rpg_valid_indicators_proc
'updated 2004/03/30
'validate indicators in sg_pass1 
'sg_pass1 is 2 or 3 long
'dg_pass1=1 means indicator, 2=none, 3=maybe
    vari s_any, d_any, s_dot, d_dot, s_tap, s_out
    vari s_indicat, s_num, d_long, d_error, d_yesnomaybe

    s_indicat = sg_pass1
    d_yesnomaybe = dg_pass1

    'beg dg_errnumber,d_error,1300
    d_error = 0
    $trb s_any, s_indicat
    $len d_long, s_any

    dift d_yesnomaybe = 1
	  'yes we must have an indicator
	  dift d_long <> 2
		dift d_long <> 3: d_error = 1301
	  endi
    endi
    dift d_yesnomaybe = 2
	  'no we must not have an indicator
	  dift d_long <> 0: d_error = 1302
    endi
    dift d_yesnomaybe = 3
	  'maybe we have an indicator
	  d_any = 2
	  dift d_long = 0: d_any = 1
	  dift d_long = 2: d_any = 1
	  dift d_long = 3: d_any = 1
	  dift d_any <> 1: d_error = 1303
    endi
    dift d_error > 0: d_long = 0

    dift d_long > 0
        $len d_long, s_indicat
        dift d_long = 3
		'we have a use indicator
		$cut s_any, s_indicat, 1, 1
		s_tap = " N"
		$lok d_any, s_tap, 1, s_any
		dift d_any = 0: d_error = 1304

		$cut s_num, s_indicat, 2, 2
		$ist d_any, s_num, "9"
		dift d_any <> 1: d_error = 1305

		dift d_error = 0
		    $lok d_dot, sg_indicatuse, 1, s_num
		    dift d_dot = 0: $app sg_indicatuse, s_num + ","
		endi		
        endi
        dift d_long = 2
		'we have a set indicator
		$ist d_any, s_indicat, "9"
		dift d_any <> 1
		    $ift s_indicat <> "LR": d_error = 1306
		endi
		dift d_error = 0
		    $lok d_dot, sg_indicatuse, 1, s_indicat
		    dift d_dot = 0
			  $app sg_indicatset, s_indicat + ","
		    endi
		endi		
        endi
    endi
    dift d_error > 0
        'end dg_errnumber,d_error,1300
	  dg_errnumber = d_error
	  dift d_yesnomaybe = 1
		sg_pass1 = "bad or missing indicator=" + s_indicat
 	      sub_error
	  endi
	  dift d_yesnomaybe = 2
		sg_pass1 = "bad or improper indicator=" + s_indicat
 	      sub_error
	  endi
	  dift d_yesnomaybe = 3
		sg_pass1 = "bad or improper indicator=" + s_indicat
 	      sub_error
	  endi
    endi
ends sub_rpg_valid_indicators_proc


subr sub_rpg_valid_varsize_strings
'updated 2003/11/30
'validate global variables in sg_rpgvarnames,sg_rpgvarsizes
'to see if each varname has a valid varsize
    vari s_any, d_any, s_dot, d_dot, s_out
    vari s_varname, s_varsize, d_byte, d_loop, d_long
    vari d_varnumct, d_varalphact, d_arraynumct, d_arrayalphact
    vari s_fromsubr, d_count, d_vartype, d_varindexct

    $sys sg_subroutine, 2
    s_fromsubr = sg_subroutine
    dift dg_tdebug = 1
	  sg_pass1 = sg_subroutine
	  sub_return
    endi

    d_varnumct = 0
    d_varalphact = 0
    d_arraynumct = 0
    d_arrayalphact = 0

    $len d_long, sg_rpgvarsizes
    d_count = 0
    d_byte = 1
    d_loop = 1
    dwhi d_loop = 1
	  $sho s_fromsubr + "=" + d_count
	  $cut s_varsize, sg_rpgvarsizes, d_byte, 9
	  $trb s_any, s_varsize

	  'test for length=9
	  $len d_any, s_any
	  dift d_any <> 9: d_any = 0

	  'test for numeric
	  $ch$ s_dot, "9", 9
	  dift d_any = 9: $isp d_any, s_any, s_dot
	  dift d_any <> 1
		$cut s_varname, sg_rpgvarnames, d_byte, 9
		sg_pass1 = "undefined='" + s_varname
		$app sg_pass1, "', size='" + s_varsize + "'"
		sub_error
	  else
'123456789 sg_rpgvarnames 9 long
'abbbbcccd sg_rpgvarsizes 9 long
'a    = d_vartype: 1=numeric,2=numeric array,6=alpha,7=alpha array
'bbbb = d_varindexct: index count
'ccc  = d_varlongct: length
'd    = d_vardecimalct: decimals
		'counts
		dinc d_count
		$cut s_any, s_varsize, 1, 1
		$tod d_vartype, s_any

		dift d_vartype = 1: dinc d_varnumct
		dift d_vartype = 2: dinc d_arraynumct
		dift d_vartype = 6: dinc d_varalphact
		dift d_vartype = 7: dinc d_arrayalphact
	  endi

	  '9 long with commas between
	  d_byte = d_byte + 10
	  dift d_byte > d_long: dinc d_loop
    endw
    $out s_fromsubr + "=" + d_count
    $out "ct varnumeric  =" + d_varnumct
    $out "ct varalpha    =" + d_varalphact
    $out "ct arraynumeric=" + d_arraynumct
    $out "ct arrayalpha  =" + d_arrayalphact

    $sys sg_subroutine, 2
    dift dg_tdebug = 1
	  sg_pass1 = sg_subroutine
	  sub_return
    endi
ends sub_rpg_valid_varsize_strings


subr sub_rpg_valid_format
'updated 2004/12/23
'validate formats of rpg lines
'we have fileinfo, variable info, indicator info already
    vari s_any, d_any, s_dot, d_dot, s_out
    vari s_record, d_loop, d_good, s_code, s_fromsubr

    $sys sg_subroutine, 2
    s_fromsubr = sg_subroutine
    dift dg_tdebug = 1
	  sg_pass1 = sg_subroutine
	  sub_return
    endi

    dg_record = 0

    d_loop = 1
    dwhi d_loop = 1
	  d_good = 1

	  sg_pass1 = s_fromsubr
	  sub_rpg_read_record
	  s_record = sg_pass1

	  dift dg_record = 0
		dinc d_good
		dinc d_loop
	  endi
	  dift d_good = 1
		'we have records to examine
		$cut s_code, s_record, 6, 1
		$ift s_code = "C"
		    sg_pass1 = s_record
		    sub_rpg_valid_format_cline
		endi
		$ift s_code = "O"
		    sg_pass1 = s_record
		    sub_rpg_valid_format_oline
		endi
	  endi
    endw

    $sys sg_subroutine, 2
    dift dg_tdebug = 1
	  sg_pass1 = sg_subroutine
	  sub_return
    endi
ends sub_rpg_valid_format


subr sub_rpg_valid_format_cline
'updated 2005/04/03, 2005/01/18, 2004/12/23
'validate the format of a cline
    vari s_any, d_any, s_dot, d_dot, s_tap, s_out
    vari s_record, d_process, d_good, d_error, s_code
    vari s_indicators1, s_factor1, s_command, s_factor2
    vari s_result, s_indicators2
    vari d_fieldtype1, d_fieldtype2, d_fieldtype3
    vari s_fieldtype1, s_fieldtype2, s_fieldtype3
    vari s_fieldlett1, s_fieldlett2, s_fieldlett3
    vari d_indextype1, d_indextype2, d_indextype3
    vari d_indexct1, d_indexct2, d_indexct3
    vari d_longct1, d_longct2, d_longct3
    vari s_blanks6, s_alpha

    s_record = sg_pass1

    $sys sg_subroutine, 2

'cline    1         2         3         4         5         6
'123456789012345678901234567890123456789012345678901234567890
'    .CSR 01 02 03FACTOR1   COMMDFACTOR2   RESULT  92H919293

    'beg dg_errnumber,d_error,3000
    d_error = 0
    d_process = 1
    $ch$ s_blanks6, " ", 6
    s_alpha = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"

    'get the parts
    $cut s_code, s_record, 6, 3
    $cut s_indicators1, s_record, 9, 9
    $cut s_factor1, s_record, 18, 10
    $cut s_command, s_record, 28, 5
    $cut s_factor2, s_record, 33, 10
    $cut s_result, s_record, 43, 6
    $cut s_indicators2, s_record, 54, 6

    'validate s_code
    s_any = s_code + ","
    s_tap = "C  ,CSR,"
    $lok d_any, s_tap, 1, s_any
    dift d_any = 0
	  d_error = 3001
	  dinc d_process
    endi

    'skip next if certain commands that only have
    'file names or tags not fields
    s_tap = "TAG  ,GOTO ,EXSR ,BEGSR,ENDSR,EXCPT,"
    $app s_tap, "READ ,READP,LOCK ,UNLCK"
    $lok d_dot, s_tap, 1, s_command
    dift d_dot > 0: dinc d_process

    'blank the file names which are validated elsewhere
    $ift s_command = "SETLL": $ch$ s_factor2, " ", 10
    $ift s_command = "CHAIN": $ch$ s_factor2, " ", 10

'd_fieldtype
'1=error A
'2=blank B
'6=*BLANK F
'7=*ZEROS G
'8=UDATE
'11=numeric literal K
'12=numeric var L
'13=numeric array with index M
'14=numeric array no index N
'21=alpha literal U
'22=alpha var V
'23=alpha array with index W
'24=alpha array no index X
    dift d_process = 1
        'what types are the three variables
        sg_pass1 = s_factor1
        sub_field_info_return
        d_fieldtype1 = dg_pass1
	  d_indextype1 = dg_pass2
	  d_indexct1 = dg_pass3
	  d_longct1 = dg_pass4
        s_fieldtype1 = sg_pass3
	  $cut s_fieldlett1, s_alpha, d_fieldtype1, 1

        sg_pass1 = s_factor2
        sub_field_info_return
        d_fieldtype2 = dg_pass1
	  d_indextype2 = dg_pass2
	  d_indexct2 = dg_pass3
	  d_longct2 = dg_pass4
        s_fieldtype2 = sg_pass3
	  $cut s_fieldlett2, s_alpha, d_fieldtype2, 1

        sg_pass1 = s_result
        sub_field_info_return
        d_fieldtype3 = dg_pass1
	  d_indextype3 = dg_pass2
	  d_indexct3 = dg_pass3
	  d_longct3 = dg_pass4
        s_fieldtype3 = sg_pass3
	  $cut s_fieldlett3, s_alpha, d_fieldtype3, 1

	  'dg_tdebug
	  dift dg_tdebug = 1
		$out s_record
		s_any = s_fieldtype1 + "," + s_fieldtype2 
		$app s_any, "," + s_fieldtype3
		$inp s_any, s_any
	  endi
    endi
'd_fieldtype
'1=error A
'2=blank B
'6=*BLANK F
'7=*ZEROS G
'8=UDATE
'11=numeric literal K
'12=numeric var L
'13=numeric array with index M
'14=numeric array no index N
'21=alpha literal U
'22=alpha var V
'23=alpha array with index W
'24=alpha array no index X

'd_kind=1 numeric
'd_kind=2 alpha
    dift d_process = 1
	  'valid_seton,valid_setof
        s_tap = "SETON,SETOF"
        $lok d_dot, s_tap, 1, s_command
        dift d_dot > 0
	      d_any = d_fieldtype1 + d_fieldtype2 + d_fieldtype3
	      dift d_any <> 6: d_error = 3002
		dinc d_process
        endi
    endi
    dift d_process = 1
        'do we have a math command
	  'valid_add,valid_sub,valid_mult,valid_div
        s_tap = "ADD  ,SUB  ,MULT ,DIV  ,"
	  $lok d_dot, s_tap, 1, s_command
	  dift d_dot > 0
		'blank,numeric literal,numeric,numeric array & index
		s_tap = "BKLM"
		$lok d_any, s_tap, 1, s_fieldlett1
		dift d_any = 0: d_error = 3003

		'numeric literal,numeric,numeric array & index
		s_tap = "KLM"
		$lok d_any, s_tap, 1, s_fieldlett2
		dift d_any = 0: d_error = 3004

		'numeric,numeric array & index
		s_tap = "LM"
		$lok d_any, s_tap, 1, s_fieldlett3
		dift d_any = 0: d_error = 3005

		'cannot have result indicators
		$ift s_indicators2 <> s_blanks6: d_error = 3006

		dinc d_process
	  endi
    endi
    dift d_process = 1
        'do we have a numeric result only command
	  'valid_mvr,valid_time
        s_tap = "MVR  ,TIME ,"
	  $lok d_dot, s_tap, 1, s_command
	  dift d_dot > 0
		'blank only
		$ift s_fieldlett1 <> "B": d_error = 3007

		'blank only
		$ift s_fieldlett2 <> "B": d_error = 3008

		'numeric,numeric array & index
		s_tap = "LM"
		$lok d_any, s_tap, 1, s_fieldlett3
		dift d_any = 0: d_error = 3009

		'cannot have result indicators
		$ift s_indicators2 <> s_blanks6: d_error = 3010

		dinc d_process
	  endi
    endi
    dift d_process = 1
        'do we have a math command
	  'valid_z-add,valid_z-sub
        s_tap = "Z-ADD,Z-SUB,"
	  $lok d_dot, s_tap, 1, s_command
	  dift d_dot > 0
		'blank
		$ift s_fieldlett1 <> "B": d_error = 3011

		'numeric literal,numeric,numeric array & index
		s_tap = "KLM"
		$lok d_any, s_tap, 1, s_fieldlett2
		dift d_any = 0: d_error = 3012

		'numeric,numeric array & index,numeric array no index
		s_tap = "LMN"
		$lok d_any, s_tap, 1, s_fieldlett3
		dift d_any = 0: d_error = 3013

		'cannot have result indicators
		$ift s_indicators2 <> s_blanks6: d_error = 3014

		dinc d_process
	  endi
	  'valid_sqrt
	  $ift s_command = "SQRT "
		'blank
		$ift s_fieldlett1 <> "B": d_error = 3015

		'numeric literal,numeric,numeric array & index
		s_tap = "KLM"
		$lok d_any, s_tap, 1, s_fieldlett2
		dift d_any = 0: d_error = 3016

		'numeric,numeric array & index
		s_tap = "LM"
		$lok d_any, s_tap, 1, s_fieldlett3
		dift d_any = 0: d_error = 3017

		'cannot have result indicators
		$ift s_indicators2 <> s_blanks6: d_error = 3018

		dinc d_process
	  endi
	  $ift s_command = "XFOOT"
		'valid_xfoot
		$ift s_fieldlett1 <> "B": d_error = 3019

		'numeric array no index
		$ift s_fieldlett2 <> "N": d_error = 3020

		'numeric variable only
		$ift s_fieldlett3 <> "L": d_error = 3021

		'cannot have result indicators
		$ift s_indicators2 <> s_blanks6: d_error = 3022

		dinc d_process
	  endi
    endi
'd_fieldtype
'1=error A
'2=blank B
'6=*BLANK F
'7=*ZEROS G
'8=UDATE
'11=numeric literal K
'12=numeric var L
'13=numeric array with index M
'14=numeric array no index N
'21=alpha literal U
'22=alpha var V
'23=alpha array with index W
'24=alpha array no index X
    dift d_process = 1
	  'do we have a move command
	  s_tap = "MOVE ,MOVEL,MOVEA"
	  $lok d_dot, s_tap, 1, s_command
	  dift d_dot > 0
		's_fieldlett1 = "B" means blank
		$ift s_fieldlett1 <> "B": d_error = 3023

		dift d_dot = 1
		    'valid_MOVE_right
		    s_tap = "FGLUV"
		    $lok d_any, s_tap, 1, s_fieldlett2
		    dift d_any = 0: d_error = 3024
		    s_tap = "LVX"
		    $lok d_any, s_tap, 1, s_fieldlett3
		    dift d_any = 0: d_error = 3025

		    $ift s_fieldlett3 = "X"
			  'can only do move into byte array
			  dift d_longct3 <> 1: d_error = 3026
		    endi
		    $ift s_fieldlett3 = "L"
			  'can not move *BLANK,*ZEROS into numeric
			  $ift s_fieldlett2 = "F": d_error = 3027
			  $ift s_fieldlett2 = "G": d_error = 3028
		    endi
		endi
		dift d_dot = 7
		    'valid_MOVEL
		    s_tap = "LUV"
		    $lok d_any, s_tap, 1, s_fieldlett2
		    dift d_any = 0: d_error = 3029

		    s_tap = "LV"
		    $lok d_any, s_tap, 1, s_fieldlett3
		    dift d_any = 0: d_error = 3030
		endi
		dift d_dot = 13
		    'valid_MOVEA
		    s_tap = "FGUVWX"
		    $lok d_any, s_tap, 1, s_fieldlett2
		    dift d_any = 0: d_error = 3031

		    s_tap = "VWX"
		    $lok d_any, s_tap, 1, s_fieldlett3
		    dift d_any = 0: d_error = 3032
		endi
		dinc d_process
	  endi
    endi
'd_fieldtype, s_fieldlett
'1=error A
'2=blank B
'6=*BLANK F
'7=*ZEROS G
'8=UDATE
'11=numeric literal K
'12=numeric var L
'13=numeric array with index M
'14=numeric array no index N
'21=alpha literal U
'22=alpha var V
'23=alpha array with index W
'24=alpha array no index X
    dift d_process = 1
	  $ift s_command = "COMP "
		'valid_comp
		's_fieldlett3 must be B
		$ift s_fieldlett3 <> "B": d_error = 3033

		'do we have a numeric compare
		d_good = 2
		s_tap = "KLM"
		$lok d_dot, s_tap, 1, s_fieldlett1
		$lok d_any, s_tap, 1, s_fieldlett2
		dift d_dot > 0
		    dift d_any > 0: d_good = 1
		endi

		'do we have an alpha compare
		s_tap = "FGUVW"
		$lok d_dot, s_tap, 1, s_fieldlett1
		$lok d_any, s_tap, 1, s_fieldlett2

		'cannot both be *BLANK=F
		dift d_dot = 1
		    dift d_any = 1: d_error = 3034
		endi

		dift d_dot > 0
		    dift d_any > 0
			  'if either is *BLANK then lengths are same
			  $ift s_fieldlett1 = "F": d_longct1 = d_longct2
			  $ift s_fieldlett2 = "F": d_longct2 = d_longct1

			  'alpha must have the same length
			  dift d_longct1 = d_longct2: d_good = 1
		    endi
		endi
		dift d_good <> 1: d_error = 3035

		dinc d_process
	  endi
    endi
    dift d_process = 1
	  $ift s_command = "LOKUP"
		'valid_lokup

		'field1=alpha literal,variable,array with index
		s_tap = "UVW"
		$lok d_dot, s_tap, 1, s_fieldlett1
		dift d_dot > 0
		    'alpha lokup
		    'field2=array with index,array no index
		    s_tap = "WX"
		    $lok d_dot, s_tap, 1, s_fieldlett2
		    dift d_dot = 0: d_error = 3036

		    'lengths must be the same
		    dift d_longct1 <> d_longct2: d_error = 3037

		    $ift s_fieldlett2 = "W"
		        'array index must be a numeric variable
			  dift d_indextype2 <> 12: d_error = 3038

			  'field3 must be blank
		        $ift s_fieldlett3 <> "B": d_error = 3039
		    else
			  'no index for field2
			  'do we have a table look up
			  $cut s_any, s_factor2, 1, 3
			  $ift s_any = "TAB"
				'table look up
				$cut s_any, s_result, 1, 3
				$ift s_any <> "TAB": d_error = 3040

				'are these table fields connected
				$cut s_any, s_factor2, 1, 6
				$lok d_any, sg_rpgtabnames1, 1, s_any
				$cut s_dot, sg_rpgtabnames2, d_any, 6
				$ift s_dot <> s_result: d_error = 3041
			  else
			      'not table, field3 must be blank
		            $ift s_fieldlett3 <> "B": d_error = 3042
			  endi
		    endi
		else
		    'numeric lokup
		    'numeric literal,variable,array with index
		    s_tap = "KLM"
		    $lok d_dot, s_tap, 1, s_fieldlett1
		    dift d_dot = 0: d_error = 3043

		    'numeric array,array with index
		    s_tap = "MN"
		    $lok d_dot, s_tap, 1, s_fieldlett2
		    dift d_dot = 0: d_error = 3044

		    $ift s_fieldlett2 = "M"
		        'array index must be a numeric variable
			  dift d_indextype2 <> 12: d_error = 3045
		    endi
		    $ift s_fieldlett3 <> "B": d_error = 3046
		endi

		'must have indicator in 58
		$off s_any, s_indicators2, 2
		$isd d_any, s_any
		dift d_any <> 1: d_error = 3047

		dinc d_process
	  endi
    endi
    dift d_process = 1
	  $ift s_command = "PUTJW"
		'valid_putjw
		s_tap = "KLM"
		$lok d_dot, s_tap, 1, s_fieldlett1
		dift d_dot = 0: d_error = 3048

		$ift s_fieldlett2 <> "U": d_error = 3049

		$ift s_fieldlett3 <> "B": d_error = 3050

		$off s_any, s_indicators2, 2
		$isd d_any, s_any
		dift d_any <> 1: d_error = 3051

		dinc d_process
	  endi
	  $ift s_command = "FNDJW"
		'valid_fndjw
		$ift s_fieldlett1 <> "B": d_error = 3052

		$ift s_fieldlett2 <> "U": d_error = 3053

		s_tap = "LM"
		$lok d_dot, s_tap, 1, s_fieldlett3
		dift d_dot = 0: d_error = 3054

		$off s_any, s_indicators2, 2
		$isd d_any, s_any
		dift d_any <> 1: d_error = 3055

		dinc d_process
	  endi
	  $ift s_command = "TESTN"
		'valid_testn
		$ift s_fieldlett1 <> "B": d_error = 3056

		$ift s_fieldlett2 <> "B": d_error = 3057

		'must be alpha var
		$ift s_fieldlett3 <> "V": d_error = 3058

		$trb s_any, s_indicators2
		$isd d_any, s_any
		dift d_any <> 1: d_error = 3059

		dinc d_process
	  endi
	  $ift s_command = "TIME "
		'valid_time
		$ift s_fieldlett1 <> "B": d_error = 3060

		$ift s_fieldlett2 <> "B": d_error = 3061

		s_tap = "LM"
		$lok d_dot, s_tap, 1, s_fieldlett3
		dift d_dot = 0: d_error = 3062

		$isc d_any, s_indicators2, " "
		dift d_any <> 1: d_error = 3063

		dinc d_process
	  endi
	  $ift s_command = "TIME2"
		'valid_time2
		$ift s_fieldlett1 <> "B": d_error = 3064

		$trr s_any, s_factor2
		$ift s_any <> "1": d_error = 3065

		$ift s_fieldlett3 <> "V": d_error = 3066

		$isc d_any, s_indicators2, " "
		dift d_any <> 1: d_error = 3067

		dinc d_process
	  endi
	  $ift s_command = "SORTA"
		'valid_sorta
		$ift s_fieldlett1 <> "B": d_error = 3068

		'only alpha or numeric array with no index
		s_tap = "NX"
		$lok d_any, s_tap, 1, s_fieldlett2
		dift d_any = 0: d_error = 3069

		$ift s_fieldlett3 <> "B": d_error = 3070

		$isc d_any, s_indicators2, " "
		dift d_any <> 1: d_error = 3071

		dinc d_process
	  endi
    endi
    dift d_process = 1
	  s_tap = "BITOF,BITON"
	  $lok d_any, s_tap, 1, s_command
	  dift d_any > 0
		'valid_biton,valid_bitof
		$ift s_fieldlett1 <> "B": d_error = 3072

	      $ift s_fieldlett2 <> "U"
		    $ift s_fieldlett2 <> "V": d_error = 3073
		endi

	      $ift s_fieldlett3 <> "V": d_error = 3074

		$isc d_any, s_indicators2, " "
		dift d_any <> 1: d_error = 3075

		dinc d_process
	  endi
    endi
    dift d_process = 1
	  $ift s_command = "SETLL"
		'valid_setll
		'factor1 must be alpha
		s_tap = "UVW"
		$lok d_dot, s_tap, 1, s_fieldlett1
		dift d_dot = 0: d_error = 3076

	 	dinc d_process
	  endi
	  $ift s_command = "CHAIN"
		'valid_chain
		'factor1 must be numeric
		s_tap = "KL"
		$lok d_dot, s_tap, 1, s_fieldlett1
		dift d_dot = 0: d_error = 3077

	 	dinc d_process
	  endi
    endi

    'command not found
    dift d_process = 1: d_error = 3099

    dift d_error > 0
	  s_out = "1" + "=" + s_fieldlett1 + "=" + s_fieldtype1
	  $app s_out, ",long=" + d_longct1
 	  $out s_out

	  s_out = "2" + "=" + s_fieldlett2 + "=" + s_fieldtype2
	  $app s_out, ",long=" + d_longct2
 	  $out s_out

	  s_out = "3" + "=" + s_fieldlett3 + "=" + s_fieldtype3
	  $app s_out, ",long=" + d_longct3
 	  $out s_out

	  'end dg_errnumber,d_error,3000
	  dg_errnumber = d_error
	  sg_pass1 = "bad rpg_valid_format"
	  sub_error
    endi
ends sub_rpg_valid_format_cline


subr sub_rpg_valid_format_oline
'updated 2005/01/09
    vari s_any, d_any, s_dot, d_dot
    vari s_record, d_process, d_error, d_floatingdollar
    vari s_field1, s_field2, d_field1, d_field2

'oline    1         2         3         4         5         6
'123456789012345678901234567890123456789012345678901234567890
'    .OFILENAMEE 12     01 02 03OLINE
'    .O        E        01 02 03VARIABJB 132 "HEADING LINE  "

    s_record = sg_pass1
    'beg dg_errnumber,d_error,1400    
    d_error = 0
    d_process = 1
    d_floatingdollar = 2

    'skip if file name begins in 7
    $cut s_any, s_record, 7, 8
    $isc d_any, s_any, " "
    dift d_any <> 1: dinc d_process

    dift d_process = 1
	  $cut s_field1, s_record, 32, 6
	  $cut s_field2, s_record, 45, 26

	  'do we have a floating dollar literal
	  $trb s_any, s_field2
	  $ift s_any = #"$"#: d_floatingdollar = 1

	  $isc d_field1, s_field1, " "
	  $isc d_field2, s_field2, " "
	  'only one can be 1
	  dift d_field1 = 1
		'field1 is blank
		dift d_field2 = 1
		    'field2 is also blank
		    d_error = 1401
		    dinc d_process
		endi
	  else
		'field1 is not blank
		dift d_field2 <> 1
		    'if both d_floatingdollar must be 1
		    dift d_floatingdollar <> 1
			  d_error = 1402
			  dinc d_process
		    endi
		endi
	  endi
    endi
    dift d_process = 1
	  dift d_field2 <> 1
		'validate literal field in output
		$trr s_field2, s_field2

		$off s_any, s_field2, 1
		$ift s_any <> #"#: d_error = 1403

		$cut s_any, s_field2, 1, 1
		$ift s_any <> #"#: d_error = 1404
		dift d_floatingdollar <> 1: dinc d_process
	  endi
    endi
'd_fieldtype
'1=error A
'2=blank B
'6=*BLANK
'7=*ZEROS
'8=UDATE
'11=numeric literal K
'12=numeric var L
'13=numeric array with index M
'14=numeric array no index N
'21=alpha literal U
'22=alpha var V
'23=alpha array with index W
'24=alpha array no index X
    dift d_process = 1
	  $trb s_field1, s_field1
	  $ift s_field1 = "UDATE"
		dinc d_process
		dift d_floatingdollar = 1: d_error = 1405
	  endi
    endi
    dift d_process = 1
        'what type is s_field1
        sg_pass1 = s_field1
        sub_field_info_return
        d_field1 = dg_pass1

	  d_dot = 0
	  dift d_field1 = 12: d_dot = 1
	  dift d_field1 = 13: d_dot = 1
	  dift d_dot <> 1
		'field1 is not numeric
		dift d_floatingdollar = 1: d_error = 1406
	  endi
    endi
    dift d_error > 0
	  'end dg_errnumber,d_error,1400
	  dg_errnumber = d_error
	  sg_pass1 = "bad rpg_valid_format"
	  sub_error
    endi
ends sub_rpg_valid_format_oline


subr sub_rpg_read_record
'updated 2005/01/15, 2003/11/18
'read record at dg_filebyte from sg_inpfile into sg_record
'to begin set dg_record = 0
'this sets dg_record = 0 when none read or at bottome arrays
    vari s_any, d_any, s_dot, d_dot, s_out
    vari d_loop, d_good, d_count, s_record, s_fromsubr

    s_fromsubr = sg_pass1
    dift dg_record = 0: dg_filebyte = 1

    d_loop = 1
    dwhi d_loop = 1
	  d_good = 1
	  fsip s_record, sg_inpfile, dg_filebyte
	  dift dg_filebyte = 0
		$out s_fromsubr + "=" + dg_record
		dg_record = 0
		dinc d_good
		dinc d_loop
	  endi
	  dift d_good = 1
		dinc dg_record
		dg_rpglinenumber = dg_record

		d_any = dg_record % 1000
		dift d_any = 0: $sho s_fromsubr + "=" + dg_record

		'make sure the record is 80 long
		$ch$ s_any, " ", 80
		$app s_record, s_any
		$cut s_record, s_record, 1, 80

		'store the line in the queue
		sg_pass1 = dg_record + " " + s_record
		sub_queue

		'end if at bottom arrays
		$cut s_any, s_record, 1, 1
		$ift s_any = "*"
		    $out s_fromsubr + "=" + dg_record
		    dg_record = 0
		    dinc d_good
		    dinc d_loop
		endi

		'drop out if not comment record
		$cut s_any, s_record, 7, 1
		$ift s_any <> "*": dinc d_loop
	  endi
    endw
    sg_pass1 = s_record
ends sub_rpg_read_record


subr sub_csv_out
'updated 2003/11/18
'output to term elements of csv record
    vari s_any, d_any, s_dot, d_dot, s_out
    vari s_csv, d_loop, d_count, s_fromsubr

    s_csv = sg_pass1

    $sys s_fromsubr, 2

    d_count = 0
    s_out = sg_nothing
    d_loop = 1
    dwhi d_loop = 1
	  $lok d_any, s_csv, 1, ","
	  dift d_any > 0
		$cut s_any, s_csv, 1, d_any
		$app s_out, s_any
		dinc d_any
		$cut s_csv, s_csv, d_any, 99999
		dinc d_count
	  else
		$len d_any, s_csv
		dift d_any > 0: dinc d_count
		$app s_out, s_csv
		s_csv = sg_nothing
	  endi

	  $len d_any, s_out
	  dift d_any > 60
		$out s_out
		s_out = sg_nothing
 	  endi
 
	  $len d_any, s_csv
	  dift d_any = 0
		$len d_any, s_out
		dift d_any > 0: $out s_out
		dinc d_loop
	  endi
    endw
    $out s_fromsubr + "=" + d_count
ends sub_csv_out


subr sub_queue
'updated 2005/04/03, 2003/09/19
'queue the program lines to be able to show if error
    vari s_any, d_any, s_dot, d_dot, s_out
    vari s_line

    s_line = sg_pass1
    $len d_any, s_line

    dift d_any = 0
	  'show lines in queue array 1/10
	  d_dot = 1
	  dwhi d_dot <= 1000
		$cut s_out, sg_queue, d_dot, 80
		$out s_out

		d_dot = d_dot + 80
	  endw
    else
	  'add s_line to queue sg_queue
	  $ch$ s_any, " ", 90
	  $app s_line, s_any
	  $cut s_line, s_line, 1, 80
	  $app sg_queue, s_line
	  $len d_any, sg_queue
	  dift d_any > 900: $cut sg_queue, sg_queue, 81, 99999
    endi
ends sub_queue

subr sub_return
'updated 2003/06/21
    vari s_any, d_any, s_dot, d_dot, s_out

    $out sg_pass1
    $inp s_any, "tdebug toggles tdebug, * to end"
    $ift s_any = "*": dinc dg_process
    $ift s_any = "tdebug"
	  dift dg_tdebug = 1
		dinc dg_tdebug
	  else
		dg_tdebug = 1
	  endi
    endi
ends sub_return


subr sub_error
'updated 2006/11/01, 2006/04/25, 2005/04/03, 2004/12/23
    vari s_any, d_any, s_dot, d_dot, s_out
    vari s_error

    dift dg_showerror = 1
        s_error = sg_pass1

        'show the last ten lines
        sg_pass1 = sg_nothing
        sub_queue
    
        $out s_error
        s_out = "in subroutine=" + sg_subroutine
	  $app s_out, ", record=" + dg_record
	  $app s_out, ", errnumber=" + dg_errnumber
	  $out s_out
	  fapp d_any, "rpgtoc.log", s_out

        dg_error = 1

        sub_variable_lookup
	  dinc dg_process
    endi
ends sub_error


subr sub_c_lineout
'updated 2007/06/17, 2005/07/06, 2005/07/01, 2005/04/29, 2004/02/22
    vari s_any, d_any, s_dot, d_dot, s_out, d_out
    vari d_delta, s_crlf, s_char10

    s_out = sg_pass1

    dch$ s_char10, 10, 1
    dch$ s_crlf, 13, 1
    $app s_crlf, s_char10
    
    $trb s_out, s_out
    $len d_any, s_out
    dift d_any > 0
        $cut s_any, s_out, 1, 2
        $ift s_any = "/*"
	      dinc dg_ccommentcount
        else
	      dinc dg_clinecount
        endi
    endi

    'begin dg_indent stuff
    'do we have a begin block { or an end block }
    d_delta = 0
    $cut s_any, s_out, 1, 1
    $ift s_any = "}": dg_indent = dg_indent - 4

    $off s_any, s_out, 1
    $ift s_any = "{": d_delta = 4

    dift dg_indent < 0: dg_indent = 0
    $ch$ s_any, " ", dg_indent
    s_out = s_any + s_out
    $trr s_out, s_out

    dg_indent = dg_indent + d_delta
    dift dg_indent < 0: dg_indent = 0
    'end of dg_indent stuff

    flen d_out, sg_outfile
    dinc d_out

    'dg_operatingsystem:1=MPE,2=Unix,3=C90
    dift dg_operatingsystem = 1
	  $app s_out, s_crlf
    else
	  $app s_out, s_char10
    endi

    fwri d_any, sg_outfile, d_out, s_out

    dift d_any = 0
	  $len d_any, s_out
	  $out "rec long=" + d_any
	  $out s_out
	  $out "above record not written to file"
	  $out "file=" + sg_outfile + " byte=" + d_out
	  $inp s_any, "program must end"
	  endp
    endi
ends sub_c_lineout


subr sub_c_blankline
'updated 2003/09/18
    sg_pass1 = sg_nothing
    sub_c_lineout
ends sub_c_blankline


subr sub_c_arrayout
'updated 2004/03/04
'output to sg_outfile from array
    vari s_any, d_any, s_dot, d_dot, s_out
    vari d_index, d_loop, d_yespreviousblank

    d_yespreviousblank = 2    
    d_index = 1
    d_loop = 1
    dwhi d_loop = 1
	  ito$ s_out, d_index
	  $trb s_out, s_out
	  $len d_any, s_out

	  dift d_any > 0
		'non-blank element
		sg_pass1 = s_out
		sub_c_lineout
		dinc d_yespreviousblank
	  else
		'blank element
		dift d_yespreviousblank <> 1: sub_c_blankline

		d_yespreviousblank = 1
	  endi

	  dinc d_index
	  dift d_index > 2000: dinc d_loop
    endw

    'blank the string array
    arrb
ends sub_c_arrayout


subr sub_take_off_leading_zeros
'updated 2005/01/02
'change -001.7 to -1.7
    vari s_any, d_any, s_dot, d_dot
    vari s_number, s_sign

    s_number = sg_pass1
    $trb s_number, s_number

    'put the sign in s_sign
    $cut s_any, s_number, 1, 1
    s_sign = sg_nothing
    d_any = 2
    $ift s_any = "-": d_any = 1
    $ift s_any = "+": d_any = 1
    dift d_any = 1
	  s_sign = s_any
	  $cut s_number, s_number, 2, 9999
    endi

    'no take off leading zeros
    d_dot = 1
    dwhi d_dot = 1
	  $cut s_any, s_number, 1, 1
	  $ift s_any = "0"
		$cut s_number, s_number, 2, 9999
	  else
		dinc d_dot
	  endi
    endw
    
    sg_pass1 = s_sign + s_number
ends sub_take_off_leading_zeros


subr sub_right_trim_spaces_only
'updated 2005/01/19
    vari s_any, d_any, s_dot, d_dot, s_out
    vari s_string

    s_string = sg_pass1
    $len d_dot, s_string

    dwhi d_dot > 0
	  $off s_dot, s_string, 1
	  $ift s_dot = " "
		ddec d_dot
		$cut s_string, s_string, 1, d_dot
	  else
		d_dot = - 9999
	  endi
    endw

    sg_pass1 = s_string    
ends sub_right_trim_spaces_only


subr sub_c_create
'updated 2004/08/09
'create the c program
    vari s_any, d_any, s_dot, d_dot, s_out

    $sys sg_subroutine, 2
    dift dg_tdebug = 1
	  sg_pass1 = sg_subroutine
	  sub_return
    endi

    'delete the output c file
    fdel d_any, sg_outfile

    dg_clinecount = 0
    dg_ccommentcount = 0

    'headers
    sub_c_headers

    'global variable declarations
    sub_c_global_c_variables
    sub_c_global_rpg_variables
    sub_c_global_rpg_indicators
    sub_c_global_file_variables

    'prototypes
    sub_c_prototypes_open_read_write_close_files
    sub_c_prototypes_input
    sub_c_prototypes_begsr
    sub_c_prototypes_excpt
    sub_c_prototypes_tsub
    sub_c_prototypes_rpg_commands
    sub_crpg_prototypes

    'make main subroutine
    sub_c_subroutines_main

    'make input subroutines
    sub_c_subroutines_input

    'make open files subroutine
    sub_c_subroutine_open_files
    sub_c_subroutine_read_files
    sub_c_subroutine_write_files
    sub_c_subroutine_close_files

    'make subroutine to initialize strings
    sub_c_initialize_strings

    'make subroutine to initialize at bottom strings
    sub_c_initialize_arrays_from_bottom

    'utility t funtions/subs 
    sub_c_subroutines_tsub1
    sub_c_subroutines_tsub2
    sub_c_subroutines_tsub3
    sub_c_subroutines_tsub4
    sub_c_subroutines_tsub5

    'rpg command subroutines
    sub_c_subroutines_rpg_commands
    sub_crpg_subroutines

    'rpg program subroutines
    sub_c_cline_commands

    'rpg program output
    sub_c_olines

    $out "bad commands:"
    $sor sg_pass1, sg_badcommands, 6

    sub_csv_out

    $out "good commands:"
    $sor sg_pass1, sg_goodcommands, 6
    sub_csv_out

    'output ending line of program
    sg_pass1 = sg_slashaster + "program = " + sg_inpfile
    $dat s_dot
    $app sg_pass1, ", " + s_dot + sg_asterslash
    sub_c_lineout

    'output to term some info    
    s_any = "program=" + sg_outfile
    $app s_any, ", c lines=" + dg_clinecount
    $app s_any, ", c comments=" + dg_ccommentcount
    $out s_any
ends sub_c_create


subr sub_c_headers
'updated 2005/04/09, 2004/12/30
'output c program header records to sg_outfile
    vari s_any, d_any, s_dot, d_dot, s_out

    dift dg_tdebug = 1
	  $sys s_any, 2
	  sg_pass1 = s_any
	  sub_return
    endi

'dg_progkind values
'10=input demand
'20=input chain
'30=update demand
'40=input ksam
'50=update ksam
'60=screen
    'blank the array
    arrb

    s_out = sg_slashaster + "program = " + sg_inpfile
    $dat s_dot
    $app s_out, ", " + s_dot + sg_asterslash
    $toi 101, s_out

    'dg_operatingsystem:1=MPE,2=Unix/Linux,3=C90 only
    s_out = "/* for the MPE operating system */"
    dift dg_operatingsystem = 2
	  s_out = "/* for the Unix/Linux operating system */"
    endi
    dift dg_operatingsystem = 3
	  s_out = "/* for the C90 only operating system */"
    endi
    $toi 111, s_out

    $toi 121, "/* headers */"
    $toi 122, "#include "
    $toi 123, "#include "
    $toi 124, "#include "
    $toi 125, "#include "
    $toi 126, "#include "

    dift dg_operatingsystem = 1
	  'HP MPE
	  $toi 150, "#include "
	  dift dg_progkind >= 40
		'HP intrinsics for ksam, manual 32650-90886.pdf
		$toi 161, "/* HP intrinsics */"
		$toi 162, "#pragma intrinsic FCLOSE, FFINDN, FLOCK"
		$toi 163, "#pragma intrinsic FREAD, FFINDBYKEY, FREMOVE"
		$toi 164, "#pragma intrinsic FUNLOCK, FUPDATE, FWRITE"
		$toi 165, "#pragma intrinsic HPCICOMMAND, HPFOPEN"
		$toi 166, "#pragma intrinsic FSPACE"
	  endi
    endi
    dift dg_operatingsystem = 2
	  'Unix/Linux
	  $toi 150, "#include "
    endi
    
    sub_c_arrayout
ends sub_c_headers


subr sub_c_global_c_variables
'updated 2005/04/09, 2004/12/29
    vari s_any, d_any, s_dot, d_dot, s_out

    dift dg_tdebug = 1
	  $sys sg_pass1, 2
	  sub_return
    endi

    arrb

    $toi 1, "/* global c variables */"
    $toi 2, "int tig_cdebug = 2;"
    $toi 3, "int tig_cerror = 2;"
    $toi 4, "int tig_eof = 2;"
    $toi 5, "int tig_x, tig_y, tig_z;"
    $toi 6, "long tng_x, tng_y, tng_z;"
    $toi 7, "long tng_index1, tng_index2;"
    $toi 8, "double tdg_x, tdg_y, tdg_z;" 

    $toi 101, "/* global char arrays */"
    $toi 102, "char tsg_256a[256];"
    $toi 103, "char tsg_256b[256];"
    $toi 104, "char tsg_input[2048];"
    $toi 105, "char tsg_output1[2048];"
    $toi 106, "char tsg_output2[2048];"

    'dg_operatingsystem:1=MPE,2=Unix/Linux,3=C90 only
    s_any = "int tig_operatingsystem = "
    $app s_any, dg_operatingsystem + ";"
    $toi 111, s_any

    'global char pointers
    $toi 201, "char *tsgp_1, *tsgp_2;"

    sub_c_arrayout
ends sub_c_global_c_variables


subr sub_c_global_rpg_variables
'updated 2003/12/27
    vari s_any, d_any, s_dot, d_dot, s_out
    vari d_loop, d_byte, d_length
    vari s_varname, s_varsize, s_fromsubr, d_count
    vari d_vartype, d_varindexct, d_varlongct, d_vardecimalct
    vari s_tabname, d_tablongct

    $sys sg_subroutine, 2
    s_fromsubr = sg_subroutine
    dift dg_tdebug = 1
	  sg_pass1 = sg_subroutine
	  sub_return
    endi

    sub_c_blankline

    sg_pass1 = "/* rpg variable declarations */"
    sub_c_lineout

'123456789 sg_rpgvarnames 9 long
'abbbbcccd sg_rpgvarsizes 9 long
'a    = d_vartype: 1=numeric,2=numeric array,6=alpha,7=alpha array
'bbbb = d_varindexct: index count
'ccc  = d_varlongct: length
'd    = d_vardecimalct: decimals

    $len d_length, sg_rpgvarnames
    d_count = 0
    d_byte = 1
    d_loop = 1
    dwhi d_loop = 1
	  dinc d_count
	  d_any = d_count % 10
	  dift d_any = 0: $sho s_fromsubr + "=" + d_count

	  'get variable data from sg_rpgvarnames, sg_rpgvarsizes
	  $cut s_varname, sg_rpgvarnames, d_byte, 9
	  $cut s_varsize, sg_rpgvarsizes, d_byte, 9

	  'make comment line with info
	  sg_pass1 = sg_slashaster + s_varname + "=" + s_varsize
	  $app sg_pass1, sg_asterslash
	  sub_c_lineout
  
        $cut s_any, s_varsize, 1, 1
	  $tod d_vartype, s_any

        $cut s_any, s_varsize, 2, 4
	  $tod d_varindexct, s_any

        $cut s_any, s_varsize, 6, 3
	  $tod d_varlongct, s_any

        $cut s_any, s_varsize, 9, 1
	  $tod d_vardecimalct, s_any

	  'skip if we have *BLANK or *ZEROS
	  $cut s_any, s_varname, 1, 1
	  $ift s_any = "*": d_vartype = 99999

	  dift d_vartype = 1
		'numeric type
		$trb s_dot, s_varname
		sg_pass1 = "double DG_" + s_dot + "=0;"
		$clo sg_pass1, sg_pass1
		sub_c_lineout
	  endi
	  dift d_vartype = 2
		'numeric array
		$trb s_dot, s_varname
		sg_pass1 = "double DGA_" + s_dot + "[" + d_varindexct
		$app sg_pass1, "];"
		$clo sg_pass1, sg_pass1
		sub_c_lineout
	  endi
	  dift d_vartype = 6
		'alpha variable
		$trb s_dot, s_varname
		sg_pass1 = "char SG_" + s_dot + "[" + d_varlongct 
		$app sg_pass1, "];"
		$clo sg_pass1, sg_pass1
		sub_c_lineout
	  endi
	  dift d_vartype = 7
		'alpha array
		'do we have a table
		$cut s_any, s_varname, 1, 3
		$ift s_any = "TAB"
		    'sg_rpgtabnames1,sg_rpgtabnames2
		    $cut s_any, s_varname, 1, 6
		    $lok d_dot, sg_rpgtabnames1, 1, s_any
		    $cut s_tabname, sg_rpgtabnames2, d_dot, 6

    		    'get rest of info about this tab2
		    sg_pass1 = s_tabname
		    sub_variable_info_return
		    d_tablongct = dg_pass3

		    'add d_varlongct and d_tablongct
		    d_varlongct = d_varlongct + d_tablongct
		endi

		sg_pass1 = "/* array " + s_varname
		$app sg_pass1, " index=" + d_varindexct
		$app sg_pass1, " long=" + d_varlongct + " */"
		$clo sg_pass1, sg_pass1
		sub_c_lineout

		$trb s_dot, s_varname
		d_any = d_varindexct * d_varlongct
		sg_pass1 = "char SGA_" + s_dot + "[" + d_any + "];"
		$clo sg_pass1, sg_pass1
		sub_c_lineout
	  endi
      
	  'they are 9 long with commas between
	  d_byte = d_byte + 10
	  dift d_byte > d_length: dinc d_loop
    endw
    $out s_fromsubr + "=" + d_count
ends sub_c_global_rpg_variables


subr sub_c_global_rpg_indicators
'updated 2003/10/25
    vari s_any, d_any, s_dot, d_dot, s_out
    vari d_count
    
    sub_c_blankline

    sg_pass1 = "/* rpg indicator integer declarations */"
    sub_c_lineout

    'we do have a 00 indicator is not used
    d_count = 1
    d_dot = 0
    dwhi d_dot < 100
	  s_dot = "0" + d_dot
	  $off s_dot, s_dot, 2

	  dift d_count = 1
	      sg_pass1 = "int ig_" + s_dot 
	  else
		$app sg_pass1, ", ig_" + s_dot
	  endi

	  dinc d_count
	  dift d_count > 8
		$app sg_pass1, ";"
		sub_c_lineout
		d_count = 1
	  endi

	  dinc d_dot
    endw
    $app sg_pass1, ";"
    sub_c_lineout

    sg_pass1 = "int ig_LR;"
    sub_c_lineout
ends sub_c_global_rpg_indicators


subr sub_c_global_file_variables
'updated 2005/01/08
'define file pointers and file byte location longs
    vari s_any, d_any, s_dot, d_dot, s_out
    vari s_filename, s_filedevice, s_filetype, d_filereclong
    vari s_filefixed, s_fileksam, d_action
    vari d_filekeybeg, d_filekeylong
    vari d_loop, d_good, d_which, s_fromsubr, s_cfilename

    $sys s_fromsubr, 2

'sg_filenames
'12345678
'aaaaaaaa=filename

'sg_filedevs
'aaaaaaaa=filedev

'sg_fileinfos
'12345678
'aabbbbcd
'aa=file type: ID,UD,IC,O
'bbbb=file record length
'c=file is F=fixed or V=variable
'd=file is F=flat or K=KSAM

'sg_filekeys
'12345678
'aaaabbbb
'aaaa=file key begin
'bbbb=file key length

    sub_c_blankline

    sg_pass1 = "/* file accesspointers and integers */"
    sub_c_lineout

    d_which = 1
    d_loop = 1
    dwhi d_loop = 1
	  $par s_filename, sg_filenames, ",", d_which
	  $trb s_any, s_filename
	  $len d_any, s_any

	  dift d_any = 0
		dinc d_loop
	  else
		$sho s_fromsubr + " " + s_filename
		sg_pass1 = s_filename
		sub_rpg_file_info_return
		s_filedevice = sg_pass1
		s_filetype = sg_pass2
		s_filefixed = sg_pass3
		s_fileksam = sg_pass4
		d_filereclong = dg_pass2
		d_filekeybeg = dg_pass3
		d_filekeylong = dg_pass4

		'skip if terminal I/O
		d_action = 1
		$trb s_filedevice, s_filedevice

		'$STDIN will use the standard stdin
		$ift s_filedevice = "$STDIN": d_action = 98

		'$STDLST will use the standard stdout
		$ift s_filedevice = "$STDLST": d_action = 99

		$ift s_filefixed = "V": d_action = 12
		$ift s_fileksam = "K": d_action = 13

		dift d_action = 1
		    $tlo s_cfilename, s_filename
		    sg_pass1 = "FILE *filep_" + s_cfilename + ";"
		    sub_c_lineout
		endi

		dift d_action = 13
		    $tlo s_cfilename, s_filename
		    sg_pass1 = "int iksam_filenum_" + s_cfilename + ";"
		    sub_c_lineout

		    sg_pass1 = "int iksam_mode_" + s_cfilename
		    $app sg_pass1, " = 1;"
		    sub_c_lineout

		    sg_pass1 = "int iksam_advanceflag_" + s_cfilename
		    $app sg_pass1, " = 2;"
		    sub_c_lineout
		endi
	  endi

	  dinc d_which
    endw

    sub_c_blankline

    sg_pass1 = "/* filebyte location longs */"
    sub_c_lineout

    d_which = 1
    d_loop = 1
    dwhi d_loop = 1
	  $par s_filename, sg_filenames, ",", d_which
	  $trb s_any, s_filename
	  $len d_any, s_any

	  dift d_any = 0
		dinc d_loop
	  else
		$sho s_fromsubr + " " + s_filename
		sg_pass1 = s_filename
		sub_rpg_file_info_return
		s_filedevice = sg_pass1
		s_filetype = sg_pass2
		s_filefixed = sg_pass3
		s_fileksam = sg_pass4
		d_filereclong = dg_pass2
		d_filekeybeg = dg_pass3
		d_filekeylong = dg_pass4

		'skip if terminal I/O
		d_good = 1
		$trb s_filedevice, s_filedevice

		'$STDIN will use the standard stdin
		$ift s_filedevice = "$STDIN": dinc d_good

		'$STDLST will use the standard stdout
		$ift s_filedevice = "$STDLST": dinc d_good

		dift d_good = 1
		    'ID,UD,O we must keep track of the filebyte
		    'IC we do not need to do so
		    $tlo s_cfilename, s_filename

		    $ift s_filetype = "ID"
		        sg_pass1 = "long ng_filebyte_" + s_cfilename
			  $app sg_pass1, " = -1;"
		        sub_c_lineout
		    endi
		    $ift s_filetype = "UD"
		        sg_pass1 = "long ng_filebyte_" + s_cfilename
			  $app sg_pass1, " = -1;"
		        sub_c_lineout
		    endi
		    $ift s_filetype = "O "
		        sg_pass1 = "long ng_filebyte_" + s_cfilename
			  $app sg_pass1, " = 0;"
		        sub_c_lineout
		    endi
		endi
	  endi

	  dinc d_which
    endw

    $out s_fromsubr
ends sub_c_global_file_variables


subr sub_c_prototypes_input
'updated 2003/10/25
    vari s_any, d_any, s_dot, d_dot, s_out
    vari s_record, d_loop, d_good, s_filename, s_fromsubr

    $sys s_fromsubr, 2

'iline    1         2         3         4         5         6
'123456789012345678901234567890123456789012345678901234567890
'    .IFILEINP AA
'    .I                                       10  20 VARIAB
    sub_c_blankline

    sg_pass1 = "/* rpg input subroutine prototypes */"
    sub_c_lineout

    dg_record = 0

    d_loop = 1
    dwhi d_loop = 1
	  d_good = 1

	  sg_pass1 = s_fromsubr
	  sub_rpg_read_record
	  s_record = sg_pass1

	  dift dg_record = 0
		dinc d_good
		dinc d_loop
	  endi
	  dift d_good = 1
		$cut s_any, s_record, 6, 1
		$ift s_any <> "I": dinc d_good

		$cut s_filename, s_record, 7, 8
		$isc d_any, s_filename, " "
		dift d_any = 1: dinc d_good

		$lok d_dot, sg_filenames, 1, s_filename
		dift d_dot = 0: dinc d_good
	  endi
	  dift d_good = 1
		$tlo s_filename, s_filename
		sg_pass1 = "void fsub_input_to_fields_"
		$app sg_pass1, s_filename + "(void);"
            sub_c_lineout
	  endi
    endw
ends sub_c_prototypes_input


subr sub_c_subroutines_input
'updated 2005/01/14, 2004/12/29
'make c subroutines to put input tsg_input into variables
    vari s_any, d_any, s_dot, d_dot, s_out
    vari d_record, s_record, d_loop, d_good, s_filename
    vari d_part1, d_part2, d_filecount, s_subrname
    vari s_fromsubr, d_beg
    vari s_varname, s_beg, s_end, s_decimals
    vari d_vartype, d_indexct, d_longct, d_decimalct

    $sys s_fromsubr, 2 
    'for file input the input will be in tsg_input
'iline    1         2         3         4         5         6
'123456789012345678901234567890123456789012345678901234567890
'    .IFILEINP AA
'    .I                                       10  202VARIAB
    sub_c_blankline

    sg_pass1 = "/* input subroutines */"
    sub_c_lineout

    dg_rpglinenumber = 0
    d_filecount = 0
    d_record = 0
    dg_filebyte = 1

    d_loop = 1
    dwhi d_loop = 1
	  'for filename input line set d_part1=1
	  d_part1 = 2
	  'for variable input line set d_part2=1
	  d_part2 = 2

	  d_good = 1

	  'we need comment lines too so use fsip
	  'to get every rpg file record
	  fsip s_record, sg_inpfile, dg_filebyte

	  dift dg_filebyte = 0
		$out s_fromsubr + "=" + d_record
		dinc d_good
		dinc d_loop
	  endi
	  dift d_good = 1
		dinc dg_rpglinenumber
		$cut s_any, s_record, 1, 1
		$ift s_any = "*"
		    dinc d_good
		    dinc d_loop
		endi
	  endi
	  dift d_good = 1
		dinc d_record

		'tell
		d_any = d_record % 1000
		dift d_any = 0: $sho s_fromsubr + "=" + d_record

		'make sure the record is 80 long
		$ch$ s_any, " ", 80
		$app s_record, s_any
		$cut s_record, s_record, 1, 80

		$cut s_any, s_record, 6, 1
		$ift s_any <> "I": dinc d_good
	  endi
	  dift d_good = 1
		$cut s_any, s_record, 7, 1
		$ift s_any = "*"
		    'comment line
		    $cut s_any, s_record, 8, 20
		    $isc d_any, s_any, " "
		    dift d_any <> 1
			  $trb s_any, s_record
			  sg_pass1 = "/* " + s_any + " */"

			  sub_c_lineout
		    endi
		    
		    dinc d_good
		endi
	  endi
	  dift d_good = 1
		sub_c_blankline

		'output this input line as a comment
		$trb s_any, s_record
		sg_pass1 = "/* " + s_any + " */"

		sub_c_lineout
	  endi
	  dift d_good = 1
	      'for filename input line set d_part1=1
	      'for variable input line set d_part2=1

		$cut s_filename, s_record, 7, 8
		$isc d_any, s_filename, " "
		dift d_any <> 1
		    d_part1 = 1
		else
		    d_part2 = 1
		endi
	  endi
	  dift d_part1 = 1
		$lok d_dot, sg_filenames, 1, s_filename
		dift d_dot = 0: dinc d_part1
	  endi
	  dift d_part1 = 1
		$sho s_fromsubr + " " + s_filename
		'we have an iline with a filename
		'are we ending a previous input
		dift d_filecount > 0
		    sg_pass1 = "} /* " + s_subrname + " */"
		    sub_c_lineout
		endi
		sub_c_blankline

		$tlo s_filename, s_filename
		s_subrname = "fsub_input_to_fields_" + s_filename
		sg_pass1 = "void " + s_subrname + "(void) {"
            sub_c_lineout

		dinc d_filecount
	  endi
	  dift d_part2 = 1
		'variable input lines
'iline    1         2         3         4         5         6
'123456789012345678901234567890123456789012345678901234567890
'    .IFILEINP AA
'    .I                                       10  202VARIAB
		$cut s_beg, s_record, 44, 4
		$cut s_end, s_record, 48, 4
		$cut s_decimals, s_record, 52, 1
		$cut s_varname, s_record, 53, 6
		$tlo s_varname, s_varname
		$trb s_beg, s_beg
		$trb s_end, s_end

		'get info for s_varname
		sg_pass1 = s_varname
		sub_variable_info_return
		d_vartype = dg_pass1
		d_indexct = dg_pass2
		d_longct = dg_pass3
		d_decimalct = dg_pass4

		$tod d_beg, s_beg
		'tsg_input begins at 0 rather than 1
		ddec d_beg
'123456789 sg_rpgvarnames 9 long
'abbbbcccd sg_rpgvarsizes 9 long
'a    = d_vartype: 1=numeric,2=numeric array,6=alpha,7=alpha array
'bbbb = d_varindexct: index count
'ccc  = d_varlongct: length
'd    = d_vardecimalct: decimals
		'everything has been verified so use
		'info from sub_variable_info_return
		'for file input the input will be in tsg_input

		dift d_vartype = 6
		    'alpha variable
		    sg_pass1 = "tsub_copy(sg_" + s_varname 
		    $app sg_pass1, ", &tsg_input[" + d_beg + "], "
		    $app sg_pass1, d_longct + ");"

		    sub_c_lineout
		endi
		dift d_vartype = 7
		    'alpha array
		    sg_pass1 = "tsub_copy(sga_" + s_varname 
		    $app sg_pass1, ", &tsg_input[" + d_beg + "], "
		    d_any = d_longct * d_indexct
		    $app sg_pass1, d_any + ");"

		    sub_c_lineout
		endi
		dift d_vartype = 1
		    'numeric variable
		    sg_pass1 = "tsub_packed_to_double(&dg_" + s_varname
		    $app sg_pass1, ", &tsg_input[" + d_beg + "], "
		    $app sg_pass1, d_longct + ", " + s_decimals
		    $app sg_pass1, ", " + dg_rpglinenumber + ");"

		    sub_c_lineout
		endi
	  endi
    endw

    'are we ending a previous input
    dift d_filecount > 0
        sg_pass1 = "} /* " + s_subrname + " */"
        sub_c_lineout
    endi
ends sub_c_subroutines_input


subr sub_c_prototypes_open_read_write_close_files
'updated 2004/12/30
'make c prototypes to open,read,write,close files
    vari s_any, d_any, s_dot, d_dot, s_out
    vari s_filename, s_filedevice, s_filetype, d_filereclong
    vari s_filefixed, s_fileksam
    vari d_filekeybeg, d_filekeylong, s_fileopenmode
    vari d_loop, d_byte, s_fromsubr, s_cfilename

    $sys sg_subroutine, 2 
    s_fromsubr = sg_subroutine

    sub_c_blankline
    sg_pass1 = "/* file subroutine prototypes */"
    sub_c_lineout

    sg_pass1 = "void fsub_open_files(void);"
    sub_c_lineout

    sg_pass1 = "void fsub_close_files(void);"
    sub_c_lineout

'sg_filenames
'12345678
'aaaaaaaa=filename

'sg_filedevs
'aaaaaaaa=filedev

'sg_fileinfos
'12345678
'aabbbbcd
'aa=file type: ID,UD,IC,O
'bbbb=file record length
'c=file is F=fixed or V=variable
'd=file is F=flat or K=KSAM

'sg_filekeys
'12345678
'aaaabbbb
'aaaa=file key begin
'bbbb=file key length

    d_byte = 1
    d_loop = 1
    dwhi d_loop = 1

	  $cut s_filename, sg_filenames, d_byte, 8
	  $sho s_fromsubr + " " + s_filename

	  sg_pass1 = s_filename
	  sub_rpg_file_info_return
	  s_filedevice = sg_pass1
	  s_filetype = sg_pass2
	  s_filefixed = sg_pass3
	  s_fileksam = sg_pass4
	  d_filereclong = dg_pass2
	  d_filekeybeg = dg_pass3
	  d_filekeylong = dg_pass4

	  $ift s_filetype = "ID": s_fileopenmode = "rb"
	  $ift s_filetype = "UD": s_fileopenmode = "r+b"
	  $ift s_filetype = "IC": s_fileopenmode = "rb"
	  $ift s_filetype = "O ": s_fileopenmode = "wb"

	  $tlo s_cfilename, s_filename

	  $ift s_filetype = "ID"
		'if read on this file make proto subr to do so
		$lok d_any, sg_readfile, 1, s_filename
		dift d_any > 0
	          sg_pass1 = "void sub_file_read_" + s_cfilename
		    $app sg_pass1, "(void);"
	          sub_c_lineout
		endi

		'if readp on this file make proto subr to do so
		$lok d_any, sg_readpfile, 1, s_filename
		dift d_any > 0
	          sg_pass1 = "void sub_file_readp_" + s_cfilename
		    $app sg_pass1, "(void);"
	          sub_c_lineout
		endi
	  endi
	  $ift s_filetype = "UD"
		'if read on this file make proto subr to do so
		$lok d_any, sg_readfile, 1, s_filename
		dift d_any > 0
	          sg_pass1 = "void sub_file_read_" + s_cfilename
		    $app sg_pass1, "(void);"
	          sub_c_lineout
		endi

		'if readp on this file make proto subr to do so
		$lok d_any, sg_readpfile, 1, s_filename
		dift d_any > 0
	          sg_pass1 = "void sub_file_readp_" + s_cfilename
		    $app sg_pass1, "(void);"
	          sub_c_lineout
		endi

		'make proto subr to do write on this file
	      sg_pass1 = "void sub_file_write_" + s_cfilename
		$app sg_pass1, "(void);"
	      sub_c_lineout
	  endi
	  $ift s_filetype = "IC"
		'if chain in this file make proto subr to do so
		$lok d_any, sg_chainfile, 1, s_filename
		dift d_any > 0
	          sg_pass1 = "void sub_file_chain_read_" + s_cfilename
		    $app sg_pass1, "(long np_recnum);"
	          sub_c_lineout
		endi
	  endi
	  $ift s_filetype = "O "
		'make proto subr to do output for output only file
	      sg_pass1 = "void sub_file_write_" + s_cfilename 
		$app sg_pass1, "(void);"
	      sub_c_lineout
	  endi

	  d_byte = d_byte + 9
	  $len d_any, sg_filenames
	  dift d_byte > d_any: dinc d_loop
    endw

    $out sg_subroutine + " done"
ends sub_c_prototypes_open_read_write_close_files


subr sub_c_subroutine_open_files
'updated 2007/06/27, 2007/06/16, 2005/01/09
'make c subroutine fsub_open_files to open files
    vari s_any, d_any, s_dot, d_dot, s_out
    vari s_filename, s_filedevice, s_filetype, d_filereclong
    vari s_filefixed, s_fileksam, d_action
    vari d_filekeybeg, d_filekeylong, s_fileopenmode
    vari d_loop, d_byte, d_good, s_cfilename, s_fromsubr

    $sys sg_subroutine, 2 
    s_fromsubr = sg_subroutine

    sub_c_blankline
    sg_pass1 = "void fsub_open_files(void) {"
    sub_c_lineout

    sg_pass1 = "char cz[80]; long n_status;"
    sub_c_lineout

    sg_pass1 = "long n_old, n_update, n_lock, n_shr;"
    sub_c_lineout
    
'sg_filenames
'12345678
'aaaaaaaa=filename

'sg_filedevs
'aaaaaaaa=filedev

'sg_fileinfos
'12345678
'aabbbbcd
'aa=file type: ID,UD,IC,O
'bbbb=file record length
'c=file is F=fixed or V=variable
'd=file is F=flat or K=KSAM

'sg_filekeys
'12345678
'aaaabbbb
'aaaa=file key begin
'bbbb=file key length

    d_byte = 1
    d_loop = 1
    dwhi d_loop = 1

	  $cut s_filename, sg_filenames, d_byte, 8
	  $sho s_fromsubr + " " + s_filename

	  sg_pass1 = s_filename
	  sub_rpg_file_info_return
	  s_filedevice = sg_pass1
	  s_filetype = sg_pass2
	  s_filefixed = sg_pass3
	  s_fileksam = sg_pass4
	  d_filereclong = dg_pass2
	  d_filekeybeg = dg_pass3
	  d_filekeylong = dg_pass4

	  $ift s_filetype = "ID": s_fileopenmode = "rb"
	  $ift s_filetype = "UD": s_fileopenmode = "r+b"
	  $ift s_filetype = "IC": s_fileopenmode = "rb"
	  $ift s_filetype = "O ": s_fileopenmode = "wb"

	  $tlo s_cfilename, s_filename

	  'skip if terminal I/O since stdin,stdout are open
	  d_action = 1
	  $trb s_filedevice, s_filedevice

	  '$STDIN will use the standard stdin
	  $ift s_filedevice = "$STDIN": d_action = 8

	  '$STDLST will use the standard stdout
	  $ift s_filedevice = "$STDLST": d_action = 9

	  $ift s_filefixed = "V"
	      'VPLUS will have V in s_filefixed
		'dg_operatingsystem:1=MPE,2=Unix/Linux,3=C90 only
		dift dg_operatingsystem = 1: d_action = 12
	  endi

	  $ift s_fileksam = "K"
	      'KSAM will have K in s_fileksam
		'dg_operatingsystem:1=MPE,2=Unix/Linux,3=C90 only
		dift dg_operatingsystem = 1: d_action = 13
	  endi

	  dift d_action = 1
	      sg_pass1 = "/* open file " + s_cfilename + " */"
	      sub_c_lineout

	      sg_pass1 = "filep_" + s_cfilename + # = fopen("#
	      $app sg_pass1, s_cfilename + #", "# 
		$app sg_pass1, s_fileopenmode + #");#
	      sub_c_lineout

	      sg_pass1 = "if(filep_" + s_cfilename + " == NULL) {"
	      sub_c_lineout

		sg_pass1 = "/* file open error */"
		sub_c_lineout

	      sg_pass1 = #sprintf(cz, "file not opened=# + s_cfilename
		$app sg_pass1, ", mode=" + s_fileopenmode + #");#
	      sub_c_lineout

		sg_pass1 = "tsub_cerror(cz);"
		sub_c_lineout
	  
	      sg_pass1 = "} /* file open error */"
	      sub_c_lineout

	      sub_c_blankline
	  endi

	  dift d_action = 13
	      'open_file KSAM on MPE
		'dg_operatingsystem:1=MPE,2=Unix/Linux,3=C90 only
'static void open_file(void) {
'/* Open file for shared update access with locking */
'int status;
'const int old=1, update=5, lock=1, shr=3;
'HPFOPEN(&filenum, &status,
'2, "-" FILENAME "-",
'3, &old,
'5, &dollarnull
'11, &update,
'12, &lock,
'13, &shr);
'assert(!status);
'}
	      sg_pass1 = "/* open file " + s_cfilename + " */"
	      sub_c_lineout

		sg_pass1 = "n_old=1; n_update=5; n_lock=1; n_shr=3;"
	      sub_c_lineout

		$ift s_filetype = "ID"
		    'n_update=0 means input demand
		    sg_pass1 = "n_update = 0;"
		    sub_c_lineout
		else
		    'n_update=5 means update demand
		    sg_pass1 = "n_update = 5;"
		    sub_c_lineout
		endi

		sg_pass1 = "/* HP intrinsic HPFOPEN */"
		sub_c_lineout

	      sg_pass1 = "HPFOPEN(&iksam_filenum_" + s_cfilename + ", "
		$app sg_pass1, "&n_status, "
	      $app sg_pass1, #2, "-" "# + s_cfilename + #" "-", # 
		$app sg_pass1, "3, &n_old, "
		$app sg_pass1, "11, &n_update, "
		$app sg_pass1, "12, &n_lock, "
		$app sg_pass1, "13, &n_shr);"
	      sub_c_lineout

		'ksam file open error
		'n_status=13107343 is for $null
	      sg_pass1 = "if(n_status != 0 && n_status != 13107343) {"
	      sub_c_lineout

		sg_pass1 = "/* ksam file open error */"
		sub_c_lineout

	      sg_pass1 = #sprintf(cz, "kfile not opened=# + s_cfilename
		$app sg_pass1, ", mode=" + s_fileopenmode + #");#
	      sub_c_lineout

		sg_pass1 = "tsub_cerror(cz);"
		sub_c_lineout
	  
	      sg_pass1 = "} /* file open error */"
	      sub_c_lineout

		'$null files give an error that we do not
		'want for ksam lookup files
		dift dg_fullcdebug1 = 1
		    'n_status=0 means file was opened
	          sg_pass1 = "if(n_status != 0) {"
	          sub_c_lineout

		    sg_pass1 = "/* file open error */"
		    sub_c_lineout

	          sg_pass1 = #sprintf(cz, "kfile not opened=#
		    $app sg_pass1, s_cfilename
		    $app sg_pass1, ", mode=" + s_fileopenmode + #");#
	          sub_c_lineout

		    sg_pass1 = "tsub_cerror(cz);"
		    sub_c_lineout
	  
	          sg_pass1 = "} /* file open error */"
	          sub_c_lineout
		endi

		'if file opened do a blank setll
		sg_pass1 = "if(n_status == 0) {"
		sub_c_lineout

		sg_pass1 = "/* HP intrinsic FFINDBYKEY */"
		sub_c_lineout

		'we have a blank literal
	      sg_pass1 = "tsub_blank(tsg_256a, 256);"
		sub_c_lineout		

	      'FFINDBYKEY(filenum,value,location,length,relop)
	      'value=key
	      'relop=2 means find record >= key
	      sg_pass1 = "FFINDBYKEY(iksam_filenum_" + s_cfilename
	      $app sg_pass1, ", tsg_256a, " + d_filekeybeg
	      $app sg_pass1, ", " + d_filekeylong + ", 2);"
	      sub_c_lineout

	      'if ccode()=CCG then end of file or before beginning
	      'set iksam_mode_ to 2 if beyond end or before beginning
	      'set iksam_mode_ to 1 if good setll>=key
	      sg_pass1 = "if(ccode() == CCG) iksam_mode_"
	      $app sg_pass1, s_cfilename + " = 2;"
	      sub_c_lineout

	      sg_pass1 = "else iksam_mode_"
	      $app sg_pass1, s_cfilename + " = 1;"
	      sub_c_lineout

	      'set iksam_advanceflag to false=2
	      sg_pass1 = "iksam_advanceflag_" + s_cfilename
	      $app sg_pass1, " = 2;"
	      sub_c_lineout

		sg_pass1 = "}"
		sub_c_lineout

	      sub_c_blankline
	  endi

	  d_byte = d_byte + 9
	  $len d_any, sg_filenames
	  dift d_byte > d_any: dinc d_loop
    endw

    sg_pass1 = "} /* void fsub_open_files(void) */"
    sub_c_lineout
    sub_c_blankline
    $out sg_subroutine + " done"
ends sub_c_subroutine_open_files


subr sub_c_subroutine_read_files
'updated 2005/01/10
'make c subroutines to read tsg_input from the files
    vari s_any, d_any, s_dot, d_dot, s_out
    vari s_filename, s_filedevice, s_filetype, d_filereclong
    vari s_filefixed, s_fileksam
    vari d_filekeybeg, d_filekeylong
    vari d_loop, d_stringbyte, s_fromsubr
    vari s_filebytevar, s_fileopenmode, s_cfilename
    vari d_yesreadterm, d_yesreadfile, d_yesreadpfile
    vari d_yeschainfile, d_yesreadksamfile, d_yesreadpksamfile
    
    $sys sg_subroutine, 2 
    s_fromsubr = sg_subroutine

'fline    1         2         3         4         5         6
'123456789012345678901234567890123456789012345678901234567890
'    .FTERMIN  ID  F      80            $STDIN
'    .FTERMOUT O   F      80            $STDLST

'sg_filenames
'12345678
'aaaaaaaa=filename

'sg_filedevs
'aaaaaaaa=filedev

'sg_fileinfos
'12345678
'aabbbbcd
'aa=file type: ID,UD,IC,O
'bbbb=file record length
'c=file is F=fixed or V=variable
'd=file is F=flat or K=KSAM

'sg_filekeys
'12345678
'aaaabbbb
'aaaa=file key begin
'bbbb=file key length

    'loop through filenames in sg_filenames
    d_stringbyte = 1
    d_loop = 1
    dwhi d_loop = 1

	  $cut s_filename, sg_filenames, d_stringbyte, 8
	  $sho s_fromsubr + " " + s_filename

	  sg_pass1 = s_filename
	  sub_rpg_file_info_return
	  s_filedevice = sg_pass1
	  s_filetype = sg_pass2
	  s_filefixed = sg_pass3
	  s_fileksam = sg_pass4
	  d_filereclong = dg_pass2
	  d_filekeybeg = dg_pass3
	  d_filekeylong = dg_pass4

	  $ift s_filetype = "ID": s_fileopenmode = "rb"
	  $ift s_filetype = "UD": s_fileopenmode = "r+b"
	  $ift s_filetype = "IC": s_fileopenmode = "rb"
	  $ift s_filetype = "O ": s_fileopenmode = "wb"

	  $tlo s_cfilename, s_filename
	  $trb s_filedevice, s_filedevice

	  d_yesreadterm = 2
	  d_yesreadfile = 2
	  d_yesreadpfile = 2
	  d_yeschainfile = 2
	  d_yesreadksamfile = 2
	  d_yesreadpksamfile = 2

	  $ift s_filetype = "ID"
		$ift s_filedevice = "$STDIN"
		    d_yesreadterm = 1
		else
		    $lok d_any, sg_readfile, 1, s_filename
		    dift d_any > 0
			  $ift s_fileksam = "K"
				d_yesreadksamfile = 1
			  else
				d_yesreadfile = 1
			  endi
		    endi

		    $lok d_any, sg_readpfile, 1, s_filename
		    dift d_any > 0
			  $ift s_fileksam = "K"
				d_yesreadpksamfile = 1
			  else
				d_yesreadpfile = 1
			  endi
		    endi
		endi
	  endi
	  $ift s_filetype = "UD"
	      $lok d_any, sg_readfile, 1, s_filename
	      dift d_any > 0
		    $ift s_fileksam = "K"
			  d_yesreadksamfile = 1
		    else
			  d_yesreadfile = 1
		    endi
	      endi

	      $lok d_any, sg_readpfile, 1, s_filename
	      dift d_any > 0
		    $ift s_fileksam = "K"
			  d_yesreadksamfile = 1
		    else
			  d_yesreadfile = 1
		    endi
		endi
	  endi
	  $ift s_filetype = "IC"
	      $lok d_any, sg_chainfile, 1, s_filename
	      dift d_any > 0: d_yeschainfile = 1
	  endi

	  dift d_yesreadterm = 1
		'read from $STDIN
	      sg_pass1 = "void sub_file_read_" + s_cfilename
		$app sg_pass1, "(void) {"
	      sub_c_lineout

		sg_pass1 = "tsub_blank(tsg_input, 79);"
		sub_c_lineout

		sg_pass1 = "fgets(tsg_input, 79, stdin);"
		sub_c_lineout

		sg_pass1 = "tsub_blank_escapes(tsg_input, 79);"
		sub_c_lineout

	      sg_pass1 = "} /* sub_file_read_" + s_cfilename + " */"
	      sub_c_lineout

	      sub_c_blankline
		'd_yesreadterm = 1
	  endi
	  dift d_yesreadfile = 1
		'create subr to read from a file named s_cfilename
		'this is an input demand or input update file
	      sg_pass1 = "void sub_file_read_" + s_cfilename
		$app sg_pass1, "(void) {"
	      sub_c_lineout

	      sg_pass1 = "long n_length; long n_filebyte; long n_eor;"
	      sub_c_lineout
	      sub_c_blankline

		'n_eor = length of end of record characters
		'dg_operatingsystem:1=MPE,2=Unix/Linux,3=C90 only
		dift dg_operatingsystem = 1
		    'MPE appears to have a LF at the end of records
		    sg_pass1 = "n_eor = 1;"
		    sub_c_lineout
		endi
		dift dg_operatingsystem = 2
		    'Unix/Linux as only LF at the end of records
		    sg_pass1 = "n_eor = 1;"
		    sub_c_lineout
		endi
		dift dg_operatingsystem = 3
		    'C90 only with CR and LF at the end of records
		    sg_pass1 = "n_eor = 2;"
		    sub_c_lineout
		endi

	      'build name of the filebyte variable for below
	      s_filebytevar = "ng_filebyte_" + s_cfilename

		'prepare the filebyte long var
		sg_pass1 = "if(" + s_filebytevar + " < 0) "
		$app sg_pass1, "n_filebyte = 0;"
		sub_c_lineout

		sg_pass1 = "else n_filebyte = " + s_filebytevar
		$app sg_pass1, " + " + d_filereclong 
		$app sg_pass1, " + n_eor;"
		sub_c_lineout

'long n_pos = 0;
'fseek(pfg_fixran_pdb, n_pos, SEEK_END);
'ng_record_last = ftell(pfg_fixran_pdb) / 114;
'fseek(pfg_fixran_pdb, n_pos, SEEK_SET);
'i_end = fread(sp_record, 1, 114, pfg_fixran_pdb);
'if(i_end != 114) {

		'set the spot to where we want to read
	      sg_pass1 = "fseek(filep_" + s_cfilename
		$app sg_pass1, ", n_filebyte, SEEK_SET);"
	      sub_c_lineout

		'read the record
	      sg_pass1 = "n_length = fread(tsg_input, 1, "
		$app sg_pass1, d_filereclong
	      $app sg_pass1, ", filep_" + s_cfilename + ");"
	      sub_c_lineout

		'blank LF and on in the record
		sg_pass1 = "tsub_blank_lf_and_after(tsg_input, "
		$app sg_pass1, d_filereclong + ");"
	      sub_c_lineout

'debug read a record
arrb
$toi 1, "if(tig_cdebug == 1) {"
s_any = #printf("file=# + s_cfilename
$app s_any, # READ at=%ld, length=%ld\n", #
$app s_any, "n_filebyte, n_length);"
$toi 2, s_any
$toi 3, "tsub_cdebug(tsg_input);"
$toi 4, "}"	  
sub_c_arrayout

		'did we read a record or not
	      sg_pass1 = "if(n_length > 0) {"
	      sub_c_lineout

		'we read the record
	      sg_pass1 = "tig_eof = 2;"
	      sub_c_lineout

	      sg_pass1 = s_filebytevar + " = n_filebyte;"
	      sub_c_lineout

		'no we did not read the record
		sg_pass1 = "} else tig_eof = 1;"
	      sub_c_lineout

	      sg_pass1 = "} /* rsub_file_read_" + s_cfilename + " */"
	      sub_c_lineout

	      sub_c_blankline
		'd_yesreadfile = 1
	  endi
	  dift d_yesreadpfile = 1
		'create subr to readp from a file named s_cfilename
	      sg_pass1 = "void sub_file_readp_"
		$app sg_pass1, s_cfilename + "(void) {"
	      sub_c_lineout

	      sg_pass1 = "long n_length = 0; long n_filebyte; "
		$app sg_pass1, "long n_eor;"
	      sub_c_lineout
	      sub_c_blankline

		'n_eor = length of end of record characters
		'dg_operatingsystem:1=MPE,2=Unix/Linux,3=C90 only
		dift dg_operatingsystem = 1
		    'MPE appears to have a LF at the end of records
		    sg_pass1 = "n_eor = 1;"
		    sub_c_lineout
		endi
		dift dg_operatingsystem = 2
		    'Unix/Linux as only LF at the end of records
		    sg_pass1 = "n_eor = 1;"
		    sub_c_lineout
		endi
		dift dg_operatingsystem = 3
		    'C90 only with CR and LF at the end of records
		    sg_pass1 = "n_eor = 2;"
		    sub_c_lineout
		endi

	      'build name of the filebyte long since we use it a lot
	      s_filebytevar = "ng_filebyte_" + s_cfilename

		'prepare the filebyte long var
		sg_pass1 = "n_filebyte = " + s_filebytevar
		$app sg_pass1, " - " + d_filereclong 
		$app sg_pass1, " - n_eor;"
		sub_c_lineout
 
'long n_pos = 0;
'fseek(pfg_fixran_pdb, n_pos, SEEK_END);
'ng_record_last = ftell(pfg_fixran_pdb) / 114;
'fseek(pfg_fixran_pdb, n_pos, SEEK_SET);
'i_end = fread(sp_record, 1, 114, pfg_fixran_pdb);
'if(i_end != 114) {

		'readp n_byte cannot be < 0
		sg_pass1 = "if(n_filebyte >= 0) {"
		sub_c_lineout

		'set the spot to where we want to read
	      sg_pass1 = "fseek(filep_" + s_cfilename
		$app sg_pass1, ", n_filebyte, SEEK_SET);"
	      sub_c_lineout

		'read the record
	      sg_pass1 = "n_length = fread(tsg_input, 1, "
		$app sg_pass1, d_filereclong
	      $app sg_pass1, ", filep_" + s_cfilename + ");"
	      sub_c_lineout

		sg_pass1 = "}"
		sub_c_lineout

'debug readp a record
arrb
$toi 1, "if(tig_cdebug == 1) {"
s_any = #printf("file=# + s_cfilename
$app s_any, # READP at=%ld, length=$ld\n", #
$app s_any, "n_filebyte, n_length);"
$toi 2, s_any
$toi 3, "tsub_cdebug(tsg_input);"
$toi 4, "}"	  
sub_c_arrayout

		'did we read a record or not
	      sg_pass1 = "if(n_length > 0) {"
	      sub_c_lineout

		'we read the record
	      sg_pass1 = "tig_eof = 2;"
	      sub_c_lineout

	      sg_pass1 = s_filebytevar + " = n_filebyte;"
	      sub_c_lineout

		'no we did not read the record
		sg_pass1 = "} else tig_eof = 1;"
	      sub_c_lineout

	      sg_pass1 = "} /* rsub_file_readp_" + s_cfilename + " */"
	      sub_c_lineout

	      sub_c_blankline
		'd_yesreadpfile = 1
	  endi
	  dift d_yeschainfile = 1
		'create subr to chain from a file named s_cfilename
	      sg_pass1 = "void sub_file_chain_" + s_cfilename
		$app sg_pass1, "(long np_recnum) {"
	      sub_c_lineout

	      sg_pass1 = "long n_length = 0; long n_filebyte;"
		$app sg_pass1, "n_eor;"
	      sub_c_lineout
	      sub_c_blankline

		'n_eor = length of end of record characters
		'dg_operatingsystem:1=MPE,2=Unix/Linux,3=C90 only
		dift dg_operatingsystem = 1
		    'MPE appears to have a LF at the end of records
		    sg_pass1 = "n_eor = 1;"
		    sub_c_lineout
		endi
		dift dg_operatingsystem = 2
		    'Unix/Linux as only LF at the end of records
		    sg_pass1 = "n_eor = 1;"
		    sub_c_lineout
		endi
		dift dg_operatingsystem = 3
		    'C90 only with CR and LF at the end of records
		    sg_pass1 = "n_eor = 2;"
		    sub_c_lineout
		endi

		'get n_byte from np_recnum
		sg_pass1 = "n_filebyte = (" + d_filereclong
		$app sg_pass1, " + n_eor) * np_recnum;"
		sub_c_lineout

'long n_pos = 0;
'fseek(pfg_fixran_pdb, n_pos, SEEK_END);
'ng_record_last = ftell(pfg_fixran_pdb) / 114;
'fseek(pfg_fixran_pdb, n_pos, SEEK_SET);
'i_end = fread(sp_record, 1, 114, pfg_fixran_pdb);
'if(i_end != 114) {

		'set the spot to where we want to read
	      sg_pass1 = "fseek(filep_" + s_cfilename
		$app sg_pass1, ", n_filebyte, SEEK_SET);"
	      sub_c_lineout

		'read the record
	      sg_pass1 = "n_length = fread(tsg_input, 1, "
		$app sg_pass1, d_filereclong
	      $app sg_pass1, ", filep_" + s_cfilename + ");"
	      sub_c_lineout

'debug chain a record
arrb
$toi 1, "if(tig_cdebug == 1) {"
s_any = #printf("file=# + s_cfilename
$app s_any, # CHAIN at=%ld, length=%ld\n", #
$app s_any, "n_filebyte, n_length);"
$toi 2, s_any
$toi 3, "tsub_cdebug(tsg_input);"
$toi 4, "}"	  
sub_c_arrayout

		'did we read a record
	      sg_pass1 = "if(n_length > 0) tig_eof = 2;"
	      sub_c_lineout

		sg_pass1 = "else tig_eof = 1;"
	      sub_c_lineout

	      sg_pass1 = "} /* rsub_file_chain_" + s_cfilename + " */"
	      sub_c_lineout

	      sub_c_blankline
		'd_yeschainfile = 1
	  endi
	  dift d_yesreadksamfile = 1
		'create subr to ksam read from a file named s_cfilename
		'this is an input demand or input update file
	      sg_pass1 = "void sub_file_read_" + s_cfilename
		$app sg_pass1, "(void) {"
	      sub_c_lineout

	      sg_pass1 = "long n_length; long n_filebyte; long n_eor;"
	      sub_c_lineout
	      sub_c_blankline

		sg_pass1 = "/* HP intrinsic FREAD */"
		sub_c_lineout

		sg_pass1 = "n_length = FREAD(iksam_filenum_"
		$app sg_pass1, s_cfilename + ", tsg_input, -"
		$app sg_pass1, d_filereclong + ");"
		sub_c_lineout

		'if CCG then end of file and advance flag=false
		sg_pass1 = "if(ccode() == CCG) {"
		sub_c_lineout

		sg_pass1 = "tig_eof = 1;"
		sub_c_lineout

		sg_pass1 = "iksam_advanceflag_" + s_cfilename + " = 2;"
		sub_c_lineout

		sg_pass1 = "}"
		sub_c_lineout

		sg_pass1 = "else {"
		sub_c_lineout

		sg_pass1 = "tig_eof = 2;"
		sub_c_lineout

		sg_pass1 = "iksam_advanceflag_" + s_cfilename + " = 1;"
		sub_c_lineout

		sg_pass1 = "}"
		sub_c_lineout

		'blank LF and on in the record
		sg_pass1 = "tsub_blank_lf_and_after(tsg_input, "
		$app sg_pass1, d_filereclong + ");"
	      sub_c_lineout

'debug read a record
arrb
$toi 1, "if(tig_cdebug == 1) {"
s_any = #printf("file=# + s_cfilename
$app s_any, # READ at=%ld, length=%ld\n", #
$app s_any, "n_filebyte, n_length);"
$toi 2, s_any
$toi 3, "tsub_cdebug(tsg_input);"
$toi 4, "}"	  
sub_c_arrayout
		sg_pass1 = "} /* sub_file_read_" + s_cfilename
		$app sg_pass1, sg_asterslash
		sub_c_lineout
		'd_yesreadksamfile = 1
	  endi
	  dift d_yesreadpksamfile = 1
		'create subr to ksam readp from a file named s_cfilename
		'this is an input demand or input update file
	      sg_pass1 = "void sub_file_readp_" + s_cfilename
		$app sg_pass1, "(void) {"
	      sub_c_lineout

	      sg_pass1 = "long n_length; long n_filebyte; long n_eor;"
	      sub_c_lineout
	      sub_c_blankline

		sg_pass1 = "/* HP intrinsic FSPACE */"
		sub_c_lineout

		'back one line or two depending on iksam_advanceflag
		sg_pass1 = "if(iksam_advanceflag_" + s_cfilename
		$app sg_pass1, " == 1) {"
		sub_c_lineout

		sg_pass1 = "FSPACE(iksam_filenum_"
		$app sg_pass1, s_cfilename + ", -2);"
		sub_c_lineout

		sg_pass1 = "}"
		sub_c_lineout

		sg_pass1 = "else {"
		sub_c_lineout

		sg_pass1 = "FSPACE(iksam_filenum_"
		$app sg_pass1, s_cfilename + ", -1);"
		sub_c_lineout

		sg_pass1 = "}"
		sub_c_lineout

		sg_pass1 = "/* HP intrinsic FREAD */"
		sub_c_lineout

		sg_pass1 = "n_length = FREAD(iksam_filenum_"
		$app sg_pass1, s_cfilename + ", tsg_input, -"
		$app sg_pass1, d_filereclong + ");"
		sub_c_lineout

		'if CCG then end of file and advance flag=false
		sg_pass1 = "if(ccode() == CCG) {"
		sub_c_lineout

		sg_pass1 = "tig_eof = 1;"
		sub_c_lineout

		sg_pass1 = "iksam_advanceflag_" + s_cfilename + " = 2;"
		sub_c_lineout

		sg_pass1 = "}"
		sub_c_lineout

		sg_pass1 = "else {"
		sub_c_lineout

		sg_pass1 = "tig_eof = 2;"
		sub_c_lineout

		sg_pass1 = "iksam_advanceflag_" + s_cfilename + " = 1;"
		sub_c_lineout

		sg_pass1 = "}"
		sub_c_lineout

		'blank LF and on in the record
		sg_pass1 = "tsub_blank_lf_and_after(tsg_input, "
		$app sg_pass1, d_filereclong + ");"
	      sub_c_lineout

'debug read a record
arrb
$toi 1, "if(tig_cdebug == 1) {"
s_any = #printf("file=# + s_cfilename
$app s_any, # READ at=%ld, length=%ld\n", #
$app s_any, "n_filebyte, n_length);"
$toi 2, s_any
$toi 3, "tsub_cdebug(tsg_input);"
$toi 4, "}"	  
sub_c_arrayout
		sg_pass1 = "} /* sub_file_readp_" + s_cfilename
		$app sg_pass1, sg_asterslash
		sub_c_lineout
		'd_yesreadpksamfile = 1
	  endi

	  d_stringbyte = d_stringbyte + 9
	  $len d_any, sg_filenames
	  dift d_stringbyte > d_any: dinc d_loop
    endw

    $out sg_subroutine + " done"
ends sub_c_subroutine_read_files


subr sub_c_subroutine_write_files
'updated 2005/07/06, 2005/07/05, 2004/10/16
'make c subroutines to write tsg_output1 to the files
    vari s_any, d_any, s_dot, d_dot, s_out
    vari s_filename, s_filedevice, s_filetype, d_filereclong
    vari s_filefixed, s_fileksam
    vari d_filekeybeg, d_filekeylong
    vari s_fileopenmode, s_cfilename, d_good, d_action
    vari d_loop, d_byte, s_fromsubr, s_filebytevar
    
    $sys sg_subroutine, 2 
    s_fromsubr = sg_subroutine

    d_byte = 1
    d_loop = 1
    dwhi d_loop = 1

'sg_filenames
'12345678
'aaaaaaaa=filename

'sg_filedevs
'aaaaaaaa=filedev

'sg_fileinfos
'12345678
'aabbbbcd
'aa=file type: ID,UD,IC,O
'bbbb=file record length
'c=file is F=fixed or V=variable
'd=file is F=flat or K=KSAM

'sg_filekeys
'12345678
'aaaabbbb
'aaaa=file key begin
'bbbb=file key length

	  $cut s_filename, sg_filenames, d_byte, 8
	  $sho s_fromsubr + " " + s_filename

	  sg_pass1 = s_filename
	  sub_rpg_file_info_return
	  s_filedevice = sg_pass1
	  s_filetype = sg_pass2
	  s_filefixed = sg_pass3
	  s_fileksam = sg_pass4
	  d_filereclong = dg_pass2
	  d_filekeybeg = dg_pass3
	  d_filekeylong = dg_pass4

	  $ift s_filetype = "ID": s_fileopenmode = "rb"
	  $ift s_filetype = "UD": s_fileopenmode = "r+b"
	  $ift s_filetype = "IC": s_fileopenmode = "rb"
	  $ift s_filetype = "O ": s_fileopenmode = "wb"

	  $tlo s_cfilename, s_filename
	  $trb s_filedevice, s_filedevice

	  d_action = 0
	  $ift s_filetype = "O "
		d_action = 2
		$ift s_filedevice = "$STDLST": d_action = 1
	  endi
	  $ift s_filetype = "UD": d_action = 3

	  dift d_action = 1
		'write to screen
	      sg_pass1 = "void sub_file_write_" + s_cfilename
		$app sg_pass1, "(void) {"
	      sub_c_lineout

		sg_pass1 = "tsg_output1[79] = 0;"
		sub_c_lineout

		sg_pass1 = #printf("%s\n", tsg_output1);#
		sub_c_lineout

	      sg_pass1 = "} /* sub_file_write_" + s_cfilename + " */"
	      sub_c_lineout

	      sub_c_blankline
	  endi
	  dift d_action = 2
		'write to file for output files only
	      sg_pass1 = "void sub_file_write_" + s_cfilename
		$app sg_pass1, "(void) {"
	      sub_c_lineout

	      sg_pass1 = "long n_length;"
	      sub_c_lineout
	      sub_c_blankline

		'dg_operatingsystem:1=MPE,2=Unix/Linux,3=C90 only
		dift dg_operatingsystem = 1
		    'MPE operating system
		    'put on line feed
		    sg_pass1 = "tsg_output1[" + d_filereclong + "] = 10;"
		    sub_c_lineout

		    d_filereclong = d_filereclong + 1
		endi
		dift dg_operatingsystem = 2
		    'Unix/Linux operating system
		    'put on line feed
		    sg_pass1 = "tsg_output1[" + d_filereclong + "] = 10;"
		    sub_c_lineout

		    d_filereclong = d_filereclong + 1
		endi
		dift dg_operatingsystem = 3
		    'C90 only operating system
		    'put on carriage return
		    sg_pass1 = "tsg_output1[" + d_filereclong + "] = 13;"
		    sub_c_lineout

		    'put on line feed
		    d_dot = d_filereclong + 1
		    sg_pass1 = "tsg_output1[" + d_dot + "] = 10;"
		    sub_c_lineout

		    d_filereclong = d_filereclong + 2
		endi

	      'build name of the filebytelong for below
	      s_filebytevar = "ng_filebyte_" + s_cfilename

'long n_pos = 0;
'fseek(pfg_fixran_pdb, n_pos, SEEK_END);
'ng_record_last = ftell(pfg_fixran_pdb) / 114;
'fseek(pfg_fixran_pdb, n_pos, SEEK_SET);
'i_end = fread(sp_record, 1, 114, pfg_fixran_pdb);
'if(i_end != 114) {

'n_pos = (np_record - 1) * 114;
'fseek(pfg_fixran_pdb, n_pos, SEEK_SET);
'i_end = fwrite(sp_record, 1, 114, pfg_fixran_pdb);
'ig_error = 0;
'if(i_end < 114) ig_error++;

		'set the file position to s_filebytevar
	      sg_pass1 = "fseek(filep_" + s_cfilename + ", "
	      $app sg_pass1, s_filebytevar + ", SEEK_SET);"
	      sub_c_lineout

		'output the record
	      sg_pass1 = "n_length = fwrite(tsg_output1, 1, "
		$app sg_pass1, d_filereclong
	      $app sg_pass1, ", filep_" + s_cfilename + ");"
	      sub_c_lineout

'debug excpt output
arrb
$toi 1, "if(tig_cdebug == 1) {"
s_any = #printf("file=# + s_cfilename
$app s_any, # EXCPT output at=%ld\n", #
$app s_any, s_filebytevar + ");"
$toi 2, s_any
$toi 3, "tsub_cdebug(tsg_input);"
$toi 4, "}"	  
sub_c_arrayout

		'if wrong length set tig_eof to 1
	      sg_pass1 = "if(n_length == " + d_filereclong + ") "
	      $app sg_pass1, "tig_eof = 2; else tig_eof = 1;"
	      sub_c_lineout

		'increase the s_filebytevar to the next record
	      sg_pass1 = s_filebytevar + " = " + s_filebytevar 
	      $app sg_pass1, " + " + d_filereclong + ";"
	      sub_c_lineout

	      sg_pass1 = "} /* sub_file_write_" + s_cfilename + " */"
	      sub_c_lineout

	      sub_c_blankline
	  endi
	  dift d_action = 3
		'write to file for update demand files only
	      sg_pass1 = "void sub_file_write_" + s_cfilename + "(void) {"
	      sub_c_lineout

	      sg_pass1 = "long n_length = 0;"
	      sub_c_lineout
	      sub_c_blankline

		'dg_operatingsystem:1=MPE,2=Unix/Linux,3=C90 only
		dift dg_operatingsystem = 1
		    'MPE operating system
		    'no record separator
		endi
		dift dg_operatingsystem = 2
		    'Unix/Linux operating system
		    'put on line feed
		    sg_pass1 = "tsg_output1[" + d_filereclong + "] = 10;"
		    sub_c_lineout

		    d_filereclong = d_filereclong + 1
		endi
		dift dg_operatingsystem = 3
		    'C90 only operating system
		    'put on carriage return
		    sg_pass1 = "tsg_output1[" + d_filereclong + "] = 13;"
		    sub_c_lineout

		    'put on line feed
		    d_dot = d_filereclong + 1
		    sg_pass1 = "tsg_output1[" + d_dot + "] = 10;"
		    sub_c_lineout

		    d_filereclong = d_filereclong + 2
		endi

	      'build name in s_filebytevar for use below
	      s_filebytevar = "ng_filebyte_" + s_cfilename

'long n_pos = 0;
'fseek(pfg_fixran_pdb, n_pos, SEEK_END);
'ng_record_last = ftell(pfg_fixran_pdb) / 114;
'fseek(pfg_fixran_pdb, n_pos, SEEK_SET);
'i_end = fread(sp_record, 1, 114, pfg_fixran_pdb);
'if(i_end != 114) {

'n_pos = (np_record - 1) * 114;
'fseek(pfg_fixran_pdb, n_pos, SEEK_SET);
'i_end = fwrite(sp_record, 1, 114, pfg_fixran_pdb);
'ig_error = 0;
'if(i_end < 114) ig_error++;

		'set the file position to s_filebytevar
	      sg_pass1 = "fseek(filep_" + s_cfilename + ", "
	      $app sg_pass1, s_filebytevar + ", SEEK_SET);"
	      sub_c_lineout

		'output the record
	      sg_pass1 = "n_length = fwrite(tsg_output1, 1, "
		$app sg_pass1, d_filereclong
	      $app sg_pass1, ", filep_" + s_cfilename + ");"
	      sub_c_lineout

'debug excpt output
arrb
$toi 1, "if(tig_cdebug == 1) {"
s_any = #printf("file=# + s_cfilename 
$app s_any, # EXCPT output at=%ld\n", #
$app s_any, s_filebytevar + ");"
$toi 2, s_any
$toi 3, "tsub_cdebug(tsg_input);"
$toi 4, "}"	  
sub_c_arrayout

	      sg_pass1 = "if(n_length == " + d_filereclong + ") "
	      $app sg_pass1, "tig_eof = 2; else tig_eof = 1;"
	      
	      sub_c_lineout

		'for update demand files we do not increase the
		'file byte number after outputting to them

	      sg_pass1 = "} /* sub_file_write_" + s_cfilename + " */"
	      sub_c_lineout

	      sub_c_blankline
	  endi

	  d_byte = d_byte + 9
	  $len d_any, sg_filenames
	  dift d_byte > d_any: dinc d_loop
    endw

    $out sg_subroutine + " done"
ends sub_c_subroutine_write_files


subr sub_c_subroutine_close_files
'updated 2004/10/23
'make c subroutine fsub_close_files to close files
    vari s_any, d_any, s_dot, d_dot, s_out
    vari s_filename, s_filedevice, s_filetype
    vari s_filefixed, s_fileksam
    vari d_filereclong, d_action
    vari d_filekeybeg, d_filekeylong, s_fileopenmode, d_good
    vari d_loop, d_byte, s_cfilename, s_fromsubr

    $sys sg_subroutine, 2 
    s_fromsubr = sg_subroutine

    sub_c_blankline
    sg_pass1 = "void fsub_close_files(void) {"
    sub_c_lineout

'sg_filenames
'12345678
'aaaaaaaa=filename

'sg_filedevs
'aaaaaaaa=filedev

'sg_fileinfos
'12345678
'aabbbbcd
'aa=file type: ID,UD,IC,O
'bbbb=file record length
'c=file is F=fixed or V=variable
'd=file is F=flat or K=KSAM

'sg_filekeys
'12345678
'aaaabbbb
'aaaa=file key begin
'bbbb=file key length

    d_byte = 1
    d_loop = 1
    dwhi d_loop = 1

	  $cut s_filename, sg_filenames, d_byte, 8
	  $sho s_fromsubr + " " + s_filename
	  sg_pass1 = s_filename
	  sub_rpg_file_info_return
	  s_filedevice = sg_pass1
	  s_filetype = sg_pass2
	  s_filefixed = sg_pass3
	  s_fileksam = sg_pass4
	  d_filereclong = dg_pass2
	  d_filekeybeg = dg_pass3
	  d_filekeylong = dg_pass4

	  $ift s_filetype = "ID": s_fileopenmode = "rb"
	  $ift s_filetype = "IC": s_fileopenmode = "rb"
	  $ift s_filetype = "UD": s_fileopenmode = "r+b"
	  $ift s_filetype = "O ": s_fileopenmode = "wb"

	  $tlo s_cfilename, s_filename
	  $trb s_filedevice, s_filedevice

	  'skip closing if terminal I/O
	  d_action = 1

	  '$STDIN will use the standard C stream stdin
        $ift s_filedevice = "$STDIN": d_action = 98

	  '$STDLST will use the standard C stream stdout
        $ift s_filedevice = "$STDLST": d_action = 99

	  $ift s_fileksam = "K": d_action = 13

        dift d_action = 1
	      sg_pass1 = "/* close file " + s_cfilename + " */"
	      sub_c_lineout

	      sg_pass1 = "fclose(filep_" + s_cfilename + ");"

	      
	      sub_c_lineout

	      sub_c_blankline
	  endi

        dift d_action = 13
	      sg_pass1 = "/* close ksam file " + s_cfilename + " */"
	      sub_c_lineout

	      sg_pass1 = "FCLOSE(iksam_filenum_" + s_cfilename 
		$app sg_pass1, ", 0, 0);"
	      sub_c_lineout

	      sub_c_blankline
	  endi

	  d_byte = d_byte + 9
	  $len d_any, sg_filenames
	  dift d_byte > d_any: dinc d_loop
    endw

    sg_pass1 = "} /* void fsub_close_files(void) */"
    sub_c_lineout
    sub_c_blankline
    $out sg_subroutine + " done"
ends sub_c_subroutine_close_files


subr sub_c_prototypes_begsr
'updated 2003/11/18
    vari s_any, d_any, s_dot, d_dot, s_out
    vari s_record, d_loop, d_good, s_fromsubr

    $sys s_fromsubr, 2

'cline    1         2         3         4         5         6
'123456789012345678901234567890123456789012345678901234567890
'    .CSR 01 02 03FACTOR1   COMMDFACTOR2   RESULT  92H919293
    sub_c_blankline

    sg_pass1 = "/* rpg subroutine prototypes */"
    sub_c_lineout

    dg_record = 0

    d_loop = 1
    dwhi d_loop = 1
	  d_good = 1

	  sg_pass1 = s_fromsubr
	  sub_rpg_read_record
	  s_record = sg_pass1

	  dift dg_record = 0
		dinc d_good
		dinc d_loop
	  endi
	  dift d_good = 1
		$cut s_any, s_record, 6, 1
		$ift s_any <> "C": dinc d_good

		$cut s_any, s_record, 28, 5
		$ift s_any <> "BEGSR": dinc d_good
	  endi
	  dift d_good = 1
		$cut s_dot, s_record, 18, 6
		$tlo s_dot, s_dot
		sg_pass1 = "void sub_begsr_" + s_dot + "(void);"
            sub_c_lineout
	  endi
    endw
ends sub_c_prototypes_begsr


subr sub_c_prototypes_excpt
'updated 2007/06/16, 2004/01/19
'prototypes of subroutines to perform excpt output
    vari s_any, d_any, s_dot, d_dot, s_out
    vari s_record, d_loop, d_good, s_excpt, s_allexcpts
    vari s_fromsubr

    $sys s_fromsubr, 2
'oline    1         2         3         4         5         6
'123456789012345678901234567890123456789012345678901234567890
'    .OFILENAMEE 12     01 02 03OLINE
'    .O        E        01 02 03VARIABJB 132 "HEADING LINE  "

    sub_c_blankline
    sg_pass1 = "/* rpg excpt subroutine prototypes */"
    sub_c_lineout

    s_allexcpts = sg_nothing
    dg_record = 0

    d_loop = 1
    dwhi d_loop = 1
	  d_good = 1

	  sg_pass1 = s_fromsubr
	  sub_rpg_read_record
	  s_record = sg_pass1

	  dift dg_record = 0
		dinc d_good
		dinc d_loop
	  endi
	  dift d_good = 1
		'we must have an output excpt tag line
		$cut s_any, s_record, 6, 1
		$ift s_any <> "O": dinc d_good

		$cut s_any, s_record, 15, 1
		$ift s_any <> "E": dinc d_good

		$cut s_excpt, s_record, 32, 6
		$isc d_any, s_excpt, " "
		dift d_any = 1: dinc d_good
	  endi
	  dift d_good = 1
		'have we already done this excpt
		s_any = ":" + s_excpt + ","
		$lok d_any, s_allexcpts, 1, s_any
		dift d_any > 0: dinc d_good
	  endi
	  dift d_good = 1
		$app s_allexcpts, ":" + s_excpt + ","
		$tlo s_excpt, s_excpt
		sg_pass1 = "void sub_excpt_" + s_excpt + "(void);"
            sub_c_lineout
	  endi
    endw
ends sub_c_prototypes_excpt


subr sub_c_initialize_strings
'updated 2004/12/27
'write c lines to initialize strings
    vari s_any, d_any, s_dot, d_dot, s_out
    vari d_loop, d_byte, d_length, d_count
    vari s_string, d_strlength, d_index
    vari s_varname, s_varsize, s_fromsubr
    vari d_vartype, d_varindexct, d_varlongct, d_vardecimalct
    vari s_tabname, d_tablongct

    $sys sg_subroutine, 2
    s_fromsubr = sg_subroutine
    dift dg_tdebug = 1
	  sg_pass1 = sg_subroutine
	  sub_return
    endi

'123456789 sg_rpgvarnames 9 long
'abbbbcccd sg_rpgvarsizes 9 long
'a    = d_vartype: 1=numeric,2=numeric array,6=alpha,7=alpha array
'bbbb = d_varindexct: index count
'ccc  = d_varlongct: length
'd    = d_vardecimalct: decimals

    arrb

    $toi 1, "/* rpg string initialization */"
    $toi 2, "void rsub_initialize_strings(void) {"
    $toi 3, "int iz;"
    d_index = 11

    $len d_length, sg_rpgvarnames
    d_count = 0
    d_byte = 1
    d_loop = 1
    dwhi d_loop = 1
	  dinc d_count
	  d_any = d_count % 100
	  dift d_any = 0: $sho s_fromsubr + "=" + d_count

	  'get variable data from sg_rpgvarnames, sg_rpgvarsizes
	  $cut s_varname, sg_rpgvarnames, d_byte, 9
	  $cut s_varsize, sg_rpgvarsizes, d_byte, 9

        $cut s_any, s_varsize, 1, 1
	  $tod d_vartype, s_any

        $cut s_any, s_varsize, 2, 4
	  $tod d_varindexct, s_any

        $cut s_any, s_varsize, 6, 3
	  $tod d_varlongct, s_any

        $cut s_any, s_varsize, 9, 1
	  $tod d_vardecimalct, s_any

	  d_strlength = d_varindexct * d_varlongct

	  'skip if we have *BLANK or *ZEROS
	  $cut s_any, s_varname, 1, 1
	  $ift s_any = "*": d_vartype = 99999

	  dift d_vartype = 6
		'alpha variable
		$tlo s_dot, s_varname
		s_string = "sg_" + s_dot 
		s_out = "for(iz = 0; iz < " + d_strlength
		$app s_out, "; iz++) " + s_string + "[iz] = ' ';"
		$toi d_index, s_out
		dinc d_index
	  endi
	  dift d_vartype = 7
		'alpha array
		'do we have a table
		$cut s_any, s_varname, 1, 3
		$ift s_any = "TAB"
		    $cut s_any, s_varname, 1, 6
		    $lok d_dot, sg_rpgtabnames1, 1, s_any
		    $cut s_tabname, sg_rpgtabnames2, d_dot, 6
		    sg_pass1 = s_tabname
		    sub_variable_info_return
		    d_tablongct = dg_pass3
		    d_varlongct = d_varlongct + d_tablongct
		endi

	      d_strlength = d_varindexct * d_varlongct
		$tlo s_dot, s_varname
		s_string = "sga_" + s_dot 
		s_out = "for(iz = 0; iz < " + d_strlength
		$app s_out, "; iz++) " + s_string + "[iz] = ' ';"
		$toi d_index, s_out
		dinc d_index
	  endi

	  dift d_index > 1000
		sub_c_arrayout
		arrb
		d_index = 1
	  endi
      
	  'they are 9 long with commas between
	  d_byte = d_byte + 10
	  dift d_byte > d_length: dinc d_loop
    endw

    $toi 901, "} /* rsub_initialize_strings */"

    sub_c_arrayout
    $out s_fromsubr + "=" + d_count
ends sub_c_initialize_strings


subr sub_c_initialize_arrays_from_bottom
'updated 2005/01/27, 2005/01/19, 2005/01/18, 2004/12/29
'make subroutine to initialize bottom strings
    vari s_any, d_any, s_dot, d_dot, s_out
    vari d_loop1, d_loop2, d_good, d_action
    vari d_count, s_fromsubr, d_which, d_long
    vari d_record, s_record, d_yesinarray, d_yesnumeric
    vari s_rpgvarname, s_tlovarname, s_cvarname
    vari d_vartype, d_varindexct, d_varlongct
    vari d_vardecimalct, d_maxperlinect, d_perlinect
    vari d_byte, d_element, s_data, d_index
    vari s_rpgtabname, d_tablongct

    $sys sg_subroutine, 2
    s_fromsubr = sg_subroutine
    dift dg_tdebug = 1
	  sg_pass1 = sg_subroutine
	  sub_return
    endi

    sg_pass1 = "void rsub_initialize_arrays_from_bottom(void) {"
    sub_c_lineout

    'the below strings are made in sub_rpg_valid_varsize_eline
    'sg_bottomarray1, csv with array names 6 long
    'sg_bottomarray2, csv with perlinect 6 long
    'sg_rpgtabnames1, sg_rpgtabnames2

    'find the arrays and initialize
    d_which = 0
    d_yesinarray = 2
    d_byte = 1
    d_record = 0
    dg_filebyte = 1

    d_loop1 = 1
    dwhi d_loop1 = 1
	  d_good = 1
	  d_action = 99999

	  fsip s_record, sg_inpfile, dg_filebyte
	  dift dg_filebyte = 0
		$out s_fromsubr + "=" + d_record
		dg_record = 0
		dinc d_good
		dinc d_loop1
	  endi
	  dift d_good = 1
		dinc d_record

		'tell
		d_any = d_record % 100
		dift d_any = 0: $sho s_fromsubr + "=" + d_record

		'does the record begin with **
		$cut s_any, s_record, 1, 2
		$isc d_any, s_any, "*"
		dift d_any = 1
		    d_action = 1
		    d_yesinarray = 1
		    d_index = 1
		else
		    dift d_yesinarray = 1
			  'use line to update numeric array
			  dift d_yesnumeric = 1: d_action = 2

			  'use line to update alpha array
			  dift d_yesnumeric <> 1: d_action = 3
		    endi
		endi
	  endi
	  dift d_action = 1
		'get the array name if any
		dinc d_which
		$par s_rpgvarname, sg_bottomarray1, ",", d_which

		'do we have a new array to begin initializing
		$tlo s_tlovarname, s_rpgvarname
		$len d_any, s_tlovarname
		dift d_any = 0
		    'no new array so we have an error
		    dinc d_yesinarray
		    d_action = 99999
		    dinc d_loop1

		    'we have unknown array
		    $out d_record + " " + s_record
		    $out "unknown array"
		    sub_variable_lookup

		    dg_error = 1
		endi
	  endi
'123456789 sg_rpgvarnames 9 long
'abbbbcccd sg_rpgvarsizes 9 long
'a    = d_vartype: 1=numeric,2=numeric array,6=alpha,7=alpha array
'bbbb = d_varindexct: index count
'ccc  = d_varlongct: length
'd    = d_vardecimalct: decimals

	  dift d_action = 1
		'we have an array name in s_rpgvarname,s_tlovarname
		$par s_any, sg_bottomarray2, ",", d_which
		$tod d_maxperlinect, s_any

		'get rest of info about this array
		sg_pass1 = s_tlovarname
		sub_variable_info_return
		d_vartype = dg_pass1
		d_varindexct = dg_pass2
		d_varlongct = dg_pass3
		d_vardecimalct = dg_pass4

		'do we have a table
	      'sg_rpgtabnames1, sg_rpgtabnames2
		$cut s_any, s_rpgvarname, 1, 3
		$ift s_any = "TAB"
		    $lok d_dot, sg_rpgtabnames1, 1, s_rpgvarname
		    dbad d_dot = 0

		    'we know it is there
		    $cut s_rpgtabname, sg_rpgtabnames2, d_dot, 6

		    'get rest of info about this tab2
		    sg_pass1 = s_rpgtabname
		    sub_variable_info_return
		    d_tablongct = dg_pass3

		    'add d_varlongct and d_tablongct
		    d_varlongct = d_varlongct + d_tablongct
		endi

		'prepare to use next lines to initialize
		d_yesinarray = 1
		d_byte = 0
		d_element = 0
		dift d_vartype = 2
		    'numeric array
		    s_cvarname = "dga_" + s_tlovarname
		    d_yesnumeric = 1
		endi
		dift d_vartype = 7
		    'alpha array
		    s_cvarname = "sga_" + s_tlovarname
		    d_yesnumeric = 2
		endi
	  endi
	  dift d_action = 2
		'use line to initialize the numeric array
		d_byte = 1
		d_perlinect = 0
		d_loop2 = 1
		dwhi d_loop2 = 1
		    'put data into s_data and then to array
		    $cut s_data, s_record, d_byte, d_varlongct
		    sg_pass1 = s_cvarname + "[" + d_index + "] = "
		    $app sg_pass1, s_data + ";" 
		    
		    sub_c_lineout

		    d_byte = d_byte + d_varlongct
		    dinc d_perlinect
		    dift d_perlinect >= d_maxperlinect: dinc d_loop2
		    dinc d_index
		    dift d_index >= d_varindexct: dinc d_loop2
		endw
 	  endi
	  dift d_action = 3
		'use line to initialize the alpha array

		d_byte = 1
		d_perlinect = 0
		d_loop2 = 1
		dwhi d_loop2 = 1
		    'get the data and copy to the char array
		    $cut s_data, s_record, d_byte, d_varlongct

		    sg_pass1 = s_data
		    sub_right_trim_spaces_only
		    s_data = sg_pass1
		    $len d_long, s_data

		    d_dot = d_index - 1 * d_varlongct

		    'blank the element first
		    sg_pass1 = "tsub_blank(&" + s_cvarname + "[" + d_dot
		    $app sg_pass1, "], " + d_varlongct + ");"
		    sub_c_lineout

		    'copy in the data
		    sg_pass1 = "tsub_copy(&" + s_cvarname + "[" + d_dot
		    $app sg_pass1, #], "# + s_data + #", # + d_long
		    $app sg_pass1, ");"
		    sub_c_lineout

		    d_byte = d_byte + d_varlongct
		    dinc d_perlinect
		    dift d_perlinect >= d_maxperlinect: dinc d_loop2
		    dinc d_index
		    dift d_index > d_varindexct: dinc d_loop2
		endw
 	  endi
    endw
    sg_pass1 = "} /* rsub_initialize_arrays_from_bottom(void) */"
    sub_c_lineout
ends sub_c_initialize_arrays_from_bottom


subr sub_c_subroutines_main
'updated 2004/11/06
vari s_any, d_any, s_dot, d_dot, s_out

    dift dg_fullcdebug1 = 1
	  s_out = "tig_cdebug = 1;"
    else
	  s_out = "tig_cdebug = 2;"
    endi

'blank the string array
arrb

'main calls rsub_rpg_calculations which has non-subr rpg lines
$toi 1, "/* main subroutine */"
$toi 2, "int main(void) {"
$toi 3, "char cz[79];"    

's_out either sets tig_cdebug to 1 or 2 see above
$toi 11, s_out

$toi 21, "tsub_translation_date();"

$toi 31, #if(tig_cdebug == 1) tsub_cdebug("begin program");#

$toi 101, "/* initialize strings */"
$toi 102, #if(tig_cdebug == 1) tsub_cdebug("rsub_initialize_strings");#
$toi 103, "rsub_initialize_strings();"

$toi 201, "/* initialize arrays from bottom */"
$toi 202, "if(tig_cdebug == 1)"
$toi 203, #tsub_cdebug("rsub_initialize_arrays_from_bottom");#
$toi 204, "rsub_initialize_arrays_from_bottom();"

$toi 301, "/* open all of the files */"
$toi 302, #if(tig_cdebug == 1) tsub_cdebug("fsub_open_files");#
$toi 303, "fsub_open_files();"

$toi 401, "/* rpg calculations */"
$toi 402, #if(tig_cdebug == 1) tsub_cdebug("rsub_rpg_calculations");#
$toi 403, "rsub_rpg_calculations();"

$toi 501, "/* close all of the files */"
$toi 502, #if(tig_cdebug == 1) tsub_cdebug("fsub_close_files");#
$toi 503, "fsub_close_files();"

$toi 621, "tsub_translation_date();"
$toi 622, #if(tig_cdebug == 1) tsub_cdebug("end of program");#

$toi 701, "/* return a number to the system */"
$toi 702, "return tig_cerror;"

$toi 801, "/* end of main subroutine */"
$toi 802, "} /* main */"

sub_c_arrayout
ends sub_c_subroutines_main


subr sub_c_prototypes_tsub
'updated 2005/01/13, 2004/12/07
    vari s_any, d_any, s_dot, d_dot, s_out

    'blank the string array
    arrb

    $toi 1, "/* tsub prototypes */"

    'the t on tfni and tsub is for utility

    'prototype tsub_cdebug
    $toi 101, "/* prototype tsub_cdebug */"
    $toi 102, "void tsub_cdebug(char *sp_1);"

    'prototype tsub_numberruler
    $toi 131, "/* prototype tsub_numberruler */"
    $toi 132, "void tsub_numberruler(int ip_beg);"

    'prototype tsub_out79
    $toi 151, "/* prototype tsub_out79 */"
    $toi 152, "void tsub_out79(char *sp_1);"

    'prototype tsub_char_out79
    $toi 161, "/* prototype tsub_char_out79 */"
    $toi 162, "void tsub_char_out79(char sc1);"

    'prototype tsub_cerror
    $toi 171, "/* prototype for tsub_cerror */"
    $toi 172, "void tsub_cerror(char *sp_1);"

    'prototype tsub_runtime_error_exit_program
    $toi 176, "/* prototype tsub_runtime_error_exit_program */"
    $toi 177, "void tsub_runtime_error_exit_program(char *sp_1);"

    'prototype tsub_index_range_cerror
    $toi 181, "/* prototype tsub_index_range_cerror */"
    $toi 182, "void tsub_index_range_cerror(double dp_1, int "
    $toi 183, "ip_max, int ip_line);"

    'prototype tfni_index
    $toi 201, "/* prototype round double to integer for an index */"
    $toi 202, "int tfni_index(double dp_1);"

    'prototype tfnn_from_string
    $toi 301, "/* prototype tfnn_from_string */"
    $toi 302, "long tfnn_from_string(char *ps1, int ip_long);"

    'prototype tfnn_string_of_numbers
    $toi 351, "/* prototype tfnn_string_of_numbers */"
    $toi 352, "long tfnn_string_of_numbers(char *sp_1);"

    'prototype tfnd_round
    $toi 401, "/* prototype round a double to a double */"
    $toi 402, "double tfnd_round(double dp_1, int ip_decimals);"

    'prototype tfnd_trunc
    $toi 501, "/* prototype truncate a double to a double */"
    $toi 502, "double tfnd_trunc(double dp_1, int ip_decimals, "
    $toi 503, "int ip_add);"

    'prototype tsub_copy
    $toi 601, "/* prototype copy sp_2 to sp_1 for length ip_long */"
    $toi 602, "void tsub_copy(char *sp_1, char *sp_2, int ip_long);"

    'prototype tsub_acopy = array copy 
    $toi 701, "/* prototype array copy from sp_2 which is of */"
    $toi 702, "/* length ip_long2 to begin at ip_beg2 to sp_1 */"
    $toi 703, "/* which is of length ip_long1 to begin at ip_beg1 */"
    $toi 704, "void tsub_acopy(char *sp_1, int ip_long1, int ip_beg1,"
    $toi 705, "char *sp_2, int ip_long2, int ip_beg2);"

    'prototype tsub_blank to blank char array
    $toi 851, "void tsub_blank(char *sp_1, int ip_long);"

    'prototype tsub_double_to_packed
    $toi 901, "/* prototype of double to packed */"
    $toi 902, "/* with length and decimals of double */"
    $toi 903, "void tsub_double_to_packed(char *sp_1, "
    $toi 904, "double dp_1, int ip_long, int ip_decimals);"

    'prototype tsub_packed_to_double
    $toi 951, "/* prototype of tsub_packed_to_double */"
    $toi 952, "/* with length and decimals of double */"
    $toi 953, "void tsub_packed_to_double(double *pdp_1, char *sp_1, "
    $toi 954, "int ip_long, int ip_decimals, int ip_line);"
    sub_c_arrayout

    'prototype tfnd_time
    $toi 101, "/* prototype of tfnd_time */"
    $toi 102, "/* with 6=time, 12=time and date */"
    $toi 103, "double tfnd_time(int ip_1);"

    'prototype tsub_time2
    $toi 201, "/* prototype of tsub_time2 */"
    $toi 202, "void tsub_time2(char *sp_1, int ip_long);"

    'prototype tsub_udate
    $toi 301, "/* prototype of tsub_udate */"
    $toi 302, "void tsub_udate(char *sp_1, char cp_1);"

'prototype tsub_zadd_array to do z-add to an array no index
$toi 351, "/* prototype of tsub_zadd_array to do z-add to array */"
$toi 352, "void tsub_zadd_array(double *pdp1, int ip1, double dp2);"

    'prototype tsub_compare_numbers
    $toi 401, "/* prototype of tsub_compare_numbers */"
    $toi 402, "void tsub_compare_numbers(double dp_1, double dp_2,"
    $toi 403, "int *ip_1, int *ip_2, int *ip_3);"

    'prototype tsub_compare_strings
    $toi 451, "/* prototype of tsub_compare_strings */"
    $toi 451, "void tsub_compare_strings(char *sp_1, int ip_long1,"
    $toi 453, "char *sp_2, int ip_long2,"
    $toi 454, "int *ip_1, int *ip_2, int *ip_3);"

    'prototype tfni_compare_strings
    $toi 501, "/* prototype of tfni_compare_strings */"
    $toi 502, "int tfni_compare_strings(char *sp_1, "
    $toi 503, "char *sp_2, int ip_long2);"

    'prototype compare string to char for length
    $toi 601, "/* prototype tsub_comp_string_to_char */"
    $toi 602, "void tsub_comp_string_to_char("
    $toi 603, "char *sp_1, int ip_long, char cp_1,"
    $toi 604, "int *ip_1, int *ip_2, int *ip_3);"

    'prototype edit double to string
    $toi 701, "/* prototype edit double to string */"
    $toi 702, "void tsub_edit_double_to_string("
    $toi 703, "char *sp_1, double dp_1, int ip_decimals, "
    $toi 704, "char cp_edit, int *pip_long);"

    'prototype for numeric sort array
    $toi 801, "/* prototype numeric sorta */"
    $toi 802, "void tsub_nsorta(double *dap_array, int ip_indexct);"
 
    'prototype for alpha sort array
    $toi 901, "/* prototype alpha sorta */"
    $toi 902, "void tsub_asorta(char *sap_array, "
    $toi 903, "int ip_indexct, int ip_longct);"
    sub_c_arrayout

    $toi 101, "/* blank escapes for length */"
    $toi 102, "void tsub_blank_escapes(char *sp_1, int ip1);"

    $toi 201, "/* blank line feed and after */"
    $toi 202, "void tsub_blank_lf_and_after(char *sp_1, int ip1);"

$toi 301, "/* prototype tsub_move_right_into_array */"
$toi 302, "void tsub_move_right_into_array(char *sp_1, int ip_indexct1, "
$toi 303, "int ip_longct1, char* sp_2, int ip_longct2);"

$toi 401, "/* prototype tsub_translation_date */"
$toi 402, "void tsub_translation_date(void);"

$toi 501, "/* prototype tsub_upper_case */"
$toi 502, "void tsub_upper_case(char *sp1, int ip_long);"
sub_c_arrayout

ends sub_c_prototypes_tsub


subr sub_c_subroutines_tsub1
'updated 2005/01/14, 2005/01/13, 2005/01/11
    vari s_any, d_any, s_dot, d_dot, s_out

    'blank the string array
    arrb

    $toi 1, "/* tsub subroutines */"

'subroutine tsub_cdebug
$toi 101, "void tsub_cdebug(char *sp_1) {"
$toi 102, "int iy, iz; char cz[80];"
$toi 121, "if(sp_1[0] != 0) {"
$toi 122, "tsub_out79(sp_1);"
$toi 123, "}"
$toi 131, #tsub_out79("cdebug to turn off cdebug or return");#
$toi 132, "fgets(cz, 79, stdin);"
$toi 133, "tsub_upper_case(cz, 6);"
$toi 141, #iy = tfni_compare_strings(cz, "CDEBUG", 6);#
$toi 161, "if(iy == 0) {"
$toi 162, "if(tig_cdebug == 1) tig_cdebug++;"
$toi 163, "else tig_cdebug = 1;"
$toi 164, "}"
$toi 181, "} /* tsub_cdebug */"

'subroutine tsub_numberruler
$toi 201, "/* subroutine tsub_numberruler */"
$toi 202, "void tsub_numberruler(int ip_beg) {"
$toi 203, "char cz[160]; int iz;"
$toi 204, #char s_num[11] = "1234567890";#
$toi 221, "for(iz = 0; iz < 80; iz++) cz[iz] = '.';"
$toi 231, "for(iz = 0; iz < 10; iz++) {"
$toi 232, "tsub_copy(&cz[ip_beg + iz * 10], s_num, 10);"
$toi 233, "}"
$toi 281, "tsub_out79(cz);"
$toi 291, "} /* tsub_numberruler */"
sub_c_arrayout

'subroutine tsub_out79
$toi 201, "/* subroutine tsub_out79 */"
$toi 202, "void tsub_out79(char *sp_1) {"
$toi 203, "int iy, iz; char cz[80];"
$toi 211, "for(iy = 1, iz = 0; iz < 79; iz++) {"
$toi 212, "if(sp_1[iz] == 0) iy++;"
$toi 213, "if(iy == 1) {"
$toi 214, "cz[iz] = sp_1[iz];"
$toi 215, "if(cz[iz] < 32) cz[iz] = 32;"
$toi 216, "}"
$toi 217, "else cz[iz] = 32;"
$toi 231, "}"
$toi 241, "cz[79] = 0;"
$toi 242, "puts(cz);"
$toi 251, "} /* tsub_out79 */"

'subroutine tsub_char_out79
$toi 261, "/* subroutine tsub_char_out79 */"
$toi 262, "void tsub_char_out79(char sc1) {"
$toi 263, "char cz[80]; int iz;"
$toi 271, "for(iz = 0; iz < 80; iz++) cz[iz] = sc1;"
$toi 272, "tsub_out79(cz);"
$toi 279, "} /* tsub_char_out79 */"

'subroutine tsub_cerror
$toi 301, "void tsub_cerror(char *sp_1) {"
$toi 302, "/* for cerrors */"
$toi 321, "tsub_out79(sp_1);"
$toi 322, #tsub_cdebug("error");#
$toi 331, "tig_cerror = 1;"
$toi 391, "} /* tsub_cerror */"

'subroutine tsub_index_range_cerror
$toi 401, "/* subroutine tsub_index_range_cerror */"
$toi 402, "void tsub_index_range_cerror(double dp_1, "
$toi 403, "int ip_max, int ip_line) {"
$toi 411, "char cz[50]; int iz; int i_error = 2;"
$toi 421, "if(dp_1 > 32767 || dp_1 < 0.99) i_error = 1;"
$toi 422, "else {"
$toi 431, "iz = (int)floor(dp_1 + 0.51);"
$toi 432, "if(iz < 1 || iz > ip_max) i_error = 1;"
$toi 433, "}"
$toi 451, "if(i_error == 1) {"
$toi 452, #sprintf(cz, "line=%d has bad index=%lf", ip_line, dp_1);#
$toi 461, "tsub_runtime_error_exit_program(cz);"
$toi 491, "}"
$toi 499, "} /* tsub_index_range_cerror */"

'subroutine tsub_runtime_error_exit_program
$toi 501, "/* subroutine tsub_runtime_error_exit_program */"
$toi 502, "void tsub_runtime_error_exit_program(char *sp_1) {"
$toi 503, "char cz[80];"
$toi 511, "tsub_out79(sp_1);"
$toi 521, #tsub_out79("runtime error, program will now end");#
$toi 522, "fgets(cz, 79, stdin);"
$toi 531, "fsub_close_files();"
$toi 541, "exit(1);"
$toi 599, "} /* tsub_runtime_error_exit_program */"

sub_c_arrayout

'subroutine tfni_index
$toi 11, "int tfni_index(double dp_1) {"
$toi 12, "/* round double to integer */"
$toi 13, "int iz; double dz;"
$toi 21, "dz = floor(dp_1 + 0.51);"
$toi 22, "if(dz > 32767) iz = 32767;"
$toi 23, "else if(dz < -32767) iz = -32767;"
$toi 24, "else iz = (int)dz;"
$toi 25, "return iz;"
$toi 26, "} /* tfni_index */"

'subroutine tfnn_from_string
$toi 101, "long tfnn_from_string(char *ps1, int ip_long) {"
$toi 102, "/* subroutine string to long */"
$toi 103, "long n_result = 0; int i_char; int iz;"
$toi 104, "for(iz = 0; iz < ip_long; iz++) {"
$toi 105, "i_char = ps1[iz];"
$toi 106, "/* ignore non-numeric characters */"
$toi 107, "if(i_char >= 48 && i_char <= 57) {"
$toi 108, "n_result = n_result * 10 + i_char - 48;"
$toi 109, "}"
$toi 110, "}"
$toi 111, "return n_result;"
$toi 199, "} /* tfnn_from_string */"

'subroutine tfnn_string_of_numbers
$toi 201, "long tfnn_string_of_numbers(char *sp_1) {"
$toi 202, "/* subroutine string of numbers to long */"
$toi 203, "long n_result = 0; int i_char; int iz;"
$toi 211, "for(iz = 0; iz < 9; iz++) {"
$toi 212, "i_char = sp_1[iz];"
$toi 221, "/* stop at non-number */"
$toi 222, "if(i_char >= 48 && i_char <= 57) {"
$toi 223, "n_result = n_result * 10 + i_char - 48;"
$toi 224, "}"
$toi 231, "else iz = 100;"
$toi 251, "}"
$toi 291, "return n_result;"
$toi 299, "} /* tfnn_string_of_numbers */"

sub_c_arrayout

'subroutine tfnd_round
$toi 201, "double tfnd_round(double dp_1, int ip_decimals) {"
$toi 202, "/* round double by decimals */"
$toi 203, "double dz, d_fact; int iz;"
$toi 204, "d_fact = 1.0;"
$toi 205, "for(iz = 0; iz < ip_decimals; iz++) d_fact = d_fact * 10;"
$toi 206, "dz = floor(dp_1 * d_fact + 0.5) / d_fact;"
$toi 207, "return dz;"
$toi 208, "} /* tfnd_round */"

    'subroutine tfnd_trunc
    $toi 301, "double tfnd_trunc(double dp_1, int ip_decimals, "
    $toi 302, "int ip_add) {"
    $toi 303, "/* truncate double by decimals */"
    $toi 304, "double dz, d_fact; int i_neg, iz;"

    $toi 311, "dz = dp_1; i_neg = 2;"
    $toi 312, "if(dz < 0.0) {"
    $toi 313, "dz = -dz; i_neg = 1;"
    $toi 314, "}"

    $toi 331, "d_fact = 1.0;"
    $toi 332, "for(iz = 0; iz < ip_decimals; iz++) "
    $toi 333, "d_fact = d_fact * 10;"

    $toi 341, "dz = dz * d_fact;"
    $toi 342, "if(ip_add == 1) dz = dz + 0.001;"
    $toi 343, "dz = floor(dz) / d_fact;"
    $toi 344, "if(i_neg == 1) dz = -dz;"

    $toi 391, "return dz;"
    $toi 399, "} /* tfnd_trunc */"

'subroutine tsub_copy
$toi 401, "void tsub_copy(char *sp_1, char *sp_2, int ip_long) {"
$toi 402, "/* to copy from sp_2 to sp_1 for length ip_long */"
$toi 403, "int iz;"
$toi 404, "for(iz = 0; iz < ip_long; iz++) sp_1[iz] = sp_2[iz];"
$toi 405, "} /* tsub_copy */"

'subroutine tsub_acopy
$toi 501, "void tsub_acopy(char *sp_1, int ip_long1, int ip_beg1,"
$toi 502, "char *sp_2, int ip_long2, int ip_beg2){"
$toi 503, "/* array copy */"
$toi 504, "int i_error, i_count, iy, iz;"
$toi 505, "i_error = 2;"
$toi 506, "/* first index is 0, last index is long-1 */"
$toi 507, "if(ip_beg1 >= ip_long1) i_error = 1;"
$toi 508, "if(ip_beg2 >= ip_long2) i_error = 1;"
$toi 509, "if(ip_beg1 < 0 || ip_beg2 < 0) i_error = 1;"
$toi 510, "i_count = ip_long1 - ip_beg1;"
$toi 511, "iz = ip_long2 - ip_beg2;"
$toi 512, "if(i_count > iz) i_count = iz;" 
$toi 513, "if(i_error != 1) {"
$toi 514, "for(iz = 0; iz < i_count; iz++)"
$toi 515, "sp_1[ip_beg1 + iz] = sp_2[ip_beg2 + iz];"
$toi 516, "}"
$toi 517, "} /* tsub_acopy */"

sub_c_arrayout
ends sub_c_subroutines_tsub1


subr sub_c_subroutines_tsub2
'updated 2005/01/17, 2004/09/18
vari s_any, d_any, s_dot, d_dot, s_out

'blank the string array
arrb

'subroutine tsub_blank to blank char array
$toi 201, "void tsub_blank(char *sp_1, int ip_long) {"
$toi 203, "/* subroutine blank char array for ip_long */"
$toi 206, "int iz;"
$toi 210, "for(iz = 0; iz < ip_long; iz++) sp_1[iz] = ' ';"
$toi 211, "} /* tsub_blank */"

sub_c_arrayout
arrb

'subroutine tsub_double_to_packed
$toi 201, "void tsub_double_to_packed(char *sp_1, "
$toi 202, "double dp_1, int ip_long, int ip_decimals) {"
$toi 203, "/* subroutine of double to packed */"
$toi 204, "/* with length and decimals of double */"
$toi 205, "char cz[40]; int iy, iz, i_neg; double dz;"
$toi 206, "dz = dp_1;"
$toi 207, "i_neg = 2;"
$toi 208, "if(dz < 0) {"
$toi 209, "dz = - dz;"
$toi 210, "i_neg = 1;"
$toi 211, "}" 
$toi 212, "for(iz = 0; iz < ip_decimals; iz++) dz = dz * 10;"
$toi 213, "for(iz = 0; iz < 40; iz++) cz[iz] = ' ';"
$toi 214, "/* zero filled no decimal places decimal in cz[20] */"
$toi 215, #sprintf(cz, "%020.0lf", dz);#
$toi 221, "/* the far right digit is in cz[19] */"
$toi 222, "if(i_neg == 1) {"
$toi 223, "if(cz[19] >= '1' && cz[19] <= '9') cz[19] = cz[19] + 25;"
$toi 224, "else if(cz[19] == '0') cz[19] = '}';"
$toi 225, "}"
$toi 226, "iy = 20 - ip_long;"
$toi 227, "for(iz = 0; iz < ip_long; iz++, iy++) sp_1[iz] = cz[iy];"    
$toi 228, "} /* tsub_double_to_packed */"

'subroutine tsub_packed_to_double
$toi 301, "void tsub_packed_to_double(double *pdp_1, char *sp_1, "
$toi 302, "int ip_long, int ip_decimals, int ip_line) {"
$toi 303, "/* subroutine of packed to double */"
$toi 304, "/* with length and decimals of double */"
$toi 305, "int ix, iy, iz; int i_good; char cz[80];"
$toi 306, "double dz = 0; int i_error = 0;"

$toi 321, "/* A-I is 1-9, J-R is 1-9, S-Z is 2-9 */"
$toi 322, "/* blank and { are zero, } is -zero */"
$toi 323, "/* A is 65, J is 74, S is 83 */"
$toi 324, "/* 0 is char 48 and 9 is char 57 */"

$toi 341, "/* get all but right most digit */"
$toi 342, "for(iz = 0; iz < (ip_long - 1); iz++) {"
$toi 343, "ix = sp_1[iz];"

$toi 361, "iy = 9999;"
$toi 362, "if(ix >= 48 && ix <= 57) iy = ix - 48;"
$toi 363, "else if(ix == 32) iy = 0;"
$toi 364, "else if(ix >= 65 && ix <= 73) iy = ix - 64;"
$toi 365, "else if(ix >= 74 && ix <= 82) iy = ix - 73;"
$toi 366, "else if(ix >= 83 && ix <= 90) iy = ix - 81;"

$toi 381, "if(iy != 9999) dz = dz * 10 + iy;"
$toi 382, "else i_error = 1;"
$toi 383, "}"

$toi 401, "/* get right most digit and validate */"
$toi 402, "iy = 9999;"
$toi 403, "ix = sp_1[ip_long - 1];"

$toi 421, "/* A=65,I=73,J=74,R=82,{=123,}=125 */"
$toi 422, "if(ix == 32) iy = 0;"
$toi 423, "else if(ix >= 48 && ix <= 57) iy = ix - 48;"
$toi 424, "else if(ix == 123) iy = 0;"
$toi 425, "else if(ix >= 65 && ix <= 73) iy = ix - 64;"

$toi 431, "else if(ix >= 74 && ix <= 82) {"
$toi 432, "iy = 73 - ix;"
$toi 433, "dz = -dz;"
$toi 434, "}"

$toi 441, "else if(ix == 125) {"
$toi 442, "iy = 0;"
$toi 443, "dz = - dz;"
$toi 444, "}"

$toi 451, "if(iy == 9999) i_error = 1;"
$toi 452, "else dz = dz * 10 + iy;"

$toi 461, "/* get decimal correct */"
$toi 462, "for(iz = 0; iz < ip_decimals; iz++) dz = dz / 10;"

$toi 481, "/* do we have an error */"
$toi 482, "if(i_error == 1) {"
$toi 483, "sp_1[ip_long] = 0;"
$toi 484, #sprintf(cz, "line=%d, not number='%s'\n", #
$toi 485, "ip_line, sp_1);"
$toi 486, "tsub_runtime_error_exit_program(cz);"
$toi 487, "}"

$toi 498, "*pdp_1 = dz;"
$toi 499, "} /* tsub_packed_to_double */"

sub_c_arrayout
ends sub_c_subroutines_tsub2


subr sub_c_subroutines_tsub3
'updated 2004/12/07
vari s_any, d_any, s_dot, d_dot, s_out

'blank the string array
arrb

'subroutine tfnd_time
$toi 301, "double tfnd_time(int ip_1) {"
$toi 302, "/* subroutine of tfnd_time */"
$toi 303, "/* with 6=time, 12=time and date */"
$toi 304, "time_t time_1; char sz[50]; char sy[50];"
$toi 305, "double d_result = 0; long n_month = 0; long nz = 0;"

'JanFebMarAprMayJunJulAugSepOctNovDec
'012345678901234567890123
'Wed Oct 30 05:02:00 1996
'sprintf(sz, "%s", ctime(&time_1));
$toi 311, "/* 012345678901234567890123 */"
$toi 312, "/* Wed Oct 30 05:02:00 1996 */"
$toi 313, "/* 050200103096 */"
$toi 314, "time_1 = time(NULL);"

$toi 315, "/* tig_operatingsystem:1=MPE,2=Unix/Linux,3=C90 only */"
$toi 316, "if(tig_operatingsystem == 1) time_1 = time_1 + 14400;"
$toi 317, #sprintf(sz, "%s", ctime(&time_1));#

$toi 321, "d_result = tfnn_from_string(&sz[11], 2);"
$toi 322, "d_result = d_result * 100.0 + tfnn_from_string(&sz[14], 2);"
$toi 323, "d_result = d_result * 100.0 + tfnn_from_string(&sz[17], 2);"

$toi 330, "if(ip_1 >= 12) {"
$toi 331, "nz = sz[4] + sz[5] + sz[6];"
$toi 332, "if(nz == 281) n_month = 1;"
$toi 333, "if(nz == 269) n_month = 2;"
$toi 334, "if(nz == 288) n_month = 3;"
$toi 335, "if(nz == 291) n_month = 4;"
$toi 336, "if(nz == 295) n_month = 5;"
$toi 337, "if(nz == 301) n_month = 6;"
$toi 338, "if(nz == 299) n_month = 7;"
$toi 339, "if(nz == 285) n_month = 8;"
$toi 340, "if(nz == 296) n_month = 9;"
$toi 341, "if(nz == 294) n_month = 10;"
$toi 342, "if(nz == 307) n_month = 11;"
$toi 343, "if(nz == 268) n_month = 12;"

$toi 351, "d_result = d_result * 100.0 + n_month;"
$toi 352, "d_result = d_result * 100.0 + tfnn_from_string(&sz[8], 2);"
$toi 353, "d_result = d_result * 100.0 + tfnn_from_string(&sz[22], 2);"
$toi 354, "}"

$toi 355, "return d_result;"
$toi 356, "} /* tfnd_time */"

'subroutine tsub_time2
$toi 401, "void tsub_time2(char *sp_1, int ip_long) {"
$toi 402, "/* subroutine of tsub_time2 */"
$toi 403, "/*           1         2         3         4 */"
$toi 404, "/* 01234567890123456789012345678901234567890 */"
$toi 405, "/* TUE. APR  4, 2000, 11:05 AM   JULIAN:095 */"
$toi 406, "/* 012345678901234567890123 */"
$toi 407, "/* Wed Oct 30 05:02:00 1996 */"

$toi 411, "time_t time_1; char sz[50]; char sy[50]; int iz;"
$toi 412, "time_1 = time(NULL);"

$toi 421, "/* tig_operatingsystem:1=MPE,2=Unix/Linux,3=C90 only */"
$toi 422, "if(tig_operatingsystem == 1) time_1 = time_1 + 14400;"

$toi 431, #sprintf(sz, "%s", ctime(&time_1));#
$toi 432, "for(iz = 0; iz < 50; iz++) sy[iz] = ' ';"
$toi 433, "tsub_copy(sy, sz, 3);"
$toi 434, "sy[3] = '.';"

$toi 441, "tsub_copy(&sy[5], &sz[4], 6);"
$toi 442, "sy[11] = ',';"

$toi 451, "tsub_copy(&sy[13], &sz[20], 4);"
$toi 452, "sy[17] = ',';"

$toi 461, "tsub_copy(&sy[19], &sz[11], 5);"
$toi 462, "tsub_copy(sp_1, sy, ip_long);"
$toi 499, "} /* tsub_time2 */"

sub_c_arrayout

'subroutine tsub_udate
$toi 501, "/* subroutine of tsub_udate */"
$toi 502, "void tsub_udate(char *sp_1, char cp_1) {"
$toi 503, "/* UDATE into sp_1 using edit code cp_1 */"
$toi 504, "char sz[20]; double dz;"

$toi 511, "dz = tfnd_time(12);"
$toi 512, "dz = fmod(dz, 1000000.0);"
$toi 513, #sprintf(sz, "%08.1lf", dz);#

$toi 521, "tsub_copy(sp_1, sz, 6);"
$toi 522, "if(cp_1 == 'Y') {"
$toi 523, "sp_1[2] = '/'; sp_1[3] = sz[2]; sp_1[4] = sz[3];"
$toi 524, "sp_1[5] = '/'; sp_1[6] = sz[4]; sp_1[7] = sz[5];"
$toi 525, "}"
$toi 526, "} /* tsub_udate */"

'subroutine tsub_zadd_array z-add to array no index
$toi 601, "/* subroutine of tsub_zadd_array z-add to array no index */"
$toi 602, "void tsub_zadd_array(double *pdp1, int ip1, double dp2) {"
$toi 603, "int iz;"
$toi 611, "for(iz = 0; iz < ip1; iz++) pdp1[iz] = dp2;"
$toi 699, "} /* tsub_zadd_array */"

sub_c_arrayout
ends sub_c_subroutines_tsub3


subr sub_c_subroutines_tsub4
'updated 2005/01/04
vari s_any, d_any, s_dot, d_dot, s_out

'blank the string array
arrb

'subroutine tsub_compare_numbers
$toi 501, "void tsub_compare_numbers(double dp_1, double dp_2,"
$toi 502, "int *ip_1, int *ip_2, int *ip_3) {"
$toi 503, "/* subroutine tsub_compare_numbers */"
$toi 504, "/* set result indicators */"
$toi 505, "*ip_1 = 0; *ip_2 = 0; *ip_3 = 0;"
$toi 506, "if(dp_1 > dp_2) *ip_1 = 1;"
$toi 507, "if(dp_1 < dp_2) *ip_2 = 1;"
$toi 508, "if(dp_1 == dp_2) *ip_3 = 1;"
$toi 509, "} /* tsub_compare_numbers */"

'subroutine tfni_compare_strings
$toi 551, "/* subroutine of tfni_compare_strings */"
$toi 552, "int tfni_compare_strings(char *sp_1, char *sp_2, "
$toi 553, "int ip_long) {"
$toi 554, "int iy, iz;"

$toi 571, "iy = 0;"
$toi 572, "for(iz = 0; iy == 0 && iz < ip_long; iz++) {"
$toi 573, "if(sp_1[iz] < sp_2[iz]) iy--;"
$toi 574, "else if(sp_1[iz] > sp_2[iz]) iy++;"
$toi 575, "}"
$toi 589, "return iy;"
$toi 590, "} /* tfni_compare_strings */"

'subroutine tsub_compare_strings
$toi 601, "void tsub_compare_strings(char *sp_1, int ip_long1,"
$toi 602, "char *sp_2, int ip_long2,"
$toi 603, "int *ip_1, int *ip_2, int *ip_3) {"

$toi 611, "/* subroutine tsub_compare_strings */"
$toi 612, "/* set result indicators */"
$toi 613, "int iy, iz; int i_max;"
$toi 614, "*ip_1 = 0; *ip_2 = 0; *ip_3 = 0;"

$toi 621, "i_max = ip_long1;"
$toi 622, "if(i_max > ip_long2) i_max = ip_long2;"

$toi 631, "for(iy = -1, iz = 0; iy == -1 && iz < i_max; iz++) {"
$toi 632, "if(sp_1[iz] != sp_2[iz]) iy = iz;"
$toi 633, "}"

$toi 641, "if(iy == -1) {"
$toi 642, "if(ip_long1 == ip_long2) *ip_3 = 1;"
$toi 643, "if(ip_long1 > ip_long2) *ip_1 = 1;"
$toi 644, "if(ip_long1 < ip_long2) *ip_2 = 1;"
$toi 645, "}"

$toi 651, "else {"
$toi 652, "if(sp_1[iy] > sp_2[iy]) *ip_1 = 1;"
$toi 653, "else *ip_2 = 1;"
$toi 654, "}"

$toi 699, "} /* tsub_compare_strings */"

sub_c_arrayout

'subroutine compare string to char for length
$toi 601, "/* subroutine tsub_comp_string_to_char */"
$toi 602, "void tsub_comp_string_to_char("
$toi 603, "char *sp_1, int ip_long, char cp_1, "
$toi 604, "int *ip_1, int *ip_2, int *ip_3) {"
$toi 611, "int iy, iz;"
$toi 612, "iy = 0; iz = 0;"
$toi 613, "*ip_1 = 2; *ip_2 = 2; *ip_3 = 2;"
$toi 621, "for(; iz < ip_long && iy == 0; iz++) {"
$toi 622, "if(sp_1[iz] > cp_1) iy = 1;"
$toi 623, "else if(sp_1[iz] < cp_1) iy = -1;"
$toi 624, "}"
$toi 631, "if(iy == 1) *ip_1 = 1;"
$toi 632, "if(iy == -1) *ip_2 = 1;"
$toi 633, "if(iy == 0) *ip_3 = 1;"
$toi 642, "} /* tsub_comp_string_to_char */"

sub_c_arrayout
ends sub_c_subroutines_tsub4


subr sub_c_subroutines_tsub5
'updated 2006/07/12, 2006/06/29, 2006/06/28, 2005/01/06
vari s_any, d_any, s_dot, d_dot, s_out

    'blank the string array
    arrb

    'subroutine edit double to string
    $toi 701, "void tsub_edit_double_to_string("
    $toi 702, "char *sp_1, double dp_1, int ip_decimals, "
    $toi 703, "char cp_edit, int *pip_long) {"
    $toi 704, "/* subroutine edit double to string */"
    $toi 705, "/* *pip_long is the length of the number */"

    $toi 721, "char s_format[20], ca_y[30], ca_z[30], cz;"
    $toi 722, "int i_long, iw, ix, iy, iz;"
    $toi 723, "double d_double; int i_neg = 2;"
    $toi 724, "int i_yescommas = 2, i_yessign = 2, i_yeszero = 2;"
    $toi 725, #char s_numbers[12] = "0123456789";#

'first column is no sign, second has sign             
'1,000 & zero 1 J
'1,000        2 K
'zero         3 L
'neither      4 M
'also Y and Z
$toi 741, "if(cp_edit == '1' || cp_edit == '2' || cp_edit == 'J' "
$toi 742, "|| cp_edit == 'K') i_yescommas = 1;"
$toi 743, "if(cp_edit >= 'J' && cp_edit <= 'M') i_yessign = 1;"
$toi 744, "if(cp_edit == '1' || cp_edit == 'J' || cp_edit == '3' "
$toi 745, "|| cp_edit == 'L') i_yeszero = 1;"

    $toi 761, "tsub_blank(sp_1, 30);"
    $toi 762, "tsub_blank(ca_z, 30);"
    $toi 763, "tsub_blank(ca_y, 30);"
    $toi 764, "tsub_blank(s_format, 20);"
    $toi 765, "i_long = *pip_long;"

'make format string in s_format
'0123456789
'%25.2lf
    $toi 781, #tsub_copy(s_format, "%25.2lf", 7);#
    $toi 782, "s_format[4] = s_numbers[ip_decimals];"
    $toi 783, "s_format[7] = 0;"

    'make number positive
    $toi 801, "if(dp_1 < 0) {"
    $toi 802, "d_double = - dp_1; i_neg = 1;"
    $toi 803, "}"
    $toi 804, "else {"
    $toi 805, "d_double = dp_1; i_neg = 2;"
    $toi 806, "}"

    'put number in string add 1 to length for decimal
    $toi 821, #/* sprintf(ca_z, "%25.2lf", d_double); */#
    $toi 822, "sprintf(ca_z, s_format, d_double);"
    $toi 823, "i_long++;"
    $toi 824, "tsub_copy(ca_y, ca_z, 25);"

    $toi 841, "/* add commas if needed to ca_y */"
    $toi 842, "if(i_yescommas == 1) {"
    $toi 843, "/* first digit left of the decimal is */"
    $toi 844, "/* 23 - ip_decimals */"
    $toi 845, "iw = 23 - ip_decimals;"
    $toi 846, "if(ip_decimals == 0) iw = 24;"

    $toi 861, "/* the positive number ends in 24 */"
    $toi 862, "/* copy digits from ca_z to ca_y adding commas */"
    $toi 863, "for(iy = 0, ix = iw, iz = iw; iz > 0; iz--, ix--) {"
    $toi 864, "/* iy counts the digits */"
    $toi 865, "cz = ca_z[iz];"

    $toi 881, "if(cz >= '0' && cz <= '9') {"
    $toi 882, "/* we have a digit */"
    $toi 883, "iy++;"
    $toi 884, "if(iy > 3) {"
    $toi 885, "iy = 1;"
    $toi 886, "ca_y[ix] = ',';"
    $toi 887, "i_long++;"
    $toi 888, "ix--;"
    $toi 889, "}"
    $toi 890, "ca_y[ix] = cz;"
    $toi 891, "}"
    $toi 892, "}"
    $toi 893, "}"

    'put sign on
    $toi 921, "if(i_yessign == 1) {"
    $toi 922, "if(i_neg == 1) ca_y[25] = '-';"
    $toi 923, "else ca_y[25] = ' ';"
    $toi 924, "i_long++;"
    $toi 925, "tsub_copy(sp_1, ca_y, 26);" 
    $toi 927, "}"

    'do not put sign on
    $toi 941, "else {"
    $toi 942, "sp_1[0] = ' ';"
    $toi 944, "tsub_copy(&sp_1[1], ca_y, 26);"
    $toi 945, "}"

    'not zeros
    $toi 961, "if(d_double == 0.00 && i_yeszero != 1) "
    $toi 962, "tsub_blank(sp_1, 30);"

    $toi 991, "*pip_long = i_long;"
    $toi 999, "} /* tsub_edit_double_to_string */"

    sub_c_arrayout

'subroutine for numeric sort array
$toi 101, "/* subroutine numeric sorta */"
$toi 102, "void tsub_nsorta(double *dap_array, int ip_indexct) {"
$toi 103, "int ix1, ix2, i_last; double dx1, dx2, dx3;"
$toi 104, "i_last = ip_indexct - 1;"

$toi 111, "for(ix1 = 0; ix1 < i_last; ix1++) {"
$toi 112, "dx1 = dap_array[ix1];"
$toi 113, "for(ix2 = ix1 + 1; ix2 <= i_last; ix2++) {"
$toi 114, "dx2 = dap_array[ix2];"
$toi 115, "if(dx1 > dx2) {"
$toi 116, "dap_array[ix2] = dx1;"
$toi 117, "dap_array[ix1] = dx2;"
$toi 118, "dx1 = dx2;" 

$toi 121, "}"
$toi 122, "}"
$toi 123, "}"

$toi 131, "} /* tsub_nsorta */"
 
'subroutine for alpha sort array
$toi 201, "/* subroutine alpha sorta */"
$toi 202, "void tsub_asorta(char *sap_array, "
$toi 203, "int ip_indexct, int ip_longct) {"

$toi 204, "char *ps_1; char *ps_2; int i_index1, i_index2;"
$toi 205, "int i_byte1, i_byte2, i_last, iy, iz; char cz;"

$toi 211, "i_last = ip_indexct;"
$toi 212, "for(i_index1 = 1; i_index1 < i_last; i_index1++) {"
$toi 213, "i_byte1 = (i_index1 - 1) * ip_longct;"
$toi 214, "ps_1 = &sap_array[i_byte1];"

$toi 221, "i_index2 = i_index1 + 1;"
$toi 222, "for(; i_index2 <= i_last; i_index2++) {"
$toi 223, "i_byte2 = (i_index2 - 1) * ip_longct;"
$toi 224, "ps_2 = &sap_array[i_byte2];"

$toi 231, "iy = tfni_compare_strings(ps_1, ps_2, ip_longct);"
$toi 232, "if(iy > 0) {"
$toi 233, "/* switch strings */"
$toi 234, "for(iy = 0; iy < ip_longct; iy++) {"
$toi 235, "cz = sap_array[i_byte1 + iy];"
$toi 236, "sap_array[i_byte1 + iy] = sap_array[i_byte2 + iy];"
$toi 237, "sap_array[i_byte2 + iy] = cz;"
$toi 238, "}"
$toi 239, "}"
$toi 244, "}"
$toi 245, "}"
$toi 251, "} /* tsub_asorta */"

$toi 301, "/* blank escapes for length */"
$toi 302, "void tsub_blank_escapes(char *sp_1, int ip1) {"
$toi 303, "int iz;"
$toi 304, "for(iz = 0; iz < ip1; iz++) {"
$toi 305, "if(sp_1[iz] < 32) sp_1[iz] = ' ';"
$toi 306, "}"
$toi 311, "} /* tsub_blank_escapes */"

$toi 401, "/* blank LF and after */"
$toi 402, "void tsub_blank_lf_and_after(char *sp_1, int ip1) {"
$toi 403, "int iy, iz;"

$toi 411, "for(iy = 0, iz = 0; iz < ip1; iz++) {"
'$toi 412, #if(sp_1[iz] < 32) printf("char=%d\n", sp_1[iz]);#
$toi 413, "if(sp_1[iz] == 10) iy = 1;"
$toi 414, "if(iy == 1) sp_1[iz] = ' ';"
$toi 441, "}"
$toi 451, "} /* tsub_blank_lf_after */"

$toi 501, "/* subroutine tsub_move_right_into_array */"
$toi 502, "void tsub_move_right_into_array(char *sp_1, int ip_indexct1, "
$toi 503, "int ip_longct1, char *sp_2, int ip_longct2) {"
$toi 504, "int i_index, iy, iz;"
'$toi 506, #printf("%d, %d, %d\n", ip_indexct1, ip_longct1, ip_longct2);#
$toi 511, "if(ip_longct2 > ip_longct1) ip_longct2 = ip_longct1;"

$toi 521, "for(i_index = 1; i_index <= ip_indexct1; i_index++) {"
$toi 522, "iz = (i_index - 1) * ip_longct1;"
$toi 523, "iz = iz + ip_longct1 - ip_longct2;"
$toi 524, "for(iy = 0; iy < ip_longct2; iy++) sp_1[iz + iy] = sp_2[iy];"
$toi 571, "}"

$toi 581, "} /* tsub_move_right_into_array */"

$toi 601, "/* subroutine tsub_translation_date */"
$toi 602, "void tsub_translation_date(void) {"

$toi 621, "tsub_char_out79('-');"
    'rpgtoc translation date
    $dat s_any
    $cut s_any, s_any, 1, 20
    $app s_any, " " + sg_inpfile
    $app s_any, " translated by rpgtoc.tea for "
    dift dg_operatingsystem = 1: $app s_any, "MPE"
    dift dg_operatingsystem = 2: $app s_any, "Linux"
    dift dg_operatingsystem = 3: $app s_any, "C90"

    s_any = #tsub_out79("# + s_any + #");#
$toi 661, s_any

$toi 671, "tsub_char_out79('-');"

$toi 680, "} /* tsub_translation_date */"


$toi 701, "/* subroutine tsub_upper_case */"
$toi 702, "void tsub_upper_case(char *sp1, int ip_long) {"
$toi 711, "int iz;"
$toi 721, "for(iz = 0; iz < ip_long; iz++) {"
$toi 731, "if(sp1[iz] >= 97 && sp1[iz] <= 122)"
$toi 732, "sp1[iz] = sp1[iz] - 32;"
$toi 751, "}"
$toi 780, "} /* tsub_upper_case */"

sub_c_arrayout
ends sub_c_subroutines_tsub5

'******************
'printf codes below
'%c one character
'%d integer
'%ld long
'%lf double
'%s string of char
'printf codes above
'******************

subr sub_c_prototypes_rpg_commands
'updated 2005/01/13, 2004/12/27
vari s_any, d_any, s_dot, d_dot, s_out

'blank the string array
arrb

$toi 101, "/* rpg command prototypes */"

$toi 201, "void rsub_rpg_calculations(void);"

$toi 301, "void rsub_initialize_strings(void);"

$toi 401, "void rsub_initialize_arrays_from_bottom(void);"

$toi 501, "void rsub_command_seton(int *ip_1,int *ip_2,int *ip_3);"

$toi 601, "void rsub_command_setof(int *ip_1,int *ip_2,int *ip_3);"

    $toi 701, "double rfnd_math_result(double dp_num, "
    $toi 702, "int ip_decimals, char c_half, int ip_add);"

    $toi 801, "double rfnd_divide(double dp_1, double dp_2,"
    $toi 802, "int ip_dec, char cp_half, int ip_line);"

$toi 851, "double rfnd_mvr_modulus(double dp_1, double dp_2,"
$toi 852, "int ip_dec, char cp_half, int ip_line);"
sub_c_arrayout

$toi 101, "double rfnd_add(double dp1, int ip1, double dp2, int ip2);"

$toi 201, "double rfnd_subtract(double dp1, int ip1, "
$toi 202, "double dp2, int ip2);"

$toi 301, "void rsub_testn(char *sp_1, int ip_long, int *ip1, "
$toi 302, "int *ip2, int *ip3);"

$toi 401, "int rfni_slokup(char *sp_lookin, int ip_indexct, "
$toi 402, "int ip_long, int ip_begindex, char *sp_lookfor);"

$toi 451, "int rfni_stablokup(char *sp_lookin, int ip_indexct, "
$toi 452, "int ip_long1, int ip_long2, char *sp_lookfor, "
$toi 453, "char *sp_putinto);"

$toi 501, "int rfni_nlokup(double *dp_lookin, int ip_indexct, "
$toi 502, "int ip_decimals, int ip_begindex, double dp_lookfor);"

$toi 601, "void rsub_command_biton(char *sp_to, char *sp_from, "
$toi 602, "int ip_long);"

$toi 701, "void rsub_command_bitof(char *sp_to, char *sp_from, "
$toi 702, " int ip_long);"

$toi 801, "double rfnd_xfoot(double *dp_1, int ip_indexct);"
sub_c_arrayout

$toi 101, "void rsub_putjw(char *sp_1, double dp_1, int *ip_2);"

$toi 201, "void rsub_fndjw(char *sp_1, double *dp_1, int *ip_2);"

sub_c_arrayout
ends sub_c_prototypes_rpg_commands


subr sub_c_subroutines_rpg_commands
'updated 2005/01/13, 2004/12/29
    vari s_any, d_any, s_dot, d_dot, s_out

    'blank the string array
    arrb

'subroutine seton command
$toi 1, "/* seton command */"
$toi 2, "void rsub_command_seton(int *ip_1,int *ip_2,int *ip_3) {"
$toi 3, "*ip_1 = 1; *ip_2 = 1; *ip_3 = 1;"
$toi 4, "} /* rsub_command_seton */"

'subroutine setof command
$toi 101, "/* setof command */"
$toi 102, "void rsub_command_setof(int *ip_1,int *ip_2,int *ip_3) {"
$toi 103, "*ip_1 = 2; *ip_2 = 2; *ip_3 = 2;"
$toi 104, "} /* rsub_command_setof */"

    'subroutine rfnd_math_result
    $toi 201, "/* math result */"
    $toi 202, "double rfnd_math_result(double dp_num, "
    $toi 203, "int ip_decimals, char cp_half, int ip_add) {"

    $toi 211, "double dz;"
    $toi 212, "dz = dp_num;"

    $toi 221, "if(cp_half == 'H') {"
    $toi 222, "dz = tfnd_round(dp_num, ip_decimals);"
    $toi 223, "}"

    $toi 231, "else {"
    $toi 232, "dz = tfnd_trunc(dp_num, ip_decimals, ip_add);"
    $toi 233, "}"

    $toi 241, "return dz;"
    $toi 249, "} /* rfnd_math_result */"

    'subroutine rfnd_divide
    $toi 301, "double rfnd_divide(double dp_1, double dp_2,"
    $toi 302, "int ip_dec, char cp_half, int ip_line) {"
    $toi 303, "double dz = 0; char cz[50];"

    $toi 311, "if(dp_2 == 0.0) {"
    $toi 312, #sprintf(cz, "zero divide line=%d", ip_line);#
    $toi 313, "tsub_runtime_error_exit_program(cz);"

    $toi 331, "}"
    $toi 351, "else {"
    $toi 352, "if(cp_half == 'H') {"
    $toi 353, "dz = tfnd_round(dp_1 / dp_2, ip_dec);"
    $toi 354, "}"

    $toi 361, "else {"
    $toi 362, "dz = tfnd_trunc(dp_1 / dp_2, ip_dec, 0);"
    $toi 363, "}"
    $toi 364, "}"

    $toi 395, "return dz;"
    $toi 399, "} /* rfnd_divide */"

    'subroutine rfnd_mvr_modulus
    $toi 401, "double rfnd_mvr_modulus(double dp_1, double dp_2,"
    $toi 402, "int ip_dec, char cp_half, int ip_line) {"
    $toi 403, "double dz = 0; char cz[50];"
    $toi 411, "if(dp_2 == 0.0) {"
    $toi 412, #sprintf(cz, "zero mvr modulus line=%d", ip_line);#
    $toi 413, "tsub_runtime_error_exit_program(cz);"
    $toi 431, "}"
    $toi 451, "else {"
    $toi 452, "if(cp_half == 'H') {"
    $toi 453, "dz = tfnd_round(fmod(dp_1, dp_2), ip_dec);"
    $toi 454, "}"
    $toi 461, "else {"
    $toi 462, "dz = tfnd_trunc(fmod(dp_1, dp_2), ip_dec, 0);"
    $toi 463, "}"
    $toi 491, "}"
    $toi 495, "return dz;"
    $toi 499, "} /* rfnd_mvr_modulus */"

    sub_c_arrayout

'subroutine rfnd_add to add two numbers
$toi 501, "double rfnd_add(double dp1, int ip1, "
$toi 502, "double dp2, int ip2){"
$toi 503, "double d_factor, d_total; int iy, iz;"
$toi 504, "iy = ip1; d_factor = 1;"
$toi 505, "if(ip2 > ip1) iy = ip2;"
$toi 506, "for(iz = 0; iz < iy; iz++) d_factor = d_factor * 10;"
$toi 507, "d_total = dp1 * d_factor + dp2 * d_factor;"
$toi 508, "d_total = floor(d_total + 0.5) / d_factor;"
$toi 509, "return d_total;"
$toi 510, "} /* rfnd_add */"

'subroutine rfnd_subtract to sub two numbers
$toi 601, "double rfnd_subtract(double dp1, int ip1, "
$toi 602, "double dp2, int ip2){"
$toi 603, "double d_factor, d_total; int iy, iz;"
$toi 604, "iy = ip1; d_factor = 1;"
$toi 605, "if(ip2 > ip1) iy = ip2;"
$toi 606, "for(iz = 0; iz < iy; iz++) d_factor = d_factor * 10;"
$toi 607, "d_total = dp1 * d_factor - dp2 * d_factor;"
$toi 608, "d_total = floor(d_total + 0.5) / d_factor;"
$toi 609, "return d_total;"
$toi 610, "} /* rfnd_subtract */"

'subroutine rsub_testn
$toi 701, "/* subroutine of rsub_testn */"
$toi 702, "void rsub_testn(char *sp_1, int ip_long, int *ip1, "
$toi 703, "int *ip2, int *ip3) {"
$toi 704, "int i_result, i_blanks, i_num, i_char, iy, iz;"
$toi 705, "i_blanks = 0; i_num = 0; iy = 0;"

'all numbers turn on high, the manuals are wrong about all blanks
'blanks and numbers turn on low
'blanks only turn on equal

$toi 706, "for(iz = 0; iz < ip_long; iz++) {"
$toi 707, "i_char = sp_1[iz];"
$toi 708, "if(i_char == 32 && iy ==0) i_blanks++;"
$toi 709, "else {"
$toi 710, "iy++;"
$toi 711, "if(i_char >= '0' && i_char <= '9') i_num++;"
$toi 712, "else if(iz == (ip_long - 1)) {"
$toi 713, "if(i_char >= 'A' && i_char <= 'R') i_num++;"
$toi 714, "if(i_char == '{' || i_char == '}') i_num++;"
$toi 715, "}"
$toi 716, "}"
$toi 717, "}"

$toi 721, "*ip1 = 2; *ip2 = 2; *ip3 = 2;"

$toi 731, "if(i_num == ip_long) *ip1 = 1;"
$toi 732, "if(i_blanks == ip_long) *ip3 = 1;"

$toi 741, "iz = i_blanks + i_num; iy = i_blanks * i_num;"
$toi 742, "if(iz == ip_long && iy > 0) *ip2 = 1;"
$toi 751, "} /* rsub_testn */"

'subroutine rfni_slokup
$toi 801, "/* subroutine rfni_slokup */"
$toi 802, "/* numeric parameters as in rpg */"
$toi 803, "int rfni_slokup(char *sp_lookin, int ip_indexct, "
$toi 804, "int ip_long, int ip_begindex, char *sp_lookfor) {"

$toi 805, "int i_result = 0; int i_index, i_byte, iy, iz;"

$toi 806, "i_index = ip_begindex;"
$toi 807, "for(; i_index <= ip_indexct; i_index++) {"
$toi 808, "i_byte = (i_index - 1) * ip_long;"

$toi 809, "for(iy = 1, iz = 0; iz < ip_long; iz++) {" 
$toi 810, "if(sp_lookin[i_byte + iz] != sp_lookfor[iz]) iy++;"
$toi 811, "}"

$toi 812, "if(iy == 1) {"
$toi 813, "i_result = i_index;"
$toi 814, "i_index = ip_indexct + 1;"
$toi 815, "}"

$toi 816, "}"

$toi 817, "return i_result;"
$toi 818, "} /* rfni_slokup */"

'subroutine rsub_stablokup
$toi 851, "int rfni_stablokup(char *sp_lookin, int ip_indexct, "
$toi 852, "int ip_long1, int ip_long2, char *sp_lookfor, "
$toi 853, "char *sp_putinto) {"
$toi 861, "int i_result, i_loop, iw, ix, iy, iz;"
$toi 862, "i_result = 2; i_loop = 1; iz = 0;"
$toi 863, "iw = ip_long1 + ip_long2;"

$toi 866, "while(i_loop == 1) {"
$toi 867, "ix = tfni_compare_strings(&sp_lookin[iz * iw], sp_lookfor, "
$toi 868, "ip_long1);"
$toi 869, "if(ix == 0) {"
$toi 870, "i_result = 1; i_loop++;"
$toi 871, "iy = iz * iw + ip_long1;"
$toi 872, "}"
$toi 875, "iz++;"
$toi 876, "if(iz >= ip_indexct) i_loop++;"
$toi 877, "}"
$toi 881, "if(i_result == 1) tsub_copy(sp_putinto, &sp_lookin[iy], "
$toi 882, "ip_long2);"

$toi 889, "return i_result;"
$toi 890, "} /* rfni_stablokup */"

'subroutine rfni_nlokup
$toi 901, "/* subroutine rfni_nlokup */"
$toi 902, "/* numeric parameters as in rpg */"
$toi 903, "int rfni_nlokup(double *dpp_lookin, int ip_indexct, "
$toi 904, "int ip_decimals, int ip_begindex, double dp_lookfor) {"

$toi 911, "int i_result = 0; int i_index, i_cindex, iy, iz;"
$toi 912, "double d_lookfor, d_lookat;"
$toi 913, "d_lookfor = tfnd_trunc(dp_lookfor, ip_decimals, 0);"
$toi 914, "i_index = ip_begindex;"
$toi 921, "for(; i_index <= ip_indexct; i_index++) {"
$toi 922, "i_cindex = i_index - 1;"
$toi 923, "d_lookat = tfnd_trunc(dpp_lookin[i_cindex], "
$toi 924, "ip_decimals, 0);" 

$toi 931, "if(d_lookfor == d_lookat) {"
$toi 932, "i_result = i_index;"
$toi 933, "i_index = ip_indexct + 1;"
$toi 941, "}"
$toi 951, "}"
$toi 961, "return i_result;"
$toi 999, "} /* rfni_nlokup */"

sub_c_arrayout

'subroutine rsub_command_bitof
$toi 101, "/* rsubroutine rsub_command_bitof */"
$toi 102, "void rsub_command_bitof(char *sp_to, char *sp_from,"
$toi 103, "int ip_long) {"
$toi 104, "int iz;"

'diagnostic
'$toi 107, "iz = sp_to[0];"
'$toi 108, #printf("bitof1=%d\n", iz);#

$toi 111, "for(iz = 0; iz < ip_long; iz++) {"
$toi 112, "if(sp_from[iz] == '7') sp_to[0] = sp_to[0] & ~1;"
$toi 113, "else if(sp_from[iz] == '6') sp_to[0] = sp_to[0] & ~2;"
$toi 114, "else if(sp_from[iz] == '5') sp_to[0] = sp_to[0] & ~4;"
$toi 115, "else if(sp_from[iz] == '4') sp_to[0] = sp_to[0] & ~8;"
$toi 116, "else if(sp_from[iz] == '3') sp_to[0] = sp_to[0] & ~16;"
$toi 117, "else if(sp_from[iz] == '2') sp_to[0] = sp_to[0] & ~32;"
$toi 118, "else if(sp_from[iz] == '1') sp_to[0] = sp_to[0] & ~64;"
$toi 119, "else if(sp_from[iz] == '0') sp_to[0] = sp_to[0] & ~128;"
$toi 121, "}"

'diagnostic
'$toi 181, "iz = sp_to[0];"
'$toi 182, #printf("bitof2=%d\n", iz);#

$toi 199, "} /* rsub_command_bitof */"

'subroutine rsub_command_biton
$toi 201, "/* rsubroutine rsub_command_biton */"
$toi 202, "void rsub_command_biton(char *sp_to, char *sp_from,"
$toi 203, "int ip_long) {"
$toi 204, "int iz;"

'diagnostic
'$toi 207, "iz = sp_to[0];"
'$toi 208, #printf("biton1=%d\n", iz);#

$toi 211, "for(iz = 0; iz < ip_long; iz++) {"
$toi 212, "if(sp_from[iz] == '7') sp_to[0] = sp_to[0] | 1;"
$toi 213, "else if(sp_from[iz] == '6') sp_to[0] = sp_to[0] | 2;"
$toi 214, "else if(sp_from[iz] == '5') sp_to[0] = sp_to[0] | 4;"
$toi 215, "else if(sp_from[iz] == '4') sp_to[0] = sp_to[0] | 8;"
$toi 216, "else if(sp_from[iz] == '3') sp_to[0] = sp_to[0] | 16;"
$toi 217, "else if(sp_from[iz] == '2') sp_to[0] = sp_to[0] | 32;"
$toi 218, "else if(sp_from[iz] == '1') sp_to[0] = sp_to[0] | 64;"
$toi 219, "else if(sp_from[iz] == '0') sp_to[0] = sp_to[0] | 128;"
$toi 221, "}"

'diagnostic
'$toi 281, "iz = sp_to[0];"
'$toi 282, #printf("biton2=%d\n", iz);#

$toi 299, "} /* rsub_command_biton */"

'subroutine rfnd_xfoot
$toi 301, "/* function rfnd_xfoot */"
$toi 302, "double rfnd_xfoot(double *dp_1, int ip_indexct) {"
$toi 303, "double d_total; int iz;"
$toi 311, "for(d_total = 0, iz = 0; iz < ip_indexct; iz++) {"
$toi 312, "d_total = d_total + dp_1[iz];"
$toi 313, "}"
$toi 349, "return d_total;"
$toi 350, "} /* rfnd_xfoot */"
sub_c_arrayout

'subroutine rsub_putjw
$toi 101, "/* subroutine to do putjw 0 to 65535*/"
$toi 102, "void rsub_putjw(char *sp_1, double dp_1, int *ip_2) {"
$toi 103, "double dz; long n_jcw; int iz; char cz[25];"
$toi 104, "int i_error = 2;"

$toi 111, "tsub_blank(cz, 25);"
$toi 112, "/* 01234567890123456789 */"
$toi 113, "/* SETJCW J234567=65535 */"

$toi 121, #tsub_copy(cz, "SETJCW ", 7);#

$toi 122, "tsub_copy(&cz[7], sp_1, 7);"
$toi 123, "tsub_blank_escapes(cz, 25);"
$toi 124, "cz[14] = '=';"

$toi 141, "dz = floor(dp_1 + 0.51);"
$toi 142, "if(dz > 65535) i_error = 1;"
$toi 143, "else if(dz < 0) i_error = 1;"
$toi 144, "else n_jcw = (long)dz;"

$toi 151, "if(i_error != 1) {"
$toi 152, #sprintf(&cz[15], "%ld", n_jcw);#
$toi 153, "iz = system(cz);"
$toi 154, "if(iz != 0) i_error = 1;"
$toi 155, "}"

$toi 162, "*ip_2 = 2;"
$toi 163, "if(i_error != 1) *ip_2 = 1;"
$toi 199, "} /* rsub_putjw */"

'subroutine rsub_fndjw
$toi 201, "/* subroutine to do fndjw */"
$toi 202, "void rsub_fndjw(char *sp_1, double *dp_1, int *ip_2) {"
$toi 203, "char *ps_1; int iz; char cz[10];"

$toi 211, "tsub_blank(cz, 10);"
$toi 212, "tsub_copy(cz, sp_1, 7);"
$toi 213, "cz[8] = 0;"

$toi 221, "*ip_2 = 2;"
$toi 222, "ps_1 = getenv(cz);"

$toi 231, "if(ps_1 != NULL) {"
$toi 251, "*dp_1 = tfnn_string_of_numbers(ps_1);"
$toi 252, "*ip_2 = 1;"
$toi 253, "}"
$toi 299, "} /* rsub_fndjw */"

sub_c_arrayout
ends sub_c_subroutines_rpg_commands


subr sub_crpg_prototypes
'updated 2004/08/05

arrb

'prototype rsub_crpg_movea
$toi 101, "void rsub_crpg_movea("
$toi 102, "char *sp_1, int ip_indexct1, int ip_longct1, int ip_beg1, "
$toi 103, "char *sp_2, int ip_indexct2, int ip_longct2, int ip_beg2);"
$toi 105, "/* movea from sp_2 to sp_1, rpg parms */"
sub_c_arrayout

'prototype rsub_crpg_movel
$toi 101, "void rsub_crpg_movel("
$toi 102, "char *sp_1, int ip_longct1, "
$toi 103, "char *sp_2, int ip_longct2);"
sub_c_arrayout

'prototype rsub_crpg_move_right
$toi 101, "void rsub_crpg_move_right("
$toi 102, "char *sp_1, int ip_longct1, "
$toi 103, "char *sp_2, int ip_longct2);"
sub_c_arrayout

'prototype rsub_crpg_movea_blankorzero
$toi 101, "void rsub_crpg_movea_blankorzero("
$toi 102, "char *sp_1, int ip_indexct, int ip_longct, "
$toi 103, "int ip_beg, char cp_1);"
$toi 104, "/* subroutine blank or zero to sp_1 of ip_indexct of */"
$toi 105, "/* ip_longct beginning at ip_beg using char cp_1 */"
sub_c_arrayout

ends sub_crpg_prototypes


subr sub_crpg_subroutines
'updated 2004/08/05

arrb

'subroutine rsub_crpg_movea
$toi 101, "void rsub_crpg_movea("
$toi 102, "char *sp_1, int ip_indexct1, int ip_longct1, int ip_beg1, "
$toi 103, "char *sp_2, int ip_indexct2, int ip_longct2, int ip_beg2"
$toi 104, ") {"
$toi 105, "/* movea from sp_2 to sp_1, parms are rpg */"

$toi 111, "int i_cbeg1, i_cbeg2, i_clong1, i_clong2;"
$toi 112, "int i_ctogoct1, i_ctogoct2;"
$toi 113, "int i_cbytect, i_error = 2, iz;"

$toi 141, "i_cbeg2 = (ip_beg2 - 1) * ip_longct2;"
$toi 142, "i_cbeg1 = (ip_beg1 - 1) * ip_longct1;"

$toi 151, "i_clong2 = ip_indexct2 * ip_longct2;"
$toi 152, "i_clong1 = ip_indexct1 * ip_longct1;"

$toi 161, "if(i_cbeg1 < 0 || i_cbeg1 >= i_clong1) i_error = 1;"
$toi 162, "if(i_cbeg2 < 0 || i_cbeg2 >= i_clong2) i_error = 1;"

$toi 171, "i_ctogoct2 = i_clong2 - i_cbeg2;"
$toi 172, "i_ctogoct1 = i_clong1 - i_cbeg1;"
$toi 173, "if(i_ctogoct2 < i_ctogoct1) i_cbytect = i_ctogoct2;"
$toi 174, "else i_cbytect = i_ctogoct1;"

$toi 182, "if(i_error == 1) {"
$toi 183, #tsub_cerror("bad index in MOVEA");#
$toi 184, "}"

$toi 191, "else {"
$toi 192, "for(iz = 0; iz < i_cbytect; iz++) {"
$toi 193, "sp_1[i_cbeg1 + iz] = sp_2[i_cbeg2 + iz];"
$toi 194, "}"
$toi 195, "}"

$toi 299, "} /* rsub_crpg_movea */"
sub_c_arrayout

'subroutine rsub_crpg_movel
$toi 101, "void rsub_crpg_movel("
$toi 102, "char *sp_1, int ip_longct1, "
$toi 103, "char *sp_2, int ip_longct2) {"
$toi 104, "/* movel from sp_2 to sp_1, parms are rpg */"

$toi 111, "int iy, iz;"

$toi 132, "if(ip_longct2 < ip_longct1) iy = ip_longct2;"
$toi 133, "else iy = ip_longct1;"

$toi 141, "for(iz = 0; iz < iy; iz++) sp_1[iz] = sp_2[iz];"

$toi 199, "} /* rsub_crpg_movel */"
sub_c_arrayout

'subroutine rsub_crpg_move_right
$toi 101, "void rsub_crpg_move_right("
$toi 102, "char *sp_1, int ip_longct1, "
$toi 103, "char *sp_2, int ip_longct2) {"
$toi 104, "/* move_right from sp_2 to sp_1 */"

$toi 111, "int iy, iz;"

$toi 131, "if(ip_longct2 < ip_longct1) iy = ip_longct2;"
$toi 132, "else iy = ip_longct1;"

$toi 141, "for(iz = 1; iz <= iy; iz++) {"
$toi 142, "sp_1[ip_longct1 - iz] = sp_2[ip_longct2 - iz];"
$toi 143, "}"

$toi 199, "} /* rsub_crpg_move_right */"
sub_c_arrayout

'subroutine rsub_crpg_movea_blankorzero
$toi 101, "void rsub_crpg_movea_blankorzero("
$toi 102, "char *sp_1, int ip_indexct, int ip_longct, "
$toi 103, "int ip_beg, char cp_1) {"
$toi 104, "/* subroutine blank or zero to sp_1 of ip_indexct of */"
$toi 105, "/* ip_longct beginning at ip_beg using char cp_1 */"
$toi 106, "/* rpg parameters */"

$toi 111, "int i_begbt, i_longtot, iz;"

$toi 121, "i_longtot = ip_indexct * ip_longct;"
$toi 122, "i_begbt = (ip_beg - 1) * ip_longct;"

$toi 131, "if(i_begbt < 0 || i_begbt >= i_longtot) {"
$toi 132, #tsub_cerror("bad index");#
$toi 133, "}"
$toi 134, "else {"

$toi 151, "for(iz = i_begbt; iz < i_longtot; iz++) "
$toi 152, "sp_1[iz] = cp_1;"

$toi 161, "}"
$toi 191, "} /* rsub_crpg_movea_blankorzero */"

sub_c_arrayout
ends sub_crpg_subroutines


subr sub_c_cline_fullcdebug_beg
'updated 2004/07/21
'write clines for cdebug of a program record
    vari s_any, d_any, s_dot, d_dot, s_out
    vari d_record, s_record, d_good, d_yeslines
    vari s_factor1, s_command, s_factor2, s_result
    vari s_var1, s_var2, d_type1, d_type2
    vari d_indexct1, d_decimalct1, d_longct1
    vari s_indicators1, s_indicators2
    vari s_cfield, d_action, d_yesnumberruler

    s_record = sg_pass1
    d_record = dg_pass1
'cline    1         2         3         4         5         6
'123456789012345678901234567890123456789012345678901234567890
'    .CSR 01 02 03FACTOR1   COMMDFACTOR2   RESULT  92H919293
    $cut s_indicators1, s_record, 9, 9
    $cut s_factor1, s_record, 18, 10
    $cut s_command, s_record, 28, 5
    $cut s_factor2, s_record, 33, 10
    $cut s_result, s_record, 43, 6
    $cut s_indicators2, s_record, 54, 6

    'is there anything to cdebug
    d_yeslines = 2
    d_yesnumberruler = 2

    sg_pass1 = "if(tig_cdebug == 1) {"
    sub_c_lineout

    sg_pass1 = #tsub_out79("******************");#
    sub_c_lineout

    $ift s_command = "GOTO "
        $trb s_any, s_record
        $swp s_any, #"#, "'"
        sg_pass1 = #tsub_out79("# + d_record + " " + s_any + #");#
        sub_c_lineout
    endi

    'begin indicators
    s_any = s_indicators1 + s_indicators2
    $isc d_any, s_any, " "
    dift d_any <> 1
	  d_yeslines = 1

	  'blank tsg_256a to show indicators
        sg_pass1 = "tsub_blank(tsg_256a, 80);"
        sub_c_lineout

        $cut s_any, s_record, 10, 2
        $isc d_any, s_any, " "
        dift d_any <> 1
		'99=on
	      sg_pass1 = #tsub_copy(&tsg_256a[0], "#
	      $app sg_pass1, s_any + "=on" + #", 5);#
		sub_c_lineout

		'99=off
		sg_pass1 = "if(ig_" + s_any + " != 1) " 
		$app sg_pass1, #tsub_copy(&tsg_256a[3], "#
		$app sg_pass1, "off" + #", 3);#
		sub_c_lineout
	  endi

        $cut s_any, s_record, 13, 2
        $isc d_any, s_any, " "
        dift d_any <> 1
		'99=on
	      sg_pass1 = #tsub_copy(&tsg_256a[10], "#
	      $app sg_pass1, s_any + "=on" + #", 5);#
		sub_c_lineout

		'99=off
		sg_pass1 = "if(ig_" + s_any + " != 1) "
		$app sg_pass1, #tsub_copy(&tsg_256a[13], "#
		$app sg_pass1, "off" + #", 3);#
		sub_c_lineout
	  endi

        $cut s_any, s_record, 16, 2
        $isc d_any, s_any, " "
        dift d_any <> 1
		'99=on
	      sg_pass1 = #tsub_copy(&tsg_256a[20], "#
	      $app sg_pass1, s_any + "=on" + #", 5);#
		sub_c_lineout

		'99=off
		sg_pass1 = "if(ig_" + s_any + " != 1) "
		$app sg_pass1, #tsub_copy(&tsg_256a[23], "#
		$app sg_pass1, "off" + #", 3);#
		sub_c_lineout
	  endi

        $cut s_any, s_record, 54, 2
        $isc d_any, s_any, " "
        dift d_any <> 1
		'99=on
	      sg_pass1 = #tsub_copy(&tsg_256a[40], "#
	      $app sg_pass1, s_any + "=on" + #", 5);#
		sub_c_lineout

		'99=off
		sg_pass1 = "if(ig_" + s_any + " != 1) " 
		$app sg_pass1, #tsub_copy(&tsg_256a[43], "#
		$app sg_pass1, "off" + #", 3);#
		sub_c_lineout
	  endi

        $cut s_any, s_record, 56, 2
        $isc d_any, s_any, " "
        dift d_any <> 1
		'99=on
	      sg_pass1 = #tsub_copy(&tsg_256a[50], "#
	      $app sg_pass1, s_any + "=on" + #", 5);#
		sub_c_lineout

		'99=off
		sg_pass1 = "if(ig_" + s_any + " != 1) "
		$app sg_pass1, #tsub_copy(&tsg_256a[53], "#
		$app sg_pass1, "off" + #", 3);#
		sub_c_lineout
	  endi

        $cut s_any, s_record, 58, 2
        $isc d_any, s_any, " "
        dift d_any <> 1
		'99=on
	      sg_pass1 = #tsub_copy(&tsg_256a[60], "#
	      $app sg_pass1, s_any + "=on" + #", 5);#
		sub_c_lineout

		'99=off
		sg_pass1 = "if(ig_" + s_any + " != 1) "
		$app sg_pass1, #tsub_copy(&tsg_256a[63], "#
		$app sg_pass1, "off" + #", 3);#
		sub_c_lineout
	  endi

	  sg_pass1 = "tsub_out79(tsg_256a);"
	  sub_c_lineout
    endi
    'indicators above

    sg_pass1 = s_factor1
    sub_c_cline_varfullcdebug
    dift dg_pass1 = 1
	  d_yeslines = 1
	  d_yesnumberruler = 1
    endi

    sg_pass1 = s_factor2
    sub_c_cline_varfullcdebug
    dift dg_pass1 = 1
	  d_yeslines = 1
	  d_yesnumberruler = 1
    endi

    sg_pass1 = s_result
    sub_c_cline_varfullcdebug
    dift dg_pass1 = 1
	  d_yeslines = 1
	  d_yesnumberruler = 1
    endi

    dift d_yesnumberruler = 1
	  sg_pass1 = "tsub_numberruler(11);"
	  sub_c_lineout
    endi

    sg_pass1 = "} /* tig_cdebug ==1 */"
    sub_c_lineout  
ends sub_c_cline_fullcdebug_beg


subr sub_c_cline_fullcdebug_end
'updated 2004/08/31
'write clines for cdebug of a program record
    vari s_any, d_any, s_dot, d_dot, s_out
    vari d_record, s_record, d_good, d_yeslines
    vari s_factor1, s_command, s_factor2, s_result
    vari s_var1, s_var2, d_type1, d_type2
    vari d_indexct1, d_decimalct1, d_longct1
    vari s_indicators1, s_indicators2
    vari s_cfield, d_action, d_yesnumberruler
    vari s_allvarsizes

    s_record = sg_pass1
    d_record = dg_pass1
'cline    1         2         3         4         5         6
'123456789012345678901234567890123456789012345678901234567890
'    .CSR 01 02 03FACTOR1   COMMDFACTOR2   RESULT  92H919293
    $cut s_indicators1, s_record, 9, 9
    $cut s_factor1, s_record, 18, 10
    $cut s_command, s_record, 28, 5
    $cut s_factor2, s_record, 33, 10
    $cut s_result, s_record, 43, 6
    $cut s_indicators2, s_record, 54, 6

    'is there anything to cdebug
    s_allvarsizes = sg_nothing
    d_yeslines = 2
    d_yesnumberruler = 2

    sg_pass1 = "if(tig_cdebug == 1) {"
    sub_c_lineout

    sg_pass1 = "tsub_char_out79('-');"
    sub_c_lineout

    'begin indicators and end indicators
    s_any = s_indicators1 + s_indicators2
    $isc d_any, s_any, " "
    dift d_any <> 1
	  d_yeslines = 1

	  'blank tsg_256a to show indicators
        sg_pass1 = "tsub_blank(tsg_256a, 80);"
        sub_c_lineout

        $cut s_any, s_record, 10, 2
        $isc d_any, s_any, " "
        dift d_any <> 1
		'99=on
	      sg_pass1 = #tsub_copy(&tsg_256a[0], "#
	      $app sg_pass1, s_any + "=on" + #", 5);#
		sub_c_lineout

		'99=off
		sg_pass1 = "if(ig_" + s_any + " != 1) " 
		$app sg_pass1, #tsub_copy(&tsg_256a[3], "#
		$app sg_pass1, "off" + #", 3);#
		sub_c_lineout
	  endi

        $cut s_any, s_record, 13, 2
        $isc d_any, s_any, " "
        dift d_any <> 1
		'99=on
	      sg_pass1 = #tsub_copy(&tsg_256a[10], "#
	      $app sg_pass1, s_any + "=on" + #", 5);#
		sub_c_lineout

		'99=off
		sg_pass1 = "if(ig_" + s_any + " != 1) "
		$app sg_pass1, #tsub_copy(&tsg_256a[13], "#
		$app sg_pass1, "off" + #", 3);#
		sub_c_lineout
	  endi

        $cut s_any, s_record, 16, 2
        $isc d_any, s_any, " "
        dift d_any <> 1
		'99=on
	      sg_pass1 = #tsub_copy(&tsg_256a[20], "#
	      $app sg_pass1, s_any + "=on" + #", 5);#
		sub_c_lineout

		'99=off
		sg_pass1 = "if(ig_" + s_any + " != 1) "
		$app sg_pass1, #tsub_copy(&tsg_256a[23], "#
		$app sg_pass1, "off" + #", 3);#
		sub_c_lineout
	  endi

        $cut s_any, s_record, 54, 2
        $isc d_any, s_any, " "
        dift d_any <> 1
		'99=on
	      sg_pass1 = #tsub_copy(&tsg_256a[40], "#
	      $app sg_pass1, s_any + "=on" + #", 5);#
		sub_c_lineout

		'99=off
		sg_pass1 = "if(ig_" + s_any + " != 1) " 
		$app sg_pass1, #tsub_copy(&tsg_256a[43], "#
		$app sg_pass1, "off" + #", 3);#
		sub_c_lineout
	  endi

        $cut s_any, s_record, 56, 2
        $isc d_any, s_any, " "
        dift d_any <> 1
		'99=on
	      sg_pass1 = #tsub_copy(&tsg_256a[50], "#
	      $app sg_pass1, s_any + "=on" + #", 5);#
		sub_c_lineout

		'99=off
		sg_pass1 = "if(ig_" + s_any + " != 1) "
		$app sg_pass1, #tsub_copy(&tsg_256a[53], "#
		$app sg_pass1, "off" + #", 3);#
		sub_c_lineout
	  endi

        $cut s_any, s_record, 58, 2
        $isc d_any, s_any, " "
        dift d_any <> 1
		'99=on
	      sg_pass1 = #tsub_copy(&tsg_256a[60], "#
	      $app sg_pass1, s_any + "=on" + #", 5);#
		sub_c_lineout

		'99=off
		sg_pass1 = "if(ig_" + s_any + " != 1) "
		$app sg_pass1, #tsub_copy(&tsg_256a[63], "#
		$app sg_pass1, "off" + #", 3);#
		sub_c_lineout
	  endi

	  sg_pass1 = "tsub_out79(tsg_256a);"
	  sub_c_lineout
    endi
    'indicators above

    sg_pass1 = s_factor1
    sub_c_cline_varfullcdebug
    dift dg_pass1 = 1
	  d_yeslines = 1
	  d_yesnumberruler = 1
	  $app s_allvarsizes, sg_pass1
    endi

    sg_pass1 = s_factor2
    sub_c_cline_varfullcdebug
    dift dg_pass1 = 1
	  d_yeslines = 1
	  d_yesnumberruler = 1
	  $app s_allvarsizes, " " + sg_pass1
    endi

    sg_pass1 = s_result
    sub_c_cline_varfullcdebug
    dift dg_pass1 = 1
	  d_yeslines = 1
	  d_yesnumberruler = 1
	  $app s_allvarsizes, " " + sg_pass1
    endi

    dift d_yesnumberruler = 1
	  sg_pass1 = "tsub_numberruler(11);"
	  sub_c_lineout
    endi

    dift d_yeslines = 1
	  'output all field varsizes
	  $trb s_allvarsizes, s_allvarsizes
	  $len d_any, s_allvarsizes
	  dift d_any > 0
	      sg_pass1 = #tsub_out79("# + s_allvarsizes + #");#
	      sub_c_lineout
	  endi
    endi

    $trb s_any, s_record
    $swp s_any, #"#, "'"
    sg_pass1 = #tsub_out79("# + d_record + " " + s_any + #");#
    sub_c_lineout

    dift d_yeslines = 1    
        sg_pass1 = #tsub_cdebug("");#
        sub_c_lineout
    endi

    sg_pass1 = "} /* tig_cdebug ==1 */"
    sub_c_lineout  
ends sub_c_cline_fullcdebug_end


subr sub_c_cline_varfullcdebug
'updated 2006/11/01, 004/12/29
'write clines for cdebug of a program record
    vari s_any, d_any, s_dot, d_dot, s_out
    vari s_field, d_good, d_yeslines
    vari s_var1, d_type1
    vari d_indexct1, d_decimalct1, d_longct1
    vari s_var2, d_type2
    vari d_indexct2, d_decimalct2, d_longct2
    vari s_cfield, d_action, d_end
    vari s_varsize1, s_varsize2, s_expvarsizes

    s_field = sg_pass1

    'is there anything to cdebug
    d_yeslines = 2

'1=error
'2=blank
'6=*BLANK
'7=*ZEROS
'8=UDATE
'11=number
'12=numeric var
'13=numeric array with index
'14=numeric array no index
'21=alpha literal
'22=alpha var
'23=alpha array with index
'24=alpha array no index

    'get info for 
    d_action = 0
    $isc d_any, s_field, " "
    dift d_any <> 1
	  'turn off errors in case of files or tags
	  dinc dg_showerror

        sg_pass1 = s_field
        sub_field_info_return
        d_type1 = dg_pass1
        d_type2 = dg_pass2
        d_indexct1 = dg_pass3
        d_longct1 = dg_pass4
        d_decimalct1 = dg_pass5
        d_longct2 = dg_pass6
        d_decimalct2 = dg_pass7
        s_var1 = sg_pass1
        s_var2 = sg_pass2
	  s_cfield = sg_pass4
	  s_varsize1 = sg_pass5
	  s_varsize2 = sg_pass6

	  'we want to show errors
	  dg_showerror = 1
	  d_end = 80

	  $trb s_field, s_field
	  $app s_field, sg_20blanks
	  $cut s_field, s_field, 1, 10

	  'prep s_expvarsizes for export
	  'varsize=type of var,indexct,longct,decimals
	  s_expvarsizes = sg_nothing
	  $len d_any, s_varsize1
	  dift d_any = 9
		s_expvarsizes = s_var1 + "=" + s_varsize1
		$len d_any, s_varsize2
		dift d_any = 9
		    $app s_expvarsizes, " " + s_var2
		    $app s_expvarsizes, "=" + s_varsize2
		endi
	  endi

	  dift d_type1 = 12: d_action = 12
	  dift d_type1 = 13: d_action = 13
	  dift d_type1 = 14: d_action = 14

	  dift d_type1 = 22: d_action = 22
	  dift d_type1 = 23: d_action = 23
	  dift d_type1 = 24: d_action = 24
    endi
    dift d_action = 12
	  'numeric variable
	  d_yeslines = 1

	  sg_pass1 = #printf("# + s_field + "=%17."
	  $app sg_pass1, d_decimalct1 + "lf\n" + #", #
	  $app sg_pass1, s_cfield + ");"
	  sub_c_lineout
    endi
    dift d_action = 13
	  'numeric array with index
	  d_yeslines = 1

	  sg_pass1 = #printf("# + s_field + "=%17."
	  $app sg_pass1, d_decimalct1 + "lf\n" + #", #
	  $app sg_pass1, s_cfield + ");"
	  sub_c_lineout

	  dift d_type2 = 12
		'numeric variable for index
		$tlo s_dot, s_var2
		$app s_var2, sg_20blanks
		$cut s_var2, s_var2, 1, 10
		$cup s_var2, s_var2
	      sg_pass1 = #printf("# + s_var2 + "=%17."
		$app sg_pass1, d_decimalct2 + "lf\n" + #", #
	      $app sg_pass1, "dg_" + s_dot + ");"
	      sub_c_lineout
	  endi
    endi
    dift d_action = 14
	  'numeric array no index
	  d_yeslines = 1

	  sg_pass1 = #printf("# + s_field + ",1=%15."
	  $app sg_pass1, d_decimalct1 + "lf\n" + #", #
	  $app sg_pass1, s_cfield + "[0] );"
	  sub_c_lineout

	  dift d_indexct1 > 1
	      sg_pass1 = #printf("# + s_field + ",2=%15."
	      $app sg_pass1, d_decimalct1 + "lf\n" + #", #
	      $app sg_pass1, s_cfield + "[1] );"
	      sub_c_lineout
	  endi
	  dift d_indexct1 > 2
	      sg_pass1 = #printf("# + s_field + ",3=%15."
	      $app sg_pass1, d_decimalct1 + "lf\n" + #", #
	      $app sg_pass1, s_cfield + "[2] );"
	      sub_c_lineout
	  endi
    endi
    dift d_action = 22
	  'alpha variable
	  d_yeslines = 1

	  'blank tsg_256a to show indicators
        sg_pass1 = "tsub_blank(tsg_256a, 80);"
        sub_c_lineout

	  d_dot = d_longct1
	  dift d_dot > d_end: d_dot = d_end
	  sg_pass1 = "tsub_copy(tsg_256a, "
	  $app sg_pass1, s_cfield + ", " + d_dot + ");"
	  sub_c_lineout

	  dift d_longct1 > 1
		'put = at end of string which is longer than 1	  
	      sg_pass1 = "tsg_256a[" + d_dot + "] = '=';"
	      sub_c_lineout

		'put 0 at end of string which is longer than 1	  
		dinc d_dot
	      sg_pass1 = "tsg_256a[" + d_dot + "] = 0;"
	      sub_c_lineout
	  else
		'field is one long
		sg_pass1 = "tig_z = tsg_256a[0];"
		sub_c_lineout

		sg_pass1 = "if(tig_z < 32) tsg_256a[0] = 32;"
		sub_c_lineout

		sg_pass1 = #sprintf(&tsg_256a[1], "= char number=%d", #
		$app sg_pass1, "tig_z);"
	      sub_c_lineout
	  endi

	  sg_pass1 = #sprintf(tsg_256b, "# + s_field + #=%s\n", #
	  $app sg_pass1, "tsg_256a);"
	  sub_c_lineout

	  sg_pass1 = "tsub_out79(tsg_256b);"
	  sub_c_lineout
    endi
    dift d_action = 23
	  'indexed alpha array
	  d_yeslines = 1

	  'blank tsg_256a
        sg_pass1 = "tsub_blank(tsg_256a, 80);"
        sub_c_lineout

	  'how long in bytes to the end of the array
	  $tlo s_dot, s_var2

	  'd_type2=12 for numeric variable
	  dift d_type2 = 12: s_dot = "tfni_index(dg_" + s_dot + ")"

	  sg_pass1 = "tig_z = (" + d_indexct1 + " - " + s_dot
	  $app sg_pass1, " + 1) * " + d_longct1 + ";"
	  sub_c_lineout

	  sg_pass1 = "if(tig_z > " + d_end + ") tig_z = "
	  $app sg_pass1, d_end + ";"
	  sub_c_lineout

	  sg_pass1 = "tsub_copy(tsg_256a, &"
	  $app sg_pass1, s_cfield + ", tig_z);"
	  sub_c_lineout

	  sg_pass1 = "tsg_256a[tig_z] = 0;"
	  sub_c_lineout

	  sg_pass1 = #sprintf(tsg_256b, "# + s_field + #=%s=\n", #
	  $app sg_pass1, "tsg_256a);"
	  sub_c_lineout

	  sg_pass1 = "tsub_out79(tsg_256b);"
	  sub_c_lineout

	  'now output the whole alpha array
	  	  
	  'blank tsg_256a
        sg_pass1 = "tsub_blank(tsg_256a, 80);"
        sub_c_lineout

	  d_dot = d_indexct1 * d_longct1
	  dift d_dot > d_end: d_dot = d_end

	  $tlo s_var1, s_var1
	  sg_pass1 = "tsub_copy(tsg_256a, sga_"
	  $app sg_pass1, s_var1 + ", " + d_dot + ");"
	  sub_c_lineout

	  sg_pass1 = "tsg_256a[" + d_dot + "] = 0;"
	  sub_c_lineout

	  s_dot = s_var1 + sg_20blanks
	  $cut s_dot, s_dot, 1, 10
	  $cup s_dot, s_dot
	  sg_pass1 = #sprintf(tsg_256b, "# + s_dot + #=%s=\n", #
	  $app sg_pass1, "tsg_256a);"
	  sub_c_lineout

	  sg_pass1 = "tsub_out79(tsg_256b);"
	  sub_c_lineout

	  dift d_type2 = 12
		'numeric variable for index
		$tlo s_dot, s_var2
		$app s_var2, sg_20blanks
		$cut s_var2, s_var2, 1, 10
		$cup s_var2, s_var2
	      sg_pass1 = #printf("# + s_var2 + "=%17."
		$app sg_pass1, d_decimalct2 + "lf\n" + #", #
	      $app sg_pass1, "dg_" + s_dot + ");"
	      sub_c_lineout
	  endi
    endi
    dift d_action = 24
	  'whole alpha arrays
	  d_yeslines = 1

	  'is this a table
	  $cut s_any, s_field, 1, 3
	  $ift s_any = "TAB"
		's_field is a table so fix d_longct1
		$cut s_any, s_field, 1, 6
		$lok d_any, sg_rpgtabnames1, 1, s_any
		$cut s_any, sg_rpgtabnames2, d_any, 6
		sg_pass1 = s_any
		sub_variable_info_return
		d_dot = dg_pass3
		d_longct1 = d_longct1 + d_dot
	  endi

	  'blank tsg_256a
        sg_pass1 = "tsub_blank(tsg_256a, 80);"
        sub_c_lineout

	  d_dot = d_indexct1 * d_longct1
	  dift d_dot > d_end: d_dot = d_end

	  sg_pass1 = "tsub_copy(tsg_256a, "
	  $app sg_pass1, s_cfield + ", " + d_dot + ");"
	  sub_c_lineout

	  sg_pass1 = "tsg_256a[" + d_dot + "] = 0;"
	  sub_c_lineout

	  sg_pass1 = #sprintf(tsg_256b, "# + s_field + #=%s=\n", #
	  $app sg_pass1, "tsg_256a);"
	  sub_c_lineout

	  sg_pass1 = "tsub_out79(tsg_256b);"
	  sub_c_lineout
    endi

    dg_pass1 = d_yeslines
    sg_pass1 = s_expvarsizes
ends sub_c_cline_varfullcdebug


subr sub_c_numeric_field_prep
'updated 2005/04/03, 2005/01/13, 2005/01/02
'change rpg numfield to C with info for sub_c_cline_math
    vari s_any, d_any, s_dot, d_dot, s_tap, s_out
    vari d_process, d_action, d_error, s_error, d_comma
    vari s_rpgfield, s_wrkfield, s_cfield
    vari d_vartype, d_indexct, d_longct, d_decimalct
    vari d_fieldtype, s_fieldtype
    vari d_fieldindexct, d_fieldlongct, d_fielddecimalct
    vari d_fieldindextype, s_fieldindexvar
    vari s_var1, s_var2, s_size1, s_size2
    vari s_sign, d_byte, d_length

'd_fieldtype
'1=bad field
'2=blank
'6=*BLANK
'7=*ZEROS
'8=UDATE
'11=numeric literal
'12=numeric var
'13=numeric array with index
'14=numeric array no index
'21=alpha literal
'22=alpha var
'23=alpha array with index
'24=alpha array no index

    's_rpgfield is input
    's_wrkfield is work 
    's_cfield is output
    s_rpgfield = sg_pass1

    s_cfield = sg_nothing
    s_fieldindexvar = sg_nothing
    d_fieldindextype = 0

    s_sign = sg_nothing
    'beg dg_errnumber,d_error,1500
    d_error = 0
    d_process = 1
    d_action = 0

    d_fieldtype = 0
    d_fieldindexct = 0
    d_fieldlongct = 0
    d_fielddecimalct = 0

    $trb s_wrkfield, s_rpgfield
    $len d_any, s_wrkfield
    dift d_any = 0
	  'we have nothing
	  d_fieldtype = 2
	  s_cfield = sg_nothing
	  dinc d_process
    endi
								
    dift d_process = 1
	  'put the sign in s_sign
	  $cut s_any, s_wrkfield, 1, 1
	  s_tap = "+-"
	  $lok d_any, s_tap, 1, s_any
	  dift d_any > 0
		s_sign = s_any
		$cut s_wrkfield, s_wrkfield, 2, 99999
	  endi

	  $isd d_any, s_wrkfield
	  dift d_any = 1
		'we have a numeric literal

		'take off leading zeros
		sg_pass1 = s_wrkfield
		sub_take_off_leading_zeros
		s_wrkfield = sg_pass1

		'make sure it looks like a double ie. 0.0
		$lok d_any, s_wrkfield, 1, "."
		dift d_any = 0: $app s_wrkfield, ".0"
		$off s_any, s_wrkfield, 1
		$ift s_any = ".": $app s_wrkfield, "0"
		$cut s_any, s_wrkfield, 1, 1
		$ift s_any = ".": s_wrkfield = "0" + s_wrkfield

		d_fieldindexct = 0

		'how many decimal positions
		$len d_any, s_wrkfield
		d_fieldlongct = d_any - 1
		$lok d_dot, s_wrkfield, 1, "."

	      d_fielddecimalct = d_any - d_dot

		d_fieldtype = 11
		s_cfield = s_sign + s_wrkfield
	      dinc d_process
	  endi
    endi
    dift d_process = 1
	  'do we have an indexed variable
	  $lok d_comma, s_wrkfield, 1, ","

	  d_action = 1
	  dift d_comma > 0: d_action = 2
	  'd_action = 1 means variable not indexed
	  'd_action = 2 means indexed variable
    endi	  
    dift d_action = 1
	  'variable not indexed
	  s_var1 = s_rpgfield + sg_20blanks
	  $cut s_var1, s_var1, 1, 9

	  $lok d_byte, sg_rpgvarnames, 1, s_var1
	  dift d_byte = 0
	      'not found so error
	      s_error = s_rpgfield
	      d_error = 1501
	      d_action = 0
	  endi
    endi

'123456789 sg_rpgvarnames 9 long
'abbbbcccd sg_rpgvarsizes 9 long
'a    = d_vartype: 1=numeric,2=numeric array,6=alpha,7=alpha array
'bbbb = d_varindexct: index count
'ccc  = d_varlongct: length
'd    = d_vardecimalct: decimals

    dift d_action = 1
	  'variable not indexed
	  $cut s_size1, sg_rpgvarsizes, d_byte, 9
	  $cut s_any, s_size1, 1, 1
        $tod d_vartype, s_any

	  'get the d_fieldindexct
	  $cut s_any, s_size1, 2, 4
	  $tod d_fieldindexct, s_any

	  'get the d_fieldlongct
	  $cut s_any, s_size1, 6, 3
	  $tod d_fieldlongct, s_any

	  'get the d_fielddecimalct
	  $cut s_any, s_size1, 9, 1
	  $tod d_fielddecimalct, s_any

	  dift d_vartype = 1
	      'numeric variable
	      d_fieldtype = 12
	      s_cfield = "dg_" + s_wrkfield
	      $tlo s_cfield, s_cfield
	      s_cfield = s_sign + s_cfield
        endi
        dift d_vartype = 2		    
		'numeric array no index and has no sign
		d_fieldtype = 14
		s_cfield = "dga_" + s_wrkfield
		$tlo s_cfield, s_cfield
	  endi
	  dift d_vartype > 2
	      d_error = 1502
		s_error = s_rpgfield
	  endi
    endi
    'not indexed variable above

'123456789 sg_rpgvarnames 9 long
'abbbbcccd sg_rpgvarsizes 9 long
'a    = d_vartype: 1=numeric,2=numeric array,6=alpha,7=alpha array
'bbbb = d_varindexct: index count
'ccc  = d_varlongct: length
'd    = d_vardecimalct: decimals

    dift d_action = 2
	  'indexed variable
        $par s_var1, s_wrkfield, ",", 1
        $par s_var2, s_wrkfield, ",", 2

        $trb s_var1, s_var1
	  $trb s_var2, s_var2

	  'validate s_var1
	  $app s_var1, sg_20blanks
	  $cut s_var1, s_var1, 1, 9

	  $lok d_byte, sg_rpgvarnames, 1, s_var1
	  dift d_byte = 0
		d_error = 1503
		s_error = s_rpgfield
		d_action = 0
	  endi
    endi

'123456789 sg_rpgvarnames 9 long
'abbbbcccd sg_rpgvarsizes 9 long
'a    = d_vartype: 1=numeric,2=numeric array,6=alpha,7=alpha array
'bbbb = d_varindexct: index count
'ccc  = d_varlongct: length
'd    = d_vardecimalct: decimals

    dift d_action = 2
	  'for indexed variable s_var1
        $cut s_size1, sg_rpgvarsizes, d_byte, 9
        $cut s_any, s_size1, 1, 1
	  $tod d_vartype, s_any

	  'get the d_fieldindexct
	  $cut s_any, s_size1, 2, 4
	  $tod d_fieldindexct, s_any
  
        'get the d_fieldlongct
        $cut s_any, s_size1, 6, 3
        $tod d_fieldlongct, s_any

        'get the d_fielddecimalct
        $cut s_any, s_size1, 9, 1
        $tod d_fielddecimalct, s_any

        dift d_vartype = 2		    
	      'numeric array with index
	      d_fieldtype = 13
        else
	      d_error = 1504
	      s_error = s_rpgfield
		d_action = 0
        endi
    endi
    dift d_action = 2
        'is index s_var2 an integer
        $trb s_var2, s_var2
        $ist d_any, s_var2, "9"
        dift d_any = 1
		'index s_var2 is an integer
		'take off leading zeros
		$tod d_any, s_var2
		s_var2 = d_any

		$tlo s_var1, s_var1
		s_cfield = "dga_" + s_var1 + "[" + s_var2 
		$app s_cfield, " - 1]"
	      s_cfield = s_sign + s_cfield

		d_fieldindextype = 11
		s_fieldindexvar = s_var2
		d_action = 0
	  endi
    endi
    dift d_action = 2
	  'validate index s_var2 as a numeric variable
	  $app s_var2, sg_20blanks
	  $cut s_var2, s_var2, 1, 9

	  $lok d_byte, sg_rpgvarnames, 1, s_var2
	  dift d_byte = 0
		d_error = 1505
		s_error = s_rpgfield
	  endi
    endi
    dift d_action = 2
	  $cut s_size2, sg_rpgvarsizes, d_byte, 9

	  'index s_var2 must be a numeric var
	  $cut s_any, s_size2, 1, 1
	  $tod d_vartype, s_any

	  dift d_vartype = 1
		's_var2 is a numeric variable
	      $tlo s_var1, s_var1
	      $tlo s_var2, s_var2
	      s_cfield = "dga_" + s_var1 + "[tfni_index(dg_"
	      $app s_cfield, s_var2 + ") - 1]"
	      s_cfield = s_sign + s_cfield

		d_fieldindextype = 12
		s_fieldindexvar = "dg_" + s_var2
	  else
	      d_error = 1506
	      s_error = s_rpgfield
	  endi
    endi
    dift d_error > 0
	  'end dg_errnumber,d_error,1500
	  dg_errnumber = d_error
	  d_fieldtype = 0
	  s_any = "sub_numfield_prep, bad field="
	  $app s_any, s_error
	  sg_pass1 = s_any
	  sub_error
    endi

'd_fieldtype
'1=error
'2=blank
'6=*BLANK
'7=*ZEROS
'8=UDATE
'11=number
'12=numeric var
'13=numeric array with index
'14=numeric array no index
'21=alpha literal
'22=alpha var
'23=alpha array with index
'24=alpha array no index

    dg_pass1 = d_fieldtype
    dg_pass2 = d_fieldindexct
    dg_pass3 = d_fieldlongct
    dg_pass4 = d_fielddecimalct
    dg_pass5 = d_fieldindextype

    sg_pass1 = s_cfield
    sg_pass2 = s_fieldindexvar
ends sub_c_numeric_field_prep


subr sub_c_ifindicators
'updated 2004/02/19
'put c indicator if command in sg_ifindicators,dg_yesifindicators
    vari s_any, d_any, s_dot, d_dot
    vari s_inpstring, s_outstring
    vari s_indicator, s_not, s_part, d_already

    s_inpstring = sg_pass1
    s_outstring = sg_nothing
    
    d_already = 2

    's_inpstring is : "N91 92N93"
    $isc d_any, s_inpstring, " "
    dift d_any <> 1
	  'indicator in 9/11 ie. ig_99 which is 1 or 2
	  $cut s_not, s_inpstring, 1, 1
	  $cut s_indicator, s_inpstring, 2, 2

	  $ist d_any, s_indicator, "9"
	  dift d_any = 1
		'ig_99==1
		s_part = "ig_" + s_indicator + "==1"
		$ift s_not = "N": $rep s_part, 6, "!"
		$app s_outstring, s_part
		d_already = 1
	  endi

	  'indicator in 12/14 ie. ig_99 which is 1 or 2
	  $cut s_not, s_inpstring, 4, 1
	  $cut s_indicator, s_inpstring, 5, 2

	  $ist d_any, s_indicator, "9"
	  dift d_any = 1
		'ig_99==1
		s_part = "ig_" + s_indicator + "==1"
		$ift s_not = "N": $rep s_part, 6, "!"
		dift d_already = 1: $app s_outstring, " && "
		$app s_outstring, s_part
		d_already = 1
	  endi

	  'indicator in 15/17 ie. ig_99 which is 1 or 2
	  $cut s_not, s_inpstring, 7, 1
	  $cut s_indicator, s_inpstring, 8, 2

	  $ist d_any, s_indicator, "9"
	  dift d_any = 1
		'ig_99==1
		s_part = "ig_" + s_indicator + "==1"
		$ift s_not = "N": $rep s_part, 6, "!"
		dift d_already = 1: $app s_outstring, " && "
		$app s_outstring, s_part
		d_already = 1
	  endi
	  dift d_already = 1
		s_outstring = "if(" + s_outstring + ") "
	  endi
    endi

    dg_yesifindicators = 2
    $len d_any, s_outstring
    dift d_any > 0: dg_yesifindicators = 1
    sg_ifindicators = s_outstring
ends sub_c_ifindicators


subr sub_c_cline_commands
'updated 2005/04/03, 2004/11/04    
    vari s_any, d_any, s_dot, d_dot, s_tap, s_out
    vari d_loop, d_good, d_count
    vari d_record, s_record, d_rpgclines
    vari s_6byte, s_7byte, s_8byte, d_command, s_filename
    vari s_factor1, s_command, s_factor2, s_result
    vari s_indicator4, s_indicator5, s_indicator6
    vari d_fieldtype1, d_fieldtype2, d_fieldtype3
    vari d_decimalct1, d_decimalct2, d_decimalct3, s_half
    vari d_longct, s_fromsubr, d_yesifwrapper

    $sys sg_subroutine, 2
    s_fromsubr = sg_subroutine
    dift dg_tdebug = 1
	  sg_pass1 = sg_subroutine
	  sub_return
    endi

    'turn on fullcdebug only if dg_fullcdebug1=1
    'and C* CDEBUG ON until C* CDEBUG OFF
    dg_fullcdebug2 = 2

    sg_goodcommands = sg_nothing
    sg_badcommands = sg_nothing
    sg_csubrname = sg_nothing
    dg_rpglinenumber = 0
    d_rpgclines = 0
    d_record = 0
    dg_filebyte = 1

    d_loop = 1
    dwhi d_loop = 1
	  d_good = 1
	  dg_yeslinedone = 99999

	  fsip s_record, sg_inpfile, dg_filebyte
	  dift dg_filebyte = 0
		$out s_fromsubr + "=" + dg_record
		dg_record = 0
		dinc d_good
		dinc d_loop
	  endi
	  dift d_good = 1
		dinc dg_rpglinenumber
		dinc d_record
		dinc dg_record

		'tell
		d_any = dg_record % 100
		dift d_any = 0: $sho s_fromsubr + "=" + dg_record

		'make sure the record is 80 long
		$ch$ s_any, " ", 80
		$app s_record, s_any
		$cut s_record, s_record, 1, 80

		'store the line in the queue
		sg_pass1 = dg_record + " " + s_record
		sub_queue

		$cut s_6byte, s_record, 6, 1
		$cut s_7byte, s_record, 7, 1
		$cut s_8byte, s_record, 8, 1

		$ift s_6byte <> "C"
		    'non cline so make into comment
		    dinc d_good
		    $trb s_any, s_record
	          sg_pass1 = sg_slashaster + d_record + " " 
		    $app sg_pass1, s_any + sg_asterslash
                sub_c_lineout
		endi

		'stop at output lines
		$ift s_6byte = "O"
		    'd_rpgclines=1 means in rpg c-lines
		    dift d_rpgclines = 1
			  'end of c-lines
			  sg_pass1 = "}" + sg_csubrname
			  sub_c_lineout
			  d_rpgclines = 2
		    endi

		    $out s_fromsubr + "=" + dg_record

		    dinc d_good
		    dinc d_loop
		endi
	  endi
	  dift d_good = 1
		dift d_rpgclines = 0
		    sub_c_blankline

		    'd_rpgclines=0 means no previous calcs
		    'rsub_rpg_calculations is called by main
		    sg_pass1 = "void rsub_rpg_calculations(void) {"
                sub_c_lineout

		    'save the name to put after the closing }
		    sg_csubrname = "/* rsub_rpg_calculations */"

		    'd_rpgclines=1 means in rpg c-calcs 
		    d_rpgclines = 1
		endi
	  endi
	  dift d_good = 1
		'comment records preceded by blankline
		$ift s_7byte = "*"
		    $cut s_any, s_record, 9, 99
		    $isc d_any, s_any, " "
		    dift d_any <> 1
			  sub_c_blankline
			  $trb s_any, s_record
		        sg_pass1 = sg_slashaster + d_record + " "
			  $app sg_pass1, s_any + sg_asterslash
                    sub_c_lineout
		    endi

		    dift dg_fullcdebug1 = 1
		        '6789012345678
		        'C* CDEBUG ON
		        'C* CDEBUG OFF
		        $cut s_any, s_record, 9, 6
		        $ift s_any = "CDEBUG"
			      $cut s_any, s_record, 16, 3
				$ift s_any = "ON "
				    dg_fullcdebug2 = 1
				endi			  
				$ift s_any = "OFF"
				    dg_fullcdebug2 = 2
				endi			  
		        endi 
		    endi

		    dinc d_good
		endi
	  endi
	  dift d_good = 1
		dift d_rpgclines = 1
		    'd_rpgclines=1 means in rpg c-calcs 

		    $ift s_7byte = "S"
			  'put end to subroutine of c-calcs

			  sg_pass1 = "}" + sg_csubrname
			  sub_c_lineout

			  'd_rpgclines=2 means in rpg csr-calcs 
			  d_rpgclines = 2
		    endi
		endi
	  endi
	  dift d_good = 1
		'we have a cline to do
		dg_yeslinedone = 2

		'change indicators to sg_ifindicators,dg_yesifindicators
		$cut s_any, s_record, 9, 9
		sg_pass1 = s_any
		sub_c_ifindicators

		$cut s_factor1, s_record, 18, 10
		$cut s_command, s_record, 28, 5
		$cut s_factor2, s_record, 33, 10
		$cut s_result, s_record, 43, 6
		$cut s_indicator4, s_record, 54, 2
		$cut s_indicator5, s_record, 56, 2
		$cut s_indicator6, s_record, 58, 2

		'make blank indicators 00
		$swp s_indicator4, " ", "0"
		$swp s_indicator5, " ", "0"
		$swp s_indicator6, " ", "0"

		'turn off showing errors
		dinc dg_showerror
	      sg_pass1 = s_factor1
	      sub_field_info_return
	      d_fieldtype1 = dg_pass1

	      sg_pass1 = s_factor2
	      sub_field_info_return
	      d_fieldtype2 = dg_pass1

	      sg_pass1 = s_result
	      sub_field_info_return
	      d_fieldtype3 = dg_pass1

		'turn on showing errors
		dg_showerror = 1

		'do we need fullcdebug
		d_dot = 2
		dift dg_fullcdebug2 = 1: d_dot = 1
		$ift s_command = "BEGSR": dinc d_dot
		$ift s_command = "ENDSR": dinc d_dot
		$ift s_command = "TAG  ": dinc d_dot
		dift d_dot = 1
		    'add lines for fullcdebug
		    sg_pass1 = s_record
		    dg_pass1 = d_record
		    sub_c_cline_fullcdebug_beg
		endi
	  endi
	  dift d_good = 1
		'output the rpg record as a comment
	      sub_c_blankline

		$trb s_any, s_record
		sg_pass1 = sg_slashaster + d_record + " "
		$app sg_pass1, s_any + sg_asterslash
		sub_c_lineout
	  endi
'cline    1         2         3         4         5         6
'123456789012345678901234567890123456789012345678901234567890
'    .CSR 01 02 03FACTOR1   COMMDFACTOR2   RESULT  92H919293
	  dift d_good = 1
		$ift s_command = "BEGSR"
		    'command_begsr
		    $tlo s_dot, s_factor1

		    'save name for closing brace
		    sg_csubrname = "/* sub_begsr_" + s_dot + " */"

		    sg_pass1 = "void sub_begsr_" + s_dot + "() {"
		    sub_c_lineout

		    dinc d_good
		    dg_yeslinedone = 1
		endi
		$ift s_command = "ENDSR"
		    'command_endsr
		    'do we need an end of subr tag
		    $isc d_any, s_factor1, " "
		    dift d_any <> 1
		        $tlo s_any, s_factor1
		        sg_pass1 = s_any + ":;"
		        sub_c_lineout
		    endi

		    'end of a subr
		    sg_pass1 = "}" + sg_csubrname
		    sub_c_lineout

		    dinc d_good
		    dg_yeslinedone = 1
		endi
		$ift s_command = "EXCPT"
		    'command_excpt

dift dg_fullcdebug2 = 1
    $tlo s_any, s_result
    $ift s_any = "oterm"
        sg_pass1 = "if(tig_cdebug == 1) {"
	  sub_c_lineout

	  sg_pass1 = #tsub_out79("oterm output below");#
	  sub_c_lineout

	  sg_pass1 = "tsub_numberruler(0);"
	  sub_c_lineout

	  sg_pass1 = "}"
	  sub_c_lineout
    endi
endi

		    $tlo s_any, s_result
	          sg_pass1 = sg_ifindicators 
	          $app sg_pass1, "sub_excpt_" + s_any + "();"
		    sub_c_lineout

		    dinc d_good
		    dg_yeslinedone = 1
		endi
		dift d_good = 1
		    'command_read,command_readp,command_chain
		    s_dot = "READ ,READP,CHAIN,"
		    $lok d_dot, s_dot, 1, s_command
		    dift d_dot > 0
			  sg_pass1 = s_record
			  sub_c_cline_file_read
			  dinc d_good
			  dg_yeslinedone = 1
		    endi
		endi
		$ift s_command = "SETLL"
		    'command_setll
		    sg_pass1 = s_record
		    sub_c_cline_lock_unlck_setll
		    dinc d_good
		    dg_yeslinedone = 1
		endi
		$ift s_command = "LOCK "
		    'command_lock
		    sg_pass1 = s_record
		    sub_c_cline_lock_unlck_setll
		    dinc d_good
		    dg_yeslinedone = 1
		endi
		$ift s_command = "UNLCK"
		    'command_unlck
		    sg_pass1 = s_record
		    sub_c_cline_lock_unlck_setll
		    dinc d_good
		    dg_yeslinedone = 1
		endi
		$ift s_command = "BITON"
		    'command_biton
		    sg_pass1 = s_record
		    sub_c_cline_biton_bitof

		    dinc d_good
		endi
		$ift s_command = "BITOF"
		    'command_biton
		    sg_pass1 = s_record
		    sub_c_cline_biton_bitof

		    dinc d_good
		endi
		$ift s_command = "GOTO "
		    'command_goto
		    $tlo s_dot, s_factor2
		    sg_pass1 = sg_ifindicators
		    $app sg_pass1, "goto " + s_dot + ";"
		    sub_c_lineout

		    dinc d_good
		    dg_yeslinedone = 1
		endi
		$ift s_command = "EXSR "
		    'command_exsr
		    $tlo s_any, s_factor2
		    sg_pass1 = sg_ifindicators
		    $app sg_pass1, "sub_begsr_" + s_any 
		    $app sg_pass1, "();"
		    sub_c_lineout

		    dinc d_good
		    dg_yeslinedone = 1
		endi
		$ift s_command = "TAG  "
		    'command_tag
		    $tlo s_any, s_factor1
		    sg_pass1 = s_any + ":;"
		    sub_c_lineout

		    dinc d_good
		    dg_yeslinedone = 1
		endi
		$ift s_command = "SETON"
		    'command_seton
		    sg_pass1 = sg_ifindicators
		    $app sg_pass1, "rsub_command_seton("
		    $app sg_pass1, "&ig_" + s_indicator4 + ","
		    $app sg_pass1, "&ig_" + s_indicator5 + ","
		    $app sg_pass1, "&ig_" + s_indicator6 + ");"
		    sub_c_lineout

		    dinc d_good
		    dg_yeslinedone = 1
		endi
		$ift s_command = "SETOF"
		    'command_setof
		    sg_pass1 = sg_ifindicators
		    $app sg_pass1, "rsub_command_setof("
		    $app sg_pass1, "&ig_" + s_indicator4 + ","
		    $app sg_pass1, "&ig_" + s_indicator5 + ","
		    $app sg_pass1, "&ig_" + s_indicator6 + ");"
		    sub_c_lineout

		    dinc d_good
		    dg_yeslinedone = 1
		endi
	  endi
	  dift d_good = 1
		'command_z-add,command_z-sub,command_add,
		'command_sub,command_mult,command_div,
		'command_mvr,command_time,command_sqrt,
		'command_xfoot
		s_tap = "Z-ADD,Z-SUB,ADD  ,SUB  ,MULT ,DIV  ,"
		$app s_tap, "MVR  ,TIME ,SQRT ,XFOOT,"
		$lok d_any, s_tap, 1, s_command
		dift d_any > 0
		    sg_pass1 = s_record
		    sub_c_cline_math
		    dinc d_good
		endi
	  endi
	  dift d_good = 1
		$ift s_command = "MOVEA"
		    'command_movea
		    sg_pass1 = s_record
		    sub_c_cline_movea
		    dinc d_good
		endi
		$ift s_command = "MOVEL"
		    'command_movel
		    sg_pass1 = s_record
		    sub_c_cline_movel
		    dinc d_good
		endi
		$ift s_command = "MOVE "
		    'command_move_right
		    sg_pass1 = s_record
		    sub_c_cline_move_right
		    dinc d_good
		endi
	  endi
	  dift d_good = 1
		$ift s_command = "COMP "
		    'command_comp
		    sg_pass1 = s_record
		    sub_c_cline_comp
		    dinc d_good
		endi
		$ift s_command = "LOKUP"
		    'command_lokup
		    '21,22,23 is alpha in factor1
		    d_dot = 2
		    dift d_fieldtype1 = 21: d_dot = 1
		    dift d_fieldtype1 = 22: d_dot = 1
		    dift d_fieldtype1 = 23: d_dot = 1
		    dift d_dot = 1
			  'alpha lokup
		        sg_pass1 = s_record
		        sub_c_cline_slokup
		    else
			  'numeric lokup
		        sg_pass1 = s_record
		        sub_c_cline_nlokup
		    endi

		    dinc d_good
		endi
		$ift s_command = "SORTA"
		    'command_sorta
		    sg_pass1 = s_record
		    sub_c_cline_sorta
		    dinc d_good
		endi
	  endi
	  dift d_good = 1
		$ift s_command = "TESTN"
		    'command_testn
		    sg_pass1 = s_result
		    sub_field_info_return
		    d_longct = dg_pass4
		    $tlo s_result, s_result

		    sg_pass1 = sg_ifindicators 
		    $app sg_pass1, "rsub_testn(sg_"
		    $app sg_pass1, s_result + ", " + d_longct
		    $app sg_pass1, ", &ig_" + s_indicator4
		    $app sg_pass1, ", &ig_" + s_indicator5
		    $app sg_pass1, ", &ig_" + s_indicator6 + ");"
		    sub_c_lineout

		    dinc d_good
		    dg_yeslinedone = 1
		endi
		$ift s_command = "TIME2"
		    'command_time2
'         1         2         3         4
'1234567890123456789012345678901234567890
'TUE. APR  4, 2000, 11:05 AM   JULIAN:095
		    sg_pass1 = s_result
		    sub_field_info_return
		    d_longct = dg_pass4
		    dift d_longct > 40: d_longct = 40
		    $tlo s_result, s_result
		    sg_pass1 = sg_ifindicators + "tsub_time2(sg_"
		    $app sg_pass1, s_result + ", " + d_longct + ");"
		    sub_c_lineout

		    dinc d_good
		    dg_yeslinedone = 1
		endi
	  endi
	  dift d_good = 1
'both below are in stdlib.h
'int setenv(const char *envname, const char *envval, int overwrite);
'int putenv(char *string); 
		$ift s_command = "PUTJW"
		    'command_setjcw
		    sg_pass1 = s_factor1
		    sub_c_numeric_field_prep
		    s_factor1 = sg_pass1

		    sg_pass1 = sg_ifindicators
		    $app sg_pass1, "rsub_putjw(" + s_factor2 + ", "
		    $app sg_pass1, s_factor1 + ", &ig_"
		    $app sg_pass1, s_indicator6 + ");"		    
		    sub_c_lineout

		    dinc d_good
		    dg_yeslinedone = 1
		endi
		$ift s_command = "FNDJW"
		    'command_fndjw
		    sg_pass1 = s_result
		    sub_c_numeric_field_prep
		    s_result = sg_pass1

		    sg_pass1 = sg_ifindicators
		    $app sg_pass1, "rsub_fndjw(" + s_factor2 + ", "
		    $app sg_pass1, "&" + s_result + ", "
		    $app sg_pass1, "&ig_" + s_indicator6 + ");" 
		    sub_c_lineout

		    dinc d_good
		    dg_yeslinedone = 1
		endi
	  endi

	  dift dg_yeslinedone = 1
		'the command s_command was done
		$lok d_any, sg_goodcommands, 1, s_command
		dift d_any = 0: $app sg_goodcommands, s_command + ","

		'do we want the fullcdebug stuff
		d_dot = 2
		dift dg_fullcdebug2 = 1: d_dot = 1
		$ift s_command = "ENDSR": dinc d_dot
		$ift s_command = "GOTO ": dinc d_dot
		dift d_dot = 1
		    'add lines for fullcdebug
		    sg_pass1 = s_record
		    dg_pass1 = d_record
		    sub_c_cline_fullcdebug_end
		endi
	  endi

	  dift dg_yeslinedone = 2
		'the command s_command was not done
		$trb s_any, s_record
		$out "not done=" + d_record + " " + s_any
		$lok d_any, sg_badcommands, 1, s_command
		dift d_any = 0
		    $app sg_badcommands, s_command + ","
		    $inp s_any, "return"
		endi		 
	  endi
    endw
ends sub_c_cline_commands


subr sub_c_cline_file_read
'updated 2004/10/27
'do commands READ,READP,CHAIN
    vari s_any, d_any, s_dot, d_dot, s_out
    vari s_record, s_factor1, s_command, s_factor2, s_result
    vari s_indicator4, s_indicator5, s_indicator6
    vari s_filename, s_filedevice, s_filetype, d_filereclong
    vari s_filefixed, s_fileksam
    vari d_filekeybeg, d_filekeylong
    vari s_recnum, s_cfilename, d_action
    vari d_indexct1, d_longct1, d_decimalct1
    
    s_record = sg_pass1

    'change indicators to sg_ifindicators,dg_yesifindicators
    $cut s_any, s_record, 9, 9
    sg_pass1 = s_any
    sub_c_ifindicators

    $cut s_factor1, s_record, 18, 10
    $cut s_command, s_record, 28, 5
    $cut s_factor2, s_record, 33, 10
    $cut s_result, s_record, 43, 6
    $cut s_indicator4, s_record, 54, 2
    $cut s_indicator5, s_record, 56, 2
    $cut s_indicator6, s_record, 58, 2

    'make blank indicators 00
    $swp s_indicator4, " ", "0"
    $swp s_indicator5, " ", "0"
    $swp s_indicator6, " ", "0"

    sg_pass1 = s_factor2
    sub_rpg_file_info_return
    s_filedevice = sg_pass1
    s_filetype = sg_pass2
    s_filefixed = sg_pass3
    s_fileksam = sg_pass4
    d_filereclong = dg_pass2
    d_filekeybeg = dg_pass3
    d_filekeylong = dg_pass4

    $trb s_filedevice, s_filedevice

    $tlo s_cfilename, s_factor2

    'do we need an ifindicators wrapper
    dift dg_yesifindicators = 1
	  sg_pass1 = sg_ifindicators + "{"
	  sub_c_lineout
    endi

    d_action = 0
    $ift s_command = "READ "
	  d_action = 2
	  $ift s_filedevice = "$STDIN": d_action = 1
	  $ift s_fileksam = "K": d_action = 13
    endi
    $ift s_command = "READP": d_action = 3
    $ift s_command = "CHAIN": d_action = 4

    s_recnum = "tng_recnum_" + s_cfilename

    dift d_action = 1
        'read the record from $STDIN
	  dift dg_fullcdebug2 = 1
		sg_pass1 = "if(tig_cdebug == 1) {"
		sub_c_lineout

		sg_pass1 = #tsub_out79("terminal input below");#
		sub_c_lineout

		sg_pass1 = "}"
		sub_c_lineout
	  endi

        sg_pass1 = "sub_file_read_" + s_cfilename + "();"
        sub_c_lineout
			
        'move fields to input since not eof
        sg_pass1 = "fsub_input_to_fields_" + s_cfilename + "();"
        sub_c_lineout

        'end the ifindicators wrapper
        dift dg_yesifindicators = 1
            sg_pass1 = "} /* ifindicators */"
	      sub_c_lineout
        endi

        dg_yeslinedone = 1
    endi
    dift d_action = 2
        'read record from file
        sg_pass1 = "sub_file_read_" + s_cfilename
	  $app sg_pass1, "();"
        sub_c_lineout
			
        'not eof
        sg_pass1 = "if(tig_eof != 1) {"
        sub_c_lineout

        'move fields to input since not eof
        sg_pass1 = "fsub_input_to_fields_" + s_cfilename + "();"
        sub_c_lineout

        'set the eof result indicator in 58/59
        sg_pass1 = "ig_" + s_indicator6 + " = 2;"
        sub_c_lineout

        sg_pass1 = "}"
        sub_c_lineout

	  'else we did not read a record
        sg_pass1 = "else ig_" + s_indicator6
        $app sg_pass1, " = 1;"
        sub_c_lineout

        'end the ifindicators wrapper
        dift dg_yesifindicators = 1
            sg_pass1 = "} /* ifindicators */"
	      sub_c_lineout
        endi

        dg_yeslinedone = 1
    endi
    dift d_action = 3
        'readp record from file
        sg_pass1 = "sub_file_readp_" + s_cfilename
	  $app sg_pass1, "();"
        sub_c_lineout
			
        'not eof
        sg_pass1 = "if(tig_eof != 1) {"
        sub_c_lineout

        'move fields to input since not eof
        sg_pass1 = "fsub_input_to_fields_" + s_cfilename + "();"
        sub_c_lineout

        'set the eof result indicator in 58/59
        sg_pass1 = "ig_" + s_indicator6 + " = 2;"
        sub_c_lineout

        sg_pass1 = "}"
        sub_c_lineout

	  'else we did not read a record
        sg_pass1 = "else ig_" + s_indicator6
        $app sg_pass1, " = 1;"
        sub_c_lineout

        'end the ifindicators wrapper
        dift dg_yesifindicators = 1
            sg_pass1 = "} /* ifindicators */"
	      sub_c_lineout
        endi

        dg_yeslinedone = 1
    endi
    dift d_action = 4
        'chain record from file
        sg_pass1 = s_factor1
        sub_c_numeric_field_prep
        s_factor1 = sg_pass1
        d_indexct1 = dg_pass2
        d_longct1 = dg_pass3
        d_decimalct1 = dg_pass4

        sg_pass1 = "sub_file_readp_" + s_cfilename
	  $app sg_pass1, "(tfni_index(" + s_factor1 + "));"
        sub_c_lineout
			
        'not eof
        sg_pass1 = "if(tig_eof != 1) {"
        sub_c_lineout

        'move fields to input since not eof
        sg_pass1 = "fsub_input_to_fields_" + s_cfilename + "();"
        sub_c_lineout

        'set the eof result indicator in 58/59
        sg_pass1 = "ig_" + s_indicator6 + " = 2;"
        sub_c_lineout

        sg_pass1 = "}"
        sub_c_lineout

	  'else we did not read a record
        sg_pass1 = "else ig_" + s_indicator6
        $app sg_pass1, " = 1;"
        sub_c_lineout

        'end the ifindicators wrapper
        dift dg_yesifindicators = 1
            sg_pass1 = "} /* ifindicators */"
	      sub_c_lineout
        endi

        dg_yeslinedone = 1
    endi
    dift d_action = 13
	  'read from KSAM file using HP intrinsic FREAD

        'read record from file
        sg_pass1 = "sub_file_read_" + s_cfilename
	  $app sg_pass1, "();"
        sub_c_lineout
			
        'not eof
        sg_pass1 = "if(tig_eof != 1) {"
        sub_c_lineout

        'move fields to input since not eof
        sg_pass1 = "fsub_input_to_fields_" + s_cfilename + "();"
        sub_c_lineout

        'set the eof result indicator in 58/59
        sg_pass1 = "ig_" + s_indicator6 + " = 2;"
        sub_c_lineout

        sg_pass1 = "}"
        sub_c_lineout

	  'else we did not read a record
        sg_pass1 = "else ig_" + s_indicator6
        $app sg_pass1, " = 1;"
        sub_c_lineout

        'end the ifindicators wrapper
        dift dg_yesifindicators = 1
            sg_pass1 = "} /* ifindicators */"
	      sub_c_lineout
        endi

        dg_yeslinedone = 1
    endi
ends sub_c_cline_file_read


subr sub_c_cline_lock_unlck_setll
'updated 2005/01/09
'lock,unlck,setll
    vari s_any, d_any, s_dot, d_dot, s_out
    vari s_record, s_factor1, s_command, s_factor2, s_result
    vari s_indicator4, s_indicator5, s_indicator6
    vari s_filename, s_filedevice, s_filetype, d_filereclong
    vari s_filefixed, s_fileksam
    vari d_filekeybeg, d_filekeylong
    vari s_recnum, s_cfilename, d_action
    vari d_indexct1, d_longct1, d_decimalct1
    vari d_type11, s_var11

    s_record = sg_pass1

    'change indicators to sg_ifindicators,dg_yesifindicators
    $cut s_any, s_record, 9, 9
    sg_pass1 = s_any
    sub_c_ifindicators

    $cut s_factor1, s_record, 18, 10
    $cut s_command, s_record, 28, 5
    $cut s_factor2, s_record, 33, 10
    $cut s_result, s_record, 43, 6
    $cut s_indicator4, s_record, 54, 2
    $cut s_indicator5, s_record, 56, 2
    $cut s_indicator6, s_record, 58, 2

    'make blank indicators 00
    $swp s_indicator4, " ", "0"
    $swp s_indicator5, " ", "0"
    $swp s_indicator6, " ", "0"

    sg_pass1 = s_factor2
    sub_rpg_file_info_return
    s_filedevice = sg_pass1
    s_filetype = sg_pass2
    s_filefixed = sg_pass3
    s_fileksam = sg_pass4
    d_filereclong = dg_pass2
    d_filekeybeg = dg_pass3
    d_filekeylong = dg_pass4

    $trb s_filedevice, s_filedevice

    $tlo s_cfilename, s_factor2

    dift dg_yesifindicators = 1
        'we need an ifindicators wrapper
	  sg_pass1 = sg_ifindicators + "{"
	  sub_c_lineout
    endi

    d_action = 0
    $ift s_command = "SETLL"
	  'HP intrinsic FFINDBYKEY

'd_expfieldtype1
'1=error
'2=blank
'6=*BLANK
'7=*ZEROS
'8=UDATE
'11=number
'12=numeric var
'13=numeric array with index
'14=numeric array no index
'21=alpha literal
'22=alpha var
'23=alpha array with index
'24=alpha array no index

        'get info for s_factor1
        sg_pass1 = s_factor1
        sub_field_info_return
        d_type11 = dg_pass1
        'd_type12 = dg_pass2
        'd_indexct1 = dg_pass3
        d_longct1 = dg_pass4
        'd_decimalct1 = dg_pass5
        s_var11 = sg_pass1
        's_var12 = sg_pass2
        's_cindex1 = sg_pass7

	  dift d_type11 = 21
		'we have an alpha literal
	      sg_pass1 = "tsub_copy(tsg_256a, " + s_var11
		$app sg_pass1, ", " + d_longct1 + ");"
		sub_c_lineout		
	  else
		'we have an alpha variable
		$clo s_any, s_var11
	      sg_pass1 = "tsub_copy(tsg_256a, sg_" + s_any
		$app sg_pass1, ", " + d_longct1 + ");"
		sub_c_lineout		
	  endi

	  sg_pass1 = "/* HP intrinsic FFINDBYKEY */"
	  sub_c_lineout

	  'FFINDBYKEY(filenum,value,location,length,relop)
	  'value=key
	  'relop=2 means find record >= key
	  sg_pass1 = "FFINDBYKEY(iksam_filenum_" + s_cfilename
	  $app sg_pass1, ", tsg_256a, " + d_filekeybeg
	  $app sg_pass1, ", " + d_filekeylong + ", 2);"
	  sub_c_lineout

	  'if ccode()=CCG then end of file or before beginning
	  'set iksam_mode_ to 2 if beyond end or before beginning
	  'set iksam_mode_ to 1 if good setll>=key
	  sg_pass1 = "if(ccode() == CCG) iksam_mode_"
	  $app sg_pass1, s_cfilename + " = 2;"
	  sub_c_lineout

	  sg_pass1 = "else iksam_mode_"
	  $app sg_pass1, s_cfilename + " = 1;"
	  sub_c_lineout

	  'set iksam_advanceflag to false=2
	  sg_pass1 = "iksam_advanceflag_" + s_cfilename
	  $app sg_pass1, " = 2;"
	  sub_c_lineout
    endi
    $ift s_command = "LOCK "
	  'HP intrinsic FLOCK

	  sg_pass1 = "/* HP intrinsic FLOCK */"
	  sub_c_lineout

	  sg_pass1 = "FLOCK(iksam_filenum_" + s_cfilename
	  $app sg_pass1, ", 1);"
	  sub_c_lineout

	  sg_pass1 = "ig_" + s_indicator6 + " = 2;"
	  sub_c_lineout

	  sg_pass1 = "if(ccode() == CCE) ig_"
	  $app sg_pass1, s_indicator6 + " = 1;"
	  sub_c_lineout
    endi
    $ift s_command = "UNLCK"
	  'HP intrinsic UNFLOCK

	  sg_pass1 = "/* HP intrinsic FUNLOCK */"
	  sub_c_lineout

	  sg_pass1 = "FUNLOCK(iksam_filenum_" + s_cfilename + ");"
	  sub_c_lineout

	  sg_pass1 = "ig_" + s_indicator6 + " = 2;"
	  sub_c_lineout

	  sg_pass1 = "if(ccode() == CCE) ig_"
	  $app sg_pass1, s_indicator6 + " = 1;"
	  sub_c_lineout
    endi

    dift dg_yesifindicators = 1
        'we need an ifindicators wrapper
	  sg_pass1 = "}"
	  sub_c_lineout
    endi
ends sub_c_cline_lock_unlck_setll


subr sub_c_cline_math
'updated 2005/01/13, 2005/01/11
'do commands Z-ADD,Z-SUB,ADD,SUB,MULT,DIV,MVR,TIME,SQRT,XFOOT
    vari s_any, d_any, s_dot, d_dot, s_out
    vari d_record, s_record, d_good, d_action
    vari s_rpgfield1, s_rpgcommand, s_rpgfield2, s_rpgfield3
    vari s_cfield1, s_cfield2, s_cfield3
    vari d_type1, d_type2, d_type3
    vari d_indexct1, d_indexct2, d_indexct3
    vari d_decimalct1, d_decimalct2, d_decimalct3, s_half
    vari d_longct1, d_longct2, d_longct3
    vari d_indextype1, d_indextype2, d_indextype3
    vari s_indexvar1, s_indexvar2, s_indexvar3

    s_record = sg_pass1

'cline    1         2         3         4         5         6
'123456789012345678901234567890123456789012345678901234567890
'    .CSR 01 02 03FIELD1    COMMDFIELD2    FIELD3  92H919293
'we use field instead of factor,result for simplicity here
    'the C if indicators are in sg_ifindicators

    $cut s_rpgfield1, s_record, 18, 10
    $cut s_rpgcommand, s_record, 28, 5
    $cut s_rpgfield2, s_record, 33, 10
    $cut s_rpgfield3, s_record, 43, 6

    'get half adjust char
    $cut s_half, s_record, 53, 1
	
    sg_pass1 = s_rpgfield1
    sub_c_numeric_field_prep
    d_type1 = dg_pass1
    d_indexct1 = dg_pass2
    d_longct1 = dg_pass3
    d_decimalct1 = dg_pass4
    d_indextype1 = dg_pass5
    s_cfield1 = sg_pass1
    s_indexvar1 = sg_pass2

    sg_pass1 = s_rpgfield2
    sub_c_numeric_field_prep
    d_type2 = dg_pass1
    d_indexct2 = dg_pass2
    d_longct2 = dg_pass3
    d_decimalct2 = dg_pass4
    d_indextype2 = dg_pass5
    s_cfield2 = sg_pass1
    s_indexvar2 = sg_pass2

    sg_pass1 = s_rpgfield3
    sub_c_numeric_field_prep
    d_type3 = dg_pass1
    d_indexct3 = dg_pass2
    d_longct3 = dg_pass3
    d_decimalct3 = dg_pass4
    d_indextype3 = dg_pass5
    s_cfield3 = sg_pass1
    s_indexvar3 = sg_pass2

'd_fieldtype
'1=bad field
'2=blank
'6=*BLANK
'7=*ZEROS
'8=UDATE
'11=numeric literal
'12=numeric var
'13=numeric array with index
'14=numeric array no index
'21=alpha literal
'22=alpha var
'23=alpha array with index
'24=alpha array no index

    $ift s_rpgcommand = "Z-ADD"
	  'zero add

	  dift d_indextype2 = 12
		'validate numeric var index for s_cfield2
		sg_pass1 = sg_ifindicators
		$app sg_pass1, "tsub_index_range_cerror("
		$app sg_pass1, s_indexvar2
		$app sg_pass1, ", " + d_indexct2 + ", "
		$app sg_pass1, dg_rpglinenumber + ");"
		sub_c_lineout
	  endi

	  dift d_indextype3 = 12
		'validate numeric var index for s_cfield3
		sg_pass1 = sg_ifindicators
		$app sg_pass1, "tsub_index_range_cerror("
		$app sg_pass1, s_indexvar3
		$app sg_pass1, ", " + d_indexct3 + ", "
		$app sg_pass1, dg_rpglinenumber + ");"
		sub_c_lineout
	  endi

	  'do we have d_type3=14 numeric array no index
	  d_action = 1
	  dift d_type3 = 14: d_action = 2

	  dift d_action = 1
		's_cfield3 is numeric var or numeric array with index
            sg_pass1 = sg_ifindicators
	      $app sg_pass1, s_cfield3
	      $app sg_pass1, " = rfnd_math_result("
	      $app sg_pass1, s_cfield2 + ", "
	      $app sg_pass1, d_decimalct3 + ", '" + s_half
	      $app sg_pass1, "', 1);"
            sub_c_lineout
	  endi
	  dift d_action = 2
		's_cfield3 is numeric array no index
            sg_pass1 = sg_ifindicators
		$app sg_pass1, "tsub_zadd_array(" + s_cfield3
		$app sg_pass1, ", " + d_indexct3 + ", "
		$app sg_pass1, s_cfield2 + ");"
            sub_c_lineout
	  endi

	  dg_yeslinedone = 1
    endi
    $ift s_rpgcommand = "Z-SUB"
	  'zero subtract
	  dift d_indextype2 = 12
		'validate numeric var index for s_cfield2
		sg_pass1 = sg_ifindicators
		$app sg_pass1, "tsub_index_range_cerror("
		$app sg_pass1, s_indexvar2
		$app sg_pass1, ", " + d_indexct2 + ", "
		$app sg_pass1, dg_rpglinenumber + ");"
		sub_c_lineout
	  endi

	  dift d_indextype3 = 12
		'validate numeric var index for s_cfield3
		sg_pass1 = sg_ifindicators
		$app sg_pass1, "tsub_index_range_cerror("
		$app sg_pass1, s_indexvar3
		$app sg_pass1, ", " + d_indexct3 + ", "
		$app sg_pass1, dg_rpglinenumber + ");"
		sub_c_lineout
	  endi

	  'do we have d_type3=14 numeric array no index
	  d_action = 1
	  dift d_type3 = 14: d_action = 2

	  dift d_action = 1
		's_cfield3 is numeric var or numeric array with index
            sg_pass1 = sg_ifindicators
	      $app sg_pass1, s_cfield3
	      $app sg_pass1, " = -rfnd_math_result("
	      $app sg_pass1, s_cfield2 + ", "
	      $app sg_pass1, d_decimalct3 + ", '" + s_half
	      $app sg_pass1, "', 1);"
            sub_c_lineout
	  endi
	  dift d_action = 2
		's_cfield3 is numeric array no index
            sg_pass1 = sg_ifindicators
		$app sg_pass1, "tsub_zadd_array(" + s_cfield3
		$app sg_pass1, ", " + d_indexct3 + ", -"
		$app sg_pass1, s_cfield2 + ");"
	  endi

	  dg_yeslinedone = 1
    endi
    $ift s_rpgcommand = "ADD  "
	  'addition
	  $len d_any, s_cfield1
	  dift d_any = 0
		s_cfield1 = s_cfield3
		d_decimalct1 = d_decimalct3
		s_indexvar1 = s_indexvar3
		d_indexct1 = d_indexct3
	  endi

	  dift d_indextype1 = 12
		'validate numeric var index for s_cfield1
		sg_pass1 = sg_ifindicators
		$app sg_pass1, "tsub_index_range_cerror("
		$app sg_pass1, s_indexvar1
		$app sg_pass1, ", " + d_indexct1 + ", "
		$app sg_pass1, dg_rpglinenumber + ");"
		sub_c_lineout
	  endi

	  dift d_indextype2 = 12
		'validate numeric var index for s_cfield2
		sg_pass1 = sg_ifindicators
		$app sg_pass1, "tsub_index_range_cerror("
		$app sg_pass1, s_indexvar2
		$app sg_pass1, ", " + d_indexct2 + ", "
		$app sg_pass1, dg_rpglinenumber + ");"
		sub_c_lineout
	  endi

	  dift d_indextype3 = 12
		'validate numeric var index for s_cfield3
		sg_pass1 = sg_ifindicators
		$app sg_pass1, "tsub_index_range_cerror("
		$app sg_pass1, s_indexvar3
		$app sg_pass1, ", " + d_indexct3 + ", "
		$app sg_pass1, dg_rpglinenumber + ");"
		sub_c_lineout
	  endi

        sg_pass1 = sg_ifindicators
	  $app sg_pass1, s_cfield3
	  $app sg_pass1, " = rfnd_math_result(" 
	  $app sg_pass1, s_cfield1 + " + " + s_cfield2 
	  $app sg_pass1, ", " + d_decimalct3
	  $app sg_pass1, ", '" + s_half + "', 1);"
        sub_c_lineout

	  dg_yeslinedone = 1
    endi
    $ift s_rpgcommand = "SUB  "
	  'subtract
	  $len d_any, s_cfield1
	  dift d_any = 0
		s_cfield1 = s_cfield3
		d_decimalct1 = d_decimalct3
		s_indexvar1 = s_indexvar3
		d_indexct1 = d_indexct3
	  endi

	  dift d_indextype1 = 12
		'validate numeric var index for s_cfield1
		sg_pass1 = sg_ifindicators
		$app sg_pass1, "tsub_index_range_cerror("
		$app sg_pass1, s_indexvar1
		$app sg_pass1, ", " + d_indexct1 + ", "
		$app sg_pass1, dg_rpglinenumber + ");"
		sub_c_lineout
	  endi

	  dift d_indextype2 = 12
		'validate numeric var index for s_cfield2
		sg_pass1 = sg_ifindicators
		$app sg_pass1, "tsub_index_range_cerror("
		$app sg_pass1, s_indexvar2
		$app sg_pass1, ", " + d_indexct2 + ", "
		$app sg_pass1, dg_rpglinenumber + ");"
		sub_c_lineout
	  endi

	  dift d_indextype3 = 12
		'validate numeric var index for s_cfield3
		sg_pass1 = sg_ifindicators
		$app sg_pass1, "tsub_index_range_cerror("
		$app sg_pass1, s_indexvar3
		$app sg_pass1, ", " + d_indexct3 + ", "
		$app sg_pass1, dg_rpglinenumber + ");"
		sub_c_lineout
	  endi

        sg_pass1 = sg_ifindicators
	  $app sg_pass1, s_cfield3
	  $app sg_pass1, " = rfnd_math_result(" 
	  $app sg_pass1, s_cfield1 + " - " + s_cfield2 
	  $app sg_pass1, ", " + d_decimalct3
	  $app sg_pass1, ", '" + s_half + "', 1);"
        sub_c_lineout

	  dg_yeslinedone = 1
    endi
    $ift s_rpgcommand = "MULT "
	  'multiply
	  $len d_any, s_cfield1
	  dift d_any = 0
		s_cfield1 = s_cfield3
		d_decimalct1 = d_decimalct3
		s_indexvar1 = s_indexvar3
		d_indexct1 = d_indexct3
	  endi

	  dift d_indextype1 = 12
		'validate numeric var index for s_cfield1
		sg_pass1 = sg_ifindicators
		$app sg_pass1, "tsub_index_range_cerror("
		$app sg_pass1, s_indexvar1
		$app sg_pass1, ", " + d_indexct1 + ", "
		$app sg_pass1, dg_rpglinenumber + ");"
		sub_c_lineout
	  endi

	  dift d_indextype2 = 12
		'validate numeric var index for s_cfield2
		sg_pass1 = sg_ifindicators
		$app sg_pass1, "tsub_index_range_cerror("
		$app sg_pass1, s_indexvar2
		$app sg_pass1, ", " + d_indexct2 + ", "
		$app sg_pass1, dg_rpglinenumber + ");"
		sub_c_lineout
	  endi

	  dift d_indextype3 = 12
		'validate numeric var index for s_cfield3
		sg_pass1 = sg_ifindicators
		$app sg_pass1, "tsub_index_range_cerror("
		$app sg_pass1, s_indexvar3
		$app sg_pass1, ", " + d_indexct3 + ", "
		$app sg_pass1, dg_rpglinenumber + ");"
		sub_c_lineout
	  endi

        sg_pass1 = sg_ifindicators + s_cfield3
	  $app sg_pass1, " = rfnd_math_result("
	  $app sg_pass1, s_cfield1 + " * " + s_cfield2 + " ,"
	  $app sg_pass1, d_decimalct3 + ", '" + s_half
	  $app sg_pass1, "', 0);"
        sub_c_lineout

	  dg_yeslinedone = 1
    endi
    $ift s_rpgcommand = "DIV  "
	  'divide
	  $len d_any, s_cfield1
	  dift d_any = 0
		s_cfield1 = s_cfield3
		d_decimalct1 = d_decimalct3
		s_indexvar1 = s_indexvar3
		d_indexct1 = d_indexct3
	  endi

	  dift d_indextype1 = 12
		'validate numeric var index for s_cfield1
		sg_pass1 = sg_ifindicators
		$app sg_pass1, "tsub_index_range_cerror("
		$app sg_pass1, s_indexvar1
		$app sg_pass1, ", " + d_indexct1 + ", "
		$app sg_pass1, dg_rpglinenumber + ");"
		sub_c_lineout
	  endi

	  dift d_indextype2 = 12
		'validate numeric var index for s_cfield2
		sg_pass1 = sg_ifindicators
		$app sg_pass1, "tsub_index_range_cerror("
		$app sg_pass1, s_indexvar2
		$app sg_pass1, ", " + d_indexct2 + ", "
		$app sg_pass1, dg_rpglinenumber + ");"
		sub_c_lineout
	  endi

	  dift d_indextype3 = 12
		'validate numeric var index for s_cfield3
		sg_pass1 = sg_ifindicators
		$app sg_pass1, "tsub_index_range_cerror("
		$app sg_pass1, s_indexvar3
		$app sg_pass1, ", " + d_indexct3 + ", "
		$app sg_pass1, dg_rpglinenumber + ");"
		sub_c_lineout
	  endi

	  'save s_cfield1,s_cfield2 in case of MVR next
	  sg_prevdividefactor1 = s_cfield1
	  sg_prevdividefactor2 = s_cfield2

        sg_pass1 = sg_ifindicators
	  $app sg_pass1, s_cfield3 + " = rfnd_divide("
	  $app sg_pass1, s_cfield1 + ", " + s_cfield2 + ", "
	  $app sg_pass1, d_decimalct3 + ", '" + s_half + "', "
	  $app sg_pass1, dg_rpglinenumber + ");"
        sub_c_lineout

	  dg_yeslinedone = 1
    endi
    $ift s_rpgcommand = "MVR  "
	  'mvr or modulus
	  dift d_indextype3 = 12
		'validate numeric var index for s_cfield3
		sg_pass1 = sg_ifindicators
		$app sg_pass1, "tsub_index_range_cerror("
		$app sg_pass1, s_indexvar3
		$app sg_pass1, ", " + d_indexct3 + ", "
		$app sg_pass1, dg_rpglinenumber + ");"
		sub_c_lineout
	  endi

        sg_pass1 = sg_ifindicators
	  $app sg_pass1, s_cfield3 + " = rfnd_mvr_modulus("
	  $app sg_pass1, sg_prevdividefactor1 + ", " 
	  $app sg_pass1, sg_prevdividefactor2 + ", "
	  $app sg_pass1, d_decimalct3 + ", '" + s_half + "', "
	  $app sg_pass1, dg_rpglinenumber + ");"
        sub_c_lineout

	  dg_yeslinedone = 1
    endi
    $ift s_rpgcommand = "TIME "
	  'time
	  dift d_indextype3 = 12
		'validate numeric var index for s_cfield3
		sg_pass1 = sg_ifindicators
		$app sg_pass1, "tsub_index_range_cerror("
		$app sg_pass1, s_indexvar3
		$app sg_pass1, ", " + d_indexct3 + ", "
		$app sg_pass1, dg_rpglinenumber + ");"
		sub_c_lineout
	  endi

	  d_any = 6
	  dift d_longct3 > 6: d_any = 12

	  sg_pass1 = sg_ifindicators
	  $app sg_pass1, s_cfield3 + " = tfnd_time( " 
	  $app sg_pass1, d_any + ");"
        sub_c_lineout

	  dg_yeslinedone = 1
    endi
    $ift s_rpgcommand = "SQRT "
	  'square root
	  dift d_indextype2 = 12
		'validate numeric var index for s_cfield2
		sg_pass1 = sg_ifindicators
		$app sg_pass1, "tsub_index_range_cerror("
		$app sg_pass1, s_indexvar2
		$app sg_pass1, ", " + d_indexct2 + ", "
		$app sg_pass1, dg_rpglinenumber + ");"
		sub_c_lineout
	  endi

	  dift d_indextype3 = 12
		'validate numeric var index for s_cfield3
		sg_pass1 = sg_ifindicators
		$app sg_pass1, "tsub_index_range_cerror("
		$app sg_pass1, s_indexvar3
		$app sg_pass1, ", " + d_indexct3 + ", "
		$app sg_pass1, dg_rpglinenumber + ");"
		sub_c_lineout
	  endi

        sg_pass1 = sg_ifindicators
	  $app sg_pass1, s_cfield3
	  $app sg_pass1, " = rfnd_math_result(sqrt(fabs("
	  $app sg_pass1, s_cfield2 + ")), "
	  $app sg_pass1, d_decimalct3 + ", '" + s_half
	  $app sg_pass1, "', 0);"
        sub_c_lineout

	  dg_yeslinedone = 1
    endi
    $ift s_rpgcommand = "XFOOT"
	  'cross foot
	  dift d_indextype3 = 12
		'validate numeric var index for s_cfield3
		sg_pass1 = sg_ifindicators
		$app sg_pass1, "tsub_index_range_cerror("
		$app sg_pass1, s_indexvar3
		$app sg_pass1, ", " + d_indexct3 + ", "
		$app sg_pass1, dg_rpglinenumber + ");"
		sub_c_lineout
	  endi

        sg_pass1 = sg_ifindicators
	  $app sg_pass1, s_cfield3
	  $app sg_pass1, " = rfnd_math_result(rfnd_xfoot("
	  $app sg_pass1, s_cfield2 + ", "
	  $app sg_pass1, d_indexct2 + "), "
	  $app sg_pass1, d_decimalct3 
	  $app sg_pass1, ", '" + s_half + "', 1);"
        sub_c_lineout

	  dg_yeslinedone = 1
    endi
ends sub_c_cline_math


subr sub_c_cline_comp
'updated 2004/09/05
    vari s_any, d_any, s_dot, d_dot, s_out
    vari d_record, s_record, d_good, d_action, d_length
    vari s_factor1, s_factor2
    vari s_indicator1, s_indicator2, s_indicator3
    vari d_type11, d_type12, d_indexct1, d_longct1, d_decimalct1
    vari s_var11, s_var12
    vari d_type21, d_type22, d_indexct2, d_longct2, d_decimalct2
    vari s_var21, s_var22
    vari s_cindex1, s_cindex2
    vari s_pvar1, s_pvar2, s_plong1, s_plong2, s_pchar

    s_record = sg_pass1
    $cut s_factor1, s_record, 18, 10
    $cut s_factor2, s_record, 33, 10
    $cut s_indicator1, s_record, 54, 2
    $cut s_indicator2, s_record, 56, 2
    $cut s_indicator3, s_record, 58, 2
    s_any = "  "
    s_dot = "00"
    $ift s_indicator1 = s_any: s_indicator1 = s_dot
    $ift s_indicator2 = s_any: s_indicator2 = s_dot
    $ift s_indicator3 = s_any: s_indicator3 = s_dot

'cline    1         2         3         4         5         6
'123456789012345678901234567890123456789012345678901234567890
'    .CSR 01 02 03FACTOR1   COMMDFACTOR2   RESULT  92H919293
'd_expfieldtype1
'1=error
'2=blank
'6=*BLANK
'7=*ZEROS
'8=UDATE
'11=number
'12=numeric var
'13=numeric array with index
'14=numeric array no index
'21=alpha literal
'22=alpha var
'23=alpha array with index
'24=alpha array no index

    'get info for s_inpfield = factor1
    sg_pass1 = s_factor1
    sub_field_info_return
    d_type11 = dg_pass1
    d_type12 = dg_pass2
    d_indexct1 = dg_pass3
    d_longct1 = dg_pass4
    d_decimalct1 = dg_pass5
    s_var11 = sg_pass1
    s_var12 = sg_pass2
    s_cindex1 = sg_pass7

    'get info for s_inpfield = factor2
    sg_pass1 = s_factor2
    sub_field_info_return
    d_type21 = dg_pass1
    d_type22 = dg_pass2
    d_indexct2 = dg_pass3
    d_longct2 = dg_pass4
    d_decimalct2 = dg_pass5
    s_var21 = sg_pass1
    s_var22 = sg_pass2
    s_cindex2 = sg_pass7

    'd_action = 1 for numeric and 2 for alpha
    d_action = 99999

    'first numeric whose type is 11 to 13
    d_dot = 0
    dift d_type11 >= 11
	  dift d_type11 <= 13: dinc d_dot
    endi
    dift d_type21 >= 11
	  dift d_type21 <= 13: dinc d_dot
    endi
    dift d_dot = 2: d_action = 1

    'now alpha variables types=6,7,21,22,23
    d_dot = 0
    'we do not put *BLANK or *ZEROS in field1
    dift d_type11 = 21: dinc d_dot
    dift d_type11 = 22: dinc d_dot
    dift d_type11 = 23: dinc d_dot

    dift d_type21 = 6: dinc d_dot
    dift d_type21 = 7: dinc d_dot
    dift d_type21 = 21: dinc d_dot
    dift d_type21 = 22: dinc d_dot
    dift d_type21 = 23: dinc d_dot
    dift d_dot = 2: d_action = 2

    'd_action = 1 for numeric and 2 for alpha
    dift d_action = 1
	  'number compare
	  dift d_type12 = 12
		'validate numeric var index for s_cfield1
		sg_pass1 = sg_ifindicators
		$app sg_pass1, "tsub_index_range_cerror("
		$app sg_pass1, s_cindex1
		$app sg_pass1, ", " + d_indexct1 + ", "
		$app sg_pass1, dg_rpglinenumber + ");"
		sub_c_lineout
	  endi
	  dift d_type22 = 12
		'validate numeric var index for s_cfield2
		sg_pass1 = sg_ifindicators
		$app sg_pass1, "tsub_index_range_cerror("
		$app sg_pass1, s_cindex2
		$app sg_pass1, ", " + d_indexct2 + ", "
		$app sg_pass1, dg_rpglinenumber + ");"
		sub_c_lineout
	  endi

        sg_pass1 = s_factor1
        sub_c_numeric_field_prep
        s_factor1 = sg_pass1

        sg_pass1 = s_factor2
        sub_c_numeric_field_prep
        s_factor2 = sg_pass1

	  sg_pass1 = sg_ifindicators + "tsub_compare_numbers( "
	  $app sg_pass1, s_factor1 + " ," + s_factor2 + ", &ig_"
	  $app sg_pass1, s_indicator1 + ", &ig_" + s_indicator2
	  $app sg_pass1, ", &ig_" + s_indicator3 + ");"

        sub_c_lineout
	  dg_yeslinedone = 1
    endi

    'd_action = 1 for numeric and 2 for alpha
    dift d_action = 2
	  'string compare first factor
	  dift d_type11 = 21
		'string literal
		s_pvar1 = s_var11
		s_plong1 = d_longct1
	  endi
	  dift d_type11 = 22
		'string variable
		s_pvar1 = "sg_" + s_var11
		$clo s_pvar1, s_pvar1
		s_plong1 = d_longct1
	  endi
	  dift d_type11 = 23
		'string array with index
	      dift d_type12 = 12
		    'validate numeric var index for s_cfield1
		    sg_pass1 = sg_ifindicators
		    $app sg_pass1, "tsub_index_range_cerror("
		    $app sg_pass1, s_cindex1
		    $app sg_pass1, ", " + d_indexct1 + ", "
		    $app sg_pass1, dg_rpglinenumber + ");"
		    sub_c_lineout
	      endi

		$trb s_any, s_var11
		s_pvar1 = "&sga_" + s_any + "[tfni_index( "

		'is s_var12 a numeric variable
		$trb s_any, s_var12
		dift d_type12 = 12: s_any = "dg_" + s_any

		$app s_pvar1, s_any + " - 1) * " 
		$app s_pvar1, d_longct1 + "]"
		$clo s_pvar1, s_pvar1
		s_plong1 = d_longct1
	  endi

	  'string compare second factor
	  dift d_type21 = 6
		'*BLANK
		s_pchar = " "

		'use length of s_pvar1
		s_plong2 = d_longct1
		d_action = 22
	  endi
	  dift d_type21 = 7
		'*ZEROS
		s_pchar = "0"

		'use length of s_pvar1
		s_plong2 = d_longct1
		d_action = 22
	  endi
	  dift d_type21 = 21
		'string literal
		s_pvar2 = s_var21
		s_plong2 = d_longct2
		d_action = 21
	  endi
	  dift d_type21 = 22
		'string variable
		s_pvar2 = "sg_" + s_var21
		$clo s_pvar2, s_pvar2
		s_plong2 = d_longct2
		d_action = 21
	  endi
	  dift d_type21 = 23
		'string array with index
	      dift d_type22 = 12
		    'validate numeric var index for s_cfield2
		    sg_pass1 = sg_ifindicators
		    $app sg_pass1, "tsub_index_range_cerror("
		    $app sg_pass1, s_cindex2
		    $app sg_pass1, ", " + d_indexct2 + ", "
		    $app sg_pass1, dg_rpglinenumber + ");"
		    sub_c_lineout
	      endi

		$trb s_any, s_var21
		s_pvar2 = "&sga_" + s_any + "[tfni_index( "

		'is s_var22 a numeric variable
		$trb s_any, s_var22
		dift d_type22 = 12: s_any = "dg_" + s_any
		$app s_pvar2, s_any + " - 1) * "

		$app s_pvar2, d_longct2 + "];"
		$clo s_pvar2, s_pvar2
		s_plong2 = d_longct2
		d_action = 21
	  endi
    endi
    dift d_action = 21
	  'string compare without *BLANK or *ZEROS
	  sg_pass1 = sg_ifindicators
	  $app sg_pass1, "tsub_compare_strings("
	  $app sg_pass1, s_pvar1 + ", " + s_plong1 + ", "
	  $app sg_pass1, s_pvar2 + ", " + s_plong2
	  $app sg_pass1, ", &ig_" + s_indicator1
	  $app sg_pass1, ", &ig_" + s_indicator2
	  $app sg_pass1, ", &ig_" + s_indicator3 + ");"
        sub_c_lineout

	  dg_yeslinedone = 1
    endi
    dift d_action = 22
	  'string compare with *BLANK or *ZEROS
	  sg_pass1 = sg_ifindicators
	  $app sg_pass1, "tsub_comp_string_to_char("
	  $app sg_pass1, s_pvar1 + ", " + s_plong1 
	  $app sg_pass1, ", '" + s_pchar + "'" 
	  $app sg_pass1, ", &ig_" + s_indicator1
	  $app sg_pass1, ", &ig_" + s_indicator2
	  $app sg_pass1, ", &ig_" + s_indicator3 + ");"
        sub_c_lineout

	  dg_yeslinedone = 1
    endi
ends sub_c_cline_comp


subr sub_c_cline_slokup
'updated 2004/12/28
'string lokup
    vari s_any, d_any, s_dot, d_dot, s_out
    vari d_record, s_record, d_good
    vari s_field1, s_field2, s_indicator
    vari d_type11, d_type12, s_var11, s_var12
    vari d_type21, d_type22, s_var21, s_var22
    vari d_longct1, d_indexct1, d_longct2, d_indexct2
    vari s_cindex1, s_cindex2
    vari s_pvar1, s_pvar2, s_pbegindex, s_preturnindex
    vari d_plongct, d_pindexct
    vari s_field3, d_tablongct3

    s_record = sg_pass1
'cline    1         2         3         4         5         6
'123456789012345678901234567890123456789012345678901234567890
'    .CSR 01 02 03FACTOR1   COMMDFACTOR2   RESULT  92H919293
    $cut s_field1, s_record, 18, 10
    $cut s_field2, s_record, 33, 10
    $cut s_field3, s_record, 43, 6
    $cut s_indicator, s_record, 58, 2

    sg_pass1 = s_field1
    sub_field_info_return
    d_type11 = dg_pass1
    d_type12 = dg_pass2
    d_indexct1 = dg_pass3
    d_longct1 = dg_pass4
    $trb s_var11, sg_pass1
    $trb s_var12, sg_pass2
    s_cindex1 = sg_pass7

    sg_pass1 = s_field2
    sub_field_info_return
    d_type21 = dg_pass1
    d_type22 = dg_pass2
    d_indexct2 = dg_pass3
    d_longct2 = dg_pass4
    $trb s_var21, sg_pass1
    $trb s_var22, sg_pass2
    s_cindex2 = sg_pass7

'd_expfieldtype1
'1=error
'2=blank
'6=*BLANK
'7=*ZEROS
'8=UDATE
'11=number
'12=numeric var
'13=numeric array with index
'14=numeric array no index
'21=alpha literal
'22=alpha var
'23=alpha array with index
'24=alpha array no index

    'first do we have a table lookup
    dift d_type21 = 24
	  $isc d_any, s_field3, " "
	  dift d_any <> 1: d_type21 = 25
    endi

    'prep the lookfor field
    dift d_type11 = 21
	  'alpha literal
	  s_pvar1 = s_var11	  
    endi
    dift d_type11 = 22
	  'alpha variable
	  $tlo s_any, s_var11
	  s_pvar1 = "sg_" + s_any
    endi
    dift d_type11 = 23
	  'alpha array with index
        dift d_type12 = 12
	      'validate numeric var index for s_field1
	      sg_pass1 = sg_ifindicators
	      $app sg_pass1, "tsub_index_range_cerror("
		$app sg_pass1, s_cindex1
	      $app sg_pass1, ", " + d_indexct1 + ", "
	      $app sg_pass1, dg_rpglinenumber + ");"
	      sub_c_lineout
        endi

	  'prep the index first
	  dift d_type12 = 12
		'numeric var
		$tlo s_any, s_var12
		s_dot = "tfni_index(dg_" + s_any + ")"
	  else
		'numeric literal
	      s_dot = s_var12
	  endi
	  s_dot = "(" + s_dot + " - 1) * " + d_longct1

	  $tlo s_any, s_var11
	  s_pvar1 = "&sga_" + s_any + "[" + s_dot + "]"
    endi

    'prep the lookin array
    $tlo s_any, s_var21
    s_pvar2 = "sga_" + s_any

    d_plongct = d_longct2
    d_pindexct = d_indexct2

    dift d_type21 = 23
	  'alpha array with index
        dift d_type22 = 12
	      'validate numeric var index for s_field2
	      sg_pass1 = sg_ifindicators
	      $app sg_pass1, "tsub_index_range_cerror("
		$app sg_pass1, s_cindex2
	      $app sg_pass1, ", " + d_indexct2 + ", "
	      $app sg_pass1, dg_rpglinenumber + ");"
	      sub_c_lineout
        endi

	  'index must be a numeric variable
	  $tlo s_any, s_var22
	  s_pbegindex = "tfni_index(dg_" + s_any + ")"
	  s_preturnindex = "dg_" + s_any

        sg_pass1 = sg_ifindicators
	  $app sg_pass1, "tng_z = rfni_slokup("
	  $app sg_pass1, s_pvar2 + ", " 
	  $app sg_pass1, d_pindexct + ", "
        $app sg_pass1, d_plongct + ", "
	  $app sg_pass1, s_pbegindex + ", "
        $app sg_pass1, s_pvar1 + ");"
        sub_c_lineout

	  'index is numeric variable
	  sg_pass1 = sg_ifindicators
	  $app sg_pass1, s_preturnindex
	  $app sg_pass1, " = " + "tng_z;"
        sub_c_lineout

	  s_any = "ig_" + s_indicator

	  'set the indicator
	  sg_pass1 = sg_ifindicators
	  $app sg_pass1, "if(tng_z > 0) " + s_any
	  $app sg_pass1, " = 1; else " + s_any + " = 2;"
        sub_c_lineout

	  dg_yeslinedone = 1
    endi
    dift d_type21 = 24
	  'alpha array no index
        sg_pass1 = sg_ifindicators
	  $app sg_pass1, "tng_z = rfni_slokup("
	  $app sg_pass1, s_pvar2 + ", " 
	  $app sg_pass1, d_pindexct + ", "
        $app sg_pass1, d_plongct + ", "
	  $app sg_pass1, "1, "
        $app sg_pass1, s_pvar1 + ");"
        sub_c_lineout

	  s_any = "ig_" + s_indicator

	  'set the indicator
	  sg_pass1 = sg_ifindicators
	  $app sg_pass1, "if(tng_z > 0) " + s_any
	  $app sg_pass1, " = 1; else " + s_any + " = 2;"
        sub_c_lineout

	  dg_yeslinedone = 1
    endi
    dift d_type21 = 25
	  'table lookup
	  sg_pass1 = s_field3
	  sub_variable_info_return
	  d_tablongct3 = dg_pass3

	  $tlo s_field3, s_field3

        sg_pass1 = sg_ifindicators
	  $app sg_pass1, "tng_z = rfni_stablokup("
	  $app sg_pass1, s_pvar2 + ", " 
	  $app sg_pass1, d_pindexct + ", "
        $app sg_pass1, d_plongct + ", "
	  $app sg_pass1, d_tablongct3 + ", "
        $app sg_pass1, s_pvar1 + ", "
	  $app sg_pass1, "sg_" + s_field3 + ");"
        sub_c_lineout

	  s_any = "ig_" + s_indicator

	  'set the indicator
	  sg_pass1 = sg_ifindicators
	  $app sg_pass1, "if(tng_z == 1) " + s_any
	  $app sg_pass1, " = 1; else " + s_any + " = 2;"
        sub_c_lineout

	  dg_yeslinedone = 1
    endi
'int rfni_slokup(char *sp_lookin, int ip_indexct,
'int ip_long, int ip_begindex, char *sp_lookfor);

'int rfni_stablokup(char *sp_lookin, int ip_indexct,
'int ip_long1, int ip_long2, char *sp_lookfor,
'char *sp_putinto);
ends sub_c_cline_slokup


subr sub_c_cline_nlokup
'updated 2004/09/05
'numeric lokup
    vari s_any, d_any, s_dot, d_dot, s_out
    vari d_record, s_record, d_good
    vari s_field1, s_field2, s_indicator
    vari d_type11, d_type12, s_var11, s_var12
    vari d_type21, d_type22, s_var21, s_var22
    vari d_longct1, d_indexct1, d_longct2, d_indexct2
    vari s_cindex1, s_cindex2
    vari s_pvar1, s_pvar2, s_pbegindex, s_preturnindex
    vari d_plongct, d_pindexct

    s_record = sg_pass1
    $cut s_field1, s_record, 18, 10
    $cut s_field2, s_record, 33, 10
    $cut s_indicator, s_record, 58, 2

    sg_pass1 = s_field1
    sub_field_info_return
    d_type11 = dg_pass1
    d_type12 = dg_pass2
    d_indexct1 = dg_pass3
    d_longct1 = dg_pass4
    $trb s_var11, sg_pass1
    $trb s_var12, sg_pass2
    s_cindex1 = sg_pass7

    sg_pass1 = s_field2
    sub_field_info_return
    d_type21 = dg_pass1
    d_type22 = dg_pass2
    d_indexct2 = dg_pass3
    d_longct2 = dg_pass4
    $trb s_var21, sg_pass1
    $trb s_var22, sg_pass2
    s_cindex2 = sg_pass7

'd_expfieldtype1
'1=error
'2=blank
'6=*BLANK
'7=*ZEROS
'8=UDATE
'11=number
'12=numeric var
'13=numeric array with index
'14=numeric array no index
'21=alpha literal
'22=alpha var
'23=alpha array with index
'24=alpha array no index

    'prep the lookfor field
    dift d_type11 = 11
	  'numeric literal
	  s_pvar1 = s_var11
    endi
    dift d_type11 = 12
	  'numeric variable
	  $tlo s_any, s_var11
	  s_pvar1 = "dg_" + s_any
    endi
    dift d_type11 = 13
	  'numeric array with index
        dift d_type12 = 12
	      'validate numeric var index for s_field1
	      sg_pass1 = sg_ifindicators
	      $app sg_pass1, "tsub_index_range_cerror("
		$app sg_pass1, s_cindex1
	      $app sg_pass1, ", " + d_indexct1 + ", "
	      $app sg_pass1, dg_rpglinenumber + ");"
	      sub_c_lineout
        endi

	  'prep the index first
	  dift d_type12 = 12
		'numeric var index
		$tlo s_any, s_var12
		s_dot = "tfni_index(dg_" + s_any + ")"
	  else
		'numeric literal index
	      s_dot = s_var12
	  endi

	  $tlo s_any, s_var11
	  s_pvar1 = "&dga_" + s_any + "[" + s_dot + " - 1]"
    endi

    'prep the lookin array
    dift d_type21 = 13
	  'numeric array with index
        dift d_type22 = 12
	      'validate numeric var index for s_field2
	      sg_pass1 = sg_ifindicators
	      $app sg_pass1, "tsub_index_range_cerror("
		$app sg_pass1, s_cindex2
	      $app sg_pass1, ", " + d_indexct2 + ", "
	      $app sg_pass1, dg_rpglinenumber + ");"
	      sub_c_lineout
        endi

        $tlo s_any, s_var21
        s_pvar2 = "dga_" + s_any
    endi
    dift d_type21 = 14
	  'numeric array no index
        $tlo s_any, s_var21
        s_pvar2 = "dga_" + s_any
    endi

    d_plongct = d_longct2
    d_pindexct = d_indexct2

    dift d_type21 = 13
	  'numeric array with index

	  'prep the begindex
	  dift d_type22 = 12
		'index is numeric variable
		$tlo s_any, s_var22
		s_pbegindex = "tfni_index(dg_" + s_any + ")"
		s_preturnindex = "dg_" + s_any
	  else
		'index in numeric literal
		s_pbegindex = s_var22
	  endi

        sg_pass1 = sg_ifindicators + "tng_z = rfni_nlokup("
	  $app sg_pass1, s_pvar2 + ", " 
	  $app sg_pass1, d_pindexct + ", "
        $app sg_pass1, d_plongct + ", "
	  $app sg_pass1, s_pbegindex + ", "
        $app sg_pass1, s_pvar1 + ");"
        sub_c_lineout

	  'index is numeric variable
	  sg_pass1 = sg_ifindicators
	  $app sg_pass1, s_preturnindex
	  $app sg_pass1, " = " + "tng_z;"
        sub_c_lineout

	  s_any = "ig_" + s_indicator

	  'set the indicator
	  sg_pass1 = sg_ifindicators
	  $app sg_pass1, "if(tng_z > 0) " + s_any
	  $app sg_pass1, " = 1; else " + s_any + " = 2;"
        sub_c_lineout

	  dg_yeslinedone = 1
    endi
    dift d_type21 = 14
	  'numeric array no index
        sg_pass1 = sg_ifindicators
	  $app sg_pass1, "tng_z = rfni_nlokup("
	  $app sg_pass1, s_pvar2 + ", " 
	  $app sg_pass1, d_pindexct + ", "
        $app sg_pass1, d_plongct + ", "
	  $app sg_pass1, "1, "
        $app sg_pass1, s_pvar1 + ");"
        sub_c_lineout

	  s_any = "ig_" + s_indicator

	  'set the indicator
	  sg_pass1 = sg_ifindicators
	  $app sg_pass1, "if(tng_z > 0) " + s_any
	  $app sg_pass1, " = 1; else " + s_any + " = 2;"
        sub_c_lineout

	  dg_yeslinedone = 1
    endi

'int rfni_slokup(char *sp_lookin, int ip_indexct,
'int ip_long, int ip_begindex, char *sp_lookfor);
ends sub_c_cline_nlokup


subr sub_c_cline_movea
'updated 2004/12/30
'make C lines for command MOVEA
    vari s_any, d_any, s_dot, d_dot, s_out
    vari d_record, s_record, d_good, d_action
    vari s_command, s_field1, s_field2
    vari d_type11, d_type12, s_var11, s_var12
    vari d_type21, d_type22, s_var21, s_var22
    vari d_longct1, d_indexct1, d_longct2, d_indexct2
    vari s_pbeg1, s_pbeg2, d_plong1, d_plong2
    vari s_cfield1, s_cfield2  
    vari s_cindex1, s_cindex2
    vari s_pvar1, s_pvar2

    s_record = sg_pass1

'cline    1         2         3         4         5         6
'123456789012345678901234567890123456789012345678901234567890
'    .CSR 01 02 03FACTOR1   COMMDFACTOR2   RESULT  92H919293

    'c if indicators are in sg_ifindicators

    $cut s_command, s_record, 28, 5
    $cut s_field1, s_record, 33, 10
    $cut s_field2, s_record, 43, 6

's_field1 which is factor2 can be:
'*BLANK
'alpha literal
'alpha var
'alpha array with index
'alpha array

's_field2 which is the result can be
'alpha var
'alpha array with index
'alpha array

'd_expfieldtype1
'1=error
'2=blank
'6=*BLANK
'7=*ZEROS
'8=UDATE
'11=number
'12=numeric var
'13=numeric array with index
'14=numeric array no index
'21=alpha literal
'22=alpha var
'23=alpha array with index
'24=alpha array no index

    'get info for s_field1 = factor2
    sg_pass1 = s_field1
    sub_field_info_return
    d_type11 = dg_pass1
    d_type12 = dg_pass2
    d_indexct1 = dg_pass3
    d_longct1 = dg_pass4
    s_var11 = sg_pass1
    s_var12 = sg_pass2
    s_cfield1 = sg_pass4
    s_cindex1 = sg_pass7

    dift d_type11 = 21
	  'alpha literal
	  s_pvar1 = s_cfield1
	  s_pbeg1 = "1"
    endi
    dift d_type11 = 22
	  'alpha variable
	  s_pvar1 = s_cfield1
	  s_pbeg1 = "1"
    endi
    dift d_type11 = 23
	  'alpha array with index
	  dift d_type12 = 12
		'validate numeric var index for s_field1
		sg_pass1 = sg_ifindicators
		$app sg_pass1, "tsub_index_range_cerror("
		$app sg_pass1, s_cindex1
		$app sg_pass1, ", " + d_indexct1 + ", "
		$app sg_pass1, dg_rpglinenumber + ");"
		sub_c_lineout
	  endi

	  $tlo s_var11, s_var11
	  s_pvar1 = "sga_" + s_var11
	  dift d_type12 = 11
		'number literal index
		s_pbeg1 = s_var12
	  else
		'number variable index
		$tlo s_any, s_var12
		s_pbeg1 = "tfni_index( dg_" + s_any + ")"
	  endi
    endi
    dift d_type11 = 24
	  'alpha array no index
	  $tlo s_var11, s_var11
	  s_pvar1 = "sga_" + s_var11
	  s_pbeg1 = "1"
    endi

    sg_pass1 = s_field2
    sub_field_info_return
    d_type21 = dg_pass1
    d_type22 = dg_pass2
    d_indexct2 = dg_pass3
    d_longct2 = dg_pass4
    s_var21 = sg_pass1
    s_var22 = sg_pass2
    s_cfield2 = sg_pass4
    s_cindex2 = sg_pass7

    $tlo s_var21, s_var21
    $tlo s_var22, s_var22

    dift d_type21 = 22
	  'alpha variable
	  s_pvar2 = "sg_" + s_var21
	  s_pbeg2 = "1"
    endi
    dift d_type21 = 23
	  'alpha array with index
	  dift d_type22 = 12
		'validate numeric var index for s_field2
		sg_pass1 = sg_ifindicators
		$app sg_pass1, "tsub_index_range_cerror("
		$app sg_pass1, s_cindex2
		$app sg_pass1, ", " + d_indexct2 + ", "
		$app sg_pass1, dg_rpglinenumber + ");"
		sub_c_lineout
	  endi

	  s_pvar2 = "sga_" + s_var21
	  dift d_type22 = 11
		'number index take off leading zeros
		s_pbeg2 = s_var22
	  else
		'variable index
		s_pbeg2 = "tfni_index( dg_" + s_var22 + ")"
	  endi
    endi
    dift d_type21 = 24
	  'alpha array no index
	  s_pvar2 = "sga_" + s_var21
	  s_pbeg2 = "1"
    endi

    d_good = 1
    dift d_type11 = 6
	  'MOVEA *BLANK
	  sg_pass1 = sg_ifindicators
	  $app sg_pass1, "rsub_crpg_movea_blankorzero( "
	  $app sg_pass1, s_pvar2 + ", " + d_indexct2 + ", "
	  $app sg_pass1, d_longct2 + ", " + s_pbeg2
	  $app sg_pass1, ", ' ');"
        sub_c_lineout

	  dinc d_good
	  dg_yeslinedone = 1
    endi
    dift d_type11 = 7
	  'MOVEA *ZEROS
	  sg_pass1 = sg_ifindicators
	  $app sg_pass1, "rsub_crpg_movea_blankorzero( "
	  $app sg_pass1, s_pvar2 + ", " + d_indexct2 + ", "
	  $app sg_pass1, d_longct2 + ", " + s_pbeg2
	  $app sg_pass1, ", '0');"
        sub_c_lineout

	  dinc d_good
	  dg_yeslinedone = 1
    endi
    dift d_good = 1
	  'output to c for MOVEA
        sg_pass1 = sg_ifindicators
	  $app sg_pass1, "rsub_crpg_movea(" 
        $app sg_pass1, s_pvar2 + ", " + d_indexct2 + ", "
	  $app sg_pass1, d_longct2 + ", " + s_pbeg2 + ", "
        $app sg_pass1, s_pvar1 + ", " + d_indexct1 + ", "
	  $app sg_pass1, d_longct1 + ", " + s_pbeg1 + ");"
        sub_c_lineout

	  dg_yeslinedone = 1
    endi
ends sub_c_cline_movea


subr sub_c_cline_movel
'updated 2004/09/18
'make C lines for command MOVEL
    vari s_any, d_any, s_dot, d_dot, s_out
    vari s_record, d_action
    vari s_field1, d_type1, d_longct1, d_decimalct1, s_var1 
    vari s_field2, d_type2, d_longct2, d_decimalct2, s_var2
    vari s_pbeg1, s_pbeg2, d_plong1, d_plong2
    vari s_pvar1, s_pvar2

    s_record = sg_pass1

'cline    1         2         3         4         5         6
'123456789012345678901234567890123456789012345678901234567890
'    .CSR 01 02 03FACTOR1   COMMDFACTOR2   RESULT  92H919293

    'c if indicators are in sg_ifindicators
    $cut s_field1, s_record, 33, 10
    $cut s_field2, s_record, 43, 6

's_field1 which is factor2 can be:
'*BLANK
'alpha literal
'alpha var
'alpha array with index
'alpha array

's_field2 which is the result can be
'alpha var
'alpha array with index
'alpha array

'd_expfieldtype1
'1=error
'2=blank
'6=*BLANK
'7=*ZEROS
'8=UDATE
'11=number
'12=numeric var
'13=numeric array with index
'14=numeric array no index
'21=alpha literal
'22=alpha var
'23=alpha array with index
'24=alpha array no index

    'get info for s_field1 = factor2
    sg_pass1 = s_field1
    sub_field_info_return
    d_type1 = dg_pass1
    d_longct1 = dg_pass4
    d_decimalct1 = dg_pass5
    s_var1 = sg_pass1

    dift d_type1 = 12
	  'numeric variable to tsg_256a
	  $tlo s_var1, s_var1
	  sg_pass1 = sg_ifindicators
	  $app sg_pass1, "tsub_double_to_packed(tsg_256a, "
	  $app sg_pass1, "dg_" + s_var1 + ", "
	  $app sg_pass1, d_longct1 + ", " + d_decimalct1 + ");"
        sub_c_lineout

	  sg_pass1 = sg_ifindicators
	  $app sg_pass1, "tsgp_1 = tsg_256a;"
        sub_c_lineout
    endi
    dift d_type1 = 21
	  'alpha literal to tsg_256a
	  sg_pass1 = sg_ifindicators
	  $app sg_pass1, "tsub_copy(tsg_256a, " + s_var1
	  $app sg_pass1, ", " + d_longct1 + ");" 
        sub_c_lineout

	  sg_pass1 = sg_ifindicators
	  $app sg_pass1, "tsgp_1 = tsg_256a;"
        sub_c_lineout
    endi
    dift d_type1 = 22
	  'alpha variable
	  $tlo s_var1, s_var1
	  sg_pass1 = sg_ifindicators
	  $app sg_pass1, "tsgp_1 = sg_" + s_var1 + ";"
	  sub_c_lineout
    endi

    'get info for s_field2 = result field
    sg_pass1 = s_field2
    sub_field_info_return
    d_type2 = dg_pass1
    d_longct2 = dg_pass4
    d_decimalct2 = dg_pass5
    s_var2 = sg_pass1
    $tlo s_var2, s_var2

    d_action = 0

    dift d_type2 = 12
	  'to a numeric variable

	  'put numeric variable in tsg_256b
	  sg_pass1 = sg_ifindicators
	  $app sg_pass1, "tsub_double_to_packed(tsg_256b, "
	  $app sg_pass1, "dg_" + s_var2 + ", "
	  $app sg_pass1, d_longct2 + ", " + d_decimalct2 + ");"
        sub_c_lineout

	  'MOVEL
	  sg_pass1 = sg_ifindicators
        $app sg_pass1, "rsub_crpg_movel(tsg_256b, "
	  $app sg_pass1, d_longct2 + ", tsgp_1, " 
	  $app sg_pass1, d_longct1 + ");"
        sub_c_lineout

	  'put tsg_256b into numeric variable
	  sg_pass1 = sg_ifindicators
	  $app sg_pass1, "tsub_packed_to_double(&dg_" + s_var2
	  $app sg_pass1, ", tsg_256b, " + d_longct2 + ", "
	  $app sg_pass1, d_decimalct2 + ", " + dg_rpglinenumber
	  $app sg_pass1, ");"
	  sub_c_lineout

	  dg_yeslinedone = 1
    endi
    dift d_type2 = 22
	  'to alpha variable
	  'MOVEL
	  sg_pass1 = sg_ifindicators
        $app sg_pass1, "rsub_crpg_movel(sg_" + s_var2
	  $app sg_pass1, ", " + d_longct2 + ", tsgp_1, " 
	  $app sg_pass1, d_longct1 + ");"
        sub_c_lineout

	  dg_yeslinedone = 1
    endi    
ends sub_c_cline_movel


subr sub_c_cline_move_right  
'updated 2004/09/18
'make C lines for command MOVE
    vari s_any, d_any, s_dot, d_dot
    vari s_record, d_action
    vari s_field1, d_type1, d_indexct1
    vari d_longct1, d_decimalct1, s_var1 
    vari s_field2, d_type2, d_indexct2
    vari d_longct2, d_decimalct2, s_var2

    s_record = sg_pass1

'cline    1         2         3         4         5         6
'123456789012345678901234567890123456789012345678901234567890
'    .CSR 01 02 03FACTOR1   COMMDFACTOR2   RESULT  92H919293

    'c if indicators are in sg_ifindicators
    $cut s_field1, s_record, 33, 10
    $cut s_field2, s_record, 43, 6

's_field1 which is factor2 can be:
'*BLANK=6
'*ZEROS=7
'numeric var=12
'alpha literal=21
'alpha var=22

's_field2 which is the result can be
'numeric var-12
'alpha var=22
'alpha array no index=24

'd_expfieldtype1
'1=error
'2=blank
'6=*BLANK
'7=*ZEROS
'8=UDATE
'11=number
'12=numeric var
'13=numeric array with index
'14=numeric array no index
'21=alpha literal
'22=alpha var
'23=alpha array with index
'24=alpha array no index

    'get info for s_field1 = factor2
    sg_pass1 = s_field1
    sub_field_info_return
    d_type1 = dg_pass1
    d_indexct1 = dg_pass3
    d_longct1 = dg_pass4
    d_decimalct1 = dg_pass5
    s_var1 = sg_pass1

    dift d_type1 = 12
	  'numeric variable to tsg_256a
	  $tlo s_var1, s_var1

        sg_pass1 = sg_ifindicators
	  $app sg_pass1, "tsub_double_to_packed(tsg_256a, "
	  $app sg_pass1, "dg_" + s_var1 + ", "
	  $app sg_pass1, d_longct1 + ", " + d_decimalct1 + ");"
        sub_c_lineout

	  sg_pass1 = sg_ifindicators + "tsgp_1 = tsg_256a;"
        sub_c_lineout
    endi
    dift d_type1 = 21
	  'alpha literal to tsg_256a
        sg_pass1 = sg_ifindicators
	  $app sg_pass1, "tsub_copy(tsg_256a, " + s_var1
	  $app sg_pass1, ", " + d_longct1 + ");" 
        sub_c_lineout

	  sg_pass1 = sg_ifindicators
	  $app sg_pass1, "tsgp_1 = tsg_256a;"
        sub_c_lineout
    endi
    dift d_type1 = 22
	  'alpha variable
	  $tlo s_var1, s_var1

	  sg_pass1 = sg_ifindicators
	  $app sg_pass1, "tsgp_1 = sg_" + s_var1 + ";"
	  sub_c_lineout
    endi

    'get info for s_field2 = result field
    sg_pass1 = s_field2
    sub_field_info_return
    d_type2 = dg_pass1
    d_indexct2 = dg_pass3
    d_longct2 = dg_pass4
    d_decimalct2 = dg_pass5
    s_var2 = sg_pass1
    $tlo s_var2, s_var2

    d_action = 0

    '6 is *BLANK
    dift d_type1 = 6: d_action = 1

    '7 is *ZEROS
    dift d_type1 = 7: d_action = 2

    dift d_action = 0
	  'to a numeric variable
	  dift d_type2 = 12: d_action = 3

	  'to an alpha variable
	  dift d_type2 = 22: d_action = 4

	  'to an alpha array no index
	  dift d_type2 = 24: d_action = 5
    endi

    dift d_action = 1
	  'MOVE *BLANK
        sg_pass1 = sg_ifindicators
	  $app sg_pass1, "rsub_crpg_movea_blankorzero("
	  $app sg_pass1, "sg_" + s_var2 + ", " + d_indexct2 + ", "
	  $app sg_pass1, d_longct2 + ", 1, ' ');"
        sub_c_lineout

        dg_yeslinedone = 1
    endi
    dift d_action = 2
	  'MOVE *ZEROS
        sg_pass1 = sg_ifindicators
	  $app sg_pass1, "rsub_crpg_movea_blankorzero("
	  $app sg_pass1, "sg_" + s_var2 + ", " + d_indexct2 + ", "
	  $app sg_pass1, d_longct2 + ", 1, '0');"
	  sub_c_lineout

	  dg_yeslinedone = 1
    endi
    dift d_action = 3
	  'to a numeric variable

	  'put numeric variable in tsg_256b
        sg_pass1 = sg_ifindicators
	  $app sg_pass1, "tsub_double_to_packed(tsg_256b, "
	  $app sg_pass1, "dg_" + s_var2 + ", "
	  $app sg_pass1, d_longct2 + ", " + d_decimalct2 + ");"
        sub_c_lineout

	  'move right
	  sg_pass1 = sg_ifindicators
        $app sg_pass1, "rsub_crpg_move_right(tsg_256b, "
	  $app sg_pass1, d_longct2 + ", tsgp_1, " 
	  $app sg_pass1, d_longct1 + ");"
        sub_c_lineout

	  'put tsg_256b into numeric variable
	  sg_pass1 = sg_ifindicators
	  $app sg_pass1, "tsub_packed_to_double(&dg_" + s_var2
	  $app sg_pass1, ", tsg_256b, " + d_longct2 + ", "
	  $app sg_pass1, d_decimalct2 + ", " + dg_rpglinenumber
	  $app sg_pass1, ");"
	  sub_c_lineout

	  dg_yeslinedone = 1
    endi
    dift d_action = 4
	  'to alpha variable
	  'MOVE right
	  sg_pass1 = sg_ifindicators
        $app sg_pass1, "rsub_crpg_move_right(sg_" + s_var2
	  $app sg_pass1, ", " + d_longct2 + ", tsgp_1, " 
	  $app sg_pass1, d_longct1 + ");"
        sub_c_lineout

	  dg_yeslinedone = 1
    endi
    dift d_action = 5
	  'move to array
	  sg_pass1 = sg_ifindicators
	  $app sg_pass1, "tsub_move_right_into_array(sga_" + s_var2
	  $app sg_pass1, ", " + d_indexct2 + ", " + d_longct2
	  $app sg_pass1, ", tsgp_1, " + d_longct1 + ");" 
	  sub_c_lineout

	  dg_yeslinedone = 1
    endi
ends sub_c_cline_move_right


subr sub_c_cline_biton_bitof
'updated 2004/08/29
'make C lines for command MOVE
    vari s_any, d_any, s_dot, d_dot, s_out
    vari s_record, d_good, d_numresult, s_command
    vari s_field1, d_type1, d_longct1, d_decimalct1, s_var1 
    vari s_field2, d_type2, d_longct2, d_decimalct2, s_var2
    vari s_pbeg1, s_pbeg2, d_plong1, d_plong2
    vari s_pvar1, s_pvar2

    s_record = sg_pass1

'cline    1         2         3         4         5         6
'123456789012345678901234567890123456789012345678901234567890
'    .CSR 01 02 03FACTOR1   COMMDFACTOR2   RESULT  92H919293

    'c if indicators are in sg_ifindicators
    $cut s_command, s_record, 28, 5
    $cut s_field1, s_record, 33, 10
    $cut s_field2, s_record, 43, 6
    
's_field1 which is factor2 can be:
'alpha literal
'alpha var

's_field2 which is the result can be
'alpha var

'd_expfieldtype1
'1=error
'2=blank
'6=*BLANK
'7=*ZEROS
'8=UDATE
'11=number
'12=numeric var
'13=numeric array with index
'14=numeric array no index
'21=alpha literal
'22=alpha var
'23=alpha array with index
'24=alpha array no index

    d_numresult = 2

    'get info for s_field1 = factor2
    sg_pass1 = s_field1
    sub_field_info_return
    d_type1 = dg_pass1
    d_longct1 = dg_pass4
    d_decimalct1 = dg_pass5
    s_var1 = sg_pass1

    $tlo s_var1, s_var1

    dift d_type1 = 21
	  'alpha literal to tsg_256a
	  'copy the literal into tsg_256a

	  sg_pass1 = sg_ifindicators
	  $app sg_pass1, "tsub_copy(tsg_256a, " + s_var1
	  $app sg_pass1, ", " + d_longct1 + ");" 
        sub_c_lineout

	  'set pointer tsgp_1 to point to tsg_256a
	  sg_pass1 = sg_ifindicators
	  $app sg_pass1, "tsgp_1 = tsg_256a;"
        sub_c_lineout
    endi
    dift d_type1 = 22
	  'alpha variable
	  'set pointer tsgp_1 to point to the alpha variable
	  sg_pass1 = sg_ifindicators
	  $app sg_pass1, "tsgp_1 = sg_" + s_var1 + ";"
	  sub_c_lineout
    endi

    'get info for s_field2 = result field
    'must be alpha var one long
    sg_pass1 = s_field2
    sub_field_info_return
    d_type2 = dg_pass1
    d_longct2 = dg_pass4
    d_decimalct2 = dg_pass5
    s_var2 = sg_pass1

    $tlo s_var2, s_var2

    'must have alpha variable
    'set the pointer tsgp_2 to point to the alpha variable
    sg_pass1 = sg_ifindicators
    $app sg_pass1, "tsgp_2 = sg_" + s_var2 + ";"
    sub_c_lineout

    'call the needed rsub
    $ift s_command = "BITON"
        sg_pass1 = sg_ifindicators
	  $app sg_pass1, "rsub_command_biton(tsgp_2, tsgp_1, "
	  $app sg_pass1, d_longct1 + ");"
        sub_c_lineout

        dg_yeslinedone = 1
    else
	  'BITOF
        sg_pass1 = sg_ifindicators
	  $app sg_pass1, "rsub_command_bitof(tsgp_2, tsgp_1, "
	  $app sg_pass1, d_longct1 + ");"
        sub_c_lineout

	  dg_yeslinedone = 1
    endi
ends sub_c_cline_biton_bitof


subr sub_c_cline_sorta
'updated 2004/09/06
    vari s_any, d_any, s_dot, d_dot, s_out
    vari s_record, s_factor2
    vari d_vartype, d_indexct, d_longct, d_decimalct

    s_record = sg_pass1
'cline    1         2         3         4         5         6
'123456789012345678901234567890123456789012345678901234567890
'    .CSR 01 02 03FACTOR1   COMMDFACTOR2   RESULT  92H919293

    $cut s_factor2, s_record, 33, 10
'123456789 sg_rpgvarnames 9 long
'abbbbcccd sg_rpgvarsizes 9 long
'a    = d_vartype: 1=numeric,2=numeric array,6=alpha,7=alpha array
'bbbb = d_varindexct: index count
'ccc  = d_varlongct: length
'd    = d_vardecimalct: decimals
    sg_pass1 = s_factor2
    sub_variable_info_return
    d_vartype = dg_pass1
    d_indexct = dg_pass2
    d_longct = dg_pass3
    d_decimalct = dg_pass4

    $tlo s_factor2, s_factor2

    dift d_vartype = 2
	  'numeric sort array
        sg_pass1 = sg_ifindicators
	  $app sg_pass1, "tsub_nsorta(dga_" + s_factor2 + ", "
	  $app sg_pass1, d_indexct + ");"

	  sub_c_lineout
	  dg_yeslinedone = 1
    endi

    dift d_vartype = 7
	  'alpha sort array
        sg_pass1 = sg_ifindicators
	  $app sg_pass1, "tsub_asorta(sga_" + s_factor2 + ", "
	  $app sg_pass1, d_indexct + ", " + d_longct + ");"

	  sub_c_lineout
	  dg_yeslinedone = 1
    endi
ends sub_c_cline_sorta


subr sub_c_olines
'updated 2007/06/17, 2005/01/27, 2004/03/14
    vari s_any, d_any, s_dot, d_dot, s_out
    vari d_loop, d_good, d_count, s_fromsubr
    vari d_record, s_record, d_olinebegin, d_filebyteold
    vari s_6hold, s_6byte, s_7byte
    vari s_excpttags, s_tag, d_tag

    $sys sg_subroutine, 2
    s_fromsubr = sg_subroutine
    dift dg_tdebug = 1
	  sg_pass1 = sg_subroutine
	  sub_return
    endi

    'find where the olines begin=d_olinebegin
    sg_csubrname = sg_nothing
    d_filebyteold = 1
    d_olinebegin = 1
    s_excpttags = sg_nothing
    dg_rpglinenumber = 0
    d_record = 0
    dg_filebyte = 1

    d_loop = 1
    dwhi d_loop = 1
	  d_filebyteold = dg_filebyte
	  d_good = 1

	  fsip s_record, sg_inpfile, dg_filebyte

	  dift dg_filebyte = 0
		$out s_fromsubr + "=" + dg_record
		dg_record = 0
		dinc d_good
		dinc d_loop
	  endi
	  dift d_good = 1
		dinc dg_record
		dinc dg_rpglinenumber

		'tell
		d_any = dg_record % 1000
		dift d_any = 0: $sho s_fromsubr + "=" + dg_record

		'make sure the record is 80 long
		$ch$ s_any, " ", 80
		$app s_record, s_any
		$cut s_record, s_record, 1, 80

		$cut s_6byte, s_record, 6, 1
		$cut s_7byte, s_record, 7, 1

		$ift s_6byte = "O"
		    'make sure the O is for an oline
		    $ift s_6hold = "C"
			  d_olinebegin = d_filebyteold
		    endi
		    $ift s_7byte = "*": dinc d_good
		else
		    dinc d_good
		endi

		s_6hold = s_6byte
	  endi
	  dift d_good = 1
		'put new excpt tags in s_excpttags
		$ift s_7byte <> " "
		    $cut s_tag, s_record, 32, 6
		    $lok d_any, s_excpttags, 1, s_tag
		    dift d_any = 0: $app s_excpttags, s_tag + ","
		endi
	  endi
    endw

'oline    1         2         3         4         5         6
'123456789012345678901234567890123456789012345678901234567890
'    .OFILENAMEE 12     01 02 03OLINE
'    .O                 01 02 03VARIABJB 132 "HEADING LINE  "
    'go through excpt tags to create oline_subroutines
    d_tag = 0
    d_loop = 1
    dwhi d_loop = 1
	  dinc d_tag
	  $par s_tag, s_excpttags, ",", d_tag

	  'did we get an excpttag
	  $trb s_tag, s_tag
	  $len d_any, s_tag
	  dift d_any > 0
		$sho s_fromsubr + "=" + s_tag 
	      dg_pass1 = d_olinebegin
	      sg_pass1 = s_tag
	      sub_c_oline_subroutines
	  else
		$out s_fromsubr + " done" 
		dinc d_loop
	  endi
    endw
ends sub_c_olines


subr sub_c_oline_subroutines
'updated 2007/06/20, 2007/06/18, 2007/06/17
'2007/06/15, 2006/07/12, 2005/07/06, 2005/07/05, 2005/01/11
'create subroutine for particular excpttag
    vari s_any, d_any, s_dot, d_dot, s_out
    vari d_loop, d_good, d_count, d_long
    vari s_record, d_filebyte
    vari s_6byte, s_7byte, d_action
    vari s_fileout, s_filedevice, d_yesterminal
    vari s_excpttag, s_tag, s_excptsubr
    vari d_skipbefore, d_skipafter
    vari s_indicators, s_oifindicators
    vari s_variable, s_endbyte, s_literal
    vari s_editcd, s_blankcd
    vari d_yesinexcpttag, d_yessubrfilewrite, s_subrfilewrite
    vari d_vartype1, d_vartype2, s_var1, s_var2
    vari d_varindexct1, d_varlongct1, d_vardecimalct1
    vari d_beg, d_end, s_index

    'd_filebyte is beginning of output lines
    's_excpttag is the excpttag to create sub for
    d_filebyte = dg_pass1
    s_excpttag = sg_pass1

    sub_c_blankline

    'output subroutine beginning
    $tlo s_any, s_excpttag
    s_excptsubr = "sub_excpt_" + s_any
    sg_pass1 = "void " + s_excptsubr + "(void) {"
    sub_c_lineout

    sg_pass1 = "int i_long; int i_index;"
    sub_c_lineout

    'starting at d_filebyte create subroutine for s_excpttag
    d_yesinexcpttag = 2
    d_yesterminal = 2
    d_loop = 1

    dwhi d_loop = 1
	  d_good = 1
	  d_action = 0
	  d_yessubrfilewrite = 2

	  'sip in a record
	  fsip s_record, sg_inpfile, d_filebyte

	  dift d_filebyte = 0
		'we are at the end of olines
		dinc d_good
		dinc d_loop
	      dift d_yesinexcpttag = 1: d_yessubrfilewrite = 1
	      dinc d_yesinexcpttag
	  endi
	  dift d_good = 1
		'make sure the record is 80 long
		$ch$ s_any, " ", 80
		$app s_record, s_any
		$cut s_record, s_record, 1, 80

		'store the line in the queue
		sg_pass1 = dg_record + " " + s_record
		sub_queue

		$cut s_6byte, s_record, 6, 1
		$cut s_7byte, s_record, 7, 1

		$ift s_6byte <> "O"
		    'we are at the end of the olines
		    dinc d_good
		    dinc d_loop
		    dift d_yesinexcpttag = 1: d_yessubrfilewrite = 1
		    dinc d_yesinexcpttag
		endi
	  endi
	  dift d_good = 1
		'have we an excpttag in s_record
		$ist d_any, s_7byte, "A"
		dift d_any = 1
		    'have we been in the wanted excpttag
		    dift d_yesinexcpttag = 1
			  'output tsg_output2 down below
			  d_yessubrfilewrite = 1
		    endi

		    'have we the wanted excpttag in this line
		    $cut s_tag, s_record, 32, 6
		    $trb s_tag, s_tag

		    $ift s_tag = s_excpttag
			  'begin building wanted excpttag
			  d_action = 100
			  d_yesinexcpttag = 1
		    else
			  'begin an unwanted excpttag
			  dinc d_yesinexcpttag
		    endi

		    dinc d_good
		endi
		dift d_yesinexcpttag <> 1: dinc d_good
	  endi
'oline    1         2         3         4         5         6
'123456789012345678901234567890123456789012345678901234567890
'    .OFILENAMEE 12     01 02 03OLINE
'    .O                 01 02 03VARIABJB 132 "HEADING LINE  "
	  dift d_good = 1
		'we are in output of wanted excpttag
		$ift s_7byte = "*"
		    'we have a comment oline
		    d_action = 20
		    dinc d_good
		endi
	  endi
	  dift d_good = 1
		'do we have a variable or literal output oline
	      $cut s_any, s_record, 32, 6
	      $isc d_any, s_any, " "
	      dift d_any = 1: d_action = 200
	      dift d_any <> 1: d_action = 300
	  endi

	  'do we have terminal output 
	  d_any = 2
	  dift d_yessubrfilewrite = 1
		dift d_yesterminal = 1: d_any = 1
	  endi
	  dift d_any = 1
		'output to the term data is in tsg_output2
		'the output subroutine outputs tsg_output1

		'blank tsg_output1 no s_oifindicators here
		sg_pass1 = "tsub_blank(tsg_output1, 2048);"
		sub_c_lineout

		'skip lines before if needed
		d_any = 0
		dwhi d_any < d_skipbefore
		    'call s_subrfilewrite to output tsg_output1
		    sg_pass1 = s_oifindicators + s_subrfilewrite
		    sub_c_lineout

		    dinc d_any		
		endw

		'copy tsg_output2 to tsg_output1
		sg_pass1 = s_oifindicators
		$app sg_pass1, "tsub_copy(tsg_output1, tsg_output2, 2048);"
		sub_c_lineout

		'call the subroutine to output
		sg_pass1 = s_oifindicators + s_subrfilewrite
		sub_c_lineout

		'blank tsg_output2 no s_oifindicators here
		sg_pass1 = "tsub_blank(tsg_output2, 2048);"
		sub_c_lineout

		'blank tsg_output1 no s_oifindicators here
		sg_pass1 = "tsub_blank(tsg_output1, 2048);"
		sub_c_lineout

		'skip lines after if needed
		d_any = 1
		dwhi d_any < d_skipafter
		    'call subr to output tsg_output1
		    sg_pass1 = s_oifindicators + s_subrfilewrite
		    sub_c_lineout

		    dinc d_any		
		endw

		dinc d_yessubrfilewrite
	  endi

	  'do we have file output
	  d_any = 2
	  dift d_yessubrfilewrite = 1
		dift d_yesterminal <> 1: d_any = 1
	  endi
	  dift d_any = 1
		'output to the file data is in tsg_output2
		'the output subroutine outputs tsg_output1

		'copy tsg_output2 to tsg_output1
		sg_pass1 = s_oifindicators 
		$app sg_pass1, "tsub_copy(tsg_output1, tsg_output2, 2048);"
		sub_c_lineout

		'call the subroutine to output to the file
		sg_pass1 = s_oifindicators + s_subrfilewrite
		sub_c_lineout

		'blank tsg_output2 no s_ifindicators here
		sg_pass1 = "tsub_blank(tsg_output2, 2048);"
		sub_c_lineout

		'blank tsg_output1 no s_oifindicators here
		sg_pass1 = "tsub_blank(tsg_output1, 2048);"
		sub_c_lineout

		dinc d_yessubrfilewrite
	  endi

	  dift d_action = 20
		'output the comment line in wanted excpttag
	      $cut s_any, s_record, 8, 99
	      $trb s_any, s_any
	      $len d_any, s_any
	      dift d_any > 0
		    sub_c_blankline
		    $trb s_any, s_record
	          sg_pass1 = sg_slashaster + s_any + sg_asterslash
                sub_c_lineout
	      endi
	  endi

	  dift d_action > 20
		dift d_action < 900
		    'output RPG line as comment line 
		    'with blank line first
		    sub_c_blankline

		    $trb s_any, s_record
		    sg_pass1 = sg_slashaster + dg_rpglinenumber
		    $app sg_pass1, " " + s_any + sg_asterslash
		    sub_c_lineout
		endi
	  endi

	  dift d_action = 100
		'filename excpt tag oline
		$cut s_fileout, s_record, 7, 8
		$tlo s_fileout, s_fileout

		'get file information
		sg_pass1 = s_fileout
		sub_rpg_file_info_return
		s_filedevice = sg_pass1

		'get d_skipbefore and d_skipafter
		$cut s_any, s_record, 17, 1
		$isd d_any, s_any
		dift d_any <> 1: s_any = "0"
		$tod d_skipbefore, s_any

		$cut s_any, s_record, 18, 1
		$isd d_any, s_any
		dift d_any <> 1: s_any = "1"
		$tod d_skipafter, s_any

		'if s_filedevice<>"$STDLST " adjust skips
		$ift s_filedevice <> "$STDLST "
		    d_skipbefore = 0
		    d_skipafter = 1
		    d_yesterminal = 1
		else
		    d_yesterminal = 2
		endi

		'get excpt tag oline s_oifindicators
		$cut s_indicators, s_record, 23, 9
		sg_pass1 = s_indicators
		sub_c_ifindicators
		s_oifindicators = sg_ifindicators

		s_subrfilewrite = "sub_file_write_" + s_fileout
		$app s_subrfilewrite, "();"

		'blank tsg_output2 no s_oifindicators here
		sg_pass1 = "tsub_blank(tsg_output2, 2048);"

		sub_c_lineout
	  endi
	  dift d_action = 200
		'literal output oline
		$cut s_indicators, s_record, 23, 9
		sg_pass1 = s_indicators
		sub_c_ifindicators

		$cut s_endbyte, s_record, 40, 4
		$cut s_literal, s_record, 45, 30
		$trb s_literal, s_literal
		$len d_long, s_literal
		d_long = d_long - 2

		$tod d_dot, s_endbyte
		d_dot = d_dot - d_long
		sg_pass1 = sg_ifindicators 
		$app sg_pass1, "tsub_copy(&tsg_output2[" + d_dot
		$app sg_pass1, "], " + s_literal + ", "
		$app sg_pass1, d_long + ");"

		sub_c_lineout
	  endi
	  dift d_action = 300
		'variable output oline
		$cut s_indicators, s_record, 23, 9
		sg_pass1 = s_indicators
		sub_c_ifindicators

		$cut s_variable, s_record, 32, 6
		$cut s_editcd, s_record, 38, 1
		$cut s_blankcd, s_record, 39, 1
		$cut s_endbyte, s_record, 40, 4
		$cut s_literal, s_record, 45, 30
		$tod d_end, s_endbyte
'd_fieldtype
'1=error A
'2=blank B
'6=*BLANK
'7=*ZEROS
'8=UDATE
'11=numeric literal K
'12=numeric var L
'13=numeric array with index M
'14=numeric array no index N
'21=alpha literal U
'22=alpha var V
'23=alpha array with index W
'24=alpha array no index X
		'what kind of variable have we
		sg_pass1 = s_variable
		sub_field_info_return
		d_vartype1 = dg_pass1
		d_vartype2 = dg_pass2
		d_varindexct1 = dg_pass3
		d_varlongct1 = dg_pass4
		d_vardecimalct1 = dg_pass5
		s_var1 = sg_pass1
		s_var2 = sg_pass2

		dift d_vartype1 = 8: d_action = 405
		dift d_vartype1 = 12: d_action = 410
		dift d_vartype1 = 13: d_action = 420
		dift d_vartype1 = 22: d_action = 440
		dift d_vartype1 = 23: d_action = 450
		dift d_vartype1 = 24: d_action = 460

		$tlo s_var1, s_var1
		$tlo s_var2, s_var2
	  endi

	  dift d_action = 405
		'UDATE
		sg_pass1 = "tsub_udate(tsg_256a, '"
		$app sg_pass1, s_editcd + "');"

		sub_c_lineout

		d_dot = d_end - 6
		d_long = 6
		$ift s_editcd = "Y"
		    d_dot = d_end - 8
		    d_long = 8
		endi

		
		sg_pass1 = sg_ifindicators
		$app sg_pass1, "tsub_copy(&tsg_output2[" + d_dot
		$app sg_pass1, "], tsg_256a, " + d_long + ");"
		sub_c_lineout		
	  endi

	  dift d_action = 410
		'numeric variable
		sg_pass1 = "i_long = " + d_varlongct1 + ";"
		sub_c_lineout

		sg_pass1 = sg_ifindicators
		$app sg_pass1, "tsub_edit_double_to_string(tsg_256a, " 
		$app sg_pass1, "dg_" + s_var1 + ", " + d_vardecimalct1
		$app sg_pass1, ", '" + s_editcd + "', &i_long);"

            sub_c_lineout

		sg_pass1 = sg_ifindicators
		$app sg_pass1, "tsub_copy(&tsg_output2[" + d_end 
		$app sg_pass1, " - i_long], "
		$app sg_pass1, "&tsg_256a[26 - i_long], i_long);"
		 
            sub_c_lineout

		'do we need to blank the variable
		$ift s_blankcd = "B"
		    sg_pass1 = sg_ifindicators + "dg_" + s_var1
		    $app sg_pass1, " = 0;"

                sub_c_lineout
		endi
	  endi
	  dift d_action = 420
		'numeric array with index
		sg_pass1 = "i_long = " + d_varlongct1 + ";"
		sub_c_lineout

		dift d_vartype2 = 11
		    'the index is numeric
		    sg_pass1 = "i_index = " + s_var2 + ";"
		    sub_c_lineout
		else
		    'the index is a numeric variable
		    sg_pass1 = "i_index = tfni_index(dg_" 
		    $app sg_pass1, s_var2 + ");"

		    sub_c_lineout
		endi
		
		'subtract one in going from RPG to C 
		sg_pass1 = "tdg_z = dga_" + s_var1 + "[i_index - 1];"
		sub_c_lineout

		sg_pass1 = sg_ifindicators
		$app sg_pass1, "tsub_edit_double_to_string(tsg_256a, " 
		$app sg_pass1, "tdg_z, " + d_vardecimalct1
		$app sg_pass1, ", '" + s_editcd + "', &i_long);"

            sub_c_lineout

		sg_pass1 = sg_ifindicators
		$app sg_pass1, "tsub_copy(&tsg_output2[" + d_end 
		$app sg_pass1, " - i_long], "
		$app sg_pass1, "&tsg_256a[26 - i_long], i_long);"
		 
            sub_c_lineout

		'do we need to blank the variable
		$ift s_blankcd = "B"
		    sg_pass1 = sg_ifindicators + "dga_" + s_var1
		    $app sg_pass1, "[i_index] = 0;"

                sub_c_lineout
		endi
	  endi
	  dift d_action = 440
		'alpha variable
		d_beg = d_end - d_varlongct1
            sg_pass1 = sg_ifindicators + "tsub_copy(" 
            $app sg_pass1, "&tsg_output2[tfni_index("
		$app sg_pass1, d_beg + ")], "
		$app sg_pass1, "sg_" + s_var1 + ", " + d_varlongct1 
		$app sg_pass1, ");"

            sub_c_lineout

		'do we need to blank the variable
		$ift s_blankcd = "B"
		    sg_pass1 = sg_ifindicators + "tsub_blank("
		    $app sg_pass1, "sg_" + s_var1 + ", " + d_varlongct1
		    $app sg_pass1, ");"

                sub_c_lineout
		endi
	  endi
	  dift d_action = 450
		'alpha array with index
		'get the index into s_index
		'is s_var2 a number or a variable
		$ist d_any, s_var2, "9"
		dift d_any = 1
		    s_index = s_var2
		else
		    s_index = "tfni_index(dg_" + s_var2 + ")"
		endi
		s_index = "(" + s_index + " - 1)"
		$app s_index, " * " + d_varlongct1

		d_beg = d_end - d_varlongct1
            sg_pass1 = sg_ifindicators + "tsub_copy(" 
            $app sg_pass1, "&tsg_output2[tfni_index("
		$app sg_pass1, d_beg + ")], "
		$app sg_pass1, "&sga_" + s_var1 + "[" + s_index
		$app sg_pass1, "], " + d_varlongct1 + ");"

            sub_c_lineout

		'do we need to blank the array
		$ift s_blankcd = "B"
		    sg_pass1 = sg_ifindicators + "tsub_blank("
		    $app sg_pass1, "&sga_" + s_var1 + "[" + s_index
		    $app sg_pass1, "], " + d_varlongct1 + ");"

                sub_c_lineout
		endi
	  endi
	  dift d_action = 460
		'alpha array no index
		d_long = d_varlongct1 * d_varindexct1
		d_beg = d_end - d_long
            sg_pass1 = sg_ifindicators + "tsub_copy(" 
            $app sg_pass1, "&tsg_output2[tfni_index("
		$app sg_pass1, d_beg + ")], "
		$app sg_pass1, "sga_" + s_var1 + ", " + d_long 
		$app sg_pass1, ");"

            sub_c_lineout

		'do we need to blank the array
		$ift s_blankcd = "B"
		    sg_pass1 = sg_ifindicators + "tsub_blank("
		    $app sg_pass1, "sga_" + s_var1 + ", " + d_long
		    $app sg_pass1, ");"

                sub_c_lineout
		endi
	  endi
    endw

    'output the end of the subroutine
    sg_pass1 = "} /* " + s_excptsubr + " */"
    sub_c_lineout
'oline    1         2         3         4         5         6
'123456789012345678901234567890123456789012345678901234567890
'    .OFILENAMEE 12     01 02 03OLINE
'    .O                 01 02 03VARIABJB 132 "HEADING LINE  "
ends sub_c_oline_subroutines


subr sub_path_memory_lines
'updated 2007/11/12
'2006/09/25, 2006/09/04, 2006/08/29, 2006/04/23, 2005/10/08
    vari s_out, s_path, d_memory, s_memory
    vari d_lines, s_lines, s_date, s_version

    $sys s_version, 3
    $out s_version
    $out sg_build
    $sys s_path, 1
    $out "Path: " + s_path

    $dat s_date
    $cut s_date, s_date, 1, 20
    dsys d_memory, 1
    dsys d_lines, 2
    ded$ s_memory, d_memory, 0, 0
    ded$ s_lines, d_lines, 0, 0
    s_out = "memory=" + s_memory 
    $app s_out, ", lines=" + s_lines
    $app s_out, ", date=" + s_date
    $out s_out
ends sub_path_memory_lines


subr sub_speedquick
'updated 2008/02/23
    vari d_any, d_dot, d_time

    dsec d_time
    d_dot = 10 ^ 6 * 2
    d_any = 0
    dwhi d_any < d_dot
	  dinc d_any
    endw
    dsec d_any
    dg_pass1 = d_any - d_time
ends sub_speedquick


subr sub_speed_test
'updated 2007/11/12, 2007/07/11, 2005/10/08, 2004/02/14
'speed of computer
    vari d_any, s_any, d_dot, s_dot
    vari d_sec1, d_sec2, d_sec3, d_count, d_total

    $ch$ s_dot, "-", 76
    $out s_dot

    $out "We are looping 50,000,000 times"

    d_count = 0
    d_total = 10000 * 5000

    'loop fifty million times
    dsec d_sec1
    dwhi d_count < d_total
	  dinc d_count
    endw
    dsec d_sec2

    d_sec3 = d_sec2 - d_sec1

    $out "The time was " + d_sec3 + " seconds."
    $out s_dot
    sub_path_memory_lines

    $out s_dot  

    $inp s_any, "return"
ends sub_speed_test
'end of rpgtoc.tea