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 2
c
c FORTRAN TEMPLATE DEMONSTRATING THE USE OF DDS CONVENIENCE
c ROUTINES FOR A SIMPLE TRACE-TO-TRACE PROCESSING SCHEME
c WITHOUT USING OR PASSING ANY TRACE HEADERS.
c
c Use a file extension of ".F" instead of ".f" to pull in the
c compiler preprocessor.
c
c Written by Jerry Ehlers August 2006
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
program template2
c
implicit none
c
c INCLUDE THE DDS API (Application Program Interface)
c
#include <fdds.h>
c
integer in_bin,out_bin
integer ier,ns
real scale
character*80 title
c
real databuf(1)
pointer (ptr_databuf,databuf)
c
data title/'template2: example of Fortran DDS program'/
data in_bin,out_bin/-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_template2.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_template2', '$Id: f_template2.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 FILE
c 'fddx_in' function:
c This function opens the input file, with data Samples only
c as real values (unless input is complex).
c
in_bin=fddx_in('in','stdin:',title)
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 Get input data parameters
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
ier=fdds_scanf('size.axis(1)','%d\0',ns)
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 parameters
c
scale=1.0
ier=fdds_scanf('scale','%f\0',scale)
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('\n\0')
c
c=======================================================================
c open the output file
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 FROM INPUT DICTIONARY
c 'fddx_out' function:
c This function will create an output dataset from the input
c binary, passing all it's history information along.
c The user can override the output format and binary data by
c defining "out_format=" or "out_data=" since the first
c argument is 'out'.
c
c With the output convenience routines, the binaries are not
c actually opened until the binary tag is first used for I/O.
c This way the internal buffer definitions for the output file
c can be redefined (eg. axis, size, delta, origin...). So no
c need to check out_bin until after it really gets opened.
c
out_bin=fddx_out('out','stdout:',title,in_bin)
c
c FORCE OPEN THE OUTPUT BINARIES
c 'fdds_lseek' function:
c This function seeks to a specific trace position. It is used
c here simply to force open the internal and output binaries.
c Now we can check if it was really opened.
c
ier=fdds_lseek(out_bin,0,0,SEEK_SET)
if (ier.lt.0) then
ier=fdds_prterr('Unable to open output\n\0')
goto 900
endif
c
c=======================================================================
c allocate dynamic arrays
c=======================================================================
c
if (fdds_errors().ne.0) goto 900
c
c Allocate memory for a single trace
c
c ALLOCATE DYNAMIC ARRAYS
c 'fdds_malloc' function:
c This function allocates memory or reports an error & aborts.
c Storage can be released by calling "fdds_free".
c
ptr_databuf=fdds_malloc(ns * SIZEOF_REAL)
c
c=======================================================================
c process the data
c=======================================================================
c
if (fdds_errors().ne.0) goto 900
c
call doit(in_bin,out_bin,ns,scale,databuf)
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(out_bin)
c
ier=fdds_closepr()
end
c
c***********************************************************************
c
c doit
c
c***********************************************************************
c
subroutine doit(in_bin,out_bin,ns,scale,databuf)
c
implicit none
c
#include <fdds.h>
c
integer in_bin,out_bin
integer ns
real scale
real databuf(ns)
c
integer ier,is
c
c loop over each trace
c
c
c READ DATA
c 'fddx_read' function:
c This function reads a specified number of traces.
c Check the number read in case of any problems.
c
ier=fddx_read(in_bin,databuf,1)
do while(ier.eq.1)
c
c process the trace
c
do is=1,ns
databuf(is)=scale*databuf(is)
enddo
c
c WRITE DATA
c 'fddx_write' function:
c This function writes a specified number of traces.
c Check the number written in case of any problems.
c
ier=fddx_write(out_bin,databuf,1)
if (ier.ne.1) then
ier=fdds_prterr('writing output\n\0')
return
endif
c
c read the next trace
c
ier=fddx_read(in_bin,databuf,1)
enddo
c
return
end