c***********************************************************************
c                     B P   A M E R I C A 
c             PROPRIETARY - TO BE MAINTAINED IN CONFIDENCE 
c                           COPYRIGHTED 2006   
c***********************************************************************
c
c                           TEMPLATE 1
c
c     FORTRAN TEMPLATE DEMONSTRATING THE USE OF THE BASE DDS ROUTINES
c     FOR A SIMPLE TRACE-TO-TRACE PROCESSING SCHEME.
c
c     Use a file extension of ".F" instead of ".f" to pull in the 
c     compiler preprocessor.
c
c     Written by Jerry Ehlers November 2006
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
      program template1
c
      implicit none
c
c     INCLUDE THE DDS API (Application Program Interface)
c
c     Need 2*PATHNAME_MAX for input dictionaries because they will hold
c     names for a temporary dictionary as well as the actual input
c     dictionary if it exists.
c
#include <fdds.h>
c
      integer in_bin,in_buf_bin,out_buf_bin,out_bin
      character*(2*PATHNAME_MAX) in_dict
      character*(PATHNAME_MAX) in_buf_dict,out_buf_dict,out_dict
      character*80 title
c
      integer ier,ns,nout,tag,ndxsmp,nbytes
      real    scale
c
c     Dynamic Arrays
c
      real    inbuf(1),outbuf(1)
      pointer (ptr_inbuf,inbuf)
      pointer (ptr_outbuf,outbuf)
c
      data    title/'template1: example of Fortran DDS program'/
      data    in_bin,in_buf_bin,out_buf_bin,out_bin/-1,-1,-1,-1/
c     
c=======================================================================
c     initialize
c=======================================================================
c
c     OPEN THE PRINT FILE & CHECK FOR HELP 
c     'fdds_openpr' function:
c          Open a printfile using the information automatically 
c          generated by RCS in '$Id: f_template1.html 125 2009-10-27 17:55:30Z ehlersjw $'.  If the user specifies some
c          form of help (-h help= HELP=...) on the command line,
c          then the return value will be < 0.
c
      ier=fdds_openpr('f_template1', '$Id: f_template1.html 125 2009-10-27 17:55:30Z ehlersjw $')
      if (ier.gt.0) call help()
c
c=======================================================================
c     open input data file
c=======================================================================
c
c     OPEN THE INPUT DICTIONARY 
c     'fdds_in' function:
c          This function opens an input dictionary.
c
      ier=fdds_in(in_dict,'in','stdin:',title)
c
c     OPEN THE INPUT BINARY 
c     'fdds_open' function:
c          This function opens the input binary.
c
      in_bin=fdds_open(in_dict,'in_format','in_data','r')
c
c     PRINT ERROR MESSAGE
c     'fdds_prterr' function:
c          Print an error message to the console (& printfile if 
c          exists). Error count is kept by DDS.  Check for errors later, 
c          before processing to check for as many things as possible 
c          first.
c
      if (in_bin.lt.0) then
         ier=fdds_prterr('Unable to open input data\n\0')
      endif
c
c     RETRIEVE DATASET DEFINITIONS NEEDED BY APPLICATION 
c     'fdds_scanf' function:
c          Default values are assigned prior to definition retrieval.
c          A variable are unchanged, if it is not specified.
c
c          NOTE: What's special about the "size.axis(1)" definition?
c          'axis(N)' is automatically converted to the Nth axis name.
c          This allows hyper cube attributes to be retrieved by axis
c          number, instead of axis name.  For example, "size.axis(1)"
c          becomes "size.t" (assuming "axis=  t x y").
c
c          WARNING: Do NOT use %i, use %d to scan for integers because
c                   %i will interpret a value with a leading "0" as 
c                   octal instead decimal (eg. 010 would be read as
c                   8 instead of 10).
c
c     Get input data parameters
c
      ier=fdds_scanf('size.axis(1)','%d\0',ns)
c     
c=======================================================================
c     open input data buffer
c=======================================================================
c
c     Define the input buffer Samples as host-dependent float
c
c     SETUP INTERNAL BUFFER REDEFINING Samples
c     'fdds_dict' function:
c          Setup to print definitions to the internal "override:"
c          dictionary.
c
c     'fdds_printf' function:
c          Define SAMPLE_TYPE as host-dependent floats
c
      ier=fdds_dict('override:','print')
      ier=fdds_printf('fmt:*:ibuf.SAMPLE_TYPE','\n\0')
      ier=fdds_printf(' ','   typedef float SAMPLE_TYPE;\n\0')
c     
c     OPEN THE INTERNAL BUFFER
c     'fdds_out' function:
c          Opens the internal buffer for writing into.  
c
c     Add aliased old_format to point to the input format so that 
c     it will be used as the default output format.
c
c     Setup internal buffer format to be "asp" via "ibuf_fmt" alias
c
c     Open the binary for the internal buffer via "fdds_open"
c
c
      ier=fdds_out(in_buf_dict,'ibuf',' ',in_dict)
      ier=fdds_printf('$old_format','format\n\0')
      ier=fdds_printf('ibuf_fmt','asp\n\0')
      in_buf_bin=fdds_open(in_buf_dict,'ibuf_fmt',' ','m')
      if (in_buf_bin.lt.0) then
         ier=fdds_prterr('Unable to open internal input buffer!\n\0')
      endif
