C                                                            <HTML><PRE>
C Subroutine file 'writ.for' to create the output files of complete ray
C tracing
C
C Date: 2005, June 20
C Coded by Ludek Klimes
C
C.......................................................................
C
C This file consists of:
C     WRITB...Block data subroutine defining common blocks /WRITT/,
C             /WRITC/ and /WRITN/ to store the input data on the names
C             of output files.
C             <A HREF="#WRITB">WRITB</A>
C     WRIT1...Subroutine called when starting the complete ray tracing
C             program, and when starting the computation of a new
C             elementary wave.
C             <A HREF="#WRIT1">WRIT1</A>
C     WRIT2...Subroutine called when starting the complete tracing of a
C             new ray.
C             <A HREF="#WRIT2">WRIT2</A>
C     WRIT31..Subroutine storing the computed quantities along a ray,
C             see
C             <A HREF="../../../papers/b88vc200.htm#28">C.R.T.5.5.1</A>.
C             It is called with constant step STORE (see input data
C             in the file 'ray.for') of the independent variable along
C             the ray, and at the points of intersection with interfaces
C             either before and after the transformation.
C             <A HREF="#WRIT31">WRIT31</A>
C     WRIT32..Subroutine storing the computed quantities at specified
C             surfaces, see
C             <A HREF="../../../papers/b88vc200.htm#29">C.R.T.5.5.2</A>.
C             It is called at the points of intersection of the ray
C             with the specified surfaces.
C             <A HREF="#WRIT32">WRIT32</A>
C     WRIT33..Subroutine storing the computed quantities at the
C             endpoints of the individual elementary waves, see
C             <A HREF="../../../papers/b88vc200.htm#29">C.R.T.5.5.3</A>.
C             It is called at the endpoints of the elements of rays,
C             situated at structural interfaces.
C             <A HREF="#WRIT33">WRIT33</A>
C     WRIT4...Subroutine storing the quantities at the initial point of
C             the ray, see
C             <A HREF="../../../papers/b88vc200.htm#52">C.R.T.6.1</A>.
C             It is called after termination of tracing the ray.
C             <A HREF="#WRIT4">WRIT4</A>
C     CHECK...Auxiliary subroutine to WRIT4.
C             <A HREF="#CHECK">CHECK</A>
C     WRIT5...Subroutine called after termination of the computation of
C             an elementary wave, and when terminating the complete ray
C             tracing program.
C             <A HREF="#WRIT5">WRIT5</A>
C     FNAME...Subroutine analyzing the specified strings and composing
C             the filename of them.  Auxiliary subroutine to WRIT1.
C             <A HREF="#FNAME">FNAME</A>
C     WRITTR..Subroutine writing the indices of rays forming the
C             homogeneous triangles in the ray-parameter domain.
C             <A HREF="#WRITTR">WRITTR</A>
C     WRITBR...Subroutine writing the indices of boundary rays.
C             <A HREF="#WRITBR">WRITBR</A>
C
C.......................................................................
C
C Description of data files:
C                                                    <A NAME="data"></A>
C Input data WRIT to specify the names of the output files with the
C computed quantities:
C     The data are read in by the list directed input (free format).
C     The strings have thus to be enclosed in apostrophes.  In the list
C     of input data below, each numbered paragraph indicates
C     the beginning of a new input operation (new READ statement).  All
C     input variables, except K2P, are of the type CHARACTER.
C     The data are read by the subroutine WRIT1.
C     The filenames are generated using several components (strings) in
C     the following way:  Each component (string) is divided into words,
C     each word being followed by just one space.  Here a word is a
C     substring containing no space, preceded and followed by spaces or
C     by the beginning or end of the string.  An empty word lies between
C     two consecutive spaces.  The filename is composed of
C             the 1-st word of the 1-st component,
C             the 1-st word of the 2-nd component,
C             ...
C             the 1-st word of the last component,
C             the 2-nd word of the 1-st component,
C             the 2-nd word of the 2-nd component,
C             ...
C             the last word of the last component.
C     Example:
C             1-st component = 'd/  .out',
C             2-nd component = 'a b',
C             3-rd component = '1 2',
C             resulting filename = 'd/a1b2.out'.
C     Note that only first 16 characters of each filename component are
C     significant.
C (1) 'TEXTW'
C     String describing the data.  Only the first 80 characters of the
C     string are read.
C     Default: TEXTW=' '.
C (2) K2P,/
C     K2P...  If non-zero, only two-point rays are written to the files
C             with quantities stored along rays.  Storage of quantities
C             at specified surfaces is not affected by this parameter.
C     /...    An obligatory slash.
C     Default:  K2P=0.
C (3) 'FN1A','FN1I','FN1T','FN1BR',/
C     'FN1A'... String containing the first component of the name of the
C             output file 'CRT-R' with the computed quantities stored
C             along the rays, see
C             <A HREF="../../../papers/b88vc200.htm#28">C.R.T.5.5.1</A>.
C             <A HREF="#out1">Description of output file C.R.T.5.5.1</A>
C     'FN1I'... String containing the first component of the name of the
C             output file 'CRT-I' with the quantities at the initial
C             points of rays, see
C             <A HREF="../../../papers/b88vc200.htm#52">C.R.T.6.1</A>,
C             related to the output file 'CRT-R' with the computed
C             quantities stored along the rays.  The other components
C             of the filename are common with the related file 'CRT-R'
C             containing the computed quantities.
C             <A HREF="#outi">Description of output file C.R.T.6.1</A>
C     'FN1T'... String containing the first component of the name of the
C             formatted output file 'CRT-T' specifying the homogeneous
C             triangles in the ray-parameter domain.  The other
C             components of the filename are common with the related
C             file 'CRT-R' with the computed quantities along rays.
C             <A HREF="#outt">Description of file with triangles</A>
C     'FN1BR'... String containing the first component of the name of
C             the formatted output file 'CRT-B' specifying the indices
C             of boundary rays.  The other components of the filename
C             are common with the related file 'CRT-R' containing
C             the computed quantities along rays.
C            <A HREF="#outbr">Description of file with boundary rays</A>
C     /...    An obligatory slash.
C     Default: all strings blank.
C (4) 'FN2A','FN2I',('FN2B(I)',I=1,NENDF),/
C     'FN2A'... String containing the first component of the name of the
C             output file 'CRT-S' with the computed quantities stored at
C             the specified surfaces, see
C             <A HREF="../../../papers/b88vc200.htm#29">C.R.T.5.5.2</A>.
C             <A HREF="#out2">Description of output file C.R.T.5.5.2</A>
C     'FN2I'... String containing the first component of the name of the
C             output file 'CRT-I' with the quantities at the initial
C             points of rays, see
C             <A HREF="../../../papers/b88vc200.htm#52">C.R.T.6.1</A>,
C             related to the output file 'CRT-S' with the computed
C             quantities stored at the specified surfaces.  The other
C             components of the filename are common with the related
C             file 'CRT-S' containing the computed quantities.
C             <A HREF="#outi">Description of output file C.R.T.6.1</A>
C     'FN2B(I)'... String containing the second component of the name of
C             the output file 'CRT-S' with the computed quantities
C             stored at the I-th specified surface.  Here NENDF is
C             the number of surfaces specified for storing the computed
C             quantities.
C     /...    An obligatory slash.
C     Default: all strings blank.
C (5) Either (5.1) or (5.2):
C (5.1) /
C     A slash is fully sufficient if MODCRT.LE.1,
C     see <A HREF="ray.for#data">input data set DCRT</A>.
C     If MODCRT.LE.1, the filenames (5.2) are ignored if specified.
C     If MODCRT.GE.2, the filenames (5.2) are obligatory.
C (5.2) 'FN3A','FN3I',('FN3B(I)',I=1,NELEM),/
C     'FN3A'... String containing the first component of the name of the
C             output file 'CRT-E' with the computed quantities stored
C             at the endpoints of the elements of rays, see
C             <A HREF="../../../papers/b88vc200.htm#29">C.R.T.5.5.3</A>.
C             <A HREF="#out3">Description of output file C.R.T.5.5.3</A>
C     'FN3I'... String containing the first component of the name of the
C             output file 'CRT-I' with the quantities at the initial
C             points of rays, see
C             <A HREF="../../../papers/b88vc200.htm#52">C.R.T.6.1</A>,
C             related to the output file 'CRT-E' with the computed
C             quantities stored at the endpoints of the elements
C             of rays.  The other components of the filename are common
C             with the related file 'CRT-E' containing the computed
C             quantities.
C             <A HREF="#outi">Description of output file C.R.T.6.1</A>
C     'FN3B(I)'... String containing the second component of the name of
C             the output file 'CRT-E' with the computed quantities
C             stored at the endpoints of the I-th element of rays.
C             None of the strings FN3B(I), corresponding to the endpoint
C             of a ray element at which quantities are stored, may equal
C             spaces for MODCRT.GE.2.
C     /...    An obligatory slash.
C     Default: all strings blank.
C (6) For each elementary wave IWAVE the following data (6.1):
C (6.1) 'FN1C','FN2C','FN3C',('FN2D(I)',I=1,NENDF),/
C     'FN1C'... String containing the second component of the name of
C             the output file 'CRT-R' with the computed quantities
C             stored along the rays, see
C             <A HREF="../../../papers/b88vc200.htm#28">C.R.T.5.5.1</A>.
C     'FN2C'... String containing the third component of the name of the
C             output file 'CRT-S' with the computed quantities stored at
C             the specified surfaces, see
C             <A HREF="../../../papers/b88vc200.htm#29">C.R.T.5.5.2</A>.
C     'FN3C'... String containing the third component of the name of the
C             output file 'CRT-E' with the computed quantities stored at
C             the endpoints of the elements of rays, see
C             <A HREF="../../../papers/b88vc200.htm#29">C.R.T.5.5.3</A>.
C             This string may not equal spaces for MODCRT.GE.2.
C             If MODCRT.LE.1, the file is not created.
C     'FN2D(I)'... String containing the fourth component of the name of
C             the output file 'CRT-S' with the computed quantities
C             stored at the I-th specified surface, see
C             <A HREF="../../../papers/b88vc200.htm#29">C.R.T.5.5.2</A>.
C             Here NENDF is the number of surfaces specified for storing
C             the computed quantities.
C     /...    An obligatory slash.
C     Default: all strings blank.
C Following table summarizes the components, of which the individual
C filenames of the output files are composed:
C       Output file:                Components:
C     'CRT-R'                   FN1A +            FN1C(IW)
C     corresponding 'CRT-I'     FN1I +            FN1C(IW)
C     corresponding 'CRT-T'     FN1T +            FN1C(IW)
C     corresponding 'CRT-B'     FN1BR+            FN1C(IW)
C     'CRT-S'                   FN2A + FN2B(IS) + FN2C(IW) + FN2D(IS,IW)
C     corresponding 'CRT-I'     FN2I + FN2B(IS) + FN2C(IW) + FN2D(IS,IW)
C     'CRT-E'                   FN3A + FN3B(IE) + FN3C(IW)
C     corresponding 'CRT-I'     FN3I + FN3B(IE) + FN3C(IW)
C   IW is a total index of elementary wave, IW=NWAVE*(ISRC-1)+IWAVE,
C   where ISRC is index of the source, IWAVE is the index of
C   the elementary wave for source ISRC, and NWAVE is the number of
C   elementary waves to be calculated for each source.
C   IS is an index of a storing surface, IS=1,NENDF.
C   IE is an index of a storing element, IE=1,NELEM.
C Notes:
C   If the first component of the name of any of the CRT output
C     files is blank, the file is not created.
C   File 'CRT-S' and corresponding file 'CRT-I' are not created if
C     FN2B(IS), FN2C(IW) and FN2D(IS,IW) are all blank.
C   The components FN1A, FN1I, FN1T and FN1BR must be mutually
C     different, if they are not blank.
C   The components FN2A and FN2I must differ, if they are not blank.
C   The components FN3A and FN3I must differ, if they are not blank.
C
C Examples of data set WRIT:
C     <A HREF="writ.dat"   >writ.dat   </A> two-point rays stored.
C     <A HREF="writall.dat">writall.dat</A> all rays stored.
C     <A HREF="writsrf.dat">writsrf.dat</A> no rays stored.
C In the above examples, the computed quantities at specified surfaces
C are stored.
C
C The names of the output files of program 'crt.for' are specified here
C in the input data WRIT.  On the other hand, the programs processing
C the results of complete ray tracing assume the names of the same
C output files of program 'crt.for' to be specified in file CRTOUT
C formatted as follows:
C                                                  <A NAME="CRTOUT"></A>
C General description of formatted file CRTOUT:
C     The file consists of character strings to be read by list directed
C     (free format) input.  The strings have thus to be enclosed in
C     apostrophes.
C (1) For each set of CRT output files data record (1.1):
C (1.1) 'CRT-R','CRT-S','CRT-I','CRT-T','CRT-B',/
C     'CRT-R'.. Name of the unformatted CRT output file with the
C             quantities stored along rays, see
C             <A HREF="../../../papers/b88vc200.htm#28">C.R.T.5.5.1</A>.
C             <A HREF="writ.for#out1">Description of file 'CRT-R'</A>
C     'CRT-S'.. Name of the unformatted CRT output file with the
C             quantities stored at the points of intersections of rays
C             with the specified surfaces, see
C             <A HREF="../../../papers/b88vc200.htm#29">C.R.T.5.5.2</A>.
C             <A HREF="writ.for#out2">Description of file 'CRT-S'</A>
C     'CRT-I'.. Name of the unformatted CRT output file with the
C             quantities at the initial points of rays, see
C             <A HREF="../../../papers/b88vc200.htm#52">C.R.T.6.1</A>.
C             <A HREF="writ.for#outi">Description of file 'CRT-I'</A>
C     'CRT-T'.. Name of the formatted CRT output file with the
C             homogeneous triangles in the ray-parameter domain.
C             <A HREF="writ.for#outt">Description of file 'CRT-T'</A>
C     'CRT-B'.. Name of the formatted CRT output file with the
C             indices of boundary rays.
C             <A HREF="writ.for#outbr">Description of file 'CRT-B'</A>
C     /...    An obligatory slash.
C     General defaults for the first set of the CRT output files:
C             The defaults may be blank or following:
C             'CRT-R'='r01.out', 'CRT-S'='s01.out', 'CRT-I'='r01i.out'
C             or 'CRT-I'='s01i.out', 'CRT-T'='t01.out', 'CRT-B'=' '
C     General defaults for the subsequent sets:
C             'CRT-R'=' ', 'CRT-S'=' ', 'CRT-I'=' ', 'CRT-T'=' ',
C             'CRT-B'=' '
C (2) / (a slash or the end of file).
C     The end of the data is also assumed if all filenames are blank.
C
C                                                    <A NAME="out1"></A>
C Output files 'CRT-R' with the computed quantities stored along the
C rays, see <A HREF="../../../papers/b88vc200.htm#28">C.R.T.5.5.1</A>.
C     Unformatted output.  The computed quantities are stored with the
C     step STORE (see the input data in the subroutine file 'ray.for')
C     along all rays, and at all points of intersection of rays with
C     structural interfaces either before and after the transformation.
C     For each point - one record containing the following quantities:
C (1) ISRC,IWAVE,IRAY,NY,ICB1,ISRF,X,(YL(I),I=1,6),(Y(I),I=1,NY)
C     ISRC .. Index of the source.
C     IWAVE...Index of the elementary wave (output of the subroutine
C             CODE1).  Elementary waves are indexed by 1,2,3,... .
C     IRAY... Index of the ray (output of the subroutine RPAR2).  Rays
C             within each elementary wave are indexed by 1,2,3,... .
C             Note that some of the indexed rays need not exist.
C     NY=IY(1)=27+NAMPL... Number of the basic quantities describing the
C             point of the ray, see the file 'ray.for'.
C     ICB1=IY(5)... Index of the complex block in which the stored point
C             of the ray is situated, supplemented by a sign '+' for P
C             wave and sign '-' for S wave.
C     ISRF=IY(6)... Index of the surface at which the endpoint of the
C             computed element of the ray is situated, supplemented by
C             a sign '+' or '-' for the endpoint situated at the
C             positive or negative side of the surface, respectively.
C             Zero inside the complex block.  Note: the sign of this
C             quantity is the exception to the definition in the
C             original paper on C.R.T.
C     X...    Independent variable along a ray, see YY(1) in
C             <A HREF="../../../papers/b88vc200.htm#24">C.R.T.5.2.2</A>.
C     YL...   Array containing local quantities at the point of the ray,
C             see
C             <A HREF="../../../papers/b88vc200.htm#30">C.R.T.5.5.4</A>.
C             <A HREF="ray.for#YL">Description of YL</A>
C     Y...    Array containing basic quantities computed along the ray,
C             see
C             <A HREF="../../../papers/b88vc200.htm#23">C.R.T.5.2.1</A>.
C             <A HREF="ray.for#Y">Description of Y</A>
C     The detailed description of the quantities YL, YY and IY may be
C     found in the file 'ray.for'.
C
C                                                    <A NAME="out2"></A>
C Output files 'CRT-S' with the computed quantities stored at the
C specified surfaces, see
C <A HREF="../../../papers/b88vc200.htm#29">C.R.T.5.5.2</A>.
C     Unformatted output.  The computed quantities are stored at the
C     points of intersection of rays with the specified surfaces.
C     For each point - one record containing the following quantities:
C (1) ISRC,IWAVE,IRAY,NY,ICB1,ISRF,X,(YL(I),I=1,6),(Y(I),I=1,NY)
C     The same quantities as in the data set described above, except
C     that the vectorial reduced amplitudes Y(28)-Y(IY(1)) may (but need
C     not) be replaced by the reduced amplitudes YC(1) to YC(NY-27)
C     involving appropriate conversion coefficients, see
C     <A HREF="../../../papers/b88vc200.htm#30">C.R.T.5.5.4</A>.
C     YC(1) to YC(NY-27) are described in the subroutine CONV (file
C     'trans.for') and in the subroutine WRIT32 (this file).  Note that
C     NY=33 for P wave and NY=39 for S wave at the initial point of the
C     ray.
C
C                                                    <A NAME="out3"></A>
C Output files 'CRT-E' with the computed quantities stored at the
C endpoints of the elements of rays, see
C <A HREF="../../../papers/b88vc200.htm#29">C.R.T.5.5.3</A>.
C     Unformatted output.  The files, generated only if KSTORE.GE.2 (see
C     input data in the subroutine file 'ray.for'),  are auxiliary disk
C     storage locations to the program CRT and are not intended to be
C     the output of the complete ray tracing used by the user
C     application programs.  The computed quantities are stored at the
C     endpoints of the elements of all rays before the transformation.
C     For each point - one record containing the following quantities:
C (1) IRAY,(IY(I),I=1,12),(YL(I),I=1,6),(Y(I),I=1,IY(1)),(YY(I),I=1,5)
C     IRAY... Index of the ray (output of the subroutine RPAR2).  Rays
C             within each elementary wave are indexed by 1,2,3,... .
C             Note that some of the indexed rays may not exist.
C     YL...   Array containing local quantities at the point of the ray,
C             see
C             <A HREF="../../../papers/b88vc200.htm#30">C.R.T.5.5.4</A>.
C             <A HREF="ray.for#YL">Description of YL</A>
C     Y...    Array containing basic quantities computed along the ray,
C             see
C             <A HREF="../../../papers/b88vc200.htm#23">C.R.T.5.2.1</A>.
C             <A HREF="ray.for#Y">Description of Y</A>
C     YY...   Array containing real auxiliary quantities computed along
C             the ray, see
C             <A HREF="../../../papers/b88vc200.htm#24">C.R.T.5.2.2</A>.
C             <A HREF="ray.for#YY">Description of YY</A>
C     IY...   Array containing integer auxiliary quantities computed
C             along the ray, see
C             <A HREF="../../../papers/b88vc200.htm#24">C.R.T.5.2.2</A>.
C             <A HREF="ray.for#IY">Description of IY</A>
C     The detailed description of the quantities YL, Y, YY and IY may be
C     found in the file 'ray.for'.
C
C                                                    <A NAME="outi"></A>
C Output files 'CRT-I' with the quantities at the initial points of
C rays, see <A HREF="../../../papers/b88vc200.htm#52">C.R.T.6.1</A>.
C     Unformatted output.  The quantities are stored at the initial
C             points of rays.
C     For whole rays ('CRT-R'), only initial points of two-point
C             rays are stored if only two-point rays are stored.
C     For intersections with surfaces ('CRT-S') and endpoints of the
C             elements of rays ('CRT-E') initial points of all rays
C             are stored.
C     For initial point - one record containing following 34 quantities:
C (1) ISRC,-IWAVE,IRAY,ICB1I,IEND,ISHEET,IREC,(YLI(I),I=1,6),
C     (YI(I),I=1,29)
C     ISRC .. Index of the source.
C     IWAVE...Index of the elementary wave (output of the subroutine
C             CODE1).  Elementary waves are indexed by 1,2,3,... .
C     IRAY... Index of the ray (output of the subroutine RPAR2).  Rays
C             within each elementary wave are indexed by 1,2,3,... .
C             Note that some of the indexed rays may not exist.
C     ICB1I...Index of the complex block in which the initial point of
C             the ray is situated, supplemented by a sign '+' for P wave
C             and sign '-' for S wave, see
C             <A HREF="../../../papers/b88vc200.htm#52">C.R.T.6.1</A>.
C     IEND... Reason of the termination of the computation of a ray, see
C             <A HREF="../../../papers/b88vc200.htm#27">C.R.T.5.4</A>.
C             See subroutine RAY in the subroutine file 'ray.for' for
C             <A HREF="ray.for#IEND">detailed description of IEND</A>.
C     ISHEET..Ray-history index.  The different ray histories are
C             consecutively indexed by positive integers 1,2,3,...
C             According to their appearance during ray tracing.
C             The ray histories are indexed independently within each
C             elementary wave.  The indices are the output of subroutine
C             RPAR4 of the file 'rpar.for'.
C             The ray-history indices are complemented with sign:
C             Positive - successful ray (crossing reference surface),
C             negative - unsuccessful ray (terminating before crossing
C             reference surface).
C     IREC... Index of the receiver for a two-point ray, determined in
C             subroutine <A HREF="rpar.for#IREC">RPAR4</A>.
C     YLI...  Array containing the values of the quantities YL(1)-YL(6),
C             see
C             <A HREF="../../../papers/b88vc200.htm#30">C.R.T.5.5.4</A>,
C             describing the local properties of the model at the
C             initial point of the ray.   See the list of YL(1) to YL(6)
C             in the file 'ray.for'.
C             <A HREF="ray.for#YL">Description of YL</A>
C     YI...   Array containing the quantities describing the properties
C             of the rays and of the travel-time field at the initial
C             point of the ray, see
C             <A HREF="../../../papers/b88vc200.htm#52">C.R.T.6.1</A>.
C             These quantities are listed in the file 'init.for'.
C             <A HREF="initc.inc#YI">Description of YI</A>
C
C                                                    <A NAME="outt"></A>
C Output files 'CRT-T' specifying homogeneous triangles in the
C ray-parameter domain. Formatted output, each record containing
C three integers:
C (1) For each elementary wave IWAVE the following data (1.1) and (1.2):
C (1.1) 0,ISRC,IWAVE
C     0  ...  Zero identifying new elementary wave.
C     ISRC .. Index of the source.
C     IWAVE . Index of the elementary wave.
C (1.2) For each homogeneous triangle of the elementary wave
C     data (1.2.1):
C (1.2.1) IRAY1,IRAY2,IRAY3
C     IRAY1,IRAY2,IRAY3... Indices of rays forming the vertices of the
C             homogeneous triangle.
C             For one-parametric (2-D) systems of rays, triangles are
C             replaced with intervals and IRAY3=0.
C
C                                                   <A NAME="outbr"></A>
C Output file 'CRT-B' specifying indices of boundary rays.
C Formatted output, each record containing four integers:
C (1) For each elementary wave IWAVE the following data (1.1) and (1.2):
C (1.1) 0,0,ISRC,IWAVE
C     0  ...  Zero identifying new elementary wave.
C     0  ...  Zero.
C     ISRC .. Index of the source.
C     IWAVE . Index of the elementary wave.
C (1.2) For each boundary ray data (1.2.1):
C (1.2.1) IB1,IB2,IB3,IB4
C     IB1 ... Index of the boundary ray.
C     IB2 ... Index of the boundary ray coupled with IB1.
C     IB3,IB4 . Indices of two boundary rays equal in history with IB1,
C             coupled with rays equal in history with IB2, and connected
C             with boundary ray IB1 by sides of homogeneous triangles.
C             IB4=0 if there is only one ray of the described
C             properties.
C             IB3=0 and IB4=0 if there is no ray of the described
C             properties, and for one-parametric shooting in 2-D.
C
C.......................................................................
C
C Storage in the memory:
C     The input data WRIT (2) to (6) describing the names of the output
C     files with the computed quantities are stored in the common block
C     /WRITT/.  Other important variables shared by the subroutines of
C     this file are stored in the common blocks /WRITC/ and /WRITN/.
C     The common blocks are defined in the following subroutine:
C     ------------------------------------------------------------------
C     <A NAME="WRITB"></A>
C
      BLOCK DATA WRITB
      INCLUDE 'writ.inc'
