/************************************************************************* * * (c) Copyright 1992,1993,1994 by G & A Technical Software, Inc., * 28 Research Drive, Hampton, Virginia, 23666. * * All Rights Reserved. No part of this software or publication may be * reproduced, stored in a retrieval system, or transmitted, in any form * or by any means, electronic, mechanical, photocopying, recording, or * otherwise without the prior written permission of G & A Technical * Software, Inc. * ************************************************************************* * * Filename: * * Purpose: * * Author: John Burton * * Date: 5/31/94 * ************************************************************************* * * Modification History: * * $Log: s3_s3tof77_functions.c,v $ * Revision 2.1 1994/07/08 17:52:27 jcburt * Updated typedefs, defines and function protypes to allow recursive * parsing of pct files. Enabled use of sub-PDT files and scoping of * datasets. Datasets used in a pct must be defined either in the * associated pdt file or the pdt file associated with the direct * ancestors of the current pct file. * * DataSet functions and subroutines now have an additional parameter * passed to them, indicating the number of parameters passed in the * dataset list, i.e. was: function(DataSet **dl) * now: function(int nargs, DataSet **dl) * Parameters passed to the dataset routines from the PCT level are all * still contained in the dataset list, nargs is during the function or * subroutine call from s3_exec_enode * * Revision 2.0.0.1 1994/06/28 18:48:27 jcburt * S3 Version 2.0 Initial Source * * ************************************************************************* * * Revision Control Information: * *************************************************************************/ static char rcsid[] = "$Id: s3_s3tof77_functions.c,v 2.1 1994/07/08 17:52:27 jcburt Exp $"; static char rcsrev[] = "$Revision: 2.1 $"; /************************************************************************* * * Include Files * *************************************************************************/ #include #include #include "ctype.h" #include "s3_defines.h" #include "s3_typedefs.h" #include "s3_externals.h" #include "s3_globals.h" #include "s3_parser.tab.h" /************************************************************************* * * Global Variables * *************************************************************************/ int PRINT = FALSE; char *inc_file = NULL; char *eol_inc_file = NULL; /************************************************************************* * * Module: * * Description: * * Syntax: * * Inputs: * * Outputs: * * Returns: * * Modules Called: * *************************************************************************/ static void outlist(FILE *fp, char *buff, int len, char *bchars) { int i,j,l,hlen; char *tmp,*t,*ptr,*tbuff,header[64],tchar; char buffer[80]; sprintf(header," &%*s",len," "); hlen = strlen(header); tbuff = strsave(buff); tmp = tbuff; j = 0; while((ptr=strpbrk(tmp,bchars)) != NULL) { l = (ptr - tmp) + 1; if((l+j) > 72) { fprintf(fp,"\n%s",header); j = hlen; } j += l; tchar = ptr[1]; ptr[1] = '\0'; fprintf(fp,"%s",tmp); ptr[1] = tchar; tmp = ptr+1; } if((j+strlen(tmp)) > 72) fprintf(fp,"\n%s",header); fprintf(fp,"%s\n",tmp); xfree(tbuff); } /************************************************************************* * * Module: * * Description: * * Syntax: * * Inputs: * * Outputs: * * Returns: * * Modules Called: * *************************************************************************/ static void outconlist(FILE *fp, char *buff, int len) { int i,j; char *tmp1,*tmp2; while(strlen(buff) > 70) { i = 70; tmp1 = strsave(buff); while((tmp1[i] != ',')&&(tmp1[i] != ')')) i--; i++; tmp2 = strsave((&tmp1[i])); tmp1[i] ='\0'; fprintf(fp,"%s\n",tmp1); xfree(tmp1); tmp1 = strsave(" &"); for(i=0;ids; /* len = strlen(ds.name); */ /* ds.name[len-1] = '\0'; */ ds.name++; list[0]->ds = ds; } } /************************************************************************* * * Module: * * Description: * * Syntax: * * Inputs: * * Outputs: * * Returns: * * Modules Called: * *************************************************************************/ static void write_sub_call(FILE *fp, int nspace, int type, char *label, char *name, ST_entry **list, int count, int which) { int i,j,len,lenn,nlen; char buff[256],*tmp; DataSet ds; #ifdef _AIX char *cprefix = ""; #else char *cprefix = "_"; #endif if(which == 0) tmp = strsave("IF"); else { tmp = strsave("ELSE IF"); nspace += 2; } switch(type) { case CFUNC: fprintf(fp,"%*s%s (S3_eo .EQ. \'%s\') THEN\n",(nspace-1)," ",tmp,label); sprintf(buff,"%*sS3_ir = %s%s",(nspace+1),"",cprefix,name); nlen = nspace + 1; break; case CSUBR: fprintf(fp,"%*s%s (S3_eo .EQ. \'%s\') THEN\n",(nspace-1)," ",tmp,label); sprintf(buff,"%*sCALL %s%s",(nspace+1),"",cprefix,name); nlen = 0; break; case DFUNC: fprintf(fp,"%*s%s (S3_eo .EQ. \'%s\') THEN\n",(nspace-1)," ",tmp,label); sprintf(buff,"%*sS3_ir = %s",(nspace+1),"",name); nlen = nspace + 1; break; case DSUBR: fprintf(fp,"%*s%s (S3_eo .EQ. \'%s\') THEN\n",(nspace-1)," ",tmp,label); sprintf(buff,"%*sCALL %s",(nspace+1),"",name); nlen = 0; break; case FFUNC: fprintf(fp,"%*s%s (S3_eo .EQ. \'%s\') THEN\n",(nspace-1)," ",tmp,label); sprintf(buff,"%*sS3_ir = %s",(nspace+1),"",name); nlen = nspace + 1; break; case FSUBR: fprintf(fp,"%*s%s (S3_eo .EQ. \'%s\') THEN\n",(nspace-1)," ",tmp,label); sprintf(buff,"%*sCALL %s",(nspace+1),"",name); nlen = 0; break; case PNODE: fprintf(fp,"%*s%s (S3_eo .EQ. \'%s\') THEN\n",(nspace-1)," ",tmp,label); sprintf(buff,"%*sS3_ir = %s",(nspace+1),"",name); nlen = nspace + 1; break; default: s3_internal_error(__FILE__,__LINE__,LOC,"write_sub_call: unknown subroutine type : %d \n",type); break; } lenn = strlen(name); len = strlen(buff) - 6; if (lenn > 8) len = len - lenn + 8; tmp = strsave(buff); tmp = stringcat(tmp,"("); if((count > 0)&&(list != NULL)) { len = len + 1; for(i=0;ids; tmp = stringcat(tmp,ds.name); if(i<(count-1)) tmp = stringcat(tmp,","); } } tmp = stringcat(tmp,")"); outlist(fp,tmp,len,","); xfree(tmp); if(nlen > 0) fprintf(fp,"%*sexit_loop = (S3_ir .GT. 0)\n",nlen,""); } /************************************************************************* * * Module: * * Description: * * Syntax: * * Inputs: * * Outputs: * * Returns: * * Modules Called: * *************************************************************************/ static void write_var_list(FILE *fp, int type, ST_entry **list, int count) { int i,j,blen,clen; char *buff,*ctmp,*dtmp; DataSet ds; ST_entry *dlist; if(count > 0) { switch(type) { case INT: fprintf(fp,"c\nc Start INTEGER type declarations section \nc\n"); buff = strsave(" INTEGER "); ctmp = strsave(" COMMON /S3INTEGER/ "); break; case REAL: fprintf(fp,"c\nc Start REAL*4 type declarations section \nc\n"); buff = strsave(" REAL*4 "); ctmp = strsave(" COMMON /S3REAL4/ "); break; case DREAL: fprintf(fp,"c\nc Start REAL*8 type declarations section \nc\n"); buff = strsave(" REAL*8 "); ctmp = strsave(" COMMON /S3REAL8/ "); break; case COMP: fprintf(fp,"c\nc Start COMPLEX*8 type declarations section \nc\n"); buff = strsave(" COMPLEX*8 "); ctmp = strsave(" COMMON /S3COMPLEX8/ "); break; case DCOMP: fprintf(fp,"c\nc Start COMPLEX*16 type declarations section \nc\n"); buff = strsave(" COMPLEX*16 "); ctmp = strsave(" COMMON /S3COMPLEX16/ "); break; default: s3_internal_error(__FILE__,__LINE__,LOC,"write_var_list: unknown data type : %d \n",type); break; } /* blen = strlen(buff) - 6; */ /* clen = strlen(ctmp) - 6; */ blen = 4; clen = 4; for(i=0;ids; buff = stringcat(buff,ds.name); ctmp = stringcat(ctmp,ds.name); if(ds.NDIMS > 0) { buff = stringcat(buff,"("); buff = stringcat(buff,ds.dimlist[0]->co.name); for(j=1;jco.name); } buff = stringcat(buff,")"); } if(i<(count-1)) { buff = stringcat(buff,","); ctmp = stringcat(ctmp,","); } } outlist(fp,buff,blen,","); fprintf(fp,"\n"); outlist(fp,ctmp,clen,","); xfree(buff); xfree(ctmp); switch(type) { case INT: fprintf(fp,"c\nc End INTEGER type declarations section \nc\n"); break; case REAL: fprintf(fp,"c\nc End REAL*4 type declarations section \nc\n"); break; case DREAL: fprintf(fp,"c\nc End REAL*8 type declarations section \nc\n"); break; case COMP: fprintf(fp,"c\nc End COMPLEX*8 type declarations section \nc\n"); break; case DCOMP: fprintf(fp,"c\nc End COMPLEX*16 type declarations section \nc\n"); break; default: s3_internal_error(__FILE__,__LINE__,LOC,"write_var_list: unknown data type : %d \n",type); break; } } return; } /************************************************************************* * * Module: * * Description: * * Syntax: * * Inputs: * * Outputs: * * Returns: * * Modules Called: * *************************************************************************/ static void write_data_init(FILE *fp, int type, ST_entry **list, int count) { int i,j,blen,clen; char *buff,*ctmp,*dtmp; DataSet ds; ST_entry *dlist; PRINT = TRUE; if(count > 0) { switch(type) { case CHAR: fprintf(fp,"c\nc Start CHARACTER DATA initialization section \nc\n"); break; case INT: fprintf(fp,"c\nc Start INTEGER DATA initialization section \nc\n"); break; case REAL: fprintf(fp,"c\nc Start REAL*4 DATA initialization section \nc\n"); break; case DREAL: fprintf(fp,"c\nc Start REAL*8 DATA initialization section \nc\n"); break; case COMP: fprintf(fp,"c\nc Start COMPLEX*8 DATA initialization section \nc\n"); break; case DCOMP: fprintf(fp,"c\nc Start COMPLEX*16 DATA initialization section \nc\n"); break; default: s3_internal_error(__FILE__,__LINE__,LOC,"write_var_list: unknown data type : %d \n",type); break; } fprintf(fp,"\n"); for(i=0;ids.vallist != NULL) { ds = list[i]->ds; buff = strsave(" DATA "); blen = strlen(buff) - 6; buff = stringcat(buff,ds.name); buff = stringcat(buff," / "); buff = stringcat(buff,ds.vallist); buff = stringcat(buff," / "); outlist(fp,buff,blen,",\""); xfree(buff); } switch(type) { case CHAR: fprintf(fp,"c\nc End CHARACTER DATA initialization section \nc\n"); break; case INT: fprintf(fp,"c\nc End INTEGER DATA initialization section \nc\n"); break; case REAL: fprintf(fp,"c\nc End REAL*4 DATA initialization section \nc\n"); break; case DREAL: fprintf(fp,"c\nc End REAL*8 DATA initialization section \nc\n"); break; case COMP: fprintf(fp,"c\nc End COMPLEX*8 DATA initialization section \nc\n"); break; case DCOMP: fprintf(fp,"c\nc End COMPLEX*16 DATA initialization section \nc\n"); break; default: s3_internal_error(__FILE__,__LINE__,LOC,"write_var_list: unknown data type : %d \n",type); break; } } PRINT = FALSE; return; } /************************************************************************* * * Module: * * Description: * * Syntax: * * Inputs: * * Outputs: * * Returns: * * Modules Called: * *************************************************************************/ static void write_chr_list(FILE *fp, ST_entry **list, int count) { int i,j,len,clen; char *buff,*ctmp; DataSet ds; ST_entry *dlist; if(count > 0) { fprintf(fp,"c\nc Start CHARACTER type declarations section \nc\n"); buff = strsave(" CHARACTER "); /* len = strlen(buff) - 6; */ len = 4; ctmp = strsave(" COMMON /S3CHARACTER/ "); clen = 4; /* clen = strlen(ctmp) - 6; */ for(i=0;ids; buff = stringcat(buff,ds.name); ctmp = stringcat(ctmp,ds.name); if(ds.NDIMS > 0) { if(ds.NDIMS > 1) { buff = stringcat(buff,"("); buff = stringcat(buff,ds.dimlist[1]->co.name); for(j=2;jco.name); } buff = stringcat(buff,")"); } #ifdef _AIX buff = stringcat(buff,"*("); buff = stringcat(buff,ds.dimlist[0]->co.name); buff = stringcat(buff,")"); #else buff = stringcat(buff,"*"); buff = stringcat(buff,ds.dimlist[0]->co.name); #endif } if(i<(count-1)) { buff = stringcat(buff,","); ctmp = stringcat(ctmp,","); } } outlist(fp,buff,len,","); outlist(fp,ctmp,clen,","); xfree(buff); xfree(ctmp); fprintf(fp,"c\nc End CHARACTER type declarations section \nc\n"); } return; } /************************************************************************* * * Module: * * Description: * * Syntax: * * Inputs: * * Outputs: * * Returns: * * Modules Called: * *************************************************************************/ static void write_con_list(FILE *fp, ST_entry **list, int count) { int i,j,len,dlen; char *dbuff,*buff,*tmp1,tmp2; Constant co; ST_entry *dlist; if(count > 0) { fprintf(fp,"c\nc Start PARAMETER declarations section \nc\n"); dbuff = strsave(" INTEGER "); buff = strsave(" PARAMETER ("); dlen = strlen(dbuff) - 6; len = strlen(buff) - 6; for(i=0;ico; dbuff = stringcat(dbuff,co.name); buff = stringcat(buff,co.name); buff = stringcat(buff," = "); buff = stringcat(buff,co.description); if(i<(count-1)) { dbuff = stringcat(dbuff,","); buff = stringcat(buff,","); } } buff = stringcat(buff,")"); outlist(fp,dbuff,dlen,","); fprintf(fp,"\n"); outconlist(fp,buff,len); fprintf(fp,"c\nc End PARAMETER declarations section \nc\n"); xfree(buff); xfree(dbuff); } return; } /************************************************************************* * * Module: * * Description: * * Syntax: * * Inputs: * * Outputs: * * Returns: * * Modules Called: * *************************************************************************/ static void write_EO_init(FILE *fp, ST_entry **list, int count) { int i,j,ilen,llen; char *ibuff,*lbuff,ival[32],*itmp,*ltmp; Pnode pn; ST_entry *dlist; if(count > 0) { fprintf(fp,"c\nc Start EOL/EOI DATA initialization section \nc\n"); ibuff = strsave(" DATA S3_EOI_ARRAY / "); lbuff = strsave(" DATA S3_EOL_ARRAY / "); ilen = strlen(ibuff) - 6; llen = strlen(lbuff) - 6; for(i=0;ipn; sprintf(ival,"%d",pn.EOI); ibuff = stringcat(ibuff,ival); lbuff = stringcat(lbuff,"\'"); lbuff = stringcat(lbuff,pn.EOL); lbuff = stringcat(lbuff,"\'"); if(i==(count-1)) { ibuff = stringcat(ibuff," / "); lbuff = stringcat(lbuff," / "); } else { ibuff = stringcat(ibuff,", "); lbuff = stringcat(lbuff,", "); } } outlist(fp,ibuff,ilen,",/"); outlist(fp,lbuff,llen,",/"); xfree(ibuff); xfree(lbuff); fprintf(fp,"c\nc End EOL/EOI DATA initialization section \nc\n"); fprintf(fp," END\n"); } return; } /************************************************************************* * * Module: * * Description: * * Syntax: * * Inputs: * * Outputs: * * Returns: * * Modules Called: * *************************************************************************/ static void write_header(FILE *fp,char *fname) { int i; char *datetimestr; char *username; long now; #ifdef _AIX extern char *getlogin(); #endif time(&now); datetimestr = ctime(&now); username = getlogin(); i = strlen(datetimestr); while((i>=0) && (datetimestr[i] != '\n')) i--; if(i > 0) datetimestr[i] = ' '; fprintf(fp,"c-------------------------------------------------------------------------------\n"); fprintf(fp,"c \n"); fprintf(fp,"c \n"); fprintf(fp,"c \n"); fprintf(fp,"c (c) Copyright 1992-1997 by GATS, Inc., \n"); fprintf(fp,"c 28 Research Drive, Hampton, Virginia, 23666. \n"); fprintf(fp,"c \n"); fprintf(fp,"c All Rights Reserved. No part of this software or publication may be \n"); fprintf(fp,"c reproduced, stored in a retrieval system, or transmitted, in any form \n"); fprintf(fp,"c or by any means, electronic, mechanical, photocopying, recording, or \n"); fprintf(fp,"c otherwise without the prior written permission of G & A Technical \n"); fprintf(fp,"c Software, Inc. \n"); fprintf(fp,"c \n"); fprintf(fp,"c \n"); fprintf(fp,"c \n"); fprintf(fp,"c This file was generated by %s, a GATS utility for converting S3 based \n",progname); fprintf(fp,"c programs into FORTRAN source code.\n"); fprintf(fp,"c \n"); fprintf(fp,"c File: %s \n",fname); fprintf(fp,"c User: %s \n",username); fprintf(fp,"c Date: %s \n",datetimestr); fprintf(fp,"c \n"); fprintf(fp,"c-------------------------------------------------------------------------------\n"); } static void write_pct_header(FILE *fppct,char *fnm,ST_entry *pct,int which_pct) { char buff1[82], buff2[82]; char buff3[82], buff4[82]; int i,len; if(which_pct == 1) fprintf(fppct," PROGRAM %s_pct\n",pct->pn.name); else fprintf(fppct," INTEGER FUNCTION ipct_%s()\n",pct->pn.name); write_header(fppct,fnm); sprintf(buff1,"c INCLUDE \'hal_src:%s\'",inc_file); sprintf(buff2,"c INCLUDE \'hal_src:%s\'",eol_inc_file); sprintf(buff3," INCLUDE \'%s\'",inc_file); sprintf(buff4," INCLUDE \'%s\'",eol_inc_file); for(i=strlen(buff1);i<76;i++) buff1[i] = ' '; for(i=strlen(buff2);i<76;i++) buff2[i] = ' '; for(i=strlen(buff3);i<76;i++) buff3[i] = ' '; for(i=strlen(buff4);i<76;i++) buff4[i] = ' '; buff1[76] = buff2[76] = 'V'; buff1[77] = buff2[77] = 'A'; buff1[78] = buff2[78] = 'X'; buff1[79] = buff2[79] = '\0'; buff3[76] = buff4[76] = '!'; buff3[77] = buff4[77] = 'I'; buff3[78] = buff4[78] = 'B'; buff3[79] = buff4[79] = 'M'; buff3[80] = buff4[80] = '\0'; fprintf(fppct,"%s\n",buff1); fprintf(fppct,"%s\n",buff2); fprintf(fppct,"%s\n",buff3); fprintf(fppct,"%s\n",buff4); fprintf(fppct,"c\nc LOCAL variables used by this S3 PCT subroutine only\nc\n"); fprintf(fppct," CHARACTER*64 S3_eol\n"); fprintf(fppct," CHARACTER*1 S3_eo\n"); fprintf(fppct," INTEGER S3_eoi, S3_ir, S3_is, S3_ie\n"); fprintf(fppct," LOGICAL exit_loop\n"); fprintf(fppct,"c\n"); fprintf(fppct,"c-------------------------------------------------------------------------------\n"); fprintf(fppct,"c\n"); fflush(fppct); } static void write_pct_body(FILE *fpout,ST_entry *pct,int which_pct) { ST_entry *entry,**paramlist; int i,nparams; char *name,label[2]; label[0] = NULLCH; label[1] = NULLCH; fprintf(fpout," EQUIVALENCE( S3_eol, S3_EOL_ARRAY(%d) )\n",which_pct); fprintf(fpout," EQUIVALENCE( S3_eoi, S3_EOI_ARRAY(%d) )\n\n",which_pct); fprintf(fpout," exit_loop = .FALSE.\n"); fprintf(fpout," S3_ir = 0\n\n"); fprintf(fpout," DO WHILE (.NOT. exit_loop)\n"); fprintf(fpout," WHICH_PCT = %d\n",which_pct); fprintf(fpout," S3_is = S3_eoi + 1\n"); fprintf(fpout," S3_ie = S3_eoi + 2\n"); fprintf(fpout," S3_eo = S3_eol(S3_is:S3_ie)\n"); fprintf(fpout," S3_eoi = S3_eoi + 1\n"); fflush(fpout); for(i=0;ipn.NE;i++) { entry = pct->pn.elist[i]; switch(entry->ss.type) { case PNODE: name = strsave2("ipct_",entry->ss.name); nparams = 0; paramlist = NULL; break; case DFUNC: case DSUBR: name = strsave(entry->ss.name); nparams = entry->en.NDS; paramlist = entry->en.dslist; modify_sub_call(name,paramlist,nparams); break; case CFUNC: case CSUBR: case FFUNC: case FSUBR: name = strsave(entry->ss.name); nparams = entry->en.NDS; paramlist = entry->en.dslist; break; } label[0] = pct->pn.elkey[i]; write_sub_call(fpout,9,entry->ss.type,label,name,paramlist,nparams,i); xfree(name); } } static void write_pct_trailer(FILE *fppct,ST_entry *pct,int which_pct) { fprintf(fppct," ELSE\n"); fprintf(fppct," exit_loop = .TRUE.\n"); fprintf(fppct," END IF\n"); fprintf(fppct," END DO\n"); if(which_pct>1) { fprintf(fppct," IF(S3_ir .GT. 0) S3_ir = S3_ir - 1\n",pct->pn.name); fprintf(fppct," ipct_%s = S3_ir\n",pct->pn.name); fprintf(fppct," RETURN\n"); } fprintf(fppct," END\n"); fprintf(fpout,"done\n"); } void print_utilities() { FILE *fp; char *fname = "S3_DataSet_Utilities.f"; if((fp = fopen(fname,"w")) == NULL) s3_error(SYS,"Cannot open file %s for writing",fname); fprintf(fpout," Writing %s. . .",fname); write_header(fp,fname); fprintf(fp," subroutine set_eol(ipct,eol)\n"); fprintf(fp," integer*4 ipct\n"); fprintf(fp," character*64 eol\n"); fprintf(fp," include \'%s\'\n",eol_inc_file); fprintf(fp," S3_EOL_ARRAY(ipct) = eol\n"); fprintf(fp," return\n"); fprintf(fp," end\n"); fprintf(fp,"\n\n\n"); fprintf(fp," subroutine set_eoi(ipct,eoi)\n"); fprintf(fp," integer*4 ipct, eoi\n"); fprintf(fp," include \'%s\'\n",eol_inc_file); fprintf(fp," S3_EOI_ARRAY(ipct) = eoi\n"); fprintf(fp," return\n"); fprintf(fp," end\n"); fprintf(fp,"\n\n\n"); fprintf(fp," subroutine incr(ival,byval)\n"); fprintf(fp," integer*4 ival, byval\n"); fprintf(fp," ival = ival + byval\n"); fprintf(fp," return\n"); fprintf(fp," end\n"); fprintf(fp,"\n\n\n"); fprintf(fp," subroutine decr(ival,byval)\n"); fprintf(fp," integer*4 ival, byval\n"); fprintf(fp," ival = ival - byval\n"); fprintf(fp," return\n"); fprintf(fp," end\n"); fprintf(fp,"\n\n\n"); fprintf(fp," subroutine if_then_else(test,tndx,fndx)\n"); fprintf(fp," integer*4 test, tndx, fndx\n"); fprintf(fp," include \'%s\'\n",eol_inc_file); fprintf(fp," if(test.NE.0) then \n"); fprintf(fp," S3_EOI_ARRAY(WHICH_PCT) = tndx\n"); fprintf(fp," else \n"); fprintf(fp," S3_EOI_ARRAY(WHICH_PCT) = fndx\n"); fprintf(fp," end if\n"); fprintf(fp," return\n"); fprintf(fp," end\n"); fprintf(fp,"\n\n\n"); fprintf(fp," subroutine dsz(cntrl,tndx)\n"); fprintf(fp," integer*4 cntrl, tndx\n"); fprintf(fp," include \'%s\'\n",eol_inc_file); fprintf(fp," cntrl = cntrl - 1\n"); fprintf(fp," if(cntrl.GT.0) S3_EOI_ARRAY(WHICH_PCT) = tndx\n"); fprintf(fp," return\n"); fprintf(fp," end\n"); fprintf(fp,"\n\n\n"); fprintf(fp," subroutine ise(count,stop,ndx)\n"); fprintf(fp," integer*4 count,stop,ndx\n"); fprintf(fp," include \'%s\'\n",eol_inc_file); fprintf(fp," if(count.LT.stop) S3_EOI_ARRAY(WHICH_PCT) = ndx\n"); fprintf(fp," count = count + 1\n"); fprintf(fp," return\n"); fprintf(fp," end\n"); fprintf(fp,"\n\n\n"); fprintf(fpout,"done\n"); } void write_EO_list(char *fname,char *bname,ST_entry **list,int count) { Pnode pn; ST_entry *dlist; FILE *fp; int i,len; char *tmp; tmp = strsave(" INTEGER "); len = strlen(tmp); if((fp = fopen(fname,"w")) == NULL) s3_error(SYS,"Cannot open file %s for writing",fname); fprintf(fpout," Writing %s. . .",fname); write_header(fp,fname); fprintf(fp,"c\nc NOTE: Original PCT EOL / EOI declarations were:\n"); fprintf(fp,"c PCT Name WHICH_PCT EOI EOL\n"); fprintf(fp,"c -------- --------- --- ---\n"); for(i=0;ipn; tmp = stringcat(tmp,pn.name); if(i < count-1) tmp = stringcat(tmp,","); fprintf(fp,"c %-25s %3d %3d %s\n",pn.name,i,pn.EOI,pn.EOL); } fprintf(fp,"c\nc See Block Data Subprogram file %s for data initializations\nc\n",bname); outlist(fp,tmp,len,","); fprintf(fp,"\n"); for(i=0;ipn; fprintf(fp," PARAMETER (%s = %d)\n",pn.name,i); } fprintf(fp,"c\nc Start EOL / EOI declarations section \nc\n"); fprintf(fp," CHARACTER*64 S3_EOL_ARRAY(%d)\n",count); fprintf(fp," INTEGER*4 WHICH_PCT, S3_EOI_ARRAY(%d)\n",count); fprintf(fp," COMMON /S3EOL_EOI/ WHICH_PCT, S3_EOI_ARRAY, S3_EOL_ARRAY\n"); fprintf(fp,"c\nc End EOL / EOI declarations section \nc\n"); fprintf(fpout,"done\n"); fclose(fp); return; } void write_include_file(FILE *fp, char *fname, PDT_struct *pdt) { fprintf(fpout,"\n Writing %s. . .",fname); write_header(fp,fname); write_con_list(fp,pdt->const_list,pdt->nconst); write_chr_list(fp,pdt->char_list,pdt->nchar); write_var_list(fp,INT,pdt->int_list,pdt->nint); write_var_list(fp,REAL,pdt->real_list,pdt->nreal); write_var_list(fp,DREAL,pdt->dreal_list,pdt->ndreal); write_var_list(fp,COMP,pdt->comp_list,pdt->ncomp); write_var_list(fp,DCOMP,pdt->dcomp_list,pdt->ndcomp); fprintf(fpout,"done\n"); } void write_block_data_file(FILE *fp,char *bname, PDT_struct *pdt) { char *fname; fname = strsave2(bname,".f"); fprintf(fpout," Writing %s. . . ",fname); fprintf(fp," BLOCK DATA %s\n",bname); write_header(fp,fname); fprintf(fp," INCLUDE \'%s\'\n",inc_file); fprintf(fp," INCLUDE \'%s\'\n",eol_inc_file); write_data_init(fp,CHAR,pdt->char_list,pdt->nchar); write_data_init(fp,INT,pdt->int_list,pdt->nint); write_data_init(fp,REAL,pdt->real_list,pdt->nreal); write_data_init(fp,DREAL,pdt->dreal_list,pdt->ndreal); write_data_init(fp,COMP,pdt->comp_list,pdt->ncomp); write_data_init(fp,DCOMP,pdt->dcomp_list,pdt->ndcomp); xfree(fname); fprintf(fpout,"done\n"); } void write_pct_file(ST_entry *pct,int main_pct) { char *fnm, *tmp; FILE *fppct; fnm = strsave2("s3_",pct->pn.filename); tmp = strchr(fnm,(int)'.'); tmp[1] = 'f'; tmp[2] = NULLCH; tmp[3] = NULLCH; if((fppct = fopen(fnm,"w")) == NULL) s3_error(SYS,"Cannot open output file %s",fnm); fprintf(fpout," Writing %s. . . ",fnm); tmp[0] = NULLCH; write_pct_header(fppct,fnm,pct,main_pct); write_pct_body(fppct,pct,main_pct); write_pct_trailer(fppct,pct,main_pct); fclose(fppct); xfree(fnm); } void s3tof77(PCT_struct *pct_info, PDT_struct *pdt_info, char *basename) { int i,i2; char *main_file, *blk_data_file, *blk_data; FILE *fpmain, *fpinc, *fpblk, *fppct; main_file = strsave2(strsave2("s3_",basename),".f"); inc_file = strsave2(strsave2("s3_",basename),".inc"); eol_inc_file = strsave2(strsave2("s3_eol_",basename),".inc"); blk_data = strsave2("s3_pdt_",basename); blk_data_file = strsave2(blk_data,".f"); if((fpmain = fopen(main_file,"w")) == NULL) s3_error(SYS,"Cannot open file %s for writing",main_file); if((fpinc = fopen(inc_file,"w")) == NULL) s3_error(SYS,"Cannot open file %s for writing",inc_file); if((fpblk = fopen(blk_data_file,"w")) == NULL) s3_error(SYS,"Cannot open file %s for writing",blk_data_file); write_include_file(fpinc,inc_file,pdt_info); write_block_data_file(fpblk,blk_data,pdt_info); write_EO_list(eol_inc_file,blk_data_file,pct_info->pct_list,pct_info->npct); write_EO_init(fpblk,pct_info->pct_list,pct_info->npct); fclose(fpblk); for(i=0,i2=1;inpct;i++,i2++) write_pct_file(pct_info->pct_list[i],i2); print_utilities(); }