C SUBROUTINE FILE 'WRIT.FOR' TO CREATE THE OUTPUT FILES OF COMPLETE RAY
C TRACING
C
C BY VLASTISLAV CERVENY, LUDEK KLIMES, IVAN PSENCIK
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     WRIT1...SUBROUTINE CALLED WHEN STARTING THE COMPLETE RAY TRACING
C             PROGRAM, AND WHEN STARTING THE COMPUTATION OF A NEW
C             ELEMENTARY WAVE.
C     WRIT2...SUBROUTINE CALLED WHEN STARTING THE COMPLETE TRACING OF A
C             NEW RAY.
C     WRIT31..SUBROUTINE STORING THE COMPUTED QUANTITIES ALONG A RAY
C             (C.R.T.5.5.1).  IT IS CALLED WITH CONSTANT STEP STORE (SEE
C             INPUT DATA IN THE FILE 'RAY.FOR') OF THE INDEPENDENT
C             VARIABLE ALONG THE RAY, AND AT THE POINTS OF INTERSECTION
C             WITH INTERFACES EITHER BEFORE AND AFTER THE
C             TRANSFORMATION.
C     WRIT32..SUBROUTINE STORING THE COMPUTED QUANTITIES AT SPECIFIED
C             SURFACES (C.R.T.5.5.2).  IT IS CALLED AT THE POINTS OF
C             INTERSECTION OF THE RAY WITH THE SPECIFIED SURFACES.
C     WRIT33..SUBROUTINE STORING THE COMPUTED QUANTITIES AT THE
C             ENDPOINTS OF THE INDIVIDUAL ELEMENTARY WAVES
C             (C.R.T.5.5.3).  IT IS CALLED AT THE ENDPOINTS OF THE
C             ELEMENTS OF RAYS, SITUATED AT STRUCTURAL INTERFACES.
C     WRIT4...SUBROUTINE STORING THE QUANTITIES AT THE INITIAL POINT OF
C             THE RAY (C.R.T.6.1).  IT IS CALLED AFTER TERMINATION OF
C             TRACING THE RAY.
C     CHECK...AUXILIARY SUBROUTINE TO WRIT4.
C     WRIT5...SUBROUTINE CALLED AFTER TERMINATION OF THE COMPUTATION OF
C             AN ELEMENTARY WAVE, AND WHEN TERMINATING THE COMPLETE RAY
C             TRACING PROGRAM.
C     FNAME...SUBROUTINE ANALYSING THE SPECIFIED STRINGS AND COMPOSING
C             THE FILENAME OF THEM.  AUXILIARY SUBROUTINE TO WRIT1.
C
C INPUT DATA TO SPECIFY THE NAMES OF THE OUTPUT FILES WITH THE COMPUTED
C QUANTITIES:
C     THE DATA ARE READ IN BY THE LIST DIRECTED INPUT (FREE FORMAT).  IN
C     THE LIST OF INPUT DATA BELOW, EACH NUMBERED PARAGRAPH INDICATES
C     THE BEGINNING OF A NEW INPUT OPERATION (NEW READ STATEMENT).  ALL
C     INPUT VARIABLES ARE OF THE TYPE CHARACTER.  THE DATA ARE READ BY
C     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 SIGNIFICANT.
C (2) FN1A,FN1I,/
C     FN1A... STRING CONTAINING THE FIRST COMPONENT OF THE NAME OF THE
C             OUTPUT FILE WITH THE COMPUTED QUANTITIES STORED ALONG THE
C             RAYS (C.R.T.5.5.1).
C     FN1I... STRING CONTAINING THE FIRST COMPONENT OF THE NAME OF THE
C             OUTPUT FILE WITH THE QUANTITIES AT THE INITIAL POINTS OF
C             RAYS (C.R.T.6.1), RELATED TO THE OUTPUT FILE WITH THE
C             COMPUTED QUANTITIES STORED ALONG THE RAYS (C.R.T.5.5.1).
C             THE OTHER COMPONENTS OF THE FILENAME ARE COMMON WITH THE
C             RELATED FILE CONTAINING THE COMPUTED QUANTITIES.
C     /...    AN OBLIGATORY SLASH.
C     DEFAULT: ALL FILENAMES BLANK.
C (3) FN2A,FN2I,(FN2B(I),I=1,NENDF),/
C     FN2A... STRING CONTAINING THE FIRST COMPONENT OF THE NAME OF THE
C             OUTPUT FILE WITH THE COMPUTED QUANTITIES STORED AT THE
C             SPECIFIED SURFACES (C.R.T.5.5.2).
C     FN2I... STRING CONTAINING THE FIRST COMPONENT OF THE NAME OF THE
C             OUTPUT FILE WITH THE QUANTITIES AT THE INITIAL POINTS OF
C             RAYS (C.R.T.6.1), RELATED TO THE OUTPUT FILE WITH THE
C             COMPUTED QUANTITIES STORED AT THE SPECIFIED SURFACES
C             (C.R.T.5.5.2).  THE OTHER COMPONENTS OF THE FILENAME ARE
C             COMMON WITH THE RELATED FILE CONTAINING THE COMPUTED
C             QUANTITIES.
C     FN2B(I)... STRING CONTAINING THE SECOND COMPONENT OF THE NAME OF
C             THE OUTPUT FILE WITH THE COMPUTED QUANTITIES STORED AT THE
C             I-TH SPECIFIED SURFACE (C.R.T.5.5.2).  HERE NENDF IS THE
C             NUMBER OF SURFACES SPECIFIED FOR STORING THE COMPUTED
C             QUANTITIES.
C     /...    AN OBLIGATORY SLASH.
C     DEFAULT: ALL FILENAMES BLANK.
C (4) EITHER (4.1) OR (4.2):
C (4.1) /
C     A SLASH IS FULLY SUFFICIENT IF MODCRT.LE.1, SEE INPUT DATA
C     'DCRT.DAT' DESCRIBED IN SOURCE CODE FILE 'RAY.FOR'.
C     IF MODCRT.LE.1, THE FILENAMES (4.2) ARE IGNORED IF SPECIFIED.
C     IF MODCRT.GE.2, THE FILENAMES (4.2) ARE OBLIGATORY.
C (4.2) FN3A,FN3I,(FN3B(I),I=1,NELEM),/
C     FN3A... STRING CONTAINING THE FIRST COMPONENT OF THE NAME OF THE
C             OUTPUT FILE WITH THE COMPUTED QUANTITIES STORED AT THE
C             ENDPOINTS OF THE ELEMENTS OF RAYS (C.R.T.5.5.3).
C     FN3I... STRING CONTAINING THE FIRST COMPONENT OF THE NAME OF THE
C             OUTPUT FILE WITH THE QUANTITIES AT THE INITIAL POINTS OF
C             RAYS (C.R.T.6.1), RELATED TO THE OUTPUT FILE WITH THE
C             COMPUTED QUANTITIES STORED AT THE ENDPOINTS OF THE
C             ELEMENTS OF RAYS (C.R.T.5.5.3).  THE OTHER COMPONENTS OF
C             THE FILENAME ARE COMMON WITH THE RELATED FILE CONTAINING
C             THE COMPUTED QUANTITIES.
C     FN3B(I)... STRING CONTAINING THE SECOND COMPONENT OF THE NAME OF
C             THE OUTPUT FILE WITH THE COMPUTED QUANTITIES STORED AT THE
C             ENDPOINTS OF THE I-TH ELEMENT OF RAYS (C.R.T.5.5.3).
C             THESE STRINGS NEED NOT BE SPECIFIED FOR MODCRT.LE.1, SEE
C             INPUT DATA 'DCRT.DAT'.  OTHERWISE, NONE OF FN3B(I)
C             CORRESPONDING TO THE ENDPOINT OF A RAY ELEMENT AT WHICH
C             QUANTITIES ARE STORED (SEE MODCRT IN THE INPUT DATA
C             'DCRT.DAT') MAY EQUAL SPACES.
C     /...    AN OBLIGATORY SLASH.
C     DEFAULT: ALL FILENAMES BLANK.
C (5) FOR EACH ELEMENTARY WAVE IWAVE THE FOLLOWING DATA (5.1):
C (5.1) FN1C,FN2C,FN3C,(FN2D(I),I=1,NENDF),/
C     FN1C... STRING CONTAINING THE SECOND COMPONENT OF THE NAME OF THE
C             OUTPUT FILE WITH THE COMPUTED QUANTITIES STORED ALONG THE
C             RAYS (C.R.T.5.5.1).
C             IF BOTH THE FIRST AND SECOND COMPONENT OF THE FILENAME ARE
C             BLANK, THE FILE IS NOT CREATED.
C     FN2C... STRING CONTAINING THE THIRD COMPONENT OF THE NAME OF THE
C             OUTPUT FILE WITH THE COMPUTED QUANTITIES STORED AT THE
C             SPECIFIED SURFACES (C.R.T.5.5.2).
C             IF THE SECOND, THIRD AND FOURTH COMPONENTS OF THE FILENAME
C             ARE ALL BLANK, THE FILE IS NOT CREATED.
C     FN3C... STRING CONTAINING THE THIRD COMPONENT OF THE NAME OF THE
C             OUTPUT FILE WITH THE COMPUTED QUANTITIES STORED AT THE
C             ENDPOINTS OF THE ELEMENTS OF RAYS (C.R.T.5.5.3).
C             THIS STRING MAY NOT EQUAL SPACES FOR MODCRT.GE.2, SEE
C             INPUT DATA 'DCRT.DAT'.
C             IF MODCRT.LE.1, SEE INPUT DATA 'DCRT.DAT', THE FILE IS NOT
C             CREATED.
C     FN2D(I)... STRING CONTAINING THE FOURTH COMPONENT OF THE NAME OF
C             THE OUTPUT FILE WITH THE COMPUTED QUANTITIES STORED AT THE
C             I-TH SPECIFIED SURFACE (C.R.T.5.5.2).  HERE NENDF IS THE
C             NUMBER OF SURFACES SPECIFIED FOR STORING THE COMPUTED
C             QUANTITIES.
C     /...    AN OBLIGATORY SLASH.
C     DEFAULT: ALL FILENAMES BLANK.
C
C STORAGE IN THE MEMORY:
C     THE INPUT DATA (1) TO (5) DESCRIBING THE NAMES OF THE OUTPUT FILES
C     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     ------------------------------------------------------------------
      BLOCK DATA WRITB
      INTEGER MF
      PARAMETER (MF=64)
      CHARACTER*80 TEXTW
      CHARACTER*16 FN1A,FN2A,FN3A,FN1I,FN2I,FN3I,FNB(MF),FN1C,FN2C,FN3C
      CHARACTER*16 FN2D(MF)
      COMMON/WRITT/TEXTW,
     *             FN1A,FN2A,FN3A,FN1I,FN2I,FN3I,FNB,FN1C,FN2C,FN3C,FN2D
      SAVE /WRITT/
      INTEGER JWAVE,JRAY,JUEB,JFCT,JOUTP,JTRANS
      INTEGER KWRIT1,KWRIT2,KWRIT3,NF1,NF2,NF3,MF3,NUW,MENDR
      PARAMETER (NUW=16)
      PARAMETER (MENDR=17)
      INTEGER LUW(NUW),JPOINT(NUW),JSTOR(NUW)
      INTEGER JENDR(MENDR),NENDR(MENDR+2)
      COMMON/WRITC/JWAVE,JRAY,JUEB,JFCT,JOUTP,JTRANS,KWRIT1,KWRIT2,
     *             KWRIT3,NF1,NF2,NF3,MF3,LUW,JPOINT,JSTOR,JENDR,NENDR
      SAVE /WRITC/
      CHARACTER*16 NAME2(NUW)
      COMMON/WRITN/NAME2
      SAVE /WRITN/
      DATA LUW/10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25/
      DATA JENDR/10,21,22,23,24,25,26,30,32,33,40,50,60,61,71,72,74/
      END