C     <A HREF="writ.inc">writ.inc</A>
      DATA LUW/10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,
     *         26,27,28,29,30,31,32,33,34,35,36,37,38,39/
      DATA JENDR/10,21,22,23,24,25,26,30,32,33,37,39,
     *           40,50,60,61,71,72,73,74/
      END
C     ------------------------------------------------------------------
C
C=======================================================================
C
C     <A NAME="WRIT1"></A>
C
      SUBROUTINE WRIT1(LUN,LULOG,IWAVE,IWAVE0,IKODE)
      INTEGER LUN,LULOG,IWAVE,IWAVE0,IKODE
C
C This subroutine is called when starting the complete ray tracing
C program, and when starting the computation of a new elementary wave.
C
C Input:
C     LUN...  Logical unit number of the external input device
C             containing the input data.
C     LULOG...Logical unit number of the log output device.
C     IWAVE...Zero when starting the complete ray tracing program,
C             otherwise the index of the elementary wave which will be
C             computed (i.e. the output of the subroutine CODE1 from the
C             file 'code.for').
C     IWAVE0..Index of the already computed elementary wave having the
C             most numerous common elements with the current elementary
C             wave.  Need not be defined if IWAVE=0.
C     IKODE...The length of the common part of the codes of the IWAVE-th
C             and IWAVE0-th elementary waves.  Need not be defined if
C             IWAVE=0.
C
C No output.
C
C Common block /DCRT/ (see subroutine file 'ray.for'):
      INCLUDE 'dcrt.inc'
