sds_fort.c

This Source-Navigator, an IDE for C/C++/Fortran/Java/Tcl/PHP/Python and a host of other languages.

  int  length,leno;
#else
/*************** SUN-XTENDED_FORT ******************************************/
int
#if defined(F77)
sdthrd_(sds,obj_ptr,name,n1,n2,n3,elemcod,obj_index,length,leno)
#else
sds_threed_fdeclare_(sds,obj_ptr,name,n1,n2,n3,elemcod,obj_index,length,leno)
#endif
int  *sds,*elemcod,*n1,*n2,*n3,length,leno,*obj_index;
char  *obj_ptr,*name;
{
#endif
  char  *pass_ptr = obj_ptr;
  long  ec = *elemcod;

  if (ec == SDS_FSTRING) {
#ifdef vms
    struct vms_fstring *obj = (struct vms_fstring*)pass_ptr;
    leno = (int)obj->len;
    pass_ptr = obj->string;
#endif
    getc_from_f(&cstring[0],name,&length);  
  }
  else
    getc_from_f(&cstring[0],name,&leno);  

  *obj_index = sds_threed_declare(*sds,pass_ptr,cstring,*n3,*n2,*n1,ec);
  if (*obj_index == 0) return(-2*(sds_error));
  else return(1);
}
/*********************************************************************/
/*  SDS_FDUPLICATE 
 *  Duplicate an existing SDS
 *
 *      ISTATUS = SDS_FDUPLICATE(sds,"myfile",NEW_SDS)
 *
 *  The new sds index is returned in NEW_SDS
 *  
 *  
 *********************************************************************/
