| DDS Developers Documentation → Fortran Templates → Complex Convenience |
 Simple Convenience |  Fortran Templates | MPI Convenience  |
VII. Fortran Templates C. Complex Convenience
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 3
c
c FORTRAN TEMPLATE DEMONSTRATING THE USE OF DDS CONVENIENCE
c ROUTINES FOR MULTIPLE INPUT AND OUTPUT DATASETS REFERENCING
c INPUT HEADERS AND CREATING NEW OUTPUT HEADERS. THIS ALSO
c INCLUDES AN OPTIONAL INPUT DATASET AND READING A FULL VOLUME
c DATASET.
c
c This may have become pretty busy trying to show several different
c techniques in this one template.
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 template3
c
implicit none
c
c INCLUDE THE DDS API (Application Program Interface)
c
#include <fdds.h>
c
integer in_bin,aux_bin,out_bin
integer ier,ibeta,n1_out,nh
integer n1,n2,n3,n4,n1_aux,n2_aux,n3_aux,n1_vel,n2_vel,n3_vel
integer rank,insmpl,outsmpl,nbytes,nwrds
integer vsize(RANK_MAX)
logical check
real scale,d1_out,dh
real d1,d2,d3,d1_vel,d2_vel,d3_vel
real o1,o2,o3,o1_vel,o2_vel,o3_vel
real vdelta(RANK_MAX),vorigin(RANK_MAX)
character*16 genus,ctype,axis(3)
character*80 title
c
real indata(1),auxdata(1),vel(1),outdata(1)
pointer (ptr_indata,indata)
pointer (ptr_auxdata,auxdata)
pointer (ptr_vel,vel)
pointer (ptr_outdata,outdata)
c
data title/'template3: example of Fortran DDS program'/
data in_bin,aux_bin,out_bin/-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_template3.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_template3', '$Id: f_template3.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_inhdr' function:
c This function opens the input file, with the specified
c headers as integers in the trace buffer followed by the
c other input headers and then the data Samples as real values.
c The user can override the input format and binary data by
c defining "in_format=" and⁄or "in_data=" since the first
c argument is 'in'. If no headers are to be used yet you
c still want to pass them to an output file, use fddx_in2.
c If you simply want to read the Samples and throw away any
c input headers, use fddx_in.
c
in_bin=fddx_inhdr('in','stdin:',title,DDS_REAL,DDS_REAL,
* 'SrPtXC SrPtYC StaCor')
c
c PRINT ERROR MESSAGE
c 'fdds_prterr' function:
c Print an error message to the console (and 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_scank' function:
c With ' ' as the second parameter, just return the number
c of axes defined.
c
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 axis names if needed later
c
ier=fdds_scanf('axis','%s %s %s\0',axis(1),axis(2),axis(3))
c
rank=fdds_scank('axis',' ')
n4=1
ier=fdds_scanf('size.axis(1)','%d\0',n1)
ier=fdds_scanf('size.axis(2)','%d\0',n2)
ier=fdds_scanf('size.axis(3)','%d\0',n3)
ier=fdds_scanf('size.axis(4)','%d\0',n4)
ier=fdds_scanf('delta.axis(1)','%f\0',d1)
ier=fdds_scanf('delta.axis(2)','%f\0',d2)
ier=fdds_scanf('delta.axis(3)','%f\0',d3)
ier=fdds_scanf('origin.axis(1)','%f\0',o1)
ier=fdds_scanf('origin.axis(2)','%f\0',o2)
ier=fdds_scanf('origin.axis(3)','%f\0',o3)
c
if (rank.lt.3.or.rank.gt.4) then
ier=fdds_prterr(
* 'Can only handle 3D or 4D datasets in this program\n\0')
endif
c
c RETRIEVE INDEX OFFSET TO THE SAMPLES
c 'fddx_index' function:
c This function returns an offset index to the input Samples
c in each trace buffer.
c
tag=fdds_member(in_bin,0,'Samples')
ier=fdds_genus(genus,in_bin,tag)
c
insmpl=fddx_index(in_bin,'Samples',DDS_REAL)
if (genus.eq.'complex') then
insmpl=2 * insmpl
endif
c
c=======================================================================
c open optional auxillary input file
c=======================================================================
c
c OPEN THE OPTIONAL INPUT FILE
c 'fddx_in' function:
c This function opens an input file (throwing away any input
c trace headers) and without specifying a default filename (2nd
c argument) will simply return -2 without any errors.
c
aux_bin=fddx_in('aux',' ',title)
if (aux_bin.ge.0) then
ier=fdds_scanf('size.axis(1)','%d\0',n1_aux)
ier=fdds_scanf('size.axis(2)','%d\0',n2_aux)
ier=fdds_scanf('size.axis(3)','%d\0',n3_aux)
if (n1_aux.ne.n1.or.n2_aux.ne.n2.or.n3_aux.ne.n3) then
ier=fdds_prterr(
* '"aux" input dataset not conformable with "in"\n\0')
endif
elseif (aux_bin.ne.-2) then
ier=fdds_prterr('Unable to open aux input\n\0')
endif
c
c=======================================================================
c open and read velocity input file
c=======================================================================
c
c OPEN AND READ THE VELOCITY INPUT FILE
c 'fddx_readall' function:
c This function opens the an file, allocates the buffer, reads
c the entire dataset, and closes the file. This is convenient
c when you need to have an entire dataset in memory. Just be
c aware that the program could abort if it is unable to
c allocate the required memory.
c
ier=fddx_readall('in',ptr_vel,rank,vsize,vdelta,vorigin)
if (ier.lt.0) then
ier=fdds_prterr(
* 'Unable to open "vel" dataset\n\0')
elseif (rank.ne.3.and.n2_vel*n3_vel.ne.1) then
ier=fdds_prterr(
* '"vel" must be 3D or a single velocity function\n\0')
endif
c
n1_vel=vsize(1)
n2_vel=vsize(2)
n3_vel=vsize(3)
d1_vel=vdelta(1)
d2_vel=vdelta(2)
d3_vel=vdelta(3)
o1_vel=vorigin(1)
o2_vel=vorigin(2)
o3_vel=vorigin(3)
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 beta, scale and ctype
c (initialize ibeta & scale defaults; ctype is required)
c
ibeta=7
scale=1.0
ctype=' '
ier=fdds_scanf('beta','%d\0',ibeta)
ier=fdds_scanf('scale','%f\0',scale)
ier=fdds_scanf('type','%s\0',ctype)
if (ier.le.0) then
ier=fdds_prterr('"type" MUST be specified\n\0')
endif
c
c get output file parameters
c
n1_out=n1
d1_out=d1
nh=1
dh=50.0
ier=fdds_scanf('n1_out','%d\0',n1_out)
ier=fdds_scanf('d1_out','%f\0',d1_out)
ier=fdds_scanf('nh','%d\0',nh)
ier=fdds_scanf('dh','%f\0',dh)
c
c RETRIEVE SWITCH PARAMETER
c 'fdds_switch' function:
c This function returns non-zero if specified with nothing or
c "1 y Y yes Yes YES t T true True TRUE"; zero if specified
c with "0 n N no No NO f F false False FALSE"; otherwise it
c returns the default value (2nd argument).
c
check=(fdds_switch('check',0).ne.0)
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 "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 "closepr".
c
ier=fdds_prtmsg('\n*** USER PARAMETERS ***\n\n\0')
ier=fdds_prtmsg('\tbeta =%d\n\0',ibeta)
ier=fdds_prtmsg('\tscale =%g\n\0',scale)
ier=fdds_prtmsg('\ttype =%s\n\0',ctype)
ier=fdds_prtmsg('\tn1_out =%d\n\0',n1_out)
ier=fdds_prtmsg('\td1_out =%g\n\0',d1_out)
ier=fdds_prtmsg('\tnh =%d\n\0',nh)
ier=fdds_prtmsg('\tdh =%g\n\0',dh)
if (check) then
ier=fdds_prtmsg('\tcheck =YES\n\0')
else
ier=fdds_prtmsg('\tcheck =NO\n\0')
endif
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 "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_outhdr' function:
c This function will create an output dataset from the input
c binary passing all it's history information and trace headers
c along. The specified headers can be newly created or
c existing headers and will be in order at the beginning of
c the trace buffer, followed by any other trace headers, and
c last are the Samples. The user can override the output
c format and binary data by defining "out_format=" or
c "out_data=" since the first argument is 'out'. If you
c simply want to pass the headers and Samples along as the
c same data types, use fddx_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_outhdr('out','stdout:',title,in_bin,DDS_REAL,
* DDS_REAL,'RcPtXC RcPtYC StaCor')
c
c MODIFY THE OUTPUT AXIS
c 'fddx_dict' function:
c This function changes the dictionary mode associated with the
c binary tag. If redefining the 'axis', then we need to rescan
c the dictionary to get DDS to reset the axis names internally
c and set it back for printing so we can use the ".axis(1)"
c internal DDS function instead of having to use the actual
c axis names in the definitions.
c
ier=fdds_printf('axis','%s h %s %s\n\0',axis(1),axis(2),
* axis(3))
ier=fddx_dict(out_bin,'scan')
ier=fddx_dict(out_bin,'print')
c
c Only need to defined the parameters that might have changed from
c or are not in the input dataset.
c
ier=fdds_printf('size.axis(1)','%d\n\0',n1_out)
ier=fdds_printf('delta.axis(1)','%f\n\0',d1_out)
ier=fdds_printf('size.h','%d\n\0',nh)
ier=fdds_printf('delta.h','%f\n\0',dh)
ier=fdds_printf('origin.h','0\n\0')
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 can be 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 Now that the output is open, get the index to the output Samples
c
outsmpl=fddx_index(out_bin,'Samples',DDS_REAL)
c
c=======================================================================
c allocate dynamic arrays
c=======================================================================
c
if (fdds_errors().ne.0) goto 900
c
c Allocate memory for an entire input record and a single output
c trace
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 "free".
c
nbytes=fdds_prec(in_bin,0)
nwrds=nbytes/SIZEOF_REAL
ptr_indata=fdds_malloc(n2 * nbytes)
nbytes=fdds_prec(out_bin,0)
ptr_outdata=fdds_malloc(nbytes)
c
c If aux opened, allocate memory for a single aux trace.
c (No headers used, so we know how many Samples there are)
c
if (aux_bin.ge.0) then
ptr_auxdata=fdds_malloc(n1_aux * SIZEOF_REAL)
endif
c
c=======================================================================
c process the data
c=======================================================================
c
if (fdds_errors().ne.0) goto 900
c
call doit(in_bin,aux_bin,out_bin,ibeta,n1_out,nh,n1,n2,n3,
* n4,n1_vel,n2_vel,n3_vel,insmpl,outsmpl,nwrds,check,scale,
* d1_out,dh,d1,d2,d3,d1_vel,d2_vel,d3_vel,o1,o2,o3,o1_vel,
* o2_vel,o3_vel,indata,auxdata,vel,outdata,ctype)
c
c=======================================================================
c close files, clean-up, & exit
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(aux_bin)
ier=fdds_close(out_bin)
c
ier=fdds_closepr()
end
c
c***********************************************************************
c
c doit
c
c***********************************************************************
c
subroutine doit(in_bin,aux_bin,out_bin,ibeta,n1_out,nh,n1,n2,n3,
* n4,n1_vel,n2_vel,n3_vel,insmpl,outsmpl,nwrds,check,scale,
* d1_out,dh,d1,d2,d3,d1_vel,d2_vel,d3_vel,o1,o2,o3,o1_vel,
* o2_vel,o3_vel,indata,auxdata,vel,outdata,ctype)
c
implicit none
c
#include <fdds.h>
c
integer in_bin,aux_bin,out_bin
integer ibeta,n1_out,nh
integer n1,n2,n3,n4,n1_vel,n2_vel,n3_vel
integer insmpl,outsmpl,nwrds
logical check
real scale,d1_out,dh
real d1,d2,d3,d1_vel,d2_vel,d3_vel
real o1,o2,o3,o1_vel,o2_vel,o3_vel
real indata(nwrds,n2)
real auxdata(n1)
real vel(n1_vel,n2_vel,n3_vel)
real outdata(*)
character*(*) ctype
c
integer ier,i1,i2,i3
real srcx,srcy,dead
c
c loop over records
c
do i3=1,n3
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,indata,n2)
if (ier.ne.n2) then
ier=fdds_prterr('reading "in" input\n\0')
return
endif
c
c process a record
c
do i2=1,n2
c
c read an auxillary trace if available
c otherwise use indata
c
if (aux_bin.ge.0) then
ier=fddx_read(aux_bin,auxdata,1)
if (ier.ne.1) then
ier=fdds_prterr('reading "aux" input\n\0')
return
endif
else
do i1=1,n1
auxdata(i1)=indata(insmpl+i1,i2)
enddo
endif
c
c get needed input trace headers
c
srcx=indata(1,i2)
srcy=indata(2,i2)
dead=indata(3,i2)
c
c MAP INPUT HEADERS TO OUTPUT HEADERS
c 'fdds_map' function:
c This function maps the input trace to the output trace.
c Using the open output convenience function, only maps
c trace headers (not "Samples").
c
ier=fdds_map(out_bin,0,outdata,in_bin,0,indata)
c
c process this trace
c
if (dead.ne.30000) then
call algorithm(n1,n2,n3,srcx,srcy,scale,ibeta,check,
* ctype,indata(insmpl+1,i2),auxdata,vel,
* outdata(outsmpl+1))
endif
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,outdata,1)
if (ier.ne.1) then
ier=fdds_prterr('writing output\n\0')
return
endif
enddo
enddo
c
return
end
| Simple Convenience | Fortran Templates | MPI Convenience |