C     <A HREF="dcrt.inc">dcrt.inc</A>
C None of the storage locations of the common block are altered.
C
C Common blocks /WRITT/, /WRITC/ and /WRITN/:
      INCLUDE 'writ.inc'
C     <A HREF="writ.inc">writ.inc</A>
C All the storage locations of the common blocks are defined in this
C subroutine.
C
C Subroutines and external functions required:
      INTEGER LCODE,NELEM
      EXTERNAL WRITB,LCODE,NELEM,SCRO1,FNAME
C     WRITB.. Block data subroutine of this file.
C     LCODE,NELEM... File 'code.for'.
C     SCRO1...One of files 'scro*.for'.
C     FNAME... This file.
C
C Date: 2005, June 20
C Coded by Ludek Klimes
C
C-----------------------------------------------------------------------
C
C     Auxiliary storage locations:
      INTEGER NKODE,IE1,IE2,I,J
      CHARACTER*16 NAME1(4)
C
      IF(IWAVE.LE.0) THEN
C
C       Initiating the source index
        ISRC=1
C
C       Reading the name of the input data
        TEXTW=' '
        READ(LUN,*) TEXTW
C
        K2P=0
        READ(LUN,*) K2P
C
C       Reading strings composing the names of output files (CRT.5.5.1)
        FN1A=' '
        FN1I=' '
        FN1T=' '
        FN1BR=' '
        READ(LUN,*) FN1A,FN1I,FN1T,FN1BR