C     ------------------------------------------------------------------
C     TEXTW...THE NAME OF THE DATA SET. STRING OF 80 CHARACTERS.
C     FN1A,FN2A,FN3A,FN1I,FN2I,FN3I,FNB(MF),FN1C,FN2C,FN3C... STORAGE
C             LOCATIONS FOR THE INPUT DATA (2) TO (5).
C             THE COMMON BLOCK /WRITT/ IS USED JUST IN THE SUBROUTINE
C             WRIT1.
C     JWAVE...INDEX OF THE CURRENT ELEMENTARY WAVE.
C     JRAY... INDEX OF THE CURRENT RAY.
C     JUEB... COUNT OF RAYS EXCEEDING THE SPECIFIED UPPER BOUNDS OF THE
C             CHECKED QUANTITIES.
C     JFCT... TOTAL NUMBER OF INVOCATIONS OF THE SUBROUTINE FCT.
C     JOUTP...TOTAL NUMBER OF STEPS OF THE NUMERICAL INTEGRATION.
C     JTRANS..TOTAL NUMBER OF INVOCATIONS OF THE SUBROUTINE TRANS.
C     KWRIT1,KWRIT2,KWRIT3... NUMBERS OF INITIAL RAY ELEMENTS ALONG
C             WHICH NOTHING IS STORED IN THE SUBROUTINES WRIT31, WRIT32
C             AND WRIT33, RESPECTIVELY.
C     NF1...  NUMBER OF OPEN FILES, SEE THE INPUT DATA (2) AND THE
C             SUBROUTINE WRIT31.
C     NF2...  NUMBER OF OPEN FILES, SEE THE INPUT DATA (3) AND THE
C             SUBROUTINE WRIT32.
C     NF3...  NUMBER OF OPEN FILES, SEE THE INPUT DATA (4) AND THE
C             SUBROUTINE WRIT33.
C     MF3...  NUMBER OF FILES CORRESPONDING TO THE CURRENT ELEMENTARY
C             WAVE, SEE THE INPUT DATA (4) AND THE SUBROUTINE WRIT33.
C     NUW...  THE MAXIMUM COUNT OF AVAILABLE LOGICAL UNIT NUMBERS.
C     LUW...  LIST OF THE LOGICAL UNIT NUMBERS CORRESPONDING TO THE
C             OUTPUT FILES.
C     JPOINT..ARRAY CONTAINING NUMBERS OF POINTS STORED INTO THE FILES.
C     JSTOR(I)... THE NUMBER OF CROSSECTIONS OF THE COMPUTED RAY WITH
C             THE SURFACE KSTOR(I).  BECAUSE, FOR THE STRUCTURAL
C             INTERFACES, THE POSITIVE OR NEGATIVE SIDE OF THE SURFACE
C             IS SPECIFIED, EITHER ZERO OR TWO CROSSECTIONS CORRESPOND
C             TO THE REFLECTION FROM THE SURFACE KSTOR(I).
C     MENDR...TOTAL NUMBER OF DISTINCT REASONS OF THE TERMINATION OF THE
C             COMPUTATION OF THE RAY, SEE SUBROUTINE RAY2 OF THE FILE
C             'RAY.FOR' AND SUBROUTINE INIT2 OF THE FILE 'INIT.FOR'.
C     JENDR...LIST OF THE INDICES CORRESPONDING TO DISTINCT REASONS OF
C             THE TERMINATION OF THE COMPUTATION OF THE RAY, SEE
C             SUBROUTINE RAY2 OF THE FILE 'RAY.FOR' AND SUBROUTINE INIT2
C             OF THE FILE 'INIT.FOR'.
C     NENDR...NENDR(I),I=1,MENDR... NUMBER OF RAYS TERMINATED FOR THE
C               REASON JENDR(I).
C             NENDR(MENDR+1)... NUMBER OF RAYS TERMINATED FOR THE REASON
C               NOT LISTED IN THE ARRAY JENDR.
C             NENDR(MENDR+2)... TOTAL NUMBER OF COMPUTED RAYS OF THE
C               CURRENT ELEMENTARY WAVE.
C     NAME2...LIST OF THE NAMES OF THE OPEN FILES.
C
C OUTPUT FILES WITH THE COMPUTED QUANTITIES STORED ALONG THE RAYS
C (C.R.T.5.5.1):
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) IWAVE,IRAY,NY,ICB1,ISRF,X,(YL(I),I=1,6),(Y(I),I=1,NY)
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 EXEPTION TO THE DEFINITION IN THE ORIGINAL
C             PAPER ON C.R.T.
C     X...    INDEPENDENT VARIABLE ALONG A RAY (SEE YY(1) IN
C             C.R.T.5.2.2).
C     YL...   ARRAY CONTAINING LOCAL QUANTITIES AT THE POINT OF THE RAY
C             (C.R.T.5.5.4).
C     Y...    ARRAY CONTAINING BASIC QUANTITIES COMPUTED ALONG THE RAY
C             (C.R.T.5.2.1).
C     THE DETAILED DESCRIPTION OF THE QUANTITIES YL, YY AND IY MAY BE
C     FOUND IN THE FILE 'RAY.FOR'.
C
C OUTPUT FILES WITH THE COMPUTED QUANTITIES STORED AT THE SPECIFIED
C SURFACES (C.R.T.5.5.2):
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) 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.R.T.5.5.4.
C     YC(1) TO YC(NY-27) ARE DESCRIBED IN THE SUBROUTINE CONV (FILR
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 OUTPUT FILES WITH THE COMPUTED QUANTITIES STORED AT THE ENDPOINTS OF
C THE ELEMENTS OF RAYS (C.R.T.5.5.3):
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             (C.R.T.5.5.4).
C     Y...    ARRAY CONTAINING BASIC QUANTITIES COMPUTED ALONG THE RAY.
C             (C.R.T.5.2.1).
C     YY...   ARRAY CONTAINING REAL AUXILIARY QUANTITIES COMPUTED ALONG
C             THE RAY (C.R.T.5.2.2).
C     IY...   ARRAY CONTAINING INTEGER AUXILIARY QUANTITIES COMPUTED
C             ALONG THE RAY (C.R.T.5.2.2).
C     THE DETAILED DESCRIPTION OF THE QUANTITIES YL, Y, YY AND IY MAY BE
C     FOUND IN THE FILE 'RAY.FOR'.
C
C OUTPUT FILES WITH THE QUANTITIES AT THE INITIAL POINTS OF RAYS
C (C.R.T.6.1):
C     UNFORMATTED OUTPUT.  THE QUANTITIES ARE STORED AT THE INITIAL
C     POINTS OF ALL RAYS.
C     FOR EACH RAY - ONE RECORD CONTAINING FOLLOWING 34 QUANTITIES:
C (1) (-IWAVE),IRAY,ICB1I,IEND,ISHEET,(YLI(I),I=1,6),(YI(I),I=1,25)
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.R.T.6.1).
C     IEND... REASON OF THE TERMINATION OF THE COMPUTATION OF A RAY (SEE
C             C.R.T.5.4).  FOR A DETAILED DESCRIPTION SEE SUBROUTINES
C             RAY2 (FILE 'RAY.FOR') AND INIT2 (FILE 'INIT.FOR').
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     YLI...  ARRAY CONTAINING THE VALUES OF THE QUANTITIES YL(1)-YL(6),
C             SEE C.R.T.5.5.4, DESCRIBING THE LOCAL PROPERTIES OF THE
C             MODEL AT THE INITIAL POINT OF THE RAY.  SEE THE LIST OF
C             YL(1) TO YL(6) IN THE FILE 'RAY.FOR'.
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.R.T.6.1.  THESE QUANTITIES ARE
C             LISTED IN THE FILE 'INIT.FOR'.
C
C DATE: 1994, JANUARY 23
C CODED BY LUDEK KLIMES
C
C=======================================================================
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'):
      INTEGER MEND,MSTOR
      PARAMETER (MEND=128)
      PARAMETER (MSTOR=128)
      INTEGER KSTORE,NEXPS,NHLF,MODCRT
      REAL STORE,STEP,UEB,UEBPP,UEBPH,UEBHH,UEBDRT,BOUNDR(7)
      INTEGER NSRFCA,NEND,KEND(MEND),NSTOR,KSTOR(MSTOR)
      COMMON/DCRT/ KSTORE,NEXPS,NHLF,MODCRT,STORE,STEP,UEB,UEBPP,UEBPH,
     *             UEBHH,UEBDRT,BOUNDR,NSRFCA,NEND,KEND,NSTOR,KSTOR
