Re: Converting code from single to double precision

Anyone know of a tool to take the donkey work out of this?

I wrote the following c code several years ago in order to convert our
550,000 lines of code f77 program from single to double. It worked
for about 95% of the code. And, yes, we do use /xfloat in the open
watcom compilers now.

Since we equivalence integer arrays to real arrays all over the place, I
converted all integer arrays to type64 arrays in the code. I use the
dii.inc include file below. This is so that all arrays have 8 byte boundaries
for both real*8 and type64 datatypes.

Good luck, you are going to need it !

Lynn

===== dii.inc ============================

implicit none

structure / type64 /
union
map
double precision d
end map
map
integer i
integer i_low
end map
map
logical l
integer l_low
end map
map
character*8 s
end map
end union
end structure

====== d2double.c ================================

/* d2double.c

for converting fortran subroutines from single to double
1. dropping all characters after character 72
2. from using 6 for the output file unit to 2 for the output file unit
3. adding "include 'dii.inc'" to all functions just
after the subroutine statement or the function statement (actually
on the line after closing paren if there is a opening paren)
4. convert all ' REAL ' to ' REAL*8 '
5. convert all 'IVDY (' to 'IVDY (1,'
6. convert all 'LVDY (' to 'LVDY (1,'

the converted subroutine is written to standard output
*/


// #define PRINT_VARIABLE_TABLE


#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <ctype.h>


#ifndef TRUE
#define TRUE 1
#endif

#ifndef FALSE
#define FALSE 0
#endif


#define MAXVARS 10000
#define MAXDIMS 10


#define VarIsInteger 1
#define VarIsLogical 2
#define VarIsReal 3
#define VarIsDouble 4
#define VarIsCharacter 5


char *VarNames [MAXVARS];
int VarTypes [MAXVARS];
char *VarArrayDimensionNames [MAXVARS] [MAXDIMS];
int VarHasData [MAXVARS];
int VarHasEquivalence [MAXVARS];
int VarIsArgument [MAXVARS];
int VarIsInCommon [MAXVARS];
int VarIsInInclude [MAXVARS];
int VarDefinedOutsideCommon [MAXVARS];
int NumberOfVars = 0;


void PrintFortranLine (char *s);
void FirstPass (FILE *anysub, int isIncludeFile);
void WriteDiiVars (void);