C       Number of output files to be open
        IF(STORE.EQ.0.) THEN
          NF1=0
        ELSE
          NF1=1
        END IF
C
C       Reading strings composing the names of output files (CRT.5.5.2)
        FN2A=' '
        FN2I=' '
        DO 21 I=1,MF
          FNB(I)=' '
   21   CONTINUE
        READ(LUN,*) FN2A,FN2I,(FNB(I),I=1,MF)
C       Number of output files to be open
        NF2=NSTOR
        IF(2*(NF1+NF2).GT.NUW) THEN
C         <A NAME="error553.1"></A><FONT COLOR="RED">553.1</FONT>
          CALL ERROR('553.1 in WRIT1: Few logical units available')
C         There are NUW logical units available, see the common
C         blocks /WRITC/ and /WRITN/ defined in the block data
C         WRITB.  This number should be increased.
        END IF
C
C       Reading strings composing the names of output files (CRT.5.5.3)
        FN3A=' '
        FN3I=' '
        DO 31 I=NF2+1,MF
          FNB(I)=' '
   31   CONTINUE
        READ(LUN,*) FN3A,FN3I,(FNB(I),I=NF2+1,MF)
C       Number of output files to be open
        IF(MODCRT.LE.1) THEN
          MF3=0
        ELSE
          DO 32 I=NF2+1,MF
            IF(FNB(I).EQ.' ') THEN
              MF3=I-1-NF2
              GO TO 33
            END IF
   32     CONTINUE
          MF3=MF-NF2
   33     CONTINUE
        END IF
C
        IF ( ((FN1A .NE.' ').AND.
     *     ((FN1A .EQ.FN1I).OR.(FN1A .EQ.FN1T).OR.(FN1A .EQ.FN1BR))).OR.
     *       ((FN1I .NE.' ').AND.
     *     ((FN1I .EQ.FN1A).OR.(FN1I .EQ.FN1T).OR.(FN1I .EQ.FN1BR))).OR.
     *       ((FN1T .NE.' ').AND.
     *     ((FN1T .EQ.FN1A).OR.(FN1T .EQ.FN1I).OR.(FN1T .EQ.FN1BR))).OR.
     *       ((FN1BR.NE.' ').AND.
     *     ((FN1BR.EQ.FN1A).OR.(FN1BR.EQ.FN1I).OR.(FN1BR.EQ.FN1T ))).OR.
     *       ((FN2A.NE.' ').AND.(FN2A.EQ.FN2I)).OR.
     *       ((FN3A.NE.' ').AND.(FN3A.EQ.FN3I)) ) THEN
C         <A NAME="error554"></A><FONT COLOR="RED">554</FONT>
          CALL ERROR('554 in WRIT1: Equal first filename components.')
C         The components FN1A, FN1I, FN1T and FN1BR must be mutually
C         different, if they are not blank. Similarly FN2A and FN2I must
C         differ, and FN3A and FN3I must differ, if they are not blank.
        ENDIF
C
      ELSE
C
C       Updating the source index
        IF(IWAVE.LE.JWAVE) THEN
          ISRC=ISRC+1
        END IF
C
C       Numbers of initial ray elements along which nothing is stored
        IF(MODCRT.EQ.0) THEN
          KWRIT1=0
        ELSE
          KWRIT1=NELEM(IKODE)
        END IF
        KWRIT2=KWRIT1
        IF(MODCRT.LE.1) THEN
          KWRIT3=999999
        ELSE
          KWRIT3=NELEM(IKODE)
        END IF
C
C       Reading strings composing the names of output files
        DO 41 I=JWAVE+1,IWAVE-1
          READ(LUN,*,END=98) FN1C,FN2C,FN3C,(FN2D(J),J=1,MF)
   41   CONTINUE
        FN1C=' '
        FN2C=' '
        FN3C=' '
        DO 42 I=1,MF
          FN2D(I)=' '
   42   CONTINUE
        READ(LUN,*,END=98) FN1C,FN2C,FN3C,(FN2D(I),I=1,MF)
C
C       Opening the output files (CRT.5.5.1)
        IF(NF1.NE.0.) THEN
          NAME1(1)=FN1A
          NAME1(2)=FN1C
          NAME2(1)=' '
          IF(FN1A.NE.' ') THEN
            CALL FNAME(2,NAME1,NAME2(1))
            OPEN(LUW(1),FILE=NAME2(1),FORM='UNFORMATTED',IOSTAT=IE1)
            IF(IE1.NE.0) THEN
C             <A NAME="error551.1"></A><FONT COLOR="RED">551.1</FONT>
C             Open file error
              IE2=1
              J=1
              GO TO 91
            END IF
          END IF
          NAME1(1)=FN1I
          NAME2(2)=' '
          IF(FN1I.NE.' ') THEN
            CALL FNAME(2,NAME1,NAME2(2))
            OPEN(LUW(2),FILE=NAME2(2),FORM='UNFORMATTED',IOSTAT=IE1)
            IF(IE1.NE.0) THEN
C             <A NAME="error551.4"></A><FONT COLOR="RED">551.4</FONT>
C             Open file error
              IE2=4
              J=2
              GO TO 91
            END IF
          END IF
        END IF
C
C       Opening the output files (CRT.5.5.2)
        DO 44 I=1,NF2
          NAME1(1)=FN2A
          NAME1(2)=FNB(I)
          NAME1(3)=FN2C
          NAME1(4)=FN2D(I)
          IF(NAME1(2).EQ.' '.AND.NAME1(3).EQ.' '.AND.NAME1(4).EQ.' ')
     *                                                              THEN
            NAME1(1)=' '
          END IF
          J=2*(NF1+I)-1
          NAME2(J)=' '
          IF(FN2A.NE.' ') THEN
            CALL FNAME(4,NAME1,NAME2(J))
            IF(NAME2(J).NE.' ') THEN
              OPEN(LUW(J),FILE=NAME2(J),FORM='UNFORMATTED',IOSTAT=IE1)
              IF(IE1.NE.0) THEN
C               <A NAME="error551.2"></A><FONT COLOR="RED">551.2</FONT>
C               Open file error
                IE2=2
                GO TO 91
              END IF
            END IF
          END IF
          NAME1(1)=FN2I
          IF(NAME1(2).EQ.' '.AND.NAME1(3).EQ.' '.AND.NAME1(4).EQ.' ')
     *                                                              THEN
            NAME1(1)=' '
          END IF
          J=2*(NF1+I)
          NAME2(J)=' '
          IF(FN2I.NE.' ') THEN
            CALL FNAME(4,NAME1,NAME2(J))
            IF(NAME2(J).NE.' ') THEN
              OPEN(LUW(J),FILE=NAME2(J),FORM='UNFORMATTED',IOSTAT=IE1)
              IF(IE1.NE.0) THEN
C               <A NAME="error551.5"></A><FONT COLOR="RED">551.5</FONT>
C               Open file error
                IE2=5
                GO TO 91
              END IF
            END IF
          END IF
   44   CONTINUE
C
C       Opening the output files (CRT.5.5.3)
        NF3=0
        IF(MODCRT.GE.2) THEN
          IF(FN3C.EQ.' ') THEN
C           <A NAME="error557"></A><FONT COLOR="RED">557</FONT>
            CALL ERROR('557 in WRIT1: Few filenames specified')