C NONE OF THE STORAGE LOCATIONS OF THE COMMON BLOCK ARE ALTERED.
C
C COMMON BLOCK /WRITT/:
      INTEGER MF
      PARAMETER (MF=64)
      CHARACTER*80 TEXTW
      CHARACTER*16 FN1A,FN2A,FN3A,FN1I,FN2I,FN3I,FNB(MF),FN1C,FN2C,FN3C
      CHARACTER*16 FN2D(MF)
      COMMON/WRITT/TEXTW,
     *             FN1A,FN2A,FN3A,FN1I,FN2I,FN3I,FNB,FN1C,FN2C,FN3C,FN2D
C
C COMMON BLOCKS /WRITC/ AND /WRITN/:
      INTEGER JWAVE,JRAY,JUEB,JFCT,JOUTP,JTRANS
      INTEGER KWRIT1,KWRIT2,KWRIT3,NF1,NF2,NF3,MF3,NUW,MENDR
      PARAMETER (NUW=16)
      PARAMETER (MENDR=17)
      INTEGER LUW(NUW),JPOINT(NUW),JSTOR(NUW)
      INTEGER JENDR(MENDR),NENDR(MENDR+2)
      COMMON/WRITC/JWAVE,JRAY,JUEB,JFCT,JOUTP,JTRANS,KWRIT1,KWRIT2,
     *             KWRIT3,NF1,NF2,NF3,MF3,LUW,JPOINT,JSTOR,JENDR,NENDR
      CHARACTER*16 NAME2(NUW)
      COMMON/WRITN/NAME2
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... FILE 'SCRO.FOR'.
C     FNAME... THIS FILE.
C
C ERROR MESSAGES:
C     551...  OPEN FILE ERROR:
C             OPEN FILE ERROR WHEN OPENING THE FILE TO STORE:
C             1 COMPUTED QUANTITIES ALONG THE RAYS.
C             2 COMPUTED QUANTITIES AT THE SPECIFIED SURFACES.
C             3 COMPUTED QUANTITIES AT THE ENDPOINTS OF THE ELEMENTS OF
C               THE RAYS OF THE ELEMENTARY WAVE.
C             4 QUANTITIES AT THE INITIAL POINTS OF RAYS, CORRESPONDING
C               TO THE ABOVE FILE 1.
C             5 QUANTITIES AT THE INITIAL POINTS OF RAYS, CORRESPONDING
C               TO THE ABOVE FILE 2.
C             6 QUANTITIES AT THE INITIAL POINTS OF RAYS, CORRESPONDING
C               TO THE ABOVE FILE 3.
C             THE TYPE 1 TO 6 OF THE FILE IS GIVEN BY THE FIRST DECIMAL
C             PLACE OF THE STATUS.
C     554...  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.
C     556...  FEW FILENAMES SPECIFIED:
C             THERE ARE MORE ELEMENTS OF THE RAYS OF AN ELEMENTARY WAVE
C             THAN THE CORRESPONDING SPECIFIED FILENAMES.
C     557...  FEW FILENAMES SPECIFIED:
C             THERE ARE MORE REQUIRED ELEMENTARY WAVES THAN THE
C             CORRESPONDING SPECIFIED FILENAMES.
C     558...  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.
C
C DATE: 1993, DECEMBER 18
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       READING THE NAME OF THE INPUT DATA
        READ(LUN,*) TEXTW