int main (int argc, char **argv)
{
char s [1000];
FILE *anysub = NULL;
int LookingForTop = FALSE;
int LookingForIntegerDimensionLogical = FALSE;
int LookingForEquivalenceCommon = FALSE;
int continuedWrite = FALSE;
int continuedFormat = FALSE;
int continuedDimensionLogicalRealInteger = FALSE;
int writeDiiVars = FALSE;
int diiVarsWritten = FALSE;
int firstTime = TRUE;

if (argc != 2)
{
fprintf (stderr, "Error: d2double anysub.f, args = %d\n", argc);
exit (1);
}

anysub = fopen (argv [1], "rt");
if (! anysub)
{
fprintf (stderr, "Error: could not open %s\n", argv [1]);
exit (1);
}

FirstPass (anysub, FALSE);

while (fgets (s, sizeof (s), anysub))
{
int writeDiiIncLine = FALSE;
char *p = NULL;

// check if we want to throw away this line
if ( 'C' == s [0] && strstr (s, " --- < F66 >")) continue;
if ( 'C' == s [0] && strstr (s, " --- < F77 >")) continue;

// get rid of the trailing line feed
p = & (s [strlen (s) - 1]);
if ( '\n' == *p ) *p = '\0';

// if not a comment line then do special processing
if ( s [0] != 'C' && s [0] != 'c' && strncmp (s, "*$pragma", 8))
{
// get rid of trailing comments, blanks, etc...
s [72] = '\0';

// get rid of all embedded tabs, replace with 5 spaces
while ( p = strstr (s, "\t") )
{
char str [1000];

*p = '\0';
sprintf (str, "%s %s", s, p + 1);
strcpy (s, str);
}

// replace a zero in column 6 with a blank
if ( '0' == s [5] ) s [5] = ' ';
if (s [5] == ' ')
{
continuedWrite = FALSE;
continuedFormat = FALSE;
}

if (strstr (s, " FORMAT ") || strstr (s, " format ") ||
strstr (s, " FORMAT(") || strstr (s, " format("))
{
continuedFormat = TRUE;
}

// if implicit then throw it away since dii.inc covers this
if (strstr (s, " IMPLICIT ")) continue;

// if WRITE and IO unit is 6 then change to 2
p = strstr (s, "WRITE");
if (p)
{
p += 5;
while (' ' == *p || '(' == *p) p++;
if ('6' == *p && ')' != *(p + 1)) *p = '2';
}

// replace ALOG( with LOG(
while (p = strstr (s, "ALOG("))
{
*p = 'L';
p++;
*p = 'O';
p++;
*p = 'G';
p++;
*p = ' ';
}

// replace ALOG( with LOG(
while (p = strstr (s, "ALOG ("))
{
*p = 'L';
p++;
*p = 'O';
p++;
*p = 'G';
p++;
*p = ' ';
}

// replace ALOG10( with LOG10(
while (p = strstr (s, "ALOG10("))
{
*p = 'L';
p++;
*p = 'O';
p++;
*p = 'G';
p++;
*p = '1';
p++;
*p = '0';
p++;
*p = ' ';
}

while (p = strstr (s, "ALOG10 ("))
{
*p = 'L';
p++;
*p = 'O';
p++;
*p = 'G';
p++;
*p = '1';
p++;
*p = '0';
p++;
*p = ' ';
}

// replace AMAX1( with DMAX1 (
while (p = strstr (s, "AMAX1("))
{
*p = 'D';
}

// replace AMAX1( with DMAX1 (
while (p = strstr (s, "AMAX1 ("))
{
*p = 'D';
}

// replace AMIN1( with DMIN1 (
while (p = strstr (s, "AMIN1("))
{
*p = 'D';
}

// replace AMIN1( with DMIN1 (
while (p = strstr (s, "AMIN1 ("))
{
*p = 'D';
}

// replace SIGN ( with DSIGN (
while (p = strstr (s, " SIGN ("))
{
char temp [1024];

*p = '\0';
strcpy (temp, s);
strcat (temp, " D");
strcat (temp, p + 1);
strcpy (s, temp);
}

// replace SIGN( with DSIGN(
while (p = strstr (s, " SIGN("))
{
char temp [1024];

*p = '\0';
strcpy (temp, s);
strcat (temp, " D");
strcat (temp, p + 1);
strcpy (s, temp);
}

// replace =SIGN( with = DSIGN(
while (p = strstr (s, "=SIGN("))
{
char temp [1024];

*p = '\0';
strcpy (temp, s);
strcat (temp, "= D");
strcat (temp, p + 1);
strcpy (s, temp);
}

// replace +SIGN( with + DSIGN(
while (p = strstr (s, "+SIGN("))
{
char temp [1024];

*p = '\0';
strcpy (temp, s);
strcat (temp, "+ D");
strcat (temp, p + 1);
strcpy (s, temp);
}

// replace (SIGN( with + DSIGN(
while (p = strstr (s, "(SIGN("))
{
char temp [1024];

*p = '\0';
strcpy (temp, s);
strcat (temp, " (D");
strcat (temp, p + 1);
strcpy (s, temp);
}

if (LookingForTop)
{
int i = 0;

for (i = 0; i < NumberOfVars; i++)
{
char *ppp = strstr (s, VarNames [i]);

if (ppp)
{
// if the next character is a comma then this it
char *comma = ppp + strlen (VarNames [i]);

while (*comma && ' ' == *comma) comma++;
if (*comma && (',' == *comma || ')' == *comma))
VarIsArgument [i] = TRUE;
}
}
}

// add a special include at the beginning of the subroutine
if (LookingForTop && strstr (s, ")"))
{
writeDiiIncLine = TRUE;
LookingForTop = FALSE;
}
if (strstr (s, " SUBROUTINE ") ||
strstr (s, " subroutine "))
{
if ( ! firstTime)
{
NumberOfVars = 0;
FirstPass (anysub, FALSE);
diiVarsWritten = FALSE;
}

firstTime = FALSE;

if ( ! strstr (s, "("))
writeDiiIncLine = TRUE;
else if (strstr (s, "(") && strstr (s, ")"))
{
int i = 0;

p = strstr (s, "(");
for (i = 0; i < NumberOfVars; i++)
{
char *ppp = strstr (p, VarNames [i]);

if (ppp)
{
// if the next character is a comma then this it
char *comma = ppp + strlen (VarNames [i]);

while (*comma && ' ' == *comma) comma++;
if (*comma && (',' == *comma || ')' == *comma))
VarIsArgument [i] = TRUE;
}
}
writeDiiIncLine = TRUE;
}
else
LookingForTop = TRUE;
}
if ( ! continuedFormat && s [5] == ' ' &&
(strstr (s, " FUNCTION ") || strstr (s, " function ")))
{
char temp [1000];

if ( ! firstTime)
{
NumberOfVars = 0;
FirstPass (anysub, FALSE);
diiVarsWritten = FALSE;
}

firstTime = FALSE;

// if no function type then make it Double
if (strstr (s, " FUNCTION") || strstr (s, " function "))
{
sprintf (temp, " DOUBLE PRECISION %s", &(s[6]));
strcpy (s, temp);
}
if ( ! strstr (s, "("))
writeDiiIncLine = TRUE;
else if (strstr (s, "(") && strstr (s, ")"))
{
int i = 0;

p = strstr (s, "(");
for (i = 0; i < NumberOfVars; i++)
{
char *ppp = strstr (p, VarNames [i]);

if (ppp)
{
// if the next character is a comma then this it
char *comma = ppp + strlen (VarNames [i]);

while (*comma && ' ' == *comma) comma++;
if (*comma && (',' == *comma || ')' == *comma))
VarIsArgument [i] = TRUE;
}
}
writeDiiIncLine = TRUE;
}
else
LookingForTop = TRUE;
}

if (' ' == s [5])
{
LookingForIntegerDimensionLogical = FALSE;
LookingForEquivalenceCommon = FALSE;
continuedDimensionLogicalRealInteger = FALSE;
}

if ( ! continuedFormat &&
! strstr (s, " FUNCTION ") && ! strstr (s, " function ") &&
(strstr (s, " DIMENSION ") || strstr (s, " dimension ") ||
strstr (s, " REAL ") || strstr (s, " real ") ||
strstr (s, " REAL*4 ") || strstr (s, " real*4 ") ||
strstr (s, " REAL*8 ") || strstr (s, " real*8 ") ||
strstr (s, " DOUBLE PRECISION ") ||
strstr (s, " double precision ") ||
strstr (s, " INTEGER ") || strstr (s, " integer ") ||
strstr (s, " LOGICAL ") || strstr (s, " logical ")))
continuedDimensionLogicalRealInteger = TRUE;

if (continuedDimensionLogicalRealInteger) continue;

if ( ! continuedFormat &&
(strstr (s, " DIMENSION ") || strstr (s, " dimension ") ||
strstr (s, " INTEGER ") || strstr (s, " integer ") ||
strstr (s, " LOGICAL ") || strstr (s, " logical ")))
LookingForIntegerDimensionLogical = TRUE;

if ( ! continuedFormat &&
(strstr (s, " EQUIVALENCE ") || strstr (s, " equivalence ") ||
strstr (s, " EQUIVALENCE(") || strstr (s, " equivalence(") ||
strstr (s, " CHARACTER ") || strstr (s, " character ") ||
strstr (s, " CHARACTER*") || strstr (s, " character*") ||
strstr (s, " DOUBLE ") || strstr (s, " double ") ||
strstr (s, " REAL ") || strstr (s, " real ") ||
strstr (s, " REAL*8 ") || strstr (s, " real*8 ") ||
strstr (s, " COMMON ") || strstr (s, " common ") ||
strstr (s, " COMMON/") || strstr (s, " common/")))
LookingForEquivalenceCommon = TRUE;

if (continuedFormat || strstr (s, " CALL ") ||
(strstr (s, "=") && ! strstr (s, "PARAMETER")) ||
strstr (s, " READ ") || strstr (s, " read ") ||
strstr (s, " READ(") || strstr (s, " read(") ||
strstr (s, " IF ") || strstr (s, " if ") ||
strstr (s, " IF(") || strstr (s, " if(") ||
strstr (s, " DO ") || strstr (s, " do ") ||
strstr (s, " GO TO ") || strstr (s, " go to ") ||
strstr (s, " GOTO ") || strstr (s, " goto ") ||
strstr (s, " CONTINUE") || strstr (s, " continue") ||
strstr (s, " PARAMETER ") || strstr (s, " parameter ") ||
strstr (s, " RETURN ") || strstr (s, " return ") ||
strstr (s, " DATA ") || strstr (s, " data "))
writeDiiVars = TRUE;

// loop thru the line looking for variable name matches now
if ( ! continuedFormat) for (p = s; p && *p; p++)
{
int i = 0;
char *pp = p;

if (strstr (p, " CHARACTER ")) p += 16;
if (strstr (p, " character ")) p += 16;
if (strstr (p, " CHARACTER*")) p += 16;
if (strstr (p, " character*")) p += 16;
if (strstr (p, " COMMON ")) break;
if (strstr (p, " common ")) break;
if (strstr (p, " COMMON/")) break;
if (strstr (p, " common/")) break;
if (strstr (p, " SUBROUTINE ")) break;
if (strstr (p, " subroutine ")) break;
if (strstr (p, " FUNCTION ")) break;
if (strstr (p, " function ")) break;

// check to see if we are in the middle of a variable
if ( ! *p) continue;
if ( ! isalpha (*p)) continue;

for (i = 0; i < NumberOfVars; i++)
{
int len = strlen (VarNames [i]);

if ( ! VarArrayDimensionNames [i] [0]) continue;
if (VarIsReal == VarTypes [i]) continue;
if (VarIsDouble == VarTypes [i]) continue;
if (VarIsCharacter == VarTypes [i]) continue;
if ( ! strnicmp (p, VarNames [i], len))
{
// check for false positives
// IUNIT for IUNITS
if (isalnum (*(p + len))) continue;
if (isalnum (*(p - 1))) continue;

// add the type identifier to variable if not declaration
if ( ! LookingForEquivalenceCommon)
{
char *pp = p + len;

// skip past the blanks
while (*pp && ' ' == *pp) pp++;
// if there a left paren then find the right paren
// and append a .type indicator to it
if ('(' == *pp)
{
int insideParen = 1;

while (*pp && insideParen > 0)
{
pp++;
if (*pp == '(') insideParen++;
if (*pp == ')') insideParen--;
}
if (*pp && ')' == *pp)
{
char temp [1000];
char varTypeString [3];
char aChar = ' ';

if (VarIsInteger == VarTypes [i])
strcpy (varTypeString, ".I");
else
strcpy (varTypeString, ".L");

pp++;
aChar = *pp;
*pp = '\0';
pp++;
sprintf (temp, "%s%s %c%s",
s, varTypeString, aChar, pp);
strcpy (s, temp);
p += len - 1;
}
}
}
}
}
}

// must change "DATA IAAA" to "DATA (IAAA (I).type, I = 1, dim)"
// type is .I or .L
p = strstr (s, " DATA ");
if ( ! continuedFormat && p)
{
int i = 0;

p += 11;

for (i = 0; i < NumberOfVars; i++)
{
char *ppp = strstr (p, VarNames [i]);

if (ppp && VarArrayDimensionNames [i] [0] &&
(VarIsInteger == VarTypes [i] ||
VarIsLogical == VarTypes [i]))
{
char tempstr [1024];
char *pppm1 = ppp - 1;
char *pppPlen = ppp + strlen (VarNames [i]);
char varTypeString [3];

if (VarIsInteger == VarTypes [i])
strcpy (varTypeString, ".I");
else
strcpy (varTypeString, ".L");

// previous character must be space or comma
if ( *pppm1 != ' ' && *pppm1 != ',' ) continue;

// next character must be slash, comma or end of line
// skip spaces
while ( *pppPlen && ' ' == *pppPlen ) pppPlen++;
if ( *pppPlen && *pppPlen != '/' && *pppPlen != ',' )
continue;

// now change "DATA IAAA" to "DATA (IAAA (I) .type, I = 1, dim)"
*ppp = '\0';

// check for 3 dimensions
if (VarArrayDimensionNames [i] [0] &&
VarArrayDimensionNames [i] [1] &&
VarArrayDimensionNames [i] [2])
sprintf (tempstr,
"%s(((%s (I, J, K)%s, "
"I = 1, %s), J = 1, %s), K = 1, %s) %s",
s, VarNames [i], varTypeString,
VarArrayDimensionNames [i] [0],
VarArrayDimensionNames [i] [1],
VarArrayDimensionNames [i] [2],
ppp + strlen (VarNames [i]));
// check for 2 dimensions
else if (VarArrayDimensionNames [i] [0] &&
VarArrayDimensionNames [i] [1])
sprintf (tempstr,
"%s((%s (I, J)%s, "
"I = 1, %s), J = 1, %s) %s",
s, VarNames [i], varTypeString,
VarArrayDimensionNames [i] [0],
VarArrayDimensionNames [i] [1],
ppp + strlen (VarNames [i]));
// check for 1 dimension
else if (VarArrayDimensionNames [i] [0])
sprintf (tempstr,
"%s(%s (I)%s, I = 1, %s) %s",
s, VarNames [i], varTypeString,
VarArrayDimensionNames [i] [0],
ppp + strlen (VarNames [i]));

// overwrite the original
strcpy (s, tempstr);
}
}
}

// must change "WRITE (2, 2000) IAAA" to
// "WRITE (2, 2000) (IAAA (I).type, I = 1, dim)"
p = strstr (s, " WRITE ");
if ( ! p) p = strstr (s, " WRITE(");
if ( p ) p += 11;
if ( ! p)
{
p = strstr (s, " READ ");
if ( ! p) p = strstr (s, " READ(");
if ( p ) p += 10;
}
if ( ! p && continuedWrite ) p = s + 6;
if ( ! continuedFormat && p)
{
int i = 0;

continuedWrite = TRUE;

for (i = 0; i < NumberOfVars; i++)
{
char *ppp = strstr (p, VarNames [i]);

if (ppp && VarArrayDimensionNames [i] [0] &&
(VarIsInteger == VarTypes [i] ||
VarIsLogical == VarTypes [i]))
{
char tempstr [1024];
char *pppm1 = ppp - 1;
char *pppPlen = ppp + strlen (VarNames [i]);
char varTypeString [3];

if (VarIsInteger == VarTypes [i])
strcpy (varTypeString, ".I");
else
strcpy (varTypeString, ".L");

// previous character must be space or comma
if ( *pppm1 != ' ' && *pppm1 != ',' ) continue;

// next character must be comma or end of line
// skip spaces
while ( *pppPlen && ' ' == *pppPlen ) pppPlen++;
if ( *pppPlen && *pppPlen != ',' )
continue;

// now change "IAAA" to "(IAAA (1, I), I = 1, dim)"
*ppp = '\0';

// check for 3 dimensions
if (VarArrayDimensionNames [i] [0] &&
VarArrayDimensionNames [i] [1] &&
VarArrayDimensionNames [i] [2])
sprintf (tempstr,
"%s(((%s (III123456, JJJ123456, KKK123456)%s, "
"III123456 = 1, %s), JJJ123456 = 1, %s), KKK123456 = 1, %s) %s",
s, VarNames [i], varTypeString,
VarArrayDimensionNames [i] [0],
VarArrayDimensionNames [i] [1],
VarArrayDimensionNames [i] [2],
ppp + strlen (VarNames [i]));
// check for 2 dimensions
else if (VarArrayDimensionNames [i] [0] &&
VarArrayDimensionNames [i] [1])
sprintf (tempstr,
"%s((%s (III123456, JJJ123456)%s, "
"III123456 = 1, %s), JJJ123456 = 1, %s) %s",
s, VarNames [i], varTypeString,
VarArrayDimensionNames [i] [0],
VarArrayDimensionNames [i] [1],
ppp + strlen (VarNames [i]));
// check for 1 dimension
else if (VarArrayDimensionNames [i] [0])
sprintf (tempstr,
"%s(%s (III123456)%s, III123456 = 1, %s) %s",
s, VarNames [i], varTypeString,
VarArrayDimensionNames [i] [0],
ppp + strlen (VarNames [i]));

// overwrite the original
strcpy (s, tempstr);
}
}
}
}
else // this is a comment line
{
// see if there is a line change date, if so, delete it
if (strlen (s) > 72)
{
if (0 == strncmp (& s [75], "JAN", 3) ||
0 == strncmp (& s [75], "FEB", 3) ||
0 == strncmp (& s [75], "MAR", 3) ||
0 == strncmp (& s [75], "APR", 3) ||
0 == strncmp (& s [75], "MAY", 3) ||
0 == strncmp (& s [75], "JUN", 3) ||
0 == strncmp (& s [75], "JUL", 3) ||
0 == strncmp (& s [75], "AUG", 3) ||
0 == strncmp (& s [75], "SEP", 3) ||
0 == strncmp (& s [75], "OCT", 3) ||
0 == strncmp (& s [75], "NOV", 3) ||
0 == strncmp (& s [75], "DEC", 3) ||
0 == strncmp (& s [74], "Jan", 3) ||
0 == strncmp (& s [74], "Feb", 3) ||
0 == strncmp (& s [74], "Mar", 3) ||
0 == strncmp (& s [74], "Apr", 3) ||
0 == strncmp (& s [74], "May", 3) ||
0 == strncmp (& s [74], "Jun", 3) ||
0 == strncmp (& s [74], "Jul", 3) ||
0 == strncmp (& s [74], "Aug", 3) ||
0 == strncmp (& s [74], "Sep", 3) ||
0 == strncmp (& s [74], "Oct", 3) ||
0 == strncmp (& s [74], "Nov", 3) ||
0 == strncmp (& s [74], "Dec", 3) ||
(s [74] == '/' && s [77] == '/'))
s [72] = '\0';
}
}

// get rid of trailing blanks
for (p = & (s [strlen (s) - 1]); *p && p > s; p--)
{
if ( ' ' == *p )
*p = '\0';
else
break;
}

// declare all the local variable arrays to be of type64
if (writeDiiVars && ! diiVarsWritten)
{
diiVarsWritten = TRUE;
WriteDiiVars ();
}

PrintFortranLine (s);

if (writeDiiIncLine) fputs ("\n INCLUDE 'dii.inc'\n\n", stdout);
}

fclose (anysub);

if ( ! diiVarsWritten) WriteDiiVars ();

return 0;
}