c
c     INITIALIZE MAPPING FROM INPUT TO INTERNAL BUFFER
c     'fdds_openm' function:
c          Opens the mapping function from in_bin to in_buf_bin.
c          This is NOT necessary -- DDS will make this call for you the
c          first time you try and map data from in_bin to in_buf_bin. 
c          However, the dictionaries must still be opened at the time.
c          It is best, in general, to keep the dictionaries opened
c          anyway and let the fdds_close close them at the time
c          of the binary closing.
c
      ier=fdds_openm(in_buf_bin,0,in_bin,0)
c
c=======================================================================
c     read parameters
c=======================================================================
c
c     RETRIEVE COMMAND LINE PARAMETERS
c     'fdds_dict' function:
c          'fdds_dict' selects the 'par:' dictionary for scanning.
c          This dictionary only contains definitions from the command
c          line, and parameter dictionaries ("par=  fn1  fn2 ...").
c          Parameters ("in= ", "out_format= ", etc.) for the current
c          process can be read, without ambiguity from the input history 
c          (ie. local parameters only).
c
      ier=fdds_dict('par:','scan')
c
c     get scale parameter (default 1.0)
c
      scale=1.0
      ier=fdds_scanf('scale','%f\0',scale)
c
c     get # samples out (default ns)
c
c     Use "%d" instead of "%i" because "%i" will read any values
c     starting with "0" as octal numbers instead of decimal numbers.
c
      nout=ns
      ier=fdds_scanf(nout,'%d\0',nout)
c
c=======================================================================
c     print user parameters
c=======================================================================
c
c     PRINT MESSAGES 
c     'fdds_prtmsg' function:
c          This function prints a formatted message to the print file
c          opened by "fdds_openpr"; otherwise to the console (stderr).
c
c     'fdds_prtcon' function:
c          This function prints a formatted message to the console and
c          to the print file if opened.
c
c     'fdds_prtmsg' function:
c          This function prints a formatted error message to the console 
c          and to the print file if opened.  It also keeps track of the
c          number of error messages printed for "fdds_closepr".
c
      ier=fdds_prtmsg('\n*** USER PARAMETERS ***\n\n\0')
      ier=fdds_prtmsg('\tscale = %g\n\0',scale)
      ier=fdds_prtmsg('\tnout  = %d\n\0',nout)
      ier=fdds_prtmsg('\n\0')
c
c     Check parameters
c
      if (scale.lt.0.0) then
         ier=fdds_prtcon('WARNING: "scale" is negative!\n\0')
      endif
c
c=======================================================================
c     allocate dynamic arrays
c=======================================================================
c
c     Don't allocate arrays if there are already any errors; 
c     we could have bad array sizes
c 
      if (fdds_errors().ne.0) goto 900
c
c     ALLOCATE DYNAMIC ARRAYS 
c     'fdds_prec' function:
c          This function returns the number of bytes for each trace in
c          an open binary.
c
c     'fdds_malloc' function:
c          This function allocates memory or reports an error & aborts.
c          Storage can be released by calling "fdds_free".  Use 
c          "dds_debug= dbg_call" will cause DDS to check memory at
c          each api call.
c
c     'fdds_member' function:
c          This function gets the field tag for any trace header in a
c          given opened binary; the 2nd parameter, "0", specifies
c          the trace sequence; the 3rd parameter specifies the name
c          of the trace header -- in this case it's for "Samples".
c
c     'fdds_index' function:
c          This function gets the offset index to a trace field.
c
c     Allocate memory for an entire input record & single output trace 
c
      nbytes=fdds_prec(in_buf_bin,0)
      ptr_inbuf=fdds_malloc(nbytes)
c
      nbytes=fdds_prec(out_buf_bin,0)
      ptr_outbuf=fdds_malloc(nbytes)
c
c     get index to samples (allowing for possible trace headers)
c     (since we are not modifying any trace headers in this program,
c      we can use the same index for both input and output buffers.)
c
      tag=fdds_member(in_buf_bin,0,'Samples')
      ndxsmp=1+fdds_index(in_buf_bin,tag,DDS_REAL)
c
c=======================================================================
c     open internal output buffer
c=======================================================================
c     
c     CHECK FOR ERRORS BEFORE PROCEEDING ANY FURTHER 
c     'fdds_errors' function:
c          This function returns the number of errors reported using
c          "fdds_prterr".  No reason to create a new output if there
c          have been any errors.
c
      if (fdds_errors().ne.0) goto 900
c
c     CREATE OUTPUT INTERNAL BUFFER FROM INPUT BUFFER 
c     Modify the output Samples type (if it is being changed by this 
c     program) by printing a format change for SAMPLE_TYPE for the 
c     output buffer via "obuf" alias into the "override" dictionary.
c
c     'fdds_out' function:
c          This function will create an output dictionary from a 
c          previous one, passing all it's history information along.  
c
      ier=fdds_dict('override:','print')
      ier=fdds_printf('fmt:*:obuf.SAMPLE_TYPE','\n\0')
      ier=fdds_printf(' ','   typedef complex SAMPLE_TYPE;\n\0')