C
C       READING STRINGS COMPOSING THE NAMES OF OUTPUT FILES (CRT.5.5.1)
        FN1A=' '
        FN1I=' '
        READ(LUN,*) FN1A,FN1I
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
          PAUSE 'ERROR 554 IN WRIT1: FEW LOGICAL UNITS AVAILABLE'
          STOP
        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
      ELSE
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
          CALL FNAME(2,NAME1,NAME2(1))
          IF(NAME2(1).NE.' ') THEN
            OPEN(LUW(1),FILE=NAME2(1),FORM='UNFORMATTED',IOSTAT=IE1)
            IF(IE1.NE.0) THEN
C             OPEN FILE ERROR
              IE2=1
              J=1
              GO TO 91
            END IF
          END IF
          NAME1(1)=FN1I
          CALL FNAME(2,NAME1,NAME2(2))
          IF(NAME2(2).NE.' ') THEN
            OPEN(LUW(2),FILE=NAME2(2),FORM='UNFORMATTED',IOSTAT=IE1)
            IF(IE1.NE.0) THEN
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
          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             OPEN FILE ERROR
              IE2=2
              GO TO 91
            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)
          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             OPEN FILE ERROR
              IE2=5
              GO TO 91
            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
            PAUSE 'ERROR 557 IN WRIT1: FEW FILENAMES SPECIFIED'
            STOP
          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
              PAUSE 'ERROR 556 IN WRIT1: FEW FILENAMES SPECIFIED'
              STOP
            ELSE IF(2*(NF1+NF2+NF3).GT.NUW) THEN
              PAUSE 'ERROR 554 IN WRIT1: FEW LOGICAL UNITS AVAILABLE'
              STOP
            END IF
            DO 45 I=1,NF3
              NAME1(1)=FN3A
              NAME1(2)=FNB(KWRIT3+I)
              NAME1(3)=FN3C
              J=2*(NF1+NF2+I)-1
              CALL FNAME(3,NAME1,NAME2(J))
              IF(NAME2(J).NE.' ') THEN
                OPEN(LUW(J),FILE=NAME2(J),FORM='UNFORMATTED',IOSTAT=IE1)
                IF(IE1.NE.0) THEN