void WriteDiiVars (void)
{
int i = 0;
int j = 0;

fprintf (stdout, "\n");
for (i = 0; i < NumberOfVars; i++)
{
if ( ! VarIsInInclude [i] && VarTypes [i] != VarIsCharacter)
{
switch (VarTypes [i])
{
case VarIsInteger:
case VarIsLogical:
if (VarArrayDimensionNames [i] [0])
fprintf (stdout, " record / type64 / %s",
VarNames [i]);
else if (VarTypes [i] == VarIsInteger)
fprintf (stdout, " integer %s", VarNames [i]);
else if (VarTypes [i] == VarIsLogical)
fprintf (stdout, " logical %s", VarNames [i]);
break;
case VarIsReal:
case VarIsDouble:
fprintf (stdout, " double precision %s", VarNames [i]);
break;
}
if (VarArrayDimensionNames [i] [0] &&
((VarIsInCommon [i] && VarDefinedOutsideCommon [i]) ||
! VarIsInCommon [i]))
{
fprintf (stdout, " (");
for (j = 0; j < MAXDIMS; j++)
{
if (VarArrayDimensionNames [i] [j])
{
if (j > 0) fprintf (stdout, ", ");
fprintf (stdout, "%s", VarArrayDimensionNames [i] [j]);
}
}
fprintf (stdout, ")");
}
fprintf (stdout, "\n");
}
}
fputs ("\n", stdout);
}