C           There are more required elementary waves than the
C           corresponding specified filenames.
          ELSE
            NKODE=NELEM(LCODE())
C           NKODE is the number of ray elements
            IF(MODCRT.GE.3) NKODE=MIN0(KWRIT3+1,NKODE)
C           NKODE is the index of the last ray element to be stored
            NF3=NKODE-KWRIT3
            IF(NF3.GT.MF3) THEN
C             <A NAME="error556"></A><FONT COLOR="RED">556</FONT>
              CALL ERROR('556 in WRIT1: Few filenames specified')
C             There are more elements of the rays of an elementary wave
C             than the corresponding specified filenames.
            ELSE IF(2*(NF1+NF2+NF3).GT.NUW) THEN
C             <A NAME="error553.2"></A><FONT COLOR="RED">553.2</FONT>
              CALL ERROR('553.2 in WRIT1: Few logical units available')
C             There are NUW logical units available, see the common
C             blocks /WRITC/ and /WRITN/ defined in the block data
C             WRITB.  This number should be increased.
            END IF
            DO 45 I=1,NF3
              NAME1(1)=FN3A
              NAME1(2)=FNB(KWRIT3+I)
              NAME1(3)=FN3C
              J=2*(NF1+NF2+I)-1
              NAME2(J)=' '
              IF(FN3A.NE.' ') THEN
                CALL FNAME(3,NAME1,NAME2(J))
                OPEN(LUW(J),FILE=NAME2(J),FORM='UNFORMATTED',IOSTAT=IE1)
                IF(IE1.NE.0) THEN
C                 <A NAME="error551.3"></A>
C                 <FONT COLOR="RED">551.3</FONT>
C                 Open file error
                  IE2=3
                  GO TO 91
                END IF
              END IF
              NAME1(1)=FN3I
              J=2*(NF1+NF2+I)
              NAME2(J)=' '
              IF(FN3I.NE.' ') THEN
                CALL FNAME(3,NAME1,NAME2(J))
                OPEN(LUW(J),FILE=NAME2(J),FORM='UNFORMATTED',IOSTAT=IE1)
                IF(IE1.NE.0) THEN
C                 <A NAME="error551.6"></A>
C                 <FONT COLOR="RED">551.6</FONT>
C                 Open file error
                  IE2=6
                  GO TO 91
                END IF
              END IF
   45       CONTINUE
          END IF
        END IF
C
C       Opening the output file with homogeneous triangles:
        J=2*(NF1+NF2+NF3)+1
        IF (J.GT.NUW) THEN
C         <A NAME="error553.3"></A><FONT COLOR="RED">553.3</FONT>
          CALL ERROR('553.3 in WRIT1: Few logical units available')
C         There are NUW logical units available, see the common
C         blocks /WRITC/ and /WRITN/ defined in the block data
C         WRITB.  The number NUW should be increased.
        ENDIF
        NAME2(J)=' '
        IF(FN1T.NE.' ') THEN
          NAME1(1)=FN1T
          NAME1(2)=FN1C
          CALL FNAME(2,NAME1,NAME2(J))
          OPEN(LUW(J),FILE=NAME2(J),FORM='FORMATTED',IOSTAT=IE1)
          IF(IE1.NE.0) THEN
C           <A NAME="error551.7"></A><FONT COLOR="RED">551.7</FONT>
C           Open file error
            IE2=7
            GO TO 91
          END IF
        END IF
C
C       Opening the output file with boundary rays:
        J=2*(NF1+NF2+NF3)+2
        IF (J.GT.NUW) THEN
C         <A NAME="error553.4"></A><FONT COLOR="RED">553.4</FONT>
          CALL ERROR('553.4 in WRIT1: Few logical units available')
C         There are NUW logical units available, see the common
C         blocks /WRITC/ and /WRITN/ defined in the block data
C         WRITB.  The number NUW should be increased.
        ENDIF
        NAME2(J)=' '
        IF(FN1BR.NE.' ') THEN
          NAME1(1)=FN1BR
          NAME1(2)=FN1C
          CALL FNAME(2,NAME1,NAME2(J))
          OPEN(LUW(J),FILE=NAME2(J),FORM='FORMATTED',IOSTAT=IE1)
          IF(IE1.NE.0) THEN
C           <A NAME="error551.8"></A><FONT COLOR="RED">551.8</FONT>
C           Open file error
            IE2=8
            GO TO 91
          END IF
        END IF
C
C       Initial values for the elementary wave
        JRAY=0
        JUEB=0
        JFCT=0
        JOUTP=0
        JTRANS=0
        DO 51 I=1,MENDR+2
          NENDR(I)=0
   51   CONTINUE
        DO 52 I=1,2*(NF1+NF2+NF3)
          JPOINT(I)=0
   52   CONTINUE
C
C       Writing to the output LOG file
        WRITE(LULOG,81) IWAVE
   81   FORMAT(' WAVE',I5,':')
C
C       Writing to the file 'CRT-T' with homogeneous triangles:
        CALL WRITTR(0,ISRC,IWAVE)
C
C       Writing to the file 'CRT-B' with boundary rays:
        CALL WRITBR(0,0,ISRC,IWAVE)
C
      END IF
C
C     Index of the last wave:
      JWAVE=IWAVE
C
C     Screen output
      CALL SCRO1(ISRC,IWAVE)
      RETURN
C
   91 CONTINUE
C       <A NAME="error551"></A><FONT COLOR="RED">551</FONT>
        WRITE(*,'('' STATUS'',I6,''.'',I1,'': '',A)') IE1,IE2,NAME2(J)
        CALL ERROR('551 in WRIT1: Open file error')
C       Open file error when opening the file to store:
C       1 computed quantities along the rays.
C         <A HREF="#error551.1">Location of error 551.1 in the code</A>
C       2 computed quantities at the specified surfaces.
C         <A HREF="#error551.2">Location of error 551.2 in the code</A>
C       3 computed quantities at the endpoints of the elements of
C         the rays of the elementary wave.
C         <A HREF="#error551.3">Location of error 551.3 in the code</A>
C       4 quantities at the initial points of rays, corresponding
C         to the above file 1.
C         <A HREF="#error551.4">Location of error 551.4 in the code</A>
C       5 quantities at the initial points of rays, corresponding
C         to the above file 2.
C         <A HREF="#error551.5">Location of error 551.5 in the code</A>
C       6 quantities at the initial points of rays, corresponding
C         to the above file 3.
C         <A HREF="#error551.6">Location of error 551.6 in the code</A>
C       7 homogeneous triangles in the ray-parameter domain.
C         <A HREF="#error551.7">Location of error 551.7 in the code</A>
C       8 boundary rays.
C         <A HREF="#error551.8">Location of error 551.8 in the code</A>
C       The type 1 to 8 of the file is given by the first decimal
C       place of the status.
   98 CONTINUE
C       <A NAME="error558"></A><FONT COLOR="RED">558</FONT>
        CALL ERROR('558 in WRIT1: End of input file')
C       End of input data file WRIT specifying the names of the
C       output files encountered before all required elementary
C       waves are computed.  The number of elementary waves
C       exceeds the number of specified output filenames.
      END
C
C=======================================================================
C
C     <A NAME="WRIT2"></A>
C
      SUBROUTINE WRIT2(LULOG,IRAY)
      INTEGER LULOG,IRAY
C
C This subroutine is called when starting the complete tracing of a new
C ray.
C
C Input:
C     LULOG...Logical unit number of the log output device.
C     IRAY... The index of the ray which will be computed (i.e. the
C             output of the subroutine RPAR2 from the file 'rpar.for').
C
C No output.
C
C Common blocks /WRITC/ and /WRITN/:
      INCLUDE 'writ.inc'
C     <A HREF="writ.inc">writ.inc</A>
C JRAY is redefined in this subroutine.  No other of the storage
C locations of the common block are altered.
C
C Subroutines and external functions required:
      EXTERNAL SCRO2
C     SCRO2...One of files 'scro*.for'.
C
C Date: 1996, June 15
C Coded by Ludek Klimes
C
C-----------------------------------------------------------------------
C
C     Auxiliary storage locations:
      INTEGER I
C
      NTMP=0
      JRAY=IRAY
      DO 1 I=1,NF2
        JSTOR(I)=0
    1 CONTINUE
C
C     Screen output
      CALL SCRO2(IRAY)
      RETURN
      END
C
C=======================================================================
C
C     <A NAME="WRIT31"></A>
C
      SUBROUTINE WRIT31(YL,Y,YY,IY)
      REAL YL(6),Y(35),YY(5)
      INTEGER IY(12)