C                 OPEN FILE ERROR
                  IE2=5
                  GO TO 91
                END IF
              END IF
              NAME1(1)=FN3I
              J=2*(NF1+NF2+I)
              CALL FNAME(3,NAME1,NAME2(J))
              IF(NAME2(J).NE.' ') THEN
                OPEN(LUW(J),FILE=NAME2(J),FORM='UNFORMATTED',IOSTAT=IE1)
                IF(IE1.NE.0) THEN
C                 OPEN FILE ERROR
                  IE2=6
                  GO TO 91
                END IF
              END IF
   45       CONTINUE
          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
      END IF
C
C     INDEX OF THE LAST WAVE:
      JWAVE=IWAVE
C
C     SCREEN OUTPUT
      CALL SCRO1(IWAVE)
      RETURN
C
   91 CONTINUE
      WRITE(*,'('' STATUS'',I6,''.'',I1,'': '',A)') IE1,IE2,NAME2(J)
      PAUSE 'ERROR 551 IN WRIT1: OPEN FILE ERROR'
      STOP
   98 CONTINUE
      PAUSE 'ERROR 558 IN WRIT1: END OF INPUT FILE'
      STOP
      END
C
C=======================================================================
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/:
      INTEGER JWAVE,JRAY,JUEB,JFCT,JOUTP,JTRANS
      INTEGER KWRIT1,KWRIT2,KWRIT3,NF1,NF2,NF3,MF3,NUW,MENDR
      PARAMETER (NUW=16)
      PARAMETER (MENDR=17)
      INTEGER LUW(NUW),JPOINT(NUW),JSTOR(NUW)
      INTEGER JENDR(MENDR),NENDR(MENDR+2)
      COMMON/WRITC/JWAVE,JRAY,JUEB,JFCT,JOUTP,JTRANS,KWRIT1,KWRIT2,
     *             KWRIT3,NF1,NF2,NF3,MF3,LUW,JPOINT,JSTOR,JENDR,NENDR
      CHARACTER*16 NAME2(NUW)
      COMMON/WRITN/NAME2
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... FILE 'SCRO.FOR'.
C
C DATE: 1990, NOVEMBER 11
C CODED BY LUDEK KLIMES
C
C-----------------------------------------------------------------------
C
C     AUXILIARY STORAGE LOCATIONS:
      INTEGER I