c
c     open output buffer dictionary
c
      ier=fdds_out(out_buf_dict,'obuf',' ',in_buf_dict)
c
c     print any definitions that might have changed from the input
c
      ier=fdds_printf('size.axis(1)','%d\n\0',nout)
c     
c     open output buffer binary (using "asp" format)
c     
      ier=fdds_printf('obuf_fmt','asp\n\0')
      out_buf_bin=fdds_open(out_buf_dict,'obuf_fmt',' ','m')
      if (out_buf_bin.lt.0) then
         ier=fdds_prterr('Unable to open output buffer!\n\0')
      endif
c
c=======================================================================
c     open output data
c=======================================================================
c  
c     open the output dictionary from the internal output buffer
c   
      ier=fdds_out(out_dict,'out','stdout:',out_buf_dict)
c
c     open the output binary
c
      out_bin=fdds_open(out_dict,'out_format','out_data','w+')
      if (out_bin.lt.0) then
         ier=fdds_prterr('Unable to open output file!\n\0')
      endif
c
c     explicitly open the mapping from the internal output buffer to
c     the output dataset
c
      ier=fdds_openm(out_bin,0,out_buf_bin,0)
c
c=======================================================================
c     process the data
c=======================================================================
c
      if (fdds_errors().ne.0) goto 900
c
      call doit(in_bin,in_buf_bin,out_buf_bin,out_bin,ns,nout,
     *   scale,inbuf,outbuf)
c
c=======================================================================
c     close files, clean-up, & exit
c=======================================================================
c
c
c     CLOSE OUT
c     'fdds_close' function:
c          This function closes a dataset if the binary tag is >= 0
c          including all underlying dictionaries and data structures.
c          This will also flush out all DDS data buffers out to the
c          kernel.
c
c     'fdds_closepr' function:
c          This function will close out the print file (if opened)
c          adding diagnostic information, unread command line 
c          parameters and termination status.  It will also exit
c          the program giving a usable status code.
c
 900  ier=fdds_close(in_bin)
      ier=fdds_close(in_buf_bin)
      ier=fdds_close(out_buf_bin)
      ier=fdds_close(out_bin)
c
      ier=fdds_closepr()

      end
c
c***********************************************************************
c
c     doit
c
c***********************************************************************
c
      subroutine doit(in_bin,in_buf_bin,out_buf_bin,out_bin,ns,nout,
     *   scale,inbuf,outbuf)
c
      implicit none
c
#include <fdds.h>
c
      integer in_bin,in_buf_bin,out_buf_bin,out_bin
      integer ns,nout,ndxsmp
      real    scale
      real    inbuf(*)
      real    outbuf(*)
c
      integer ier,i
c
c     loop over each trace
c
c
c        READ DATA
c        'fdds_readm' function:
c             This function reads a specified number of traces mapping
c             each into the input internal buffer.  
c             Check the number read in case of any problems.
c
      ier=fdds_readm(in_bin,0,in_buf_bin,0,inbuf,1)
      
      do while(ier.eq.1)
c
c        save trace headers to output buffer
c
         do i=1,ndxsmp-1
            outbuf(i)=inbuf(i)
         enddo
c
c        process the trace Samples
c
         call process(ns,nout,scale,inbuf(ndxsmp),outbuf(ndxsmp))
c
c        write the trace
c
c        WRITE DATA
c        'fdds_writem' function:
c             This function maps a specified number of traces from the
c             out_buf_bin to the out_bin and writes them out.  
c             Check the number written in case of any problems.
c
         ier=fdds_writem(out_bin,0,out_buf_bin,0,outbuf,1)
         if (ier.ne.1) then
            ier=fdds_prterr('writing output\n\0')
            return
         endif
c
c        read the next trace
c
         ier=fdds_readm(in_bin,0,in_buf_bin,0,inbuf,1)
      enddo
c
      return
      end
c     
c***********************************************************************
c     
c     help
c
c***********************************************************************
c
      subroutine help()
c
      write(0,*) 'Template program demonstraing the use of the base'
      write(0,*) 'DDS routines for a simple trace-to-trace processing' 
      write(0,*) 'scheme.'
      write(0,*) ' '
      write(0,*) 'usage:'
      write(0,*) 
     * '   f_template [in=dat] [in_data=bin] [in_format=fmt] \\'
      write(0,*) 
     * '   [out=dat] [out_data=bin] [out_format=fmt] \\'
      write(0,*) 
     * '   [nout=n] [scale=f]'
      write(0,*) '   '
      write(0,*) 'where:'
      write(0,*) '   in=        input dataset'
      write(0,*) '   in_data=   input binary'
      write(0,*) '   in_format= input format'
      write(0,*) '   out=       output dictionary'
      write(0,*) '   out_data=  output binary'
      write(0,*) '   out_format=output format'
      write(0,*) '   nout=      output samples (dflt=input)'
      write(0,*) '   scale=     scale factor (dflt=1.0)'
      write(0,*) ' '

      stop 0

      end