// print out a line of fortran code, making sure each line is 72
// characters long or less

void PrintFortranLine (char *s)
{
char *p = NULL;
int len = strlen (s);
int i = 0;
int j = 0;
char str [100];

if ('C' == s [0] || 'c' == s [0])
{
printf ("%s\n", s);
return;
}

// get rid of trailing LF
if ('\n' == s [len - 1])
{
s [ len - 1 ] = '\0';
len--;
}

// get rid of the trailing blanks or tabs
for (p = & (s [len - 1]); (' ' == *p || '\t' == *p) && p > s; p--)
*p = '\0';

str [0] = '\0';
for (i = 0, j = 0; s [i]; i++)
{
str [j] = s [i];
j++;
str [j] = '\0';
// check to see if we have to manually break this line
if (73 == j)
{
int k = 0;
char *data = strstr (str, " DATA ");
int done = FALSE;

if (data)
{
// this is a DATA statement so move forward to the first
// slash mark
for (k = 7; k < j; k++)
if ('/' == str [k])
{
char temp [100];

// make sure that we are not in a hollerith variable
if ( ! strncmp (& (str [k - 2]), "4H", 2) ||
! strncmp (& (str [k - 3]), "4H", 2) ||
! strncmp (& (str [k - 4]), "4H", 2) ||
! strncmp (& (str [k - 5]), "4H", 2)) continue;

// save at the split character so that we can overwrite it
strcpy (temp, & (str [k]));
str [k] = '\0';
printf ("%s\n", str);
sprintf (str, " 1 %s", temp);
j = strlen (str);
done = TRUE;
break;
}
}

if ( ! done)
{
// backup to the last split character, a close paren
// start looking at column 72 so decrement back by 2
for (k = j - 2; k > 0; k--)
if (')' == str [k])
{
char temp [100];

// make sure that we are not in a hollerith variable
if ( ! strncmp (& (str [k - 2]), "4H", 2) ||
! strncmp (& (str [k - 3]), "4H", 2) ||
! strncmp (& (str [k - 4]), "4H", 2) ||
! strncmp (& (str [k - 5]), "4H", 2)) continue;

// save past the split character so that we can overwrite it
strcpy (temp, & (str [k + 1]));
str [k + 1] = '\0';
printf ("%s\n", str);
sprintf (str, " 1 %s", temp);
j = strlen (str);
done = TRUE;
break;
}
}

if ( ! done)
{
// backup to the last split character, a comma
// start looking at column 72 so decrement back by 2
for (k = j - 2; k > 0; k--)
if (',' == str [k])
{
char temp [100];

// make sure that we are not in a hollerith variable
if ( ! strncmp (& (str [k - 2]), "4H", 2) ||
! strncmp (& (str [k - 3]), "4H", 2) ||
! strncmp (& (str [k - 4]), "4H", 2) ||
! strncmp (& (str [k - 5]), "4H", 2)) continue;

// save past the split character so that we can overwrite it
strcpy (temp, & (str [k + 1]));
str [k + 1] = '\0';
printf ("%s\n", str);
sprintf (str, " 1 %s", temp);
j = strlen (str);
done = TRUE;
break;
}
}

if ( ! done)
{
// backup to the last split character, a open paren
// start looking at column 72 so decrement back by 2
for (k = j - 2; k > 0; k--)
if ('(' == str [k])
{
char temp [100];

// make sure that we are not in a hollerith variable
if ( ! strncmp (& (str [k - 2]), "4H", 2) ||
! strncmp (& (str [k - 3]), "4H", 2) ||
! strncmp (& (str [k - 4]), "4H", 2) ||
! strncmp (& (str [k - 5]), "4H", 2)) continue;

// save past the split character so that we can overwrite it
strcpy (temp, & (str [k + 1]));
str [k + 1] = '\0';
printf ("%s\n", str);
sprintf (str, " 1 %s", temp);
j = strlen (str);
done = TRUE;
break;
}
}
}
}

len = strlen (s);
if (len == 0 || len > 6) printf ("%s\n", str); // print the last part
}