C
C This subroutine stores the computed quantities along a ray, see
C <A HREF="../../../papers/b88vc200.htm#28">C.R.T.5.5.1</A>.
C It is called with constant step STORE of the independent variable
C along the ray, and at the points of intersection with interfaces
C either before and after the transformation.
C
C Input:
C     YL...   Array containing local quantities at the point of the ray.
C     Y...    Array containing basic quantities computed along the ray.
C     YY...   Array containing real auxiliary quantities computed along
C             the ray.
C     IY...   Array containing integer auxiliary quantities computed
C             along the ray.
C None of the input parameters are altered.
C
C No output.
C
C Common blocks /WRITC/ and /WRITN/:
      INCLUDE 'writ.inc'
C     <A HREF="writ.inc">writ.inc</A>
C Array JPOINT is modified in this subroutine.
C
C Subroutines and external functions required:
      EXTERNAL NELEM,SCRO3
      INTEGER NELEM
C     NELEM.. File 'code.for'.
C     SCRO3...One of files 'scro*.for'.
C
C Date: 2003, November 24
C Coded by Ludek Klimes
C
C-----------------------------------------------------------------------
C
C     Auxiliary storage locations:
      INTEGER I
C
      IF(NELEM(IY(2)).GT.KWRIT1) THEN
        IF(NAME2(1).NE.' ') THEN
          IF(K2P.EQ.0) THEN
            JPOINT(1)=JPOINT(1)+1
            WRITE(LUW(1)) ISRC,JWAVE,JRAY,IY(1),IY(5),IY(6),IY(12),
     *                    YY(1),YY(2),YL,(Y(I),I=1,IY(1))
          ELSE
            NTMP=NTMP+1
            IF(NTMP.LE.MTMP) THEN
              KTMP(1,NTMP)=ISRC
              KTMP(2,NTMP)=JWAVE
              KTMP(3,NTMP)=JRAY
              KTMP(4,NTMP)=IY(1)
              KTMP(5,NTMP)=IY(5)
              KTMP(6,NTMP)=IY(6)
              KTMP(7,NTMP)=IY(12)
              TMP(1,NTMP)=YY(1)
              TMP(2,NTMP)=YY(2)
              DO 11 I=1,6
                TMP(2+I,NTMP)=YL(I)
   11         CONTINUE
              DO 12 I=1,IY(1)
                TMP(8+I,NTMP)=Y(I)
   12         CONTINUE
            ELSE
C             <A NAME="error552"></A><FONT COLOR="RED">552</FONT>
              CALL ERROR('552 in WRIT31: Too many points along a ray')
C             Dimension MTMP of array to temporarily store the traced
C             ray in the memory is smaller than the number of points
C             along the ray.
            END IF
          END IF
        END IF
      END IF
C
C     Screen output
      CALL SCRO3(YL,Y,YY,IY)
      RETURN
      END
C
C=======================================================================
C
C     <A NAME="WRIT32"></A>
C
      SUBROUTINE WRIT32(ISTOR,YL,Y,YY,IY,NAMPL,YC)
      INTEGER ISTOR,IY(12),NAMPL
      REAL YL(6),Y(27),YY(5),YC(NAMPL)
C
C This subroutine stores the computed quantities at specified surfaces,
C see <A HREF="../../../papers/b88vc200.htm#29">C.R.T.5.5.2</A>.
C It is called at the points of intersection of the ray with specified
C surfaces.
C
C Input:
C     ISTOR...The sequential number in the input data of the specified
C             surface.
C     YL...   Array containing local quantities at the point of the ray.
C     Y...    Array containing basic quantities computed along the ray.
C             Quantities Y(28) to Y(IY(1)) representing reduced
C             amplitudes are ignored.
C     YY...   Array containing real auxiliary quantities computed along
C             the ray.
C     IY...   Array containing integer auxiliary quantities computed
C             along the ray.
C     NAMPL...Number of real quantities representing complex-valued
C             vectorial reduced amplitudes.  If no conversion
C             coefficients are applied NAMPL=IY(1)-27,  otherwise
C             NAMPL=6 or 12, see
C             <A HREF="../../../papers/b88vc200.htm#30">C.R.T.5.5.4</A>.
C     YC...   Array containing real quantities representing complex-
C             -valued vectorial reduced amplitudes.  If no conversion
C             coefficients are applied, YC is a copy of Y(28) to
C             Y(IY(1)).  Otherwise,  YC represents the vectorial reduced
C             amplitudes involving appropriate conversion coefficients,
C             expressed in ray-centred coordinate system, see
C             <A HREF="../../../papers/b88vc200.htm#30">C.R.T.5.5.4</A>.
C             P wave at the initial point of the ray:
C               NAMPL=6,
C               YC(1)=REAL(A13),  YC(2)=AIMAG(A13),
C               YC(3)=REAL(A23),  YC(4)=AIMAG(A23),
C               YC(5)=REAL(A33),  YC(6)=AIMAG(A33).
C             S wave at the initial point of the ray:
C               NAMPL=12,
C               YC(1)=REAL(A11),  YC(2)=AIMAG(A11),
C               YC(3)=REAL(A21),  YC(4)=AIMAG(A21),
C               YC(5)=REAL(A31),  YC(6)=AIMAG(A31),
C               YC(7)=REAL(A12),  YC(8)=AIMAG(A12),
C               YC(9)=REAL(A22),  YC(10)=AIMAG(A22),
C               YC(11)=REAL(A32), YC(12)=AIMAG(A32).
C None of the input parameters are altered.
C
C No output.
C
C Common block /DCRT/ (see subroutine file 'ray.for'):
      INCLUDE 'dcrt.inc'
C     <A HREF="dcrt.inc">dcrt.inc</A>
C None of the storage locations of the common block are altered.
C
C Common blocks /WRITC/ and /WRITN/:
      INCLUDE 'writ.inc'
C     <A HREF="writ.inc">writ.inc</A>
C Array JPOINT is modified in this subroutine.
C
C Subroutines and external functions required:
      EXTERNAL NELEM
      INTEGER NELEM
C     NELEM...File 'code.for'.
C
C Date: 2003, November 23
C Coded by Ludek Klimes
C
C-----------------------------------------------------------------------
C
C     Auxiliary storage locations:
      INTEGER NY
C
      JSTOR(ISTOR)=JSTOR(ISTOR)+1
      IF(KSTOR(NSTOR+ISTOR).LE.JSTOR(ISTOR)
     *    .AND.JSTOR(ISTOR).LE.KSTOR(2*NSTOR+ISTOR)) THEN
        IF(NELEM(IY(2)).GT.KWRIT2) THEN
          IF(NAME2(2*(NF1+ISTOR)-1).NE.' ') THEN
            JPOINT(2*(NF1+ISTOR)-1)=JPOINT(2*(NF1+ISTOR)-1)+1
            NY=27+NAMPL
            WRITE(LUW(2*(NF1+ISTOR)-1))
     *                      ISRC,JWAVE,JRAY,NY,IY(5),IY(6),IY(12),
     *                      YY(1),YY(2),YL,Y,YC
          END IF
        END IF
      END IF
      RETURN
      END
C
C=======================================================================
C
C     <A NAME="WRIT33"></A>
C
      SUBROUTINE WRIT33(YL,Y,YY,IY)
      REAL YL(6),Y(35),YY(5)
      INTEGER IY(12)
C
C This subroutine stores the computed quantities at the endpoints of the
C individual elementary waves, see
C <A HREF="../../../papers/b88vc200.htm#29">C.R.T.5.5.3</A>.
C It is called at the endpoints of the elements of rays, situated
C at structural interfaces.
C
C Input:
C     YL...   Array containing local quantities at the point of the ray.
C     Y...    Array containing basic quantities computed along the ray.
C     YY...   Array containing real auxiliary quantities computed along
C             the ray.
C     IY...   Array containing integer auxiliary quantities computed
C             along the ray.
C None of the input parameters are altered.
C
C No output.
C
C Common blocks /WRITC/ and /WRITN/:
      INCLUDE 'writ.inc'
C     <A HREF="writ.inc">writ.inc</A>
C None of the storage locations of the common block are altered.
C
C Subroutines and external functions required:
      EXTERNAL NELEM
      INTEGER NELEM
C     NELEM...File 'code.for'.
C
C Date: 1996, June 15
C Coded by Ludek Klimes
C
C-----------------------------------------------------------------------
C
C     Auxiliary storage location:
      INTEGER I
C
      I=NELEM(IY(2))-KWRIT3
      IF(1.LE.I.AND.I.LE.NF3) THEN
        IF(NAME2(2*(NF1+NF2+I)-1).NE.' ') THEN
          JPOINT(2*(NF1+NF2+I)-1)=JPOINT(2*(NF1+NF2+I)-1)+1
          WRITE(LUW(2*(NF1+NF2+I)-1)) JRAY,IY,YL,(Y(I),I=1,IY(1)),YY
        END IF
      END IF
      RETURN
      END
C
C=======================================================================
C
C     <A NAME="WRIT4"></A>
C
      SUBROUTINE WRIT4(LULOG,IRAY,YL,Y,YY,IY,IEND,ISHEET,IREC)
C
      INTEGER LULOG,IRAY,IY(12),IEND,ISHEET,IREC
      REAL YL(6),Y(35),YY(5)