/**************** VMS_FORTRAN ****************************************/
#ifdef vms
int
sds_fduplicate(sds,filename,new_sds)
int *sds,*new_sds;
char  *filename;
{
  int  length;
#else
/*************** SUN-XTENDED_FORT ******************************************/
int
#if defined(F77)
sddup_(sds,filename,new_sds,length)
#else
sds_fduplicate_(sds,filename,new_sds,length)
#endif
int *sds,length,*new_sds;
char  *filename;
{
#endif

  getc_from_f(cstring,filename,&length);
  *new_sds = sds_dup(*sds,cstring);
  if (*new_sds == 0) return(-2*(sds_error));
  else return(1);
}
/*********************************************************************/
/*      SDS_FMAKE
*      Assemble an SDS
*
*      ISTATUS = SDS_FMAKE(sds,"myfile",TYPE_PARAMETER,NEW_SDS)
*
*      NEW_SDS may be different from SDS if a new sds is made (eg when
*      assembled to shared memory)
*
*      where TYPE_PARAMETER is one of
*              SDS_NEW_FILE
*              SDS_APP_FILE
*              SDS_PROC_MEM
*              SDS_SHARED_MEM
*              SDS_SYBASE
*
*
*********************************************************************/
/**************** VMS_FORTRAN ****************************************/
#ifdef vms
int
sds_fmake(sds,filename,type,new_sds)
int *sds,*type,*new_sds;
char  *filename;
{
  int  length;
#else
/*************** SUN-XTENDED_FORT ******************************************/
int
#if defined(F77)
sdmake_(sds,filename,type,new_sds,length)
#else
sds_fmake_(sds,filename,type,new_sds,length)
#endif
int *sds,length,*type,*new_sds;
char  *filename;
{
#endif

  getc_from_f(cstring,filename,&length);
  *new_sds = sds_ass((int)*sds,cstring,*type);
  if (*new_sds == 0) return(-2*(sds_error));
  else return(1);
}
/*********************************************************************/
/* SDNORD
 *   Named object read.
 *   Reads a named sds object into a piece of Fortran memory
 * Bound checking is not done: caveat programmer!
 * Better still, don't use Fortram
 */
/**************** VMS_FORTRAN ****************************************/
#ifdef vms
int
sds_snord(sds,obj_ptr,object,fd)
int  *sds,*fd;
char  *obj_ptr,*object;
{
  int oblen;
#else
/*************** SUN-XTENDED_FORT ******************************************/
int
#if defined(F77)
sdnord_(sds,obj_ptr,object,oblen,fd)
#else
sds_sdnord_(sds,obj_ptr,object,oblen,fd)
#endif
int  *sds,oblen,*fd;
char  *obj_ptr,*object;
{
#endif
  char  obname[128];
  int max, obindex, number;
  struct direc *dptr = sds_direc_ptr(*sds);
 
  getc_from_f(obname,object,&oblen);
  obindex = sds_name2ind(*sds, obname);
  max = sds_array_size(*sds, obindex);
  number = sds_read_object(*sds,obindex,obj_ptr,0,max,fd);
  if (number == 0) 
    return(-2*sds_error);
  else 
  {
    dptr[obindex].offst = (long)obj_ptr;
    return(1);
  }
}

/*********************************************************************/
/*  SDS_FREADS 
 *
 *  Loads a data object into previously defined character string
 *  spcae. This is only necessary for Vax fortran character
 *  data: it is here for Sun as well for source code 
 *  compatablity. I'll try to find a better way....
 *
 */
/*********************************************************************/
/**************** VMS_FORTRAN ****************************************/
#ifdef vms
int
sds_freads(sds,object,obj_ptr,start,max,number)
#else
/*************** SUN-XTENDED_FORT ******************************************/
int
#if defined(F77)
sdsrd_(sds,object,obj_ptr,start,max,number)
#else
sds_freads_(sds,object,obj_ptr,start,max,number)
#endif
#endif
int  *sds,*object,*max,*number,*start;
char  *obj_ptr;
{
  char  *pass_ptr = obj_ptr;
  long  cstart = *start - 1;
  struct direc *dptr = sds_direc_ptr(*sds);

#ifdef vms
  struct vms_fstring *obj = (struct vms_fstring*)obj_ptr;
  pass_ptr = obj->string;
#endif
  *number = sds_read_object(*sds,*object,pass_ptr,cstart,*max);
  if (*number == 0) 
    return(-2*sds_error);
  else 
  {
    dptr[*object].offst = (long)pass_ptr;
    return(1);
  }
}
/*********************************************************************/
/*  SDS_FREAD0 
 *
 *  Loads a data object into previously defined space
 */
/*********************************************************************/
/**************** VMS_FORTRAN ****************************************/
#ifdef vms
int
sds_freado(sds,object,obj_ptr,start,max,number)
#else
/*************** SUN-XTENDED_FORT ******************************************/
int
#if defined(F77)
sdread_(sds,object,obj_ptr,start,max,number)
#else
sds_freado_(sds,object,obj_ptr,start,max,number)
#endif
#endif
int  *sds,*object,*max,*number,*start;
char  *obj_ptr;
{
  char  *pass_ptr = obj_ptr;
  long  cstart = *start - 1;
  struct direc *dptr = sds_direc_ptr(*sds);

  *number = sds_read_object(*sds,*object,pass_ptr,cstart,*max);
  if (*number == 0) 
    return(-2*(sds_error));
  else 
  {
    dptr[*object].offst = (long)obj_ptr;
    return(1);
  }
}
/*********************************************************************/
/*  SDS_FLOAD 
 *
 *  Loads an existing SDS to process memory
 *
 *      ISTATUS = SDS_FLOAD("myfile_name",SOURCE_TYPE,ACCESS_MODE,sds)
 *
 *  Where SOURCE_TYPE is one of
 *    SDS_FILE
 *    SDS_DIREC_ONLY
 *    SDS_SHARED_MEM
 *  And ACCESS_MODE is one of
 *    SDS_READ
 *    SDS_WRITE
 *
 *  The resulting SDS index is return in sds
 *  
 *  
 *********************************************************************/
#ifdef vms
/**************** VMS_FORTRAN ****************************************/
int
sds_fload(name,type,mode,sds)
char  *name;
int  *type,*mode,*sds;
{
  int  length;
#else
/*************** SUN-XTENDED_FORT ******************************************/
int
#if defined(F77)
sdload_(name,type,mode,sds,length)
#else
sds_fload_(name,type,mode,sds,length)
#endif
char  *name;
int  length,*type,*mode,*sds;
{
#endif
  getc_from_f(cstring,name,&length);  
  *sds = sds_access(cstring,*type,*mode);
  if (*sds == 0) return(-2*(sds_error));
  else return(1);
}
/*********************************************************************/
/*  SDS_STREAM_CLOSE 
 *  close an input stream (use after SDS_FLOAD with
 *  DIRECTORY_ONLY switch on
 *********************************************************************/
#ifdef vms
/**************** VMS_FORTRAN ****************************************/
int
sds_stream_close(sds)
#else
/*************** SUN-XTENDED_FORT ******************************************/
int
#if defined(F77)
sdsclo_(sds)
#else
sds_stream_close_(sds)
#endif
#endif
sds_handle  *sds;
{
  int fd = sds_stream(*sds);
  *sds = sds_ass(*sds,sds_obind2name(*sds,0),SDS_PROC_MEM);
  close(fd);
  return(1);
}
/*********************************************************************/
/*  SDS_FWHAT 
 *  
 *  Returns description of object 'obj' in sds 'sds'
 *  number of elements,name and type of element (elemcod) are filled.
 *
 *  INTEGER*4 IA,IB,IC
 *  CHARACTER*20 NAME
 *  .
 *  .
 *      ISTATUS = SDS_FWHAT(1,1,IA,IB,IC,NAME)
 *
 *  
 *  
 *********************************************************************/
#ifdef vms
/**************** VMS_FORTRAN ****************************************/
int
sds_fwhat(sds,obj,nelems,elemcod,name)
int  *sds,*obj,*nelems,*elemcod;
char   *name;
{
  int  length;
#else
/*************** SUN-XTENDED_FORT ******************************************/
int
#if defined(F77)
sdwhat_(sds,obj,nelems,elemcod,name,length)
#else
sds_fwhat_(sds,obj,nelems,elemcod,name,length)
#endif
int  *sds,*obj,*nelems,*elemcod,length;
char   *name;
{
#endif
  struct direc *dptr;

  if ((dptr = sds_direc_ptr(*sds)) == DNULL) 
    return(-2*SDS_NO_SUCH_SDS);
  if (*obj > dptr[0].nelems) return(-2*SDS_NO_SUCH_OBJ);
  *nelems = dptr[*obj].nelems;
  *elemcod = dptr[*obj].elemcod;
  getf_from_c(sds_obind2name(*sds,*obj),name,&length);
  return(1);
}

/*********************************************************************/
/*  SDS_FPRINT 
 *  
 *  lists to standard out object 'obj' of SDS 'sds'
 *
 *
 *      ISTATUS = SDS_FPRINT(1,0)
 *
 *  Lists directory of SDS 1
 *
 *  
 *  
 *********************************************************************/
#ifdef vms
/**************** VMS_FORTRAN ****************************************/
int
sds_fprint(sds,obj)
#else
/*************** SUN-XTENDED_FORT ******************************************/
int
#if defined(F77)
sdprin_(sds,obj)
#else
sds_fprint_(sds,obj)
#endif
#endif
int *sds,*obj;
{
  sds_list(*sds,*obj,SDS_LIST_FORMATTED);
  return(1);
}
/*********************************************************************/
/*  SDS_FINDO 
 *  find object name 'name' in SDS 'sds'
 *
 *      ISTATUS = SDS_FINDO(1,"blech",obj_ind)
 *
 *  Searches for object "blech" in SDS 1
 *  
 *  Returns object index in obj_ind
 *  
 *********************************************************************/
#ifdef vms
/**************** VMS_FORTRAN ****************************************/
int
sds_findo(sds,name,object)
int *sds,*object;
char *name;
{
  int  length;
#else
/*************** SUN-XTENDED_FORT ******************************************/
int
#if defined(F77)
sdfind_(sds,name,object,length)
#else
sds_findo_(sds,name,object,length)
#endif
int *sds,length,*object;
char *name;
{
#endif
  getc_from_f(cstring,name,&length);
  *object = sds_name2ind(*sds,cstring); 
  if (*object == 0) return(-2*(sds_error));
  else return(1);
}
/*********************************************************************/
void
unzterm(buffer,length)
char *buffer;
int  length;
/*********************************************************************/
{
  int  i;
  for (i=0;i<length;i++,buffer++)
    if (*buffer == 0) *buffer = ' ';
}
/*********************************************************************/
void
zterm(cbuffer)
char *cbuffer;
/*********************************************************************/
{
  while(*(--cbuffer) == ' ');
  cbuffer++;
  if ((int)*cbuffer) *cbuffer = (char)0;
}
#ifdef vms
/*********************************************************************/
int
getc_from_f(cbuffer,fpointer,len)
char  *cbuffer;
struct vms_fstring *fpointer;
int  *len;
/*********************************************************************/
{
  int  i;
  char  *fptr = fpointer->string;
  for(i=0;i<(int)fpointer->len;i++,*cbuffer++ = *fptr++);
  zterm(cbuffer);
}
#else

/*********************************************************************/
int
getc_from_f(cbuffer,fpointer,len)
char  *cbuffer,*fpointer;
int  *len;
/*********************************************************************/
{
  int i;
  for(i=0;i<*len;i++,*cbuffer++ = *fpointer++);
  zterm(cbuffer);
  return 0;
}
#endif
#ifdef vms
/*********************************************************************/
int
getf_from_c(cbuffer,fpointer,len)
char  *cbuffer;
struct vms_fstring *fpointer;
int  *len;
/*********************************************************************/
{
  int i;
  char  *fptr,*tptr;
  tptr = fpointer->string;
  fptr = cbuffer;
  for(i=0;i<(int)fpointer->len && *fptr != (char)0;i++,*tptr++ = *fptr++);
  for(;i<(int)fpointer->len;i++,*tptr++ = ' ');
  return 1;
}
#else

/*********************************************************************/
int
getf_from_c(cbuffer,fpointer,len)
char  *cbuffer,*fpointer;
int  *len;
/*********************************************************************/
{
  int i;
  char  *fptr,*tptr;
  tptr = fpointer;
  fptr = cbuffer;
  for(i=0;i<*len && *fptr != (char)0;i++,*tptr++ = *fptr++);
  for(;i<*len;i++,*tptr++ = ' ');
  return 1;
}
#endif