C
      JRAY=IRAY
      DO 1 I=1,NF2
        JSTOR(I)=0
    1 CONTINUE
C
C     SCREEN OUTPUT
      CALL SCRO2(IRAY)
      RETURN
      END
C
C=======================================================================
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 C.R.T.5.5.1).  IT IS CALLED WITH CONSTANT STEP STORE OF THE
C INDEPENDENT VARIABLE ALONG THE RAY, AND AT THE POINTS OF INTERSECTION
C WITH INTERFACES 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/:
      INTEGER JWAVE,JRAY,JUEB,JFCT,JOUTP,JTRANS
      INTEGER KWRIT1,KWRIT2,KWRIT3,NF1,NF2,NF3,MF3,NUW,MENDR
      PARAMETER (NUW=16)
      PARAMETER (MENDR=17)
      INTEGER LUW(NUW),JPOINT(NUW),JSTOR(NUW)
      INTEGER JENDR(MENDR),NENDR(MENDR+2)
      COMMON/WRITC/JWAVE,JRAY,JUEB,JFCT,JOUTP,JTRANS,KWRIT1,KWRIT2,
     *             KWRIT3,NF1,NF2,NF3,MF3,LUW,JPOINT,JSTOR,JENDR,NENDR
      CHARACTER*16 NAME2(NUW)
      COMMON/WRITN/NAME2
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... FILE 'SCRO.FOR'.
C
C DATE: 1992, DECEMBER 18
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
          WRITE(LUW(1))
     *            JWAVE,JRAY,IY(1),IY(5),IY(6),YY(1),YL,(Y(I),I=1,IY(1))
        END IF
        JPOINT(1)=JPOINT(1)+1
      END IF
C
C     SCREEN OUTPUT
      CALL SCRO3(YL,Y,YY,IY)
      RETURN
      END
C
C=======================================================================
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 C.R.T.5.5.2).  IT IS CALLED AT THE POINTS OF INTERSECTION OF THE
C RAY WITH SPECIFIED 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.R.T.5.5.4).
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             C.R.T.5.5.4):
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'):
      INTEGER MEND,MSTOR
      PARAMETER (MEND=128)
      PARAMETER (MSTOR=128)
      INTEGER KSTORE,NEXPS,NHLF,MODCRT
      REAL STORE,STEP,UEB,UEBPP,UEBPH,UEBHH,UEBDRT,BOUNDR(7)
      INTEGER NSRFCA,NEND,KEND(MEND),NSTOR,KSTOR(MSTOR)
      COMMON/DCRT/ KSTORE,NEXPS,NHLF,MODCRT,STORE,STEP,UEB,UEBPP,UEBPH,
     *             UEBHH,UEBDRT,BOUNDR,NSRFCA,NEND,KEND,NSTOR,KSTOR