C
C This subroutine stores the quantities at the initial point of the ray,
C see <A HREF="../../../papers/b88vc200.htm#52">C.R.T.6.1</A>.
C It is called after termination of tracing the ray.
C
C Input:
C     LULOG...Logical unit number of the log output device.
C     IRAY... The index of the ray which has been computed (i.e. the
C             output of the subroutine RPAR2 from the file 'rpar.for').
C     YL...   Array containing local quantities at the point of the ray.
C     Y...    Array containing basic quantities computed along the ray.
C     YY...   Array containing real auxiliary quantities computed along
C             the ray.
C     IY...   Array containing integer auxiliary quantities computed
C             along the ray.
C     IEND... Reason of the termination of the computation of a ray, see
C             <A HREF="../../../papers/b88vc200.htm#27">C.R.T.5.4</A>.
C             See subroutine RAY in the subroutine file 'ray.for' for
C             <A HREF="ray.for#IEND">detailed description of IEND</A>.
C     ISHEET..Ray-history index.  The different ray histories are
C             consecutively indexed by positive integers 1,2,3,...
C             According to their appearance during ray tracing.
C             The ray histories are indexed independently within each
C             elementary wave.
C             The ray-history indices are complemented with sign:
C             positive - successful ray (crossing reference surface),
C             negative - unsuccessful ray (terminating before crossing
C             reference surface).
C     IREC... Index of the receiver for a two-point ray,
C             otherwise zero.
C
C No output.
C
C Common block /DCRT/ (see subroutine file 'ray.for'):
      INCLUDE 'dcrt.inc'
C     <A HREF="dcrt.inc">dcrt.inc</A>
C None of the storage locations of the common block are altered.
C
C Common block /INITC/ (see subroutine file 'init.for'):
      INCLUDE 'initc.inc'
C     <A HREF="initc.inc">initc.inc</A>
C None of the storage locations are altered.
C
C Common blocks /WRITC/ and /WRITN/:
      INCLUDE 'writ.inc'
C     <A HREF="writ.inc">writ.inc</A>
C JUEB, JFCT, JOUTP, JTRANS, arrays JPOINT and NENDR are modified in
C this subroutine.
C
C Subroutines and external functions required:
      EXTERNAL SCRO4,CHECK
C     SCRO4...One of files 'scro*.for'.
C     CHECK...This file.
C
C Date: 2003, November 24
C Coded by Ludek Klimes
C
C-----------------------------------------------------------------------
C
C     Auxiliary storage locations:
      INTEGER I,I0,I1,I2,I3,I4,I5,I6,I7,I8,I9,J
      REAL S12,S13,S23,S14,S24,S34
C
C.......................................................................
C
C     Screen output
      CALL SCRO4(IRAY,YL,Y,YY,IY,IEND,ISHEET)
C
C     Statistics
      DO 11 I=1,MENDR
        IF(IEND.EQ.JENDR(I)) THEN
          NENDR(I)=NENDR(I)+1
          GO TO 12
        END IF
   11 CONTINUE
      NENDR(MENDR+1)=NENDR(MENDR+1)+1
   12 CONTINUE
      NENDR(MENDR+2)=NENDR(MENDR+2)+1
C
C     Check for non-existing rays:
      IF(IEND.GE.70) THEN
        RETURN
      END IF
C
C     Statistics
      JFCT=JFCT+IY(9)
      JOUTP=JOUTP+IY(10)
      JTRANS=JTRANS+IY(11)
C
C     Writing the quantities at the initial point of the ray, see
C     <A HREF="../../../papers/b88vc200.htm#52">C.R.T.6.1</A>.
      I1=-JWAVE
      DO 20 I=1,NF1+NF2+NF3
        IF(NAME2(2*I).NE.' ') THEN
C         For whole rays, only initial points of two-point rays are
C         stored if only two-point rays are stored.
C         For intersections with surfaces and endpoints of elementary
C         waves, initial points of all rays are stored.
          IF(K2P.EQ.0.OR.IREC.GT.0.OR.I.GT.NF1) THEN
            JPOINT(2*I)=JPOINT(2*I)+1
            WRITE(LUW(2*I)) ISRC,I1,IRAY,ICB1I,IEND,ISHEET,IREC,YLI,YI
          END IF
        END IF
   20 CONTINUE
C
C     Writing the quantities along the two-point ray:
      IF(NAME2(1).NE.' ') THEN
        IF(K2P.NE.0.AND.IREC.GT.0) THEN
          JPOINT(1)=JPOINT(1)+NTMP
          DO 30 J=1,NTMP
            WRITE(LUW(1)) (KTMP(I,J),I=1,7),(TMP(I,J),I=1,8+KTMP(4,J))
   30     CONTINUE
        END IF
      END IF
C
C     Writing to the output LOG file
C     Simplecticity of the propagator matrix, see
C     <A HREF="../../../papers/b88vc200.htm#32">C.R.T.5.6l</A>.
      IF(UEBDRT.GT.0.) THEN
        S12=Y(12)*Y(18)+Y(13)*Y(19)-Y(14)*Y(16)-Y(15)*Y(17)
        S13=Y(12)*Y(22)+Y(13)*Y(23)-Y(14)*Y(20)-Y(15)*Y(21)-1.
        S23=Y(16)*Y(22)+Y(17)*Y(23)-Y(18)*Y(20)-Y(19)*Y(21)
        S14=Y(12)*Y(26)+Y(13)*Y(27)-Y(14)*Y(24)-Y(15)*Y(25)
        S24=Y(16)*Y(26)+Y(17)*Y(27)-Y(18)*Y(24)-Y(19)*Y(25)-1.
        S34=Y(20)*Y(26)+Y(21)*Y(27)-Y(22)*Y(24)-Y(23)*Y(25)
      END IF
C     Checking exceeding the specified limits
      I=0
      CALL CHECK(YY(2),UEB,I0,I)
      CALL CHECK(YY(3),UEBPP,I1,I)
      CALL CHECK(YY(4),UEBPH,I2,I)
      CALL CHECK(YY(5),UEBHH,I3,I)
      CALL CHECK(S12,UEBDRT,I4,I)
      CALL CHECK(S13,UEBDRT,I5,I)
      CALL CHECK(S23,UEBDRT,I6,I)
      CALL CHECK(S14,UEBDRT,I7,I)
      CALL CHECK(S24,UEBDRT,I8,I)
      CALL CHECK(S34,UEBDRT,I9,I)
C     I is the number of checked quantities exceeding their specified
C     Upper limits
      IF(I.GT.0) THEN
C       Writing report on this ray
        IF(JUEB.EQ.0) THEN
          WRITE(LULOG,'(2A)') '       RAY:     ',
     *        'CHECKED QUANTITIES IN PERCENTS OF THEIR SPECIFIED LIMITS'
        END IF
        JUEB=JUEB+1
        WRITE(LULOG,'(I10,A,10I6)')
     *                           IRAY,': ',I0,I1,I2,I3,I4,I5,I6,I7,I8,I9
      END IF
C
      RETURN
      END
C
C-----------------------------------------------------------------------
C
C     <A NAME="CHECK"></A>
C
      SUBROUTINE CHECK(Q,QUEB,IRATE,I)
      REAL Q,QUEB
      INTEGER IRATE,I
C
C     Auxiliary subroutine to WRIT4
C
      IF(QUEB.LE.0.) THEN
        IRATE=0
      ELSE
        IF(ABS(Q).GT.QUEB) THEN
          I=I+1
        END IF
        IF(ABS(Q).GT.10000.*QUEB) THEN
          IRATE=1000000.
        ELSE
          IRATE=INT(100.*Q/QUEB+0.5)
        END IF
      END IF
      RETURN
      END
C
C=======================================================================
C
C     <A NAME="WRIT5"></A>
C
      SUBROUTINE WRIT5(LULOG,IWAVE)
      INTEGER LULOG,IWAVE
C
C This subroutine is called after termination of the computation of an
C elementary wave, and when terminating the complete ray tracing
C program.
C
C Input:
C     LULOG...Logical unit number of the log output device.
C     IWAVE...Zero when terminating the complete ray tracing program,
C             otherwise the index of the elementary wave which has been
C             computed (i.e. the output of the subroutine CODE1 from the
C             file 'code.for').
C
C No output.
C
C Common blocks /WRITC/ and /WRITN/:
      INCLUDE 'writ.inc'
C     <A HREF="writ.inc">writ.inc</A>
C None of the storage locations of the common block are altered.
C
C Subroutines and external functions required:
      EXTERNAL SCRO5
C     SCRO5...One of files 'scro*.for'.
C
C Date: 1992, December 18
C Coded by Ludek Klimes
C
C-----------------------------------------------------------------------
C
C     Auxiliary storage locations:
      INTEGER I,J,N,K(4)
C
C     Writing to the output LOG file:
      IF(IWAVE.NE.0) THEN
        IF(JUEB.GT.0) THEN
          WRITE(LULOG,10)
   10     FORMAT(11X,'ABOVE RAYS ARE COMPUTED WITH DECREASED ACCURACY')
        END IF