// read in the declared vars INTEGER, REAL, DIMENSION, DOUBLE or LOGICAL
// include the var if it is dimensioned
// exclude the var if there is a data statement

void FirstPass (FILE *anysub, int isIncludeFile)
{
int i = 0;
char s [1000];
int continuedSubroutine = FALSE;
int continuedReal = FALSE;
int continuedInteger = FALSE;
int continuedLogical = FALSE;
int continuedDimension = FALSE;
int continuedCommon = FALSE;
int continuedDouble = FALSE;
int continuedCharacter = FALSE;
int continuedData = FALSE;
int continuedEquivalence = FALSE;
int savedPlace = ftell (anysub);

while (fgets (s, sizeof (s), anysub))
{
char *p = NULL;
char *p1 = NULL;
int len = strlen (s);
int datatype = 0;
int varIsInCommon = FALSE;
int varDefinedOutsideCommon = FALSE;

if ('C' == s [0] || 'c' == s [0]) continue;
if ( ! strncmp (s, "*$pragma", 8)) continue;
if (strstr (s, " IMPLICIT ")) continue;
if (strstr (s, " implicit ")) continue;
if (strstr (s, " EXTERNAL ")) continue;
if (strstr (s, " external ")) continue;

// add the globals to our variable list
if (strstr (s, " INCLUDE ") || strstr (s, "include "))
{
FILE *includeFile = NULL;
char filename [1024];
char *p = s;
char *f = NULL;

strcpy (filename, "\\dii\\inc\\");
while (*p && *p != '\'') p++;
p++;
f = p;
while (*p && *p != '\'') p++;
*p = '\0';
strcat (filename, f);

includeFile = fopen (filename, "rt");
if (includeFile)
{
FirstPass (includeFile, TRUE);
fclose (includeFile);
}
}

if (strstr (s, " END")) break;
if (strstr (s, " end")) break;

// make sure the string has no comments at the end
s [72] = '\0';
p = strstr (s, "\n");
if (p) *p = '\0';

if ( len < 7 || ' ' == s [5] || '0' == s [5] )
{
continuedSubroutine = FALSE;
continuedReal = FALSE;
continuedInteger = FALSE;
continuedLogical = FALSE;
continuedDimension = FALSE;
continuedCommon = FALSE;
continuedDouble = FALSE;
continuedCharacter = FALSE;
continuedData = FALSE;
continuedEquivalence = FALSE;
}

p = strstr (s, " FUNCTION ");
if ( ! p) p = strstr (s, " function ");
if ( ! p) p = strstr (s, " SUBROUTINE ");
if ( ! p) p = strstr (s, " subroutine ");
if (p)
{
if (strstr (s, " FORMAT")) p = NULL;
if (p)
{
char *p1 = NULL;

while (*p && *p != '(') p++;
if (*p == '(') p++;
p1 = strstr (p, ")");
if (p1) *p1 = ' ';
datatype = 0; // dont know yet !
continuedSubroutine = TRUE;
}
}
if ( ! p && ' ' != s [5] && continuedSubroutine)
{
char *p1 = NULL;

p = s + 6;
datatype = 0; // dont know yet !
if (strstr (p, "("))
{
while (*p && *p != '(') p++;
if (*p == '(') p++;
}
p1 = strstr (p, ")");
if (p1) *p1 = ' ';
}

if ( ! p)
{
p = strstr (s, " DIMENSION ");
if ( ! p) p = strstr (s, " dimension ");
if (p)
{
if (strstr (s, " FORMAT")) p = NULL;
if (p)
{
p += 16;
datatype = 0; // dont know yet !
continuedDimension = TRUE;
}
}
}
if ( ! p && ' ' != s [5] && continuedDimension)
{
p = s + 6;
datatype = 0; // dont know yet !
}

if ( ! p)
{
p = strstr (s, " COMMON ");
if ( ! p) p = strstr (s, " common ");
if ( ! p) p = strstr (s, " COMMON/");
if (p)
{
if (strstr (s, " FORMAT")) p = NULL;
if (p)
{
// find the first slash
char *ppp = strstr (s, "/");

if (ppp)
{
// find the second slash
p = strstr (ppp + 1, "/");
if (p) ++p; // move past the slash mark
}
else
p = p + 13;
datatype = 0; // dont know yet !
continuedCommon = TRUE;
varIsInCommon = TRUE;
}
}
}
if ( ! p && ' ' != s [5] && continuedCommon)
{
p = s + 6;
datatype = 0; // dont know yet !
varIsInCommon = TRUE;
}

if ( ! p)
{
p = strstr (s, " LOGICAL ");
if ( ! p) p = strstr (s, " logical ");
if (strstr (s, " FORMAT")) p = NULL;
if (p)
{
p += 13;
datatype = VarIsLogical;
continuedLogical = TRUE;
}
}
if ( ! p && ' ' != s [5] && continuedLogical)
{
p = s + 6;
datatype = VarIsLogical;
}

if ( ! p)
{
p = strstr (s, " INTEGER ");
if ( ! p) p = strstr (s, " integer ");
if (strstr (s, " FORMAT")) p = NULL;
if (p)
{
p += 13;
datatype = VarIsInteger;
continuedInteger = TRUE;
}
}
if ( ! p && ' ' != s [5] && continuedInteger)
{
p = s + 6;
datatype = VarIsInteger;
}

if ( ! p)
{
p = strstr (s, " DOUBLE PRECISION ");
if ( ! p) p = strstr (s, " double precision ");
if (strstr (s, " FORMAT")) p = NULL;
if (p)
{
p += 22;
datatype = VarIsDouble;
continuedDouble = TRUE;
}
}
if ( ! p)
{
p = strstr (s, " REAL*8 ");
if ( ! p) p = strstr (s, " real*8 ");
if (strstr (s, " FORMAT")) p = NULL;
if (p)
{
p = p + 12;
datatype = VarIsDouble;
continuedDouble = TRUE;
}
}
if ( ! p && ' ' != s [5] && continuedDouble)
{
p = s + 6;
datatype = VarIsDouble;
}

if ( ! p)
{
p = strstr (s, " REAL ");
if ( ! p) p = strstr (s, " real ");
if (strstr (s, " FORMAT")) p = NULL;
if (p)
{
p += 10;
datatype = VarIsReal;
continuedReal = TRUE;
}
}
if ( ! p && ' ' != s [5] && continuedReal)
{
p = s + 6;
datatype = VarIsReal;
}

if ( ! p)
{
p = strstr (s, " CHARACTER ");
if ( ! p) p = strstr (s, " character ");
if ( ! p) p = strstr (s, " CHARACTER*");
if ( ! p) p = strstr (s, " character*");
if (strstr (s, " FORMAT")) p = NULL;
if (p)
{
p += 13;
while (*p && *p != ' ') p++;
datatype = VarIsCharacter;
continuedCharacter = TRUE;
}
}
if ( ! p && ' ' != s [5] && continuedCharacter)
{
p = s + 6;
datatype = VarIsCharacter;
}

if (p)
{
while (p && *p)
{
char *arrayDimensionNames [MAXDIMS] =
{ NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL };
char name [1000];
int i = 0;
int len = 0;

name [0] = '\0';
while (*p && (' ' == *p || ',' == *p || ')' == *p)) p++;
// look for CHARACTER CBUF*80,
if (*p && *p == '*')
while (*p && *p != ',' && *p != ' ') p++;
while (*p && (' ' == *p || ',' == *p || ')' == *p)) p++;
while (*p && ('_' == *p ||
('z' >= *p && 'a' <= *p) ||
('Z' >= *p && 'A' <= *p) ||
('9' >= *p && '0' <= *p)))
{
name [i] = *p;
i++;
name [i] = '\0';
p++;
}
while (*p && ' ' == *p) p++;
if (*p && '(' == *p)
{
int index = 0;
if ( ! continuedCommon) varDefinedOutsideCommon = TRUE;

p++; // pass the open parenthesis
while (*p && ')' != *p)
{
if (',' == *p)
index++;
else
{
char str [1000];

switch (*p)
{
case ' ': break;
default:
if (arrayDimensionNames [index])
{
int len = 0;

strcpy (str, arrayDimensionNames [index]);
len = strlen (str);
str [len] = *p;
str [len + 1] = '\0';
arrayDimensionNames [index] = strdup (str);
}
else
{
str [0] = *p;
str [1] = '\0';
arrayDimensionNames [index] = strdup (str);
}
}
}
p++;
}
if (')' == *p) p++; // one more for the closing parenthesis
}
len = strlen (name);
if (len > 0)
{
int i = 0;
int j = 0;
int found = FALSE;

for (i = 0; i < NumberOfVars; i++)
{
if ( ! strcmp (VarNames [i], name))
{
found = TRUE;
break;
}
}
if ( ! found)
{
VarNames [NumberOfVars] = strdup (name);
for (j = 0; j < MAXDIMS; j++)
VarArrayDimensionNames [NumberOfVars] [j] =
arrayDimensionNames [j];
VarHasData [NumberOfVars] = FALSE;
VarTypes [NumberOfVars] = datatype;
VarHasEquivalence [NumberOfVars] = FALSE;
VarIsArgument [NumberOfVars] = FALSE;
VarIsInCommon [NumberOfVars] = varIsInCommon;
VarDefinedOutsideCommon [NumberOfVars] =
varDefinedOutsideCommon;
VarIsInInclude [NumberOfVars] = isIncludeFile;
NumberOfVars++;
}
else
{
if (arrayDimensionNames [0] || arrayDimensionNames [1])
for (j = 0; j < MAXDIMS; j++)
VarArrayDimensionNames [i] [j] =
arrayDimensionNames [j];
if (datatype > 0) VarTypes [i] = datatype;
if (varIsInCommon) VarIsInCommon [i] = varIsInCommon;
if (varDefinedOutsideCommon)
VarDefinedOutsideCommon [i] = varDefinedOutsideCommon;
VarIsInInclude [NumberOfVars] = isIncludeFile;
}
}
}
continue;
}

p = strstr (s, " DATA ");
if (strstr (s, " FORMAT")) p = NULL;
if (p || (' ' != s [5] && continuedData))
{
int i = 0;

if (p)
p += 11;
else
p = s + 6;

for (i = 0; i < NumberOfVars; i++)
{
char *ppp = strstr (p, VarNames [i]);

if (ppp)
{
char *pppm1 = ppp - 1;
// if the next character is a slash then this it
char *slash = ppp + strlen (VarNames [i]);

// previous character must be space or comma
if ( *pppm1 != ' ' && *pppm1 != ',' ) continue;

// next character must be space or slash
if ( *slash != ' ' && *slash != '/' ) continue;

VarHasData [i] = TRUE;
}
}
continuedData = TRUE;
continue;
}

p = strstr (s, " EQUIVALENCE ");
if (strstr (s, " FORMAT")) p = NULL;
if (p || (' ' != s [5] && continuedEquivalence))
{
int i = 0;

if (p)
p += 18;
else
p = s + 6;

for (i = 0; i < NumberOfVars; i++)
{
char *ppp = strstr (p, VarNames [i]);

if (ppp)
{
// if the next character is a comma or paren then this it
char *comma = ppp + strlen (VarNames [i]);

while (*comma && ' ' == *comma) comma++;
if (*comma &&
(',' == *comma || ')' == *comma || '(' == *comma))
VarHasEquivalence [i] = TRUE;
}
}
continuedEquivalence = TRUE;
continue;
}
}

// reset the file position to the place where we entered at
fseek (anysub, savedPlace, SEEK_SET);

for (i = 0; i < NumberOfVars; i++)
{
int len = strlen (VarNames [i]);
int j = 0;
int comma = FALSE;

#ifdef PRINT_VARIABLE_TABLE

printf ("C%8s", VarNames [i]);

if (VarHasData [i])
printf (" HasDat:Y");
else
printf (" HasDat:N");

if (VarIsInInclude [i])
printf (" Inc:Y");
else
printf (" Inc:N");

if (VarIsInCommon [i])
printf (" Com:Y");
else
printf (" Com:N");

#endif

// assign the implicit data type if necesary
if (0 == VarTypes [i]) switch (VarNames [i] [0])
{
case 'i':
case 'j':
case 'k':
case 'l':
case 'm':
case 'n':
case 'I':
case 'J':
case 'K':
case 'L':
case 'M':
case 'N': VarTypes [i] = VarIsInteger; break;
default: VarTypes [i] = VarIsReal;
}

#ifdef PRINT_VARIABLE_TABLE

switch (VarTypes [i])
{
case VarIsInteger: printf (" DataType: Int "); break;
case VarIsLogical: printf (" DataType: Logl"); break;
case VarIsDouble: printf (" DataType: Doub"); break;
case VarIsReal: printf (" DataType: Real"); break;
case VarIsCharacter: printf (" DataType: Char"); break;
}

if (VarHasEquivalence [i])
printf (" Equ:Y");
else
printf (" Equ:N");

printf (" ArrayDimension: ");
for (j = 0; j < MAXDIMS; j++)
{
if (VarArrayDimensionNames [i] [j])
{
if (comma) printf (",");
printf ("%s", VarArrayDimensionNames [i] [j]);
}
comma = TRUE;
}

printf ("\n");

#endif

}
}



.

Relevant Pages

  • could you help with c++ ? (HW)
    ... char *local_value; ... int truelangth; ... void setnumber; ... delete temp; ...
    (Debian-User)
  • Re: Struggling with libraries
    ... void insert(char* insrt, char* source, int place){ ... strcpy(source, temp); ... char * insert(char* insrt, char* source, int place){ ...
    (comp.lang.c)
  • Re: Struggling with libraries
    ... void insert(char* insrt, char* source, int place){ ... strcpy(source, temp); ... char * insert(char* insrt, char* source, int place){ ...
    (comp.lang.c)
  • Re: Unmanaged code(dll) function: int myfunc (char* temp)
    ... //Assigning an value to temp ... I am using char* not TCHAR* ... Can you help me how to get the value of temp when using string builder ... int myfunc ...
    (microsoft.public.dotnet.framework.compactframework)
  • SSPI Kerberos for delegation
    ... const char *tokenSource, const char *name = NULL, ... DWORD bufsiz = sizeof buf; ... int n = ib.cbBuffer; ... // wserr() displays winsock errors and aborts. ...
    (microsoft.public.dotnet.framework.remoting)