C NONE OF THE STORAGE LOCATIONS OF THE COMMON BLOCK ARE ALTERED.
C
C COMMON BLOCKS /WRITC/ AND /WRITN/:
      INTEGER JWAVE,JRAY,JUEB,JFCT,JOUTP,JTRANS
      INTEGER KWRIT1,KWRIT2,KWRIT3,NF1,NF2,NF3,MF3,NUW,MENDR
      PARAMETER (NUW=16)
      PARAMETER (MENDR=17)
      INTEGER LUW(NUW),JPOINT(NUW),JSTOR(NUW)
      INTEGER JENDR(MENDR),NENDR(MENDR+2)
      COMMON/WRITC/JWAVE,JRAY,JUEB,JFCT,JOUTP,JTRANS,KWRIT1,KWRIT2,
     *             KWRIT3,NF1,NF2,NF3,MF3,LUW,JPOINT,JSTOR,JENDR,NENDR
      CHARACTER*16 NAME2(NUW)
      COMMON/WRITN/NAME2
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: 1992, DECEMBER 18
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
          NY=27+NAMPL
          IF(NAME2(2*(NF1+ISTOR)-1).NE.' ') THEN
            WRITE(LUW(2*(NF1+ISTOR)-1))
     *                           JWAVE,JRAY,NY,IY(5),IY(6),YY(1),YL,Y,YC
          END IF
          JPOINT(2*(NF1+ISTOR)-1)=JPOINT(2*(NF1+ISTOR)-1)+1
        END IF
      END IF
      RETURN
      END
C
C=======================================================================
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.R.T.5.5.3).  IT IS CALLED AT THE
C ENDPOINTS OF THE ELEMENTS OF RAYS, SITUATED 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/:
      INTEGER JWAVE,JRAY,JUEB,JFCT,JOUTP,JTRANS
      INTEGER KWRIT1,KWRIT2,KWRIT3,NF1,NF2,NF3,MF3,NUW,MENDR
      PARAMETER (NUW=16)
      PARAMETER (MENDR=17)
      INTEGER LUW(NUW),JPOINT(NUW),JSTOR(NUW)
      INTEGER JENDR(MENDR),NENDR(MENDR+2)
      COMMON/WRITC/JWAVE,JRAY,JUEB,JFCT,JOUTP,JTRANS,KWRIT1,KWRIT2,
     *             KWRIT3,NF1,NF2,NF3,MF3,LUW,JPOINT,JSTOR,JENDR,NENDR
      CHARACTER*16 NAME2(NUW)
      COMMON/WRITN/NAME2
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: 1992, DECEMBER 18
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
          WRITE(LUW(2*(NF1+NF2+I)-1)) JRAY,IY,YL,(Y(I),I=1,IY(1)),YY
        END IF
        JPOINT(2*(NF1+NF2+I)-1)=JPOINT(2*(NF1+NF2+I)-1)+1
      END IF
      RETURN
      END
C
C=======================================================================
C
      SUBROUTINE WRIT4(LULOG,IRAY,YL,Y,YY,IY,IEND,ISHEET)
C
      INTEGER LULOG,IRAY,IY(12),IEND,ISHEET
      REAL YL(6),Y(35),YY(5)
C
C THIS SUBROUTINE STORES THE QUANTITIES AT THE INITIAL POINT OF THE RAY
C (SEE C.R.T.6.1).  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             C.R.T.5.4).  FOR A DETAILED DESCRIPTION SEE SUBROUTINES
C             RAY2 (FILE 'RAY.FOR') AND INIT2 (FILE 'INIT.FOR').
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
C NO OUTPUT.
C
C COMMON BLOCK /DCRT/ (SEE SUBROUTINE FILE 'RAY.FOR'):
      INTEGER MEND,MSTOR
      PARAMETER (MEND=128)
      PARAMETER (MSTOR=128)
      INTEGER KSTORE,NEXPS,NHLF,MODCRT
      REAL STORE,STEP,UEB,UEBPP,UEBPH,UEBHH,UEBDRT,BOUNDR(7)
      INTEGER NSRFCA,NEND,KEND(MEND),NSTOR,KSTOR(MSTOR)
      COMMON/DCRT/ KSTORE,NEXPS,NHLF,MODCRT,STORE,STEP,UEB,UEBPP,UEBPH,
     *             UEBHH,UEBDRT,BOUNDR,NSRFCA,NEND,KEND,NSTOR,KSTOR
C NONE OF THE STORAGE LOCATIONS OF THE COMMON BLOCK ARE ALTERED.
C
C COMMON BLOCK /INITC/ (SEE SUBROUTINE FILE 'INIT.FOR'):
      INTEGER MSRFCA
      PARAMETER (MSRFCA=128)
      INTEGER ISB1I,ICB1I
      REAL YLI(6),YI(25),FSRFCA(MSRFCA)
      COMMON/INITC/ISB1I,ICB1I,YLI,YI,FSRFCA
C NONE OF THE STORAGE LOCATIONS ARE ALTERED.
C
C COMMON BLOCKS /WRITC/ AND /WRITN/:
      INTEGER JWAVE,JRAY,JUEB,JFCT,JOUTP,JTRANS
      INTEGER KWRIT1,KWRIT2,KWRIT3,NF1,NF2,NF3,MF3,NUW,MENDR
      PARAMETER (NUW=16)
      PARAMETER (MENDR=17)
      INTEGER LUW(NUW),JPOINT(NUW),JSTOR(NUW)
      INTEGER JENDR(MENDR),NENDR(MENDR+2)
      COMMON/WRITC/JWAVE,JRAY,JUEB,JFCT,JOUTP,JTRANS,KWRIT1,KWRIT2,
     *             KWRIT3,NF1,NF2,NF3,MF3,LUW,JPOINT,JSTOR,JENDR,NENDR
      CHARACTER*16 NAME2(NUW)
      COMMON/WRITN/NAME2
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... FILE 'SCRO.FOR'.
C     CHECK... THIS FILE.
C
C DATE: 1994, JANUARY 23
C CODED BY LUDEK KLIMES
C
C-----------------------------------------------------------------------
C
C     AUXILIARY STORAGE LOCATIONS:
      INTEGER I,I0,I1,I2,I3,I4,I5,I6,I7,I8,I9
      REAL S12,S13,S23,S14,S24,S34