C       Reasons of termination of tracing rays
        WRITE(LULOG,21) NENDR(MENDR+2),JFCT,JOUTP,JTRANS
        N=0
        DO 12 J=1,MENDR
          IF(NENDR(J).GT.0) THEN
            N=N+1
            K(N)=J
          END IF
          IF(N.EQ.4.OR.(J.EQ.MENDR.AND.N.GT.0)) THEN
            WRITE(LULOG,22) (NENDR(K(I)),JENDR(K(I)),I=1,N)
            N=0
          END IF
   12   CONTINUE
        IF(NENDR(MENDR+1).NE.0) THEN
          WRITE(LULOG,23) NENDR(MENDR+1)
        END IF
C       List of output files
        DO 14 I=1,2*(NF1+NF2+NF3)
          IF(NAME2(I).NE.' ') THEN
            WRITE(LULOG,24) JPOINT(I),NAME2(I)
          END IF
   14   CONTINUE
C       formats
   21   FORMAT(  I10,' RAYS ',I12,' FCT  ',I12,' STEPS',I12,' TRANS')
   22   FORMAT(4(I10,' IEND=',I2))
   23   FORMAT(  I10,' IEND=OTHER')
   24   FORMAT(  I10,' POINTS IN FILE: ',A)
      END IF
C
C     Screen output:
      CALL SCRO5(IWAVE)
      RETURN
      END
C
C=======================================================================
C
C     <A NAME="FNAME"></A>
C
      SUBROUTINE FNAME(NUM1,NAME1,NAME2)
      INTEGER NUM1
      CHARACTER*(*) NAME1(NUM1)
      CHARACTER*(*) NAME2
C
C This subroutine is designed to analyze the specified strings and to
C compose the filename of them.
C
C Input:
C     NAME1...Character array of character strings to be analyzed.
C     NUM1... Number of filenames to be analyzed.
C
C Output:
C     NAME2...Filename composed of the analyzed input components
C             (strings).
C
C No subroutines and external functions required.
C
C Date: 1992, December 18
C Coded by Ludek Klimes
C
C-----------------------------------------------------------------------
C
C     Auxiliary storage locations:
      INTEGER M1
      PARAMETER (M1=4)
      INTEGER J1(M1),L1(M1),I1,J2,L2,I2,N,I
C
C     M1...   Maximum number of analyzed strings.
C     J1(N)...Number of the currently analyzed characters of NAME1(N),
C             i.e. the position of the space after the last analyzed
C             word of NAME1(N).  A word is a substring between two
C             consecutive spaces.
C     L1(N)...Length of NAME1(N).
C     I1...   Beginning of the last analyzed word of NAME1(N), i.e. the
C             previous value of J1(N) increased by 1.
C     J2...   Number of the currently defined characters of NAME2.
C     L2...   Length of NAME2.
C     I2...   Auxiliary variable - previous value of J2 increased by 1.
C     N...    Loop variable - index of input filename.
C     I...    Loop variable - position in a string.
C
C.......................................................................
C
      IF(M1.LT.NUM1) THEN
C       <A NAME="error559"></A><FONT COLOR="RED">559</FONT>
        CALL ERROR('559 in FNAME: Too many strings')
C       The number NUM1 of input strings exceeds the dimension M1
C       of arrays J1 and L1.  Parameter M1 must be increased.
      END IF
      DO 11 N=1,NUM1
        J1(N)=0
        L1(N)=LEN(NAME1(N))
   11 CONTINUE
      J2=0
      L2=LEN(NAME2)
C
   20 CONTINUE
      DO 29 N=1,NUM1
C       (a) Analyzing NAME1(N):
        I1=J1(N)+1
        DO 21 I=I1,L1(N)
          IF(NAME1(N)(I:I).EQ.' ') THEN
            J1(N)=I
            GO TO 22
          END IF
   21   CONTINUE
        J1(N)=L1(N)+1
   22   CONTINUE
C       J1(N)-th character of NAME1(N) is found to be blank.
C       (b) Copying the word from NAME1(N) to NAME2:
        IF(J1(N).GT.I1) THEN
          I2=J2+1
          J2=MIN0(J2+J1(N)-I1,L2)
          NAME2(I2:J2)=NAME1(N)(I1:J1(N)-1)
        END IF
   29 CONTINUE
C
      DO 31 N=1,NUM1
        IF(J1(N).LT.L1(N)) GO TO 20
   31 CONTINUE
      DO 32 I=J2+1,L2
        NAME2(I:I)=' '
   32 CONTINUE
      RETURN
      END
C
C=======================================================================
C
C     <A NAME="WRITTR"></A>
C
      SUBROUTINE WRITTR(IRAY1,IRAY2,IRAY3)
      INTEGER IRAY1,IRAY2,IRAY3
C
C This subroutine is designed to write the indices of rays forming
C the homogeneous triangles in the ray-parameter domain.
C
C Input:
C     IRAY1,IRAY2,IRAY3... Indices of rays forming the homogeneous
C             triangle.  IRAY3=0 in 2-D.
C
C No output.
C
C Common blocks /WRITC/ and /WRITN/:
      INCLUDE 'writ.inc'
C     <A HREF="writ.inc">writ.inc</A>
C None of the storage locations of the common block are altered.
C
C No subroutines and external functions required.
C
C Date: 1997, October 20
C Coded by Ludek Klimes
C
C-----------------------------------------------------------------------
C
C     Auxiliary storage locations:
      INTEGER IFORM1,IFORM3
      CHARACTER*10 FORMAT
      SAVE IFORM1,IFORM3,FORMAT
      DATA IFORM1/99999/,IFORM3/0/,FORMAT/'(I6,I6,I2)'/
C
C     Writing to the output file with homogeneous triangles:
      IF(NAME2(2*(NF1+NF2+NF3)+1).NE.' ') THEN
        IF(IRAY1.GT.IFORM1.OR.IRAY2.GT.IFORM1.OR.IRAY3.GT.IFORM1) THEN
          IFORM1=IFORM1*10+9
          FORMAT(3:3)=CHAR(ICHAR(FORMAT(3:3))+1)
          FORMAT(6:6)=FORMAT(3:3)
          IFORM3=0
        END IF
        IF(IRAY3.GT.IFORM3) THEN
          IFORM3=IFORM1
          FORMAT(9:9)=FORMAT(3:3)
        END IF
        WRITE(LUW(2*(NF1+NF2+NF3)+1),FORMAT) IRAY1,IRAY2,IRAY3
      END IF
C
      RETURN
      END
C
C=======================================================================
C
C     <A NAME="WRITBR"></A>
C
      SUBROUTINE WRITBR(IB1,IB2,IB3,IB4)
      INTEGER IB1,IB2,IB3,IB4
C
C This subroutine is designed to write the indices of boundary rays.
C
C Input:
C     IB1 ... Index of the boundary ray.
C     IB2 ... Index of the boundary ray coupled with IB1.
C     IB3,IB4 . Indices of two boundary rays equal in history with IB1,
C             coupled with rays equal in history with IB2, and connected
C             with boundary ray IB1 by sides of homogeneous triangles.
C             IB4=0 if there is only one ray of the described
C             properties.
C             IB3=0 and IB4=0 if there is no ray of the described
C             properties and for one-parametric shooting in 2-D.
C
C No output.
C
C Common blocks /WRITC/ and /WRITN/:
      INCLUDE 'writ.inc'
C     <A HREF="writ.inc">writ.inc</A>
C None of the storage locations of the common block are altered.
C
C No subroutines and external functions required.
C
C Date: 2001, October 29
C Coded by Petr Bulant
C
C-----------------------------------------------------------------------
C
C     Auxiliary storage locations:
      INTEGER IFORM1,IFORM3
      CHARACTER*13 FORMAT
      SAVE IFORM1,IFORM3,FORMAT
      DATA IFORM1/99999/,IFORM3/0/,FORMAT/'(I6,I6,I6,I2)'/
C
C     Writing to the output file with boundary rays:
      IF(NAME2(2*(NF1+NF2+NF3)+2).NE.' ') THEN
        IF(IB1.GT.IFORM1.OR.IB2.GT.IFORM1.OR.IB3.GT.IFORM1.OR.
     *     IB4.GT.IFORM1) THEN
          IFORM1=IFORM1*10+9
          FORMAT(3:3)=CHAR(ICHAR(FORMAT(3:3))+1)
          FORMAT(6:6)=FORMAT(3:3)
          FORMAT(9:9)=FORMAT(3:3)
          IFORM3=0
        END IF
        IF(IB4.GT.IFORM3) THEN
          IFORM3=IFORM1
          FORMAT(12:12)=FORMAT(3:3)
        END IF
        WRITE(LUW(2*(NF1+NF2+NF3)+2),FORMAT) IB1,IB2,IB3,IB4
      END IF
C
      RETURN
      END
C
C=======================================================================
C                                                                 </PRE>