C
C     WRITING THE QUANTITIES AT THE INITIAL POINT OF THE RAY (C.R.T.6.1)
      I1=-JWAVE
      DO 10 I=1,NF1+NF2+NF3
        IF(NAME2(2*I).NE.' ') THEN
          WRITE(LUW(2*I)) I1,IRAY,ICB1I,IEND,ISHEET,YLI,YI
        END IF
        JPOINT(2*I)=JPOINT(2*I)+1
   10 CONTINUE
C
C     STATISTICS
      JFCT=JFCT+IY(9)
      JOUTP=JOUTP+IY(10)
      JTRANS=JTRANS+IY(11)
      DO 21 I=1,MENDR
        IF(IEND.EQ.JENDR(I)) THEN
          NENDR(I)=NENDR(I)+1
          GO TO 22
        END IF
   21 CONTINUE
      NENDR(MENDR+1)=NENDR(MENDR+1)+1
   22 CONTINUE
      NENDR(MENDR+2)=NENDR(MENDR+2)+1
C
C     WRITING TO THE OUTPUT LOG FILE
C     SIMPLECTICITY OF THE PROPAGATOR MATRIX (SEE C.R.T.5.6L)
      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)
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,31)
   31     FORMAT(7X,'RAY:',5X,
     *      'CHECKED QUANTITIES IN PERCENTS OF THEIR SPECIFIED LIMITS')
        END IF
        JUEB=JUEB+1
        WRITE(LULOG,32) IRAY,I0,I1,I2,I3,I4,I5,I6,I7,I8,I9
   32   FORMAT(  I10,': ',10I6)
      END IF
C
C     SCREEN OUTPUT
      CALL SCRO4(IRAY,YL,Y,YY,IY,IEND,ISHEET)
      RETURN
      END
C
C-----------------------------------------------------------------------
C
      SUBROUTINE CHECK(Q,QUEB,IRATE,I)
      REAL Q,QUEB
      INTEGER IRATE,I
C
C     AUXILIARY SUBROUTINE TO WRIT4
C
      IF(QUEB.GT.0.) THEN
        IRATE=INT(100.*Q/QUEB+0.5)
      ELSE
        IRATE=0
      END IF
      IF(ABS(Q).GT.QUEB) THEN
        I=I+1
      END IF
      RETURN
      END
C
C=======================================================================
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/:
      INTEGER JWAVE,JRAY,JUEB,JFCT,JOUTP,JTRANS
      INTEGER KWRIT1,KWRIT2,KWRIT3,NF1,NF2,NF3,MF3,NUW,MENDR
      PARAMETER (NUW=16)
      PARAMETER (MENDR=17)
      INTEGER LUW(NUW),JPOINT(NUW),JSTOR(NUW)
      INTEGER JENDR(MENDR),NENDR(MENDR+2)
      COMMON/WRITC/JWAVE,JRAY,JUEB,JFCT,JOUTP,JTRANS,KWRIT1,KWRIT2,
     *             KWRIT3,NF1,NF2,NF3,MF3,LUW,JPOINT,JSTOR,JENDR,NENDR
      CHARACTER*16 NAME2(NUW)
      COMMON/WRITN/NAME2
C NONE OF THE STORAGE LOCATIONS OF THE COMMON BLOCK ARE ALTERED.
C
C SUBROUTINES AND EXTERNAL FUNCTIONS REQUIRED:
      EXTERNAL SCRO5
C     SCRO5... FILE '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
      SUBROUTINE FNAME(NUM1,NAME1,NAME2)
      INTEGER NUM1
      CHARACTER*(*) NAME1(NUM1)
      CHARACTER*(*) NAME2
C
C THIS SUBROUTINE IS DESIGNED TO ANALYSE THE SPECIFIED STRINGS AND TO
C COMPOSE THE FILENAME OF THEM.
C
C INPUT:
C     NAME1...CHARACTER ARRAY OF CHARACTER STRINGS TO BE ANALYSED.
C     NUM1... NUMBER OF FILENAMES TO BE ANALYSED.
C
C OUTPUT:
C     NAME2...FILENAME COMPOSED OF THE ANALYSED INPUT COMPONENTS
C             (STRINGS).
C
C NO SUBROUTINES AND EXTERNAL FUNCTIONS REQUIRED.
C
C ERROR MESSAGES:
C     559...  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.
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 ANALYSED STRINGS.
C     J1(N)...NUMBER OF THE CURRENTLY ANALYSED CHARACTERS OF NAME1(N),
C             I.E. THE POSITION OF THE SPACE AFTER THE LAST ANALYSED
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 ANALYSED 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
        PAUSE 'ERROR 559 IN FNAME: TOO MANY STRINGS'
        STOP
      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) ANALYSING 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
