!      PROGRAM MARCO      VERSION  2.6  June, 1998
!!
!!**********Modified file***************dont use
!
!       Previous releases:  Version 2.2  October, 1997
!                           Version 2.1  May, 1997
!                           Version 2.0  October, 1996
!                           Version 1.2  February, 1996
!                           Version 1.1  September, 1995
!
!               ELECTROMAGNETIC MODELLING GROUP
!               CRC FOR AUSTRALIAN MINERAL EXPLORATION TECHNOLOGIES
!               located at
!               EARTH SCIENCES, MACQUARIE UNIVERSITY, NSW, 2109, AUSTRALIA.
!
!
!    #######################################################################
!    #*********************************************************************#
!    #*                                                                   *#
!    #*  THIS PROGRAM HAS BEEN RELEASED STRICTLY FOR THE USE OF SPONSORS  *#
!    #*   OF AMIRA PROJECT P223D AND THEIR AUTHORISED AGENTS.             *#
!    #*                                                                   *#
!    #*********************************************************************#
!    #######################################################################
!
!
!       CHANGES SINCE VERSION 2.2
!
!
!    1. Version numbers are printed immediately when the program starts
!       to run.  This is important since different versions may require
!       different input format.
!
!    2. Axial electric component has been added to the output for non-vertical
!       bohrhole measurements.  There had been in fact an error in printing
!       outputs of downhole responses of inclined wells under electric bipoles
!       or loop transmitters in the frequency domain.
!
!    3. An error has been found which affects the fast solver option
!       (KACC=1).  This error was caused by the reformulation of the routine
!       STRUCTURING from the Fortran 77 version to the Fortran 90 version.
!
!    4. An error has been corrected which cause array allocation problem for
!       electric current bipoles if the bipoles across a layer boundary.
!
!    5. For receivers in drillholes the z-coordinates must be negative.
!       Earlier versions of Marco do continue to run if you inadvertly set
!       those coordinates to be positive so that they are in fact in the air.
!       A test has now been designed to halt the excution should this happens.
!
!    6. Automatic test and re-arranging of electrode positions for vertical
!       current bipoles has been added in the current version.  The program
!       reverses the position of the first and the second electrodes of a
!       current bipole pair if the positions in the input data are wrongly
!       specified.  Previous versions of Marco yielded wrong results if the
!       second electrode is above the first one.
!
!    7. The run time message "Spatial Symmetry Reduction Used!" which confused
!       some users no longer appears.  However, users are urged to read the
!       section STRUCTURE, SYMMETRY, AND SPEED, just before the description of
!       RECORD 12.  The use of the symmetry option can cut runtimes by as much
!       as an order of magnitude in some cases.
!
!    8. Units are specified for the output electric and magnetic fields.
!       We use standard SI units, i.e., Volts/m for the electric field and
!       Ampers/m for the magnetic field.  This may differ from the units
!       people use in exploration but outputs in standard SI make it also
!       more convenient for the user to transform the  data for other
!       purposes such as tensor CSAMT analysis.
!
!    9. Extended explanation of the use of dip for the transmitters and
!       receivers in downhole application in the documentation.  Our
!       definition of dip is equivalent to another term used in exploration,
!       the hade angle.  Here define 0 = vertical because of the fact that
!       this is the angle between the dipole and the axis of the bohrhole.
!
!   10. An array allocation problem has been corrected which affects MT
!       computations.
!
!
!       CHANGES SINCE VERSION 2.1
!
! 1. An internal conversion error in the receiver vertical coordinates has been
!    corrected.  The user is asked to specify sub surface receiver positions as
!    RL's.  This usually means that the entries will have a negative sign. If
!    the mis-directed user of 2.1 followed this specification, the program would
!    compute the responses above the surface rather than downhole.
!
!  NOTE:  Downhole receiver and transmitter positions are specified as RL's;
!         i.e., as negative numbers. BUT
!         The vertical position of the target blocks is specified as depth to
!         the top surface from the earth-air interface; i.e. as a positive number
!         so as to be consistent with Marco_Air & Leroi_Air.
!         Thus the variable, SURFACE_RL requested in RECORD 2 is irrelevant in
!         specifying target location.
!
! 2. A serious documentation omission was fixed.  The new RECORD 7 for frequency-
!    domain options specifies whether or not the position of the receiver array
!    changes with changing transmitter position.  This was not documented
!    previously.
!
!    Changes prior to this release are contained at the end of the documentation
!    section, before the start of the main program.

!********************
!   DESCRIPTION     *
!********************
!
!  Within a multi-layered earth, Marco computes the frequency domain and/or
!  the time domain responses for any arbitrary structure which can be
!  composed of multiple rectilinear prisms oriented parallel to the three
!  component axes.
!  Cole-Cole resistivities may be specified for target and layers.
!  Receivers may be in air, downhole, or on the surface of the earth.
!
!  Marco also computes high frequency radio imaging responses for grounded
!  sources and downhole magnetic dipole sources.
!
!  Marco uses multiple prismatic blocks to simulate arbitrary structures.
!  The conductivity in each block can be arbitrary or constant.  The
!  program also allows symmetric structures with two symmetry planes,
!  the (XOZ) and (YOZ) planes, with the shape and conductivity of the
!  structure in one quadrant being arbitrary.  Symmetrical considerations
!  greatly saves both computation time and storage requirements.
!
!  This program uses a system iterative method for solving the matrix
!  equation,  thus it allows a large number of cells to be handled for
!  large and complex structures.  The division of substructures are
!  done automatically by the program itself if the number of cells for the
!  structure or for one quadrant of a symmetric structure exceeds defined
!  limits for a single scattering matrix.  There is in fact no limit on
!  the total number of cells to be computed by this program.  If the
!  structure is discretized into equal sized cells that fit in a uniform
!  grid, the program will invoke spatial symmetry reductions to speed up
!  the computation for the Green's functions.  The spatial symmetry
!  reductions also enable fast re-computation of all matrix elements,
!  which in conjunction with the method of system iteration allows tens,
!  or even hundreds of thousands of cells.  Thus there is no limit on the
!  size of the models to be computed,  as long as there is available
!  computer time.
!
!  This current version of Marco is however restricted to conductivity
!  contrasts of up to about 1000 to 1 between the 3D target and its
!  immediate host.
!
!*************************
!   GEOMETRY CONVENTIONS *
!*************************
!
!   USER SYSTEM
!
!   Depths are expressed in RLs (relative levels which increase negatively
!   with depth.  Horizontal positions are expressed in Eastings and Northings.
!
!   FOR DOWNHOLE APPLICATIONS
!
!   In addition to the three positional coordinates, if a receiver or
!   transmitter is downhole, two orientation angles, azimuth and dip,
!   are required.  If the user wants output in the global East, North,
!   Vertical system, the receiver dip should be specified as 0 degrees.
!   Alternatively, output can be given in the local system with the following
!   conventions.  Although the drill is not logged per se, the description
!   below assumes that receiver axis and the drill hole axis are the same.
!
!   A vertical drill hole has a dip of 0,  A horizontal portion has a
!   90 degree dip.  If it bends back upwards towards the surface, the
!   dip > 90 degrees.
!
!   Azimuth is 0 due North, 90 due East and 180 due South.  If the drill hole
!   axis at a given depth is due West of its axis on the surface, then the
!   azimuth angle is 270 or -90 degrees.  If the dip > 0, then the output
!   components are C1, C2, C3 where C3 is the axial component, C1 is the
!   component perpendicular to C3, lying in the vertical plane and C3 is
!   the horizontal component perpendicular to C1 and C3.
!
!   INTERNAL PROGRAM SYSTEM
!
!   The system is right-handed with X positive North, Y positive East,
!   and Z positive down.  This is consistent with angles being defined
!   as positive going East from North.  It is also chosen to maintain internal
!   consistency with other programs released by the group.
!
!
!*********************
!   FILE CONVENTIONS *
!*********************
!
!   INPUT data are read from logical unit number 3 and
!   OUTPUT data are written to unit 4.
!   OUTPUT.FRQ data are written to unit 7.
!
!    UNIT #   UNIT ID    FILE ID        FUNCTION
!    ------   -------    -------        --------
!      3        NR       INPUT.DAT      INPUT DATA
!      4        NW       OUTPUT.OUT     TIME-DOMAIN OUTPUT DATA
!      7        ND       OUTPUT.FRQ     FREQUENCY-DOMAIN DATA
!      22       NA       AMIRA.FMT      AMIRA FORMAT OUTPUT DATA
!
!  These unit numbers are set at the start of the MAIN program
!  and can be changed to suit the users host computer.
!
!
!===== Frequency domain output files
!
!   For ground applications and for downhole measurements with strictly
!   vertical drillholes the frequency domain output file OUTPUT.OUT contains
!   ALL SIX components at each receiver site.  The user can specify output
!   either as sounding or in profile formats, or both.  In addition to field
!   components, the CSAMT option prints apparent resistivities in terms of
!   amplitudes and phases for each electric and magnetic field pair.
!
!   For downhole receivers in an INCLINED DRILLHOLE, the three components of
!   the magnetic field in the coaxial, normal, and horizontal direction of the
!   local coordinate systems defined by the drillhole angles are printed.
!
!   For MT applications, 7 files are printed,  The general file OUTPUT.OUT
!   and 6 files for the sounding and profile outputs for the amplitudes and
!   phases of the apparent resistivities,  FRQRES, FRQPHS, RES_X, RES_Y, PHS_X,
!   and PHS_Y.
!
!*******************
!  USEFUL FEATURES *
!*******************
!
!  For time-domain applications, the frequency- domain results are written
!  UNIT 7 to a file called OUTPUT.FRQ.
!  This allows the user to experiment with different transmitter waveforms
!  and receiver windows without re-running the entire frequency-domain
!  computation as long as the model and Tx-Rx geometry remain the same.
!  Specifying NTEM3D = 2 in RECORD 4 will accomplish this.
!  Scattered fields can now be printed by specifying NTEM3D as a negative
!  integer; i.e., NTEM3D = -1 or -2.
!
!  Marco allows for arbitrary transmitter waveform input.
!  One can input linear segment waveforms with corners (ICURV = 0)
!  or smooth waveforms (ICURV = 1).  Either of these can be repeated as
!  bipolar pulses (IBPLR = 0) or as a series of positive pulses (IBPLR = 1).
!
!   MARCO allows the user to model a layered half-spaces of up to 20 layers.
!
!*********************
!  TECHNICAL ASPECTS *
!*********************
!
!  The time-domain response is computed by first calculating the
!  frequency-domain response from 0.1 Hz to 100 kHz at an interval
!  of six frequencies per decade.  A cubic spline interpolation of
!  the imaginary component of the magnetic field is used to
!  represent the frequency-domain response over the whole spectrum.
!
!  The time domain-magnetic fields are computed using digital
!  filter coefficients which had been derived from the fast Hankel
!  transform program of Johansen and Sorensen.  A spline is fit to
!  the time-domain magnetic fields and db/dt is computed using the
!  spline coefficients.  This is then convolved with the source
!  function to give the field voltages (area * db/dt).
!
!  Marco avoids a problem which can arise from using representing the
!  normal field from the transmitter loop as a line integration of
!  horizontal electric dipoles.  The dipoles one opposite sides of the loop
!  contribute fields of opposite sign.  At late times, these have the same
!  magnitude so that the sum produces numerical chaos.  Before this
!  happens, the "smoke ring" passes the transmitter boundary which means
!  that the transmitter acts like a single vertical magnetic dipole.  An
!  even more accurate approximation at this point is to use the response
!  from a circular loop of equal area.  These computations do not suffer
!  from numerical instability at late times.
!  This version tests for this condition and switches representation
!  before numerical chaos sets in.  This will affect the horizontal
!  fields more than the vertical ones.
!
!**********************************
!  TIME-DOMAIN SYSTEM CONVENTIONS *
!**********************************
!
!  For Sirotem and EM37 options, this program assumes a bipolar transmitter
!  waveform with an exponential rise time constant of TRISE and a ramp
!  turnoff time TRMP.  The offtime and ontime are each of duration OFFTYM.
!  The offtime starts from the top of ramp turnoff.
!  The ontime starts from the beginning of the exponential rise.
!  For Sirotem options, the delay times are referenced from the top of
!  the ramp turnoff.
!  For EM37 and user supplied delay time options, delay time is
!  referenced from the foot of ramp turnoff.
!
!  The user defined option (ITYM = 2) also assumes a bipolar waveform
!  of 4 non-overlapping parts: a linear ramp turnon, an on-time of
!  constant current = 1 amp, a linear ramp turn-off, and an off-time.
!
!  The arbitrary waveform options (ITYM = 4) allow a general waveform
!  which may or may not be bi-polar in form.
!
!  The ROI_UTEM option is the only one which allows for measurements during
!  the on-time because there is no off-time
!
!***************************************************************************
!************         DESCRIPTION OF DATA RECORDS            ***************
!***************************************************************************
!
!  All records are in list directed (free) format except for
!  the TITLE in RECORD 1.
!
!    NOTE:  All distances and locations are to be specified in metres.
!    ----   All angles are to be specified in degrees.
!
!      In plan view, the coordinate system used for input and output
!      has X positive to the North and Y positive to the East
!      RLs (relative levels increase negatively downwards.
!
!***************************************************************************
!
!** RECORD 1:  TITLE - UP TO 80 CHARACTERS
!
!** RECORD 2:  FREQ_TYM, SURFACE_RL
!
!    FREQ_TYM = 0 compute time domain responses for rectangular loop
!                 source-receiver configurations.
!
!             = 1 compute frequency domain responses with various
!                 systems.
!
!    SURFACE_RL - relative level of air-earth interface in metres.
!
!================================================================================
! AT THIS POINT, DAYA INPUT FOR TIME-DOMAIN & FREQUENCY-DOMAIN SYSTEM
! COMPUTATIONS IS SPLIT INTO TWO SEPARATE SECTIONS!
!================================================================================
!
!  FOR TIME-DOMAIN systems (FREQ_TYM = 0), continue on TO RECORD 3.
!  FOR FREQUENCY-DOMAIN systems (FREQ_TYM = 1), go past RECORD 16 of this
!  section and begin with RECORD 3 of the frequency-domain section.
!
!***************************************************************************
!
!    INPUT DATA DESCRIPTION FOR TIME-DOMAIN SYSTEMS  ( FREQ_TYM = 0 )
!
!***************************************************************************
!
!         CONTROL PARAMETERS FOR TIME-DOMAIN SYSTEMS
!         ------------------------------------------
!
!** RECORD 3:  NTEM3D, IPRF, ISTOP
!
!      NTEM3D = 1  compute new 3D model
!
!             = 2  instead of computing the frequency-domain responses
!                 (70-99 percent of Marco's usual computation time) use
!                 previously computed frequency-domain responses contained
!                 in file OUTPUT.FRQ to calculate 3-D time-domain responses.
!
!             = 0  compute layered half-space model only. (no sheet)
!
!         Specifying NTEM3D as -1 or -2 will cause the program to
!         additionally print the un-normalised scattered fields.
!
!       IPRF = 1  OUTPUT VOLTAGES IN TEMPORAL MODE
!                 each voltage column contains the voltages at a given
!                 receiver position for all channels.
!
!            = 2  OUTPUT VOLTAGES IN PROFILE MODE
!                 each voltage column contains the voltages for a given
!                 channel for a specified bird for profile stations
!
!       ISTOP = 0  read the input data and run the specified models.
!             = 1  read the input data, print the model description
!                  and STOP so that the model description can be verified.
!                  REMEMBER to change ISTOP to 0 once the models have been
!                  verified.
!
!            If ISTOP is set to a negative integer, a 12 point per decade
!            model will be run from 1 Hz to 1 MHz instead of .1 MHz; i.e.
!            73 frequency-domain models instead of 31.
!
!  NOTE:  Each time MARCO is run with NTEM3D = 1, a file called
!         OUTPUT.FRQ is created on logical unit ND = 7.  MARCO reads this
!         file to produce the time-domain responses.  Setting NTEM3D = 2
!         allows the user to test different time-domain systems
!         (with the same model and Tx-Rx geometry of course) in a tiny
!         fraction of the time required to rerun the whole model.
!
!         MARCO prints out TOTAL response for each component.
!         The scattered response is defined as the
!         vortex + current gathering parts; i.e., the total field minus the
!         the layered earth field.  MARCO also prints out the percent
!         scattered response; i.e., the scattered field normalised by the
!         total field.
!         Specifying NTEM3D as -1 or -2 will cause the program to
!         additionally print the un-normalised scattered fields.
!
!         TIME-DOMAIN SYSTEM INFORMATION
!         ------------------------------
!
!** RECORD 4:  NCHNL, ITYM, IDH
!
!      NCHNL - number of channels or delay times
!
!                    EM37 OPTIONS.
!                    ------------
!            ITYM = -3  Use EM37 2.5 Hz. delay times.
!                   -2  Use EM37 6.25 Hz. delay times.
!                   -1  Use EM37 25 Hz. delay times.
!
!                    SIROTEM OPTIONS.
!                    ---------------
!            ITYM  = 0  Sirotem early time option.
!                  = 1  Standard Sirotem delay times are used.
!
!                    USER SUPPLIED DELAY TIMES. (BOXCAR PULSES WITH RAMPS)
!                    --------------------------
!            ITYM  = 2   User delay times and transmitter on, off, ramp,
!                        and rise times read as input data.
!
!                    ARBITRARY WAVEFORM OPTION
!                    -------------------------
!            ITYM  = 4   Digitised waveform will be entered in RECORD 6
!
!                    ROI_UTEM OPTION
!                    -----------
!            ITYM  = 9   ROI_UTEM option;  NCHNL must = 10 or 20
!      The downhole option for the ROI_UTEM system has not yet been implemented.
!      Thus the combination IDH = 1 with ITYM = 9 is not allowed.
!
!
!      IDH  - survey type
!
!        IDH = 0  if all roving receivers are on the surface.
!            = 1  if any receiver is below the surface.
!            = 6  single receiver at constant x-y offset
!                 e.g. central loop or slingram configuration
!            = 7  coincident loop option
!
!  NOTE: ONLY IDH = 0 IS ALLOWED FOR ROI_UTEM OPTION (ITYM = 9) !!!!
!
!================================
!   ONLY IF ITYM = 9  (ROI_UTEM)
!================================
!** RECORD 4:  BASFRQ - base frequency in Hz.
!
!  ROI_UTEM system entry is finished.
!  IF NTEM3D = 1, Go to RECORD 7 to enter transmitter data.
!  IF NTEM3D = 2, DATA ENTRY IS FINISHED, since all further information
!                will be contained in the file OUTPUT.FRQ
!**********************************************************************
!
!======================================
!   ONLY IF ITYM IS LESS THAN 0  (EM37)
!======================================
!** RECORD 5:  TRMP, TRYS
!
!                TRMP - ramp turnoff time in ms.
!                TRYS - turn on exponential time constant in ms.
!      NOTE: An exponential time constant = TRYS is computationally
!            equivalent to a ramp turn on = 2. * TRYS.  In fact, this is
!            how the program computes the effect of signal risetime.
!            So - in the absence of measured risetimes, try TRYS = TRMP/2
!
!  EM37 system entry is finished.
!  IF NTEM3D = 1, Go to RECORD 7 to enter transmitter data.
!  IF NTEM3D = 2, DATA ENTRY IS FINISHED, since all further information
!                will be contained in the file OUTPUT.FRQ
!**********************************************************************
!
!==================================
!  ONLY IF ITYM = 0 OR 1  (Sirotem)
!==================================
!** RECORD 4:  TRMP, TRYS, RXAREA   if IDH .NE. 7  OR
!              TRMP, TRYS           if IDH = 7   (coincident loop)
!
!            RXAREA - effective area of receivers in square metres.
!              TRMP - ramp turnoff time in ms.
!              TRYS - turn on exponential time constant in ms.
!
!      NOTE: An exponential time constant = TRYS is computationally
!            equivalent to a ramp turn on = 2. * TRYS.  In fact, this is
!            how the program computes the effect of signal risetime.
!            So - in the absence of measured risetimes, try TRYS = TRMP/2
!
!  SIROTEM system entry is finished.
!  IF NTEM3D = 1, Go to RECORD 7 to enter transmitter data.
!  IF NTEM3D = 2, DATA ENTRY IS FINISHED, since all further information
!                will be contained in the file OUTPUT.FRQ
!**********************************************************************
!
!============================================================
!  ONLY IF ITYM = 2 (User defined bipolar boxcar with ramps)
!============================================================
!** RECORD 5:  IRXW, TRMP, TRYS, OFFTYM, ONTYM, RXAREA   if IDH .NE. 7  OR
!              IRXW, TRMP, TRYS, OFFTYM, ONTYM           if IDH = 7
!
!               IRXW =  0  User does not specify Rx window widths.
!                          These are set by the program to be
!                          15 percent of the delay time value.
!                    =  1  Receiver window widths are to be read from
!                          RECORD 7.1.
!               TRMP - ramp turnoff time in ms.
!               TRYS - turn-on ramp time in ms.
!                     (this is a linear ramp, not an exponential one)
!
!             OFFTYM - time (ms) during which current = 0
!                      (does not include TRMP or TRYS)
!                      OFFTYM must be > TMS(NCHNL) + .5* WTMS(NCHNL)
!              ONTYM - time (ms) during which current is constant
!                      (does not include TRMP or TRYS)
!             RXAREA - effective area of receivers in square metres.
!*******************************************************************
!
!========================================
!  ONLY IF ITYM = 4 (Arbitrary waveform)
!============================================================
!** RECORD 5:  IRXW, IBPLR, ICURV, NSX, OFFTYM, RXAREA   if IDH .NE. 7  OR
!              IRXW, IBPLR, ICURV, NSX, OFFTYM           if IDH = 7
!
!           IRXW =  0  User does not specify Rx window widths.
!                      These are set by the program to be
!                      15 percent of the delay time value.
!                =  1  Receiver window widths are to be read from
!                      RECORD 7.1.
!
!          IBPLR =  0  bipolar pulse
!                      (each pulse is the negative of the previous pulse)
!                =  1  monopolar pulse
!                      (each pulse is the same as the previous pulse)
!
!          ICURV =  0  the transmitter waveform is composed of linear
!                      segments between specified points.
!                =  1  the transmitter waveform is a smooth curve
!                      between specified points.
!    NOTE: The wave form time - current amplitude pairs are read in
!          RECORD 8.  For the same pairs, ICURV = 1 will give a lower
!          amplitude and different decay rate response compared to
!          ICURV = 0 because the sharp corners (discontinuous first
!          derivatives) are smoothed since ICURV = 1 uses cubic splines
!          to produce a smooth transmitter waveform.
!
!            NSX - number of time points used to specify digitised
!                  time-current transmitter waveform
!
!         OFFTYM - time (ms) during which current is switched off
!                  OFFTYM must be > TMS(NCHNL) + .5* WTMS(NCHNL)
!
!         RXAREA - effective area of receivers in square metres.
!
!=========================
!  ONLY IF ITYM = 2 OR 4
!=========================
!** RECORD 6: (TMS(J), J=1,NCHNL)  -  Delay times in milliseconds
!                                     (from the end of ramp turnoff)
!
!=====================================
!  ONLY IF ITYM = 2 or 4 AND IRXW = 1
!=====================================
!** RECORD 6.1: (WTMS(J), J=1,NCHNL) - window width of each receiver channel
!
!  IF ITYM = 2 THEN
!    system entry is finished.
!    IF NTEM3D = 1, Go to RECORD 7 to enter transmitter data.
!    IF NTEM3D = 2, DATA ENTRY IS FINISHED, since all further information
!                will be contained in the file OUTPUT.FRQ
!  ENDIF for ITYM = 2
!************************************************************************
!************************************************************************
!
!==========================----===========
!  ONLY IF ITYM = 4 (Arbitrary waveform)
!==========================----===========
!** RECORD 7:   (TXON(J), TXAMP(J),  J = 1, NSX)
!
!
!       TXON(J) = digitised time (in milliseconds) at J
!      TXAMP(J) = transmitter current (in amps) at time TXON(J)
!
!      TXON AND TXAMP ARE ENTERED AS PAIRS.
!
!      REQUIREMENTS:  TXON(1) = 0,  TXAMP(1) = 0
!                    TXON(NSX) = pulse ontime (ms),  TXAMP(NSX) = 0
!
!    End of arbitrary waveform entry.
!    IF NTEM3D = 2, DATA ENTRY IS FINISHED, since all further information
!                 will be contained in the file OUTPUT.FRQ
!**********************************************************************
!
!         TRANSMITTER - RECEIVER INFORMATION
!         **********************************
!
!** RECORD 8:  NTX   (number of transmitter positions)
!
!=======================================================================|
!  ONLY FOR IDH = 6   which means that there is a single receiver at    |
!                     constant offset from transmitter such as occurs   |
!                     for central loop or slingram configurations.      |
!                                                                       |
!** RECORD 8.P: RXF, RYF  - East - North offsets of single receiver     |
!                           relative to transmitter loop centre.                    |
!                           For central loop, RXF = 0,  RYF = 0         |
!========================================================================
!
!         TRANSMITTER LOCATIONS
!         ---------------------
!   For each rectangular loop source, I (I = 1, NTX), enter the East - North
!   coordinates of the four transmitter loop vertices in counter-clockwise
!   order.  The loop must be rectangular.
!
!  THERE WILL BE NTX BLOCKS OF 4 LINES EACH (TRANSMITTER CORNER COORDINATES)
!  ENTERED BEFORE PROCEEDING ON TO RECEIVER COORDINATE ENTRY (IF APPLICABLE).
!
!**  RECORD 8.1:  SX(1,I), SY(1,I) - bottom left (SW) corner
!**  RECORD 8.2:  SX(2,I), SY(2,I) - bottom right (SE) corner
!**  RECORD 8.3:  SX(3,I), SY(3,I) - top right (NE) corner
!**  RECORD 8.4:  SX(4,I), SY(4,I) - top left (NW) corner
!
!  RECEIVER LOCATIONS
!  ------------------
!
!=========================================================================
!  IF IDH = 6 or 7 (coincident loop option),
!  SKIP  RECORDS 8, 8.1, 8.2, & 8.3
!  GO DIRECTLY TO RECORD 9.
!=========================================================================
!
!** RECORD 9:  (NRX(I), I = 1,NTX)  - number of receivers for ALL (!!)
!                                     transmitters
!   SURFACE RECEIVERS (IDH = 0)
!** RECORD 9.1: RE(1,I), RN(1,I)
!           .
!** RECORD 9.J: RE(J,I), RN(J,I)
!** RECORD 9.NRX: RE(NRX,I), RN(NRX,I)
!
!======================================
!  DOWNHOLE RECEIVERS (ONLY IF IDH = 1)
!======================================
!** RECORD 9.1: RE(1,I), RN(1,I), RZ(1,J), RDIP(1,J), RPHI(1,J)
!           .
!** RECORD 9.NRX: RE(NRX,I), RN(NRX,I), RZ(NRX,J), RDIP(NRX,J), RPHI(NRX,J)
!
!  RE & RN are the East & North components of the receivers
!  RZ is the relative level of the receiver.  (RZ < SURFACE_RL)

!  Angles are specified in degrees.
!  THE Dip angle, RDIP is zero for vertical receivers and 90 degrees for
!  horizontal  receivers.  Azimuth angle RPHI is defined as 0 degrees due
!  north and 90 degrees due East.
!
!         LAYERED EARTH MODEL PARAMETERS
!         ------------------------------
!** RECORD 10:  NLAYER - number of layers including host.
!
!      Specify NLAYER as a negative number if any layer is to have
!      a complex resistivity.  (Cole-Cole model)
!
!         NLAYER can be a positive integer from 1 to 20.
!             in which case a pure real earth is assumed and only
!             resistivities and thickness are specified in RECORD 15
!
!         OR  a negative integer from -1 to -20 in which case one must also
!             specify Cole-Cole parameters in RECORD 15.
!
!==================================================================
!   FOR NLAYER > 0
!
!** RECORD 11.1: THICK(1), RES(1)
!     .
!     .
!     .
!** RECORD 11.J: THICK(J), RES(J)
!
!** RECORD 11.NL: RES(NL)         MAX VALUE of NL = 20
!==================================================================
!  OR IF NLAYER < 0
!** RECORD 11.1: THICK(1), RES(1), CHRG(1), CTAU(1), CFREQ(1)
!
!     .
!     .
!** RECORD 11.J: THICK(J), RES(J), CHRG(J), CTAU(J), CFREQ(J)
!
!** RECORD 11.NL: RES(NL), CHRG(NL), CTAU(NL), CFREQ(NL)
!
!               NL = NLAYER
!         THICK(J) = thickness of layer J
!           RES(J) = resistivity of layer J
!          CHRG(J) = instantaneous chargeability of layer J
!          CTAU(J) = time constant of layer J (in seconds)
!         CFREQ(J) = frequency constant of layer J
!
!   Note that NLAYER < 0 causes all resistivities to be Cole-Cole,  which
!   means that Cole-Cole models must be input for the 3D target if it
!   is going to be computed ( ABS (NTEM3D) > 0 ).
!
!****************************************
!  DATA ENTRY IS FINISHED IF NTEM3D = 0,
!****************************************
!
!** Input data for the 3D target
!
!            STRUCTURE, SYMMETRY, AND SPEED
!            ------------------------------
!
!  Marco can build up geometrically complex models as an agglomeration
!  of rectangular bricks whose boundaries are parallel to the three
!  coordinate axes.  The bricks can touch or be separated by any distance.
!  Thus a model could consist of a complex structure composed of abutting
!  rectangular bricks plus another distant structure.  The input parameter
!  TRGT_BLCK in RECORD 12 specifies the number of bricks needed to build a
!  model.
!
!  Marcoair contains a spatial symmetry reduction algorithm which can decrease
!  model computation times substantially, particularly when the 3D structure
!  is composed of more than one block (TRGT_BLCK > 1).  This rquires that
!
!  1. all blocks are discretised into equal-sized cells and that
!  2. all blocks must be aligned such that the distances between
!     the blocks are integer multiples of cell dimensions.
!
!     Alternatively, visualise a uniformly discritised super mesh, large
!     enough to contain the entire target block structure.
!
!  Computation times can be further reduced by as much as an order of
!  magnitude if the total model has two-fold symmetry; ie, it is symmetric
!  with respect to both the both North-South and East-West axes.
!  In this case set KSYMM = 1 in RECORD 12 to invoke this symmetry
!  reduction technique.
!
!  NOTE 1: The symmetry is necessary for the model only and is not required
!           for transmitter or receiver positions.
!
!  NOTE 2: Both symmetry reduction techniques retain accuracy.
!
!
!    COMPUTATION SPEED, MODEL SIZE, and SOLUTION METHOD
!    --------------------------------------------------
!
!    As memtioned at the beginningof this document,  there is no limit on the
!    total number of cells this program can handle,  thanks to the use of a
!    block iterative solver which is referred to as the method of system
!    iteration.  Although choosing the direct or the iterative solver is done
!    automatically by the code itself,  according to the size of the problem,
!    it is important that the user understand how the code chooses the solvers.
!    For those who would rather not bother with those trivialities please
!    proceed to the next section entitled "MORE SPEED".
!
!    For a single transmitter position, iterative matrix solution methods are
!    faster than direct methods.  The speed advantage grows rapidly as the
!    size of the model increases.  However, direct methods allow one to model
!    effect of many transmitter positions simultaneously whereas the iterative
!    solution must begin anew for each new transmitter position.  Thus direct
!    methods are best for small models with many transmitter positions and
!    iterative models are best for big models with few transmitter positions.
!
!    Thus if there are many transmitter positions, it is advantageous to use
!    the direct solver.  However, you may have to use the iterative solver
!    if the target is big or if your system has limited memory.
!
!    To give you a rough idea on how much memory is required to run the job
!    using the direct solver,  here are the sizes of the matrices involved for
!    the total number of cells (in your input data only,  because this is the
!    total number of cells in one quadrant for a symmetric model):
!
!         Total number of cells       Size of the matrix (in Mega-Bytes)
!
!                 300                           6.48
!                 500                          18
!                 800                          46.08
!                1000                          72
!                1500                         162
!                2000                         288
!
!    Note that the size of the matrix increases quadratically with the number
!    of cells.  Therefore,  the iterative solver becomes advantageous if the
!    model is big (with a large number of cells).
!
!    The controlling parameter for the switch between the direct solver and the
!    iterative solver is SUB_CELL_MAX.  Currently this parameter is set to 500
!    at the beginning of the main program on the line like
!
!      INTEGER, PARAMETER :: SUB_CELL_MAX=500
!
!    You may want to adjust this number according to the memory of your computer.
!
!    To confuse you further,  Marco has another feature to re-compute the Green's
!    functions matrix for each iteration if the model discretization allows the
!    use of spatial symmetry reduction.  Accoding to the above table,  you can
!    readily calculate the for a discretization with 10,000 cells the size of
!    the matrix is 7.2 Giga-bytes.  Not to say that there is no computer equipped
!    with that much memory,  such a big disk is also rare.  By utilising the
!    spatial symmetry reduction to re-generate the matrix entries such huge
!    matrices literally do not exist with Marco.  One exception:  re-computing
!    the matrix entries using the group symmetric operations is about 2 to 3
!    times more costly than reading stored data on the disk (for most UNIX
!    systems) for symmetric models (KSYMM=1).  Therefore,  Marco re-computes
!    the four block matrices of a symmetric model (KSYMM=1) only if the number
!    of cells in one quadrant exceeds 800 which would otherwise require over
!    200 Mega-bytes of disk space.
!
!
!  MORE SPEED (but less accuracy)
!  ------------------------------
!
!  Sometimes you may want to run a model very quickly to get a general idea
!  of what the profile will look like.  In this case set KACC = 1.  For
!  general use, set KACC = 2.  For final reports, we use KACC = 3.
!
!
!** RECORD 12:  KSYMM, TRGT_BLCK, KACC
!
!            KSYMM = 0:  general non-symmetric model
!                  = 1:  model symmetric to the (XOZ) and (YOZ) planes
!
!        TRGT_BLCK = Number of blocks.
!             KACC = Accuracy level for the computation of the scattered
!                    field.
!
!                    CHOOSE 2 OR 3 FOR ACCURATE COMPUTATION.
!
!                    KACC = 1 invokes a fast solver that uses a fast
!                    approximation for the solution of the matrix
!                    equation.
!
!   The model below can be described using KSYMM = 0 in which case TRGT_BLCK = 7
!   It can also be described using KSYMM = 1 in which case TRGT_BLCK = 3
!
!
!                                NORTH
!
!                                  ^
!                                  |
!                                  |
!     xxxxxxxxxxxxxxxx      xxxxxxx|xxxxxxx     xxxxxxxxxxxxxxxx
!     x              x      x      |      x     x              x
!     x      4.      x      x      |  2.  x     x     1.       x
!     x              x      xxxxxxx|xxxxxxx     x              x
!     xxxxxxxxxxxxxxxx             |            xxxxxxxxxxxxxxxx
!                                  |
!                             xxxxx|xxxxx
!                             x    | 3. x
!   --------------------------x----|----x---------------------------->  EAST
!                             x    |    x
!                             xxxxx|xxxxx
!                                  |
!     xxxxxxxxxxxxxxxx             |            xxxxxxxxxxxxxxxx
!     x              x      xxxxxxx|xxxxxxx     x              x
!     x       5.     x      x      |  6.  x     x     7.       x
!     x              x      x      |      x     x              x
!     xxxxxxxxxxxxxxxx      xxxxxxx|xxxxxxx     xxxxxxxxxxxxxxxx
!                                  |
!                                  |
!
!                     FIG 1 - an example of a symmetric model
!
!
!   BUILDING THE MODEL OUT OF ONE OR MORE BLOCKS
!   --------------------------------------------
!
!  RECORDS 13, 14, 15 & 16 are repeated sequentially for each block (brick)
!
!
!     DO FOR J = 1, TRGT_BLCK
!
!**      RECORD 13:  BLCK_NE(J),BLCK_NN(J),BLCK_NZ(J)
!
!     BLCK_NE(J) = number of cells for the J'th block in the East direction.
!     BLCK_NN(J) = number of cells for the J'th block in the North direction.
!     BLCK_NZ(J) = number of cells for the J'th block in the vertical direction.
!
!**     RECORD 14:  BLCK_LE(J),BLCK_LN(J),BLCK_LZ(J)
!
!          BLCK_LE(J) = length of the J'th block in the east direction.
!          BLCK_LN(J) = length of the J'th block in the north direction.
!          BLCK_LZ(J) = depth extent of the J'th block
!
!**     RECORD 15:  BLCK_CE(J),BLCK_CN(J),ZTOP(J)
!
!          BLCK_CE(J) = east coordinate of the centre of the J'th block.
!          BLCL_CN(J) = north coordinate of the centre of the J'th block.
!          ZTOP(J)    = depth of burial of the top of the J'th block.
!
!   If KSYMM is set to 1, data is entered only for the upper right quadrant
!   and the program generates data for the rest.  Thus in entering data for a
!   model like Fig 1, KSYMM = 1 implies that TRGT_BLCK = 3.
!   In this case the number of cells, length, and location of BLOCK 1 is
!   entered normally.  However, one treats the right half of BLOCK 2 and
!   the upper right quadrant of BLOCK 3 as though they were blocks in their
!   own right.
!   Pictorially, data entry would be based on the 3 block model below.
!
!                        North
!
!                          ^
!                          |
!                          |
!                          |xxxxxxx     xxxxxxxxxxxxxxxx
!                          |      x     x              x
!                          |  2.  x     x     1.       x
!                          |xxxxxxx     x              x
!                          |            xxxxxxxxxxxxxxxx
!                          |
!                          |xxxxx
!                          | 3. x
!       -------------------|xxxxx------------------------>   East
!                          |
!                          |
!                          |
!                          |
!
!   Note that KSYMM=1 also means that the conductivities in the blocks
!   are subject to the symmetry relations.  This means that for the
!   model in Fig 1 the conductivities in blocks #1, #4, #5 and #7 are
!   identical,  and the conductivities in blocks #2 and #6 are identical.
!
!==========================================================================
!
! Note that the option for complex resistivities of the 3D targets is
! controlled by the parameter NLAYER for the layered earth part. NLAYER < 0
! causes all resistivities to be Cole-Cole.
!
!**     If NLAYER > 0
!**     RECORD 16:  RSB(J)
!
!           RSB(J) = resistivity of the J'th block
!
!**     If NLAYER < 0
!**     RECORD 15:  RSB(J), CHRSB(J), TAUSB(J), CFRSB(J)
!
!           RSB(J) = resistivity of the J'th block
!         CHRSB(J) = instantaneous chargeability of the J'th block
!         TAUSB(J) = time constant of the J'th block (in seconds)
!         CFRSB(J) = frequency constant of the J'th block
!
!     ENDDO
!
!**  If TRGT_BLCK > 1,  repeat records 12 through 15 for the second,  third,
!    ......,  blocks
!
!*****          END INPUT DATA FORMAT FOR TIME-DOMAIN SYSTEMS          *****
!***************************************************************************
!***************************************************************************
!
!
!***************************************************************************
!*****        BEGIN INPUT DATA FORMAT FOR FREQUENCY-DOMAIN SYSTEMS     *****
!
!********* Input data format for FREQ_TYM = 0
!
!
!** RECORD 3:  SOURCE, OUTPUT_FMT
!
!       SOURCE  :  Type of excitations and configurations.
!
!            = 1: horizontal electric bipoles (multiple receivers)
!                (for example CSAMT);
!
!              2: vertical current bipoles for down hole modelling
!                 (multiple receivers);
!
!              3: horizontal polygonal loops (3, 4, 5, or more sides)
!                 (multiple receivers);
!
!              4: magnetic dipole transmitters with arbitrary location and
!                 orientation (multiple receivers);
!
!              5: horizontal circular loops (multiple receivers);  and
!
!              6: circular horizontal transmitter loop with one receiver
!                 moving at constant offset along profiles with arbitrary
!                 angles;
!
!              7: Downhole magnetic dipole probe / general coaxial system --
!                 a single coaxial transmitter - receiver pair moving at fixed
!                 offset, vertically, horizontally or down an angled borehole.
!                 User can specify dip and azimuth angles at each probe
!                 position.    This can also be used for ground surveys.
!
!              8: General coplanar system with magnetic dipole -- a single
!                 coplanar transmitter - receiver pair moving at fixed
!                 offset, vertically, horizontally or down an angled borehole.
!                 User can specify dip and azimuth angles at each probe
!                 position.  User can choose from two coplanar systems:
!                 horizontal coplanar system, and normal coplanar system
!                 which is normal to the downhole and the horizontal axes.
!                 This can also be used for ground as well as downhole
!                 surveys.  In particular,  the normal coplanar system moving
!                 along a horizontal profile is equivalent to SOURCE=6 with
!                 small circular transmitter loops;
!
!              9: magnetotellurics.
!
!                 Note that all 6 components, i.e, the three magnetic and three
!                 electric field components are computed for all cases except
!                 for the cases of downhole local coordinate systems and for
!                 magnetotellurics.
!
!     OUTPUT_FMT: = 1, results printed in sounding format;
!                 = 2, results printed in profile format; and
!                 = 3, results printed both in sounding format and
!                      in profile format.
!
!
!*** Subsequent record entries for excitation parameters depend on the value
!    of SOURCE due to the special configurations of each case.
!
!
!######################
!#  Transmitter data  #
!######################
!
!*********  IF (SOURCE=1.OR.SOURCE=2) *****************
!* (horizontal or vertical bipoles, CSAMT or downhole)*
!
!** RECORD 4:  DH_SYS
!
!   DH_SYS:  = 0, if all receivers are on the surface
!                 (only Eastings and Northings required for RX location)
!            = 1, if any receiver is downhole.
!                 RX specification will require RLs plus dip & azimuth angles
!*                                                    *
!** Record 5:  NTX_FD  - number of source positions
!
!--------- DO J=1, NTX_FD -----------
!|                                 |
!
!** Record 6:  (TX_EAST(I,J), TX_NRTH(I,J), TX_VERT(I,J), I=1,2)
!
!               East, north, and vertical coordinates of the two
!               bipole electrodes for each transmitter J.
!
!        If SOURCE = 1 (horizontal bipole) then TX_VERT (1,J) must equal
!         TX_VERT (2,J) or else error will occur.
!        If SOURCE = 2 (vertical bipole) then TX_EAST (1,J) and TX_NRTH (1,J)
!        must equal TX_EAST (2,J) and TX_NRTH (2,J) respectively.
!
!|                                 |
!------ END DO J=1, NTX_FD ----------
!*                                                                            *
!********* End for SOURCE=1.OR.SOURCE=2 (horizontal or vertical bipoles) ******
!
!
!*****************  IF (SOURCE=3) *********************
!*            horizontal polygonal loops              *
!
!** RECORD 4:  DH_SYS
!
!   DH_SYS:  = 0, if all receivers are on the surface
!                 (only Eastings and Northings required for RX location)
!            = 1, if any receiver is downhole.
!                 RX specification will require RLs plus dip & azimuth angles
!*                                                    *
!** Record 5:  NTX_FD  - number of source positions
!
!** Record 5a:  N_SIDE
!
!      N_SIDE :  Numbers of straight sides of the loops.
!                For the usual rectangular loop, N_SIDE=4
!
!--------- DO J=1, NTX_FD -----------
!|                                 |
!
!** Record 6:  (TX_EAST(I,J), TX_NRTH(I,J), TX_VERT(I,J), I = 1, N_SIDE)
!
!               Array for the east, north, and vertical coordinates each
!               corner of each loop.
!
!|                                 |
!------ END DO J=1, NTX_FD ----------
!*                                                    *
!**************** End  IF (SOURCE=3) ******************
!
!
!******************* IF (SOURCE=4) **************************
!*(Magnetic dipoles with arbitrary location and orientation)*
!*                                                          *
!
!** RECORD 4:  DH_SYS
!
!   DH_SYS:  = 0, if all receivers are on the surface
!                 (only Eastings and Northings required for RX location)
!            = 1, if any receiver is downhole.
!                 RX specification will require RLs plus dip & azimuth angles
!
!** Record 5:  NTX_FD  - number of source positions
!
!--------- DO J=1, NTX_FD -----------
!|                                 |
!
!** Record 6:  TX_EAST(J), TX_NRTH(J), TX_VERT(J), TX_DIP(J), TX_PHI(J)
!
!              East, north, and vertical coordinates and the orientation of
!              the dipole for each transmitter position
!
!              TX_DIP (dip angle) =  0 for a vertical dipole;  and
!                                 = 90 for a horizontal dipole
!              TX_PHI (azimuthal angle) =   0 due north;
!                                       =  90 due east; and
!                                       = 270 due west
!
!              The dip angle is the angle from the negative z-axis, i.e.,
!              from the axis down to the earth (assuming the z axis is pointing
!              upwards).  The azimuthal angle is the angle from the north,
!              the y-axis.  Thus for a vertical magnetic dipole TX_DIP(J)=180
!              for pointing up to the air and TX_DIP(J)=0 for pointing downward.
!              A horizontal magnetic dipole pointing north will have TX_DIP(J)=90
!              and TX_PHI(J)=0,  and a horizontal magnetic dipole pointing east
!              will have TX_DIP(J)=90 and TX_PHI(J)=90.
!
!              Note that our definition of dip is equivalent to another term
!              used in exploration, the hade angle.  Here define 0 = vertical
!              because of the fact that this is the angle between the dipole
!              and the axis of the bohrhole.
!
!|                                 |
!------ END DO J=1, NTX_FD ----------
!*                                           *
!********** End IF (SOURCE=4) ****************
!
!
!************* IF (SOURCE=5) *****************
!*       (horizontal circular loop)          *
!*                                           *
!
!** RECORD 4:  DH_SYS
!
!   DH_SYS:  = 0, if all receivers are on the surface
!                 (only Eastings and Northings required for RX location)
!            = 1, if any receiver is downhole.
!                 RX specification will require RLs plus dip & azimuth angles
!
!** Record 5:  NTX_FD  - number of source positions
!
!--------- DO J=1, NTX_FD -----------
!|                                 |
!
!** Record 5a: RAD(J)
!
!               Radius of the circular loops for each source position.
!
!** Record 6:  TX_EAST(J), TX_NRTH(J), TX_VERT(J)
!
!               Array for the east, north, and vertical coordinates of the
!               dipole for each source position.
!
!|                                 |
!------ END DO J=1, NTX_FD ----------
!*                                           *
!********** End IF (SOURCE=5) ****************
!
!
!********  IF (SOURCE=6.OR.SOURCE=7.OR.SOURCE=8) *************
!*                                                           *
! (Transmitter - receiver pair moving with fixed TX-RX offset)
!  For those cases the input for transmitters and receivers
!  are combined and are described later with receiver data
!*                                                           *
!******** End  IF (SOURCE=4.OR.SOURCE=5.OR.SOURCE=6) *********
!
!
!************** IF (SOURCE=9) ****************
!*           (Magnetotellurics)              *
!*                                           *
!  There is no transmitter option for MT
!  problems.
!*                                           *
!********** End IF (SOURCE=9) ****************
!
!
!######################
!#   Receiver data    #
!######################
!
!
!** Record 7:  FIXED_RX
!
!              Parameter controlling whether the receiver array is fixed
!              for all transmitters.
!
!              FIXED_RX = 1: fixed receiver array for all transmitter positions.
!                       = 0: receiver positions depend upon transmitter
!                            positions.
!
!              This recorded must be specified, even if there is only one transmitter.
!
!
!  *** The following receiver data formats are given for the case FIXED_RX=0.
!      For fixed receivers input only one set of receivers as if NTX_FD=1.
!
!
!*********  IF (SOURCE=1.OR.SOURCE=2.OR.SOURCE=3) ******************
!* (horizontal/vertical bipoles, CSAMT/downhole, horizontal loops) *
!
!** Record 8:  (N_RX(I),I=1,NTX_FD)
!
!--------- DO J=1, NTX_FD -----------
!|                                 |
!
!~~~~~~~~ If DH_SYS =0 ~~~~~~~~~~
!
!** Record 9.1:  RX_E(1,J),RX_N(1,J)
!
!** Record 9.2:  RX_E(2,J),RX_N(2,J)
!                     .
!** Record 9.N_RX(J):  RX_E(N_RX(J),J),RX_N(N_RX(J),J)
!
!               Array for the east and north coordinates of
!               receivers for each excitation.
!
!~~~~~~ End if DH_SYS =0 ~~~~~~~~
!
!~~~~~~~~ If DH_SYS =1 ~~~~~~~~~~
!
!** Record 9.1:  RX_E(1,J),RX_N(1,J),RX_Z(1,J),RDIP(1,J),RPHI(1,J)
!** Record 9.2:  RX_E(2,J),RX_N(2,J),RX_Z(2,J),RDIP(2,J),RPHI(2,J)
!                     .
!** Record 9.N_RX(J):  RX_E(N_RX(J),J),RX_N(N_RX(J),J),RX_Z(N_RX(J),J),
!                      RDIP(N_RX(J),J),RPHI(N_RX(J),J)
!
!              Array for the east (RX_E), north (RX_N) coordinates
!              relative levels (RX_Z),  and dip (RDIP) and azimuthal
!              (RPHI) angles of the receivers for each transmitter.
!
!              The dip and azimuthal angles of the receivers are defined
!              in exactly the same way as the dip and azimuthal angles of
!              the transmitters.
!              Dip = 0 for a vertical dipole; 90 for a horizontal dipole
!              Azimuth = 0 due north; 90 due east; 270 due west
!
!~~~~~~ End if DH_SYS =1 ~~~~~~~~
!
!|                                 |
!------ END DO J=1, NTX_FD ----------
!*                                                                 *
!********* End  IF (SOURCE=1.OR.SOURCE=2.OR.SOURCE=3) **************
!
!
!************* IF (SOURCE=4) *****************
!*      Receivers for arbitrarily oriented magnetic dipole transmitters
!*                                           *
!
!** Record 8:  (N_RX(I),I=1,NTX_FD)
!
!--------- DO J=1, NTX_FD -----------
!|                                 |
!
!.........  DO I=1,N_RX(J) .........
!
!~~~~~~~~ If DH_SYS =0 ~~~~~~~~~~
!
!** Record 9.1:  RX_E(1,J),RX_N(1,J)
!** Record 9.2:  RX_E(2,J),RX_N(2,J)
!                     .
!** Record 9.N_RX(J):  RX_E(N_RX(J),J),RX_N(N_RX(J),J)
!
!               Array for the east and north coordinates of
!               receivers for each excitation.
!
!~~~~~~ End if DH_SYS =0 ~~~~~~~~
!
!~~~~~~~~ If DH_SYS =1 ~~~~~~~~~~
!
!** Record 9.1:  RX_E(1,J),RX_N(1,J),RX_Z(1,J),RDIP(1,J),RPHI(1,J)
!** Record 9.2:  RX_E(2,J),RX_N(2,J),RX_Z(2,J),RDIP(2,J),RPHI(2,J)
!                     .
!** Record 9.N_RX(J):  RX_E(N_RX(J),J),RX_N(N_RX(J),J),RX_Z(N_RX(J),J),
!                      RDIP(N_RX(J),J),RPHI(N_RX(J),J)
!
!              Array for the east (RX_E), north (RX_N) coordinates
!              relative levels (RX_Z),  and dip (RDIP) and azimuthal
!              (RPHI) angles of the receivers for each transmitter.
!
!              The dip and azimuthal angles of the receivers are defined
!              in exactly the same way as the dip and azimuthal angles of
!              the transmitters.
!
!~~~~~~ End if DH_SYS =1 ~~~~~~~~
!|                                 |
!------ END DO J=1, NTX_FD ----------
!*                                           *
!********** End IF (SOURCE=4) ****************
!
!
!************* IF (SOURCE=5) *****************
!*       (horizontal circular loop)          *
!*                                           *
!
!** Record 8:  (N_RX(I),I=1,NTX_FD)
!
!--------- DO J=1, NTX_FD -----------
!|                                 |
!
!~~~~~~~~ If DH_SYS =0 ~~~~~~~~~~
!
!** Record 9.1:  RX_E(1,J),RX_N(1,J)
!** Record 9.2:  RX_E(2,J),RX_N(2,J)
!                     .
!** Record 9.N_RX(J):  RX_E(N_RX(J),J),RX_N(N_RX(J),J)
!
!               Array for the east and north coordinates of
!               receivers for each excitation.
!
!~~~~~~ End if DH_SYS =0 ~~~~~~~~
!
!~~~~~~~~ If DH_SYS =1 ~~~~~~~~~~
!
!** Record 9.1:  RX_E(1,J),RX_N(1,J),RX_Z(1,J),RDIP(1,J),RPHI(1,J)
!** Record 9.2:  RX_E(2,J),RX_N(2,J),RX_Z(2,J),RDIP(2,J),RPHI(2,J)
!                     .
!** Record 9.N_RX(J):  RX_E(N_RX(J),J),RX_N(N_RX(J),J),RX_Z(N_RX(J),J),
!                      RDIP(N_RX(J),J),RPHI(N_RX(J),J)
!
!              Array for the east (RX_E), north (RX_N) coordinates
!              relative levels (RX_Z),  and dip (RDIP) and azimuthal
!              (RPHI) angles of the receivers for each transmitter.
!
!              The dip and azimuthal angles of the receivers are defined
!              in exactly the same way as the dip and azimuthal angles of
!              the transmitters.
!
!~~~~~~ End if DH_SYS =1 ~~~~~~~~
!
!|                                 |
!------ END DO J=1, NTX_FD ----------
!*                                           *
!********** End IF (SOURCE=5) ****************
!
!
!********  IF (SOURCE=6.OR.SOURCE=7.OR.SOURCE=8) *************
!*         (Tx-Rx moving with fixed TX-RX offset)            *
!*                                                           *
!
!------ If SOURCE=6 -------
!| (horizontal loop only) |
!
!** Record 4:  RAD2
!
!      RAD2 :  Radius of the transmitting loop.  The value RAD2 is arbitrary,
!              depending on the actual survey,  but one may assign RAD2 a
!              value of 0.5642, or 5.642 to model transmitters with 1 Am**2
!              or 100 Am**2 of dipole moment.
!
!|                        |
!---- End if SOURCE=6 -----
!
!------ If SOURCE=8 -------
!| (coplanar systems only)|
!
!** Record 4:  PLANAR
!
!      PLANAR :  = 1,  horizontal coplanar system (always horizontal);  and
!                = 2,  normal coplanar system (vertical if the profile is
!                      horizontal)
!
!|                        |
!---- End if SOURCE=8 -----
!
!** Record 5:  TR_OFF_E, TR_OFF_N, TR_OFF_Z
!
!   TR_OFF_E, TR_OFF_N, TR_OFF_Z : Transmitter-receiver offsets in East, North,
!                 and elevation difference.
!
!                 TR_OFF_E is positive if the receiver is to the east of the
!                 transmitter.
!                 TR_OFF_N is positive if the receiver is to the north of the
!                 transmitter.
!                 TR_OFF_Z is positive if the receiver is below the transmitter.
!
!                 For downhole measurements with vertically moving magnetic
!                 dipoles use TR_OFF_E=TR_OFF_N=0.
!
!** Record 6:  N_PROFL
!
!       N_PROFL :  Number of profiles
!
!** Record 7:  N_PROFL
!
!------- DO I=1, N_PROFL ------------
!
!** Record 8: START_E(I),START_N(I),START_Z(I),PROFL_DIP(I),        &
!             PROFL_PHI(I),N_STATN(I),STATN_DIST(I)
!
!      START_E(I) : Tx start Easting for the Ith profile, positive eastward
!      START_N(I) : Tx start Northing for the Ith profile, positive northward
!      START_Z(I) : Tx start RL for the Ith profile, positive downward
!      PROFL_DIP(I) : Profile dip in degrees, = 0 vertical; =90 horizontal
!      PROFL_PHI(I) : Profile azimuth in degrees, = 0 due north; =90 due east
!      N_STATN(I) : Number of stations on the Ith profile
!      STATN_DIST(I) : Distance between stations on the Ith profile
!
!----- END DO I=1, N_PROFL ------------
!*                                                           *
!******** End  IF (SOURCE=6.OR.SOURCE=7.OR.SOURCE=8) *********
!
!
!************** IF (SOURCE=9) ****************
!*           (Magnetotellurics)              *
!*                                           *
!
!**** Note that the coordinate system for MT applications is different from
!     the coordinate system for controlled source problems.  For MT problems
!     the X-axis points toward north, Y points toward east, and Z points
!     downwards.
!
!** Record 4:  NPOL,MT_PROFL,MT_STATN,ZMT
!** Record 5:  (XRMT(I),I=1,MT_PROFL)
!** Record 6:  (YRMT(I),I=1,MT_STATN)
!
!   NPOL : polarizations of the incident fields for MT studies.
!          =0: B-polarization;
!          =1: E-polarization; and
!          =2: both polarizations.
!          Note that accurate calculations of the impedance matrix
!          and apparent resistivities require both of the two polar-
!          izations. NPOL=0 or 1 is designed for quick estimations
!          of the anomalies of elongated structures in a specific
!          polarization.
!   MT_PROFL: number of profiles to be calculated (in x-direction).
!   MT_STATN: number of the receiving points at each profile (in y-direction).
!   ZMT  : z-coordinate of the receiver plane.  This is designed for
!          measurements at sea floor (ZMT positive).
!   XRMT(*): x-coordinates of the the profiles.
!   YRMT(*): y-coordinates of the receivers.
!
!*                                           *
!********** End IF (SOURCE=9) ****************
!
!   Note that the record numbers are different from one SOURCE type to
!   another.
!
!** RECORD 10:  NFRQ
!
!       NFRQ :  Number of frequencies
!
!** RECORD 11:  (FRQM(I),I=1,NFRQ)
!
!       FRQM(*) :  Frequencies
!
!** RECORD 12:  (AJ(I),I=1,NFRQ)
!
!       AJ(*) :  Current amplitude for electric sources
!                (SOURCE=1, 2, 3, 5, and 6);   or
!                Dipole moment for magnetic sources
!                (SOURCE=4, 7, and 8)
!
!
!#####################
!#   Model entries   #
!#####################
!
!
!** RECORD 13:  INCL_DIELEC
!
!      INCL_DIELEC = 1  Compute dielectric models at high frequencies
!                       above 1 MHz up to 50 MHz
!
!                  = 0  Conventional EM applications with frequencies
!                       below 1 MHz.  Displacement currents are still
!                       included in the computations but dielectric
!                       permittivities are all set to be 1.
!
!** RECORD 14:  COLE_COLE
!
!      COLE_COLE = 1  Compute dispersive or polarizable models
!
!                = 0  Compute non-dispersive or non-polarizable models
!
!                     Dispersive and polarizable models are assumed to be
!                     Cole-Cole,  i.e.,  both the dielectric permittivities
!                     and the resistivities are described by Cole-Cole models
!
!** RECORD 15  MLAYER
!
!       MLAYER :  Number of layers in the earth including the basement.
!                 MLAYER is limited to be less than 200.  If one wishes
!                 to compute more layers,  change the value of the
!                 parameter LAYERM in routine ONE_D_KERNEL.

!
!** RECORD 16:  (RES_EARTH(I),I=1,MLAYER)
!
!       RES_EARTH(*) : the resistivities of the MLAYER layers of the earth
!
!========= If COLE_COLE = 1 then ===========
!||                                       ||
!** RECORD 16a:  (CHRG_EARTH(I),I=1,MLAYER)
!** RECORD 16b:  (TAU_EARTH(I),I=1,MLAYER)
!** RECORD 16c:  (FRQC_EARTH(I),I=1,MLAYER)
!
!       CHRG_EARTH :  The chargeabilities of the earth
!       TAU_EARTH :  The time constants of the earth
!       FRQC_EARTH :  The frequency constants of the earth
!||                                       ||
!========= End if COLE_COLE = 1  ===========
!
!========= If INCL_DIELEC = 1 then ===========
!||                                         ||
!** RECORD 16d:  (DIELC_EARTH(I),I=1,MLAYER)
!
!       DIELC_EARTH(*) : dielectric permittivities of the MLAYER layers of the earth
!
!------------ If COLE_COLE = 1 then -----------
!|                                            |
!** RECORD 16e:  (DCHRG_EARTH(I),I=1,MLAYER)
!** RECORD 16f:  (DTAU_EARTH(I),I=1,MLAYER)
!** RECORD 16g:  (DFRQC_EARTH(I),I=1,MLAYER)
!
!       DCHRG_EARTH :  The chargeabilities of the permittivities the earth
!       DTAU_EARTH :  The time constants of the permittivities the earth
!       DFRQC_EARTH :  The frequency constants of the permittivities the earth
!|                                            |
!---------  End if COLE_COLE = 1  -------------
!
!||                                         ||
!========= End if INCL_DIELEC = 1  ===========
!
!       Note that if INCL_DIELEC = 1 and  COLE_COLE = 1,  Cole-Cole
!       parameters both for the resistivities and for the permittivities
!       must be given,  though you can opt for one of them by assigning
!       a zero value for the chargeabilities of the other.
!
!
!** RECORD 17:  (LRYTH(I),I=1,MLAYER)
!
!       LRYTH(*) : Thickness of the layers; to be read only if MLAYER > 1
!
!
!** Record 18: DO_3D
!
!      DO_3D = 1  Compute 3D models
!
!            = 0  Compute 1D responses only
!
!===============================================================================
!
!****** Data input finished if DO_3D = 0
!
!** Data input for the 3D model is identical to the format for FREQ_TYM=0
!** in the following we list only the records for the 3D body.  More
!** detailed descriptions can be found in the previous case of FREQ_TYM=0
!
!
!===========  If DO_3D = 1 then  ==================
!||                                              ||
!
!** RECORD 19:  KSYMM, TRGT_BLCK, KACC
!
!             KSYMM = 0:  general non-symmetric model
!                   = 1:  model symmetric to the (XOZ) and (YOZ) planes
!             TRGT_BLCK = Number of blocks.
!             KACC = Accuracy level for the computation of the scattered
!                    field.  Choose 2 or 3 for accurate computation.
!                    KACC = 1 invokes a fast solver that uses a fast
!                    approximation for the solution of the matrix
!                    equation.
!
!
!======  DO FOR J = 1, TRGT_BLCK  ============
!
!**  RECORD 20:  BLCK_NE(J),BLCK_NN(J),BLCK_NZ(J)
!
!     BLCK_NE(J) = number of cells for the J'th block in the East direction.
!     BLCK_NN(J) = number of cells for the J'th block in the North direction.
!     BLCK_NZ(J) = number of cells for the J'th block in the vertical direction.
!
!**  RECORD 21:  BLCK_LE(J),BLCK_LN(J),BLCK_LZ(J)
!
!          BLCK_LE(J) = length of the J'th block in the east direction.
!          BLCK_LN(J) = length of the J'th block in the north direction.
!          BLCK_LZ(J) = depth extent of the J'th block
!
!**  RECORD 22:  BLCK_CE(J),BLCK_CN(J),ZTOP(J)
!
!          BLCK_CE(J) = east coordinate of the centre of the J'th block.
!          BLCL_CN(J) = north coordinate of the centre of the J'th block.
!          ZTOP(J)    = depth of burial of the top of the J'th block.
!
!**  RECORD 23:  RSB(J)
!
!        RSB(J) = resistivity of the J'th block
!
!------  If COLE_COLE = 1 then  ------
!|                                   |
!
!**  RECORD 24:  RSB(J), CHRSB(J), TAUSB(J), CFRSB(J)
!
!        RSB(J) = resistivity of the J'th block
!      CHRSB(J) = instantaneous chargeability of the J'th block
!      TAUSB(J) = time constant of the J'th block (in seconds)
!      CFRSB(J) = frequency constant of the J'th block
!
!|                                   |
!------  End if COLE_COLE = 1 --------
!
!======  ENDDO  ===============================
!
!**  If TRGT_BLCK > 1,  repeat records 18 through 22 for the second,  third,
!    ......,  blocks
!
!||                                              ||
!===========  End if DO_3D = 1 ====================
!
!
!#####################
!  END OF DATA ENTRY #
!#####################
!
!*********************
!   SAMPLE DATA SETS *
!*********************
!
!  Example T1 - Illustrates use of an option with multiple transmitters
!               for a prismatic slab with IP response.
!               IP response also comes from top 5 metres.
!               RUNTIME: 158 sec on Digital Alphastation 200
!  ---------------------------------------------------------------------
!
!  MULTI TX EM37 TEST FOR A PRISMATIC SLAB WITH IP RESPONSE
!   0 0.   ! FREQ_TYM, SURFACE_RL; FREQ_TYM=0: Compute time domain responses
!   1 1 0                 ! NTEM3D, IPRF, ISTOP
!  20 1 0                 ! NCHNL, ITYM, IDH
!  .2 .1  1.E4            ! TRMP, TRYS, RXAREA
!  5                      ! NTX
!  -100. -100.
!   100. -100.
!   100.  100.
!  -100.  100.            ! TRANSMITTER 1 CORNER (E,N) LOCATIONS
!     0. -100.
!   200. -100.
!   200.  100.
!     0.  100.            ! TRANSMITTER 2 CORNER (E,N) LOCATIONS
!   100. -100.
!   300. -100.
!   300.  100.
!   100.  100.            ! TRANSMITTER 3 CORNER (E,N) LOCATIONS
!   200. -100.
!   400. -100.
!   400.  100.
!   200.  100.            ! TRANSMITTER 4 CORNER (E,N) LOCATIONS
!   300. -100.
!   500. -100.
!   500.  100.
!   300.  100.            ! TRANSMITTER 5 CORNER (E,N) LOCATIONS
!  3 4 2 5 1              ! NRX FOR EACH TX
!  0    0
!  50  20
!  150 50            !  RE RN (Receiver eastings and northings) FOR TX #1
!  100 0
!  150 20
!  200 20
!  250 50            !  RE RN (Receiver eastings and northings) FOR TX #2
!  200  0
!  200 50            !  RE RN (Receiver eastings and northings) FOR TX #3
!  300  0
!  350 30
!  400 60
!  450 80
!  500 100           !  RE RN (Receiver eastings and northings) FOR TX #4
!  410 20            !  RE RN (Receiver eastings and northings) FOR TX #5
!  -2                     ! NLYR
!  5. 275. .30 .0001 .3   ! OVERBURDEN THICK, RES, CHRG, CTAU, CFREQ
!  275. 0. 0. 0.          ! BASEMENT RES, CHRG, CTAU, CFREQ
!  0 1 2                  ! KSYMM, TRGT_BLCK, KACC
!  6 10 2                 ! BLCK_NE(1),BLCK_NN(1),BLCK_NZ(1)
!  500. 800. 100.         ! BLCK_LE(1),BLCK_LN(1),BLCK_LZ(1)
!  0. 0. 100.             ! BLCK_CE(1),BLCK_CN(1),ZTOP(1)
!  2. 0.4 .001 0.75       ! RSB(1),CHRSB(1),TAUSB(1),CFRSB(1)
!
!* Change the fifth line from the bottom to
!
!  0 1 1                  ! KSYMM, TRGT_BLCK, KACC
!
!  will invoke the fast approximate solver.  However,  the run time being
!  saved may not be very much,  which also depends on the machine on which
!  the code is running.  In fact,  with KACC=1 the job takes 130 sec on
!  a Digital Alphastation 200.  With just one excitation the saving on
!  computation time will be more.  This is in general the case for any
!  RELIABLE fast solvers compared with a good exact solver.   Marco is
!  equipped with spatial symmetry reductions in computing the scattering
!  matrix which greatly speeds up the computation.
!
!* This 3D block can also be modelled using group symmetric reductions
!  by choosing KSYMM=1.  Replace the last five lines with the following
!  will markedly speed up the computation,  especially if there are a
!  large number of cells, without any lose of accuracy:
!
!  1 1 2                  ! KSYMM, TRGT_BLCK, KACC
!  3 5 2                  ! BLCK_NE(1),BLCK_NN(1),BLCK_NZ(1)
!  250. 400. 100.         ! BLCK_LE(1),BLCK_LN(1),BLCK_LZ(1)
!  125. 200. 100.         ! BLCK_CE(1),BLCK_CN(1),ZTOP(1)
!  2. 0.4 .001 0.75       ! RSB(1),CHRSB(1),TAUSB(1),CFRSB(1)
!
!  The run time is 126 sec on a Digital Alphastation 200.
!
!  Note that only 1/4 of the body in the first quadrant needs to be input.
!  Marco will automatically reflect this quadrant to other three quadrants.
!  If KSYMM=1,  the x and y coordinate centres must be direct above the
!  centre of the 3D block.
!
!========================================================================
!
!  Example T2 - Illustrates coincident loop profile over a three-brick
!               targets. The three bricks are both 100 m by 160 m by 120 m
!               in dimension.  The one in the centre has a resistivity of
!               1 ohm-m, while the other two are resistive with a
!               resistivity 10000 ohm-m. Note that only two blocks in the
!               first quadrant are input.  The third block is constructed
!               by Marco itself by symmetry operations.
!               Note that the scattered field option has been used.
!               RUNTIME: 12 min on Digital Alphastation 200
!  ----------------------------------------------------------------
!
!  SIROTEM COINCIDENT LOOP PROFILE OVER A THREE-BRICK MODEL
!   0 0.   ! FREQ_TYM, SURFACE_RL; FREQ_TYM=0: Compute time domain responses
!  -1 2 0            ! NTEM3D, IPRF, ISTOP
!  20 1 7            ! NCHNL, ITYM, IDH
!  .2 .1             ! TRMP, TRYS
!  10                ! NTX
!  -100. -100.
!   100. -100.
!   100.  100.
!  -100.  100.       ! TRANSMITTER 1 CORNER (E,N) LOCATIONS
!   -50. -100.
!   150. -100.
!   150.  100.
!   -50.  100.       ! TRANSMITTER 2 CORNER (E,N) LOCATIONS
!     0. -100.
!   200. -100.
!   200.  100.
!     0.  100.       ! TRANSMITTER 3 CORNER (E,N) LOCATIONS
!    50. -100.
!   250. -100.
!   250.  100.
!    50.  100.       ! TRANSMITTER 4 CORNER (E,N) LOCATIONS
!   100. -100.
!   300. -100.
!   300.  100.
!   100.  100.       ! TRANSMITTER 5 CORNER (E,N) LOCATIONS
!   150. -100.
!   350. -100.
!   350.  100.
!   150.  100.       ! TRANSMITTER 6 CORNER (E,N) LOCATIONS
!   200. -100.
!   400. -100.
!   400.  100.
!   200.  100.       ! TRANSMITTER 7 CORNER (E,N) LOCATIONS
!   250. -100.
!   450. -100.
!   450.  100.
!   250.  100.       ! TRANSMITTER 8 CORNER (E,N) LOCATIONS
!   300. -100.
!   500. -100.
!   500.  100.
!   300.  100.       ! TRANSMITTER 9 CORNER (E,N) LOCATIONS
!   350. -100.
!   550. -100.
!   550.  100.
!   350.  100.       ! TRANSMITTER 10 CORNER (E,N) LOCATIONS
!  2                 ! NLYR
!  70 50.            ! OVERBURDEN THICK, RES
!  300.              ! BASEMENT RESISTIVITY
!  1 2 2             ! KSYMM, TRGT_BLCK, KACC
!  2 3 4             ! BLCK_NE(1),BLCK_NN(1),BLCK_NZ(1)
!  50. 80. 120.      ! BLCK_LE(1),BLCK_LN(1),BLCK_LZ(1)
!  25. 40. 70.       ! BLCK_CE(1),BLCK_CN(1),ZTOP(1)
!  1.                ! RSB(1)
!  4 3 4             ! BLCK_NE(2),BLCK_NN(2),BLCK_NZ(2)
!  100. 80. 120.     ! BLCK_LE(2),BLCK_LN(2),BLCK_LZ(2)
!  100. 40. 70.      ! BLCK_CE(2),BLCK_CN(2),ZTOP(2)
!  10000.            ! RSB(2)
!
!========================================================================
!
!  Example T3 - Illustrates central loop profile over a dipping target.
!               Note that 5 blocks are used to build a northward dipping
!               target with increasing conductivities.
!               RUNTIME: 35 min on Digital Alphastation 200
!  ----------------------------------------------------------------
!
!  SIROTEM CENTRAL LOOP PROFILE OVER DIPPING TARGET
!   0 0.   ! FREQ_TYM, SURFACE_RL; FREQ_TYM=0: Compute time domain responses
!  -1 2 0            ! NTEM3D, IPRF, ISTOP
!  20 1 6            ! NCHNL, ITYM, IDH
!  .2 .1 1.E4        ! TRMP, TRYS, RXAREA
!  10                ! NTX
!  0. 0.             ! RECEIVER OFFSET
!  -100. -100.
!   100. -100.
!   100.  100.
!  -100.  100.        ! TRANSMITTER 1 CORNER (E,N) LOCATIONS
!   -50. -100.
!   150. -100.
!   150.  100.
!   -50.  100.        ! TRANSMITTER 2 CORNER (E,N) LOCATIONS
!     0. -100.
!   200. -100.
!   200.  100.
!     0.  100.        ! TRANSMITTER 3 CORNER (E,N) LOCATIONS
!    50. -100.
!   250. -100.
!   250.  100.
!    50.  100.        ! TRANSMITTER 4 CORNER (E,N) LOCATIONS
!   100. -100.
!   300. -100.
!   300.  100.
!   100.  100.        ! TRANSMITTER 5 CORNER (E,N) LOCATIONS
!   150. -100.
!   350. -100.
!   350.  100.
!   150.  100.        ! TRANSMITTER 6 CORNER (E,N) LOCATIONS
!   200. -100.
!   400. -100.
!   400.  100.
!   200.  100.        ! TRANSMITTER 7 CORNER (E,N) LOCATIONS
!   250. -100.
!   450. -100.
!   450.  100.
!   250.  100.        ! TRANSMITTER 8 CORNER (E,N) LOCATIONS
!   300. -100.
!   500. -100.
!   500.  100.
!   300.  100.        ! TRANSMITTER 9 CORNER (E,N) LOCATIONS
!   350. -100.
!   550. -100.
!   550.  100.
!   350.  100.        ! TRANSMITTER 10 CORNER (E,N) LOCATIONS
!  2                  ! NLYR
!  70 50.             ! OVERBURDEN THICK, RES
!  300.               ! BASEMENT RESISTIVITY
!  0 5 2              ! KSYMM, TRGT_BLCK, KACC
!  4 5 2              ! BLCK_NE(1),BLCK_NN(1),BLCK_NZ(1)
!  100. 150. 50.      ! BLCK_LE(1),BLCK_LN(1),BLCK_LZ(1)
!  0. -120 105.       ! BLCK_CE(1),BLCK_CN(1),ZTOP(1)
!  10.                ! RSB(1)
!  4 5 2              ! BLCK_NE(2),BLCK_NN(2),BLCK_NZ(2)
!  100. 150. 50.      ! BLCK_LE(2),BLCK_LN(2),BLCK_LZ(2)
!  00. -60. 155.      ! BLCK_CE(2),BLCK_CN(2),ZTOP(2)
!  5.                 ! RSB(2)
!  4 5 2              ! BLCK_NE(3),BLCK_NN(3),BLCK_NZ(3)
!  100. 150. 50.      ! BLCK_LE(3),BLCK_LN(3),BLCK_LZ(3)
!  00. 0. 205.        ! BLCK_CE(3),BLCK_CN(3),ZTOP(3)
!  2.                 ! RSB(3)
!  4 5 2              ! BLCK_NE(4),BLCK_NN(4),BLCK_NZ(4)
!  100. 150. 50.      ! BLCK_LE(4),BLCK_LN(4),BLCK_LZ(4)
!  00. 60. 255.       ! BLCK_CE(4),BLCK_CN(4),ZTOP(4)
!  1.                 ! RSB(4)
!  4 5 2              ! BLCK_NE(5),BLCK_NN(5),BLCK_NZ(5)
!  100. 150. 50.      ! BLCK_LE(5),BLCK_LN(5),BLCK_LZ(5)
!  00. 120. 305.      ! BLCK_CE(5),BLCK_CN(5),ZTOP(5)
!  .5                 ! RSB(5)
!
!* This example also illustrate the use of spatial symmetry reduction
!  for the computation of the Green's functions.  Note that the three
!  blocks are discretised into equal-sized cells, plus that those cells
!  are aligned as if they were part of a ficticious "super-block" that
!  is discretised uniformly.  Despite the fact that the blocks have
!  different resistivities and that the whole structure is not symmetric
!  at all,  the above discretization still invokes the spatial symmetry
!  reductions.  If, however, the y-coordinate (or any other coordinates)
!  in any of the five blocks is shifted not by multiples of the cell
!  dimension in the y-direction, namely,  n*30 m,  spatial symmetry
!  reductions cannot be used.  Increasing cell sizes for blocks at depth
!  will also disable the spatial symmetry reductions.  As a test you may
!  try to discretise one of the blocks differently while keeping the
!  total number of cells unchanged, or to shift one of the blocks slightly.
!  You will notice that the run time will be greatly increased.
!
!* Also note that the matrix equation is solved by system iterations
!  since this model has more than 3 blocks which is the designed limit
!  of blocks for a substructure,  parameter NBMAX.  System iteration
!  will be used whenever the total number of cells for a non-symmetric
!  structure,  or the total number of cells in one quadrant for a
!  symmetric structure, exceeds the value of NSUBCM (=260) or whenever
!  the total number of blocks exceeds NBMAX (=3).  For multi-excitations
!  you may wish to use direct solutions of the matrix equations since
!  it is advantageous to do so because the matrix needs only to be
!  factorized once for all excitations.  In such cases,  change the
!  parameters NSUBCM and/or NMBAX accordingly.  There is actually a
!  balance between the direct solver and the iterative solver in Marco.
!  The iterative solver is in general (not always!) faster than the
!  direct solver for a single excitation.  But the direct solver is
!  faster if there are a lot of excitations.
!
!========================================================================
!
!  Example T4 - Downhole response of a prismatic target with one drillhole
!               through the target
!               RUNTIME: 7 min on Digital Alphastation 200
!  ----------------------------------------------------------------
!
! 2 VERTICAL DRILLHOLES, 1 INTERSECTING THE TARGET
! 0 0.   ! FREQ_TYM, SURFACE_RL; FREQ_TYM=0: Compute time domain responses
! -1 2 0                             ! NTEM3D, IPRF, ISTOP
! 10 2 1                             ! NCHNL, ITYM, IDH
! 0 .1 .05 60 60 1000                ! IRXW, TRMP, TRYS, OFFTYM, ONTYM, RXAREA
! .1 .3 .5 1. 3. 5. 10. 20. 30. 50.  ! 10 DELAY TIMES
! 1                                  ! NTX
! -200.   0.
!    0.   0.
!    0. 400.
! -200. 400.                         ! TRANSMITTER CORNER (E,N) LOCATIONS
! 24                                 ! NUMBER OF RECEIVERS
!  0 100    0 0 0
!  0 100  -25 0 0
!  0 100  -50 0 0
!  0 100 -100 0 0
!  0 100 -125 0 0
!  0 100 -150 0 0
!  0 100 -175 0 0
!  0 100 -200 0 0
!  0 100 -225 0 0
!  0 100 -250 0 0
!  0 100 -275 0 0
!  0 100 -300 0 0
!  -60 100    0  0 0
!  -60 100  -25  0 0
!  -60 100  -50  0 0
!  -60 100 -100  0 0
!  -60 100 -125  0 0
!  -60 100 -150  0 0
!  -60 100 -175  0 0
!  -60 100 -200  0 0
!  -60 100 -225  0 0
!  -60 100 -250  0 0
!  -60 100 -275  0 0
!  -60 100 -300  0 0                 !  RE RN RZ RDIP RPHI
! 2                                  ! NLYR
! 50. 10.                            ! OVERBURDEN THICK, RES
! 50. 0. 0. 0.                       ! BASEMENT RES
!  1 1 2                             ! KSYMM, TRGT_BLCK, KACC
!  2 8 5                             ! BLCK_NE(1),BLCK_NN(1),BLCK_NZ(1)
!  50. 200. 100.                     ! BLCK_LE(1),BLCK_LN(1),BLCK_LZ(1)
!  25. 100. 100.                     ! BLCK_CE(1),BLCK_CN(1),ZTOP(1)
!  .1                                ! RSB(1)
!
!* Note that the second drillhole intersects the target region.
!
!========================================================================
!
!  Example T5 - Illustrates the computation of pure step response of
!               an outcropping T-shaped target in a 4-layered earth.
!               RUNTIME: 18 min on Digital Alphastation 200
!  ---------------------------------------------------------------------
!
!  STEP RESPONSE OF A T-SHAPED MODEL
!   0 0.   ! FREQ_TYM, SURFACE_RL; FREQ_TYM=0: Compute time domain responses
!  -1 1 0                 ! NTEM3D, IPRF, ISTOP
!  41 2 0                 ! NCHNL, ITYM, IDH
!   1 0. 0. 100. 100. 1.e-6 !IRXW, TRMP, TRYS, OFFTYM, ONTYM, RXAREA
!  0.0088 0.0109 0.0140 0.0177 0.0221
!  0.0282 0.0357 0.0446 0.0567 0.0716
!  0.088 0.109 0.140 0.177 0.221
!  0.282 0.357 0.446 0.567 0.716
!  0.88 1.09 1.40 1.77 2.21
!  2.82 3.57 4.46 5.67 7.16
!  8.8 10.9 14.0 17.7 22.1
!  28.2 35.7 44.6 56.7 71.6 88.0 ! 41 delay times TMS
!  41*0.                  ! 41 window width WTMS
!  1                      ! NTX
!  -500. -100.
!  -300. -100.
!  -300.  100.
!  -500.  100.            ! TRANSMITTER 1 CORNER (E,N) LOCATIONS
!  10                     ! NRX
!    0 0
!   50 0
!  100 0
!  150 0
!  200 0
!  250 0
!  300 0
!  350 0
!  400 0
!  450 0     ! RE RN  East and North coordinates of the receivers
!  4                      ! NLYR
!  50. 20.                ! THK(1), RES(1)
!  300. 1000.             ! THK(2), RES(2)
!  200. 100.              ! THK(3), RES(3)
!  1000.                  ! RES(4)
!  0 2 2                  ! KSYMM, TRGT_BLCK, KACC
!  4 8 1                  ! BLCK_NE(1),BLCK_NN(1),BLCK_NZ(1)
!  500. 800. 50.          ! BLCK_LE(1),BLCK_LN(1),BLCK_LZ(1)
!  0. 0. 0.               ! BLCK_CE(1),BLCK_CN(1),ZTOP(1)
!  10000.                 ! RSB(1)
!  1 6 5                  ! BLCK_NE(2),BLCK_NN(2),BLCK_NZ(2)
!  50. 800. 500.          ! BLCK_LE(2),BLCK_LN(2),BLCK_LZ(2)
!  0. 0. 50.              ! BLCK_CE(2),BLCK_CN(2),ZTOP(2)
!  1.                     ! RSB(2)
!
!* Note that the first slab outcrops and is totally embedded in the first
!  layer touching its two boundaries,  and the second block,  the dyke,
!  straddles two layers.  The cells of the dyke are confined within the
!  layers, i.e.,  no cell runs across layer boundaries while the whole
!  block does.  Marco restricts discretized cells to be totally within a
!  layer while it allows the whole 3D structure to move in a layered
!  earth.  For the above example the discretization of the second block
!  in the vertical direction must be multiples of 5 unless you break the
!  block into two.  Thus this 3D model can be equivalently input as
!
!  0 3 2                  ! KSYMM, TRGT_BLCK, KACC
!  4 8 1                  ! BLCK_NE(1),BLCK_NN(1),BLCK_NZ(1)
!  500. 800. 50.          ! BLCK_LE(1),BLCK_LN(1),BLCK_LZ(1)
!  0. 0. 0.               ! BLCK_CE(1),BLCK_CN(1),ZTOP(1)
!  10000.                 ! RSB(1)
!  1 6 3                  ! BLCK_NE(2),BLCK_NN(2),BLCK_NZ(2)
!  50. 800. 300.          ! BLCK_LE(2),BLCK_LN(2),BLCK_LZ(2)
!  0. 0. 50.              ! BLCK_CE(2),BLCK_CN(2),ZTOP(2)
!  1.                     ! RSB(2)
!  1 4 1                  ! BLCK_NE(3),BLCK_NN(3),BLCK_NZ(3)
!  50. 800. 200.          ! BLCK_LE(3),BLCK_LN(3),BLCK_LZ(3)
!  0. 0. 350.             ! BLCK_CE(3),BLCK_CN(3),ZTOP(3)
!  1.                     ! RSB(3)
!
!  The last block has only one cell in the vertical direction.
!
!* The symmetric option for the above input examples with 3 blocks read:
!
!  1 3 2                  ! KSYMM, TRGT_BLCK, KACC
!  2 4 1                  ! BLCK_NE(1),BLCK_NN(1),BLCK_NZ(1)
!  250. 400. 50.          ! BLCK_LE(1),BLCK_LN(1),BLCK_LZ(1)
!  125. 200. 0.           ! BLCK_CE(1),BLCK_CN(1),ZTOP(1)
!  10000.                 ! RSB(1)
!  1 3 3                  ! BLCK_NE(2),BLCK_NN(2),BLCK_NZ(2)
!  25. 400. 300.          ! BLCK_LE(2),BLCK_LN(2),BLCK_LZ(2)
!  12.5 200. 50.          ! BLCK_CE(2),BLCK_CN(2),ZTOP(2)
!  1.                     ! RSB(2)
!  1 2 1                  ! BLCK_NE(3),BLCK_NN(3),BLCK_NZ(3)
!  25. 400. 200.          ! BLCK_LE(3),BLCK_LN(3),BLCK_LZ(3)
!  12.5 200. 350.         ! BLCK_CE(3),BLCK_CN(3),ZTOP(3)
!  1.                     ! RSB(3)
!
!* As an exercise,  one can change the x-coordinates of the last two
!  blocks (actually the dyke) to get a pi-shaped structure since the
!  program will build the whole structure by symmetry operations.
!
!* Since blocks in this model are not discretized into equal-sized cells,
!  spatial symmetry reduction cannot be used.  However,  group symmetric
!  reduction can still be used because the total structure is symmetric.
!
!
!*********************
!   SAMPLE DATA SETS *
!*********************
!
!   Example F1:  CSAMT illustration.
!
!            This input example illustrates the data input for a CSAMT model
!            studied by Boschetto and Hohmann, Geophysics, Vol 56, p. 255-264,
!            1991.  The body is a 2 km by 2 km by 1 km prism buried 250 m
!            deep.  Field components are printed in files OUTPUT.FEE etc.
!            Apparent resistivities can be check out in file OUTPUT.RES.
!
!            Run time: 1 min on DEC Alphas 200 (9 sec per frequency)
!
!                                     x
!
!                                     x
!
!                            ---------x---------
!       Ty                   |                 |
!       _                    |        x        |
!       |  Tx                |                 |        Rx
!    |-----|  x  x  x  x  x  x  x  x  x  x  x  x  x  x  x  x  x  x
!       |                    |                 |
!       -                    |        x        |
!                            |                 |
!                            ---------x---------
!
!      (not to scale)                 x
!
!                                     x
!
!
!   'Horizontal_bipoles_CSAMT'  ! TITLE          Name of the model
!   1 0.   ! FREQ_TYM, SURFACE_RL; FREQ_TYM=1:  Frequency domain computation
!   1 3               ! SOURCE OUTPUT_FMT  Horizontal current bipoles
!   0                           ! DH_SYS   Surface receivers
!   2                           ! NTX_FD   Two such bipoles
!   -3500.    0. 0.         ! TX_EAST(1,1),TX_NRTH(1,1),TX_VERT(1,1) First
!   -2500.    0. 0.         ! TX_EAST(2,1),TX_NRTH(2,1),TX_VERT(2,1)   bipole
!   -3000.  500. 0.         ! TX_EAST(1,2),TX_NRTH(1,2),TX_VERT(1,2) Second
!   -3000. -500. 0.         ! TX_EAST(2,2),TX_NRTH(2,2),TX_VERT(2,2)   bipole
!   1                       ! FIXED_RX   Same Rx for all Tx
!   17                      ! N_RX     Numbers of receivers
!   -2000 0
!   -1500 0
!   -1000 0
!   500   0
!   0     0
!   500   0
!   1000  0
!   1500  0
!   2000  0
!   2500  0
!   3000  0
!   0   500
!   0  1000
!   0  1500
!   0  2000
!   0  2500
!   0  3000                     ! RX_E RX_N  Receiver coordinates
!   7                           ! NFRQ           Number of frequencies
!   1 3.16 10 31.6 100 316 1000 ! FRQM(*)        Frequencies
!   1 1 1 1 1 1 1            ! AJ(*)          Current amplitude per frequency
!   0                           ! INCL_DIELEC    low frequency application
!   0                           ! COLE_COLE      Non-IP model
!   1                           ! MLAYER         Halfspace
!   100.                        ! RES_EARTH(*)      Halfspace resistivities
!   1                           ! DO_3D
!   1 1 2                       ! KSYMM, TRGT_BLCK, KACC
!   4 4 4                       ! BLCK_NE(1),BLCK_NN(1),BLCK_NZ(1)
!   1000 1000 1000              ! BLCK_LE(1),BLCK_LN(1),BLCK_LZ(1)
!   500 500 250                 ! BLCK_CE(1),BLCK_CN(1),ZTOP(1)
!   1                           ! RSB(1)
!
!
!*** Example F2
!
!   'Vertical_bipole'       ! TITLE          Name of the model
!   1 0.   ! FREQ_TYM, SURFACE_RL; FREQ_TYM=1:  Frequency domain computation
!   2  2         ! SOURCE OUTPUT_FMT   Vertical current bipoles
!   1                       ! DH_SYS   Downhole receivers
!   2                       ! NTX_FD           Two such bipoles
!   -100. -200. 0.          ! TX_EAST(1,1),TX_NRTH(1,1),TX_VERT(1,1) First
!   -100. -200. -300.       ! TX_EAST(2,1),TX_NRTH(2,1),TX_VERT(2,1)   bipole
!   -100.  200. -100.       ! TX_EAST(1,2),TX_NRTH(1,2),TX_VERT(1,2) Second
!   -100.  200. -500.       ! TX_EAST(2,2),TX_NRTH(2,2),TX_VERT(2,2)   bipole
!   0                       ! FIXED_RX   Different Rx for different Tx
!   7 7                     ! N_RX(*)        Numbers of receivers
!   0   0    0 0 0
!   0   0  -50 0 0
!   0   0 -100 0 0
!   0   0 -150 0 0
!   0   0 -200 0 0
!   0   0 -250 0 0
!   0   0 -300 0 0   ! RX_E RX_N RX_Z RDIP RPHI  Rx for the first Tx
!   100 0    0 0 0
!   100 0  -50 0 0
!   100 0 -100 0 0
!   100 0 -150 0 0
!   100 0 -200 0 0
!   100 0 -250 0 0
!   100 0 -300 0 0   ! RX_E RX_N RX_Z RDIP RPHI  Rx for the second Tx
!   3                       ! NFRQ           Number of frequencies
!   1. 100. 10000.          ! FRQM(*)        Frequencies
!   1 1 1                   ! AJ(*)          Current amplitude per frequency
!   0                       ! INCL_DIELEC    low frequency application
!   0                       ! COLE_COLE      Non-IP model
!   4                       ! MLAYER         Four layers
!   20. 1000. 100. 3000.    ! RES_EARTH(*)      Layer resistivities
!   20. 50. 300.            ! LRYTH(*)       Layer thickness
!   1                       ! DO_3D
!   1 1 2                   ! KSYMM, TRGT_BLCK, KACC
!   2 3 6                   ! BLCK_NE(1),BLCK_NN(1),BLCK_NZ(1)
!   20 50 200               ! BLCK_LE(1),BLCK_LN(1),BLCK_LZ(1)
!   10 25 100               ! BLCK_CE(1),BLCK_CN(1),ZTOP(1)
!   .5                      ! RSB(1)
!
!
!*** Example F3
!
!   'Arbitrary_loops'       ! TITLE          Name of the model
!   1 0.   ! FREQ_TYM, SURFACE_RL; FREQ_TYM=1:  Frequency domain computation
!   3 2    ! SOURCE OUTPUT_FMT         Arbitrary loops
!   0                       ! DH_SYS   Surface receivers
!   2                       ! NTX_FD           Two such loops
!   4                       ! N_SIDE(1)       Quadrilateral loops
!   -100. -400. 0. !TX_EAST(1,1),TX_NRTH(1,1),TX_VERT(1,1) First (quadrilateral)
!   -100. -200. 0.   ! TX_EAST(2,1),TX_NRTH(2,1),TX_VERT(2,1)   transmitter
!    100. -200. 0.   ! TX_EAST(3,1),TX_NRTH(3,1),TX_VERT(3,1)   loop
!    100. -400. 0.   ! TX_EAST(4,1),TX_NRTH(4,1),TX_VERT(4,1)   coordinates
!   0.   141.42 0.   ! TX_EAST(1,2),TX_NRTH(1,2),TX_VERT(1,2) Second
!   -141.42  0. 0.   ! TX_EAST(2,2),TX_NRTH(2,2),TX_VERT(2,2)   transmitter
!   0.  -141.42 0.   ! TX_EAST(3,2),TX_NRTH(3,2),TX_VERT(3,2)   loop
!   141.42   0. 0.   ! TX_EAST(4,2),TX_NRTH(4,2),TX_VERT(4,2)   coordinates
!   0                       ! FIXED_RX   Different Rx for different Tx
!   5 4                     ! N_RX(*)        Numbers of receivers
!   0 -300
!   0 -250
!   0 -200
!   0 -150
!   0 -100                  ! RX_E(*,1),RX_N(*,1)  Rx for the first Tx
!   0    0
!   100  0
!   200  0
!   300  0                  ! RX_E(*,2),RX_N(*,2)   Rx for the second Tx
!   3                       ! NFRQ           Number of frequencies
!   1. 100. 10000.          ! FRQM(*)        Frequencies
!   1 1 1                   ! AJ(*)          Current amplitude per frequency
!   0                       ! INCL_DIELEC    low frequency application
!   1                       ! COLE_COLE      Polarizable model
!   4                       ! MLAYER         Four layers
!   20. 1000. 100. 3000.    ! RES_EARTH(*)   Layer resistivities
!   .2 .5 .3 .1             ! CHRG_EARTH(*)  Chargeabilities of the layers
!   .01 .1 1. 100.          ! TAU_EARTH(*)   Time constants of the layers
!   .25 .5 .75 1.           ! FRQC_EARTH(*)  Frequency constants of the layers
!   20. 50. 300.            ! LRYTH(*)       Layer thickness
!   1                       ! DO_3D
!   0 2 2                   ! KSYMM, TRGT_BLCK, KACC
!   2 4 6                   ! BLCK_NE(1),BLCK_NN(1),BLCK_NZ(1)
!   20 50 200               ! BLCK_LE(1),BLCK_LN(1),BLCK_LZ(1)
!   0 0 100                 ! BLCK_CE(1),BLCK_CN(1),ZTOP(1)
!   .5 .4 .1 .25            ! RSB(1),CHRSB(1),TAUSB(1),CFRSB(1)
!   5 2 5                   ! BLCK_NE(2),BLCK_NN(2),BLCK_NZ(2)
!   100 20 100              ! BLCK_LE(2),BLCK_LN(2),BLCK_LZ(2)
!   100 0 100               ! BLCK_CE(2),BLCK_CN(2),ZTOP(2)
!   1. .2 .001 .75          ! RSB(2),CHRSB(2),TAUSB(2),CFRSB(2)
!
!
!*** Example F4 :  Downhole RIM model
!
!                 This example shows a L-shaped model intersected by a
!                 drillhole.  Another drillhole misses the model.  The
!                 transmitters are magnetic dipoles along the drillhole
!                 axis.
!
!
!             ----------------------------------------------------
!                ||                           || || Rx1
!                 ||                          ||||
!             - - -|| - - - - - - - - - - - - |||- - -  - - - - -
!                   ||           ____         ||
!                    ||          |  |        |||
!                 Tx  ||         |  |       ||||
!                      ||        |  |______|| ||
!                       ||       |        ||| ||  Rx2
!                        ||      |       || | ||
!                         ||     |______||__| ||
!                          ||          ||     ||
!             - - - - - - - ||- - - - ||- - - ||- - -  - - - - -
!                            ||      ||       ||
!                             ||    ||        ||
!
!
!   'Magnetic_Dipoles'  ! TITLE          Name of the model
!   1 0.   ! FREQ_TYM, SURFACE_RL; FREQ_TYM=1:  Frequency domain computation
!   4 1              ! SOURCE OUTPUT_FMT        Arbitrary magnetic dipoles
!   1                   ! DH_SYS   Downhole local Rx system
!   11                  ! NTX_FD          Three dipoles
!   -90 0 -980  45 90  ! TX_EAST(1),TX_NRTH(1),TX_VERT(1),TX_DIP(1),TX_PHI(1)
!   -85 0 -985  45 90  ! TX_EAST(2),TX_NRTH(2),TX_VERT(2),TX_DIP(2),TX_PHI(2)
!   -80 0 -990  45 90  ! TX_EAST(3),TX_NRTH(3),TX_VERT(3),TX_DIP(3),TX_PHI(3)
!   -75 0 -995  45 90  ! TX_EAST(4),TX_NRTH(4),TX_VERT(4),TX_DIP(4),TX_PHI(4)
!   -70 0 -1000 45 90  ! TX_EAST(5),TX_NRTH(5),TX_VERT(5),TX_DIP(5),TX_PHI(5)
!   -65 0 -1015 45 90  ! TX_EAST(6),TX_NRTH(6),TX_VERT(6),TX_DIP(6),TX_PHI(6)
!   -60 0 -1020 45 90  ! TX_EAST(7),TX_NRTH(7),TX_VERT(7),TX_DIP(7),TX_PHI(7)
!   -55 0 -1025 45 90  ! TX_EAST(8),TX_NRTH(8),TX_VERT(8),TX_DIP(8),TX_PHI(8)
!   -50 0 -1030 45 90  ! TX_EAST(9),TX_NRTH(9),TX_VERT(9),TX_DIP(9),TX_PHI(9)
!   -45 0 -1035 45 90  ! TX_EAST(10),TX_NRTH(10),TX_VERT(10),TX_DIP(10),TX_PHI(10)
!   -40 0 -1040 45 90  ! TX_EAST(11),TX_NRTH(11),TX_VERT(11),TX_DIP(11),TX_PHI(11)
!   1                  ! FIXED_RX    Same receivers for all transmitters
!   26                 ! N_RX        Number of receivers
!    30 0  -980 45 270
!    25 0  -985 45 270
!    20 0  -990 45 270
!    15 0  -995 45 270
!    10 0 -1000 45 270
!     5 0 -1005 45 270
!     0 0 -1010 45 270
!    -5 0 -1015 45 270
!   -10 0 -1020 45 270
!   -15 0 -1025 45 270
!   -20 0 -1030 45 270
!   -25 0 -1035 45 270
!   -30 0 -1040 45 270
!   20 20  -980 0 0
!   20 20  -985 0 0
!   20 20  -990 0 0
!   20 20  -995 0 0
!   20 20 -1000 0 0
!   20 20 -1005 0 0
!   20 20 -1010 0 0
!   20 20 -1015 0 0
!   20 20 -1020 0 0
!   20 20 -1025 0 0
!   20 20 -1030 0 0
!   20 20 -1035 0 0
!   20 20 -1040 0 0  ! RX_E(*) RX_N(*) RX_Z(*) RDIP(*) RPHI(*)
!   5                       ! NFRQ           Number of frequencies
!   1.E5 3.E5 1.E6 3.E6 1.E7 ! FRQM(*)        Frequencies
!   1 1 1 1 1          ! AJ(*)          Dipole moment
!   1                  ! INCL_DIELEC    High frequency application
!   1                  ! COLE_COLE      Dispersive model
!   3                  ! MLAYER         Four layers
!   1000. 100. 3000.   ! RES_EARTH(*)   Layer resistivities
!   .0 .0 .0           ! CHRG_EARTH(*)  Chargeabilities of the layers
!   .0 .0 .0           ! TAU_EARTH(*)   Time constants of the layers
!   .0 .0 .0           ! FRQC_EARTH(*)  Frequency constants of the layers
!   5. 10. 6.          ! DIELC_EARTH(*) Layer permittivities
!   .2 .1 .5           ! DCHRG_EARTH(*) Chargeabilities of the permittivities
!   1.E-5 1.E-6 1.e-7  ! DTAU_EARTH(*)  Time constants of the permittivities
!   .5 .25 .75         ! DFRQC_EARTH(*) Frequency constants of the permittivities
!   990. 40.           ! LRYTH(*)       Layer thickness
!   1                  ! DO_3D
!   0 2 2              ! KSYMM, TRGT_BLCK, KACC
!   2 8 8              ! BLCK_NE(1),BLCK_NN(1),BLCK_NZ(1)
!   5 20 20            ! BLCK_LE(1),BLCK_LN(1),BLCK_LZ(1)
!   -12.5 0 1000       ! BLCK_CE(1),BLCK_CN(1),ZTOP(1)
!   .5 0. 0. 0.        ! RSB(1),CHRSB(1),TAUSB(1),CFRSB(1)
!   20. .3 1.E-6 1.    ! DESB(1),DCHRSB(1),DTAUSB(1),DCFRSB(1)
!   8 8 2              ! BLCK_NE(2),BLCK_NN(2),BLCK_NZ(2)
!   20 20 5            ! BLCK_LE(2),BLCK_LN(2),BLCK_LZ(2)
!   0 0 1015           ! BLCK_CE(2),BLCK_CN(2),ZTOP(2)
!   .5 0. 0. 0.        ! RSB(2),CHRSB(2),TAUSB(2),CFRSB(2)
!   20. .3 1.E-6 1.    ! DESB(2),DCHRSB(2),DTAUSB(2),DCFRSB(2)
!
!
!*** Example F5
!
!   'Circular_loop'         ! TITLE          Name of the model
!   1 0.   ! FREQ_TYM, SURFACE_RL; FREQ_TYM=1:  Frequency domain computation
!   5 2    ! SOURCE OUTPUT_FMT              Horizontal circular loop
!   0                       ! DH_SYS        Surface receivers
!   1                       ! NTX_FD           One loop
!   100.                    ! RAD            Radius of the loop
!   0. 0. 0.                ! TX_EAST TX_NRTH TX_VERT  Centre of the loop
!   0                       ! FIXED_RX    Read this record for consistence
!   3                       ! N_RX(*)        Numbers of receivers
!   0   0
!   0  50
!   0 200                   ! RX_E RX_N   Receiver coordinates
!   3                       ! NFRQ           Number of frequencies
!   1. 100. 10000.          ! FRQM(*)        Frequencies
!   1 1 1                   ! AJ(*)          Current amplitude per frequency
!   0                       ! INCL_DIELEC    low frequency application
!   0                       ! COLE_COLE      Non-IP model
!   4                       ! MLAYER         Four layers
!   20. 1000. 100. 3000.    ! RES_EARTH(*)      Layer resistivities
!   20. 50. 300.            ! LRYTH(*)       Layer thickness
!   0                       ! DO_3D          Compute 1D only
!
!
!*** Example F6
!
!   'Loop_loop_system'      ! TITLE          Name of the model
!   1 0.   ! FREQ_TYM, SURFACE_RL; FREQ_TYM=1:  Frequency domain computation
!   6  2   ! SOURCE OUTPUT_FMT               Horizontal loop-loop configuration
!   10.                     ! RAD2           Transmitter loop radius
!   30. 30. 0.              ! TR_OFF_E TR_OFF_N TR_OFF_Z Tx-Rx offsets
!   1                       ! N_PROFL      Numbers of profiles
!   -100 -100 0 90 45 10 50 ! START_E, _N, _Z, PROFL_DIP, _PHI N_STATN STATN_DIST
!   3                       ! NFRQ           Number of frequencies
!   1. 100. 10000.          ! FRQM(*)        Frequencies
!   1 1 1                   ! AJ(*)          Current amplitude per frequency
!   0                       ! INCL_DIELEC    low frequency application
!   0                       ! COLE_COLE      Non-IP model
!   4                       ! MLAYER         Four layers
!   20. 1000. 100. 3000.    ! RES_EARTH(*)      Layer resistivities
!   20. 50. 300.            ! LRYTH(*)       Layer thickness
!   1                       ! DO_3D
!   1 1 2                   ! KSYMM, TRGT_BLCK, KACC
!   2 3 6                   ! BLCK_NE(1),BLCK_NN(1),BLCK_NZ(1)
!   20 50 200               ! BLCK_LE(1),BLCK_LN(1),BLCK_LZ(1)
!   10 25 70                ! BLCK_CE(1),BLCK_CN(1),ZTOP(1)
!   .5                      ! RSB(1)
!
!
!*** Example F7
!
!   'Moving_HHD'            ! TITLE          Name of the model
!   1 0.   ! FREQ_TYM, SURFACE_RL; FREQ_TYM=1:  Frequency domain computation
!   7 2    ! SOURCE OUTPUT_FMT  Moving coaxial HHD with fixed Tx-Rx offset
!   0 0 3                   ! TR_OFF_E TR_OFF_N TR_OFF_Z Tx-Rx offsets
!   1                       ! N_PROFL      Numbers of profiles
!   20 0 -390 0 45 10 5     ! START_E, _N, _Z, PROFL_DIP, _PHI N_STATN STATN_DIST
!   3                       ! NFRQ           Number of frequencies
!   1.E5 1.E6 1.E7          ! FRQM(*)        Frequencies
!   1 1 1                   ! AJ(*)          Current amplitude per frequency
!   1                       ! INCL_DIELEC    High frequency application
!   0                       ! COLE_COLE      Non-IP model
!   4                       ! MLAYER         Four layers
!   20. 1000. 100. 3000.    ! RES_EARTH(*)   Layer resistivities
!   5. 10. 6. 1.            ! DIELC_EARTH(*) Layer permittivities
!   20. 50. 300.            ! LRYTH(*)       Layer thickness
!   1                       ! DO_3D
!   1 1 2                   ! KSYMM, TRGT_BLCK, KACC
!   2 3 6                   ! BLCK_NE(1),BLCK_NN(1),BLCK_NZ(1)
!   5 10 20                 ! BLCK_LE(1),BLCK_LN(1),BLCK_LZ(1)
!   2.5 5 400               ! BLCK_CE(1),BLCK_CN(1),ZTOP(1)
!   10. 20.                 ! RSB(1),DESB(1)
!
!
!*** Example F8
!
!   'Moving_VHD'            ! TITLE          Name of the model
!   1 0.   ! FREQ_TYM, SURFACE_RL; FREQ_TYM=1:  Frequency domain computation
!   8 2    ! SOURCE OUTPUT_FMT  Moving coplanar VHD with fixed Tx-Rx offset
!   2      ! PLANAR     Vertical coplanar system
!   30. 30. 0.              ! TR_OFF_E TR_OFF_N TR_OFF_Z Tx-Rx offsets
!   1                       ! N_PROFL      Numbers of profiles
!   -100 -100 0 90 45 10 50 ! START_E, _N, _Z, PROFL_DIP, _PHI N_STATN STATN_DIST
!   3                       ! NFRQ           Number of frequencies
!   1. 100. 10000.          ! FRQM(*)        Frequencies
!   1 1 1                   ! AJ(*)          Current amplitude per frequency
!   0                       ! INCL_DIELEC    low frequency application
!   0                       ! COLE_COLE      Non-IP model
!   4                       ! MLAYER         Four layers
!   20. 1000. 100. 3000.    ! RES_EARTH(*)      Layer resistivities
!   20. 50. 300.            ! LRYTH(*)       Layer thickness
!   1                       ! DO_3D
!   1 1 2                   ! KSYMM, TRGT_BLCK, KACC
!   2 3 6                   ! BLCK_NE(1),BLCK_NN(1),BLCK_NZ(1)
!   20 50 200               ! BLCK_LE(1),BLCK_LN(1),BLCK_LZ(1)
!   10 25 70                ! BLCK_CE(1),BLCK_CN(1),ZTOP(1)
!   .5                      ! RSB(1)
!
!*** Example F9
!
!   'Magnetotellurics'      ! TITLE          Name of the model
!   1 0.   ! FREQ_TYM, SURFACE_RL; FREQ_TYM=1:  Frequency domain computation
!   9 3              ! SOURCE OUTPUT_FMT        Magnetotellurics
!   2 5 7 0.                ! NPOL,MT_PROFL,MT_STATN,ZMT
!   -500 -250 0 250 500     ! XRMT(*)        Receiver station x-coordinates
!   -300 -200 -100 0 100 200 300 ! YRMT      Receiver station y-coordinates
!   3                       ! NFRQ           Number of frequencies
!   1. 100. 10000.          ! FRQM(*)        Frequencies
!   0                       ! INCL_DIELEC    low frequency application
!   0                       ! COLE_COLE      Non-IP model
!   4                       ! MLAYER         Four layers
!   20. 1000. 100. 3000.    ! RES_EARTH(*)      Layer resistivities
!   20. 50. 300.            ! LRYTH(*)       Layer thickness
!   1                       ! DO_3D
!   1 1 2                   ! KSYMM, TRGT_BLCK, KACC
!   2 3 6                   ! BLCK_NE(1),BLCK_NN(1),BLCK_NZ(1)
!   20 50 200               ! BLCK_LE(1),BLCK_LN(1),BLCK_LZ(1)
!   10 25 100               ! BLCK_CE(1),BLCK_CN(1),ZTOP(1)
!   .5                      ! RSB(1)
!
!   Note that the coordinate system for MT is different from that for
!   controlled sources.  For MT problems,  the X-axis is pointed to the
!   north while the Y-axis is pointed to the east.
!
!*****          end input data format for FREQ_TYM=1                   *****
!***************************************************************************
!
!&&&&&&&&&&&&&&&&&&&&&&&&&&
!          PRIOR CHANGES  &
!&&&&&&&&&&&&&&&&&&&&&&&&&&
!
!       CHANGES SINCE VERSION 2.0
!
!   There had been two problems experienced by sponsors since the release
!   of version 2.0.  One of them was an array allocation that caused
!   "out of memory" messages in certain cases.  The other problem was
!   caused by a facility to scale of model dimensions to improve the
!   accuracy when modelling small targets.  This seemed to cause errors
!   in some systems.  Thus this function has been turned off for robustness.
!   A third problem which our recent testing discovered occurred when running
!   Marco as a 1D program with coincident loop sources.  Apart correcting
!   these problems, a few cosmetic improvements have to added to the current
!   version.
!
!
!       CHANGES SINCE VERSION 1.2
!
!     MARCO 2.0 has undergone profound changes with many additional features
!   described below.
!
!     DATA INPUT HAS CHANGED CONSIDERABLY.  OLD INPUT DATA FILES WON'T WORK!
!   Refer to DATA input description files and Sample Input Data files in the
!   documentation below.
!
!  1. MARCO 2.0 is written in Fortran 90.  It will not compile under
!     Fortran 77.  Amongst other things, this means dynamic memory allocation
!     and improved structural efficiency.
!
!  2. New frequency domain source options have been added.  These include:
!
!      a. horizontal electric bipoles (for example CSAMT);
!      b. vertical current bipoles for down hole modelling;
!      c. magnetic dipoles (including downhole sources) with arbitrary
!         location and arbitrary orientation
!      d. horizontal arbitrary loops;
!      e. Tx_Rx moving with constant offset
!      f. horizontal circular loops;  and
!      h: magnetotellurics.
!
!  3. There is a high frequency option to model RIM and similar systems.
!
!  4. RELATIVE LEVELS  Downhole receiver / transmitter
!     coordinates are specified in terms of relative levels.  This means that
!     a new record giving the RL of the surface must also be read in.
!
!  5. Horizontal locations are specified as east and north.
!
!  6. The magnetic components for downhole receivers follow Jim Cull's
!     convention.  The local component system consists of C3, an axial
!     component, C1 a component lying in the vertical plane made by
!     a dipping borehole (perpendicular to the axial component and
!     C2 lying in the horizontal plane, orthogonal to C1 and C3.
!
!     Alternatively, components can be specified in the global system,
!     (Vertical, East, North) by specifying the receiver dip as 0.
!
!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
!
!
!  START MAIN
!
   PROGRAM MARCO
!
      IMPLICIT NONE
!
! ---- Parameter SUB_CELL_MAX is the maximal number of cells to be allowed
!      in a substructure.  The parameter defines the maximal size of the
!      scattering matrix.  Note that the total number of cells to be modeled
!      is independent of SUB_CELL_MAX.  In fact,  there is no limit on the
!      total number of cells this program can handle as long as there is
!      enough disk space.
!
      INTEGER, PARAMETER :: SUB_CELL_MAX=500
!
! ---- TITLE is the name of the model
!
      CHARACTER*80 TITLE
!
!**** Parameters for the 1D earths  *****************
!*                                                  *
!
      COMPLEX, ALLOCATABLE, DIMENSION(:) :: CDH,CDV,KKH
!
      REAL, ALLOCATABLE, DIMENSION (:) :: RES_EARTH,CHRG_EARTH,TAU_EARTH,FRQC_EARTH,      &
                                          DIELC_EARTH,DCHRG_EARTH,DTAU_EARTH,DFRQC_EARTH,   &
                                          LRYTH,ZBND,HVK
      REAL, ALLOCATABLE :: FRQM(:)
!*                                                  *
!****************************************************
!
!**** Parameters for sources and receivers  *********
!*                                                  *
!
      INTEGER, ALLOCATABLE, DIMENSION(:) :: N_RX,N_SIDE,N_STATN
      REAL, ALLOCATABLE, DIMENSION(:,:)  :: RX_X,RX_Y,RX_Z,TX_CRDX,TX_CRDY, &
                                            TX_CRDZ,MD_ANGLE
      REAL, ALLOCATABLE, DIMENSION(:,:,:) :: RX_ANGLE
      REAL, ALLOCATABLE, DIMENSION(:)    :: TX_CRDXI,TX_CRDYI,TX_CRDZI,RAD, &
                                            START_X,START_Y,START_Z,PROFL_DIP, &
                                            PROFL_PHI,STATN_DIST
      REAL                               :: SURFACE_RL
      INTEGER                            :: DH_SYS
!
!   -- AJ is the current amplitude for electric sources or the dipole
!      moment for magnetic sources.  It must be given for each frequency.
!
      REAL, ALLOCATABLE :: AJ(:)
!*                                                  *
!****************************************************
!
! --- Arrays storing the tabulated Hankel integrals.  RRG contains the lateral
!     grid abscissas
!
      REAL, ALLOCATABLE :: RRG(:),RRG3(:)
      COMPLEX, ALLOCATABLE :: GRHF(:,:,:,:),GRHO0(:,:,:)
!  ---   For 3D applications only :
      COMPLEX, ALLOCATABLE :: GRHF3(:,:,:),GRHO03(:,:)
!
!  --- MZGRID is the maximal number of the vertical z-levels of the sources
!      and receivers.   300 should be quite big since it corresponds to an
!      array size of over 600 M-bytes for the array GRHF.
!
!      The arrays ZOBG etc. may also be made allocatable so that the parameter
!      MZGRID is eliminated.  However,  unless the routine INIT_ZLVLS is made an
!      internal routine of the main program this may affect the beauty of the
!      code since determining the z-levels is quite lengthy.
!
      INTEGER, PARAMETER :: MZGRID=300
!
      REAL :: ZOBG(MZGRID),ZSRG(2,MZGRID),ZOBCS(MZGRID),ZSRCS(2,MZGRID)
      REAL, ALLOCATABLE :: ZBG(:,:)
!
      COMPLEX, ALLOCATABLE, DIMENSION(:,:) :: ENX,ENY,ENZ,HNX,HNY,HNZ,    &
!   ----            For 3D applications only:
                                              ESX,ESY,ESZ,HSX,HSY,HSZ
!
!
! ---- The parameter NSBM controls the sizes of the arrays for
!      the structure blocks  which are to be divided into
!      computational blocks for system iterations.
!
      INTEGER, PARAMETER :: NSBM=20
!
!******* Parameter FREQ_TYM controls whether this program  ********
!        computes time domain or frequency domain results
!
!        Time domain results are for horizontal loops only
!
!        Frequency domain results can be computed for arbitrary sources
!
!      FREQ_TYM=1: Frequency domain
!            =0: Time domain.
!
!      Note that with AMIRA formats Marco computes the frequency
!      domain 3D responses only.  1D parts and time domain wave
!      form convolutions are done by routines developed by Art
!      Raiche.
!
!**** Parameters for FREQ_TYM=0
!
!   Note that the array HFD cannot share memory with any of the
!   big arrays because it is there during the frequency domain
!   computation in every frequency.  This may be changed if the
!   frequency domain results are stored as for FREQ_TYM=1.
!
!               Tx       Rx      Frq       Time      Layer
      INTEGER MXFRQ,MXLYR,MXRX,MXTX,MXTYM,NCHNL,ND,NLYR,NR,NSHT,IDH,      &
              IPRF,ITYM,JC,JF,JR,JS,MDELYT,NSXL,NTEM3D,NTX
      PARAMETER (MXTX=25,MXRX=50, MXFRQ=75, MXTYM=75, MXLYR=20)
      REAL BASFRQ,OFFTYM,RXAREA
      REAL HFD(MXFRQ,3,MXRX,MXTX),WRX(MXRX),WTX(MXTX),RX(MXRX,MXTX),      &
           RY(MXRX,MXTX),RZ(MXRX,MXTX),RE(MXRX,MXTX),RN(MXRX,MXTX),       &
           RDIP(MXRX,MXTX),RPHI(MXRX,MXTX),SX(4,MXTX),SY(4,MXTX),         &
           FREQ(MXFRQ),TMS(MXTYM),WTMS(MXTYM),TMSPR(MXTYM),TXON(MXTYM),   &
           TXAMP(4,MXTYM),RES(MXLYR),THK(MXLYR),CHRG(MXLYR),              &
           CFREQ(MXLYR),CTAU(MXLYR)
      INTEGER ICOLE(MXLYR),NRX(MXTX)
      LOGICAL CDNT, DWNHL, COLE, DO3D, BPLR, CRVSEG, PRTSEC
!
!***************************************************************
!
      REAL BLMIN,CLMN2,FRQ,RAD2,RMAX1,RMAX2,RMIN1,RMIN2,SBX,SBY,SBZ,SCALE,  &
           SCALE2,SCX,SCY,SCZ,TR_OFF_X,TR_OFF_Y,TR_OFF_Z,XSB,YSB,ZMT,ZSB,   &
           HTMPX,HTMPY,HTMPZ,AA1,AA2,DIP,AZIM
      INTEGER I,IFRQ,J,KACC,KANIS,KBOUND,KGHP,FIXED_RX,COLE_COLE,           &
              KSFT,KSMR,CS_TYPE,KSYMM,KAUTO,KTEM,KUTCRP,DOWNHOLE,N_PROFL,   &
              LP1,LP2,MLAYER,NBODY,NCRD,NCTT,NEQ,NFRQ,NBMAX,MT_PROFL,NPOL,  &
              MT_STATN,TRGT_BLCK,DO_3D,NTX_FD,NXS,NYS,NOBCS,NSRCS,NZOB,     &
              NZSR,NZBG,NZS,PLANAR,OUTPUT_FMT
      REAL    :: WMU
      COMPLEX :: EH1,EH2
      INTEGER :: IEXCI
!
! --- OUT_REF controls whether or not the reference output file OUTPUT.REF should
!     be printed.  It contains output results in the internal coordinate system.
!
      INTEGER, PARAMETER :: OUT_REF=0
!
!**** Parameters for the 3D body  *******************
!*                                                  *
!
      INTEGER, ALLOCATABLE :: BLCK_NX(:),BLCK_NY(:),BLCK_NZ(:),              &
                              NX(:,:),NY(:,:),NZ(:,:),NCELL(:,:),            &
                              NXI(:),NYI(:),NZI(:),NXJ(:),NYJ(:),            &
                              NZJ(:),NCELLI(:),NCELLJ(:),NCT(:),NET(:),      &
                              KCELL(:),SUB_BLOCK(:),KEYSF(:,:)
      COMPLEX, ALLOCATABLE :: CDB(:,:)
      REAL, ALLOCATABLE :: CLMN(:),BLCK_LX(:),BLCK_LY(:),BLCK_LZ(:),          &
                           BLCK_CX(:),BLCK_CY(:),BLCK_CZ(:),RSB(:),CHRSB(:),  &
                           TAUSB(:),CFRSB(:),DESB(:),DCHRSB(:),DTAUSB(:),     &
                           DCFRSB(:),RBC(:,:),CHRBC(:,:),TAUBC(:,:),CFRBC(:,:),&
                           DEBC(:,:),DCHRBC(:,:),DTAUBC(:,:),DCFRBC(:,:),     &
                           BLX(:,:),BLY(:,:),BLZ(:,:),XBL(:,:),YBL(:,:),      &
                           ZBL(:,:),XCELL(:,:,:),YCELL(:,:,:),ZCELL(:,:,:),   &
                           BLXI(:),BLYI(:),BLZI(:),XCELLI(:,:),YCELLI(:,:),   &
                           ZCELLI(:,:),XCELLJ(:,:),YCELLJ(:,:),ZCELLJ(:,:),   &
                           X1(:),Y1(:),Z1(:)
!
!*                                                  *
!****************************************************
!
!**** Parameters for MT receivers *******************
!*                                                  *
!
!   The MT option is retained in this version since this does not take
!   much extra spaces.  On the other hand,  the plane wave excitations
!   may somethmes be useful.
!
      REAL, ALLOCATABLE :: XRMT(:),YRMT(:)
!
      COMPLEX :: H0X,H0Y,E0X,E0Y
!
!  -- Arrays for scattered fields of MT stations
!
      COMPLEX, ALLOCATABLE :: EXMT(:,:,:),EYMT(:,:,:),EZMT(:,:,:),        &
                              HXMT(:,:,:),HYMT(:,:,:),HZMT(:,:,:)
!*                                                  *
!****************************************************
!
!
      INTEGER NMAX
!
      COMPLEX, ALLOCATABLE :: GA(:,:),EN(:),EMT(:),ENT(:,:),JST(:,:),     &
                              EJGS(:),EJGS2(:)
      REAL, ALLOCATABLE :: VV(:),GAI(:)
      INTEGER, ALLOCATABLE :: IND(:)
!
! ----- The arrays GSB1 and GSB2 stores the elements of the scattering
!     matrix to be used using symmetry reduction.  GSB1 shares the
!     storage with GA.  GSB2 shares the storage with the array GRHF
!     which stores the grid values of the Hankel transforms.   GSB1
!     and GSB2 are in fact identical.  Only one of them is used at
!     a time.  They are used to save memory since GA is not needed
!     when GSB1 is computed using GRHF and GRHF is not in used when
!     GA is computed using GSB2.  Thus all contents of GSB1 is transferred
!     to GSB2 after GSB1 is computed.
!
!     Since GA and GRHF are linked by GSB1 and GSB2, it is
!     desirable to have all of them the same size.  Because the array
!     GRHF are relatively hard to be changed in size, here GSB1 and
!     GSB2 are declared the same size as GRHF.  The only way to
!     change the size of GRHF is to change the parameter NZTMAX.
!     See the above comments on NZTMAX.
!
!
! ---- Parameter NSMR controls the size of the array containing
!    all the non-identical matrix elements for spatial symmetry
!    reductions.  Note that NSRM is defined differently from the
!    old version SYSEM since the first subscriptor of GRHF is changed.
!
!    In case NZTMAX has to be enlarged to allow either more cells
!    in the vertical direction or to allow more downhole receivers,
!    but the array GSB1 and GSB2 is big enough for the problem,
!    the definition of NSMR may changed in order to minimize the
!    memory requirement.  The memory requirement will otherwise
!    increases with NZTMAX quadratically.
!
      INTEGER NSMR
!
      COMPLEX, ALLOCATABLE :: GSB1(:,:),GSB2(:,:)
!
!   The array TCDB is used to compute electric fields at
!   receivers located on or within a cell.
!
      COMPLEX, ALLOCATABLE :: TCDB(:,:,:)
!
      COMPLEX, ALLOCATABLE :: EAX(:),EAY(:),EAZ(:),HAX(:),HAY(:),HAZ(:)
!
       INTEGER, PARAMETER :: KCOND=0, KJST=0, KCLMN=0
!
      REAL :: ALMAX,DMIN,RHOMAX,RHOMIN
      INTEGER :: FREQ_TYM,MBODY,M_RX,NFRQM,NHFILM,NSUBCM,            &
                 NW,NWR,NXMAX,NYMAX,NZMAX,INCL_DIELEC
!
!---- AMIRA I/O formats
!
!   INPUT data are read from logical unit number 3 and
!   OUTPUT data are written to unit 4.
!   OUTPUT.FRQ data are written to unit 7.
!
!    UNIT #   UNIT ID    FILE ID        FUNCTION
!    ------   -------    -------        --------
!      3        NR       INPUT.DAT      INPUT DATA
!      4        NW       OUTPUT.OUT     TIME-DOMAIN OUTPUT DATA
!      7        ND       OUTPUT.FRQ     FREQUENCY-DOMAIN DATA
!      22       NA       AMIRA.FMT      AMIRA FORMAT OUTPUT DATA
!      8        NWR      OUTPUT.REF     FREQUENCY-DOMAIN DETAILED RESULTS
!
         NR=3
         NW=4
         ND=7
         NWR=8
         OPEN (NR,FILE='INPUT.DAT',STATUS='UNKNOWN')
         OPEN (NW,FILE='OUTPUT.OUT',STATUS='UNKNOWN')
         IF (OUT_REF==1.OR.KJST==1)                      &
            OPEN (NWR,FILE='OUTPUT.REF',STATUS='REPLACE')
!
   WRITE(NW,1)
   WRITE(*,1)
!
 1 FORMAT (/' Modified EM integral equation code,/ Standard AR input format,/,Mayavi output format '/)
!			   
!
! --- Open files RESST and CONDT for storing the resistivity and the
!    complex conductivity of the cells.  These two units must be
!    opened for computation since cell conductivities are needed.
!    These two units won't be used by routine ROI_READ if FREQ_TYM=0.
!
      OPEN (61,FILE='RESST',FORM='UNFORMATTED',STATUS='UNKNOWN')
      OPEN (62,FILE='CONDT',FORM='UNFORMATTED',STATUS='UNKNOWN')
!
      READ (NR,*) TITLE
      READ (NR,*) FREQ_TYM,SURFACE_RL
!
      IF (FREQ_TYM==1) THEN
!***************************************************
!*                                                 *
         CALL READATA
!
! --- Translate the vertical coordinates relative to a ground level to the
!     true coordinates where the ground is always zero.
!
         IF (CS_TYPE/=1)                                                      &
         CALL INIT_GROUND (SURFACE_RL,NTX_FD,N_RX,M_RX,TRGT_BLCK,             &
                           TX_CRDZ,RX_Z,BLCK_CZ,DO_3D,1,1)
!
! --- Convert the input coordinate system to the coordinate system for
!     computation
!
!     After the execution of this routine, X points north, Y points east,
!     and Z points down.
!
         IF (CS_TYPE/=1)                                                      &
         CALL INIT_CONVERT (CS_TYPE,NTX_FD,NCRD,N_SIDE,N_RX,M_RX,DO_3D,1,     &
                            TRGT_BLCK,TX_CRDX,TX_CRDY,TX_CRDZ,RX_X,RX_Y,RX_Z, &
                            TR_OFF_X,TR_OFF_Y,N_PROFL,START_X,START_Y,        &
                            START_Z,BLCK_LX,BLCK_LY,BLCK_CX,BLCK_CY,BLCK_CZ,  &
                            BLCK_NX,BLCK_NY)
!*                                                 *
!***************************************************
      ENDIF
!
      IF (FREQ_TYM==0) THEN
!**************************************************
!                                                 *
!
!  Read in data.  Then check for central loop or slingram type configuration.
!
!    Routine ROI_READ is adapted from Leroi routine READLR to
!    accommodate Marco 3D parameters.
!
! -- Use NSBM,  instead of the actual target block numbers for FREQ_TYM=0.
!    This allows the routine ROI_READ to be an independent one.
!
!    MBODY etc. must be assigned for ROI_READ unless ROI_READ is made an internal
!    routine like READATA
!
         INCL_DIELEC=0
         MBODY=20; NXMAX=60; NYMAX=60; NZMAX=30
!
         ALLOCATE(BLCK_NX(NSBM),BLCK_NY(NSBM),BLCK_NZ(NSBM),               &
                  BLCK_LX(NSBM),BLCK_LY(NSBM),BLCK_LZ(NSBM),               &
                  BLCK_CX(NSBM),BLCK_CY(NSBM),BLCK_CZ(NSBM),               &
                  RSB(NSBM),CHRSB(NSBM),TAUSB(NSBM),              &
                  CFRSB(NSBM),DESB(NSBM),DCHRSB(NSBM),            &
                  DTAUSB(NSBM),DCFRSB(NSBM))
!
!  --  Note that the parameter NSX of Leroi has been changed to NSXL
!      due to conflict with NSX of the superblock of Marco
!
         CALL ROI_READ(NR,ND,NW,MXTYM,MXTX,MXRX,MXLYR,MXFRQ,NFRQ,FREQ,        &
                       TITLE,NTEM3D,PRTSEC,IDH,CDNT,DWNHL,IPRF,NCHNL,ITYM,    &
                       TMS,TMSPR,WTMS,OFFTYM,RXAREA,MDELYT,BASFRQ,NSXL,       &
                       BPLR,CRVSEG,TXON,TXAMP,NTX,SX,SY,NRX,RX,RY,RZ,         &
                       RE,RN,RDIP,RPHI,NLYR,NSHT,THK,RES,COLE,ICOLE,CHRG,     &
                       CTAU,CFREQ,KACC,KSYMM,NSBM,NXMAX,NYMAX,NZMAX,          &
                       TRGT_BLCK,BLCK_NX,BLCK_NY,BLCK_NZ,BLCK_LX,BLCK_LY,     &
                       BLCK_LZ,BLCK_CX,BLCK_CY,BLCK_CZ,RSB,CHRSB,TAUSB,CFRSB)

         DO3D=.FALSE.
         IF (NTEM3D==1) DO3D=.TRUE.

!  Set up transmitter loop target relationships.  Set up coincident loop
!  integration points if necessary.

         IF (CDNT.AND.DO3D) CALL ROI_CLPRX(NTX,SX,SY,MXRX,NRX,RX,RY,WTX,WRX)
!
!**** Convert to Marco parameters for 3D computations
!
! -- Allocate arrays
!
         MLAYER=ABS(NLYR)
         ALLOCATE(RES_EARTH(MLAYER),CHRG_EARTH(MLAYER),TAU_EARTH(MLAYER),     &
                  FRQC_EARTH(MLAYER),DIELC_EARTH(MLAYER),DCHRG_EARTH(MLAYER), &
                  DTAU_EARTH(MLAYER),DFRQC_EARTH(MLAYER))
         ALLOCATE(LRYTH(MLAYER),HVK(0:MLAYER))
         NCRD=4
         NTX_FD=NTX
         ALLOCATE(RAD(NTX_FD),TX_CRDX(NCRD,NTX_FD),TX_CRDY(NCRD,NTX_FD),   &
                  TX_CRDZ(NCRD,NTX_FD))
         ALLOCATE(N_RX(NTX_FD),N_SIDE(NTX_FD))
         DO J=1,NTX
            N_RX(J)=NRX(J)
            N_SIDE(J)=4
         ENDDO
         M_RX=MAXVAL(N_RX)
         ALLOCATE(RX_X(M_RX,NTX_FD),RX_Y(M_RX,NTX_FD),RX_Z(M_RX,NTX_FD))
         IF (IDH==1) ALLOCATE(RX_ANGLE(2,M_RX,NTX_FD))
         ALLOCATE(FRQM(NFRQ),AJ(NFRQ))
         AJ=1.
!
         CALL ROI_2_MARCO(surface_rl,      &
                     MXTX,MXRX,MXLYR,MXFRQ,NFRQ,FREQ,NTX,SX,SY,NRX,RX,  &
                     RY,RZ,RDIP,RPHI,IDH,NLYR,THK,RES,CHRG,CTAU,CFREQ,COLE,  &
                     DO3D,TRGT_BLCK,BLCK_NX,BLCK_NY,BLCK_LX,BLCK_LY,BLCK_CX, &
                     BLCK_CY,BLCK_CZ,DO_3D,COLE_COLE,KAUTO,DESB,DCHRSB,DTAUSB, &
                     DCFRSB,MLAYER,KANIS,RES_EARTH,CHRG_EARTH,TAU_EARTH,     &
                     FRQC_EARTH,DIELC_EARTH,DCHRG_EARTH,DTAU_EARTH,          &
                     DFRQC_EARTH,HVK,LRYTH,KTEM,FRQM,CS_TYPE,M_RX,NTX_FD,    &
                     TX_CRDX,TX_CRDY,TX_CRDZ,NCRD,N_RX,RX_X,RX_Y,RX_Z,RX_ANGLE)
!         CALL ROI_2_MARCO(SURFACE_RL,MXTX,MXRX,MXLYR,MXFRQ,NFRQ,FREQ,NTX,SX, &
!                          SY,NRX,RX,RY,RZ,RDIP,RPHI,IDH,NLYR,THK,RES,CHRG,   &
!                          CTAU,CFREQ,COLE,DO3D,TRGT_BLCK,BLCK_NX,BLCK_NY,    &
!                          BLCK_LX,BLCK_LY,BLCK_CX,BLCK_CY,BLCK_CZ,DO_3D,     &
!                          COLE_COLE,KAUTO,DESB,DCHRSB,DTAUSB,DCFRSB,MLAYER,  &
!                          KANIS,RES_EARTH,CHRG_EARTH,DTAUSB,FRQC_EARTH,      &
!                          DIELC_EARTH,DCHRG_EARTH,DTAU_EARTH,DFRQC_EARTH,    &
!                          HVK,LRYTH,KTEM,FRQM,CS_TYPE,M_RX,NTX_FD,TX_CRDX,   &
!                          TX_CRDY,TX_CRDZ,NCRD,N_RX,RX_X,RX_Y,RX_Z,RX_ANGLE)
!
! --- Test for downhole local receiver coordinate system.  If the dip angles
!     of the downhole is zero, use global system
!
         DOWNHOLE=0
         IF (IDH==1) THEN
            DO I=1,NTX_FD
               DO J=1,N_RX(I)
                  IF (ABS(RX_ANGLE(1,J,I))>.001) DOWNHOLE=1
               ENDDO
            ENDDO
         ENDIF
!*                                                 *
!***************************************************
      ENDIF
!
! ---- Set parameters for the high or low frequency version (i.e.,
!      whether displacement currents should be included)
!
!      ALMAX for the truncation of the kernels functions is determined
!      by the switch INCL_DIELEC.  ALMAX is to be passed into routine
!      ONE_D_0_2_INFTY.
!
!      DMIN is the geometric resolution limit.
!
!      RHOMIN and RHOMAX determine the minimal and maximal dimensions the
!      code can handle,  which is determined by the filters and required
!      size of the array GRHF.  They must agree with the design of
!      routine HFIL (the array dimensions in that routine).
!
!      NHFILM is the total number of grid for the spatial Hankel transforms
!      designed in routine HFIL which uses 15-per-decade filters in the low
!      frequency version and 50-per-decade filters in the high frequency
!      version.
!
!      The value of ALMAX depends on the highest frequency
!
      IF (INCL_DIELEC==1) THEN
         IF (MAXVAL(FRQM)>5.E7) THEN
            ALMAX=300.
         ELSE
            ALMAX=100.
         ENDIF
         DMIN=0.001; RHOMIN=0.01
      ELSE
         ALMAX=20.; DMIN=.1;  RHOMIN=0.1
      ENDIF
!
!   -- Check consistence of the above parameters with respect to INCL_DIELEC
!      and NHFILM.
!
!  -- Allocate working array for the electrode coordinates of the loops
!
      ALLOCATE(TX_CRDXI(NCRD),TX_CRDYI(NCRD),TX_CRDZI(NCRD))
!
!  --- Divide the block(s) into substructures if necessary
!
      IF (DO_3D==1) THEN
!
!      Parameter NBMAX for the maximal number of block in each substructure
!      is necessary to control the number of blocks in a substructure.
!
         NBMAX=3
!
         CALL STRUCTURING
!
!  --    Allocate 3D parametric arrays
!
         NXMAX=MAXVAL(NX)
         NYMAX=MAXVAL(NY)
         NZMAX=MAXVAL(NZ)
!  -- Reset NBMAX
         NBMAX=MAXVAL(SUB_BLOCK)
         NSUBCM=MAXVAL(NCT)
         MBODY=NBODY                   !! MBODY is to be removed

         ALLOCATE(XCELL(NXMAX,NBMAX,NBODY),YCELL(NYMAX,NBMAX,NBODY),          &
                  ZCELL(NZMAX,NBMAX,NBODY),BLXI(NBMAX),BLYI(NBMAX),           &
                  BLZI(NBMAX),XCELLI(NXMAX,NBMAX),YCELLI(NYMAX,NBMAX),        &
                  ZCELLI(NZMAX,NBMAX),XCELLJ(NXMAX,NBMAX),                    &
                  YCELLJ(NYMAX,NBMAX),ZCELLJ(NZMAX,NBMAX),X1(NXMAX),          &
                  Y1(NYMAX),Z1(NZMAX),NXI(NBMAX),NYI(NBMAX),NZI(NBMAX),       &
                  NXJ(NBMAX),NYJ(NBMAX),NZJ(NBMAX),NCELLI(NBMAX),             &
                  NCELLJ(NBMAX),NET(NBODY),KCELL(NBODY),CLMN(NBODY),          &
                  KEYSF(NBMAX,NBODY))
!
      ENDIF
!
      NFRQM=NFRQ                    ! nfrqm to be removed!
      ALLOCATE (ZBND(0:MLAYER),CDH(0:MLAYER),CDV(0:MLAYER),KKH(0:MLAYER))
!
! ---- Note that after the routine INIT_COMPUTATION is executed,
!    arrays BLX,  BLY,  and BLZ contains the dimensions
!    of the cells instead of the blocks.
!
      CALL INIT_COMPUTATION(DMIN,MBODY,NBMAX,NXMAX,NYMAX,NZMAX,MLAYER,ZBND,  &
                            LRYTH,HVK,CS_TYPE,KSYMM,RAD,RAD2,NCRD,TX_CRDX,   &
                            TX_CRDY,TX_CRDZ,PLANAR,MD_ANGLE,RX_ANGLE,TR_OFF_X,&
                            TR_OFF_Y,TR_OFF_Z,N_PROFL,START_X,START_Y,       &
                            START_Z,PROFL_DIP,PROFL_PHI,N_STATN,STATN_DIST,  &
                            NTX_FD,N_RX,RX_X,RX_Y,RX_Z,ZMT,M_RX,MT_PROFL,    &
                            MT_STATN,XRMT,YRMT,NBODY,SUB_BLOCK,NX,NY,NZ,     &
                            BLX,BLY,BLZ,XBL,YBL,ZBL,X1,Y1,Z1,DO_3D,          &
                            NCT,NET,NCELL,NCTT,NEQ,XCELL,YCELL,ZCELL,KCELL,  &
                            KBOUND,KSFT,KEYSF,KGHP,BLMIN)
!
! ---- Determine the reference length for numerical integration
!    of the Green's functions as required by the accuracy levels
!    determined by the parameter KACC.

      IF (DO_3D==1) CALL INIT_REF_CELL_DIM(NW,MBODY,NBMAX,NBODY,SUB_BLOCK,   &
                                           BLX,BLY,BLZ,DMIN,KCLMN,CLMN)
!
! ---- Determine if the spatial symmetry reduction can be used
!
!   Spatial symmetry reduction cannot be used if the structure
!   lies across a layer boundary in anisotropic earth
!
!-- Only if 3D is computed
!
      IF (DO_3D==1) THEN
!---------------------------------------------
!|                                           |
         IF (KANIS/=0.AND.KBOUND==1) THEN
            KSMR=0
!
!-- Spatial symmetry cannot be used if the body straddles anisotropic
!   layers
!
         ELSEIF (KANIS==1.AND.KBOUND==1) THEN
            KSMR=0
            WRITE (*,1020)
            WRITE (NW,1020)
         ELSE
            CALL INIT_SUPER_BLOCK(NW,MBODY,NBMAX,NSMR,KSYMM,DMIN,NXMAX,      &
                                  NYMAX,NZMAX,NBODY,SUB_BLOCK,BLX,BLY,BLZ,   &
                                  NX,NY,NZ,XBL,YBL,ZBL,XCELL,YCELL,ZCELL,    &
                                  SBX,SBY,SBZ,XSB,YSB,ZSB,SCX,SCY,SCZ,NXS,   &
                                  NYS,NZS,KSMR)
         ENDIF
!
! --- For approximate solutions it is suggested to use spatial
!   symmetry reduction.  Issue warnings if not so.
!
         IF (KACC==1.AND.KSMR==0) THEN
            WRITE (*,1030)
            WRITE (NW,1030)
         ENDIF
!|                                           |
!---------------------------------------------
      ENDIF
!
      CALL INIT_ZLVLSCS(NW,MZGRID,CS_TYPE,NTX_FD,M_RX,N_RX,NCRD,      &
                        TX_CRDZ,RX_Z,ZMT,DMIN,NSRCS,ZSRCS,NOBCS,ZOBCS)
      IF (DO_3D==1)                                                       &
      CALL INIT_ZLVLS(NW,MBODY,NBMAX,NZMAX,KSMR,NBODY,SUB_BLOCK,          &
                      NZS,NZ,SBZ,SCZ,ZSB,ZCELL,BLZ,                       &
                      MZGRID,DMIN,NZSR,ZSRG,NZOB,ZOBG)
!
      CALL INIT_SCALING(MBODY,NBMAX,NXMAX,NYMAX,NZMAX,CS_TYPE,                &
                        KSYMM,KTEM,DO_3D,NFRQM,NFRQ,FRQM,NBODY,SUB_BLOCK,     &
                        NX,NY,NZ,XCELL,YCELL,ZCELL,BLX,BLY,BLZ,XBL,YBL,ZBL,   &
                        SBX,SBY,SBZ,SCX,SCY,SCZ,XSB,YSB,ZSB,NZOB,ZOBG,NZSR,   &
                        ZSRG,NSRCS,ZSRCS,NOBCS,ZOBCS,NTX_FD,RAD,NCRD,N_SIDE,  &
                        TX_CRDX,TX_CRDY,TX_CRDZ,TR_OFF_X,TR_OFF_Y,TR_OFF_Z,   &
                        N_PROFL,START_X,START_Y,START_Z,N_STATN,STATN_DIST,   &
                        N_RX,RX_X,RX_Y,RX_Z,BLMIN,ZMT,M_RX,MT_PROFL,MT_STATN, &
                        XRMT,YRMT,MLAYER,ZBND,LRYTH,RHOMIN,RMAX1,RMIN1,RMAX2, &
                        RMIN2,CLMN,SCALE)
!
! --- Test input data after all initializations are done
!
      CALL INIT_INPUT_TEST(NW,INCL_DIELEC,DO_3D,KACC,KAUTO,CS_TYPE,KTEM,NFRQ, &
                           FRQM,NTX_FD,M_RX,NCRD,TX_CRDX,                     &
                           TX_CRDY,TX_CRDZ,KSYMM,DMIN,NSUBCM,NSBM,MBODY,NBMAX,&
                           NXMAX,NYMAX,NZMAX,TRGT_BLCK,NBODY,SUB_BLOCK,BLCK_LX,&
                           BLCK_LY,BLCK_LZ,BLCK_CX,BLCK_CY,BLCK_CZ,NCT,NX,    &
                           NY,NZ,BLX,BLY,BLZ,XBL,YBL,ZBL,MLAYER,ZBND,ZCELL)
!
! ---- Allocate arrays for field components
!
      IF (CS_TYPE==1) THEN
!  --  Allocate MT arrays
         ALLOCATE(EXMT(MT_PROFL,MT_STATN,2),EYMT(MT_PROFL,MT_STATN,2),     &
                  EZMT(MT_PROFL,MT_STATN,2),HXMT(MT_PROFL,MT_STATN,2),     &
                  HYMT(MT_PROFL,MT_STATN,2),HZMT(MT_PROFL,MT_STATN,2))
      ELSE
         ALLOCATE(ENX(M_RX,NTX_FD),ENY(M_RX,NTX_FD),ENZ(M_RX,NTX_FD),      &
                  HNX(M_RX,NTX_FD),HNY(M_RX,NTX_FD),HNZ(M_RX,NTX_FD),      &
                  ESX(M_RX,NTX_FD),ESY(M_RX,NTX_FD),ESZ(M_RX,NTX_FD),      &
                  HSX(M_RX,NTX_FD),HSY(M_RX,NTX_FD),HSZ(M_RX,NTX_FD))
         ALLOCATE(EAX(M_RX),EAY(M_RX),EAZ(M_RX),HAX(M_RX),HAY(M_RX),HAZ(M_RX))
      ENDIF
      ALLOCATE(TCDB(NSUBCM,NBMAX,MBODY),CDB(NSUBCM,NBMAX))
!
!***********  Allocate and deallocate arrays GA, GRHF, GSB1 and GSB2 !!!!!!!
!
      RHOMAX=MAX(RMAX1,RMAX2) ! NHFILM=301;RHOMIN=0.1; RHOMAX=100000.; NHFILM=91
!
! --- Determine the number grid nodes in the rho-direction for the Hankel tables.
!     Note those values must strictly be determined by the sampling density
!     values of the filters used in routines HFILL and HFILH.
!
      IF (INCL_DIELEC==1) THEN
         NHFILM=INT(ALOG(RHOMAX)/(ALOG(10.)/50.))+100+5
      ELSE
         NHFILM=INT(ALOG(RHOMAX)/(ALOG(10.)/15.))+15+5
      ENDIF
!  -- ZBG is a working array that breaks the downhole current bipoles
!     into sections if the two electrodes straddle layers.  This is
!     necessary for the analytic integration of the Hankel kernels in
!     the vertical direction.
      NZBG=NSRCS+MLAYER
      ALLOCATE(ZBG(2,NZBG))
      ALLOCATE(RRG(NHFILM))
      ALLOCATE(RRG3(NHFILM))
      ALLOCATE(GRHF3(11,NHFILM,NZSR),GRHO03(4,NZSR))
!
! **** de- re- allocate!!
!
      ALLOCATE(GRHF(11,NHFILM,max(NZSR,nsrcs),max(NZOB,nobcs)),        &
               GRHO0(4,       max(NZSR,nsrcs),max(NZOB,nobcs)))
!
      IF (DO_3D==1) THEN
!
         NMAX=3*NSUBCM
         ALLOCATE(GA(NMAX,NMAX),EN(NMAX),EMT(NMAX),ENT(NMAX,NBODY),          &
                  JST(NMAX,NBODY),EJGS(4*NMAX*NBODY),EJGS2(4*NMAX*NBODY),    &
                  VV(NMAX),GAI(NMAX),IND(NMAX))
!  --- Take the maximal value of nsmr (=9*NXS*NYS*NZS*(NZS+1)/2) and
!      the size of the array for the Hankel tables
!         NSMR=MAX(11*NHFILM*NZSR*NZOB,NSMR)
! *** NSMR does not have to be linked to the array GRHF
         ALLOCATE(GSB1(NSMR/3,3),GSB2(NSMR/3,3))
!
      ENDIF
!
! ---- Open files to store the scattering matrices
!
!--- Files Green0 through 8 store the scattering matrices.
!
!    For MT problems, GREEN1 and GREEN3 stores the diagonal
!    submatrices for the two polarizations, while GREEN2 and
!    GREEN4 store the interaction submatrices for the two
!    polarization.  Green5 and GREEN6 are used as a working
!    file.
!
!    For CSAMT problems unit 31 through 38 store the block
!    matrices  computed by group theoretical diagonalization.
!    The original scattering matrix is block diagonalized into
!    four block matrices piece by piece.   Those four block
!    matrices are then further partitioned into submatrices
!    for the use of system iteration.   Units 32 through 35
!    store the diagonal submatrices of the four block matrices
!    obtained by group reduction. Units 31 through 34 store
!    the factored results.  Unit 35 through 38 store the
!    interaction submatrices, or the off-diagonal submatrices.
!    Note that unit 35 first store the diagonal submatrices
!    temporarily.  After factorization it's contents are move
!    to unit 34, and contents in units 34, 33,  and 32 are
!    move to units 33, 32, and 31.
!
!    Units 41 through 44 stores the four sets of transformed
!    incident fields used by the group reduction.  They
!    correspond to the incident fields for the four block
!    matrices
!    Units 45 through 48 stores the four sets of transformed
!    scattering currents
!
      IF (KSYMM==1.OR.NBODY>1) THEN
         OPEN (31,FILE='GREEN1',FORM='UNFORMATTED',STATUS='UNKNOWN')
         OPEN (32,FILE='GREEN2',FORM='UNFORMATTED',STATUS='UNKNOWN')
      ENDIF
      IF (KSYMM==1) THEN
         OPEN (33,FILE='GREEN3',FORM='UNFORMATTED',STATUS='UNKNOWN')
         OPEN (34,FILE='GREEN4',FORM='UNFORMATTED',STATUS='UNKNOWN')
         OPEN (35,FILE='GREEN5',FORM='UNFORMATTED',STATUS='UNKNOWN')
         OPEN (36,FILE='GREEN6',FORM='UNFORMATTED',STATUS='UNKNOWN')
      ENDIF
      IF (KSYMM==1.AND.CS_TYPE/=1) THEN
         OPEN (37,FILE='GREEN7',FORM='UNFORMATTED',STATUS='UNKNOWN')
         OPEN (38,FILE='GREEN8',FORM='UNFORMATTED',STATUS='UNKNOWN')
         OPEN (41,FILE='UEI1',FORM='UNFORMATTED',STATUS='UNKNOWN')
         OPEN (42,FILE='UEI2',FORM='UNFORMATTED',STATUS='UNKNOWN')
         OPEN (43,FILE='UEI3',FORM='UNFORMATTED',STATUS='UNKNOWN')
         OPEN (44,FILE='UEI4',FORM='UNFORMATTED',STATUS='UNKNOWN')
         OPEN (45,FILE='UJS1',FORM='UNFORMATTED',STATUS='UNKNOWN')
         OPEN (46,FILE='UJS2',FORM='UNFORMATTED',STATUS='UNKNOWN')
         OPEN (47,FILE='UJS3',FORM='UNFORMATTED',STATUS='UNKNOWN')
         OPEN (48,FILE='UJS4',FORM='UNFORMATTED',STATUS='UNKNOWN')
      ENDIF
!
! ---- File INDEX1 through INDEX4 in units 63 through 66 store the
!    array IND used in solution of the matrix equations
!
      OPEN (63,FILE='INDEX1',FORM='UNFORMATTED',STATUS='UNKNOWN')
      OPEN (64,FILE='INDEX2',FORM='UNFORMATTED',STATUS='UNKNOWN')
      OPEN (65,FILE='INDEX3',FORM='UNFORMATTED',STATUS='UNKNOWN')
      OPEN (66,FILE='INDEX4',FORM='UNFORMATTED',STATUS='UNKNOWN')
!
! ---- Eics and Jscs store the electric fields and scattering
!    current in the structure due to different excitation sites.
!    Note that for symmetric structures 41 through 44 instead of
!    10 will be used
!
      IF (KSYMM==0.OR.NPOL==2) OPEN (10,FILE='EICS',FORM='UNFORMATTED',    &
          STATUS='UNKNOWN')
      IF (CS_TYPE/=1.OR.NPOL==2) OPEN (20,FILE='JSCS',FORM='UNFORMATTED',  &
          STATUS='UNKNOWN')
!
!-- Units 11 and 12 store the values of the normal and scattered
!   electric and magnetic fields at each frequency used both in
!   the Fourier transforms for time domain solutions and in printing
!   the frequency domain results for plotting purpose.
!
!   Unit 13 (tmp13) stores the apparent resistivities of CSAMT computation
!
      IF (FREQ_TYM==1) THEN
         OPEN (11,FILE='tmp11',FORM='UNFORMATTED',STATUS='UNKNOWN')
         OPEN (12,FILE='tmp12',FORM='UNFORMATTED',STATUS='UNKNOWN')
         IF (CS_TYPE==3)   &
         OPEN (13,FILE='tmp13',FORM='UNFORMATTED',STATUS='UNKNOWN')
      ENDIF
!
! ------ Begin the frequency loop -------------------------------------
!
! Compute frequency domain solutions.
!
      Frequency_loop: DO IFRQ=1,NFRQ
!
         FRQ=FRQM(IFRQ)
!
         IF (NFRQ>1.AND.IFRQ==1) WRITE (*,*) ' '
         IF (FREQ_TYM==0.AND.DO3D.OR.FREQ_TYM==1.AND.NFRQ>1)            &
             WRITE (*,1050) FRQ*SCALE**2,100.*(IFRQ-1.)/NFRQ
!
!---- Compute the complex conductivities of the earths and the cells.
!
         CALL INIT_CMPLX_CD(NW,FRQ,COLE_COLE,DO_3D,MLAYER,KANIS,HVK,         &
                            RES_EARTH,CHRG_EARTH,TAU_EARTH,FRQC_EARTH,       &
                            DIELC_EARTH,DCHRG_EARTH,DTAU_EARTH,DFRQC_EARTH,  &
                            CDH,CDV,KKH,MBODY,NBMAX,NBODY,SUB_BLOCK,         &
                            NCELL,NSUBCM,CDB,RBC,CHRBC,                      &
                            TAUBC,CFRBC,DEBC,DCHRBC,DTAUBC,DCFRBC)
!
!-- No outcrops in forming the scattering matrix
!
         KUTCRP=0
!
! ----  NPOL controls the polarizations of the incident waves
!     for MT problems
!
!     For controlled sources, npol must be 0
!
         IF (CS_TYPE/=1) NPOL=0
!
         IF (NPOL==0.OR.NPOL==1) THEN
            LP1=1+NPOL
            LP2=1+NPOL
         ELSEIF (NPOL==2) THEN
            LP1=1
            LP2=2
         ELSE
            WRITE (NW,*) ' NPOL can only be 0, 1 or 2.  Please check'  &
                         ,' the input.  Program aborted.'
            WRITE (*,*) ' NPOL can only be 0, 1 or 2.  Please check',  &
                        ' the input.  Program aborted.'
            STOP
         ENDIF
!
! ---- calculate the incident fields at cell centres
!
         IF (DO_3D==1)                                                       &
            CALL MAIN_PRM_AT_CELL(NW,FRQ,MLAYER,ZBND,LRYTH,HVK,KKH,CDH,      &
                                  KANIS,INCL_DIELEC,CS_TYPE,KSYMM,MBODY,     &
                                  NBMAX,NSUBCM,NMAX,NXMAX,NYMAX,NZMAX,       &
                                  NTX_FD,MD_ANGLE,NCRD,N_SIDE,TX_CRDX,       &
                                  TX_CRDY,TX_CRDZ,RAD,TX_CRDXI,TX_CRDYI,     &
                                  TX_CRDZI,NPOL,LP1,LP2,NBODY,SUB_BLOCK,     &
                                  NET,NEQ,NX,NY,NZ,NCELL,XCELL,YCELL,        &
                                  ZCELL,NXI,NYI,NZI,NCELLI,XCELLI,YCELLI,    &
                                  ZCELLI,CDB,EN,EMT,ENT,EJGS,EJGS2,RHOMIN,   &
                                  RMAX1,NZOB,ZOBG,NSRCS,ZSRCS,NZBG,ZBG,      &
                                  KACC,AJ(IFRQ),DMIN,NHFILM,ALMAX,BLMIN,     &
                                  GRHF,RRG,GRHO0)
!
         IF (KSMR==1) THEN
!
! ---- Compute the non-indentical elements of the scattering matrix
!    for use by spatial symmetry reductions.
!
!    Only the value of the clmn of one substructure is valid.
!
            CLMN2=CLMN(1)
!
            CALL MAIN_SUPER_GRID(GSB1,INCL_DIELEC,CLMN2,KANIS,SBX,SBY,SBZ,   &
                                 NXS,NYS,NZS,XSB,YSB,ZSB,NSMR,FRQ,MLAYER,    &
                                 ZBND,LRYTH,KKH,CDH,HVK,NZOB,ZOBG,NZSR,ZSRG, &
                                 DMIN,NHFILM,RHOMIN,RMAX2,RRG,RRG3,GRHF,     &
                                 GRHF3,GRHO0,GRHO03,ALMAX,KSFT,KCLMN,BLMIN,  &
                                 KACC,KUTCRP)
!
! -- Move the results from the array gsb1 to the array gsb2
!    since the array ga will be used later
!
            DO J=1,3
               DO I=1,3*NXS*NYS*NZS*(NZS+1)/2
                  GSB2(I,J)=GSB1(I,J)
               ENDDO
            ENDDO
!
         ENDIF
!
! --- Form the scattering matrices
!
         IF (DO_3D==1)                                                      &
            CALL MAIN_MATRICES(NW,INCL_DIELEC,NPOL,KSMR,CLMN,KANIS,         &
                               KBOUND,KSYMM,CS_TYPE,KCOND,GA,GSB2,IND,      &
                               VV,GAI,EN,EMT,CDB,MBODY,NBMAX,NXMAX,NYMAX,   &
                               NZMAX,NSUBCM,NBODY,SUB_BLOCK,NET,NX,NY,NZ,   &
                               NCELL,BLX,BLY,BLZ,XCELL,YCELL,ZCELL,KCELL,   &
                               NEQ,NMAX,NXI,NYI,NZI,NCELLI,BLXI,BLYI,       &
                               BLZI,XCELLI,YCELLI,ZCELLI,NXJ,NYJ,NZJ,       &
                               NCELLJ,XCELLJ,YCELLJ,ZCELLJ,SBX,SBY,SBZ,     &
                               NXS,NYS,NZS,ZSB,NSMR,FRQ,MLAYER,ZBND,        &
                               LRYTH,KKH,CDH,CDV,HVK,NZOB,ZOBG,NZSR,ZSRG,   &
                               DMIN,NHFILM,RHOMIN,RMAX2,RRG,RRG3,GRHF,      &
                               GRHF3,GRHO0,GRHO03,ALMAX,KSFT,KCLMN,BLMIN,   &
                               KACC,KUTCRP)
!
! --- Solving the matrix equations for the scattering currents
!   in the 3D structure using the system iteration method
!
         IF (DO_3D==1)                                                      &
            CALL MAIN_SOLVER(NW,GA,IND,EMT,EN,ENT,NET,JST,EJGS,EJGS2,       &
                             KACC,KSMR,KSYMM,CS_TYPE,KANIS,KBOUND,NTX_FD,   &
                             LP1,LP2,NPOL,MBODY,NBMAX,NXMAX,NYMAX,          &
                             NZMAX,NMAX,NBODY,SUB_BLOCK,NX,NY,NZ,NCELL,     &
                             NCT,KCELL,XCELL,YCELL,ZCELL,BLX,BLY,BLZ,       &
                             NXI,NYI,NZI,NCELLI,XCELLI,YCELLI,ZCELLI,       &
                             BLXI,BLYI,BLZI,NXJ,NYJ,NZJ,NCELLJ,XCELLJ,      &
                             YCELLJ,ZCELLJ,SBX,SBY,SBZ,NXS,NYS,NZS,ZSB,     &
                             NSMR,GSB2,NEQ)
!
! --- Calculate EM fields at receiver sites
!
         IF (FREQ_TYM==1)                                                    &
            CALL MAIN_PRM_AT_RCV(NW,INCL_DIELEC,CS_TYPE,KACC,SCALE,MLAYER,   &
                                 ZBND,CDH,ZMT,FRQ,NTX_FD,MD_ANGLE,NCRD,M_RX, &
                                 N_RX,RX_X,RX_Y,RX_Z,N_SIDE,TX_CRDX,TX_CRDY, &
                                 TX_CRDZ,RAD,TX_CRDXI,TX_CRDYI,TX_CRDZI,ENX, &
                                 ENY,ENZ,HNX,HNY,HNZ,NHFILM,LRYTH,HVK,KKH,   &
                                 KANIS,BLMIN,DMIN,RHOMIN,RMAX1,NOBCS,ZOBCS,  &
                                 NSRCS,ZSRCS,NZBG,ZBG,ALMAX,GRHF,RRG,GRHO0,  &
                                 E0X,E0Y,H0X,H0Y,AJ(IFRQ))
!
! --- Compute scattered E and H fields at receiver sites.  Note
!   that MAIN_PRM_AT_RCV must be called before EHSRCV because of the
!   handling of receivers on or in the 3D target.
!
!-- Note that the two subroutines MAIN_SCAT_EH_MT and MAIN_SCAT_EH_CS may be
!   combined into one,  but they are separated because of the
!   different definitions of the arrays ESX etc. verse EXMT
!   etc.
!
         IF (DO_3D==1) THEN
            IF (CS_TYPE==1)                                                  &
               CALL MAIN_SCAT_EH_MT(INCL_DIELEC,KACC,KSYMM,MBODY,NBMAX,      &
                                    NSUBCM,NBODY,SUB_BLOCK,NCELL,TCDB,       &
                                    JST,NMAX,NHFILM,FRQ,MLAYER,ZBND,         &
                                    LRYTH,HVK,KKH,KANIS,BLMIN,DMIN,          &
                                    RHOMIN,RMAX1,NOBCS,ZOBCS,NZSR,ZSRG,      &
                                    ALMAX,RRG,RRG3,GRHF,GRHF3,GRHO0,         &
                                    GRHO03,MT_PROFL,MT_STATN,XRMT,YRMT,      &
                                    NXMAX,NYMAX,NZMAX,NX,NY,NZ,XCELL,        &
                                    YCELL,ZCELL,BLX,BLY,BLZ,CDH,NPOL,E0X,    &
                                    E0Y,ZMT,KSFT,CLMN,EXMT,EYMT,HXMT,        &
                                    HYMT,HZMT)
            IF (CS_TYPE/=1)                                                  &
               CALL MAIN_SCAT_EH_CS(INCL_DIELEC,KACC,KSYMM,MBODY,            &
                                    NBMAX,NSUBCM,NBODY,SUB_BLOCK,NCELL,      &
                                    NET,TCDB,EMT,JST,EJGS,NMAX,NTX_FD,N_RX,  &
                                    NHFILM,FRQ,MLAYER,ZBND,LRYTH,HVK,KKH,    &
                                    KANIS,BLMIN,DMIN,RHOMIN,RMAX1,NOBCS,     &
                                    ZOBCS,NZSR,ZSRG,ALMAX,RRG,RRG3,GRHF,     &
                                    GRHF3,GRHO0,GRHO03,RX_X,RX_Y,RX_Z,       &
                                    NXMAX,NYMAX,NZMAX,NEQ,NX,NY,NZ,XCELL,    &
                                    YCELL,ZCELL,BLX,BLY,BLZ,CDH,CDV,KSFT,    &
                                    CLMN,M_RX,ENX,ENY,ENZ,EAX,EAY,EAZ,       &
                                    HAX,HAY,HAZ,ESX,ESY,ESZ,HSX,HSY,HSZ)
!
! ---- Print out results -----
!
            IF (CS_TYPE.EQ.1) THEN
               CALL PRINT_MT(NW,MT_PROFL,MT_STATN,XRMT,YRMT,SCALE,E0X,E0Y,   &
                             H0X,H0Y,FRQ,NPOL,ZMT,EXMT,EYMT,EZMT,HXMT,HYMT,  &
                             HZMT)
            ELSE
               IF (FREQ_TYM.EQ.1.AND.OUT_REF.EQ.1)                           &
                  CALL PRINT_CS(NWR,CS_TYPE,M_RX,NTX_FD,NCRD,TX_CRDX,        &
                                TX_CRDY,TX_CRDZ,RAD,TR_OFF_X,TR_OFF_Y,       &
                                TR_OFF_Z,MD_ANGLE,N_RX,RX_X,RX_Y,RX_Z,       &
                                SURFACE_RL,FRQ,SCALE,ENX,ENY,ENZ,HNX,        &
                                HNY,HNZ,ESX,ESY,ESZ,HSX,HSY,HSZ)
            ENDIF
!
! --- Print out internal scattering currents in each block if kjst=1
!
            IF (KJST.EQ.1)                                                   &
               CALL PRINT_JS(NWR,CS_TYPE,SCALE,NTX_FD,NPOL,LP1,LP2,KSYMM,NEQ,&
                             NMAX,MBODY,NBMAX,NBODY,SUB_BLOCK,EMT,JST,EJGS,  &
                             NCT,NET,NCELL,NX,NY,NZ,BLX,BLY,BLZ,XBL,YBL,ZBL, &
                             E0X,E0Y)
!
         ENDIF
!
!********** Start a new frequency loop ***********
!
         IF (NFRQ/=1.OR.KTEM/=0) THEN
!
            IF (KSYMM==1.OR.NBODY>1) THEN
               REWIND (31)
               REWIND (32)
            ENDIF
            IF (KSYMM==1) THEN
               REWIND (33)
               REWIND (34)
               REWIND (35)
               REWIND (36)
            ENDIF
            IF (KSYMM==1.AND.CS_TYPE/=1) THEN
               REWIND (37)
               REWIND (38)
               REWIND (41)
               REWIND (42)
               REWIND (43)
               REWIND (44)
               REWIND (45)
               REWIND (46)
               REWIND (47)
               REWIND (48)
            ENDIF
            IF (KSYMM==0.OR.NPOL==2) REWIND (10)
            IF (CS_TYPE/=1.OR.NPOL==2) REWIND (20)
            DO I=1,6
               REWIND (60+I)
            ENDDO
         ENDIF
!
! --- Write the normal and scattered fields on the disk
!     for time domain computations
!
         IF (FREQ_TYM==1.AND.CS_TYPE/=1) THEN
!
!--- Set scattered fields to be zero for 1D computation only
!
            IF (DO_3D==0) THEN
               ESX=(0.,.0)
               ESY=(0.,.0)
               ESZ=(0.,.0)
               HSX=(0.,.0)
               HSY=(0.,.0)
               HSZ=(0.,.0)
            ENDIF
!
            SCALE2=SCALE**2
!
! --- Results are designed to be saved in the order of
!
!            WRITE (11) ((ENX(I,J)*SCALE2,I=1,N_RX(J)),J=1,NTX_FD)
!            WRITE (11) ((ENY(I,J)*SCALE2,I=1,N_RX(J)),J=1,NTX_FD)
!            WRITE (11) ((ENZ(I,J)*SCALE2,I=1,N_RX(J)),J=1,NTX_FD)
!            WRITE (11) ((HNX(I,J)*SCALE,I=1,N_RX(J)),J=1,NTX_FD)
!            WRITE (11) ((HNY(I,J)*SCALE,I=1,N_RX(J)),J=1,NTX_FD)
!            WRITE (11) ((HNZ(I,J)*SCALE,I=1,N_RX(J)),J=1,NTX_FD)
!            WRITE (12) ((ESX(I,J)*SCALE2,I=1,N_RX(J)),J=1,NTX_FD)
!            WRITE (12) ((ESY(I,J)*SCALE2,I=1,N_RX(J)),J=1,NTX_FD)
!            WRITE (12) ((ESZ(I,J)*SCALE2,I=1,N_RX(J)),J=1,NTX_FD)
!            WRITE (12) ((HSX(I,J)*SCALE,I=1,N_RX(J)),J=1,NTX_FD)
!            WRITE (12) ((HSY(I,J)*SCALE,I=1,N_RX(J)),J=1,NTX_FD)
!            WRITE (12) ((HSZ(I,J)*SCALE,I=1,N_RX(J)),J=1,NTX_FD)
!
!     However, due to the tranform of the coordinate systems,  the
!     output files for the x and y components are swaped,  and the
!     signes of the z components are reversed.
!
            WRITE (11) (( ENY(I,J)*SCALE2,I=1,N_RX(J)),J=1,NTX_FD)
            WRITE (11) (( ENX(I,J)*SCALE2,I=1,N_RX(J)),J=1,NTX_FD)
            WRITE (11) ((-ENZ(I,J)*SCALE2,I=1,N_RX(J)),J=1,NTX_FD)
            WRITE (11) (( HNY(I,J)*SCALE,I=1,N_RX(J)),J=1,NTX_FD)
            WRITE (11) (( HNX(I,J)*SCALE,I=1,N_RX(J)),J=1,NTX_FD)
            WRITE (11) ((-HNZ(I,J)*SCALE,I=1,N_RX(J)),J=1,NTX_FD)
            WRITE (12) (( ESY(I,J)*SCALE2,I=1,N_RX(J)),J=1,NTX_FD)
            WRITE (12) (( ESX(I,J)*SCALE2,I=1,N_RX(J)),J=1,NTX_FD)
            WRITE (12) ((-ESZ(I,J)*SCALE2,I=1,N_RX(J)),J=1,NTX_FD)
            WRITE (12) (( HSY(I,J)*SCALE,I=1,N_RX(J)),J=1,NTX_FD)
            WRITE (12) (( HSX(I,J)*SCALE,I=1,N_RX(J)),J=1,NTX_FD)
            WRITE (12) ((-HSZ(I,J)*SCALE,I=1,N_RX(J)),J=1,NTX_FD)
!
!  --  Write apparent resistivities for CSAMT applicaitons to unit 13
!
            IF (CS_TYPE==3) THEN
            DO IEXCI=1,NTX_FD
            DO I=1,N_RX(IEXCI)
!
! --- To prevent overflow in computing EH1**2 and EH2**2,
!     use 1.E-25 instead of 1.E-30.
!
               WMU=78.9568352E-7*FRQ
               EH2=(ESX(I,IEXCI)+ENX(I,IEXCI))/(HSY(I,IEXCI)+HNY(I,IEXCI)+   &
                    CMPLX(SIGN(1.E-25,REAL(HSY(I,IEXCI)+HNY(I,IEXCI))),0.))
               EH1=(ESY(I,IEXCI)+ENY(I,IEXCI))/(HSX(I,IEXCI)+HNX(I,IEXCI)+   &
                    CMPLX(SIGN(1.E-25,REAL(HSX(I,IEXCI)+HNX(I,IEXCI))),0.))
!               EH1=(ESX(I,IEXCI)+ENX(I,IEXCI))/(HSY(I,IEXCI)+HNY(I,IEXCI)+  &
!                    SIGN(1.E-25,REAL(HSY(I,IEXCI)+HNY(I,IEXCI))))
!               EH2=(ESY(I,IEXCI)+ENY(I,IEXCI))/(HSX(I,IEXCI)+HNX(I,IEXCI)+  &
!                    SIGN(1.E-25,REAL(HSX(I,IEXCI)+HNX(I,IEXCI))))
!
               WRITE (13) CABS(EH1)**2/WMU,CABS(EH2)**2/WMU,        &
                           ATAN2(AIMAG(EH1),REAL(EH1)               &
                           +SIGN(1.E-30,REAL(EH1)))*180./3.1416,    &
                           ATAN2(AIMAG(EH2),REAL(EH2)               &
                           +SIGN(1.E-30,REAL(EH2)))*180./3.1416
!
            ENDDO
            ENDDO
            ENDIF
!
         ENDIF
!
         IF (FREQ_TYM==0.AND.DO3D) THEN
!
! ---- Assign array HFD with the imaginary parts of the scattered
!    magnetic fields.
!
!    Leroi and Marco have different coordinate systems.  The x and
!    y components are switched in the following.  Note the sign
!    reversals
!
!    The sequence of the do loops is kept identical to that
!    of Leroi.
!
            DO J=1,NTX
               DO I=1,NRX(J)
                  IF (DOWNHOLE==0)THEN
                     HFD(IFRQ,1,I,J)=-AIMAG(HSY(I,J))
                     HFD(IFRQ,2,I,J)=-AIMAG(HSX(I,J))
                     HFD(IFRQ,3,I,J)=AIMAG(HSZ(I,J))
                  ELSE
!
!  --- Rotate the components in the output coordinate system to the
!      internal coordinate system.  Note that the rotation must agree
!      with the primary field components in routine ROI_TDPULS.
!      Consistence of coordinate sytems has to be tested out.
!
                     HTMPX=-AIMAG(HSY(I,J))
                     HTMPY=-AIMAG(HSX(I,J))
                     HTMPZ=AIMAG(HSZ(I,J))
                     DIP=RDIP(I,J)/180.*3.14159265359
                     AZIM=RPHI(I,J)/180.*3.14159265359
                     AA1= COS(AZIM)*HTMPX+SIN(AZIM)*HTMPY
                     AA2=-SIN(AZIM)*HTMPX+COS(AZIM)*HTMPY
                     HFD(IFRQ,3,I,J)= COS(DIP)*HTMPZ+SIN(DIP)*AA1
                     HFD(IFRQ,1,I,J)=-SIN(DIP)*HTMPZ+COS(DIP)*AA1
                     HFD(IFRQ,2,I,J)=AA2
                  ENDIF
               ENDDO
            ENDDO
!
         ENDIF
!
      ENDDO Frequency_loop
!
! --- Close units 10, 20,  41 through 48 and units 61 through 66
!   in order to reduce the total number of files being opened.
!   The units 31 through 38 storing the scattering matrix may
!   be too large to be closed during the excutation and thus
!   will not closed during the executaion.
!
!  !! Unit 31 through 38 must be closed since the total number
!     of files is too large for some computers like Silicon
!     Graphics workstations
!
      IF (KSYMM==0.OR.NPOL==2) CLOSE (10,STATUS='DELETE')
      IF (CS_TYPE/=1.OR.NPOL==2) CLOSE (20,STATUS='DELETE')
      DO I=1,6
         CLOSE (UNIT=60+I,STATUS='DELETE')
      ENDDO
      IF (KSYMM==1.AND.CS_TYPE/=1) THEN
         DO I=1,8
            CLOSE (UNIT=40+I,STATUS='DELETE')
         ENDDO
      ENDIF
      DO I=1,8
         CLOSE (UNIT=30+I,STATUS='DELETE')
      ENDDO
!
!******************************************************
!* This big bracket includes 4 IF blocks for FREQ_TYM=0 *
!
      IF (FREQ_TYM==0.AND.DO3D) THEN
!
!  Write out the imaginary part of the frequency-domain scattered
!  magnetic fields for each to UNIT ND.


         IF (CDNT) CALL ROI_CLRSP(MXFRQ,MXTX,NTX,MXRX,NFRQ,NRX,WTX,WRX,HFD)

         DO JF=1,NFRQ
            DO JS=1,NTX
               DO JR=1,NRX(JS)
                  IF (CDNT) THEN
                     WRITE (ND,'(E16.6)') HFD(JF,3,1,JS)
                  ELSE
                     WRITE (ND,'(3E16.6)') (HFD(JF,JC,JR,JS),JC=1,3)
                  ENDIF
               ENDDO
            ENDDO
         ENDDO

         CLOSE (ND)
         WRITE (*,'(/A/A)') ' Frequency-domain computations finished.',  &
           ' Start time-domain transformation and waveform convolution.'
!
      ENDIF
!
      IF (FREQ_TYM==0.AND.NTEM3D==2) THEN
         DO3D=.TRUE.

!  Read frequency-domain data from UNIT ND and convert to time-domain.

         CALL ROI_FDREAD(ND,MXFRQ,MXRX,MXTX,NFRQ,NRX,NTX,CDNT,HFD)
         CLOSE (ND)
      ENDIF
!
!  Construct the time-domain response.
!
      IF (FREQ_TYM==0.AND.ITYM==9) THEN
         CALL ROI_UTEM(NW,MXTX,NCHNL,BASFRQ,NFRQ,FREQ,HFD,NTX,SX,SY,NRX,    &
                       RX,RY,RZ,DO3D,NLYR,RES,THK,COLE,ICOLE,CHRG,CTAU,     &
                       CFREQ,TITLE,IPRF)
      ENDIF
!
      IF (FREQ_TYM==0.AND.ITYM/=9) THEN
!  --  Note that the parameter NSX of Leroi has been changed to NSXL
!      due to conflict with NSX of the superblock of Marco
         CALL ROI_TDPULS(NW,DO3D,IPRF,PRTSEC,IDH,CDNT,DWNHL,MXTX,ITYM,NCHNL, &
                         TMS,WTMS,OFFTYM,MDELYT,TMSPR,NSXL,BPLR,CRVSEG,TXON, &
                         TXAMP,NFRQ,FREQ,HFD,NTX,SX,SY,NRX,RX,RY,RZ,RXAREA,  &
                         NLYR,RES,THK,COLE,ICOLE,CHRG,CTAU,CFREQ,TITLE,      &
                         RDIP,RPHI,DOWNHOLE)
         WRITE (*,'(//A//)') ' MARCO HAS FINISHED!'
      ENDIF
!*                                                    *
!******************************************************
!
! ----- Print out results -----
!
!******************************************************
!* This big bracket includes 4 IF blocks for FREQ_TYM=1 *
!
      IF (FREQ_TYM==1) THEN
!
         IF (CS_TYPE/=1) THEN
!
! --- Test for downhole local receiver coordinate system.  If the dip angles
!     of the downhole is zero, use global system
!
            DOWNHOLE=0
            IF (DH_SYS==1) THEN
               DO I=1,NTX_FD
                  DO J=1,N_RX(I)
                     IF (ABS(RX_ANGLE(1,J,I))>.001) DOWNHOLE=1
                  ENDDO
               ENDDO
            ENDIF
!
!  -- For moving systems,  DOWNHOLE=1 if 0 < dip < 90
!
            IF (CS_TYPE==7.OR.CS_TYPE==8) THEN
               DO I=1,NTX_FD
                  DO J=1,N_RX(I)
                     IF (ABS(RX_ANGLE(1,J,I))>.001.AND.     &
                         ABS(ABS(RX_ANGLE(1,J,I))-90.)>.001) DOWNHOLE=1
                  ENDDO
               ENDDO
            ENDIF
!
! --- Rewind files storing the field components
!
            REWIND (11)
            REWIND (12)
!
            IF (DO_3D==1) DEALLOCATE(GA,ENT,JST,EJGS,EJGS2,GSB1,GSB2)
            DEALLOCATE(ENX,ENY,ENZ,HNX,HNY,HNZ,ESX,ESY,ESZ,HSX,HSY,HSZ)
            ALLOCATE(ENX(NFRQ,M_RX),ENY(NFRQ,M_RX),ENZ(NFRQ,M_RX),          &
                     HNX(NFRQ,M_RX),HNY(NFRQ,M_RX),HNZ(NFRQ,M_RX),          &
                     ESX(NFRQ,M_RX),ESY(NFRQ,M_RX),ESZ(NFRQ,M_RX),          &
                     HSX(NFRQ,M_RX),HSY(NFRQ,M_RX),HSZ(NFRQ,M_RX))
!
! ---  Tranform the coordinate system again to the I/O system.  Note that
!      components have been transformed when they are saved.
!
            CALL INIT_CONVERT (CS_TYPE,NTX_FD,NCRD,N_SIDE,N_RX,M_RX,DO_3D,0, &
                               TRGT_BLCK,TX_CRDX,TX_CRDY,TX_CRDZ,RX_X,RX_Y,  &
                               RX_Z,TR_OFF_X,TR_OFF_Y,N_PROFL,START_X,       &
                               START_Y,START_Z,BLCK_LX,BLCK_LY,BLCK_CX,      &
                               BLCK_CY,BLCK_CZ,BLCK_NX,BLCK_NY)
!
            CALL INIT_GROUND (SURFACE_RL,NTX_FD,N_RX,M_RX,TRGT_BLCK,         &
                              TX_CRDZ,RX_Z,BLCK_CZ,DO_3D,1,-1)
!
            IF (DOWNHOLE==0)                                                 &
            CALL PRINT_CS_EH(NW,M_RX,NFRQ,NTX_FD,N_RX,CS_TYPE,FRQM,          &
                             OUTPUT_FMT,RX_X,RX_Y,RX_Z,TR_OFF_X,TR_OFF_Y,    &
                             TR_OFF_Z,N_SIDE,NCRD,TX_CRDX,TX_CRDY,TX_CRDZ,   &
                             RAD,MD_ANGLE,ENX,ENY,ENZ,HNX,HNY,HNZ,ESX,ESY,   &
                             ESZ,HSX,HSY,HSZ)
!
! --- Close units 41 through 56 and reopen 41 through 46 for downhole printing
!
!               DO I=1,6
!                  CLOSE (40+I)
!                  CLOSE (50+I)
!               ENDDO
!
            IF (DOWNHOLE==1) THEN
!               OPEN (41,FILE='OUTPUT.EC3',STATUS='REPLACE')
!               OPEN (42,FILE='OUTPUT.EC1',STATUS='REPLACE')
!               OPEN (43,FILE='OUTPUT.EC2',STATUS='REPLACE')
!               OPEN (44,FILE='OUTPUT.HC3',STATUS='REPLACE')
!               OPEN (45,FILE='OUTPUT.HC1',STATUS='REPLACE')
!               OPEN (46,FILE='OUTPUT.HC2',STATUS='REPLACE')
               CALL PRINT_CS_DH (NW,CS_TYPE,NFRQ,FRQM,NCRD,NTX_FD,M_RX,N_RX,   &
                               RX_X,RX_Y,RX_Z,N_SIDE,TX_CRDX,TX_CRDY,TX_CRDZ,  &
                               MD_ANGLE,RX_ANGLE,TR_OFF_X,TR_OFF_Y,TR_OFF_Z)
            ENDIF
!
! --- Close units 11 through 13
!
            CLOSE (11,STATUS='DELETE')
            CLOSE (12,STATUS='DELETE')
            IF (CS_TYPE==3)   &
            CLOSE (13,STATUS='DELETE')
!
         ELSE
!
! --- Print MT results in files suitable for plotting
!
            OPEN (51,FILE='RES_X',STATUS='UNKNOWN')
            OPEN (52,FILE='RES_Y',STATUS='UNKNOWN')
            OPEN (53,FILE='PHS_X',STATUS='UNKNOWN')
            OPEN (54,FILE='PHS_Y',STATUS='UNKNOWN')
            OPEN (55,FILE='FRQRES',STATUS='UNKNOWN')
            OPEN (56,FILE='FRQPHS',STATUS='UNKNOWN')
            REWIND (11)
            REWIND (12)
            CALL PRINT_MT_RES(MT_PROFL,MT_STATN,XRMT,YRMT,NFRQ,FRQM,SCALE,  &
                              TITLE,NFRQM)
            CLOSE (11,STATUS='DELETE')
            CLOSE (12,STATUS='DELETE')
!
         ENDIF
!
      ENDIF
!*                                                    *
!******************************************************
!
      STOP
!
 1020 FORMAT (/'Spatial symmetry reduction cannot be used',            &
              '  because the body stradles anisotropic layers!')
 1030 FORMAT (/,'It is suggested to use spatial symmetry reduction ',  &
              'to compute approximate solutions ',/,                   &
              'by discretizing the body into equal size cells ',       &
              'in order to achieve maximal efficiency!')
 1050 FORMAT (' Freq:',G12.4,1X,F5.1,' percent done')
!
!  END PROGRAM MARCO
!
   CONTAINS
!
      SUBROUTINE READATA
!
!**** Read data from file MARCO.DAT and print them out in file MARCO.OUT
!
!     Necessary arrays are allocated in this routine
!
      IMPLICIT NONE
!
      CHARACTER*80 INP
      REAL    :: ZTOP,TR_OFF_E,TR_OFF_N
      INTEGER :: I,II,J,SOURCE,NUMCEL,NUML
!
! -- Internal working arrays for data read only.  Those arrays are designed
!    to name the data records in terms of East and North instead of X and Y,
!    and to use explicit names for dip and azimuthal angles.
!
      INTEGER, ALLOCATABLE :: BLCK_NE(:),BLCK_NN(:)
      REAL, ALLOCATABLE :: BLCK_LE(:),BLCK_LN(:),BLCK_CE(:),BLCK_CN(:),     &
                           TX_EAST(:,:),TX_NRTH(:,:),TX_VERT(:,:),          &
                           RX_E(:,:),RX_N(:,:),START_E(:),START_N(:),       &
                           TX_DIP(:),TX_PHI(:),                             &
                           RDIP(:,:),RPHI(:,:)  ! Note this rdip and rphi are
                                                ! different from those in the
                                                ! main program which are for
                                                ! the time domain Leroi format
!
! -- Read and print input data
!
      WRITE (NW,'(T11,A/T11,A/)') 'INPUT DATA','----------'
      REWIND NR
  100 READ (NR,'(A)',END=200) INP
      WRITE (NW,'(1X,A)') INP
      GOTO 100
  200 REWIND NR
!
!  -- Skip the first two records
!
      READ (NR,'(A)') INP
      READ (NR,'(A)') INP
!
! --- Read source parameters
!
      READ (NR,*) SOURCE,OUTPUT_FMT
!
!  -- Convert SOURCE to CS_TYPE for computation
!
      IF (SOURCE==1) CS_TYPE=3
      IF (SOURCE==2) CS_TYPE=2
      IF (SOURCE==3) CS_TYPE=4
      IF (SOURCE==4) CS_TYPE=9
      IF (SOURCE==5) CS_TYPE=5
      IF (SOURCE==6) CS_TYPE=6
      IF (SOURCE==7) CS_TYPE=7
      IF (SOURCE==8) CS_TYPE=8
      IF (SOURCE==9) CS_TYPE=1
!
      DH_SYS=0
      IF (CS_TYPE/=1.AND.CS_TYPE/=6.AND.CS_TYPE/=7.AND.CS_TYPE/=8) THEN
         READ (NR,*) DH_SYS
         READ (NR,*) NTX_FD
      ENDIF
!
!  -- Set NTX_FD=1 for MT applications.  NTX_FD will be used in the excitation
!     loop in MATRIX_SOLVER
!
      IF (CS_TYPE==1) NTX_FD=1
!
      IF (CS_TYPE==5.OR.CS_TYPE==9) THEN
         NCRD=1
      ELSEIF (CS_TYPE>=1.AND.CS_TYPE<=3) THEN
         NCRD=2
      ENDIF
      IF (CS_TYPE==4) THEN
         ALLOCATE(N_SIDE(NTX_FD))
!
!   -- Instead of
!         READ (NR,*) (N_SIDE(J),J=1,NTX_FD)
!      read only one value for N_SIDE assuming N_SIDE does not vary in a survey.
!
         READ (NR,*) N_SIDE(1)
         DO J=2,NTX_FD
            N_SIDE(J)=N_SIDE(1)
         ENDDO
!
         NCRD=MAXVAL(N_SIDE)
      ENDIF
!
      IF (CS_TYPE/=6.AND.CS_TYPE/=7.AND.CS_TYPE/=8) THEN
         ALLOCATE(RAD(NTX_FD),TX_CRDX(NCRD,NTX_FD),TX_CRDY(NCRD,NTX_FD),   &
                  TX_CRDZ(NCRD,NTX_FD),TX_EAST(NCRD,NTX_FD),               &
                  TX_NRTH(NCRD,NTX_FD),TX_VERT(NCRD,NTX_FD))
      ENDIF
!
      IF (CS_TYPE==9) ALLOCATE(MD_ANGLE(2,NTX_FD),TX_DIP(NTX_FD),TX_PHI(NTX_FD))
!
      IF (CS_TYPE/=1.AND.CS_TYPE/=6.AND.CS_TYPE/=7.AND.CS_TYPE/=8) THEN
         DO J=1,NTX_FD
            IF (CS_TYPE==5) READ (NR,*) RAD(J)
            IF (CS_TYPE==9) THEN
               READ (NR,*) TX_EAST(1,J),TX_NRTH(1,J),TX_VERT(1,J),         &
                           TX_DIP(J),TX_PHI(J)
               TX_CRDX(1,J)=TX_EAST(1,J)
               TX_CRDY(1,J)=TX_NRTH(1,J)
               TX_CRDZ(1,J)=TX_VERT(1,J)
               MD_ANGLE(1,J)=TX_DIP(J)
               MD_ANGLE(2,J)=TX_PHI(J)
            ELSE IF (CS_TYPE==4) THEN
               DO I=1,N_SIDE(J)
                  READ (NR,*) TX_EAST(I,J),TX_NRTH(I,J),TX_VERT(I,J)
                  TX_CRDX(I,J)=TX_EAST(I,J)
                  TX_CRDY(I,J)=TX_NRTH(I,J)
                  TX_CRDZ(I,J)=TX_VERT(I,J)
               ENDDO
            ELSE
               DO I=1,NCRD
                  READ (NR,*) TX_EAST(I,J),TX_NRTH(I,J),TX_VERT(I,J)
                  TX_CRDX(I,J)=TX_EAST(I,J)
                  TX_CRDY(I,J)=TX_NRTH(I,J)
                  TX_CRDZ(I,J)=TX_VERT(I,J)
               ENDDO
            ENDIF
         ENDDO
      ENDIF
!
! --- Read receiver parameters
!
      IF (CS_TYPE==6.OR.CS_TYPE==7.OR.CS_TYPE==8) THEN
         IF (CS_TYPE==6) READ (NR,*) RAD2
         IF (CS_TYPE==8) READ (NR,*) PLANAR
         READ (NR,*) TR_OFF_E,TR_OFF_N,TR_OFF_Z
         TR_OFF_X=TR_OFF_E; TR_OFF_Y=TR_OFF_N
         READ (NR,*) N_PROFL
         ALLOCATE(START_X(N_PROFL),START_Y(N_PROFL),START_E(N_PROFL),        &
                  START_N(N_PROFL),START_Z(N_PROFL),PROFL_DIP(N_PROFL),      &
                  PROFL_PHI(N_PROFL),N_STATN(N_PROFL),STATN_DIST(N_PROFL))
         NTX_FD=0
         DO I=1,N_PROFL
            READ (NR,*) START_E(I),START_N(I),START_Z(I),PROFL_DIP(I),   &
                        PROFL_PHI(I),N_STATN(I),STATN_DIST(I)
            START_X(I)=START_E(I);  START_Y(I)=START_N(I)
            NTX_FD=NTX_FD+N_STATN(I)
         ENDDO
         NCRD=1
!  -- Allocate RAD, TX_CRDX etc for those cases
         ALLOCATE(RAD(NTX_FD),TX_CRDX(NCRD,NTX_FD),TX_CRDY(NCRD,NTX_FD),  &
                  TX_CRDZ(NCRD,NTX_FD))
      ENDIF
!
      IF (CS_TYPE==6.OR.CS_TYPE==7.OR.CS_TYPE==8)                          &
          ALLOCATE(MD_ANGLE(2,NTX_FD),RX_ANGLE(2,1,NTX_FD))
      ALLOCATE(N_RX(NTX_FD))
!
      IF (CS_TYPE==6.OR.CS_TYPE==7.OR.CS_TYPE==8) THEN
         N_RX=1
      ELSE
         IF (CS_TYPE/=1) THEN
!   --  Always read FIXED_RX to avoid confusion in data input
            READ (NR,*) FIXED_RX
            IF (NTX_FD==1) FIXED_RX=0
            IF (FIXED_RX==1) THEN
               READ (NR,*) N_RX(1)
               DO I=2,NTX_FD
                  N_RX(I)=N_RX(1)
               ENDDO
            ELSE
               READ (NR,*) (N_RX(I),I=1,NTX_FD)
            ENDIF
         ENDIF
      ENDIF
!
      M_RX=MAXVAL(N_RX)
      ALLOCATE(RX_X(M_RX,NTX_FD),RX_Y(M_RX,NTX_FD),RX_Z(M_RX,NTX_FD),    &
               RX_E(M_RX,NTX_FD),RX_N(M_RX,NTX_FD))
      IF (DH_SYS==1) ALLOCATE(RDIP(M_RX,NTX_FD),RPHI(M_RX,NTX_FD),       &
                              RX_ANGLE(2,M_RX,NTX_FD))
!
      IF (CS_TYPE.EQ.1) THEN
         READ (NR,*) NPOL,MT_PROFL,MT_STATN,ZMT
         ALLOCATE(XRMT(MT_PROFL),YRMT(MT_STATN))
         READ (NR,*) (XRMT(I),I=1,MT_PROFL)
         READ (NR,*) (YRMT(I),I=1,MT_STATN)
      ENDIF
      IF (CS_TYPE/=6.AND.CS_TYPE/=7.AND.CS_TYPE/=8) THEN
         IF (DH_SYS==0) THEN
            DO II=1,NTX_FD
               IF (II==1.OR.FIXED_RX==0) THEN
                  DO I=1,N_RX(II)
                     READ (NR,*) RX_E(I,II),RX_N(I,II)
                     RX_X(I,II)=RX_E(I,II); RX_Y(I,II)=RX_N(I,II); RX_Z(I,II)=0.
                  ENDDO
               ELSE IF (II>1.AND.FIXED_RX==1) THEN
                  DO I=1,N_RX(II)
                     RX_X(I,II)=RX_X(I,1)
                     RX_Y(I,II)=RX_Y(I,1)
                     RX_Z(I,II)=RX_Z(I,1)
                  ENDDO
               ENDIF
            ENDDO
         ELSE IF (DH_SYS==1) THEN
            DO II=1,NTX_FD
               IF (II==1.OR.FIXED_RX==0) THEN
                  DO I=1,N_RX(II)
                     READ (NR,*) RX_E(I,II),RX_N(I,II),RX_Z(I,II),  &
                                 RDIP(I,II),RPHI(I,II)
                     RX_X(I,II)=RX_E(I,II);  RX_Y(I,II)=RX_N(I,II)
                     RX_ANGLE(1,I,II)=RDIP(I,II); RX_ANGLE(2,I,II)=RPHI(I,II)
                  ENDDO
               ELSE IF (II>1.AND.FIXED_RX==1) THEN
                  DO I=1,N_RX(II)
                     RX_X(I,II)=RX_X(I,1)
                     RX_Y(I,II)=RX_Y(I,1)
                     RX_Z(I,II)=RX_Z(I,1)
                     RX_ANGLE(1,I,II)=RX_ANGLE(1,I,1)
                     RX_ANGLE(2,I,II)=RX_ANGLE(2,I,1)
                  ENDDO
               ENDIF
            ENDDO
         ENDIF
      ENDIF
!
! --- Read frequency parameters
!
      READ (NR,*) NFRQ
!
      ALLOCATE(FRQM(NFRQ))
!
      READ (NR,*) (FRQM(I),I=1,NFRQ)
!
!  --- Read current amplitudes or dipole moments for each frequency
!
!  -- AJ must be allocated for all source type enven though it is not used
!     for MT (AJ is used as a dummy arguement)
      ALLOCATE (AJ(NFRQ))
      IF (CS_TYPE/=1) THEN
         READ (NR,*) (AJ(I),I=1,NFRQ)
      ENDIF
!
! ----  The parameter INCL_DIELEC controls whether or not dielectric
!       permittivities of the media must be considered in the
!       computations.  This is usually the case at high frequencies.
!       If permittivities are to be inlcuded,  the program considers
!       the frequency is high (above 1 MHz,  up to about 200 MHz)
!       and displacement currents are important and chooses a set of
!       100 per decade filters to evaluate the Hankel transforms.
!       Otherwise,  all permittivities are assumed to be 1 although
!       displacement currents are still included in the computations,
!       and the program considers the frequency is low (usually below
!       1 MHz, but definitely below 10 MHz) and chooses a set of 15
!       per decade filters to compute the Hankel transofrms.  It is
!       possible to further introduce another intermediate frequency
!       range to improve efficiency.  Thus,  the parameter INCL_DIELEC
!       can be considered as a frequency range option.
!
!       INCL_DIELEC = 0, low frequency computations;  and
!                   = 1, high frequency version computations.
!
!       If INCL_DIELEC=1, dielectric parameters need to be input
!
!       Actually the parameter INCL_DIELEC can be determined by the
!       maximal frequency automatically,  but this may cause confusion
!       for the data input since dielectric parameters must be input
!       for INCL_DIELEC=1.  Thus,  instead of this automation only a
!       warning message will be issued if Maxval(FRQM)>1 MHz and
!       INCL_DIELEC=0.
!
      READ (NR,*) INCL_DIELEC
!
      READ (NR,*) COLE_COLE
!
! --- Read layer paramters
!
!      The earth is assume to be isotropic
!      READ (NR,*) MLAYER,KANIS
      KANIS=0
!
      READ (NR,*) MLAYER
!
      ALLOCATE(RES_EARTH(MLAYER),CHRG_EARTH(MLAYER),TAU_EARTH(MLAYER),      &
               FRQC_EARTH(MLAYER),DIELC_EARTH(MLAYER),DCHRG_EARTH(MLAYER),  &
               DTAU_EARTH(MLAYER),DFRQC_EARTH(MLAYER),                      &
               LRYTH(MLAYER),HVK(0:MLAYER))
!
      READ (NR,*) (RES_EARTH(I),I=1,MLAYER)
      IF (COLE_COLE==1) THEN
         READ (NR,*) (CHRG_EARTH(I),I=1,MLAYER)
         READ (NR,*) (TAU_EARTH(I),I=1,MLAYER)
         READ (NR,*) (FRQC_EARTH(I),I=1,MLAYER)
      ENDIF
      IF (INCL_DIELEC==1) READ (NR,*) (DIELC_EARTH(I),I=1,MLAYER)
      IF (INCL_DIELEC==1.AND.COLE_COLE==1) THEN
         READ (NR,*) (DCHRG_EARTH(I),I=1,MLAYER)
         READ (NR,*) (DTAU_EARTH(I),I=1,MLAYER)
         READ (NR,*) (DFRQC_EARTH(I),I=1,MLAYER)
      ENDIF
!
!  -- Set default dielectric permitivities for low frequency modeling
!
      IF (INCL_DIELEC==0) THEN
         DO I=1,MLAYER
            DIELC_EARTH(I)=1.
         ENDDO
         IF (COLE_COLE==1) THEN
            DO I=1,MLAYER
               DCHRG_EARTH(I)=0.
               DTAU_EARTH(I)=1.
               DFRQC_EARTH(I)=1.
            ENDDO
         ENDIF
      ENDIF
!
      IF (KANIS/=0) READ (NR,*) (HVK(I),I=1,MLAYER)
      IF (MLAYER>1) READ (NR,*) (LRYTH(I),I=1,MLAYER-1)
!
      READ (NR,*) DO_3D
!
      IF (DO_3D==1) THEN
!
! --- Input the 3D model
!
!--- Read the 3D structure in terms of blocks.
!
         READ (NR,*) KSYMM,TRGT_BLCK,KACC
!   --   KAUTO is not used in this program but it was originally designed in
!        program SYSEM.  Set KAUTO=1 to minimize rewriting.
         KAUTO=1
!
         ALLOCATE(BLCK_NX(TRGT_BLCK),BLCK_NY(TRGT_BLCK),BLCK_NZ(TRGT_BLCK),  &
                  BLCK_LX(TRGT_BLCK),BLCK_LY(TRGT_BLCK),BLCK_LZ(TRGT_BLCK),  &
                  BLCK_CX(TRGT_BLCK),BLCK_CY(TRGT_BLCK),BLCK_CZ(TRGT_BLCK),  &
                  BLCK_NE(TRGT_BLCK),BLCK_NN(TRGT_BLCK),BLCK_LE(TRGT_BLCK),  &
                  BLCK_LN(TRGT_BLCK),BLCK_CE(TRGT_BLCK),BLCK_CN(TRGT_BLCK),  &
                  RSB(TRGT_BLCK),CHRSB(TRGT_BLCK),TAUSB(TRGT_BLCK),          &
                  CFRSB(TRGT_BLCK),DESB(TRGT_BLCK),DCHRSB(TRGT_BLCK),        &
                  DTAUSB(TRGT_BLCK),DCFRSB(TRGT_BLCK))
!
         DO II=1,TRGT_BLCK
!
            READ (NR,*) BLCK_NE(II),BLCK_NN(II),BLCK_NZ(II)
            READ (NR,*) BLCK_LE(II),BLCK_LN(II),BLCK_LZ(II)
            READ (NR,*) BLCK_CE(II),BLCK_CN(II),ZTOP
!
!   -- In this routine x and y are oriented in east and north, respectively
!      BLCK_LE etc are introduced only for data input
!
!      BLCK_LX etc. will be converted to computational system after data
!      input.  This is different from MarcoAir where the conversions are
!      done right here.
!
            BLCK_NX(II)=BLCK_NE(II);  BLCK_NY(II)=BLCK_NN(II)
            BLCK_LX(II)=BLCK_LE(II);  BLCK_LY(II)=BLCK_LN(II)
            BLCK_CX(II)=BLCK_CE(II);  BLCK_CY(II)=BLCK_CN(II)
!
            BLCK_CZ(II)=ZTOP+.5*BLCK_LZ(II)
!
            IF (INCL_DIELEC==1) THEN
               IF (COLE_COLE/=1) READ (NR,*) RSB(II),DESB(II)
               IF (COLE_COLE==1) THEN
                  READ (NR,*) RSB(II),CHRSB(II),TAUSB(II),CFRSB(II)
                  READ (NR,*) DESB(II),DCHRSB(II),DTAUSB(II),DCFRSB(II)
               ENDIF
            ELSE
               IF (COLE_COLE/=1) THEN
                  READ (NR,*) RSB(II)
                  DESB(II)=1.
               ENDIF
               IF (COLE_COLE==1) THEN
                  READ (NR,*) RSB(II),CHRSB(II),TAUSB(II),CFRSB(II)
                  DESB(II)=1.
                  DCHRSB(II)=0.
                  DTAUSB(II)=1.
                  DCFRSB(II)=1.
               ENDIF
            ENDIF
         ENDDO
!
      ENDIF
!
! --- Print messages for successful input of data.
!
!      WRITE (NW,*) 'Input successful!'
!
! ------  The input data are now printed
!
      IF (CS_TYPE==1) WRITE (NW,1010)
      IF (CS_TYPE==2) WRITE (NW,1020)
      IF (CS_TYPE==3) WRITE (NW,1030)
      IF (CS_TYPE==4) WRITE (NW,1040)
      IF (CS_TYPE==5) WRITE (NW,1050)
      IF (CS_TYPE==6) WRITE (NW,1060)
      IF (CS_TYPE==7) WRITE (NW,1070)
      IF (CS_TYPE==8) WRITE (NW,1080)
      IF (CS_TYPE==9) WRITE (NW,1090)
!
      WRITE (NW,1100) TITLE
!      WRITE (NW,1110) (RES_EARTH(I),I=1,MLAYER)
!      IF (COLE_COLE==1) THEN
!         WRITE (NW,1120) (CHRG_EARTH(I),I=1,MLAYER)
!         WRITE (NW,1130) (TAU_EARTH(I),I=1,MLAYER)
!         WRITE (NW,1140) (FRQC_EARTH(I),I=1,MLAYER)
!      ENDIF
!      IF (INCL_DIELEC==1) WRITE (NW,1150) (DIELC_EARTH(I),I=1,MLAYER)
!      IF (INCL_DIELEC==1.AND.COLE_COLE==1) THEN
!         WRITE (NW,1160) (DCHRG_EARTH(I),I=1,MLAYER)
!         WRITE (NW,1170) (DTAU_EARTH(I),I=1,MLAYER)
!         WRITE (NW,1180) (DFRQC_EARTH(I),I=1,MLAYER)
!      ENDIF
!
!      IF (KANIS/=0) WRITE (NW,1190) (HVK(I),I=1,MLAYER)
!      IF (MLAYER>1) WRITE (NW,1200) (LRYTH(I),I=1,MLAYER-1)
!
!  Print out layered earth parameters
!
      WRITE (NW,2040)
!
      IF (COLE_COLE==1) THEN
         WRITE (NW,2050)
         DO I=1,MLAYER
            IF (I==MLAYER) THEN
               WRITE (NW,2060) I,RES_EARTH(I),CHRG_EARTH(I),TAU_EARTH(I),  &
                                 FRQC_EARTH(I)
            ELSE
               WRITE (NW,2070) I,LRYTH(I),RES_EARTH(I),CHRG_EARTH(I),      &
                                 TAU_EARTH(I),FRQC_EARTH(I)
            ENDIF
         ENDDO
      ELSE
         WRITE (NW,2080)
         DO I=1,MLAYER
            IF (I<MLAYER) THEN
               WRITE (NW,2090) I,LRYTH(I),RES_EARTH(I)
            ELSE
               WRITE (NW,3100) I,RES_EARTH(I)
            ENDIF
         ENDDO
      ENDIF
!
      IF (INCL_DIELEC==1) THEN
         IF (COLE_COLE==1) THEN
            WRITE (NW,3050)
            DO I=1,MLAYER
               WRITE (NW,3060) I,DIELC_EARTH(I),DCHRG_EARTH(I),  &
                                 DTAU_EARTH(I),DFRQC_EARTH(I)
            ENDDO
         ELSE
            WRITE (NW,3080)
            DO I=1,MLAYER
               IF (I<MLAYER) THEN
                  WRITE (NW,3090) I,LRYTH(I),RES_EARTH(I)
               ELSE
                  WRITE (NW,3100) I,RES_EARTH(I)
               ENDIF
            ENDDO
         ENDIF
      ENDIF
!
      IF (DO_3D==0) THEN
         WRITE (NW,*) ' '
         WRITE (NW,*) '*** Only 1D responses are computed! '
         IF (KTEM==1) WRITE (9,*) '*** Only 1D responses are computed! '
      ENDIF
!
      IF (DO_3D==1) THEN
!
         WRITE (NW,2110)
!
         IF (KSYMM==1) THEN
            WRITE (NW,*) ' '
            WRITE (NW,*) '  The structure is symmetrical and the following'
            WRITE (NW,*) '  structure parameters are only for quadrant I'
         ENDIF
         WRITE (NW,*) ' '
         IF (TRGT_BLCK==1) WRITE (NW,2120)
         IF (TRGT_BLCK>1) WRITE (NW,2130) TRGT_BLCK
!
         DO II=1,TRGT_BLCK
!            WRITE (NW,1210) II,BLCK_NX(II),BLCK_NY(II),BLCK_NZ(II),           &
!                            BLCK_LX(II),BLCK_LY(II),BLCK_LZ(II),              &
!                            BLCK_CX(II),BLCK_CY(II),BLCK_CZ(II)
            NUML=BLCK_NX(II)*BLCK_NY(II)*BLCK_NZ(II)
            NUMCEL=NUMCEL+NUML
!            WRITE (NW,2140) II,NUML,BLCK_LX(II),BLCK_CX(II),BLCK_NX(II),      &
!                            BLCK_LY(II),BLCK_CY(II),BLCK_NY(II),BLCK_LZ(II),  &
!     -- Equivalent to above two lines
            WRITE (NW,2140) II,NUML,BLCK_LE(II),BLCK_CE(II),BLCK_NE(II),      &
                            BLCK_LN(II),BLCK_CN(II),BLCK_NN(II),BLCK_LZ(II),  &
                            BLCK_CZ(II)-.5*BLCK_LZ(II),BLCK_NZ(II)
            IF (INCL_DIELEC==1) THEN
               IF (COLE_COLE/=1) WRITE (NW,1220) RSB(II),DESB(II)
               IF (COLE_COLE==1) WRITE (NW,1230) RSB(II),CHRSB(II),TAUSB(II), &
                                           CFRSB(II),DESB(II),DCHRSB(II),     &
                                           DTAUSB(II),DCFRSB(II)
            ELSE
               IF (COLE_COLE/=1) WRITE (NW,1240) RSB(II)
               IF (COLE_COLE==1) WRITE (NW,1250) RSB(II),CHRSB(II),TAUSB(II), &
                                                 CFRSB(II)
            ENDIF
         ENDDO
!
         IF (KACC==1) THEN
            WRITE (NW,'(A)')   &
                     ' A FAST APPROXIMATE 3D SOLUTION WILL BE COMPUTED!'
         ELSE
            WRITE (NW,*) ' '
            WRITE (NW,'(A,I3)') ' ACCURACY LEVEL: ',KACC
         ENDIF
!
      ENDIF
!
      RETURN
!
 1010 FORMAT (////3X,'RESPONSES OF MAGNETOTELLURIC ',                   &
              'PROFILE(S) OVER A 3-DIMENSIONAL STRUCTURE',//13x,        &
              'EMBEDDED IN A MULTI-LAYER ANISOTROPIC EARTH')
 1020 FORMAT (////3X,'RESPONSES OF A 3-DIMENSIONAL STRUCTURE',//13x,    &
            'EMBEDDED IN A MULTI-LAYER ANISOTROPIC EARTH',//18X,        &
            'EXCITED BY VERTICAL CURRENT BIPOLE(S)')
 1030 FORMAT (////15X,'RESPONSES OF A 3-DIMENSIONAL STRUCTURE',//13x,   &
            'EMBEDDED IN A MULTI-LAYER ANISOTROPIC EARTH',//15X,        &
            'EXCITED BY HORIZONTAL CURRENT BIPOLE(S)')
 1040 FORMAT (////15X,'RESPONSES OF A 3-DIMENSIONAL STRUCTURE',//13x,   &
            'EMBEDDED IN A MULTI-LAYER ANISOTROPIC EARTH',//14X,        &
            'EXCITED BY HORIZONTAL POLYGONAL LOOP(S)')
 1050 FORMAT (////15X,'RESPONSES OF A 3-DIMENSIONAL STRUCTURE',//13x,   &
            'EMBEDDED IN A MULTI-LAYER ANISOTROPIC EARTH',//15X,        &
            'EXCITED BY HORIZONTAL CIRCULAR LOOP(S)')
 1060 FORMAT (////15X,'RESPONSES OF A 3-DIMENSIONAL STRUCTURE',//13x,   &
            'EMBEDDED IN A MULTI-LAYER ANISOTROPIC EARTH',//20X,        &
            'FOR A LOOP-LOOP CONFIGURATION')
 1070 FORMAT (////15X,'RESPONSES OF A 3-DIMENSIONAL STRUCTURE',//13x,   &
            'EMBEDDED IN A MULTI-LAYER ANISOTROPIC EARTH',//12X,        &
            'FOR MOVING VERTICAL CO-AXIAL MAGNETIC DIPOLES')
 1080 FORMAT (////15X,'RESPONSES OF A 3-DIMENSIONAL STRUCTURE',//13x,   &
            'EMBEDDED IN A MULTI-LAYER ANISOTROPIC EARTH',//15X,        &
            'FOR MOVING CO-PLANAR MAGNETIC DIPOLES')
 1090 FORMAT (////15X,'RESPONSES OF A 3-DIMENSIONAL STRUCTURE',//13x,   &
            'EMBEDDED IN A MULTI-LAYER ANISOTROPIC EARTH',//23X,        &
            'FOR MAGNETIC DIPOLE(S)')
 1100 FORMAT (//'For model:  ',A)
! 1110 FORMAT (/'Resistivities of the earths in each layer :',/3X,5F12.3)
!  1120 FORMAT ('Chargeabilities of the earths in each layer :',/3X,     &
!            5F12.3)
! 1130 FORMAT ('Time constants of the earths in each layer :',/3X,5E12.3)
! 1140 FORMAT ('Frequency constants of the earths in each layer :',/3X,  &
!            5F12.3)
! 1150 FORMAT ('Dielectric constants of the earths in each layer :',/3X, &
!            5F12.3)
! 1160 FORMAT ('Chargeabilities of the dielectric constants of the ',    &
!            'earths in each layer :',/3X,5F12.3)
! 1170 FORMAT ('Time constant of the dielectric constants of the ',      &
!            'earths in each layer :',/3X,5E12.3)
! 1180 FORMAT ('Frequency constant of the dielectric constants of the ', &
!            'earths in each layer :',/3X,5F12.3)
! 1190 FORMAT ('Coefficients of anisotropy of each layer :',/3X,5F12.3)
! 1200 FORMAT ('Thickness of each layer :',/3X,5F12.3)
! 1210 FORMAT (/'Numbers of cells divided in the x, y, and z-',          &
! 1210 FORMAT (/'Numbers of cells divided in the East, North, and Vertical', &
!              'directions for block #',I2,':',/10X,3I12,                &
!              /'Dimensions of this block in the x, y, and z-',          &
!              /'Dimensions of this block in the East, North, and Vertical', &
!              'directions (in meter):',/10X,3F12.3,                     &
!              /'Coordinates of the centre of this block:',/8X,'( ',     &
!               3F12.3,' )')
 1220 FORMAT ( '        RESISTIVITY:',G13.4,                            &
              /'        PERMITIVITY:',G13.4)
 1230 FORMAT ( '        RESISTIVITY:',G13.4,                            &
              /'      CHARGEABILITY:',G13.4,                            &
              /'      TIME CONSTANT:',G13.4,                            &
              /' FREQUENCY CONSTANT:',G13.4,                            &
              /'        PERMITIVITY:',G13.4                             &
              /'CHRG OF PERMITIVITY:',G13.4,                            &
              /' TAU OF PERMITIVITY:',G13.4,                            &
              /'FREQ OF PERMITIVITY:',G13.4)
 1240 FORMAT ( '        RESISTIVITY:',G13.4)
 1250 FORMAT ( '        RESISTIVITY:',G13.4,                            &
              /'      CHARGEABILITY:',G13.4,                            &
              /'      TIME CONSTANT:',G13.4,                            &
              /' FREQUENCY CONSTANT:',G13.4)
 2040 FORMAT (//10X,'+----------------------------------+'/10X,           &
              '+  LAYERED EARTH MODEL PARAMETERS  +'/10X,                 &
              '+----------------------------------+'/)
 2050 FORMAT (' LAYER    THICKNESS   RESISTIVITY',6X,'CHRG',10X,' TAU',   &
              7X,'FREQ-CONST'/' -----    ---------   -----------',6X,'----',  &
              10X,'----',11X,'-----')
 2060 FORMAT (I4,17X,G13.4,1X,G13.4,1X,G13.4,2X,G13.4)
 2070 FORMAT (I4,4X,2G13.4,1X,G13.4,1X,G13.4,2X,G13.4)
 2080 FORMAT (10X,' LAYER    THICKNESS   RESISTIVITY'/10X,                &
              ' -----    ---------   -----------')
 2090 FORMAT (10X,I4,4X,2G13.4)
 3100 FORMAT (10X,I4,17X,G13.4)
 2110 FORMAT (//10X,'+---------------------------+'/10X,                  &
              '+    3-D MODLE PARAMETERS   +'/10X,                        &
              '+---------------------------+'/)
 2120 FORMAT (/' THE 3-D MODEL IS CONSTRUCTED FROM ONE BLOCK.')
 2130 FORMAT (/' THE 3-D MODEL IS CONSTRUCTED FROM',I3,' BLOCKS.')
 2140 FORMAT (//25X,'DESCRIPTION OF BLOCK #',I3,'   (',I3,                &
              ' CELLS )'/25X,40('-')/20X,                                 &
              'DIMENSION   COORDINATES OF    CELL'/20X,                   &
              '(METRES)    TOP FACE CENTRE   DISCRETISATION'//            &
              '     EAST - WEST:',F11.1,F14.1,10X,                        &
              I3/'   NORTH - SOUTH:',F11.1,F14.1,10X,                     &
              I3/'           DEPTH:',F11.1,F14.1,10X,I3/)
! 2150 FORMAT (10X,'RESISTIVITY:',G12.4,'OHM-METRES')
! 2160 FORMAT (8X,'CHARGEABILITY:',G12.4/8X,'TIME CONSTANT:',G12.4,        &
!              ' SEC'/3X,'FREQUENCY CONSTANT:',G12.4/)
! 2170 FORMAT (/75('-')/T24,'END OF INPUT DATA DESCRIPTION'/75('-')//)
! 2180 FORMAT (' THE TOTAL MODEL HAS BEEN DISCRETISED INTO',I5,' CELLS.')
!
 3050 FORMAT (/' LAYER               PERMITTIVITY',6X,'DCHRG',9X,'DTAU',   &
              7X,'DFREQ-CONST'/' -----                -----------',6X,'----', &
              10X,'----',11X,'-----')
 3060 FORMAT (I4,17X,G13.4,1X,G13.4,1X,G13.4,2X,G13.4)
 3080 FORMAT (10X,' LAYER         PERMITTIVITY'/10X,                &
              ' -----    ---------   -----------')
 3090 FORMAT (10X,I4,4X,2G13.4)
! 3110 FORMAT (//10X,'+---------------------------+'/10X,                  &
!              '+  3-D SOLUTION PARAMETERS  +'/10X,                        &
!              '+---------------------------+'/)
! 3120 FORMAT (/' THE 3-D MODEL IS CONSTRUCTED FROM ONE BLOCK.')
! 3130 FORMAT (/' THE 3-D MODEL IS CONSTRUCTED FROM',I3,' BLOCKS.')
! 3140 FORMAT (//25X,'DESCRIPTION OF BLOCK #',I3,'   (',I3,                &
!              ' CELLS )'/25X,40('-')/20X,                                 &
!              'DIMENSION   COORDINATES OF    CELL'/20X,                   &
!              '(METRES)    TOP FACE CENTRE   DISCRETISATION'//            &
!              '     EAST - WEST:',F11.1,F14.1,10X,                        &
!              I3/'   NORTH - SOUTH:',F11.1,F14.1,10X,                     &
!              I3/'           DEPTH:',F11.1,F14.1,10X,I3/)
! 3150 FORMAT (10X,'RESISTIVITY:',G12.4,'OHM-METRES')
! 3160 FORMAT (8X,'CHARGEABILITY:',G12.4/8X,'TIME CONSTANT:',G12.4,        &
!              ' SEC'/3X,'FREQUENCY CONSTANT:',G12.4/)
! 3170 FORMAT (/75('-')/T24,'END OF INPUT DATA DESCRIPTION'/75('-')//)
! 3180 FORMAT (' THE TOTAL MODEL HAS BEEN DISCRETISED INTO',I5,' CELLS.')
!
      END SUBROUTINE READATA
!
      SUBROUTINE STRUCTURING
!
!**** Divide block(s) into substructures
!
!   Input blocks are divided into substructures for the use of the
!   system iteration.  Blcoks are halved in the direction of maximal
!   cell numbers untill the total number of cells within each
!   substructure is reduced to a quarter of NSUBCM.
!
!Input parameters:
!
!  NSUBCM:  Integer(*4),  maximal nuber of cells in a substructure.
!  MBODY:   Integer,  maximal number of substructures allowed in the
!           program.
!  NBMAX:   Integer,  maximal number of blocks allowed in a
!           substructure.  It is the maximum of SUB_BLOCK used for
!           array definitions.
!  TRGT_BLCK: Integer,  number of input blocks to be divided into
!           substructures.
!  BLCK_NX:    Integer BLCK_NX(TRGT_BLCK),  number of cells in the x-direction
!           of blocks.
!  BLCK_NY:    Integer BLCK_NY(TRGT_BLCK),  number of cells in the y-direction
!           of blocks.
!  BLCK_NZ:    Integer BLCK_NZ(TRGT_BLCK),  number of cells in the z-direction
!           of blocks.
!  BLCK_LX:    Real BLCK_LX(TRGT_BLCK),  dimensions of the blocks in the
!           x-direction.
!  BLCK_LY:    Real BLCK_LY(TRGT_BLCK),  dimensions of the blocks in the
!           y-direction.
!  BLCK_LZ:    Real BLCK_LZ(TRGT_BLCK),  dimensions of the blocks in the
!           z-direction.
!  BLCK_CX:    Real BLCK_CX(TRGT_BLCK),  x-coordinates of the block centres.
!  BLCK_CY:    Real BLCK_CY(TRGT_BLCK),  y-coordinates of the block centres.
!  BLCK_CZ:    Real BLCK_CZ(TRGT_BLCK),  z-coordinates of the block centres.
!  RSB:     Real RSB(TRGT_BLCK),  resistivities of the blocks.
!  CHRSB:   Real CHRSB(TRGT_BLCK),  chargeability of the blocks (if it
!           is polarisable).  Cole-Cole models are used to presents
!           polarisable models.
!  TAUSB:   Real TAUSB(TRGT_BLCK),  time constants of the blocks.
!  CFRSB:   Real CFRSB(TRGT_BLCK),  frequency constants of the blocks.
!  DESB:    Real DESB(TRGT_BLCK),  dielectric permittivities of the blocks.
!  DCHRSB:  Real DCHRSB(TRGT_BLCK),  chargeabilities of the dielectric
!           permittivities of the blocks.  If the dielectric permittivities
!           of the model are frequency-dependent,  they are represented by
!           Cole-Cole models.
!  DTAUSB:  Real DTAUSB(TRGT_BLCK),  time constants of the dielectric
!           permittivities of the blocks.
!  DCFRSB:  Real DCFRSB(TRGT_BLCK),  frequency constants of the dielectric
!           permittivities of the blocks.
!  KACC:    Integer,  accuracy level for the computation of the scattered
!           fields.  See documentation file "MARCO.DOC" for detail.
!  COLE_COLE:     Integer,  parameter controlling whether the model is polarisable.
!           COLE_COLE = 0:  non-polarisable;  and
!               = 1:  polarisable.
!
!
!Output parameters:
!
!  NBODY:   Integer,  number of substructures.
!  SUB_BLOCK:  Integer SUB_BLOCK(MBODY),  number of blocks in each substructure.
!  NCT:     Integer NCT(MBODY),  number of cells in each substructure.
!  NCELL:   Integer NCELL(NBMAX,MBODY),  number of cells in each block
!           of the substructures.
!  NX:      Integer NX(NBMAX,MBODY),  numbers of cells in the x-direction
!           in each block of the substructures.
!  NY:      Integer NY(NBMAX,MBODY),  numbers of cells in the y-direction
!           in each block of the substructures.
!  NZ:      Integer NZ(NBMAX,MBODY),  numbers of cells in the z-direction
!           in each block of the substructures.
!  BLX:     Real BLX(NBMAX,MBODY),  dimensions of each blocks of the
!           substructures in the x-direction.
!  BLY:     Real BLY(NBMAX,MBODY),  dimensions of each blocks of the
!           substructures in the y-direction.
!  BLZ:     Real BLZ(NBMAX,MBODY),  dimensions of each blocks of the
!           substructures in the z-direction.
!  XBL:     Real XBL(NBMAX,MBODY),  x-coordinates of each blocks in the
!           substructures.
!  YBL:     Real YBL(NBMAX,MBODY),  y-coordinates of each blocks in the
!           substructures.
!  ZBL:     Real ZBL(NBMAX,MBODY),  z-coordinates of each blocks in the
!           substructures.
!  RBC:     Real RBC(NBMAX,MBODY),  resistivities of each blocks of the
!           substructures.
!  CHRBC:   Real CHRBC(NBMAX,MBODY),  chargeabilities of each blocks of
!           the substructures.
!  TAUBC:   Real TAUBC(NBMAX,MBODY),  time constants of each blocks of
!           the substructures.
!  CFRBC:   Real CFRBC(NBMAX,MBODY),  frequency constants of each blocks of
!           the substructures.
!  DEBC:    Real DEBC(NBMAX,MBODY),  dielectric permittivities of blocks
!           in the substructures.
!  DCHRBC:  Real DCHRBC(NBMAX,MBODY),  chargeabilities of the dielectric
!           permittivities of the blocks of the substructures.
!  DTAUBC:  Real DTAUBC(NBMAX,MBODY),  time constants of the dielectric
!           permittivities of the blocks of the substructures.
!  DCFRBC:  Real DCFRBC(NBMAX,MBODY),  freqeuncy constants of the dielectric
!           permittivities of the blocks of the substructures.
!
!Note that the word "block" means differently for the input and output.
!In the input it is the blocks that are read from the data input file
!"MARCO.DAT".  In the output it is the blocks for computation purpose.
!
!
      IMPLICIT NONE
!
      INTEGER I,IB,II,IMAX,PARTITION,N1,N2,             &
              NCLIM,NCMAX,NM,NBODY1
!
! --- Divide the structure blocks into substructures
!
      NCTT=0
      DO II=1,TRGT_BLCK
         NCTT=NCTT+BLCK_NX(II)*BLCK_NY(II)*BLCK_NZ(II)
      ENDDO
!
!-- If the total number of the substructure cells does not exceed the
!   designed limits or if accurate solution is needed
!
!*** This criterion may be changed !!
!
      IF (NCTT<=SUB_CELL_MAX.AND.TRGT_BLCK<=NBMAX.AND.KACC>1) THEN
!********************************************************************
!*                                                                  *
         NBODY=1
!
         ALLOCATE(BLX(TRGT_BLCK,1),BLY(TRGT_BLCK,1),BLZ(TRGT_BLCK,1),      &
                  XBL(TRGT_BLCK,1),YBL(TRGT_BLCK,1),ZBL(TRGT_BLCK,1),      &
                  NX(TRGT_BLCK,1),NY(TRGT_BLCK,1),NZ(TRGT_BLCK,1),         &
                  NCT(1),NCELL(TRGT_BLCK,1),                               &
                  RBC(TRGT_BLCK,1),DEBC(TRGT_BLCK,1),CHRBC(TRGT_BLCK,1),   &
                  TAUBC(TRGT_BLCK,1),CFRBC(TRGT_BLCK,1),                   &
                  DCHRBC(TRGT_BLCK,1),DTAUBC(TRGT_BLCK,1),                 &
                  DCFRBC(TRGT_BLCK,1),SUB_BLOCK(1))
!
         SUB_BLOCK(1)=TRGT_BLCK
         NCT(1)=0
         DO I=1,SUB_BLOCK(1)
            BLX(I,1)=BLCK_LX(I)
            BLY(I,1)=BLCK_LY(I)
            BLZ(I,1)=BLCK_LZ(I)
            XBL(I,1)=BLCK_CX(I)
            YBL(I,1)=BLCK_CY(I)
            ZBL(I,1)=BLCK_CZ(I)
            NX(I,1)=BLCK_NX(I)
            NY(I,1)=BLCK_NY(I)
            NZ(I,1)=BLCK_NZ(I)
            NCELL(I,1)=NX(I,1)*NY(I,1)*NZ(I,1)
            NCT(1)=NCT(1)+NCELL(I,1)
            RBC(I,1)=RSB(I)
            DEBC(I,1)=DESB(I)
            IF (COLE_COLE==1) THEN
               CHRBC(I,1)=CHRSB(I)
               TAUBC(I,1)=TAUSB(I)
               CFRBC(I,1)=CFRSB(I)
               DCHRBC(I,1)=DCHRSB(I)
               DTAUBC(I,1)=DTAUSB(I)
               DCFRBC(I,1)=DCFRSB(I)
            ENDIF
         ENDDO
!*                                                                  *
!********************************************************************
      ELSE
!********************************************************************
!*                                                                  *
!
! -- Determine the number of substructures according to number of
!    cells in the substructures
!
!    NBODY1 is used as a working parameter that is the maximal number of
!    substructures for the fast solver with KACC=1
!
         NBODY1=NCTT/10
         ALLOCATE(NX(1,NBODY1),NY(1,NBODY1),NZ(1,NBODY1),NCT(NBODY1),   &
                  NCELL(1,NBODY1))
!
         NBODY=TRGT_BLCK
!
         DO IB=1,NBODY
            NX(1,IB)=BLCK_NX(IB)
            NY(1,IB)=BLCK_NY(IB)
            NZ(1,IB)=BLCK_NZ(IB)
         ENDDO
!
! --- Break the block that has the maximal number of cells in the
!     direction of maximal cell numbers.
!
         DO PARTITION=1,100000
!
            DO IB=1,NBODY
               NCT(IB)=0
               NCELL(1,IB)=NX(1,IB)*NY(1,IB)*NZ(1,IB)
               NCT(IB)=NCT(IB)+NCELL(1,IB)
            ENDDO
!
            NCMAX=0
            DO IB=1,NBODY
               IF (NCMAX<NCT(IB)) THEN
                  NCMAX=NCT(IB)
                  IMAX=IB
               ENDIF
            ENDDO
!
!--- No further division necessary if the maximal number of
!    cells in a subbstructure is less than SUB_CELL_MAX/4 or if
!    the maximal number of substructurs is reached
!
!    In case an approximate solution is sought,  the body
!    is divided into maximal number of substructures defined by NCLIM
!
            IF (KACC==1) THEN
               NCLIM=10
            ELSE
               NCLIM=SUB_CELL_MAX/4
            ENDIF
!
!      --   NBODY1 is the maximum for the number of substructures
            IF (NCMAX<=NCLIM.OR.NBODY==NBODY1) THEN
               EXIT
            ENDIF
!
! -- Increase the number of substructures by 1
!
            NBODY=NBODY+1
!
! -- Move the blocks
!
            DO IB=NBODY,IMAX+2,-1
               NX(1,IB)=NX(1,IB-1)
               NY(1,IB)=NY(1,IB-1)
               NZ(1,IB)=NZ(1,IB-1)
            ENDDO
!
! -- divide the block imax into two
!
            NM=NX(1,IMAX)
            II=1
            IF (NM<NY(1,IMAX)) THEN
               NM=NY(1,IMAX)
               II=2
            ENDIF
            IF (NM<NZ(1,IMAX)) THEN
               NM=NZ(1,IMAX)
               II=3
            ENDIF
            N1=NM/2
            N2=NM-N1
!
            IF (II==1) THEN
               NX(1,IMAX+1)=N2
               NY(1,IMAX+1)=NY(1,IMAX)
               NZ(1,IMAX+1)=NZ(1,IMAX)
               NX(1,IMAX)=N1
            ENDIF
!
            IF (II==2) THEN
               NX(1,IMAX+1)=NX(1,IMAX)
               NY(1,IMAX+1)=N2
               NZ(1,IMAX+1)=NZ(1,IMAX)
               NY(1,IMAX)=N1
            ENDIF
!
            IF (II==3) THEN
               NX(1,IMAX+1)=NX(1,IMAX)
               NY(1,IMAX+1)=NY(1,IMAX)
               NZ(1,IMAX+1)=N2
               NZ(1,IMAX)=N1
            ENDIF
!
         ENDDO
!
! --- Now that the exact number of substructures is determined, reallocate
!     the arrays NX etc. and complete the restructuring.
!
         DEALLOCATE(NX,NY,NZ,NCT,NCELL)
         ALLOCATE(NX(1,NBODY),NY(1,NBODY),NZ(1,NBODY),NCT(NBODY),         &
                  NCELL(1,NBODY),BLX(1,NBODY),BLY(1,NBODY),BLZ(1,NBODY),  &
                  XBL(1,NBODY),YBL(1,NBODY),ZBL(1,NBODY),                 &
                  RBC(1,NBODY),DEBC(1,NBODY),CHRBC(1,NBODY),              &
                  TAUBC(1,NBODY),CFRBC(1,NBODY),                          &
                  DCHRBC(1,NBODY),DTAUBC(1,NBODY),                        &
                  DCFRBC(1,NBODY),SUB_BLOCK(NBODY))
         NBODY1=NBODY
!
! --  Now divide the blocks into substructures as determined above.
!     Note that the following rules are identical the above.
!
         NBODY=TRGT_BLCK
!
! -- SUB_BLOCK for all substructures set to be one.
!
         DO IB=1,NBODY1
            SUB_BLOCK(IB)=1
         ENDDO
!
         NCT=0
         DO IB=1,NBODY
            BLX(1,IB)=BLCK_LX(IB)
            BLY(1,IB)=BLCK_LY(IB)
            BLZ(1,IB)=BLCK_LZ(IB)
            XBL(1,IB)=BLCK_CX(IB)
            YBL(1,IB)=BLCK_CY(IB)
            ZBL(1,IB)=BLCK_CZ(IB)
            NX(1,IB)=BLCK_NX(IB)
            NY(1,IB)=BLCK_NY(IB)
            NZ(1,IB)=BLCK_NZ(IB)
            NCELL(1,IB)=NX(1,IB)*NY(1,IB)*NZ(1,IB)
            NCT(IB)=NCT(IB)+NCELL(1,IB)
            RBC(1,IB)=RSB(IB)
            DEBC(1,IB)=DESB(IB)
            IF (COLE_COLE==1) THEN
               CHRBC(1,IB)=CHRSB(IB)
               TAUBC(1,IB)=TAUSB(IB)
               CFRBC(1,IB)=CFRSB(IB)
               DCHRBC(1,IB)=DCHRSB(IB)
               DTAUBC(1,IB)=DTAUSB(IB)
               DCFRBC(1,IB)=DCFRSB(IB)
            ENDIF
         ENDDO
!
! --- Break the block that has the maximal number of cells in the
!     direction of maximal cell numbers.
!
         DO PARTITION=1,100000
!
            DO IB=1,NBODY
               NCT(IB)=0
               NCELL(1,IB)=NX(1,IB)*NY(1,IB)*NZ(1,IB)
               NCT(IB)=NCT(IB)+NCELL(1,IB)
            ENDDO
!
            NCMAX=0
            DO IB=1,NBODY
               IF (NCMAX<NCT(IB)) THEN
                  NCMAX=NCT(IB)
                  IMAX=IB
               ENDIF
            ENDDO
!
!--- No further division necessary if the maximal number of
!    cells in a subbstructure is less than SUB_CELL_MAX/4 or if
!    the maximal number of substructurs is reached
!
!    In case an approximate solution is sought,  the body
!    is divided into maximal number of substructures defined by NCLIM
!
            IF (KACC==1) THEN
               NCLIM=10
            ELSE
               NCLIM=SUB_CELL_MAX/4
            ENDIF
!
            IF (NCMAX<=NCLIM.OR.NBODY==NBODY1) THEN
               EXIT
            ENDIF
!
! -- Increase the number of substructures by 1
!
            NBODY=NBODY+1
!
! -- Move the blocks
!
            DO IB=NBODY,IMAX+2,-1
               BLX(1,IB)=BLX(1,IB-1)
               BLY(1,IB)=BLY(1,IB-1)
               BLZ(1,IB)=BLZ(1,IB-1)
               XBL(1,IB)=XBL(1,IB-1)
               YBL(1,IB)=YBL(1,IB-1)
               ZBL(1,IB)=ZBL(1,IB-1)
               NX(1,IB)=NX(1,IB-1)
               NY(1,IB)=NY(1,IB-1)
               NZ(1,IB)=NZ(1,IB-1)
               RBC(1,IB)=RBC(1,IB-1)
               DEBC(1,IB)=DEBC(1,IB-1)
               IF (COLE_COLE==1) THEN
                  CHRBC(1,IB)=CHRBC(1,IB-1)
                  TAUBC(1,IB)=TAUBC(1,IB-1)
                  CFRBC(1,IB)=CFRBC(1,IB-1)
                  DCHRBC(1,IB)=DCHRBC(1,IB-1)
                  DTAUBC(1,IB)=DTAUBC(1,IB-1)
                  DCFRBC(1,IB)=DCFRBC(1,IB-1)
               ENDIF
            ENDDO
!
! -- divide the block imax into two
!
            NM=NX(1,IMAX)
            II=1
            IF (NM<NY(1,IMAX)) THEN
               NM=NY(1,IMAX)
               II=2
            ENDIF
            IF (NM<NZ(1,IMAX)) THEN
               NM=NZ(1,IMAX)
               II=3
            ENDIF
            N1=NM/2
            N2=NM-N1
!
            IF (II==1) THEN
               BLX(1,IMAX+1)=BLX(1,IMAX)*N2/NM
               BLY(1,IMAX+1)=BLY(1,IMAX)
               BLZ(1,IMAX+1)=BLZ(1,IMAX)
               XBL(1,IMAX+1)=XBL(1,IMAX)-.5*BLX(1,IMAX)+.5*BLX(1,IMAX+1)
               YBL(1,IMAX+1)=YBL(1,IMAX)
               ZBL(1,IMAX+1)=ZBL(1,IMAX)
               NX(1,IMAX+1)=N2
               NY(1,IMAX+1)=NY(1,IMAX)
               NZ(1,IMAX+1)=NZ(1,IMAX)
               BLX(1,IMAX)=BLX(1,IMAX)*N1/NM
               XBL(1,IMAX)=XBL(1,IMAX+1)+.5*(BLX(1,IMAX)+BLX(1,IMAX+1))
               NX(1,IMAX)=N1
            ENDIF
!
            IF (II==2) THEN
               BLX(1,IMAX+1)=BLX(1,IMAX)
               BLY(1,IMAX+1)=BLY(1,IMAX)*N2/NM
               BLZ(1,IMAX+1)=BLZ(1,IMAX)
               XBL(1,IMAX+1)=XBL(1,IMAX)
               YBL(1,IMAX+1)=YBL(1,IMAX)-.5*BLY(1,IMAX)+.5*BLY(1,IMAX+1)
               ZBL(1,IMAX+1)=ZBL(1,IMAX)
               NX(1,IMAX+1)=NX(1,IMAX)
               NY(1,IMAX+1)=N2
               NZ(1,IMAX+1)=NZ(1,IMAX)
               BLY(1,IMAX)=BLY(1,IMAX)*N1/NM
               YBL(1,IMAX)=YBL(1,IMAX+1)+.5*(BLY(1,IMAX)+BLY(1,IMAX+1))
               NY(1,IMAX)=N1
            ENDIF
!
            IF (II==3) THEN
               BLX(1,IMAX+1)=BLX(1,IMAX)
               BLY(1,IMAX+1)=BLY(1,IMAX)
               BLZ(1,IMAX+1)=BLZ(1,IMAX)*N2/NM
               XBL(1,IMAX+1)=XBL(1,IMAX)
               YBL(1,IMAX+1)=YBL(1,IMAX)
               ZBL(1,IMAX+1)=ZBL(1,IMAX)-.5*BLZ(1,IMAX)+.5*BLZ(1,IMAX+1)
               NX(1,IMAX+1)=NX(1,IMAX)
               NY(1,IMAX+1)=NY(1,IMAX)
               NZ(1,IMAX+1)=N2
               BLZ(1,IMAX)=BLZ(1,IMAX)*N1/NM
               ZBL(1,IMAX)=ZBL(1,IMAX+1)+.5*(BLZ(1,IMAX)+BLZ(1,IMAX+1))
               NZ(1,IMAX)=N1
            ENDIF
!
            RBC(1,IMAX+1)=RBC(1,IMAX)
            DEBC(1,IMAX+1)=DEBC(1,IMAX)
            IF (COLE_COLE==1) THEN
               CHRBC(1,IMAX+1)=CHRBC(1,IMAX)
               TAUBC(1,IMAX+1)=TAUBC(1,IMAX)
               CFRBC(1,IMAX+1)=CFRBC(1,IMAX)
               DCHRBC(1,IMAX+1)=DCHRBC(1,IMAX)
               DTAUBC(1,IMAX+1)=DTAUBC(1,IMAX)
               DCFRBC(1,IMAX+1)=DCFRBC(1,IMAX)
            ENDIF
!
         ENDDO
!
! -- Check is NBODY = NBODY1.  They must be identical, or something must
!    be wrong in determining NBODY and/or NBODY1.
!
         IF (NBODY1/=NBODY) THEN
            WRITE(NW,*) 'Error in routine STRUCTURING: NBODY1/=NBODY.'
            STOP 'Program aborted.  Check error message in file OUTPUT.OUT'
         ENDIF
!*                                                                  *
!********************************************************************
      ENDIF
!
! --- Substructure information can be printed out as in program Sysem
!     if necessary.  Check file sysem.f, line 1594 ff.
!
      RETURN
!
      END SUBROUTINE STRUCTURING
!
   END PROGRAM MARCO
!
!
      SUBROUTINE INIT_CMPLX_CD(NW,FRQ,COLE_COLE,DO_3D,MLAYER,KANIS,HVK,   &
                               RES_EARTH,CHRG_EARTH,TAU_EARTH,FRQC_EARTH, &
                               DIELC_EARTH,DCHRG_EARTH,DTAU_EARTH,        &
                               DFRQC_EARTH,CDH,CDV,KKH,MBODY,NBMAX,       &
                               NBODY,SUB_BLOCK,NCELL,NSUBCM,              &
                               CDB,RBC,CHRBC,TAUBC,CFRBC,                 &
                               DEBC,DCHRBC,DTAUBC,DCFRBC)
!
!**** Compute the complex conductivities of the earths and the cells
!
!   Note that units 61 and 62 are used to read and store cells
!   conductivity parameters.   The reading sequence must be consistent
!   with the writing sequence in routine READATA.


!Input parameters:

!  FRQ:    Real,  the frequency.
!  COLE_COLE:    Integer,  parameter controlling whether the model (including
!          the earth) is polarizable.  If so,  Cole-Cole models are used
!          to represent the complex resistivities of the model.
!  DO_3D: Integer,  parameter controlling whether only 1D responses
!          are to be computed.  DO_3D=1: yes;  =0,  no.
!  MLAYER: Integer,  number of layers of the earth.
!  KANIS:  Integer,  parameter controlling whether the earth is vertically
!          anisotropic in conductivity.  KANIS=1, yes;  =0,  no.
!  HVK:     Real HVK(0:MLAYER), the anisotropy coefficients of
!           the layer conductivities as defined by the square
!           root of the ratio of horizontal conductivity to
!           vertical conductivity.
!  RES_EARTH:  Real RES_EARTH(MLAYER),  resistivities of each layer of the earth.
!  CHRG_EARTH: Real CHRG_EARTH(MLAYER),  chargeabilities of the earths.
!  TAU_EARTH: Real TAU_EARTH(MLAYER),  time constants of the earths.
!  FRQC_EARTH: Real FRQC_EARTH(MLAYER), frequency constants of the earths.
!  DIELC_EARTH:   Real DIELC_EARTH(MLAYER),  dielectric permittivities of the earths.
!  DCHRG_EARTH: Real DCHRG_EARTH(MLAYER), chargeabilities of the frequency-
!           dependent permittivities of the earth as described by
!           Cole-Cole models.
!  DTAU_EARTH: Real DTAU_EARTH(MLAYER),  time constants of the frequency-
!           dependent permittivities of the earth.
!  DFRQC_EARTH: Real DFRQC_EARTH(MLAYER), frequency constants of the frequency-
!           dependent permittivities of the earth.
!  MBODY:   Integer,  maximal number of substructures allowed in the
!           program.
!  NBMAX:   Integer,  maximal number of blocks allowed in a
!           substructure.  It is the maximum of SUB_BLOCK used for
!           array definitions.
!  NBODY:   Integer,  number of substructures.
!  SUB_BLOCK:  Integer SUB_BLOCK(MBODY),  number of blocks in each substructure.
!  NCELL:   Integer NCELL(NBMAX,MBODY),  number of cells in each block
!           of the substructures.
!  NSUBCM:  Integer,  maximal number of cells in a substructure.
!  CDB:    COMPLEX CDB(NSUBCM,NBMAX),  working array for the
!          complex conductivities of the cells in a substructure.
!          Its values are all stored on the disk in unit 62
!  RBC:     Real RBC(NBMAX,MBODY),  resistivities of each blocks of the
!           substructures.
!  CHRBC:   Real CHRBC(NBMAX,MBODY),  chargeabilities of each blocks of
!           the substructures.
!  TAUBC:   Real TAUBC(NBMAX,MBODY),  time constants of each blocks of
!           the substructures.
!  CFRBC:   Real CFRBC(NBMAX,MBODY),  frequency constants of each blocks of
!           the substructures.
!  DEBC:    Real DEBC(NBMAX,MBODY),  dielectric permittivities of blocks
!           in the substructures.
!  DCHRBC:  Real DCHRBC(NBMAX,MBODY),  chargeabilities of the dielectric
!           permittivities of the blocks of the substructures.
!  DTAUBC:  Real DTAUBC(NBMAX,MBODY),  time constants of the dielectric
!           permittivities of the blocks of the substructures.
!  DCFRBC:  Real DCFRBC(NBMAX,MBODY),  freqeuncy constants of the dielectric
!           permittivities of the blocks of the substructures.
!
! Output parameters:
!
!  CDH:    Complex CDH(0:MLAYER),  complex conductivities of
!          the layers in the lateral direction including the
!          air (layer 0).
!  CDV:    Complex CDV(0:MLAYER),  complex conductivities of
!          the layers in the vertical direction including the
!          air (layer 0).
!  KKH:    Complex(*8) KKH(0:MLAYER),  square ( **2) of the complex wave
!          number of the layers (in the lateral direction) including
!          the air (layer number 0).

!  Complex conductivities of the 3D cells are stored in unit
!  62 on the disk.
!
!**** Called by:  main
!**** Calls:      none
!
!
      IMPLICIT NONE
!
      REAL AIRCD,FRQ,MU0,EPSL0,OMEGA,PI,TOLCC
      INTEGER I,IB,J,KANIS,COLE_COLE,MBODY,MLAYER,NBMAX,NBODY,   &
              NSUBCM,DO_3D,NW
      COMPLEX ONE,SIG,P,CALF,DSIG,DP,DCALF,WMU,CDH(0:MLAYER),                &
              CDV(0:MLAYER),KKH(0:MLAYER)
      COMPLEX CDB(NSUBCM,NBMAX)
      REAL RES_EARTH(MLAYER),CHRG_EARTH(MLAYER),TAU_EARTH(MLAYER),                       &
           FRQC_EARTH(MLAYER),DIELC_EARTH(MLAYER),DCHRG_EARTH(MLAYER),                      &
           DTAU_EARTH(MLAYER),DFRQC_EARTH(MLAYER),HVK(0:MLAYER)
      INTEGER SUB_BLOCK(MBODY),NCELL(NBMAX,MBODY)
      REAL RBC(NBMAX,MBODY),CHRBC(NBMAX,MBODY),TAUBC(NBMAX,MBODY),           &
           CFRBC(NBMAX,MBODY),DEBC(NBMAX,MBODY),DCHRBC(NBMAX,MBODY),         &
           DTAUBC(NBMAX,MBODY),DCFRBC(NBMAX,MBODY)
!
      DATA ONE /(1.,0.)/, PI /3.141592654/, EPSL0 /8.854156E-12/,            &
           TOLCC /1.E-12/
!
      REAL, ALLOCATABLE :: RCELL(:),CHCLL(:),TACLL(:),CFCLL(:),              &
                           DECELL(:),DCHCLL(:),DTACLL(:),DCFCLL(:)
!
!  RCELL:   Real RCELL(NSUBCM), resistivities of each cell in a
!           substructure.
!  CHCLL: Real CHCLL(NSUBCM), chargeability of each cell in a
!           substructure.
!  TACLL: Real TACLL(NSUBCM), time constants of each cell in a
!           substructure.
!  CFCLL: Real CFCLL(NSUBCM), frequency constants of each cell in a
!           substructure.
!  DECELL:  Real DECELL(NSUBCM), dielectric permittivities of each cell
!           in a substructure.
!  DCHCLL: Real DCHCLL(NSUBCM), chargeabilities of the dielectric
!           permittivities of the frequency-dependent permittivities of
!           each cell in a substructure as described by Cole-Cole models.
!  DTACLL: Real DTACLL(NSUBCM),  time constants of the dielectric
!           permittivities of the frequency-dependent permittivities of
!           each cell in a substructure.
!  DCHCLL: Real DCHCLL(NSUBCM), frequency constants of the dielectric
!           permittivities of the frequency-dependent permittivities of
!           each cell in a substructure.
!
      ALLOCATE (RCELL(NSUBCM),CHCLL(NSUBCM),TACLL(NSUBCM),        &
                CFCLL(NSUBCM),DECELL(NSUBCM),DCHCLL(NSUBCM),      &
                DTACLL(NSUBCM),DCFCLL(NSUBCM))
!
!-- The conductivity of the air is set to 1.E-20.  This is
!   necessary for the elimination of singularity of the kernels
!   of the Hankel transforms at high frequencies.  As thus,
!   there should be no air layers added to the earth.  Such
!   an air layer may reduce the accuracy of the results

      AIRCD=1.E-20

!-- Issue warnings if there is an air layer in the input

      IF (RES_EARTH(1)>=1.E+8) THEN
         WRITE (*,1010)
         WRITE (NW,1010)
      ENDIF

      MU0=PI*4.E-7
      OMEGA=2.*PI*FRQ
      WMU=CMPLX(0.,MU0*OMEGA)
      CDH(0)=CMPLX(AIRCD,EPSL0*OMEGA)
      DO I=0,MLAYER
         IF (KANIS==0) HVK(I)=1.

!-- Note that the values of DIELC_EARTH, DCHRG_EARTH etc for the 1D layers
!   have been assigned in the routine READATA regardless of the
!   value of INCL_DIELEC.

         IF (I/=0) THEN
            SIG=CMPLX(1./RES_EARTH(I),0.)
            DSIG=CMPLX(0.,OMEGA*EPSL0*DIELC_EARTH(I))
            IF (COLE_COLE/=1) THEN
               CDH(I)=SIG+DSIG
            ELSE
!
!  -- Add Cole-Cole models to the conductivities and permitivities
!
               P=(0.,0.)
               DP=(0.,0.)
               IF ((TAU_EARTH(I)>TOLCC).AND.(FRQC_EARTH(I)>TOLCC))     &
                   P=CMPLX(0.,OMEGA*TAU_EARTH(I))**FRQC_EARTH(I)
               IF ((DTAU_EARTH(I)>TOLCC).AND.(DFRQC_EARTH(I)>TOLCC))   &
                   DP=CMPLX(0.,OMEGA*DTAU_EARTH(I))**DFRQC_EARTH(I)
               CALF=CMPLX((1.-CHRG_EARTH(I)),0.)
               DCALF=CMPLX((1.-DCHRG_EARTH(I)),0.)
               CDH(I)=SIG*(ONE+P)/(ONE+CALF*P)+DSIG*(ONE+DP)  &
                      /(ONE+DCALF*DP)
            ENDIF
         ENDIF

         CDV(I)=CDH(I)/HVK(I)**2
         KKH(I)=WMU*CDH(I)
      ENDDO

! ---- Set cell conductivities

      IF (DO_3D==1) THEN

         DO IB=1,NBODY
            DO J=1,SUB_BLOCK(IB)
               DO I=1,NCELL(J,IB)
                  RCELL(I)=RBC(J,IB)
                  DECELL(I)=DEBC(J,IB)
                  IF (COLE_COLE==1) THEN
                     CHCLL(I)=CHRBC(J,IB)
                     TACLL(I)=TAUBC(J,IB)
                     CFCLL(I)=CFRBC(J,IB)
                     DCHCLL(I)=DCHRBC(J,IB)
                     DTACLL(I)=DTAUBC(J,IB)
                     DCFCLL(I)=DCFRBC(J,IB)
                  ENDIF
               ENDDO
!
               DO I=1,NCELL(J,IB)
                  SIG=CMPLX(1./RCELL(I),0.)
                  DSIG=CMPLX(0.,OMEGA*EPSL0*DECELL(I))

                  IF (COLE_COLE/=1) THEN
                     CDB(I,J)=SIG+DSIG
                  ELSE

!  -- Add Cole-Cole models to the conductivities and permitivities

                     P=CMPLX(0.,OMEGA*TACLL(I))**CFCLL(I)
                     DP=CMPLX(0.,OMEGA*DTACLL(I))**DCFCLL(I)
                     CALF=CMPLX((1.-CHCLL(I)),0.)
                     DCALF=CMPLX((1.-DCHCLL(I)),0.)
                     CDB(I,J)=SIG*(ONE+P)/(ONE+CALF*P)+DSIG*(ONE+DP)  &
                        /(ONE+DCALF*DP)
                  ENDIF
               ENDDO

            ENDDO

! --- Store the cell conductivity to file CONDT (unit 62)

            WRITE (62) ((CDB(I,J),I=1,NCELL(J,IB)),J=1,SUB_BLOCK(IB))

         ENDDO

         REWIND (61)
         REWIND (62)

      ENDIF
!
      DEALLOCATE (RCELL,CHCLL,TACLL,CFCLL,DECELL,DCHCLL,DTACLL,DCFCLL)
!
      RETURN
 1010 FORMAT (' WARNING: THE INTRODUCTION OF AN AIR LAYER MAY REDUCE',  &
              ' THE ACCURACY'/10X,'OF THE RESULTS!  USE NEGATIVE',      &
              ' Z-COORDINATES INSTEAD.')
      END

!**** End of INIT_CMPLX_CD
!
!
!===== Subroutines for intializations
!
      SUBROUTINE INIT_COMPUTATION (DMIN,MBODY,NBMAX,NXMAX,NYMAX,NZMAX,       &
                                   MLAYER,ZBND,LRYTH,HVK,CS_TYPE,KSYMM,RAD,  &
                                   RAD2,NCRD,TX_CRDX,TX_CRDY,TX_CRDZ,PLANAR, &
                                   MD_ANGLE,RX_ANGLE,TR_OFF_X,TR_OFF_Y,      &
                                   TR_OFF_Z,N_PROFL,START_X,START_Y,START_Z, &
                                   PROFL_DIP,PROFL_PHI,N_STATN,STATN_DIST,   &
                                   NTX_FD,N_RX,RX_X,RX_Y,RX_Z,ZMT,M_RX,      &
                                   MT_PROFL,MT_STATN,XRMT,YRMT,NBODY,        &
                                   SUB_BLOCK,NX,NY,NZ,BLX,BLY,BLZ,XBL,YBL,   &
                                   ZBL,X1,Y1,Z1,DO_3D,NCT,NET,NCELL,         &
                                   NCTT,NEQ,XCELL,YCELL,ZCELL,KCELL,KBOUND,  &
                                   KSFT,KEYSF,KGHP,BLMIN)
!
!**** Initial computations
!
!   Set input parameters to those suitable for computation,
!   discretize the blocks into cell,  etc.
!
!   Note that after this routine is excuted,  the arrays BLX,  BLY,
!   and BLZ become the dimensions of the cells
!
!
! Input parameters:
!
!  DMIN:    Real,  minimal dimension value that is considered to be
!           zero.  DMIN=0.1 for the low frequency module and DMIN=0.001
!           for the high frequency module.
!  MBODY:   Integer(*4),  maximal number of substructures allowed in
!           the program.
!  NBMAX:   Integer,  maximal number of blocks allowed in a
!           substructure.  It is the maximum of SUB_BLOCK used for
!           array definitions.
!  NXMAX:   Integer,  maximal number of cells in the x-direction
!           in a block.
!  NYMAX:   Integer,  maximal number of cells in the y-direction
!           in a block.
!  NZMAX:   Integer,  maximal number of cells in the z-direction
!           in a block.
!  ZBND:    Real ZBND(0:MLAYER), the z-coordinates of the layer
!           boundaries with the air-earth interface being always
!           0 (zbnd(0)=0).
!  LRYTH:   Real LRYTH(MLAYER), the thickness of the layers.
!  CS_TYPE:    Integer,  type of excitation and configuration.
!           See documentation "MARCO.DOC" for description.
!  KSYMM:   Integer,  controlling parameter for the two-plane symmetry
!           fo the 3D model.  KSYMM=1:  symmetric model;  =0:  non-sym-
!           metric model.
!  RAD:     Real RAD(NTX_FD),  radius of the loops of the excitations.
!  RAD2:    Real,  radius of the loop for CS_TYPE=6.
!  NCRD:
!  TX_CRDX, TX_CRDY, TX_CRDZ: Real TX_CRDX(NCRD,NTX_FD), TX_CRDY(NCRD,NTX_FD),
!  TX_CRDZ(NCRD,NTX_FD):
!           coordinates of electrodes (the end points of current bipoles
!           or loop corners) or the center coordinates of a current loop
!           or a magnetic dipole for all the excitations.   For various
!           values of CS_TYPE,  the four elements for the first index of
!           TX_CRDX, TX_CRDY,  and TX_CRDZ contain the following information:
!           CS_TYPE =2, and 3:  the first two elements of TX_CRDX etc.
!                    represent the two electrodes of the bipoles;
!                =4: the arrays TX_CRDX etc. show the coordinates
!                    of the four corner of the rectangular loop.
!                =5, and 6: the first elements of TX_CRDX etc. contain the
!                    coordinates of the centre of the circular
!                    loop;  and
!                =7, 8, and 9: the first elements of TX_CRDX etc.
!                    contain the coordinates of the centre of the
!                    magnetic dipole.
!  NTX_FD:    Integer,  number of excitations.
!  N_RX:    Integer N_RX(NTX_FD),  number of receiver sites.
!  MT_STATN:    Integer,  number of receivers on one profile for MT probelms.
!  RX_X,RX_Y,RX_Z:  Real RX_X(M_RX,NTX_FD), RX_Y(M_RX,NTX_FD),
!           RX_Z(M_RX,NTX_FD), receiver sites coordinates in the x, y,
!           and z-directions for receiver sites,  respectively.
!  ZMT:     Real,  z coordinate of the measuring plane for MT stations.
!  M_RX:    Integer,  maximal number of receivers for controlled source
!           problems and maximal number of receivers on one profile for
!           MT problems.
!  MT_PROFL:    Integer,  number of profiles for MT problems.
!  XRMT:    Real XRMT(MT_PROFL),  x-coordinates of the MT profiles.
!  YRMT:    Real YRMT(MT_STATN),  y-coordinates of the MT profiles.
!  NBODY:   Integer,  number of substructures.
!  SUB_BLOCK:   Integer SUB_BLOCK(MBODY),  number of blocks in each substructure.
!  NX:      Integer NX(NBMAX,MBODY),  numbers of cells in the x-direction
!           in each block of the substructures.
!  NY:      Integer NY(NBMAX,MBODY),  numbers of cells in the y-direction
!           in each block of the substructures.
!  NZ:      Integer NZ(NBMAX,MBODY),  numbers of cells in the z-direction
!           in each block of the substructures.
!  BLX:     Real BLX(NBMAX,MBODY),  dimensions of each blocks of the
!           substructures in the x-direction.
!  BLY:     Real BLY(NBMAX,MBODY),  dimensions of each blocks of the
!           substructures in the y-direction.
!  BLZ:     Real BLZ(NBMAX,MBODY),  dimensions of each blocks of the
!           substructures in the z-direction.
!  XBL:     Real XBL(NBMAX,MBODY),  x-coordinates of each blocks in the
!           substructures.
!  YBL:     Real YBL(NBMAX,MBODY),  y-coordinates of each blocks in the
!           substructures.
!  ZBL:     Real ZBL(NBMAX,MBODY),  z-coordinates of each blocks in the
!           substructures.
!  X1, Y1, Z1: Real X1(NXMAX), Y1(NYMAX), Z1(NZMAX),  working arrays for
!           center coordinates of the cells.
!  DO_3D: Integer,  parameter controlling whether only 1D responses
!          are to be computed.  DO_3D=1: yes;  =0,  no.
!
!
! Output parameters:
!
!  HVK:     Real HVK(0:MLAYER), the anisotropy coefficients of
!           the layer conductivities as defined by the square
!           root of the ratio of horizontal conductivity to
!           vertical conductivity.  HVK(0)=1 is the output.
!  ZBND:    Real ZBND(0:MLAYER), the z-coordinates of the layer
!           boundaries with the air-earth interface being always
!           0 (zbnd(0)=0).
!  NCT:     Integer NCT(MBODY),  number of cells in each substructure.
!  NET:     Integer NET(MBODY),  number of unknowns in each substructure.
!           NET=3*NCT.
!  NCELL:   Integer NCELL(NBMAX,MBODY),  number of cells in each block
!           of the substructures.
!  NCT:     Integer,  total number of cells for the whole structure.
!  NEQ:     Integer,  total number of cells in one quadrant of a symmetric
!           model.
!  XCELL:   Real XCELL(NXMAX,NBMAX,MBODY),  x-coordinates of the cells.
!  YCELL:   Real YCELL(NYMAX,NBMAX,MBODY),  y-coordinates of the cells.
!  ZCELL:   Real ZCELL(NZMAX,NBMAX,MBODY),  z-coordinates of the cells.
!  KCELL:   Integer KCELL(MBODY), controlling parameter whether all cells
!           in each substructure are equal-sized.
!  KBOUND:  Integer,  parameter controlling whether the structure
!           intersects any layer boundary.  kbound=1: yes; =0: no.
!  KFST, KEYSF: Integer KFST, KEYSF(NBMAX,MBODY),  controlling parameters
!           whether there are outcropping cells for the whole structure
!           (KSFT) and for the blocks in each substructure (KEYSF).
!           KEYSF, KSFT=1: yes; KEYSF, KSFT=0:,no.
!  KGHP:    Integer, parameter controlling whether there is a receiver
!           located within the target.
!  BLMIN:   Real,  redius and height of a cylinder to be removed
!           from computation for the treatment of singularity
!           arising in the computation of magnetic fields due to
!           an outcropping cell.  See description for KUTCRP
!           in routine THR_D_GREEN for more details.
!  BLX:     Real BLX(NBMAX,MBODY),  dimensions of each cells of the
!           substructures in the x-direction.
!  BLY:     Real BLY(NBMAX,MBODY),  dimensions of each cells of the
!           substructures in the y-direction.
!  BLZ:     Real BLZ(NBMAX,MBODY),  dimensions of each cells of the
!           substructures in the z-direction.
!
!**** Called by:  main
!**** Calls:      none
!
!
      IMPLICIT NONE
!
      INTEGER II,I,IB,J,JB,K,KBOUND,KGHP,KSFT,CS_TYPE,KSYMM,L,MBODY,    &
              MLAYER,M_RX,NBMAX,NBODY,NCTT,NEQ,MT_PROFL,MT_STATN,NSR,NSR1,   &
              DO_3D,NTX_FD,NCRD,NXMAX,NYMAX,NZMAX,PLANAR,                    &
              NX(NBMAX,MBODY),NY(NBMAX,MBODY),NZ(NBMAX,MBODY),               &
              NCELL(NBMAX,MBODY),NCT(MBODY),NET(MBODY),                      &
              KCELL(MBODY),SUB_BLOCK(MBODY),KEYSF(NBMAX,MBODY),              &
              N_RX(NTX_FD),N_PROFL,N_STATN(N_PROFL)
      REAL BLMIN,DMIN,RAD2,XJ,YJ,ZJ,ZMT,LRYTH(MLAYER),                       &
           ZBND(0:MLAYER),HVK(0:MLAYER),XRMT(MT_PROFL),YRMT(MT_STATN),       &
           RX_X(M_RX,NTX_FD),RX_Y(M_RX,NTX_FD),RX_Z(M_RX,NTX_FD),RAD(NTX_FD),&
           TX_CRDX(NCRD,NTX_FD),TX_CRDY(NCRD,NTX_FD),TX_CRDZ(NCRD,NTX_FD),   &
           BLX(NBMAX,MBODY),BLY(NBMAX,MBODY),BLZ(NBMAX,MBODY),               &
           XBL(NBMAX,MBODY),YBL(NBMAX,MBODY),ZBL(NBMAX,MBODY),               &
           XCELL(NXMAX,NBMAX,MBODY),YCELL(NYMAX,NBMAX,MBODY),                &
           ZCELL(NZMAX,NBMAX,MBODY),X1(NXMAX),Y1(NYMAX),Z1(NZMAX),           &
           START_X(N_PROFL),START_Y(N_PROFL),START_Z(N_PROFL),               &
           PROFL_DIP(N_PROFL),PROFL_PHI(N_PROFL),STATN_DIST(N_PROFL),        &
           MD_ANGLE(2,NTX_FD),RX_ANGLE(2,1,NTX_FD),TR_OFF_X,TR_OFF_Y,        &
           TR_OFF_Z,PX,PY,PZ,DIP,AZIM
!
!-- The air is isotropic in conductivity
!
      HVK(0)=1.
!
! --- Contruct layer boundaries coordinates from layer thickness
!
      ZBND(0)=0.
      DO I=1,MLAYER-1
         ZBND(I)=ZBND(I-1)+LRYTH(I)
      ENDDO
!
! --- Transform the input parameters for CS_TYPE=6, 7, and 8 into
!   those suitable for computation
!
      IF (CS_TYPE==6.OR.CS_TYPE==7.OR.CS_TYPE==8) THEN
         IF (CS_TYPE==6) THEN
            DO I=1,NTX_FD
               RAD(I)=RAD2
            ENDDO
         ENDIF
         II=0
         DO I=1,N_PROFL
            DO J=1,N_STATN(I)
               II=II+1
               DIP=PROFL_DIP(I)/180.*3.14159265359
               AZIM=PROFL_PHI(I)/180.*3.14159265359
               PX=SIN(DIP)*COS(AZIM)
               PY=SIN(DIP)*SIN(AZIM)
               PZ=COS(DIP)
               TX_CRDX(1,II)=START_X(I)+(J-1)*STATN_DIST(I)*PX
               TX_CRDY(1,II)=START_Y(I)+(J-1)*STATN_DIST(I)*PY
               TX_CRDZ(1,II)=START_Z(I)+(J-1)*STATN_DIST(I)*PZ
               RX_X(1,II)=TX_CRDX(1,II)+TR_OFF_X
               RX_Y(1,II)=TX_CRDY(1,II)+TR_OFF_Y
               RX_Z(1,II)=TX_CRDZ(1,II)+TR_OFF_Z
               IF (CS_TYPE==7) THEN
                  MD_ANGLE(1,II)=PROFL_DIP(I)
                  MD_ANGLE(2,II)=PROFL_PHI(I)
               ENDIF
               IF (CS_TYPE==8) THEN
                  IF (PLANAR==1) THEN
                     MD_ANGLE(1,II)=90.
                     MD_ANGLE(2,II)=PROFL_PHI(I)-90.
                  ELSE
                     MD_ANGLE(1,II)=PROFL_DIP(I)-90.
                     MD_ANGLE(2,II)=PROFL_PHI(I)
                  ENDIF
               ENDIF
!
!   -- Receiver angles are identical as the profile angles
!
               RX_ANGLE(1,1,II)=PROFL_DIP(I)
               RX_ANGLE(2,1,II)=PROFL_PHI(I)
            ENDDO
         ENDDO
      ENDIF
!
!***** Return if compute 1D only
!
      IF (DO_3D==0) THEN
         RETURN
      ENDIF
!
      NCTT=0
      DO IB=1,NBODY
         NCT(IB)=0
         DO I=1,SUB_BLOCK(IB)
            NCELL(I,IB)=NX(I,IB)*NY(I,IB)*NZ(I,IB)
            NCT(IB)=NCT(IB)+NCELL(I,IB)
         ENDDO
!
         NET(IB)=3*NCT(IB)
         NCTT=NCTT+NCT(IB)
      ENDDO
!
! ---- NEQ is the total number of cells in a quater used by
!    group theoretical reduction
!
      IF (KSYMM==1.AND.CS_TYPE/=1) THEN
         NEQ=0
         DO IB=1,NBODY
            NEQ=NEQ+NET(IB)
         ENDDO
      ENDIF
!
! ----- Dividing the blocks into cells
!
      DO IB=1,NBODY
         DO I=1,SUB_BLOCK(IB)
            CALL INIT_DISCRETIZATION(BLX(I,IB),BLY(I,IB),BLZ(I,IB),NX(I,IB), &
                                     NY(I,IB),NZ(I,IB),XBL(I,IB),YBL(I,IB),  &
                                     ZBL(I,IB),X1,Y1,Z1)
! ----- Note BLX BLY and BLZ become now the dimensions of the cells
            DO J=1,NX(I,IB)
               XCELL(J,I,IB)=X1(J)
            ENDDO
            DO J=1,NY(I,IB)
               YCELL(J,I,IB)=Y1(J)
            ENDDO
            DO J=1,NZ(I,IB)
               ZCELL(J,I,IB)=Z1(J)
            ENDDO
         ENDDO
      ENDDO
!
!
! --- Determine if all the cells in a substructure have the same size.
!   KCELL(ib)=1: yes; KCELL(ib)=0: no.
      DO IB=1,NBODY
         KCELL(IB)=1
         DO L=2,SUB_BLOCK(IB)
            IF (ABS(BLX(L,IB)-BLX(1,IB))>DMIN.OR.  &
                ABS(BLY(L,IB)-BLY(1,IB))>DMIN.OR.  &
                ABS(BLZ(L,IB)-BLZ(1,IB))>DMIN) KCELL(IB)=0
         ENDDO
      ENDDO
!
!
! ----- Check if the structure intersects any layer boundary.
!     kbound=1: yes; =0: no.
!
      KBOUND=0
      DO IB=1,NBODY
         DO L=1,SUB_BLOCK(IB)
            DO I=1,NZ(L,IB)
               DO J=MLAYER-1,0,-1
                  IF (ZCELL(I,L,IB)>=ZBND(J)) THEN
                     NSR=J+1
                     GOTO 10
                  ENDIF
               ENDDO
               NSR=0
   10          IF (IB==1.AND.L==1.AND.I==1) THEN
                  NSR1=NSR
                  CYCLE
               ENDIF
               IF (NSR/=NSR1) THEN
                  KBOUND=1
                  GOTO 100
               ENDIF
            ENDDO
         ENDDO
      ENDDO
!
! --- Determine if there are any outcropping blocks
!   KEYSF, KSFT=1: yes; KEYSF, KSFT=0:,no.
!
  100 DO I=1,NBODY
         DO L=1,SUB_BLOCK(I)
            IF (ABS(ZCELL(1,L,I)-.5*BLZ(L,I))<DMIN) THEN
               KEYSF(L,I)=1
            ELSE
               KEYSF(L,I)=0
            ENDIF
         ENDDO
      ENDDO
      KSFT=0
      DO I=1,NBODY
         DO L=1,SUB_BLOCK(I)
            IF (KEYSF(L,I)==1) THEN
               KSFT=1
               GOTO 200
            ENDIF
         ENDDO
      ENDDO
!
! ---- Determine if there are downhole receivers that are
!    located in the 3D structure.  If so, of if the structure
!    outcrops, the Green's functions, (especially the magnetic
!    Green's function), will be separated into primary and
!    secondary parts in computation.
!
!    kghp=1: no receiver within the body; =0: yes.
!
!    Note the parameter kghp has been disabled lately.
!    Now the Green's functions are no more separated into
!    primary and secondary terms in computing the EM fields
!    at receiver sites.  The following design for kghp is
!    still perserved.  But it is not effective.
!
  200 KGHP=1
!
      IF (KSFT==1) THEN
         KGHP=0
         GOTO 300
      ENDIF
!
      IF (CS_TYPE==1) THEN
!
         IF (ZMT>=DMIN) THEN
!
!---  Check if any receivers are located on the top or within
!     the body if zmt >0.
!
            KGHP=1
!
            DO JB=1,NBODY
               DO J=1,SUB_BLOCK(JB)
! ---  Note that blx, bly and blz are the dimensions of the cells
!      after discretization.
                  XJ=.5*BLX(J,JB)*NX(J,JB)+DMIN
                  YJ=.5*BLY(J,JB)*NY(J,JB)+DMIN
                  ZJ=.5*BLZ(J,JB)*NZ(J,JB)+DMIN
                  DO I=1,MT_PROFL
                     DO K=1,MT_STATN
                        IF (XRMT(I)>XBL(J,JB)-XJ.AND.XRMT(I)<XBL(J,JB)   &
                            +XJ.AND.YRMT(K)>YBL(J,JB)-YJ.AND.YRMT(K)     &
                            <YBL(J,JB)+YJ.AND.ZMT>ZBL(J,JB)-ZJ.AND.      &
                            ZMT<ZBL(J,JB)+ZJ) THEN
                           KGHP=0
                           GOTO 300
                        ENDIF
                     ENDDO
                  ENDDO
               ENDDO
!
            ENDDO
         ENDIF
         GOTO 300
      ENDIF
!
!---  Check downhole receivers
!
      DO JB=1,NBODY
         DO J=1,SUB_BLOCK(JB)
! --  Note that blx, bly and blz are the dimensions of the cells
!   after discretization.
            XJ=.5*BLX(J,JB)*NX(J,JB)+DMIN
            YJ=.5*BLY(J,JB)*NY(J,JB)+DMIN
            ZJ=.5*BLZ(J,JB)*NZ(J,JB)+DMIN
            DO II=1,NTX_FD
               DO I=1,N_RX(II)
                  IF (RX_X(I,II)>XBL(J,JB)-XJ.AND.RX_X(I,II)<XBL(J,JB)   &
                      +XJ.AND.RX_Y(I,II)>YBL(J,JB)-YJ.AND.RX_Y(I,II)     &
                      <YBL(J,JB)+YJ.AND.RX_Z(I,II)>ZBL(J,JB)-ZJ.AND.     &
                      RX_Z(I,II)<ZBL(J,JB)+ZJ) THEN
                     KGHP=0
                     GOTO 300
                  ENDIF
               ENDDO
            ENDDO
         ENDDO
      ENDDO
!
! ---- In case of outcropping structures a minmal length, blmin,
!    is determined which is the radius and the height of a
!    small cylinder to be excluded in the numerical integration
!    of the magnetic Green's functions for the treatments of
!    singularities when the receiver is located on the top of
!    an outcropping cell. Note that the electric fields on the
!    top of outcropping cells are determined be the scattering
!    currents directly.
!
!    Note that blmin is also used for vertical bipole
!    excitations. In order to avoid singularity that may occur
!    due to inapproperiate discretizations of the structures
!    which makes some cell centers coincide with the source
!    lines, the current lines may be cut into many intervals
!    with a distance of blmin to the receivers of cell centers.
!
  300 BLMIN=100000.
      DO IB=1,NBODY
         DO L=1,SUB_BLOCK(IB)
            BLMIN=AMIN1(BLMIN,BLX(L,IB),BLY(L,IB),BLZ(L,IB))
         ENDDO
      ENDDO
!
!--- Take one tenth of the minimal dimension as blmin
!
      BLMIN=BLMIN/10.

!
      RETURN
      END
!
!**** End of INIT_COMPUTATION
!
!
   SUBROUTINE INIT_CONVERT (CS_TYPE,NTX_FD,NCRD,N_SIDE,N_RX,M_RX,DO_3D,      &
                            CONV_3D,TRGT_BLCK,TX_CRDX,TX_CRDY,TX_CRDZ,RX_X,  &
                            RX_Y,RX_Z,TR_OFF_X,TR_OFF_Y,N_PROFL,START_X,     &
                            START_Y,START_Z,BLCK_LX,BLCK_LY,BLCK_CX,         &
                            BLCK_CY,BLCK_CZ,BLCK_NX,BLCK_NY)
!
!**** Convert the input coordinate system to the coordinate system
!     for computation
!
!     The input data coordinate syste:   X -- East
!                                        Y -- North
!                                        Z -- Upward
!     The computation coordinate syste:  X -- North
!                                        Y -- East
!                                        Z -- Down
!
!     Note that this conversion is done only for controlled source problems.
!     For MT applications input the data in a coordinate system identical to
!     actual computation.
!
!*** Called by:  Main
!
      IMPLICIT NONE
!
      INTEGER, INTENT(IN) :: CS_TYPE,NTX_FD,NCRD,N_SIDE(NTX_FD),N_RX(NTX_FD), &
                             M_RX,DO_3D,TRGT_BLCK,CONV_3D,N_PROFL
      INTEGER, INTENT(INOUT) :: BLCK_NX(TRGT_BLCK),BLCK_NY(TRGT_BLCK)
      REAL, INTENT(INOUT) :: TX_CRDX(NCRD,NTX_FD),TX_CRDY(NCRD,NTX_FD),       &
                             TX_CRDZ(NCRD,NTX_FD),RX_X(M_RX,NTX_FD),          &
                             RX_Y(M_RX,NTX_FD),RX_Z(M_RX,NTX_FD),             &
                             BLCK_LX(TRGT_BLCK),BLCK_LY(TRGT_BLCK),           &
                             BLCK_CX(TRGT_BLCK),BLCK_CY(TRGT_BLCK),           &
                             BLCK_CZ(TRGT_BLCK),                              &
                             TR_OFF_X,TR_OFF_Y,START_X(N_PROFL),              &
                             START_Y(N_PROFL),START_Z(N_PROFL)
!
      INTEGER :: I,J,NN
      REAL    :: XYSWAP
!
      DO I=1,NTX_FD
         IF (CS_TYPE==4) NN=N_SIDE(I)
         IF (CS_TYPE/=4) NN=NCRD
         DO J=1,NN
            XYSWAP=TX_CRDX(J,I)
            TX_CRDX(J,I)=TX_CRDY(J,I)
            TX_CRDY(J,I)=XYSWAP
            TX_CRDZ(J,I)=-TX_CRDZ(J,I)
         ENDDO
         DO J=1,N_RX(I)
            XYSWAP=RX_X(J,I)
            RX_X(J,I)=RX_Y(J,I)
            RX_Y(J,I)=XYSWAP
            RX_Z(J,I)=-RX_Z(J,I)
         ENDDO
      ENDDO
!
      IF (CS_TYPE==6.OR.CS_TYPE==7.OR.CS_TYPE==8) THEN
         XYSWAP=TR_OFF_X
         TR_OFF_X=TR_OFF_Y
         TR_OFF_Y=XYSWAP
         DO I=1,N_PROFL
            XYSWAP=START_X(I)
            START_X(I)=START_Y(I)
            START_Y(I)=XYSWAP
            START_Z(I)=-START_Z(I)
         ENDDO
      ENDIF
!
      IF (DO_3D==1.AND.CONV_3D==1) THEN
         DO I=1,TRGT_BLCK
            XYSWAP=BLCK_LX(I)
            BLCK_LX(I)=BLCK_LY(I)
            BLCK_LY(I)=XYSWAP
            XYSWAP=BLCK_CX(I)
            BLCK_CX(I)=BLCK_CY(I)
            BLCK_CY(I)=XYSWAP
            J=BLCK_NX(I)
            BLCK_NX(I)=BLCK_NY(I)
            BLCK_NY(I)=J
!  -- Note that BLCK_CZ etc. need not be converted since it is the depth to the
!     earth's surface that is input.  It ISN'T a relative level.
            BLCK_CZ(I)=0+BLCK_CZ(I)
         ENDDO
      ENDIF
!
   END SUBROUTINE INIT_CONVERT
!
!
   SUBROUTINE INIT_GROUND (SURFACE_RL,NTX_FD,N_RX,M_RX,TRGT_BLCK,      &
                           TX_CRDZ,RX_Z,BLCK_CZ,DO_3D,CONV_3D,PM)
!
!*** Convert the input coordinate system to the coordinate system for computation
!
!    PM =  1 : before computation
!    PM = -1 : after computation
!
!*** Called by:  Main
!
      IMPLICIT NONE
!
      INTEGER, INTENT(IN) :: NTX_FD,N_RX(NTX_FD),M_RX,TRGT_BLCK,   &
                             DO_3D,CONV_3D,PM
      REAL, INTENT(INOUT) :: TX_CRDZ(1,NTX_FD),RX_Z(M_RX,NTX_FD),  &
                             BLCK_CZ(TRGT_BLCK),SURFACE_RL
!
      INTEGER :: I,J
!
      DO I=1,NTX_FD
         TX_CRDZ(1,I)=PM*SURFACE_RL+TX_CRDZ(1,I)
         DO J=1,N_RX(I)
            RX_Z(J,I)=PM*SURFACE_RL+RX_Z(J,I)
         ENDDO
      ENDDO
!
      IF (DO_3D==1.AND.CONV_3D==1) THEN
         DO I=1,TRGT_BLCK
            BLCK_CZ(I)=PM*SURFACE_RL+BLCK_CZ(I)
         ENDDO
      ENDIF
!
   END SUBROUTINE INIT_GROUND
!
!
      SUBROUTINE INIT_INPUT_TEST(NW,INCL_DIELEC,DO_3D,KACC,KAUTO,CS_TYPE,   &
                                 KTEM,NFRQ,FRQM,NTX_FD,                     &
                                 M_RX,NCRD,TX_CRDX,TX_CRDY,TX_CRDZ,KSYMM,   &
                                 DMIN,NSUBCM,NSBM,MBODY,NBMAX,NXMAX,NYMAX,  &
                                 NZMAX,TRGT_BLCK,NBODY,SUB_BLOCK,BLCK_LX,   &
                                 BLCK_LY,BLCK_LZ,BLCK_CX,BLCK_CY,BLCK_CZ,   &
                                 NCT,NX,NY,NZ,BLX,BLY,BLZ,XBL,YBL,ZBL,      &
                                 MLAYER,ZBND,ZCELL)
!
!**** The input data are tested to make sure that they are correct
!     and lie within designed limits
!
!     Parameters NXMAX etc. are to be passed into routine INIT_3D_INPUT_TEST.
!     Other input parameters for this routine are the same as those
!     in the routine READATA.
!
!**** Called by: main
!
!**** Calls:     INIT_3D_INPUT_TEST
!
!
      IMPLICIT NONE
!
!
      REAL DMIN
      INTEGER J,KACC,KAUTO,INCL_DIELEC,CS_TYPE,KSYMM,KTEM,MBODY,         &
              MLAYER,M_RX,NBMAX,NBODY,NFRQ,NW,NCRD
      INTEGER TRGT_BLCK,NSBM,NSUBCM,DO_3D,NTX_FD,      &
              NXMAX,NYMAX,NZMAX
      INTEGER NX(NBMAX,MBODY),NY(NBMAX,MBODY),NZ(NBMAX,MBODY),           &
              SUB_BLOCK(MBODY),NCT(MBODY)
      REAL BLCK_LX(NSBM),BLCK_LY(NSBM),BLCK_LZ(NSBM),                    &
           BLCK_CX(NSBM),BLCK_CY(NSBM),BLCK_CZ(NSBM),                    &
           BLX(NBMAX,MBODY),BLY(NBMAX,MBODY),BLZ(NBMAX,MBODY),           &
           XBL(NBMAX,MBODY),YBL(NBMAX,MBODY),ZBL(NBMAX,MBODY),           &
           ZCELL(NZMAX,NBMAX,MBODY),FRQM(NFRQ)
      REAL ZBND(0:MLAYER)
      REAL TX_CRDX(NCRD,M_RX),TX_CRDY(NCRD,M_RX),TX_CRDZ(NCRD,M_RX)
!
! --- Check the consistency of the frequency range with INCL_DIELEC value
!
      IF (MAXVAL(FRQM)>50.E6) WRITE (NW,1010)
      IF (MAXVAL(FRQM)> 1.E6 .AND. INCL_DIELEC==0) WRITE (NW,1020)
!
! --- No time domain solutions for plane wave excitations.
!
      IF (CS_TYPE==1.AND.KTEM/=0) THEN
         KTEM=0
         WRITE (NW,1030)
         WRITE (*,1030)
      ENDIF
!
      IF (CS_TYPE/=1.AND.CS_TYPE/=6.AND.CS_TYPE/=7.AND.CS_TYPE/=8        &
          .AND.NTX_FD<=0) THEN
         WRITE (NW,*) 'Error: NTX_FD must be  > 0. ', ' Input NTX_FD=',NTX_FD
         STOP   &
             'Program aborted. Please check the error messages in OUTPUT.OUT'
      ENDIF
!
! -- Test if vertical bipoles are strictly vertical
!
      IF (CS_TYPE==2) THEN
!
         DO J=1,NTX_FD
!
!-- DMIN is the parameter for round-off errors
!
            IF (ABS(TX_CRDZ(1,J)-TX_CRDZ(2,J))>DMIN.AND.  &
                ABS(TX_CRDX(1,J)-TX_CRDX(2,J))<DMIN.AND.  &
                ABS(TX_CRDY(1,J)-TX_CRDY(2,J))<DMIN) THEN
               CYCLE
            ENDIF
            WRITE (NW,*)   &
                      'Error: The coordinates of the electrodes do not '  &
                      ,'imply a current in the z-direction!'
            STOP   &
             'Program aborted. Please check the error messages in OUTPUT.OUT'
!
         ENDDO
!
      ENDIF
!
      IF (DO_3D==1) THEN
!
         IF (KACC<1.OR.KACC>5) THEN
            WRITE (NW,*) ' There are five accuracy levels only.',  &
                         ' KACC should be >= 1 and <= 5.',  &
                         ' Program aborted.'
            STOP   &
             'Program aborted. Please check the error messages in OUTPUT.OUT'
         ENDIF
         WRITE (NW,*) ' '
         IF (KTEM==1) WRITE (9,*) ' '
         IF (KACC==1) THEN
            WRITE (NW,*) 'The following are approximate solutions! '
            IF (KTEM==1) WRITE (9,*)  &
                 'The following are approximate solutions! '
         ELSE
!            WRITE (NW,*) 'Accuracy level: ',KACC
            IF (KTEM==1) WRITE (9,*) 'Accuracy level: ',KACC
         ENDIF
         IF (KACC==1.AND.KAUTO==0) THEN
            WRITE (*,1040)
            WRITE (NW,1040)
         ENDIF
!
      ENDIF
!
      IF (DO_3D==1)                                                           &
         CALL INIT_3D_INPUT_TEST(NW,KAUTO,KSYMM,DMIN,NSUBCM,NSBM,MBODY,NBMAX, &
                                 NXMAX,NYMAX,NZMAX,NBODY,TRGT_BLCK,BLCK_LX,   &
                                 BLCK_LY,BLCK_LZ,BLCK_CX,BLCK_CY,BLCK_CZ,NCT, &
                                 SUB_BLOCK,NX,NY,NZ,BLX,BLY,BLZ,XBL,YBL,ZBL,  &
                                 MLAYER,ZBND,ZCELL)
!
      WRITE (*,*) ' '
      WRITE (*,*) 'Input data passed elementary tests.  Computation begins ...'
!
      RETURN
 1010 FORMAT (/'Warning: frequency range exceeds designed limit!',   &
              /'Results may not be accurate enough at high frequencies.')
 1020 FORMAT (/'Warning: frequency range exceeds designed limit for ', &
               'INCL_DIELEC=0 !',/'Use INCL_DIELEC=1 and recompute.')
 1030 FORMAT (/'Warning: No time domain solutions for plane wave ',  &
              'excitations.  KTEM adjusted to 0.')
 1040 FORMAT (/,'It is suggested to use automatic division of ',     &
              'substructures to compute',/,                          &
              'approximate solutions with KAUTO=1 ',                 &
              'in order to achieve maximal efficiency!')
!
      END SUBROUTINE INIT_INPUT_TEST
!
!
      SUBROUTINE INIT_3D_INPUT_TEST(NW,KAUTO,KSYMM,DMIN,NSUBCM,NSBM,MBODY,   &
                                    NBMAX,NXMAX,NYMAX,NZMAX,NBODY,TRGT_BLCK, &
                                    BLCK_LX,BLCK_LY,BLCK_LZ,BLCK_CX,BLCK_CY, &
                                    BLCK_CZ,NCT,SUB_BLOCK,NX,NY,NZ,BLX,BLY,  &
                                    BLZ,XBL,YBL,ZBL,MLAYER,ZBND,ZCELL)
!
!**** Test 3D data
!
!Input parameters:
!
!  NXMAX:   Integer(*4),  maximal number of cells in the x-direction
!           in a block.
!  NYMAX:   Integer(*4),  maximal number of cells in the y-direction
!           in a block.
!  NZMAX:   Integer(*4),  maximal number of cells in the z-direction
!           in a block.
!
!Other parameters for this routine are the same as those in routine
!READATA.
!
!**** Called by:  INIT_INPUT_TEST
!
!**** Calls:      none
!
!
      IMPLICIT NONE
!
      REAL DMIN,RR1,XI,XJ,YI,YJ,ZI,ZJ
      INTEGER I,IB,II,J,JB,JJ,K,KAUTO,KEYBZ,KK,KSYMM,L,MBODY,MLAYER,   &
              NBMAX,NBODY,TRGT_BLCK,NSBM,NSR,NSR1,NW
      INTEGER NSUBCM,NXMAX,NYMAX,NZMAX
      INTEGER NX(NBMAX,MBODY),NY(NBMAX,MBODY),NZ(NBMAX,MBODY),         &
              SUB_BLOCK(MBODY),NCT(MBODY)
      REAL BLCK_LX(NSBM),BLCK_LY(NSBM),BLCK_LZ(NSBM),                  &
           BLCK_CX(NSBM),BLCK_CY(NSBM),BLCK_CZ(NSBM),                  &
           BLX(NBMAX,MBODY),BLY(NBMAX,MBODY),BLZ(NBMAX,MBODY),         &
           XBL(NBMAX,MBODY),YBL(NBMAX,MBODY),ZBL(NBMAX,MBODY),         &
           ZCELL(NZMAX,NBMAX,MBODY)
      REAL ZBND(0:MLAYER)
!
      IF (KAUTO/=0) THEN
!**************************************************
!*                                                *
!
! --- Test if there is a block out of quadrant
!
         IF (KSYMM==1) THEN
            DO I=1,TRGT_BLCK
               IF (BLCK_CX(I)-.5*BLCK_LX(I)<-.0001.OR.      &
                   BLCK_CY(I)-.5*BLCK_LY(I)<-.0001) THEN
                  WRITE (NW,*) ' Block #',I,' is out of quadrant I. ',  &
                         ' Program aborted. Please check the input'
                  STOP   &
             'Program aborted. Please check the error messages in OUTPUT.OUT'
               ENDIF
            ENDDO
         ENDIF
!
! ----- Test if the blocks overlap each other
!
         DO I=1,TRGT_BLCK
            DO J=1,TRGT_BLCK
!
               IF (I/=J) THEN
!
                  XJ=.5*BLCK_LX(J)-DMIN
                  YJ=.5*BLCK_LY(J)-DMIN
                  ZJ=.5*BLCK_LZ(J)-DMIN
                  DO II=1,5
                     DO JJ=1,5
                        DO KK=1,5
                           XI=BLCK_CX(I)-.5*BLCK_LX(I)+BLCK_LX(I)*(II-1.)/4.
                           YI=BLCK_CY(I)-.5*BLCK_LY(I)+BLCK_LY(I)*(JJ-1.)/4.
                           ZI=BLCK_CZ(I)-.5*BLCK_LZ(I)+BLCK_LZ(I)*(KK-1.)/4.
                           IF (XI>BLCK_CX(J)-XJ.AND.XI<BLCK_CX(J)+XJ.AND.  &
                               YI>BLCK_CY(J)-YJ.AND.YI<BLCK_CY(J)+YJ.AND.  &
                               ZI>BLCK_CZ(J)-ZJ.AND.ZI<BLCK_CZ(J)+ZJ) THEN
                               WRITE (NW,*) ' Block #',I,  &
                                 ' overlaps with block #',J
                               WRITE (NW,*)   &
                              'Program aborted.  Please check the input'
                              STOP   &
             'Program aborted. Please check the error messages in OUTPUT.OUT'
                           ENDIF
                        ENDDO
                     ENDDO
                  ENDDO
               ENDIF
!
            ENDDO
         ENDDO
!*                                                *
!**************************************************
      ENDIF
!
      IF (KAUTO==0) THEN
!**************************************************
!*                                                *
         IF (KSYMM==1) THEN
!-------------------------------------------
!|                                         |
            DO IB=1,NBODY
               DO I=1,SUB_BLOCK(IB)
                  IF (XBL(I,IB)-.5*BLX(I,IB)<-.0001.OR.YBL(I,IB)  &
                      -.5*BLY(I,IB)<-.0001) THEN
                     WRITE (NW,*) ' Block #',I,' of substructure #',IB,  &
                            ' is out of quadrant I. ',  &
                            ' Program aborted. Please check the input'
                     STOP   &
             'Program aborted. Please check the error messages in OUTPUT.OUT'
                  ENDIF
               ENDDO
            ENDDO
!|                                         |
!-------------------------------------------
         ELSE
!-------------------------------------------
!|                                         |
            DO IB=1,NBODY
               DO I=1,SUB_BLOCK(IB)
                  IF (NX(I,IB)>NXMAX.OR.NY(I,IB)>NYMAX.OR.NZ(I,IB)      &
                      >NZMAX) THEN
                     WRITE (NW,*)  &
                             'Cell number in one of the x, y, and z-',  &
                            'direction exceeds the limit.'
                     WRITE (NW,*) 'Program aborted ',  &
                            'Please check the input'
                     WRITE (NW,*)   &
                           'Advice: if you need more cells, please use '  &
                           ,'more blocks.'
                     WRITE (NW,*) 'The limits are set for each block alone.'
                     STOP   &
             'Program aborted. Please check the error messages in OUTPUT.OUT'
                  ENDIF
               ENDDO
            ENDDO
!
! ----- Test if the blocks overlap each other
!
            DO IB=1,NBODY
               DO I=1,SUB_BLOCK(IB)
                  DO JB=1,NBODY
                     DO J=1,SUB_BLOCK(JB)
!
                        IF (IB/=JB.OR.I/=J) THEN
!
                           XJ=.5*BLX(J,JB)-DMIN
                           YJ=.5*BLY(J,JB)-DMIN
                           ZJ=.5*BLZ(J,JB)-DMIN
                           DO II=1,5
                              DO JJ=1,5
                              DO KK=1,5
                              XI=XBL(I,IB)-.5*BLX(I,IB)+BLX(I,IB)*(II-1.)/4.
                              YI=YBL(I,IB)-.5*BLY(I,IB)+BLY(I,IB)*(JJ-1.)/4.
                              ZI=ZBL(I,IB)-.5*BLZ(I,IB)+BLZ(I,IB)*(KK-1.)/4.
                              IF (XI>XBL(J,JB)-XJ.AND.XI<XBL(J,JB)           &
                                  +XJ.AND.YI>YBL(J,JB)-YJ.AND.               &
                                  YI<YBL(J,JB)+YJ.AND.ZI>ZBL(J,JB)           &
                                  -ZJ.AND.ZI<ZBL(J,JB)+ZJ) THEN
                              WRITE (NW,*) ' Block #',I,                     &
                                 ' of substructure #',IB,                    &
                                 ' overlaps with block #',J,                 &
                                 ' of substructure #',JB,                    &
                              'Program aborted.  Please check the input'
                              STOP   &
             'Program aborted. Please check the error messages in OUTPUT.OUT'
                              ENDIF
                              ENDDO
                              ENDDO
                           ENDDO
                        ENDIF
!
                     ENDDO
                  ENDDO
               ENDDO
            ENDDO
!|                                         |
!-------------------------------------------
         ENDIF
!*                                                *
!**************************************************
      ENDIF
!
      DO IB=1,NBODY
         IF (NCT(IB)>NSUBCM) THEN
            WRITE (NW,*) ' Total number of cells of a substructure',  &
                         ' exceeds maximum allowed!  Program aborted.'
            STOP   &
             'Program aborted. Please check the error messages in OUTPUT.OUT'
         ENDIF
      ENDDO
!
! --- Check if there is any cell across a layer boundary.
!   KEYBZ=1: yes; KEYBZ=0: no.
      KEYBZ=0
      DO IB=1,NBODY
         DO L=1,SUB_BLOCK(IB)
            DO I=1,NZ(L,IB)
               DO J=MLAYER-1,0,-1
! ---  In order to increase stability .499 is used here instead of .5
                  IF (ZCELL(I,L,IB)-.499*BLZ(L,IB)>=ZBND(J)) THEN
                     NSR=J+1
                     GOTO 10
                  ENDIF
               ENDDO
               NSR=0
   10          DO J=MLAYER-1,0,-1
                  IF (ZCELL(I,L,IB)+.499*BLZ(L,IB)>=ZBND(J)) THEN
                     NSR1=J+1
                     GOTO 20
                  ENDIF
               ENDDO
               NSR1=0
   20          IF (NSR/=NSR1) THEN
                  KEYBZ=1
                  GOTO 100
               ENDIF
            ENDDO
         ENDDO
      ENDDO
!
! ---- It is not allowed to have a cell lying across any layer
!   boundary due to the restrictions arising from the separation
!   of the Green's functions into primary and secondary parts.
!
  100 IF (KEYBZ==1) THEN
         WRITE (NW,*) ' It is not allowed to have a cell across a',       &
                      ' layer boundary.  Please re-discretize the body',  &
                      ' in the z-direction.'
         STOP   &
             'Program aborted. Please check the error messages in OUTPUT.OUT'
      ENDIF
!
! ---- No outcroping above the earth's surface is allowed
!
!    Tests have shown that the current version is not capable of
!    modeling models in free space
!
      DO IB=1,NBODY
         DO L=1,SUB_BLOCK(IB)
            DO K=1,NZ(L,IB)
               RR1=ZCELL(K,L,IB)-.5*BLZ(L,IB)
               IF (RR1<-.001) THEN
                  WRITE (NW,*) ' A block is above the earths surface.',  &
                         ' Please check the input.  Program aborted.'
                  STOP   &
             'Program aborted. Please check the error messages in OUTPUT.OUT'
               ENDIF
            ENDDO
         ENDDO
      ENDDO
!
!
      END SUBROUTINE INIT_3D_INPUT_TEST
!
!**** End of INIT_3D_INPUT_TEST
!
!
      SUBROUTINE INIT_DISCRETIZATION (BLX,BLY,BLZ,NX,NY,NZ,XCD,YCD,ZCD,X,Y,Z)
!
!*****  Discretize a blck into equal-size cells
!
      IMPLICIT NONE
!
      REAL BLX,BLY,BLZ,X,XCD,Y,YCD,Z,ZCD
      INTEGER I,N1,NX,NY,NZ
      DIMENSION X(NX),Y(NY),Z(NZ)
      BLX=BLX/FLOAT(NX)
      BLY=BLY/FLOAT(NY)
      BLZ=BLZ/FLOAT(NZ)
      IF (ABS(AMOD(FLOAT(NX),2.))<.2) THEN
         N1=NX/2
         DO I=1,NX
            X(I)=BLX*(FLOAT(I)-FLOAT(N1))-BLX/2.+XCD
         ENDDO
      ELSE
         N1=NX/2+1
         DO I=1,NX
            X(I)=BLX*(I-N1)+XCD
         ENDDO
      ENDIF
      IF (ABS(AMOD(FLOAT(NY),2.))<.2) THEN
         N1=NY/2
         DO I=1,NY
            Y(I)=BLY*(FLOAT(I)-FLOAT(N1)-.5)+YCD
         ENDDO
      ELSE
         N1=NY/2+1
         DO I=1,NY
            Y(I)=BLY*(FLOAT(I)-FLOAT(N1))+YCD
         ENDDO
      ENDIF
      IF (ABS(AMOD(FLOAT(NZ),2.))<.2) THEN
         N1=NZ/2
         DO I=1,NZ
            Z(I)=BLZ*(FLOAT(I)-FLOAT(N1)-.5)+ZCD
         ENDDO
      ELSE
         N1=NZ/2+1
         DO I=1,NZ
            Z(I)=BLZ*(FLOAT(I)-FLOAT(N1))+ZCD
         ENDDO
      ENDIF
      RETURN
      END
!
!
      SUBROUTINE INIT_REF_CELL_DIM(NW,MBODY,NBMAX,NBODY,SUB_BLOCK,   &
                                   BLX,BLY,BLZ,DMIN,KCLMN,CLMN)
!
!**** Determine the reference length for numerical integration
!   of the Green's functions as required by the accuracy levels
!   determined by teh paramter KACC.
!
!   If clmn(ib)=0., it is then replaced by the default value which
!   is chosen as follows. The code finds at first two cells with
!   maximal diagonal lengths. Note that in each block the cells
!   have the same size. Let the dimensions of one of these two cells,
!   blx1, bly1, and blz1 be arranged in an increasing order, say,
!   blx1<=bly1<=blz1, then the mediate length of the cell is bly1.
!   The mediate length of the other cell can be found in the same
!   way. The value of clmn(ib) is then the average of those two
!   mediate lengths.
!
!   Note that clmn takes its value for each substructure.
!
!
!Input parameters:
!
!  MBODY:   Integer(*4),  maximal number of substructures allowed in
!           the program.
!  NBMAX:   Integer,  maximal number of blocks allowed in a
!           substructure.  It is the maximum of SUB_BLOCK used for
!           array definitions.
!  NBODY:   Integer,  number of substructures.
!  SUB_BLOCK:  Integer SUB_BLOCK(MBODY),  number of blocks in each substructure.
!  BLX:     Real BLX(NBMAX,MBODY),  dimensions of each blocks of the
!           substructures in the x-direction.
!  BLY:     Real BLY(NBMAX,MBODY),  dimensions of each blocks of the
!           substructures in the y-direction.
!  BLZ:     Real BLZ(NBMAX,MBODY),  dimensions of each blocks of the
!           substructures in the z-direction.
!  DMIN:    Real,  minimal dimension value that is considered to be
!           zero.  DMIN=0.1 for the low frequency module and DMIN=0.001
!           for the high frequency module.
!  KCLMN:   Integer,  parameter controlling whether values for CLMN
!           need to be input or to be set automatically by this routine.
!
!Output parameters:
!
!  CLMN:    Real CLMN(MBODY),  the reference lengths in each substructure.
!
!
!**** Called by:  main
!
!**** Calls:      none
!
!
      IMPLICIT NONE
!
      REAL AA1,AA2,CL1,CLMN1,CLMN2,CLXM,CLYM,CLZM,DMIN
      INTEGER IB,KCLMN,L,LL,LM,LMN,LN,MBODY,NBMAX,NBODY,NW
      REAL BLX(NBMAX,MBODY),BLY(NBMAX,MBODY),BLZ(NBMAX,MBODY),CLMN(MBODY)
      INTEGER SUB_BLOCK(MBODY)
!
      DO IB=1,NBODY
!
         IF (KCLMN==0) CLMN(IB)=0.
!
! ---- cl1 is the diagonal length of a cell
         CL1=SQRT(BLX(1,IB)**2+BLY(1,IB)**2+BLZ(1,IB)**2)
         LMN=1
         CLXM=BLX(1,IB)
         CLYM=BLY(1,IB)
         CLZM=BLZ(1,IB)
         DO L=2,SUB_BLOCK(IB)
            AA1=SQRT(BLX(L,IB)**2+BLY(L,IB)**2+BLZ(L,IB)**2)
            IF (CL1<AA1) THEN
               CL1=AA1
               CLXM=BLX(L,IB)
               CLYM=BLY(L,IB)
               CLZM=BLZ(L,IB)
               LMN=L
            ENDIF
         ENDDO
!
         LL=1
!
   50    AA1=AMAX1(CLXM,CLYM,CLZM)
         AA2=AMIN1(CLXM,CLYM,CLZM)
!
         IF (ABS(CLXM-AA1)<=DMIN) LM=1
         IF (ABS(CLYM-AA1)<=DMIN) LM=2
         IF (ABS(CLZM-AA1)<=DMIN) LM=3
         IF (ABS(CLXM-AA2)<=DMIN) LN=1
         IF (ABS(CLYM-AA2)<=DMIN) LN=2
         IF (ABS(CLZM-AA2)<=DMIN) LN=3
!
         IF (LM==2) THEN
!
            IF (LN==2) THEN
               CLMN1=CLYM
            ELSEIF (LN==3) THEN
               CLMN1=CLXM
            ELSE
               CLMN1=CLZM
            ENDIF
         ELSEIF (LM==3) THEN
!
            IF (LN==2) THEN
               CLMN1=CLXM
            ELSEIF (LN==3) THEN
               CLMN1=CLZM
            ELSE
               CLMN1=CLYM
            ENDIF
!
         ELSEIF (LN==2) THEN
            CLMN1=CLZM
         ELSEIF (LN==3) THEN
            CLMN1=CLYM
         ELSE
            CLMN1=CLXM
         ENDIF
!
         IF (SUB_BLOCK(IB)/=1) THEN
            IF (LL==1) THEN
!
! ---- Determine the second mediate length
               CL1=0.
               DO L=1,SUB_BLOCK(IB)
                  IF (L/=LMN) THEN
                     AA1=SQRT(BLX(L,IB)**2+BLY(L,IB)**2+BLZ(L,IB)**2)
                     IF (CL1<AA1) THEN
                        CL1=AA1
                        CLXM=BLX(L,IB)
                        CLYM=BLY(L,IB)
                        CLZM=BLZ(L,IB)
                     ENDIF
                  ENDIF
               ENDDO
!
               CLMN2=CLMN1
               LL=2
               GOTO 50
!
            ELSE
               CLMN1=(CLMN1+CLMN2)/2.
!
            ENDIF
         ENDIF
         IF (CLMN(IB)<.0) THEN
            WRITE (NW,*) ' Warning: negative CLMN entered, replaced',  &
                         ' by default value.'
         ENDIF
         IF (CLMN(IB)<DMIN) CLMN(IB)=CLMN1
         IF (CLMN(IB)<CLMN1) THEN
            WRITE (NW,1010) IB
            WRITE (*,1010) IB
         ENDIF
!
      ENDDO
!
      RETURN
 1010 FORMAT (' Warning: entered CLMN for substructure #',I3,  &
              ' is less than the default value',               &
              /'  (average of the mediate lengths ',           &
              'of two biggest cells).',/'   Number of steps ', &
              'in numerical integrations increases.')
      END
!
!**** End of INIT_REF_CELL_DIM
!
!
      SUBROUTINE INIT_SUPER_BLOCK(NW,MBODY,NBMAX,NSMR,KSYMM,DMIN,NXMAX,NYMAX, &
                                  NZMAX,NBODY,SUB_BLOCK,BLX,BLY,BLZ,NX,NY,NZ, &
                                  XBL,YBL,ZBL,XCELL,YCELL,ZCELL,SBX,SBY,SBZ,  &
                                  XSB,YSB,ZSB,SCX,SCY,SCZ,NXS,NYS,NZS,KSMR)
!
!**** Determine the super block for the spatial symmetry reductions
!
!   This routine find the super block that contains all the
!   structural blocks of the 3D body.  All disrectized cells
!   must coincide with the cells of the super block to facilitate
!   the spatial symmetry reduction.
!
!   Note that unlike in routine INIT_COMPUTATION, the arrays BLX,  BLY,
!   and BLZ containes the dimensions of the cells instead of the
!   blocks.
!
!Input parameters:
!
!  MBODY:   Integer(*4), the maximal number of substructures allowed
!           in the program.
!  NBMAX:   Integer,  the maximal number of blocks allowed in a
!           substructure.  It is the maximum of SUB_BLOCK used for
!           array definitions.
!  NSMR:    Integer,  the maximal number of non-identical elements
!           for the scattering matrix which is determined by the
!           paramters NZSR, NZOB and NHFILM of the code.  See the corresponding
!           paramter list in the main program for detail.
!  KSYMM:   Integer,  controlling parameter for the two-plane symmetry
!           fo the 3D model.  KSYMM=1:  symmetric model;  =0:  non-sym-
!           metric model.
!  DMIN:    Real,  minimal dimension value that is considered to be
!           zero.  DMIN=0.1 for the low frequency module and DMIN=0.001
!           for the high frequency module.
!  NXMAX:   Integer,  maximal number of cells in the x-direction
!           in a block.
!  NYMAX:   Integer,  maximal number of cells in the y-direction
!           in a block.
!  NZMAX:   Integer,  maximal number of cells in the z-direction
!           in a block.
!  NBODY:   Integer,  number of substructures.
!  SUB_BLOCK:  Integer SUB_BLOCK(MBODY),  number of blocks in each substructure.
!  BLX:     Real BLX(NBMAX,MBODY),  dimensions of each cells of the
!           substructures in the x-direction.
!  BLY:     Real BLY(NBMAX,MBODY),  dimensions of each cells of the
!           substructures in the y-direction.
!  BLZ:     Real BLZ(NBMAX,MBODY),  dimensions of each cells of the
!           substructures in the z-direction.
!  NX:      Integer NX(NBMAX,MBODY),  numbers of cells in the x-direction
!           in each block of the substructures.
!  NY:      Integer NY(NBMAX,MBODY),  numbers of cells in the y-direction
!           in each block of the substructures.
!  NZ:      Integer NZ(NBMAX,MBODY),  numbers of cells in the z-direction
!           in each block of the substructures.
!  XBL:     Real XBL(NBMAX,MBODY),  x-coordinates of each blocks in the
!           substructures.
!  YBL:     Real YBL(NBMAX,MBODY),  y-coordinates of each blocks in the
!           substructures.
!  ZBL:     Real ZBL(NBMAX,MBODY),  z-coordinates of each blocks in the
!           substructures.
!  XCELL:   Real XCELL(NXMAX,NBMAX,MBODY),  x-coordinates of the cells.
!  YCELL:   Real YCELL(NYMAX,NBMAX,MBODY),  y-coordinates of the cells.
!  ZCELL:   Real ZCELL(NZMAX,NBMAX,MBODY),  z-coordinates of the cells.
!
!
!Output parameters:
!
!  SBX:     Real,  dimension of the super block in the x-direction.
!  SBY:     Real,  dimension of the super block in the y-direction.
!  SBZ:     Real,  dimension of the super block in the z-direction.
!  XSB:     Real,  x-ccordinate of the superblock.
!  YSB:     Real,  y-ccordinate of the superblock.
!  ZSB:     Real,  z-ccordinate of the superblock.
!  SCX:     Real,  dimension the cells of the super block in the
!           x-direction.
!  SCY:     Real,  dimension the cells of the super block in the
!           y-direction.
!  SCZ:     Real,  dimension the cells of the super block in the
!           z-direction.
!  NXS:     Integer,  number of cells in the x-direction of the superblock.
!  NYS:     Integer,  number of cells in the y-direction of the superblock.
!  NZS:     Integer,  number of cells in the z-direction of the superblock.
!  KSMR:    Integer,  controlling parameter whether spatial symmetry can
!           be used or not.  KSMR=1:  yes;  =0:  no.
!
!**** Called by:  main
!
!**** Calls:      none
!
!
      IMPLICIT NONE
!
      REAL DMIN,SBX,SBX1,SBX2,SBY,SBY1,SBY2,SBZ,SBZ1,SBZ2,SCX,SCY,SCZ,   &
           XI,XSB,YI,YSB,ZI,ZSB
      INTEGER I,IB,II,J,JB,JJ,K,KCELLT,KK,KSMR,KSYMM,L,MBODY,NBMAX,      &
              NBODY,NSMR,NXMAX,NXS,NYMAX,NYS,NW
      INTEGER NZMAX,NZS
      INTEGER SUB_BLOCK(MBODY),NX(NBMAX,MBODY),NY(NBMAX,MBODY),NZ(NBMAX,MBODY)
      REAL BLX(NBMAX,MBODY),BLY(NBMAX,MBODY),BLZ(NBMAX,MBODY),           &
           XBL(NBMAX,MBODY),YBL(NBMAX,MBODY),ZBL(NBMAX,MBODY),           &
           XCELL(NXMAX,NBMAX,MBODY),YCELL(NYMAX,NBMAX,MBODY),            &
           ZCELL(NZMAX,NBMAX,MBODY)
! ---- Determine if the spatial symmetry reduction can be used
!
! --- Determine if all the cells have the same size.
!   KCELLT=1: yes; =0: no
!
      KCELLT=1
      DO IB=1,NBODY
         DO L=1,SUB_BLOCK(IB)
            IF (IB/=1.OR.L/=1) THEN
               IF (ABS(BLX(L,IB)-BLX(1,1))>DMIN.OR.  &
                   ABS(BLY(L,IB)-BLY(1,1))>DMIN.OR.  &
                   ABS(BLZ(L,IB)-BLZ(1,1))>DMIN) THEN
                  KCELLT=0
                  GOTO 100
               ENDIF
            ENDIF
         ENDDO
      ENDDO
!
! --- If all the cells have the same size (kcellt=1), great saving
!   can be achieved by spatial symmetry reduction in forming the
!   scattering matrix.
!
!
!-- Find the dimension of the super block.
!   Note that the parameters blx etc. are the cell dimensions now
!   xbl etc. are still the coordinates of the blocks.
!
      SBX1=100000.
      SBY1=100000.
      SBZ1=100000.
      SBX2=-100000.
      SBY2=-100000.
      SBZ2=-100000.
!
      DO IB=1,NBODY
         DO L=1,SUB_BLOCK(IB)
            SBX1=AMIN1(SBX1,XBL(L,IB)-.5*BLX(L,IB)*NX(L,IB))
            SBX2=AMAX1(SBX2,XBL(L,IB)+.5*BLX(L,IB)*NX(L,IB))
            SBY1=AMIN1(SBY1,YBL(L,IB)-.5*BLY(L,IB)*NY(L,IB))
            SBY2=AMAX1(SBY2,YBL(L,IB)+.5*BLY(L,IB)*NY(L,IB))
            SBZ1=AMIN1(SBZ1,ZBL(L,IB)-.5*BLZ(L,IB)*NZ(L,IB))
            SBZ2=AMAX1(SBZ2,ZBL(L,IB)+.5*BLZ(L,IB)*NZ(L,IB))
         ENDDO
      ENDDO
!
      SBX=SBX2-SBX1
      SBY=SBY2-SBY1
      SBZ=SBZ2-SBZ1
!
!-- For symmetric structures the super block need to include
!   the block that are not input.  The super block must also
!   include the full region covered by the SBX2 instead of
!   SBX2-SBX1
!
      IF (KSYMM==1) THEN
         SBX=2.*SBX2
         SBY=2.*SBY2
      ENDIF
!
!-- Determine the center coordinates of the super block
!
      IF (KSYMM==0) THEN
         XSB=SBX2-.5*SBX
         YSB=SBY2-.5*SBY
      ELSE
         XSB=0.
         YSB=0.
      ENDIF
      ZSB=SBZ2-.5*SBZ
!
!-- Determine the number of cells of the super block
!
      NXS=INT(SBX/BLX(1,1)+.2)
      NYS=INT(SBY/BLY(1,1)+.2)
      NZS=INT(SBZ/BLZ(1,1)+.2)
!
!-- Check if all cells coincide with the cells of the super block.
!   If so, the symmetry reduction can be used, and the parameter
!   KSMR is set to be 1.  Otherwise, the symmetry reduction cannot
!   be used even if kcellt=1, and KSMR is assigned a 0.
!
!   This may be done by comparing the dimensions of a cell of the
!   super block and the dimensions of a cell of the original body.
!   But such a check may fail if a block in between does not coincide
!   with the super block cells.
!
!   Note the blocks in other three quadrants for a symmetric
!   structure need not be tested since the super block automatically
!   contain them by reflection.
!
!-- Compute the cell dimension of the super block
!
      SCX=SBX/NXS
      SCY=SBY/NYS
      SCZ=SBZ/NZS
!
      DO IB=1,NBODY
         DO L=1,SUB_BLOCK(IB)
!
            DO I=1,NX(L,IB)
               DO J=1,NY(L,IB)
                  DO K=1,NZ(L,IB)
                     DO II=1,NXS
                        DO JJ=1,NYS
                           DO KK=1,NZS
                              XI=XSB-.5*SBX+.5*SCX+(II-1)*SCX
                              YI=YSB-.5*SBY+.5*SCY+(JJ-1)*SCY
                              ZI=ZSB-.5*SBZ+.5*SCZ+(KK-1)*SCZ
                              IF (ABS(XI-XCELL(I,L,IB))<DMIN.AND.  &
                                  ABS(YI-YCELL(J,L,IB))<DMIN.AND.  &
                                  ABS(ZI-ZCELL(K,L,IB))<DMIN) THEN
                              GOTO 5
                              ENDIF
!
                           ENDDO
                        ENDDO
                     ENDDO
!
!-- If any cell of the original body fails to identify a cell
!   from the super block, ksmr=0
!
                     KSMR=0
!
                     WRITE (*,1010) XCELL(I,L,IB),YCELL(I,L,IB),ZCELL(I,L,IB)
                     WRITE (NW,1010) XCELL(I,L,IB),YCELL(I,L,IB),ZCELL(I,L,IB)
!
!-- Patial use of the spatial symmetry may be possible for
!   substructures with one block
!
                     IF (KSYMM==0) THEN
                        DO JB=1,NBODY
                           IF (SUB_BLOCK(JB)==1) THEN
                              WRITE (*,1020) JB
                              WRITE (NW,1020) JB
                           ENDIF
                        ENDDO
                     ENDIF
!
                     GOTO 100
!
    5             ENDDO
               ENDDO
            ENDDO
         ENDDO
      ENDDO
!
!-- Now that all cells passed the test, namely, all cells have
!   successfully identified a cell from the super block, symmetry
!   reduction can be used
!
      KSMR=1
!
! ** The following is disfunctioned in F90 version.  Only the value
!    of NSMR is returned instead
!
! -- Final check on the total number of cells of the super block.
!    Symmetry reduction can be used only if it is within the
!    designed limit.
!
!      IF (9*NXS*NYS*NZS*(NZS+1)/2<=NSMR) THEN
!         WRITE (*,1030)
!         WRITE (NW,1030)
!      ELSE
!         KSMR=0
!         WRITE (*,1040)
!         WRITE (NW,1040)
!      ENDIF
!
  100 IF (KCELLT==0) KSMR=0
!
      NSMR=9*NXS*NYS*NZS*(NZS+1)/2
!
      RETURN
 1010 FORMAT ('The spatial symmetry reduction cannot be used ',            &
              'for the whole body',                                        &
              /'because the cell with the coordinates',/'   (',3F14.5,     &
              ' )',/'does not coincide with any cell of the ',             &
              'super block.',                                              &
              /'You may need to re-discretize the body if you ',           &
              /'still wish to use the spatial symmetry reduction.')
 1020 FORMAT (/'Partial use of spatial symmetry reduction for ',           &
              'substructure #',I4)
! 1030 FORMAT (/'  --- Spatial symmetry reduction used ! ---')
! 1040 FORMAT (/'  --- Total number of the non-identical elements of ',     &
!              'scattering matrix ',                                        &
!              /'      for the super block exceeds maximum desigen',        &
!              /'      Spatial symmetry reduction cannot be used !',        &
!              /'      You may need to reduce the number of cells, ',       &
!              /'      especially in the vertical direction in order to ',  &
!              /'      facilitate spatial symmetry reduction')
      END
!
!**** End of INIT_SUPER_BLOCK
!
!
      SUBROUTINE INIT_SCALING(MBODY,NBMAX,NXMAX,NYMAX,NZMAX,      &
                              CS_TYPE,KSYMM,KTEM,DO_3D,NFRQM,NFRQ,FRQM,NBODY, &
                              SUB_BLOCK,NX,NY,NZ,XCELL,YCELL,ZCELL,BLX,BLY,   &
                              BLZ,XBL,YBL,ZBL,SBX,SBY,SBZ,SCX,SCY,SCZ,XSB,    &
                              YSB,ZSB,NZOB,ZOBG,NZSR,ZSRG,NSRCS,ZSRCS,NOBCS,  &
                              ZOBCS,NTX_FD,RAD,NCRD,N_SIDE,TX_CRDX,TX_CRDY,   &
                              TX_CRDZ,TR_OFF_X,TR_OFF_Y,TR_OFF_Z,N_PROFL,     &
                              START_X,START_Y,START_Z,N_STATN,STATN_DIST,     &
                              N_RX,RX_X,RX_Y,RX_Z,BLMIN,ZMT,M_RX,MT_PROFL,    &
                              MT_STATN,XRMT,YRMT,MLAYER,ZBND,LRYTH,RHOMIN,    &
                              RMAX1,RMIN1,RMAX2,RMIN2,CLMN,SCALE)
!
!**** Scale the model down to within 100 km if it exceeds this limit
!
!   The grids for the Hankel integral is limited to be less than
!   100 km.  If a model configuation exceeds this limit,  as this
!   may often happen in MT applications,  all dimensions will be
!   reduced according to the scaling law,  i.e.,  the frequency
!   will be increased.  This design is most useful for MT applications.
!
!
! Input parameters:
!
!  MBODY:   Integer,  maximal number of substructures allowed in the
!           program.
!  NBMAX:   Integer,  maximal number of blocks allowed in a
!           substructure.  It is the maximum of SUB_BLOCK used for
!           array definitions.
!  NXMAX:   Integer,  maximal number of cells in the x-direction
!           in a block.
!  NYMAX:   Integer,  maximal number of cells in the y-direction
!           in a block.
!  NZMAX:   Integer,  maximal number of cells in the z-direction
!           in a block.
!  CS_TYPE:    Integer,  type of excitation and configuration.
!           See documentation "MARCO.DOC" for description.
!  KSYMM:   Integer,  controlling parameter for the two-plane symmetry
!           fo the 3D model.  KSYMM=1:  symmetric model;  =0:  non-sym-
!           metric model.
!  KTEM:    Integer,  controlling parameter for the frequency domain or
!           the time domain computation.
!           KTEM = 0:  the frequency domain;  and
!                = 1:  the time domain.
!  DO_3D: Integer,  parameter controlling whether only 1D responses
!          are to be computed.  DO_3D=1: yes;  =0,  no.
!  NFRQM:   Integer,  maximal number of frequencies (allowed by the code).
!  NFRQ:    Integer,  number of frequencies.
!  FRQM:    Real FRQM(NFRQ), array for the frequencies.
!  NBODY:   Integer,  number of substructures.
!  SUB_BLOCK:  Integer SUB_BLOCK(MBODY),  number of blocks in each substructure.
!  NX:      Integer NX(NBMAX,MBODY),  numbers of cells in the x-direction
!           in each block of the substructures.
!  NY:      Integer NY(NBMAX,MBODY),  numbers of cells in the y-direction
!           in each block of the substructures.
!  NZ:      Integer NZ(NBMAX,MBODY),  numbers of cells in the z-direction
!           in each block of the substructures.
!  XCELL:   Real XCELL(NXMAX,NBMAX,MBODY),  x-coordinates of the cells.
!  YCELL:   Real YCELL(NYMAX,NBMAX,MBODY),  y-coordinates of the cells.
!  ZCELL:   Real ZCELL(NZMAX,NBMAX,MBODY),  z-coordinates of the cells.
!  BLX:     Real BLX(NBMAX,MBODY),  dimensions of each cells of the
!           substructures in the x-direction.
!  BLY:     Real BLY(NBMAX,MBODY),  dimensions of each cells of the
!           substructures in the y-direction.
!  BLZ:     Real BLZ(NBMAX,MBODY),  dimensions of each cells of the
!           substructures in the z-direction.
!  XBL:     Real XBL(NBMAX,MBODY),  x-coordinates of each blocks in the
!           substructures.
!  YBL:     Real YBL(NBMAX,MBODY),  y-coordinates of each blocks in the
!           substructures.
!  ZBL:     Real ZBL(NBMAX,MBODY),  z-coordinates of each blocks in the
!           substructures.
!  SBX:     Real,  dimension of the super block in the x-direction.
!  SBY:     Real,  dimension of the super block in the y-direction.
!  SBZ:     Real,  dimension of the super block in the z-direction.
!  SCX:     Real,  dimension the cells of the super block in the
!           x-direction.
!  SCY:     Real,  dimension the cells of the super block in the
!           y-direction.
!  SCZ:     Real,  dimension the cells of the super block in the
!           z-direction.
!  XSB:     Real,  x-ccordinate of the superblock.
!  YSB:     Real,  y-ccordinate of the superblock.
!  ZSB:     Real,  z-ccordinate of the superblock.
!  NZOB:    Integer, number of z-levels for the cells of the 3D body.
!  ZOBG:    Real ZOBG(NZOB), the coordinates of the nzob z-levels
!           for the cells of the 3D body.
!  NZSR:    Integer,  number of z'-levels for the cells of the 3D body.
!  ZSRG:    Real ZSRG(2,NZSR), the coordinates of the nzob z-levels
!           for the cells of the 3D body.
!  NSRCS:    Integer,  number of z-levels for the excitation sources.
!  ZSRCS:   Real ZSRCS(2,NSRCS),  the coordinates of the nzcs z'-levels
!           for the excitation sources.
!  NOBCS:   Integer,  number of z-levels for the receivers.
!  ZOBCS:   Real ZOBCS(NOBCS),  the coordinates of the nzcs z-levels
!           for the excitation sources.
!  NTX_FD:    Integer,  nubmer of excitations.
!  RAD:     Real RAD(NTX_FD),  radius of the loops.
!  NCRD:    Integer,  nubmer of electrodes or number of different coordinates
!           for the source configuration per excitation.
!  TX_CRDX, TX_CRDY, TX_CRDZ: Real TX_CRDX(NCRD,NTX_FD), TX_CRDY(NCRD,NTX_FD),
!  TX_CRDZ(NCRD,NTX_FD):
!           coordinates of electrodes (the end points of current bipoles
!           or loop corners) or the center coordinates of a current loop
!           or a magnetic dipole for all the excitations.   For various
!           values of CS_TYPE,  the four elements for the first index of
!           TX_CRDX, TX_CRDY,  and TX_CRDZ contain the following information:
!           CS_TYPE =2, and 3:  the first two elements of TX_CRDX etc.
!                    represent the two electrodes of the bipoles;
!                =4: the arrays TX_CRDX etc. show the coordinates
!                    of the four corner of the rectangular loop.
!                =5, and 6: the first elements of TX_CRDX etc. contain the
!                    coordinates of the centre of the circular
!                    loop;  and
!                =7, 8, and 9: the first elements of TX_CRDX etc.
!                    contain the coordinates of the centre of the
!                    magnetic dipole.
!  RX_X,RX_Y,RX_Z:  Real RX_X(M_RX,NTX_FD), RX_Y(M_RX,NTX_FD),
!           RX_Z(M_RX,NTX_FD),  receiver sites coordinates in the
!           x, y, and z-directions the receivers of each excitation.
!  BLMIN:   Real,  redius and height of a cylinder to be removed
!           from computation for the treatment of singularity
!           arising in the computation of magnetic fields due to
!           an outcropping cell.
!  ZMT:     Real,  z coordinate of the measuring plane for MT stations.
!  N_RX:    Integer N_RX(NTX_FD),  number of receivers for each excitation.
!  MT_PROFL:    Integer,  number of profiles for MT problems.
!  M_RX:    Integer,  maximal number of receivers for controlled source
!           problems and maximal number of receivers on one profile for
!           MT problems.
!  MT_STATN:    Integer,  number of receivers on one profile for MT probelms.
!  XRMT:    Real XRMT(MT_PROFL),  x-coordinates of the MT profiles.
!  YRMT:    Real YRMT(MT_STATN),  y-coordinates of the MT profiles.
!  MLAYER:  Integer, the number of layers including the air.
!  ZBND:    Real ZBND(0:MLAYER), the z-coordinates of the layer
!           boundaries with the air-earth interface being always
!           0 (zbnd(0)=0).
!  LRYTH:   Real LRYTH(MLAYER), the thickness of the layers.
!  RHOMIN:  Real,  minimum of the lateral grid (rho) which determines
!           the minimum of rho in the Hankel integrals.  RHOMIN=0.1 for
!           the low frequency mdule and RHOMIN=0.01 for the high
!           frequency module.
!  RMAX1:   Real,  the maximum of the geometric dimensions of the model
!           in the lateral direction.
!  RMIN1:   Real,  the minimum of the geometric dimensions of the model
!           in the lateral direction.
!  RMAX2:   Real,  the maximum of the geometric dimensions of the model
!           including the reciever stations in the lateral direction for
!           MT applications.
!  RMIN2:   Real,  the minimum of the geometric dimensions of the model
!           including the reciever stations in the lateral direction for
!           MT applications.
!  CLMN:    Real CLMN(MBODY),  the reference lengths in each substructure.
!
!
!Output parameter:
!
!  SCALE:   Real,  the scaling ratio.
!
!
!**** Called by:  main
!
!**** Calls:      none
!
!
      IMPLICIT NONE
!
      REAL BLMIN,RHOMIN,RMAX,RMAX1,RMAX2,RMIN1,RMIN2,RR1,RR2,RR3,RR4,         &
           RR5,SBX,SBY,SBZ,SCALE,SCX,SCY,SCZ,SX,SY,XSB,YSB,ZMT,ZSB
      INTEGER I,IB,IB2,II,J,JJ,CS_TYPE,KSYMM,KTEM,L,LL,LSYM,                  &
              MBODY,MLAYER,M_RX,NBMAX,NBODY,NCRD,JX,NN,NFRQ,NFRQM,NOBCS,      &
              MT_PROFL,MT_STATN,NSYM,DO_3D,NTX_FD,NXMAX,NYMAX,NSRCS,NZMAX,    &
              NZOB,NZSR,NX(NBMAX,MBODY),NY(NBMAX,MBODY),NZ(NBMAX,MBODY),      &
              SUB_BLOCK(MBODY),N_RX(NTX_FD),N_SIDE(NTX_FD),                   &
              N_PROFL,N_STATN(N_PROFL)
      REAL ZBND(0:MLAYER),LRYTH(MLAYER),CLMN(MBODY),FRQM(NFRQM),              &
           BLX(NBMAX,MBODY),BLY(NBMAX,MBODY),BLZ(NBMAX,MBODY),                &
           XBL(NBMAX,MBODY),YBL(NBMAX,MBODY),ZBL(NBMAX,MBODY),                &
           XCELL(NXMAX,NBMAX,MBODY),YCELL(NYMAX,NBMAX,MBODY),                 &
           ZCELL(NZMAX,NBMAX,MBODY),XRMT(MT_PROFL),YRMT(MT_STATN),            &
           RX_X(M_RX,NTX_FD),RX_Y(M_RX,NTX_FD),RX_Z(M_RX,NTX_FD),             &
           RAD(NTX_FD),TX_CRDX(NCRD,NTX_FD),TX_CRDY(NCRD,NTX_FD),             &
           TX_CRDZ(NCRD,NTX_FD),ZOBG(NZOB),ZSRG(2,NZSR),                      &
           ZOBCS(NOBCS),ZSRCS(2,NSRCS),START_X(N_PROFL),START_Y(N_PROFL),     &
           START_Z(N_PROFL),STATN_DIST(N_PROFL),TR_OFF_X,TR_OFF_Y,TR_OFF_Z
!
!
! ---- Determine the maximal dimensions of the structure in
!    the lateral direction (the range of Rho).
!    The minimum should always be rhomin
!
      IF (DO_3D==1) THEN
!
         RMAX=0.
         DO IB=1,NBODY
            DO L=1,SUB_BLOCK(IB)
               DO I=1,NX(L,IB)
                  DO J=1,NY(L,IB)
                     DO IB2=1,NBODY
                        DO LL=1,SUB_BLOCK(IB2)
                           DO II=1,NX(LL,IB2)
                              DO JJ=1,NY(LL,IB2)
                              IF (IB/=IB2.OR.L/=LL.OR.I/=II.OR.J/=JJ) THEN
                                 RR1=SQRT((XCELL(I,L,IB)-XCELL(II,LL,IB2))    &
                                     **2+(YCELL(J,L,IB)-YCELL(JJ,LL,IB2))**2)
                              ENDIF
                              RR2=SQRT((ABS(XCELL(I,L,IB)-XCELL(II,LL,IB2))   &
                                  +.5*BLX(LL,IB2))**2+(ABS(YCELL(J,L,IB)-     &
                                  YCELL(JJ,LL,IB2)))**2)
                              RR3=SQRT((ABS(XCELL(I,L,IB)-XCELL(II,LL,IB2))   &
                                  -.5*BLX(LL,IB2))**2+(ABS(YCELL(J,L,IB)-     &
                                  YCELL(JJ,LL,IB2)))**2)
                              RR4=SQRT((ABS(XCELL(I,L,IB)-XCELL(II,LL,IB2)))  &
                                  **2+(ABS(YCELL(J,L,IB)-YCELL(JJ,LL,IB2))    &
                                  +.5*BLY(LL,IB2))**2)
                              RR5=SQRT((ABS(XCELL(I,L,IB)-XCELL(II,LL,IB2)))  &
                                  **2+(ABS(YCELL(J,L,IB)-YCELL(JJ,LL,IB2))    &
                                  -.5*BLY(LL,IB2))**2)
                              RMAX=MAX(RR1,RR2,RR3,RR4,RR5,RMAX)
                              IF (KSYMM==1) THEN
                              RR2=SQRT((ABS(XCELL(I,L,IB)+XCELL(II,LL,IB2))   &
                                  +.5*BLX(LL,IB2))**2+(ABS(YCELL(J,L,IB)+     &
                                  YCELL(JJ,LL,IB2))+.5*BLY(LL,IB2))**2)
                              IF (RR2>RMAX) RMAX=RR2
                              ENDIF
                              ENDDO
                           ENDDO
                        ENDDO
                     ENDDO
                  ENDDO
               ENDDO
            ENDDO
         ENDDO
!
         RMIN2=RHOMIN
         RMAX2=RMAX
!
      ENDIF
!
! --- Determine the maximal source-receiver and target-receiver
!     distances
!
      IF (CS_TYPE/=1) THEN
!****************************************
!*                                      *
!
! -- Determine the maximal source-receiver distance
!
         RMAX=0.
         DO I=1,NTX_FD
            DO JJ=1,N_RX(I)
!
! -- Note that circular loops are checked by their maximal and
!    minimal wire locations.
!
               IF (CS_TYPE==5.OR.CS_TYPE==6) THEN
                  RR1=SQRT((RX_X(JJ,I)-TX_CRDX(1,I))**2+                &
                           (RX_Y(JJ,I)-TX_CRDY(1,I))**2)
                  RR2=SQRT((RX_X(JJ,I)-TX_CRDX(1,I)-RAD(I))**2+         &
                           (RX_Y(JJ,I)-TX_CRDY(1,I)-RAD(I))**2)
                  RR3=SQRT((RX_X(JJ,I)-TX_CRDX(1,I)+RAD(I))**2+         &
                           (RX_Y(JJ,I)-TX_CRDY(1,I)-RAD(I))**2)
                  RR4=SQRT((RX_X(JJ,I)-TX_CRDX(1,I)-RAD(I))**2+         &
                           (RX_Y(JJ,I)-TX_CRDY(1,I)+RAD(I))**2)
                  RR5=SQRT((RX_X(JJ,I)-TX_CRDX(1,I)+RAD(I))**2+         &
                           (RX_Y(JJ,I)-TX_CRDY(1,I)+RAD(I))**2)
                  RMAX=MAX(RR1,RR2,RR3,RR4,RR5,RMAX)
               ELSE
                  IF (CS_TYPE/=4) NN=NCRD
                  IF (CS_TYPE==4) NN=N_SIDE(I)
                  DO J=1,NN
                     RR1=SQRT((RX_X(JJ,I)-TX_CRDX(J,I))**2+             &
                              (RX_Y(JJ,I)-TX_CRDY(J,I))**2)
                     IF (RR1>RMAX) RMAX=RR1
                  ENDDO
               ENDIF
            ENDDO
         ENDDO
!
         RMAX1=RMAX
!
         IF (DO_3D==1) THEN
!
!-- Determine maximal source-target distance
!
            RMAX=0.
            DO IB=1,NBODY
            DO L=1,SUB_BLOCK(IB)
            DO I=1,NX(L,IB)
            DO J=1,NY(L,IB)
               IF (KSYMM==0) THEN
                  NSYM=1
               ELSE
                  NSYM=4
               ENDIF
               DO LSYM=1,NSYM
                  IF (LSYM==1) THEN
                    SX=1.
                    SY=1.
                  ENDIF
                  IF (LSYM==2) THEN
                    SX=-1.
                    SY=1.
                  ENDIF
                  IF (LSYM==3) THEN
                    SX=1.
                    SY=-1.
                  ENDIF
                  IF (LSYM==4) THEN
                    SX=-1.
                    SY=-1.
                  ENDIF
                  DO JX=1,NTX_FD
                     IF (CS_TYPE==5.OR.CS_TYPE==6) THEN
                        RR1=SQRT((TX_CRDX(1,JX)-XCELL(I,L,IB))**2+            &
                                 (TX_CRDY(1,JX)-YCELL(J,L,IB))**2)
                        RR2=SQRT((TX_CRDX(1,JX)+RAD(JX)-XCELL(I,L,IB))**2+    &
                                 (TX_CRDY(1,JX)+RAD(JX)-YCELL(J,L,IB))**2)
                        RR3=SQRT((TX_CRDX(1,JX)-RAD(JX)-XCELL(I,L,IB))**2+    &
                                 (TX_CRDY(1,JX)+RAD(JX)-YCELL(J,L,IB))**2)
                        RR4=SQRT((TX_CRDX(1,JX)+RAD(JX)-XCELL(I,L,IB))**2+    &
                                 (TX_CRDY(1,JX)-RAD(JX)-YCELL(J,L,IB))**2)
                        RR5=SQRT((TX_CRDX(1,JX)-RAD(JX)-XCELL(I,L,IB))**2+    &
                                 (TX_CRDY(1,JX)-RAD(JX)-YCELL(J,L,IB))**2)
                        RMAX=MAX(RR1,RR2,RR3,RR4,RR5,RMAX)
                     ELSE
                        IF (CS_TYPE/=4) NN=NCRD
                        IF (CS_TYPE==4) NN=N_SIDE(JX)
                        DO JJ=1,NN
                           RR1=SQRT((TX_CRDX(JJ,JX)-XCELL(I,L,IB))**2+      &
                                    (TX_CRDY(JJ,JX)-YCELL(J,L,IB))**2)
                           RR2=SQRT((ABS(TX_CRDX(JJ,JX)-SX*XCELL(I,L,IB))   &
                               +.5*BLX(L,IB))**2+(ABS(TX_CRDY(JJ,JX)-       &
                               SY*YCELL(J,L,IB)))**2)
                           RR3=SQRT((ABS(TX_CRDX(JJ,JX)-SX*XCELL(I,L,IB))   &
                               -.5*BLX(L,IB))**2+(ABS(TX_CRDY(JJ,JX)-       &
                               SY*YCELL(J,L,IB)))**2)
                           RR4=SQRT((ABS(TX_CRDX(JJ,JX)-SX*XCELL(I,L,IB)))  &
                               **2+(ABS(TX_CRDY(JJ,JX)-SY*YCELL(J,L,IB))    &
                               +.5*BLY(L,IB))**2)
                           RR5=SQRT((ABS(TX_CRDX(JJ,JX)-SX*XCELL(I,L,IB)))  &
                               **2+(ABS(TX_CRDY(JJ,JX)-SY*YCELL(J,L,IB))    &
                               -.5*BLY(L,IB))**2)
                           RMAX=MAX(RR1,RR2,RR3,RR4,RR5,RMAX)
                        ENDDO
                     ENDIF
                  ENDDO
               ENDDO
            ENDDO
            ENDDO
            ENDDO
            ENDDO
!
            RMAX1=AMAX1(RMAX1,RMAX)
!
!-- Determine maximal target-receiver distance
!
            RMAX=0.
            DO JX=1,NTX_FD
               DO JJ=1,N_RX(JX)
                  DO IB=1,NBODY
                     DO L=1,SUB_BLOCK(IB)
                        DO I=1,NX(L,IB)
                           DO J=1,NY(L,IB)
                              IF (KSYMM==0) THEN
                              NSYM=1
                              ELSE
                              NSYM=4
                              ENDIF
                              DO LSYM=1,NSYM
                              IF (LSYM==1) THEN
                              SX=1.
                              SY=1.
                              ENDIF
                              IF (LSYM==2) THEN
                              SX=-1.
                              SY=1.
                              ENDIF
                              IF (LSYM==3) THEN
                              SX=1.
                              SY=-1.
                              ENDIF
                              IF (LSYM==4) THEN
                              SX=-1.
                              SY=-1.
                              ENDIF
                              RR1=SQRT((RX_X(JJ,JX)-XCELL(I,L,IB))**2+      &
                                       (RX_Y(JJ,JX)-YCELL(J,L,IB))**2)
                              RR2=SQRT((ABS(RX_X(JJ,JX)-SX*XCELL(I,L,IB))   &
                                  +.5*BLX(L,IB))**2+(ABS(RX_Y(JJ,JX)-       &
                                  SY*YCELL(J,L,IB)))**2)
                              RR3=SQRT((ABS(RX_X(JJ,JX)-SX*XCELL(I,L,IB))   &
                                  -.5*BLX(L,IB))**2+(ABS(RX_Y(JJ,JX)-       &
                                  SY*YCELL(J,L,IB)))**2)
                              RR4=SQRT((ABS(RX_X(JJ,JX)-SX*XCELL(I,L,IB)))  &
                                  **2+(ABS(RX_Y(JJ,JX)-SY*YCELL(J,L,IB))    &
                                  +.5*BLY(L,IB))**2)
                              RR5=SQRT((ABS(RX_X(JJ,JX)-SX*XCELL(I,L,IB)))  &
                                  **2+(ABS(RX_Y(JJ,JX)-SY*YCELL(J,L,IB))    &
                                  -.5*BLY(L,IB))**2)
                              RMAX=MAX(RR1,RR2,RR3,RR4,RR5,RMAX)
                              ENDDO
                           ENDDO
                        ENDDO
                     ENDDO
                  ENDDO
               ENDDO
            ENDDO
!
            RMAX1=AMAX1(RMAX1,RMAX)
!
         ENDIF
!*                                      *
!****************************************
      ENDIF
!
! --- Determine maximal target-receiver distance for MT problems
!
      IF (CS_TYPE==1) THEN
!****************************************
!*                                      *
         RMAX=0.
         DO II=1,MT_PROFL
            DO JJ=1,MT_STATN
               DO IB=1,NBODY
                  DO L=1,SUB_BLOCK(IB)
                     DO I=1,NX(L,IB)
                        DO J=1,NY(L,IB)
                           IF (KSYMM==0) THEN
                              NSYM=1
                           ELSE
                              NSYM=4
                           ENDIF
                           DO LSYM=1,NSYM
                              IF (LSYM==1) THEN
                                 SX=1.
                                 SY=1.
                              ENDIF
                              IF (LSYM==2) THEN
                                 SX=-1.
                                 SY=1.
                              ENDIF
                              IF (LSYM==3) THEN
                                 SX=1.
                                 SY=-1.
                              ENDIF
                              IF (LSYM==4) THEN
                                 SX=-1.
                                 SY=-1.
                              ENDIF
                              RR1=SQRT((XRMT(II)-XCELL(I,L,IB))**2+         &
                                       (YRMT(JJ)-YCELL(J,L,IB))**2)
                              RR2=SQRT((ABS(XRMT(II)-SX*XCELL(I,L,IB))+     &
                                       .5*BLX(L,IB))**2+(ABS(YRMT(JJ)-      &
                                       SY*YCELL(J,L,IB)))**2)
                              RR3=SQRT((ABS(XRMT(II)-SX*XCELL(I,L,IB))-     &
                                       .5*BLX(L,IB))**2+(ABS(YRMT(JJ)-      &
                                       SY*YCELL(J,L,IB)))**2)
                              RR4=SQRT((ABS(XRMT(II)-SX*XCELL(I,L,IB)))**2  &
                                       +(ABS(YRMT(JJ)-SY*YCELL(J,L,IB))     &
                                       +.5*BLY(L,IB))**2)
                              RR5=SQRT((ABS(XRMT(II)-SX*XCELL(I,L,IB)))**2  &
                                       +(ABS(YRMT(JJ)-SY*YCELL(J,L,IB))     &
                                       -.5*BLY(L,IB))**2)
                              RMAX=MAX(RR1,RR2,RR3,RR4,RR5,RMAX)
                           ENDDO
                        ENDDO
                     ENDDO
                  ENDDO
               ENDDO
            ENDDO
         ENDDO
!
         RMAX1=RMAX
!*                                      *
!****************************************
      ENDIF
!
! --- Always set RMIN1=RHOMIN
!
      RMIN1=RHOMIN
!
! --- RMIN1 can sometimes be zero,  as in the case of 1D downhole
!     computation.
!
      IF (RMAX1<RHOMIN) RMAX1=RHOMIN
!
! --- In order to avoid unaccounted errors,  increase the values of
!     RMAX1 and RMAX2
!
      RMAX1=1.2*RMAX1
      RMAX2=1.1*RMAX2
!
! ---- If the geometrical dimenion exceeds 100 km the whole model
!    configuration is then reduced according to the scaling law
!    in order to ensure the accuracy in computing the Hankel
!    transform using digital filters. If it is less than 10 m,
!    this is also done to ensure accuracies, as the code uses
!    0.1 as limit for zero in most cases which is used to enhance
!    numerical stabilities.
!
!    In such cases all the geometrical lengths will be reduced
!    by a factor of SCALE, and the frequency will be increased
!    by SCALE**2
!
!    RMAX1 and RMAX2 are not allowed to exceed designed limit for
!    the high frequency version.  They will be tested in routine
!    INIT_INPUT_TEST
!
! ---- Determine the scale factor
!
! *** It is better to disable this function for controlled source problems
!     (The parameter INCL_DIELEC has been removed from the argument list)
!
!      SCALE=AMAX1(RMAX1,RMAX2)
!
! -- No transforms are done for time domain computation.
!
!      IF (SCALE<10..AND.INCL_DIELEC==0.AND.KTEM==0) THEN
!         SCALE=SCALE/10.
!      ELSEIF (SCALE>100000.) THEN
!
!  -- Transform large models only
!      IF (SCALE>100000.) THEN
!         SCALE=100000./SCALE
!      ELSE
         SCALE=1.
!      ENDIF
!
      IF (ABS(SCALE-1.)>=.0001) THEN
!
! ---- Re-form the model using the scaling law
!
         IF (KTEM==0) THEN
            DO I=1,NFRQ
               FRQM(I)=FRQM(I)/SCALE**2
            ENDDO
         ENDIF
!
         IF (DO_3D==1) THEN
!
            DO IB=1,NBODY
               CLMN(IB)=CLMN(IB)*SCALE
               DO L=1,SUB_BLOCK(IB)
                  BLX(L,IB)=BLX(L,IB)*SCALE
                  BLY(L,IB)=BLY(L,IB)*SCALE
                  BLZ(L,IB)=BLZ(L,IB)*SCALE
                  XBL(L,IB)=XBL(L,IB)*SCALE
                  YBL(L,IB)=YBL(L,IB)*SCALE
                  ZBL(L,IB)=ZBL(L,IB)*SCALE
                  DO I=1,NX(L,IB)
                     XCELL(I,L,IB)=XCELL(I,L,IB)*SCALE
                  ENDDO
                  DO I=1,NY(L,IB)
                     YCELL(I,L,IB)=YCELL(I,L,IB)*SCALE
                  ENDDO
                  DO I=1,NZ(L,IB)
                     ZCELL(I,L,IB)=ZCELL(I,L,IB)*SCALE
                  ENDDO
               ENDDO
            ENDDO
!
            SBX=SBX*SCALE
            SBY=SBY*SCALE
            SBZ=SBZ*SCALE
            SCX=SCX*SCALE
            SCY=SCY*SCALE
            SCZ=SCZ*SCALE
            XSB=XSB*SCALE
            YSB=YSB*SCALE
            ZSB=ZSB*SCALE
!
            DO I=1,NZOB
               ZOBG(I)=ZOBG(I)*SCALE
            ENDDO
            DO I=1,NZSR
               ZSRG(1,I)=ZSRG(1,I)*SCALE
               ZSRG(2,I)=ZSRG(2,I)*SCALE
            ENDDO
            BLMIN=BLMIN*SCALE
            ZMT=ZMT*SCALE
!
         ENDIF
!
         RMAX1=RMAX1*SCALE
         RMAX2=RMAX2*SCALE
         RMIN1=RMIN1*SCALE
         RMIN2=RMIN2*SCALE
         IF (RMIN1<.1) RMIN1=.1
         IF (RMIN2<.1) RMIN2=.1
!
         DO I=1,MLAYER
            ZBND(I)=ZBND(I)*SCALE
            LRYTH(I)=LRYTH(I)*SCALE
         ENDDO
!
         DO I=1,NSRCS
            ZSRCS(1,I)=ZSRCS(1,I)*SCALE
            ZSRCS(2,I)=ZSRCS(2,I)*SCALE
         ENDDO
         DO I=1,NOBCS
            ZOBCS(I)=ZOBCS(I)*SCALE
         ENDDO
         DO I=1,NTX_FD
            RAD(I)=RAD(I)*SCALE
            DO J=1,NCRD
               TX_CRDX(J,I)=TX_CRDX(J,I)*SCALE
               TX_CRDY(J,I)=TX_CRDY(J,I)*SCALE
               TX_CRDZ(J,I)=TX_CRDZ(J,I)*SCALE
            ENDDO
         ENDDO
!   RAD2=RAD2*SCALE --This has been assigned to RAD at the beginning
      IF (CS_TYPE==6.OR.CS_TYPE==7.OR.CS_TYPE==8) THEN
         TR_OFF_X=TR_OFF_X*SCALE
         TR_OFF_Y=TR_OFF_Y*SCALE
         TR_OFF_Z=TR_OFF_Z*SCALE
         DO I=1,N_PROFL
            N_STATN(I)=INT(FLOAT(N_STATN(I))*SCALE)
            START_X(I)=START_X(I)*SCALE
            START_Y(I)=START_Y(I)*SCALE
            START_Z(I)=START_Z(I)*SCALE
            STATN_DIST(I)=STATN_DIST(I)*SCALE
         ENDDO
      ENDIF
!
         IF (CS_TYPE/=1) THEN
            DO JX=1,NTX_FD
               DO I=1,N_RX(JX)
                  RX_X(I,JX)=RX_X(I,JX)*SCALE
                  RX_Y(I,JX)=RX_Y(I,JX)*SCALE
                  RX_Z(I,JX)=RX_Z(I,JX)*SCALE
               ENDDO
            ENDDO
         ELSE
            DO I=1,MT_PROFL
               XRMT(I)=XRMT(I)*SCALE
            ENDDO
            DO I=1,MT_STATN
               YRMT(I)=YRMT(I)*SCALE
            ENDDO
         ENDIF
      ENDIF
!
      RETURN
      END
!
!**** End of INIT_SCALING
!
!
   SUBROUTINE INIT_ZLVLSCS(NW,MZGRID,CS_TYPE,NTX_FD,M_RX,N_RX,NCRD,   &
                           TX_CRDZ,RX_Z,ZMT,DMIN,NZSR,ZSRG,NZOB,ZOBG)
!
!**** Determine the z and z'-levels in the vertical direction
!
!     The program automatically finds all z and z'-levels for the
!     3D body and for the sources and receivers.  Hankel integrals
!     are computed at those levels for various rho (in the lateral
!     direction) for interpolations for computing the (integrated)
!     Green's tensors.
!
!  Input parameters:
!
!    MZRGID:  Integer,  dimension parameter for the arrays ZOBG and
!             ZSRG.  MZGRID must be much larger than NZTMAX since
!             these two arrays also works as working arrays.
!    CS_TYPE:    Integer,  type of excitation and configuration.
!             See documentation "MARCO.DOC" for description.
!    NTX_FD:   Integer,  nubmer of  excitations.
!    M_RX:
!    N_RX:    Integer N_RX(NTX_FD),  number of receiver sites.
!    NCRD:
!    TX_CRDZ:    TX_CRDZ(NCRD,NTX_FD), z-coordinates of electrodes or the center
!             z-coordinates of a current loop or a magnetic dipole for all the
!             excitations.
!    RX_Z:    Real RX_Z(M_RX,NTX_FD),  receiver sites coordinates in the
!             z-direction for the receiver sites.
!    ZMT:     Real,  z coordinate of the measuring plane for MT stations.
!    DMIN:
!
!  Output parameters:
!
!     NZOB:   Integer, number of z-levels for the excitation sources.
!     NZSR:   Integer,  number of z-levels for the excitation sources.
!     ZOBG:  Real ZOBG(MZGRID),  the coordinates of the nzob z-levels
!             for the excitation sources.
!     ZSRG:   Real ZSRG(MZGRID), the coordinates of the nzsr z-levels
!             for the excitation sources.
!
!
!**** Called by:  main
!
!**** Calls:      none
!
!
      IMPLICIT NONE
!
      INTEGER, INTENT(IN) ::  CS_TYPE,MZGRID,NTX_FD,NCRD,M_RX,NW
      INTEGER, INTENT(IN) ::  N_RX(NTX_FD)
      INTEGER, INTENT(OUT) :: NZOB,NZSR
      REAL, INTENT(IN) :: DMIN,RX_Z(M_RX,NTX_FD),ZMT
!  -- The two electrodes in TX_CRDZ for vertical bipoles may be reversed here
      REAL, INTENT(INOUT) :: TX_CRDZ(NCRD,NTX_FD)
      REAL, INTENT(OUT) :: ZOBG(MZGRID),ZSRG(2,MZGRID)
!
      INTEGER ::  I,J,II,JJ
      REAL :: ZSR1
!
! --- ZWORK is an allocatable working array for sorting
!
      REAL, ALLOCATABLE :: ZWORK(:),ZWORK2(:,:)
!
! --- Determine the z-levels for the receivers
!
!     Firstly all different z-levels are found.  They are then
!     re-arranged later.
!
      IF (CS_TYPE==1) THEN
         NZOB=1
         ZOBG(1)=ZMT
         RETURN
      ENDIF
!
      ZOBG(1)=RX_Z(1,1)
      JJ=1
      DO J=1,NTX_FD
         DO I=1,N_RX(J)
            DO II=1,JJ
               IF (ABS(RX_Z(I,J)-ZOBG(II))<=DMIN) GOTO 2
            ENDDO
            JJ=JJ+1
            ZOBG(JJ)=RX_Z(I,J)
   2     CONTINUE
      ENDDO
      ENDDO
      NZOB=JJ
!
!  -- Arrange the elements of ZOBG in an increasing order.
!
!     This part is a bit tricky,  but it's organized as follows:
!     The Order_loop finds the (next) minimal ZOBG(:) and put them
!     in a increasing order;  the Minimization_loop identifies the
!     element that is smaller than the current one;  and the Skip_loop
!     skips those that have already been identified which are always
!     <= the current one.
!
!  -- Allocate the working array
!
      ALLOCATE(ZWORK(NZOB+1))
!
      ZWORK(1)=ZOBG(1)
      Order_loop:  DO I=1,NZOB
         Minimization_loop:  DO J=1,NZOB
            IF (ZOBG(J)<ZWORK(I)) THEN
               Skip_loop:  DO JJ=1,I-1
                  IF (ZOBG(J)<=ZWORK(JJ)) CYCLE Minimization_loop
               ENDDO Skip_loop
               ZWORK(I)=ZOBG(J)
            ENDIF
         ENDDO Minimization_loop
         ZWORK(I+1)=1.E20
      ENDDO Order_loop
!
      ZOBG(1:NZOB)=ZWORK(1:NZOB)
!
!  -- Deallocate the working array
!
      DEALLOCATE(ZWORK)
!
! --- Determine the z_prime levels for different excitations
!     in controlled source cases.
!
!     The technique used here is exactly the same as in the above
!
! --- Make sure that vertical coordinate of the second electrode is larger
!     than that of the first one for vertical current bipoles.
!
      DO J=1,NTX_FD
         IF(CS_TYPE.EQ.2.AND.TX_CRDZ(2,J).LT.TX_CRDZ(1,J)) THEN
           ZSR1=TX_CRDZ(1,J)
           TX_CRDZ(1,J)=TX_CRDZ(2,J)
           TX_CRDZ(2,J)=ZSR1
           WRITE(NW,223) J
           WRITE(*,223) J
         ENDIF
      ENDDO
!
      ZSRG(1,1)=TX_CRDZ(1,1)
      IF (CS_TYPE==2) THEN
         ZSRG(2,1)=TX_CRDZ(2,1)
      ELSE
         ZSRG(2,1)=TX_CRDZ(1,1)
      ENDIF
      JJ=1
!
      DO J=1,NTX_FD
!
         DO I=1,JJ
            IF (CS_TYPE==2) THEN
               IF (ABS(TX_CRDZ(1,J)-ZSRG(1,I))<=DMIN .AND.     &
                   ABS(TX_CRDZ(2,J)-ZSRG(2,I))<=DMIN) GOTO 5
            ELSE
               IF (ABS(TX_CRDZ(1,J)-ZSRG(1,I))<=DMIN) GOTO 5
            ENDIF
         ENDDO
!
         JJ=JJ+1
         IF (CS_TYPE==2) THEN
            ZSRG(1,JJ)=TX_CRDZ(1,J)
            ZSRG(2,JJ)=TX_CRDZ(2,J)
         ELSE
            ZSRG(1,JJ)=TX_CRDZ(1,J)
            ZSRG(2,JJ)=TX_CRDZ(1,J)
         ENDIF
!
   5     CONTINUE
!
      ENDDO
!
      NZSR=JJ
!
!  -- Allocate the working array
!
      ALLOCATE(ZWORK2(2,NZSR+1))
!
!  -- Arrange the elements of ZSRG in an increasing order according
!     to ZSRG(1,*).
!
      ZWORK2(1:2,1)=ZSRG(1:2,1)
      Order_loop2:  DO I=1,NZSR
         Minimization_loop2:  DO J=1,NZSR
            IF (ZSRG(1,J)<ZWORK2(1,I)) THEN
            Skip_loop2:  DO JJ=1,I-1
                  IF (ZSRG(1,J)<ZWORK2(1,JJ) .OR.                 &
                      (ABS(ZSRG(1,J)-ZWORK2(1,JJ))<DMIN.AND.      &
                       ABS(ZSRG(2,J)-ZWORK2(2,JJ))<DMIN))    THEN
                     Cycle Minimization_loop2
                  ENDIF
               ENDDO Skip_loop2
               ZWORK2(1:2,I)=ZSRG(1:2,J)
            ENDIF
         ENDDO Minimization_loop2
         ZWORK2(1,I+1)=1.E20
      ENDDO Order_loop2
!
      ZSRG(1:2,1:NZSR)=ZWORK2(1:2,1:NZSR)
!
      DEALLOCATE(ZWORK2)
!
      RETURN
!
 223    FORMAT(/'Warning: the order of the electrode for ',    &
                'excitation #',I3,' is reversed as required',  &
               /'by the program. Primary and secondary ',      &
                'field quantities reverse signs.')
!
   END SUBROUTINE INIT_ZLVLSCS
!
!
   SUBROUTINE INIT_ZLVLS(NW,MBODY,NBMAX,NZMAX,KSMR,NBODY,SUB_BLOCK,       &
                         NZS,NZ,SBZ,SCZ,ZSB,ZCELL,BLZ,                    &
                         MZGRID,DMIN,NZSR,ZSRG,NZOB,ZOBG)
!
!**** Determine the z and z'-levels in the vertical direction
!
!     The program automatically finds all z and z'-levels for the
!     3D body and for the sources and receivers.  Hankel integrals
!     are computed at those levels for various rho (in the lateral
!     direction) for interpolations for computing the (integrated)
!     Green's tensors.
!
!  Input parameters:
!
!  MBODY:   Integer,  maximal number of substructures allowed in the
!           program.
!  NBMAX:   Integer,  maximal number of blocks allowed in a
!           substructure.  It is the maximum of SUB_BLOCK used for
!           array definitions.
!  NZMAX:   Integer,  maximal number of cells in the z-direction
!           in a block.
!  KSMR:    Integer,  controlling parameter whether spatial symmetry can
!           be used or not.  KSMR=1:  yes;  =0:  no.
!  NBODY:   Integer,  number of substructures.
!  SUB_BLOCK:  Integer SUB_BLOCK(MBODY),  number of blocks in each substructure.
!  NZS:     Integer,  number of cells in the z-direction of the superblock.
!  NZ:      Integer NZ(NBMAX,MBODY),  numbers of cells in the z-direction
!           in each block of the substructures.
!  SBZ:     Real,  dimension of the super block in the z-direction.
!  SCZ:     Real,  dimension the cells of the super block in the
!           z-direction.
!  ZSB:     Real,  z-ccordinate of the superblock.
!  ZCELL:   Real ZCELL(NZMAX,NBMAX,MBODY),  z-coordinates of the cells.
!  BLZ:     Real BLZ(NBMAX,MBODY),  dimensions of each cells of the
!           substructures in the z-direction.
!  MZRGID:  Integer,  dimension parameter for the arrays ZOBG and
!           ZSRG.  MZGRID must be much larger than NZTMAX since
!           these two arrays also works as working arrays.
!  DMIN:
!
!  Output parameters:
!
!     NZOB:   Integer, number of z-levels for the cells of the 3D bodies.
!     NZSR:   Integer,  number of z-levels for the 3D bodies.
!     ZOBG:   Real ZOBG(MZGRID),  the coordinates of the nzob z-levels
!             for the 3D bodies.
!     ZSRG:   Real ZSRG(MZGRID), the coordinates of the nzsr z-levels
!             for the cells of the 3D bodies.
!
!**** Called by:  main
!
!**** Calls:      none
!
!
      IMPLICIT NONE
!
      INTEGER, INTENT(IN) :: KSMR,MBODY,MZGRID,NBMAX,NBODY,NZMAX,NZS,NW,    &
                             SUB_BLOCK(MBODY),NZ(NBMAX,MBODY)
      REAL,    INTENT(IN) :: DMIN,SBZ,SCZ,ZSB,BLZ(NBMAX,MBODY),             &
                             ZCELL(NZMAX,NBMAX,MBODY)
      INTEGER, INTENT(OUT) :: NZOB,NZSR
      REAL,    INTENT(OUT) :: ZOBG(MZGRID),ZSRG(2,MZGRID)
!
      INTEGER :: I,II,J,JJ,IB
!
! --- ZWORK is an allocatable working array for sorting
!
      REAL, ALLOCATABLE :: ZWORK(:),ZWORK2(:,:)
!
! --- Life is easy with spatially symmetric models
!
      IF (KSMR==1) THEN
         NZOB=NZS
         NZSR=NZS
!
         DO I=1,NZS
            ZOBG(I)=ZSB-.5*SBZ+.5*SCZ+(I-1)*SCZ
            ZSRG(1,I)=ZSB-.5*SBZ+(I-1)*SCZ
            ZSRG(2,I)=ZSB-.5*SBZ+I*SCZ
         ENDDO
         RETURN
      ENDIF
!
! ----- Determine the z-levels for storing the values of the
!     Green's functions (the Hankel transforms) in the z-direction
!
!     Note that the z and z'-levels are different with and
!     without spatial symmetry reductions if there more than
!     two separated blocks.
!
!     Firstly all different z-levels are found.  They are then
!     re-arranged later.
!
      JJ=1
      ZOBG(1)=ZCELL(1,1,1)
      DO IB=1,NBODY
         DO I=1,SUB_BLOCK(IB)
            DO J=1,NZ(I,IB)
               DO II=1,JJ
                  IF (ABS(ZCELL(J,I,IB)-ZOBG(II))<=DMIN) GOTO 2
               ENDDO
               JJ=JJ+1
!--- The maximal value of JJ is MZGRID
               IF (JJ>MZGRID) THEN
                  WRITE (*,1010)
                  WRITE (NW,1010)
                  STOP   &
       'Program aborted. Please check the error messages in OUTPUT.OUT'
               ENDIF
               ZOBG(JJ)=ZCELL(J,I,IB)
   2           CONTINUE
            ENDDO
         ENDDO
      ENDDO
      NZOB=JJ
!  -- Arrange the elements of ZOBG in an increasing order.
!
!     This part is a bit tricky,  but it's organized as follows:
!     The Order_loop finds the (next) minimal ZOBG(:) and put them
!     in a increasing order;  the Minimization_loop identifies the
!     element that is smaller than the current one;  and the Skip_loop
!     skips those that have already been identified which are always
!     <= the current one.
!
!  -- Allocate the working array
!
      ALLOCATE(ZWORK(NZOB+1))
!
      ZWORK(1)=ZOBG(1)
      Order_loop:  DO I=1,NZOB
         Minimization_loop:  DO J=1,NZOB
            IF (ZOBG(J)<ZWORK(I)) THEN
               Skip_loop:  DO JJ=1,I-1
                  IF (ZOBG(J)<=ZWORK(JJ)) CYCLE Minimization_loop
               ENDDO Skip_loop
               ZWORK(I)=ZOBG(J)
            ENDIF
         ENDDO Minimization_loop
         ZWORK(I+1)=1.E20
      ENDDO Order_loop
!
      ZOBG(1:NZOB)=ZWORK(1:NZOB)
!
!  -- Deallocate the working array
!
      DEALLOCATE(ZWORK)
!
!
! ---  Determine the z'-levels for storing the values of the
!      Green's functions integrated in the z'-direction
!
!     The technique used here is exactly the same as in the above
!
!
      JJ=1
      ZSRG(1,JJ)=ZCELL(1,1,1)-.5*BLZ(1,1)
      ZSRG(2,JJ)=ZCELL(1,1,1)+.5*BLZ(1,1)
      DO IB=1,NBODY
         DO I=1,SUB_BLOCK(IB)
            DO J=1,NZ(I,IB)
               DO II=1,JJ
                  IF (ABS(ZSRG(1,II)-ZCELL(J,I,IB)-.5*BLZ(I,IB))<=DMIN.AND. &
                      ABS(ZSRG(2,II)-ZCELL(J,I,IB)+.5*BLZ(I,IB))<=DMIN) GOTO 4
               ENDDO
               JJ=JJ+1
               ZSRG(1,JJ)=ZCELL(J,I,IB)-.5*BLZ(I,IB)
               ZSRG(2,JJ)=ZCELL(J,I,IB)+.5*BLZ(I,IB)
   4           CONTINUE
            ENDDO
         ENDDO
      ENDDO
      NZSR=JJ
!
!  -- Allocate the working array
!
      ALLOCATE(ZWORK2(2,NZSR+1))
!
!  -- Arrange the elements of ZSRG in an increasing order according
!     to ZSRG(1,*).
!
      ZWORK2(1:2,1)=ZSRG(1:2,1)
      Order_loop2:  DO I=1,NZSR
         Minimization_loop2:  DO J=1,NZSR
            IF (ZSRG(1,J)<ZWORK2(1,I)) THEN
            Skip_loop2:  DO JJ=1,I-1
                  IF (ZSRG(1,J)<ZWORK2(1,JJ) .OR.                 &
                      (ABS(ZSRG(1,J)-ZWORK2(1,JJ))<DMIN.AND.      &
                       ABS(ZSRG(2,J)-ZWORK2(2,JJ))<DMIN))    THEN
                     Cycle Minimization_loop2
                  ENDIF
               ENDDO Skip_loop2
               ZWORK2(1:2,I)=ZSRG(1:2,J)
            ENDIF
         ENDDO Minimization_loop2
         ZWORK2(1,I+1)=1.E20
      ENDDO Order_loop2
!
      ZSRG(1:2,1:NZSR)=ZWORK2(1:2,1:NZSR)
!
      DEALLOCATE(ZWORK2)
!
      RETURN
!
 1010 FORMAT (/'The sum of all the cell numbers in the vertical',          &
               'direction of all blocks exceed designed limit.',           &
             'Please either change the value of the parameter MZGRID or',  &
             'try to use less blocks or reduce the cells in the vertical', &
             'direction.')
!
   END SUBROUTINE INIT_ZLVLS
!
!
!===== Subroutines called directly by the main program -- major structuring
!      of the program
!
      SUBROUTINE MAIN_PRM_AT_CELL(NW,FRQ,MLAYER,ZBND,LRYTH,HVK,KKH,CDH,   &
                                  KANIS,INCL_DIELEC,CS_TYPE,KSYMM,MBODY,  &
                                  NBMAX,NSUBCM,NMAX,NXMAX,NYMAX,NZMAX,    &
                                  NTX_FD,MD_ANGLE,NCRD,N_SIDE,TX_CRDX,    &
                                  TX_CRDY,TX_CRDZ,RAD,TX_CRDXI,TX_CRDYI,  &
                                  TX_CRDZI,NPOL,LP1,LP2,NBODY,SUB_BLOCK,  &
                                  NET,NEQ,NX,NY,NZ,NCELL,XCELL,YCELL,     &
                                  ZCELL,NXI,NYI,NZI,NCELLI,XCELLI,YCELLI, &
                                  ZCELLI,CDB,EN,EMT,ENT,EJGS,EJGS2,       &
                                  RHOMIN,RHOMAX,NZOB,ZOBG,NZSR,ZSRG,NZBG, &
                                  ZBG,KACC,AJ,DMIN,NHFILM,ALMAX,BLMIN,    &
                                  GRHF,RRG,GRHO0)
!
!**** calculate the incident fields at cell centres
!
!   Results (electric fields at cell centers) for non-symmetric
!   models are stored on the disk in unit 10 if there is more than
!   one excitation and/or more than one substructure.  Results for
!   for symmetric models are always stored in unit 20 on the disk.
!   Access to those units must be in the same sequence as
!   used here in this routine.
!
!
!Input parameters:
!
!  FRQ:     Real,  the frequency.
!  MLAYER:  Integer,  number of layers of the earth.
!  ZBND:    Real ZBND(0:MLAYER), the z-coordinates of the layer
!           boundaries with the air-earth interface being always
!           0 (zbnd(0)=0).
!  LRYTH:   Real LRYTH(MLAYER), the thickness of the layers.
!  HVK:     Real HVK(0:MLAYER), the anisotropy coefficients of
!           the layer conductivities as defined by the square
!           root of the ratio of horizontal conductivity to
!           vertical conductivity.
!  KKH:    Complex(*8) KKH(0:MLAYER),  square ( **2) of the complex wave
!          number of the layers (in the lateral direction) including
!          the air (layer number 0).
!  CDH:    Complex CDH(0:MLAYER),  complex conductivities of
!          the layers in the lateral direction including the
!          air (layer 0).
!  KANIS:  Integer,  parameter controlling whether the earth is vertically
!          anisotropic in conductivity.  KANIS=1, yes;  =0,  no.
!  The above parameters FRQ etc. are to be passed into subroutines.
!  INCL_DIELEC:  Integer,  controlling parameter for high frequency (in the
!           tens of MHz range) or low frequency (conventional frequency
!           ranges) computation.
!           INCL_DIELEC = 0:  low frequency ranges;  and
!                  = 1:  high frequency ranges.
!  CS_TYPE:    Integer,  type of excitation and configuration.
!           See documentation "MARCO.DOC" for description.
!  KSYMM:   Integer,  controlling parameter for the two-plane symmetry
!           fo the 3D model.  KSYMM=1:  symmetric model;  =0:  non-sym-
!           metric model.
!  MBODY:   Integer,  maximal number of substructures allowed in the
!           program.
!  NBMAX:   Integer,  maximal number of blocks allowed in a
!           substructure.  It is the maximum of SUB_BLOCK used for
!           array definitions.
!  NSUBCM:  Integer,  maximal nuber of cells in a substructure.
!  NMAX:    Integer,  maximal number of unknowns in a substructure.
!           NMAX=3*NSUBCM.
!  NXMAX:   Integer,  maximal number of cells in the x-direction
!           in a block.
!  NYMAX:   Integer,  maximal number of cells in the y-direction
!           in a block.
!  NZMAX:   Integer,  maximal number of cells in the z-direction
!           in a block.
!  NTX_FD:    Integer,  nubmer of excitations.
!  MD_ANGLE:  Real MD_ANGLE(2,NTX_FD),  orientations of arbitrary magnetic
!           dipoles for CS_TYPE=9 for each excitation.  For each excitation
!           the two elements of MD_ANGLE(1:2,J) contain the dip angle
!           MD_ANGLE(1,J) and the azimuthal angle MD_ANGLE(2,J) of the Jth
!           magnetic dipole.  The dip angle is the angle from the axis down
!           to the earth (note that this is the internal positive z-axis
!           which differs from the input-output z-axis that points upwards).
!           The azimuthal angle is the angle from the north,  the y-axis.
!           Thus for a vertical magnetic dipole MD_ANGLE(1,J)=180 for
!           pointing up air and MD_ANGLE(1,J) =0 for pointing down.  A
!           horizontal magnetic dipole pointing north will have MD_ANGLE(1,J)
!           =90 and MD_ANGLE(2,J)=0,  and a horizontal magnetic dipole
!           pointing east will have MD_ANGLE(1,J)=90 and MD_ANGLE(2,J)=90.
!  NCRD:    Integer,  nubmer of electrodes or number of different coordinates
!           for the source configuration per excitation.
!  TX_CRDX, TX_CRDY, TX_CRDZ: Real TX_CRDX(NCRD,NTX_FD), TX_CRDY(NCRD,NTX_FD),
!  TX_CRDZ(NCRD,NTX_FD):
!           coordinates of electrodes (the end points of current bipoles
!           or loop corners) or the center coordinates of a current loop
!           or a magnetic dipole for all the excitations.   For various
!           values of CS_TYPE,  the four elements for the first index of
!           TX_CRDX, TX_CRDY,  and TX_CRDZ contain the following information:
!           CS_TYPE =2, and 3:  the first two elements of TX_CRDX etc.
!                    represent the two electrodes of the bipoles;
!                =4: the arrays TX_CRDX etc. show the coordinates
!                    of the four corner of the rectangular loop.
!                =5, and 6: the first elements of TX_CRDX etc. contain the
!                    coordinates of the centre of the circular
!                    loop;  and
!                =7, 8, and 9: the first elements of TX_CRDX etc.
!                    contain the coordinates of the centre of the
!                    magnetic dipole.
!  RAD:     Real RAD(NTX_FD),  radius of the loops.
!  TX_CRDXI, TX_CRDYI, TX_CRDZI: Real TX_CRDXI(NCRD), TX_CRDYI(NCRD),
!  TX_CRDZI(NCRD):  the x, y, and z-coordinates of the sources for one
!           excitation.  They are used as working arrays.
!  NPOL, LP1, LP2: Integer,  the controlling parameters for the
!           polarizations in MT computations.
!  NBODY:   Integer,  number of substructures.
!  SUB_BLOCK:  Integer SUB_BLOCK(MBODY),  number of blocks in each substructure.
!  NET:     Integer NET(MBODY),  number of unknowns in each substructure.
!  NEQ:     Integer,  total number of cells in one quadrant of a symmetric
!           model.
!  NX:      Integer NX(NBMAX,MBODY),  numbers of cells in the x-direction
!           in each block of the substructures.
!  NY:      Integer NY(NBMAX,MBODY),  numbers of cells in the y-direction
!           in each block of the substructures.
!  NZ:      Integer NZ(NBMAX,MBODY),  numbers of cells in the z-direction
!           in each block of the substructures.
!  NCELL:   Integer NCELL(NBMAX,MBODY),  number of cells in each block
!           of the substructures.
!  XCELL:   Real XCELL(NXMAX,NBMAX,MBODY),  x-coordinates of the cells.
!  YCELL:   Real YCELL(NYMAX,NBMAX,MBODY),  y-coordinates of the cells.
!  ZCELL:   Real ZCELL(NZMAX,NBMAX,MBODY),  z-coordinates of the cells.
!  NXI, NYI, NZI, NCELLI, XCELLI, YCELLI, and ZCELLI:   working arrays
!           corresponding to NX, NY, NZ, NCELL, XCELL, YCELL, and
!           ZCELL for each substructure.
!  CDB:     COMPLEX CDB(NSUBCM,NBMAX),  working array for the
!           complex conductivities of the cells in a substructure.
!           Its values are all stored on the disk in unit 62.
!  EN:      Complex EN(NMAX),  the incident electric fields in a
!           substructure. It is used as a working array.
!  DMIN:    Real,  minimal dimension value that is considered to be
!           zero.  DMIN=0.1 for the low frequency module and DMIN=0.001
!           for the high frequency module.
!
!  Parameters RHOMIN, RHOMAX, NZOB, ZOBG, NZSR, ZSRG, ZBG, KACC,
!  AJ, NHFILM, HF, HF1, BLMIN, GRHF, RRG, ALMAX, and GRHO0 are to be passed
!  into routine ONE_D_HF_TABLE.  Check ONE_D_HF_TABLE for descriptions
!
!Output parameter:
!
!
!  ENT:    Complex ENT(NMAX),  the incident electric fields in a
!          substructure multiplied by the conductivity difference
!          between the target and the host.  ENT won't be used in
!          this version.
!  EJGS:   Complex EJGS(4*NMAX*MBODY),  the incident electric fields
!          for all cells of a symmetric model with KSYMM=1.  Note
!          that the input data contain only the model in the first
!          quadrant,  but the actual computation is done for all the
!          body.
!  EJGS2:  Complex EJGS2(4*NMAX*MBODY),  the transformed incident
!          fields for the four block matrices of group reductions.
!
!
!**** Called by:  main
!
!**** Calls:      ONE_D_HF_TABLE,  EN_PRM,  EN_PRM_CS,  EN_PRM_GS,  and
!                 MTRX_UNITARY
!
!
      IMPLICIT NONE
!
      REAL AJ,ALMAX,BLMIN,DMIN,FRQ,RADI,RHOMAX,RHOMIN,U,HFILL,HFILH
      INTEGER I,IB,IEXCI,II,IQ,IR,J,JCOL,JJ,KACC,KANIS,INCL_DIELEC,KEYG,KPOL, &
              CS_TYPE,KSYMM,LP1,LP2,LPC,LPR,NCRDI,NW
      INTEGER LQC,LQR,MBODY,MLAYER,SUB_BLOCKI,NBMAX,NBODY,NCB1,NCRD,          &
              NEQ,NETI,NHFILM,NRG,NMAX,NPOL,NSUBCM,NTX_FD,NXMAX,NYMAX
      INTEGER NZMAX,NZOB,NZSR,NZBG
      COMPLEX EN(NMAX),EMT(NMAX),ENT(NMAX,NBODY),EJGS(4*NMAX*MBODY),          &
              EJGS2(4*NMAX*MBODY),CDH(0:MLAYER),KKH(0:MLAYER),                &
              CDB(NSUBCM,NBMAX),GRHF(11,NHFILM,NZSR,NZOB),GRHO0(4,NZSR,NZOB)
      REAL  ZBND(0:MLAYER),LRYTH(MLAYER),HVK(0:MLAYER)
      REAL  ZOBG(NZOB),ZSRG(2,NZSR),ZBG(2,NZBG),RRG(NHFILM)
      REAL XCELL(NXMAX,NBMAX,MBODY),YCELL(NYMAX,NBMAX,MBODY),                 &
           ZCELL(NZMAX,NBMAX,MBODY),XCELLI(NXMAX,NBMAX),                      &
           YCELLI(NYMAX,NBMAX),ZCELLI(NZMAX,NBMAX),                           &
           RAD(NTX_FD),TX_CRDX(NCRD,NTX_FD),TX_CRDY(NCRD,NTX_FD),             &
           TX_CRDZ(NCRD,NTX_FD),TX_CRDXI(NCRD),TX_CRDYI(NCRD),TX_CRDZI(NCRD)
      INTEGER N_SIDE(NTX_FD)
      INTEGER NX(NBMAX,MBODY),NY(NBMAX,MBODY),NZ(NBMAX,MBODY),                &
              NCELL(NBMAX,MBODY),NET(MBODY),SUB_BLOCK(MBODY),                 &
              NXI(NBMAX),NYI(NBMAX),NZI(NBMAX),NCELLI(NBMAX)
      REAL :: MD_ANGLE(2,NTX_FD)
      REAL :: ANGLES(2)
!
      EXTERNAL HFILL,HFILH
!
      KEYG=1
!
      IF (CS_TYPE/=1) THEN
!
! ---- Compute the grid values for the interpolation of the
!    Hankel transforms in integrating current sources.
!
         IF (INCL_DIELEC==0) THEN
            CALL ONE_D_HF_TABLE(HFILL,NHFILM,MLAYER,ZBND,LRYTH,HVK,KKH,KANIS,        &
                        BLMIN,CS_TYPE,KEYG,DMIN,RHOMIN,RHOMAX,NZOB,ZOBG,     &
                        NZSR,ZSRG,NZBG,ZBG,ALMAX,GRHF,RRG,NRG,GRHO0)
         ELSE
            CALL ONE_D_HF_TABLE(HFILH,NHFILM,MLAYER,ZBND,LRYTH,HVK,KKH,KANIS,        &
                        BLMIN,CS_TYPE,KEYG,DMIN,RHOMIN,RHOMAX,NZOB,ZOBG,     &
                        NZSR,ZSRG,NZBG,ZBG,ALMAX,GRHF,RRG,NRG,GRHO0)
         ENDIF
!
      ENDIF
!
      DO IEXCI=1,NTX_FD
!
!-- Determine the orientation of the magnetic dipoles
!
         IF (CS_TYPE==7.OR.CS_TYPE==8.OR.CS_TYPE==9) THEN
            ANGLES(1)=MD_ANGLE(1,IEXCI)
            ANGLES(2)=MD_ANGLE(2,IEXCI)
         ENDIF
!
         IF (CS_TYPE/=1) THEN
            IF (CS_TYPE==4) THEN
               NCRDI=N_SIDE(IEXCI)
            ELSE
               NCRDI=NCRD
            ENDIF
            DO I=1,NCRDI
!
! ---- Corrections are made for 1D loop-loop responses only.
!    Issue warnings otherwise.
!
               IF (FRQ>1.E7 .AND. TX_CRDZ(I,IEXCI)<0.) THEN
                  WRITE (*,*)   &
                    'Warning: Corrections made for 1D Hxz and Hyz only!'
                  WRITE (NW,*)   &
                    'Warning: Corrections made for 1D Hxz and Hyz only!'
               ENDIF
!
               TX_CRDXI(I)=TX_CRDX(I,IEXCI)
               TX_CRDYI(I)=TX_CRDY(I,IEXCI)
               TX_CRDZI(I)=TX_CRDZ(I,IEXCI)
            ENDDO
            RADI=RAD(IEXCI)
         ENDIF
!
         IF (KSYMM==0.OR.CS_TYPE==1) THEN
! *********************************
! *                               *
            DO KPOL=LP1,LP2
!
               DO IB=1,NBODY
                  SUB_BLOCKI=SUB_BLOCK(IB)
                  NETI=NET(IB)
                  DO I=1,SUB_BLOCKI
                     NXI(I)=NX(I,IB)
                     NYI(I)=NY(I,IB)
                     NZI(I)=NZ(I,IB)
                     NCELLI(I)=NCELL(I,IB)
                     DO J=1,NXI(I)
                        XCELLI(J,I)=XCELL(J,I,IB)
                     ENDDO
                     DO J=1,NYI(I)
                        YCELLI(J,I)=YCELL(J,I,IB)
                     ENDDO
                     DO J=1,NZI(I)
                        ZCELLI(J,I)=ZCELL(J,I,IB)
                     ENDDO
                  ENDDO
!
                  IF (CS_TYPE==1) THEN
!
! ----- Note that the array emt is not used.  Thus the value of
!     the array cdb is arbitrary
!
                     CALL EN_PRM(FRQ,MLAYER,ZBND,LRYTH,KKH,CDH,NETI,         &
                                 SUB_BLOCKI,NSUBCM,NZMAX,NXI,NYI,NZI,        &
                                 NCELLI,ZCELLI,CDB,KPOL,EN,EMT)
                  ELSE
                     CALL EN_PRM_CS(NETI,SUB_BLOCKI,NSUBCM,NXMAX,NYMAX,NZMAX,&
                                NXI,NYI,NZI,NCELLI,XCELLI,YCELLI,ZCELLI,CDB, &
                                CS_TYPE,NCRDI,TX_CRDXI,TX_CRDYI,TX_CRDZI,    &
                                RADI,EN,EMT,FRQ,MLAYER,ZBND,KKH,CDH,ANGLES,  &
                                KEYG,KACC,AJ,NZOB,ZOBG,NZSR,ZSRG,            &
                                RHOMIN,NHFILM,RRG,NRG,GRHF,GRHO0)
                  ENDIF
!
                  DO J=1,NETI
                     ENT(J,IB)=EN(J)
                  ENDDO
!
               ENDDO
!
! --- Store ent in case of multiple excitations
!
               IF (NTX_FD>1.OR.(CS_TYPE==1.AND.NPOL==2)) THEN
                  DO IB=1,NBODY
                     WRITE (10) (ENT(I,IB),I=1,NET(IB))
                  ENDDO
               ENDIF
!
            ENDDO
! *                               *
! *********************************
         ENDIF
!
         IF (KSYMM==1.AND.CS_TYPE/=1) THEN
! *********************************
! *                               *
            CALL EN_PRM_GS(NEQ,NBODY,SUB_BLOCK,NBMAX,NXMAX,NYMAX,NZMAX,NET, &
                       NX,NY,NZ,NCELL,XCELL,YCELL,ZCELL,CS_TYPE,NCRDI,      &
                       TX_CRDXI,TX_CRDYI,TX_CRDZI,RADI,EJGS,FRQ,MLAYER,     &
                       ZBND,KKH,CDH,ANGLES,KEYG,KACC,AJ,NZOB,ZOBG,          &
                       NZSR,ZSRG,RHOMIN,NHFILM,RRG,NRG,GRHF,GRHO0)
!
! --- The arrays EJGS and EJGS2 are very big.  They share the
!   memory with GA and GHF2 etc.  The unitary transforms
!   require both EJGS and EJGS2. But the array GHF2 storing
!   the grid values of the Hankel transforms is still in use
!   for computing the incident fields.  Thus EJGS must be
!   stored for now.
!
            WRITE (20) (EJGS(I),I=1,4*NEQ)
! *                               *
! *********************************
         ENDIF
!
      ENDDO
!
! --- Transform the incident field by the unitary matrix for
!   symmetrical model under controlled source excitations
!
      IF (KSYMM==1.AND.CS_TYPE/=1) THEN
!
         REWIND (20)
!
         DO IEXCI=1,NTX_FD
!
            READ (20) (EJGS(I),I=1,4*NEQ)
!
            DO LPR=1,NEQ/3
               DO LQR=1,4
                  DO II=1,3
                     IR=NEQ*(LQR-1)+3*(LPR-1)+II
                     EJGS2(IR)=(0.,0.)
                     DO LPC=1,NEQ/3
                        DO LQC=1,4
                           DO JJ=1,3
!
!--- Note that the entries of the unitary matrix for
!    lpr .ne. lpc and ii .ne. jj are zero
!
                              IF (LPR==LPC.AND.II==JJ) THEN
                              CALL MTRX_UNITARY(LPR,LQR,II,LPC,LQC,JJ,U)
!--- PMAX=NEQ/3.  JCOL is not computed in MTRX_UNITARY
                              JCOL=12*(LPC-1)+3*(LQC-1)+JJ
                              EJGS2(IR)=EJGS2(IR)+U*EJGS(JCOL)
                              ENDIF
                           ENDDO
                        ENDDO
                     ENDDO
                  ENDDO
               ENDDO
            ENDDO
!
! ---  Store EJGS2 in four files which correspond to the four
!    block matrices
!
!    The do loop IB is necessary because the incident fields
!    will be read so during system iteration later on
!
            NCB1=0
            DO IB=1,NBODY
               IF (IB>1) NCB1=NCB1+NET(IB-1)
               DO IQ=1,4
                  WRITE (40+IQ) (EJGS2(NCB1+I+NEQ*(IQ-1)),I=1,NET(IB))
               ENDDO
            ENDDO
!
         ENDDO
!
      ENDIF
!
      IF (CS_TYPE/=1.AND.KSYMM==1) THEN
         REWIND (20)
         DO IQ=1,4
            REWIND (40+IQ)
         ENDDO
      ELSEIF (NTX_FD>1.OR.(CS_TYPE==1.AND.NPOL==2)) THEN
         REWIND (10)
      ENDIF
!
      RETURN
      END
!
!**** End of MAIN_PRM_AT_CELL
!
!
      SUBROUTINE MAIN_SUPER_GRID(GSB1,INCL_DIELEC,CLMN2,KANIS,SBX,SBY,SBZ,   &
                                 NXS,NYS,NZS,XSB,YSB,ZSB,NSMR,FRQ,MLAYER,    &
                                 ZBND,LRYTH,KKH,CDH,HVK,NZOB,ZOBG,NZSR,ZSRG, &
                                 DMIN,NHFILM,RHOMIN,RHOMAX,RRG,RRG3,GRHF,    &
                                 GRHF3,GRHO0,GRHO03,ALMAX,KSFT,KCLMN,        &
                                 BLMIN,KACC,KUTCRP)
!
!**** Compute the nonidentical elements of the scattering matrix for the
!   use of spatial symmetry reduction.  This must be an independent
!   subroutine called directly by the main program because of memory
!   management.  See comments about the definittion of the arrays
!   GSB1 and GSB2 in the main program for detail.
!
!
!  SBX,SBY,SBZ,NXS,NYS,NZS,XSB,YSB,ZSB,NSMR,GSB1 are to be passed
!  into routine GSB
!
!
!
!**** Called by:  main
!
!**** Calls:      THR_D_HF_TABLE,  GSB,
!
!
      IMPLICIT NONE
!
      REAL ALMAX,BLMIN,CLMN2,DMIN,FRQ,RHOMAX,RHOMIN,                        &
           SBX,SBY,SBZ,XSB,YSB,ZSB,HFILL,HFILH
      INTEGER KACC,KANIS,KCLMN,INCL_DIELEC,KEYG,KSFT,KUTCRP,MLAYER,NHFILM,  &
              NRG,NRG3,NSMR,NXS,NYS,NZOB,NZS,NZSR
      COMPLEX GSB1(NSMR/3,3),GRHF(11,NHFILM,NZSR,NZOB),                     &
              GRHF3(11,NHFILM,NZSR),GRHO0(4,NZSR,NZOB),                     &
              GRHO03(4,NZSR),KKH(0:MLAYER),CDH(0:MLAYER)
      REAL ZOBG(NZOB),ZSRG(2,NZSR),RRG(NHFILM),RRG3(NHFILM),                &
           LRYTH(MLAYER),ZBND(0:MLAYER),HVK(0:MLAYER)
      EXTERNAL HFILL,HFILH
!
! ---- Compute the grid values for the interpolation of the
!    Hankel transforms
!
      KEYG=1
!
      IF (INCL_DIELEC==1) THEN
         CALL THR_D_HF_TABLE(HFILH,NHFILM,MLAYER,ZBND,LRYTH,HVK,KKH,KANIS,   &
                             KSFT,BLMIN,KEYG,DMIN,RHOMIN,RHOMAX,NZOB,ZOBG,   &
                             NZSR,ZSRG,ALMAX,RRG,NRG,RRG3,NRG3,GRHF,GRHF3,   &
                             GRHO0,GRHO03)
      ELSE
         CALL THR_D_HF_TABLE(HFILL,NHFILM,MLAYER,ZBND,LRYTH,HVK,KKH,KANIS,   &
                             KSFT,BLMIN,KEYG,DMIN,RHOMIN,RHOMAX,NZOB,ZOBG,   &
                             NZSR,ZSRG,ALMAX,RRG,NRG,RRG3,NRG3,GRHF,GRHF3,   &
                             GRHO0,GRHO03)
      ENDIF
!
! ---- Compute the scattering matrix elements of the super block
!    used in spatial symmetry reduction.
!
      CALL MTRX_SPSGSB(SBX,SBY,SBZ,NXS,NYS,NZS,XSB,YSB,ZSB,NSMR,GSB1,FRQ,    &
                       MLAYER,ZBND,CDH,HVK,NZOB,ZOBG,NZSR,ZSRG,RHOMIN,DMIN,  &
                       NHFILM,RRG,NRG,GRHF,RRG3,NRG3,GRHF3,GRHO0,GRHO03,     &
                       CLMN2,KCLMN,BLMIN,KACC,KUTCRP)
!
      RETURN
      END
!
!**** End of MAIN_SUPER_GRID
!
!
      SUBROUTINE MAIN_MATRICES(NW,INCL_DIELEC,NPOL,KSMR,CLMN,KANIS,KBOUND,   &
                               KSYMM,CS_TYPE,KCOND,GA,GSB2,IND,VV,GAI,EN,    &
                               EMT,CDB,MBODY,NBMAX,NXMAX,NYMAX,NZMAX,NSUBCM, &
                               NBODY,SUB_BLOCK,NET,NX,NY,NZ,NCELL,BLX,BLY,   &
                               BLZ,XCELL,YCELL,ZCELL,KCELL,NEQ,NMAX,NXI,NYI, &
                               NZI,NCELLI,BLXI,BLYI,BLZI,XCELLI,YCELLI,      &
                               ZCELLI,NXJ,NYJ,NZJ,NCELLJ,XCELLJ,YCELLJ,      &
                               ZCELLJ,SBX,SBY,SBZ,NXS,NYS,NZS,ZSB,NSMR,FRQ,  &
                               MLAYER,ZBND,LRYTH,KKH,CDH,CDV,HVK,NZOB,ZOBG,  &
                               NZSR,ZSRG,DMIN,NHFILM,RHOMIN,RHOMAX,RRG,RRG3, &
                               GRHF,GRHF3,GRHO0,GRHO03,ALMAX,KSFT,KCLMN,     &
                               BLMIN,KACC,KUTCRP)
!
!**** Form the scattering matrices
!
!
!
!  Parameters NHFILM, LRYTH,
!                  KANIS,KSFT,BLMIN,DMIN,RHOMIN,RHOMAX,
!                 NZOB,ZOBG,NZSR,ZSRG,ALMAX,
!                 RRG,NRG,RRG3,NRG3,GRHF,GRHF3,GRHO0,GRHO03
!  are to be passed into routine THR_D_HF_TABLE,  check THR_D_HF_TABLE for
!  their descriptions.
!
!  SBX,SBY,SBZ,NXS,NYS,NZS,ZSB,NSMR,GSB1 are to be passed
!  into routine GSB
!
!  commonly:
!  FRQ,MLAYER,ZBND,HVK,KKH,BLMIN,NZOB,ZOBG,NZSR,ZSRG,
!  RRG,NRG,DMIN,RHOMIN,NHFILM,GRHF,GRHF3,GRHO0,GRHO03
!
!
!**** Called by:  main
!
!**** Calls:  THR_D_HF_TABLE,  GSB,  MTRX_SPS,  MTRX_SPS1B,  MTRX_1MS,  MTRX_1M,
!             MTRX_SLV_FACTOR,  MTRX_SPSS,  MTRX_3MS,  MTRX_3M,  MTRX_GS,
!             MTRX_SPSM,  MTRX_M,  MTRX_GS,  MTRX_SPSSM,  MTRX_MS,
!
!
      IMPLICIT NONE
!
      REAL AEM,ALMAX,ANORM1,ANORM3,BLMIN,CLMN2,COND1,COND3,DMIN,FRQ,          &
           RHOMAX,RHOMIN,SBX,SBY,SBZ,ZSB,HFILL,HFILH
      INTEGER I,IB,II,IQ,J,JB,JJ,KACC,KANIS,KBOUND,KCLMN,KCOND,INCL_DIELEC,   &
              KEYG,KK,KS,KSFT,KSMR,CS_TYPE,KSYMM,NW
      INTEGER KUTCRP,LL,MBODY,MLAYER,N2,SUB_BLOCKI,SUB_BLOCKJ,NBMAX,NBODY,    &
              NCB1,NEQ,NETI,NETJ,NHFILM,NMAX,NPOL,NRG,NRG3,NSMR,NSUBCM
      INTEGER NXMAX,NXS,NYMAX,NYS,NZMAX,NZOB,NZS,NZSR
      COMPLEX GA(NMAX,NMAX),GSB2(NSMR/3,3)
!
      REAL  VV(NMAX),GAI(NMAX)
      INTEGER IND(NMAX)
      COMPLEX EN(NMAX),EMT(NMAX)
      INTEGER NX(NBMAX,MBODY),NY(NBMAX,MBODY),NZ(NBMAX,MBODY),          &
              NCELL(NBMAX,MBODY),                                       &
              NXI(NBMAX),NYI(NBMAX),NZI(NBMAX),NXJ(NBMAX),              &
              NYJ(NBMAX),NZJ(NBMAX),NCELLI(NBMAX),NCELLJ(NBMAX),        &
              NET(MBODY),KCELL(MBODY),SUB_BLOCK(MBODY)
      REAL BLX(NBMAX,MBODY),BLY(NBMAX,MBODY),BLZ(NBMAX,MBODY),          &
           XCELL(NXMAX,NBMAX,MBODY),YCELL(NYMAX,NBMAX,MBODY),           &
           ZCELL(NZMAX,NBMAX,MBODY)
      REAL BLXI(NBMAX),BLYI(NBMAX),BLZI(NBMAX),                         &
           XCELLI(NXMAX,NBMAX),YCELLI(NYMAX,NBMAX),                     &
           ZCELLI(NZMAX,NBMAX),XCELLJ(NXMAX,NBMAX),                     &
           YCELLJ(NYMAX,NBMAX),ZCELLJ(NZMAX,NBMAX)
      COMPLEX GRHF(11,NHFILM,NZSR,NZOB),GRHF3(11,NHFILM,NZSR),          &
              GRHO0(4,NZSR,NZOB),GRHO03(4,NZSR),                        &
              KKH(0:MLAYER),CDH(0:MLAYER),CDV(0:MLAYER)
      COMPLEX CDB(NSUBCM,NBMAX)
      REAL ZOBG(NZOB),ZSRG(2,NZSR),RRG(NHFILM),RRG3(NHFILM),            &
           LRYTH(MLAYER),ZBND(0:MLAYER),HVK(0:MLAYER)
      REAL CLMN(NBODY)
      EXTERNAL HFILL,HFILH
!
! ---- Compute the grid values for the interpolation of the
!    Hankel transforms if KSMR=0
!
      IF (KSMR==0) THEN
!
         KEYG=1
!
         IF (INCL_DIELEC==1) THEN
            CALL THR_D_HF_TABLE(HFILH,NHFILM,MLAYER,ZBND,LRYTH,HVK,KKH,KANIS, &
                                KSFT,BLMIN,KEYG,DMIN,RHOMIN,RHOMAX,NZOB,ZOBG, &
                                NZSR,ZSRG,ALMAX,RRG,NRG,RRG3,NRG3,GRHF,GRHF3, &
                                GRHO0,GRHO03)
         ELSE
            CALL THR_D_HF_TABLE(HFILL,NHFILM,MLAYER,ZBND,LRYTH,HVK,KKH,KANIS, &
                                KSFT,BLMIN,KEYG,DMIN,RHOMIN,RHOMAX,NZOB,ZOBG, &
                                NZSR,ZSRG,ALMAX,RRG,NRG,RRG3,NRG3,GRHF,GRHF3, &
                                GRHO0,GRHO03)
         ENDIF
!
      ENDIF
!
! --- compute the diagonal submatrices
!
      DO IB=1,NBODY
         SUB_BLOCKI=SUB_BLOCK(IB)
         NETI=NET(IB)
         DO I=1,SUB_BLOCKI
            NXI(I)=NX(I,IB)
            NYI(I)=NY(I,IB)
            NZI(I)=NZ(I,IB)
            NCELLI(I)=NCELL(I,IB)
            BLXI(I)=BLX(I,IB)
            BLYI(I)=BLY(I,IB)
            BLZI(I)=BLZ(I,IB)
            DO J=1,NXI(I)
               XCELLI(J,I)=XCELL(J,I,IB)
            ENDDO
            DO J=1,NYI(I)
               YCELLI(J,I)=YCELL(J,I,IB)
            ENDDO
            DO J=1,NZI(I)
               ZCELLI(J,I)=ZCELL(J,I,IB)
            ENDDO
         ENDDO
! --- Read cell conductivity from file CONDT (unit 62)
         READ (62) ((CDB(J,I),J=1,NCELL(I,IB)),I=1,SUB_BLOCK(IB))
!
         CLMN2=CLMN(IB)
!
         IF (KCELL(IB)==1.AND.(KANIS==0.OR.KBOUND==0)) THEN
! ----- The scattering matrix is symmetric
            KS=1
         ELSE
! ----- The scattering matrix is non-symmetric
            KS=0
         ENDIF
!
         IF (KSYMM==1.AND.CS_TYPE==1) THEN
!
! -------- Symmetric structure (two plane symmetries) with
!        plane wave excitations (MT)
!
!---- Compute the contributions due to quadrant II and III
!
            IF (KS/=1) THEN
               CALL MTRX_3M(NMAX,NETI,NXMAX,NYMAX,NZMAX,NXI,NYI,NZI,NCELLI,  &
                            NSUBCM,SUB_BLOCKI,XCELLI,YCELLI,ZCELLI,BLXI,     &
                            BLYI,BLZI,CDB,2,GA,FRQ,MLAYER,ZBND,CDH,CDV,HVK,  &
                            NZOB,ZOBG,NZSR,ZSRG,RHOMIN,DMIN,NHFILM,RRG,NRG,  &
                            GRHF,RRG3,NRG3,GRHF3,GRHO0,GRHO03,CLMN2,KCLMN,   &
                            BLMIN,KACC,KUTCRP)
! ----  Symmetric scattering matrix
            ELSEIF (KSMR==1) THEN
               CALL MTRX_SPSS(NSMR,MLAYER,ZBND,CDH,CDV,SBX,SBY,SBZ,NXS,NYS,  &
                              NZS,ZSB,NMAX,NETI,NXMAX,NYMAX,NZMAX,NXI,NYI,   &
                              NZI,NCELLI,NSUBCM,SUB_BLOCKI,XCELLI,YCELLI,    &
                              ZCELLI,CDB,2,GA,GSB2)
            ELSE
               CALL MTRX_3MS(NMAX,NETI,NXMAX,NYMAX,NZMAX,NXI,NYI,NZI,        &
                             NCELLI,NSUBCM,SUB_BLOCKI,XCELLI,YCELLI,ZCELLI,  &
                             BLXI,BLYI,BLZI,CDB,2,GA,FRQ,MLAYER,ZBND,CDH,    &
                             CDV,HVK,NZOB,ZOBG,NZSR,ZSRG,RHOMIN,DMIN,        &
                             NHFILM,RRG,NRG,GRHF,RRG3,NRG3,GRHF3,GRHO0,      &
                             GRHO03,CLMN2,KCLMN,BLMIN,KACC,KUTCRP)
! ----  Non-symmetric scattering matrix
            ENDIF
!
!---- Store the results in GREEN5
!     The do loop is used in order to match the read later on
            DO I=1,NETI
               WRITE (35) (GA(J,I),J=1,NETI)
            ENDDO
            REWIND (35)
!
!---- Compute the contributions due to quadrant I and IV
!
            IF (KS/=1) THEN
               CALL MTRX_3M(NMAX,NETI,NXMAX,NYMAX,NZMAX,NXI,NYI,NZI,         &
                            NCELLI,NSUBCM,SUB_BLOCKI,XCELLI,YCELLI,ZCELLI,   &
                            BLXI,BLYI,BLZI,CDB,1,GA,FRQ,MLAYER,ZBND,CDH,     &
                            CDV,HVK,NZOB,ZOBG,NZSR,ZSRG,RHOMIN,DMIN,         &
                            NHFILM,RRG,NRG,GRHF,RRG3,NRG3,GRHF3,GRHO0,       &
                            GRHO03,CLMN2,KCLMN,BLMIN,KACC,KUTCRP)
! ----  Symmetric scattering matrix
            ELSEIF (KSMR==1) THEN
               CALL MTRX_SPSS(NSMR,MLAYER,ZBND,CDH,CDV,SBX,SBY,SBZ,NXS,NYS,  &
                              NZS,ZSB,NMAX,NETI,NXMAX,NYMAX,NZMAX,NXI,NYI,   &
                              NZI,NCELLI,NSUBCM,SUB_BLOCKI,XCELLI,YCELLI,    &
                              ZCELLI,CDB,1,GA,GSB2)
            ELSE
               CALL MTRX_3MS(NMAX,NETI,NXMAX,NYMAX,NZMAX,NXI,NYI,NZI,        &
                             NCELLI,NSUBCM,SUB_BLOCKI,XCELLI,YCELLI,ZCELLI,  &
                             BLXI,BLYI,BLZI,CDB,1,GA,FRQ,MLAYER,ZBND,CDH,    &
                             CDV,HVK,NZOB,ZOBG,NZSR,ZSRG,RHOMIN,DMIN,        &
                             NHFILM,RRG,NRG,GRHF,RRG3,NRG3,GRHF3,GRHO0,      &
                             GRHO03,CLMN2,KCLMN,BLMIN,KACC,KUTCRP)
! ----  Non-symmetric scattering matrix
            ENDIF
!
!---- Store the results in GREEN6
!
            DO I=1,NETI
               WRITE (36) (GA(J,I),J=1,NETI)
            ENDDO
            REWIND (36)
!
! -------- Form the scattering matrix for B-polarization
!
            IF (NPOL/=1) THEN
               DO I=1,NETI
! ---- Read the results in GREEN5 by column
                  READ (35) (EMT(J),J=1,NETI)
                  DO J=1,NETI
                     GA(J,I)=GA(J,I)+EMT(J)
                  ENDDO
               ENDDO
!
               REWIND (35)
!
! ---- Factor the matrix with condition number computation
!
               CALL MTRX_SLV_FACTOR(NW,GA,NMAX,NETI,IND,VV,EN,GAI,KS,KCOND,  &
                                    ANORM1,ANORM3,COND1,COND3,AEM)
!
               WRITE (63) (IND(I),I=1,NETI)
!
               IF (KCOND==1) THEN
                  WRITE (NW,1010) IB,ANORM1,ANORM3
                  WRITE (NW,1020) COND1,COND3,AEM
               ENDIF
!
! --- Store the factored matrix
!
               DO I=1,NETI
                  WRITE (31) (GA(J,I),J=1,NETI)
               ENDDO
!
            ENDIF
!
! -------- Form the scattering matrix for E-polarization
!
            IF (NPOL/=0) THEN
!
!--- Read the contribution of quadrant I and IV from GREEN6
!
               DO I=1,NETI
                  READ (36) (GA(J,I),J=1,NETI)
               ENDDO
               REWIND (36)
!
               DO I=1,NETI
! ---- Read the results in GREEN5 by column
                  READ (35) (EMT(J),J=1,NETI)
                  DO J=1,NETI
                     GA(J,I)=GA(J,I)-EMT(J)
                  ENDDO
               ENDDO
!
               REWIND (35)
!
! ---- Factor the matrix with condition number computation
!
               CALL MTRX_SLV_FACTOR(NW,GA,NMAX,NETI,IND,VV,EN,GAI,KS,KCOND,  &
                                    ANORM1,ANORM3,COND1,COND3,AEM)
!
!--- The array IND for E-polarization must be stored in
!    another file
!
               WRITE (64) (IND(I),I=1,NETI)
!
               IF (KCOND==1) THEN
                  WRITE (NW,1030) IB,ANORM1,ANORM3
                  WRITE (NW,1040) COND1,COND3,AEM
               ENDIF
!
! --- Store the factored matrix
!
               DO I=1,NETI
                  WRITE (33) (GA(J,I),J=1,NETI)
               ENDDO
!
!
            ENDIF
         ELSEIF (KSYMM==1.AND.CS_TYPE/=1) THEN
!
! -------- Symmetric structure (two plane symmetries) with
!        arbitrary excitations (CSAMT).
!
!        Block diagonalization using group theory.
!        Note that all the four block matrices obtained
!        by block diagonalization are further partioned
!        into block submatrices to be used by system
!        iteration.  Here the diagonal submatrices for
!        each of the four block matrices are computed.
!
!        In order to save memory as much as possible,
!        only one column for each of the four block
!        matrices is computed at a time which is
!        then stored.
!
            NCB1=0
            DO LL=1,SUB_BLOCKI
               IF (LL>1) NCB1=NCB1+NCELLI(LL-1)
               DO II=1,NXI(LL)
                  DO JJ=1,NYI(LL)
                     DO KK=1,NZI(LL)
!
                        N2=(II-1)*NYI(LL)*NZI(LL)+(JJ-1)*NZI(LL)+KK+NCB1
!
                        CALL MTRX_GS(KSMR,NSMR,NXS,NYS,NZS,SBX,SBY,SBZ,ZSB,   &
                                   KS,1,12,N2,BLXI(LL),BLYI(LL),BLZI(LL),     &
                                   XCELLI(II,LL),YCELLI(JJ,LL),ZCELLI(KK,LL), &
                                   NMAX,NXMAX,NYMAX,NZMAX,NXI,NYI,NZI,NCELLI, &
                                   NSUBCM,SUB_BLOCKI,XCELLI,YCELLI,ZCELLI,    &
                                   CDB,GA,GSB2,FRQ,MLAYER,ZBND,CDH,CDV,HVK,   &
                                   NZOB,ZOBG,NZSR,ZSRG,RHOMIN,DMIN,NHFILM,    &
                                   RRG,NRG,GRHF,RRG3,NRG3,GRHF3,GRHO0,GRHO03, &
                                   CLMN2,KCLMN,BLMIN,KACC,KUTCRP)
!
! --- Store the four submatrices
!
                        DO IQ=1,4
                           DO J=1,3
                              WRITE (31+IQ) (GA(I,3*(IQ-1)+J),I=1,NETI)
                           ENDDO
                        ENDDO
!
                     ENDDO
                  ENDDO
               ENDDO
            ENDDO
         ELSE
!
! -------- General, non-symmeytric structure
!
            IF (KS/=1) THEN
! ----  Non-symmetric scattering matrix
               CALL MTRX_1M(NMAX,NETI,NXMAX,NYMAX,NZMAX,NXI,NYI,NZI,      &
                          NCELLI,NSUBCM,SUB_BLOCKI,XCELLI,YCELLI,ZCELLI,  &
                          BLXI,BLYI,BLZI,CDB,GA,FRQ,MLAYER,ZBND,CDH,CDV,  &
                          HVK,NZOB,ZOBG,NZSR,ZSRG,RHOMIN,DMIN,            &
                          NHFILM,RRG,NRG,GRHF,RRG3,NRG3,GRHF3,GRHO0,      &
                          GRHO03,CLMN2,KCLMN,BLMIN,KACC,KUTCRP)
! ----  Symmetric scattering matrix
            ELSEIF (KSMR==1) THEN
               CALL MTRX_SPS(NSMR,MLAYER,ZBND,CDH,CDV,SBX,SBY,SBZ,NXS,NYS,NZS,&
                          ZSB,NMAX,NETI,NXMAX,NYMAX,NZMAX,NXI,NYI,NZI,NCELLI, &
                          NSUBCM,SUB_BLOCKI,XCELLI,YCELLI,ZCELLI,CDB,GSB2,GA)
            ELSEIF (SUB_BLOCKI==1) THEN
!--- Use the spatial symmetry reduction for a single block
!    substructure if it cannot be use for the whole structure
               CALL MTRX_SPS1B(NMAX,NETI,NXMAX,NYMAX,NZMAX,NXI,NYI,NZI,NSUBCM,&
                          SUB_BLOCKI,XCELLI,YCELLI,ZCELLI,BLXI,BLYI,BLZI,   &
                          CDB,GA,FRQ,MLAYER,ZBND,CDH,CDV,HVK,NZOB,ZOBG,     &
                          NZSR,ZSRG,RHOMIN,DMIN,NHFILM,RRG,NRG,GRHF,RRG3,   &
                          NRG3,GRHF3,GRHO0,GRHO03,CLMN2,KCLMN,BLMIN,KACC,   &
                          KUTCRP)
            ELSE
               CALL MTRX_1MS(NMAX,NETI,NXMAX,NYMAX,NZMAX,NXI,NYI,NZI,NCELLI, &
                             NSUBCM,SUB_BLOCKI,XCELLI,YCELLI,ZCELLI,BLXI,    &
                             BLYI,BLZI,CDB,GA,FRQ,MLAYER,ZBND,CDH,CDV,HVK,   &
                             NZOB,ZOBG,NZSR,ZSRG,RHOMIN,DMIN,NHFILM,RRG,NRG, &
                             GRHF,RRG3,NRG3,GRHF3,GRHO0,GRHO03,CLMN2,KCLMN,  &
                             BLMIN,KACC,KUTCRP)
            ENDIF
!
! ---- Factor the matrix with condition number computation.
!    EN works here as a working array only
!
            CALL MTRX_SLV_FACTOR(NW,GA,NMAX,NETI,IND,VV,EN,GAI,KS,KCOND,     &
                                 ANORM1,ANORM3,COND1,COND3,AEM)
!
!--- Store ind in file index1 in unit 63
!
            WRITE (63) (IND(I),I=1,NETI)
!
            IF (KCOND==1) THEN
               WRITE (NW,1050) IB,ANORM1,ANORM3
               WRITE (NW,1060) COND1,COND3,AEM
            ENDIF
!
! --- Store the factored matrix in unit 31
!   The do loop is used to reduced the stacks for excution
!
!   Note that if nbody = 1 the array ga needs not to be stored
!
            IF (NBODY>1) THEN
               DO I=1,NETI
                  WRITE (31) (GA(J,I),J=1,NETI)
               ENDDO
!
            ENDIF
         ENDIF
!
      ENDDO
!
      IF (KSYMM==1.AND.CS_TYPE/=1) THEN
         DO IQ=1,4
            REWIND (31+IQ)
         ENDDO
      ELSE
         IF (KSYMM==1.OR.NBODY>1) REWIND (31)
         IF (KSYMM==1.AND.CS_TYPE==1) REWIND (33)
      ENDIF
!
      IF (KSYMM/=0.AND.CS_TYPE/=1) THEN
!
! --- Read the submatrices in units 32, 33, 34, and 35 and
!   factorize them and store them in unit 31, 32, 33, and 34
!
         DO IQ=1,4
!
            IF (KCOND==1) WRITE (NW,1070) IQ
!
            DO IB=1,NBODY
               NETI=NET(IB)
!
               IF (KCELL(IB)==1.AND.(KANIS==0.OR.KBOUND==0)) THEN
! ----- The block matrix is symmetric
                  KS=1
               ELSE
! ----- The block matrix is non-symmetric
                  KS=0
               ENDIF
!
               DO I=1,NETI
                  READ (31+IQ) (GA(J,I),J=1,NETI)
               ENDDO
!
! ---- Determine the lower triangles of the block matrices
!    for symmetric matrices
!
               IF (KS==1) THEN
                  DO I=1,NETI
                     DO J=1,NETI
                        IF (J<I) GA(J,I)=GA(I,J)
                     ENDDO
                  ENDDO
               ENDIF
!
! ---- Factor the matrix with condition number computation.
!    EN works here as a working array only
!
               CALL MTRX_SLV_FACTOR(NW,GA,NMAX,NETI,IND,VV,EN,GAI,KS,KCOND,    &
                                    ANORM1,ANORM3,COND1,COND3,AEM)
!
!--- Store ind in files index1, index2, index3, or index4
!    in units 63, 64, 65, or 66 according to the value of IQ
!
               WRITE (62+IQ) (IND(I),I=1,NETI)
!
               IF (KCOND==1) THEN
                  IF (NBODY==1) WRITE (NW,1080) ANORM1,ANORM3
                  IF (NBODY>1) WRITE (NW,1090) IB,ANORM1,ANORM3
                  WRITE (NW,1100) COND1,COND3,AEM
               ENDIF
!
! --- Store the factored matrix in unit 31, 32, 33, and 34
!
               DO I=1,NETI
                  WRITE (30+IQ) (GA(J,I),J=1,NETI)
               ENDDO
!
            ENDDO
!
            REWIND (31+IQ)
!
         ENDDO
!
         DO IQ=1,4
            REWIND (30+IQ)
         ENDDO
      ENDIF
!
      REWIND (62)
!
      DO IQ=1,4
         REWIND (62+IQ)
      ENDDO
!
! ---------- Form the mutual-coupling, or off-diagonal matrices.
!          Note that the interaction matrices between two
!          substructures, ib and jb, are assumed to be
!          non-symmetric, i.e., the reciprocity do not hold
!          true due to different cell sizes in general cases.
!
!---- For efficiency in array references in interpolation,
!     jb is designed to be the out-loop here
!
!
!---- In case of spatial symmetry reductions,  the mutual
!     coupling matrices need not be formed here.  They will
!     be computed in each iteration in order to save both
!     the disk storage requirement and the disk access time.
!     For symmetric bodies with group reduction the computation
!     time needed for complete the block diagonalizations is
!     too much to be economical.  Thus the mutual interaction
!     matrices will be always stored unless the total disk
!     storage requirements exceed ca. 200 M-bytes, i.e., about
!     800 cells per quadrant.
!
!
      IF (.NOT.(NBODY==1.OR.KSMR==1.AND.(KSYMM==0.OR.CS_TYPE==1).OR.  &
          KSMR==1.AND.CS_TYPE/=1.AND.KSYMM==1.AND.NEQ/3>800)) THEN
!
         DO JB=1,NBODY
!
            SUB_BLOCKJ=SUB_BLOCK(JB)
            NETJ=NET(JB)
            DO I=1,SUB_BLOCKJ
               NXJ(I)=NX(I,JB)
               NYJ(I)=NY(I,JB)
               NZJ(I)=NZ(I,JB)
               NCELLJ(I)=NCELL(I,JB)
               DO J=1,NXJ(I)
                  XCELLJ(J,I)=XCELL(J,I,JB)
               ENDDO
               DO J=1,NYJ(I)
                  YCELLJ(J,I)=YCELL(J,I,JB)
               ENDDO
               DO J=1,NZJ(I)
                  ZCELLJ(J,I)=ZCELL(J,I,JB)
               ENDDO
            ENDDO
!
            DO IB=1,NBODY
!
               SUB_BLOCKI=SUB_BLOCK(IB)
               NETI=NET(IB)
               DO I=1,SUB_BLOCKI
                  NXI(I)=NX(I,IB)
                  NYI(I)=NY(I,IB)
                  NZI(I)=NZ(I,IB)
                  NCELLI(I)=NCELL(I,IB)
                  BLXI(I)=BLX(I,IB)
                  BLYI(I)=BLY(I,IB)
                  BLZI(I)=BLZ(I,IB)
                  DO J=1,NXI(I)
                     XCELLI(J,I)=XCELL(J,I,IB)
                  ENDDO
                  DO J=1,NYI(I)
                     YCELLI(J,I)=YCELL(J,I,IB)
                  ENDDO
                  DO J=1,NZI(I)
                     ZCELLI(J,I)=ZCELL(J,I,IB)
                  ENDDO
               ENDDO
!
               CLMN2=CLMN(IB)
!
               IF (IB/=JB) THEN
!
                  IF (KSYMM==1.AND.CS_TYPE/=1) THEN
!
! ---- Groupe reduction for controlled source problems
!
                     NCB1=0
                     DO LL=1,SUB_BLOCKI
                        IF (LL>1) NCB1=NCB1+NCELLI(LL-1)
                        DO II=1,NXI(LL)
                           DO JJ=1,NYI(LL)
                              DO KK=1,NZI(LL)
!
                              N2=(II-1)*NYI(LL)*NZI(LL)+(JJ-1)*NZI(LL)   &
                                 +KK+NCB1
!
! ---   cdb is not used and is thus arbitrary
!
                              CALL MTRX_GS(KSMR,NSMR,NXS,NYS,NZS,SBX,SBY,SBZ,  &
                                         ZSB,0,0,12,N2,BLXI(LL),BLYI(LL),      &
                                         BLZI(LL),XCELLI(II,LL),YCELLI(JJ,LL), &
                                         ZCELLI(KK,LL),NMAX,NXMAX,NYMAX,NZMAX, &
                                         NXJ,NYJ,NZJ,NCELLJ,NSUBCM,SUB_BLOCKJ, &
                                         XCELLJ,YCELLJ,ZCELLJ,CDB,GA,GSB2,FRQ, &
                                         MLAYER,ZBND,CDH,CDV,HVK,NZOB,ZOBG,    &
                                         NZSR,ZSRG,RHOMIN,DMIN,NHFILM,RRG,NRG, &
                                         GRHF,RRG3,NRG3,GRHF3,GRHO0,GRHO03,    &
                                         CLMN2,KCLMN,BLMIN,KACC,KUTCRP)
!
! --- Store the four submatrices
!
!   Note that the submatrices as computed by the routines
!   MTRX_SPSM, MTRX_M, MTRX_SPSSM, MTRX_MS, MTRX_SPSSM, and MTRX_MS
!   have their sign reversed as compared with the results
!   here.  Thus -GA is stored in order to use the same
!   algorithm for system iteration
!
                              DO IQ=1,4
                              DO J=1,3
                              WRITE (34+IQ) (-GA(I,3*(IQ-1)+J),I=1,NETJ)
                              ENDDO
                              ENDDO
!
                              ENDDO
                           ENDDO
                        ENDDO
!
                     ENDDO
                  ELSEIF (KSYMM==1.AND.CS_TYPE==1) THEN
!
! ---- Compute the contributions due to quadrant II and III
!    for plane wave excitations
!
                     IF (KSMR==1) THEN
                        CALL MTRX_SPSSM(SBX,SBY,SBZ,NXS,NYS,NZS,ZSB,NMAX,    &
                           NETI,NXMAX,NYMAX,NZMAX,NXJ,NYJ,NZJ,NCELLJ,        &
                           SUB_BLOCKJ,XCELLJ,YCELLJ,ZCELLJ,NXI,NYI,NZI,      &
                           NCELLI,SUB_BLOCKI,XCELLI,YCELLI,ZCELLI,2,GA,NSMR, &
                           GSB2)
                     ELSE
                        CALL MTRX_MS(NMAX,NETI,NXMAX,NYMAX,NZMAX,NXJ,NYJ,   &
                           NZJ,NCELLJ,SUB_BLOCKJ,XCELLJ,YCELLJ,ZCELLJ,NXI,  &
                           NYI,NZI,NCELLI,SUB_BLOCKI,XCELLI,YCELLI,ZCELLI,  &
                           BLXI,BLYI,BLZI,2,GA,FRQ,MLAYER,ZBND,CDH,HVK,     &
                           NZOB,ZOBG,NZSR,ZSRG,RHOMIN,DMIN,                 &
                           NHFILM,RRG,NRG,GRHF,RRG3,NRG3,GRHF3,GRHO0,       &
                           GRHO03,CLMN2,KCLMN,BLMIN,KACC,KUTCRP)
                     ENDIF
!
!---- Store the results in GREEN5
!     The do loop is used in order to match the read later on
                     DO I=1,NETI
                        WRITE (35) (GA(J,I),J=1,NETJ)
                     ENDDO
                     REWIND (35)
!
!---- Compute the contributions due to quadrant I and IV
!
                     IF (KSMR==1) THEN
                        CALL MTRX_SPSSM(SBX,SBY,SBZ,NXS,NYS,NZS,ZSB,NMAX,    &
                           NETI,NXMAX,NYMAX,NZMAX,NXJ,NYJ,NZJ,NCELLJ,        &
                           SUB_BLOCKJ,XCELLJ,YCELLJ,ZCELLJ,NXI,NYI,NZI,      &
                           NCELLI,SUB_BLOCKI,XCELLI,YCELLI,ZCELLI,1,GA,NSMR, &
                           GSB2)
                     ELSE
                        CALL MTRX_MS(NMAX,NETI,NXMAX,NYMAX,NZMAX,NXJ,NYJ,   &
                           NZJ,NCELLJ,SUB_BLOCKJ,XCELLJ,YCELLJ,ZCELLJ,NXI,  &
                           NYI,NZI,NCELLI,SUB_BLOCKI,XCELLI,YCELLI,ZCELLI,  &
                           BLXI,BLYI,BLZI,1,GA,FRQ,MLAYER,ZBND,CDH,HVK,     &
                           NZOB,ZOBG,NZSR,ZSRG,RHOMIN,DMIN,                 &
                           NHFILM,RRG,NRG,GRHF,RRG3,NRG3,GRHF3,GRHO0,       &
                           GRHO03,CLMN2,KCLMN,BLMIN,KACC,KUTCRP)
                     ENDIF
!
!---- Store the results in GREEN6
!
                     DO I=1,NETI
                        WRITE (36) (GA(J,I),J=1,NETJ)
                     ENDDO
                     REWIND (36)
!
! -------- Form the interaction matrices for B-polarization
!
                     IF (NPOL/=1) THEN
!
                        DO I=1,NETI
! ---- Read the results in GREEN5 by column
                           READ (35) (EMT(J),J=1,NETJ)
                           DO J=1,NETJ
                              GA(J,I)=GA(J,I)+EMT(J)
                           ENDDO
                        ENDDO
!
                        REWIND (35)
!
! ---- Store the B-p interaction matrices in GREEN2
!
                        DO I=1,NETI
                           WRITE (32) (GA(J,I),J=1,NETJ)
                        ENDDO
!
                     ENDIF
!
! -------- Form the interaction matrices for E-polarization
!
                     IF (NPOL/=0) THEN
!
!--- Read the contribution of quadrant I and IV from GREEN6
!
                        DO I=1,NETI
                           READ (36) (GA(J,I),J=1,NETJ)
                        ENDDO
                        REWIND (36)
!
                        DO I=1,NETI
! ---- Read the results in GREEN5 by column
                           READ (35) (EMT(J),J=1,NETJ)
                           DO J=1,NETJ
                              GA(J,I)=GA(J,I)-EMT(J)
                           ENDDO
                        ENDDO
!
                        REWIND (35)
!
! ---- Store the E-p interaction matrices in GREEN4
!
                        DO I=1,NETI
                           WRITE (34) (GA(J,I),J=1,NETJ)
                        ENDDO
!
                     ENDIF
                  ELSE
!
                     IF (KSMR==1) THEN
                        CALL MTRX_SPSM(SBX,SBY,SBZ,NXS,NYS,NZS,ZSB,NMAX,NETI,&
                           NXMAX,NYMAX,NZMAX,NXJ,NYJ,NZJ,NCELLJ,SUB_BLOCKJ,  &
                           XCELLJ,YCELLJ,ZCELLJ,NXI,NYI,NZI,NCELLI,          &
                           SUB_BLOCKI,XCELLI,YCELLI,ZCELLI,GA,NSMR,GSB2)
                     ELSE
                        CALL MTRX_M(NMAX,NETI,NXMAX,NYMAX,NZMAX,NXJ,NYJ,    &
                           NZJ,NCELLJ,SUB_BLOCKJ,XCELLJ,YCELLJ,ZCELLJ,NXI,  &
                           NYI,NZI,NCELLI,SUB_BLOCKI,XCELLI,YCELLI,ZCELLI,  &
                           BLXI,BLYI,BLZI,GA,FRQ,MLAYER,ZBND,CDH,HVK,       &
                           NZOB,ZOBG,NZSR,ZSRG,RHOMIN,DMIN,                 &
                           NHFILM,RRG,NRG,GRHF,RRG3,NRG3,GRHF3,GRHO0,       &
                           GRHO03,CLMN2,KCLMN,BLMIN,KACC,KUTCRP)
                     ENDIF
!
! ---- Store the interaction matrices in GREEN2
!
                     DO I=1,NETI
                        WRITE (32) (GA(J,I),J=1,NETJ)
!
                     ENDDO
                  ENDIF
               ENDIF
!
            ENDDO
         ENDDO
!
         IF (KSYMM==1.AND.CS_TYPE/=1) THEN
            DO IQ=1,4
               REWIND (34+IQ)
            ENDDO
         ELSE
            REWIND (32)
            IF (KSYMM==1) REWIND (34)
         ENDIF
      ENDIF
!


      RETURN
 1010 FORMAT (/'Maximal column and maximal row norms of the ',           &
              'scattering matrix',/'  for substructure #',I3,            &
              ' for B-polarization:',2E15.7)
 1020 FORMAT ('Condition numbers after these two norms:',3X,2E15.7,      &
              /'Maximal diagonal element of the matrix:',4X,E15.7)
 1030 FORMAT (/'Maximal column and maximal row norms of the ',           &
              'scattering matrix',/'  for substructure #',I3,            &
              ' for E-polarization:',2E15.7)
 1040 FORMAT ('Condition numbers after these two norms:',3X,2E15.7,      &
              /'Maximal diagonal element of the matrix:',4X,E15.7)
 1050 FORMAT (/'Maximal column and maximal row norms of the ',           &
              'scattering matrix',/'  for substructure #',I3,':',16X,    &
              2E15.7)
 1060 FORMAT ('Condition numbers after these two norms:',2E15.7,         &
              /'Maximal diagonal element of the matrix:',E16.7)
 1070 FORMAT (/'Norms and condition numbers of the ',                    &
              'submatrices for quadrant',I2)
 1080 FORMAT (/'    Maximal column and row norms:           ',2E15.7)
 1090 FORMAT ('  Substructure #',I3,':',                                 &
              /'    Maximal column and row norms:           ',2E15.7)
 1100 FORMAT ('    Condition numbers after these two norms:',2E15.7,     &
              /'    Maximal diagonal element of the matrix:',E16.7)
      END
!
!**** End of MAIN_MATRICES
!
!
      SUBROUTINE MAIN_SOLVER(NW,GA,IND,EMT,EN,ENT,NET,JST,EJGS,EJGS2,        &
                             KACC,KSMR,KSYMM,CS_TYPE,KANIS,KBOUND,NTX_FD,    &
                             LP1,LP2,NPOL,MBODY,NBMAX,NXMAX,NYMAX,NZMAX,     &
                             NMAX,NBODY,SUB_BLOCK,NX,NY,NZ,NCELL,NCT,KCELL,  &
                             XCELL,YCELL,ZCELL,BLX,BLY,BLZ,NXI,NYI,NZI,      &
                             NCELLI,XCELLI,YCELLI,ZCELLI,BLXI,BLYI,BLZI,     &
                             NXJ,NYJ,NZJ,NCELLJ,XCELLJ,YCELLJ,ZCELLJ,        &
                             SBX,SBY,SBZ,NXS,NYS,NZS,ZSB,NSMR,GSB2,NEQ)
!
!--- NITMAX is the maximal number of iteration allowed in the
!    program.  It is also the maximal length of the array ERR.
!
      IMPLICIT NONE
!
      REAL EPS,FRACCN,SBX,SBY,SBZ,TJS,U,ZSB
      INTEGER I,IB,IEXCI,II,IQ,IROW,J,JB,JC,JJ,KACC,KANIS,KBOUND,KPOL,   &
              KSMR,CS_TYPE,KSYMM,LP1,LP2,LPC,NW
      INTEGER LPR,LQC,LQR,MBODY,SUB_BLOCKI,SUB_BLOCKJ,NBMAX,NBODY,NCB1,NCMAX,&
              NEQ,NERR,NETI,NETJ,NITER,NITM,NITMAX,NMAX,NPOL,NQ
      INTEGER NSMR,NUNIT,NTX_FD,NXMAX,NXS,NYMAX,NYS,NZMAX,NZS
      PARAMETER (NITMAX=500)
!
      REAL ERR(NITMAX)
!
      COMPLEX GA(NMAX,NMAX)

!**** Only one of them
      COMPLEX GSB2(NSMR/3,3)
!   COMPLEX GSB1(NSMR/3,3),GSB2(NSMR/3,3)

      INTEGER IND(NMAX)
      COMPLEX EN(NMAX),EMT(NMAX),ENT(NMAX,MBODY),JST(NMAX,MBODY),   &
              EJGS(4*NMAX*MBODY),EJGS2(4*NMAX*MBODY)
      INTEGER NX(NBMAX,MBODY),NY(NBMAX,MBODY),NZ(NBMAX,MBODY),      &
              NCELL(NBMAX,MBODY),                                   &
              NXI(NBMAX),NYI(NBMAX),NZI(NBMAX),NXJ(NBMAX),          &
              NYJ(NBMAX),NZJ(NBMAX),NCELLI(NBMAX),NCELLJ(NBMAX),    &
              NCT(MBODY),NET(MBODY),KCELL(MBODY),SUB_BLOCK(MBODY)
      REAL BLX(NBMAX,MBODY),BLY(NBMAX,MBODY),BLZ(NBMAX,MBODY),      &
           XCELL(NXMAX,NBMAX,MBODY),YCELL(NYMAX,NBMAX,MBODY),       &
           ZCELL(NZMAX,NBMAX,MBODY)
      REAL BLXI(NBMAX),BLYI(NBMAX),BLZI(NBMAX),                     &
           XCELLI(NXMAX,NBMAX),YCELLI(NYMAX,NBMAX),                 &
           ZCELLI(NZMAX,NBMAX),XCELLJ(NXMAX,NBMAX),                 &
           YCELLJ(NYMAX,NBMAX),ZCELLJ(NZMAX,NBMAX)
!
! --- Solving the matrix equations for the scattering currents
!   in the 3D structure using the system iteration method
!
!-- The maximal number of iterations is determined by the
!   number of substructures and the total number of cells.
!   500 cells as reference
!
      NCMAX=0
      DO IB=1,NBODY
         NCMAX=NCMAX+NCT(IB)
      ENDDO
      FRACCN=FLOAT(NCMAX)/500.
!
      NITM=2*NBODY**2
      IF (NITM<60) NITM=60
      NITM=INT(NITM*(1.+FRACCN))
      IF (NITM>NITMAX) NITM=NITMAX
!
!-- KACC=1 corresponds to approximate solutions with an
!   accuracy of 20%.  NITLM will also be limited to be 3
!   for the fast solver
!
      IF (KACC==1) THEN
         EPS=2.E-01
         NITM=3
      ELSEIF (KACC>=2.AND.KACC<=4) THEN
         EPS=1.E-04
      ELSE
         EPS=1.E-05
      ENDIF
!
      IF (KSYMM==1.AND.CS_TYPE/=1) THEN
         NQ=4
      ELSE
         NQ=1
      ENDIF
!
!--- Start the loop for the four quadrants in case of
!    group reduction
!
      DO IQ=1,NQ
!
! ---- Start the loop for multiple excitations
!
         DO IEXCI=1,NTX_FD
!
!--- Start system iteration for the B and E-polarization for
!    plane wave excitations
!
            DO KPOL=LP1,LP2
!
               IF (NQ/=1) THEN
! -- Read ent from unit 41, 42, 43, or 44 for the corresponding
!    quadrants
                  DO IB=1,NBODY
                     READ (40+IQ) (EMT(I),I=1,NET(IB))
                     DO J=1,NET(IB)
                        ENT(J,IB)=EMT(J)
                     ENDDO
                  ENDDO
! -- Read ent from unit 10 for multiple excitations
               ELSEIF (NTX_FD>1.OR.NPOL==2) THEN
                  DO IB=1,NBODY
                     READ (10) (EMT(I),I=1,NET(IB))
                     DO J=1,NET(IB)
                        ENT(J,IB)=EMT(J)
                     ENDDO
                  ENDDO
               ENDIF
!
! ---- Assign jst initial values (zero)
!
               DO IB=1,NBODY
                  DO I=1,NET(IB)
                     JST(I,IB)=(0.,0.)
                  ENDDO
               ENDDO
!
               NITER=1
   10          ERR(NITER)=0.
               TJS=0.
               NERR=0
!
! ---- Loop 4500 is for the solutions of the scattering currents
!    in the substructures (# JB)
!
               DO JB=1,NBODY
                  NETJ=NET(JB)
!    LET=NETJ*(NETJ+1)/2
                  NERR=NERR+NETJ
!
                  DO I=1,NETJ
                     EMT(I)=(0.,0.)
                  ENDDO
!
! ---- Computing mutual interactions, namely, the scattered fields
!    of all other substructure to substructures jb
!
!--- The mutual interaction matrices will be either read from
!    the disk or computed with pre-computed values using the
!    spatial symmetry property of the Green's functions.
!    See the comments before the line labeled 5800 for more
!    explanations
!
                  DO IB=1,NBODY
!
                     IF (IB/=JB) THEN
                        NETI=NET(IB)
!
                        IF (KSMR==1.AND.(KSYMM==0.OR.CS_TYPE==1).OR.  &
                            KSMR==1.AND.CS_TYPE/=1.AND.KSYMM==1.AND.  &
                            NEQ/3>800) THEN
!
!    ENDIF
!
! ---- Re-compute the matrices using spatial symmetries
!
! -- The following lines are similar to those for forming the
!    mutual-coupling matrices earlier in the program,  with
!    slight differences in some subroutines.
!
! -- The following lines for jb may be moved outside the
!    ib loop.
!
                           SUB_BLOCKJ=SUB_BLOCK(JB)
                           NETJ=NET(JB)
                           DO I=1,SUB_BLOCKJ
                              NXJ(I)=NX(I,JB)
                              NYJ(I)=NY(I,JB)
                              NZJ(I)=NZ(I,JB)
                              NCELLJ(I)=NCELL(I,JB)
                              DO J=1,NXJ(I)
                              XCELLJ(J,I)=XCELL(J,I,JB)
                              ENDDO
                              DO J=1,NYJ(I)
                              YCELLJ(J,I)=YCELL(J,I,JB)
                              ENDDO
                              DO J=1,NZJ(I)
                              ZCELLJ(J,I)=ZCELL(J,I,JB)
                              ENDDO
                           ENDDO
!
                           SUB_BLOCKI=SUB_BLOCK(IB)
                           NETI=NET(IB)
                           DO I=1,SUB_BLOCKI
                              NXI(I)=NX(I,IB)
                              NYI(I)=NY(I,IB)
                              NZI(I)=NZ(I,IB)
                              NCELLI(I)=NCELL(I,IB)
                              BLXI(I)=BLX(I,IB)
                              BLYI(I)=BLY(I,IB)
                              BLZI(I)=BLZ(I,IB)
                              DO J=1,NXI(I)
                              XCELLI(J,I)=XCELL(J,I,IB)
                              ENDDO
                              DO J=1,NYI(I)
                              YCELLI(J,I)=YCELL(J,I,IB)
                              ENDDO
                              DO J=1,NZI(I)
                              ZCELLI(J,I)=ZCELL(J,I,IB)
                              ENDDO
                           ENDDO
!
                           IF (KSYMM==1.AND.CS_TYPE/=1) THEN
!
! ---- Groupe reduction for controlled source problems
!
!
                              CALL MTRX_SMRGS(NXS,NYS,NZS,SBX,SBY,SBZ,ZSB,  &
                                 NMAX,NXMAX,NYMAX,NZMAX,NETI,SUB_BLOCKI,    &
                                 NCELLI,XCELLI,YCELLI,ZCELLI,NXI,NYI,       &
                                 NZI,NETJ,SUB_BLOCKJ,NCELLJ,NXJ,NYJ,NZJ,    &
                                 XCELLJ,YCELLJ,ZCELLJ,IQ,GA,NSMR,GSB2)
                           ELSEIF (KSYMM==1.AND.CS_TYPE==1) THEN
!
! ---- Plane wave excitations
!
                              CALL MTRX_SPSSM2(SBX,SBY,SBZ,NXS,NYS,NZS,ZSB, &
                                 NMAX,NETJ,NETI,NXMAX,NYMAX,NZMAX,NXJ,      &
                                 NYJ,NZJ,NCELLJ,SUB_BLOCKJ,XCELLJ,YCELLJ,   &
                                 ZCELLJ,NXI,NYI,NZI,NCELLI,SUB_BLOCKI,      &
                                 XCELLI,YCELLI,ZCELLI,KPOL,GA,NSMR,GSB2)
                           ELSE
!
!
                              CALL MTRX_SPSM(SBX,SBY,SBZ,NXS,NYS,NZS,ZSB,    &
                                 NMAX,NETI,NXMAX,NYMAX,NZMAX,NXJ,NYJ,        &
                                 NZJ,NCELLJ,SUB_BLOCKJ,XCELLJ,YCELLJ,ZCELLJ, &
                                 NXI,NYI,NZI,NCELLI,SUB_BLOCKI,XCELLI,       &
                                 YCELLI,ZCELLI,GA,NSMR,GSB2)
                           ENDIF
                        ELSE
!
!    IF(KSMR.EQ.0 .OR.
!   +   KSMR.EQ.1.AND.CS_TYPE.NE.1.AND.KSYMM.EQ.1.AND.
!   +   NEQ/3.LT.800) THEN
!
! ---- Read the interaction matrices from GREEN2, GREEN4
!    or GREEN5 through GREEN8
!
                           IF (KSYMM==1.AND.CS_TYPE/=1) THEN
                              NUNIT=34+IQ
                           ELSEIF (KSYMM==0.OR.KPOL==1) THEN
                              NUNIT=32
                           ELSE
                              NUNIT=34
                           ENDIF
                           DO I=1,NETI
                              READ (NUNIT) (GA(J,I),J=1,NETJ)
!
                           ENDDO
                        ENDIF
!
!-- Compute the mutual interactions
!
                        DO I=1,NETI
                           DO J=1,NETJ
                              EMT(J)=EMT(J)+GA(J,I)*JST(I,IB)
                           ENDDO
                        ENDDO
                     ENDIF
                  ENDDO
!
                  DO J=1,NETJ
                     EN(J)=ENT(J,JB)+EMT(J)
                  ENDDO
!
!--- Read the factored matrices from GREEN1 or GREEN3
!    for MT problems,  or from GREEN1, GREEN2, GREEN3,
!    and GREEN4 for CSAMT problems with group reduction
!
!    Note that if nbody=1 and ksymm=0 ga is not stored
!
                  IF (KSYMM/=0.OR.NBODY/=1) THEN
!
                     IF (KSYMM==1.AND.CS_TYPE/=1) THEN
!
!-- Read the factored matrices for each quadrant in
!   case of group reduction
!
                        DO I=1,NETJ
                           READ (30+IQ) (GA(J,I),J=1,NETJ)
                        ENDDO
!
                     ELSEIF (KSYMM==0.OR.KPOL==1) THEN
                        DO I=1,NETJ
                           READ (31) (GA(J,I),J=1,NETJ)
                        ENDDO
                     ELSE
                        DO I=1,NETJ
                           READ (33) (GA(J,I),J=1,NETJ)
                        ENDDO
                     ENDIF
                  ENDIF
!
!-- Read the array ind from the files index1 though index4
!   in unit 63 through 66
!
                  IF (KSYMM==1.AND.CS_TYPE/=1) THEN
                     READ (62+IQ) (IND(J),J=1,NETJ)
                  ELSEIF (KSYMM==1.AND.KPOL==2.AND.NPOL==2) THEN
                     READ (64) (IND(J),J=1,NETJ)
                  ELSE
                     READ (63) (IND(J),J=1,NETJ)
                  ENDIF
!
                  IF (KCELL(JB)==1.AND.(KANIS==0.OR.KBOUND==0)) THEN
                     CALL MTRX_SLV_CSISL(GA,NMAX,NETJ,IND,EN)
                  ELSE
                     CALL MTRX_SLV_LUBKSB(GA,EN,NMAX,NETJ,IND)
                  ENDIF
!
! ----- Determine the accuracy of iteration and store the
!     evaluated scattering currents
!
                  DO J=1,NETJ
!
!--- The following error criterium some times yield pure
!    convergency if jst is negligible but have large
!    relative error.
!      ERR(NITER)=ERR(NITER)+((CABS(EN(J))-CABS(JST(J,JB)))/
!   +           (CABS(EN(J))+CABS(JST(J,JB))+1.E-30))**2
                     ERR(NITER)=ERR(NITER)   &
                        +(ABS(CABS(EN(J))-CABS(JST(J,JB))))**2
                     TJS=TJS+(CABS(EN(J)))**2
                     JST(J,JB)=EN(J)
                  ENDDO
!
               ENDDO
!
!    ERR(NITER)=SQRT(ERR(NITER)/NERR)
!
! --- 1.E-30 is added to TJS to avoid overflow in case TJS is zero.
!   TJS may be zero for some quadrants if a vertical dipole is
!   located on some symmetry axes.
!
               ERR(NITER)=SQRT(ERR(NITER)/(TJS+1.E-30))
!
! --- Rewind all the files regardless convergency or not because
!   there may be multi-excitations.
!
               IF (KSYMM==1.AND.CS_TYPE/=1) THEN
                  REWIND (30+IQ)
                  REWIND (34+IQ)
               ELSEIF (KSYMM==0.OR.KPOL==1) THEN
                  IF (NBODY>1) REWIND (31)
                  IF (NBODY>1) REWIND (32)
               ELSE
                  REWIND (33)
                  REWIND (34)
               ENDIF
               DO I=1,4
                  REWIND (62+I)
               ENDDO
!
               IF (ERR(NITER)<=EPS.OR.NITER>=NITM.OR.NBODY==1) THEN
!
                  IF (NBODY.GT.1) THEN
                     IF (NTX_FD.GT.1) WRITE (NW,1030) IEXCI
                     IF (NTX_FD.EQ.1) WRITE (NW,*) ' '
                     IF (KSYMM.EQ.1.AND.CS_TYPE.NE.1) THEN
                        WRITE (NW,1040) IQ,NITER
                     ELSE
                        WRITE (NW,1050) NITER
                     ENDIF
                  ENDIF
                  IF (NITER>=NITM) THEN
                     IF (KSYMM==1.AND.CS_TYPE/=1) THEN
                        WRITE (NW,1010) NITER,IQ,ERR(NITER)
                     ELSE
                        WRITE (NW,1020) NITER,ERR(NITER)
                     ENDIF
                  ENDIF
!
! --- Store jst in case of multiple excitation
!   or group reduction
!   Note that kpol=1 for controlled source problems
!
                  IF (KSYMM==1.AND.CS_TYPE/=1) THEN
                     DO IB=1,NBODY
                        WRITE (44+IQ) (JST(I,IB),I=1,NET(IB))
                     ENDDO
                  ELSEIF (NTX_FD>1.OR.(CS_TYPE==1.AND.NPOL==2)) THEN
                     DO IB=1,NBODY
                        WRITE (20) (JST(I,IB),I=1,NET(IB))
                     ENDDO
                  ENDIF
               ELSE
                  NITER=NITER+1
                  IF (KSYMM==0.AND.NBODY==1) THEN
                  ENDIF
                  GOTO 10
               ENDIF
!
            ENDDO
         ENDDO
!
         IF ((KSYMM==0.AND.NTX_FD>1).OR.(CS_TYPE==1.AND.NPOL==2))  &
             REWIND (20)
         IF (KSYMM==1.AND.CS_TYPE/=1) REWIND (44+IQ)
!
      ENDDO
!
      IF (KSYMM/=0.AND.CS_TYPE/=1) THEN
!
! --- Read the transformed scattering currents from units
!   45 through 48, transform them back to real scattering
!   currents, and then store them in unit 20
!
         DO IEXCI=1,NTX_FD
!
            DO IQ=1,4
               NCB1=0
               DO IB=1,NBODY
                  IF (IB>1) NCB1=NCB1+NET(IB-1)
                  READ (44+IQ) (EMT(I),I=1,NET(IB))
                  DO J=1,NET(IB)
                     EJGS(J+NCB1+NEQ*(IQ-1))=EMT(J)
                  ENDDO
               ENDDO
            ENDDO
!
! --- Back transformation of the scattering currents by
!   the transposed unitary matrix
!
            DO LPC=1,NEQ/3
               DO LQC=1,4
                  DO JJ=1,3
                     JC=12*(LPC-1)+3*(LQC-1)+JJ
                     EJGS2(JC)=(0.,0.)
                     DO LPR=1,NEQ/3
                        DO LQR=1,4
                           DO II=1,3
!
!--- Note that the entries of the unitary matrix for
!    lpr .ne. lpc and ii .ne. jj are zero
!
                              IF (LPR==LPC.AND.II==JJ) THEN
                              CALL MTRX_UNITARY(LPR,LQR,II,LPC,LQC,JJ,U)
!-- PMAX=NEQ/3,  IROW is not computed in MTRX_UNITARY
                              IROW=NEQ*(LQR-1)+3*(LPR-1)+II
                              EJGS2(JC)=EJGS2(JC)+U*EJGS(IROW)
                              ENDIF
                           ENDDO
                        ENDDO
                     ENDDO
                  ENDDO
               ENDDO
            ENDDO
!
! ---  Store EJGS2 in unit 20
!
            WRITE (20) (EJGS2(I),I=1,4*NEQ)
!
         ENDDO
!
         REWIND (20)
      ENDIF
!

      RETURN
!                IF (NBODY.GT.1) THEN
!                   WRITE (NW,*)
!   +                       'Relative differences of the soultion in ',
!   +                      'each iteration:'
!                   WRITE (NW,1060) (ERR(J),J=1,NITER)
! 1060              FORMAT (4X,5E12.3)
!                ENDIF
 1010 FORMAT (' Warning: Iteration did not converge in ',I4,  &
              ' iterations! for quadrant #',I2,  &
              /' Accuracy of the solution:',E10.3)
 1020 FORMAT (' Warning: Iteration did not converge in ',I4,  &
              ' iterations!',/' Accuracy of the solution:',E10.3)
 1030             FORMAT (/'Excitation (or transmitter) number',I3)
 1040             FORMAT ('Number of system iterations for quadrant #',   &
                          I2,':',I4)
 1050             FORMAT ('Number of system iterations:',I4)
      END
!
!**** End of MAIN_SOLVER
!
!
      SUBROUTINE MAIN_PRM_AT_RCV(NW,INCL_DIELEC,CS_TYPE,KACC,SCALE,MLAYER,   &
                                 ZBND,CDH,ZMT,FRQ,NTX_FD,MD_ANGLE,NCRD,M_RX, &
                                 N_RX,RX_X,RX_Y,RX_Z,N_SIDE,TX_CRDX,TX_CRDY, &
                                 TX_CRDZ,RAD,TX_CRDXI,TX_CRDYI,TX_CRDZI,ENX, &
                                 ENY,ENZ,HNX,HNY,HNZ,NHFILM,LRYTH,HVK,KKH,   &
                                 KANIS,BLMIN,DMIN,RHOMIN,RHOMAX,NZOB,ZOBG,   &
                                 NZSR,ZSRG,NZBG,ZBG,ALMAX,GRHF,RRG,GRHO0,         &
                                 E0X1,E0Y1,H0X1,H0Y1,AJ)
!
!**** Calculate the normal fields at receiver stations
!
!
      IMPLICIT NONE
!
      REAL AJ,ALMAX,BLMIN,DMIN,FRQ,RADI,RHOMAX,RHOMIN,SCALE,ZMT,HFILL,HFILH
      INTEGER I,IEXCI,II,J,KACC,KANIS,INCL_DIELEC,KEYG,CS_TYPE,MLAYER,M_RX, &
              NCRD,NHFILM,NRG,NTX_FD,NZMT,NZOB,NCRDI,NW
      INTEGER NZSR,NZBG
      COMPLEX E0X,E0Y,H0X,H0Y,E0X1,E0Y1,H0X1,H0Y1,EX,EY,EZ,HX,HY,HZ,        &
              ENX(M_RX,NTX_FD),ENY(M_RX,NTX_FD),ENZ(M_RX,NTX_FD),           &
              HNX(M_RX,NTX_FD),HNY(M_RX,NTX_FD),HNZ(M_RX,NTX_FD),           &
              KKH(0:MLAYER),EHFLD(6),CDH(0:MLAYER),                         &
              GRHF(11,NHFILM,NZSR,NZOB),GRHO0(4,NZSR,NZOB)
      REAL RAD(NTX_FD),TX_CRDX(NCRD,NTX_FD),TX_CRDY(NCRD,NTX_FD),           &
           TX_CRDZ(NCRD,NTX_FD),TX_CRDXI(NCRD),TX_CRDYI(NCRD),              &
           TX_CRDZI(NCRD),RECVR(3),LRYTH(MLAYER),ZBND(0:MLAYER),HVK(0:MLAYER)
      REAL  ZOBG(NZOB),ZSRG(2,NZSR),ZBG(2,NZBG),RRG(NHFILM)
      REAL RX_X(M_RX,NTX_FD),RX_Y(M_RX,NTX_FD),RX_Z(M_RX,NTX_FD)
      INTEGER N_RX(NTX_FD),N_SIDE(NTX_FD)
      REAL :: MD_ANGLE(2,NTX_FD)
      REAL :: ANGLES(2)
      EQUIVALENCE (EHFLD(1),EX),(EHFLD(2),EY),(EHFLD(3),EZ),   &
                  (EHFLD(4),HX),(EHFLD(5),HY),(EHFLD(6),HZ)
      EXTERNAL HFILL,HFILH
!
      IF (CS_TYPE==1) THEN
!
! --- Calculate the incident waves at the earth's surface
!
         CALL EN_PRM_MT(FRQ,MLAYER,ZBND,LRYTH,KKH,0,0.,E0X,E0Y,H0X,H0Y)
!
         WRITE (NW,1010) REAL(H0X),AIMAG(H0X)*SCALE,REAL(H0Y),AIMAG(H0Y)  &
                         *SCALE,E0X*SCALE,E0Y*SCALE
!
! ----- Calculate the incident waves at the receiver plane
!
         DO J=MLAYER-1,0,-1
            IF (ZMT>=ZBND(J)) THEN
               NZMT=J+1
               GOTO 50
            ENDIF
         ENDDO
         NZMT=0
!
   50    CALL EN_PRM_MT(FRQ,MLAYER,ZBND,LRYTH,KKH,NZMT,ZMT,E0X,E0Y,H0X,H0Y)
         E0X1=E0X
         E0Y1=E0Y
         H0X1=H0X
         H0Y1=H0Y
         GOTO 100
!
      ENDIF
!
      KEYG=2
!
      IF (INCL_DIELEC==0) THEN
         CALL ONE_D_HF_TABLE(HFILL,NHFILM,MLAYER,ZBND,LRYTH,HVK,KKH,KANIS,   &
                             BLMIN,CS_TYPE,KEYG,DMIN,RHOMIN,RHOMAX,NZOB,     &
                             ZOBG,NZSR,ZSRG,NZBG,ZBG,ALMAX,GRHF,RRG,NRG,GRHO0)
      ELSE
         CALL ONE_D_HF_TABLE(HFILH,NHFILM,MLAYER,ZBND,LRYTH,HVK,KKH,KANIS,   &
                             BLMIN,CS_TYPE,KEYG,DMIN,RHOMIN,RHOMAX,NZOB,     &
                             ZOBG,NZSR,ZSRG,NZBG,ZBG,ALMAX,GRHF,RRG,NRG,GRHO0)
      ENDIF
!
      DO IEXCI=1,NTX_FD
!
!-- Determine the orientation of the magnetic dipoles
!
         IF (CS_TYPE==7.OR.CS_TYPE==8.OR.CS_TYPE==9) THEN
            ANGLES(1)=MD_ANGLE(1,IEXCI)
            ANGLES(2)=MD_ANGLE(2,IEXCI)
         ENDIF
!
         IF (CS_TYPE==4) THEN
            NCRDI=N_SIDE(IEXCI)
         ELSE
            NCRDI=NCRD
         ENDIF
         DO I=1,NCRDI
            TX_CRDXI(I)=TX_CRDX(I,IEXCI)
            TX_CRDYI(I)=TX_CRDY(I,IEXCI)
            TX_CRDZI(I)=TX_CRDZ(I,IEXCI)
            RADI=RAD(IEXCI)
         ENDDO
!
         DO II=1,N_RX(IEXCI)
!
            IF (CS_TYPE/=6.AND.CS_TYPE/=7.AND.CS_TYPE/=8) THEN
!
               RECVR(1)=RX_X(II,IEXCI)
               RECVR(2)=RX_Y(II,IEXCI)
               RECVR(3)=RX_Z(II,IEXCI)
!
               CALL ONE_D_SOURCE(CS_TYPE,ANGLES,RECVR,NCRDI,TX_CRDXI,TX_CRDYI,&
                                 TX_CRDZI,RADI,KEYG,KACC,FRQ,MLAYER,ZBND,AJ,  &
                                 KKH,CDH,NZOB,ZOBG,NZSR,ZSRG,RHOMIN,NHFILM,   &
                                 RRG,NRG,GRHF,GRHO0,EHFLD)
!
               ENX(II,IEXCI)=EX
               ENY(II,IEXCI)=EY
               ENZ(II,IEXCI)=EZ
               HNX(II,IEXCI)=HX
               HNY(II,IEXCI)=HY
               HNZ(II,IEXCI)=HZ
            ENDIF
!
            IF (CS_TYPE==6.OR.CS_TYPE==7.OR.CS_TYPE==8) THEN
!
!-- For loop-loop configurations,  horizontal co-axis magnetic
!   dipoles and vertical co-plane magnetic dipoles only one
!   receiver per excitation and one value for each component of
!   the normal fields.
!
!   The number of different normal fields are determined by
!   the number of different source levels (the z'-levels).
!   If there is only one source level,  the normal fields
!   need to be computed only once.  Otherwise the normal
!   fields for each receiver site must be computed since it is
!   not obvious when the receivers will jump into another level.
!
               IF (NZSR>1.OR.(NZSR==1.AND.II==1.AND.IEXCI==1)) THEN
!
                  RECVR(1)=RX_X(1,IEXCI)
                  RECVR(2)=RX_Y(1,IEXCI)
                  RECVR(3)=RX_Z(1,IEXCI)
                  NCRDI=1
                  CALL ONE_D_SOURCE(CS_TYPE,ANGLES,RECVR,NCRDI,TX_CRDXI,  &
                                    TX_CRDYI,TX_CRDZI,RADI,KEYG,KACC,FRQ, &
                                    MLAYER,ZBND,AJ,KKH,CDH,NZOB,ZOBG,     &
                                    NZSR,ZSRG,RHOMIN,NHFILM,RRG,NRG,      &
                                    GRHF,GRHO0,EHFLD)
!
                  ENX(II,IEXCI)=EX
                  ENY(II,IEXCI)=EY
                  ENZ(II,IEXCI)=EZ
                  HNX(II,IEXCI)=HX
                  HNY(II,IEXCI)=HY
                  HNZ(II,IEXCI)=HZ
               ELSE
                  ENX(II,IEXCI)=ENX(1,1)
                  ENY(II,IEXCI)=ENY(1,1)
                  ENZ(II,IEXCI)=ENZ(1,1)
                  HNX(II,IEXCI)=HNX(1,1)
                  HNY(II,IEXCI)=HNY(1,1)
                  HNZ(II,IEXCI)=HNZ(1,1)
               ENDIF
!
            ENDIF
!
         ENDDO
      ENDDO

  100 RETURN
 1010 FORMAT (//'Incident Wave at the earths surface: ',  &
              ' H =(1i + 1j)*EXP(ikoz) (H in A/m)',  &
              /'(Responses due to the layers. For reference only)',/2X,  &
              'Hox  Hoy =',4E16.8,/2X,'Eox  Eoy =',4E16.8)
      END
!
!**** End of MAIN_PRM_AT_RCV
!
!
      SUBROUTINE MAIN_SCAT_EH_CS(INCL_DIELEC,KACC,KSYMM,MBODY,NBMAX,         &
                                 NSUBCM,NBODY,SUB_BLOCK,NCELL,NET,TCDB,EMT,  &
                                 JST,EJGS,NMAX,NTX_FD,N_RX,NHFILM,FRQ,MLAYER,&
                                 ZBND,LRYTH,HVK,KKH,KANIS,BLMIN,DMIN,RHOMIN, &
                                 RHOMAX,NZOB,ZOBG,NZSR,ZSRG,ALMAX,RRG,RRG3,  &
                                 GRHF,GRHF3,GRHO0,GRHO03,RX_X,RX_Y,RX_Z,     &
                                 NXMAX,NYMAX,NZMAX,NEQ,NX,NY,NZ,XCELL,YCELL, &
                                 ZCELL,BLX,BLY,BLZ,CDH,CDV,KSFT,CLMN,M_RX,   &
                                 ENX,ENY,ENZ,EAX,EAY,EAZ,HAX,HAY,HAZ,        &
                                 ESX,ESY,ESZ,HSX,HSY,HSZ)
!
!**** Calculate EM fields at receiver sites
!
!
!   EAX etc are for one excitation whilst ESX are for all excitations
!
!
      IMPLICIT NONE
!
      REAL HFILL,HFILH
      REAL ALMAX,BLMIN,DMIN,FRQ,RHOMAX,RHOMIN
      INTEGER I,IB,IEXCI,J,KACC,KACC1,KANIS,KCLMN,INCL_DIELEC,KEYG,KSFT,   &
              KSYMM,MBODY,MLAYER,M_RX,NBMAX,NBODY,NEQ,NHFILM
      INTEGER NMAX,NRG,NRG3,NSUBCM,NTX_FD,NXMAX,NYMAX,NZMAX,NZOB,NZSR
      COMPLEX EMT(NMAX),JST(NMAX,MBODY),EJGS(4*NMAX*MBODY),                &
              TCDB(NSUBCM,NBMAX,MBODY),GRHF(11,NHFILM,NZSR,NZOB),          &
              GRHF3(11,NHFILM,NZSR),GRHO0(4,NZSR,NZOB),GRHO03(4,NZSR),     &
              KKH(0:MLAYER),CDH(0:MLAYER),CDV(0:MLAYER),                   &
              EAX(M_RX),EAY(M_RX),EAZ(M_RX),                               &
              HAX(M_RX),HAY(M_RX),HAZ(M_RX),                               &
              ENX(M_RX,NTX_FD),ENY(M_RX,NTX_FD),ENZ(M_RX,NTX_FD),          &
              ESX(M_RX,NTX_FD),ESY(M_RX,NTX_FD),ESZ(M_RX,NTX_FD),          &
              HSX(M_RX,NTX_FD),HSY(M_RX,NTX_FD),HSZ(M_RX,NTX_FD)
      REAL ZOBG(NZOB),ZSRG(2,NZSR),RRG(NHFILM),RRG3(NHFILM),               &
           LRYTH(MLAYER),ZBND(0:MLAYER),HVK(0:MLAYER)
      REAL BLX(NBMAX,MBODY),BLY(NBMAX,MBODY),BLZ(NBMAX,MBODY),             &
           XCELL(NXMAX,NBMAX,MBODY),YCELL(NYMAX,NBMAX,MBODY),              &
           ZCELL(NZMAX,NBMAX,MBODY)
      REAL RX_X(M_RX,NTX_FD),RX_Y(M_RX,NTX_FD),RX_Z(M_RX,NTX_FD)
      INTEGER N_RX(NTX_FD)
      INTEGER NX(NBMAX,MBODY),NY(NBMAX,MBODY),NZ(NBMAX,MBODY),             &
              NCELL(NBMAX,MBODY),NET(MBODY),SUB_BLOCK(MBODY)
      REAL CLMN(NBODY)
      EXTERNAL HFILL,HFILH
!
! --- Reduce the accuracy level for computing scattered responses
!   to 3 if it is above 3.  High accuracy levels are necessary
!   for accurate computation of the matrix elements which are
!   also affordable if spatial symmetry reductions are used.
!
      IF (KACC>3) THEN
         KACC1=3
      ELSE
         KACC1=KACC
      ENDIF
!
! ---- Compute the grid values for the interpolation of the
!    Hankel transforms
!
      KEYG=2
!
      IF (INCL_DIELEC==1) THEN
         CALL THR_D_HF_TABLE(HFILH,NHFILM,MLAYER,ZBND,LRYTH,HVK,KKH,KANIS,   &
                             KSFT,BLMIN,KEYG,DMIN,RHOMIN,RHOMAX,NZOB,ZOBG,   &
                             NZSR,ZSRG,ALMAX,RRG,NRG,RRG3,NRG3,GRHF,GRHF3,   &
                             GRHO0,GRHO03)
      ELSE
         CALL THR_D_HF_TABLE(HFILL,NHFILM,MLAYER,ZBND,LRYTH,HVK,KKH,KANIS,   &
                             KSFT,BLMIN,KEYG,DMIN,RHOMIN,RHOMAX,NZOB,ZOBG,   &
                             NZSR,ZSRG,ALMAX,RRG,NRG,RRG3,NRG3,GRHF,GRHF3,   &
                             GRHO0,GRHO03)
      ENDIF
!
!--- Read the array TCDB for use in computing the electrical
!    fields at receivers on or within a cell
!
      REWIND (62)
!
! --- Read cell conductivity from file CONDT (unit 62)
!
      DO IB=1,NBODY
         READ (62) ((TCDB(J,I,IB),J=1,NCELL(I,IB)),I=1,SUB_BLOCK(IB))
      ENDDO
!
      REWIND (62)
!
      DO IEXCI=1,NTX_FD
!
! ---- Read jst from unit 20 for multiple excitations
!    or ejgs from 20 for controlled source problems
!    with two-plane symmetries (group reduction)
!
         IF (NTX_FD>1.AND.KSYMM==0) THEN
            DO IB=1,NBODY
               READ (20) (EMT(I),I=1,NET(IB))
               DO J=1,NET(IB)
                  JST(J,IB)=EMT(J)
               ENDDO
            ENDDO
         ENDIF
!
         IF (KSYMM==1) READ (20) (EJGS(I),I=1,4*NEQ)
!
!-- For loop-loop configurations only one receiver per excitation
!
         IF (KSYMM==0) CALL SCAT_EH_CS(NBMAX,NMAX,NXMAX,NYMAX,NZMAX,NBODY, &
             SUB_BLOCK,N_RX,RX_X,RX_Y,RX_Z,NX,NY,NZ,NCELL,XCELL,YCELL,     &
             ZCELL,BLX,BLY,BLZ,JST,NSUBCM,TCDB,IEXCI,CLMN,M_RX,NTX_FD,     &
             ENX,ENY,ENZ,EAX,EAY,EAZ,HAX,HAY,HAZ,FRQ,MLAYER,ZBND,CDH,      &
             CDV,HVK,NZOB,ZOBG,NZSR,ZSRG,RHOMIN,DMIN,NHFILM,               &
             RRG,NRG,GRHF,RRG3,NRG3,GRHF3,GRHO0,GRHO03,KCLMN,BLMIN,        &
             KACC1)
         IF (KSYMM==1) CALL SCAT_EH_CSGS(NBMAX,NEQ,NXMAX,NYMAX,NZMAX,NBODY,&
             SUB_BLOCK,NET,N_RX,RX_X,RX_Y,RX_Z,NX,NY,NZ,NCELL,XCELL,       &
             YCELL,ZCELL,BLX,BLY,BLZ,EJGS,NSUBCM,TCDB,IEXCI,CLMN,          &
             M_RX,NTX_FD,ENX,ENY,ENZ,EAX,EAY,EAZ,HAX,HAY,HAZ,FRQ,          &
             MLAYER,ZBND,CDH,CDV,HVK,NZOB,ZOBG,NZSR,ZSRG,                  &
             RHOMIN,DMIN,NHFILM,RRG,NRG,GRHF,RRG3,NRG3,GRHF3,GRHO0,        &
             GRHO03,KCLMN,BLMIN,KACC1)
!
         DO I=1,N_RX(IEXCI)
            ESX(I,IEXCI)=EAX(I)
            ESY(I,IEXCI)=EAY(I)
            ESZ(I,IEXCI)=EAZ(I)
            HSX(I,IEXCI)=HAX(I)
            HSY(I,IEXCI)=HAY(I)
            HSZ(I,IEXCI)=HAZ(I)
         ENDDO
!
      ENDDO
!
      RETURN
      END
!
!**** End of MAIN_SCAT_EH_CS
!
!
!
      SUBROUTINE MAIN_SCAT_EH_MT(INCL_DIELEC,KACC,KSYMM,MBODY,NBMAX,NSUBCM,  &
                                 NBODY,SUB_BLOCK,NCELL,TCDB,JST,NMAX,NHFILM, &
                                 FRQ,MLAYER,ZBND,LRYTH,HVK,KKH,KANIS,BLMIN,  &
                                 DMIN,RHOMIN,RHOMAX,NZOB,ZOBG,NZSR,ZSRG,     &
                                 ALMAX,RRG,RRG3,GRHF,GRHF3,GRHO0,GRHO03,     &
                                 MT_PROFL,MT_STATN,XRMT,YRMT,NXMAX,NYMAX,    &
                                 NZMAX,NX,NY,NZ,XCELL,YCELL,ZCELL,BLX,BLY,   &
                                 BLZ,CDH,NPOL,E0X1,E0Y1,ZMT,KSFT,CLMN,       &
                                 EXMT,EYMT,HXMT,HYMT,HZMT)
!
!**** Calculate EM fields at receiver sites
!
!
!   NPOL,E0X1,E0Y1,ZMT are to be passed into routines SCAT_EH_MT
!   and SCAT_EH_MTS
!
!
!   EAX etc are for one excitation whilst EXMT are for all excitations
!
!
      IMPLICIT NONE
!
      REAL HFILL,HFILH
      REAL ALMAX,BLMIN,DMIN,FRQ,RHOMAX,RHOMIN,ZMT
      INTEGER I,IB,J,KACC,KACC1,KANIS,KCLMN,INCL_DIELEC,KEYG,KSFT,KSYMM,     &
              MBODY,MLAYER,NBMAX,NBODY,NHFILM,NMAX,MT_PROFL
      INTEGER NPOL,MT_STATN,NRG,NRG3,NSUBCM,NXMAX,NYMAX,NZMAX,NZOB,NZSR
      COMPLEX JST(NMAX,MBODY),TCDB(NSUBCM,NBMAX,MBODY),E0X1,E0Y1,            &
              GRHF(11,NHFILM,NZSR,NZOB),GRHF3(11,NHFILM,NZSR),               &
              GRHO0(4,NZSR,NZOB),GRHO03(4,NZSR),                             &
              KKH(0:MLAYER),CDH(0:MLAYER),                                   &
              EXMT(MT_PROFL,MT_STATN,2),EYMT(MT_PROFL,MT_STATN,2),           &
              HXMT(MT_PROFL,MT_STATN,2),HYMT(MT_PROFL,MT_STATN,2),           &
              HZMT(MT_PROFL,MT_STATN,2)
      REAL ZOBG(NZOB),ZSRG(2,NZSR),RRG(NHFILM),RRG3(NHFILM),                 &
           LRYTH(MLAYER),ZBND(0:MLAYER),HVK(0:MLAYER)
      REAL BLX(NBMAX,MBODY),BLY(NBMAX,MBODY),BLZ(NBMAX,MBODY),               &
           XCELL(NXMAX,NBMAX,MBODY),YCELL(NYMAX,NBMAX,MBODY),                &
           ZCELL(NZMAX,NBMAX,MBODY)
      REAL XRMT(MT_PROFL),YRMT(MT_STATN)
      INTEGER NX(NBMAX,MBODY),NY(NBMAX,MBODY),NZ(NBMAX,MBODY),               &
              NCELL(NBMAX,MBODY),SUB_BLOCK(MBODY)
      REAL CLMN(NBODY)
      EXTERNAL HFILL,HFILH
!
! --- Reduce the accuracy level for computing scattered responses
!   to 3 if it is above 3.  High accuracy levels are necessary
!   for accurate computation of the matrix elements which are
!   also affordable if spatial symmetry reductions are used.
!
      IF (KACC>3) THEN
         KACC1=3
      ELSE
         KACC1=KACC
      ENDIF
!
! ---- Compute the grid values for the interpolation of the
!    Hankel transforms
!
      KEYG=2
!
      IF (INCL_DIELEC==1) THEN
         CALL THR_D_HF_TABLE(HFILH,NHFILM,MLAYER,ZBND,LRYTH,HVK,KKH,KANIS,   &
                             KSFT,BLMIN,KEYG,DMIN,RHOMIN,RHOMAX,NZOB,ZOBG,   &
                             NZSR,ZSRG,ALMAX,RRG,NRG,RRG3,NRG3,GRHF,GRHF3,   &
                             GRHO0,GRHO03)
      ELSE
         CALL THR_D_HF_TABLE(HFILL,NHFILM,MLAYER,ZBND,LRYTH,HVK,KKH,KANIS,   &
                             KSFT,BLMIN,KEYG,DMIN,RHOMIN,RHOMAX,NZOB,ZOBG,   &
                             NZSR,ZSRG,ALMAX,RRG,NRG,RRG3,NRG3,GRHF,GRHF3,   &
                             GRHO0,GRHO03)
      ENDIF
!
!--- Read the array TCDB for use in computing the electrical
!    fields at receivers on or within a cell
!
      REWIND (62)
!
! --- Read cell conductivity from file CONDT (unit 62)
!
      DO IB=1,NBODY
         READ (62) ((TCDB(J,I,IB),J=1,NCELL(I,IB)),I=1,SUB_BLOCK(IB))
      ENDDO
!
      REWIND (62)
!
! ---- Compute MT responses
!
      IF (KSYMM==0) CALL SCAT_EH_MT(NBMAX,NMAX,NXMAX,NYMAX,NZMAX,NBODY,      &
                         SUB_BLOCK,MT_PROFL,MT_STATN,XRMT,YRMT,NX,NY,NZ,     &
                         NCELL,XCELL,YCELL,ZCELL,BLX,BLY,BLZ,JST,NPOL,KSFT,  &
                         NSUBCM,TCDB,CLMN,ZMT,E0X1,E0Y1,EXMT,EYMT,HXMT,HYMT, &
                         HZMT,FRQ,MLAYER,ZBND,CDH,HVK,NZOB,ZOBG,NZSR,ZSRG,   &
                         RHOMIN,DMIN,NHFILM,RRG,NRG,GRHF,RRG3,NRG3,          &
                         GRHF3,GRHO0,GRHO03,KCLMN,BLMIN,KACC1)
      IF (KSYMM==1) CALL SCAT_EH_MTS(NBMAX,NMAX,NXMAX,NYMAX,NZMAX,NBODY,     &
                         SUB_BLOCK,MT_PROFL,MT_STATN,XRMT,YRMT,NX,NY,NZ,     &
                         NCELL,XCELL,YCELL,ZCELL,BLX,BLY,BLZ,JST,NPOL,KSFT,  &
                         NSUBCM,TCDB,CLMN,ZMT,E0X1,E0Y1,EXMT,EYMT,HXMT,HYMT, &
                         HZMT,FRQ,MLAYER,ZBND,CDH,HVK,NZOB,ZOBG,NZSR,ZSRG,   &
                         RHOMIN,DMIN,NHFILM,RRG,NRG,GRHF,RRG3,NRG3,GRHF3,    &
                         GRHO0,GRHO03,KCLMN,BLMIN,KACC1)
!
      RETURN
      END
!
!**** End of MAIN_SCAT_EH_MT
!
!
      SUBROUTINE MTRX_1M(NMAX,N,NXMAX,NYMAX,NZMAX,NX,NY,NZ,NCELL,    &
                         NSUBCM,SUB_BLOCK,X,Y,Z,CLX,CLY,CLZ,CDB,G,   &
                         FRQ,MLAYER,ZBND,CDH,CDV,HVK,NZOB,ZOBG,      &
                         NZSR,ZSRG,RHOMIN,DMIN,NHFILM,RRG,           &
                         NRG,GRHF,RRG3,NRG3,GRHF3,GRHO0,GRHO03,      &
                         CLMN,KCLMN,BLMIN,KACC,KUTCRP)
!
!**** SET UP THE MATRIX FOR A STRUCTURE WITH DIFFERENT CELL
!   SIZES OR A STRUCTURE EMBBEDED IN AN ANISOTROPIC LAYER
!   WITH THE BODY CROSSING A LAYER BOUNDARY
!
!   Note the matrix is not symmetrical
!
!   The difference between smtrx1 (in MT3D) and smtrx1m is
!   that the matrix elements in smtrx1 are multiplied by the
!   conductivity differences
!
!   The parameter kself controls if the computation for the
!   integration of the primary part of the Green's function
!   for self-cells should be repeated. As the dimensions of
!   the cells within a block is the same, this integration
!   need to be done only once (kself=1) for cells located in
!   the same layer.   The results are stored in a common
!   block in geprm for use for all other cells in this block
!   (kself=0)
!
!Input parameters:
!
!
!
!  All other parameters FRQ, MLAYER, ZBND,  CDH, HVK, NZOB, ZOBG,
!  NZSR, ZSRG, RHOMIN, DMIN, NHFILM, RRG, NRG, GRHF,
!  GRHF3, GRHO0, GRHO03, CLMN, KCLMN, BLMIN, KACC, and KUTCRP are to
!  be passed into routine THR_D_GREEN.  Check THR_D_GREEN for their
!  descriptions.
!
!
!Output parameters:
!
!  G:
!
!
!**** Called by: MAIN_MATRICES
!
!**** Calls:     THR_D_GREEN
!
!
      IMPLICIT NONE
!
      REAL BLMIN,CLMN,CLX1,CLY1,CLZ1,DMIN,FRQ,RHOMIN
      INTEGER I,II,IOB,ISR,J,JJ,K,KACC,KCLMN,KEYG,KK,KSELF,KUTCRP,L,LL,   &
              MLAYER,N,N1,N2,SUB_BLOCK
      INTEGER NCB,NCB1,NHFILM,NMAX,NN,NN1,NN2,NOB,NOB1,NRG,NRG3,NSR,      &
              NSUBCM,NXMAX,NYMAX,NZMAX,NZOB,NZSR
      COMPLEX G(NMAX,N),EXX,EXY,EXZ,EYX,EYY,EYZ,EZX,EZY,EZZ,              &
              CDH(0:MLAYER),CDV(0:MLAYER),                                &
              CDB(NSUBCM,SUB_BLOCK),DELTH,DELTV,                          &
              GRHF(11,NHFILM,NZSR,NZOB),GRHO0(4,NZSR,NZOB),               &
              GRHF3(11,NHFILM,NZSR),GRHO03(4,NZSR)
      INTEGER NX(SUB_BLOCK),NY(SUB_BLOCK),NZ(SUB_BLOCK),NCELL(SUB_BLOCK)
      REAL  X(NXMAX,SUB_BLOCK),Y(NYMAX,SUB_BLOCK),Z(NZMAX,SUB_BLOCK),     &
            CLX(SUB_BLOCK),CLY(SUB_BLOCK),CLZ(SUB_BLOCK),                 &
            ZBND(0:MLAYER),HVK(0:MLAYER),ZOBG(NZOB),                      &
            ZSRG(2,NZSR),RRG(NRG),RRG3(NRG3),PSTION(8)
      COMPLEX ECOMP(9),HCOMP(9)
      EQUIVALENCE (ECOMP(1),EXX),(ECOMP(2),EYX),(ECOMP(3),EZX),   &
                  (ECOMP(4),EXY),(ECOMP(5),EYY),(ECOMP(6),EZY),   &
                  (ECOMP(7),EXZ),(ECOMP(8),EYZ),(ECOMP(9),EZZ)
!
      KEYG=1
!
      NCB=0
      DO L=1,SUB_BLOCK
         IF (L>1) NCB=NCB+NCELL(L-1)
         DO K=1,NZ(L)
            DO IOB=MLAYER-1,0,-1
               IF (Z(K,L)>=ZBND(IOB)) THEN
                  NOB=IOB+1
                  GOTO 20
               ENDIF
            ENDDO
            NOB=0
   20       IF (L==1.AND.K==1) NOB1=NOB
            DO I=1,NX(L)
               DO J=1,NY(L)
                  NN=(I-1)*NY(L)*NZ(L)+(J-1)*NZ(L)+K
                  N1=NN+NCB
                  NN1=(N1-1)*3+1
                  DELTH=CDB(NN,L)-CDH(NOB)
                  DELTV=CDB(NN,L)-CDV(NOB)
!
                  NCB1=0
                  DO LL=1,SUB_BLOCK
                     IF (LL>1) NCB1=NCB1+NCELL(LL-1)
                     DO II=1,NX(LL)
                        DO JJ=1,NY(LL)
                           DO KK=1,NZ(LL)
                              N2=(II-1)*NY(LL)*NZ(LL)+(JJ-1)*NZ(LL)   &
                                 +KK+NCB1
                              NN2=(N2-1)*3+1
!
                              DO ISR=MLAYER-1,0,-1
                              IF (Z(KK,LL)>=ZBND(ISR)) THEN
                              NSR=ISR+1
                              GOTO 22
                              ENDIF
                              ENDDO
                              NSR=0
!
! ---- KSELF controls if the calculation for the self-cells
!    should be repeated
   22                         IF (I==1.AND.J==1.AND.K==1.OR.  &
                                 NOB1/=NOB.OR.NOB1/=NSR) THEN
                              KSELF=1
                              ELSE
                              KSELF=0
                              ENDIF
!
                              CLX1=CLX(LL)
                              CLY1=CLY(LL)
                              CLZ1=CLZ(LL)
!
                              PSTION(1)=X(I,L)
                              PSTION(2)=Y(J,L)
                              PSTION(3)=Z(K,L)
                              PSTION(4)=X(II,LL)
                              PSTION(5)=Y(JJ,LL)
                              PSTION(6)=Z(KK,LL)
                              CALL THR_D_GREEN(KEYG,PSTION,FRQ,MLAYER,ZBND,  &
                                 CDH,HVK,NZOB,ZOBG,NZSR,ZSRG,                &
                                 RHOMIN,DMIN,NHFILM,RRG,NRG,GRHF,RRG3,       &
                                 NRG3,GRHF3,GRHO0,GRHO03,CLX1,CLY1,CLZ1,     &
                                 CLMN,KCLMN,BLMIN,KACC,KUTCRP,KSELF,         &
                                 ECOMP,HCOMP)
!
                              IF (N1==N2) THEN
                              G(NN1,NN2)=1./DELTH-EXX
                              G(NN1+1,NN2+1)=1./DELTH-EYY
                              G(NN1+2,NN2+2)=1./DELTV-EZZ
                              ELSE
                              G(NN1,NN2)=-EXX
                              G(NN1+1,NN2+1)=-EYY
                              G(NN1+2,NN2+2)=-EZZ
                              ENDIF
                              G(NN1+1,NN2)=-EYX
                              G(NN1+2,NN2)=-EZX
                              G(NN1,NN2+1)=-EXY
                              G(NN1+2,NN2+1)=-EZY
                              G(NN1,NN2+2)=-EXZ
                              G(NN1+1,NN2+2)=-EYZ
                           ENDDO
                        ENDDO
                     ENDDO
                  ENDDO
               ENDDO
            ENDDO
         ENDDO
      ENDDO
      RETURN
      END
!
!**** End of MTRX_1M
!
!
      SUBROUTINE MTRX_1MS(NMAX,N,NXMAX,NYMAX,NZMAX,NX,NY,NZ,NCELL,    &
                          NSUBCM,SUB_BLOCK,X,Y,Z,CLX,CLY,CLZ,CDB,G,   &
                          FRQ,MLAYER,ZBND,CDH,CDV,HVK,NZOB,ZOBG,      &
                          NZSR,ZSRG,RHOMIN,DMIN,NHFILM,               &
                          RRG,NRG,GRHF,RRG3,NRG3,GRHF3,GRHO0,GRHO03,  &
                          CLMN,KCLMN,BLMIN,KACC,KUTCRP)
!
!**** SET UP THE MATRIX FOR A STRUCTURE WITH EQUAL CELL
!   SIZES FOR A STRUCTURE EMBBEDED IN AN ISOPTROPIC EARTN
!   OR IN A SINGLE LAYER OF AN ANISOTROPIC EARTH
!
!   Note the matrix is symmetrical and is stored in a doubly
!   subscripted array
!
!   smtrx1ms is essentially the same as smtrx1m except
!   that smtrx1ms save a half computer time due to symmetry.
!   smtrx1ms and smtrx differ only in their way of storing
!   the matrices
!
!
!Input parameters:
!
!
!
!  All other parameters FRQ, MLAYER, ZBND,  CDH, HVK, NZOB, ZOBG,
!  NZSR, ZSRG, RHOMIN, DMIN, NHFILM, RRG, NRG, GRHF,
!  GRHF3, GRHO0, GRHO03, CLMN, KCLMN, BLMIN, KACC, and KUTCRP are to
!  be passed into routine THR_D_GREEN.  Check THR_D_GREEN for their
!  descriptions.
!
!
!Output parameters:
!
!  G:
!
!
!**** Called by: MAIN_MATRICES
!
!**** Calls:     THR_D_GREEN
!
!
      IMPLICIT NONE
!
      REAL BLMIN,CLMN,CLX1,CLY1,CLZ1,DMIN,FRQ,RHOMIN
      INTEGER I,II,IOB,ISR,J,JJ,K,KACC,KCLMN,KEYG,KK,KSELF,KUTCRP,L,LL,   &
              MLAYER,N,N1,N2,SUB_BLOCK
      INTEGER NCB,NCB1,NHFILM,NMAX,NN,NN1,NN2,NOB,NOB1,NRG,NRG3,NSR,      &
              NSUBCM,NXMAX,NYMAX,NZMAX,NZOB,NZSR
      COMPLEX G(NMAX,N),EXX,EXY,EXZ,EYX,EYY,EYZ,EZX,EZY,EZZ,              &
              CDH(0:MLAYER),CDV(0:MLAYER),                                &
              CDB(NSUBCM,SUB_BLOCK),DELTH,DELTV,                          &
              GRHF(11,NHFILM,NZSR,NZOB),GRHO0(4,NZSR,NZOB),               &
              GRHF3(11,NHFILM,NZSR),GRHO03(4,NZSR)
      INTEGER NX(SUB_BLOCK),NY(SUB_BLOCK),NZ(SUB_BLOCK),NCELL(SUB_BLOCK)
      REAL  X(NXMAX,SUB_BLOCK),Y(NYMAX,SUB_BLOCK),Z(NZMAX,SUB_BLOCK),     &
            CLX(SUB_BLOCK),CLY(SUB_BLOCK),CLZ(SUB_BLOCK),                 &
            ZBND(0:MLAYER),HVK(0:MLAYER),ZOBG(NZOB),                      &
            ZSRG(2,NZSR),RRG(NRG),RRG3(NRG3),PSTION(8)
      COMPLEX ECOMP(9),HCOMP(9)
      EQUIVALENCE (ECOMP(1),EXX),(ECOMP(2),EYX),(ECOMP(3),EZX),   &
                  (ECOMP(4),EXY),(ECOMP(5),EYY),(ECOMP(6),EZY),   &
                  (ECOMP(7),EXZ),(ECOMP(8),EYZ),(ECOMP(9),EZZ)
!
      KEYG=1
!
      NCB=0
      DO L=1,SUB_BLOCK
         IF (L>1) NCB=NCB+NCELL(L-1)
         DO K=1,NZ(L)
            DO IOB=MLAYER-1,0,-1
               IF (Z(K,L)>=ZBND(IOB)) THEN
                  NOB=IOB+1
                  GOTO 20
               ENDIF
            ENDDO
            NOB=0
   20       IF (L==1.AND.K==1) NOB1=NOB
            DO I=1,NX(L)
               DO J=1,NY(L)
                  NN=(I-1)*NY(L)*NZ(L)+(J-1)*NZ(L)+K
                  N1=NN+NCB
                  NN1=(N1-1)*3+1
                  DELTH=CDB(NN,L)-CDH(NOB)
                  DELTV=CDB(NN,L)-CDV(NOB)
!
                  NCB1=0
                  DO LL=1,SUB_BLOCK
                     IF (LL>1) NCB1=NCB1+NCELL(LL-1)
                     DO II=1,NX(LL)
                        DO JJ=1,NY(LL)
                           DO KK=1,NZ(LL)
                              N2=(II-1)*NY(LL)*NZ(LL)+(JJ-1)*NZ(LL)   &
                                 +KK+NCB1
                              NN2=(N2-1)*3+1
!
                              IF (N1<=N2) THEN
!
                              DO ISR=MLAYER-1,0,-1
                              IF (Z(KK,LL)>=ZBND(ISR)) THEN
                              NSR=ISR+1
                              GOTO 22
                              ENDIF
                              ENDDO
                              NSR=0
!
! ---- KSELF controls if the calculation for the self-cells
!    should be repeated
   22                         IF (I==1.AND.J==1.AND.K==1.OR.  &
                                 NOB1/=NOB.OR.NOB1/=NSR) THEN
                              KSELF=1
                              ELSE
                              KSELF=0
                              ENDIF
!
                              CLX1=CLX(LL)
                              CLY1=CLY(LL)
                              CLZ1=CLZ(LL)
!
                              PSTION(1)=X(I,L)
                              PSTION(2)=Y(J,L)
                              PSTION(3)=Z(K,L)
                              PSTION(4)=X(II,LL)
                              PSTION(5)=Y(JJ,LL)
                              PSTION(6)=Z(KK,LL)
                              CALL THR_D_GREEN(KEYG,PSTION,FRQ,MLAYER,ZBND,  &
                                 CDH,HVK,NZOB,ZOBG,NZSR,ZSRG,                &
                                 RHOMIN,DMIN,NHFILM,RRG,NRG,GRHF,RRG3,       &
                                 NRG3,GRHF3,GRHO0,GRHO03,CLX1,CLY1,CLZ1,     &
                                 CLMN,KCLMN,BLMIN,KACC,KUTCRP,KSELF,         &
                                 ECOMP,HCOMP)
!
                              IF (N1==N2) THEN
                              G(NN1,NN2)=1./DELTH-EXX
                              G(NN1+1,NN2+1)=1./DELTH-EYY
                              G(NN1+2,NN2+2)=1./DELTV-EZZ
                              ELSE
                              G(NN1,NN2)=-EXX
                              G(NN1+1,NN2+1)=-EYY
                              G(NN1+2,NN2+2)=-EZZ
                              ENDIF
                              G(NN1+1,NN2)=-EYX
                              G(NN1+2,NN2)=-EZX
                              G(NN1,NN2+1)=-EXY
                              G(NN1+2,NN2+1)=-EZY
                              G(NN1,NN2+2)=-EXZ
                              G(NN1+1,NN2+2)=-EYZ
                              ENDIF
                           ENDDO
                        ENDDO
                     ENDDO
                  ENDDO
               ENDDO
            ENDDO
         ENDDO
      ENDDO
      DO I=1,N
         DO J=1,N
            IF (I>J) G(I,J)=G(J,I)
         ENDDO
      ENDDO
      RETURN
      END
!
!**** End of MTRX_1MS
!
!
      SUBROUTINE MTRX_3M(NMAX,N,NXMAX,NYMAX,NZMAX,NX,NY,NZ,NCELL,         &
                         NSUBCM,SUB_BLOCK,X,Y,Z,CLX,CLY,CLZ,CDB,KSYM,G,   &
                         FRQ,MLAYER,ZBND,CDH,CDV,HVK,NZOB,ZOBG,NZSR,      &
                         ZSRG,RHOMIN,DMIN,NHFILM,RRG,NRG,GRHF,            &
                         RRG3,NRG3,GRHF3,GRHO0,GRHO03,CLMN,KCLMN,         &
                         BLMIN,KACC,KUTCRP)
!
!     SETTING UP THE MATRIX FOR A SYMMETRIC STRUCTURE WITH
!     DIFFERENT CELL SIZES OR FOR SYMMETRIC BODY EMBBEDED IN
!     AN ANISOTROPIC LAYER WITH THE BODY CROSSING A LAYER BOUNDARY
!
!      Note the matrix is not symmetrical
!
!      The differences between smtrx3 (in MT3D) and smtrx3m
!      are like those between smtrx1 amd smtrx1m
!
!      Note that only two quarters, either quarter I and IV
!      or quarter II and III, are computed at a time, which is
!      controled by the parameter KSYM (=1 or 2). The actual
!      scattering matrix is then formed in the main routine
!      by addition or substraction of the results of KSYM=1
!      and 2 according to the polarizations.
!
!
      IMPLICIT NONE
!
      REAL BLMIN,BX,BY,CLMN,CLX1,CLY1,CLZ1,DMIN,FRQ,RHOMIN,SX,SY,SZ
      INTEGER I,II,IOB,ISR,J,JJ,K,KACC,KCLMN,KEYG,KK,KSELF,KSYM,KUTCRP,    &
              L,LL,LS1,LS2,LS3,LSYM
      INTEGER MLAYER,N,N1,N2,SUB_BLOCK,NCB,NCB1,NHFILM,NMAX,NN,NN1,NN2,    &
              NOB,NOB1,NRG,NRG3,NSR,NSUBCM,NXMAX,NYMAX
      INTEGER NZMAX,NZOB,NZSR
      COMPLEX G(NMAX,N),EXX,EXY,EXZ,EYX,EYY,EYZ,EZX,EZY,EZZ,               &
              CDH(0:MLAYER),CDV(0:MLAYER),                                 &
              CDB(NSUBCM,SUB_BLOCK),DELTH,DELTV,                           &
              GRHF(11,NHFILM,NZSR,NZOB),GRHO0(4,NZSR,NZOB),                &
              GRHF3(11,NHFILM,NZSR),GRHO03(4,NZSR)
      INTEGER NX(SUB_BLOCK),NY(SUB_BLOCK),NZ(SUB_BLOCK),NCELL(SUB_BLOCK)
      REAL  X(NXMAX,SUB_BLOCK),Y(NYMAX,SUB_BLOCK),Z(NZMAX,SUB_BLOCK),      &
            CLX(SUB_BLOCK),CLY(SUB_BLOCK),CLZ(SUB_BLOCK),                  &
            ZBND(0:MLAYER),HVK(0:MLAYER),ZOBG(NZOB),                       &
            ZSRG(2,NZSR),RRG(NRG),RRG3(NRG3),PSTION(8)
      COMPLEX ECOMP(9),HCOMP(9)
      EQUIVALENCE (ECOMP(1),EXX),(ECOMP(2),EYX),(ECOMP(3),EZX),   &
                  (ECOMP(4),EXY),(ECOMP(5),EYY),(ECOMP(6),EZY),   &
                  (ECOMP(7),EXZ),(ECOMP(8),EYZ),(ECOMP(9),EZZ)
!
      KEYG=1
!
      IF (KSYM==1) THEN
         LS1=1
         LS2=4
         LS3=3
      ELSE
         LS1=2
         LS2=3
         LS3=1
      ENDIF
!
      DO I=1,N
         DO J=1,N
            G(J,I)=(0.,0.)
         ENDDO
      ENDDO
!
      NCB=0
      DO L=1,SUB_BLOCK
         IF (L>1) NCB=NCB+NCELL(L-1)
         DO K=1,NZ(L)
            DO IOB=MLAYER-1,0,-1
               IF (Z(K,L)>=ZBND(IOB)) THEN
                  NOB=IOB+1
                  GOTO 20
               ENDIF
            ENDDO
            NOB=0
   20       IF (L==1.AND.K==1) NOB1=NOB
            DO I=1,NX(L)
               DO J=1,NY(L)
                  NN=(I-1)*NY(L)*NZ(L)+(J-1)*NZ(L)+K
                  N1=NN+NCB
                  NN1=(N1-1)*3+1
                  DELTH=CDB(NN,L)-CDH(NOB)
                  DELTV=CDB(NN,L)-CDV(NOB)
!
                  NCB1=0
                  DO LL=1,SUB_BLOCK
                     IF (LL>1) NCB1=NCB1+NCELL(LL-1)
                     DO II=1,NX(LL)
                        DO JJ=1,NY(LL)
                           DO KK=1,NZ(LL)
                              N2=(II-1)*NY(LL)*NZ(LL)+(JJ-1)*NZ(LL)   &
                                 +KK+NCB1
                              NN2=(N2-1)*3+1
!
                              DO ISR=MLAYER-1,0,-1
                              IF (Z(KK,LL)>=ZBND(ISR)) THEN
                              NSR=ISR+1
                              GOTO 22
                              ENDIF
                              ENDDO
                              NSR=0
!
! ---- KSELF controls if the calculation for the self-cells
!    should be repeated
   22                         IF (I==1.AND.J==1.AND.K==1.OR.  &
                                 NOB1/=NOB.OR.NOB1/=NSR) THEN
                              KSELF=1
                              ELSE
                              KSELF=0
                              ENDIF
!
                              CLX1=CLX(LL)
                              CLY1=CLY(LL)
                              CLZ1=CLZ(LL)
!
                              DO LSYM=LS1,LS2,LS3
                              IF (LSYM==1) THEN
                              BX=1.
                              BY=1.
                              SX=1.
                              SY=1.
                              SZ=1.
                              ENDIF
                              IF (LSYM==2) THEN
                              BX=-1.
                              BY=1.
                              SX=-1.
                              SY=1.
                              SZ=1.
                              ENDIF
                              IF (LSYM==3) THEN
                              BX=1.
                              BY=-1.
                              SX=-1.
                              SY=1.
                              SZ=-1.
                              ENDIF
                              IF (LSYM==4) THEN
                              BX=-1.
                              BY=-1.
                              SX=1.
                              SY=1.
                              SZ=-1.
                              ENDIF
!
                              PSTION(1)=X(I,L)
                              PSTION(2)=Y(J,L)
                              PSTION(3)=Z(K,L)
                              PSTION(4)=BX*X(II,LL)
                              PSTION(5)=BY*Y(JJ,LL)
                              PSTION(6)=Z(KK,LL)
                              CALL THR_D_GREEN(KEYG,PSTION,FRQ,MLAYER,ZBND,  &
                                 CDH,HVK,NZOB,ZOBG,NZSR,ZSRG,                &
                                 RHOMIN,DMIN,NHFILM,RRG,NRG,GRHF,RRG3,       &
                                 NRG3,GRHF3,GRHO0,GRHO03,CLX1,CLY1,CLZ1,     &
                                 CLMN,KCLMN,BLMIN,KACC,KUTCRP,KSELF,         &
                                 ECOMP,HCOMP)
!
                              G(NN1,NN2)=G(NN1,NN2)-SX*EXX
                              G(NN1+1,NN2)=G(NN1+1,NN2)-SX*EYX
                              G(NN1+2,NN2)=G(NN1+2,NN2)-SX*EZX
                              G(NN1,NN2+1)=G(NN1,NN2+1)-SY*EXY
                              G(NN1+1,NN2+1)=G(NN1+1,NN2+1)-SY*EYY
                              G(NN1+2,NN2+1)=G(NN1+2,NN2+1)-SY*EZY
                              G(NN1,NN2+2)=G(NN1,NN2+2)-SZ*EXZ
                              G(NN1+1,NN2+2)=G(NN1+1,NN2+2)-SZ*EYZ
                              G(NN1+2,NN2+2)=G(NN1+2,NN2+2)-SZ*EZZ
                              ENDDO
                              IF (KSYM==1.AND.N1==N2) THEN
                              G(NN1,NN2)=G(NN1,NN2)+1./DELTH
                              G(NN1+1,NN2+1)=G(NN1+1,NN2+1)+1./DELTH
                              G(NN1+2,NN2+2)=G(NN1+2,NN2+2)+1./DELTV
                              ENDIF
                           ENDDO
                        ENDDO
                     ENDDO
                  ENDDO
               ENDDO
            ENDDO
         ENDDO
      ENDDO
      RETURN
      END
!
!**** End of MTRX_3M
!
!
      SUBROUTINE MTRX_3MS(NMAX,N,NXMAX,NYMAX,NZMAX,NX,NY,NZ,NCELL,        &
                          NSUBCM,SUB_BLOCK,X,Y,Z,CLX,CLY,CLZ,CDB,KSYM,G,  &
                          FRQ,MLAYER,ZBND,CDH,CDV,HVK,NZOB,ZOBG,NZSR,     &
                          ZSRG,RHOMIN,DMIN,NHFILM,RRG,NRG,GRHF,           &
                          RRG3,NRG3,GRHF3,GRHO0,GRHO03,CLMN,KCLMN,        &
                          BLMIN,KACC,KUTCRP)
!
!**** SET UP THE MATRIX FOR A SYMMETRIC STRUCTURE WITH
!   EQUAL CELL SIZES FOR SYMMETRIC BODY EMBBEDED IN
!   AN ISOTROPIC BODY OR IN A SINGLE LAYER OF AN ANISOTROPIC
!   EARTH
!
!   Note the matrix is symmetrical and is stored in a doubly
!   subscripted array
!
!   The differences among smtrx3ms, smtrx3m and smtrx3
!   are like those among smtrx1ms, smtrx1m and smtrx1
!
!   Note that only two quarters, either quarter I and IV
!   or quarter II and III, are computed at a time, which is
!   controled by the parameter KSYM (=1 or 2). The actual
!   scattering matrix is then formed in the main routine
!   by addition or substraction of the results of KSYM=1
!   and 2 according to the polarizations.
!
!
      IMPLICIT NONE
!
      REAL BLMIN,BX,BY,CLMN,CLX1,CLY1,CLZ1,DMIN,FRQ,RHOMIN,SX,SY,SZ
      INTEGER I,II,IOB,ISR,J,JJ,K,KACC,KCLMN,KEYG,KK,KSELF,KSYM,KUTCRP,   &
              L,LL,LS1,LS2,LS3,LSYM
      INTEGER MLAYER,N,N1,N2,SUB_BLOCK,NCB,NCB1,NHFILM,NMAX,NN,NN1,NN2,   &
              NOB,NOB1,NRG,NRG3,NSR,NSUBCM,NXMAX,NYMAX
      INTEGER NZMAX,NZOB,NZSR
      COMPLEX G(NMAX,N),EXX,EXY,EXZ,EYX,EYY,EYZ,EZX,EZY,EZZ,              &
              CDH(0:MLAYER),CDV(0:MLAYER),                                &
              CDB(NSUBCM,SUB_BLOCK),DELTH,DELTV,                          &
              GRHF(11,NHFILM,NZSR,NZOB),GRHO0(4,NZSR,NZOB),               &
              GRHF3(11,NHFILM,NZSR),GRHO03(4,NZSR)
      INTEGER NX(SUB_BLOCK),NY(SUB_BLOCK),NZ(SUB_BLOCK),NCELL(SUB_BLOCK)
      REAL  X(NXMAX,SUB_BLOCK),Y(NYMAX,SUB_BLOCK),Z(NZMAX,SUB_BLOCK),     &
            CLX(SUB_BLOCK),CLY(SUB_BLOCK),CLZ(SUB_BLOCK),                 &
            ZBND(0:MLAYER),HVK(0:MLAYER),ZOBG(NZOB),                      &
            ZSRG(2,NZSR),RRG(NRG),RRG3(NRG3),PSTION(8)
      COMPLEX ECOMP(9),HCOMP(9)
      EQUIVALENCE (ECOMP(1),EXX),(ECOMP(2),EYX),(ECOMP(3),EZX),   &
                  (ECOMP(4),EXY),(ECOMP(5),EYY),(ECOMP(6),EZY),   &
                  (ECOMP(7),EXZ),(ECOMP(8),EYZ),(ECOMP(9),EZZ)
!
      KEYG=1
!
      IF (KSYM==1) THEN
         LS1=1
         LS2=4
         LS3=3
      ELSE
         LS1=2
         LS2=3
         LS3=1
      ENDIF
!
      DO I=1,N
         DO J=1,N
            G(J,I)=(0.,0.)
         ENDDO
      ENDDO
!
      NCB=0
      DO L=1,SUB_BLOCK
         IF (L>1) NCB=NCB+NCELL(L-1)
         DO K=1,NZ(L)
            DO IOB=MLAYER-1,0,-1
               IF (Z(K,L)>=ZBND(IOB)) THEN
                  NOB=IOB+1
                  GOTO 20
               ENDIF
            ENDDO
            NOB=0
   20       IF (L==1.AND.K==1) NOB1=NOB
            DO I=1,NX(L)
               DO J=1,NY(L)
                  NN=(I-1)*NY(L)*NZ(L)+(J-1)*NZ(L)+K
                  N1=NN+NCB
                  NN1=(N1-1)*3+1
                  DELTH=CDB(NN,L)-CDH(NOB)
                  DELTV=CDB(NN,L)-CDV(NOB)
!
                  NCB1=0
                  DO LL=1,SUB_BLOCK
                     IF (LL>1) NCB1=NCB1+NCELL(LL-1)
                     DO II=1,NX(LL)
                        DO JJ=1,NY(LL)
                           DO KK=1,NZ(LL)
                              N2=(II-1)*NY(LL)*NZ(LL)+(JJ-1)*NZ(LL)   &
                                 +KK+NCB1
                              NN2=(N2-1)*3+1
                              DO ISR=MLAYER-1,0,-1
                              IF (Z(KK,LL)>=ZBND(ISR)) THEN
                              NSR=ISR+1
                              GOTO 22
                              ENDIF
                              ENDDO
                              NSR=0
!
! ---- KSELF controls if the calculation for the self-cells
!    should be repeated
   22                         IF (I==1.AND.J==1.AND.K==1.OR.  &
                                 NOB1/=NOB.OR.NOB1/=NSR) THEN
                              KSELF=1
                              ELSE
                              KSELF=0
                              ENDIF
!
                              IF (N1<=N2) THEN
!
                              CLX1=CLX(LL)
                              CLY1=CLY(LL)
                              CLZ1=CLZ(LL)
                              DO LSYM=LS1,LS2,LS3
                              IF (LSYM==1) THEN
                              BX=1.
                              BY=1.
                              SX=1.
                              SY=1.
                              SZ=1.
                              ENDIF
                              IF (LSYM==2) THEN
                              BX=-1.
                              BY=1.
                              SX=-1.
                              SY=1.
                              SZ=1.
                              ENDIF
                              IF (LSYM==3) THEN
                              BX=1.
                              BY=-1.
                              SX=-1.
                              SY=1.
                              SZ=-1.
                              ENDIF
                              IF (LSYM==4) THEN
                              BX=-1.
                              BY=-1.
                              SX=1.
                              SY=1.
                              SZ=-1.
                              ENDIF
!
                              PSTION(1)=X(I,L)
                              PSTION(2)=Y(J,L)
                              PSTION(3)=Z(K,L)
                              PSTION(4)=BX*X(II,LL)
                              PSTION(5)=BY*Y(JJ,LL)
                              PSTION(6)=Z(KK,LL)
                              CALL THR_D_GREEN(KEYG,PSTION,FRQ,MLAYER,ZBND,  &
                                 CDH,HVK,NZOB,ZOBG,NZSR,ZSRG,                &
                                 RHOMIN,DMIN,NHFILM,RRG,NRG,GRHF,RRG3,       &
                                 NRG3,GRHF3,GRHO0,GRHO03,CLX1,CLY1,CLZ1,     &
                                 CLMN,KCLMN,BLMIN,KACC,KUTCRP,KSELF,         &
                                 ECOMP,HCOMP)
!
                              G(NN1,NN2)=G(NN1,NN2)-SX*EXX
                              G(NN1+1,NN2)=G(NN1+1,NN2)-SX*EYX
                              G(NN1+2,NN2)=G(NN1+2,NN2)-SX*EZX
                              G(NN1,NN2+1)=G(NN1,NN2+1)-SY*EXY
                              G(NN1+1,NN2+1)=G(NN1+1,NN2+1)-SY*EYY
                              G(NN1+2,NN2+1)=G(NN1+2,NN2+1)-SY*EZY
                              G(NN1,NN2+2)=G(NN1,NN2+2)-SZ*EXZ
                              G(NN1+1,NN2+2)=G(NN1+1,NN2+2)-SZ*EYZ
                              G(NN1+2,NN2+2)=G(NN1+2,NN2+2)-SZ*EZZ
                              ENDDO
                              IF (KSYM==1.AND.N1==N2) THEN
                              G(NN1,NN2)=G(NN1,NN2)+1./DELTH
                              G(NN1+1,NN2+1)=G(NN1+1,NN2+1)+1./DELTH
                              G(NN1+2,NN2+2)=G(NN1+2,NN2+2)+1./DELTV
                              ENDIF
                              ENDIF
                           ENDDO
                        ENDDO
                     ENDDO
                  ENDDO
               ENDDO
            ENDDO
         ENDDO
      ENDDO
      DO I=1,N
         DO J=1,N
            IF (I>J) G(I,J)=G(J,I)
         ENDDO
      ENDDO
      RETURN
      END
!
!**** End of MTRX_3MS
!
!
      SUBROUTINE MTRX_M(NMAX,N,NXMAX,NYMAX,NZMAX,NX1,NY1,NZ1,NCELL1,     &
                        SUB_BLOCK1,X1,Y1,Z1,NX2,NY2,NZ2,NCELL2,          &
                        SUB_BLOCK2,X2,Y2,Z2,CLX2,CLY2,CLZ2,G,FRQ,MLAYER, &
                        ZBND,CDH,HVK,NZOB,ZOBG,NZSR,ZSRG,RHOMIN,DMIN,    &
                        NHFILM,RRG,NRG,GRHF,RRG3,NRG3,GRHF3,GRHO0,       &
                        GRHO03,CLMN,KCLMN,BLMIN,KACC,KUTCRP)
!
!**** Form mutual-coupling matrices between substructures
!
      IMPLICIT NONE
!
      REAL BLMIN,CLMN,CLX,CLY,CLZ,DMIN,FRQ,RHOMIN
      INTEGER I,II,J,JJ,K,KACC,KCLMN,KEYG,KK,KSELF,KUTCRP,L,LL,MLAYER,N,  &
              N1,N2,SUB_BLOCK1,SUB_BLOCK2,NCB
      INTEGER NCB1,NHFILM,NMAX,NN,NN1,NN2,NRG,NRG3,NXMAX,NYMAX,NZMAX,     &
              NZOB,NZSR
      COMPLEX G(NMAX,N),EXX,EXY,EXZ,EYX,EYY,EYZ,EZX,EZY,EZZ,              &
              GRHF(11,NHFILM,NZSR,NZOB),GRHO0(4,NZSR,NZOB),               &
              GRHF3(11,NHFILM,NZSR),GRHO03(4,NZSR)
      INTEGER NX1(SUB_BLOCK1),NY1(SUB_BLOCK1),NZ1(SUB_BLOCK1),            &
              NCELL1(SUB_BLOCK1),NX2(SUB_BLOCK2),NY2(SUB_BLOCK2),         &
              NZ2(SUB_BLOCK2),NCELL2(SUB_BLOCK2)
      REAL  X1(NXMAX,SUB_BLOCK1),Y1(NYMAX,SUB_BLOCK1),Z1(NZMAX,SUB_BLOCK1),  &
            X2(NXMAX,SUB_BLOCK2),Y2(NYMAX,SUB_BLOCK2),Z2(NZMAX,SUB_BLOCK2),  &
            CLX2(SUB_BLOCK2),CLY2(SUB_BLOCK2),CLZ2(SUB_BLOCK2),              &
            ZBND(0:MLAYER),HVK(0:MLAYER),ZOBG(NZOB),                         &
            ZSRG(2,NZSR),RRG(NRG),RRG3(NRG3),PSTION(8)
      COMPLEX CDH(0:MLAYER),ECOMP(9),HCOMP(9)
      EQUIVALENCE (ECOMP(1),EXX),(ECOMP(2),EYX),(ECOMP(3),EZX),   &
                  (ECOMP(4),EXY),(ECOMP(5),EYY),(ECOMP(6),EZY),   &
                  (ECOMP(7),EXZ),(ECOMP(8),EYZ),(ECOMP(9),EZZ)
!
      KEYG=1
!
      NCB=0
      DO L=1,SUB_BLOCK1
         IF (L>1) NCB=NCB+NCELL1(L-1)
! ---- Note that here k is the out-loop which may save some time in
!    array reference in the interpolation
         DO K=1,NZ1(L)
            DO I=1,NX1(L)
               DO J=1,NY1(L)
                  NN=(I-1)*NY1(L)*NZ1(L)+(J-1)*NZ1(L)+K
                  N1=NN+NCB
                  NN1=(N1-1)*3+1
                  NCB1=0
                  DO LL=1,SUB_BLOCK2
                     IF (LL>1) NCB1=NCB1+NCELL2(LL-1)
                     DO II=1,NX2(LL)
                        DO JJ=1,NY2(LL)
                           DO KK=1,NZ2(LL)
                              N2=(II-1)*NY2(LL)*NZ2(LL)+(JJ-1)*NZ2(LL) +   &
                                  KK+NCB1
                              NN2=(N2-1)*3+1
                              CLX=CLX2(LL)
                              CLY=CLY2(LL)
                              CLZ=CLZ2(LL)
!
                              PSTION(1)=X1(I,L)
                              PSTION(2)=Y1(J,L)
                              PSTION(3)=Z1(K,L)
                              PSTION(4)=X2(II,LL)
                              PSTION(5)=Y2(JJ,LL)
                              PSTION(6)=Z2(KK,LL)
                              CALL THR_D_GREEN(KEYG,PSTION,FRQ,MLAYER,ZBND,  &
                                 CDH,HVK,NZOB,ZOBG,NZSR,ZSRG,                &
                                 RHOMIN,DMIN,NHFILM,RRG,NRG,GRHF,RRG3,       &
                                 NRG3,GRHF3,GRHO0,GRHO03,CLX,CLY,CLZ,        &
                                 CLMN,KCLMN,BLMIN,KACC,KUTCRP,KSELF,         &
                                 ECOMP,HCOMP)
!
                              G(NN1,NN2)=EXX
                              G(NN1+1,NN2)=EYX
                              G(NN1+2,NN2)=EZX
                              G(NN1,NN2+1)=EXY
                              G(NN1+1,NN2+1)=EYY
                              G(NN1+2,NN2+1)=EZY
                              G(NN1,NN2+2)=EXZ
                              G(NN1+1,NN2+2)=EYZ
                              G(NN1+2,NN2+2)=EZZ
                           ENDDO
                        ENDDO
                     ENDDO
                  ENDDO
               ENDDO
            ENDDO
         ENDDO
      ENDDO
      RETURN
      END
!
!
      SUBROUTINE MTRX_MS(NMAX,N,NXMAX,NYMAX,NZMAX,NX1,NY1,NZ1,NCELL1,     &
                         SUB_BLOCK1,X1,Y1,Z1,NX2,NY2,NZ2,NCELL2,          &
                         SUB_BLOCK2,X2,Y2,Z2,CLX2,CLY2,CLZ2,KSYM,G,       &
                         FRQ,MLAYER,ZBND,CDH,HVK,NZOB,ZOBG,NZSR,          &
                         ZSRG,RHOMIN,DMIN,NHFILM,RRG,NRG,                 &
                         GRHF,RRG3,NRG3,GRHF3,GRHO0,GRHO03,CLMN,          &
                         KCLMN,BLMIN,KACC,KUTCRP)
!
!     Setting up the mutual interaction matrix for a symmetric
!     Structure
!
!      Note that only two quarters, either quarter I and IV
!      or quarter II and III, are computed at a time, which is
!      controled by the parameter KSYM (=1 or 2). The actual
!      scattering matrix is then formed in the main routine
!      by addition or substraction of the results of KSYM=1
!      and 2 according to the polarizations.
!
      IMPLICIT NONE
!
      REAL BLMIN,BX,BY,CLMN,CLX,CLY,CLZ,DMIN,FRQ,RHOMIN,SX,SY,SZ
      INTEGER I,II,J,JJ,K,KACC,KCLMN,KEYG,KK,KSELF,KSYM,KUTCRP,L,LL,LS1,    &
              LS2,LS3,LSYM,MLAYER,N
      INTEGER N1,N2,SUB_BLOCK1,SUB_BLOCK2,NCB,NCB1,NHFILM,NMAX,NN,NN1,NN2,  &
              NRG,NRG3,NXMAX,NYMAX,NZMAX,NZOB,NZSR
      COMPLEX G(NMAX,N),EXX,EXY,EXZ,EYX,EYY,EYZ,EZX,EZY,EZZ,                &
              GRHF(11,NHFILM,NZSR,NZOB),GRHO0(4,NZSR,NZOB),                 &
              GRHF3(11,NHFILM,NZSR),GRHO03(4,NZSR)
      INTEGER NX1(SUB_BLOCK1),NY1(SUB_BLOCK1),NZ1(SUB_BLOCK1),              &
              NCELL1(SUB_BLOCK1),NX2(SUB_BLOCK2),NY2(SUB_BLOCK2),           &
              NZ2(SUB_BLOCK2),NCELL2(SUB_BLOCK2)
      REAL  X1(NXMAX,SUB_BLOCK1),Y1(NYMAX,SUB_BLOCK1),Z1(NZMAX,SUB_BLOCK1), &
            X2(NXMAX,SUB_BLOCK2),Y2(NYMAX,SUB_BLOCK2),Z2(NZMAX,SUB_BLOCK2),  &
            CLX2(SUB_BLOCK2),CLY2(SUB_BLOCK2),CLZ2(SUB_BLOCK2),              &
            ZBND(0:MLAYER),HVK(0:MLAYER),ZOBG(NZOB),                         &
            ZSRG(2,NZSR),RRG(NRG),RRG3(NRG3),PSTION(8)
      COMPLEX CDH(0:MLAYER),ECOMP(9),HCOMP(9)
      EQUIVALENCE (ECOMP(1),EXX),(ECOMP(2),EYX),(ECOMP(3),EZX),   &
                  (ECOMP(4),EXY),(ECOMP(5),EYY),(ECOMP(6),EZY),   &
                  (ECOMP(7),EXZ),(ECOMP(8),EYZ),(ECOMP(9),EZZ)
!
      KEYG=1
!
      IF (KSYM==1) THEN
         LS1=1
         LS2=4
         LS3=3
      ELSE
         LS1=2
         LS2=3
         LS3=1
      ENDIF
!
      DO I=1,N
         DO J=1,NMAX
            G(J,I)=(0.,0.)
         ENDDO
      ENDDO
!
      NCB=0
      DO L=1,SUB_BLOCK1
         IF (L>1) NCB=NCB+NCELL1(L-1)
! ---- Note that here k is the out-loop which may save some time in
!    array reference in the interpolation
         DO K=1,NZ1(L)
            DO I=1,NX1(L)
               DO J=1,NY1(L)
                  NN=(I-1)*NY1(L)*NZ1(L)+(J-1)*NZ1(L)+K
                  N1=NN+NCB
                  NN1=(N1-1)*3+1
                  NCB1=0
                  DO LL=1,SUB_BLOCK2
                     IF (LL>1) NCB1=NCB1+NCELL2(LL-1)
                     DO II=1,NX2(LL)
                        DO JJ=1,NY2(LL)
                           DO KK=1,NZ2(LL)
                              N2=(II-1)*NY2(LL)*NZ2(LL)+(JJ-1)*NZ2(LL)  &
                                 +KK+NCB1
                              NN2=(N2-1)*3+1
                              CLX=CLX2(LL)
                              CLY=CLY2(LL)
                              CLZ=CLZ2(LL)
                              DO LSYM=LS1,LS2,LS3
                              IF (LSYM==1) THEN
                              BX=1.
                              BY=1.
                              SX=1.
                              SY=1.
                              SZ=1.
                              ENDIF
                              IF (LSYM==2) THEN
                              BX=-1.
                              BY=1.
                              SX=-1.
                              SY=1.
                              SZ=1.
                              ENDIF
                              IF (LSYM==3) THEN
                              BX=1.
                              BY=-1.
                              SX=-1.
                              SY=1.
                              SZ=-1.
                              ENDIF
                              IF (LSYM==4) THEN
                              BX=-1.
                              BY=-1.
                              SX=1.
                              SY=1.
                              SZ=-1.
                              ENDIF
!
                              PSTION(1)=X1(I,L)
                              PSTION(2)=Y1(J,L)
                              PSTION(3)=Z1(K,L)
                              PSTION(4)=BX*X2(II,LL)
                              PSTION(5)=BY*Y2(JJ,LL)
                              PSTION(6)=Z2(KK,LL)
                              CALL THR_D_GREEN(KEYG,PSTION,FRQ,MLAYER,ZBND,  &
                                 CDH,HVK,NZOB,ZOBG,NZSR,ZSRG,RHOMIN,DMIN,    &
                                 NHFILM,RRG,NRG,GRHF,RRG3,NRG3,GRHF3,GRHO0,  &
                                 GRHO03,CLX,CLY,CLZ,CLMN,KCLMN,BLMIN,KACC,   &
                                 KUTCRP,KSELF,ECOMP,HCOMP)
!
                              G(NN1,NN2)=G(NN1,NN2)+SX*EXX
                              G(NN1+1,NN2)=G(NN1+1,NN2)+SX*EYX
                              G(NN1+2,NN2)=G(NN1+2,NN2)+SX*EZX
                              G(NN1,NN2+1)=G(NN1,NN2+1)+SY*EXY
                              G(NN1+1,NN2+1)=G(NN1+1,NN2+1)+SY*EYY
                              G(NN1+2,NN2+1)=G(NN1+2,NN2+1)+SY*EZY
                              G(NN1,NN2+2)=G(NN1,NN2+2)+SZ*EXZ
                              G(NN1+1,NN2+2)=G(NN1+1,NN2+2)+SZ*EYZ
                              G(NN1+2,NN2+2)=G(NN1+2,NN2+2)+SZ*EZZ
                              ENDDO
                           ENDDO
                        ENDDO
                     ENDDO
                  ENDDO
               ENDDO
            ENDDO
         ENDDO
      ENDDO
      RETURN
      END
!
!**** End of MTRX_MS
!
!
      SUBROUTINE MTRX_SPSGSB(SBX,SBY,SBZ,NXS,NYS,NZS,XSB,YSB,ZSB,NSMR,G,   &
                             FRQ,MLAYER,ZBND,CDH,HVK,NZOB,ZOBG,NZSR,ZSRG,  &
                             RHOMIN,DMIN,NHFILM,RRG,NRG,GRHF,RRG3,NRG3,    &
                             GRHF3,GRHO0,GRHO03,CLMN,KCLMN,BLMIN,KACC,KUTCRP)
!
!**** Compute the non-identical elements of the scattering matrix
!   for the super block discretized into equal-size cells
!
!   Cell conductivities are not considered in this routine.
!
!   The size of the array G is determined in the main program.
!   It has the same size as the array grhf which stores the
!   grid value of the hankel transforms.
!
!   The parameter kself controls if the computation for the
!   integration of the primary part of the Green's function
!   for self-cells should be repeated. As the dimensions of
!   the cells within a block is the same, this integration
!   need to be done only once (kself=1) for cells located in
!   the same layer.
!
! Input parameters
!
!  SBX:     Real,  dimension of the super block in the x-direction.
!  SBY:     Real,  dimension of the super block in the y-direction.
!  SBZ:     Real,  dimension of the super block in the z-direction.
!  NXS:     Integer,  number of cells in the x-direction of the superblock.
!  NYS:     Integer,  number of cells in the y-direction of the superblock.
!  NZS:     Integer,  number of cells in the z-direction of the superblock.
!  XSB:     Real,  x-ccordinate of the superblock.
!  YSB:     Real,  y-ccordinate of the superblock.
!  ZSB:     Real,  z-ccordinate of the superblock.
!  NSMR:    Integer,  the maximal number of non-identical elements
!           for the scattering matrix which is determined by the
!           paramters NZSR, NZOB, and NHFILM of the code.  See the corresponding
!           paramter list in the main program for detail.
!
!  All other parameters FRQ, MLAYER, ZBND,  CDH, HVK, NZOB, ZOBG,
!  NZSR, ZSRG,  RHOMIN, DMIN, NHFILM, RRG, NRG, GRHF,
!  GRHF3, GRHO0, GRHO03, CLMN, KCLMN, BLMIN, KACC, and KUTCRP are to
!  be passed into routine THR_D_GREEN.  Check THR_D_GREEN for their
!  descriptions.
!
!
!Output parameters:
!
!  G:       Complex G(NSMR/3,3),  the non-identical matrix entries
!
!
!**** Called by:  MAIN_MATRICES
!
!**** Calls:      THR_D_GREEN
!
!
      IMPLICIT NONE
!
      REAL BLMIN,CLMN,FRQ,RHOMIN,SBX,SBY,SBZ,SCX,SCY,SCZ,X1,XI,XSB,Y1,   &
           YI,YSB,ZI,ZJ,ZSB
      INTEGER I,IOB,ISR,J,K,KACC,KCLMN,KEYG,KK,KSELF,KUTCRP,MLAYER,      &
              NHFILM,NN,NN1,NOB,NOB1,NRG,NRG3,NSMR
      INTEGER NSR,NXS,NYS,NZOB,NZS,NZSR
!
      COMPLEX G(NSMR/3,3)
!-- Parameter HCOMP is only used for consistence with routine THR_D_GREEN.
      COMPLEX ECOMP(9),HCOMP(9),EXX,EYX,EZX,EXY,EYY,EZY,EXZ,EYZ,EZZ,       &
              CDH(0:MLAYER),GRHF(11,NHFILM,NZSR,NZOB),GRHO0(4,NZSR,NZOB),  &
              GRHF3(11,NHFILM,NZSR),GRHO03(4,NZSR)
      REAL ZBND(0:MLAYER),HVK(0:MLAYER),ZOBG(NZOB),ZSRG(2,NZSR),           &
           RRG(NHFILM),RRG3(NRG3),PSTION(8),DMIN
      EQUIVALENCE (ECOMP(1),EXX),(ECOMP(2),EYX),(ECOMP(3),EZX),   &
                  (ECOMP(4),EXY),(ECOMP(5),EYY),(ECOMP(6),EZY),   &
                  (ECOMP(7),EXZ),(ECOMP(8),EYZ),(ECOMP(9),EZZ)
!
      KEYG=1
!
! --- Compute the cell dimension of the super block
!
      SCX=SBX/NXS
      SCY=SBY/NYS
      SCZ=SBZ/NZS
!
! --- Set the x- and y-coordinates of the cells at the lower left
!   corner
!
      X1=XSB-.5*SBX+.5*SCX
      Y1=YSB-.5*SBY+.5*SCY
!
      DO KK=1,NZS
         ZJ=ZSB-.5*SBZ+.5*SCZ+(KK-1)*SCZ
         DO IOB=MLAYER-1,0,-1
            IF (ZJ>=ZBND(IOB)) THEN
               NOB=IOB+1
               GOTO 50
            ENDIF
         ENDDO
         NOB=0
   50    IF (KK==1) NOB1=NOB
!
         DO K=1,NZS
!
! --- Reciprocity
!
!   Note that unlike in the routines MTRX_SPS1 etc. here the KK loop
!   is the field cell loop
!
            IF (KK<=K) THEN
!
               ZI=ZSB-.5*SBZ+.5*SCZ+(K-1)*SCZ
               DO ISR=MLAYER-1,0,-1
                  IF (ZI>=ZBND(ISR)) THEN
                     NSR=ISR+1
                     GOTO 60
                  ENDIF
               ENDDO
               NSR=0
!
! --- Note that the order of the array G in this routine is
!   different from that of the scattering matrices in other
!   routines which form the scattering matrices.  This is
!   due to the consideration of the reciprocity available for
!   different z-levels (the KK loop).  Also the loop for the
!   vertical direction (the K loop) is moved ahead of the
!   other two loops
!
   60          DO J=1,NYS
                  DO I=1,NXS
!
                     NN=(K-KK)*NXS*NYS+(J-1)*NXS+I
                     NN1=(3*NXS*NYS*NZS+3*NXS*NYS*NZS-3*NXS*NYS*(KK-2))  &
                         *(KK-1)/2+(NN-1)*3+1
!
! ---- KSELF controls if the calculation for the self-cells
!    should be repeated
!
                     IF (I==1.AND.J==1.AND.K==1.OR.NOB1/=NOB.OR.  &
                         NOB1/=NSR) THEN
                        KSELF=1
                     ELSE
                        KSELF=0
                     ENDIF
!
                     XI=XSB-.5*SBX+.5*SCX+(I-1)*SCX
                     YI=YSB-.5*SBY+.5*SCY+(J-1)*SCY
!
                     PSTION(1)=X1
                     PSTION(2)=Y1
                     PSTION(3)=ZJ
                     PSTION(4)=XI
                     PSTION(5)=YI
                     PSTION(6)=ZI
                     CALL THR_D_GREEN(KEYG,PSTION,FRQ,MLAYER,ZBND,CDH,HVK,  &
                        NZOB,ZOBG,NZSR,ZSRG,RHOMIN,DMIN,NHFILM,             &
                        RRG,NRG,GRHF,RRG3,NRG3,GRHF3,GRHO0,GRHO03,SCX,      &
                        SCY,SCZ,CLMN,KCLMN,BLMIN,KACC,KUTCRP,KSELF,         &
                        ECOMP,HCOMP)
!
                     G(NN1,1)=-EXX
                     G(NN1+1,1)=-EYX
                     G(NN1+2,1)=-EZX
                     G(NN1,2)=-EXY
                     G(NN1+1,2)=-EYY
                     G(NN1+2,2)=-EZY
                     G(NN1,3)=-EXZ
                     G(NN1+1,3)=-EYZ
                     G(NN1+2,3)=-EZZ
                  ENDDO
               ENDDO
            ENDIF
!
         ENDDO
      ENDDO
!
      RETURN
      END
!
!**** End of GSB
!
!
      SUBROUTINE MTRX_SPS(NSMR,MLAYER,ZBND,CDH,CDV,SBX,SBY,SBZ,NXS,NYS,    &
                          NZS,ZSB,NMAX,N,NXMAX,NYMAX,NZMAX,NX,NY,NZ,NCELL, &
                          NSUBCM,SUB_BLOCK,X,Y,Z,CDB,GSB2,G)
!
!****  Form the scattering matrix using spatial symmetry reduction
!    for diagonal submatrices or a general matrix of a
!    non-symmetric structure
!
!    The non-identical elements are pre-computed by the routine
!    GSB and are stored in the array gsb2.  Routine GSB must be called
!    before this routine.
!
!    Note that this routine works per substructure.  Thus,  all
!    structure parameters like NX etc. are those for one substructure.
!
!Input parameters
!
!  NSMR:    Integer,  the maximal number of non-identical elements
!           for the scattering matrix which is determined by the
!           paramters NZSR, NZOB and NHFILM of the code.  See the corresponding
!           paramter list in the main program for detail.
!  MLAYER:  Integer, the number of layers including the air.
!  ZBND:    Real ZBND(0:MLAYER), the z-coordinates of the layer
!           boundaries with the air-earth interface being always
!           0 (zbnd(0)=0).
!  CDH:     Complex CDH(0:MLAYER),  complex conductivities of
!           the layers in the lateral direction including the
!           air (layer 0).
!  CDV:     Complex CDV(0:MLAYER),  complex conductivities of
!           the layers in the vertical direction including the
!           air (layer 0).
!  SBX:     Real,  dimension of the super block in the x-direction.
!  SBY:     Real,  dimension of the super block in the y-direction.
!  SBZ:     Real,  dimension of the super block in the z-direction.
!  NXS:     Integer,  number of cells in the x-direction of the superblock.
!  NYS:     Integer,  number of cells in the y-direction of the superblock.
!  NZS:     Integer,  number of cells in the z-direction of the superblock.
!  ZSB:     Real,  z-ccordinate of the superblock.
!  NMAX:     Integer,  maximal number of unknowns in a substructure.
!            NMAX=3*NSUBCM.
!  N:       Integer,  real dimension of the scattering matrix.
!  NXMAX:   Integer,  maximal number of cells in the x-direction
!           in a block.
!  NYMAX:   Integer,  maximal number of cells in the y-direction
!           in a block.
!  NZMAX:   Integer,  maximal number of cells in the z-direction
!           in a block.
!  NX:      Integer NX(SUB_BLOCK), number of cells in the substructure
!           in the x-direction.
!  NY:      Integer NY(SUB_BLOCK), number of cells in the substructure
!           in the y-direction.
!  NZ:      Integer NZ(SUB_BLOCK), number of cells in the substructure
!           in the z-direction.
!  NCELL:   Integer NCELL(SUB_BLOCK),  number of cell in each block
!           of the substructure.
!  NSUBCM:  Integer,  maximal nuber of cells in a substructure.
!  SUB_BLOCK:  Integer,  number of blocks in the substructure.
!  X:       Real X(NXMAX,SUB_BLOCK), the x-coordinates of the cells
!           of the blocks in the substructure.
!  Y:       Real Y(NXMAX,SUB_BLOCK), the y-coordinates of the cells
!           of the blocks in the substructure.
!  Z:       Real Z(NXMAX,SUB_BLOCK), the z-coordinates of the cells
!           of the blocks in the substructure.
!  CDB:     COMPLEX CDB(NSUBCM,NBMAX),  working array for the
!           complex conductivities of the cells in a substructure.
!           Its values are all stored on the disk in unit 62.
!  GSB2:    Complex GSB2(NSMR/3,3),  the non-identical matrix entries
!
!
!Output parameters:
!
!  G:       Complex G(NMAX,N),  the scattering matrix or the
!           diagonal submatrix
!
!**** Called by:  MAIN_MATRICES
!
!**** Calls:      none
!
!
      IMPLICIT NONE
!
      REAL DX,DY,SBX,SBY,SBZ,SCX,SCY,SCZ,ZSB
      INTEGER I,II,IOB,IX,J,JJ,JY,K,KK,KKZ,KZ,L,LL,MLAYER,MM,MM2,MX,MY,N,N1
      INTEGER N2,SUB_BLOCK,NCB,NCB1,NMAX,NN,NN1,NN2,NOB,NSMR,NSUBCM,NXMAX,   &
              NXS,NYMAX,NYS,NZMAX,NZS
!
      COMPLEX G(NMAX,N),GSB2(NSMR/3,3),CDH(0:MLAYER),CDV(0:MLAYER),          &
              CDB(NSUBCM,SUB_BLOCK),DELTH,DELTV
      INTEGER NX(SUB_BLOCK),NY(SUB_BLOCK),NZ(SUB_BLOCK),NCELL(SUB_BLOCK)
      REAL  X(NXMAX,SUB_BLOCK),Y(NYMAX,SUB_BLOCK),Z(NZMAX,SUB_BLOCK),        &
            ZBND(0:MLAYER)
!
      SCX=SBX/NXS
      SCY=SBY/NYS
      SCZ=SBZ/NZS
!
      NCB=0
      DO L=1,SUB_BLOCK
         IF (L>1) NCB=NCB+NCELL(L-1)
!
         DO I=1,NX(L)
            DO J=1,NY(L)
               DO K=1,NZ(L)
!
                  NN=(I-1)*NY(L)*NZ(L)+(J-1)*NZ(L)+K
                  N1=NN+NCB
                  NN1=(N1-1)*3+1
!
! --- Locate the z-level of the field cell in the super block
!
                  KZ=INT((Z(K,L)+.5*SCZ-(ZSB-.5*SBZ))/SCZ+.2)
!
                  NCB1=0
                  DO LL=1,SUB_BLOCK
                     IF (LL>1) NCB1=NCB1+NCELL(LL-1)
                     DO II=1,NX(LL)
                        DO JJ=1,NY(LL)
                           DO KK=1,NZ(LL)
!
! --- Locate the z'-level of the source cell in the super block
!
                              KKZ=INT((Z(KK,LL)+.5*SCZ-(ZSB-.5*SBZ))  &
                                 /SCZ+.2)
!
! --- Reciprocity to be considered later
!
                              IF (KZ<=KKZ) THEN
!
                              N2=(II-1)*NY(LL)*NZ(LL)+(JJ-1)*NZ(LL)  &
                                 +KK+NCB1
                              NN2=(N2-1)*3+1
!
! --- Identify the relative cell location in the super blocks
!
                              DX=(X(II,LL)-X(I,L))/SCX
! -- For stability
                              IF (DX>=0) IX=INT(DX+.2)+1
                              IF (DX<0) IX=INT(DX-.2)-1
                              IF (IX==-1) IX=1
!
                              DY=(Y(JJ,LL)-Y(J,L))/SCY
! -- For stability
                              IF (DY>=0) JY=INT(DY+.2)+1
                              IF (DY<0) JY=INT(DY-.2)-1
                              IF (JY==-1) JY=1
!
! --- Determine the values of the scattering matrix using the
!   symmetry properties of the Green's functions
!
                              IF (IX>0.AND.JY>0) THEN
!
                              MX=IX
                              MY=JY
!
! --- Note that the order of the array GSB2 determined in the
!   routine GSB is different from that of the scattering matrix
!   formed here in this routine.  Check the routine GSB for
!   more explanations.
!
!   Note here KZ controls the field cell levels
!
                              MM=(KKZ-KZ)*NXS*NYS+(MY-1)*NXS+MX
                              MM2=(3*NXS*NYS*NZS+3*NXS*NYS*NZS-  &
                                 3*NXS*NYS*(KZ-2))*(KZ-1)/2+(MM-1)*3+1
!
                              G(NN1,NN2)=GSB2(MM2,1)
                              G(NN1+1,NN2)=GSB2(MM2+1,1)
                              G(NN1+2,NN2)=GSB2(MM2+2,1)
                              G(NN1,NN2+1)=GSB2(MM2,1+1)
                              G(NN1+1,NN2+1)=GSB2(MM2+1,1+1)
                              G(NN1+2,NN2+1)=GSB2(MM2+2,1+1)
                              G(NN1,NN2+2)=GSB2(MM2,1+2)
                              G(NN1+1,NN2+2)=GSB2(MM2+1,1+2)
                              G(NN1+2,NN2+2)=GSB2(MM2+2,1+2)
!
                              ENDIF
!
                              IF (IX<0.AND.JY>0) THEN
!
                              MX=-IX
                              MY=JY
!
                              MM=(KKZ-KZ)*NXS*NYS+(MY-1)*NXS+MX
                              MM2=(3*NXS*NYS*NZS+3*NXS*NYS*NZS-  &
                                 3*NXS*NYS*(KZ-2))*(KZ-1)/2+(MM-1)*3+1
!
                              G(NN1,NN2)=GSB2(MM2,1)
                              G(NN1+1,NN2)=-GSB2(MM2+1,1)
                              G(NN1+2,NN2)=-GSB2(MM2+2,1)
                              G(NN1,NN2+1)=-GSB2(MM2,1+1)
                              G(NN1+1,NN2+1)=GSB2(MM2+1,1+1)
                              G(NN1+2,NN2+1)=GSB2(MM2+2,1+1)
                              G(NN1,NN2+2)=-GSB2(MM2,1+2)
                              G(NN1+1,NN2+2)=GSB2(MM2+1,1+2)
                              G(NN1+2,NN2+2)=GSB2(MM2+2,1+2)
!
                              ENDIF
!
                              IF (IX<0.AND.JY<0) THEN
!
                              MX=-IX
                              MY=-JY
!
                              MM=(KKZ-KZ)*NXS*NYS+(MY-1)*NXS+MX
                              MM2=(3*NXS*NYS*NZS+3*NXS*NYS*NZS-  &
                                 3*NXS*NYS*(KZ-2))*(KZ-1)/2+(MM-1)*3+1
!
                              G(NN1,NN2)=GSB2(MM2,1)
                              G(NN1+1,NN2)=GSB2(MM2+1,1)
                              G(NN1+2,NN2)=-GSB2(MM2+2,1)
                              G(NN1,NN2+1)=GSB2(MM2,1+1)
                              G(NN1+1,NN2+1)=GSB2(MM2+1,1+1)
                              G(NN1+2,NN2+1)=-GSB2(MM2+2,1+1)
                              G(NN1,NN2+2)=-GSB2(MM2,1+2)
                              G(NN1+1,NN2+2)=-GSB2(MM2+1,1+2)
                              G(NN1+2,NN2+2)=GSB2(MM2+2,1+2)
!
                              ENDIF
!
                              IF (IX>0.AND.JY<0) THEN
!
                              MX=IX
                              MY=-JY
!
                              MM=(KKZ-KZ)*NXS*NYS+(MY-1)*NXS+MX
                              MM2=(3*NXS*NYS*NZS+3*NXS*NYS*NZS-  &
                                 3*NXS*NYS*(KZ-2))*(KZ-1)/2+(MM-1)*3+1
!
                              G(NN1,NN2)=GSB2(MM2,1)
                              G(NN1+1,NN2)=-GSB2(MM2+1,1)
                              G(NN1+2,NN2)=GSB2(MM2+2,1)
                              G(NN1,NN2+1)=-GSB2(MM2,1+1)
                              G(NN1+1,NN2+1)=GSB2(MM2+1,1+1)
                              G(NN1+2,NN2+1)=-GSB2(MM2+2,1+1)
                              G(NN1,NN2+2)=GSB2(MM2,1+2)
                              G(NN1+1,NN2+2)=-GSB2(MM2+1,1+2)
                              G(NN1+2,NN2+2)=GSB2(MM2+2,1+2)
!
                              ENDIF
                              ENDIF
!
                           ENDDO
                        ENDDO
                     ENDDO
                  ENDDO
               ENDDO
            ENDDO
         ENDDO
      ENDDO
!
! --- Construct the entries of KKZ > KZ using the reciprocity
!
      NCB=0
      DO L=1,SUB_BLOCK
         IF (L>1) NCB=NCB+NCELL(L-1)
!
         DO I=1,NX(L)
            DO J=1,NY(L)
               DO K=1,NZ(L)
!
                  NN=(I-1)*NY(L)*NZ(L)+(J-1)*NZ(L)+K
                  N1=NN+NCB
                  NN1=(N1-1)*3+1
!
                  KZ=INT((Z(K,L)+.5*SCZ-(ZSB-.5*SBZ))/SCZ+.2)
!
                  NCB1=0
                  DO LL=1,SUB_BLOCK
                     IF (LL>1) NCB1=NCB1+NCELL(LL-1)
                     DO II=1,NX(LL)
                        DO JJ=1,NY(LL)
                           DO KK=1,NZ(LL)
!
                              KKZ=INT((Z(KK,LL)+.5*SCZ-(ZSB-.5*SBZ))/SCZ+.2)
!
                              IF (KZ>KKZ) THEN
!
                              N2=(II-1)*NY(LL)*NZ(LL)+(JJ-1)*NZ(LL)+KK+NCB1
                              NN2=(N2-1)*3+1
!
                              G(NN1,NN2)=G(NN2,NN1)
                              G(NN1+1,NN2)=G(NN2,NN1+1)
                              G(NN1+2,NN2)=G(NN2,NN1+2)
                              G(NN1,NN2+1)=G(NN2+1,NN1)
                              G(NN1+1,NN2+1)=G(NN2+1,NN1+1)
                              G(NN1+2,NN2+1)=G(NN2+1,NN1+2)
                              G(NN1,NN2+2)=G(NN2+2,NN1)
                              G(NN1+1,NN2+2)=G(NN2+2,NN1+1)
                              G(NN1+2,NN2+2)=G(NN2+2,NN1+2)
                              ENDIF
!
                           ENDDO
                        ENDDO
                     ENDDO
                  ENDDO
               ENDDO
            ENDDO
         ENDDO
      ENDDO
!
! --- Add the term of cell conductivity to the celf cells
!
      NCB=0
      DO L=1,SUB_BLOCK
         IF (L>1) NCB=NCB+NCELL(L-1)
!
         DO K=1,NZ(L)
            DO IOB=MLAYER-1,0,-1
               IF (Z(K,L)>=ZBND(IOB)) THEN
                  NOB=IOB+1
                  GOTO 20
               ENDIF
            ENDDO
            NOB=0
!
   20       DO I=1,NX(L)
               DO J=1,NY(L)
!
                  NN=(I-1)*NY(L)*NZ(L)+(J-1)*NZ(L)+K
                  N1=NN+NCB
                  NN1=(N1-1)*3+1
!
                  DELTH=CDB(NN,L)-CDH(NOB)
                  DELTV=CDB(NN,L)-CDV(NOB)
!
                  G(NN1,NN1)=1./DELTH+G(NN1,NN1)
                  G(NN1+1,NN1+1)=1./DELTH+G(NN1+1,NN1+1)
                  G(NN1+2,NN1+2)=1./DELTV+G(NN1+2,NN1+2)
!
               ENDDO
            ENDDO
         ENDDO
      ENDDO
!
      RETURN
      END
!
!**** End of MTRX_SPS
!
!
      SUBROUTINE MTRX_SPSS(NSMR,MLAYER,ZBND,CDH,CDV,SBX,SBY,SBZ,NXS,NYS,    &
                           NZS,ZSB,NMAX,N,NXMAX,NYMAX,NZMAX,NX,NY,NZ,NCELL, &
                           NSUBCM,SUB_BLOCK,X,Y,Z,CDB,KSYM,G,GSB2)
!
!**** Form the scattering matrix using spatial symmetry reduction
!      for structures with two-plane symmetries under
!             plane wave excitations
!
!   For the diagonal submatrices or a general matrix of a
!   non-symmetric structure
!
!   Non-identical elements are pre-computed by the routine
!   GSB and are stored in the array gsb2.
!
!   Note the matrix is symmetrical and is stored in a doubly
!   subscripted array
!
!   Note that only two quarters, either quarter I and IV
!   or quarter II and III, are computed at a time, which is
!   controled by the parameter KSYM (=1 or 2). The actual
!   scattering matrix is then formed in the main routine
!   by addition or substraction of the results of KSYM=1
!   and 2 according to the polarizations.
!
!    Note that this routine works per substructure.  Thus,  all
!    structure parameters like NX etc. are those for one substructure.
!
!Input parameters
!
!  NSMR:    Integer,  the maximal number of non-identical elements
!           for the scattering matrix which is determined by the
!           paramters NZSR, NZOB and NHFILM of the code.  See the corresponding
!           paramter list in the main program for detail.
!  MLAYER:  Integer, the number of layers including the air.
!  ZBND:    Real ZBND(0:MLAYER), the z-coordinates of the layer
!           boundaries with the air-earth interface being always
!           0 (zbnd(0)=0).
!  CDH:     Complex CDH(0:MLAYER),  complex conductivities of
!           the layers in the lateral direction including the
!           air (layer 0).
!  CDV:     Complex CDV(0:MLAYER),  complex conductivities of
!           the layers in the vertical direction including the
!           air (layer 0).
!  SBX:     Real,  dimension of the super block in the x-direction.
!  SBY:     Real,  dimension of the super block in the y-direction.
!  SBZ:     Real,  dimension of the super block in the z-direction.
!  NXS:     Integer,  number of cells in the x-direction of the superblock.
!  NYS:     Integer,  number of cells in the y-direction of the superblock.
!  NZS:     Integer,  number of cells in the z-direction of the superblock.
!  ZSB:     Real,  z-ccordinate of the superblock.
!  NMAX:     Integer,  maximal number of unknowns in a substructure.
!            NMAX=3*NSUBCM.
!  N:       Integer,  real dimension of the scattering matrix.
!  NXMAX:   Integer,  maximal number of cells in the x-direction
!           in a block.
!  NYMAX:   Integer,  maximal number of cells in the y-direction
!           in a block.
!  NZMAX:   Integer,  maximal number of cells in the z-direction
!           in a block.
!  NX:      Integer NX(SUB_BLOCK), number of cells in the substructure
!           in the x-direction.
!  NY:      Integer NY(SUB_BLOCK), number of cells in the substructure
!           in the y-direction.
!  NZ:      Integer NZ(SUB_BLOCK), number of cells in the substructure
!           in the z-direction.
!  NCELL:   Integer NCELL(SUB_BLOCK),  number of cell in each block
!           of the substructure.
!  NSUBCM:  Integer,  maximal nuber of cells in a substructure.
!  SUB_BLOCK:  Integer,  number of blocks in the substructure.
!  X:       Real X(NXMAX,SUB_BLOCK), the x-coordinates of the cells
!           of the blocks in the substructure.
!  Y:       Real Y(NXMAX,SUB_BLOCK), the y-coordinates of the cells
!           of the blocks in the substructure.
!  Z:       Real Z(NXMAX,SUB_BLOCK), the z-coordinates of the cells
!           of the blocks in the substructure.
!  CDB:     COMPLEX CDB(NSUBCM,NBMAX),  working array for the
!           complex conductivities of the cells in a substructure.
!           Its values are all stored on the disk in unit 62.
!  GSB2:    Complex GSB2(NSMR/3,3),  the non-identical matrix entries
!
!
!Output parameters:
!
!  G:       Complex G(NMAX,N),  the scattering matrix or the
!           diagonal submatrix
!
!**** Called by:  MAIN_MATRICES
!
!**** Calls:      none
!
!
      IMPLICIT NONE
!
      REAL BX,BY,DX,DY,SBX,SBY,SBZ,SCX,SCY,SCZ,SX,SY,SZ,ZSB
      INTEGER I,II,IOB,IX,J,JJ,JY,K,KK,KKZ,KSYM,KZ,L,LL,LS1,LS2,LS3,          &
              LSYM,MLAYER,MM
      INTEGER MM2,MX,MY,N,N1,N2,SUB_BLOCK,NCB,NCB1,NMAX,NN,NN1,NN2,NOB,NSMR,  &
              NSUBCM,NXMAX,NXS,NYMAX,NYS,NZMAX,NZS
!
      COMPLEX GSB2(NSMR/3,3),G(NMAX,N),CDH(0:MLAYER),CDV(0:MLAYER),           &
              CDB(NSUBCM,SUB_BLOCK),DELTH,DELTV
      INTEGER NX(SUB_BLOCK),NY(SUB_BLOCK),NZ(SUB_BLOCK),NCELL(SUB_BLOCK)
      REAL  X(NXMAX,SUB_BLOCK),Y(NYMAX,SUB_BLOCK),Z(NZMAX,SUB_BLOCK),         &
            ZBND(0:MLAYER)
!
      SCX=SBX/NXS
      SCY=SBY/NYS
      SCZ=SBZ/NZS
!
      IF (KSYM==1) THEN
         LS1=1
         LS2=4
         LS3=3
      ELSE
         LS1=2
         LS2=3
         LS3=1
      ENDIF
!
      DO I=1,N
         DO J=1,N
            G(J,I)=(0.,0.)
         ENDDO
      ENDDO
!
      NCB=0
      DO L=1,SUB_BLOCK
         IF (L>1) NCB=NCB+NCELL(L-1)
!
         DO I=1,NX(L)
            DO J=1,NY(L)
               DO K=1,NZ(L)
!
                  NN=(I-1)*NY(L)*NZ(L)+(J-1)*NZ(L)+K
                  N1=NN+NCB
                  NN1=(N1-1)*3+1
!
! --- Locate the z-level of the field cell in the super block
!
                  KZ=INT((Z(K,L)+.5*SCZ-(ZSB-.5*SBZ))/SCZ+.2)
!
                  NCB1=0
                  DO LL=1,SUB_BLOCK
                     IF (LL>1) NCB1=NCB1+NCELL(LL-1)
                     DO II=1,NX(LL)
                        DO JJ=1,NY(LL)
                           DO KK=1,NZ(LL)
!
! --- Locate the z'-level of the source cell in the super block
!
                              KKZ=INT((Z(KK,LL)+.5*SCZ-(ZSB-.5*SBZ))  &
                                 /SCZ+.2)
!
                              N2=(II-1)*NY(LL)*NZ(LL)+(JJ-1)*NZ(LL)  &
                                 +KK+NCB1
                              NN2=(N2-1)*3+1
!
! --- Compute the contributions of each quarter
!
                              DO LSYM=LS1,LS2,LS3
!
                              IF (LSYM==1) THEN
                              BX=1.
                              BY=1.
                              SX=1.
                              SY=1.
                              SZ=1.
                              ENDIF
                              IF (LSYM==2) THEN
                              BX=-1.
                              BY=1.
                              SX=-1.
                              SY=1.
                              SZ=1.
                              ENDIF
                              IF (LSYM==3) THEN
                              BX=1.
                              BY=-1.
                              SX=-1.
                              SY=1.
                              SZ=-1.
                              ENDIF
                              IF (LSYM==4) THEN
                              BX=-1.
                              BY=-1.
                              SX=1.
                              SY=1.
                              SZ=-1.
                              ENDIF
!
! --- Identify the relative cell location in the super blocks
!
!   Note that reciprocity is considered here
!
                              IF (KZ<=KKZ) THEN
                              DX=(BX*X(II,LL)-X(I,L))/SCX
                              ELSE
                              DX=(X(I,L)-BX*X(II,LL))/SCX
                              ENDIF
                              IF (DX>=0) IX=INT(DX+.2)+1
                              IF (DX<0) IX=INT(DX-.2)-1
                              IF (IX==-1) IX=1
!
                              IF (KZ<=KKZ) THEN
                              DY=(BY*Y(JJ,LL)-Y(J,L))/SCY
                              ELSE
                              DY=(Y(J,L)-BY*Y(JJ,LL))/SCY
                              ENDIF
                              IF (DY>=0) JY=INT(DY+.2)+1
                              IF (DY<0) JY=INT(DY-.2)-1
                              IF (JY==-1) JY=1
!
! --- Determine the values of the scattering matrix using the
!   symmetry properties of the Green's functions
!
!      IF(KZ.LE.KKZ) THEN
!           MZ=KKZ
!         ELSE
!           MZ=KZ
!       ENDIF
!
                              IF (IX>0.AND.JY>0) THEN
!
                              MX=IX
                              MY=JY
!
! --- Note that the order of the array GSB2 determined in the
!   routine GSB is different from that of the scattering matrix
!   formed here in this routine.  Check the routine GSB for
!   more explanations.
!
!   Note that if KZ.LE.KKZ then KZ controls the field cell levels.
!   otherwise KZZ controls the field cell levels..
!
                              IF (KZ<=KKZ) THEN
                              MM=(KKZ-KZ)*NXS*NYS+(MY-1)*NXS+MX
                              MM2=(3*NXS*NYS*NZS+3*NXS*NYS*NZS-  &
                                 3*NXS*NYS*(KZ-2))*(KZ-1)/2+(MM-1)*3+1
                              ELSE
                              MM=(KZ-KKZ)*NXS*NYS+(MY-1)*NXS+MX
                              MM2=(3*NXS*NYS*NZS+3*NXS*NYS*NZS-  &
                                 3*NXS*NYS*(KKZ-2))*(KKZ-1)/2+(MM-1)*3+1
                              ENDIF
!
                              IF (KZ>KKZ) THEN
!
!--- Use the reciprocity theorem
!
                              G(NN1,NN2)=G(NN1,NN2)+SX*GSB2(MM2,1)
                              G(NN1+1,NN2)=G(NN1+1,NN2)+SX*GSB2(MM2,1+1)
                              G(NN1+2,NN2)=G(NN1+2,NN2)+SX*GSB2(MM2,1+2)
                              G(NN1,NN2+1)=G(NN1,NN2+1)+SY*GSB2(MM2+1,1)
                              G(NN1+1,NN2+1)=G(NN1+1,NN2+1)  &
                                 +SY*GSB2(MM2+1,1+1)
                              G(NN1+2,NN2+1)=G(NN1+2,NN2+1)  &
                                 +SY*GSB2(MM2+1,1+2)
                              G(NN1,NN2+2)=G(NN1,NN2+2)+SZ*GSB2(MM2+2,1)
                              G(NN1+1,NN2+2)=G(NN1+1,NN2+2)  &
                                 +SZ*GSB2(MM2+2,1+1)
                              G(NN1+2,NN2+2)=G(NN1+2,NN2+2)  &
                                 +SZ*GSB2(MM2+2,1+2)
                              ELSE
!
                              G(NN1,NN2)=G(NN1,NN2)+SX*GSB2(MM2,1)
                              G(NN1+1,NN2)=G(NN1+1,NN2)+SX*GSB2(MM2+1,1)
                              G(NN1+2,NN2)=G(NN1+2,NN2)+SX*GSB2(MM2+2,1)
                              G(NN1,NN2+1)=G(NN1,NN2+1)+SY*GSB2(MM2,1+1)
                              G(NN1+1,NN2+1)=G(NN1+1,NN2+1)  &
                                 +SY*GSB2(MM2+1,1+1)
                              G(NN1+2,NN2+1)=G(NN1+2,NN2+1)  &
                                 +SY*GSB2(MM2+2,1+1)
                              G(NN1,NN2+2)=G(NN1,NN2+2)+SZ*GSB2(MM2,1+2)
                              G(NN1+1,NN2+2)=G(NN1+1,NN2+2)  &
                                 +SZ*GSB2(MM2+1,1+2)
                              G(NN1+2,NN2+2)=G(NN1+2,NN2+2)  &
                                 +SZ*GSB2(MM2+2,1+2)
                              ENDIF
                              CYCLE
!
                              ENDIF
!
                              IF (IX<0.AND.JY>0) THEN
!
                              MX=-IX
                              MY=JY
!
!   Note that if KZ.LE.KKZ then KZ controls the field cell levels.
!   otherwise KZZ controls the field cell levels..
!
                              IF (KZ<=KKZ) THEN
                              MM=(KKZ-KZ)*NXS*NYS+(MY-1)*NXS+MX
                              MM2=(3*NXS*NYS*NZS+3*NXS*NYS*NZS-  &
                                 3*NXS*NYS*(KZ-2))*(KZ-1)/2+(MM-1)*3+1
                              ELSE
                              MM=(KZ-KKZ)*NXS*NYS+(MY-1)*NXS+MX
                              MM2=(3*NXS*NYS*NZS+3*NXS*NYS*NZS-  &
                                 3*NXS*NYS*(KKZ-2))*(KKZ-1)/2+(MM-1)*3+1
                              ENDIF
!
                              IF (KZ>KKZ) THEN
!
!--- Use the reciprocity theorem
!
                              G(NN1,NN2)=G(NN1,NN2)+SX*GSB2(MM2,1)
                              G(NN1+1,NN2)=G(NN1+1,NN2)-SX*GSB2(MM2,1+1)
                              G(NN1+2,NN2)=G(NN1+2,NN2)-SX*GSB2(MM2,1+2)
                              G(NN1,NN2+1)=G(NN1,NN2+1)-SY*GSB2(MM2+1,1)
                              G(NN1+1,NN2+1)=G(NN1+1,NN2+1)  &
                                 +SY*GSB2(MM2+1,1+1)
                              G(NN1+2,NN2+1)=G(NN1+2,NN2+1)  &
                                 +SY*GSB2(MM2+1,1+2)
                              G(NN1,NN2+2)=G(NN1,NN2+2)-SZ*GSB2(MM2+2,1)
                              G(NN1+1,NN2+2)=G(NN1+1,NN2+2)  &
                                 +SZ*GSB2(MM2+2,1+1)
                              G(NN1+2,NN2+2)=G(NN1+2,NN2+2)  &
                                 +SZ*GSB2(MM2+2,1+2)
                              ELSE
!
                              G(NN1,NN2)=G(NN1,NN2)+SX*GSB2(MM2,1)
                              G(NN1+1,NN2)=G(NN1+1,NN2)-SX*GSB2(MM2+1,1)
                              G(NN1+2,NN2)=G(NN1+2,NN2)-SX*GSB2(MM2+2,1)
                              G(NN1,NN2+1)=G(NN1,NN2+1)-SY*GSB2(MM2,1+1)
                              G(NN1+1,NN2+1)=G(NN1+1,NN2+1)  &
                                 +SY*GSB2(MM2+1,1+1)
                              G(NN1+2,NN2+1)=G(NN1+2,NN2+1)  &
                                 +SY*GSB2(MM2+2,1+1)
                              G(NN1,NN2+2)=G(NN1,NN2+2)-SZ*GSB2(MM2,1+2)
                              G(NN1+1,NN2+2)=G(NN1+1,NN2+2)  &
                                 +SZ*GSB2(MM2+1,1+2)
                              G(NN1+2,NN2+2)=G(NN1+2,NN2+2)  &
                                 +SZ*GSB2(MM2+2,1+2)
                              ENDIF
                              CYCLE
!
                              ENDIF
!
                              IF (IX<0.AND.JY<0) THEN
!
                              MX=-IX
                              MY=-JY
!
!   Note that if KZ.LE.KKZ then KZ controls the field cell levels.
!   otherwise KZZ controls the field cell levels..
!
                              IF (KZ<=KKZ) THEN
                              MM=(KKZ-KZ)*NXS*NYS+(MY-1)*NXS+MX
                              MM2=(3*NXS*NYS*NZS+3*NXS*NYS*NZS-  &
                                 3*NXS*NYS*(KZ-2))*(KZ-1)/2+(MM-1)*3+1
                              ELSE
                              MM=(KZ-KKZ)*NXS*NYS+(MY-1)*NXS+MX
                              MM2=(3*NXS*NYS*NZS+3*NXS*NYS*NZS-  &
                                 3*NXS*NYS*(KKZ-2))*(KKZ-1)/2+(MM-1)*3+1
                              ENDIF
!
                              IF (KZ>KKZ) THEN
!
!--- Use the reciprocity theorem
!
                              G(NN1,NN2)=G(NN1,NN2)+SX*GSB2(MM2,1)
                              G(NN1+1,NN2)=G(NN1+1,NN2)+SX*GSB2(MM2,1+1)
                              G(NN1+2,NN2)=G(NN1+2,NN2)-SX*GSB2(MM2,1+2)
                              G(NN1,NN2+1)=G(NN1,NN2+1)+SY*GSB2(MM2+1,1)
                              G(NN1+1,NN2+1)=G(NN1+1,NN2+1)  &
                                 +SY*GSB2(MM2+1,1+1)
                              G(NN1+2,NN2+1)=G(NN1+2,NN2+1)  &
                                 -SY*GSB2(MM2+1,1+2)
                              G(NN1,NN2+2)=G(NN1,NN2+2)-SZ*GSB2(MM2+2,1)
                              G(NN1+1,NN2+2)=G(NN1+1,NN2+2)  &
                                 -SZ*GSB2(MM2+2,1+1)
                              G(NN1+2,NN2+2)=G(NN1+2,NN2+2)  &
                                 +SZ*GSB2(MM2+2,1+2)
                              ELSE
!
                              G(NN1,NN2)=G(NN1,NN2)+SX*GSB2(MM2,1)
                              G(NN1+1,NN2)=G(NN1+1,NN2)+SX*GSB2(MM2+1,1)
                              G(NN1+2,NN2)=G(NN1+2,NN2)-SX*GSB2(MM2+2,1)
                              G(NN1,NN2+1)=G(NN1,NN2+1)+SY*GSB2(MM2,1+1)
                              G(NN1+1,NN2+1)=G(NN1+1,NN2+1)  &
                                 +SY*GSB2(MM2+1,1+1)
                              G(NN1+2,NN2+1)=G(NN1+2,NN2+1)  &
                                 -SY*GSB2(MM2+2,1+1)
                              G(NN1,NN2+2)=G(NN1,NN2+2)-SZ*GSB2(MM2,1+2)
                              G(NN1+1,NN2+2)=G(NN1+1,NN2+2)  &
                                 -SZ*GSB2(MM2+1,1+2)
                              G(NN1+2,NN2+2)=G(NN1+2,NN2+2)  &
                                 +SZ*GSB2(MM2+2,1+2)
                              ENDIF
                              CYCLE
!
                              ENDIF
!
                              IF (IX>0.AND.JY<0) THEN
!
                              MX=IX
                              MY=-JY
!
!   Note that if KZ.LE.KKZ then KZ controls the field cell levels.
!   otherwise KZZ controls the field cell levels..
!
                              IF (KZ<=KKZ) THEN
                              MM=(KKZ-KZ)*NXS*NYS+(MY-1)*NXS+MX
                              MM2=(3*NXS*NYS*NZS+3*NXS*NYS*NZS-  &
                                 3*NXS*NYS*(KZ-2))*(KZ-1)/2+(MM-1)*3+1
                              ELSE
                              MM=(KZ-KKZ)*NXS*NYS+(MY-1)*NXS+MX
                              MM2=(3*NXS*NYS*NZS+3*NXS*NYS*NZS-  &
                                 3*NXS*NYS*(KKZ-2))*(KKZ-1)/2+(MM-1)*3+1
                              ENDIF
!
                              IF (KZ>KKZ) THEN
!
!--- Use the reciprocity theorem
!
                              G(NN1,NN2)=G(NN1,NN2)+SX*GSB2(MM2,1)
                              G(NN1+1,NN2)=G(NN1+1,NN2)-SX*GSB2(MM2,1+1)
                              G(NN1+2,NN2)=G(NN1+2,NN2)+SX*GSB2(MM2,1+2)
                              G(NN1,NN2+1)=G(NN1,NN2+1)-SY*GSB2(MM2+1,1)
                              G(NN1+1,NN2+1)=G(NN1+1,NN2+1)  &
                                 +SY*GSB2(MM2+1,1+1)
                              G(NN1+2,NN2+1)=G(NN1+2,NN2+1)  &
                                 -SY*GSB2(MM2+1,1+2)
                              G(NN1,NN2+2)=G(NN1,NN2+2)+SZ*GSB2(MM2+2,1)
                              G(NN1+1,NN2+2)=G(NN1+1,NN2+2)  &
                                 -SZ*GSB2(MM2+2,1+1)
                              G(NN1+2,NN2+2)=G(NN1+2,NN2+2)  &
                                 +SZ*GSB2(MM2+2,1+2)
                              ELSE
!
                              G(NN1,NN2)=G(NN1,NN2)+SX*GSB2(MM2,1)
                              G(NN1+1,NN2)=G(NN1+1,NN2)-SX*GSB2(MM2+1,1)
                              G(NN1+2,NN2)=G(NN1+2,NN2)+SX*GSB2(MM2+2,1)
                              G(NN1,NN2+1)=G(NN1,NN2+1)-SY*GSB2(MM2,1+1)
                              G(NN1+1,NN2+1)=G(NN1+1,NN2+1)  &
                                 +SY*GSB2(MM2+1,1+1)
                              G(NN1+2,NN2+1)=G(NN1+2,NN2+1)  &
                                 -SY*GSB2(MM2+2,1+1)
                              G(NN1,NN2+2)=G(NN1,NN2+2)+SZ*GSB2(MM2,1+2)
                              G(NN1+1,NN2+2)=G(NN1+1,NN2+2)  &
                                 -SZ*GSB2(MM2+1,1+2)
                              G(NN1+2,NN2+2)=G(NN1+2,NN2+2)  &
                                 +SZ*GSB2(MM2+2,1+2)
                              ENDIF
!
                              ENDIF
!
                              ENDDO
!
                           ENDDO
                        ENDDO
                     ENDDO
                  ENDDO
               ENDDO
            ENDDO
         ENDDO
      ENDDO
!
! --- Add the term of cell conductivity to the self cells
!
!-- Only for ksym=1
!
      IF (KSYM/=1) THEN
         RETURN
      ENDIF
!
      NCB=0
      DO L=1,SUB_BLOCK
         IF (L>1) NCB=NCB+NCELL(L-1)
!
         DO K=1,NZ(L)
            DO IOB=MLAYER-1,0,-1
               IF (Z(K,L)>=ZBND(IOB)) THEN
                  NOB=IOB+1
                  GOTO 20
               ENDIF
            ENDDO
            NOB=0
!
   20       DO I=1,NX(L)
               DO J=1,NY(L)
!
                  NN=(I-1)*NY(L)*NZ(L)+(J-1)*NZ(L)+K
                  N1=NN+NCB
                  NN1=(N1-1)*3+1
!
                  DELTH=CDB(NN,L)-CDH(NOB)
                  DELTV=CDB(NN,L)-CDV(NOB)
!
                  G(NN1,NN1)=1./DELTH+G(NN1,NN1)
                  G(NN1+1,NN1+1)=1./DELTH+G(NN1+1,NN1+1)
                  G(NN1+2,NN1+2)=1./DELTV+G(NN1+2,NN1+2)
!
               ENDDO
            ENDDO
         ENDDO
      ENDDO
!
      RETURN
      END
!
!**** End of MTRX_SPSS
!
!
      SUBROUTINE MTRX_SPSM(SBX,SBY,SBZ,NXS,NYS,NZS,ZSB,NMAX,N,NXMAX,NYMAX,  &
                           NZMAX,NX1,NY1,NZ1,NCELL1,SUB_BLOCK1,X1,Y1,Z1,    &
                           NX2,NY2,NZ2,NCELL2,SUB_BLOCK2,X2,Y2,Z2,G,NSMR,GSB2)
!
!**** Form the mutual-coupling between substructures
!   using spatial symmetry reduction for
!   non-symmetric structures
!
!   The non-identical elements are pre-computed by the routine
!   GSB and are stored in the array gsb2
!
!
      IMPLICIT NONE
!
      REAL DX,DY,SBX,SBY,SBZ,SCX,SCY,SCZ,ZSB
      INTEGER I,II,IX,J,JJ,JY,K,KK,KKZ,KZ,L,LL,MM,MM1,MM2,MM3,MX,MY,N,N1
      INTEGER N12,N13,N2,N22,N23,SUB_BLOCK1,SUB_BLOCK2,NCB,NCB1,NMAX,NN,   &
              NN1,NN2,NSMR,NXMAX,NXS,NYMAX,NYS,NZMAX,NZS
!
      COMPLEX GSB2(NSMR/3,3),G(NMAX,N)
      INTEGER NX1(SUB_BLOCK1),NY1(SUB_BLOCK1),NZ1(SUB_BLOCK1),             &
              NCELL1(SUB_BLOCK1),NX2(SUB_BLOCK2),NY2(SUB_BLOCK2),          &
              NZ2(SUB_BLOCK2),NCELL2(SUB_BLOCK2)
      REAL  X1(NXMAX,SUB_BLOCK1),Y1(NYMAX,SUB_BLOCK1),Z1(NZMAX,SUB_BLOCK1), &
            X2(NXMAX,SUB_BLOCK2),Y2(NYMAX,SUB_BLOCK2),Z2(NZMAX,SUB_BLOCK2)
!
      SCX=SBX/NXS
      SCY=SBY/NYS
      SCZ=SBZ/NZS
!
      NCB=0
      DO L=1,SUB_BLOCK1
         IF (L>1) NCB=NCB+NCELL1(L-1)
! ---- Note that here k is the out-loop which may save some time in
!    array reference in identifying elements from GSB2
         DO K=1,NZ1(L)
!
! --- Locate the z-level of the field cell in the super block
!
            KZ=INT((Z1(K,L)+.5*SCZ-(ZSB-.5*SBZ))/SCZ+.2)
!
            DO I=1,NX1(L)
               DO J=1,NY1(L)
                  NN=((I-1)*NY1(L)+(J-1))*NZ1(L)+K
                  N1=NN+NCB
                  NN1=(N1-1)*3+1
                  N12=NN1+1
                  N13=NN1+2
!
                  NCB1=0
                  DO LL=1,SUB_BLOCK2
                     IF (LL>1) NCB1=NCB1+NCELL2(LL-1)
                     DO KK=1,NZ2(LL)
!
! --- Locate the z'-level of the source cell in the super block
!
                        KKZ=INT((Z2(KK,LL)+.5*SCZ-(ZSB-.5*SBZ))/SCZ+.2)
!
                        DO II=1,NX2(LL)
                           DO JJ=1,NY2(LL)
                              N2=((II-1)*NY2(LL)+(JJ-1))*NZ2(LL)+KK+NCB1
                              NN2=(N2-1)*3+1
                              N22=NN2+1
                              N23=NN2+2
!
! --- Identify the relative cell location in the super blocks
!
!   Note that reciprocity is considered here
!
                              IF (KZ<=KKZ) THEN
                              DX=(X2(II,LL)-X1(I,L))/SCX
                              ELSE
                              DX=(X1(I,L)-X2(II,LL))/SCX
                              ENDIF
                              IF (DX>=0) IX=INT(DX+.2)+1
                              IF (DX<0) IX=INT(DX-.2)-1
                              IF (IX==-1) IX=1
!
                              IF (KZ<=KKZ) THEN
                              DY=(Y2(JJ,LL)-Y1(J,L))/SCY
                              ELSE
                              DY=(Y1(J,L)-Y2(JJ,LL))/SCY
                              ENDIF
                              IF (DY>=0) JY=INT(DY+.2)+1
                              IF (DY<0) JY=INT(DY-.2)-1
                              IF (JY==-1) JY=1
!
! --- Determine the values of the scattering matrix using the
!   symmetry properties of the Green's functions
!
!      IF(KZ.LE.KKZ) THEN
!           MZ=KKZ
!         ELSE
!           MZ=KZ
!       ENDIF
!
                              IF (IX>0.AND.JY>0) THEN
!
                              MX=IX
                              MY=JY
!
! --- Note that the order of the array GSB2 determined in the
!   routine GSB is different from that of the scattering matrix
!   formed here in this routine.  Check the routine GSB for
!   more explanations.
!
!   Note that if KZ.LE.KKZ then KZ controls the field cell levels.
!   otherwise KZZ controls the field cell levels..
!
                              IF (KZ<=KKZ) THEN
                              MM=((KKZ-KZ)*NYS+(MY-1))*NXS+MX
                              MM1=(3*NXS*NYS*(2*NZS-(KZ-2)))*(KZ-1)  &
                                 /2+(MM-1)*3+1
                              ELSE
                              MM=((KZ-KKZ)*NYS+(MY-1))*NXS+MX
                              MM1=(3*NXS*NYS*(2*NZS-(KKZ-2)))*(KKZ-1)  &
                                 /2+(MM-1)*3+1
                              ENDIF
                              MM2=MM1+1
                              MM3=MM1+2
!
                              IF (KZ>KKZ) THEN
!
!--- Use the reciprocity theorem
!
                              G(NN1,NN2)=-GSB2(MM1,1)
                              G(N12,NN2)=-GSB2(MM1,2)
                              G(N13,NN2)=-GSB2(MM1,3)
                              G(NN1,N22)=-GSB2(MM2,1)
                              G(N12,N22)=-GSB2(MM2,2)
                              G(N13,N22)=-GSB2(MM2,3)
                              G(NN1,N23)=-GSB2(MM3,1)
                              G(N12,N23)=-GSB2(MM3,2)
                              G(N13,N23)=-GSB2(MM3,3)
                              ELSE
!
! ---  The sign of G is reversed as compared to those in
!      the routine MTRX_SPSS
!
                              G(NN1,NN2)=-GSB2(MM1,1)
                              G(N12,NN2)=-GSB2(MM2,1)
                              G(N13,NN2)=-GSB2(MM3,1)
                              G(NN1,N22)=-GSB2(MM1,2)
                              G(N12,N22)=-GSB2(MM2,2)
                              G(N13,N22)=-GSB2(MM3,2)
                              G(NN1,N23)=-GSB2(MM1,3)
                              G(N12,N23)=-GSB2(MM2,3)
                              G(N13,N23)=-GSB2(MM3,3)
                              ENDIF
                              CYCLE
!
                              ENDIF
!
                              IF (IX<0.AND.JY>0) THEN
!
                              MX=-IX
                              MY=JY
!
!   Note that if KZ.LE.KKZ then KZ controls the field cell levels.
!   otherwise KZZ controls the field cell levels..
!
                              IF (KZ<=KKZ) THEN
                              MM=((KKZ-KZ)*NYS+(MY-1))*NXS+MX
                              MM1=(3*NXS*NYS*(2*NZS-(KZ-2)))*(KZ-1)  &
                                 /2+(MM-1)*3+1
                              ELSE
                              MM=((KZ-KKZ)*NYS+(MY-1))*NXS+MX
                              MM1=(3*NXS*NYS*(2*NZS-(KKZ-2)))*(KKZ-1)  &
                                 /2+(MM-1)*3+1
                              ENDIF
                              MM2=MM1+1
                              MM3=MM1+2
!
                              IF (KZ>KKZ) THEN
!
!--- Use the reciprocity theorem
!
                              G(NN1,NN2)=-GSB2(MM1,1)
                              G(N12,NN2)=GSB2(MM1,2)
                              G(N13,NN2)=GSB2(MM1,3)
                              G(NN1,N22)=GSB2(MM2,1)
                              G(N12,N22)=-GSB2(MM2,2)
                              G(N13,N22)=-GSB2(MM2,3)
                              G(NN1,N23)=GSB2(MM3,1)
                              G(N12,N23)=-GSB2(MM3,2)
                              G(N13,N23)=-GSB2(MM3,3)
                              ELSE
!
                              G(NN1,NN2)=-GSB2(MM1,1)
                              G(N12,NN2)=GSB2(MM2,1)
                              G(N13,NN2)=GSB2(MM3,1)
                              G(NN1,N22)=GSB2(MM1,2)
                              G(N12,N22)=-GSB2(MM2,2)
                              G(N13,N22)=-GSB2(MM3,2)
                              G(NN1,N23)=GSB2(MM1,3)
                              G(N12,N23)=-GSB2(MM2,3)
                              G(N13,N23)=-GSB2(MM3,3)
                              ENDIF
                              CYCLE
!
                              ENDIF
!
                              IF (IX<0.AND.JY<0) THEN
!
                              MX=-IX
                              MY=-JY
!
!   Note that if KZ.LE.KKZ then KZ controls the field cell levels.
!   otherwise KZZ controls the field cell levels..
!
                              IF (KZ<=KKZ) THEN
                              MM=((KKZ-KZ)*NYS+(MY-1))*NXS+MX
                              MM1=(3*NXS*NYS*(2*NZS-(KZ-2)))*(KZ-1)  &
                                 /2+(MM-1)*3+1
                              ELSE
                              MM=((KZ-KKZ)*NYS+(MY-1))*NXS+MX
                              MM1=(3*NXS*NYS*(2*NZS-(KKZ-2)))*(KKZ-1)  &
                                 /2+(MM-1)*3+1
                              ENDIF
                              MM2=MM1+1
                              MM3=MM1+2
!
                              IF (KZ>KKZ) THEN
!
!--- Use the reciprocity theorem
!
                              G(NN1,NN2)=-GSB2(MM1,1)
                              G(N12,NN2)=-GSB2(MM1,2)
                              G(N13,NN2)=GSB2(MM1,3)
                              G(NN1,N22)=-GSB2(MM2,1)
                              G(N12,N22)=-GSB2(MM2,2)
                              G(N13,N22)=GSB2(MM2,3)
                              G(NN1,N23)=GSB2(MM3,1)
                              G(N12,N23)=GSB2(MM3,2)
                              G(N13,N23)=-GSB2(MM3,3)
                              ELSE
!
                              G(NN1,NN2)=-GSB2(MM1,1)
                              G(N12,NN2)=-GSB2(MM2,1)
                              G(N13,NN2)=GSB2(MM3,1)
                              G(NN1,N22)=-GSB2(MM1,2)
                              G(N12,N22)=-GSB2(MM2,2)
                              G(N13,N22)=GSB2(MM3,2)
                              G(NN1,N23)=GSB2(MM1,3)
                              G(N12,N23)=GSB2(MM2,3)
                              G(N13,N23)=-GSB2(MM3,3)
                              ENDIF
                              CYCLE
!
                              ENDIF
!
                              IF (IX>0.AND.JY<0) THEN
!
                              MX=IX
                              MY=-JY
!
!   Note that if KZ.LE.KKZ then KZ controls the field cell levels.
!   otherwise KZZ controls the field cell levels..
!
                              IF (KZ<=KKZ) THEN
                              MM=((KKZ-KZ)*NYS+(MY-1))*NXS+MX
                              MM1=(3*NXS*NYS*(2*NZS-(KZ-2)))*(KZ-1)  &
                                 /2+(MM-1)*3+1
                              ELSE
                              MM=((KZ-KKZ)*NYS+(MY-1))*NXS+MX
                              MM1=(3*NXS*NYS*(2*NZS-(KKZ-2)))*(KKZ-1)  &
                                 /2+(MM-1)*3+1
                              ENDIF
                              MM2=MM1+1
                              MM3=MM1+2
!
                              IF (KZ>KKZ) THEN
!
!--- Use the reciprocity theorem
!
                              G(NN1,NN2)=-GSB2(MM1,1)
                              G(N12,NN2)=GSB2(MM1,2)
                              G(N13,NN2)=-GSB2(MM1,3)
                              G(NN1,N22)=GSB2(MM2,1)
                              G(N12,N22)=-GSB2(MM2,2)
                              G(N13,N22)=GSB2(MM2,3)
                              G(NN1,N23)=-GSB2(MM3,1)
                              G(N12,N23)=GSB2(MM3,2)
                              G(N13,N23)=-GSB2(MM3,3)
                              ELSE
!
                              G(NN1,NN2)=-GSB2(MM1,1)
                              G(N12,NN2)=GSB2(MM2,1)
                              G(N13,NN2)=-GSB2(MM3,1)
                              G(NN1,N22)=GSB2(MM1,2)
                              G(N12,N22)=-GSB2(MM2,2)
                              G(N13,N22)=GSB2(MM3,2)
                              G(NN1,N23)=-GSB2(MM1,3)
                              G(N12,N23)=GSB2(MM2,3)
                              G(N13,N23)=-GSB2(MM3,3)
                              ENDIF
!
                              ENDIF
!
                           ENDDO
                        ENDDO
                     ENDDO
                  ENDDO
               ENDDO
            ENDDO
         ENDDO
      ENDDO
!
      RETURN
      END
!
!
      SUBROUTINE MTRX_SPSSM(SBX,SBY,SBZ,NXS,NYS,NZS,ZSB,NMAX,N,NXMAX,    &
                            NYMAX,NZMAX,NX1,NY1,NZ1,NCELL1,SUB_BLOCK1,   &
                            X1,Y1,Z1,NX2,NY2,NZ2,NCELL2,SUB_BLOCK2,X2,   &
                            Y2,Z2,KSYM,G,NSMR,GSB2)
!
!**** Form the mutual-coupling between substructures
!   using spatial symmetry reduction for structures with
!   two-plane symmetries under plane wave excitations
!
!   The non-identical elements are pre-computed by the routine
!   GSB and are stored in the array gsb2 in the common block /ghf
!
!
!      Note that only two quarters, either quarter I and IV
!      or quarter II and III, are computed at a time, which is
!      controled by the parameter KSYM (=1 or 2). The actual
!      scattering matrix is then formed in the main routine
!      by addition or substraction of the results of KSYM=1
!      and 2 according to the polarizations.
!
!      The parameter nztmax controls the size of the array g
!      which shares storage with the array grhf.  The value
!      of nztmax must be consistent throughout the program.
!      check the comments on the beginning of the main program
!      if the value of nztmax is to be changed.
!
!
      IMPLICIT NONE
!
      REAL BX,BY,DX,DY,SBX,SBY,SBZ,SCX,SCY,SCZ,SX,SY,SZ,ZSB
      INTEGER I,II,IX,J,JJ,JY,K,KK,KKZ,KSYM,KZ,L,LL,LS1,LS2,LS3,LSYM,MM,    &
              MM2,MX,MY,N,N1,N2,SUB_BLOCK1,SUB_BLOCK2,NCB,NCB1,NMAX,NN,NN1, &
              NN2,NSMR,NXMAX,NXS,NYMAX,NYS,NZMAX,NZS
!
      COMPLEX GSB2(NSMR/3,3),G(NMAX,N)
      INTEGER NX1(SUB_BLOCK1),NY1(SUB_BLOCK1),NZ1(SUB_BLOCK1),              &
              NCELL1(SUB_BLOCK1),NX2(SUB_BLOCK2),NY2(SUB_BLOCK2),           &
              NZ2(SUB_BLOCK2),NCELL2(SUB_BLOCK2)
      REAL  X1(NXMAX,SUB_BLOCK1),Y1(NYMAX,SUB_BLOCK1),Z1(NZMAX,SUB_BLOCK1), &
            X2(NXMAX,SUB_BLOCK2),Y2(NYMAX,SUB_BLOCK2),Z2(NZMAX,SUB_BLOCK2)
!
      SCX=SBX/NXS
      SCY=SBY/NYS
      SCZ=SBZ/NZS
!
      IF (KSYM==1) THEN
         LS1=1
         LS2=4
         LS3=3
      ELSE
         LS1=2
         LS2=3
         LS3=1
      ENDIF
!
      DO I=1,N
         DO J=1,NMAX
            G(J,I)=(0.,0.)
         ENDDO
      ENDDO
!
      NCB=0
      DO L=1,SUB_BLOCK1
         IF (L>1) NCB=NCB+NCELL1(L-1)
! ---- Note that here k is the out-loop which may save some time in
!    array reference in identifying elements from GSB2
         DO K=1,NZ1(L)
            DO I=1,NX1(L)
               DO J=1,NY1(L)
                  NN=(I-1)*NY1(L)*NZ1(L)+(J-1)*NZ1(L)+K
                  N1=NN+NCB
                  NN1=(N1-1)*3+1
!
! --- Locate the z-level of the field cell in the super block
!
                  KZ=INT((Z1(K,L)+.5*SCZ-(ZSB-.5*SBZ))/SCZ+.2)
!
                  NCB1=0
                  DO LL=1,SUB_BLOCK2
                     IF (LL>1) NCB1=NCB1+NCELL2(LL-1)
                     DO KK=1,NZ2(LL)
                        DO II=1,NX2(LL)
                           DO JJ=1,NY2(LL)
                              N2=(II-1)*NY2(LL)*NZ2(LL)+(JJ-1)*NZ2(LL)+KK+NCB1
                              NN2=(N2-1)*3+1
!
! --- Locate the z'-level of the source cell in the super block
!
                              KKZ=INT((Z2(KK,LL)+.5*SCZ-(ZSB-.5*SBZ))/SCZ+.2)
!
! --- Compute the contributions of each quarter
!
                              DO LSYM=LS1,LS2,LS3
!
                              IF (LSYM==1) THEN
                              BX=1.
                              BY=1.
                              SX=1.
                              SY=1.
                              SZ=1.
                              ENDIF
                              IF (LSYM==2) THEN
                              BX=-1.
                              BY=1.
                              SX=-1.
                              SY=1.
                              SZ=1.
                              ENDIF
                              IF (LSYM==3) THEN
                              BX=1.
                              BY=-1.
                              SX=-1.
                              SY=1.
                              SZ=-1.
                              ENDIF
                              IF (LSYM==4) THEN
                              BX=-1.
                              BY=-1.
                              SX=1.
                              SY=1.
                              SZ=-1.
                              ENDIF
!
! --- Identify the relative cell location in the super blocks
!
!   Note that reciprocity is considered here
!
                              IF (KZ<=KKZ) THEN
                              DX=(BX*X2(II,LL)-X1(I,L))/SCX
                              ELSE
                              DX=(X1(I,L)-BX*X2(II,LL))/SCX
                              ENDIF
                              IF (DX>=0) IX=INT(DX+.2)+1
                              IF (DX<0) IX=INT(DX-.2)-1
                              IF (IX==-1) IX=1
!
                              IF (KZ<=KKZ) THEN
                              DY=(BY*Y2(JJ,LL)-Y1(J,L))/SCY
                              ELSE
                              DY=(Y1(J,L)-BY*Y2(JJ,LL))/SCY
                              ENDIF
                              IF (DY>=0) JY=INT(DY+.2)+1
                              IF (DY<0) JY=INT(DY-.2)-1
                              IF (JY==-1) JY=1
!
! --- Determine the values of the scattering matrix using the
!   symmetry properties of the Green's functions
!
!      IF(KZ.LE.KKZ) THEN
!           MZ=KKZ
!         ELSE
!           MZ=KZ
!       ENDIF
!
                              IF (IX>0.AND.JY>0) THEN
!
                              MX=IX
                              MY=JY
!
! --- Note that the order of the array GSB2 determined in the
!   routine GSB is different from that of the scattering matrix
!   formed here in this routine.  Check the routine GSB for
!   more explanations.
!
!   Note that if KZ.LE.KKZ then KZ controls the field cell levels.
!   otherwise KZZ controls the field cell levels..
!
                              IF (KZ<=KKZ) THEN
                              MM=(KKZ-KZ)*NXS*NYS+(MY-1)*NXS+MX
                              MM2=(3*NXS*NYS*NZS+3*NXS*NYS*NZS-  &
                                 3*NXS*NYS*(KZ-2))*(KZ-1)/2+(MM-1)*3+1
                              ELSE
                              MM=(KZ-KKZ)*NXS*NYS+(MY-1)*NXS+MX
                              MM2=(3*NXS*NYS*NZS+3*NXS*NYS*NZS-  &
                                 3*NXS*NYS*(KKZ-2))*(KKZ-1)/2+(MM-1)*3+1
                              ENDIF
!
                              IF (KZ>KKZ) THEN
!
!--- Use the reciprocity theorem
!
                              G(NN1,NN2)=G(NN1,NN2)+SX*GSB2(MM2,1)
                              G(NN1+1,NN2)=G(NN1+1,NN2)+SX*GSB2(MM2,1+1)
                              G(NN1+2,NN2)=G(NN1+2,NN2)+SX*GSB2(MM2,1+2)
                              G(NN1,NN2+1)=G(NN1,NN2+1)+SY*GSB2(MM2+1,1)
                              G(NN1+1,NN2+1)=G(NN1+1,NN2+1)  &
                                 +SY*GSB2(MM2+1,1+1)
                              G(NN1+2,NN2+1)=G(NN1+2,NN2+1)  &
                                 +SY*GSB2(MM2+1,1+2)
                              G(NN1,NN2+2)=G(NN1,NN2+2)+SZ*GSB2(MM2+2,1)
                              G(NN1+1,NN2+2)=G(NN1+1,NN2+2)  &
                                 +SZ*GSB2(MM2+2,1+1)
                              G(NN1+2,NN2+2)=G(NN1+2,NN2+2)  &
                                 +SZ*GSB2(MM2+2,1+2)
                              ELSE
!
! ---  The sign of G will be reversed later on.  The following
!      lines are designed to identical as in the routine MTRX_SPSS
!
                              G(NN1,NN2)=G(NN1,NN2)+SX*GSB2(MM2,1)
                              G(NN1+1,NN2)=G(NN1+1,NN2)+SX*GSB2(MM2+1,1)
                              G(NN1+2,NN2)=G(NN1+2,NN2)+SX*GSB2(MM2+2,1)
                              G(NN1,NN2+1)=G(NN1,NN2+1)+SY*GSB2(MM2,1+1)
                              G(NN1+1,NN2+1)=G(NN1+1,NN2+1)  &
                                 +SY*GSB2(MM2+1,1+1)
                              G(NN1+2,NN2+1)=G(NN1+2,NN2+1)  &
                                 +SY*GSB2(MM2+2,1+1)
                              G(NN1,NN2+2)=G(NN1,NN2+2)+SZ*GSB2(MM2,1+2)
                              G(NN1+1,NN2+2)=G(NN1+1,NN2+2)  &
                                 +SZ*GSB2(MM2+1,1+2)
                              G(NN1+2,NN2+2)=G(NN1+2,NN2+2)  &
                                 +SZ*GSB2(MM2+2,1+2)
                              ENDIF
                              CYCLE
!
                              ENDIF
!
                              IF (IX<0.AND.JY>0) THEN
!
                              MX=-IX
                              MY=JY
!
!   Note that if KZ.LE.KKZ then KZ controls the field cell levels.
!   otherwise KZZ controls the field cell levels..
!
                              IF (KZ<=KKZ) THEN
                              MM=(KKZ-KZ)*NXS*NYS+(MY-1)*NXS+MX
                              MM2=(3*NXS*NYS*NZS+3*NXS*NYS*NZS-  &
                                 3*NXS*NYS*(KZ-2))*(KZ-1)/2+(MM-1)*3+1
                              ELSE
                              MM=(KZ-KKZ)*NXS*NYS+(MY-1)*NXS+MX
                              MM2=(3*NXS*NYS*NZS+3*NXS*NYS*NZS-  &
                                 3*NXS*NYS*(KKZ-2))*(KKZ-1)/2+(MM-1)*3+1
                              ENDIF
!
                              IF (KZ>KKZ) THEN
!
!--- Use the reciprocity theorem
!
                              G(NN1,NN2)=G(NN1,NN2)+SX*GSB2(MM2,1)
                              G(NN1+1,NN2)=G(NN1+1,NN2)-SX*GSB2(MM2,1+1)
                              G(NN1+2,NN2)=G(NN1+2,NN2)-SX*GSB2(MM2,1+2)
                              G(NN1,NN2+1)=G(NN1,NN2+1)-SY*GSB2(MM2+1,1)
                              G(NN1+1,NN2+1)=G(NN1+1,NN2+1)  &
                                 +SY*GSB2(MM2+1,1+1)
                              G(NN1+2,NN2+1)=G(NN1+2,NN2+1)  &
                                 +SY*GSB2(MM2+1,1+2)
                              G(NN1,NN2+2)=G(NN1,NN2+2)-SZ*GSB2(MM2+2,1)
                              G(NN1+1,NN2+2)=G(NN1+1,NN2+2)  &
                                 +SZ*GSB2(MM2+2,1+1)
                              G(NN1+2,NN2+2)=G(NN1+2,NN2+2)  &
                                 +SZ*GSB2(MM2+2,1+2)
                              ELSE
!
                              G(NN1,NN2)=G(NN1,NN2)+SX*GSB2(MM2,1)
                              G(NN1+1,NN2)=G(NN1+1,NN2)-SX*GSB2(MM2+1,1)
                              G(NN1+2,NN2)=G(NN1+2,NN2)-SX*GSB2(MM2+2,1)
                              G(NN1,NN2+1)=G(NN1,NN2+1)-SY*GSB2(MM2,1+1)
                              G(NN1+1,NN2+1)=G(NN1+1,NN2+1)  &
                                 +SY*GSB2(MM2+1,1+1)
                              G(NN1+2,NN2+1)=G(NN1+2,NN2+1)  &
                                 +SY*GSB2(MM2+2,1+1)
                              G(NN1,NN2+2)=G(NN1,NN2+2)-SZ*GSB2(MM2,1+2)
                              G(NN1+1,NN2+2)=G(NN1+1,NN2+2)  &
                                 +SZ*GSB2(MM2+1,1+2)
                              G(NN1+2,NN2+2)=G(NN1+2,NN2+2)  &
                                 +SZ*GSB2(MM2+2,1+2)
                              ENDIF
                              CYCLE
!
                              ENDIF
!
                              IF (IX<0.AND.JY<0) THEN
!
                              MX=-IX
                              MY=-JY
!
!   Note that if KZ.LE.KKZ then KZ controls the field cell levels.
!   otherwise KZZ controls the field cell levels..
!
                              IF (KZ<=KKZ) THEN
                              MM=(KKZ-KZ)*NXS*NYS+(MY-1)*NXS+MX
                              MM2=(3*NXS*NYS*NZS+3*NXS*NYS*NZS-  &
                                 3*NXS*NYS*(KZ-2))*(KZ-1)/2+(MM-1)*3+1
                              ELSE
                              MM=(KZ-KKZ)*NXS*NYS+(MY-1)*NXS+MX
                              MM2=(3*NXS*NYS*NZS+3*NXS*NYS*NZS-  &
                                 3*NXS*NYS*(KKZ-2))*(KKZ-1)/2+(MM-1)*3+1
                              ENDIF
!
                              IF (KZ>KKZ) THEN
!
!--- Use the reciprocity theorem
!
                              G(NN1,NN2)=G(NN1,NN2)+SX*GSB2(MM2,1)
                              G(NN1+1,NN2)=G(NN1+1,NN2)+SX*GSB2(MM2,1+1)
                              G(NN1+2,NN2)=G(NN1+2,NN2)-SX*GSB2(MM2,1+2)
                              G(NN1,NN2+1)=G(NN1,NN2+1)+SY*GSB2(MM2+1,1)
                              G(NN1+1,NN2+1)=G(NN1+1,NN2+1)  &
                                 +SY*GSB2(MM2+1,1+1)
                              G(NN1+2,NN2+1)=G(NN1+2,NN2+1)  &
                                 -SY*GSB2(MM2+1,1+2)
                              G(NN1,NN2+2)=G(NN1,NN2+2)-SZ*GSB2(MM2+2,1)
                              G(NN1+1,NN2+2)=G(NN1+1,NN2+2)  &
                                 -SZ*GSB2(MM2+2,1+1)
                              G(NN1+2,NN2+2)=G(NN1+2,NN2+2)  &
                                 +SZ*GSB2(MM2+2,1+2)
                              ELSE
!
                              G(NN1,NN2)=G(NN1,NN2)+SX*GSB2(MM2,1)
                              G(NN1+1,NN2)=G(NN1+1,NN2)+SX*GSB2(MM2+1,1)
                              G(NN1+2,NN2)=G(NN1+2,NN2)-SX*GSB2(MM2+2,1)
                              G(NN1,NN2+1)=G(NN1,NN2+1)+SY*GSB2(MM2,1+1)
                              G(NN1+1,NN2+1)=G(NN1+1,NN2+1)  &
                                 +SY*GSB2(MM2+1,1+1)
                              G(NN1+2,NN2+1)=G(NN1+2,NN2+1)  &
                                 -SY*GSB2(MM2+2,1+1)
                              G(NN1,NN2+2)=G(NN1,NN2+2)-SZ*GSB2(MM2,1+2)
                              G(NN1+1,NN2+2)=G(NN1+1,NN2+2)  &
                                 -SZ*GSB2(MM2+1,1+2)
                              G(NN1+2,NN2+2)=G(NN1+2,NN2+2)  &
                                 +SZ*GSB2(MM2+2,1+2)
                              ENDIF
                              CYCLE
!
                              ENDIF
!
                              IF (IX>0.AND.JY<0) THEN
!
                              MX=IX
                              MY=-JY
!
!   Note that if KZ.LE.KKZ then KZ controls the field cell levels.
!   otherwise KZZ controls the field cell levels..
!
                              IF (KZ<=KKZ) THEN
                              MM=(KKZ-KZ)*NXS*NYS+(MY-1)*NXS+MX
                              MM2=(3*NXS*NYS*NZS+3*NXS*NYS*NZS-  &
                                 3*NXS*NYS*(KZ-2))*(KZ-1)/2+(MM-1)*3+1
                              ELSE
                              MM=(KZ-KKZ)*NXS*NYS+(MY-1)*NXS+MX
                              MM2=(3*NXS*NYS*NZS+3*NXS*NYS*NZS-  &
                                 3*NXS*NYS*(KKZ-2))*(KKZ-1)/2+(MM-1)*3+1
                              ENDIF
!
                              IF (KZ>KKZ) THEN
!
!--- Use the reciprocity theorem
!
                              G(NN1,NN2)=G(NN1,NN2)+SX*GSB2(MM2,1)
                              G(NN1+1,NN2)=G(NN1+1,NN2)-SX*GSB2(MM2,1+1)
                              G(NN1+2,NN2)=G(NN1+2,NN2)+SX*GSB2(MM2,1+2)
                              G(NN1,NN2+1)=G(NN1,NN2+1)-SY*GSB2(MM2+1,1)
                              G(NN1+1,NN2+1)=G(NN1+1,NN2+1)  &
                                 +SY*GSB2(MM2+1,1+1)
                              G(NN1+2,NN2+1)=G(NN1+2,NN2+1)  &
                                 -SY*GSB2(MM2+1,1+2)
                              G(NN1,NN2+2)=G(NN1,NN2+2)+SZ*GSB2(MM2+2,1)
                              G(NN1+1,NN2+2)=G(NN1+1,NN2+2)  &
                                 -SZ*GSB2(MM2+2,1+1)
                              G(NN1+2,NN2+2)=G(NN1+2,NN2+2)  &
                                 +SZ*GSB2(MM2+2,1+2)
                              ELSE
!
                              G(NN1,NN2)=G(NN1,NN2)+SX*GSB2(MM2,1)
                              G(NN1+1,NN2)=G(NN1+1,NN2)-SX*GSB2(MM2+1,1)
                              G(NN1+2,NN2)=G(NN1+2,NN2)+SX*GSB2(MM2+2,1)
                              G(NN1,NN2+1)=G(NN1,NN2+1)-SY*GSB2(MM2,1+1)
                              G(NN1+1,NN2+1)=G(NN1+1,NN2+1)  &
                                 +SY*GSB2(MM2+1,1+1)
                              G(NN1+2,NN2+1)=G(NN1+2,NN2+1)  &
                                 -SY*GSB2(MM2+2,1+1)
                              G(NN1,NN2+2)=G(NN1,NN2+2)+SZ*GSB2(MM2,1+2)
                              G(NN1+1,NN2+2)=G(NN1+1,NN2+2)  &
                                 -SZ*GSB2(MM2+1,1+2)
                              G(NN1+2,NN2+2)=G(NN1+2,NN2+2)  &
                                 +SZ*GSB2(MM2+2,1+2)
                              ENDIF
!
                              ENDIF
!
                              ENDDO
!
                           ENDDO
                        ENDDO
                     ENDDO
                  ENDDO
               ENDDO
            ENDDO
         ENDDO
      ENDDO
!
! --- Reverse the sign of G
!
      DO I=1,N
         DO J=1,NMAX
            G(J,I)=-G(J,I)
         ENDDO
      ENDDO
!
      RETURN
      END
!
!
      SUBROUTINE MTRX_SPSSM2(SBX,SBY,SBZ,NXS,NYS,NZS,ZSB,              &
                             NMAX,NJ,N,NXMAX,NYMAX,NZMAX,              &
                             NX1,NY1,NZ1,NCELL1,SUB_BLOCK1,X1,Y1,Z1,   &
                             NX2,NY2,NZ2,NCELL2,SUB_BLOCK2,X2,Y2,Z2,   &
                             KPOL,G,NSMR,GSB2)
!
!**** Form the mutual-coupling between substructures
!   using spatial symmetry reduction for structures with
!   two-plane symmetries under plane wave excitations
!
!   The non-identical elements are pre-computed by the routine
!   GSB and are stored in the array gsb2 in the common block /ghf
!
!   This routine form the interaction matrices for both
!   E-polarization and B-polarization.   Unlike in the
!   routine smrdsm,  all four quarters are computed here.
!   The parameter kpol controls the polarizations.
!   Note that one more parameter, nj, is used here.
!
!      The parameter nztmax controls the size of the array g
!      which shares storage with the array grhf.  The value
!      of nztmax must be consistent throughout the program.
!      check the comments on the beginning of the main program
!      if the value of nztmax is to be changed.
!
!
      IMPLICIT NONE
!
      REAL BX,BY,DX,DY,SBX,SBY,SBZ,SCX,SCY,SCZ,SX,SY,SZ,ZSB
      INTEGER I,II,IX,J,JJ,JY,K,KK,KKZ,KPOL,KZ,L,LL,LSYM,MM,MM1,MM2,MM3,   &
              MX,MY,N,N1,N12,N13,N2,N22,N23,SUB_BLOCK1,SUB_BLOCK2,NCB,     &
              NCB1,NJ,NMAX,NN,NN1,NN2,NSMR,NXMAX,NXS,NYMAX,NYS,NZMAX,NZS
!
      COMPLEX GSB2(NSMR/3,3)
      COMPLEX G(NMAX,N)
      INTEGER NX1(SUB_BLOCK1),NY1(SUB_BLOCK1),NZ1(SUB_BLOCK1),             &
              NCELL1(SUB_BLOCK1),NX2(SUB_BLOCK2),NY2(SUB_BLOCK2),          &
              NZ2(SUB_BLOCK2),NCELL2(SUB_BLOCK2)
      REAL  X1(NXMAX,SUB_BLOCK1),Y1(NYMAX,SUB_BLOCK1),Z1(NZMAX,SUB_BLOCK1), &
            X2(NXMAX,SUB_BLOCK2),Y2(NYMAX,SUB_BLOCK2),Z2(NZMAX,SUB_BLOCK2)
!
      SCX=SBX/NXS
      SCY=SBY/NYS
      SCZ=SBZ/NZS
!
      DO I=1,N
         DO J=1,NJ
            G(J,I)=(0.,0.)
         ENDDO
      ENDDO
!
      NCB=0
      DO L=1,SUB_BLOCK1
         IF (L>1) NCB=NCB+NCELL1(L-1)
! ---- Note that here k is the out-loop which may save some time in
!    array reference in identifying elements from GSB2
         DO K=1,NZ1(L)
!
! --- Locate the z-level of the field cell in the super block
!
            KZ=INT((Z1(K,L)+.5*SCZ-(ZSB-.5*SBZ))/SCZ+.2)
!
            DO I=1,NX1(L)
               DO J=1,NY1(L)
                  NN=((I-1)*NY1(L)+(J-1))*NZ1(L)+K
                  N1=NN+NCB
                  NN1=(N1-1)*3+1
                  N12=NN1+1
                  N13=NN1+2
!
                  NCB1=0
                  DO LL=1,SUB_BLOCK2
                     IF (LL>1) NCB1=NCB1+NCELL2(LL-1)
                     DO KK=1,NZ2(LL)
!
! --- Locate the z'-level of the source cell in the super block
!
                        KKZ=INT((Z2(KK,LL)+.5*SCZ-(ZSB-.5*SBZ))/SCZ+.2)
!
                        DO II=1,NX2(LL)
                           DO JJ=1,NY2(LL)
                              N2=((II-1)*NY2(LL)+(JJ-1))*NZ2(LL)+KK+NCB1
                              NN2=(N2-1)*3+1
                              N22=NN2+1
                              N23=NN2+2
!
! --- Compute the contributions of each quarter
!
                              DO LSYM=1,4
!
                              IF (LSYM==1) THEN
                                 BX=1.
                                 BY=1.
                                 SX=1.
                                 SY=1.
                                 SZ=1.
                              ENDIF
                              IF (LSYM==2) THEN
                                 BX=-1.
                                 BY=1.
                              IF (KPOL==1) THEN
                                 SX=-1.
                                 SY=1.
                                 SZ=1.
                              ELSE
                                 SX=1.
                                 SY=-1.
                                 SZ=-1.
                              ENDIF
                              ENDIF
                              IF (LSYM==3) THEN
                                 BX=1.
                                 BY=-1.
                              IF (KPOL==1) THEN
                                 SX=-1.
                                 SY=1.
                                 SZ=-1.
                              ELSE
                                 SX=1.
                                 SY=-1.
                                 SZ=1.
                              ENDIF
                              ENDIF
                              IF (LSYM==4) THEN
                                 BX=-1.
                                 BY=-1.
                                 SX=1.
                                 SY=1.
                                 SZ=-1.
                              ENDIF
!
! --- Identify the relative cell location in the super blocks
!
!   Note that reciprocity is considered here
!
                              IF (KZ<=KKZ) THEN
                                 DX=(BX*X2(II,LL)-X1(I,L))/SCX
                              ELSE
                                 DX=(X1(I,L)-BX*X2(II,LL))/SCX
                              ENDIF
                              IF (DX>=0) IX=INT(DX+.2)+1
                              IF (DX<0) IX=INT(DX-.2)-1
                              IF (IX==-1) IX=1
!
                              IF (KZ<=KKZ) THEN
                                 DY=(BY*Y2(JJ,LL)-Y1(J,L))/SCY
                              ELSE
                                 DY=(Y1(J,L)-BY*Y2(JJ,LL))/SCY
                              ENDIF
                              IF (DY>=0) JY=INT(DY+.2)+1
                              IF (DY<0) JY=INT(DY-.2)-1
                              IF (JY==-1) JY=1
!
! --- Determine the values of the scattering matrix using the
!   symmetry properties of the Green's functions
!
!      IF(KZ.LE.KKZ) THEN
!           MZ=KKZ
!         ELSE
!           MZ=KZ
!       ENDIF
!
                              IF (IX>0.AND.JY>0) THEN
!
                              MX=IX
                              MY=JY
!
! --- Note that the order of the array GSB2 determined in the
!   routine GSB is different from that of the scattering matrix
!   formed here in this routine.  Check the routine GSB for
!   more explanations.
!
!   Note that if KZ.LE.KKZ then KZ controls the field cell levels.
!   otherwise KZZ controls the field cell levels..
!
                              IF (KZ<=KKZ) THEN
                              MM=((KKZ-KZ)*NYS+(MY-1))*NXS+MX
                              MM1=(3*NXS*NYS*(2*NZS-(KZ-2)))*(KZ-1)  &
                                 /2+(MM-1)*3+1
                              ELSE
                              MM=((KZ-KKZ)*NYS+(MY-1))*NXS+MX
                              MM1=(3*NXS*NYS*(2*NZS-(KKZ-2)))*(KKZ-1)  &
                                 /2+(MM-1)*3+1
                              ENDIF
                              MM2=MM1+1
                              MM3=MM1+2
!
                              IF (KZ>KKZ) THEN
!
!--- Use the reciprocity theorem
!
                              IF (SX>0.) THEN
                              G(NN1,NN2)=G(NN1,NN2)-GSB2(MM1,1)
                              G(N12,NN2)=G(N12,NN2)-GSB2(MM1,2)
                              G(N13,NN2)=G(N13,NN2)-GSB2(MM1,3)
                              ELSE
                              G(NN1,NN2)=G(NN1,NN2)+GSB2(MM1,1)
                              G(N12,NN2)=G(N12,NN2)+GSB2(MM1,2)
                              G(N13,NN2)=G(N13,NN2)+GSB2(MM1,3)
                              ENDIF
                              IF (SY>0.) THEN
                              G(NN1,N22)=G(NN1,N22)-GSB2(MM2,1)
                              G(N12,N22)=G(N12,N22)-GSB2(MM2,2)
                              G(N13,N22)=G(N13,N22)-GSB2(MM2,3)
                              ELSE
                              G(NN1,N22)=G(NN1,N22)+GSB2(MM2,1)
                              G(N12,N22)=G(N12,N22)+GSB2(MM2,2)
                              G(N13,N22)=G(N13,N22)+GSB2(MM2,3)
                              ENDIF
                              IF (SZ>0.) THEN
                              G(NN1,N23)=G(NN1,N23)-GSB2(MM3,1)
                              G(N12,N23)=G(N12,N23)-GSB2(MM3,2)
                              G(N13,N23)=G(N13,N23)-GSB2(MM3,3)
                              ELSE
                              G(NN1,N23)=G(NN1,N23)+GSB2(MM3,1)
                              G(N12,N23)=G(N12,N23)+GSB2(MM3,2)
                              G(N13,N23)=G(N13,N23)+GSB2(MM3,3)
                              ENDIF
                              ELSE
!
! ---  The sign of G is reversed as compared to those in
!      the routine MTRX_SPSS
!
                              IF (SX>0.) THEN
                              G(NN1,NN2)=G(NN1,NN2)-GSB2(MM1,1)
                              G(N12,NN2)=G(N12,NN2)-GSB2(MM2,1)
                              G(N13,NN2)=G(N13,NN2)-GSB2(MM3,1)
                              ELSE
                              G(NN1,NN2)=G(NN1,NN2)+GSB2(MM1,1)
                              G(N12,NN2)=G(N12,NN2)+GSB2(MM2,1)
                              G(N13,NN2)=G(N13,NN2)+GSB2(MM3,1)
                              ENDIF
                              IF (SY>0.) THEN
                              G(NN1,N22)=G(NN1,N22)-GSB2(MM1,2)
                              G(N12,N22)=G(N12,N22)-GSB2(MM2,2)
                              G(N13,N22)=G(N13,N22)-GSB2(MM3,2)
                              ELSE
                              G(NN1,N22)=G(NN1,N22)+GSB2(MM1,2)
                              G(N12,N22)=G(N12,N22)+GSB2(MM2,2)
                              G(N13,N22)=G(N13,N22)+GSB2(MM3,2)
                              ENDIF
                              IF (SZ>0.) THEN
                              G(NN1,N23)=G(NN1,N23)-GSB2(MM1,3)
                              G(N12,N23)=G(N12,N23)-GSB2(MM2,3)
                              G(N13,N23)=G(N13,N23)-GSB2(MM3,3)
                              ELSE
                              G(NN1,N23)=G(NN1,N23)+GSB2(MM1,3)
                              G(N12,N23)=G(N12,N23)+GSB2(MM2,3)
                              G(N13,N23)=G(N13,N23)+GSB2(MM3,3)
                              ENDIF
                              ENDIF
                              CYCLE
!
                              ENDIF
!
                              IF (IX<0.AND.JY>0) THEN
!
                              MX=-IX
                              MY=JY
!
!   Note that if KZ.LE.KKZ then KZ controls the field cell levels.
!   otherwise KZZ controls the field cell levels..
!
                              IF (KZ<=KKZ) THEN
                              MM=((KKZ-KZ)*NYS+(MY-1))*NXS+MX
                              MM1=(3*NXS*NYS*(2*NZS-(KZ-2)))*(KZ-1)  &
                                 /2+(MM-1)*3+1
                              ELSE
                              MM=((KZ-KKZ)*NYS+(MY-1))*NXS+MX
                              MM1=(3*NXS*NYS*(2*NZS-(KKZ-2)))*(KKZ-1)  &
                                 /2+(MM-1)*3+1
                              ENDIF
                              MM2=MM1+1
                              MM3=MM1+2
!
                              IF (KZ>KKZ) THEN
!
!--- Use the reciprocity theorem
!
                              IF (SX>0.) THEN
                              G(NN1,NN2)=G(NN1,NN2)-GSB2(MM1,1)
                              G(N12,NN2)=G(N12,NN2)+GSB2(MM1,2)
                              G(N13,NN2)=G(N13,NN2)+GSB2(MM1,3)
                              ELSE
                              G(NN1,NN2)=G(NN1,NN2)+GSB2(MM1,1)
                              G(N12,NN2)=G(N12,NN2)-GSB2(MM1,2)
                              G(N13,NN2)=G(N13,NN2)-GSB2(MM1,3)
                              ENDIF
                              IF (SY>0.) THEN
                              G(NN1,N22)=G(NN1,N22)+GSB2(MM2,1)
                              G(N12,N22)=G(N12,N22)-GSB2(MM2,2)
                              G(N13,N22)=G(N13,N22)-GSB2(MM2,3)
                              ELSE
                              G(NN1,N22)=G(NN1,N22)-GSB2(MM2,1)
                              G(N12,N22)=G(N12,N22)+GSB2(MM2,2)
                              G(N13,N22)=G(N13,N22)+GSB2(MM2,3)
                              ENDIF
                              IF (SZ>0.) THEN
                              G(NN1,N23)=G(NN1,N23)+GSB2(MM3,1)
                              G(N12,N23)=G(N12,N23)-GSB2(MM3,2)
                              G(N13,N23)=G(N13,N23)-GSB2(MM3,3)
                              ELSE
                              G(NN1,N23)=G(NN1,N23)-GSB2(MM3,1)
                              G(N12,N23)=G(N12,N23)+GSB2(MM3,2)
                              G(N13,N23)=G(N13,N23)+GSB2(MM3,3)
                              ENDIF
                              ELSE
!
                              IF (SX>0.) THEN
                              G(NN1,NN2)=G(NN1,NN2)-GSB2(MM1,1)
                              G(N12,NN2)=G(N12,NN2)+GSB2(MM2,1)
                              G(N13,NN2)=G(N13,NN2)+GSB2(MM3,1)
                              ELSE
                              G(NN1,NN2)=G(NN1,NN2)+GSB2(MM1,1)
                              G(N12,NN2)=G(N12,NN2)-GSB2(MM2,1)
                              G(N13,NN2)=G(N13,NN2)-GSB2(MM3,1)
                              ENDIF
                              IF (SY>0.) THEN
                              G(NN1,N22)=G(NN1,N22)+GSB2(MM1,2)
                              G(N12,N22)=G(N12,N22)-GSB2(MM2,2)
                              G(N13,N22)=G(N13,N22)-GSB2(MM3,2)
                              ELSE
                              G(NN1,N22)=G(NN1,N22)-GSB2(MM1,2)
                              G(N12,N22)=G(N12,N22)+GSB2(MM2,2)
                              G(N13,N22)=G(N13,N22)+GSB2(MM3,2)
                              ENDIF
                              IF (SZ>0.) THEN
                              G(NN1,N23)=G(NN1,N23)+GSB2(MM1,3)
                              G(N12,N23)=G(N12,N23)-GSB2(MM2,3)
                              G(N13,N23)=G(N13,N23)-GSB2(MM3,3)
                              ELSE
                              G(NN1,N23)=G(NN1,N23)-GSB2(MM1,3)
                              G(N12,N23)=G(N12,N23)+GSB2(MM2,3)
                              G(N13,N23)=G(N13,N23)+GSB2(MM3,3)
                              ENDIF
                              ENDIF
                              CYCLE
!
                              ENDIF
!
                              IF (IX<0.AND.JY<0) THEN
!
                              MX=-IX
                              MY=-JY
!
!   Note that if KZ.LE.KKZ then KZ controls the field cell levels.
!   otherwise KZZ controls the field cell levels..
!
                              IF (KZ<=KKZ) THEN
                              MM=((KKZ-KZ)*NYS+(MY-1))*NXS+MX
                              MM1=(3*NXS*NYS*(2*NZS-(KZ-2)))*(KZ-1)  &
                                 /2+(MM-1)*3+1
                              ELSE
                              MM=((KZ-KKZ)*NYS+(MY-1))*NXS+MX
                              MM1=(3*NXS*NYS*(2*NZS-(KKZ-2)))*(KKZ-1)  &
                                 /2+(MM-1)*3+1
                              ENDIF
                              MM2=MM1+1
                              MM3=MM1+2
!
                              IF (KZ>KKZ) THEN
!
!--- Use the reciprocity theorem
!
                              IF (SX>0.) THEN
                              G(NN1,NN2)=G(NN1,NN2)-GSB2(MM1,1)
                              G(N12,NN2)=G(N12,NN2)-GSB2(MM1,2)
                              G(N13,NN2)=G(N13,NN2)+GSB2(MM1,3)
                              ELSE
                              G(NN1,NN2)=G(NN1,NN2)+GSB2(MM1,1)
                              G(N12,NN2)=G(N12,NN2)+GSB2(MM1,2)
                              G(N13,NN2)=G(N13,NN2)-GSB2(MM1,3)
                              ENDIF
                              IF (SY>0.) THEN
                              G(NN1,N22)=G(NN1,N22)-GSB2(MM2,1)
                              G(N12,N22)=G(N12,N22)-GSB2(MM2,2)
                              G(N13,N22)=G(N13,N22)+GSB2(MM2,3)
                              ELSE
                              G(NN1,N22)=G(NN1,N22)+GSB2(MM2,1)
                              G(N12,N22)=G(N12,N22)+GSB2(MM2,2)
                              G(N13,N22)=G(N13,N22)-GSB2(MM2,3)
                              ENDIF
                              IF (SZ>0.) THEN
                              G(NN1,N23)=G(NN1,N23)+GSB2(MM3,1)
                              G(N12,N23)=G(N12,N23)+GSB2(MM3,2)
                              G(N13,N23)=G(N13,N23)-GSB2(MM3,3)
                              ELSE
                              G(NN1,N23)=G(NN1,N23)+GSB2(MM3,1)
                              G(N12,N23)=G(N12,N23)+GSB2(MM3,2)
                              G(N13,N23)=G(N13,N23)-GSB2(MM3,3)
                              ENDIF
                              ELSE
!
                              IF (SX>0.) THEN
                              G(NN1,NN2)=G(NN1,NN2)-GSB2(MM1,1)
                              G(N12,NN2)=G(N12,NN2)-GSB2(MM2,1)
                              G(N13,NN2)=G(N13,NN2)+GSB2(MM3,1)
                              ELSE
                              G(NN1,NN2)=G(NN1,NN2)+GSB2(MM1,1)
                              G(N12,NN2)=G(N12,NN2)+GSB2(MM2,1)
                              G(N13,NN2)=G(N13,NN2)-GSB2(MM3,1)
                              ENDIF
                              IF (SY>0.) THEN
                              G(NN1,N22)=G(NN1,N22)-GSB2(MM1,2)
                              G(N12,N22)=G(N12,N22)-GSB2(MM2,2)
                              G(N13,N22)=G(N13,N22)+GSB2(MM3,2)
                              ELSE
                              G(NN1,N22)=G(NN1,N22)+GSB2(MM1,2)
                              G(N12,N22)=G(N12,N22)+GSB2(MM2,2)
                              G(N13,N22)=G(N13,N22)-GSB2(MM3,2)
                              ENDIF
                              IF (SZ>0.) THEN
                              G(NN1,N23)=G(NN1,N23)+GSB2(MM1,3)
                              G(N12,N23)=G(N12,N23)+GSB2(MM2,3)
                              G(N13,N23)=G(N13,N23)-GSB2(MM3,3)
                              ELSE
                              G(NN1,N23)=G(NN1,N23)-GSB2(MM1,3)
                              G(N12,N23)=G(N12,N23)-GSB2(MM2,3)
                              G(N13,N23)=G(N13,N23)+GSB2(MM3,3)
                              ENDIF
                              ENDIF
                              CYCLE
!
                              ENDIF
!
                              IF (IX>0.AND.JY<0) THEN
!
                              MX=IX
                              MY=-JY
!
!   Note that if KZ.LE.KKZ then KZ controls the field cell levels.
!   otherwise KZZ controls the field cell levels..
!
                              IF (KZ<=KKZ) THEN
                              MM=((KKZ-KZ)*NYS+(MY-1))*NXS+MX
                              MM1=(3*NXS*NYS*(2*NZS-(KZ-2)))*(KZ-1)  &
                                 /2+(MM-1)*3+1
                              ELSE
                              MM=((KZ-KKZ)*NYS+(MY-1))*NXS+MX
                              MM1=(3*NXS*NYS*(2*NZS-(KKZ-2)))*(KKZ-1)  &
                                 /2+(MM-1)*3+1
                              ENDIF
                              MM2=MM1+1
                              MM3=MM1+2
!
                              IF (KZ>KKZ) THEN
!
!--- Use the reciprocity theorem
!
                              IF (SX>0.) THEN
                              G(NN1,NN2)=G(NN1,NN2)-GSB2(MM1,1)
                              G(N12,NN2)=G(N12,NN2)+GSB2(MM1,2)
                              G(N13,NN2)=G(N13,NN2)-GSB2(MM1,3)
                              ELSE
                              G(NN1,NN2)=G(NN1,NN2)+GSB2(MM1,1)
                              G(N12,NN2)=G(N12,NN2)-GSB2(MM1,2)
                              G(N13,NN2)=G(N13,NN2)+GSB2(MM1,3)
                              ENDIF
                              IF (SY>0.) THEN
                              G(NN1,N22)=G(NN1,N22)+GSB2(MM2,1)
                              G(N12,N22)=G(N12,N22)-GSB2(MM2,2)
                              G(N13,N22)=G(N13,N22)+GSB2(MM2,3)
                              ELSE
                              G(NN1,N22)=G(NN1,N22)-GSB2(MM2,1)
                              G(N12,N22)=G(N12,N22)+GSB2(MM2,2)
                              G(N13,N22)=G(N13,N22)-GSB2(MM2,3)
                              ENDIF
                              IF (SZ>0.) THEN
                              G(NN1,N23)=G(NN1,N23)-GSB2(MM3,1)
                              G(N12,N23)=G(N12,N23)+GSB2(MM3,2)
                              G(N13,N23)=G(N13,N23)-GSB2(MM3,3)
                              ELSE
                              G(NN1,N23)=G(NN1,N23)+GSB2(MM3,1)
                              G(N12,N23)=G(N12,N23)-GSB2(MM3,2)
                              G(N13,N23)=G(N13,N23)+GSB2(MM3,3)
                              ENDIF
                              ELSE
!
                              IF (SX>0.) THEN
                              G(NN1,NN2)=G(NN1,NN2)-GSB2(MM1,1)
                              G(N12,NN2)=G(N12,NN2)+GSB2(MM2,1)
                              G(N13,NN2)=G(N13,NN2)-GSB2(MM3,1)
                              ELSE
                              G(NN1,NN2)=G(NN1,NN2)+GSB2(MM1,1)
                              G(N12,NN2)=G(N12,NN2)-GSB2(MM2,1)
                              G(N13,NN2)=G(N13,NN2)+GSB2(MM3,1)
                              ENDIF
                              IF (SY>0.) THEN
                              G(NN1,N22)=G(NN1,N22)+GSB2(MM1,2)
                              G(N12,N22)=G(N12,N22)-GSB2(MM2,2)
                              G(N13,N22)=G(N13,N22)+GSB2(MM3,2)
                              ELSE
                              G(NN1,N22)=G(NN1,N22)-GSB2(MM1,2)
                              G(N12,N22)=G(N12,N22)+GSB2(MM2,2)
                              G(N13,N22)=G(N13,N22)-GSB2(MM3,2)
                              ENDIF
                              IF (SZ>0.) THEN
                              G(NN1,N23)=G(NN1,N23)-GSB2(MM1,3)
                              G(N12,N23)=G(N12,N23)+GSB2(MM2,3)
                              G(N13,N23)=G(N13,N23)-GSB2(MM3,3)
                              ELSE
                              G(NN1,N23)=G(NN1,N23)+GSB2(MM1,3)
                              G(N12,N23)=G(N12,N23)-GSB2(MM2,3)
                              G(N13,N23)=G(N13,N23)+GSB2(MM3,3)
                              ENDIF
                              ENDIF
!
                              ENDIF
!
                              ENDDO
!
                           ENDDO
                        ENDDO
                     ENDDO
                  ENDDO
               ENDDO
            ENDDO
         ENDDO
      ENDDO
!
      RETURN
      END
!
!
      SUBROUTINE MTRX_SPS1B(NMAX,N,NXMAX,NYMAX,NZMAX,NX,NY,NZ,           &
                            NSUBCM,SUB_BLOCK,X,Y,Z,CLX,CLY,CLZ,CDB,G,    &
                            FRQ,MLAYER,ZBND,CDH,CDV,HVK,NZOB,ZOBG,NZSR,  &
                            ZSRG,RHOMIN,DMIN,NHFILM,RRG,NRG,GRHF,        &
                            RRG3,NRG3,GRHF3,GRHO0,GRHO03,CLMN,KCLMN,     &
                            BLMIN,KACC,KUTCRP)
!
!**** Form the scattering matrix of a single block structure using
!   spatial symmetry reductions
!
!   This routine is for one single block only.  This may be
!   useful if the whole structure is not divided into equal-
!   size cells but there is a substructure or more that
!   consists of only one block.  Note that the design of this
!   routine is completely different from the design of other
!   routines like MTRX_SPS and MTRX_SPSS.  Here no extra memory is
!   required.
!
!   The parameter kself controls if the computation for the
!   integration of the primary part of the Green's function
!   for self-cells should be repeated. As the dimensions of
!   the cells within a block is the same, this integration
!   need to be done only once (kself=1) for cells located in
!   the same layer.   The results are stored in a common
!   block in geprm for use for all other cells in this block
!   (kself=0)
!
!Input parameters:
!
!
!
!  All other parameters FRQ, MLAYER, ZBND,  CDH, HVK, NZOB, ZOBG,
!  NZSR, ZSRG, RHOMIN, DMIN, NHFILM, RRG, NRG, GRHF,
!  GRHF3, GRHO0, GRHO03, CLMN, KCLMN, BLMIN, KACC, and KUTCRP are to
!  be passed into routine THR_D_GREEN.  Check THR_D_GREEN for their
!  descriptions.
!
!
!Output parameters:
!
!  G:
!
!
!**** Called by: MAIN_MATRICES
!
!**** Calls:     THR_D_GREEN
!
!
      IMPLICIT NONE
!
      REAL BLMIN,CLMN,CLX1,CLY1,CLZ1,DMIN,DX,DY,FRQ,RHOMIN
      INTEGER I,II,IOB,ISR,IX,J,JJ,JY,K,KACC,KCLMN,KEYG,KK,KSELF,KUTCRP,   &
              L,LL,MLAYER,MM,MM1
      INTEGER MM2,MX,MY,MZ,N,N1,N2,SUB_BLOCK,NCB,NCB1,NHFILM,NMAX,NN,NN1,  &
              NN2,NOB,NOB1,NRG,NRG3,NSR
      INTEGER NSUBCM,NXMAX,NYMAX,NZMAX,NZOB,NZSR
!
      COMPLEX G(NMAX,N),EXX,EXY,EXZ,EYX,EYY,EYZ,EZX,EZY,EZZ,               &
              CDH(0:MLAYER),CDV(0:MLAYER),                                 &
              CDB(NSUBCM,SUB_BLOCK),DELTH,DELTV,                           &
              GRHF(11,NHFILM,NZSR,NZOB),GRHO0(4,NZSR,NZOB),                &
              GRHF3(11,NHFILM,NZSR),GRHO03(4,NZSR)
      INTEGER NX(SUB_BLOCK),NY(SUB_BLOCK),NZ(SUB_BLOCK)
      REAL  X(NXMAX,SUB_BLOCK),Y(NYMAX,SUB_BLOCK),Z(NZMAX,SUB_BLOCK),      &
            CLX(SUB_BLOCK),CLY(SUB_BLOCK),CLZ(SUB_BLOCK),                  &
            ZBND(0:MLAYER),HVK(0:MLAYER),ZOBG(NZOB),                       &
            ZSRG(2,NZSR),RRG(NRG),RRG3(NRG3),PSTION(8)
      COMPLEX ECOMP(9),HCOMP(9)
      EQUIVALENCE (ECOMP(1),EXX),(ECOMP(2),EYX),(ECOMP(3),EZX),   &
                  (ECOMP(4),EXY),(ECOMP(5),EYY),(ECOMP(6),EZY),   &
                  (ECOMP(7),EXZ),(ECOMP(8),EYZ),(ECOMP(9),EZZ)
!
      KEYG=1
!
! ******  SUB_BLOCK=1 FOR THE TIME BEING!!
      IF (SUB_BLOCK>1) THEN
         STOP 'SUB_BLOCK>1 !!'
      ENDIF
!
      L=1
      NCB=0
      DO K=1,NZ(L)
         DO IOB=MLAYER-1,0,-1
            IF (Z(K,L)>=ZBND(IOB)) THEN
               NOB=IOB+1
               GOTO 50
            ENDIF
         ENDDO
         NOB=0
   50    IF (L==1.AND.K==1) NOB1=NOB
!
         LL=1
         NCB1=0
         DO KK=1,NZ(LL)
!
! --- RECIPROCITY CONSIDERATIONS
!
            IF (KK<=K) THEN
!
               DO ISR=MLAYER-1,0,-1
                  IF (Z(KK,LL)>=ZBND(ISR)) THEN
                     NSR=ISR+1
                     GOTO 60
                  ENDIF
               ENDDO
               NSR=0
!
   60          DO I=1,NX(L)
                  DO J=1,NY(L)
                     NN=(I-1)*NY(L)*NZ(L)+(J-1)*NZ(L)+K
                     N1=NN+NCB
                     NN1=(N1-1)*3+1
!
! ---- KSELF CONTROLS IF THE CALCULATION FOR THE SELF-CELLS
!    SHOULD BE REPEATED
!
! THIS PART MAY BE DISABLED FOR TEST PUPPOSE IN ORDER TO MATCH
! THE THEORETICAL REDUCTION MTRX_SLV_FACTOR
!
! ---- KSELF controls if the calculation for the self-cells
!    should be repeated
                     IF (I==1.AND.J==1.AND.K==1.OR.NOB1/=NOB.OR.  &
                         NOB1/=NSR) THEN
                        KSELF=1
                     ELSE
                        KSELF=0
                     ENDIF
!
                     DO II=1,NX(LL)
                        DO JJ=1,NY(LL)
!
                           N2=(II-1)*NY(LL)*NZ(LL)+(JJ-1)*NZ(LL)+KK+NCB1
                           NN2=(N2-1)*3+1
                           CLX1=CLX(LL)
                           CLY1=CLY(LL)
                           CLZ1=CLZ(LL)
!
                           IF (I==1.AND.J==1) THEN
!
                              IF (II==1.AND.JJ==1) MM1=NN1
!
                              PSTION(1)=X(I,L)
                              PSTION(2)=Y(J,L)
                              PSTION(3)=Z(K,L)
                              PSTION(4)=X(II,LL)
                              PSTION(5)=Y(JJ,LL)
                              PSTION(6)=Z(KK,LL)
                              CALL THR_D_GREEN(KEYG,PSTION,FRQ,MLAYER,ZBND,  &
                                 CDH,HVK,NZOB,ZOBG,NZSR,ZSRG,                &
                                 RHOMIN,DMIN,NHFILM,RRG,NRG,GRHF,RRG3,       &
                                 NRG3,GRHF3,GRHO0,GRHO03,CLX1,CLY1,CLZ1,     &
                                 CLMN,KCLMN,BLMIN,KACC,KUTCRP,KSELF,         &
                                 ECOMP,HCOMP)
!
                              G(NN1,NN2)=-EXX
                              G(NN1+1,NN2+1)=-EYY
                              G(NN1+2,NN2+2)=-EZZ
                              G(NN1+1,NN2)=-EYX
                              G(NN1+2,NN2)=-EZX
                              G(NN1,NN2+1)=-EXY
                              G(NN1+2,NN2+1)=-EZY
                              G(NN1,NN2+2)=-EXZ
                              G(NN1+1,NN2+2)=-EYZ
!
                              CYCLE
!
                           ENDIF
!
                           DX=(X(II,LL)-X(I,L))/CLX1
!     FOR STABILITY
                           IF (DX>=0) IX=INT(DX+.2)+1
                           IF (DX<0) IX=INT(DX-.2)-1
                           IF (IX==-1) IX=1
!
                           DY=(Y(JJ,LL)-Y(J,L))/CLY1
!     FOR STABILITY
                           IF (DY>=0) JY=INT(DY+.2)+1
                           IF (DY<0) JY=INT(DY-.2)-1
                           IF (JY==-1) JY=1
!
                           IF (IX>0.AND.JY>0) THEN
!
                              MX=IX
                              MY=JY
                              MZ=KK
!
                              MM=(MX-1)*NY(L)*NZ(L)+(MY-1)*NZ(L)+MZ
                              MM2=(MM-1)*3+1
!
                              G(NN1,NN2)=G(MM1,MM2)
                              G(NN1+1,NN2)=G(MM1+1,MM2)
                              G(NN1+2,NN2)=G(MM1+2,MM2)
                              G(NN1,NN2+1)=G(MM1,MM2+1)
                              G(NN1+1,NN2+1)=G(MM1+1,MM2+1)
                              G(NN1+2,NN2+1)=G(MM1+2,MM2+1)
                              G(NN1,NN2+2)=G(MM1,MM2+2)
                              G(NN1+1,NN2+2)=G(MM1+1,MM2+2)
                              G(NN1+2,NN2+2)=G(MM1+2,MM2+2)
!
                           ENDIF
!
                           IF (IX<0.AND.JY>0) THEN
!
                              MX=-IX
                              MY=JY
!              NOT K !!
                              MZ=KK
!
                              MM=(MX-1)*NY(L)*NZ(L)+(MY-1)*NZ(L)+MZ
                              MM2=(MM-1)*3+1
!
                              G(NN1,NN2)=G(MM1,MM2)
                              G(NN1+1,NN2)=-G(MM1+1,MM2)
                              G(NN1+2,NN2)=-G(MM1+2,MM2)
                              G(NN1,NN2+1)=-G(MM1,MM2+1)
                              G(NN1+1,NN2+1)=G(MM1+1,MM2+1)
                              G(NN1+2,NN2+1)=G(MM1+2,MM2+1)
                              G(NN1,NN2+2)=-G(MM1,MM2+2)
                              G(NN1+1,NN2+2)=G(MM1+1,MM2+2)
                              G(NN1+2,NN2+2)=G(MM1+2,MM2+2)
!
                           ENDIF
!
                           IF (IX<0.AND.JY<0) THEN
!
                              MX=-IX
                              MY=-JY
!              NOT K !!
                              MZ=KK
!
                              MM=(MX-1)*NY(L)*NZ(L)+(MY-1)*NZ(L)+MZ
                              MM2=(MM-1)*3+1
!
                              G(NN1,NN2)=G(MM1,MM2)
                              G(NN1+1,NN2)=G(MM1+1,MM2)
                              G(NN1+2,NN2)=-G(MM1+2,MM2)
                              G(NN1,NN2+1)=G(MM1,MM2+1)
                              G(NN1+1,NN2+1)=G(MM1+1,MM2+1)
                              G(NN1+2,NN2+1)=-G(MM1+2,MM2+1)
                              G(NN1,NN2+2)=-G(MM1,MM2+2)
                              G(NN1+1,NN2+2)=-G(MM1+1,MM2+2)
                              G(NN1+2,NN2+2)=G(MM1+2,MM2+2)
!
                           ENDIF
!
                           IF (IX>0.AND.JY<0) THEN
!
                              MX=IX
                              MY=-JY
!              NOT K !!
                              MZ=KK
!
                              MM=(MX-1)*NY(L)*NZ(L)+(MY-1)*NZ(L)+MZ
                              MM2=(MM-1)*3+1

                              G(NN1,NN2)=G(MM1,MM2)
                              G(NN1+1,NN2)=-G(MM1+1,MM2)
                              G(NN1+2,NN2)=G(MM1+2,MM2)
                              G(NN1,NN2+1)=-G(MM1,MM2+1)
                              G(NN1+1,NN2+1)=G(MM1+1,MM2+1)
                              G(NN1+2,NN2+1)=-G(MM1+2,MM2+1)
                              G(NN1,NN2+2)=G(MM1,MM2+2)
                              G(NN1+1,NN2+2)=-G(MM1+1,MM2+2)
                              G(NN1+2,NN2+2)=G(MM1+2,MM2+2)
!
                           ENDIF
!
                        ENDDO
                     ENDDO
                  ENDDO
               ENDDO
            ENDIF
!
         ENDDO
      ENDDO
!
! ---  RECIPROCITY
!
      L=1
      LL=1
      NCB=0
      NCB1=0
!
      DO K=1,NZ(L)
!
         DO KK=1,NZ(LL)
!
            IF (KK>K) THEN
!
               DO I=1,NX(L)
                  DO J=1,NY(L)
                     NN=(I-1)*NY(L)*NZ(L)+(J-1)*NZ(L)+K
                     N1=NN+NCB
                     NN1=(N1-1)*3+1
!
                     DO II=1,NX(LL)
                        DO JJ=1,NY(LL)
                           N2=(II-1)*NY(LL)*NZ(LL)+(JJ-1)*NZ(LL)+KK+NCB1
                           NN2=(N2-1)*3+1
!
                           G(NN1,NN2)=G(NN2,NN1)
                           G(NN1+1,NN2)=G(NN2,NN1+1)
                           G(NN1+2,NN2)=G(NN2,NN1+2)
                           G(NN1,NN2+1)=G(NN2+1,NN1)
                           G(NN1+1,NN2+1)=G(NN2+1,NN1+1)
                           G(NN1+2,NN2+1)=G(NN2+1,NN1+2)
                           G(NN1,NN2+2)=G(NN2+2,NN1)
                           G(NN1+1,NN2+2)=G(NN2+2,NN1+1)
                           G(NN1+2,NN2+2)=G(NN2+2,NN1+2)
!
                        ENDDO
                     ENDDO
                  ENDDO
               ENDDO
            ENDIF
!
         ENDDO
      ENDDO

! --- Add the term of cell conductivity to the celf cells
!
      NCB=0
      L=1
!
      DO K=1,NZ(L)
         DO IOB=MLAYER-1,0,-1
            IF (Z(K,L)>=ZBND(IOB)) THEN
               NOB=IOB+1
               GOTO 100
            ENDIF
         ENDDO
         NOB=0
!
  100    DO I=1,NX(L)
            DO J=1,NY(L)
!
               NN=(I-1)*NY(L)*NZ(L)+(J-1)*NZ(L)+K
               N1=NN+NCB
               NN1=(N1-1)*3+1
!
               DELTH=CDB(NN,L)-CDH(NOB)
               DELTV=CDB(NN,L)-CDV(NOB)
!
               G(NN1,NN1)=1./DELTH+G(NN1,NN1)
               G(NN1+1,NN1+1)=1./DELTH+G(NN1+1,NN1+1)
               G(NN1+2,NN1+2)=1./DELTV+G(NN1+2,NN1+2)
!
            ENDDO
         ENDDO
      ENDDO
!
      RETURN
      END
!
!**** End of MTRX_SPS1B
!
!
      SUBROUTINE MTRX_GS(KSMR,NSMR,NXS,NYS,NZS,SBX,SBY,SBZ,ZSB,          &
                         KS,KDIAG,N,N2,CLX,CLY,CLZ,XSR,YSR,ZSR,          &
                         NMAX,NXMAX,NYMAX,NZMAX,NX,NY,NZ,NCELL,          &
                         NSUBCM,SUB_BLOCK,X,Y,Z,CDB,G,GSB2,              &
                         FRQ,MLAYER,ZBND,CDH,CDV,HVK,NZOB,ZOBG,NZSR,     &
                         ZSRG,RHOMIN,DMIN,NHFILM,RRG,NRG,GRHF,           &
                         RRG3,NRG3,GRHF3,GRHO0,GRHO03,CLMN,KCLMN,        &
                         BLMIN,KACC,KUTCRP)
!
!****  Compute the column matrices of the submatrices of the four
!  block matrices obtained by group theoretical reduction
!
!  Three columns for each field cell in the four block matrices
!  are computed at a time
!
!  The parameter KDIAG controls whether the diagonal or off-
!  diagonal submatrices are computed. KDIAG=1: diagonal;
!  =0, off-diagonal.
!
!  The parameter KS controls if the matrices are symmetric.
!  If so, only half of the elements will be computed.  The rests
!  will be determined in the main program.  In case of system
!  iteration is applied, however, the symmetry of the block
!  matrices will not used in forming the matrices except for
!  the diagonal submatrices.  The use of symmetry will save
!  some computer time for the block diagonalization.  The
!  use of symmetry in the actual computation of the Green's
!  functions has been considered in the spatial symmetry
!  reduction already.  The use of symmetry here will save
!  the total computation time by about 10 percent.
!
!  The parameter kself controling the computation for the
!  integration of the primary part of the Green's function
!  for self-cells as in other routines like smtrx1m is dropped
!  since one loop is move to the main program.
!
!
      IMPLICIT NONE
!
      REAL BLMIN,CLMN,CLX,CLY,CLZ,DMIN,DX,DY,FRQ,RHOMIN,SBX,SBY,SBZ,SCX,  &
           SCY,SCZ,XOB1,XSR,XSR1,YOB1
      REAL YSR,YSR1,ZSB,ZSR
      INTEGER I,II,II1,II2,II3,IOB,IX,J,JJ,JJ1,JJ2,JJ3,JY,K,KACC,KCLMN,   &
              KDIAG,KEYG,KKZ,KS
      INTEGER KSELF,KSMR,KUTCRP,KZ,L,LQ,LQC,LQR,MLAYER,MM,MM1,MM2,MM3,    &
              MX,MY,N,N1,N2,SUB_BLOCK,NCB
      INTEGER NHFILM,NMAX,NN,NN1,NOB,NQ,NQC,NQR,NRG,NRG3,NSMR,NSUBCM,     &
              NXMAX,NXS,NYMAX,NYS,NZMAX,NZOB,NZS,NZSR
!
      COMPLEX GSB2(NSMR/3,3)
!
      COMPLEX G(NMAX,N),EXX,EXY,EXZ,EYX,EYY,EYZ,EZX,EZY,EZZ,              &
              CDH(0:MLAYER),CDV(0:MLAYER),                                &
              CDB(NSUBCM,SUB_BLOCK),DELTH,DELTV,                          &
              GE(12,12),AA(3,3),                                          &
              GRHF(11,NHFILM,NZSR,NZOB),GRHO0(4,NZSR,NZOB),               &
              GRHF3(11,NHFILM,NZSR),GRHO03(4,NZSR)
      INTEGER NX(SUB_BLOCK),NY(SUB_BLOCK),NZ(SUB_BLOCK),NCELL(SUB_BLOCK)
      REAL  X(NXMAX,SUB_BLOCK),Y(NYMAX,SUB_BLOCK),Z(NZMAX,SUB_BLOCK),     &
            BX(4),BY(4),ZBND(0:MLAYER),HVK(0:MLAYER),UR(3),UC(3,4),       &
            ZOBG(NZOB),ZSRG(2,NZSR),RRG(NRG),RRG3(NRG3),PSTION(8)
      COMPLEX ECOMP(9),HCOMP(9)
      EQUIVALENCE (ECOMP(1),EXX),(ECOMP(2),EYX),(ECOMP(3),EZX),   &
                  (ECOMP(4),EXY),(ECOMP(5),EYY),(ECOMP(6),EZY),   &
                  (ECOMP(7),EXZ),(ECOMP(8),EYZ),(ECOMP(9),EZZ)
!
      DATA BX /-1., 1.,1.,-1./
      DATA BY /-1.,-1.,1., 1./
!
      KEYG=1
!
! --- Compute the cell dimension of the super block
!
      IF (KSMR==1) THEN
         SCX=SBX/NXS
         SCY=SBY/NYS
         SCZ=SBZ/NZS
      ENDIF
!
! --- KSELF set to be 1
!
      KSELF=1
!
      DO I=1,N
         DO J=1,NMAX
            G(J,I)=(0.,0.)
         ENDDO
      ENDDO
!
      IF (KSMR==1) THEN
!
! --- Locate the z'-level of the source cell in the super block
!
!   Note that the source cells are the out loop here.  Thus
!   the design of the program is slightly different from
!   the designs in routines MTRX_SPSS etc.
!
         KKZ=INT((ZSR+.5*SCZ-(ZSB-.5*SBZ))/SCZ+.2)
!
      ENDIF
!
      NCB=0
      DO L=1,SUB_BLOCK
         IF (L>1) NCB=NCB+NCELL(L-1)
         DO K=1,NZ(L)
!
            IF (KSMR==1) THEN
!
! --- Locate the z-level of the field cell in the super block
!
!   Note that the source cells are the out loop here.  Thus
!   the design of the program is slightly different from
!   the designs in routines MTRX_SPSS etc.
!
               KZ=INT((Z(K,L)+.5*SCZ-(ZSB-.5*SBZ))/SCZ+.2)
!
            ENDIF
!
            IF (KDIAG==1) THEN
               DO IOB=MLAYER-1,0,-1
                  IF (Z(K,L)>=ZBND(IOB)) THEN
                     NOB=IOB+1
                     GOTO 20
                  ENDIF
               ENDDO
               NOB=0
            ENDIF
!
   20       DO I=1,NX(L)
               DO J=1,NY(L)
                  NN=((I-1)*NY(L)+(J-1))*NZ(L)+K
                  N1=NN+NCB
                  NN1=(N1-1)*3
!
! --- For symmetric matrices only the upper triangles need to
!   be computed
!
                  IF (KS/=1.OR.N1>=N2) THEN
!
                     IF (KDIAG==1.AND.N1==N2) THEN
                        DELTH=CDB(NN,L)-CDH(NOB)
                        DELTV=CDB(NN,L)-CDV(NOB)
                     ENDIF
!
! --- Compute the elements for the 4 quarters
!
                     DO LQC=1,4
                        JJ=3*(LQC-1)
                        JJ1=JJ+1
                        JJ2=JJ+2
                        JJ3=JJ+3
                        IF (BX(LQC)>0.) THEN
                           XSR1=XSR
                        ELSE
                           XSR1=-XSR
                        ENDIF
                        IF (BY(LQC)>0.) THEN
                           YSR1=YSR
                        ELSE
                           YSR1=-YSR
                        ENDIF
!
                        DO LQR=1,4
                           II=3*(LQR-1)
                           II1=II+1
                           II2=II+2
                           II3=II+3
                           IF (BX(LQR)>0.) THEN
                              XOB1=X(I,L)
                           ELSE
                              XOB1=-X(I,L)
                           ENDIF
                           IF (BY(LQR)>0.) THEN
                              YOB1=Y(J,L)
                           ELSE
                              YOB1=-Y(J,L)
                           ENDIF
!
                           IF (LQC==1) THEN
!
                              IF (KSMR==0) THEN
!
                              PSTION(1)=XOB1
                              PSTION(2)=YOB1
                              PSTION(3)=Z(K,L)
                              PSTION(4)=XSR1
                              PSTION(5)=YSR1
                              PSTION(6)=ZSR
                              CALL THR_D_GREEN(KEYG,PSTION,FRQ,MLAYER,ZBND,  &
                                 CDH,HVK,NZOB,ZOBG,NZSR,ZSRG,                &
                                 RHOMIN,DMIN,NHFILM,RRG,NRG,GRHF,RRG3,       &
                                 NRG3,GRHF3,GRHO0,GRHO03,CLX,CLY,CLZ,        &
                                 CLMN,KCLMN,BLMIN,KACC,KUTCRP,KSELF,         &
                                 ECOMP,HCOMP)
!
                              GE(II1,JJ1)=-EXX
                              GE(II2,JJ1)=-EYX
                              GE(II3,JJ1)=-EZX
                              GE(II1,JJ2)=-EXY
                              GE(II2,JJ2)=-EYY
                              GE(II3,JJ2)=-EZY
                              GE(II1,JJ3)=-EXZ
                              GE(II2,JJ3)=-EYZ
                              GE(II3,JJ3)=-EZZ
!
                              CYCLE
!
                              ENDIF
!
! --- Evaluate the Green's functions by means of spatial symmetry
!   using pre-computed results
!
! --- Identify the relative cell location in the super blocks
!
!   Note that reciprocity is considered here
!
                              IF (KZ<=KKZ) THEN
                              DX=(XSR1-XOB1)/SCX
                              ELSE
                              DX=(XOB1-XSR1)/SCX
                              ENDIF
                              IF (DX>=0) IX=INT(DX+.2)+1
                              IF (DX<0) IX=INT(DX-.2)-1
                              IF (IX==-1) IX=1
!
                              IF (KZ<=KKZ) THEN
                              DY=(YSR1-YOB1)/SCY
                              ELSE
                              DY=(YOB1-YSR1)/SCY
                              ENDIF
                              IF (DY>=0) JY=INT(DY+.2)+1
                              IF (DY<0) JY=INT(DY-.2)-1
                              IF (JY==-1) JY=1
!
! --- Determine the values of the scattering matrix using the
!   symmetry properties of the Green's functions
!
!      IF(KZ.LE.KKZ) THEN
!           MZ=KKZ
!         ELSE
!           MZ=KZ
!       ENDIF
!
                              IF (IX>0.AND.JY>0) THEN
!
                              MX=IX
                              MY=JY
!
! --- Note that the order of the array GSB2 determined in the
!   routine GSB is different from that of the scattering matrix
!   formed here in this routine.  Check the routine GSB for
!   more explanations.
!
!   Note that if KZ.LE.KKZ then KZ controls the field cell levels.
!   otherwise KZZ controls the field cell levels..
!
                              IF (KZ<=KKZ) THEN
                              MM=((KKZ-KZ)*NYS+(MY-1))*NXS+MX
                              MM1=(3*NXS*NYS*(2*NZS-(KZ-2)))*(KZ-1)  &
                                 /2+(MM-1)*3+1
                              ELSE
                              MM=((KZ-KKZ)*NYS+(MY-1))*NXS+MX
                              MM1=(3*NXS*NYS*(2*NZS-(KKZ-2)))*(KKZ-1)  &
                                 /2+(MM-1)*3+1
                              ENDIF
                              MM2=MM1+1
                              MM3=MM1+2
!
                              IF (KZ>KKZ) THEN
!
!--- Use the reciprocity theorem
!
                              GE(II1,JJ1)=GSB2(MM1,1)
                              GE(II2,JJ1)=GSB2(MM1,2)
                              GE(II3,JJ1)=GSB2(MM1,3)
                              GE(II1,JJ2)=GSB2(MM2,1)
                              GE(II2,JJ2)=GSB2(MM2,2)
                              GE(II3,JJ2)=GSB2(MM2,3)
                              GE(II1,JJ3)=GSB2(MM3,1)
                              GE(II2,JJ3)=GSB2(MM3,2)
                              GE(II3,JJ3)=GSB2(MM3,3)
                              ELSE
!
                              GE(II1,JJ1)=GSB2(MM1,1)
                              GE(II2,JJ1)=GSB2(MM2,1)
                              GE(II3,JJ1)=GSB2(MM3,1)
                              GE(II1,JJ2)=GSB2(MM1,2)
                              GE(II2,JJ2)=GSB2(MM2,2)
                              GE(II3,JJ2)=GSB2(MM3,2)
                              GE(II1,JJ3)=GSB2(MM1,3)
                              GE(II2,JJ3)=GSB2(MM2,3)
                              GE(II3,JJ3)=GSB2(MM3,3)
                              ENDIF
                              CYCLE
!
                              ENDIF
!
                              IF (IX<0.AND.JY>0) THEN
!
                              MX=-IX
                              MY=JY
!
!   Note that if KZ.LE.KKZ then KZ controls the field cell levels.
!   otherwise KZZ controls the field cell levels..
!
                              IF (KZ<=KKZ) THEN
                              MM=((KKZ-KZ)*NYS+(MY-1))*NXS+MX
                              MM1=(3*NXS*NYS*(2*NZS-(KZ-2)))*(KZ-1)  &
                                 /2+(MM-1)*3+1
                              ELSE
                              MM=((KZ-KKZ)*NYS+(MY-1))*NXS+MX
                              MM1=(3*NXS*NYS*(2*NZS-(KKZ-2)))*(KKZ-1)  &
                                 /2+(MM-1)*3+1
                              ENDIF
                              MM2=MM1+1
                              MM3=MM1+2
!
                              IF (KZ>KKZ) THEN
!
!--- Use the reciprocity theorem
!
                              GE(II1,JJ1)=GSB2(MM1,1)
                              GE(II2,JJ1)=-GSB2(MM1,2)
                              GE(II3,JJ1)=-GSB2(MM1,3)
                              GE(II1,JJ2)=-GSB2(MM2,1)
                              GE(II2,JJ2)=GSB2(MM2,2)
                              GE(II3,JJ2)=GSB2(MM2,3)
                              GE(II1,JJ3)=-GSB2(MM3,1)
                              GE(II2,JJ3)=GSB2(MM3,2)
                              GE(II3,JJ3)=GSB2(MM3,3)
                              ELSE
!
                              GE(II1,JJ1)=GSB2(MM1,1)
                              GE(II2,JJ1)=-GSB2(MM2,1)
                              GE(II3,JJ1)=-GSB2(MM3,1)
                              GE(II1,JJ2)=-GSB2(MM1,2)
                              GE(II2,JJ2)=GSB2(MM2,2)
                              GE(II3,JJ2)=GSB2(MM3,2)
                              GE(II1,JJ3)=-GSB2(MM1,3)
                              GE(II2,JJ3)=GSB2(MM2,3)
                              GE(II3,JJ3)=GSB2(MM3,3)
                              ENDIF
                              CYCLE
!
                              ENDIF
!
                              IF (IX<0.AND.JY<0) THEN
!
                              MX=-IX
                              MY=-JY
!
!   Note that if KZ.LE.KKZ then KZ controls the field cell levels.
!   otherwise KZZ controls the field cell levels..
!
                              IF (KZ<=KKZ) THEN
                              MM=((KKZ-KZ)*NYS+(MY-1))*NXS+MX
                              MM1=(3*NXS*NYS*(2*NZS-(KZ-2)))*(KZ-1)  &
                                 /2+(MM-1)*3+1
                              ELSE
                              MM=((KZ-KKZ)*NYS+(MY-1))*NXS+MX
                              MM1=(3*NXS*NYS*(2*NZS-(KKZ-2)))*(KKZ-1)  &
                                 /2+(MM-1)*3+1
                              ENDIF
                              MM2=MM1+1
                              MM3=MM1+2
!
                              IF (KZ>KKZ) THEN
!
!--- Use the reciprocity theorem
!
                              GE(II1,JJ1)=GSB2(MM1,1)
                              GE(II2,JJ1)=GSB2(MM1,2)
                              GE(II3,JJ1)=-GSB2(MM1,3)
                              GE(II1,JJ2)=GSB2(MM2,1)
                              GE(II2,JJ2)=GSB2(MM2,2)
                              GE(II3,JJ2)=-GSB2(MM2,3)
                              GE(II1,JJ3)=-GSB2(MM3,1)
                              GE(II2,JJ3)=-GSB2(MM3,2)
                              GE(II3,JJ3)=GSB2(MM3,3)
                              ELSE
!
                              GE(II1,JJ1)=GSB2(MM1,1)
                              GE(II2,JJ1)=GSB2(MM2,1)
                              GE(II3,JJ1)=-GSB2(MM3,1)
                              GE(II1,JJ2)=GSB2(MM1,2)
                              GE(II2,JJ2)=GSB2(MM2,2)
                              GE(II3,JJ2)=-GSB2(MM3,2)
                              GE(II1,JJ3)=-GSB2(MM1,3)
                              GE(II2,JJ3)=-GSB2(MM2,3)
                              GE(II3,JJ3)=GSB2(MM3,3)
                              ENDIF
                              CYCLE
!
                              ENDIF
!
                              IF (IX>0.AND.JY<0) THEN
!
                              MX=IX
                              MY=-JY
!
!   Note that if KZ.LE.KKZ then KZ controls the field cell levels.
!   otherwise KZZ controls the field cell levels..
!
                              IF (KZ<=KKZ) THEN
                              MM=((KKZ-KZ)*NYS+(MY-1))*NXS+MX
                              MM1=(3*NXS*NYS*(2*NZS-(KZ-2)))*(KZ-1)  &
                                 /2+(MM-1)*3+1
                              ELSE
                              MM=((KZ-KKZ)*NYS+(MY-1))*NXS+MX
                              MM1=(3*NXS*NYS*(2*NZS-(KKZ-2)))*(KKZ-1)  &
                                 /2+(MM-1)*3+1
                              ENDIF
                              MM2=MM1+1
                              MM3=MM1+2
!
                              IF (KZ>KKZ) THEN
!
!--- Use the reciprocity theorem
!
                              GE(II1,JJ1)=GSB2(MM1,1)
                              GE(II2,JJ1)=-GSB2(MM1,2)
                              GE(II3,JJ1)=GSB2(MM1,3)
                              GE(II1,JJ2)=-GSB2(MM2,1)
                              GE(II2,JJ2)=GSB2(MM2,2)
                              GE(II3,JJ2)=-GSB2(MM2,3)
                              GE(II1,JJ3)=GSB2(MM3,1)
                              GE(II2,JJ3)=-GSB2(MM3,2)
                              GE(II3,JJ3)=GSB2(MM3,3)
                              ELSE
!
                              GE(II1,JJ1)=GSB2(MM1,1)
                              GE(II2,JJ1)=-GSB2(MM2,1)
                              GE(II3,JJ1)=GSB2(MM3,1)
                              GE(II1,JJ2)=-GSB2(MM1,2)
                              GE(II2,JJ2)=GSB2(MM2,2)
                              GE(II3,JJ2)=-GSB2(MM3,2)
                              GE(II1,JJ3)=GSB2(MM1,3)
                              GE(II2,JJ3)=-GSB2(MM2,3)
                              GE(II3,JJ3)=GSB2(MM3,3)
                              ENDIF
                              CYCLE
!
                              ENDIF
                           ENDIF
!
! --- Compute the elements of GE for LQC.NE.1 by
!   symmetry relations of the Green's functions.
!   In the following the spatial symmetry is used to
!   determine the Green's functions.  In some cases
!   the reciprocity thereom may also be used.  Note
!   that the reciprocity thereom is not always true
!   here unless the media are isotropic or the four
!   field cells and the four source cells locate in
!   a single anisotropic layer. For this reason the
!   use of the reciprocity thereom is avoid here.
!
!   The following parameters r(-i)(-j) etc. refer to
!   thos in Table 1 of Xiong and Tripp (1992)
!   (spatial symmetry reduction).
!
                           IF (LQC==1) THEN
                           ELSEIF (LQC==3) THEN
!
                              IF (LQR==2) THEN
!
! --- Equivalent to the results of r(-i)(-j).
!
!   May also use reciprocity.
!   II=3, JJ=6
                              GE(II1,JJ1)=GE(10,1)
                              GE(II2,JJ1)=GE(11,1)
                              GE(II3,JJ1)=-GE(12,1)
                              GE(II1,JJ2)=GE(10,2)
                              GE(II2,JJ2)=GE(11,2)
                              GE(II3,JJ2)=-GE(12,2)
                              GE(II1,JJ3)=-GE(10,3)
                              GE(II2,JJ3)=-GE(11,3)
!
                              GE(II3,JJ3)=GE(12,3)
                              ELSEIF (LQR==3) THEN
!
! --- Equivalent to the results of r(-i)(-j).
!
!   Note this is not a self-cell unless N1=N2.
!
!   II=JJ=6
                              GE(II1,JJ1)=GE(1,1)
                              GE(II2,JJ1)=GE(2,1)
                              GE(II3,JJ1)=-GE(3,1)
                              GE(II1,JJ2)=GE(1,2)
                              GE(II2,JJ2)=GE(2,2)
                              GE(II3,JJ2)=-GE(3,2)
                              GE(II1,JJ3)=-GE(1,3)
                              GE(II2,JJ3)=-GE(2,3)
!
                              GE(II3,JJ3)=GE(3,3)
                              ELSEIF (LQR==4) THEN
!
! --- Equivalent to the results of r(-i)(-j).
!
!   II=9, JJ=6.
                              GE(II1,JJ1)=GE(4,1)
                              GE(II2,JJ1)=GE(5,1)
                              GE(II3,JJ1)=-GE(6,1)
                              GE(II1,JJ2)=GE(4,2)
                              GE(II2,JJ2)=GE(5,2)
                              GE(II3,JJ2)=-GE(6,2)
                              GE(II1,JJ3)=-GE(4,3)
                              GE(II2,JJ3)=-GE(5,3)
!
                              GE(II3,JJ3)=GE(6,3)
                              ELSE
!
! --- Equivalent to the results of r(-i)(-j).
!   II=0, JJ=6
                              GE(II1,JJ1)=GE(7,1)
                              GE(II2,JJ1)=GE(8,1)
                              GE(II3,JJ1)=-GE(9,1)
                              GE(II1,JJ2)=GE(7,2)
                              GE(II2,JJ2)=GE(8,2)
                              GE(II3,JJ2)=-GE(9,2)
                              GE(II1,JJ3)=-GE(7,3)
                              GE(II2,JJ3)=-GE(8,3)
!
                              GE(II3,JJ3)=GE(9,3)
                              ENDIF
                           ELSEIF (LQC==4) THEN
!
                              IF (LQR==2) THEN
!
! --- Equivalent to  ri(-j) or the combination of
!   r(-i)j and r(-i)(-j).
!
!   II=3, JJ=9
                              GE(II1,JJ1)=GE(7,1)
                              GE(II2,JJ1)=-GE(8,1)
                              GE(II3,JJ1)=GE(9,1)
                              GE(II1,JJ2)=-GE(7,2)
                              GE(II2,JJ2)=GE(8,2)
                              GE(II3,JJ2)=-GE(9,2)
                              GE(II1,JJ3)=GE(7,3)
                              GE(II2,JJ3)=-GE(8,3)
!
                              GE(II3,JJ3)=GE(9,3)
                              ELSEIF (LQR==3) THEN
!
! --- Equivalent to the results of ri(-j).
!
!   II=6, JJ=9
                              GE(II1,JJ1)=GE(4,1)
                              GE(II2,JJ1)=-GE(5,1)
                              GE(II3,JJ1)=GE(6,1)
                              GE(II1,JJ2)=-GE(4,2)
                              GE(II2,JJ2)=GE(5,2)
                              GE(II3,JJ2)=-GE(6,2)
                              GE(II1,JJ3)=GE(4,3)
                              GE(II2,JJ3)=-GE(5,3)
!
                              GE(II3,JJ3)=GE(6,3)
                              ELSEIF (LQR==4) THEN
!
! --- Equivalent to the results of ri(-j).
!
!   Note this is not a self-cell unless N1=N2.
!
!   II=JJ=9
                              GE(II1,JJ1)=GE(1,1)
                              GE(II2,JJ1)=-GE(2,1)
                              GE(II3,JJ1)=GE(3,1)
                              GE(II1,JJ2)=-GE(1,2)
                              GE(II2,JJ2)=GE(2,2)
                              GE(II3,JJ2)=-GE(3,2)
                              GE(II1,JJ3)=GE(1,3)
                              GE(II2,JJ3)=-GE(2,3)
                              GE(II3,JJ3)=GE(3,3)
                              ELSE
!
! --- Equivalent to the results of ri(-j).
!
!   II=0, JJ=9.
                              GE(II1,JJ1)=GE(10,1)
                              GE(II2,JJ1)=-GE(11,1)
                              GE(II3,JJ1)=GE(12,1)
                              GE(II1,JJ2)=-GE(10,2)
                              GE(II2,JJ2)=GE(11,2)
                              GE(II3,JJ2)=-GE(12,2)
                              GE(II1,JJ3)=GE(10,3)
                              GE(II2,JJ3)=-GE(11,3)
!
                              GE(II3,JJ3)=GE(12,3)
                              ENDIF
!
                           ELSEIF (LQR==2) THEN
!
! --- Equivalent to the results of r(-i)j.
!
!   Note this is not a self-cell unless N1=N2.
!
!   II=JJ=3
                              GE(II1,JJ1)=GE(1,1)
                              GE(II2,JJ1)=-GE(2,1)
                              GE(II3,JJ1)=-GE(3,1)
                              GE(II1,JJ2)=-GE(1,2)
                              GE(II2,JJ2)=GE(2,2)
                              GE(II3,JJ2)=GE(3,2)
                              GE(II1,JJ3)=-GE(1,3)
                              GE(II2,JJ3)=GE(2,3)
!
                              GE(II3,JJ3)=GE(3,3)
                           ELSEIF (LQR==3) THEN
!
! --- Equivalent to the results of r(-i)j.
!
!   II=6, JJ=3
                              GE(II1,JJ1)=GE(10,1)
                              GE(II2,JJ1)=-GE(11,1)
                              GE(II3,JJ1)=-GE(12,1)
                              GE(II1,JJ2)=-GE(10,2)
                              GE(II2,JJ2)=GE(11,2)
                              GE(II3,JJ2)=GE(12,2)
                              GE(II1,JJ3)=-GE(10,3)
                              GE(II2,JJ3)=GE(11,3)
!
                              GE(II3,JJ3)=GE(12,3)
                           ELSEIF (LQR==4) THEN
!
! --- Equivalent to r(-i)j or the combination of
!   ri(-j) and r(-i)(-j).
!   II=9, JJ=3
                              GE(II1,JJ1)=GE(7,1)
                              GE(II2,JJ1)=-GE(8,1)
                              GE(II3,JJ1)=-GE(9,1)
                              GE(II1,JJ2)=-GE(7,2)
                              GE(II2,JJ2)=GE(8,2)
                              GE(II3,JJ2)=GE(9,2)
                              GE(II1,JJ3)=-GE(7,3)
                              GE(II2,JJ3)=GE(8,3)
!
                              GE(II3,JJ3)=GE(9,3)
                           ELSE
!
! --- Equivalent to the results of r(-i)j.
!
!   In the following 9 lines II=0, JJ=3
                              GE(II1,JJ1)=GE(4,1)
                              GE(II2,JJ1)=-GE(5,1)
                              GE(II3,JJ1)=-GE(6,1)
                              GE(II1,JJ2)=-GE(4,2)
                              GE(II2,JJ2)=GE(5,2)
                              GE(II3,JJ2)=GE(6,2)
                              GE(II1,JJ3)=-GE(4,3)
                              GE(II2,JJ3)=GE(5,3)
!
                              GE(II3,JJ3)=GE(6,3)
                           ENDIF
!
                        ENDDO
                     ENDDO
!
! --- Add the conductivity term
!
                     IF (N1==N2.AND.KDIAG==1) THEN
                        DO LQR=1,4
                           II=3*(LQR-1)
                           GE(II1,II1)=1./DELTH+GE(II1,II1)
                           GE(II2,II2)=1./DELTH+GE(II2,II2)
                           GE(II3,II3)=1./DELTV+GE(II3,II3)
                        ENDDO
                     ENDIF
!
! --- Transform the above elements of the scattering matrix
!   by the unitary matrix, U*Z*UT
!
!   Note that the total number of cells in one quarter and
!   the cell number as required by the parameters PMAX, PR
!   and PC in the routine unitary are not important here
!   as long as PR=PC, since the parameters IROW and JCOL
!   are of no use in the routine
!
!-- The loop LQ controls the contributions to the four
!   block matrices.  To test the validity of the block
!   diagonalization as well as the code, i.e., the off
!   diagonal matrices are zero, just change the loop LQ
!   into two loops, as
!     DO 28 LQ1=1,4
!     DO 28 LQ2=1,4  ,
!   call MTRX_UNITARY in the loop LQR like
!     CALL MTRX_UNITARY (1,LQ1,II,1,LQR,II,UR(II)) ,
!   and call MTRX_UNITARY in the loop LQC like
!     CALL MTRX_UNITARY (1,LQ2,JJ,1,LQR,JJ,UC(JJ)) ,
!   then the following sum should be zero for LQ1.NE.LQ2
!
                     DO LQ=1,4
                        NQ=3*(LQ-1)
!
                        DO II=1,3
                           DO JJ=1,3
                              AA(JJ,II)=(0.,0.)
                           ENDDO
                        ENDDO
!
                        DO LQR=1,4
                           NQR=3*(LQR-1)
                           DO II=1,3
! --               PMAX=1
                              CALL MTRX_UNITARY(1,LQ,II,1,LQR,II,UR(II))
                           ENDDO
                           DO LQC=1,4
                              NQC=3*(LQC-1)
                              IF (LQR==1) THEN
                              DO JJ=1,3
! --                 PMAX=1
                              CALL MTRX_UNITARY(1,LQ,JJ,1,LQC,JJ,UC(JJ,LQC))
                              ENDDO
                              ENDIF
!
                              DO JJ=1,3
                              DO II=1,3
!
! --- The following may be simply designed as
!
!      G(NN1+II,NQ+JJ)=G(NN1+II,NQ+JJ)+
!   +                  UR(II)*GE(NQR+II,NQC+JJ)*UC(JJ,LQC)
!
!   The following designed is intended to reduce computation
!   time by avoiding multipications.  Not that the values of
!   UR and UC are either +.5 or -.5
!
                              IF (UR(II)<0) THEN
                              IF (UC(JJ,LQC)>=0) THEN
                              GOTO 22
                              ENDIF
                              ELSEIF (UC(JJ,LQC)<=0) THEN
                              GOTO 22
                              ENDIF
!
                              AA(II,JJ)=AA(II,JJ)+GE(NQR+II,NQC+JJ)
                              CYCLE
   22                         AA(II,JJ)=AA(II,JJ)-GE(NQR+II,NQC+JJ)
!
                              ENDDO
                              ENDDO
                           ENDDO
                        ENDDO
!
                        DO JJ=1,3
                           DO II=1,3
                              G(NN1+II,NQ+JJ)=.25*AA(II,JJ)
                           ENDDO
                        ENDDO
!
                     ENDDO
                  ENDIF
!
               ENDDO
            ENDDO
         ENDDO
      ENDDO
!
      RETURN
      END
!
!**** End of MTRX_GS
!
!
      SUBROUTINE MTRX_SMRGS(NXS,NYS,NZS,SBX,SBY,SBZ,ZSB,NMAX,NXMAX,     &
                            NYMAX,NZMAX,NETI,SUB_BLOCKI,NCELLI,XCELLI,  &
                            YCELLI,ZCELLI,NXI,NYI,NZI,NET,SUB_BLOCK,    &
                            NCELL,NX,NY,NZ,X,Y,Z,LQ,G,NSMR,GSB2)
!
!**** Compute the submatrices of one of the four block matrices
!   obtained by group theoretical reduction using spatial
!   symmetry relations
!
!   This routine differs from smtrxgs in that the full matrix
!   is computed for one quadrant.   And the signs of the matrix
!   elements are reversed here in this routine,  instead of in
!   the main program
!
      IMPLICIT NONE
!
      REAL DX,DY,SBX,SBY,SBZ,SCX,SCY,SCZ,XOB1,XSR1,YOB1,YSR1,ZSB
      INTEGER I,II,II1,II2,II3,IL,IX,J,JJ,JJ1,JJ2,JJ3,JL,JY,K,KK,KKZ,KZ,   &
              L,LL,LQ,LQC,LQR,MM,MM1,MM2,MM3,MX,MY,N1,N2,SUB_BLOCK,        &
              SUB_BLOCKI,NCB,NCBI,NET,NETI,NMAX,NN,NN1
      INTEGER NN2,NQC,NQR,NSMR,NXMAX,NXS,NYMAX,NYS,NZMAX,NZS
!
      COMPLEX GSB2(NSMR/3,3)
      COMPLEX G(NMAX,NETI),GE(12,12),AA(3,3)
      INTEGER NX(SUB_BLOCK),NY(SUB_BLOCK),NZ(SUB_BLOCK),NCELL(SUB_BLOCK),   &
              NXI(SUB_BLOCKI),NYI(SUB_BLOCKI),NZI(SUB_BLOCKI),              &
              NCELLI(SUB_BLOCKI)
      REAL  X(NXMAX,SUB_BLOCK),Y(NYMAX,SUB_BLOCK),Z(NZMAX,SUB_BLOCK),       &
            XCELLI(NXMAX,SUB_BLOCKI),YCELLI(NYMAX,SUB_BLOCKI),              &
            ZCELLI(NZMAX,SUB_BLOCKI),                                       &
            BX(4),BY(4),UR(3),UC(3,4)
!
      DATA BX /-1., 1.,1.,-1./
      DATA BY /-1.,-1.,1., 1./
!
! --- Compute the cell dimension of the super block
!
      SCX=SBX/NXS
      SCY=SBY/NYS
      SCZ=SBZ/NZS
!
      DO I=1,NETI
         DO J=1,NET
            G(J,I)=(0.,0.)
         ENDDO
      ENDDO
!
      NCBI=0
      DO LL=1,SUB_BLOCKI
         IF (LL>1) NCBI=NCBI+NCELLI(LL-1)
         DO IL=1,NXI(LL)
            DO JL=1,NYI(LL)
               DO KK=1,NZI(LL)
!
                  N2=((IL-1)*NYI(LL)+(JL-1))*NZI(LL)+KK+NCBI
                  NN2=(N2-1)*3
!
! --- Locate the z'-level of the source cell in the super block
!
!   Note that the source cells are the out loop here.  Thus
!   the design of the program is slightly different from
!   the designs in routines MTRX_SPSS etc.
!
                  KKZ=INT((ZCELLI(KK,LL)+.5*SCZ-(ZSB-.5*SBZ))/SCZ+.2)
!
                  NCB=0
                  DO L=1,SUB_BLOCK
                     IF (L>1) NCB=NCB+NCELL(L-1)
                     DO K=1,NZ(L)
!
! --- Locate the z-level of the field cell in the super block
!
!   Note that the source cells are the out loop here.  Thus
!   the design of the program is slightly different from
!   the designs in routines MTRX_SPSS etc.
!
                        KZ=INT((Z(K,L)+.5*SCZ-(ZSB-.5*SBZ))/SCZ+.2)
!
                        DO I=1,NX(L)
                           DO J=1,NY(L)
                              NN=((I-1)*NY(L)+(J-1))*NZ(L)+K
                              N1=NN+NCB
                              NN1=(N1-1)*3
!
! --- Compute the elements for the 4 quarters
!
                              DO LQC=1,4
                              JJ=3*(LQC-1)
                              JJ1=JJ+1
                              JJ2=JJ+2
                              JJ3=JJ+3
                              IF (BX(LQC)>0.) THEN
                              XSR1=XCELLI(IL,LL)
                              ELSE
                              XSR1=-XCELLI(IL,LL)
                              ENDIF
                              IF (BY(LQC)>0.) THEN
                              YSR1=YCELLI(JL,LL)
                              ELSE
                              YSR1=-YCELLI(JL,LL)
                              ENDIF
!
                              DO LQR=1,4
                              II=3*(LQR-1)
                              II1=II+1
                              II2=II+2
                              II3=II+3
                              IF (BX(LQR)>0.) THEN
                              XOB1=X(I,L)
                              ELSE
                              XOB1=-X(I,L)
                              ENDIF
                              IF (BY(LQR)>0.) THEN
                              YOB1=Y(J,L)
                              ELSE
                              YOB1=-Y(J,L)
                              ENDIF
!
                              IF (LQC==1) THEN
!
! --- Evaluate the Green's functions by means of spatial symmetry
!   using pre-computed results
!
! --- Identify the relative cell location in the super blocks
!
!   Note that reciprocity is considered here
!
                              IF (KZ<=KKZ) THEN
                              DX=(XSR1-XOB1)/SCX
                              ELSE
                              DX=(XOB1-XSR1)/SCX
                              ENDIF
                              IF (DX>=0) IX=INT(DX+.2)+1
                              IF (DX<0) IX=INT(DX-.2)-1
                              IF (IX==-1) IX=1
!
                              IF (KZ<=KKZ) THEN
                              DY=(YSR1-YOB1)/SCY
                              ELSE
                              DY=(YOB1-YSR1)/SCY
                              ENDIF
                              IF (DY>=0) JY=INT(DY+.2)+1
                              IF (DY<0) JY=INT(DY-.2)-1
                              IF (JY==-1) JY=1
!
! --- Determine the values of the scattering matrix using the
!   symmetry properties of the Green's functions
!
!      IF(KZ.LE.KKZ) THEN
!           MZ=KKZ
!         ELSE
!           MZ=KZ
!       ENDIF
!
                              IF (IX>0.AND.JY>0) THEN
!
                              MX=IX
                              MY=JY
!
! --- Note that the order of the array GSB2 determined in the
!   routine GSB is different from that of the scattering matrix
!   formed here in this routine.  Check the routine GSB for
!   more explanations.
!
!   Note that if KZ.LE.KKZ then KZ controls the field cell levels.
!   otherwise KZZ controls the field cell levels..
!
                              IF (KZ<=KKZ) THEN
                              MM=((KKZ-KZ)*NYS+(MY-1))*NXS+MX
                              MM1=(3*NXS*NYS*(2*NZS-(KZ-2)))*(KZ-1)  &
                                 /2+(MM-1)*3+1
                              ELSE
                              MM=((KZ-KKZ)*NYS+(MY-1))*NXS+MX
                              MM1=(3*NXS*NYS*(2*NZS-(KKZ-2)))*(KKZ-1)  &
                                 /2+(MM-1)*3+1
                              ENDIF
                              MM2=MM1+1
                              MM3=MM1+2
!
                              IF (KZ>KKZ) THEN
!
!--- Use the reciprocity theorem
!
                              GE(II1,JJ1)=GSB2(MM1,1)
                              GE(II2,JJ1)=GSB2(MM1,2)
                              GE(II3,JJ1)=GSB2(MM1,3)
                              GE(II1,JJ2)=GSB2(MM2,1)
                              GE(II2,JJ2)=GSB2(MM2,2)
                              GE(II3,JJ2)=GSB2(MM2,3)
                              GE(II1,JJ3)=GSB2(MM3,1)
                              GE(II2,JJ3)=GSB2(MM3,2)
                              GE(II3,JJ3)=GSB2(MM3,3)
                              ELSE
!
                              GE(II1,JJ1)=GSB2(MM1,1)
                              GE(II2,JJ1)=GSB2(MM2,1)
                              GE(II3,JJ1)=GSB2(MM3,1)
                              GE(II1,JJ2)=GSB2(MM1,2)
                              GE(II2,JJ2)=GSB2(MM2,2)
                              GE(II3,JJ2)=GSB2(MM3,2)
                              GE(II1,JJ3)=GSB2(MM1,3)
                              GE(II2,JJ3)=GSB2(MM2,3)
                              GE(II3,JJ3)=GSB2(MM3,3)
                              ENDIF
                              CYCLE
!
                              ENDIF
!
                              IF (IX<0.AND.JY>0) THEN
!
                              MX=-IX
                              MY=JY
!
!   Note that if KZ.LE.KKZ then KZ controls the field cell levels.
!   otherwise KZZ controls the field cell levels..
!
                              IF (KZ<=KKZ) THEN
                              MM=((KKZ-KZ)*NYS+(MY-1))*NXS+MX
                              MM1=(3*NXS*NYS*(2*NZS-(KZ-2)))*(KZ-1)  &
                                 /2+(MM-1)*3+1
                              ELSE
                              MM=((KZ-KKZ)*NYS+(MY-1))*NXS+MX
                              MM1=(3*NXS*NYS*(2*NZS-(KKZ-2)))*(KKZ-1)  &
                                 /2+(MM-1)*3+1
                              ENDIF
                              MM2=MM1+1
                              MM3=MM1+2
!
                              IF (KZ>KKZ) THEN
!
!--- Use the reciprocity theorem
!
                              GE(II1,JJ1)=GSB2(MM1,1)
                              GE(II2,JJ1)=-GSB2(MM1,2)
                              GE(II3,JJ1)=-GSB2(MM1,3)
                              GE(II1,JJ2)=-GSB2(MM2,1)
                              GE(II2,JJ2)=GSB2(MM2,2)
                              GE(II3,JJ2)=GSB2(MM2,3)
                              GE(II1,JJ3)=-GSB2(MM3,1)
                              GE(II2,JJ3)=GSB2(MM3,2)
                              GE(II3,JJ3)=GSB2(MM3,3)
                              ELSE
!
                              GE(II1,JJ1)=GSB2(MM1,1)
                              GE(II2,JJ1)=-GSB2(MM2,1)
                              GE(II3,JJ1)=-GSB2(MM3,1)
                              GE(II1,JJ2)=-GSB2(MM1,2)
                              GE(II2,JJ2)=GSB2(MM2,2)
                              GE(II3,JJ2)=GSB2(MM3,2)
                              GE(II1,JJ3)=-GSB2(MM1,3)
                              GE(II2,JJ3)=GSB2(MM2,3)
                              GE(II3,JJ3)=GSB2(MM3,3)
                              ENDIF
                              CYCLE
!
                              ENDIF
!
                              IF (IX<0.AND.JY<0) THEN
!
                              MX=-IX
                              MY=-JY
!
!   Note that if KZ.LE.KKZ then KZ controls the field cell levels.
!   otherwise KZZ controls the field cell levels..
!
                              IF (KZ<=KKZ) THEN
                              MM=((KKZ-KZ)*NYS+(MY-1))*NXS+MX
                              MM1=(3*NXS*NYS*(2*NZS-(KZ-2)))*(KZ-1)  &
                                 /2+(MM-1)*3+1
                              ELSE
                              MM=((KZ-KKZ)*NYS+(MY-1))*NXS+MX
                              MM1=(3*NXS*NYS*(2*NZS-(KKZ-2)))*(KKZ-1)  &
                                 /2+(MM-1)*3+1
                              ENDIF
                              MM2=MM1+1
                              MM3=MM1+2
!
                              IF (KZ>KKZ) THEN
!
!--- Use the reciprocity theorem
!
                              GE(II1,JJ1)=GSB2(MM1,1)
                              GE(II2,JJ1)=GSB2(MM1,2)
                              GE(II3,JJ1)=-GSB2(MM1,3)
                              GE(II1,JJ2)=GSB2(MM2,1)
                              GE(II2,JJ2)=GSB2(MM2,2)
                              GE(II3,JJ2)=-GSB2(MM2,3)
                              GE(II1,JJ3)=-GSB2(MM3,1)
                              GE(II2,JJ3)=-GSB2(MM3,2)
                              GE(II3,JJ3)=GSB2(MM3,3)
                              ELSE
!
                              GE(II1,JJ1)=GSB2(MM1,1)
                              GE(II2,JJ1)=GSB2(MM2,1)
                              GE(II3,JJ1)=-GSB2(MM3,1)
                              GE(II1,JJ2)=GSB2(MM1,2)
                              GE(II2,JJ2)=GSB2(MM2,2)
                              GE(II3,JJ2)=-GSB2(MM3,2)
                              GE(II1,JJ3)=-GSB2(MM1,3)
                              GE(II2,JJ3)=-GSB2(MM2,3)
                              GE(II3,JJ3)=GSB2(MM3,3)
                              ENDIF
                              CYCLE
!
                              ENDIF
!
                              IF (IX>0.AND.JY<0) THEN
!
                              MX=IX
                              MY=-JY
!
!   Note that if KZ.LE.KKZ then KZ controls the field cell levels.
!   otherwise KZZ controls the field cell levels..
!
                              IF (KZ<=KKZ) THEN
                              MM=((KKZ-KZ)*NYS+(MY-1))*NXS+MX
                              MM1=(3*NXS*NYS*(2*NZS-(KZ-2)))*(KZ-1)  &
                                 /2+(MM-1)*3+1
                              ELSE
                              MM=((KZ-KKZ)*NYS+(MY-1))*NXS+MX
                              MM1=(3*NXS*NYS*(2*NZS-(KKZ-2)))*(KKZ-1)  &
                                 /2+(MM-1)*3+1
                              ENDIF
                              MM2=MM1+1
                              MM3=MM1+2
!
                              IF (KZ>KKZ) THEN
!
!--- Use the reciprocity theorem
!
                              GE(II1,JJ1)=GSB2(MM1,1)
                              GE(II2,JJ1)=-GSB2(MM1,2)
                              GE(II3,JJ1)=GSB2(MM1,3)
                              GE(II1,JJ2)=-GSB2(MM2,1)
                              GE(II2,JJ2)=GSB2(MM2,2)
                              GE(II3,JJ2)=-GSB2(MM2,3)
                              GE(II1,JJ3)=GSB2(MM3,1)
                              GE(II2,JJ3)=-GSB2(MM3,2)
                              GE(II3,JJ3)=GSB2(MM3,3)
                              ELSE
!
                              GE(II1,JJ1)=GSB2(MM1,1)
                              GE(II2,JJ1)=-GSB2(MM2,1)
                              GE(II3,JJ1)=GSB2(MM3,1)
                              GE(II1,JJ2)=-GSB2(MM1,2)
                              GE(II2,JJ2)=GSB2(MM2,2)
                              GE(II3,JJ2)=-GSB2(MM3,2)
                              GE(II1,JJ3)=GSB2(MM1,3)
                              GE(II2,JJ3)=-GSB2(MM2,3)
                              GE(II3,JJ3)=GSB2(MM3,3)
                              ENDIF
                              CYCLE
!
                              ENDIF
                              ENDIF
!
! --- Compute the elements of GE for LQC.NE.1 by
!   symmetry relations of the Green's functions.
!   In the following the spatial symmetry is used to
!   determine the Green's functions.  In some cases
!   the reciprocity thereom may also be used.  Note
!   that the reciprocity thereom is not always true
!   here unless the media are isotropic or the four
!   field cells and the four source cells locate in
!   a single anisotropic layer. For this reason the
!   use of the reciprocity thereom is avoid here.
!
!   The following parameters r(-i)(-j) etc. refer to
!   thos in Table 1 of Xiong and Tripp (1992)
!   (spatial symmetry reduction).
!
                              IF (LQC==1) THEN
                              ELSEIF (LQC==3) THEN
!
                              IF (LQR==2) THEN
!
! --- Equivalent to the results of r(-i)(-j).
!
!   May also use reciprocity.
!   II=3, JJ=6
                              GE(II1,JJ1)=GE(10,1)
                              GE(II2,JJ1)=GE(11,1)
                              GE(II3,JJ1)=-GE(12,1)
                              GE(II1,JJ2)=GE(10,2)
                              GE(II2,JJ2)=GE(11,2)
                              GE(II3,JJ2)=-GE(12,2)
                              GE(II1,JJ3)=-GE(10,3)
                              GE(II2,JJ3)=-GE(11,3)
!
                              GE(II3,JJ3)=GE(12,3)
                              ELSEIF (LQR==3) THEN
!
! --- Equivalent to the results of r(-i)(-j).
!
!   Note this is not a self-cell unless N1=N2.
!
!   II=JJ=6
                              GE(II1,JJ1)=GE(1,1)
                              GE(II2,JJ1)=GE(2,1)
                              GE(II3,JJ1)=-GE(3,1)
                              GE(II1,JJ2)=GE(1,2)
                              GE(II2,JJ2)=GE(2,2)
                              GE(II3,JJ2)=-GE(3,2)
                              GE(II1,JJ3)=-GE(1,3)
                              GE(II2,JJ3)=-GE(2,3)
!
                              GE(II3,JJ3)=GE(3,3)
                              ELSEIF (LQR==4) THEN
!
! --- Equivalent to the results of r(-i)(-j).
!
!   II=9, JJ=6.
                              GE(II1,JJ1)=GE(4,1)
                              GE(II2,JJ1)=GE(5,1)
                              GE(II3,JJ1)=-GE(6,1)
                              GE(II1,JJ2)=GE(4,2)
                              GE(II2,JJ2)=GE(5,2)
                              GE(II3,JJ2)=-GE(6,2)
                              GE(II1,JJ3)=-GE(4,3)
                              GE(II2,JJ3)=-GE(5,3)
!
                              GE(II3,JJ3)=GE(6,3)
                              ELSE
!
! --- Equivalent to the results of r(-i)(-j).
!   II=0, JJ=6
                              GE(II1,JJ1)=GE(7,1)
                              GE(II2,JJ1)=GE(8,1)
                              GE(II3,JJ1)=-GE(9,1)
                              GE(II1,JJ2)=GE(7,2)
                              GE(II2,JJ2)=GE(8,2)
                              GE(II3,JJ2)=-GE(9,2)
                              GE(II1,JJ3)=-GE(7,3)
                              GE(II2,JJ3)=-GE(8,3)
!
                              GE(II3,JJ3)=GE(9,3)
                              ENDIF
                              ELSEIF (LQC==4) THEN
!
                              IF (LQR==2) THEN
!
! --- Equivalent to  ri(-j) or the combination of
!   r(-i)j and r(-i)(-j).
!
!   II=3, JJ=9
                              GE(II1,JJ1)=GE(7,1)
                              GE(II2,JJ1)=-GE(8,1)
                              GE(II3,JJ1)=GE(9,1)
                              GE(II1,JJ2)=-GE(7,2)
                              GE(II2,JJ2)=GE(8,2)
                              GE(II3,JJ2)=-GE(9,2)
                              GE(II1,JJ3)=GE(7,3)
                              GE(II2,JJ3)=-GE(8,3)
!
                              GE(II3,JJ3)=GE(9,3)
                              ELSEIF (LQR==3) THEN
!
! --- Equivalent to the results of ri(-j).
!
!   II=6, JJ=9
                              GE(II1,JJ1)=GE(4,1)
                              GE(II2,JJ1)=-GE(5,1)
                              GE(II3,JJ1)=GE(6,1)
                              GE(II1,JJ2)=-GE(4,2)
                              GE(II2,JJ2)=GE(5,2)
                              GE(II3,JJ2)=-GE(6,2)
                              GE(II1,JJ3)=GE(4,3)
                              GE(II2,JJ3)=-GE(5,3)
!
                              GE(II3,JJ3)=GE(6,3)
                              ELSEIF (LQR==4) THEN
!
! --- Equivalent to the results of ri(-j).
!
!   Note this is not a self-cell unless N1=N2.
!
!   II=JJ=9
                              GE(II1,JJ1)=GE(1,1)
                              GE(II2,JJ1)=-GE(2,1)
                              GE(II3,JJ1)=GE(3,1)
                              GE(II1,JJ2)=-GE(1,2)
                              GE(II2,JJ2)=GE(2,2)
                              GE(II3,JJ2)=-GE(3,2)
                              GE(II1,JJ3)=GE(1,3)
                              GE(II2,JJ3)=-GE(2,3)
                              GE(II3,JJ3)=GE(3,3)
                              ELSE
!
! --- Equivalent to the results of ri(-j).
!
!   II=0, JJ=9.
                              GE(II1,JJ1)=GE(10,1)
                              GE(II2,JJ1)=-GE(11,1)
                              GE(II3,JJ1)=GE(12,1)
                              GE(II1,JJ2)=-GE(10,2)
                              GE(II2,JJ2)=GE(11,2)
                              GE(II3,JJ2)=-GE(12,2)
                              GE(II1,JJ3)=GE(10,3)
                              GE(II2,JJ3)=-GE(11,3)
!
                              GE(II3,JJ3)=GE(12,3)
                              ENDIF
!
                              ELSEIF (LQR==2) THEN
!
! --- Equivalent to the results of r(-i)j.
!
!   Note this is not a self-cell unless N1=N2.
!
!   II=JJ=3
                              GE(II1,JJ1)=GE(1,1)
                              GE(II2,JJ1)=-GE(2,1)
                              GE(II3,JJ1)=-GE(3,1)
                              GE(II1,JJ2)=-GE(1,2)
                              GE(II2,JJ2)=GE(2,2)
                              GE(II3,JJ2)=GE(3,2)
                              GE(II1,JJ3)=-GE(1,3)
                              GE(II2,JJ3)=GE(2,3)
!
                              GE(II3,JJ3)=GE(3,3)
                              ELSEIF (LQR==3) THEN
!
! --- Equivalent to the results of r(-i)j.
!
!   II=6, JJ=3
                              GE(II1,JJ1)=GE(10,1)
                              GE(II2,JJ1)=-GE(11,1)
                              GE(II3,JJ1)=-GE(12,1)
                              GE(II1,JJ2)=-GE(10,2)
                              GE(II2,JJ2)=GE(11,2)
                              GE(II3,JJ2)=GE(12,2)
                              GE(II1,JJ3)=-GE(10,3)
                              GE(II2,JJ3)=GE(11,3)
!
                              GE(II3,JJ3)=GE(12,3)
                              ELSEIF (LQR==4) THEN
!
! --- Equivalent to r(-i)j or the combination of
!   ri(-j) and r(-i)(-j).
!   II=9, JJ=3
                              GE(II1,JJ1)=GE(7,1)
                              GE(II2,JJ1)=-GE(8,1)
                              GE(II3,JJ1)=-GE(9,1)
                              GE(II1,JJ2)=-GE(7,2)
                              GE(II2,JJ2)=GE(8,2)
                              GE(II3,JJ2)=GE(9,2)
                              GE(II1,JJ3)=-GE(7,3)
                              GE(II2,JJ3)=GE(8,3)
!
                              GE(II3,JJ3)=GE(9,3)
                              ELSE
!
! --- Equivalent to the results of r(-i)j.
!
!   In the following 9 lines II=0, JJ=3
                              GE(II1,JJ1)=GE(4,1)
                              GE(II2,JJ1)=-GE(5,1)
                              GE(II3,JJ1)=-GE(6,1)
                              GE(II1,JJ2)=-GE(4,2)
                              GE(II2,JJ2)=GE(5,2)
                              GE(II3,JJ2)=GE(6,2)
                              GE(II1,JJ3)=-GE(4,3)
                              GE(II2,JJ3)=GE(5,3)
!
                              GE(II3,JJ3)=GE(6,3)
                              ENDIF
!
                              ENDDO
                              ENDDO
!
! --- Transform the above elements of the scattering matrix
!   by the unitary matrix, U*Z*UT
!
!   Note that the total number of cells in one quarter and
!   the cell number as required by the parameters PMAX, PR
!   and PC in the routine unitary are not important here
!   as long as PR=PC, since the parameters IROW and JCOL
!   are of no use in the routine
!
!-- The parameter LQ controls the contributions to the four
!   block matrices.  LQ need be passed into this routine.
!
                              DO II=1,3
                              DO JJ=1,3
                              AA(JJ,II)=(0.,0.)
                              ENDDO
                              ENDDO
!
                              DO LQR=1,4
                              NQR=3*(LQR-1)
                              DO II=1,3
! --               PMAX=1
                              CALL MTRX_UNITARY(1,LQ,II,1,LQR,II,UR(II))
                              ENDDO
                              DO LQC=1,4
                              NQC=3*(LQC-1)
                              IF (LQR==1) THEN
                              DO JJ=1,3
! --                 PMAX=1
                              CALL MTRX_UNITARY(1,LQ,JJ,1,LQC,JJ,UC(JJ,LQC))
                              ENDDO
                              ENDIF
!
                              DO JJ=1,3
                              DO II=1,3
!
! --- Not that the values of UR and UC are either +.5 or -.5
!
                              IF (UR(II)<0) THEN
                              IF (UC(JJ,LQC)>=0) THEN
                              GOTO 2
                              ENDIF
                              ELSEIF (UC(JJ,LQC)<=0) THEN
                              GOTO 2
                              ENDIF
!
                              AA(II,JJ)=AA(II,JJ)+GE(NQR+II,NQC+JJ)
                              CYCLE
    2                         AA(II,JJ)=AA(II,JJ)-GE(NQR+II,NQC+JJ)
!
                              ENDDO
                              ENDDO
                              ENDDO
                              ENDDO
!
! ---  The sign of G is reversed
!
                              DO JJ=1,3
                              DO II=1,3
                              G(NN1+II,NN2+JJ)=-.25*AA(II,JJ)
                              ENDDO
                              ENDDO
!
                           ENDDO
                        ENDDO
                     ENDDO
                  ENDDO
               ENDDO
            ENDDO
         ENDDO
      ENDDO
!
      RETURN
      END
!
!
! This routine factors a square matrix by either LU or UDUT
! decomposition. The condition numbers of the matrix calculated
! by the maxmal column norm and maximal row norm will be
! returned if kcond=1. KSYM controls if whether the matrix is
! symmetric or not. This routine also returns the maxmal column
! and maximal row norms of the original matrix, anorm1 and
! anorm3, which would be useful for analysing the accuracy of
! the oringinal matrix (A) computed with different accuracy
! levels. The condition numbers may serve the same
! purpose better since they are functions of the matrix norms
! as well as the condition numbers themselves.  The routine
! also returns the maximal diagonal element of the matrix which
! should also be the maximal element of the matrix
!
      SUBROUTINE MTRX_SLV_FACTOR(NW,A,NMAX,N,IND,V,C1,AI,KSYM,         &
                                 KCOND,ANORM1,ANORM3,COND1,COND3,AEM)
!
      IMPLICIT NONE
!
      INTEGER NW
      REAL AEM,AINRM1,AINRM3,ANORM1,ANORM3,COND1,COND3,DD
      INTEGER I,INFO,J,JJ,KCOND,KSYM,N,NMAX
      COMPLEX A(NMAX,N),C1(N)
      INTEGER IND(N)
      REAL  V(N),AI(N)
      DOUBLE PRECISION AM
!
! --- Compute the norms of A
!
      IF (KCOND==1) THEN
!
! --- Maximal column norm (l_1 norm):
         ANORM1=0.
         AEM=0.
         DO J=1,N
!
! ---   Compute the maximal diagonal element
!
            AEM=AMAX1(AEM,CABS(A(J,J)))
!
            AM=0.D0
            DO I=1,N
               AM=AM+CABS(A(I,J))
            ENDDO
            ANORM1=AMAX1(ANORM1,SNGL(AM))
         ENDDO
!
! --- Maximal row norm (l_infinity norm):
         ANORM3=0.
         DO I=1,N
            AM=0.D0
            DO J=1,N
               AM=AM+CABS(A(I,J))
            ENDDO
            ANORM3=AMAX1(ANORM3,SNGL(AM))
         ENDDO
      ENDIF
!
! ---- Performing UDUT or LU decompistion
!
      IF (KSYM==1) THEN
         CALL MTRX_SLV_CSIFA(A,NMAX,N,IND,INFO)
      ELSE
         CALL MTRX_SLV_LUDCMP(NW,A,NMAX,N,IND,V,DD)
      ENDIF
!
! ----  Compute the norm of inverse A
!
      IF (KCOND/=0) THEN
         AINRM1=0.
         DO I=1,N
            AI(I)=0.
         ENDDO
!
         DO J=1,N
!
            DO JJ=1,N
               C1(JJ)=(0.,0.)
            ENDDO
            C1(J)=(1.,0.)
!
! --- Compute the column of the inverse of A
            IF (KSYM==1) THEN
               CALL MTRX_SLV_CSISL(A,NMAX,N,IND,C1)
            ELSE
               CALL MTRX_SLV_LUBKSB(A,C1,NMAX,N,IND)
            ENDIF
!
! ---- Calculate the maximal column norm
            AM=0.D0
            DO I=1,N
               AM=AM+CABS(C1(I))
            ENDDO
            AINRM1=AMAX1(AINRM1,SNGL(AM))
!
! ---- Calculate the row norms
            DO I=1,N
               AI(I)=AI(I)+CABS(C1(I))
            ENDDO
         ENDDO
!
! --- Compute the maximal row norm of inverse A
         AINRM3=0.
         DO I=1,N
            AINRM3=AMAX1(AINRM3,AI(I))
         ENDDO
!
! Determine the condition number
!
         COND1=ANORM1*AINRM1
         COND3=ANORM3*AINRM3
      ENDIF
      RETURN
      END
!
!
!           LU matrix decomposition
!  (Source: Press et al., Numerical recipes)
!
      SUBROUTINE MTRX_SLV_LUDCMP(NW,A,NP,N,INDEX,VV,D)
!
      IMPLICIT NONE
!
      INTEGER NW
      REAL AAMAX,D,DUM,TINY
      INTEGER I,IMAX,J,K,N,NP
      COMPLEX A(NP,NP),SUM,T
      REAL VV(N)
      INTEGER INDEX(N)
      PARAMETER (TINY=1.E-30)
      D=1.
      DO I=1,N
         AAMAX=0.
         DO J=1,N
            IF (CABS(A(I,J))>AAMAX) AAMAX=CABS(A(I,J))
         ENDDO
         IF (ABS(AAMAX)<TINY) THEN
            WRITE (NW,'(A)') 'Singular matrix'
            STOP 'Singular matrix'
         ENDIF
         VV(I)=1./AAMAX
      ENDDO
      DO J=1,N
         DO I=1,J-1
            SUM=A(I,J)
            DO K=1,I-1
               SUM=SUM-A(I,K)*A(K,J)
            ENDDO
            A(I,J)=SUM
         ENDDO
         AAMAX=0.
         DO I=J,N
            SUM=A(I,J)
            DO K=1,J-1
               SUM=SUM-A(I,K)*A(K,J)
            ENDDO
            A(I,J)=SUM
            DUM=VV(I)*CABS(SUM)
            IF (DUM>=AAMAX) THEN
               IMAX=I
               AAMAX=DUM
            ENDIF
         ENDDO
         IF (J/=IMAX) THEN
            DO K=1,N
               T=A(IMAX,K)
               A(IMAX,K)=A(J,K)
               A(J,K)=T
            ENDDO
            D=-D
            VV(IMAX)=VV(J)
         ENDIF
         INDEX(J)=IMAX
         IF (CABS(A(J,J))<TINY) A(J,J)=cmplx(TINY,0.)
         IF (J/=N) THEN
            T=1./A(J,J)
            DO I=J+1,N
               A(I,J)=A(I,J)*T
            ENDDO
         ENDIF
      ENDDO
      RETURN
      END
!
!
!  Solving linear equations by LU decomposition: backsubstitution
!  (Source: Press et al., Numerical recipes)
!
      SUBROUTINE MTRX_SLV_LUBKSB(A,B,NP,N,INDEX)
!
      IMPLICIT NONE
!
      INTEGER I,II,J,LL,N,NP
      REAL TINY
      COMPLEX A(NP,NP),B(N),SUM
      INTEGER INDEX(N)
      PARAMETER (TINY=1.E-30)
      II=0
      DO I=1,N
         LL=INDEX(I)
         SUM=B(LL)
         B(LL)=B(I)
         IF (II/=0) THEN
            DO J=II,I-1
               SUM=SUM-A(I,J)*B(J)
            ENDDO
         ELSEIF (CABS(SUM)>TINY) THEN
            II=I
         ENDIF
         B(I)=SUM
      ENDDO
      DO I=N,1,-1
         SUM=B(I)
         IF (I<N) THEN
            DO J=I+1,N
               SUM=SUM-A(I,J)*B(J)
            ENDDO
         ENDIF
         B(I)=SUM/A(I,I)
      ENDDO
      RETURN
      END
!
!
!   UDUT DECOMPSTION OF A SYMMETRICAL INDEFINITE COMPLEX MATRIX
!
!  (Source: Dongarra et al., Linpack user' guide)
!
      SUBROUTINE MTRX_SLV_CSIFA(A,LDA,N,KPVT,INFO)
!
      IMPLICIT NONE
!
      REAL ABSAKK,ALPHA,COLMAX,ROWMAX,TINY
      INTEGER IMAX,IMAXP1,INFO,ISAMAX,J,JJ,JMAX,K,KM1,KM2,KSTEP,LDA,N
      COMPLEX  A(LDA,N),T,MULK,MULKM1,AK,AKM1,DENOM,BK,BKM1
      INTEGER KPVT(N)
      LOGICAL SWAP
      PARAMETER (TINY=1.E-30)
!
      ALPHA=(1.+SQRT(17.))/8.
      INFO=0
!
      K=N
!
  100 IF (K/=0) THEN
         IF (K>1) THEN
!
            KM1=K-1
            ABSAKK=CABS(A(K,K))
!
            IMAX=ISAMAX(K-1,A(1,K),1)
            COLMAX=CABS(A(IMAX,K))
            IF (ABSAKK<ALPHA*COLMAX) THEN
!
               ROWMAX=0.
               IMAXP1=IMAX+1
               DO J=IMAXP1,K
                  ROWMAX=AMAX1(ROWMAX,CABS(A(IMAX,J)))
               ENDDO
               IF (IMAX/=1) THEN
                  JMAX=ISAMAX(IMAX-1,A(1,IMAX),1)
                  ROWMAX=AMAX1(ROWMAX,CABS(A(JMAX,IMAX)))
               ENDIF
               IF (CABS(A(IMAX,IMAX))>=ALPHA*ROWMAX) THEN
                  KSTEP=1
                  SWAP=.TRUE.
               ELSEIF (ABSAKK<ALPHA*COLMAX*(COLMAX/ROWMAX)) THEN
                  KSTEP=2
                  SWAP=IMAX/=KM1
               ELSE
                  KSTEP=1
                  SWAP=.FALSE.
               ENDIF
            ELSE
               KSTEP=1
               SWAP=.FALSE.
            ENDIF
            IF (ABS(AMAX1(ABSAKK,COLMAX))<=TINY) THEN
!
               KPVT(K)=K
               INFO=K
            ELSEIF (KSTEP==2) THEN
!
               IF (SWAP) THEN
!
                  CALL MTRX_SLV_SSWAP(IMAX,A(1,IMAX),1,A(1,K-1),1)
                  DO JJ=IMAX,KM1
                     J=KM1+IMAX-JJ
                     T=A(J,K-1)
                     A(J,K-1)=A(IMAX,J)
                     A(IMAX,J)=T
                  ENDDO
                  T=A(K-1,K)
                  A(K-1,K)=A(IMAX,K)
                  A(IMAX,K)=T
               ENDIF
!
               KM2=K-2
               IF (KM2/=0) THEN
                  AK=A(K,K)/A(K-1,K)
                  AKM1=A(K-1,K-1)/A(K-1,K)
                  DENOM=(1.,0.)-AK*AKM1
                  DO JJ=1,KM2
                     J=KM1-JJ
                     BK=A(J,K)/A(K-1,K)
                     BKM1=A(J,K-1)/A(K-1,K)
                     MULK=(AKM1*BK-BKM1)/DENOM
                     MULKM1=(AK*BKM1-BK)/DENOM
                     T=MULK
                     CALL MTRX_SLV_SAXPY(J,T,A(1,K),1,A(1,J),1)
                     T=MULKM1
                     CALL MTRX_SLV_SAXPY(J,T,A(1,K-1),1,A(1,J),1)
                     A(J,K)=MULK
                     A(J,K-1)=MULKM1
                  ENDDO
               ENDIF
!
               KPVT(K)=1-K
               IF (SWAP) KPVT(K)=-IMAX
               KPVT(K-1)=KPVT(K)
            ELSE
!
               IF (SWAP) THEN
!
                  CALL MTRX_SLV_SSWAP(IMAX,A(1,IMAX),1,A(1,K),1)
                  DO JJ=IMAX,K
                     J=K+IMAX-JJ
                     T=A(J,K)
                     A(J,K)=A(IMAX,J)
                     A(IMAX,J)=T
                  ENDDO
               ENDIF
!
               DO JJ=1,KM1
                  J=K-JJ
                  MULK=-A(J,K)/A(K,K)
                  T=MULK
                  CALL MTRX_SLV_SAXPY(J,T,A(1,K),1,A(1,J),1)
                  A(J,K)=MULK
               ENDDO
!
               KPVT(K)=K
               IF (SWAP) KPVT(K)=IMAX
            ENDIF
            K=K-KSTEP
            GOTO 100
         ELSE
            KPVT(1)=1
!
            IF (CABS(A(1,1))<TINY) INFO=1
         ENDIF
      ENDIF
      RETURN
      END
!
!
! SOLVING LINEAR EQUATION BY BACKSUBSTITUTE USING UDUT DECOMPSTION
!
      SUBROUTINE MTRX_SLV_CSISL(A,LDA,N,KPVT,B)
!
      IMPLICIT NONE
!
      INTEGER K,KP,LDA,N
      COMPLEX A(LDA,N),B(N),TEMP,AK,AKM1,BK,BKM1,DENOM,SDOT
      INTEGER KPVT(N)
!
      K=N
  100 IF (K==0) THEN
!
         K=1
  150    IF (K<=N) THEN
            IF (KPVT(K)<0) THEN
!
               IF (K/=1) THEN
!
                  B(K)=B(K)+SDOT(K-1,A(1,K),1,B(1),1)
                  B(K+1)=B(K+1)+SDOT(K-1,A(1,K+1),1,B(1),1)
                  KP=IABS(KPVT(K))
                  IF (KP/=K) THEN
!
                     TEMP=B(K)
                     B(K)=B(KP)
                     B(KP)=TEMP
                  ENDIF
               ENDIF
               K=K+2
            ELSE
!
               IF (K/=1) THEN
!
                  B(K)=B(K)+SDOT(K-1,A(1,K),1,B(1),1)
                  KP=KPVT(K)
                  IF (KP/=K) THEN
!
                     TEMP=B(K)
                     B(K)=B(KP)
                     B(KP)=TEMP
                  ENDIF
               ENDIF
               K=K+1
            ENDIF
            GOTO 150
         ENDIF
      ELSE
         IF (KPVT(K)<0) THEN
!
            IF (K/=2) THEN
               KP=IABS(KPVT(K))
               IF (KP/=K-1) THEN
!
                  TEMP=B(K-1)
                  B(K-1)=B(KP)
                  B(KP)=TEMP
               ENDIF
!
               CALL MTRX_SLV_SAXPY(K-2,B(K),A(1,K),1,B(1),1)
               CALL MTRX_SLV_SAXPY(K-2,B(K-1),A(1,K-1),1,B(1),1)
            ENDIF
!
            AK=A(K,K)/A(K-1,K)
            AKM1=A(K-1,K-1)/A(K-1,K)
            BK=B(K)/A(K-1,K)
            BKM1=B(K-1)/A(K-1,K)
            DENOM=AK*AKM1-(1.,0.)
            B(K)=(AKM1*BK-BKM1)/DENOM
            B(K-1)=(AK*BKM1-BK)/DENOM
            K=K-2
         ELSE
!
            IF (K/=1) THEN
               KP=KPVT(K)
               IF (KP/=K) THEN
!
                  TEMP=B(K)
                  B(K)=B(KP)
                  B(KP)=TEMP
               ENDIF
!
               CALL MTRX_SLV_SAXPY(K-1,B(K),A(1,K),1,B(1),1)
            ENDIF
!
            B(K)=B(K)/A(K,K)
            K=K-1
         ENDIF
         GOTO 100
      ENDIF
      RETURN
      END
!
!
!    BLA LISTINGS OF LINPACK
!
!
! ISAMAX
!
      INTEGER FUNCTION ISAMAX(N,SX,INCX)
      INTEGER I,INCX,IX,N
      REAL SMAX
      COMPLEX SX(N)
!
      ISAMAX=0
      IF (N<1) THEN
         RETURN
      ENDIF
      ISAMAX=1
      IF (N==1) THEN
         RETURN
      ENDIF
      IF (INCX/=1) THEN
!
         IX=1
         SMAX=CABS(SX(1))
         IX=IX+INCX
         DO I=2,N
            IF (CABS(SX(IX))>SMAX) THEN
               ISAMAX=I
               SMAX=CABS(SX(IX))
            ENDIF
            IX=IX+INCX
         ENDDO
         RETURN
      ENDIF
!
      SMAX=CABS(SX(1))
      DO I=2,N
         IF (CABS(SX(I))>SMAX) THEN
            ISAMAX=I
            SMAX=CABS(SX(I))
         ENDIF
      ENDDO
      RETURN
      END
!
!
      SUBROUTINE MTRX_SLV_SAXPY(N,SA,SX,INCX,SY,INCY)
!
!**** SAXPY
!
      IMPLICIT NONE
!
      INTEGER I,INCX,INCY,IX,IY,M,MP1,N
      REAL TINY
       COMPLEX SX(N),SY(N),SA
       PARAMETER (TINY=1.E-30)
!
      IF (N<=0) THEN
         RETURN
      ENDIF
      IF (CABS(SA)<TINY) THEN
         RETURN
      ENDIF
      IF (INCX==1.AND.INCY==1) THEN
!
         M=MOD(N,4)
         IF (M/=0) THEN
            DO I=1,M
               SY(I)=SY(I)+SA*SX(I)
            ENDDO
            IF (N<4) THEN
               RETURN
            ENDIF
         ENDIF
      ELSE
!
         IX=1
         IY=1
         IF (INCX<0) IX=(-N+1)*INCX+1
         IF (INCY<0) IY=(-N+1)*INCY+1
         DO I=1,N
            SY(IY)=SY(IY)+SA*SX(IX)
            IX=IX+INCX
            IY=IY+INCY
         ENDDO
         RETURN
      ENDIF
      MP1=M+1
      DO I=MP1,N,4
         SY(I)=SY(I)+SA*SX(I)
         SY(I+1)=SY(I+1)+SA*SX(I+1)
         SY(I+2)=SY(I+2)+SA*SX(I+2)
         SY(I+3)=SY(I+3)+SA*SX(I+3)
      ENDDO
      RETURN
      END
!
! SDOT
!
      COMPLEX FUNCTION SDOT(N,SX,INCX,SY,INCY)
      INTEGER I,INCX,INCY,IX,IY,M,MP1,N
      COMPLEX SX(N),SY(N),STEMP
!
      STEMP=(0.,0.)
      SDOT=(0.,0.)
      IF (N==0) THEN
         RETURN
      ENDIF
      IF (INCX==1.AND.INCY==1) THEN
!
         M=MOD(N,5)
         IF (M/=0) THEN
            DO I=1,M
               STEMP=STEMP+SX(I)*SY(I)
            ENDDO
            IF (N<5) THEN
               GOTO 100
            ENDIF
         ENDIF
         MP1=M+1
         DO I=MP1,N,5
            STEMP=STEMP+SX(I)*SY(I)+SX(I+1)*SY(I+1)+SX(I+2)*SY(I+2)  &
                  +SX(I+3)*SY(I+3)+SX(I+4)*SY(I+4)
         ENDDO
      ELSE
!
         IX=1
         IY=1
         IF (INCX<0) IX=(-N+1)*INCX+1
         IF (INCY<0) IY=(-N+1)*INCY+1
         DO I=1,N
            STEMP=STEMP+SX(IX)*SY(IY)
            IX=IX+INCX
            IY=IY+INCY
         ENDDO
         SDOT=STEMP
         RETURN
      ENDIF
  100 SDOT=STEMP
      RETURN
      END
!
! MTRX_SLV_SSWAP
!
      SUBROUTINE MTRX_SLV_SSWAP(N,SX,INCX,SY,INCY)
!
      IMPLICIT NONE
!
      INTEGER I,INCX,INCY,IX,IY,M,MP1,N
      COMPLEX SX(N),SY(N),STEMP
!
      IF (N<=0) THEN
         RETURN
      ENDIF
      IF (INCX==1.AND.INCY==1) THEN
!
         M=MOD(N,3)
         IF (M/=0) THEN
            DO I=1,M
               STEMP=SX(I)
               SX(I)=SY(I)
               SY(I)=STEMP
            ENDDO
            IF (N<3) THEN
               RETURN
            ENDIF
         ENDIF
      ELSE
!
         IX=1
         IY=1
         IF (INCX<0) IX=(-N+1)*INCX+1
         IF (INCY<0) IY=(-N+1)*INCY+1
         DO I=1,N
            STEMP=SX(IX)
            SX(IX)=SY(IY)
            SY(IY)=STEMP
            IX=IX+INCX
            IY=IY+INCY
         ENDDO
         RETURN
      ENDIF
      MP1=M+1
      DO I=MP1,N,3
         STEMP=SX(I)
         SX(I)=SY(I)
         SY(I)=STEMP
         STEMP=SX(I+1)
         SX(I+1)=SY(I+1)
         SY(I+1)=STEMP
         STEMP=SX(I+2)
         SX(I+2)=SY(I+2)
         SY(I+2)=STEMP
      ENDDO
      RETURN
      END
!
!
      SUBROUTINE MTRX_UNITARY (PR,QR,I,PC,QC,J,U)
!
!****  Unitary matrix that block diagonalize the scattering matrix
!
!   The routine compute the values of the unitary matrix according
!   to the position of the cell PR (for rows) and PC (for columns)
!   in sequential order in the first quadrant, the quadrant numbers
!   QR (for the rows) and QC (for the columns), and the component
!   numbers I (for the rows) and J (for the columns).  It returns
!   value of the matrix element U corresponding to the matrix row
!   number IROW and matrix column number JCOL (not computed for
!   efficience.  They are determined in the calling routines)
!   The total number of the cells in a quadrant, PMAX will be needed
!   to compute IROW and JCOL.
!
      IMPLICIT NONE
!
      INTEGER PR,PC,QR,QC,I,J
      REAL U
!
!    IF ( QR.GT.4 .OR.
!   +     QC.GT.4 .OR.
!   +      I.GT.3 .OR.
!   +      J.GT.3 )    STOP 'Error: parameters out of bound!'
!
! --- IROW and JCOL are computed where needed.  Therefore, in order
!   to save computation time, they are not computed here.
!
!    IROW=3*PMAX*(QR-1)+3*(PR-1)+I
!    JCOL=12*(PC-1)+3*(QC-1)+J
!
      IF (I/=J.OR.PR/=PC) THEN
         U=0.
         RETURN
      ENDIF
!
! --- Form I, I1, I2, and I3 according to QC.
!   Note that I=J
!
      IF (QC==2) THEN
         IF (I==2.OR.I==3) THEN
            U=.5
         ELSE
            U=-.5
         ENDIF
      ELSEIF (QC==3) THEN
!
         IF (I==3) THEN
            U=.5
         ELSE
            U=-.5
         ENDIF
      ELSEIF (QC==4) THEN
!
         IF (I==2) THEN
            U=-.5
         ELSE
            U=.5
         ENDIF
      ELSE
!
         U=.5
      ENDIF
!
      IF (QR==2) THEN
!
         IF (QC==2) THEN
            U=-U
            RETURN
         ELSEIF (QC==3) THEN
            RETURN
         ELSEIF (QC==4) THEN
            U=-U
            RETURN
         ELSE
            RETURN
         ENDIF
      ELSEIF (QR==3) THEN
!
         IF (QC==2) THEN
            RETURN
         ELSEIF (QC==3) THEN
            U=-U
            RETURN
         ELSEIF (QC==4) THEN
            U=-U
            RETURN
         ELSE
            RETURN
         ENDIF
      ELSEIF (QR==4) THEN
!
         IF (QC==2) THEN
            U=-U
            RETURN
         ELSEIF (QC==3) THEN
            U=-U
            RETURN
         ELSEIF (QC/=4) THEN
            RETURN
         ENDIF
      ELSE
!
         RETURN
      ENDIF
      RETURN
!
      END
!
!
!===== Subroutines for the right hand side of the matrix equation
!
      SUBROUTINE EN_PRM(FRQ,MLAYER,ZBND,LRYTH,KKH,CDH,         &
                        NET,SUB_BLOCK,NSUBCM,NZMAX,NX,NY,NZ,   &
                        NCELL,ZCELL,CDB,KPOL,EN,ECD)
!
!*****   Form the exciting right hand side term
!
      IMPLICIT NONE
!
      REAL FRQ
      INTEGER I,IOB,J,K,KPOL,L,MLAYER,SUB_BLOCK,NEB,NET,NN,NN1,NOBSV,   &
              NSUBCM,NZMAX
!
!**** Form the right hand side of the matrix equation,  or the
!   incident fields at cell centers.
!
      COMPLEX EN(NET),ECD(NET),EX,EY,HX,HY,DELTCD,                     &
              CDH(0:MLAYER),KKH(0:MLAYER),CDB(NSUBCM,SUB_BLOCK)
      INTEGER NX(SUB_BLOCK),NY(SUB_BLOCK),NZ(SUB_BLOCK),NCELL(SUB_BLOCK)
      REAL  ZCELL(NZMAX,SUB_BLOCK),ZBND(0:MLAYER),LRYTH(MLAYER)
!
      NEB=0
      DO L=1,SUB_BLOCK
         IF (L>1) NEB=NEB+3*NCELL(L-1)
         DO K=1,NZ(L)
            DO IOB=MLAYER-1,0,-1
               IF (ZCELL(K,L)>=ZBND(IOB)) THEN
                  NOBSV=IOB+1
                  GOTO 20
               ENDIF
            ENDDO
            NOBSV=0
   20       CALL EN_PRM_MT(FRQ,MLAYER,ZBND,LRYTH,KKH,NOBSV,ZCELL(K,L),   &
                           EX,EY,HX,HY)
            DO I=1,NX(L)
               DO J=1,NY(L)
                  NN=(I-1)*NY(L)*NZ(L)+(J-1)*NZ(L)+K
                  NN1=(NN-1)*3+1+NEB
                  IF (KPOL==1) THEN
                     EX=(0.,0.)
                  ELSE
                     EY=(0.,0.)
                  ENDIF
                  EN(NN1)=EX
                  EN(NN1+1)=EY
                  EN(NN1+2)=(0.,0.)
                  DELTCD=CDB(NN,L)-CDH(NOBSV)
                  ECD(NN1)=EX*DELTCD
                  ECD(NN1+1)=EY*DELTCD
                  ECD(NN1+2)=(.0,.0)
               ENDDO
            ENDDO
         ENDDO
      ENDDO
      RETURN
      END
!
!**** End of EN_PRM
!
!
!    EM FIELDS IN STRATIFIED MEDIA INCITED BY A PLANE WAVE
!
      SUBROUTINE EN_PRM_MT(FRQ,MLAYER,ZBND,LRYTH,KKH,NOBSV,ZOB,EX,EY,HX,HY)
!
      IMPLICIT NONE
!
      INTEGER MLAYER,NOBSV
      INTEGER J,LAYERM
!
      REAL  FRQ,ZOB,LRYTH(MLAYER),ZBND(0:MLAYER)
!
!-- Parameter LAYERM must have a value greater than or equal to
!   that in the main program
!
      PARAMETER (LAYERM=200)

      COMPLEX NU(0:LAYERM),Z(LAYERM),A(0:LAYERM),   &
                 B(0:LAYERM),C1,C2,C3,C4
      COMPLEX EX,EY,HX,HY,KKH(0:MLAYER),W,K(0:LAYERM)
!
      W=CMPLX(0.,78.9568352E-7*FRQ)
      DO J=0,MLAYER
         K(J)=CSQRT(KKH(J))
         NU(J)=W/K(J)
      ENDDO
!
! ----  A(0) so chosen that the normal incident h-filed has a
!     magnitude of  1 (a/m) in the case of h-polarisation
!
      A(0)=-NU(0)
      Z(MLAYER)=NU(MLAYER)
      IF (MLAYER>1) THEN
         DO J=MLAYER-1,1,-1
            C1=CEXP(-2.*K(J)*LRYTH(J))
            C1=((1.,0.)-C1)/((1.,0.)+C1)
            Z(J)=NU(J)*(Z(J+1)+NU(J)*C1)/(NU(J)+Z(J+1)*C1)
         ENDDO
      ENDIF
      B(0)=(Z(1)+NU(0))/(Z(1)-NU(0))*A(0)
      IF (NOBSV<=0) THEN
         EX=A(0)+B(0)
         HY=(B(0)-A(0))/NU(0)
!
! Note that EY and HX are so chosen that hy is positive
!
         EY=-EX
         HX=HY
      ELSE
         C1=(1.0,0.0)
         C2=(1.0,0.0)
         C3=(0.0,0.0)
         DO J=1,NOBSV

            IF (CABS(NU(MLAYER)-NU(MLAYER-1))>=1.E-30.OR.J==MLAYER) THEN
               C1=C1*(Z(J)-NU(J))/(Z(J)-NU(J-1))
               C2=C2*(Z(J)+NU(J))/(Z(J)+NU(J-1))
               C3=C3+(K(J-1)-K(J))*ZBND(J-1)
            ENDIF
         ENDDO
         IF (NOBSV==MLAYER) THEN

            C4=(0.,0.)
         ELSE

            C4=CEXP(C3+K(NOBSV)*ZOB)
         ENDIF

         C3=CEXP(-C3-K(NOBSV)*ZOB)
         EX=A(0)*C1*C4+B(0)*C2*C3
         HY=-(A(0)*C1*C4-B(0)*C2*C3)/NU(NOBSV)
         EY=-EX
         HX=HY
      ENDIF
!
      RETURN
      END
!
!**** End of EN_PRM_MT
!
!
      SUBROUTINE EN_PRM_CS(NET,SUB_BLOCK,NSUBCM,NXMAX,NYMAX,            &
                           NZMAX,NX,NY,NZ,NCELL,XCELL,YCELL,ZCELL,      &
                           CDB,CS_TYPE,NCRD,TX_CRDX,TX_CRDY,TX_CRDZ,    &
                           RAD,EN,ECD,FRQ,MLAYER,ZBND,KKH,CDH,ANGLES,   &
                           KEYG,KACC,AJ,NZOB,ZOBG,NZSR,ZSRG,            &
                           RHOMIN,NHFILM,RRG,NRG,GRHF,GRHO0)
!
!**** Form the right hand side of the matrix equation,  or the
!   incident fields at cell centers for controlled source problems.
!
!   Note that this routine computes the incident fields in
!   one substructure only,  and thus all the parameters like
!   NX,  XCELL,  etc are defined for one substructure only.
!   (They are represented by NXI,  XCELLI etc. in the main program)
!
!   Parameters  KEYG, KACC, AJ, NZOB, ZOBG, NZSR, ZSRG,
!   RHOMIN, NHFILM, RRG, NRG, GRHF, and GRHO0 are to be
!   passed into routine ONE_D_SOURCE.
!
!
      IMPLICIT NONE
!
      REAL AJ,FRQ,RAD,RHOMIN
      INTEGER I,IOB,J,K,KACC,KEYG,CS_TYPE,L,MLAYER,SUB_BLOCK,NEB,NET,   &
              NHFILM,NN,NN1,NOBSV,NRG,NSUBCM,NXMAX,NCRD
      INTEGER NYMAX,NZMAX,NZOB,NZSR
!
      COMPLEX EN(NET),ECD(NET),EX,EY,EZ,HX,HY,HZ,DELTCD,                 &
              CDH(0:MLAYER),KKH(0:MLAYER),CDB(NSUBCM,SUB_BLOCK)
      COMPLEX EHFLD(6)
      INTEGER NX(SUB_BLOCK),NY(SUB_BLOCK),NZ(SUB_BLOCK),NCELL(SUB_BLOCK)
      REAL  XCELL(NXMAX,SUB_BLOCK),YCELL(NYMAX,SUB_BLOCK),               &
            ZCELL(NZMAX,SUB_BLOCK),ZBND(0:MLAYER),                       &
            TX_CRDX(NCRD),TX_CRDY(NCRD),TX_CRDZ(NCRD),RECVR(3)
      REAL  ZOBG(NZOB),ZSRG(2,NZSR),RRG(NRG)
      REAL :: ANGLES(2)
      COMPLEX GRHF(11,NHFILM,NZSR,NZOB),GRHO0(4,NZSR,NZOB)
      EQUIVALENCE (EHFLD(1),EX),(EHFLD(2),EY),(EHFLD(3),EZ),   &
                  (EHFLD(4),HX),(EHFLD(5),HY),(EHFLD(6),HZ)
!
      NEB=0
      DO L=1,SUB_BLOCK
         IF (L>1) NEB=NEB+3*NCELL(L-1)
         DO K=1,NZ(L)
            DO IOB=MLAYER-1,0,-1
               IF (ZCELL(K,L)>=ZBND(IOB)) THEN
                  NOBSV=IOB+1
                  GOTO 20
               ENDIF
            ENDDO
            NOBSV=0
   20       DO I=1,NX(L)
               DO J=1,NY(L)
                  NN=(I-1)*NY(L)*NZ(L)+(J-1)*NZ(L)+K
                  NN1=(NN-1)*3+1+NEB
!
                  RECVR(1)=XCELL(I,L)
                  RECVR(2)=YCELL(J,L)
                  RECVR(3)=ZCELL(K,L)
!
                  CALL ONE_D_SOURCE(CS_TYPE,ANGLES,RECVR,NCRD,TX_CRDX,    &
                                    TX_CRDY,TX_CRDZ,RAD,KEYG,KACC,FRQ,    &
                                    MLAYER,ZBND,AJ,KKH,CDH,NZOB,ZOBG,     &
                                    NZSR,ZSRG,RHOMIN,NHFILM,RRG,NRG,GRHF, &
                                    GRHO0,EHFLD)
!
                  EN(NN1)=EX
                  EN(NN1+1)=EY
                  EN(NN1+2)=EZ
                  DELTCD=CDB(NN,L)-CDH(NOBSV)
                  ECD(NN1)=EX*DELTCD
                  ECD(NN1+1)=EY*DELTCD
                  ECD(NN1+2)=EZ*DELTCD
!
               ENDDO
            ENDDO
         ENDDO
      ENDDO
      RETURN
      END
!
!**** End of EN_PRM_CS
!
!
      SUBROUTINE EN_PRM_GS(NEQ,NBODY,SUB_BLOCK,NBMAX,NXMAX,NYMAX,NZMAX,   &
                           NET,NX,NY,NZ,NCELL,XCELL,YCELL,ZCELL,          &
                           CS_TYPE,NCRD,TX_CRDX,TX_CRDY,TX_CRDZ,RAD,EN,   &
                           FRQ,MLAYER,ZBND,KKH,CDH,ANGLES,KEYG,           &
                           KACC,AJ,NZOB,ZOBG,NZSR,ZSRG,                   &
                           RHOMIN,NHFILM,RRG,NRG,GRHF,GRHO0)
!
!**** Form the right hand side of the matrix equation,  or the
!   incident fields at cell centers for controlled source problems.
!
!   Note that this routine computes the incident fields in
!   the whole structure (unlike routine EN_PRM_CS!),  and thus all the
!   parameters like NX,  XCELL,  etc are defined for the whole
!   structure as in the main program.
!
!   Note that the array EN is arranged in an order as described
!   by Tripp and Tripp & Hohmann, i.e., the elements go first
!   by quarters
!
!   Parameters  KEYG, KACC, AJ, NZOB, ZOBG, NZSR, ZSRG,
!   RHOMIN, NHFILM, RRG, NRG, GRHF, and GRHO0 are to be
!   passed into routine ONE_D_SOURCE.
!
!
      IMPLICIT NONE
!
      REAL AJ,BX,BY,FRQ,RAD,RHOMIN
      INTEGER I,IB,IQ,J,K,KACC,KEYG,CS_TYPE,L,MLAYER,NBMAX,NBODY,NCB,NEQ,  &
              NHFILM,NN,NN1,NP,NRG,NCRD,NSUB,NXMAX,NYMAX,NZMAX,NZOB,NZSR
!
      INTEGER NX(NBMAX,NBODY),NY(NBMAX,NBODY),NZ(NBMAX,NBODY),             &
              NCELL(NBMAX,NBODY),NET(NBODY),SUB_BLOCK(NBODY)
      REAL  XCELL(NXMAX,NBMAX,NBODY),YCELL(NYMAX,NBMAX,NBODY),             &
            ZCELL(NZMAX,NBMAX,NBODY),ZBND(0:MLAYER),                       &
            TX_CRDX(NCRD),TX_CRDY(NCRD),TX_CRDZ(NCRD),RECVR(3)
      REAL :: ANGLES(2),ZOBG(NZOB),ZSRG(2,NZSR),RRG(NRG)
      COMPLEX EN(NEQ*4),EX,EY,EZ,HX,HY,HZ,CDH(0:MLAYER),KKH(0:MLAYER)
      COMPLEX EHFLD(6),GRHF(11,NHFILM,NZSR,NZOB),GRHO0(4,NZSR,NZOB)
      EQUIVALENCE (EHFLD(1),EX),(EHFLD(2),EY),(EHFLD(3),EZ),               &
                  (EHFLD(4),HX),(EHFLD(5),HY),(EHFLD(6),HZ)
!
      NSUB=0
      DO IB=1,NBODY
         IF (IB>1) NSUB=NSUB+NET(IB-1)/3
!
         NCB=0
         DO L=1,SUB_BLOCK(IB)
            IF (L>1) NCB=NCB+NCELL(L-1,IB)
            DO K=1,NZ(L,IB)
               DO I=1,NX(L,IB)
                  DO J=1,NY(L,IB)
                     NN=(I-1)*NY(L,IB)*NZ(L,IB)+(J-1)*NZ(L,IB)+K
!
                     NP=NSUB+NCB+NN
!
! --- Loop for the four quarters
                     DO IQ=1,4
!
! --- See the formula for jcol in routine unitary
                        NN1=12*(NP-1)+3*(IQ-1)+1
!
                        IF (IQ==1) THEN
                           BX=-1.
                           BY=-1.
                        ENDIF
                        IF (IQ==2) THEN
                           BX=1.
                           BY=-1.
                        ENDIF
                        IF (IQ==3) THEN
                           BX=1.
                           BY=1.
                        ENDIF
                        IF (IQ==4) THEN
                           BX=-1.
                           BY=1.
                        ENDIF
!
                        RECVR(1)=BX*XCELL(I,L,IB)
                        RECVR(2)=BY*YCELL(J,L,IB)
                        RECVR(3)=ZCELL(K,L,IB)
!
                        CALL ONE_D_SOURCE(CS_TYPE,ANGLES,RECVR,NCRD,TX_CRDX,  &
                                          TX_CRDY, TX_CRDZ,RAD,KEYG,KACC,FRQ, &
                                          MLAYER,ZBND,AJ,KKH,CDH,NZOB,ZOBG,   &
                                          NZSR,ZSRG,RHOMIN,NHFILM,RRG,        &
                                          NRG,GRHF,GRHO0,EHFLD)
!
                        EN(NN1)=EX
                        EN(NN1+1)=EY
                        EN(NN1+2)=EZ
!
                     ENDDO
                  ENDDO
               ENDDO
            ENDDO
         ENDDO
      ENDDO
!
      RETURN
      END
!
!**** End of EN_PRM_GS
!
!
   SUBROUTINE ONE_D_KERNEL(KEYG,KEMD,MLAYER,ZBND,LRYTH,HVK,KKH,     &
                           KANIS,KPRM,KRHO,KITG,KCHRG,NOB,NSR,      &
                           ZOB,ZSR,ZSRH,ZSRL,LUMBDA,FKN)
!
!****  KERNELS  OF  THE  HANKEL  TRANSFORMS  IN  THE  GREEN'S  FUNCTIONS
!      FOR ELECTROMAGNETIC FIELDS IN A STRATIFIED ANISOTROPIC EARTH
!      (INTEGRATED ANALYTICALLY IN THE VERTICAL DIRECTION IF KITG=1)
!
!    NOTE THAT THE PRIMARY CONTRIBUTION IS INCLUDED IF KPRM=1 AND
!    IS EXCLUDED IF KPRM=0. THE FIGURE AND EQUATION NUMBERS REFERED
!    HERE ARE THOSE IN XIONG, 1989, GEOPHYSICS, 1643-1646
!
!
!    This routine is identical to routine ONE_D_KERNEL of Marco except that
!    anisotropy has been taken out from this routine.  In order to minimise
!    changes,  parameter KANIS is still passed into this routine although it
!    is not used.
!
! --- The input parameters:
!
!      KEYG:    Interger(*4), parameter controlling the output kernels
!               for electric dipoles.
!               KEYG=1:  compute the kernels for electric Green's
!                        tensors as required by the scattering matrix.
!                        Only the first six elements in the output array
!                        FKNS are used which are for the general electric
!                        Green's tensor when the current and charge
!                        termss are computed together as required by old
!                        versions of the 3D code SYSEM et al.
!                    =2: kernels for electric and magnetic field without
!                        separating the current and charge terms;
!                    =3: compute the kernels for current and charge terms
!                        of electric Green's tensors as required by the
!                        scattering matrix; and
!                    =4: compute the scattered fields due to cells with
!                        the current and the charge terms separated for the
!                        electric field.
!      KEMD:    Interger, controls if electric or magnetic
!               dipoles are to be computed.
!               KEMD=1:  electric dipoles;  and
!                   =2:  magnetic dipoles.
!      MLAYER:  Integer(*4), the number of layers including the air.
!      ZBND:    Real ZBND(0:MLAYER), the z-coordinates of the layer
!               boundaries with the air-earth interface being always
!               0 (zbnd(0)=0).
!      LRYTH:   Real LRYTH(MLAYER), the thickness of the layers.
!      HVK:     Real HVK(0:MLAYER), the anisotropy coefficients of
!               the layer conductivities as defined by the square
!               root of the ratio of horizontal conductivity to
!               vertical conductivity.
!      KKH:     Complex KKH(0:MLAYER), the wave numbers of the layers
!               (the air as layer 0) defined as
!                 i*w*mu*(horizontal complex conductivity)
!               where the horizontal complex conductivity includes
!               i*epsilon*w in its imaginary part.
!      KANIS:   Integer, flag for the anisotropy of the media.
!               This parameter is however not used in this routine.
!      KPRM:    Integer, controls whether the primary parts due to
!               the whole space should be included or excluded.
!               KPRM=1:  include the primary terms so the kernels
!                        are complete for all contributions; and
!               KPRM=0:  exclude the primary terms so the kernels
!                        are secondary that are due to the layers.
!      KRHO:    Integer, flag for the value of rho
!               (=sqrt(x-x')**2+(y-y')**2).
!               KRHO=0:  rho=0;  and
!               KRHO=1:  rho>0
!               The kernels are different for rho=0 where the Hankel
!               transforms reduce to plaine infinite integrals.
!      KITG:    Integer, controls whether the kernels should be
!               integrated analytically in the z'-direction.
!               KITG=1:  integrate the kernels from ZSRL to ZSRH; and
!               KITG=0:  ordinary kernels (EM fields from sources to
!               receivers due to dipoles).
!      KCHRG: Integer,  controls whether the charge terms need be
!               removed from the kernels.  For loop sources, the charge
!               terms in the electric fields do not exist but cannot be
!               canceled exactly in the numerical procedures.  Thus
!               they need to removed directly from the kernels.
!               If KCHRG=1,  the charge terms in the electric field
!               will be removed from the kernels.  The parameter
!               KCHRG is controlled in the routine gridhf and gridcs.
!      NOB:     Integer,  the layer number for ZOB.
!      NSR:     Integer,  the layer number of ZSR, ZSRH and ZSRL (they
!               must be in the same layer).
!      ZOB:     Real(*4), the receiver z-coordinate.
!      ZSR:     Real, the source z-coordinate.  Also the mid-point
!               of ZSRH and ZSRL.
!      ZSRL,ZSRH: Real,  the lower the upper limits of the integration.
!               Note that ZSRL and ZSRH both should be either less than
!               or equal to, or greater than or equal to ZOB.
!               ZSR, ZSRH and ZSR must be in the same layer.
!      LUMBDA:   Real, the integration variable, lumbda,  in the Hankel
!               transforms.  The A in LUMBDA is used to make the
!               parameter an implicit real one.
!
! --- The output is the array FKNS
!
!      FKN:    Defined as complex FKN(11).  The contents of the
!              11 values are the kernels of the Hankel transforms
!              for the Green's tensors which are strictly related
!              to those in the routine ONE_D_GREEN and THR_D_GREEN.  The actual
!              kernels are determined by the input parameter KEYG.
!              Check comments on KEYG for more details.
!
! --- Further remarks:
!
!    The parameter EMAX represents the maximal argument of the exponential
!    functions. The exponential functions in some cases tend to infinity as
!    z and z' goes far away from each other, but their contributions to the
!    field values are less and less.   Therefore, for the sake of numerical
!    accuracy these exponential functions are set to zero if their arguments
!    exceed EMAX.  The value of EMAX depends on the accuracy of the numerical
!    Hankel tranforms as well as on the computer system used.  EMAX can be
!    chosen using reciprocity tests.
!
!    The numerical Hankel transforms used in this program yield an ac-
!    curacy of about 10**(-7).   With an EMAX ranging from 5 to 25
!    identical results (up to at least 5 figures) were observed for some
!    tests on an IBM-3090. However, the numerical integration for rho=0
!    (routine simpinf and simpsn) sometimes would not converge for
!    EMAX=20 or so.  Further tests show that EMAX must be at least greater
!    than 5 in order to reach a reasonable accuracy.  Discrepancies may still
!    be visible for EMAX < 20.
!
!    While the use of the control parameter EMAX is adequate for double
!    precision computations,  it fails to yield reasonable accuracy for
!    single precision operations.  This turns out to be caused be the
!    wave penetration factors,  which are computed as FCTA, FCTB, etc.
!    Thus they are set to be zero if penetration is weak.   Parameter
!    PENETRATION controls this threshold.
!
!    There are two recurrence formula for the computation of EM fields
!    in layered earths.  One is the Wait recursion equation and the
!    other is the Knight-Raiche recursion equation.  They both are
!    built in this routine.  Choose proper values for the parameter
!    KWAIT in the parameter list to switch between them.  The Knight-Raiche
!    recursion can be found in Geophysics, Vol. 47,  p 47-50,  1982.
!    See also Schmucker and Weidelt,  Lecture notes on electromagnetic
!    induction in the earth,  Aarhus,  1975.
!
!****    CALLED by:  hfill, hfilh, simpsn
!
!****    CALLS    :  none
!
!
      IMPLICIT NONE
!
      INTEGER, INTENT(IN) ::  KANIS,KCHRG,KEMD,KITG,KPRM,KRHO,          &
                              MLAYER,NOB,NSR,KEYG
      REAL, INTENT(IN) :: LUMBDA,ZOB,ZSR,ZSRH,ZSRL,                     &
                          LRYTH(MLAYER),HVK(0:MLAYER),ZBND(0:MLAYER)
      COMPLEX, INTENT(IN) :: KKH(0:MLAYER)
      COMPLEX, INTENT(OUT) :: FKN(11)
!
! --- Note the parameter LAYERM must have a value greater than or
!     equal to that in the main program
!
      INTEGER, PARAMETER :: LAYERM=200
!
      COMPLEX :: ZMN(LAYERM),ZPL(LAYERM),YMN(LAYERM),                &
                 YPL(LAYERM),NUMN(0:LAYERM),NUPL(0:LAYERM),          &
                 GMMN(0:LAYERM),GMPL(0:LAYERM),UMN(0:LAYERM),        &
                 UPL(0:LAYERM),VMN(0:LAYERM),VPL(0:LAYERM),          &
                 TANH1,TANH2,RMN,RPL,XMN,XPL,U0,V0,NU0,GM0,UI,VI,    &
                 A1,B1,C1,D1,P1,Q1,A2,B2,C2,D2,P2,Q2,                &
                 AE1,BE1,CE1,DE1,PE1,QE1,                            &
                 AE2,BE2,CE2,DE2,PE2,QE2,                            &
                 FCTA,FCTB,FCTC,FCTD,FCTP,FCTQ,                      &
                 EXPA,EXPB,EXPC,EXPD,EXPP,EXPQ,                      &
                 CAB,CCD,CPQ,CAB1,CCD1,CPQ1,DG,                      &
                 PAB,PCD,PPQ,PAB1,PCD1,PPQ1,DCAB,DCAB1,DCCD,DCCD1,   &
                 EA1,EA2,EB1,EB2,EC1,EC2,ED1,ED2,EP1,EP2,EQ1,EQ2,    &
!
!  --- The following three lines are for the computation of the
!      fields in the source layer using Knight and Raiche's recurrrence
!      formula.
!
                 KMN(0:LAYERM),KPL(0:LAYERM),RRU,RRUPL0,RRUMN0,      &
                 SMN0,SPL0,FMN(0:LAYERM),FPL(0:LAYERM)
!
! --- Parameter KWAIT determines whether Wait's recurssion or
!     Knight and Raiche's recursion formula are to be used to compute the
!     kernel coefficients in the source layer.
!       KWAIT=1:  Wait recursion; =0:  Knight-Raiche recursion.
!
      INTEGER, PARAMETER :: KWAIT=0
!
      INTEGER ::  L,LMN,LPL,MPLUS,NMINUS,NOB1
!
! --- For double precision computations PENETRATION should be at least 1.E-12
!
      REAL, PARAMETER :: EMAX=10.,PENETRATION=1.E-6
!
! --- PSQRT is the parameter controlling the accuracy of the binomial
!     expansion for the computation of SQRT.  This depends on the
!     precision of computation.
!
!     For double precision computation use
!
!      REAL, PARAMETER :: PSQRT=100.
!
!     For single precision computation use
!
      REAL, PARAMETER :: PSQRT=10.
!
! --- Use KANIS so that no warning message may be issued by the complier
!
      INTEGER :: WASTE
      WASTE=KANIS
      WASTE=WASTE*1
!
! --- No analytical integration of the kernels if the primary
!     contributions need to be abstracted with source and receiver
!     being in different layers.
!
      IF (KITG==1.AND.KPRM==0.AND.NSR/=NOB) THEN
         WRITE (*,*) 'Routine kernel not ready for kitg=1 and ',   &
                   'kprm=0 and nsr.ne.nob!'
         STOP 'Program aborted.'
      ENDIF
!
! --- Transform the actual layer sequence into the sequence numbered
!     downwards and upperwards with source in layer number 0 as shown
!     in Fig. 1 (of Xiong, GEOPHYSICS); and calculate the impedances
!     ZMN and ZPL.
!
!     It is assumed that there is at least one layer boundary in the
!     space.
!
!  -- MMINUS:  number of the -layers
!     MPLUS:   number of the +layers
!
      NMINUS=NSR
      MPLUS=MLAYER-NSR
!
!  -- Layer parameters
!
      DO L=0,NMINUS
         LMN=NSR-L
         KMN(L)=CSQRT(KKH(LMN))
         IF (LUMBDA>PSQRT*CABS(KMN(L))) THEN
            CAB=(KMN(L)/LUMBDA)**2
            UMN(L)=LUMBDA*((1.,0.)+CAB*((.5,0.)+CAB*(-(.125,0.)+        &
                           CAB*((.0625,0.)+CAB*(-(.0390625,0.)+         &
                           CAB*((.02734375,0.)+CAB*(-(.0205078125,0.)+  &
                           CAB*(.01611328,0.))))))))
         ELSE IF (PSQRT*LUMBDA<CABS(KMN(L))) THEN
            CAB=(LUMBDA/KMN(L))**2
            UMN(L)=KMN(L)*((1.,0.)+CAB*((.5,0.)+CAB*(-(.125,0.)+        &
                           CAB*((.0625,0.)+CAB*(-(.0390625,0.)+         &
                           CAB*((.02734375,0.)+CAB*(-(.0205078125,0.)+  &
                           CAB*(.01611328,0.))))))))
         ELSE
            UMN(L)=CSQRT(CMPLX(LUMBDA**2,0.)+KKH(LMN))
         ENDIF
         IF (ABS(HVK(LMN)-1.)>=.00001) THEN
            VMN(L)=CSQRT(CMPLX((LUMBDA*HVK(LMN))**2,0.)+KKH(LMN))
         ELSE
            VMN(L)=UMN(L)
         ENDIF
         NUMN(L)=1./UMN(L)
         GMMN(L)=KKH(LMN)/VMN(L)
      ENDDO
!
      IF (MPLUS>0) THEN
         KPL(0)=KMN(0)
         UPL(0)=UMN(0)
         VPL(0)=VMN(0)
         NUPL(0)=NUMN(0)
         GMPL(0)=GMMN(0)
      ENDIF
!
      DO L=1,MPLUS
         LPL=NSR+L
         KPL(L)=CSQRT(KKH(LPL))
         IF (LUMBDA>PSQRT*CABS(KPL(L))) THEN
            CAB=(KPL(L)/LUMBDA)**2
            UPL(L)=LUMBDA*((1.,0.)+CAB*((.5,0.)+CAB*(-(.125,0.)+        &
                           CAB*((.0625,0.)+CAB*(-(.0390625,0.)+         &
                           CAB*((.02734375,0.)+CAB*(-(.0205078125,0.)+  &
                           CAB*(.01611328,0.))))))))
         ELSE IF (PSQRT*LUMBDA<CABS(KPL(L))) THEN
            CAB=(LUMBDA/KPL(L))**2
            UPL(L)=KPL(L)*((1.,0.)+CAB*((.5,0.)+CAB*(-(.125,0.)+        &
                           CAB*((.0625,0.)+CAB*(-(.0390625,0.)+         &
                           CAB*((.02734375,0.)+CAB*(-(.0205078125,0.)+  &
                           CAB*(.01611328,0.))))))))
         ELSE
            UPL(L)=CSQRT(CMPLX(LUMBDA**2,0.)+KKH(LPL))
         ENDIF
         IF (ABS(HVK(LPL)-1.)>=.00001) THEN
            VPL(L)=CSQRT(CMPLX((LUMBDA*HVK(LPL))**2,0.)+KKH(LPL))
         ELSE
            VPL(L)=UPL(L)
         ENDIF
         NUPL(L)=1./UPL(L)
         GMPL(L)=KKH(LPL)/VPL(L)
      ENDDO
!
!  -- Recursion
!
      IF (NMINUS/=0) THEN
!
         ZMN(NMINUS)=-NUMN(NMINUS)
         YMN(NMINUS)=-GMMN(NMINUS)
         IF (KWAIT==0) THEN
            FMN(NMINUS)=(0.,0.)
         ENDIF
!
         DO L=NMINUS-1,1,-1
            LMN=NSR-L
            CAB=-2.*UMN(L)*LRYTH(LMN)
            IF (REAL(CAB)>-80.) THEN
               EA1=CEXP(CAB)
            ELSE
               EA1=(0.,0.)
            ENDIF
            IF (ABS(HVK(LMN)-1.)>=.00001) THEN
               CAB=-2.*VMN(L)*LRYTH(LMN)
               IF (REAL(CAB)>-80.) THEN
                  EA2=CEXP(CAB)
               ELSE
                  EA2=(0.,0.)
               ENDIF
            ENDIF
            TANH1=((1.,0.)-EA1)/((1.,0.)+EA1)
            IF (ABS(HVK(LMN)-1.)>=.00001) THEN
               TANH2=((1.,0.)-EA2)/((1.,0.)+EA2)
            ELSE
               TANH2=TANH1
            ENDIF
!
!  --- Note that the impedances Z and Y must be computed for
!      propagation of fields in other layers even if KWAIT=0.
!
            ZMN(L)=NUMN(L)*(ZMN(L+1)-NUMN(L)*TANH1)   &
                 /(NUMN(L)-ZMN(L+1)*TANH1)
            YMN(L)=GMMN(L)*(YMN(L+1)-GMMN(L)*TANH2)   &
                 /(GMMN(L)-YMN(L+1)*TANH2)
!
            IF (KWAIT==0) THEN
!   --- RRU is the Knight-Raiche R with both the numerator and the
!       denominator being multiplied by (u_i+u_{i+1)) for better accuracy
!               RRU=(KMN(L)**2-KMN(L+1)**2)/(UMN(L)+UMN(L+1))**2
               RRU=(KMN(L)-KMN(L+1))*(KMN(L)+KMN(L+1))/(UMN(L)+UMN(L+1))**2
               FMN(L)=EA1*(RRU+FMN(L+1))/((1.,0.)+RRU*FMN(L+1))
            ENDIF
!
         ENDDO
!
      ENDIF
!
      IF (MPLUS/=0) THEN
!
         ZPL(MPLUS)=NUPL(MPLUS)
         YPL(MPLUS)=GMPL(MPLUS)
         IF (KWAIT==0) THEN
            FPL(MPLUS)=(0.,0.)
         ENDIF
!
         DO L=MPLUS-1,1,-1
            LPL=NSR+L
            CAB=-2.*UPL(L)*LRYTH(LPL)
            IF(REAL(CAB)>-80.) THEN
               EA1=CEXP(CAB)
            ELSE
               EA1=(0.,0.)
            ENDIF
            IF (ABS(HVK(LPL)-1.)>=.00001) THEN
               CAB=-2.*VPL(L)*LRYTH(LPL)
               IF(REAL(CAB)>-80.) THEN
                  EA2=CEXP(CAB)
               ELSE
                  EA2=(0.,0.)
               ENDIF
            ENDIF
            TANH1=((1.,0.)-EA1)/((1.,0.)+EA1)
            IF (ABS(HVK(LPL)-1.)>=.00001) THEN
               TANH2=((1.,0.)-EA2)/((1.,0.)+EA2)
            ELSE
               TANH2=TANH1
            ENDIF
            ZPL(L)=NUPL(L)*(ZPL(L+1)+NUPL(L)*TANH1)   &
                 /(NUPL(L)+ZPL(L+1)*TANH1)
            YPL(L)=GMPL(L)*(YPL(L+1)+GMPL(L)*TANH2)   &
                 /(GMPL(L)+YPL(L+1)*TANH2)
!
            IF (KWAIT==0) THEN
!   --- RRU is the Knight-Raiche R with both the numerator and the
!       denominator being multiplied by (u_i+u_{i+1)) for better accuracy
!               RRU=(KPL(L)**2-KPL(L+1)**2)/(UPL(L)+UPL(L+1))**2
               RRU=(KPL(L)-KPL(L+1))*(KPL(L)+KPL(L+1))/(UPL(L)+UPL(L+1))**2
               FPL(L)=EA1*(RRU+FPL(L+1))/((1.,0.)+RRU*FPL(L+1))
            ENDIF
!
         ENDDO
!
      ENDIF
!
! --- The coefficients A0,B0,C0.,P0, and Q0 in the source layer
!     are separated into A1*EXP(AE1)+A2*EXP(AE2),... +Q2*EXP(QE2),
!     respectively, in which "1" represents the terms with EXP(+U0 Z')
!     and "2" represents those with EXP(-U0 Z). But the two exponetial
!     functions (EXP(+U0 Z') etc.) are not included here.
!
!     Note: the radiation conditions are automatically considered here
!           and the calculation is kept to the minimum for every special
!           case possible.
!
      U0=UMN(0)
      V0=VMN(0)
      NU0=NUMN(0)
      GM0=GMMN(0)
!
!  -- If the source is located neither in the upper-most nor in the
!     lower-most layer
!
      IF (NMINUS/=0.AND.MPLUS/=0) THEN
!
         IF (KWAIT==1) THEN
            RMN=(ZMN(1)+NU0)/(ZMN(1)-NU0)
            RPL=(ZPL(1)+NU0)/(ZPL(1)-NU0)
         ELSE
!            RRUMN0=(KMN(0)**2-KMN(1)**2)/(UMN(0)+UMN(1))**2
            RRUMN0=(KMN(0)-KMN(1))*(KMN(0)+KMN(1))/(UMN(0)+UMN(1))**2
            SMN0=(RRUMN0+FMN(1))/((1.,0.)+RRUMN0*FMN(1))
            RMN=SMN0
!            RRUPL0=(KPL(0)**2-KPL(1)**2)/(UPL(0)+UPL(1))**2
            RRUPL0=(KPL(0)-KPL(1))*(KPL(0)+KPL(1))/(UPL(0)+UPL(1))**2
            SPL0=(RRUPL0+FPL(1))/((1.,0.)+RRUPL0*FPL(1))
            RPL=(1.,0.)/SPL0
         ENDIF
         XMN=(YMN(1)+GM0)/(YMN(1)-GM0)
         XPL=(YPL(1)+GM0)/(YPL(1)-GM0)
         CAB=-2.*U0*LRYTH(NSR)
         IF (REAL(CAB)>-80.) THEN
            EA1=CEXP(CAB)
         ELSE
            EA1=(0.,0.)
         ENDIF
         EA2=RPL-RMN*EA1
         A1=LUMBDA/U0/EA2
         A2=A1*RMN
         B1=A2
         B2=B1*RPL
         IF (ABS(HVK(NSR)-1.)>=.00001) THEN
            CAB=-2.*V0*LRYTH(NSR)
            IF (REAL(CAB)>-80.) THEN
               EA1=CEXP(CAB)
            ELSE
               EA1=(0.,0.)
            ENDIF
         ENDIF
         EA2=XPL-XMN*EA1
         C1=-1./LUMBDA/EA2
         C2=-C1*XMN
         D1=-C2
         D2=-D1*XPL
         P1=LUMBDA/V0/EA2
         P2=P1*XMN
         Q1=P2
         Q2=Q1*XPL
         AE1=-2.*U0*ZBND(NSR)
         AE2=-2.*U0*LRYTH(NSR)
         BE1=AE2
         BE2=2.*U0*ZBND(NSR-1)
         IF (ABS(HVK(NSR)-1.)>=.00001) THEN
            CE1=-2.*V0*ZBND(NSR)
            CE2=-2.*V0*LRYTH(NSR)
            DE2=2.*V0*ZBND(NSR-1)
         ELSE
            CE1=AE1
            CE2=AE2
            DE2=BE2
         ENDIF
         DE1=CE2
         PE1=CE1
         PE2=CE2
         QE1=PE2
         QE2=DE2
!
      ENDIF
!
!  -- If the source sits in the upper-most layer and the receiver
!     everywhere but the lower-most layer
!
!     Note that the other components that are not calculated here
!     are zero and are ignored accordingly in the other parts of
!     this routine.
!
      IF (NMINUS==0.AND.NOB/=MLAYER) THEN
         IF (KWAIT==1) THEN
            RPL=(ZPL(1)+NU0)/(ZPL(1)-NU0)
         ELSE
!            RRUPL0=(KPL(0)**2-KPL(1)**2)/(UPL(0)+UPL(1))**2
            RRUPL0=(KPL(0)-KPL(1))*(KPL(0)+KPL(1))/(UPL(0)+UPL(1))**2
            SPL0=(RRUPL0+FPL(1))/((1.,0.)+RRUPL0*FPL(1))
            RPL=(1.,0.)/SPL0
         ENDIF
         XPL=(YPL(1)+GM0)/(YPL(1)-GM0)
         A1=LUMBDA/U0/RPL
         C1=-1./LUMBDA/XPL
         P1=LUMBDA/V0/XPL
         AE1=-2.*U0*ZBND(NSR)
         CE1=-2.*V0*ZBND(NSR)
         PE1=CE1
      ENDIF
!
!  -- If the source sits in the lower-most layer and the receiver
!     everywhere but the upper-most layer
!
      IF (MPLUS==0.AND.NOB/=0) THEN
         IF (KWAIT==1) THEN
            RMN=(ZMN(1)+NU0)/(ZMN(1)-NU0)
         ELSE
!            RRUMN0=(KMN(0)**2-KMN(1)**2)/(UMN(0)+UMN(1))**2
            RRUMN0=(KMN(0)-KMN(1))*(KMN(0)+KMN(1))/(UMN(0)+UMN(1))**2
            SMN0=(RRUMN0+FMN(1))/((1.,0.)+RRUMN0*FMN(1))
            RMN=SMN0
         ENDIF
         XMN=(YMN(1)+GM0)/(YMN(1)-GM0)
         B2=LUMBDA/U0*RMN
         D2=XMN/LUMBDA
         Q2=LUMBDA/V0*XMN
         BE2=2.*U0*ZBND(NSR-1)
         DE2=2.*V0*ZBND(NSR-1)
         QE2=DE2
      ENDIF
!
! --- Separate the primary contributions according to the plus
!     and minus region after equations (20) to (27).
!
!  -- Here also the cases when the receiver is in the upper-most and
!     source is in the lower-most layer and vice versa are considered.
!
      IF (ZOB>=ZSR) THEN
!
         IF (KPRM==0.AND.NSR==NOB) THEN
!
!--- Note that the primary contributions can be omitted only if ZOB
!    and ZSR are in the same layer. Otherwise, they must be subs-
!    tracted from the final results calculated later (eq. (34) and
!    (35) etc.).
!
            B1=(0.,0.)
            D1=(0.,0.)
            Q1=(0.,0.)
         ELSEIF (NMINUS==0.OR.MPLUS==0) THEN
            B1=LUMBDA/U0
            D1=-(1.,0.)/LUMBDA
            Q1=LUMBDA/V0
         ELSEIF (ABS(HVK(NSR)-1.)>=.00001) THEN
            IF (REAL(DE1).GT.-80.) THEN
               CAB=CEXP(DE1)
            ELSE
               CAB=(0.,0.)
            ENDIF
            IF (REAL(QE1).GT.-80.) THEN
               CCD=CEXP(QE1)
            ELSE
               CCD=(0.,0.)
            ENDIF
            D1=D1*CAB-(1.,0.)/LUMBDA
            Q1=Q1*CCD+LUMBDA/V0
            Q1=Q1*CCD+LUMBDA/V0
         ELSE
            IF (REAL(BE1).GT.-80.) THEN
               EA1=CEXP(BE1)
            ELSE
               EA1=(0.,0.)
            ENDIF
            B1=B1*EA1+LUMBDA/U0
            D1=D1*EA1-(1.,0.)/LUMBDA
            Q1=Q1*EA1+LUMBDA/V0
         ENDIF
         BE1=(0.,0.)
         DE1=(0.,0.)
         QE1=(0.,0.)
!
      ENDIF
!
      IF (ZOB<ZSR) THEN
!
         IF (KPRM==0.AND.NSR==NOB) THEN
            A2=(0.,0.)
            C2=(0.,0.)
            P2=(0.,0.)
         ELSEIF (NMINUS==0.OR.MPLUS==0) THEN
            A2=LUMBDA/U0
            C2=(1.,0.)/LUMBDA
            P2=LUMBDA/V0
         ELSEIF (ABS(HVK(NSR)-1.)>=.00001) THEN
            IF (REAL(AE2).GT.-80.) THEN
               CAB=CEXP(AE2)
            ELSE
               CAB=(0.,0.)
            ENDIF
            IF (REAL(CE2).GT.-80.) THEN
               CCD=CEXP(CE2)
            ELSE
               CCD=(0.,0.)
            ENDIF
            IF (REAL(PE2).GT.-80.) THEN
               CPQ=CEXP(PE2)
            ELSE
               CPQ=(0.,0.)
            ENDIF
            A2=A2*CAB+LUMBDA/U0
            C2=C2*CCD+(1.,0.)/LUMBDA
            P2=P2*CPQ+LUMBDA/V0
         ELSE
            IF (REAL(AE2).GT.-80.) THEN
               EA1=CEXP(AE2)
            ELSE
               EA1=(0.,0.)
            ENDIF
            A2=A2*EA1+LUMBDA/U0
            C2=C2*EA1+(1.,0)/LUMBDA
            P2=P2*EA1+LUMBDA/V0
         ENDIF
         AE2=(0.,0.)
         CE2=(0.,0.)
         PE2=(0.,0.)
!
      ENDIF
!
! --- Calculate the coefficients in other layers
!
!     Propagations of the coefficients a, b according to
!     equations (34) and (35).
!
      NOB1=NOB-NSR
!
      IF (NOB/=NSR) THEN
!
         FCTA=(1.,0.)
         FCTB=(1.,0.)
         FCTC=(1.,0.)
         FCTD=(1.,0.)
         EXPA=(0.,0.)
         EXPC=(0.,0.)
!
         IF (NOB1>=0) THEN
!
            DO L=1,NOB1
               IF (CABS(ZPL(L)-NUPL(L-1))>1.E-35) THEN
                  IF (CABS(ZPL(L)-NUPL(L))<PENETRATION*CABS(NUPL(L))) THEN
                     FCTA=(0.,0.)
                  ELSE
                     FCTA=FCTA*(ZPL(L)-NUPL(L))/(ZPL(L)-NUPL(L-1))
                  ENDIF
               ENDIF
               FCTB=FCTB*(ZPL(L)+NUPL(L))/(ZPL(L)+NUPL(L-1))
               IF (CABS(YPL(L)-GMPL(L-1))>1.E-35) THEN
                  IF (CABS(YPL(L)-GMPL(L))<PENETRATION*CABS(GMPL(L))) THEN
                     FCTC=(0.,0.)
                  ELSE
                     FCTC=FCTC*(YPL(L)-GMPL(L))/(YPL(L)-GMPL(L-1))
                  ENDIF
               ENDIF
               FCTD=FCTD*(YPL(L)+GMPL(L))/(YPL(L)+GMPL(L-1))
               EXPA=EXPA+(UPL(L-1)-UPL(L))*ZBND(NSR+L-1)
            ENDDO
!
         ENDIF
!
         IF (NOB1<0) THEN
!
            DO L=1,-NOB1
               FCTA=FCTA*(ZMN(L)-NUMN(L))/(ZMN(L)-NUMN(L-1))
               IF (CABS(ZMN(L)+NUMN(L-1))>1.E-35) THEN
                  IF (CABS(ZMN(L)+NUMN(L))<PENETRATION*CABS(NUMN(L))) THEN
                     FCTB=(0.,0.)
                  ELSE
                     FCTB=FCTB*(ZMN(L)+NUMN(L))/(ZMN(L)+NUMN(L-1))
                  ENDIF
               ENDIF
               FCTC=FCTC*(YMN(L)-GMMN(L))/(YMN(L)-GMMN(L-1))
               IF (CABS(YMN(L)+GMMN(L-1))>1.E-35) THEN
                  IF (CABS(YMN(L)+GMMN(L))<PENETRATION*CABS(GMMN(L))) THEN
                     FCTD=(0.,0.)
                  ELSE
                    FCTD=FCTD*(YMN(L)+GMMN(L))/(YMN(L)+GMMN(L-1))
                  ENDIF
               ENDIF
               EXPA=EXPA+(UMN(L-1)-UMN(L))*ZBND(NSR-L)
            ENDDO
!
         ENDIF
!
         EXPC=EXPA
         FCTP=FCTC
         FCTQ=FCTD
         EXPB=-EXPA
         EXPD=-EXPC
         EXPP=EXPC
         EXPQ=EXPD
!
         IF (.NOT.(NSR==0.AND.NOB==MLAYER.OR.NSR==MLAYER.AND.NOB==0))   &
           THEN
!
            IF (NMINUS==0) THEN
               A1=A1*FCTA
               C1=C1*FCTC
               P1=P1*FCTP
               AE1=AE1+EXPA
               CE1=CE1+EXPC
               PE1=PE1+EXPP
            ELSEIF (MPLUS==0) THEN
               B2=B2*FCTB
               D2=D2*FCTD
               Q2=Q2*FCTQ
               BE2=BE2+EXPB
               DE2=DE2+EXPD
               QE2=QE2+EXPQ
            ELSE
               A1=A1*FCTA
               A2=A2*FCTA
               C1=C1*FCTC
               C2=C2*FCTC
               P1=P1*FCTP
               P2=P2*FCTP
               B1=B1*FCTB
               B2=B2*FCTB
               D1=D1*FCTD
               D2=D2*FCTD
               Q1=Q1*FCTQ
               Q2=Q2*FCTQ
               AE1=AE1+EXPA
               AE2=AE2+EXPA
               CE1=CE1+EXPC
               CE2=CE2+EXPC
               PE1=PE1+EXPP
               PE2=PE2+EXPP
               BE1=BE1+EXPB
               BE2=BE2+EXPB
               DE1=DE1+EXPD
               DE2=DE2+EXPD
               QE1=QE1+EXPQ
               QE2=QE2+EXPQ
!
            ENDIF
!
         ENDIF
!
         IF (NMINUS==0.OR.MPLUS==0) THEN
!
            IF (ZOB>=ZSR) THEN
               B1=B1*FCTB
               D1=D1*FCTD
               Q1=Q1*FCTQ
               BE1=BE1+EXPB
               DE1=DE1+EXPD
               QE1=QE1+EXPQ
            ELSE
               A2=A2*FCTA
               C2=C2*FCTC
               P2=P2*FCTP
               AE2=AE2+EXPA
               CE2=CE2+EXPC
               PE2=PE2+EXPP
            ENDIF
!
         ENDIF
!
      ENDIF
!
! --- Calculate the kernels of the Hankel transforms: the coefficients
!     with the expoentials of z and z'
!
      IF (NOB1>0) THEN
         UI=UPL(NOB1)
         VI=VPL(NOB1)
      ELSE
         UI=UMN(-NOB1)
         VI=VMN(-NOB1)
      ENDIF
!
!  -- If the source is in the upper-most layer
!
!     Due to the complexity of the if blocks,  each block level is
!     marked by *****, _____, -----, or .....
!
      IF (NMINUS==0) THEN
!   **********************************
!   *                                *
!    -- If the receiver is not in the lower-most layer
!
         IF (NOB/=MLAYER) THEN
!   ______________________________
!   !                            !
            IF (KITG==0) THEN
!    ...........................
!    .                         .
               EXPA=AE1+U0*ZSR+UI*ZOB
               IF (REAL(EXPA)>-80..AND.REAL(EXPA)<=EMAX) THEN
                  CAB=CEXP(EXPA)
                  EA1=A1*CAB
                  EC1=C1*CAB
                  EP1=P1*CAB
               ELSE
                  EA1=(0.,0.)
                  EC1=(0.,0.)
                  EP1=(0.,0.)
               ENDIF
!    .                         .
!    ...........................
            ENDIF
!
            IF (KITG==1) THEN
!    ...........................
!    .                         .
               EXPA=AE1+U0*ZSRH+UI*ZOB
               IF (REAL(EXPA)>-80..AND.REAL(EXPA)<=EMAX) THEN
                  CAB=CEXP(EXPA)/U0
                  EA1=A1*CAB
                  EC1=C1*CAB
                  EP1=P1*CAB
               ELSE
                  EA1=(0.,0.)
                  EC1=(0.,0.)
                  EP1=(0.,0.)
               ENDIF
!
               EXPA=AE1+U0*ZSRL+UI*ZOB
               IF (REAL(EXPA)>-80..AND.REAL(EXPA)<=EMAX) THEN
                  CAB=CEXP(EXPA)/U0
                  EA1=EA1-A1*CAB
                  EC1=EC1-C1*CAB
                  EP1=EP1-P1*CAB
               ENDIF
!     .                        .
!     ..........................
            ENDIF
!     !                              !
!     ________________________________
         ENDIF
!
!    -- If the receiver is in the lower-most layer
!
         IF (NOB==MLAYER) THEN
!   ______________________________
!   !                            !
            EA1=(0.,0.)
            EC1=(0.,0.)
            EP1=(0.,0.)
!   !                            !
!   ______________________________
         ENDIF
!   *                                *
!   **********************************
      ENDIF
!
!  -- If the source is in the lower-most layer
!
      IF (MPLUS==0) THEN
!   ***********************************
!   *                                 *
         IF (NOB/=0) THEN
!   _________________________________
!   !                               !
            IF (KITG==0) THEN
!    ...........................
!    .                         .
               EXPB=BE2-U0*ZSR-UI*ZOB
               IF (REAL(EXPB)>-80..AND.REAL(EXPB)<=EMAX) THEN
                  CAB=CEXP(EXPB)
                  EB2=B2*CAB
                  ED2=D2*CAB
                  EQ2=Q2*CAB
               ELSE
                  EB2=(0.,0.)
                  ED2=(0.,0.)
                  EQ2=(0.,0.)
               ENDIF
!    .                           .
!    .............................
            ENDIF
!
            IF (KITG==1) THEN
!    .............................
!    .                           .
               EXPB=BE2-U0*ZSRH-UI*ZOB
               IF (REAL(EXPB)>-80..AND.REAL(EXPB)<=EMAX) THEN
                  CAB=-CEXP(EXPB)/U0
                  EB2=B2*CAB
                  ED2=D2*CAB
                  EQ2=Q2*CAB
               ELSE
                  EB2=(0.,0.)
                  ED2=(0.,0.)
                  EQ2=(0.,0.)
               ENDIF
!
               EXPB=BE2-U0*ZSRL-UI*ZOB
               IF (REAL(EXPB)>-80..AND.REAL(EXPB)<=EMAX) THEN
                  CAB=-CEXP(EXPB)/U0
                  EB2=EB2-B2*CAB
                  ED2=ED2-D2*CAB
                  EQ2=EQ2-Q2*CAB
               ENDIF
!    .                            .
!    ..............................
            ENDIF
!    !                                  !
!    ____________________________________
         ENDIF
!
         IF (NOB==0) THEN
!    ____________________________________
!    !                                  !
            EB2=(0.,0.)
            ED2=(0.,0.)
            EQ2=(0.,0.)
!    !                                  !
!    ____________________________________
         ENDIF
!   *                                      *
!   ****************************************
      ENDIF
!
!  -- For sources either in the upper-most or the lower-most layers
!
      IF (NMINUS==0.OR.MPLUS==0) THEN
!   ****************************************
!   *                                      *
         IF (ZOB<ZSR) THEN
!   _____________________________________
!   !                                   !
            IF (KPRM/=0.OR.NSR/=NOB) THEN
!   ----------------------------------
!   |                                |
!
               IF (KITG==0) THEN
!
                  EXPA=AE2-U0*ZSR+UI*ZOB
                  IF (REAL(EXPA)>-80..AND.REAL(EXPA)<=EMAX) THEN
                     CAB=CEXP(EXPA)
                     EA2=A2*CAB
                     EC2=C2*CAB
                     EP2=P2*CAB
                  ELSE
                     EA2=(0.,0.)
                     EC2=(0.,0.)
                     EP2=(0.,0.)
                  ENDIF
               ENDIF
!
               IF (KITG==1) THEN
                  EXPA=AE2-U0*ZSRH+UI*ZOB
                  IF (REAL(EXPA)>-80..AND.REAL(EXPA)<=EMAX) THEN
                     CAB=-CEXP(EXPA)/U0
                     EA2=A2*CAB
                     EC2=C2*CAB
                     EP2=P2*CAB
                  ELSE
                     EA2=(0.,0.)
                     EC2=(0.,0.)
                     EP2=(0.,0.)
                  ENDIF
!
                  EXPA=AE2-U0*ZSRL+UI*ZOB
                  IF (REAL(EXPA)>-80..AND.REAL(EXPA)<=EMAX) THEN
                     CAB=-CEXP(EXPA)/U0
                     EA2=EA2-A2*CAB
                     EC2=EC2-C2*CAB
                     EP2=EP2-P2*CAB
                  ENDIF
               ENDIF
!   |                                |
!   ----------------------------------
            ENDIF
!
            IF (KPRM==0.AND.NSR==NOB) THEN
!   ----------------------------------
!   |                                |
               EA2=(0.,0.)
               EC2=(0.,0.)
               EP2=(0.,0.)
!   |                                |
!   ----------------------------------
            ENDIF
!   !                                  !
!   ____________________________________
         ENDIF
!
         IF (ZOB>=ZSR) THEN
!   ____________________________________
!   !                                  !
            IF (KPRM/=0.OR.NSR/=NOB) THEN
!   ---------------------------------
!   |                               |
!
               IF (KITG==0) THEN
!
                  EXPB=BE1+U0*ZSR-UI*ZOB
                  IF (REAL(EXPB)>-80..AND.REAL(EXPB)<=EMAX) THEN
                     CAB=CEXP(EXPB)
                     EB1=B1*CAB
                     ED1=D1*CAB
                     EQ1=Q1*CAB
                  ELSE
                     EB1=(0.,0.)
                     ED1=(0.,0.)
                     EQ1=(0.,0.)
                  ENDIF
!
               ENDIF
!
               IF (KITG==1) THEN
!
                  EXPB=BE1+U0*ZSRH-UI*ZOB
                  IF (REAL(EXPB)>-80..AND.REAL(EXPB)<=EMAX) THEN
                     CAB=CEXP(EXPB)/U0
                     EB1=B1*CAB
                     ED1=D1*CAB
                     EQ1=Q1*CAB
                  ELSE
                     EB1=(0.,0.)
                     ED1=(0.,0.)
                     EQ1=(0.,0.)
                  ENDIF
!
                  EXPB=BE1+U0*ZSRL-UI*ZOB
                  IF (REAL(EXPB)>-80..AND.REAL(EXPB)<=EMAX) THEN
                     CAB=CEXP(EXPB)/U0
                     EB1=EB1-B1*CAB
                     ED1=ED1-D1*CAB
                     EQ1=EQ1-Q1*CAB
                  ENDIF
!
               ENDIF
!   |                                |
!   ----------------------------------
            ENDIF
!
            IF (KPRM==0.AND.NSR==NOB) THEN
!   ----------------------------------
!   |                                |
               EB1=(0.,0.)
               ED1=(0.,0.)
               EQ1=(0.,0.)
!   |                                |
!   ----------------------------------
            ENDIF
!   !                                !
!   __________________________________
         ENDIF
!   *                                      *
!   ****************************************
      ENDIF
!
!  -- For sources neither in the upper-most nor the lower-most layers
!
      IF (NMINUS/=0.AND.MPLUS/=0) THEN
!   ****************************************
!   *                                      *
         IF (NOB/=MLAYER) THEN
!   __________________________________
!   !                                !
            IF (KITG==0) THEN
!   ...........................
!   .                         .
               EXPA=AE1+U0*ZSR+UI*ZOB
               IF (REAL(EXPA)>-80..AND.REAL(EXPA)<=EMAX) THEN
                  EP1=CEXP(EXPA)
                  EA1=A1*EP1
                  EC1=C1*EP1
                  EP1=P1*EP1
               ELSE
                  EA1=(0.,0.)
                  EC1=(0.,0.)
                  EP1=(0.,0.)
               ENDIF
               EXPA=AE2-U0*ZSR+UI*ZOB
               IF (REAL(EXPA)>-80..AND.REAL(EXPA)<=EMAX) THEN
                  EP2=CEXP(EXPA)
                  EA2=A2*EP2
                  EC2=C2*EP2
                  EP2=P2*EP2
               ELSE
                  EA2=(0.,0.)
                  EC2=(0.,0.)
                  EP2=(0.,0.)
               ENDIF
!   .                         .
!   ...........................
            ENDIF
!
            IF (KITG==1) THEN
!   ...........................
!   .                         .
               EXPA=AE1+U0*ZSRH+UI*ZOB
               IF (REAL(EXPA)>-80..AND.REAL(EXPA)<=EMAX) THEN
                  CAB=CEXP(EXPA)/U0
                  EA1=A1*CAB
                  EC1=C1*CAB
                  EP1=P1*CAB
               ELSE
                  EA1=(0.,0.)
                  EC1=(0.,0.)
                  EP1=(0.,0.)
               ENDIF
               EXPA=AE2-U0*ZSRH+UI*ZOB
               IF (REAL(EXPA)>-80..AND.REAL(EXPA)<=EMAX) THEN
                  CAB=-CEXP(EXPA)/U0
                  EA2=A2*CAB
                  EC2=C2*CAB
                  EP2=P2*CAB
               ELSE
                  EA2=(0.,0.)
                  EC2=(0.,0.)
                  EP2=(0.,0.)
               ENDIF
!
               EXPA=AE1+U0*ZSRL+UI*ZOB
               IF (REAL(EXPA)>-80..AND.REAL(EXPA)<=EMAX) THEN
                  CAB=CEXP(EXPA)/U0
                  EA1=EA1-A1*CAB
                  EC1=EC1-C1*CAB
                  EP1=EP1-P1*CAB
               ELSE
                  EA1=EA1-(0.,0.)
                  EC1=EC1-(0.,0.)
                  EP1=EP1-(0.,0.)
               ENDIF
               EXPA=AE2-U0*ZSRL+UI*ZOB
               IF (REAL(EXPA)>-80..AND.REAL(EXPA)<=EMAX) THEN
                  CAB=-CEXP(EXPA)/U0
                  EA2=EA2-A2*CAB
                  EC2=EC2-C2*CAB
                  EP2=EP2-P2*CAB
               ELSE
                  EA2=EA2-(0.,0.)
                  EC2=EC2-(0.,0.)
                  EP2=EP2-(0.,0.)
               ENDIF
!   .                         .
!   ...........................
            ENDIF
!   !                                !
!   __________________________________
         ENDIF
!
         IF (NOB==MLAYER) THEN
!   __________________________________
!   !                                !
            EA1=(0.,0.)
            EC1=(0.,0.)
            EP1=(0.,0.)
            EA2=(0.,0.)
            EC2=(0.,0.)
            EP2=(0.,0.)
!   !                                !
!   __________________________________
         ENDIF
!
         IF (NOB/=0) THEN
!   __________________________________
!   !                                !
!
            IF (KITG==0) THEN
!    ...........................
!    .                         .
               EXPB=BE1+U0*ZSR-UI*ZOB
               IF (REAL(EXPB)>-80..AND.REAL(EXPB)<=EMAX) THEN
                  CAB=CEXP(EXPB)
                  EB1=B1*CAB
                  ED1=D1*CAB
                  EQ1=Q1*CAB
               ELSE
                  EB1=(0.,0.)
                  ED1=(0.,0.)
                  EQ1=(0.,0.)
               ENDIF
               EXPB=BE2-U0*ZSR-UI*ZOB
               IF (REAL(EXPB)>-80..AND.REAL(EXPB)<=EMAX) THEN
                  CAB=CEXP(EXPB)
                  EB2=B2*CAB
                  ED2=D2*CAB
                  EQ2=Q2*CAB
               ELSE
                  EB2=(0.,0.)
                  ED2=(0.,0.)
                  EQ2=(0.,0.)
               ENDIF
!    .                          .
!    ............................
            ENDIF
!
            IF (KITG==1) THEN
!    ............................
!    .                          .
               EXPB=BE1+U0*ZSRH-UI*ZOB
               IF (REAL(EXPB)>-80..AND.REAL(EXPB)<=EMAX) THEN
                  CAB=CEXP(EXPB)/U0
                  EB1=B1*CAB
                  ED1=D1*CAB
                  EQ1=Q1*CAB
               ELSE
                  EB1=(0.,0.)
                  ED1=(0.,0.)
                  EQ1=(0.,0.)
               ENDIF
               EXPB=BE2-U0*ZSRH-UI*ZOB
               IF (REAL(EXPB)>-80..AND.REAL(EXPB)<=EMAX) THEN
                  CAB=-CEXP(EXPB)/U0
                  EB2=B2*CAB
                  ED2=D2*CAB
                  EQ2=Q2*CAB
               ELSE
                  EB2=(0.,0.)
                  ED2=(0.,0.)
                  EQ2=(0.,0.)
               ENDIF
!
               EXPB=BE1+U0*ZSRL-UI*ZOB
               IF (REAL(EXPB)>-80..AND.REAL(EXPB)<=EMAX) THEN
                  CAB=CEXP(EXPB)/U0
                  EB1=EB1-B1*CAB
                  ED1=ED1-D1*CAB
                  EQ1=EQ1-Q1*CAB
               ELSE
                  EB1=EB1-(0.,0.)
                  ED1=ED1-(0.,0.)
                  EQ1=EQ1-(0.,0.)
               ENDIF
               EXPB=BE2-U0*ZSRL-UI*ZOB
               IF (REAL(EXPB)>-80..AND.REAL(EXPB)<=EMAX) THEN
                  CAB=-CEXP(EXPB)/U0
                  EB2=EB2-B2*CAB
                  ED2=ED2-D2*CAB
                  EQ2=EQ2-Q2*CAB
               ELSE
                  EB2=EB2-(0.,0.)
                  ED2=ED2-(0.,0.)
                  EQ2=EQ2-(0.,0.)
               ENDIF
!    .                          .
!    ............................
            ENDIF
!   !                                !
!   __________________________________
         ENDIF
!
         IF (NOB==0) THEN
!   __________________________________
!   !                                !
            EB1=(0.,0.)
            ED1=(0.,0.)
            EQ1=(0.,0.)
            EB2=(0.,0.)
            ED2=(0.,0.)
            EQ2=(0.,0.)
!   !                                !
!   __________________________________
         ENDIF
!   *                                      *
!   ****************************************
      ENDIF
!
! --- Calculate the kernel functions of the Hankel transforms
!     in terms of CAB etc. where CAB is defined as
!         CAB =a*exp(uz)+b*exp(-uz) and
!         CAB1=a*exp(uz)-b*exp(-uz).
!     The exponential functions exp(+-uz') are contained in a and b.
!
      IF (NMINUS==0) THEN
         CAB=EA1
         CAB1=EA1
         CCD=EC1
         CCD1=EC1
         CPQ=EP1
         CPQ1=EP1
!    --   Magnetic dipole kernels
         IF (KEMD==2) THEN
            DCAB =U0*EA1
            DCAB1=U0*EA1
            DCCD =U0*EC1
            DCCD1=U0*EC1
         ENDIF
      ELSEIF (MPLUS==0) THEN
         CAB=EB2
         CAB1=-EB2
         CCD=ED2
         CCD1=-ED2
         CPQ=EQ2
         CPQ1=-EQ2
!
         IF (KEMD==2) THEN
            DCAB =-U0*EB2
            DCAB1= U0*EB2
            DCCD =-U0*ED2
            DCCD1= U0*ED2
         ENDIF
      ELSE
         CAB=EA1+EA2+EB1+EB2
         CAB1=EA1+EA2-EB1-EB2
         CCD=EC1+EC2+ED1+ED2
         CCD1=EC1+EC2-ED1-ED2
         CPQ=EP1+EP2+EQ1+EQ2
         CPQ1=EP1+EP2-EQ1-EQ2
         IF (KEMD==2) THEN
            DCAB =U0*(EA1-EA2+EB1-EB2)
            DCAB1=U0*(EA1-EA2-EB1+EB2)
            DCCD =U0*(EC1-EC2+ED1-ED2)
            DCCD1=U0*(EC1-EC2-ED1+ED2)
         ENDIF
      ENDIF
      IF (NMINUS==0.OR.MPLUS==0) THEN
         IF (ZOB>=ZSR) THEN
            CAB=CAB+EB1
            CAB1=CAB1-EB1
            CCD=CCD+ED1
            CCD1=CCD1-ED1
            CPQ=CPQ+EQ1
            CPQ1=CPQ1-EQ1
            IF (KEMD==2) THEN
               DCAB =DCAB +U0*EB1
               DCAB1=DCAB1-U0*EB1
               DCCD =DCCD +U0*ED1
               DCCD1=DCCD1-U0*ED1
            ENDIF
         ELSE
            CAB=CAB+EA2
            CAB1=CAB1+EA2
            CCD=CCD+EC2
            CCD1=CCD1+EC2
            CPQ=CPQ+EP2
            CPQ1=CPQ1+EP2
            IF (KEMD==2) THEN
               DCAB =DCAB -U0*EA2
               DCAB1=DCAB1-U0*EA2
               DCCD =DCCD -U0*EC2
               DCCD1=DCCD1-U0*EC2
            ENDIF
         ENDIF
      ENDIF
!
!  ---- Now finally,  the kernel functions FKN.  Note
!       that they are corrected for various purposes
!
!  --- Electric dipoles
!
      IF (KEMD==1) THEN
!   **************************************
!   *                                    *
!
         IF (KPRM==1.OR.NSR==NOB) THEN
!   ___________________________________
!   !                                 !
!
!  ---  If rho=0,  only the first 4 element of fkn are needed.
!
            IF (KRHO==0) THEN
!   ---------------------------------
!   |                               |
!
!  --- Remove the charge terms from the kernels if KCHRG=1
!
!      Exx, Eyy and Ezz have different factors before the
!      integral before and after the charge term is removed.
!      This is taken into account here.
!
               IF (KEYG==1.OR.KEYG==2) THEN
                  IF (KCHRG==0) THEN
                     FKN(1)=.5*(KKH(NOB)*CAB+LUMBDA**2*VI*CCD1)
                     FKN(2)=LUMBDA**2*CPQ*HVK(NSR)**2
                  ELSE
                     FKN(1)=KKH(NOB)*CAB
                     FKN(2)=-KKH(NOB)*CPQ*HVK(NSR)**2
                  ENDIF
               ENDIF
               IF (KEYG==2) FKN(3)=.5*(UI*CAB1+LUMBDA**2*CCD)
!
               IF (KEYG==3.OR.KEYG==4) THEN
                  FKN(1)=CAB
                  FKN(2)=CPQ
                  FKN(3)=VI*CPQ1
               ENDIF
!        --  FKN(4) for KEYG=4 is identical to FKN(3) for KEYG=2
               IF (KEYG==4) FKN(4)=.5*(UI*CAB1+LUMBDA**2*CCD)
!
!   |                               |
!   ---------------------------------
            ENDIF
!
!  --- The general case with rho .ne. 0
!
            IF (KRHO/=0) THEN
!   ---------------------------------
!   |                               |
!
!  --- Corrections to the kernels for impoved filtering accuracy
!
!      FKN(2) and FKN(5) tends to 2*LUMBDA**2 as LUMBDA goes to
!      infinity for z=z'=0.  Since FKN(5) is related to z components
!      of the electric field which are not measured at the earth's
!      surface,  it is not corrected here.  For z' and z < 0, most
!      kernels for the electric field goes to LUMBDA**2 as LUMBDA
!      goes to infinity.  Since no electric field are measured in
!      such cases,  they will not be corrected here.
!
!      FKN(10) goes to LUMBDA as LUMBDA goest to infinity (CAB goes
!      to 1).  FKN(10) is related to Hzx and Hzy.  It is also
!      corrected on the earth's surface.
!
!      The filters used in this program (the filter for functions
!      with opening angle of analycity of pi/4) yield accurate
!      results even for kernels without correction.  However,
!      corrected kernel may allow the use of filters with much
!      higher accuracy (such as those for functions with opening
!      angle of analycity of pi/2 which decays not as fast as
!      the filter for pi/4)
!
!      The corrections must also be done in the routines computing
!      the electric fields,  routine ONE_D_GREEN.   Since z and z' will
!      never be zero in the routine THR_D_GREEN,  no corrections are
!      needed there.
!
               IF (KEYG==1.OR.KEYG==2) THEN
!
                  FKN(1)=CAB
                  IF (KCHRG==0) THEN
                     FKN(2)=LUMBDA**2*CCD1*VI-KKH(NOB)*CAB
!   -- Correct the kernels
                     IF (ABS(ZOB)<.001.AND.ABS(ZSR)<.001) FKN(2)=FKN(2)   &
                       -CMPLX(2.*LUMBDA**2,0.)
                     FKN(3)=LUMBDA**2*CPQ*HVK(NSR)**2
                  ELSE
!   -- Remove the charge terms
                     FKN(2)=(0.,0.)
!  --- Note that the factor before the integral for Gzz after
!      removing the charge term is also different.  In order to
!      simplify routine ONE_D_GREEN,  this factor is considered here.
                     FKN(3)=-KKH(NOB)*CPQ*HVK(NSR)**2
                  ENDIF
!
                  IF (KCHRG==0) THEN
                     FKN(4)=LUMBDA*CCD1*VI-KKH(NOB)/LUMBDA*CAB
                     FKN(5)=LUMBDA**3*CCD*HVK(NSR)**2
                     FKN(6)=LUMBDA*CPQ1*VI*HVK(NSR)**2
                  ELSE
                     FKN(4)=(0.,0.)
                     FKN(5)=-KKH(NOB)*(LUMBDA*CCD-UI/LUMBDA*CAB1)
                     FKN(6)=(0.,0.)
                  ENDIF
!
               ENDIF
!
               IF (KEYG==3.OR.KEYG==4) THEN
!   ---  FKN(1) and FKN(4) are identical to those for KEYG=1 and 2
                  FKN(1)=CAB
                  FKN(2)=CPQ
                  FKN(3)=VI*CPQ1
                  FKN(4)=LUMBDA*CCD1*VI-KKH(NOB)/LUMBDA*CAB
!   --- The fifth kernel for G^x_z for J1 transform are identical
!       to the 9th kernel for the magnetic field.
                  FKN(5)=LUMBDA*CCD-UI/LUMBDA*CAB1
               ENDIF
!
               IF (KEYG==2.OR.KEYG==4) THEN
                  FKN(7)=LUMBDA**2*CCD-UI*CAB1
                  FKN(8)=UI*CAB1
                  FKN(9)=LUMBDA*CCD-UI/LUMBDA*CAB1
               ENDIF
!
!  --- Corrections on cab for sources and receivers in the air
!      and on the air-earth interface.
!      Here 1.E-3 is regarded as zero.
!
               IF (KEYG==2.OR.KEYG==4) THEN
                  IF ((ZSR<0..AND.ZOB<0.).AND.   &
                    (ABS(ZSR)>=1.E-3.OR.ABS(ZOB)>=1.E-3)) THEN
                     FKN(10)=LUMBDA*(CAB-LUMBDA/U0*(CEXP(-U0*ABS(ZOB-ZSR))   &
                           -CEXP(U0*(ZSR+ZOB))))
                  ELSEIF (ABS(ZSR)<1.E-3.AND.ABS(ZOB)<1.E-3) THEN
                     FKN(10)=LUMBDA*(CAB-(1.,0.))
                  ELSE
                     FKN(10)=LUMBDA*CAB
                  ENDIF
                  FKN(11)=LUMBDA*CPQ*HVK(NSR)**2
               ENDIF
!   |                               |
!   ---------------------------------
            ENDIF
!   !                                 !
!   ___________________________________
         ENDIF
!
! ---- Note that the primary parts are now substracted from the
!      final results if Z' and Z are not in the same layer
!
         IF (KPRM==0.AND.NSR/=NOB) THEN
!   ___________________________________
!   !                                 !
            IF (ZOB>=ZSR) THEN
!   ---------------------------------
!   |                               |
               EXPA=CEXP(U0*ZSR-U0*ZOB)
               EB1=LUMBDA/U0*EXPA
               ED1=-1./LUMBDA*EXPA
               EQ1=LUMBDA/V0*EXPA
               PAB=EB1
               PAB1=-EB1
               PCD=ED1
               PCD1=-ED1
               PPQ=EQ1
               PPQ1=-EQ1
!   |                               |
!   ---------------------------------
            ENDIF
!
            IF (ZOB<ZSR) THEN
!   ---------------------------------
!   |                               |
               EXPA=CEXP(-U0*ZSR+U0*ZOB)
               EA2=LUMBDA/U0*EXPA
               EC2=1./LUMBDA*EXPA
               EP2=LUMBDA/V0*EXPA
               PAB=EA2
               PAB1=EA2
               PCD=EC2
               PCD1=EC2
               PPQ=EP2
               PPQ1=EP2
!   |                               |
!   ---------------------------------
            ENDIF
!
            IF (KRHO==0) THEN
!   ---------------------------------
!   |                               |
!
               IF (KEYG==1.OR.KEYG==2) THEN
                  IF (KCHRG==0) THEN
                     FKN(1)   &
                      =.5*(KKH(NOB)*CAB-KKH(NSR)*PAB+LUMBDA**2*(VI*   &
                      CCD1-V0*PCD1))
                     FKN(2)=LUMBDA**2*(CPQ-PPQ)*HVK(NSR)**2
                  ELSE
                     FKN(1)=KKH(NOB)*(CAB-PAB)
                     FKN(2)=-KKH(NOB)*(CPQ-PPQ)*HVK(NSR)**2
                  ENDIF
               ENDIF
               IF (KEYG==2) FKN(3)   &
                 =.5*(UI*CAB1-U0*PAB1+LUMBDA**2*(CCD-PCD))
!
               IF (KEYG==3.OR.KEYG==4) THEN
                  FKN(1)=CAB-PAB
                  FKN(2)=CPQ-PPQ
                  FKN(3)=VI*CPQ1-V0*PPQ1
               ENDIF
               IF (KEYG==4) FKN(4)   &
                 =.5*(UI*CAB1-U0*PAB1+LUMBDA**2*(CCD-PCD))
!   |                               |
!   ---------------------------------
            ENDIF
!
            IF (KRHO/=0) THEN
!   ---------------------------------
!   |                               |
!  --- Remove the charge terms from the kernels if KCHRG=1
!
!  !! This will never happen since KCHRG is set to zero in
!     routine THR_D_HF_TABLE where KPRM can be 0 for separating the
!     primary and the secondary Green's functions.
!
               IF (KEYG==1.OR.KEYG==2) THEN
!
                  FKN(1)=CAB-PAB
                  IF (KCHRG==0) THEN
                     FKN(2)=LUMBDA**2*(CCD1*VI-PCD1*V0)   &
                          -(KKH(NOB)*CAB-KKH(NSR)*PAB)
                     FKN(3)=LUMBDA**2*(CPQ-PPQ)*HVK(NSR)**2
                  ELSE
                     FKN(2)=(0.,0.)
                     FKN(3)=-KKH(NOB)*(CPQ-PPQ)*HVK(NSR)**2
                  ENDIF
!
                  IF (KCHRG==0) THEN
                     FKN(4)=LUMBDA*(CCD1*VI-PCD1*V0)   &
                          -(KKH(NOB)*CAB-KKH(NSR)*PAB)/LUMBDA
                     FKN(5)=LUMBDA**3*(CCD-PCD)*HVK(NSR)**2
                     FKN(6)=LUMBDA*(CPQ1*VI-PPQ1*V0)*HVK(NSR)**2
                  ELSE
                     FKN(4)=(0.,0.)
                     FKN(5)=-KKH(NOB)*(LUMBDA*CCD-UI/LUMBDA*CAB1)+KKH(NSR)   &
                          *(LUMBDA*PCD-U0/LUMBDA*PAB1)
                     FKN(6)=(0.,0.)
                  ENDIF
!
               ENDIF
!
               IF (KEYG==3.OR.KEYG==4) THEN
                  FKN(1)=CAB-PAB
                  FKN(2)=CPQ-PPQ
                  FKN(3)=VI*CPQ1-V0*PPQ1
                  FKN(4)=LUMBDA*(CCD1*VI-PCD1*V0)   &
                       -(KKH(NOB)*CAB-KKH(NSR)*PAB)/LUMBDA
                  FKN(5)=LUMBDA*(CCD-PCD)-(UI*CAB1-U0*PAB1)/LUMBDA
               ENDIF
!
               IF (KEYG==2.OR.KEYG==4) THEN
                  FKN(7)=LUMBDA**2*(CCD-PCD)-(UI*CAB1-U0*PAB1)
                  FKN(8)=UI*CAB1-U0*PAB1
                  FKN(9)=LUMBDA*(CCD-PCD)-(UI*CAB1-U0*PAB1)/LUMBDA
               ENDIF
!
               IF (KEYG==2.OR.KEYG==4) THEN
                  FKN(10)=LUMBDA*(CAB-PAB)
                  FKN(11)=LUMBDA*(CPQ-PPQ)*HVK(NSR)**2
               ENDIF
!   |                               |
!   ---------------------------------
            ENDIF
!   !                                 !
!   ___________________________________
         ENDIF
!   *                                    *
!   **************************************
      ENDIF
!
!  --- Magnetic dipoles
!
      IF (KEMD==2) THEN
!   **************************************
!   *                                    *
!
!   -- Kernel for magnetic dipoles do not separate primary and
!      secondary parts if source and receiver are not in the
!      same layer.  However,  this can be readily modified by
!      following the computations above for the electric dipoles
!      (extra computation of PAB etc.).
!
         IF (KPRM==0.AND.NSR/=NOB) THEN
            WRITE (*,1010)
!            WRITE (4,1010)
            STOP 'Program aborted.  Check error messages in OUTPUT.OUT'
         ENDIF
!
         IF (KRHO/=0) THEN
!   ___________________________________
!   !                                 !
!
!   -- In order to make the output compatible with the electric
!      dipoles cases so that routine HFIL needs not
!      be changed,  here the output FKN are order in the same way
!      as for the electric dipoles, namely, FKN(1-3) and FKN(7-8)
!      are for the J0 transforms and the rest are for the J1
!      transforms.  Since only 8 distinctive kernels exist for
!      the magnetic dipoles,  some elements of FKN are not used.
!      Note that in Exx, Eyx, etc. of the following comments the
!      first indices are for the field compoments directions and
!      the second indices are for the source orientations.
!
!      On the earth's surface CAB and CAB1 goes to 1, DCAB and
!      DCAB1 goes to LUMBDA as LUMBDA goes to infinity.
!
!      Note that all kernels for both the electric fields and the
!      magnetic fields are computed although sometimes only one
!      set of them are required.  The following computations are
!      trivial in CPU times as compared to that needed by the other
!      parts of this routine.
!
            DG=DCCD-DCAB1*UI/LUMBDA/LUMBDA
!
            FKN(1)=VI*(HVK(NSR)**2*CPQ1+DCCD1)*LUMBDA*LUMBDA-KKH(NOB)*DCAB
            FKN(2)=DCAB
            FKN(3)=UI*DCAB1
            FKN(4)=VI*(HVK(NSR)**2*CPQ1+DCCD1)*LUMBDA-KKH(NOB)*DCAB/LUMBDA
            FKN(5)=HVK(NSR)**2*(HVK(NOB)**2*CPQ+DCCD)*LUMBDA*LUMBDA*LUMBDA
            FKN(6)=LUMBDA*CAB
            FKN(7)=(DG+HVK(NSR)**2*CPQ)*LUMBDA*LUMBDA
            IF (KPRM==1.AND.ABS(ZSR-ZOB)<1.E-4) THEN
               FKN(8)=(CAB-(1.,0.))*LUMBDA*LUMBDA
            ELSE
               FKN(8)=CAB*LUMBDA*LUMBDA
            ENDIF
            FKN(9)=LUMBDA*(DG+HVK(NSR)**2*CPQ)
            FKN(10)=LUMBDA*DCAB
            FKN(11)=LUMBDA*UI*CAB1
!   !                                 !
!   ___________________________________
         ENDIF
!
         IF (KRHO==0) THEN
!   ___________________________________
!   !                                 !
            DG=DCCD-UI/LUMBDA**2*DCAB1
!
            FKN(1)=.5*DCAB*KKH(NOB)+.5*                                    &
                   (VI*(HVK(NSR)**2*CPQ1+DCCD1)*LUMBDA*LUMBDA) ! Eyx and Exy
            FKN(2)=UI*DCAB1+.5*LUMBDA**2*(DG+HVK(NSR)**2*CPQ)  ! Hxx and Hyy
            FKN(3)=CAB*LUMBDA*LUMBDA                           ! Hzz
!   !                                 !
!   ___________________________________
         ENDIF
!   *                                    *
!   **************************************
      ENDIF
!
      RETURN
!
 1010 FORMAT ('Error: kernels for magnetic dipoles do not ',   &
            'separate primary and secondary ',/'parts if ',   &
            'source and receiver are not in the same layer.',   &
            /'Modify routine ONE_D_KERNEL if you want to.')
!
   END SUBROUTINE ONE_D_KERNEL
!
!
   SUBROUTINE ONE_D_0_2_INFTY(KEYG,KEMD,MLAYER,ZBND,LRYTH,HVK,KKH,KANIS,KPRM, &
                              KITG,KCHRG,NOB,NSR,ZOB,ZSRH,ZSRL,ALMAX,KEH,S)
!
!****   Numerical integration for the case rho = 0
!
!       The integration range is from 0 to infinity. This routine determines
!       the upper integral limit automatically by double the integration
!       interval untill convergence is reached.
!
!    Input parameters:
!
!       KEH : =1, 2, 3, or 4 represents the number of the kernel values
!              for the field components. For magnetic dipoles,  the
!              first one is for the E-fields, and the last two are for
!              the H-fields.   KEH depends on the values of KEYG and KEMD.
!
!              For electric dipoles,  KEMD=1:
!
!                KEYG=1:  KEH=2,  the two elements for the general electric
!                         Green's function;
!                KEYG=2:  KEH=3,  the first two are for the E-fields,
!                         and the third one is for the H-fields;
!                KEYG=3:  KEH=3,  the three elements for the current and
!                         charge terms of the electric Green's function.
!                         in the case of KEYG=1.  The last one is for the
!                         magnetic field (as the third element as in the
!                         case of KEYG=2);  and
!                KEYG=4:  KEH=4,  the first three elements are those as
!                         in the case of KEYG=3.  The last one is for the
!                         magnetic field (as the third element as in the
!                         case of KEYG=2).
!
!              For magnetic dipoles,  KEMD=2:
!
!                KEYG=1:  KEH=1;  and
!                KEYG=3:  KEH=2.
!
!              KEH is defined in routines THR_D_HF_TABLE and ONE_D_HF_TABLE
!              (parameter NS)
!
!       Parameters KEMD, MLAYER, ZBND, LRYTH, HVK, KKH, KANIS, KPRM,
!       KITG, KCHRG, NOB,  NSR and ALMAX are to be passed to routine
!       kernel.  See routine kernel for their descriptions.
!
!    Output parameters:
!
!       S:  Complex S(4).  Kernels for electric or magnetic fields in case
!           rho=0 (source and receiver above one another).   See the above
!           description for KEH.
!
!****  CALLED by:  gridhf, gridcs
!
!****  CALLS    :  simpsn
!
!
      IMPLICIT NONE
!
      INTEGER, INTENT(IN) :: KEYG,KANIS,KCHRG,KEH,KEMD,KITG,KPRM,           &
                             MLAYER,NOB,NSR
      COMPLEX, INTENT(IN) :: KKH(0:MLAYER)
      REAL, INTENT(IN) :: LRYTH(MLAYER),HVK(0:MLAYER),ZBND(0:MLAYER),       &
                          ALMAX,ZOB,ZSRH,ZSRL
      COMPLEX, INTENT(OUT) :: S(4)
!
      REAL :: A0,A1,B1,T
      INTEGER :: I,J,N,NINT,KRHO
      COMPLEX :: S0(4)
!
! --- EPS is the desired relative accuracy of numerical intergaration.
!
      REAL, PARAMETER :: EPS=1.E-4
!
!  -- Parameter KRHO is required by routine ONE_D_KERNEL.
!     KRHO=0 means rho is zero
!
      KRHO=0
!
      A0=1.E-8
      A1=A0
      B1=1.E-4
      T=B1-A0
      DO I=1,KEH
         S(I)=(0.,0.)
      ENDDO
      CALL ONE_D_SIMPSON(KEYG,KEMD,MLAYER,ZBND,LRYTH,HVK,KKH,KANIS,KPRM,   &
                         KRHO,KITG,KCHRG,NOB,NSR,ZOB,ZSRH,ZSRL,            &
                         A1,B1,EPS,8,N,KEH,S0,S)
      DO J=1,KEH
         S(J)=S0(J)
      ENDDO
      NINT=N
  100 A1=B1
      B1=A1+T*2.
      IF (B1>ALMAX) THEN
!       WRITE (4,*)' Warning: Numerical integration did not converge.',
!    &            ' Upper limit tended to infinity.',
!    &            ' Terminated automatically.'
!       DO 2 I=1,KEH
! 2     WRITE (4,*)' Accuracy of integration: ',
!    &             CABS(S0(I))/(1.E-30+CABS(S(I)))
!
!******  Return
!
         RETURN
      ENDIF
      CALL ONE_D_SIMPSON(KEYG,KEMD,MLAYER,ZBND,LRYTH,HVK,KKH,KANIS,KPRM,   &
                         KRHO,KITG,KCHRG,NOB,NSR,ZOB,ZSRH,ZSRL,            &
                         A1,B1,EPS,8,N,KEH,S0,S)
      DO J=1,KEH
         S(J)=S(J)+S0(J)
      ENDDO
      NINT=NINT+N
      T=B1-A0
      DO I=1,KEH
         IF (CABS(S0(I))>(1.E-30+CABS(S(I)))*EPS) THEN
            GOTO 100
         ENDIF
      ENDDO
!
      RETURN
!
   END SUBROUTINE ONE_D_0_2_INFTY
!
!
   SUBROUTINE ONE_D_SIMPSON(KEYG,KEMD,MLAYER,ZBND,LRYTH,HVK,KKH,KANIS,   &
                            KPRM,KRHO,KITG,KCHRG,NOB,NSR,ZOB,ZSRH,ZSRL,  &
                            A,B,EPS,K,N,KEH,S,ST)
!
!****   NUMERICAL INTEGRATION USING ONE_D_SIMPCSSON'S RULE
!       FOR A LIMITED ROI_INTERVAL [A, B]
!
!    Input parameters:
!
!      A:    Real.  Lower limit of the interval of integration.
!      B:    Real.  Upper limit of the interval of integration.
!      EPS:  Real.  Desired relative accuracy of the numerical
!            integration.
!      K:    Integer.  Miminal number of steps for the prevention
!            of false convergence.
!      ST:   Complex.  The accumulative sum of the integrals in
!            all previous intervals.  It is used to check if the
!            results for the interval [A, B] is significant for
!            accurate computation.
!
!      Parameter KEH is defined in routine ONE_D_0_2_INFTY.  See detailed
!      description in that routine.
!
!      Parameters KEMD, MLAYER, ZBND, LRYTH, HVK, KKH, KANIS, KPRM,
!      KRHO, KITG, KCHRG, NOB,  NSR,  and FKN are to be passed
!      to routine kernel.  See routine kernel for their descriptions.
!
!    Output parameters:
!
!      N:    Integer. Number of steps used for convergence.
!
!            Note that the parameter NLIM controls the maximal
!            number of steps in the integration.  In actual modeling
!            problems the numerical integration here occasionally
!            do not converge,  no matter how large NLIM is.
!            However, this have little effects on the final results.
!            But the computation can be greatly affected by NLIM.
!            NLIM is preasigned in the parameter list.
!
!      S:    Complex S(5).  Results of the integration.  Check
!            routine ONE_D_0_2_INFTY for detailed description.
!
!
!    Note that there are multiple returns and gotos due to the complexity
!    of convergence tests.  They are marked by five stars like *****.
!
!
!****   CALLED by:  simpinf
!
!****   CALLS    :  kernel
!
      IMPLICIT NONE
!
!
      INTEGER, INTENT(IN) :: KANIS,KCHRG,KEH,KEMD,KITG,KPRM,KRHO,MLAYER, &
                             NOB,NSR,KEYG
      COMPLEX, INTENT(IN) :: ST(3)
      COMPLEX, INTENT(OUT) :: S(4)
      COMPLEX :: S0(4),T1(4),T2(4),FKN(11)
      COMPLEX, INTENT(IN) :: KKH(0:MLAYER)
      REAL, INTENT(IN) :: LRYTH(MLAYER),HVK(0:MLAYER),ZBND(0:MLAYER)
      INTEGER, INTENT(OUT) :: N
      REAL, INTENT(IN) :: A,B,EPS,ZOB,ZSRH,ZSRL
      REAL :: H,X,C
      INTEGER ::  I,J,K
      INTEGER, PARAMETER :: NLIM=1024
!
      DO I=1,KEH
         S0(I)=(0.,0.)
      ENDDO
!
      N=1
      C=ABS(A)+ABS(B)
      H=.5*(B-A)
!
      CALL ONE_D_KERNEL(KEYG,KEMD,MLAYER,ZBND,LRYTH,HVK,KKH,KANIS,KPRM,KRHO, &
                        KITG,KCHRG,NOB,NSR,ZOB,(ZSRH+ZSRL)/2.,ZSRH,ZSRL,A,FKN)
!
      DO J=1,KEH
         T1(J)=H*FKN(J)
      ENDDO
!
      CALL ONE_D_KERNEL(KEYG,KEMD,MLAYER,ZBND,LRYTH,HVK,KKH,KANIS,KPRM,KRHO, &
                        KITG,KCHRG,NOB,NSR,ZOB,(ZSRH+ZSRL)/2.,ZSRH,ZSRL,B,FKN)
!
      DO J=1,KEH
         T1(J)=T1(J)+H*FKN(J)
      ENDDO
!
!***** Branch entry point for GOTO 10
!
  100 X=A-H
      DO J=1,KEH
         T2(J)=.5*T1(J)
      ENDDO
      DO I=1,N
         X=X+2.*H
         CALL ONE_D_KERNEL(KEYG,KEMD,MLAYER,ZBND,LRYTH,HVK,KKH,KANIS,KPRM, &
                           KRHO,KITG,KCHRG,NOB,NSR,ZOB,(ZSRH+ZSRL)/2.,     &
                           ZSRH,ZSRL,X,FKN)
         DO J=1,KEH
            T2(J)=T2(J)+H*FKN(J)
         ENDDO
      ENDDO
      DO J=1,KEH
         S(J)=.333333333*(4.*T2(J)-T1(J))
      ENDDO
!
! ---- K is used to prevent false convergence
!
      IF (N>K) THEN
!-------------------------------
!|                             |
!
! ---- If convrged within the interval [a,b], then return
!
         DO I=1,KEH
            IF (CABS(S(I)-S0(I))>(1.E-30+CABS(S(I)))*EPS) THEN
               GOTO 150
            ENDIF
         ENDDO
!
!***** Return
!
         RETURN
!
! ---- In case inconvergence within the interval [a,b], still
!      return if the absolut values of the integrals for this
!      interval are less than eps times the integrals over the
!      whole interval (0,b] or if step number is over NLIM.
!
!***** Branch entry point for GOTO 30
!
  150    DO I=1,KEH
            IF (CABS(S(I))>CABS(ST(I))*EPS) THEN
               GOTO 200
            ENDIF
         ENDDO
!
!***** Return
!
         RETURN
!
!***** Branch entry point for GOTO 40
!
  200    IF (N>=NLIM) THEN
            DO I=1,KEH
               S0(I)=(S(I)-S0(I))/(CABS(S(I))+CABS(ST(I))+1.E-30)
            ENDDO
!
! ---- Warning will be issued if the total accuracy (relative)
!      is worse than EPS
!
            DO I=1,KEH
               IF (CABS(S0(I))>EPS) THEN
!          WRITE (4,*) 'Warning: numerical integration ',
!    &                'did not converge!'
!          WRITE (4,*) ' Accuracy of integration:',
!    &                (CABS(S0(II)),II=1,KEH)
!
!***** Return
!
                  RETURN
               ENDIF
            ENDDO
!
!***** Return
!
            RETURN
         ENDIF
!
!|                             |
!-------------------------------
      ENDIF
!
      N=N+N
      H=.5*H
      DO J=1,KEH
         S0(J)=S(J)
         T1(J)=T2(J)
      ENDDO
!
!***** Restart of a new iteration if the step length is still
!      distinguishable by the machine.
!
      IF (ABS(C+H-C)>1.E-37) THEN
         GOTO 100
      ENDIF
!
      WRITE (4,*) ' Warning: numerical integration step ',      &
                  ' tends to zero. Terminated automatically',   &
                  'A, B and N =',A,B,N
!
      RETURN
!
   END SUBROUTINE ONE_D_SIMPSON
!
!
   SUBROUTINE ONE_D_SIMPCS(A,B,EPS,N,FK,S,RDJXYZ,AJ,CS_TYPE,KEMD,KEYG,   &
                           PSTION,FRQ,MLAYER,ZBND,KKH,CDH,NZOB,ZOBG,     &
                           NZSR,ZSRG,RHOMIN,NHFILM,RRG,NRG,GRHF,GRHO0)
!
!****    Simpson integration of an arbitrary function
!
!   Input parameters:
!
!      A:    Real.  Lower limit of the interval of integration.
!      B:    Real.  Upper limit of the interval of integration.
!      EPS:  Real.  Desired relative accuracy of the numerical
!            integration.
!      FK:   external subroutine that generates NF function
!            values passed by the array F.
!      RDJXYZ: Real,  parameter to be passed to routines ONE_D_LINE
!            or ONE_D_CIRCLE.  It is either RAD for ONE_D_CIRCLE or AJXYZ
!            for ONE_D_LINE.  See routine ONE_D_CIRCLE or ONE_D_LINE for
!            descriptions of the two parameters.
!
!      Parameters CS_TYPE, KEMD, KEYG, PSTION, FRQ, MLAYER, ZBND,
!      KKH, CDH, NZOB, ZOBG, NZSR, ZSRG,  RHOMIN, NHFILM,
!      RRG, NRG, GRHF, and GRHO0 are to be passed into routine ONE_D_GREEN.
!      See ONE_D_GREEN for detailed descriptions.
!
!   Output parameters:
!
!      N:    Integer,  the number of steps used for convergence.
!      S:    Complex S(6).  Up to 6 integrals are computed
!            simultaneously.
!
!
!   Remarks:
!
!      Tests have shown that the numerical integrations need
!      be done in double precisions for circular loops because
!      of the canceling of the components.  With single
!      precisions computations the time domain magnetic fields
!      were very inaccurate.  Even with double precisions those
!      time domain results (after Fourier transform of the
!      frequency domain results) cannot have an accuracy of 1 %,
!      while the frequency domain results can supposedly have
!      an maximal accuracy of 1.E-4.  Increasing the number
!      of steps for the numerical integrations here does not
!      seem to solve the problem.
!
!    Note that this routine needs a kernel routine defined as
!    Subroutine FK(KEMD,X,NF,F) where X is the integration variable,
!    KEMD is to be passed to the routine ONE_D_GREEN which computes EM
!    field components due to dipoles, NF is the number of functions
!    to be integrated (NF <= 6),  and F (Complex F(6)) contains the
!    values of the kernel functions that are integrated.
!
!    In order to avoid double complex operation which is non-standard
!    on PCs,  complex operations are broken into double precision
!    real computations.
!
!    Note that there are multiple gotos due to the complexity of
!    convergence tests.  They are marked by five stars like *****.
!
!****  CALLED by:  csource
!
!****  CALLS    :  line, circle
!
!
      IMPLICIT NONE
!
      INTEGER, INTENT(IN) :: KEMD,NZOB,NZSR,NHFILM,NRG,CS_TYPE,KEYG,MLAYER
      REAL, INTENT(IN) :: A,AJ,B,EPS
      REAL, INTENT(IN) :: RDJXYZ
      COMPLEX, INTENT(OUT) :: S(6)
!
      INTEGER :: I,J,KCONT,NF,N
      REAL :: H,SM,X,C,RS,AS
      COMPLEX :: F(6),S0(6)
      DOUBLE PRECISION RT2(6),AT2(6),RT1(6),AT1(6)
      INTEGER, PARAMETER :: K=4,NLIMT=512
      EXTERNAL FK
!
! --- Parameters solely used for data passing
!
      COMPLEX, INTENT(IN) :: KKH(0:MLAYER),CDH(0:MLAYER),                 &
                             GRHF(11,NHFILM,NZSR,NZOB),GRHO0(4,NZSR,NZOB)
      REAL, INTENT(IN) :: ZBND(0:MLAYER),ZOBG(NZOB),ZSRG(2,NZSR),         &
                          FRQ,RHOMIN,RRG(NRG),PSTION(8)
!
      DO I=1,6
         S0(I)=(0.,0.)
      ENDDO
!
      N=1
      C=ABS(A)+ABS(B)
      H=.5*(B-A)
!
      CALL FK(A,RDJXYZ,AJ,NF,F,CS_TYPE,KEMD,KEYG,PSTION,FRQ,MLAYER,ZBND,    &
              KKH,CDH,NZOB,ZOBG,NZSR,ZSRG,RHOMIN,NHFILM,RRG,NRG,GRHF,GRHO0)
      DO I=1,NF
         RT1(I)=DBLE(H)*DBLE(REAL(F(I)))
         AT1(I)=DBLE(H)*DBLE(AIMAG(F(I)))
      ENDDO
      CALL FK(B,RDJXYZ,AJ,NF,F,CS_TYPE,KEMD,KEYG,PSTION,FRQ,MLAYER,ZBND,    &
              KKH,CDH,NZOB,ZOBG,NZSR,ZSRG,RHOMIN,NHFILM,RRG,NRG,GRHF,GRHO0)
      DO I=1,NF
         RT1(I)=RT1(I)+DBLE(H)*DBLE(REAL(F(I)))
         AT1(I)=AT1(I)+DBLE(H)*DBLE(AIMAG(F(I)))
      ENDDO
!
!***** Branch entry point for GOTO 10
!
  100 X=A-H
      DO I=1,NF
         RT2(I)=.5D0*RT1(I)
         AT2(I)=.5D0*AT1(I)
      ENDDO
      DO I=1,N
         X=X+2.*H
         CALL FK(X,RDJXYZ,AJ,NF,F,CS_TYPE,KEMD,KEYG,PSTION,FRQ,MLAYER,ZBND,  &
                 KKH,CDH,NZOB,ZOBG,NZSR,ZSRG,RHOMIN,NHFILM,RRG,NRG,GRHF,GRHO0)
         DO J=1,NF
            RT2(J)=RT2(J)+DBLE(H)*DBLE(REAL(F(J)))
            AT2(J)=AT2(J)+DBLE(H)*DBLE(AIMAG(F(J)))
         ENDDO
      ENDDO
      DO I=1,NF
         RS=SNGL((4.D0*RT2(I)-RT1(I))/3.D0)
         AS=SNGL((4.D0*AT2(I)-AT1(I))/3.D0)
         S(I)=CMPLX(RS,AS)
      ENDDO
!
! --- K is the minimal number of steps necessary to provent
!     from false convergence
!
      IF (N>=K) THEN
!
! --- The number of steps is limited to be NLIMT
!
!     For circular loops it is very likely that the number of
!     steps exceed the designed limit and the accuracy of
!     integration is less than 1.E-4.  Thus no warnings will
!     be issued for such cases
!
         IF (N>=NLIMT) THEN
!  -- KCONT controls whether the integration should continue
            KCONT=0
            IF (ABS(B-6.28319)>.001) THEN
               SM=CABS(S(1))
               DO I=2,NF
                  IF (SM<CABS(S(I))) SM=CABS(S(I))
               ENDDO
!            DO I=1,NF
!               ERR=CABS(S(I)-S0(I))/(1.E-30+SM)
!              IF(ERR.GT.EPS) WRITE (4,20) ERR,I,NF
!            ENDDO
            ENDIF
         ENDIF
! 20     FORMAT('Warning: Number of steps for numerical ',
!             'integration exceeded maximum allowed.',
!            /'Ralative error: ',1PE11.3,'  for  I=',I2,
!             '  and  NF=',I2)
!
! --- Test convergence
!
!     Due to numerical inaccuracy,  some components may be
!     very small.  Thus the accuracy of integration is relative
!     to the maximum of all components
!
         IF (N<NLIMT) THEN
            SM=CABS(S(1))
            DO I=2,NF
               IF (SM<CABS(S(I))) SM=CABS(S(I))
            ENDDO
            DO I=1,NF
               IF (CABS(S(I)-S0(I))>(1.E-30+SM)*EPS) THEN
                  KCONT=1
!
!***** Goto 50
!
                  GOTO 200
               ENDIF
            ENDDO
            KCONT=0
         ENDIF
!
      ENDIF
!
! --- Reduce the step and start a new loop
!
  200 IF (N<K.OR.KCONT==1) THEN
!
         N=N+N
         DO I=1,NF
            S0(I)=S(I)
            RT1(I)=RT2(I)
            AT1(I)=AT2(I)
         ENDDO
         H=.5*H
!
!***** Restart of a new iteration if the step length is still
!      distinguishable by the machine.
!
         IF (ABS(C+H-C)>1.E-37) THEN
            GOTO 100
         ENDIF
         N=-N
         WRITE (4,*) 'Warning: Step in numerical integration tended to zero.'
!
      ENDIF
!
      RETURN
!
   END SUBROUTINE ONE_D_SIMPCS
!
!
   SUBROUTINE ONE_D_LINE (X,AJXYZ,AJ,NF,F,CS_TYPE,KEMD,KEYG,PSTION,FRQ,    &
                          MLAYER,ZBND,KKH,CDH,NZOB,ZOBG,NZSR,ZSRG,RHOMIN,  &
                          NHFILM,RRG,NRG,GRHF,GRHO0)
!
!****   Kernel for the Numerical Integration of a
!       Line Current Along the Coordinate Axes
!
!
!   Input parameters:
!
!       AJXYZ:  Real,  controlling parameter for the axis the current
!               line lies along.  AJXYZ is used to pass the integer
!               parameter JXYZ to routine ONE_D_SIMPCS.  ONE_D_SIMPCS calls
!               routines ONE_D_LINE and ONE_D_CIRCLE.  Because the first
!               parameter in the arguement list of ONE_D_CIRCLE is real,
!               the parameter AJXYZ is introduced to make the arguement
!               list of ONE_D_CIRCLE and ONE_D_LINE to be compatible.
!               The value of AJXYZ (or JXYZ) means:
!               = 1: x-direction;
!                 2: y-direction; and
!                 3: z-direction.
!       AJ:    Real(*4),  amplitude of current.  It is usually 1.
!       X:     Real,  integration vaiable.
!       KEYG:  Integer(*4),  mode of computation which controls if magnetic
!              fields need to be computed,  and thus controlling the
!              number of output functions,  NF.  KEYG is also passed into
!              routine ONE_D_GREEN.  See ONE_D_GREEN for more description.
!
!
!
!      Parameters CS_TYPE, KEMD, KEYG, PSTION, FRQ, MLAYER, ZBND,
!      KKH, CDH, NZOB, ZOBG, NZSR, ZSRG,  RHOMIN, NHFILM,
!      RRG, NRG, GRHF, and GRHO0 are to be passed into routine ONE_D_GREEN.
!      See ONE_D_GREEN for detailed descriptions.
!
!   Output parameters:
!
!       NF:    Integer,  number functions (field components) to be
!              integrated.  It is controlled by the parameter KEYG.
!              NF=3 if KEYG=1,  and NF=6 if KEYG=2.
!       F:     Complex(*8) F(6),  returned NF field components.
!              The first three elements are electric field components
!              and the last three,  if computed (KEYG=2),  are magnetic
!              field components.
!
!****  CALLED by:  csource, simp
!
!****  CALLS:      green
!
!
      IMPLICIT NONE
!
      INTEGER, INTENT(IN) :: KEMD,NZOB,NZSR,NHFILM,NRG,CS_TYPE,MLAYER,KEYG
      REAL, INTENT(IN) :: PSTION(8),AJXYZ,AJ
      INTEGER, INTENT(OUT) :: NF
      COMPLEX, INTENT(OUT) :: F(6)
      COMPLEX :: ECOMP(9),HCOMP(9),                     &
                 EXX,EYX,EZX,EXY,EYY,EZY,EXZ,EYZ,EZZ,   &
                 HXX,HYX,HZX,HXY,HYY,HZY,HXZ,HYZ,HZZ
      REAL :: X,X_LINE,Y_LINE,XX,X1,X2,Y1,Y2,PSTN(8)
      INTEGER :: I,JXYZ
!
! --- Parameters used solely for data passing
!
      COMPLEX, INTENT(IN) :: KKH(0:MLAYER),CDH(0:MLAYER),                  &
                             GRHF(11,NHFILM,NZSR,NZOB),GRHO0(4,NZSR,NZOB)
      REAL, INTENT(IN) :: ZBND(0:MLAYER),ZOBG(NZOB),ZSRG(2,NZSR),          &
                          FRQ,RHOMIN,RRG(NRG)
!
      EQUIVALENCE (ECOMP(1),EXX),(ECOMP(2),EYX),(ECOMP(3),EZX),   &
                  (ECOMP(4),EXY),(ECOMP(5),EYY),(ECOMP(6),EZY),   &
                  (ECOMP(7),EXZ),(ECOMP(8),EYZ),(ECOMP(9),EZZ),   &
                  (HCOMP(1),HXX),(HCOMP(2),HYX),(HCOMP(3),HZX),   &
                  (HCOMP(4),HXY),(HCOMP(5),HYY),(HCOMP(6),HZY),   &
                  (HCOMP(7),HXZ),(HCOMP(8),HYZ),(HCOMP(9),HZZ)
!
      X_LINE (XX)=(Y2-Y1)/(X2-X1)*(XX-X1)+Y1
      Y_LINE (XX)=(X2-X1)/(Y2-Y1)*(XX-Y1)+X1
!
      X1=PSTION(4)
      Y1=PSTION(5)
      X2=PSTION(7)
      Y2=PSTION(8)
!
! --- Take the integer value of AJXYZ
!
      JXYZ=INT(AJXYZ+.1)
!
      IF (KEYG==1) THEN
         NF=3
      ELSE
         NF=6
      ENDIF
!
! --- The array PSTN is used to pass soure and receiver positions
!     to routine ONE_D_GREEN,  so that the values in the array PSTION
!     won't be altered after this routine is called.  This may not
!     be necessary here in this routine but using PSTN is much safer.
!
      DO I=1,8
         PSTN(I)=PSTION(I)
      ENDDO
!
      IF (JXYZ==1) THEN
!
         PSTN(4)=X
         PSTN(5)=X_LINE(X)
         CALL ONE_D_GREEN(CS_TYPE,KEMD,KEYG,PSTN,FRQ,MLAYER,ZBND,KKH,CDH,   &
                          NZOB,ZOBG,NZSR,ZSRG,RHOMIN,NHFILM,RRG,NRG,GRHF,   &
                          GRHO0,ECOMP,HCOMP)
!
         F(1)=(EXX+EXY*(Y2-Y1)/(X2-X1))*AJ
         F(2)=(EYX+EYY*(Y2-Y1)/(X2-X1))*AJ
         F(3)=(EZX+EZY*(Y2-Y1)/(X2-X1))*AJ
         IF (NF==6) THEN
            F(4)=(HXX+HXY*(Y2-Y1)/(X2-X1))*AJ
            F(5)=(HYX+HYY*(Y2-Y1)/(X2-X1))*AJ
            F(6)=(HZX+HZY*(Y2-Y1)/(X2-X1))*AJ
         ENDIF
!
      ELSEIF (JXYZ==2) THEN
!
         PSTN(5)=X
         PSTN(4)=Y_LINE(X)
         CALL ONE_D_GREEN(CS_TYPE,KEMD,KEYG,PSTN,FRQ,MLAYER,ZBND,KKH,CDH,  &
                          NZOB,ZOBG,NZSR,ZSRG,RHOMIN,NHFILM,RRG,NRG,GRHF,  &
                          GRHO0,ECOMP,HCOMP)
!
         F(1)=(EXY+EXX*(X2-X1)/(Y2-Y1))*AJ
         F(2)=(EYY+EYX*(X2-X1)/(Y2-Y1))*AJ
         F(3)=(EZY+EZX*(X2-X1)/(Y2-Y1))*AJ
         IF (NF==6) THEN
            F(4)=(HXY+HXX*(X2-X1)/(Y2-Y1))*AJ
            F(5)=(HYY+HYX*(X2-X1)/(Y2-Y1))*AJ
            F(6)=(HZY+HZX*(X2-X1)/(Y2-Y1))*AJ
         ENDIF
!
      ELSE
!
         PSTN(6)=X
         CALL ONE_D_GREEN(CS_TYPE,KEMD,KEYG,PSTN,FRQ,MLAYER,ZBND,KKH,CDH,  &
                          NZOB,ZOBG,NZSR,ZSRG,RHOMIN,NHFILM,RRG,NRG,GRHF,  &
                          GRHO0,ECOMP,HCOMP)
!
         F(1)=EXZ*AJ
         F(2)=EYZ*AJ
         F(3)=EZZ*AJ
         IF (NF.EQ.6) THEN
            F(4)=HXZ*AJ
            F(5)=HYZ*AJ
            F(6)=HZZ*AJ
         ENDIF
!
      ENDIF
!
      RETURN
!
   END SUBROUTINE ONE_D_LINE
!
!
   SUBROUTINE ONE_D_CIRCLE (THETA,RAD,AJ,NF,F,CS_TYPE,KEMD,KEYG,PSTION,     &
                            FRQ,MLAYER,ZBND,KKH,CDH,NZOB,ZOBG,NZSR,ZSRG,    &
                            RHOMIN,NHFILM,RRG,NRG,GRHF,GRHO0)
!
!****     Kernel for the Numerical Integration of a
!         Horizontal Circular Loop Current
!
!
!   Input parameters:
!
!       RAD:   Real(*4),  radius of the loop.
!       AJ:    Real, amplitude of current.  It is usually 1.
!       THETA: Real, angle of the line from the dipole location
!              on the circle to the loop center with respect to
!              the x axis.   It is the integration variable.
!              THETA is defined arbitrarily. The integration
!              should be from 0 to 2*pi.
!       KEYG:  Integer,  mode of computation which controls if magnetic
!              fields need to be computed,  and thus controlling the
!              number of output functions,  NF.  KEYG is also passed into
!              routine ONE_D_GREEN.  See ONE_D_GREEN for more description.
!
!       Parameters CS_TYPE, KEMD, KEYG, PSTION, FRQ, MLAYER, ZBND,
!       KKH, CDH, NZOB, ZOBG, NZSR, ZSRG,  RHOMIN, NHFILM,
!       GRHF, and GRHO0 are to be passed into routine ONE_D_GREEN.
!       See ONE_D_GREEN for detailed descriptions.
!
!   Output parameters:
!
!       NF:    Integer,  number functions (field components) to be
!              integrated.  It is controlled by the parameter KEYG.
!              NF=3 if KEYG=1,  and NF=6 if KEYG=2.
!       F:     Complex(*8) F(6),  returned NF field components.
!              The first three elements are electric field components
!              and the last three,  if computed (KEYG=2),  are magnetic
!              field components.
!
!
!****  CALLED by:  simp
!
!****  CALLS    :  green
!
!
      IMPLICIT NONE
!
      INTEGER, INTENT(IN) :: KEMD,NZOB,NZSR,NHFILM,NRG,CS_TYPE,KEYG,MLAYER
      INTEGER, INTENT(OUT) :: NF
      COMPLEX, INTENT(OUT) :: F(6)
      REAL, INTENT(IN) :: PSTION(8),RAD,THETA,AJ
      INTEGER :: I
      REAL :: PSTN(8),SN,CS
      COMPLEX :: ECOMP(9),HCOMP(9),                         &
                 EXX,EYX,EZX,EXY,EYY,EZY,EXZ,EYZ,EZZ,       &
                 HXX,HYX,HZX,HXY,HYY,HZY,HXZ,HYZ,HZZ
!
! --- Parameters used solely for data passing
!
      COMPLEX, INTENT(IN) :: KKH(0:MLAYER),CDH(0:MLAYER),                  &
                             GRHF(11,NHFILM,NZSR,NZOB),GRHO0(4,NZSR,NZOB)
      REAL, INTENT(IN) :: ZBND(0:MLAYER),ZOBG(NZOB),ZSRG(2,NZSR),          &
                          FRQ,RHOMIN,RRG(NRG)
!
      EQUIVALENCE (ECOMP(1),EXX),(ECOMP(2),EYX),(ECOMP(3),EZX),   &
                  (ECOMP(4),EXY),(ECOMP(5),EYY),(ECOMP(6),EZY),   &
                  (ECOMP(7),EXZ),(ECOMP(8),EYZ),(ECOMP(9),EZZ),   &
                  (HCOMP(1),HXX),(HCOMP(2),HYX),(HCOMP(3),HZX),   &
                  (HCOMP(4),HXY),(HCOMP(5),HYY),(HCOMP(6),HZY),   &
                  (HCOMP(7),HXZ),(HCOMP(8),HYZ),(HCOMP(9),HZZ)
!
      IF (KEYG==1) THEN
         NF=3
      ELSE
         NF=6
      ENDIF
!
! --- The array PSTN is used to pass soure and receiver positions
!     to routine ONE_D_GREEN,  so that the values in the array PSTION
!     won't be altered after this routine is called.  This is necessary
!     here since the x and y coordinates of the source are variables.
!
      DO I=1,8
         PSTN(I)=PSTION(I)
      ENDDO
!
      SN=SIN(THETA)
      CS=COS(THETA)
!
      PSTN(4)=PSTION(4)+RAD*CS
      PSTN(5)=PSTION(5)+RAD*SN
!
      CALL ONE_D_GREEN(CS_TYPE,KEMD,KEYG,PSTN,FRQ,MLAYER,ZBND,KKH,CDH,    &
                       NZOB,ZOBG,NZSR,ZSRG,RHOMIN,NHFILM,RRG,NRG,GRHF,    &
                       GRHO0,ECOMP,HCOMP)
!
      F(1)=(EXX*(-SN)+EXY*CS)*RAD*AJ
      F(2)=(EYX*(-SN)+EYY*CS)*RAD*AJ
      F(3)=(EZX*(-SN)+EZY*CS)*RAD*AJ
      IF (NF==6) THEN
         F(4)=(HXX*(-SN)+HXY*CS)*RAD*AJ
         F(5)=(HYX*(-SN)+HYY*CS)*RAD*AJ
         F(6)=(HZX*(-SN)+HZY*CS)*RAD*AJ
      ENDIF
!
      RETURN
!
   END SUBROUTINE ONE_D_CIRCLE
!
!
   SUBROUTINE ONE_D_SOURCE (CS_TYPE,ANGLES,RECVR,NCRD,TX_CRDX,TX_CRDY,   &
                            TX_CRDZ,RAD,KEYG,KACC,FRQ,MLAYER,ZBND,AJ,    &
                            KKH,CDH,NZOB,ZOBG,NZSR,ZSRG,RHOMIN,          &
                            NHFILM,RRG,NRG,GRHF,GRHO0,EHFLD)
!
!****  Electromagnetic fields due to electric or magnetic sources
!
!      Fields are obtained by the integration of dipole sources
!
!
!   Input parameters:
!
!     CS_TYPE:   Integer(*4),  type of excitation and configuration.  See
!             documentation "MARCO.DOC" for description.  It is passed
!             into this routine for proper corrections to the electric
!             fields,  i.e.,  the removal of charge terms in the Green's
!             functions for current loop sources.
!     ANGLES: Real ANGLES(2),  orientations of the magnetic dipoles for
!             CS_TYPE=9.
!             The two elements of MD_ANGLE(1:2,J) contain the dip angle
!             MD_ANGLE(1,J) and the azimuthal angle MD_ANGLE(2,J) of the Jth
!             magnetic dipole.  The dip angle is the angle from the axis down
!             to the earth (note that this is the internal positive z-axis
!             which differs from the input-output z-axis that points upwards).
!             The azimuthal angle is the angle from the north,  the y-axis.
!             Thus for a vertical magnetic dipole MD_ANGLE(1,J)=180 for
!             pointing up air and MD_ANGLE(1,J) =0 for pointing down.  A
!             horizontal magnetic dipole pointing north will have MD_ANGLE(1,J)
!             =90 and MD_ANGLE(2,J)=0,  and a horizontal magnetic dipole
!             pointing east will have MD_ANGLE(1,J)=90 and MD_ANGLE(2,J)=90.
!     RECVR: Real RECVR(3),  receiver coordinates in the x, y,
!             and z-directions,  respectively.
!     NCRD:
!     TX_CRDX, TX_CRDY, TX_CRDZ: Real TX_CRDX(NCRD), TX_CRDY(NCRD),
!     TX_CRDZ(NCRD):  coordinates of electrodes (the end points of current
!             bipoles or loop corners) or the center coordinates of a
!             current loop or a magnetic dipole.   For various values of
!             CS_TYPE,  TX_CRDX, TX_CRDY,  and TX_CRDZ contain the
!             following information:
!             CS_TYPE =2, and 3:  the first two elements of TX_CRDX etc.
!                         represent the two electrodes of the bipoles;
!                     =4: the arrays TX_CRDX etc. show the coordinates
!                         of the four corner of the rectangular loop.
!                     =5, and 6: the first elements of TX_CRDX etc. contain
!                         the coordinates of the centre of the circular
!                         loop;  and
!                     =7, 8, and 9: the first elements of TX_CRDX etc.
!                         contain the coordinates of the centre of the
!                         magnetic dipole.
!     RAD:    Real,  radius of the current loop as with CS_TYPE=5 and 6.
!     KEYG:   Integer, mode of computation controlling whether mangetic
!             fields are computed.
!             KEYG=1:  Computing electric fields only.  This is used
!                      when the exciting electric fields are computed
!                      as the right hand side of the matric equation
!                      for 3D modeling;  and
!                 =2:  All components of the electric and magnetic fields
!                      are computed.
!     KACC:   Integer: parameter controlling the accuracy of the numerical
!             integration.  For approximate solutions with KACC=1, the
!             normal fields are computed to an accuracy of 1.E-3 only.
!             However,  this would be the minimal accuracy for such cases
!             since the dipole fields are computed to an accuracy of
!             1.E-7 or so.  This parameter is also used extensively in the
!             computation of scattered fields in routine THR_D_GREEN.
!     AJ:     Real,  current amplitude for electric sources or
!             dipole moment for magnetic sources.
!
!     Parameters FRQ, MLAYER, ZBND, KKH, CDH, NZOB, ZOBG, NZSR, ZSRG,
!     RHOMIN, NHFILM, RRG, NRG, GRHF, and GRHO0 are to be passed
!     into routine ONE_D_GREEN.  See ONE_D_GREEN for detailed descriptions.
!
!
!   Output parameters:
!
!     EHFLD:  Complex EHFLD(6),  components of the electric and magnetic
!             fields in the x, y, and z-directions,  respectively.
!
!
!****  CALLED by:  main, eincs, eincsgs
!
!****  CALLS    :  line, simp, green
!
!
      IMPLICIT NONE
!
      INTEGER, INTENT(IN) :: NZOB,NZSR,NHFILM,NRG,MLAYER,KACC,KEYG,     &
                             CS_TYPE,NCRD
      REAL, INTENT(IN) :: RECVR(3),TX_CRDX(NCRD),TX_CRDY(NCRD),TX_CRDZ(NCRD), &
                          RAD,ANGLES(2)
      COMPLEX, INTENT(OUT) :: EHFLD(6)
!
      INTEGER ::  I,I1,I2,J,JXYZ,L,L1,L2,NF,NINT,KEMD
      REAL :: A,B,EPS,XOB,XSR,YOB,YSR,ZOB,ZSR,ZSR1,ZSR2,XSR2,YSR2
      REAL :: AJXYZ,PSTION(8),PX,PY,PZ,DIP,AZIM
      COMPLEX :: EX,EY,EZ,HX,HY,HZ,SEHS(6),                             &
                 EXX,EYX,EZX,EXY,EYY,EZY,EXZ,EYZ,EZZ,                   &
                 HXX,HYX,HZX,HXY,HYY,HZY,HXZ,HYZ,HZZ,ECOMP(9),HCOMP(9)
      COMPLEX :: SEH(6),SEHA(6),SEH1(6)
      EQUIVALENCE (PSTION(1),XOB),(PSTION(2),YOB),(PSTION(3),ZOB),      &
                  (PSTION(4),XSR),(PSTION(5),YSR),(PSTION(6),ZSR),      &
!      --  The last two elements of PSIION are either zsr1 and zsr2 for
!          a vertical bipole or xsr2 and ysr2 for an electric bipole.
                  (PSTION(7),ZSR1,XSR2),(PSTION(8),ZSR2,YSR2),          &
                  (ECOMP(1),EXX),(ECOMP(2),EYX),(ECOMP(3),EZX),         &
                  (ECOMP(4),EXY),(ECOMP(5),EYY),(ECOMP(6),EZY),         &
                  (ECOMP(7),EXZ),(ECOMP(8),EYZ),(ECOMP(9),EZZ),         &
                  (HCOMP(1),HXX),(HCOMP(2),HYX),(HCOMP(3),HZX),         &
                  (HCOMP(4),HXY),(HCOMP(5),HYY),(HCOMP(6),HZY),         &
                  (HCOMP(7),HXZ),(HCOMP(8),HYZ),(HCOMP(9),HZZ)
!
! --- Parameters used solely for data passing
!
      COMPLEX, INTENT(IN) :: KKH(0:MLAYER),CDH(0:MLAYER),                  &
                             GRHF(11,NHFILM,NZSR,NZOB),GRHO0(4,NZSR,NZOB)
      REAL, INTENT(IN) :: ZBND(0:MLAYER),ZOBG(NZOB),ZSRG(2,NZSR),          &
                          FRQ,RHOMIN,RRG(NRG),AJ
!
!  --  EPSH and EPS! are the highest accuracies for numerical integration
!      of bipole and circular loop currents,  respecitively.  EPSL is
!      the accuracy for both of them if the code computes approximate
!      solutions only.
      REAL, PARAMETER :: EPSH=1.E-05,EPSC=1.E-4,EPSL=1.E-3
!
      EXTERNAL ONE_D_CIRCLE, ONE_D_LINE
!
!
      XOB=RECVR(1)
      YOB=RECVR(2)
      ZOB=RECVR(3)
!
!  -- Determine the accuracy of the numerical integration according
!     to the accuracy level.
!
      IF (KACC==1) THEN
         EPS=EPSL
      ELSE
         EPS=EPSH
         IF (CS_TYPE==5.OR.CS_TYPE==6) EPS=EPSC
      ENDIF
!
! --- CS_TYPE=7, 8, or 9 are for magnetic dipole sources
!
      IF (CS_TYPE==7.OR.CS_TYPE==8.OR.CS_TYPE==9) THEN
         KEMD=2
      ELSE
         KEMD=1
      ENDIF
!
      IF (CS_TYPE/=2) THEN
         ZSR1=TX_CRDZ(1)
         ZSR2=ZSR1
      ENDIF
!
      IF (CS_TYPE==2) THEN
!
! --- Vertical current bipole
!
         JXYZ=3
         AJXYZ=JXYZ
         XSR=TX_CRDX(1)
         YSR=TX_CRDY(1)
         ZSR=.5*(TX_CRDZ(1)+TX_CRDZ(2))
         ZSR1=TX_CRDZ(1)
         ZSR2=TX_CRDZ(2)
!
! --- Note that the Green's functions are integrated analytically
!     in the vertical direction. This also implies the restriction
!     that the vertical source must not be inclined.
!
!     The array seh is in double precision, but the routine line
!     is written in single precisions.  Thus the array sehs is
!     necessary for passing the results.
!
         CALL ONE_D_LINE(ZSR,AJXYZ,AJ,NF,SEHS,CS_TYPE,KEMD,KEYG,PSTION,   &
                         FRQ,MLAYER,ZBND,KKH,CDH,NZOB,ZOBG,NZSR,ZSRG,     &
                         RHOMIN,NHFILM,RRG,NRG,GRHF,GRHO0)
         DO I=1,NF
            SEH(I)=SEHS(I)
         ENDDO
!
      ENDIF
!
      IF (CS_TYPE==3) THEN
!
         XSR=TX_CRDX(1)
         YSR=TX_CRDY(1)
         ZSR=TX_CRDZ(1)
         XSR2=TX_CRDX(2)
         YSR2=TX_CRDY(2)
!
!         CALL XYBIPOLE
!
!  -- The introduction of the internal routine XYBIPOLE doesn't seem
!     to be allowed by the SGI compiler.  Thus the whole routine is
!     inserted here.
!
!***      SUBROUTINE XYBIPOLE
!
         IF (ABS(YSR2-YSR)>=ABS(XSR2-XSR)) THEN
!
!  -- Integration along the y-axis
!
            JXYZ=2
            AJXYZ=JXYZ
            A=YSR
            B=YSR2
            CALL ONE_D_SIMPCS(A,B,EPS,NINT,ONE_D_LINE,SEH,AJXYZ,AJ,CS_TYPE,  &
                              KEMD,KEYG,PSTION,FRQ,MLAYER,ZBND,KKH,CDH,NZOB, &
                              ZOBG,NZSR,ZSRG,RHOMIN,NHFILM,RRG,NRG,GRHF,GRHO0)
         ELSE
!
!  -- Integration along the x-axis
!
            JXYZ=1
            AJXYZ=JXYZ
            A=XSR
            B=XSR2
            CALL ONE_D_SIMPCS(A,B,EPS,NINT,ONE_D_LINE,SEH,AJXYZ,AJ,CS_TYPE,  &
                              KEMD,KEYG,PSTION,FRQ,MLAYER,ZBND,KKH,CDH,NZOB, &
                              ZOBG,NZSR,ZSRG,RHOMIN,NHFILM,RRG,NRG,GRHF,GRHO0)
         ENDIF
!
!***     END SUBROUTINE XYBIPOLE
!
      ENDIF
!
! --- Horizontal rectangular loop
!
      IF (CS_TYPE==4 .AND. NCRD==4) THEN
!
         IF (KEYG==1) THEN
            NF=3
         ELSE
            NF=6
         ENDIF
!
         DO J=1,NF
            SEH(J)=(0.,0.)
            SEH1(J)=(0.,0.)
            SEHA(J)=(0.,0.)
         ENDDO
!
! --- The loop L is designed to add the two current bipoles of opposit
!     direction together before the final summation in order to reduce
!     round-off errors.
!
         DO L=1,2
            IF (L==1) THEN
               L1=1
               L2=3
            ELSE
               L1=2
               L2=4
            ENDIF
!
            DO I=L1,L2,2
!
               I1=I
               I2=I+1
               IF (I2>4) I2=1
!
               XSR=TX_CRDX(I1)
               YSR=TX_CRDY(I1)
               ZSR=TX_CRDZ(I1)
               XSR2=TX_CRDX(I2)
               YSR2=TX_CRDY(I2)
!
!               CALL XYBIPOLE
!
!*********      SUBROUTINE XYBIPOLE
!
         IF (ABS(YSR2-YSR)>=ABS(XSR2-XSR)) THEN
!
!  -- Integration along the y-axis
!
            JXYZ=2
            AJXYZ=JXYZ
            A=YSR
            B=YSR2
            CALL ONE_D_SIMPCS(A,B,EPS,NINT,ONE_D_LINE,SEH,AJXYZ,AJ,CS_TYPE,  &
                              KEMD,KEYG,PSTION,FRQ,MLAYER,ZBND,KKH,CDH,NZOB, &
                              ZOBG,NZSR,ZSRG,RHOMIN,NHFILM,RRG,NRG,GRHF,GRHO0)
         ELSE
!
!  -- Integration along the x-axis
!
            JXYZ=1
            AJXYZ=JXYZ
            A=XSR
            B=XSR2
            CALL ONE_D_SIMPCS(A,B,EPS,NINT,ONE_D_LINE,SEH,AJXYZ,AJ,CS_TYPE,  &
                              KEMD,KEYG,PSTION,FRQ,MLAYER,ZBND,KKH,CDH,NZOB, &
                              ZOBG,NZSR,ZSRG,RHOMIN,NHFILM,RRG,NRG,GRHF,GRHO0)
         ENDIF
!
!*********      END SUBROUTINE XYBIPOLE
!
               DO J=1,NF
                  IF (L==1) THEN
                     SEH1(J)=SEH1(J)+SEH(J)
                  ELSE
                     SEHA(J)=SEHA(J)+SEH(J)
                  ENDIF
               ENDDO
!
            ENDDO
         ENDDO
!
! --- Add the subtotals together
!
         DO J=1,NF
            SEH(J)=SEH1(J)+SEHA(J)
         ENDDO
!
      ENDIF
!
! --- Arbitrary horizontal loop
!
      IF (CS_TYPE==4 .AND. NCRD/=4) THEN
!
         IF (KEYG==1) THEN
            NF=3
         ELSE
            NF=6
         ENDIF
!
         DO J=1,NF
            SEH(J)=(0.,0.)
            SEH1(J)=(0.,0.)
         ENDDO
!
         DO L=1,NCRD
!
            XSR=TX_CRDX(L)
            YSR=TX_CRDY(L)
            ZSR=TX_CRDZ(L)
            IF (L==NCRD) THEN
               XSR2=TX_CRDX(1)
               YSR2=TX_CRDY(1)
            ELSE
               XSR2=TX_CRDX(L+1)
               YSR2=TX_CRDY(L+1)
            ENDIF
!
!               CALL XYBIPOLE
!
!*********      SUBROUTINE XYBIPOLE
!
            IF (ABS(YSR2-YSR)>=ABS(XSR2-XSR)) THEN
!
!  -- Integration along the y-axis
!
            JXYZ=2
            AJXYZ=JXYZ
            A=YSR
            B=YSR2
            CALL ONE_D_SIMPCS(A,B,EPS,NINT,ONE_D_LINE,SEH,AJXYZ,AJ,CS_TYPE,  &
                              KEMD,KEYG,PSTION,FRQ,MLAYER,ZBND,KKH,CDH,NZOB, &
                              ZOBG,NZSR,ZSRG,RHOMIN,NHFILM,RRG,NRG,GRHF,GRHO0)
            ELSE
!
!  -- Integration along the x-axis
!
            JXYZ=1
            AJXYZ=JXYZ
            A=XSR
            B=XSR2
            CALL ONE_D_SIMPCS(A,B,EPS,NINT,ONE_D_LINE,SEH,AJXYZ,AJ,CS_TYPE,  &
                              KEMD,KEYG,PSTION,FRQ,MLAYER,ZBND,KKH,CDH,NZOB, &
                              ZOBG,NZSR,ZSRG,RHOMIN,NHFILM,RRG,NRG,GRHF,GRHO0)
            ENDIF
!
!*********      END SUBROUTINE XYBIPOLE
!
            DO J=1,NF
               SEH1(J)=SEH1(J)+SEH(J)
            ENDDO
!
         ENDDO
!
! --- Assign SEH1 to SEH.  This is designed so that the above "subroutine"
!     XYBIPOLE remain the same throughout this routine (using SEH only)
!
         DO J=1,NF
            SEH(J)=SEH1(J)
         ENDDO
!
      ENDIF
!
! --- Horizontal circular loop
!
      IF (CS_TYPE==5.OR.CS_TYPE==6) THEN
         XSR=TX_CRDX(1)
         YSR=TX_CRDY(1)
         ZSR=TX_CRDZ(1)
         CALL ONE_D_SIMPCS(0.,2.*3.1415926,EPS,NINT,ONE_D_CIRCLE,SEH,RAD,   &
                           AJ,CS_TYPE,KEMD,KEYG,PSTION,FRQ,MLAYER,ZBND,KKH, &
                           CDH,NZOB,ZOBG,NZSR,ZSRG,RHOMIN,NHFILM,RRG,NRG,   &
                           GRHF,GRHO0)
      ENDIF
!
      IF (CS_TYPE<=6) THEN
!
         EX=SEH(1)
         EY=SEH(2)
         EZ=SEH(3)
         IF (KEYG==2) THEN
            HX=SEH(4)
            HY=SEH(5)
            HZ=SEH(6)
         ENDIF
!
      ENDIF
!
!  -- Arbitrary magnetic dipoles
!
!     Note that the first elements of the array crdx, crdy, and
!     crdz are the dipole coordinates
!
!     Zsr1 and zsr2 have been determined earlier
!
      IF (CS_TYPE==7.OR.CS_TYPE==8.OR.CS_TYPE==9) THEN
!
         XSR=TX_CRDX(1)
         YSR=TX_CRDY(1)
         ZSR=TX_CRDZ(1)
         CALL ONE_D_GREEN(CS_TYPE,KEMD,KEYG,PSTION,FRQ,MLAYER,ZBND,KKH,CDH,  &
                          NZOB,ZOBG,NZSR,ZSRG,RHOMIN,NHFILM,RRG,NRG,GRHF,    &
                          GRHO0,ECOMP,HCOMP)
!
!  --- Note that the coordinate systems for I/O and for computations are
!      different.  It is important to define the dip angle as the angle from
!      the axis pointing down and the azimuthal angle as the angle from the
!      north.
!
         DIP=ANGLES(1)/180.*3.14159265359
         AZIM=ANGLES(2)/180.*3.14159265359
!    --- Multiplied by dipole moment
         PX=SIN(DIP)*COS(AZIM)*AJ
         PY=SIN(DIP)*SIN(AZIM)*AJ
         PZ=COS(DIP)*AJ
!
         EX=PX*EXX+PY*EXY+PZ*EXZ
         EY=PX*EYX+PY*EYY+PZ*EYZ
         EZ=PX*EZX+PY*EZY+PZ*EZZ
         IF (KEYG==2) THEN
            HX=PX*HXX+PY*HXY+PZ*HXZ
            HY=PX*HYX+PY*HYY+PZ*HYZ
            HZ=PX*HZX+PY*HZY+PZ*HZZ
         ENDIF
!
      ENDIF
!
      EHFLD(1)=EX
      EHFLD(2)=EY
      EHFLD(3)=EZ
      EHFLD(4)=HX
      EHFLD(5)=HY
      EHFLD(6)=HZ
!
      RETURN
!
   END SUBROUTINE ONE_D_SOURCE
!
!
   SUBROUTINE ONE_D_GREEN (CS_TYPE,KEMD,KEYG,PSTION,FRQ,MLAYER,ZBND,      &
                           KKH,CDH,NZOB,ZOBG,NZSR,ZSRG,                   &
                           RHOMIN,NHFILM,RRG,NRG,GRHF,GRHO0,ECOMP,HCOMP)
!
!****   Electromagnetic fields of a dipole source in
!       layered anisotropic earths
!
!
!   Input parameters:
!
!     CS_TYPE:   Integer(*4),  type of excitation and configuration.  See
!             documentation "MARCO.DOC" for description.  It is passed
!             into this routine for proper corrections to the electric
!             fields,  i.e.,  the removal of charge terms in the Green's
!             functions for current loop sources.
!     KEMD:   Integer,  switch for electric or magnetic dipoles.
!             KEMD=1:  electric dipoles;  and
!                 =2:  magnetic dipoles.
!     KEYG:   Integer,  mode of computation controlling whether mangetic
!             fields are computed.
!             KEYG=1:  Computing electric fields only.  This is used
!                      when the exciting electric fields are computed
!                      as the right hand side of the matric equation
!                      for 3D modeling;  and
!                 =2:  All components of the electric and magnetic fields
!                      are computed.
!     PSTION: Real PSTION(8),  the positions of the source and the
!             receiver plus the lower and upper z-coordinates the kernels
!             are integrated analytically.  The first 3 elements of the
!             array is for the x, y, and z-coordinates of the receiver,
!             which are followed by the x, y, and z-coordinates of the
!             source.  The last two elements are the lower and upper
!             z-coordinates of the integral interval.  If the kernels
!             are not integrated,  the last two elements must be identical
!             to the source z-coordinate,  i.e.,  the last three elements
!             of PSTION must be the same if the kernels are not to be
!             integrated in teh vertical direction.
!     FRQ:    Real(*4), frequency.
!     MLAYER: Integer, number of layers excluding the air.
!     ZBND:   Real ZBND(0:MLAYER), coordinates of the layer
!             boundaries with the air earth interface being zbnd(0)=0.
!     KKH:    Complex(*8) KKH(0:MLAYER),  square ( **2) of the complex wave
!             number of the layers including the air (layer number 0).
!     CDH:    Complex CDH(0:MLAYER),  complex conductivities of
!             the layers in the lateral direction including the
!             air (layer 0).
!     NZOB:   Integer, number of z-levels. Determined in the main program.
!     ZOBG:   Real ZOBG(NZOB), the nzob z-levels coordinates.
!     NZSR:   Integer,  number of z'-levels.
!     ZSRG:   Real ZSRG(NZSR),  the nzsr z'-levels.
!     RHOMIN: Real,  minimum of the lateral grid (rho) which determines
!             the minimum of rho in the Hankel integrals.  RHOMIN=0.1 for
!             the low frequency mdule and RHOMIN=0.01 for the high
!             frequency module.
!     NHFILM: Integer,  maximal number of grids in the lateral direction
!             (rho) for all the Hankel integrals.
!     NRG:    Integer,  number of grids in the lateral direction (rho).
!     RRG:    Real RRG(NRG),  the NRG grid points in rho.
!     GRHF:   Complex GRHF(11,NHFILM,NZSR,NZOB), tabulated values of
!             the Hankel integrals.  To be passed to the interpolation
!             routines.
!     GRHO0:  Complex GRHO0(4,NZSR,NZOB), tabulated values of the
!             Hankel integrals for rho=0 (source and receiver have the
!             same x and y coordinates).
!
!   Output parameters:
!
!     ECOMP:  Complex ECOMP(9),  the nine components of the electric
!             field tensor,  Exx, Eyx, Ezx, Exy, ..., and Ezz.   See the
!             EQUIVALENCE statement.   Note that in parameters Exy etc.
!             the first index "x" denotes the direction of the field and
!             the second index "y" denotes the direction of the source.
!     HCOMP:  Complex HCOMP(9),  the nine components fo the magnetic
!             field tensor which is arranged in the same way as ECOMP.
!
!
!     Note that the Green's functions are not separated into primary and
!     secondary parts as in routine THR_D_GREEN.   Whether the kernels are
!     integrated analytically in the z'-directions or not is controlled
!     in the routine ONE_D_HF_TABLE.  The calling routine ONE_D_LINE must
!     correctly determine this.
!
!     For loop sources, i.e., ksrc=4, 5, or 6, the charge terms in
!     the electric fields need be canceled in the program since
!     they cannot be canceled numerically. This is considered in
!     kernel function, routine kernel, as well as in the routines
!     gridhf and gridcs.   However,  the components Ezz and Exx
!     for rho=0 have different factors before and after the charge
!     terms are removed.  Those factors are numerically more
!     advantagous to be considered here than to be considered in
!     the kernel functions.
!
!     Note that the Hankel integrals for the Green's functions must
!     computed before this routine is called.  The integrals are first
!     tabulated by routine ONE_D_HF_TABLE and then interpolated by routines
!     INTERPO_PLPOL etc.
!
!****  CALLED by:  line, circle, csource
!
!****  CALLS    :  intpl15, intplpol,  and intplrat (never active
!                  unless krat is changed to 1)
!
      IMPLICIT NONE
!
      INTEGER, INTENT(IN) :: KEMD,KEYG,NZOB,NZSR,NHFILM,NRG,CS_TYPE,MLAYER
      COMPLEX, INTENT(IN) :: KKH(0:MLAYER),CDH(0:MLAYER),                  &
                             GRHF(11,NHFILM,NZSR,NZOB),GRHO0(4,NZSR,NZOB)
      REAL, INTENT(IN) :: ZBND(0:MLAYER),ZOBG(NZOB),ZSRG(2,NZSR),FRQ,      &
                          RHOMIN,PSTION(8)
      COMPLEX, INTENT(OUT) :: ECOMP(9),HCOMP(9)
!
      REAL :: CRRTN,RHO,RHO1,RR0,RR1
      REAL :: XR,YR,XI,YI,C1,XOB,YOB,ZOB,XSR,YSR,ZSR,ZSR1,ZSR2,RRG(NRG)
      INTEGER :: NF,I,II,NS,NOB,IOB,ISR
      COMPLEX :: EXX,EYX,EZX,EXY,EYY,EZY,EXZ,EYZ,EZZ,   &
                 HXX,HYX,HZX,HXY,HYY,HZY,HXZ,HYZ,HZZ,   &
                 S(4),HCRR,HF(11),WMU
!
!  --- Routine INTERPO_PLPOL may used for computing normal fields at
!      high frequencies.  It offers higer accuracy for large rho (> 10 m),
!      but its run time is large.
!
      LOGICAL, PARAMETER :: PLPOL=.FALSE.
!
      RHO(XR,YR,XI,YI)=SQRT((XR-XI)**2+(YR-YI)**2)
!
      C1=1./4./3.1415926
      WMU=CMPLX(0.,78.9568352E-7*FRQ)
!
! --- Extract parameter values for XOB etc. from PSTION
!
      XOB=PSTION(1)
      YOB=PSTION(2)
      ZOB=PSTION(3)
      XSR=PSTION(4)
      YSR=PSTION(5)
      ZSR=PSTION(6)
      ZSR1=PSTION(7)
      ZSR2=PSTION(8)
!
      DO I=MLAYER-1,0,-1
         IF (ZOB>=ZBND(I)) THEN
            NOB=I+1
            GOTO 100
         ENDIF
      ENDDO
      NOB=0
!
! ---- Determine the level of zob in the grid array zobg.
!      Note that there is only one z'-level which is
!      therefore ignored.
!
  100 DO I=1,NZOB
         IF (ABS(ZOB-ZOBG(I))<.01) THEN
            IOB=I
            GOTO 200
         ENDIF
      ENDDO
!
      WRITE (4,*) 'Warning: failed to choose a z-level for zob=',ZOB
!
! ---- Determine the level of zsr in the grid array zsrg
!      Note that the z'-levels in the zsr-direction are
!      determined by the full lengths of the electrode span.
!
!      Note that in case of horizontal current bipoles or loops
!      zsr1 and zsr2 take the value of the z-coordinates of
!      any electrode.
!
  200 DO I=1,NZSR
         IF (CS_TYPE==2.AND.  &
             ABS(ZSR1-ZSRG(1,I))<.01.AND.ABS(ZSR2-ZSRG(2,I))<.01) THEN
            ISR=I
            GOTO 300
         ENDIF
         IF (CS_TYPE/=2.AND.ABS(ZSR-ZSRG(1,I))<.01) THEN
            ISR=I
            GOTO 300
         ENDIF
      ENDDO
!
      WRITE (4,*) 'Warning: failed to choose a z_prime-level',   &
                ' for electrodes (z) =',ZSR1,ZSR2
!
!
  300 IF (KEYG==1) THEN
         NF=6
      ELSE
         NF=11
      ENDIF
!
!  --- Note that both electric and magnetic dipoles have 6 non-zero
!      kernels for the electric fields,  #1 through 6,  and 5 non-zero
!      kernels for magnetic fields,  # 7 through 11.
!      For rho=0,  electric dipoles have 2 non-zero electric kernels
!      and one magnetic kernel, and magnetic dipoles have only one
!      non-zero kernel for the electric fields.
!
!      The kernels for the magnetic dipoles are arranged in such an
!      order that is compatible with the kernels for the electric
!      fields in using all teh subroutines,  especially routine
!      HFIL.
!
      IF (KEYG==2) NS=3
      IF (KEYG==1) THEN
         IF (KEMD==1) THEN
            NS=2
         ELSE
            NS=1
         ENDIF
      ENDIF
!
      RHO1=RHO(XOB,YOB,XSR,YSR)
!
      IF (RHO1>=RHOMIN) THEN
!
!  --- Interpolate the hankel integrals
!
!  --- Routine INTERPO_PLPOL may used for computing normal fields at
!      high frequencies.  It offers higer accuracy for large rho (> 10 m),
!      but its run time is large.
!
         IF (PLPOL) THEN
            CALL INTERPO_PLPOL(GRHF,RRG,NRG,NHFILM,NZSR,NZOB,ALOG(RHO1),   &
                              IOB,ISR,HF,NF)
         ELSE
            CALL INTERPO_LG6(GRHF,RRG,NRG,NHFILM,NZSR,NZOB,ALOG(RHO1),     &
                             IOB,ISR,HF,NF)
         ENDIF
!
!  --- HF are now divided by rho
!
         DO II=1,NF
            HF(II)=HF(II)/RHO1
         ENDDO
!
      ENDIF
!
! ---- Electric dipoles
!
      IF (KEMD==1) THEN
!   *****************************************
!   *                                       *
         IF (RHO1>=RHOMIN) THEN
!   --------------------------------------
!   |                                    |
!
!  --- The kernel related to HF(2) tends to 2*LUMBDA**2 as
!      LUMBDA goes to infinity for z=z'=0.  The corresponding
!      kernel has been corrected in the function ONE_D_KERNEL.
!      This affect Exx, Eyx, Eyy and Exy only.  Other components
!      and most components of the electric field in the air
!      have similar behaviors but are not corrected since they
!      are not measured.   The hankel filters used in this program
!      do yield accurate results for all cases even without
!      correction.   The corrections done here can hopefully
!      boost the accuracy of the code.  It is also possible to
!      use better filters which decay slower but have much higher
!      accuracy.
!
!      Note that the charge terms which also involves HF(2)
!      are set to zero in ONE_D_KERNEL for loop type sources in order
!      to councel the charge terms accurately
!
            IF (ABS(ZOB)<.001.AND.ABS(ZSR)<.001) THEN
               IF (CS_TYPE==4.OR.CS_TYPE==5.OR.CS_TYPE==6) THEN
                  CRRTN=0.
               ELSE
                  CRRTN=2./RHO1**3
               ENDIF
               EXX=-C1*WMU*HF(1)-C1/CDH(NOB)                           &
                   *(((XOB-XSR)/RHO1)**2*(HF(2)-CMPLX(CRRTN,0.))                 &
                   +(1.-2.*((XOB-XSR)/RHO1)**2)/RHO1*HF(4))
               EYX=-C1/CDH(NOB)*(XOB-XSR)*(YOB-YSR)                    &
                   /RHO1**2*(HF(2)-CMPLX(CRRTN,0.)-2.*HF(4)/RHO1)
               EYY=-C1*WMU*HF(1)-C1/CDH(NOB)                           &
                   *(((YOB-YSR)/RHO1)**2*(HF(2)-CMPLX(CRRTN,0.))                 &
                   +(1.-2.*((YOB-YSR)/RHO1)**2)/RHO1*HF(4))
            ELSE
               EXX=-C1*WMU*HF(1)-C1/CDH(NOB)*(((XOB-XSR)/RHO1)**2*HF(2)+  &
                   (1.-2.*((XOB-XSR)/RHO1)**2)/RHO1*HF(4))
               EYX=-C1/CDH(NOB)*(XOB-XSR)*(YOB-YSR)/RHO1**2*              &
                   (HF(2)-2.*HF(4)/RHO1)
               EYY=-C1*WMU*HF(1)-C1/CDH(NOB)*(((YOB-YSR)/RHO1)**2*HF(2)+  &
                   (1.-2.*((YOB-YSR)/RHO1)**2)/RHO1*HF(4))
            ENDIF
            EXY=EYX
            EZX=-C1/CDH(NOB)*(XOB-XSR)/RHO1*HF(5)
            EZY=-C1/CDH(NOB)*(YOB-YSR)/RHO1*HF(5)
            EXZ=-C1/CDH(NOB)*(XOB-XSR)/RHO1*HF(6)
            EYZ=-C1/CDH(NOB)*(YOB-YSR)/RHO1*HF(6)
!  --- Ezz has different factors before the integral before and
!      after the charge term is removed.  This has been taken into
!      account in routine ONE_D_KERNEL
            EZZ=C1/CDH(NOB)*HF(3)
!
!  --- Compute magnetic fields as well if keyg=2
!
            IF (KEYG==2) THEN
!
               HXX=-C1*(XOB-XSR)*(YOB-YSR)/RHO1**2*(HF(7)-2./RHO1*HF(9))
               HYX= C1*HF(8)+C1*((XOB-XSR)/RHO1)**2*HF(7)                &
                   +C1*(1.-2.*((XOB-XSR)/RHO1)**2)/RHO1*HF(9)
               HXY=-C1*HF(8)-C1*((YOB-YSR)/RHO1)**2*HF(7)                &
                   -C1*(1.-2.*((YOB-YSR)/RHO1)**2)/RHO1*HF(9)
               HYY=-HXX
!
!  --- Corrections for hxz and hyz for sources and receivers in the air.
!      This is necessary for high frequencies (>100 kHz).
!
!      These corrections need be done for all components.  Here only
!      hxz and hyz are done for the time being.
!
!      Corrections are also made for hxz and hyz for sources and
!      receivers on the earth's surface.
!
               IF (ZOB<.0.AND.ZSR<.0.AND.                      &
                 (ABS(ZOB)>=.001.OR.ABS(ZSR)>=.001)) THEN
                  RR0=SQRT(RHO1**2+(ZSR-ZOB)**2)
                  RR1=SQRT(RHO1**2+(ZSR+ZOB)**2)
                  HCRR=RHO1/RR0**3*CEXP(-CSQRT(KKH(0))*RR0)    &
                       *((1.,0.)+CSQRT(KKH(0))*RR0)                 &
                       -RHO1/RR1**3*CEXP(-CSQRT(KKH(0))*RR1)   &
                       *((1.,0.)+CSQRT(KKH(0))*RR1)
               ELSEIF (ABS(ZOB)<.001.AND.ABS(ZSR)<.001) THEN
                  HCRR=CMPLX(1./RHO1**2,0.)
               ELSE
                  HCRR=(0.,0.)
               ENDIF
!
               HZX=C1*(YOB-YSR)/RHO1*(HF(10)+HCRR)
               HZY=-C1*(XOB-XSR)/RHO1*(HF(10)+HCRR)
!
               HXZ=-C1*(YOB-YSR)/RHO1*HF(11)
               HYZ=C1*(XOB-XSR)/RHO1*HF(11)
               HZZ=(0.,0.)
!
            ENDIF
!
!   |                                    |
!   --------------------------------------
         ENDIF
!
         IF (RHO1<RHOMIN) THEN
!   --------------------------------------
!   |                                    |
!
            DO II=1,NS
               S(II)=GRHO0(II,ISR,IOB)
            ENDDO
!
            S(1)=-C1/CDH(NOB)*S(1)
            EXX=S(1)
            EYY=S(1)
            EZZ=C1/CDH(NOB)*S(2)
            EYX=(0.,0.)
            EZX=(0.,0.)
            EXY=(0.,0.)
            EZY=(0.,0.)
            EXZ=(0.,0.)
            EYZ=(0.,0.)
!
            IF (KEYG==2) THEN
               HYX=C1*S(3)
               HXY=-C1*S(3)
               HXX=(0.,0.)
               HZX=(0.,0.)
               HYY=(0.,0.)
               HZX=(0.,0.)
               HXZ=(0.,0.)
               HYZ=(0.,0.)
               HZZ=(0.,0.)
            ENDIF
!
!   |                                    |
!   --------------------------------------
         ENDIF
!
!   *                                       *
!   *****************************************
      ENDIF
!
      IF (KEMD==2) THEN
!   *****************************************
!   *                                       *
!
!     Corrections necessary for almost all components!
!     Here only Hzz is corrected for the time being.
!
         IF (RHO1>=RHOMIN) THEN
!   --------------------------------------
!   |                                    |
!
            EXX=C1/CDH(NOB)*(XOB-XSR)*(YOB-YSR)/RHO1**2*(HF(1)-2./RHO1*HF(4))
            EYX=C1*WMU*HF(2)+C1/CDH(NOB)*((YOB-YSR)/RHO1)**2*HF(1)+          &
                C1/CDH(NOB)*((XOB-XSR)**2-(YOB-YSR)**2)/RHO1/RHO1/RHO1*HF(4)
            EZX=C1/CDH(NOB)*(YOB-YSR)/RHO1*HF(5)
            EXY=-C1*WMU*HF(2)-C1/CDH(NOB)*((XOB-XSR)/RHO1)**2*HF(1)-         &
                C1/CDH(NOB)*((YOB-YSR)**2-(XOB-XSR)**2)/RHO1/RHO1/RHO1*HF(4)
            EYY=-EXX
            EZY=-C1/CDH(NOB)*(XOB-XSR)/RHO1*HF(5)
!
            EXZ=C1*WMU*(YOB-YSR)/RHO1*HF(6)
            EYZ=-C1*WMU*(XOB-XSR)/RHO1*HF(6)
            EZZ=(0.,0.)
!
            IF (KEYG==2) THEN
               HXX=C1*(HF(3)                                               &
                 +((YOB-YSR)**2*HF(7)+((XOB-XSR)**2-(YOB-YSR)**2)          &
                 /RHO1*HF(9))/RHO1**2)
               HYX=C1*(XOB-XSR)*(YOB-YSR)/RHO1**2*(-HF(7)+2.*HF(9)/RHO1)
               HZX=C1*(XOB-XSR)/RHO1*HF(10)
               HXY=HYX
               HYY=C1*(HF(3)                                               &
                  +((XOB-XSR)**2*HF(7)+((YOB-YSR)**2-(XOB-XSR)**2)         &
                 /RHO1*HF(9))/RHO1**2)
               HZY=C1*(YOB-YSR)/RHO1*HF(10)
               HXZ=-C1*(XOB-XSR)/RHO1*HF(11)
               HYZ=-C1*(YOB-YSR)/RHO1*HF(11)
               IF (ABS(ZOB-ZSR)<1.E-4) THEN
                  HCRR=-CMPLX(1./RHO1**3,0.)
               ELSE
                  HCRR=(0.,0.)
               ENDIF
               HZZ=C1*(HF(8)+HCRR)
            ENDIF
!
!   |                                    |
!   --------------------------------------
         ENDIF
!
         IF (RHO1<RHOMIN) THEN
!   --------------------------------------
!   |                                    |
            DO II=1,NS
               S(II)=GRHO0(II,ISR,IOB)
            ENDDO
!
            EYX=C1/CDH(NOB)*S(1)
            EXY=-EYX
            EXX=(0.,0.)
            EZX=(0.,0.)
            EYY=(0.,0.)
            EZY=(0.,0.)
            EXZ=(0.,0.)
            EYZ=(0.,0.)
            EZZ=(0.,0.)
!
            IF (KEYG==2) THEN
               HXX=C1*S(2)
               HYY=HXX
               HZZ=C1*S(3)
               HYX=(0.,0.)
               HZX=(0.,0.)
               HXY=(0.,0.)
               HZY=(0.,0.)
               HXZ=(0.,0.)
               HYZ=(0.,0.)
            ENDIF
!
!   |                                    |
!   --------------------------------------
         ENDIF
!
!   *                                       *
!   *****************************************
      ENDIF
!
! --- Assign the components to the arrays ECOMP and HCOMP
!     for data passing
!
      ECOMP(1)=EXX
      ECOMP(2)=EYX
      ECOMP(3)=EZX
      ECOMP(4)=EXY
      ECOMP(5)=EYY
      ECOMP(6)=EZY
      ECOMP(7)=EXZ
      ECOMP(8)=EYZ
      ECOMP(9)=EZZ
      HCOMP(1)=HXX
      HCOMP(2)=HYX
      HCOMP(3)=HZX
      HCOMP(4)=HXY
      HCOMP(5)=HYY
      HCOMP(6)=HZY
      HCOMP(7)=HXZ
      HCOMP(8)=HYZ
      HCOMP(9)=HZZ
!
      RETURN
!
   END SUBROUTINE ONE_D_GREEN
!
!
   SUBROUTINE ONE_D_HF_TABLE(FHFIL,NHFILM,MLAYER,ZBND,LRYTH,HVK,KKH,KANIS,  &
                             BLMIN,CS_TYPE,KEYG,DMIN,RHOMIN,RHOMAX,NZOB,    &
                             ZOBG,NZSR,ZSRG,NZBG,ZBG,ALMAX,GRHF,RRG,NRG,GRHO0)
!
!****  Compute tabulated Hankel integrals of the Green's functions
!      on a three-demensional grids in the rho (the lateral) direction,
!      z, and z'-directions (or the z and z'-levels).  Note that
!      Hankel integrals for many kernels associated withe the components
!      of the tensor Green's functions are computed simultaneously,
!      thus the array GRHF is four-dimensional.  Those tabulated values
!      are interpolated to compute actual Green's functions or field
!      components.
!
!      This routine is similar to THR_D_HF_TABLE but is used for
!      computing electromagnetic fields of controlled
!      sources only,  ie., the 1D responses of electric or
!      magnetic sources.
!
!
!   Input parameters:
!
!     FHFIL:
!     NHFILM: Integer,  maximal number of grids in the lateral direction
!             (rho) for all the Hankel integrals.
!     MLAYER: Integer, number of layers excluding the air.
!     ZBND:   Real ZBND(0:MLAYER), coordinates of the layer
!             boundaries with the air earth interface being zbnd(0)=0.
!     LRYTH:  Real LRYTH(MLAYER),  thickness of each layer (the air is not
!             included in LRYTH).
!     HVK:    Real HVK(0:MLAYER),  coefficients of anisotropy of the layers
!             including the air (layer 0 with HVK(0)=1).  The anisotropy
!             coefficients are defined as the square roots of the ratios of
!             horizontal conductivities to vertical conductivities of each
!             layer.  Elements of HVK are always equal to or larger than 1.
!     KKH:    Complex(*8) KKH(0:MLAYER),  square ( **2) of the complex wave
!             number of the layers including the air (layer number 0).
!     KANIS:  Integer, flag for the anisotropy of the media.
!             KANIS=1:  the media are anisotropic in the verical
!                       direction;  and
!             KANIS=0:  the media are isotropic.
!             If the media are isotropic,  use KANIS=0 to simplify
!             the computation.
!     CS_TYPE:   Integer,  type of excitation and configuration.  See
!             documentation "MARCO.DOC" for description.  It is passed
!             into this routine for proper corrections to the electric
!             fields,  i.e.,  the removal of charge terms in the Green's
!             functions for current loop sources.  It is also used to
!             determine whether the kernels for electric or magnetic
!             sources are to be computed.
!     BLMIN:  Real,  small interval to be cut from a vertical current bipole
!             that passes the center of a cell.  It is used to avoid
!             singularity.  Note that it has a different function from the
!             BLMIN in routine THR_D_HF_TABLE.
!     KEYG:   Integer.  Mode of computation controlling whether mangetic
!             fields are to be computed.
!             KEYG=1:  Computing electric fields only.  This is used
!                      when elements of the scattering impedance
!                      matrix are computed;  and
!                 =2:  All components of the electric and magnetic fields
!                      are computed as in the computation of secondary
!                      E- and H-fields.
!     DMIN:   Real,  minmum of dimension for numerical treatments of cells.
!             DMIN=0.1 for the low frequency mdule and DMIN=0.001 for the
!             high frequency module.
!     RHOMIN: Real,  minimal dimension in the lateral direction (rho).
!     RHOMAX: Real,  maxiaml dimension in the lateral direction (rho).
!     NZOB:   Integer, number of z-levels. Determined in the main program.
!     ZOBG:   Real ZOBG(NZOB), the nzob z-levels coordinates.
!     NZSR:   Integer,  number of z'-levels.
!     ZSRG:   Real ZSRG(2,NZSR),  the nzsr z'-levels.
!     ZBG:    Real ZBG(2,NZSR),  working array for the nzsr z'-levels.
!
!   Output parameters:
!
!     NRG:    Integer,  number of grids in the lateral direction (rho).
!     RRG:    Real RRG(NRG),  the NRG grid points in rho.
!     GRHF:   Complex GRHF(11,NHFILM,NZSR,NZOB), tabulated values of
!             the Hankel integrals.  To be passed to the interpolation
!             routines.
!     GRHO0:  Complex GRHO0(4,NZSR,NZOB), tabulated values of the
!             Hankel integrals for rho=0 (source and receiver have the
!             same x and y coordinates).
!
!     Parameter ALMAX is to be passed into routine ONE_D_KERNEL.  See
!     ONE_D_KERNEL for its description.
!
!
!   Remarks:
!
!        The grid points in the rho (or R) direction are set
!        up automatically by the Hankel transform subroutine
!        on a logrithmical scale.   Note that the interpolated
!        values in the rho-direction must be divided by rho
!        to obtain the value of the Hankel transform.
!
!        The grid values of the Hankel transform in the z and z'
!        directions are stored at exactly those z and z'-levels
!        (ZOBG and ZSRG) which are determined by discretization.
!        Hence no interpolations in the z and z'-direction are
!        necessary.
!
!        The Hankel transforms for vertical current bipoles are
!        integrated analytically in the z'-directrion.  Results
!        are stored in the preassigned z'-levels (zsrgrd) with
!        both upper and lower limits for integration. This analytical
!        integration increases the accuracy and efficiency of the
!        algorithm substantially.  But this design restricts that
!        the vertical bipole sources must not be inclined.  Otherwise,
!        some routines must be rewritten.
!
!        The results will be integrated analytically in the routine
!        kernel for vertical bipole sources. This analytical
!        integration increases the accuracy and efficiency
!        substantially. Yet this design restricts that the
!        vertical bipole source must not be inclined. Otherwise,
!        some routines must be rewritten.
!
!        It is assumed that there is only one z'-level for
!        the source current. This is clear for horizontal bipoles
!        or loops. For vertical current bipoles there must be
!        fixed end points.
!
!
!**** Called by:  MAIN_PRM_AT_RCV
!
!**** Calls:      ONE_D_0_2_INFTY,  HFIL
!
!
      IMPLICIT NONE
!
      REAL, INTENT(IN) :: ALMAX,BLMIN,DMIN,RHOMAX,RHOMIN
      INTEGER, INTENT(IN) :: KANIS,KEYG,CS_TYPE,MLAYER,NHFILM,NZOB,NZSR,NZBG
      INTEGER, INTENT(INOUT) :: NRG
      REAL, INTENT(IN) :: ZOBG(NZOB),ZSRG(2,NZSR),                           &
                          LRYTH(MLAYER),ZBND(0:MLAYER),HVK(0:MLAYER)
      REAL, INTENT(INOUT) :: ZBG(2,NZBG),RRG(NHFILM)
      COMPLEX, INTENT(IN) :: KKH(0:MLAYER)
      COMPLEX, INTENT(INOUT) :: GRHF(11,NHFILM,NZSR,NZOB),GRHO0(4,NZSR,NZOB)
      INTEGER :: KITG,KPRM,KCHRG,KEMD,NF,NS,NOB,NSR,NSR1,NSR2,               &
                 I,II,INTER,J,J3,JJ
      COMPLEX :: S(4),S1(4)
      EXTERNAL FHFIL
!
!  -- HF and HF1 are allocatable working arrays for the kernels of the
!     Hankel transforms.
!
      COMPLEX, ALLOCATABLE :: HF(:,:),HF1(:,:)
!
      ALLOCATE(HF(11,NHFILM),HF1(11,NHFILM))
!
! --- CS_TYPE=7, 8, or 9 are for magnetic dipole sources
!
      IF (CS_TYPE==7.OR.CS_TYPE==8.OR.CS_TYPE==9) THEN
         KEMD=2
      ELSE
         KEMD=1
      ENDIF
!
! --- The parameter KCHRG controls the charge terms in the
!     kernels of Hankel transform.  For loop sources, i.e.,
!     ksrc=0 and 4, the charge terms in the electric fields
!     need be canceled in the program since they cannot be
!     canceled numerically.
!
      IF (CS_TYPE==4.OR.CS_TYPE==5.OR.CS_TYPE==6) THEN
         KCHRG=1
      ELSE
         KCHRG=0
      ENDIF
!
      IF (CS_TYPE==2) THEN
         KITG=1
      ELSE
         KITG=0
      ENDIF
!
! --- The primary and secondary parts of the Green's functions
!     are computed together.
!
      KPRM=1
!
      IF (KEYG==1) THEN
         NF=6
      ELSE
         NF=11
      ENDIF
!
      IF (KEYG==2) NS=3
      IF (KEYG==1) THEN
         IF (KEMD==1) THEN
            NS=2
         ELSE
            NS=1
         ENDIF
      ENDIF
!
      Receiver_z_level_loop:  DO I=1,NZOB
!
         DO II=MLAYER-1,0,-1
            IF (ZOBG(I)>=ZBND(II)) THEN
               NOB=II+1
               GOTO 50
            ENDIF
         ENDDO
         NOB=0
!
      50    CONTINUE
         Source_z_level_loop:  DO J=1,NZSR
!
            DO II=1,NF
               DO J3=1,NHFILM
                  GRHF(II,J3,J,I)=(0.,0.)
               ENDDO
            ENDDO
            DO J3=1,NS
               GRHO0(J3,J,I)=(0.,0.)
            ENDDO
!
            IF (CS_TYPE==2) THEN
               DO II=MLAYER-1,0,-1
                  IF (ZSRG(1,J)>=ZBND(II)) THEN
                     NSR1=II+1
                     GOTO 60
                  ENDIF
               ENDDO
               NSR1=0
   60          DO II=MLAYER-1,0,-1
                  IF (ZSRG(2,J)>=ZBND(II)) THEN
                     NSR2=II+1
                     GOTO 80
                  ENDIF
               ENDDO
               NSR2=0
            ENDIF
!
   80       IF (CS_TYPE/=2.OR.NSR1==NSR2) THEN
               INTER=1
               ZBG(1,1)=ZSRG(1,J)
               ZBG(2,1)=ZSRG(2,J)
            ELSE
!
! --- Break the interval [zsrg(1,j), zsrg(2,j)] into subintervals
!     determined by the layer boundaries the two vertical electrodes
!     straddle over.
!
               ZBG(1,1)=ZSRG(1,J)
               INTER=1
               DO II=0,MLAYER
! --- Note that zsrg(2,*) must be > or = zsrg(1,*)
                  IF (ZBND(II)>=ZSRG(1,J).AND.ZBND(II)<=ZSRG(2,J).AND.   &
                      ABS(ZBND(II)-ZBG(1,1))>DMIN) THEN
                     ZBG(2,INTER)=ZBND(II)
                     INTER=INTER+1
                     ZBG(1,INTER)=ZBG(2,INTER-1)
                  ENDIF
               ENDDO
               ZBG(2,INTER)=ZSRG(2,J)
!
            ENDIF
!
            DO JJ=1,INTER
!
               DO II=MLAYER-1,0,-1
                  IF ((ZBG(1,JJ)+ZBG(2,JJ))/2.>=ZBND(II)) THEN
                     NSR=II+1
                     GOTO 90
                  ENDIF
               ENDDO
               NSR=0
!
! ---- If zobg(i) lies in the integral interval [zbg(1,*),zbg(2,*)]
!      the intergral will be cut into two parts for vertical
!      currents.
!
!      Note that zbg(2,*) > zbg(1,*)
!
! ----- Note the grid points in the Rho-direction are generated
!       by the program HFIL
!
   90          IF (CS_TYPE/=2.OR.ZOBG(I)>ZBG(2,JJ).OR.ZOBG(I)<ZBG(1,JJ)) THEN
                  CALL FHFIL(KEYG,KEMD,MLAYER,ZBND,LRYTH,HVK,KKH,KANIS,KPRM,  &
                             KITG,KCHRG,NOB,NSR,RHOMIN,RHOMAX,                &
                             ZOBG(I),ZBG(2,JJ),ZBG(1,JJ),NRG,RRG,HF)
               ELSE
                  CALL FHFIL(KEYG,KEMD,MLAYER,ZBND,LRYTH,HVK,KKH,KANIS,KPRM,  &
                             KITG,KCHRG,NOB,NSR,RHOMIN,RHOMAX,                &
                             ZOBG(I),ZBG(2,JJ),ZOBG(I),NRG,RRG,HF)
                  CALL FHFIL(KEYG,KEMD,MLAYER,ZBND,LRYTH,HVK,KKH,KANIS,KPRM,  &
                             KITG,KCHRG,NOB,NSR,RHOMIN,RHOMAX,                &
                             ZOBG(I),ZOBG(I),ZBG(1,JJ),NRG,RRG,HF1)
               ENDIF
!
               IF(CS_TYPE==2.AND.ZOBG(I)>=ZBG(1,JJ).AND.ZOBG(I)<=ZBG(2,JJ))THEN
!  ---- This may also happen for keyg=2 for cells just below
!       the earth's surface
                  DO II=1,NF
                     DO J3=1,NRG
                        GRHF(II,J3,J,I)=GRHF(II,J3,J,I)+HF(II,J3)+HF1(II,J3)
                     ENDDO
                  ENDDO
               ELSE
!
                  DO II=1,NF
                     DO J3=1,NRG
                        GRHF(II,J3,J,I)=GRHF(II,J3,J,I)+HF(II,J3)
                     ENDDO
                  ENDDO
!
               ENDIF
!
! --  In order to avoid the case where the transmitter and
!     the receiver coincide with each other which may happen
!     due to discretizations for a body under vertical bipole
!     source excitation, namely, the center of a cell lies
!     on the source line,  the electrodes are positioned
!     slightly above or below the receiver (cell center)
!     in such cases.
!
               IF (ABS(ZOBG(I)-ZBG(2,JJ))>=DMIN.OR.            &
                   ABS(ZOBG(I)-ZBG(1,JJ))>=DMIN)     THEN
!
                  IF (CS_TYPE/=2.OR.ZOBG(I)>ZBG(2,JJ).OR.ZOBG(I)<ZBG(1,JJ)) THEN
                     CALL ONE_D_0_2_INFTY(KEYG,KEMD,MLAYER,ZBND,LRYTH,HVK,KKH, &
                                      KANIS,KPRM,KITG,KCHRG,NOB,NSR,ZOBG(I),   &
                                      ZBG(2,JJ),ZBG(1,JJ),ALMAX,NS,S)
                  ELSEIF (ABS(ZOBG(I)-ZBG(1,JJ))<DMIN) THEN
                     CALL ONE_D_0_2_INFTY(KEYG,KEMD,MLAYER,ZBND,LRYTH,HVK,KKH, &
                                      KANIS,KPRM,KITG,KCHRG,NOB,NSR,ZOBG(I),   &
                                      ZBG(2,JJ),ZOBG(I)+2.*BLMIN,ALMAX,NS,S)
                     S1=(0.,0.)
                  ELSEIF (ABS(ZOBG(I)-ZBG(2,JJ))<DMIN) THEN
                     CALL ONE_D_0_2_INFTY(KEYG,KEMD,MLAYER,ZBND,LRYTH,HVK,KKH, &
                                      KANIS,KPRM,KITG,KCHRG,NOB,NSR,ZOBG(I),   &
                                      ZOBG(I)-2.*BLMIN,ZBG(1,JJ),ALMAX,NS,S1)
                     S=(0.,0.)
                  ELSE
                     CALL ONE_D_0_2_INFTY(KEYG,KEMD,MLAYER,ZBND,LRYTH,HVK,KKH, &
                                      KANIS,KPRM,KITG,KCHRG,NOB,NSR,ZOBG(I),   &
                                      ZBG(2,JJ),ZOBG(I)+2.*BLMIN,ALMAX,NS,S)
                     CALL ONE_D_0_2_INFTY(KEYG,KEMD,MLAYER,ZBND,LRYTH,HVK,KKH, &
                                      KANIS,KPRM,KITG,KCHRG,NOB,NSR,ZOBG(I),   &
                                      ZOBG(I)-2.*BLMIN,ZBG(1,JJ),ALMAX,NS,S1)
                  ENDIF
!
                  DO J3=1,NS
                     IF (CS_TYPE/=2.OR.ZOBG(I)>ZBG(2,JJ).OR.        &
                         ZOBG(I)<ZBG(1,JJ))               THEN
                        GRHO0(J3,J,I)=GRHO0(J3,J,I)+S(J3)
                     ELSE
                        GRHO0(J3,J,I)=GRHO0(J3,J,I)+S(J3)+S1(J3)
                     ENDIF
!
                  ENDDO
               ENDIF
!
            ENDDO
!
         ENDDO Source_z_level_loop
!
      ENDDO Receiver_z_level_loop
!
      DO J3=1,NRG
         RRG(J3)=ALOG(RRG(J3))
      ENDDO
!
      DEALLOCATE(HF,HF1)
!
      RETURN
!
   END SUBROUTINE ONE_D_HF_TABLE
!
!
      SUBROUTINE INTERPO_LG(GRHF,A,L,NHFILM,NZSR,NZOB,X,IOB,ISR,F,NF)
!
!**** INTERPOLATION OF THE HANKEL INTEGRALS
!
!    One-dimensional three-point Lagrangian interpolations
!    in the Rho-direction.
!
! Input parameters:
!
!   GRHF:   Complex GRHF(11,NHFILM,NZSR,NZOB), tabulated values of
!           the Hankel integrals.
!   L:      Integer,  number of grid points.
!   A:      Real A(L),  array for grid points.
!   NHFILM: Integer,  maximal number of grids in the lateral direction
!           (rho) for all the Hankel integrals.
!   X:      Real,  interpolation point.
!   IOB:    Integer,  number for receiver z-level.  It is used to
!           specify the third array element of GRHF.
!   ISR:    Integer,  number for receiver z'-level.  It is used to
!           specify the fourth array element of GRHF.
!   NF:     Integer,  number of functions to be interpolated.
!
! Output parameter:
!
!   F:      Complex F(NF),  interpolated NF function values.
!
!
!    This routine is similar to the routine intpl4 a
!    three-point rule is used.
!
!
!**** Called by:  THR_D_GREEN
!
!**** Calls:      none
!
!
      IMPLICIT NONE
!
      REAL A1,A2,A3,X
      INTEGER I,I1,II,IOB,ISR,L,L1,NF,NHFILM,NN,NZSR,NZOB
      REAL A(L),U(3)
      COMPLEX GRHF(11,NHFILM,NZSR,NZOB),F(NF)
!
! --- Sorting
!
      L1=L-2
      DO I=1,L1
         IF (X<=A(I+1)) THEN
            GOTO 100
         ENDIF
      ENDDO
      I=L-2
  100 IF (I/=1.AND.X-A(I)<A(I+1)-X) I=I-1
!
! --- Compute interpolant coefficients
!
      A1=A(I)
      A2=A(I+1)
      A3=A(I+2)
      U(1)=(X-A2)*(X-A3)/((A1-A2)*(A1-A3))
      U(2)=(X-A1)*(X-A3)/((A2-A1)*(A2-A3))
      U(3)=(X-A1)*(X-A2)/((A3-A1)*(A3-A2))
!
      DO NN=1,NF
         F(NN)=(.0,.0)
      ENDDO
!
      DO II=1,3
         I1=I+II-1
!
         DO NN=1,NF
            F(NN)=F(NN)+U(II)*GRHF(NN,I1,ISR,IOB)
         ENDDO
      ENDDO
      RETURN
      END
!
!**** End of INTERPO_LG
!
!
      SUBROUTINE INTERPO_LG1(GRHF3,A,L,NHFILM,NZSR,X,ISR,F,NF)
!
!****   INTERPOLATION OF THE GREEN'S FUNCTIONS FOR
!     OUTCROPPING CELLS.
!
!    One-dimensional three-point Lagrangian interpolations
!    in the Rho-direction.
!
! Input parameters:
!
!   GRHF3:  Complex GRHF3(11,NHFILM,NZSR), tabulated values of
!           the Hankel integrals for an outcropping cell.
!   L:      Integer,  number of grid points.
!   A:      Real A(L),  array for grid points.
!   NHFILM: Integer,  maximal number of grids in the lateral direction
!           (rho) for all the Hankel integrals.
!   X:      Real,  interpolation point.
!   ISR:    Integer,  number for receiver z'-level.  It is used to
!           specify the fourth array element of GRHF.
!   NF:     Integer,  number of functions to be interpolated.
!
! Output parameter:
!
!   F:      Complex F(NF),  interpolated NF function values.
!
!
!    This routine is similar to the routine intpl4 except that a
!    five-point rule is used and that there is no z-level.
!
!
!**** Called by:  THR_D_GREEN
!
!**** Calls:      none
!
!
      IMPLICIT NONE
!
      REAL A1,A2,A3,X
      INTEGER I,I1,II,ISR,L,L1,NF,NHFILM,NN,NZSR
      REAL A(L),U(3)
      COMPLEX GRHF3(11,NHFILM,NZSR),F(NF)
!
! --- Sorting
!
      L1=L-2
      DO I=1,L1
         IF (X<=A(I+1)) THEN
            GOTO 100
         ENDIF
      ENDDO
      I=L-2
  100 IF (I/=1.AND.X-A(I)<A(I+1)-X) I=I-1
!
! --- Computing interpolant coefficients
!
      A1=A(I)
      A2=A(I+1)
      A3=A(I+2)
      U(1)=(X-A2)*(X-A3)/((A1-A2)*(A1-A3))
      U(2)=(X-A1)*(X-A3)/((A2-A1)*(A2-A3))
      U(3)=(X-A1)*(X-A2)/((A3-A1)*(A3-A2))
!
      DO NN=1,NF
         F(NN)=(.0,.0)
      ENDDO
!
      DO II=1,3
         I1=I+II-1
         DO NN=1,NF
            F(NN)=F(NN)+U(II)*GRHF3(NN,I1,ISR)
         ENDDO
      ENDDO
!
      RETURN
      END
!
!**** End of INTERPO_LG1
!
!
      SUBROUTINE INTERPO_LG4(GRHF,A,L,NHFILM,NZSR,NZOB,X,IOB,ISR,F,NF)
!
!**** INTERPOLATION OF THE HANKEL INTEGRALS
!
!    Five-point Lagrangian interpolations
!    in the Rho-direction.
!    Note the abscissas are equally spaced
!
! Input parameters:
!
!   GRHF:   Complex GRHF(11,NHFILM,NZSR,NZOB), tabulated values of
!           the Hankel integrals.
!   L:      Integer,  number of grid points.
!   A:      Real A(L),  array for grid points.
!   NHFILM: Integer,  maximal number of grids in the lateral direction
!           (rho) for all the Hankel integrals.
!   X:      Real,  interpolation point.
!   IOB:    Integer,  number for receiver z-level.  It is used to
!           specify the third array element of GRHF.
!   ISR:    Integer,  number for receiver z'-level.  It is used to
!           specify the fourth array element of GRHF.
!   NF:     Integer,  number of functions to be interpolated.
!
! Output parameter:
!
!   F:      Complex F(NF),  interpolated NF function values.
!
!
!    This routine is similar to the routine intpl15 a
!    five-point rule is used.
!
!
!**** Called by:  THR_D_GREEN
!
!**** Calls:      none
!
!
      IMPLICIT NONE
!
      INTEGER I,I1,ICN2,II,IOB,ISR,L,NF,NHFILM,NN,NZSR,NZOB
      REAL P,P1,P2,PP,X
      REAL A(L),U(5)
      COMPLEX GRHF(11,NHFILM,NZSR,NZOB),F(NF)
!
! --- Sorting
!
      IF (X<=A(1)) THEN
         I=1
      ELSEIF (X>=A(L)) THEN
         I=L
      ELSE
         DO I=1,L-1
            IF (X>=A(I).AND.X<=A(I+1)) THEN
               EXIT
            ENDIF
         ENDDO
      ENDIF
!
      IF (I<=3) THEN
         ICN2=1
      ELSEIF (I>=L-2) THEN
         ICN2=L-4
      ELSE
         ICN2=I-2
      ENDIF
!
! --- Compute interpolant coefficients
!
      P=(X-A(ICN2+2))/(A(2)-A(1))
!
      PP=P*P
      P1=(PP-1.)*P/24.
      P2=P*(PP-4.)/6.
      U(1)=P1*(P-2.)
      U(2)=-(P-1.)*P2
      U(3)=(PP-1.)*(PP-4.)/4.
      U(4)=-(P+1.)*P2
      U(5)=P1*(P+2.)
!
      DO NN=1,NF
         F(NN)=(.0,.0)
      ENDDO
!
      DO II=1,5
         I1=ICN2+II-1
         DO NN=1,NF
            F(NN)=F(NN)+U(II)*GRHF(NN,I1,ISR,IOB)
         ENDDO
      ENDDO
!
      RETURN
      END
!
!**** End of INTERPO_LG4
!
!
      SUBROUTINE INTERPO_LG5(GRHF3,A,L,NHFILM,NZSR,X,ISR,F,NF)
!
!****   INTERPOLATION OF THE HANKEL INTEGRALS FOR
!     OUTCROPPING CELLS.
!
!    Five-point Lagrangian interpolations
!    in the Rho-direction.
!    Note the abscissas are equally spaced
!
!
! Input parameters:
!
!   GRHF3:  Complex GRHF3(11,NHFILM,NZSR), tabulated values of
!           the Hankel integrals for an outcropping cell.
!   L:      Integer,  number of grid points.
!   A:      Real A(L),  array for grid points.
!   NHFILM: Integer,  maximal number of grids in the lateral direction
!           (rho) for all the Hankel integrals.
!   X:      Real,  interpolation point.
!   ISR:    Integer,  number for receiver z'-level.  It is used to
!           specify the fourth array element of GRHF.
!   NF:     Integer,  number of functions to be interpolated.
!
! Output parameter:
!
!   F:      Complex F(NF),  interpolated NF function values.
!
!
!    This routine is similar to the routine intpl except that a
!    five-point rule is used.
!
!
!**** Called by:  THR_D_GREEN
!
!**** Calls:      none
!
!
      IMPLICIT NONE
!
      INTEGER I,I1,ICN2,II,ISR,L,NF,NHFILM,NN,NZSR
      REAL P,P1,P2,PP,X
      REAL A(L),U(5)
      COMPLEX GRHF3(11,NHFILM,NZSR),F(NF)
!
      IF (X<=A(1)) THEN
         I=1
         GOTO 100
      ENDIF
      IF (X>=A(L)) THEN
         I=L
         GOTO 100
      ENDIF
      DO I=1,L-1
         IF (X>=A(I).AND.X<=A(I+1)) THEN
            EXIT
         ENDIF
      ENDDO
!
  100 IF (I<=3) THEN
         ICN2=1
      ELSEIF (I>=L-2) THEN
         ICN2=L-4
      ELSE
         ICN2=I-2
      ENDIF
      P=(X-A(ICN2+2))/(A(2)-A(1))
!
      PP=P*P
      P1=(PP-1.)*P/24.
      P2=P*(PP-4.)/6.
      U(1)=P1*(P-2.)
      U(2)=-(P-1.)*P2
      U(3)=(PP-1.)*(PP-4.)/4.
      U(4)=-(P+1.)*P2
      U(5)=P1*(P+2.)
!
      DO NN=1,NF
         F(NN)=(.0,.0)
      ENDDO
!
      DO II=1,5
         I1=ICN2+II-1
         DO NN=1,NF
            F(NN)=F(NN)+U(II)*GRHF3(NN,I1,ISR)
         ENDDO
      ENDDO
!
      RETURN
      END
!
!**** End of INTERPO_LG5
!
!
      SUBROUTINE INTERPO_LG6(GRHF,A,L,NHFILM,NZSR,NZOB,X,IOB,ISR,F,NF)
!
!****    INTERPOLATION OF THE HANKEL INTEGRALS
!
!    Six-point Lagrangian interpolations
!    in the Rho-direction.
!    Note the abscissas are equally spaced
!
! Input parameters:
!
!   GRHF:   Complex GRHF(11,NHFILM,NZSR,NZOB), tabulated values of
!           the Hankel integrals.
!   L:      Integer,  number of grid points.
!   A:      Real A(L),  array for grid points.
!   NHFILM: Integer,  maximal number of grids in the lateral direction
!           (rho) for all the Hankel integrals.
!   X:      Real,  interpolation point.
!   IOB:    Integer,  number for receiver z-level.  It is used to
!           specify the third array element of GRHF.
!   ISR:    Integer,  number for receiver z'-level.  It is used to
!           specify the fourth array element of GRHF.
!   NF:     Integer,  number of functions to be interpolated.
!
! Output parameter:
!
!   F:      Complex F(NF),  interpolated NF function values.
!
!
!    This routine is similar to the routine intpl4 a
!    six-point rule is used.
!
!
!**** Called by:  ONE_D_GREEN
!
!**** Calls:      none
!
!
      IMPLICIT NONE
!
      INTEGER I,I1,ICN2,II,IOB,ISR,L,NF,NHFILM,NN,NZSR,NZOB
      REAL P,P1,P2,P3,PP1,PP4,X
      REAL A(L),U(6)
      COMPLEX GRHF(11,NHFILM,NZSR,NZOB),F(NF)
!
! --- Sorting
!
      IF (X<=A(1)) THEN
         I=1
      ELSEIF (X>=A(L)) THEN
         I=L
      ELSE
         DO I=1,L-1
            IF (X>=A(I).AND.X<=A(I+1)) THEN
               EXIT
            ENDIF
         ENDDO
      ENDIF
!
      IF (I<=3) THEN
         ICN2=1
      ELSEIF (I>=L-3) THEN
         ICN2=L-5
      ELSE
         ICN2=I-2
      ENDIF
!
! --- Compute interpolant coefficients
!
      P=(X-A(ICN2+2))/(A(2)-A(1))
!
      PP1=(P-1.)*(P+1.)
      PP4=(P-2.)*(P+2.)
      P1=PP1*P/120.
      P2=P*(P-3.)/24.
      P3=(P-3.)*PP4/12.
      U(1)=-P1*(P-2.)*(P-3.)
      U(2)=P2*(P-1.)*PP4
      U(3)=-P3*PP1
      U(4)=P3*P*(P+1.)
      U(5)=-P2*PP1*(P+2.)
      U(6)=P1*PP4
!
      DO NN=1,NF
         F(NN)=(.0,.0)
      ENDDO
!
      DO II=1,6
         I1=ICN2+II-1
         DO NN=1,NF
            F(NN)=F(NN)+U(II)*GRHF(NN,I1,ISR,IOB)
         ENDDO
      ENDDO
!
      RETURN
      END
!
!**** End of INTERPO_LG6
!
!
   SUBROUTINE INTERPO_PLPOL(GRHF,A,L,NHFILM,NZSR,NZOB,X,IOB,ISR,F,NF)
!
!****    INTERPOLATION OF THE HANKEL TRANSFORMS
!
!      Eight-point polynomial or rational interpolations
!      in the Rho-direction.
!
!
!   Input parameters:
!
!     GRHF:   Complex GRHF(11,NHFILM,NZSR,NZOB), tabulated values of
!             the Hankel integrals.
!     L:      Integer,  number of grid points.
!     A:      Real A(L),  array for grid points.
!     NHFILM: Integer,  maximal number of grids in the lateral direction
!             (rho) for all the Hankel integrals.
!     X:      Real,  interpolation point.
!     IOB:    Integer,  number for receiver z-level.  It is used to
!             specify the third array element of GRHF.
!     ISR:    Integer,  number for receiver z'-level.  It is used to
!             specify the fourth array element of GRHF.
!     NF:     Integer,  number of functions to be interpolated.
!
!   Output parameter:
!
!     F:      Complex F(NF),  interpolated NF function values.
!
!
!      This routine takes much more computation time than the
!      Lagrangian interpolations because the interpolation is
!      done recursively for each component of the array F.
!
!
!**** Called by:  ONE_D_GREEN
!
!**** Calls:      none
!
!
      IMPLICIT NONE
!
      INTEGER, INTENT(IN) :: IOB,ISR,L,NF,NHFILM,NZSR,NZOB
      REAL, INTENT(IN) :: A(L)
      COMPLEX, INTENT(OUT) :: F(NF)
!
      INTEGER :: I,I1,ICN2,II,NN
      REAL :: X
      INTEGER, PARAMETER :: NINT=8, NINTM=10
      COMPLEX :: DY,YA(NINTM)
!
      REAL :: XA(NINT)
      COMPLEX, INTENT(IN) :: GRHF(11,NHFILM,NZSR,NZOB)
!
      IF (X<=A(1)) THEN
         I=1
      ELSEIF (X>=A(L)) THEN
         I=L
      ELSE
         DO I=1,L-1
            IF (X>=A(I).AND.X<=A(I+1)) THEN
               EXIT
            ENDIF
         ENDDO
      ENDIF
!
      IF (I<=4) THEN
         ICN2=1
      ELSEIF (I>=L-4) THEN
         ICN2=L-7
      ELSE
         ICN2=I-3
      ENDIF
!
      DO II=1,NINT
         I1=ICN2+II-1
         XA(II)=A(I1)
      ENDDO
!
! --- May need to use a two dimensional array for YA
!     in order to save time.
!
      DO NN=1,NF
!
         DO II=1,NINT
            I1=ICN2+II-1
            YA(II)=GRHF(NN,I1,ISR,IOB)
         ENDDO
!
         CALL INTERPO_POLINT(XA,YA,NINT,X,F(NN),DY)
!
      ENDDO
!
      RETURN
!
   END SUBROUTINE INTERPO_PLPOL
!
!
      SUBROUTINE INTERPO_POLINT(XA,YA,N,X,Y,DY)
!
!**** Polynomial interpolation
!
!   modified from Press et al., Numerical recipes, p.82
!
!
      IMPLICIT NONE
!
      REAL DIF,DIFT,HO,HP,TINY,X
      INTEGER I,M,N,NMAX,NS
!
      PARAMETER (NMAX=10,TINY=1.E-30)
      REAL XA(N)
      COMPLEX YA(N),Y,DY,C(NMAX),D(NMAX),W,DEN
      NS=1
      DIF=ABS(X-XA(1))
      DO I=1,N
         DIFT=ABS(X-XA(I))
         IF (DIFT<DIF) THEN
            NS=I
            DIF=DIFT
         ENDIF
         C(I)=YA(I)
         D(I)=YA(I)
      ENDDO
      Y=YA(NS)
      NS=NS-1
      DO M=1,N-1
         DO I=1,N-M
            HO=XA(I)-X
            HP=XA(I+M)-X
            W=C(I+1)-D(I)
            DEN=CMPLX(HO-HP,0.)
            IF (CABS(DEN)<TINY) THEN
               STOP 'Error in routine INTERPO_POLINT: two identical XA!'
            ENDIF
            DEN=W/DEN
            D(I)=HP*DEN
            C(I)=HO*DEN
         ENDDO
         IF (2*NS<N-M) THEN
            DY=C(NS+1)
         ELSE
            DY=D(NS)
            NS=NS-1
         ENDIF
         Y=Y+DY
      ENDDO
      RETURN
      END
!
!
   SUBROUTINE THR_D_HF_TABLE(FHFIL,NHFILM,MLAYER,ZBND,LRYTH,HVK,KKH,KANIS,  &
                             KSFT,BLMIN,KEYG,DMIN,RHOMIN,RHOMAX,NZOB,ZOBG,  &
                             NZSR,ZSRG,ALMAX,RRG,NRG,RRG3,NRG3,GRHF,GRHF3,  &
                             GRHO0,GRHO03)
!
!****  Compute tabulated Hankel integrals of the Green's functions
!    on a three-demensional grids in the rho (the lateral) direction,
!    z, and z'-directions (or the z and z'-levels).  Note that
!    Hankel integrals for many kernels associated withe the components
!    of the tensor Green's functions are computed simultaneously,
!    thus the array GRHF is four-dimensional.  Those tabulated values
!    are interpolated to compute actual Green's functions or field
!    components.
!
!
! Input parameters:
!
!   NHFILM: Integer,  maximal number of grids in the lateral direction
!           (rho) for all the Hankel integrals.
!   MLAYER: Integer, number of layers excluding the air.
!   ZBND:   Real ZBND(0:MLAYER), coordinates of the layer
!           boundaries with the air earth interface being zbnd(0)=0.
!   LRYTH:  Real LRYTH(MLAYER),  thickness of each layer (the air is not
!           included in LRYTH).
!   HVK:    Real HVK(0:MLAYER),  coefficients of anisotropy of the layers
!           including the air (layer 0 with HVK(0)=1).  The anisotropy
!           coefficients are defined as the square roots of the ratios of
!           horizontal conductivities to vertical conductivities of each
!           layer.  Elements of HVK are always equal to or larger than 1.
!   KKH:    Complex(*8) KKH(0:MLAYER),  square ( **2) of the complex wave
!           number of the layers including the air (layer number 0).
!   KANIS:  Integer, flag for the anisotropy of the media.
!           KANIS=1:  the media are anisotropic in the verical
!                     direction;  and
!           KANIS=0:  the media are isotropic.
!           If the media are isotropic,  use KANIS=0 to simplify
!           the computation.
!   KSFT:   Integer,  parameter controlling whethter there is an outcropping
!           cell.  KSFT=1: yes; and KSFT=0:, no.
!   BLMIN:  Real,  redius and height of a cylinder to be removed
!           from computation for the treatment of singularity
!           arising in the computation of magnetic fields due to
!           an outcropping cell.  See description for KUTCRP
!           in routine THR_D_GREEN for more details.
!   KEYG:   Integer.  Mode of computation controlling whether mangetic
!           fields are to be computed.
!           KEYG=1:  Computing electric fields only.  This is used
!                    when elements of the scattering impedance
!                    matrix are computed;  and
!               =2:  All components of the electric and magnetic fields
!                    are computed as in the computation of secondary
!                    E- and H-fields.
!   DMIN:   Real,  minmum of dimension for numerical treatments of cells.
!           DMIN=0.1 for the low frequency mdule and DMIN=0.001 for the
!           high frequency module.
!   RHOMIN: Real,  minimal dimension in the lateral direction (rho).
!   RHOMAX: Real,  maxiaml dimension in the lateral direction (rho).
!   NZOB:   Integer, number of z-levels. Determined in the main program.
!   ZOBG:   Real ZOBG(NZOB), the nzob z-levels coordinates.
!   NZSR:   Integer,  number of z'-levels.
!   ZSRG:   Real ZSRG(NZSR),  the nzsr z'-levels.
!   FHFIL:  External subroutine determined by the calling program (the
!           main program).  FHFIL is either routine HFILL or HFILH which
!           are similar subroutines with different filters.
!
!   Parameter ALMAX is to be passed into routine ONE_D_KERNEL.  See
!   ONE_D_KERNEL for its description.
!
! Output parameters:
!
!   NRG:    Integer,  number of grids in the lateral direction (rho).
!   RRG:    Real RRG(NRG),  the NRG grid points in rho.
!   NRG3:   Integer,  number of grids in the lateral direction (rho) for
!           the Hankel integrals for outcropping cells, namely, for the
!           array GRHF3 (see following description).
!   RRG3:   Real RRG3(NRG3),  the NRG3 grid points in rho for GRHF3.
!   GRHF:   Complex GRHF(11,NHFILM,NZSR,NZOB), tabulated values of
!           the Hankel integrals.  To be passed to the interpolation
!           routines.
!   GRHF3:  Complex GRHF3(11,NHFILM,NZSR), tabulated values of
!           the Hankel integrals for outcropping cells.  To be passed
!           to the interpolation routines.  It is integrated from blmin
!           to zsrg(2,*) for receivers at the earth's surface.
!   GRHO0:  Complex GRHO0(4,NZSR), tabulated values of the
!           Hankel integrals for rho=0 (source and receiver have the
!           same x and y coordinates).
!   GRHO03:  Complex GRHO03(4,NZSR,NZOB), tabulated values of the
!           Hankel integrals for outcropping cells for rho=0 (source
!           and receiver have the same x and y coordinates).
!
!
! Remarks:
!
!      The grid points in the rho (or R) direction are set
!      up automatically by the Hankel transform subroutine
!      on a logrithmical scale.   Note that the interpolated
!      values in the rho-direction must be divided by rho
!      to obtain the value of the Hankel transform.
!
!      The grid values of the Hankel transform in the z and z'
!      directions are stored at exactly those z and z'-levels
!      (ZOBG and ZSRG) which are determined by discretization.
!      Hence no interpolations in the z and z'-direction are
!      necessary.
!
!      All the Hankel transforms are integrated analytically
!      in the z'-directrion. Results are stored in the preassigned
!      z'-levels (ZSRG) with both upper and lower limits for
!      integration.
!
!      If KSFT=1 and KEYG=2, the array grhf3 and grho3 will
!      be compute. These two arrays are used to deal with the
!      singularities of the secondary magnetic fields at the
!      earth's surface (z=z'=0).
!
!
!**** Called by:  main
!
!**** Calls:      ONE_D_0_2_INFTY,  FHFIL (HFILL,  or HFILH)
!
!
      IMPLICIT NONE
!
      REAL, INTENT(IN) :: ALMAX,BLMIN,DMIN,RHOMAX,RHOMIN
      INTEGER, INTENT(IN) :: KANIS,KEYG,KSFT,MLAYER,NHFILM,NZOB,NZSR
      INTEGER, INTENT(INOUT) :: NRG,NRG3
      REAL, INTENT(IN) :: ZOBG(NZOB),ZSRG(2,NZSR),                            &
                          LRYTH(MLAYER),ZBND(0:MLAYER),HVK(0:MLAYER)
      REAL, INTENT(INOUT) :: RRG(NHFILM),RRG3(NHFILM)
      COMPLEX, INTENT(IN) :: KKH(0:MLAYER)
      COMPLEX, INTENT(INOUT) :: GRHF(11,NHFILM,NZSR,NZOB),GRHO0(4,NZSR,NZOB), &
                                GRHF3(11,NHFILM,NZSR),GRHO03(4,NZSR)
      INTEGER :: KITG,KPRM,KCHRG,KEMD,NF,NOB,NSR,I,II,J,JJ
      REAL    :: ZSR1
      COMPLEX :: S(4),S1(4)
!
      EXTERNAL FHFIL
!
!  -- HF and HF1 are allocatable working arrays for the kernels of the
!     Hankel transforms.
!
      COMPLEX, ALLOCATABLE :: HF(:,:),HF1(:,:)
!
      ALLOCATE(HF(11,NHFILM),HF1(11,NHFILM))
!
! --- KEMD control if electric or magnetic dipoles are to be
!   computed.  Here for the Green's tensors within the body,
!   only electric dipoles are considered.
!
      KEMD=1
!
! --- The parameter KCHRG controls the charge terms in the
!   kernels of Hankel transform.
!
      KCHRG=0
!
      KITG=1
!
      IF (KEYG==1) THEN
         NF=6
      ELSE
         NF=11
      ENDIF
!
      DO I=1,NZOB
!
         DO II=MLAYER-1,0,-1
            IF (ZOBG(I)>=ZBND(II)) THEN
               NOB=II+1
               GOTO 50
            ENDIF
         ENDDO
         NOB=0
!
   50    DO J=1,NZSR
!
            DO II=MLAYER-1,0,-1
               IF ((ZSRG(1,J)+ZSRG(2,J))/2.>=ZBND(II)) THEN
                  NSR=II+1
                  GOTO 60
               ENDIF
            ENDDO
            NSR=0
!
!---- The Green's functions will be separated into primary and
!     secondary parts if the receiver and the source reside
!     in the same layer in forming the scattering matrices,
!     or if there are receivers located in the 3D structure
!     in computing the scattered fields.
!
! 20   IF(KEYG.EQ.1.AND.NOB.EQ.NSR .OR.
!   +   KEYG.EQ.2.AND.KGHP.EQ.0.AND.NOB.EQ.NSR) THEN
!
   60       IF (KEYG==1.AND.NOB==NSR) THEN
               KPRM=0
            ELSE
               KPRM=1
            ENDIF
!
! ---- If zobg(i) lies in the integral interval (zsrg(1,j)-zsrg(2,j)),
!    the intergral will be cut into two parts.
!
!    Note that zsrg(2,j) > zsrg(1,j).
!
! ----- Note the grid points in the Rho-direction are generated
!     by the program HFILL ore HFILH
!
            IF (ZOBG(I)>ZSRG(2,J).OR.ZOBG(I)<ZSRG(1,J)) THEN
               CALL FHFIL(KEYG,KEMD,MLAYER,ZBND,LRYTH,HVK,KKH,KANIS,KPRM,      &
                          KITG,KCHRG,NOB,NSR,RHOMIN,RHOMAX,ZOBG(I),            &
                          ZSRG(2,J),ZSRG(1,J),NRG,RRG,HF)
            ELSE
               CALL FHFIL(KEYG,KEMD,MLAYER,ZBND,LRYTH,HVK,KKH,KANIS,KPRM,KITG, &
                          KCHRG,NOB,NSR,RHOMIN,RHOMAX,ZOBG(I),ZSRG(2,J),       &
                          ZOBG(I),NRG,RRG,HF)
               CALL FHFIL(KEYG,KEMD,MLAYER,ZBND,LRYTH,HVK,KKH,KANIS,KPRM,KITG, &
                          KCHRG,NOB,NSR,RHOMIN,RHOMAX,ZOBG(I),ZOBG(I),         &
                          ZSRG(1,J),NRG,RRG,HF1)
            ENDIF
!
            IF (ZOBG(I)>=ZSRG(1,J).AND.ZOBG(I)<=ZSRG(2,J)) THEN
!
!---- This may also happen for keyg=2 for cells just below
!     the earth's surface
               DO JJ=1,NRG
                  DO II=1,NF
                     GRHF(II,JJ,J,I)=HF(II,JJ)+HF1(II,JJ)
                  ENDDO
               ENDDO
            ELSE
               DO JJ=1,NRG
                  DO II=1,NF
                     GRHF(II,JJ,J,I)=HF(II,JJ)
                  ENDDO
               ENDDO
            ENDIF
!
! ----- To avoid singularity in case zobg(i) and zsrg(1,j) = 0
!     the lower limit for integration in the z'-direction is
!     increased from 0 to blmin/2.
!     Note that for outcropping structures the electric fields
!     on the top of blocks at the earth's surface are determined
!     from the scattering currents directly.
!
!     Note that the two elements for self-cells are not
!     computed.
!
            IF (KEYG/=2.OR.ABS(ZOBG(I))>=DMIN.OR.ABS(ZSRG(1,J))>=DMIN)  THEN
!----------------------------------------------------
!|                                                  |
! -- Outcroppers are computed later
!
               IF (ZOBG(I)>ZSRG(2,J).OR.ZOBG(I)<ZSRG(1,J)) THEN
                  CALL ONE_D_0_2_INFTY(KEYG,KEMD,MLAYER,ZBND,LRYTH,HVK,KKH, &
                                   KANIS,KPRM,KITG,KCHRG,NOB,NSR,ZOBG(I),   &
                                   ZSRG(2,J),ZSRG(1,J),ALMAX,KEYG+1,S)
!
! -- The following two blocks are used to avoid singularity
!    if the receivers are located on or near a layer boundary
!    within the 3D structure, or in the case when the receiver
!    is located on the top or bottom of a cell and yet in a
!    different layer as the cell
!
               ELSEIF (ABS(ZOBG(I)-ZSRG(2,J))<DMIN.AND.NOB/=NSR) THEN
                  CALL ONE_D_0_2_INFTY(KEYG,KEMD,MLAYER,ZBND,LRYTH,HVK,KKH,  &
                                   KANIS,KPRM,KITG,KCHRG,NOB,NSR,ZOBG(I),    &
                                   ZSRG(2,J)-BLMIN,ZSRG(1,J),ALMAX,KEYG+1,S1)
                  DO JJ=1,KEYG+1
                     S(JJ)=(0.,0.)
                  ENDDO
               ELSEIF (ABS(ZOBG(I)-ZSRG(1,J))<DMIN.AND.NOB/=NSR) THEN
                  CALL ONE_D_0_2_INFTY(KEYG,KEMD,MLAYER,ZBND,LRYTH,HVK,KKH,  &
                                   KANIS,KPRM,KITG,KCHRG,NOB,NSR,ZOBG(I),    &
                                   ZSRG(2,J),ZSRG(1,J)+BLMIN,ALMAX,KEYG+1,S)
                  DO JJ=1,KEYG+1
                     S1(JJ)=(0.,0.)
                  ENDDO
               ELSE
                  CALL ONE_D_0_2_INFTY(KEYG,KEMD,MLAYER,ZBND,LRYTH,HVK,KKH,  &
                                   KANIS,KPRM,KITG,KCHRG,NOB,NSR,ZOBG(I),    &
                                   ZSRG(2,J),ZOBG(I),ALMAX,KEYG+1,S)
                  CALL ONE_D_0_2_INFTY(KEYG,KEMD,MLAYER,ZBND,LRYTH,HVK,KKH,  &
                                   KANIS,KPRM,KITG,KCHRG,NOB,NSR,ZOBG(I),    &
                                   ZOBG(I),ZSRG(1,J),ALMAX,KEYG+1,S1)
               ENDIF
!
            ENDIF
!|                                                  |
!----------------------------------------------------
!
            DO JJ=1,KEYG+1
               IF (ZOBG(I)>ZSRG(2,J).OR.ZOBG(I)<ZSRG(1,J)) THEN
                  GRHO0(JJ,J,I)=S(JJ)
               ELSE
                  GRHO0(JJ,J,I)=S(JJ)+S1(JJ)
               ENDIF
            ENDDO
!
         ENDDO
      ENDDO
!
      DO JJ=1,NRG
         RRG(JJ)=ALOG(RRG(JJ))
      ENDDO
!
      IF (KEYG==2.AND.KSFT==1) THEN
!**************************************************
!*                                                *
!
! ---- For outcropping structures a cylindrical volume with radius
!    of blmin and height of blmin near the observer will be
!    removed in the integration of the magnetic Green's functions.
!
!   Note here the receiver and source are in the same layer.
!   The surface of the earth is always considered to be layer # 1
!   which is the layer of the outcropping cells. Notice the .ge.
!   in the lines determining layer sequences throught the program.
!
!   kprm changed to be 1.   See the comments at the beginning of
!   the routine THR_D_GREEN
!
!    KPRM=0
!
         KPRM=1
!
! --- The array grhf3 adn grho3 are formed for every z'-level,
!   but ... (see below)
!
         DO I=1,NZSR
!
            ZSR1=(ZSRG(1,I)+ZSRG(2,I))/2.
!
            DO II=MLAYER-1,0,-1
               IF (ZSR1>=ZBND(II)) THEN
                  NSR=II+1
                  GOTO 80
               ENDIF
            ENDDO
            NSR=0
   80       NOB=NSR
!
! --- Compute GRHF3 for outcropping cells.
!
            IF (ZSRG(1,I)<=.1)                                         &
               CALL FHFIL(KEYG,KEMD,MLAYER,ZBND,LRYTH,HVK,KKH,KANIS,   &
                          KPRM,KITG,KCHRG,NOB,NSR,.1,BLMIN,0.,         &
                          ZSRG(2,I),BLMIN,NRG3,RRG3,HF)
!
            DO II=1,NF
               DO JJ=1,NRG3
                  GRHF3(II,JJ,I)=HF(II,JJ)
               ENDDO
            ENDDO
!
            IF (ZSRG(1,I)<=.1) THEN
               CALL ONE_D_0_2_INFTY(KEYG,KEMD,MLAYER,ZBND,LRYTH,HVK,   &
                                    KKH,KANIS,KPRM,KITG,KCHRG,NOB,NSR, &
                                    0.,ZSRG(2,I),BLMIN,ALMAX,3,S)
               GRHO03(1,I)=S(1)
               GRHO03(2,I)=S(2)
               GRHO03(4,I)=S(3)
            ENDIF
!
         ENDDO
!
         DO JJ=1,NRG3
            RRG3(JJ)=ALOG(RRG3(JJ))
         ENDDO
!
!*                                                *
!**************************************************
      ENDIF
!
      DEALLOCATE(HF,HF1)
!
   END SUBROUTINE THR_D_HF_TABLE
!
!
      SUBROUTINE THR_D_GREEN(KEYG,PSTION,FRQ,MLAYER,ZBND,CDH,HVK,NZOB,ZOBG,  &
                             NZSR,ZSRG,RHOMIN,DMIN,NHFILM,RRG,NRG,GRHF,RRG3, &
                             NRG3,GRHF3,GRHO0,GRHO03,CLX,CLY,CLZ,CLMN,KCLMN, &
                             BLMIN,KACC,KUTCRP,KSELF,ECOMP,HCOMP)
!
!****   Integration of the tensor green's functions over a
!     prismatic cell
!
!
! Input parameters:
!
!   KEYG:   Integer.  Mode of computation controlling whether mangetic
!           fields are to be computed.
!           KEYG=1:  Computing electric fields only.  This is used
!                    when elements of the scattering impedance
!                    matrix are computed;  and
!               =2:  All components of the electric and magnetic fields
!                    are computed as in the computation of secondary
!                    E- and H-fields.
!   PSTION: Real PSTION(8),  the positions of the source and the
!           receiver plus the lower and upper z-coordinates the kernels
!           are integrated analytically.  The first 3 elements of the
!           array is for the x, y, and z-coordinates of the receiver,
!           which are followed by the x, y, and z-coordinates of the
!           source.  The last two elements are the lower and upper
!           z-coordinates of the integral interval.  If the kernels
!           are not integrated,  the last two elements must be identical
!           to the source z-coordinate,  i.e.,  the last three elements
!           of PSTION must be the same if the kernels are not to be
!           integrated in teh vertical direction.
!   FRQ:    Real(*4), frequency.
!   MLAYER: Integer, number of layers excluding the air.
!   ZBND:   Real ZBND(0:MLAYER), coordinates of the layer
!           boundaries with the air earth interface being zbnd(0)=0.
!   CDH:    Complex CDH(0:MLAYER),  complex conductivities of
!           the layers in the lateral direction including the
!           air (layer 0).
!   HVK:    Real HVK(0:MLAYER),  coefficients of anisotropy of the layers
!           including the air (layer 0 with HVK(0)=1).  The anisotropy
!           coefficients are defined as the square roots of the ratios of
!           horizontal conductivities to vertical conductivities of each
!           layer.  Elements of HVK are always equal to or larger than 1.
!   NZOB:   Integer, number of z-levels. Determined in the main program.
!   ZOBG:   Real ZOBG(NZOB), the nzob z-levels coordinates.
!   NZSR:   Integer,  number of z'-levels.
!   ZSRG:   Real ZSRG(NZSR),  the nzsr z'-levels.
!   RHOMIN: Real,  minimum of the lateral grid (rho) which determines
!           the minimum of rho in the Hankel integrals.  RHOMIN=0.1 for
!           the low frequency mdule and RHOMIN=0.01 for the high
!           frequency module.
!   DMIN:   Real,  minmum of dimension for numerical treatments of cells.
!           DMIN=0.1 for the low frequency mdule and DMIN=0.001 for the
!           high frequency module.
!   NHFILM: Integer,  maximal number of grids in the lateral direction
!           (rho) for all the Hankel integrals.
!   NRG:    Integer,  actual number of grids in the lateral direction
!           (rho) for the arrays RRG and GRHF.
!   RRG:    Real RRG(NRG),  the NRG grid points in rho.
!   GRHF:   Complex GRHF(11,NHFILM,NZSR,NZOB), tabulated values of
!           the Hankel integrals.  To be passed to the interpolation
!           routines.
!   NRG3:   Integer,  number of actual grids in the lateral direction
!           (rho) for the arrays RRG3 and GRHF3.
!   RRG3:   Real RRG3(NRG),  the NRG3 grid points in rho.
!   GRHF3:  Complex GRHF3(11,NHFILM,NZSR), tabulated values of
!           the Hankel integrals for outcropping cells.  To be passed
!           to the interpolation routines.
!   GRHO0:  Complex GRHO0(4,NZSR,NZOB), tabulated values of the
!           Hankel integrals for rho=0 (source and receiver have the
!           same x and y coordinates).
!   GRHO03:  Complex GRHO03(4,NZSR,NZOB), tabulated values of the
!           Hankel integrals for outcropping cells for rho=0 (source
!           and receiver have the same x and y coordinates).
!   CLX:    Real,  dimension of the cell in the x-direction.
!   CLY:    Real,  dimension of the cell in the y-direction.
!   CLZ:    Real,  dimension of the cell in the z-direction.
!   KCLMN:  Integer,  controlling paramter for the choice of values
!           for the parameter CLMN.  KCLMN=0:  automatic;  and
!           KCLMN=1:  input.  See the following description for
!           CLMN for details.
!   CLMN:   Real,  medium dimension for which the number steps
!           in the numerical integration is defined.  The parameter
!           CLMN is a global parameter. For the numerical
!           integrations of self-cells and most directly adjacent
!           cells,  a parameter CLREF is found by the minimal cell
!           dimensions of that cell if keyg=1.  Otherwise the
!           global value of CLMN is used.  This allows automatic
!           control of the accuracy of integration for most cases
!           while minimizing the computation time.  Since the
!           numbers of steps for the volume and the surface
!           integrations over the cell for certain accuracy are
!           mostly determined by the geometric angle of the
!           receiver with respect to cell deimensions,  the
!           minimal cell dimension may be the best reference
!           length in forming the matrix.   But this reference
!           length may increase computation unnecessarily for
!           computing the secondary fields as well as for the
!           matrix entries of far separeted cells if the body is
!           discretized into greatly non-equal sizes of cells,
!           such as very big cells for some part and very thin
!           plate-like cells for other parts.  Therefore,  a
!           global parameter is necessary.  For keyg=1, however,
!           the global clmn may be used if KCLMN=1 which may
!           add more flexibility in dealing with complex structures
!           as well as for manipulating the numerical integrations.
!           Clmn may be input or may have defaulted values.   See
!           documention on the input parameters KCLMN and CLMN
!           in "MARCO.DOC" for details.
!   BLMIN:  Real,  redius and height of a cylinder to be removed
!           from computation for the treatment of singularity
!           arising in the computation of magnetic fields due to
!           an outcropping cell.  See description for KUTCRP
!           in the following for more details.
!   KACC:   Integer,  accuracy level of computation.  KACC=1, 2
!           3, 4, or 5.  KACC controls the accuracy of the
!           numerical integration of the Green's functions
!           with increasing number of steps as KACC increases.
!           The higher the level,  the more accurate at the
!           cost of computation time.  A 2 or 3 is usually
!           adequate.  For high contrast models us 3 or 4.
!           KACC=5 should be used only for serious convergence
!           tests purpose.  See documentation "MARCO.DOC" for
!           more details.
!   KUTCRP: Integer,  parameter controlling whether the receiver
!           is located just above a outcroping cell,  which is
!           determined in the routines emrspm and emrspms.  If so
!           (koutcrp=1),  electric fields won't be computed by
!           routines THR_D_GREEN and geprm.  Instead, the electric
!           fields at the top of a outcroping cell is determined
!           by the scattering current directly in emrspm and emrspms.
!           Magnetic fields are integrated by excluding a small
!           volume (a cylinder with radius and height of BLMIN).
!           This parameter was first introduced for MT problems
!           and has been adapted for downhole receivers of
!           controlled source problems as well as for MT receivers
!           at different z planes.  Thus, koutcrop=1 does not
!           necessarily mean the body outcrops, it may also mean
!           that the receiver is on the surfaces of or within the
!           body.
!           Note that koutcrop=0 when forming the scattering matrix
!           (keyg=1).
!   KSELF:  Integer,  parameter controlling whether computations
!           for self-cells should be done.  It is to be passed to
!           routine THR_D_GEPRM.  See THR_D_GEPRM for detail.
!
!
! Output parameters:
!
!   ECOMP:  Complex ECOMP(9),  the nine components of the electric
!           field tensor,  Exx, Eyx, Ezx, Exy, ..., and Ezz.  Note
!           that in parameters Exy etc. the first index "x" denotes
!           the direction of the field and the second index "y"
!           denotes the direction of the source.
!   HCOMP:  Complex HCOMP(9),  the nine componenets fo the magnetic
!           field tensor which is arranged in the same way as ECOMP.
!
!
!   Note that the Green's functions are not separated into primary and
!   secondary parts as in routine THR_D_GREEN.   Whether the kernels are
!   integrated analytically in the z'-directions or not is controlled
!   in the routine ONE_D_HF_TABLE.  The calling routine ONE_D_LINE must
!   correctly determine this.
!
!   For loop sources, i.e., ksrc=4, 5, or 6, the charge terms in
!   the electric fields need be canceled in the program since
!   they cannot be canceled numerically. This is considered in
!   kernel function, routine kernel, as well as in the routines
!   gridhf and gridcs.   However,  the components Ezz and Exx
!   for rho=0 have different factors before and after the charge
!   terms are removed.  Those factors are numerically more
!   advantagous to be considered here than to be considered in
!   the kernel functions.
!
!   The parameter KRAT controls the interpolation rules to be
!   used in interpolating the Hankel transforms.
!
!   Note that the Hankel integrals for the Green's functions must
!   computed before this routine is called.  The integrals are first
!   tabulated by routine THR_D_HF_TABLE and then interpolated by routines
!   INTERPO_LG4 etc.
!
!
! --- Remarks:
!
!     In parameters like EXY etc. the first index "x" denotes the
!     direction of the field and the second index "y" denotes
!     the direction of the source.
!
!     Cells are not allowed to intersect any layer boundary if
!     numerical integrations of the Green's functions are applied,
!     for otherwise the implementation of the numerical
!     integrations will be much more complicated and possiblly
!     inaccurate.
!
!     Kernels are integrated analytically in the z'-directions.
!     This has been done in the routine THR_D_HF_TABLE with KITG=1.
!     Thus the numerical integrations here are,  except for
!     self-cells, surface integration only.
!
!     The numbers of steps for the primary and secondary parts,
!     or the total Green's functions if not separated,  have
!     been thoroughly tested for both keyg=1 and keyg=2.
!
!     If keyg=1, the primary and secondary parts of the Green's
!     functions are separated if z and z' are in the same layer.
!     however, if keyg=2, they are not separated unless the
!     receiver is on or within the cell.
!
!
!****  CALLED by:
!
!****  CALLS    :  geprm, ghprm, vxyz, intpl, intpl1, intpl4 and intpl5
!
!
      IMPLICIT NONE
!
      REAL BLMIN,C1,C2,CLDST,CLMN,CLNGTH,CLREF,CLX,CLXS,CLY,CLYS,CLZ,CM,  &
           CMX,CMY,CX,CY,DIST,FRQ,RCD
      REAL RHO,RHO1,RHOMIN,SCL,X1,XI,XOB,XR,XSR,XSRS,Y1,YI,YOB,YR,YSR,    &
           YSRS,ZOB,ZSR
      INTEGER I,II,IOB,ISR,ISUB,J,JSUB,KACC,KCLMN,KEYG,KHF,KPRM,KRCD,     &
              KSELF,KUTCRP,MCX,MCY,MINT,MLAYER,MSX
      INTEGER MSY,MX,MXINT,MY,MYINT,MZINT,NF,NHFILM,NOB,NRG,NRG3,NSR,     &
              NZOB,NZSR
!
      COMPLEX ECOMP(9),HCOMP(9),                              &
              EXX,EYX,EZX,EXY,EYY,EZY,EXZ,EYZ,EZZ,            &
              HXX,HYX,HZX,HXY,HYY,HZY,HXZ,HYZ,HZZ,            &
              GAX,HF(11),WMU,CDH(0:MLAYER),S(4),              &
              GRHF(11,NHFILM,NZSR,NZOB),GRHO0(4,NZSR,NZOB),   &
              GRHF3(11,NHFILM,NZSR),GRHO03(4,NZSR)
      REAL ZBND(0:MLAYER),HVK(0:MLAYER),ZOBG(NZOB),ZSRG(2,NZSR),   &
           RRG(NRG),RRG3(NRG3),PSTION(6),DMIN
!
      RHO(XR,YR,XI,YI)=SQRT((XR-XI)**2+(YR-YI)**2)
!
      C2=1./4./3.1415926
      WMU=CMPLX(0.,78.9568352E-7*FRQ)
!
! --- Extract parameter values for XOB etc. from PSTION
!
      XOB=PSTION(1)
      YOB=PSTION(2)
      ZOB=PSTION(3)
      XSR=PSTION(4)
      YSR=PSTION(5)
      ZSR=PSTION(6)
!
! ---- Set the number of steps for the numerical integration according
!    to the accuracy levels. Note that the numbers of steps are assumed
!    to be equal in both of the three dimensions at first. The actual
!    values are then determined later on by the ratios of the lengths
!    of a specific cell in either dimension with the value of the
!    parameter CLMN and by the distance of the cell to the receiver
!    point.
!
      IF (KACC==1) THEN
         MINT=2
      ELSEIF (KACC==2) THEN
         MINT=4
      ELSEIF (KACC==3) THEN
         MINT=6
      ELSEIF (KACC==4) THEN
         MINT=8
      ELSE
         MINT=12
      ENDIF
!
! ---- Determine the actual number of steps in each dimensions
!
      MXINT=MINT
      MYINT=MINT
      MZINT=MINT
!
! ---- Determine the reference length of the cell dimensions
!    to which the above-asigned numbers of steps are defined.
!    If kclmn=0 and keyg=1, choose the minimal length of the
!    cell dimensions for self-cells and most directly adjacent
!    cells.  Otherwise, use the global value.
!
      CLREF=AMIN1(CLX,CLY,CLZ)+DMIN
      IF (KCLMN==0.AND.KEYG==1.AND.ABS(XOB-XSR)<CLREF.AND.ABS(YOB-YSR)  &
          <CLREF.AND.ABS(ZOB-ZSR)<CLREF) THEN
         CLREF=AMIN1(CLX,CLY,CLZ)
      ELSE
         CLREF=CLMN
      ENDIF
!
      IF (CLX>CLREF) MXINT=INT(FLOAT(MXINT)*(CLX/CLREF))
      IF (CLY>CLREF) MYINT=INT(FLOAT(MYINT)*(CLY/CLREF))
      IF (CLZ>CLREF) MZINT=INT(FLOAT(MZINT)*(CLZ/CLREF))
!
! --- Determine the layer numbers the cell and the receiver
!   are located.
!   Note that each cell is confined within a single layer.
!
      DO I=MLAYER-1,0,-1
         IF (ZOB>=ZBND(I)) THEN
            NOB=I+1
            GOTO 100
         ENDIF
      ENDDO
      NOB=0
  100 DO I=MLAYER-1,0,-1
         IF (ZSR>=ZBND(I)) THEN
            NSR=I+1
            GOTO 200
         ENDIF
      ENDDO
      NSR=0
!
! ---- Determine the level of zob in the grid array zobg
!
  200 DO I=1,NZOB
         IF (ABS(ZOB-ZOBG(I))<DMIN) THEN
            IOB=I
            GOTO 300
         ENDIF
      ENDDO
!
      WRITE (4,*) 'Warning: failed to choose a z-level for zob=',ZOB
!
! ---- Determine the level of zsr in the grid array zsrg
!    Note that the z'-levels in the zsr-direction are
!    determined by the full lengths of the cells
!
  300 DO I=1,NZSR
         IF (ABS(ZSR-CLZ/2.-ZSRG(1,I))<DMIN.AND.  &
             ABS(ZSR+CLZ/2.-ZSRG(2,I))<DMIN) THEN
            ISR=I
            GOTO 400
         ENDIF
      ENDDO
!
      WRITE (4,*) 'Warning: failed to choose a z_prime-level',  &
                  ' for zsr=',ZSR
!
!
! ---- Determine if the Green's functions are to be computed
!    separately as primary and secondary parts. Note this has
!    been taken into account already in the routine gridhf
!    where the gridding is formed.
!
!    Note that the meaning of KPRM is as follows:
!
!       KPRM = 0: the primary fields (the whole space terms) are cal-
!                 culated by the subroutines THR_D_GEPRM and THR_D_GHPRM; and
!            = 1: the primary fields are calculated together with the
!                 secondary terms by means of Hankel transforms
!
!    It is adviced however, not to calculate the whole space and secon-
!    dary parts separately if the observation points (ZOB or z') is in
!    the air and the source (ZSR) is in the earth, because the conducti-
!    vity of the air approaches zero and only simple precision is used
!    here in the calculation and so the electrical fields resulted may
!    be inaccurate.
!
!    The parameter KGHP is disabled.  See the following description.
!    In case this parameter need to be re-considered,  it must
!    be included in the arguement lists in this routine and
!    probably in routne THR_D_HF_TABLE as well.
!
!   KGHP:   Integer, controlling parameter for treatment of
!           singularity if the receiver is located within a cell.
!           KGHP was originally introduced to control the
!           computation for downhole receivers that are located
!           within a cell.  In such cases (KGHP=0), the primary
!           and secondary parts were separated if the receiver
!           and the source cell were in the same layer.  The
!           electric and the magnetic fields were treated in the
!           same way as for outcropping cells.  The singularity in
!           the primary parts of the magnetic Green's function was
!           removed by excluding a small sphere while the
!           contributions of the secondary parts due to a cylinder
!           were excluded in the numerical integration.   This
!           treatment, however,  seemed inaccurate,  mainly
!           because of the routine ghprm, which might still have
!           undetected error.   Therefore Now the primary and the
!           secondary parts are not separated for keyg=2.  Unlike
!           for outcropping cells,  a cylinder with radius of
!           BLMIN and height of clz is removed from the integration
!           of the magnetic Green's functions.  This treatment has
!           been proven to be more accurate and efficient.
!
!    IF(KEYG.EQ.1.AND.NOB.EQ.NSR .OR.
!   +   KEYG.EQ.2.AND.KGHP.EQ.0.AND.NOB.EQ.NSR) THEN
!
  400 IF (KEYG==1.AND.NOB==NSR) THEN
         KPRM=0
      ELSE
         KPRM=1
      ENDIF
!
! ---  Further reductions
!
! -- Reduce the number of steps for the secondary terms.  Tests
!    have shown that with a reduction factor of about 1.5 the
!    numerica integrations of the secondary parts may match the
!    accuracy of the primary parts.  Note the secondary parts
!    cost far more computation time for one single value (one step)
!    than the priamry parts.
!
!    This reduction is only valid if when the primary parts are
!    separated from the computation here
!
!  !! May sometimes affects the accuracy !!
!
!    IF(KPRM.EQ.0) THEN
!      MXINT=MXINT*.7
!      MYINT=MYINT*.7
!    ENDIF
!
! ----- The numbers of steps determined above are for the self-cells
!     only, i.e., for |r-r'|=0.  Each cell will be divided into
!     many sub-cells in order to reduce unnecessary computations
!     for cells having great aspect ratios.  The numbers of steps
!     for the numerical integration is then determined by the
!     distance of the subcells to the receiver point.
!
!     Note that the subcells for the primary parts are determined
!     similarly in the corresponding routines.
!
      IF (KPRM==0) THEN
!
! Calculating the primary terms integrated over the cell
!
! --- Note that the E-field of a outcropping block is computed by
!   the scattering current directly
!
         IF (KUTCRP==0) THEN
            CALL THR_D_GEPRM(PSTION,KACC,KSELF,CLREF,MXINT,MYINT,MZINT,CLX, &
                             CLY,CLZ,FRQ,CDH(NSR),HVK(NSR),DMIN,GAX,ECOMP)
            EXX=ECOMP(1)
            EYX=ECOMP(2)
            EZX=ECOMP(3)
            EXY=ECOMP(4)
            EYY=ECOMP(5)
            EZY=ECOMP(6)
            EXZ=ECOMP(7)
            EYZ=ECOMP(8)
            EZZ=ECOMP(9)
         ENDIF
         IF (KEYG==2) THEN
            CALL THR_D_GHPRM(PSTION,KACC,BLMIN,CLREF,MXINT,MYINT,MZINT,CLX, &
                             CLY,CLZ,FRQ,CDH(NSR),HVK(NSR),DMIN,HCOMP)
            HXX=HCOMP(1)
            HYX=HCOMP(2)
            HZX=HCOMP(3)
            HXY=HCOMP(4)
            HYY=HCOMP(5)
            HZY=HCOMP(6)
            HXZ=HCOMP(7)
            HYZ=HCOMP(8)
            HZZ=HCOMP(9)
         ENDIF
         EXX=GAX+CDH(NSR)/CDH(NOB)*(EXX-GAX)
         EYX=CDH(NSR)/CDH(NOB)*EYX
         EYY=GAX+CDH(NSR)/CDH(NOB)*(EYY-GAX)
         EXY=EYX
         EZX=CDH(NSR)/CDH(NOB)*EZX
         EZY=CDH(NSR)/CDH(NOB)*EZY
         EXZ=CDH(NSR)/CDH(NOB)*EXZ
         EYZ=CDH(NSR)/CDH(NOB)*EYZ
         EZZ=CDH(NSR)/CDH(NOB)*EZZ
      ENDIF
!
      IF (KPRM==1) THEN
         EXX=(0.,0.)
         EYX=(0.,0.)
         EZX=(0.,0.)
         EXY=(0.,0.)
         EYY=(0.,0.)
         EZY=(0.,0.)
         EXZ=(0.,0.)
         EYZ=(0.,0.)
         EZZ=(0.,0.)
         IF (KEYG==2) THEN
            HXX=(0.,0.)
            HYX=(0.,0.)
            HZX=(0.,0.)
            HXY=(0.,0.)
            HYY=(0.,0.)
            HZY=(0.,0.)
            HXZ=(0.,0.)
            HYZ=(0.,0.)
            HZZ=(0.,0.)
         ENDIF
      ENDIF
!
! -----------  Compute the secondary terms  --------------
!
! ---- Divide the cell into subcells
!
!    Every subcell has a length of either 2*CLREF or 3*CLREF
!    in either direction, according to kacc.   For higher
!    kacc it is more efficient to have smaller subcell size.
!    But small subcell may increase waste for low kacc.
!
!    Note that the cell is not divided in the vertical direction
!    since the Hankel transforms and intergrated analytically
!    in the z-direction.
!
      IF (KACC<=3) THEN
         SCL=3.*CLREF
      ELSE
         SCL=2.*CLREF
      ENDIF
      MSX=INT(CLX/SCL)
      MSY=INT(CLY/SCL)
      IF (MSX<1) MSX=1
      IF (MSY<1) MSY=1
      MCX=MXINT/MSX
      MCY=MYINT/MSY

      CLXS=CLX/MSX
      CLYS=CLY/MSY
!
      DO ISUB=1,MSX
         IF (MSX==1) THEN
            XSRS=XSR
         ELSE
            XSRS=XSR+CLXS*(ISUB-1)-CLX/2.+.5*CLXS
         ENDIF
         DO JSUB=1,MSY
            IF (MSY==1) THEN
               YSRS=YSR
            ELSE
               YSRS=YSR+CLYS*(JSUB-1)-CLY/2.+.5*CLYS
            ENDIF
!
!-- Determine the distance of the subcell to the receiver point
!   with respect to the dimension of the subcell.
!
!   Note that unlike in the routine geprm where only the dimensions
!   of the surfaces are compared with the distance, here it is the
!   subcell diagonal length that is compared with the distance
!   because the x-y surface used in the integration here is for
!   both the bottom and the top of a cell in the z'-direction.
!
            DIST=SQRT((RHO(XOB,YOB,XSRS,YSRS))**2+(ZOB-ZSR)**2)
            CLNGTH=SQRT(CLXS**2+CLYS**2+CLZ**2)
!
! --- Determine the numbers of steps according to the distance
!   between the source and the receiver
!
!-- Determine the location of the receiver close to the cell.
!   This is necessary for computing the EM fields at receiver
!   sites which are close to the cell.  Note that outcropping
!   cells has been considered already elsewhere.
!
            IF (KEYG==2.AND.KUTCRP==0) THEN
!
               IF (DIST<=CLNGTH) THEN
                  CM=AMIN1(CLXS,CLYS,CLZ)
                  KRCD=5
                  DO I=1,4
                     IF (I==1) THEN
                        RCD=.05*CM
                     ELSEIF (I==2) THEN
                        RCD=.1*CM
                     ELSEIF (I==3) THEN
                        RCD=.2*CM
                     ELSE
                        RCD=.5*CM
                     ENDIF
                     IF (XOB>=XSRS-.5*CLXS-RCD.AND.XOB<=XSRS+.5*CLXS+  &
                         RCD.AND.YOB>=YSRS-.5*CLYS-RCD.AND.  &
                         YOB<=YSRS+.5*CLYS+RCD.AND.ZOB>=ZSR-.5*CLZ-  &
                         RCD.AND.ZOB<=ZSR+.5*CLZ+RCD) THEN
                        KRCD=I
                        EXIT
                     ENDIF
                  ENDDO
               ENDIF
!
! ---- Determine the numbers of steps according to DIST and KRCD
!
               IF (DIST<=CLNGTH) THEN
                  IF (KRCD==1) THEN
                     MX=8*MCX
                     MY=8*MCY
                  ENDIF
                  IF (KRCD==2) THEN
                     MX=5*MCX
                     MY=5*MCY
                  ENDIF
                  IF (KRCD==3) THEN
                     MX=3*MCX
                     MY=3*MCY
                  ENDIF
                  IF (KRCD==4) THEN
                     MX=MCX*2
                     MY=MCY*2
                  ENDIF
                  IF (KRCD==5) THEN
                     MX=MCX*3/2
                     MY=MCY*3/2
                  ENDIF
               ELSEIF (DIST<=3.*CLNGTH) THEN
                  MX=MCX
                  MY=MCY
               ELSE
                  CLDST=SQRT(2.*CLNGTH/DIST)
                  MX=INT(FLOAT(MCX)*CLDST)
                  MY=INT(FLOAT(MCY)*CLDST)
               ENDIF
!
            ENDIF
!
! --- The following rules for the numbers of steps have been tested
!   thoroughly.
!
!   The introduction of the parameter clref garantees the accuracy
!   of the self-cells.   Self-cells are treatly more accurately in
!   order to ensure accuracies since on the other hand the primary
!   parts need to be computed only once for a block.
!
!   It seems that the accuracy of the numerical integrations for
!   cells from 0 to about 3 clengths has more effects on the
!   final results than other cells.
!
!   The rule for cldst may be changed as sqrt(clength/dist) to
!   save a little bit computation time.  There seems to be no
!   significant difference which one to use.
!
!   The decay patterns of the step numbers have been tested with
!   clength/dist, sqrt(clength/dist), and (clength/dist)**.3333.
!   It seems that the second one yields adequate accuracy while
!   minimizing the computation time.
!
!-- The following rules are also used by outcropping cells
!   in computing the responses at receiver sites
!
            IF (KEYG/=2.OR.KUTCRP/=0) THEN
!
               IF (DIST<=1.*CLNGTH) THEN
                  MX=MCX*3/2
                  MY=MCY*3/2
! --  Test has shown that the above rule is insufficient for the
!   magentic fields of outcropping cells.  Mx and My are thus
!   increased for outcropping cells.
                  IF (KEYG==2.AND.KUTCRP==1) THEN
                     MX=MX*4
                     MY=MY*4
                  ENDIF
               ELSEIF (DIST<=3.*CLNGTH) THEN
                  MX=MCX
                  MY=MCY
               ELSE
                  CLDST=SQRT(2.*CLNGTH/DIST)
                  MX=INT(FLOAT(MCX)*CLDST)
                  MY=INT(FLOAT(MCY)*CLDST)
               ENDIF
!
            ENDIF
!
            IF (MX<1) MX=1
            IF (MY<1) MY=1
!
!-- A step number of 3 may not be more accuarate than the 2
!   used for the four-point approach to surface integrations
!
            IF (MX==3) MX=2
            IF (MY==3) MY=2
!
            IF (MX>1) CMX=MX-1.
            IF (MY>1) CMY=MY-1.
!
!-- The four-point approach to the surface integration is
!   preserved from the previous work of Xiong et al (1986)
!
            DO I=1,MX
               IF (MX==1) THEN
                  X1=XSRS
                  CX=1.
               ELSEIF (MX==2) THEN
                  X1=XSRS+2.*(I-1.5)*.288675*CLXS
                  CX=.5
               ELSE
                  X1=XSRS-.5*CLXS+CLXS/CMX*(I-1.)
                  CX=1./CMX
                  IF (I==1.OR.I==MX) CX=.5*CX
               ENDIF
               DO J=1,MY
                  IF (MY==1) THEN
                     Y1=YSRS
                     CY=1.
                  ELSEIF (MY==2) THEN
                     Y1=YSRS+2.*(J-1.5)*.288675*CLYS
                     CY=.5
                  ELSE
                     Y1=YSRS-.5*CLYS+CLYS/CMY*(J-1.)
                     CY=1./CMY
                     IF (J==1.OR.J==MY) CY=.5*CY
                  ENDIF
!
                  C1=C2*CX*CY*CLXS*CLYS
!
                  RHO1=RHO(XOB,YOB,X1,Y1)
!
! ----- KHF together with keyg controls which gridding to be chosen
!     KHF=2: ordinary grid values; and
!        =1: a cylinder of radius blmin is excluded for treatment
!            of the singularities. See routine gridhf
!
!     Note this need only be done for outcropping cells.
!     for receivers on or within a cells deep in the earth
!     a cylinder of diameter blmin and height clz is excluded.
!     Here for outcropping cells the height of the cylinder is
!     blmin and the diameter is 2*blmin.   See
!     comments at the beginning of this routine.
!
                  IF (KEYG==2.AND.ABS(ZOB)<DMIN.AND.ABS(ZSR-.5*CLZ)  &
                      <DMIN.AND.RHO1<BLMIN) THEN
                     KHF=1
                  ELSE
                     KHF=2
                  ENDIF
!
! ----- If Rho < RHOMIN it should be assumed to be zero because the
!     Hankel transforms by digital linear filter are limited for
!     Rho >= RHOMIN
!
                  IF (RHO1>=RHOMIN) THEN
!****************************************************
!*                                                  *
!
                     IF (KEYG==1) THEN
                        NF=6
                     ELSE
                        NF=11
                     ENDIF
!
! --- khf controls which gridding to be chosen
!
!   Note three-point interpolation rules are used for
!   kacc <= 2 and five-point interpolation rules are
!   used for kacc>=3
!
                     IF (KHF==1) THEN
                        IF (KACC<=2)                                       &
                            CALL INTERPO_LG1(GRHF3,RRG3,NRG3,NHFILM,NZSR,  &
                                      ALOG(RHO1),ISR,HF,NF)
                        IF (KACC>=3)                                       &
                            CALL INTERPO_LG5(GRHF3,RRG3,NRG3,NHFILM,NZSR,  &
                                      ALOG(RHO1),ISR,HF,NF)
                     ELSE
                        IF (KACC<=2)                                       &
                            CALL INTERPO_LG(GRHF,RRG,NRG,NHFILM,NZSR,NZOB, &
                                     ALOG(RHO1),IOB,ISR,HF,NF)
                        IF (KACC>=3)                                        &
                            CALL INTERPO_LG4(GRHF,RRG,NRG,NHFILM,NZSR,NZOB, &
                                      ALOG(RHO1),IOB,ISR,HF,NF)
                     ENDIF
!
! ----- HF are now divided by rho
!
                     DO II=1,NF
                        HF(II)=HF(II)/RHO1
                     ENDDO
!
                     IF (KUTCRP==0) THEN
!
!-- Note that the correction done to HF(2) in the kernel
!   function, routine ONE_D_KERNEL,  will not affect this routine
!   since z and z' will never be zero.
!
                        EXX=EXX-C1*WMU*HF(1)-C1/CDH(NOB)               &
                            *(((XOB-X1)/RHO1)**2*HF(2)                 &
                            +(1.-2.*((XOB-X1)/RHO1)**2)/RHO1*HF(4))
                        EYX=EYX-C1/CDH(NOB)*(XOB-X1)*(YOB-Y1)          &
                            /RHO1**2*(HF(2)-2.*HF(4)/RHO1)
                        EYY=EYY-C1*WMU*HF(1)-C1/CDH(NOB)               &
                            *(((YOB-Y1)/RHO1)**2*HF(2)                 &
                            +(1.-2.*((YOB-Y1)/RHO1)**2)/RHO1*HF(4))
                        EXY=EYX
                        EZX=EZX-C1/CDH(NOB)*(XOB-X1)/RHO1*HF(5)
                        EZY=EZY-C1/CDH(NOB)*(YOB-Y1)/RHO1*HF(5)
                        EXZ=EXZ-C1/CDH(NOB)*(XOB-X1)/RHO1*HF(6)
                        EYZ=EYZ-C1/CDH(NOB)*(YOB-Y1)/RHO1*HF(6)
                        EZZ=EZZ+C1/CDH(NOB)*HF(3)
!
                     ENDIF
!
! ---  Compute magneti fields if KEYG=2
!
!    A cylinder of diameter blmin is removed if the receiver
!    is located on or within the cell
!
!    Note that outcropping cells has been considered by the
!    parameter KHF
!
                     IF (KEYG==2.AND.                                 &
                         .NOT.(KUTCRP==1.AND.ABS(ZOB)>=.1.AND.        &
                         ABS(ZSR-.5*CLZ)>=.1.AND.RHO1<=.5*BLMIN)) THEN
!
                        HXX=-C1*(XOB-X1)*(YOB-Y1)                     &
                            /RHO1**2*(HF(7)-2./RHO1*HF(9))+HXX
                        HYX=C1*HF(8)+C1*((XOB-X1)/RHO1)**2*HF(7)      &
                            +C1*(1.-2.*((XOB-X1)/RHO1)**2)/RHO1*HF(9) &
                            +HYX
                        HXY=-C1*HF(8)-C1*((YOB-Y1)/RHO1)**2*HF(7)     &
                            -C1*(1.-2.*((YOB-Y1)/RHO1)**2)/RHO1*HF(9) &
                            +HXY
                        HYY=-HXX
                        HZX=C1*(YOB-Y1)/RHO1*HF(10)+HZX
                        HZY=-C1*(XOB-X1)/RHO1*HF(10)+HZY
                        HXZ=-C1*(YOB-Y1)/RHO1*HF(11)+HXZ
                        HYZ=C1*(XOB-X1)/RHO1*HF(11)+HYZ
                        HZZ=(0.,0.)
                     ENDIF
!
!*                                                  *
!****************************************************
                  ENDIF
!
                  IF (RHO1<RHOMIN) THEN
!****************************************************
!*                                                  *
!
                     DO II=1,KEYG+1
                        IF (KEYG==2.AND.KHF==1) THEN
                           S(II)=GRHO03(II,ISR)
                        ELSE
                           S(II)=GRHO0(II,ISR,IOB)
                        ENDIF
                     ENDDO
!
                     IF (KUTCRP==0) THEN
                        S(1)=-C1/CDH(NOB)*S(1)
                        EXX=EXX+S(1)
                        EYY=EYY+S(1)
                        EZZ=EZZ-C1/CDH(NOB)*S(2)
                     ENDIF
!
                     IF (KEYG/=1.AND.KUTCRP/=1) THEN
                        HYX=C1*S(3)+HYX
                        HXY=-C1*S(3)+HXY
                     ENDIF
!
!*                                                  *
!****************************************************
                  ENDIF
!
               ENDDO
            ENDDO
         ENDDO
      ENDDO
!
!
! --- Assign the componenets to the arrays ECOMP and HCOMP
!   for data passing
!
      ECOMP(1)=EXX
      ECOMP(2)=EYX
      ECOMP(3)=EZX
      ECOMP(4)=EXY
      ECOMP(5)=EYY
      ECOMP(6)=EZY
      ECOMP(7)=EXZ
      ECOMP(8)=EYZ
      ECOMP(9)=EZZ
      HCOMP(1)=HXX
      HCOMP(2)=HYX
      HCOMP(3)=HZX
      HCOMP(4)=HXY
      HCOMP(5)=HYY
      HCOMP(6)=HZY
      HCOMP(7)=HXZ
      HCOMP(8)=HYZ
      HCOMP(9)=HZZ
!
      RETURN
      END
!
!**** End of THR_D_GREEN
!
!
      SUBROUTINE THR_D_VXYZ(CLX,CLY,CLZ,XSR,YSR,ZSR,XX,YY,ZZ)
!
!**** Six-point rule for numerical integration of a prismatic cube
!
! Input parameters:
!
!   CLX,CLY,CLZ:  Real,  dimension of the cell in the x, y,
!                 and z direction;  and
!   XSR,YSR,ZSR:  Real,  center coordinates of the cell in
!                 the x, y and z-direction.
!
! Output parameters:
!
!   XX, YY, ZZ:   Real XX(6), YY(6), ZZ(6),  the six sampling
!                 points for numerical volume integration.
!
!**** Called by:  THR_D_GEPRM, THR_D_GHPRM
!
!**** Calls:      None
!
!
      IMPLICIT NONE
!
      INTEGER I
      REAL SIGN
      REAL  CLX,CLY,CLZ,XSR,YSR,ZSR,XX(6),YY(6),ZZ(6)
!
      DO I=1,4
         XX(2+I)=XSR
         ZZ(I)=ZSR
      ENDDO
      DO I=1,2
         YY(I)=YSR
         YY(4+I)=YSR
         SIGN=2.*(I-1.5)
         XX(I)=XSR+SIGN*CLX/2.
         YY(2+I)=YSR+SIGN*CLY/2.
         ZZ(4+I)=ZSR+SIGN*CLZ/2.
      ENDDO
!
      RETURN
      END
!
!**** End of THR_D_VXYZ
!
!
      SUBROUTINE THR_D_GEPRM(PSTION,KACC,KSELF,CLREF,MXINT,MYINT,MZINT,   &
                             CLX,CLY,CLZ,FRQ,CDH,HVK,DMIN,GAX,ECOMP)
!
!**** Integration of the primary e-fields of the tensor green's function
!
!
! Input parameters:
!
!   KACC:   Integer,  accuracy level of computation.  KACC=1, 2
!           3, 4, or 5.  KACC controls the accuracy of the
!           numerical integration of the Green's functions
!           with increasing number of steps as KACC increases.
!           The higher the level,  the more accurate at the
!           cost of computation time.  A 2 or 3 is usually
!           adequate.  For high contrast models us 3 or 4.
!           KACC=5 should be used only for serious convergence
!           tests purpose.  See documentation "MARCO.DOC" for
!           more details.
!   KSELF:  Integer,  parameter controlling whether computations
!           for self-cells should be done.  This parameter is
!           determined in routines forming the scattering matrix.
!           Primary contributions of self-cells (fields due to
!           the cell at it's own cell center) are the same for
!           cells with the same dimensions in the same layer (
!           being treated as a whole space).  Since self-cells
!           are expensive to compute,  computing them only once
!           helps to reduce computation time.   Note that cells
!           must be arranged in certain order in order to avoid
!           fetching the wrong values for self-cells with different
!           dimensions.  Field values for a self-cell are stored
!           in the parameters EXX1,  EYX1, ..., EZZ1, and GAX1.
!           routine THR_D_GEPRM.  See THR_D_GEPRM for detail.
!   CLREF:  Real,  minimal dimension of the cell in consideration.
!           In routine THR_D_GREEN it is used as the reference
!           dimension for which the number of steps for numerical
!           integration is defined.  Actual number of steps in each
!           dimension depends on the ratio of that dimension to
!           CLREF.  Here and in the computation of the secondary
!           parts of the Green's tensors in routine THR_D_GREEN
!           CLREF is used as a reference to further dividing a
!           cell into subcells for more efficient and accurate
!           treatments of the numerical integrations.
!   MXINT:  Integer,  number of steps in the x-direction.
!   MYINT:  Integer,  number of steps in the y-direction.
!   MZINT:  Integer,  number of steps in the z-direction.
!   CLX:    Real,  dimension of the cell in the x-direction.
!   CLY:    Real,  dimension of the cell in the y-direction.
!   CLZ:    Real,  dimension of the cell in the z-direction.
!   FRQ:    Real(*4), frequency.
!   CDH:    Complex CDH(0:MLAYER),  complex conductivities of
!           the layers including the air (layer 0).
!   HVK:    Real HVK(0:MLAYER),  coefficients of anisotropy of the layers
!           including the air (layer 0 with HVK(0)=1).  The anisotropy
!           coefficients are defined as the square roots of the ratios of
!           horizontal conductivities to vertical conductivities of each
!           layer.  Elements of HVK are always equal to or larger than 1.
!   DMIN:   Real,  minmum of dimension for numerical treatments of cells.
!           DMIN=0.1 for the low frequency mdule and DMIN=0.001 for the
!           high frequency module.
!
! Output parameters:
!
!   GAX:    Complex, the primay current term due to a selff-cell.
!   ECOMP:  Complex ECOMP(9),  the nine components of the electric
!           field tensor,  Exx, Eyx, Ezx, Exy, ..., and Ezz.  Note
!           that in parameters Exy etc. the first index "x" denotes
!           the direction of the field and the second index "y"
!           denotes the direction of the source.
!
!****  CALLED by: THR_D_GREEN
!
!****  CALLS    : THR_D_GASELF,  THR_D_VXYZ
!
!
      IMPLICIT NONE
!
      REAL B1,B2,B3,CLDST,CLNGTH,CLXS,CLYS,CLZS,CMX,CMY,CMZ,CX,CY,CZ,DIST, &
           HVK,R,R1,RA,RK,RR,RR1,RS,SCL,T2,T3,T4,X1,XI,XR,XSRS,Y1,YI,YR,   &
           YSRS,Z1,ZI,ZR,ZSRS
      INTEGER I,II,ISUB,J,J3,JJ,JSUB,KACC,KINT,KSELF,KSUB,L,MCX,MCY,MCZ,   &
              MM1,MM2,MM3,MSX,MSY,MSZ,MX,MXINT,MY,MYINT,MZ,MZINT
      REAL  DMIN,XOB,YOB,ZOB,XSR,YSR,ZSR,PSTION(6),          &
            CLX,CLY,CLZ,FRQ,CLREF,XX(6),YY(6),ZZ(6)
      COMPLEX CDH,K,WMU,CG,G1,G2,G3,G4,C2,C1,                &
              GX,GY,GZ,GZX,GZY,GAX,GAX1,D1,D2,D3,ECOMP(9),   &
              EXX,EXY,EXZ,EYX,EYY,EYZ,EZX,EZY,EZZ,           &
              EXX1,EXY1,EXZ1,EYX1,EYY1,EYZ1,EZX1,EZY1,EZZ1
      SAVE EXX1,EYX1,EZX1,EXY1,EYY1,EZY1,EXZ1,EYZ1,EZZ1,GAX1
!
      R(XR,YR,ZR,XI,YI,ZI)=SQRT((XR-XI)**2+(YR-YI)**2+(ZR-ZI)**2)
      RK(XR,YR,ZR,XI,YI,ZI)=SQRT((XR-XI)**2+(YR-YI)**2+(HVK*(ZR-ZI))**2)
      RR(XR,YR,XI,YI)=SQRT((XR-XI)**2+(YR-YI)**2)
!
      WMU=CMPLX(.0,78.9568352E-7*FRQ)
      K=CSQRT(WMU*CDH)
!
! --- Extract parameter values for XOB etc. from PSTION
!
      XOB=PSTION(1)
      YOB=PSTION(2)
      ZOB=PSTION(3)
      XSR=PSTION(4)
      YSR=PSTION(5)
      ZSR=PSTION(6)
!
      RS=R(XOB,YOB,ZOB,XSR,YSR,ZSR)
!
! ----- Compute a self-cell unless kself=1
!
      IF (KSELF/=1.AND.RS<DMIN) THEN
         EXX=EXX1
         EYX=EYX1
         EZX=EZX1
         EXY=EXY1
         EYY=EYY1
         EZY=EZY1
         EXZ=EXZ1
         EYZ=EYZ1
         EZZ=EZZ1
         GAX=GAX1
!
!**** Goto the end of the routine for return
!
         GOTO 100
!
      ENDIF
!
! ---- Divide the cell into subcells
!
!    Every subcell has a length of either 2*CLREF or 3*CLREF
!    in either direction, according to kacc.   For higher
!    kacc it is more efficient to have smaller subcell size.
!    But small subcell may increase waste for low kacc.
!
      IF (KACC<=3) THEN
         SCL=3.*CLREF
      ELSE
         SCL=2.*CLREF
      ENDIF
      MSX=INT(CLX/SCL)
      MSY=INT(CLY/SCL)
      MSZ=INT(CLZ/SCL)
!
!--- For the treatment of the singularity in the current term for
!    self-cells the subdivisions of cells should be in odd
!    numbers (the center subcell is approximated by a sphere or
!    spheroid).   This may also increase the accuracy of the
!    surface integrations for the charge terms a little bit.
!
      MSX=(MSX/2)*2+1
      MSY=(MSY/2)*2+1
      MSZ=(MSZ/2)*2+1
!
      IF (MSX<1) MSX=1
      IF (MSY<1) MSY=1
      IF (MSZ<1) MSZ=1
      MCX=MXINT/MSX
      MCY=MYINT/MSY
      MCZ=MZINT/MSZ
      CLXS=CLX/MSX
      CLYS=CLY/MSY
      CLZS=CLZ/MSZ
!
! ---- Compute the current terms by volumn integrations
!
      GX=(.0,.0)
      GZ=(.0,.0)
      GZX=(.0,.0)
      GZY=(.0,.0)
!
      DO ISUB=1,MSX
         IF (MSX==1) THEN
            XSRS=XSR
         ELSE
            XSRS=XSR+CLXS*(ISUB-1)-CLX/2.+.5*CLXS
         ENDIF
         DO JSUB=1,MSY
            IF (MSY==1) THEN
               YSRS=YSR
            ELSE
               YSRS=YSR+CLYS*(JSUB-1)-CLY/2.+.5*CLYS
            ENDIF
            DO KSUB=1,MSZ
               IF (MSZ==1) THEN
                  ZSRS=ZSR
               ELSE
                  ZSRS=ZSR+CLZS*(KSUB-1)-CLZ/2.+.5*CLZS
               ENDIF
!
!-- Determine the distance of the subcell to the receiver point
!   with respect to the dimension of the subcell.
!
               DIST=SQRT((RR(XOB,YOB,XSRS,YSRS))**2+(ZOB-ZSRS)**2)
               CLNGTH=SQRT(CLXS**2+CLYS**2+CLZS**2)
!
               IF (DIST<DMIN) THEN
!*****************************************************
!*                                                   *
!
!--- If DIST < DMIN it should be assumed to be zero for the sake
!    of numerical accuracy.
!
                  CALL THR_D_GASELF(CLXS,CLYS,CLZS,MCX,MCY,MCZ,CDH,HVK,K,  &
                                    DMIN,G1,G2)
                  GX=GX+G1
                  GZ=GZ+G2
!*                                                   *
!*****************************************************
               ENDIF
!
               IF (DIST>=DMIN) THEN
!
!*****************************************************
!*                                                   *
!
!-- Determine the numbers of steps according to the distance
!   between the source and the receiver.
!   Self-cells are considered in the above line.
!
!   See the comments on the choices of step numbers in the
!   routine THR_D_GREEN.
!
                  IF (DIST<=1.*CLNGTH) THEN
                     MX=MCX*3/2
                     MY=MCY*3/2
                     MZ=MCZ*3/2
                  ELSEIF (DIST<=3.*CLNGTH) THEN
                     MX=MCX
                     MY=MCY
                     MZ=MCZ
                  ELSE
                     CLDST=SQRT(2.*CLNGTH/DIST)
                     MX=INT(FLOAT(MCX)*CLDST)
                     MY=INT(FLOAT(MCY)*CLDST)
                     MZ=INT(FLOAT(MCZ)*CLDST)
                  ENDIF
!
!--- The current terms are more smooth than the charge terms
!    for low frequencies.  Hence the number of steps for the
!    numerical integrations can be reduced.
!
!    Tests have shown that the current terms can greatly
!    affect the final accuracies for frequencies above
!    100 Hz or so.   But for lower frequencies the following
!    reduction of MX etc. seems reasonable.
!
!--- Tests done by CRA, Australia indicate that the following
!    reduction in MX etc. introduce a few percent of errors
!    in the magnetic fields for frequency at 100 Hz, and that
!    the results show a jump at 100 Hz in a magnified scale.
!    Further tests showed that even the reduction for frequency
!    lower than 1 Hz there are appreciable instability at
!    later times in time domain solutions.  Thus the following
!    reduction in MX etc. is elimilated.
!
!       IF(FRQ.LT.1.) THEN
!         MX=MX*2/3
!         MY=MY*2/3
!         MZ=MZ*2/3
!       ENDIF
!
                  IF (MX<1) MX=1
                  IF (MY<1) MY=1
                  IF (MZ<1) MZ=1
!
                  IF (MX>1) CMX=MX-1.
                  IF (MY>1) CMY=MY-1.
                  IF (MZ>1) CMZ=MZ-1.
!
                  C2=-WMU*CLXS*CLYS*CLZS
!
! --- The parameter kint controls if the six-point rule or the
!   multi-step trapezoidal rule should be used.
!   The six-point approach to the volume integration is perserved
!   from the previous work of Xiong et al (1986)
!
!   Step numbers less than or equal to 3 in either dimension
!   may not be more accuarate than the 6-point approach
!
                  IF (MX<=3.AND.MY<=3.AND.MZ<=3.AND.MX>1.AND.MY>1.AND.  &
                      MZ>1) THEN
                     KINT=1
                  ELSE
                     KINT=2
                  ENDIF
!
                  IF (KINT==1) THEN
                     CALL THR_D_VXYZ(CLXS,CLYS,CLZS,XSRS,YSRS,ZSRS,XX,YY,ZZ)
                     MM1=1
                     MM2=1
                     MM3=6
                  ELSE
                     MM1=MX
                     MM2=MY
                     MM3=MZ
                  ENDIF
!
                  DO I=1,MM1
                     IF (KINT==2.AND.MM1==1) THEN
                        X1=XSRS
                        CX=1.
                     ENDIF
                     IF (KINT==2.AND.MM1/=1) THEN
                        X1=XSRS-.5*CLXS+CLXS/CMX*(I-1.)
                        CX=1./CMX
                        IF (I==1.OR.I==MX) CX=.5*CX
                     ENDIF
                     DO J=1,MM2
                        IF (KINT==2.AND.MM2==1) THEN
                           Y1=YSRS
                           CY=1.
                        ENDIF
                        IF (KINT==2.AND.MM2/=1) THEN
                           Y1=YSRS-.5*CLYS+CLYS/CMY*(J-1.)
                           CY=1./CMY
                           IF (J==1.OR.J==MY) CY=.5*CY
                        ENDIF
                        DO J3=1,MM3
                           IF (KINT==2.AND.MM3==1) THEN
                              Z1=ZSRS
                              CZ=1.
                           ELSEIF (KINT==2.AND.MM3/=1) THEN
                              Z1=ZSRS-.5*CLZS+CLZS/CMZ*(J3-1.)
                              CZ=1./CMZ
                              IF (J3==1.OR.J3==MZ) CZ=.5*CZ
                           ELSE
                              X1=XX(J3)
                              Y1=YY(J3)
                              Z1=ZZ(J3)
                           ENDIF
!
                           IF (KINT==1) THEN
                              C1=C2/6.
                           ELSE
                              C1=C2*CX*CY*CZ
                           ENDIF
!
                           R1=R(XOB,YOB,ZOB,X1,Y1,Z1)
!
                           G1=.0795774771*CEXP(-K*R1)/R1
                           GX=GX+G1*C1
                           IF (ABS(HVK-1.)<=.00001) THEN
                              GZ=GX
                              CYCLE
                           ENDIF
                           RR1=RR(XOB,YOB,X1,Y1)
                           RA=RK(XOB,YOB,ZOB,X1,Y1,Z1)
                           G2=.0795774771*HVK*CEXP(-K*RA/HVK)/RA
                           GZ=GZ+G2*C1
                           IF (RR1<=.001) THEN
                              G3=(.0,.0)
                           ELSE
                              G3=(ZOB-Z1)/RR1**2*(G1-G2)
                           ENDIF
                           GZX=GZX+(XOB-X1)*G3*C1
                           GZY=GZY+(YOB-Y1)*G3*C1
                        ENDDO
                     ENDDO
                  ENDDO
!
!*                                                   *
!*****************************************************
               ENDIF
!
            ENDDO
         ENDDO
      ENDDO
!
      GY=GX
      IF (ABS(HVK-1.)<=.00001) GZ=GX
      GAX=GX
!
! ---- Compute the charge terms by surface integrations
!
      C2=.0795774771/CDH
      T2=.288675*CLXS
      T3=.288675*CLYS
      T4=.288675*CLZS
!
      DO L=1,3,2
!
         D1=(.0,.0)
         D2=(.0,.0)
         D3=(.0,.0)
         X1=XSR-(FLOAT(L)-2.)*CLX*.5
!
!-- Note that the coordinates in the x-direction are fixed
!   and cells are divided only in the y and z directions
!
         DO JSUB=1,MSY
            IF (MSY==1) THEN
               YSRS=YSR
            ELSE
               YSRS=YSR+CLYS*(JSUB-1)-CLY/2.+.5*CLYS
            ENDIF
            DO KSUB=1,MSZ
               IF (MSZ==1) THEN
                  ZSRS=ZSR
               ELSE
                  ZSRS=ZSR+CLZS*(KSUB-1)-CLZ/2.+.5*CLZS
               ENDIF
!
!-- Determine the distance of the subcell surface over which the
!   integration is to be done to the receiver point with
!   respect to the dimension of the subcell surface.
!
               DIST=SQRT((RR(XOB,YOB,X1,YSRS))**2+(ZOB-ZSRS)**2)
               CLNGTH=SQRT(CLYS**2+CLZS**2)
!
!-- Determine the numbers of steps according to the distance
!   between the source and the receiver
!
!   See the comments on the choices of step numbers in the
!   routine THR_D_GREEN.
!
!   Since the distance of the actual surface of integration
!   to the receiver point is used, DIST may never be zero in
!   forming the scattering matrix.
!
               IF (DIST<=1.*CLNGTH) THEN
                  MY=MCY*3/2
                  MZ=MCZ*3/2
               ELSEIF (DIST<=3.*CLNGTH) THEN
                  MY=MCY
                  MZ=MCZ
               ELSE
                  CLDST=SQRT(2.*CLNGTH/DIST)
                  MY=INT(FLOAT(MCY)*CLDST)
                  MZ=INT(FLOAT(MCZ)*CLDST)
               ENDIF
!
               IF (MY<1) MY=1
               IF (MZ<1) MZ=1
!
!-- A step number of 3 may not be more accuarate than the 2
!   used for the four-point approach to surface integrations
!
               IF (MY==3) MY=2
               IF (MZ==3) MZ=2
!
               IF (MY>1) CMY=MY-1.
               IF (MZ>1) CMZ=MZ-1.
!
!-- The four-point approach to the surface integration is preserved
!   from Xiong et al (1986)
!
               DO II=1,MY
                  IF (MY==1) THEN
                     Y1=YSRS
                     CY=1.
                  ELSEIF (MY==2) THEN
                     Y1=YSRS+2.*(II-1.5)*T3
                     CY=.5
                  ELSE
                     Y1=YSRS-.5*CLYS+CLYS/CMY*(II-1.)
                     CY=1./CMY
                     IF (II==1.OR.II==MY) CY=.5*CY
                  ENDIF
                  DO JJ=1,MZ
                     IF (MZ==1) THEN
                        Z1=ZSRS
                        CZ=1.
                     ELSEIF (MZ==2) THEN
                        Z1=ZSRS+2.*(JJ-1.5)*T4
                        CZ=.5
                     ELSE
                        Z1=ZSRS-.5*CLZS+CLZS/CMZ*(JJ-1.)
                        CZ=1./CMZ
                        IF (JJ==1.OR.JJ==MZ) CZ=.5*CZ
                     ENDIF
                     C1=C2*CY*CZ*CLYS*CLZS
!
                     R1=R(XOB,YOB,ZOB,X1,Y1,Z1)
!
                     CG=K*R1
                     G3=C1*((1.,0.)+CG)*CEXP(-CG)/R1/R1/R1
                     B1=XOB-X1
                     D1=D1+B1*G3
                     B2=YOB-Y1
                     D2=D2+B2*G3
                     IF (ABS(HVK-1.)>=.0001) THEN
                        RA=RK(XOB,YOB,ZOB,X1,Y1,Z1)/HVK
                        CG=K*RA
                        G4=C1*((1.,0.)+CG)*CEXP(-CG)/RA/RA/RA
                        RR1=RR(XOB,YOB,X1,Y1)
! ----  The limit values of the anisotropic terms for rho = 0
!     have yet to be strictly determined. Here they are assumed
!     to be zero for simplicity.
                        IF (RR1>=DMIN) THEN
                           G1=C1*CEXP(-K*R1)/R1
                           G2=C1*CEXP(-K*RA)/RA
                           B3=ZOB-Z1
                           CG=(G2-G1+B3**2*(G3-G4))/RR1**2
                           D1=D1+B1*CG
                           D2=D2+B2*CG
                        ENDIF
                        G3=G4
                     ENDIF
                     B3=ZOB-Z1
                     D3=D3+B3*G3
                  ENDDO
               ENDDO
            ENDDO
         ENDDO
         IF (L==1) THEN
            EXX=D1
            EXY=D2
            EXZ=D3
         ELSE
            EXX=EXX-D1
            EXY=EXY-D2
            EXZ=EXZ-D3
         ENDIF
!
      ENDDO
!
      DO L=1,3,2
!
         D1=(.0,.0)
         D2=(.0,.0)
         D3=(.0,.0)
         Y1=YSR-(FLOAT(L)-2.)*CLY*.5
!
!-- Note that the coordinates in the y-direction are fixed
!   and cells are divided only in the x and z directions
!
         DO ISUB=1,MSX
            IF (MSX==1) THEN
               XSRS=XSR
            ELSE
               XSRS=XSR+CLXS*(ISUB-1)-CLX/2.+.5*CLXS
            ENDIF
            DO KSUB=1,MSZ
               IF (MSZ==1) THEN
                  ZSRS=ZSR
               ELSE
                  ZSRS=ZSR+CLZS*(KSUB-1)-CLZ/2.+.5*CLZS
               ENDIF
!
!-- Determine the distance of the subcell surface over which the
!   integration is to be done to the receiver point with
!   respect to the dimension of the subcell surface.
!
               DIST=SQRT((RR(XOB,YOB,XSRS,Y1))**2+(ZOB-ZSRS)**2)
               CLNGTH=SQRT(CLXS**2+CLZS**2)
!
!-- Determine the numbers of steps according to the distance
!   between the source and the receiver
!
               IF (DIST<=1.*CLNGTH) THEN
                  MX=MCX*3/2
                  MZ=MCZ*3/2
               ELSEIF (DIST<=3.*CLNGTH) THEN
                  MX=MCX
                  MZ=MCZ
               ELSE
                  CLDST=SQRT(2.*CLNGTH/DIST)
                  MX=INT(FLOAT(MCX)*CLDST)
                  MZ=INT(FLOAT(MCZ)*CLDST)
               ENDIF
!
               IF (MX<1) MX=1
               IF (MZ<1) MZ=1
!
               IF (MX==3) MX=2
               IF (MZ==3) MZ=2
!
               IF (MX>1) CMX=MX-1.
               IF (MZ>1) CMZ=MZ-1.
!
               DO II=1,MX
                  IF (MX==1) THEN
                     X1=XSRS
                     CY=1.
                  ELSEIF (MX==2) THEN
                     X1=XSRS+2.*(II-1.5)*T2
                     CX=.5
                  ELSE
                     X1=XSRS-.5*CLXS+CLXS/CMX*(II-1.)
                     CX=1./CMX
                     IF (II==1.OR.II==MX) CX=.5*CX
                  ENDIF
                  DO JJ=1,MZ
                     IF (MZ==1) THEN
                        Z1=ZSRS
                        CZ=1.
                     ELSEIF (MZ==2) THEN
                        Z1=ZSRS+2.*(JJ-1.5)*T4
                        CZ=.5
                     ELSE
                        Z1=ZSRS-.5*CLZS+CLZS/CMZ*(JJ-1.)
                        CZ=1./CMZ
                        IF (JJ==1.OR.JJ==MZ) CZ=.5*CZ
                     ENDIF
                     C1=C2*CX*CZ*CLXS*CLZS
!
                     R1=R(XOB,YOB,ZOB,X1,Y1,Z1)
!
                     CG=K*R1
                     G3=C1*((1.,0.)+CG)*CEXP(-CG)/R1/R1/R1
                     B1=XOB-X1
                     D1=D1+B1*G3
                     B2=YOB-Y1
                     D2=D2+B2*G3
                     IF (ABS(HVK-1.)>=.0001) THEN
                        RA=RK(XOB,YOB,ZOB,X1,Y1,Z1)/HVK
                        CG=K*RA
                        G4=C1*((1.,0.)+CG)*CEXP(-CG)/RA/RA/RA
                        RR1=RR(XOB,YOB,X1,Y1)
! ----  The limit values of the anisotropic terms for rho = 0
!     have yet to be strictly determined. Here they are assumed
!     to be zero for simplicity.
                        IF (RR1>=DMIN) THEN
                           G1=C1*CEXP(-K*R1)/R1
                           G2=C1*CEXP(-K*RA)/RA
                           B3=ZOB-Z1
                           CG=(G2-G1+B3**2*(G3-G4))/RR1**2
                           D1=D1+B1*CG
                           D2=D2+B2*CG
                        ENDIF
                        G3=G4
                     ENDIF
                     B3=ZOB-Z1
                     D3=D3+B3*G3
                  ENDDO
               ENDDO
            ENDDO
         ENDDO
         IF (L==1) THEN
            EYX=D1
            EYY=D2
            EYZ=D3
         ELSE
            EYX=EYX-D1
            EYY=EYY-D2
            EYZ=EYZ-D3
         ENDIF
!
      ENDDO
!
      DO L=1,3,2
         D1=(.0,.0)
         D2=(.0,.0)
         D3=(.0,.0)
         Z1=ZSR-(FLOAT(L)-2.)*CLZ*.5
!
!-- Note that the coordinates in the z-direction are fixed
!   and cells are divided only in the x and y directions
!
         DO ISUB=1,MSX
            IF (MSX==1) THEN
               XSRS=XSR
            ELSE
               XSRS=XSR+CLXS*(ISUB-1)-CLX/2.+.5*CLXS
            ENDIF
            DO JSUB=1,MSY
               IF (MSY==1) THEN
                  YSRS=YSR
               ELSE
                  YSRS=YSR+CLYS*(JSUB-1)-CLY/2.+.5*CLYS
               ENDIF
!
!-- Determine the distance of the subcell surface over which the
!   integration is to be done to the receiver point with
!   respect to the dimension of the subcell surface.
!
               DIST=SQRT((RR(XOB,YOB,XSRS,YSRS))**2+(ZOB-Z1)**2)
               CLNGTH=SQRT(CLXS**2+CLYS**2)
!
!-- Determine the numbers of steps according to the distance
!   between the source and the receiver
!
               IF (DIST<=1.*CLNGTH) THEN
                  MX=MCX*3/2
                  MY=MCY*3/2
               ELSEIF (DIST<=3.*CLNGTH) THEN
                  MX=MCX
                  MY=MCY
               ELSE
                  CLDST=SQRT(2.*CLNGTH/DIST)
                  MX=INT(FLOAT(MCX)*CLDST)
                  MY=INT(FLOAT(MCY)*CLDST)
               ENDIF
!
               IF (MX<1) MX=1
               IF (MY<1) MY=1
!
               IF (MX==3) MX=2
               IF (MY==3) MY=2
!
               IF (MX>1) CMX=MX-1.
               IF (MY>1) CMY=MY-1.
!
               DO II=1,MX
                  IF (MX==1) THEN
                     X1=XSRS
                     CX=1.
                  ELSEIF (MX==2) THEN
                     X1=XSRS+2.*(II-1.5)*T2
                     CX=.5
                  ELSE
                     X1=XSRS-.5*CLXS+CLXS/CMX*(II-1.)
                     CX=1./CMX
                     IF (II==1.OR.II==MX) CX=.5*CX
                  ENDIF
                  DO JJ=1,MY
                     IF (MY==1) THEN
                        Y1=YSRS
                        CY=1.
                     ELSEIF (MY==2) THEN
                        Y1=YSRS+2.*(JJ-1.5)*T3
                        CY=.5
                     ELSE
                        Y1=YSRS-.5*CLYS+CLYS/CMY*(JJ-1.)
                        CY=1./CMY
                        IF (JJ==1.OR.JJ==MY) CY=.5*CY
                     ENDIF
                     C1=C2*CX*CY*CLXS*CLYS
!
                     R1=R(XOB,YOB,ZOB,X1,Y1,Z1)
!
                     CG=K*R1
                     G3=C1*((1.,0.)+CG)*CEXP(-CG)/R1/R1/R1
                     B1=XOB-X1
                     D1=D1+B1*G3
                     B2=YOB-Y1
                     D2=D2+B2*G3
                     IF (ABS(HVK-1.)>=.0001) THEN
                        RA=RK(XOB,YOB,ZOB,X1,Y1,Z1)/HVK
                        CG=K*RA
                        G4=C1*((1.,0.)+CG)*CEXP(-CG)/RA/RA/RA
                        RR1=RR(XOB,YOB,X1,Y1)
! ---- The limit values of the anisotropic terms for rho = 0
!    have yet to be strictly determined. Here they are assumed
!    to be zero for simplicity.
                        IF (RR1>=DMIN) THEN
                           G1=C1*CEXP(-K*R1)/R1
                           G2=C1*CEXP(-K*RA)/RA
                           B3=ZOB-Z1
                           CG=(G2-G1+B3**2*(G3-G4))/RR1**2
                           D1=D1+B1*CG
                           D2=D2+B2*CG
                        ENDIF
                        G3=G4
                     ENDIF
                     B3=ZOB-Z1
                     D3=D3+B3*G3
                  ENDDO
               ENDDO
            ENDDO
         ENDDO
         IF (L==1) THEN
            EZX=D1
            EZY=D2
            EZZ=D3
         ELSE
            EZX=EZX-D1
            EZY=EZY-D2
            EZZ=EZZ-D3
         ENDIF
!
      ENDDO
!
      EXX=EXX+GX
      EYY=EYY+GY
      EZX=EZX+GZX
      EZY=EZY+GZY
      EZZ=EZZ+GZ
!
! ----- Store the values for a self cell upon computation
!
      IF (KSELF==1.AND.RS<DMIN) THEN
         EXX1=EXX
         EYX1=EYX
         EZX1=EZX
         EXY1=EXY
         EYY1=EYY
         EZY1=EZY
         EXZ1=EXZ
         EYZ1=EYZ
         EZZ1=EZZ
         GAX1=GAX
      ENDIF
!
! --- Assign the componenets to the arrays ECOMP and HCOMP
!   for data passing
!
!**** Entry point for goto 500
!
  100 ECOMP(1)=EXX
      ECOMP(2)=EYX
      ECOMP(3)=EZX
      ECOMP(4)=EXY
      ECOMP(5)=EYY
      ECOMP(6)=EZY
      ECOMP(7)=EXZ
      ECOMP(8)=EYZ
      ECOMP(9)=EZZ
!
      RETURN
      END
!
!**** End of THR_D_GEPRM
!
!
      SUBROUTINE THR_D_GASELF(CLX,CLY,CLZ,MXINT,MYINT,MZINT,   &
                              CDH,HVK,K,DMIN,GX,GZ)
!
!****  Integration of the current term for a self-cell
!
!   The prism cell is divided into 27 subcells with the one
!   in the center being a cube for the approximation by a sphere.
!   Of the 27 subcells either 18 or 24 have zero size.
!
!
! Input parameters:
!
!   CLX:    Real,  dimension of the cell in the x-direction.
!   CLY:    Real,  dimension of the cell in the y-direction.
!   CLZ:    Real,  dimension of the cell in the z-direction.
!   MXINT:  Integer,  number of steps in the x-direction.
!   MYINT:  Integer,  number of steps in the y-direction.
!   MZINT:  Integer,  number of steps in the z-direction.
!   CDH:    Complex CDH(0:MLAYER),  complex conductivities of
!           the layers including the air (layer 0).
!   HVK:    Real HVK(0:MLAYER),  the coefficients of anisotropy of the layers
!           including the air (layer 0 with HVK(0)=1).  The anisotropy
!           coefficients are defined as the square roots of the ratios of
!           horizontal conductivities to vertical conductivities of each
!           layer.  Elements of HVK are always equal to or larger than 1.
!   K:      Complex,  wave number of the layer which is considered as
!           a whole space for primary parts.
!   DMIN:   Real,  minmum of dimension for numerical treatments of cells.
!           DMIN=0.1 for the low frequency mdule and DMIN=0.001 for the
!           high frequency module.
!
! Output parameters:
!
!   GX:     Complex, the x- (and y-) component of the primay current
!           term due to the selff-cell.
!   GZ:     Complex, the z- component of the primay current term due
!           to the selff-cell.  It differs from GX if the medium is
!           anisotropic.
!
!
!**** Called by:  THR_D_GEPRM
!
!**** Calls:      THR_D_G12
!
!
      IMPLICIT NONE
!
      REAL CLX,CLY,CLZ,CMX,CMY,CMZ,CX,CY,CZ,HVK,R,R1,RA,RK,SL,X1,XI,XR,   &
           Y1,YI,YR,Z1,ZI,ZR
      INTEGER I,II,J,JJ,L,LL,MX,MXINT,MY,MYINT,MZ,MZINT
      COMPLEX GX,GZ,G1,G2,K,CDH,C1,C2
      REAL  DMIN,X(3),Y(3),Z(3),XL(3),YL(3),ZL(3)
!
      R(XR,YR,ZR,XI,YI,ZI)=SQRT((XR-XI)**2+(YR-YI)**2+(ZR-ZI)**2)
      RK(XR,YR,ZR,XI,YI,ZI)=SQRT((XR-XI)**2+(YR-YI)**2+(HVK*(ZR-ZI))**2)
!
      SL=AMIN1(CLX,CLY,CLZ)
      XL(1)=(CLX-SL)/2.
      XL(2)=SL
      XL(3)=(CLX-SL)/2.
      YL(1)=(CLY-SL)/2.
      YL(2)=SL
      YL(3)=(CLY-SL)/2.
      ZL(1)=(CLZ-SL)/2.
      ZL(2)=SL
      ZL(3)=(CLZ-SL)/2.
      X(1)=-(SL/2.+XL(1)/2.)
      X(2)=0.
      X(3)=(SL/2.+XL(3)/2.)
      Y(1)=-(SL/2.+YL(1)/2.)
      Y(2)=0.
      Y(3)=(SL/2.+YL(3)/2.)
      Z(1)=-(SL/2.+ZL(1)/2.)
      Z(2)=0.
      Z(3)=(SL/2.+ZL(3)/2.)
!
      GX=(.0,.0)
      GZ=(.0,.0)
!
      DO I=1,3
         DO J=1,3
            DO L=1,3
!
!**** Skip the center cell and cells with a zero dimension
!
               IF (.NOT.(I==2.AND.J==2.AND.L==2.OR.ABS(XL(I))<=DMIN.OR.  &
                   ABS(YL(J))<=DMIN.OR.ABS(ZL(L))<=DMIN)) THEN
!
                  C2=-K**2/CDH*XL(I)*YL(J)*ZL(L)
!
                  MX=INT(FLOAT(MXINT)*(XL(I)/CLX))
                  IF (MX<1) MX=1
                  MY=INT(FLOAT(MYINT)*(YL(J)/CLY))
                  IF (MY<1) MY=1
                  MZ=INT(FLOAT(MZINT)*(ZL(L)/CLZ))
                  IF (MZ<1) MZ=1
!
                  IF (MX>1) THEN
                     CMX=MX-1.
                  ELSE
                     CMX=1.
                  ENDIF
                  IF (MY>1) THEN
                     CMY=MY-1.
                  ELSE
                     CMY=1.
                  ENDIF
                  IF (MZ>1) THEN
                     CMZ=MZ-1.
                  ELSE
                     CMZ=1.
                  ENDIF
!
                  DO II=1,MX
                     X1=X(I)-.5*XL(I)+XL(I)/CMX*(II-1.)
                     IF (MX>1) CX=1./CMX
                     IF (II==1.OR.II==MX) CX=.5*CX
                     IF (MX==1) CX=1.
                     DO JJ=1,MY
                        Y1=Y(J)-.5*YL(J)+YL(J)/CMY*(JJ-1.)
                        IF (MY>1) CY=1./CMY
                        IF (JJ==1.OR.JJ==MY) CY=.5*CY
                        IF (MY==1) CY=1.
                        DO LL=1,MZ
                           Z1=Z(L)-.5*ZL(L)+ZL(L)/CMZ*(LL-1.)
                           IF (MZ>1) CZ=1./CMZ
                           IF (LL==1.OR.LL==MZ) CZ=.5*CZ
                           IF (MZ==1) CZ=1.
                           C1=C2*CX*CY*CZ
!
                           R1=R(0.,0.,0.,X1,Y1,Z1)
                           G1=.0795774771*CEXP(-K*R1)/R1
                           GX=GX+G1*C1
                           IF (ABS(HVK-1.)>.0001) THEN
                              RA=RK(0.,0.,0.,X1,Y1,Z1)
                              G2=.0795774771*HVK*CEXP(-K*RA/HVK)/RA
                              GZ=GZ+G2*C1
                           ENDIF
!
                        ENDDO
                     ENDDO
                  ENDDO
               ENDIF
!
            ENDDO
         ENDDO
      ENDDO
      IF (ABS(HVK-1.)<=.0001) GZ=GX
      CALL THR_D_G12(SL,SL,SL,CDH,HVK,K,G1,G2)
      GX=GX+G1
      GZ=GZ+G2
!
      RETURN
      END
!
!**** End of THR_D_GASELF
!
!
      SUBROUTINE THR_D_G12(CLX,CLY,CLZ,CDH,HVK,K,G1,G2)
!
!**** Approximate the volumn integration of the primary current term
!   due to a self-cell by the analytical solution for a sphere.
!
!
! Input parameters:
!
!   CLX:    Real,  dimension of the cell in the x-direction.
!   CLY:    Real,  dimension of the cell in the y-direction.
!   CLZ:    Real,  dimension of the cell in the z-direction.
!   CDH:    Complex CDH(0:MLAYER),  complex conductivities of
!           the layers including the air (layer 0).
!   HVK:    Real HVK(0:MLAYER),  the coefficients of anisotropy of the layers
!           including the air (layer 0 with HVK(0)=1).  The anisotropy
!           coefficients are defined as the square roots of the ratios of
!           horizontal conductivities to vertical conductivities of each
!           layer.  Elements of HVK are always equal to or larger than 1.
!   K:      Complex,  wave number of the layer which is considered as
!           a whole space for primary parts.
!
! Output parameters:
!
!   G1:     Complex, the x- (and y-) component of the primay current
!           term due to the selff-cell approximated by a sphere.
!   G2:     Complex, the z- component of the primay current term due
!           to the selff-cell approximated by a sphere.  It differs
!           from GX if the medium is anisotropic.
!
!
!**** Called by:  THR_D_GASELF
!
!**** Calls:      None
!
!
      IMPLICIT NONE
!
      REAL AV,AVK,CLX,CLY,CLZ,HVK,VOLUME
      COMPLEX G1,G2,K,CDH
      VOLUME=CLX*CLY*CLZ
      AV=.6207505*VOLUME**.33333333
      AVK=AV*HVK**.33333333
      G1=(CEXP(-K*AV)*(K*AV+(1.,0.))-(1.,0.))/CDH
      IF (ABS(HVK-1.)<.0001) THEN
         G2=G1
      ELSE
         G2=HVK*HVK*(CEXP(-K*AVK/HVK)*(K*AVK/HVK+(1.,0.))-(1.,0.))/CDH
      ENDIF
!
      RETURN
      END
!
!**** End of THR_D_G12
!
!
      SUBROUTINE THR_D_GHPRM(PSTION,KACC,BLMIN,CLREF,MXINT,MYINT,MZINT,   &
                             CLX,CLY,CLZ,FRQ,CDH,HVK,DMIN,HCOMP)
!
!****  Primary parts of the magnetic Green's function
!
!    Fields are integrated in a prismatic cell using the multistep
!    trapezoidal rules.
!
!
! Input parameters:
!
!   KACC:   Integer,  accuracy level of computation.  KACC=1, 2
!           3, 4, or 5.  KACC controls the accuracy of the
!           numerical integration of the Green's functions
!           with increasing number of steps as KACC increases.
!           The higher the level,  the more accurate at the
!           cost of computation time.  A 2 or 3 is usually
!           adequate.  For high contrast models us 3 or 4.
!           KACC=5 should be used only for serious convergence
!           tests purpose.  See documentation "MARCO.DOC" for
!           more details.
!   BLMIN:  Real,  redius and height of a cylinder to be removed
!           from computation for the treatment of singularity
!           arising in the computation of magnetic fields due to
!           an outcropping cell.  See description for KUTCRP
!           in the following for more details.
!   CLREF:  Real,  minimal dimension of the cell in consideration.
!           In routine THR_D_GREEN it is used as the reference
!           dimension for which the number of steps for numerical
!           integration is defined.  Actual number of steps in each
!           dimension depends on the ratio of that dimension to
!           CLREF.  Here and in the computation of the secondary
!           parts of the Green's tensors in routine THR_D_GREEN
!           CLREF is used as a reference to further dividing a
!           cell into subcells for more efficient and accurate
!           treatments of the numerical integrations.
!   MXINT:  Integer,  number of steps in the x-direction.
!   MYINT:  Integer,  number of steps in the y-direction.
!   MZINT:  Integer,  number of steps in the z-direction.
!   CLX:    Real,  dimension of the cell in the x-direction.
!   CLY:    Real,  dimension of the cell in the y-direction.
!   CLZ:    Real,  dimension of the cell in the z-direction.
!   FRQ:    Real(*4), frequency.
!   CDH:    Complex CDH(0:MLAYER),  complex conductivities of
!           the layers including the air (layer 0).
!   HVK:    Real HVK(0:MLAYER),  coefficients of anisotropy of the layers
!           including the air (layer 0 with HVK(0)=1).  The anisotropy
!           coefficients are defined as the square roots of the ratios of
!           horizontal conductivities to vertical conductivities of each
!           layer.  Elements of HVK are always equal to or larger than 1.
!   DMIN:   Real,  minmum of dimension for numerical treatments of cells.
!           DMIN=0.1 for the low frequency mdule and DMIN=0.001 for the
!           high frequency module.
!
! Output parameters:
!
!   HCOMP:  Complex HCOMP(9),  the nine components of the electric
!           field tensor,  Hxx, Hyx, Hzx, Hxy, ..., and Hzz.  Note that
!           in parameters Hxy etc. the first index "x" denotes the
!           direction of the field and the second index "y" denotes
!           the direction of the source.
!
!Remarks:
!
!    This routine is mainly used for eliminating the singularities
!    in the numnerical integrations of the magnetic Green's functions.
!
!    Tests have shown that this routine is not accurate in treating
!    the sigularty in sea water environments.  There could be still
!    hidden error in the code.   This routine will never be called
!    due to the changes made lately in the routines THR_D_GREEN and
!    gridhf on the parameter kghp.
!    (***!!! may need double precisions !!!***)
!
!
      IMPLICIT NONE
!
      REAL BLMIN,C1,C2,C3,CC,CLDST,CLNGTH,CLXS,CLYS,CLZS,CMX,CMY,CMZ,CX,  &
           CY,CZ,DIST,HVK,R,R1,RA,RHO,RK,RR,SCL,X1,XI,XR,XSRS,Y1,YI,YR,   &
           YSRS,Z1,ZI,ZR,ZSRS
      INTEGER I,ISUB,J,J3,JSUB,KACC,KINT,KSUB,MCX,MCY,MCZ,MM1,MM2,MM3,    &
              MSX,MSY,MSZ,MX,MXINT,MY,MYINT,MZ,MZINT
      REAL  DMIN,XOB,YOB,ZOB,XSR,YSR,ZSR,PSTION(6),                       &
            CLX,CLY,CLZ,FRQ,CLREF,XX(6),YY(6),ZZ(6)
      COMPLEX CDH,K,EKR,EKRA,E1,E2,HCOMP(9),                &
              HXX,HYX,HZX,HXY,HYY,HZY,HXZ,HYZ,HZZ
!
      R(XR,YR,ZR,XI,YI,ZI)=SQRT((XR-XI)**2+(YR-YI)**2+(ZR-ZI)**2)
      RK(XR,YR,ZR,XI,YI,ZI)=SQRT((XR-XI)**2+(YR-YI)**2+(HVK*(ZR-ZI))**2)
      RR(XR,YR,XI,YI)=SQRT((XR-XI)**2+(YR-YI)**2)
!
! --- Extract parameter values for XOB etc. from PSTION
!
      XOB=PSTION(1)
      YOB=PSTION(2)
      ZOB=PSTION(3)
      XSR=PSTION(4)
      YSR=PSTION(5)
      ZSR=PSTION(6)
!
      CC=1./4./3.1415926*CLX*CLY*CLZ
      K=CSQRT(CMPLX(.0,78.9568352E-7*FRQ)*CDH)
      HXX=(0.,0.)
      HYX=(0.,0.)
      HZX=(0.,0.)
      HXY=(0.,0.)
!    HYY=(0.,0.)
      HZY=(0.,0.)
      HXZ=(0.,0.)
      HYZ=(0.,0.)
!
! ---- Divide the cell into subcells
!
!    Every subcell has a length of either 2*CLREF or 3*CLREF
!    in either direction, according to kacc.   For higher
!    kacc it is more efficient to have smaller subcell size.
!    But small subcell may increase waste for low kacc.
!
      IF (KACC<=3) THEN
         SCL=3.*CLREF
      ELSE
         SCL=2.*CLREF
      ENDIF
      MSX=INT(CLX/SCL)
      MSY=INT(CLY/SCL)
      MSZ=INT(CLZ/SCL)
      IF (MSX<1) MSX=1
      IF (MSY<1) MSY=1
      IF (MSZ<1) MSZ=1
      MCX=MXINT/MSX
      MCY=MYINT/MSY
      MCZ=MZINT/MSZ
      CLXS=CLX/MSX
      CLYS=CLY/MSY
      CLZS=CLZ/MSZ
!
!--- The magnetic Green's functions are more smooth than the
!    charge terms of the electric Green's function.
!    Hence the knots for numerical integration can be reduced
!
      MCX=MCX*2/3
      MCY=MCY*2/3
      MCZ=MCZ*2/3
!
      DO ISUB=1,MSX
         IF (MSX==1) THEN
            XSRS=XSR
         ELSE
            XSRS=XSR+CLXS*(ISUB-1)-CLX/2.+.5*CLXS
         ENDIF
         DO JSUB=1,MSY
            IF (MSY==1) THEN
               YSRS=YSR
            ELSE
               YSRS=YSR+CLYS*(JSUB-1)-CLY/2.+.5*CLYS
            ENDIF
            DO KSUB=1,MSZ
               IF (MSZ==1) THEN
                  ZSRS=ZSR
               ELSE
                  ZSRS=ZSR+CLZS*(KSUB-1)-CLZ/2.+.5*CLZS
               ENDIF
!
!-- Determine the distance of the subcell to the receiver point
!   with respect to the dimension of the subcell.
!
               DIST=SQRT((RR(XOB,YOB,XSRS,YSRS))**2+(ZOB-ZSRS)**2)
               CLNGTH=SQRT(CLXS**2+CLYS**2+CLZS**2)
!
!-- Determine the numbers of steps according to the distance
!   between the source and the receiver
!
!   See the comments on the choices of step numbers in the
!   routine THR_D_GREEN.
!
               IF (DIST<=1.*CLNGTH) THEN
                  MX=MCX*3/2
                  MY=MCY*3/2
                  MZ=MCZ*3/2
               ELSEIF (DIST<=3.*CLNGTH) THEN
                  MX=MCX
                  MY=MCY
                  MZ=MCZ
               ELSE
                  CLDST=SQRT(2.*CLNGTH/DIST)
                  MX=INT(FLOAT(MCX)*CLDST)
                  MY=INT(FLOAT(MCY)*CLDST)
                  MZ=INT(FLOAT(MCZ)*CLDST)
               ENDIF
!
               IF (MX<1) MX=1
               IF (MY<1) MY=1
               IF (MZ<1) MZ=1
               IF (MX>1) CMX=MX-1.
               IF (MY>1) CMY=MY-1.
               IF (MZ>1) CMZ=MZ-1.
!
!   Step numbers less than or equal to 3 in either dimension
!   may not be more accuarate than the 6-point approach
!
               IF (MX<=3.AND.MY<=3.AND.MZ<=3.AND.MX>1.AND.MY>1.AND.MZ>1)  &
                   THEN
                  KINT=1
                  CALL THR_D_VXYZ(CLXS,CLYS,CLZS,XSRS,YSRS,ZSRS,XX,YY,ZZ)
                  MM1=1
                  MM2=1
                  MM3=6
               ELSE
                  KINT=2
                  MM1=MX
                  MM2=MY
                  MM3=MZ
               ENDIF
!
               DO I=1,MM1
                  IF (KINT==2.AND.MM1==1) THEN
                     X1=XSRS
                     CX=1.
                  ENDIF
                  IF (KINT==2.AND.MM1/=1) THEN
                     X1=XSRS-.5*CLXS+CLXS/CMX*(I-1.)
                     CX=1./CMX
                     IF (I==1.OR.I==MX) CX=.5*CX
                  ENDIF
                  DO J=1,MM2
                     IF (KINT==2.AND.MM2==1) THEN
                        Y1=YSRS
                        CY=1.
                     ENDIF
                     IF (KINT==2.AND.MM2/=1) THEN
                        Y1=YSRS-.5*CLYS+CLYS/CMY*(J-1.)
                        CY=1./CMY
                        IF (J==1.OR.J==MY) CY=.5*CY
                     ENDIF
                     DO J3=1,MM3
                        IF (KINT==2.AND.MM3==1) THEN
                           Z1=ZSRS
                           CZ=1.
                        ELSEIF (KINT==2.AND.MM3/=1) THEN
                           Z1=ZSRS-.5*CLZS+CLZS/CMZ*(J3-1.)
                           CZ=1./CMZ
                           IF (J3==1.OR.J3==MZ) CZ=.5*CZ
                        ELSE
                           X1=XX(J3)
                           Y1=YY(J3)
                           Z1=ZZ(J3)
                        ENDIF
!
                        IF (KINT==1) THEN
                           C1=CC/6.
                        ELSE
                           C1=CC*CX*CY*CZ
                        ENDIF
!
                        R1=R(XOB,YOB,ZOB,X1,Y1,Z1)
!
! ----- In order to avoid numerical inaccuracy at the earth's surface
!     in dealing with a outcropping structure or for receivers
!     located within a structure,  singularities are
!     simply omitted if the receiver is very close to the cell
!     in integration.
!
                        IF (R1>=BLMIN) THEN
!
                           RHO=RR(XOB,YOB,X1,Y1)
!
! ----- If Rho < DMIN it should be assumed to be zero for the sake
!     of numerical accuracy.
!
                           IF (RHO>=DMIN) THEN
!
                              IF (ABS(HVK-1.)>=.0001) THEN
                              RA=RK(XOB,YOB,ZOB,X1,Y1,Z1)
                              ELSE
                              RA=R1
                              ENDIF
                              EKR=CEXP(-K*R1)
                              IF (ABS(HVK-1.)>=.0001) THEN
                              EKRA=CEXP(-K/HVK*RA)
                              ELSE
                              EKRA=EKR
                              ENDIF
                              C2=C1*(XOB-X1)*(ZOB-Z1)*(YOB-Y1)/RHO**4
                              E1=EKR*((1.,0.)+K*R1)/R1**3
                              IF (ABS(HVK-1.)>=.0001) THEN
                              E2=EKRA*(CMPLX(HVK,0.)+K*RA)/RA**3
                              ELSE
                              E2=E1
                              ENDIF
                              HXX=HXX+  &
                                 C2*(2.*(-EKR/R1+HVK*EKRA/RA)-RHO**2*  &
                                 (E1-E2))
                              C2=C1*(ZOB-Z1)  &
                                 /RHO**2*(1.-2.*((XOB-X1)/RHO)**2)
                              C3=C1*(XOB-X1)**2*(ZOB-Z1)/RHO**2
                              HYX=HYX-C1*(ZOB-Z1)  &
                                 *E1-C2*(EKR/R1-HVK*EKRA/RA)+C3*(E1-E2)
                              HZX=HZX+C1*(YOB-Y1)*E1
                              C2=C1*(ZOB-Z1)  &
                                 /RHO**2*(1.-2.*((YOB-Y1)/RHO)**2)
                              C3=C1*(YOB-Y1)**2*(ZOB-Z1)/RHO**2
                              HXY=HXY+C1*(ZOB-Z1)  &
                                 *E1+C2*(EKR/R1-HVK*EKRA/RA)-C3*(E1-E2)
                              HZY=HZY-C1*(XOB-X1)*E1
                              HXZ=HXZ-C1*(YOB-Y1)*E2
                              HYZ=HYZ+C1*(XOB-X1)*E2
!
                           ELSE
!
                              E1=-C1/2.*(1.+1./HVK**2)  &
                                 *CEXP(-K*ABS(ZOB-Z1))/(ZOB-Z1)  &
                                 *(K+CMPLX(1./ABS(ZOB-Z1),0.))
                              HYX=HYX+E1
                              HXY=HXY-E1
!
                           ENDIF
                        ENDIF
!
                     ENDDO
                  ENDDO
               ENDDO
            ENDDO
         ENDDO
      ENDDO
      HYY=-HXX
      HZZ=(0.,0.)
!
! --- Assign the componenets to the arrays ECOMP and HCOMP
!   for data passing
!
      HCOMP(1)=HXX
      HCOMP(2)=HYX
      HCOMP(3)=HZX
      HCOMP(4)=HXY
      HCOMP(5)=HYY
      HCOMP(6)=HZY
      HCOMP(7)=HXZ
      HCOMP(8)=HYZ
      HCOMP(9)=HZZ
!
      RETURN
      END
!
!**** End of THR_D_GHPRM
!
!
      SUBROUTINE SCAT_EH_MT(NBMAX,NMAX,NXMAX,NYMAX,NZMAX,NBODY,SUB_BLOCK,   &
                            MT_PROFL,MT_STATN,XRMT,YRMT,NX,NY,NZ,NCELL,X,Y, &
                            Z,CLX,CLY,CLZ,JS,NPOL,KSFT,NSUBCM,CDB,CLMN,ZMT, &
                            E0X1,E0Y1,EXMT,EYMT,HXMT,HYMT,HZMT,FRQ,MLAYER,  &
                            ZBND,CDH,HVK,NZOB,ZOBG,NZSR,ZSRG,RHOMIN,DMIN,   &
                            NHFILM,RRG,NRG,GRHF,RRG3,NRG3,GRHF3,GRHO0,      &
                            GRHO03,KCLMN,BLMIN,KACC)
!
!**** Calculate scattered fields at receiver sites
!
!   Note if the receiver is located just on the top of  a block,
!   the electric field is calculated by the scattering current
!   directly
!
!   The array clmn should have the size of mbody. Since mbody
!   may be changed in the main program, here it is defined as 30.
!
      IMPLICIT NONE
!
      REAL BLMIN,CLMN2,CLX1,CLY1,CLZ1,DMIN,FRQ,RHOMIN,ZMT
      INTEGER I,IB,IX,IY,J,K,KACC,KCLMN,KEYG,KPOL,KSELF,KSFT,KUTCRP,L,     &
              LP1,LP2,MLAYER,N1
      INTEGER N2,NBMAX,NBODY,NCT,NHFILM,NJ,NJS,NMAX,NN,NN1,MT_PROFL,NPOL,  &
              MT_STATN,NRG,NRG3,NSUBCM,NXMAX,NYMAX,NZMAX,NZOB
      INTEGER NZSR
!
      COMPLEX JS(NMAX,NBODY),EX,EY,EZ,HX,HY,HZ,E0X,E0Y,E0X1,E0Y1,          &
              EXX,EYX,EZX,EXY,EYY,EZY,EXZ,EYZ,EZZ,                         &
              HXX,HYX,HZX,HXY,HYY,HZY,HXZ,HYZ,HZZ,                         &
              EXMT(MT_PROFL,MT_STATN,2),EYMT(MT_PROFL,MT_STATN,2),         &
              HXMT(MT_PROFL,MT_STATN,2),HYMT(MT_PROFL,MT_STATN,2),         &
              HZMT(MT_PROFL,MT_STATN,2),CDH(0:MLAYER),                     &
              CDB(NSUBCM,NBMAX,NBODY),GRHF(11,NHFILM,NZSR,NZOB),           &
              GRHO0(4,NZSR,NZOB),GRHF3(11,NHFILM,NZSR),GRHO03(4,NZSR)
      INTEGER NX(NBMAX,NBODY),NY(NBMAX,NBODY),NZ(NBMAX,NBODY),             &
              NCELL(NBMAX,NBODY),SUB_BLOCK(NBODY)
      REAL  X(NXMAX,NBMAX,NBODY),Y(NYMAX,NBMAX,NBODY),                     &
            Z(NZMAX,NBMAX,NBODY),CLMN(NBODY),                              &
            CLX(NBMAX,NBODY),CLY(NBMAX,NBODY),CLZ(NBMAX,NBODY),            &
            XRMT(MT_PROFL),YRMT(MT_STATN),                                 &
            ZBND(0:MLAYER),HVK(0:MLAYER),                                  &
            ZOBG(NZOB),ZSRG(2,NZSR),                                       &
            RRG(NRG),RRG3(NRG3),PSTION(6)
      COMPLEX ECOMP(9),HCOMP(9)
      EQUIVALENCE (ECOMP(1),EXX),(ECOMP(2),EYX),(ECOMP(3),EZX),   &
                  (ECOMP(4),EXY),(ECOMP(5),EYY),(ECOMP(6),EZY),   &
                  (ECOMP(7),EXZ),(ECOMP(8),EYZ),(ECOMP(9),EZZ),   &
                  (HCOMP(1),HXX),(HCOMP(2),HYX),(HCOMP(3),HZX),   &
                  (HCOMP(4),HXY),(HCOMP(5),HYY),(HCOMP(6),HZY),   &
                  (HCOMP(7),HXZ),(HCOMP(8),HYZ),(HCOMP(9),HZZ)
!
      KSELF=0
      KEYG=2
!
      IF (NPOL==0.OR.NPOL==1) THEN
         LP1=1+NPOL
         LP2=1+NPOL
      ELSEIF (NPOL==2) THEN
         LP1=1
         LP2=2
      ENDIF
!
      DO KPOL=LP1,LP2
!
! --- Read js per polarization
!
         IF (NPOL==2) THEN
            DO IB=1,NBODY
               NCT=0
               DO I=1,SUB_BLOCK(IB)
                  NCT=NCT+NCELL(I,IB)
               ENDDO
               READ (20) (JS(J,IB),J=1,3*NCT)
            ENDDO
         ENDIF
!
         IF (KSFT/=0.OR.ZMT>=.1) THEN
            IF (KPOL==1) THEN
               E0X=(0.,0.)
               E0Y=E0Y1
            ELSE
               E0X=E0X1
               E0Y=(0.,0.)
            ENDIF
         ENDIF
!
         DO IY=1,MT_STATN
            DO IX=1,MT_PROFL
!
               EX=(0.,0.)
               EY=(0.,0.)
               EZ=(0.,0.)
               HX=(0.,0.)
               HY=(0.,0.)
               HZ=(0.,0.)
!
               IF (KSFT==0.AND.ZMT<.1) THEN
                  KUTCRP=0
                  GOTO 10
               ENDIF
!
               KUTCRP=0
               DO IB=1,NBODY
                  NJ=0
                  DO L=1,SUB_BLOCK(IB)
                     IF (L>1) NJ=NJ+3*NCELL(L-1,IB)
                     DO I=1,NX(L,IB)
                        DO J=1,NY(L,IB)
                           DO K=1,NZ(L,IB)
                              IF (XRMT(IX)>=X(I,L,IB)-.5*CLX(L,IB)        &
                                 -.1.AND.XRMT(IX)<X(I,L,IB)+.5*CLX(L,IB)  &
                                 +.1.AND.YRMT(IY)>=Y(J,L,IB)              &
                                 -.5*CLY(L,IB)-.1.AND.YRMT(IY)<Y(J,L,IB)  &
                                 +.5*CLY(L,IB)+.1.AND.ZMT>=Z(K,L,IB)      &
                                 -.5*CLZ(L,IB)-.1.AND.ZMT<Z(K,L,IB)       &
                                 +.5*CLZ(L,IB)+.1) THEN
                              KUTCRP=1
                              N1=(I-1)*NY(L,IB)*NZ(L,IB)+(J-1)*NZ(L,IB)   &
                                 +K
                              N2=(N1-1)*3+1+NJ
!
! ---- Determine the E-field (scattered) at the top of an outcropping
!    cell by the scattering current directly
!
                              EXMT(IX,IY,KPOL)=JS(N2,IB)  &
                                 /(CDB(N1,L,IB)-CDH(1))-E0X
                              EYMT(IX,IY,KPOL)=JS(N2+1,IB)  &
                                 /(CDB(N1,L,IB)-CDH(1))-E0Y
                              GOTO 10
                              ENDIF
                           ENDDO
                        ENDDO
                     ENDDO
                  ENDDO
               ENDDO
!
   10          DO IB=1,NBODY
!
                  CLMN2=CLMN(IB)
!
                  NJS=0
                  DO L=1,SUB_BLOCK(IB)
                     IF (L>1) NJS=NJS+3*NCELL(L-1,IB)
                     DO I=1,NX(L,IB)
                        DO J=1,NY(L,IB)
                           DO K=1,NZ(L,IB)
                              NN1=(I-1)*NY(L,IB)*NZ(L,IB)+(J-1)*NZ(L,IB)  &
                                 +K
                              NN=(NN1-1)*3+1+NJS
                              CLX1=CLX(L,IB)
                              CLY1=CLY(L,IB)
                              CLZ1=CLZ(L,IB)
!
                              PSTION(1)=XRMT(IX)
                              PSTION(2)=YRMT(IY)
                              PSTION(3)=ZMT
                              PSTION(4)=X(I,L,IB)
                              PSTION(5)=Y(J,L,IB)
                              PSTION(6)=Z(K,L,IB)
                              CALL THR_D_GREEN(KEYG,PSTION,FRQ,MLAYER,ZBND,  &
                                 CDH,HVK,NZOB,ZOBG,NZSR,ZSRG,                &
                                 RHOMIN,DMIN,NHFILM,RRG,NRG,GRHF,RRG3,       &
                                 NRG3,GRHF3,GRHO0,GRHO03,CLX1,CLY1,CLZ1,     &
                                 CLMN2,KCLMN,BLMIN,KACC,KUTCRP,KSELF,        &
                                 ECOMP,HCOMP)
!
                              EX=EX+(JS(NN,IB)*EXX+JS(NN+1,IB)*EXY+          &
                                     JS(NN+2,IB)*EXZ)
                              EY=EY+(JS(NN,IB)*EYX+JS(NN+1,IB)*EYY+          &
                                     JS(NN+2,IB)*EYZ)
                              EZ=EZ+(JS(NN,IB)*EZX+JS(NN+1,IB)*EZY+          &
                                     JS(NN+2,IB)*EZZ)
                              HX=HX+(JS(NN,IB)*HXX+JS(NN+1,IB)*HXY+          &
                                     JS(NN+2,IB)*HXZ)
                              HY=HY+(JS(NN,IB)*HYX+JS(NN+1,IB)*HYY+          &
                                     JS(NN+2,IB)*HYZ)
                              HZ=HZ+(JS(NN,IB)*HZX+JS(NN+1,IB)*HZY+          &
                                     JS(NN+2,IB)*HZZ)
                           ENDDO
                        ENDDO
                     ENDDO
                  ENDDO
               ENDDO
!
               IF (KUTCRP==0) THEN
                  EXMT(IX,IY,KPOL)=EX
                  EYMT(IX,IY,KPOL)=EY
               ENDIF
               HXMT(IX,IY,KPOL)=HX
               HYMT(IX,IY,KPOL)=HY
               HZMT(IX,IY,KPOL)=HZ
            ENDDO
         ENDDO
      ENDDO
!
      REWIND (20)
!
      RETURN
      END
!
!**** End of SCAT_EH_MT
!
!
      SUBROUTINE SCAT_EH_MTS(NBMAX,NMAX,NXMAX,NYMAX,NZMAX,NBODY,SUB_BLOCK,  &
                             MT_PROFL,MT_STATN,XRMT,YRMT,NX,NY,NZ,NCELL,    &
                             X,Y,Z,CLX,CLY,CLZ,JS,NPOL,KSFT,NSUBCM,CDB,     &
                             CLMN,ZMT,E0X1,E0Y1,EXMT,EYMT,HXMT,HYMT,HZMT,   &
                             FRQ,MLAYER,ZBND,CDH,HVK,NZOB,ZOBG,NZSR,ZSRG,   &
                             RHOMIN,DMIN,NHFILM,RRG,NRG,GRHF,RRG3,NRG3,     &
                             GRHF3,GRHO0,GRHO03,KCLMN,BLMIN,KACC)
!
!**** Calculate scattered fields at receiver stations
!
!   The array clmn should have the size of mbody. Since mbody
!   may be changed in the main program, here it is defined as 30.
!
!
      IMPLICIT NONE
!
      REAL BLMIN,BX,BY,CLMN2,CLX1,CLY1,CLZ1,DMIN,FRQ,RHOMIN,SP,SX,SY,SZ,ZMT
      INTEGER I,IB,IX,IY,J,K,KACC,KCLMN,KEYG,KPOL,KSELF,KSFT,KSYM,           &
              KUTCRP,L,LP1,LP2,MLAYER
      INTEGER N1,N2,NBMAX,NBODY,NCT,NHFILM,NJ,NJS,NMAX,NN,NN1,MT_PROFL,NPOL, &
              MT_STATN,NRG,NRG3,NSUBCM,NXMAX,NYMAX,NZMAX
      INTEGER NZOB,NZSR
!
      COMPLEX JS(NMAX,NBODY),EX,EY,EZ,HX,HY,HZ,E0X,E0Y,E0X1,E0Y1,       &
              EXX,EYX,EZX,EXY,EYY,EZY,EXZ,EYZ,EZZ,                      &
              HXX,HYX,HZX,HXY,HYY,HZY,HXZ,HYZ,HZZ,                      &
              EXMT(MT_PROFL,MT_STATN,2),EYMT(MT_PROFL,MT_STATN,2),      &
              HXMT(MT_PROFL,MT_STATN,2),HYMT(MT_PROFL,MT_STATN,2),      &
              HZMT(MT_PROFL,MT_STATN,2),                                &
              CDH(0:MLAYER),CDB(NSUBCM,NBMAX,NBODY),                    &
              GRHF(11,NHFILM,NZSR,NZOB),GRHO0(4,NZSR,NZOB),             &
              GRHF3(11,NHFILM,NZSR),GRHO03(4,NZSR)
      INTEGER NX(NBMAX,NBODY),NY(NBMAX,NBODY),NZ(NBMAX,NBODY),          &
              NCELL(NBMAX,NBODY),SUB_BLOCK(NBODY)
      REAL  X(NXMAX,NBMAX,NBODY),Y(NYMAX,NBMAX,NBODY),                  &
            Z(NZMAX,NBMAX,NBODY),CLMN(NBODY),                           &
            CLX(NBMAX,NBODY),CLY(NBMAX,NBODY),CLZ(NBMAX,NBODY),         &
            XRMT(MT_PROFL),YRMT(MT_STATN),ZBND(0:MLAYER),HVK(0:MLAYER),                         &
            ZOBG(NZOB),ZSRG(2,NZSR),RRG(NRG),RRG3(NRG3),PSTION(6)
      COMPLEX ECOMP(9),HCOMP(9)
      EQUIVALENCE (ECOMP(1),EXX),(ECOMP(2),EYX),(ECOMP(3),EZX),   &
                  (ECOMP(4),EXY),(ECOMP(5),EYY),(ECOMP(6),EZY),   &
                  (ECOMP(7),EXZ),(ECOMP(8),EYZ),(ECOMP(9),EZZ),   &
                  (HCOMP(1),HXX),(HCOMP(2),HYX),(HCOMP(3),HZX),   &
                  (HCOMP(4),HXY),(HCOMP(5),HYY),(HCOMP(6),HZY),   &
                  (HCOMP(7),HXZ),(HCOMP(8),HYZ),(HCOMP(9),HZZ)
!
      KSELF=0
      KEYG=2
!
      IF (NPOL==0.OR.NPOL==1) THEN
         LP1=1+NPOL
         LP2=1+NPOL
      ELSEIF (NPOL==2) THEN
         LP1=1
         LP2=2
      ENDIF
!
      DO KPOL=LP1,LP2
!
! --- Read js per polarization
!
         IF (NPOL==2) THEN
            DO IB=1,NBODY
               NCT=0
               DO I=1,SUB_BLOCK(IB)
                  NCT=NCT+NCELL(I,IB)
               ENDDO
               READ (20) (JS(J,IB),J=1,3*NCT)
            ENDDO
         ENDIF
!
         IF (KSFT/=0.OR.ZMT>=.1) THEN
            IF (KPOL==1) THEN
               E0X=(0.,0.)
               E0Y=E0Y1
            ELSE
               E0X=E0X1
               E0Y=(0.,0.)
            ENDIF
         ENDIF
!
         DO IY=1,MT_STATN
            DO IX=1,MT_PROFL
!
               IF (KPOL==1) THEN
                  SP=1.
               ELSE
                  SP=-1.
               ENDIF
               EX=(0.,0.)
               EY=(0.,0.)
               EZ=(0.,0.)
               HX=(0.,0.)
               HY=(0.,0.)
               HZ=(0.,0.)
!
               IF (KSFT==0.AND.ZMT<.1) THEN
                  KUTCRP=0
                  GOTO 10
               ENDIF
!
               KUTCRP=0
               DO IB=1,NBODY
                  NJ=0
                  DO L=1,SUB_BLOCK(IB)
                     IF (L>1) NJ=NJ+3*NCELL(L-1,IB)
                     DO I=1,NX(L,IB)
                        DO J=1,NY(L,IB)
                           DO K=1,NZ(L,IB)
!
! ---- For quarter I
                              IF (XRMT(IX)>=X(I,L,IB)-.5*CLX(L,IB)        &
                                 -.1.AND.XRMT(IX)<X(I,L,IB)+.5*CLX(L,IB)  &
                                 +.1.AND.YRMT(IY)>=Y(J,L,IB)              &
                                 -.5*CLY(L,IB)-.1.AND.YRMT(IY)<Y(J,L,IB)  &
                                 +.5*CLY(L,IB)+.1.AND.ZMT>=Z(K,L,IB)      &
                                 -.5*CLZ(L,IB)-.1.AND.ZMT<Z(K,L,IB)       &
                                 +.5*CLZ(L,IB)+.1) THEN
                              KUTCRP=1
                              N1=(I-1)*NY(L,IB)*NZ(L,IB)+(J-1)*NZ(L,IB)+K
                              N2=(N1-1)*3+1+NJ
!
! ---- Determine the E-field (scattered)  at the top of an outcropping
!    cell by the scattering current directly
!
                              EXMT(IX,IY,KPOL)=JS(N2,IB)        &
                                 /(CDB(N1,L,IB)-CDH(1))-E0X
                              EYMT(IX,IY,KPOL)=JS(N2+1,IB)      &
                                 /(CDB(N1,L,IB)-CDH(1))-E0Y
                              GOTO 10
                              ENDIF
!
! ---- For quarter II
                              IF (XRMT(IX)>=-X(I,L,IB)-.5*CLX(L,IB)       &
                                 -.1.AND.XRMT(IX)<-X(I,L,IB)              &
                                 +.5*CLX(L,IB)+.1.AND.YRMT(IY)            &
                                 >=Y(J,L,IB)-.5*CLY(L,IB)-.1.AND.         &
                                 YRMT(IY)<Y(J,L,IB)+.5*CLY(L,IB)+.1.AND.  &
                                 ZMT>=Z(K,L,IB)-.5*CLZ(L,IB)-.1.AND.      &
                                 ZMT<Z(K,L,IB)+.5*CLZ(L,IB)+.1) THEN
                              KUTCRP=1
                              N1=(I-1)*NY(L,IB)*NZ(L,IB)+(J-1)*NZ(L,IB)   &
                                 +K
                              N2=(N1-1)*3+1+NJ
!
                              EXMT(IX,IY,KPOL)=-SP*JS(N2,IB)              &
                                 /(CDB(N1,L,IB)-CDH(1))-E0X
                              EYMT(IX,IY,KPOL)=SP*JS(N2+1,IB)             &
                                 /(CDB(N1,L,IB)-CDH(1))-E0Y
                              GOTO 10
                              ENDIF
!
! ---- For quarter III
                              IF (XRMT(IX)>=-X(I,L,IB)-.5*CLX(L,IB)        &
                                 -.1.AND.XRMT(IX)<-X(I,L,IB)               &
                                 +.5*CLX(L,IB)+.1.AND.YRMT(IY)             &
                                 >=-Y(J,L,IB)-.5*CLY(L,IB)-.1.AND.         &
                                 YRMT(IY)<-Y(J,L,IB)+.5*CLY(L,IB)          &
                                 +.1.AND.ZMT>=Z(K,L,IB)-.5*CLZ(L,IB)       &
                                 -.1.AND.ZMT<Z(K,L,IB)+.5*CLZ(L,IB)+.1)    &
                                 THEN
                              KUTCRP=1
                              N1=(I-1)*NY(L,IB)*NZ(L,IB)+(J-1)*NZ(L,IB)    &
                                 +K
                              N2=(N1-1)*3+1+NJ
!
                              EXMT(IX,IY,KPOL)=JS(N2,IB)                   &
                                 /(CDB(N1,L,IB)-CDH(1))-E0X
                              EYMT(IX,IY,KPOL)=JS(N2+1,IB)                 &
                                 /(CDB(N1,L,IB)-CDH(1))-E0Y
                              GOTO 10
                              ENDIF
!
! ---- For quarter IV
                              IF (XRMT(IX)>=X(I,L,IB)-.5*CLX(L,IB)         &
                                 -.1.AND.XRMT(IX)<X(I,L,IB)+.5*CLX(L,IB)   &
                                 +.1.AND.YRMT(IY)>=-Y(J,L,IB)              &
                                 -.5*CLY(L,IB)-.1.AND.YRMT(IY)             &
                                 <-Y(J,L,IB)+.5*CLY(L,IB)+.1.AND.          &
                                 ZMT>=Z(K,L,IB)-.5*CLZ(L,IB)-.1.AND.       &
                                 ZMT<Z(K,L,IB)+.5*CLZ(L,IB)+.1) THEN
                              KUTCRP=1
                              N1=(I-1)*NY(L,IB)*NZ(L,IB)+(J-1)*NZ(L,IB)    &
                                 +K
                              N2=(N1-1)*3+1+NJ
!
                              EXMT(IX,IY,KPOL)=-SP*JS(N2,IB)               &
                                 /(CDB(N1,L,IB)-CDH(1))-E0X
                              EYMT(IX,IY,KPOL)=SP*JS(N2+1,IB)              &
                                 /(CDB(N1,L,IB)-CDH(1))-E0Y
                              GOTO 10
                              ENDIF
!
                           ENDDO
                        ENDDO
                     ENDDO
                  ENDDO
               ENDDO
!
   10          DO IB=1,NBODY
!
                  CLMN2=CLMN(IB)
!
                  NJS=0
                  DO L=1,SUB_BLOCK(IB)
                     IF (L>1) NJS=NJS+3*NCELL(L-1,IB)
                     DO I=1,NX(L,IB)
                        DO J=1,NY(L,IB)
                           DO K=1,NZ(L,IB)
                              NN1=(I-1)*NY(L,IB)*NZ(L,IB)+(J-1)*NZ(L,IB)+K
                              NN=(NN1-1)*3+1+NJS
                              CLX1=CLX(L,IB)
                              CLY1=CLY(L,IB)
                              CLZ1=CLZ(L,IB)
!
                              DO KSYM=1,4
                              IF (KSYM==1) THEN
                              BX=1.
                              BY=1.
                              SX=1.
                              SY=1.
                              SZ=1.
                              ENDIF
                              IF (KSYM==2) THEN
                              BX=-1.
                              BY=1.
                              SX=-SP
                              SY=SP
                              SZ=SP
                              ENDIF
                              IF (KSYM==3) THEN
                              BX=-1.
                              BY=-1.
                              SX=1.
                              SY=1.
                              SZ=-1.
                              ENDIF
                              IF (KSYM==4) THEN
                              BX=1.
                              BY=-1.
                              SX=-SP
                              SY=SP
                              SZ=-SP
                              ENDIF
!
                              PSTION(1)=XRMT(IX)
                              PSTION(2)=YRMT(IY)
                              PSTION(3)=ZMT
                              PSTION(4)=BX*X(I,L,IB)
                              PSTION(5)=BY*Y(J,L,IB)
                              PSTION(6)=Z(K,L,IB)
                              CALL THR_D_GREEN(KEYG,PSTION,FRQ,MLAYER,ZBND,  &
                                 CDH,HVK,NZOB,ZOBG,NZSR,ZSRG,                &
                                 RHOMIN,DMIN,NHFILM,RRG,NRG,GRHF,RRG3,       &
                                 NRG3,GRHF3,GRHO0,GRHO03,CLX1,CLY1,CLZ1,     &
                                 CLMN2,KCLMN,BLMIN,KACC,KUTCRP,KSELF,        &
                                 ECOMP,HCOMP)
!
                              EX=EX+(SX*JS(NN,IB)*EXX+SY*JS(NN+1,IB)  &
                                 *EXY+SZ*JS(NN+2,IB)*EXZ)
                              EY=EY+(SX*JS(NN,IB)*EYX+SY*JS(NN+1,IB)  &
                                 *EYY+SZ*JS(NN+2,IB)*EYZ)
                              EZ=EZ+(SX*JS(NN,IB)*EZX+SY*JS(NN+1,IB)  &
                                 *EZY+SZ*JS(NN+2,IB)*EZZ)
                              HX=HX+(SX*JS(NN,IB)*HXX+SY*JS(NN+1,IB)  &
                                 *HXY+SZ*JS(NN+2,IB)*HXZ)
                              HY=HY+(SX*JS(NN,IB)*HYX+SY*JS(NN+1,IB)  &
                                 *HYY+SZ*JS(NN+2,IB)*HYZ)
                              HZ=HZ+(SX*JS(NN,IB)*HZX+SY*JS(NN+1,IB)  &
                                 *HZY+SZ*JS(NN+2,IB)*HZZ)
                              ENDDO
                           ENDDO
                        ENDDO
                     ENDDO
                  ENDDO
               ENDDO
!
               IF (KUTCRP==0) THEN
                  EXMT(IX,IY,KPOL)=EX
                  EYMT(IX,IY,KPOL)=EY
               ENDIF
               HXMT(IX,IY,KPOL)=HX
               HYMT(IX,IY,KPOL)=HY
               HZMT(IX,IY,KPOL)=HZ
            ENDDO
         ENDDO
      ENDDO
!
      REWIND (20)
!
      RETURN
      END
!
!**** End of SCAT_EH_MTS
!
!
      SUBROUTINE SCAT_EH_CSGS(NBMAX,NEQ,NXMAX,NYMAX,NZMAX,NBODY,SUB_BLOCK, &
                              NET,N_RX,RX_X,RX_Y,RX_Z,NX,NY,NZ,NCELL,X,Y,  &
                              Z,CLX,CLY,CLZ,JS,NSUBCM,CDB,IEXCI,CLMN,M_RX, &
                              NTX_FD,ENX,ENY,ENZ,EAX,EAY,EAZ,HAX,HAY,HAZ,    &
                              FRQ,MLAYER,ZBND,CDH,CDV,HVK,NZOB,ZOBG,NZSR,  &
                              ZSRG,RHOMIN,DMIN,NHFILM,RRG,NRG,GRHF,RRG3,   &
                              NRG3,GRHF3,GRHO0,GRHO03,KCLMN,BLMIN,KACC)
!
!**** Calculate the scattered fields at receiver sites
!   due to symmetric structures
!
!   This routine is similar to the routine SCAT_EH_CS. The numbering
!   of the array JS is completely different.
!
!   Note if the receiver is located within a cell, the electric field
!   is then calculated by the scattering current directly.
!
!   Note the controlling parameter koutcrp was originally designed for
!   outcropping structures so that it bears this named.
!
!   The array clmn should have the size of mbody. Since mbody
!   may be changed in the main program, here it is defined as 30.
!
!
      IMPLICIT NONE
!
      REAL BLMIN,BX,BY,CLMN2,CLX1,CLY1,CLZ1,DMIN,FRQ,RHOMIN
      INTEGER I,IB,IEXCI,II,IQ,J,K,KACC,KCLMN,KEYG,KSELF,KUTCRP,L,      &
              MLAYER,M_RX,N1,N2,NBMAX,NBODY,NEQ
      INTEGER NHFILM,NJ,NN,NN1,NRG,NRG3,NSUB,NSUBCM,NTX_FD,NXMAX,       &
              NYMAX,NZMAX,NZOB,NZSR
!
      COMPLEX JS(4*NEQ),EX,EY,EZ,HX,HY,HZ,                              &
              EXX,EYX,EZX,EXY,EYY,EZY,EXZ,EYZ,EZZ,                      &
              HXX,HYX,HZX,HXY,HYY,HZY,HXZ,HYZ,HZZ,                      &
              ENX(M_RX,NTX_FD),ENY(M_RX,NTX_FD),ENZ(M_RX,NTX_FD),       &
              EAX(M_RX),EAY(M_RX),EAZ(M_RX),                            &
              HAX(M_RX),HAY(M_RX),HAZ(M_RX),                            &
              CDH(0:MLAYER),CDV(0:MLAYER),CDB(NSUBCM,NBMAX,NBODY),      &
              GRHF(11,NHFILM,NZSR,NZOB),GRHO0(4,NZSR,NZOB),             &
              GRHF3(11,NHFILM,NZSR),GRHO03(4,NZSR)
      INTEGER NX(NBMAX,NBODY),NY(NBMAX,NBODY),NZ(NBMAX,NBODY),          &
              NCELL(NBMAX,NBODY),SUB_BLOCK(NBODY),NET(NBODY)
      REAL  X(NXMAX,NBMAX,NBODY),Y(NYMAX,NBMAX,NBODY),                  &
            Z(NZMAX,NBMAX,NBODY),CLMN(NBODY),                           &
            CLX(NBMAX,NBODY),CLY(NBMAX,NBODY),CLZ(NBMAX,NBODY),         &
            RX_X(M_RX,NTX_FD),RX_Y(M_RX,NTX_FD),RX_Z(M_RX,NTX_FD),      &
            ZBND(0:MLAYER),HVK(0:MLAYER),                               &
            ZOBG(NZOB),ZSRG(2,NZSR),RRG(NRG),RRG3(NRG3),PSTION(6)
      INTEGER N_RX(NTX_FD)
      COMPLEX ECOMP(9),HCOMP(9)
      EQUIVALENCE (ECOMP(1),EXX),(ECOMP(2),EYX),(ECOMP(3),EZX),   &
                  (ECOMP(4),EXY),(ECOMP(5),EYY),(ECOMP(6),EZY),   &
                  (ECOMP(7),EXZ),(ECOMP(8),EYZ),(ECOMP(9),EZZ),   &
                  (HCOMP(1),HXX),(HCOMP(2),HYX),(HCOMP(3),HZX),   &
                  (HCOMP(4),HXY),(HCOMP(5),HYY),(HCOMP(6),HZY),   &
                  (HCOMP(7),HXZ),(HCOMP(8),HYZ),(HCOMP(9),HZZ)
!
      KSELF=0
      KEYG=2
!
      DO II=1,N_RX(IEXCI)
!
         EX=(0.,0.)
         EY=(0.,0.)
         EZ=(0.,0.)
         HX=(0.,0.)
         HY=(0.,0.)
         HZ=(0.,0.)
!
         KUTCRP=0
         NSUB=0
         DO IB=1,NBODY
            IF (IB>1) NSUB=NSUB+NET(IB-1)/3
            NJ=0
            DO L=1,SUB_BLOCK(IB)
               IF (L>1) NJ=NJ+NCELL(L-1,IB)
               DO I=1,NX(L,IB)
                  DO J=1,NY(L,IB)
                     DO K=1,NZ(L,IB)
                        DO IQ=1,4
!
                           IF (IQ==1) THEN
                              BX=-1.
                              BY=-1.
                           ENDIF
                           IF (IQ==2) THEN
                              BX=1.
                              BY=-1.
                           ENDIF
                           IF (IQ==3) THEN
                              BX=1.
                              BY=1.
                           ENDIF
                           IF (IQ==4) THEN
                              BX=-1.
                              BY=1.
                           ENDIF
!
                           IF (RX_X(II,IEXCI)>=BX*X(I,L,IB)-.5*CLX(L,IB)  &
                              -.01.AND.RX_X(II,IEXCI)<BX*X(I,L,IB)        &
                              +.5*CLX(L,IB)+.01.AND.RX_Y(II,IEXCI)        &
                              >=BY*Y(J,L,IB)-.5*CLY(L,IB)-.01.AND.        &
                              RX_Y(II,IEXCI)<BY*Y(J,L,IB)+.5*CLY(L,IB)    &
                              +.01.AND.RX_Z(II,IEXCI)>=Z(K,L,IB)          &
                              -.5*CLZ(L,IB)-.01.AND.RX_Z(II,IEXCI)        &
                              <Z(K,L,IB)+.5*CLZ(L,IB)+.01) THEN
                              KUTCRP=1
                              N1=(I-1)*NY(L,IB)*NZ(L,IB)+(J-1)*NZ(L,IB)+K
                              N2=12*(N1+NJ+NSUB-1)+3*(IQ-1)+1
!
! ---- Determine the E-field (scattered) within a
!    cell by the scattering current directly
!
                              EAX(II)=JS(N2)/(CDB(N1,L,IB)-CDH(1))    &
                                 -ENX(II,IEXCI)
                              EAY(II)=JS(N2+1)/(CDB(N1,L,IB)-CDH(1))  &
                                 -ENY(II,IEXCI)
                              EAZ(II)=JS(N2+2)/(CDB(N1,L,IB)-CDV(1))  &
                                 -ENZ(II,IEXCI)
                              GOTO 50
                           ENDIF
                        ENDDO
                     ENDDO
                  ENDDO
               ENDDO
            ENDDO
         ENDDO
!
   50    NSUB=0
         DO IB=1,NBODY
            IF (IB>1) NSUB=NSUB+NET(IB-1)/3
!
            CLMN2=CLMN(IB)
!
            NJ=0
            DO L=1,SUB_BLOCK(IB)
               IF (L>1) NJ=NJ+NCELL(L-1,IB)
               DO I=1,NX(L,IB)
                  DO J=1,NY(L,IB)
                     DO K=1,NZ(L,IB)
                        DO IQ=1,4
!
                           IF (IQ==1) THEN
                              BX=-1.
                              BY=-1.
                           ENDIF
                           IF (IQ==2) THEN
                              BX=1.
                              BY=-1.
                           ENDIF
                           IF (IQ==3) THEN
                              BX=1.
                              BY=1.
                           ENDIF
                           IF (IQ==4) THEN
                              BX=-1.
                              BY=1.
                           ENDIF
!
                           NN1=(I-1)*NY(L,IB)*NZ(L,IB)+(J-1)*NZ(L,IB)+K
                           NN=12*(NN1+NJ+NSUB-1)+3*(IQ-1)+1
                           CLX1=CLX(L,IB)
                           CLY1=CLY(L,IB)
                           CLZ1=CLZ(L,IB)
!
                           PSTION(1)=RX_X(II,IEXCI)
                           PSTION(2)=RX_Y(II,IEXCI)
                           PSTION(3)=RX_Z(II,IEXCI)
                           PSTION(4)=BX*X(I,L,IB)
                           PSTION(5)=BY*Y(J,L,IB)
                           PSTION(6)=Z(K,L,IB)
                           CALL THR_D_GREEN(KEYG,PSTION,FRQ,MLAYER,ZBND,CDH,  &
                              HVK,NZOB,ZOBG,NZSR,ZSRG,RHOMIN,                 &
                              DMIN,NHFILM,RRG,NRG,GRHF,RRG3,NRG3,GRHF3,       &
                              GRHO0,GRHO03,CLX1,CLY1,CLZ1,CLMN2,KCLMN,        &
                              BLMIN,KACC,KUTCRP,KSELF,ECOMP,HCOMP)
!
                           EX=EX+(JS(NN)*EXX+JS(NN+1)*EXY+JS(NN+2)*EXZ)
                           EY=EY+(JS(NN)*EYX+JS(NN+1)*EYY+JS(NN+2)*EYZ)
                           EZ=EZ+(JS(NN)*EZX+JS(NN+1)*EZY+JS(NN+2)*EZZ)
                           HX=HX+(JS(NN)*HXX+JS(NN+1)*HXY+JS(NN+2)*HXZ)
                           HY=HY+(JS(NN)*HYX+JS(NN+1)*HYY+JS(NN+2)*HYZ)
                           HZ=HZ+(JS(NN)*HZX+JS(NN+1)*HZY+JS(NN+2)*HZZ)
                        ENDDO
                     ENDDO
                  ENDDO
               ENDDO
            ENDDO
         ENDDO
!
         IF (KUTCRP==0) THEN
            EAX(II)=EX
            EAY(II)=EY
            EAZ(II)=EZ
         ENDIF
         HAX(II)=HX
         HAY(II)=HY
         HAZ(II)=HZ
      ENDDO
!
      RETURN
      END
!
!
      SUBROUTINE SCAT_EH_CS(NBMAX,NMAX,NXMAX,NYMAX,NZMAX,NBODY,SUB_BLOCK,   &
                            N_RX,RX_X,RX_Y,RX_Z,NX,NY,NZ,NCELL,X,Y,Z,CLX,   &
                            CLY,CLZ,JS,NSUBCM,CDB,IEXCI,CLMN,M_RX,NTX_FD,   &
                            ENX,ENY,ENZ,EAX,EAY,EAZ,HAX,HAY,HAZ,FRQ,MLAYER, &
                            ZBND,CDH,CDV,HVK,NZOB,ZOBG,NZSR,ZSRG,RHOMIN,    &
                            DMIN,NHFILM,RRG,NRG,GRHF,RRG3,NRG3,GRHF3,GRHO0, &
                            GRHO03,KCLMN,BLMIN,KACC)
!
!**** Calculate scattered fields at receiver sites
!
!   Note if the receiver is located within a cell, the electric field
!   is then calculated by the scattering current directly.
!
!   Note the controlling parameter koutcrp was originally designed for
!   outcropping structures so that it bears this named.
!
!   The array clmn should have the size of mbody. Since mbody
!   may be changed in the main program, here it is defined as 30.
!
!   ENX, ENY,  etc. are used to compute electric fields for receivers
!   onm or within the 3D target.
!
!
!   Parameters  FRQ,MLAYER,ZBND,
!             CDH,HVK,NZOB,ZOBG,NZSR,ZSRG,
!             RHOMIN,DMIN,NHFILM,RRG,GRHF,GRHF3,GRHO0,
!             GRHO03,KCLMN,BLMIN,
!             KACC,  are to be passed to routine THR_D_GREEN
!
!
      IMPLICIT NONE
!
      REAL BLMIN,CLMN2,CLX1,CLY1,CLZ1,DMIN,FRQ,RHOMIN
      INTEGER I,IB,IEXCI,II,J,K,KACC,KCLMN,KEYG,KSELF,KUTCRP,L,MLAYER,   &
              M_RX,N1,N2,NBMAX,NBODY,NHFILM,NJ
      INTEGER NJS,NMAX,NN,NN1,NRG,NRG3,NSUBCM,NTX_FD,NXMAX,NYMAX,        &
              NZMAX,NZOB,NZSR
!
      COMPLEX JS(NMAX,NBODY),EX,EY,EZ,HX,HY,HZ,                          &
              EXX,EYX,EZX,EXY,EYY,EZY,EXZ,EYZ,EZZ,                       &
              HXX,HYX,HZX,HXY,HYY,HZY,HXZ,HYZ,HZZ,                       &
              ENX(M_RX,NTX_FD),ENY(M_RX,NTX_FD),ENZ(M_RX,NTX_FD),        &
              EAX(M_RX),EAY(M_RX),EAZ(M_RX),                             &
              HAX(M_RX),HAY(M_RX),HAZ(M_RX),                             &
              CDH(0:MLAYER),CDV(0:MLAYER),CDB(NSUBCM,NBMAX,NBODY),       &
              GRHF(11,NHFILM,NZSR,NZOB),GRHO0(4,NZSR,NZOB),              &
              GRHF3(11,NHFILM,NZSR),GRHO03(4,NZSR)
      INTEGER NX(NBMAX,NBODY),NY(NBMAX,NBODY),NZ(NBMAX,NBODY),           &
              NCELL(NBMAX,NBODY),SUB_BLOCK(NBODY)
      REAL  X(NXMAX,NBMAX,NBODY),Y(NYMAX,NBMAX,NBODY),                   &
            Z(NZMAX,NBMAX,NBODY),CLMN(NBODY),                            &
            CLX(NBMAX,NBODY),CLY(NBMAX,NBODY),CLZ(NBMAX,NBODY),          &
            RX_X(M_RX,NTX_FD),RX_Y(M_RX,NTX_FD),RX_Z(M_RX,NTX_FD),       &
            ZBND(0:MLAYER),HVK(0:MLAYER),ZOBG(NZOB),ZSRG(2,NZSR),        &
            RRG(NRG),RRG3(NRG3),PSTION(6)
      INTEGER N_RX(NTX_FD)
      COMPLEX ECOMP(9),HCOMP(9)
      EQUIVALENCE (ECOMP(1),EXX),(ECOMP(2),EYX),(ECOMP(3),EZX),   &
                  (ECOMP(4),EXY),(ECOMP(5),EYY),(ECOMP(6),EZY),   &
                  (ECOMP(7),EXZ),(ECOMP(8),EYZ),(ECOMP(9),EZZ),   &
                  (HCOMP(1),HXX),(HCOMP(2),HYX),(HCOMP(3),HZX),   &
                  (HCOMP(4),HXY),(HCOMP(5),HYY),(HCOMP(6),HZY),   &
                  (HCOMP(7),HXZ),(HCOMP(8),HYZ),(HCOMP(9),HZZ)
!
      KSELF=0
      KEYG=2
!
      DO II=1,N_RX(IEXCI)
!
         EX=(0.,0.)
         EY=(0.,0.)
         EZ=(0.,0.)
         HX=(0.,0.)
         HY=(0.,0.)
         HZ=(0.,0.)
!
         KUTCRP=0
         DO IB=1,NBODY
            NJ=0
            DO L=1,SUB_BLOCK(IB)
               IF (L>1) NJ=NJ+3*NCELL(L-1,IB)
               DO I=1,NX(L,IB)
                  DO J=1,NY(L,IB)
                     DO K=1,NZ(L,IB)
                        IF (RX_X(II,IEXCI)>=X(I,L,IB)-.5*CLX(L,IB)  &
                            -.01.AND.RX_X(II,IEXCI)<X(I,L,IB)       &
                            +.5*CLX(L,IB)+.01.AND.RX_Y(II,IEXCI)    &
                            >=Y(J,L,IB)-.5*CLY(L,IB)-.01.AND.       &
                            RX_Y(II,IEXCI)<Y(J,L,IB)+.5*CLY(L,IB)   &
                            +.01.AND.RX_Z(II,IEXCI)>=Z(K,L,IB)      &
                            -.5*CLZ(L,IB)-.01.AND.RX_Z(II,IEXCI)    &
                            <Z(K,L,IB)+.5*CLZ(L,IB)+.01) THEN
                           KUTCRP=1
                           N1=(I-1)*NY(L,IB)*NZ(L,IB)+(J-1)*NZ(L,IB)+K
                           N2=(N1-1)*3+1+NJ
!
! ---- Determine the E-field (scattered) within a
!    cell by the scattering current directly
!
                           EAX(II)=JS(N2,IB)/(CDB(N1,L,IB)-CDH(1))    &
                              -ENX(II,IEXCI)
                           EAY(II)=JS(N2+1,IB)/(CDB(N1,L,IB)-CDH(1))  &
                              -ENY(II,IEXCI)
                           EAZ(II)=JS(N2+2,IB)/(CDB(N1,L,IB)-CDV(1))  &
                              -ENZ(II,IEXCI)
                           GOTO 50
                        ENDIF
                     ENDDO
                  ENDDO
               ENDDO
            ENDDO
         ENDDO
!
   50    DO IB=1,NBODY
!
            CLMN2=CLMN(IB)
!
            NJS=0
            DO L=1,SUB_BLOCK(IB)
               IF (L>1) NJS=NJS+3*NCELL(L-1,IB)
               DO I=1,NX(L,IB)
                  DO J=1,NY(L,IB)
                     DO K=1,NZ(L,IB)
                        NN1=(I-1)*NY(L,IB)*NZ(L,IB)+(J-1)*NZ(L,IB)+K
                        NN=(NN1-1)*3+1+NJS
                        CLX1=CLX(L,IB)
                        CLY1=CLY(L,IB)
                        CLZ1=CLZ(L,IB)
!
                        PSTION(1)=RX_X(II,IEXCI)
                        PSTION(2)=RX_Y(II,IEXCI)
                        PSTION(3)=RX_Z(II,IEXCI)
                        PSTION(4)=X(I,L,IB)
                        PSTION(5)=Y(J,L,IB)
                        PSTION(6)=Z(K,L,IB)
                        CALL THR_D_GREEN(KEYG,PSTION,FRQ,MLAYER,ZBND,CDH,HVK, &
                           NZOB,ZOBG,NZSR,ZSRG,RHOMIN,DMIN,                   &
                           NHFILM,RRG,NRG,GRHF,RRG3,NRG3,GRHF3,GRHO0,         &
                           GRHO03,CLX1,CLY1,CLZ1,CLMN2,KCLMN,BLMIN,KACC,      &
                           KUTCRP,KSELF,ECOMP,HCOMP)
!
                        EX=EX+(JS(NN,IB)*EXX+JS(NN+1,IB)*EXY+JS(NN+2,IB)  &
                           *EXZ)
                        EY=EY+(JS(NN,IB)*EYX+JS(NN+1,IB)*EYY+JS(NN+2,IB)  &
                           *EYZ)
                        EZ=EZ+(JS(NN,IB)*EZX+JS(NN+1,IB)*EZY+JS(NN+2,IB)  &
                           *EZZ)
                        HX=HX+(JS(NN,IB)*HXX+JS(NN+1,IB)*HXY+JS(NN+2,IB)  &
                           *HXZ)
                        HY=HY+(JS(NN,IB)*HYX+JS(NN+1,IB)*HYY+JS(NN+2,IB)  &
                           *HYZ)
                        HZ=HZ+(JS(NN,IB)*HZX+JS(NN+1,IB)*HZY+JS(NN+2,IB)  &
                           *HZZ)
                     ENDDO
                  ENDDO
               ENDDO
            ENDDO
         ENDDO
!
         IF (KUTCRP==0) THEN
            EAX(II)=EX
            EAY(II)=EY
            EAZ(II)=EZ
         ENDIF
         HAX(II)=HX
         HAY(II)=HY
         HAZ(II)=HZ
      ENDDO
!
      RETURN
      END
!
!
   SUBROUTINE HFILL(KEYG,KEMD,MLAYER,ZBND,LRYTH,HVK,KKH,KANIS,KPRM,KITG,   &
                    KCHRG,NOB,NSR,RLO,RHI,ZOB,ZSRH,ZSRL,NRG,RRG,HF)
!
!****  HANKEL TRANSFORMATIONS BY DIGITAL LINEAR FILTERING
!      for computing normal responses
!
!      The filters used here yield an accuracy of about 0.4E-8.
!
!      This routine is based on a filtering routine provided by
!      N. Christensen.  Though the routine has been restructured,
!      it still retains the basic original designs of Christensen
!      because of their efficience.
!
!   Input parameters:
!
!      RLO:  real (*4), minimum of rho.
!      RHI:  real     , maximumof rho.
!
!      The parameters KEMD, MLAYER, ZBND, LRYTH, HVK, KKH, KANIS, KPRM,
!      KITG, KCHRG, NOB, NSR, ZOB,  ZSRH and ZSRL are to be passed
!      to routine kernel.  See routine kernel for their descriptions.
!
!
!   Output parameters:
!
!      NRG:  integer (*4), number of data point returned.
!      RRG:  real RRG(nhfil), the discrete values of rho on
!            logrithmic scale on which results of the Hankel
!            transforms are returned.
!      HF:   complex(11,nhfil), the nhfil columns of the
!            11 components of the Hankel transforms of the
!            Green's tensors.  Note that the values contained
!            in HF must be divided by rho in order to get the
!            actual Hankel transforms.
!
!****  CALLED by:  gridhf, gridcs
!
!****  CALLS    :  kernel
!
!
!
      IMPLICIT NONE
!
      INTEGER, PARAMETER :: NHFILM=91
!
      INTEGER, INTENT(IN) :: KEYG,KEMD,MLAYER,KANIS,KPRM,KITG,KCHRG,NOB,NSR
      INTEGER, INTENT(OUT) :: NRG
      REAL, INTENT(INOUT) :: RRG(NHFILM),RLO,RHI
      COMPLEX, INTENT(INOUT) :: HF(11,NHFILM)
!
      INTEGER ::  NC(NHFILM),INR(491),NLO,NHI,NF,I0F,I0G,IGSH,   &
                  NLIM,KRHO
      REAL :: FILT0(401),FILT1(401),DEL,R1,E,R
      COMPLEX :: FC0(5,491),FC1(6,491),                     &
                 SUM0(5),SUM1(6),SDEL0(5),SDEL1(6),FKN(11)
      COMMON /J0BLK/FILT0 /J1BLK/FILT1
!
      REAL, PARAMETER :: EPS=1.E-9
      REAL :: X
      INTEGER ::  I,IG,IJ,J,K
!
!  -- Parameters to be passed to the routine kernel
!
      COMPLEX, INTENT(IN) :: KKH(0:MLAYER)
      REAL, INTENT(IN) :: LRYTH(MLAYER),HVK(0:MLAYER),ZBND(0:MLAYER),   &
                          ZOB,ZSRH,ZSRL
!
!  -- Parameter KRHO is required by routine ONE_D_KERNEL.
!     KRHO=1 means rho (or R in this routine) .ne. zero
!
      KRHO=1
!
!  -- Inititalizations
!
!     NLO, NHI, NRG, R1,  and E are determined by DEL,  RLO,  and RHI
!
      DEL=ALOG(10.)/15.
      NLO=INT(ALOG(RLO)/DEL+100.)-101
      IF (NLO<-15) NLO=-15
      NHI=INT(ALOG(RHI)/DEL+100.)-98
      IF (NHI>75) NHI=75
      NRG=NHI-NLO+1
      R1=EXP(FLOAT(NLO)*DEL)
      E=EXP(DEL)
!
!  --  NG=491 is the dimension of the arrays INR, FC0,  and FC1
!
      NLIM=60; NF=401; I0F=251; I0G=326; INR=-1
!
      R=R1/E
      IGSH=INT(ALOG(R)/DEL+100.5)-100
!
      R_loop:  DO K=1,NRG   !  This loop computes the discreted values of
                            !  the Hankel integrals at discreted points of
                            !  R on a logarithmic scale determined by DEL.
                            !  All transforms are returned simultaneously.
!
         R=R*E
!
! --- The evaluation of IGSH has been moved to the top of the do loop
!     since the value of R may not be very accurate if it is large.
!        IGSH=INT(ALOG(R)/DEL+100.5)-100
!
         IGSH=IGSH+1
!
         X=E/R*EXP(-0.141555714)     ! To be exact: EXP(-0.1415557141054993)
         SUM0=(0.,0.);  SUM1=(0.,0.)
!
         Lower_convolution_loop:  DO I=1,NF
!
            IJ=I0F-I+1
!
! --- Calculation of convolution, arg. of kernel to zero
!
!   -- Check for limits to convolution, arg. of kernel to zero.
!      Exit if the IJ runs out of the filters range
!
            IF (IJ<1) THEN
!
!               WRITE (4,111) R
!
!**** EXIT lower convolution loop due to exhaustion of filters
!
               EXIT
!
            ENDIF
!
            X=X/E
            IG=I0G-IGSH-I+1
            IF (INR(IG)<0) THEN
               CALL ONE_D_KERNEL(KEYG,KEMD,MLAYER,ZBND,LRYTH,HVK,KKH,KANIS, &
                         KPRM,KRHO,KITG,KCHRG,NOB,NSR,ZOB,(ZSRH+ZSRL)/2.,   &
                         ZSRH,ZSRL,X,FKN)
               FC0(1:3,IG)=FKN(1:3)
               FC0(4:5,IG)=FKN(7:8)
               FC1(1:3,IG)=FKN(4:6)
               FC1(4:6,IG)=FKN(9:11)
               INR(IG)=1
            ENDIF
!
            DO J=1,5
               SDEL0(J)=FILT0(IJ)*FC0(J,IG)
               SDEL1(J)=FILT1(IJ)*FC1(J,IG)
               SUM0(J)=SUM0(J)+SDEL0(J)
               SUM1(J)=SUM1(J)+SDEL1(J)
            ENDDO
            SDEL1(6)=FILT1(IJ)*FC1(6,IG)
            SUM1(6)=SUM1(6)+SDEL1(6)
!
            IF (I>NLIM) THEN
               DO J=1,5
!
! --- Use 1.E-28 so that its product with EPS is larger
!     than 1.E-38 to avoid possible problems on some machines
!
                  IF (CABS(SDEL0(J))>(1.E-28+CABS(SUM0(J)))*EPS) GOTO 50
                  IF (CABS(SDEL1(J))>(1.E-28+CABS(SUM1(J)))*EPS) GOTO 50
               ENDDO
               IF (CABS(SDEL1(6))>(1.E-28+CABS(SUM1(6)))*EPS) GOTO 50
!
!****   Proper EXIT of lower convolution loop upon convergence
!
               EXIT
!
            ENDIF
!
   50    ENDDO Lower_convolution_loop
!
         NC(K)=I
!
! --- Calculation of convolution, arg. of kernel to infinity
!
         X=1./R*EXP(-0.141555714)    ! To be exact: EXP(-0.1415557141054993)
!
         Upper_convolution_loop:  DO I=1,NF
!
            IJ=I0F+I
!
! --- Check for limits to convolution, arg. of kernel to infinity.
!     Exit if the IJ runs out of the filters range
!
            IF (IJ>NF) THEN
!
!               WRITE (4,222) R
!
!****   EXIT upper convolution loop due to exhaustion of filters
!
               EXIT
!
            ENDIF
!
            X=X*E
            IG=I0G-IGSH+I
            IF (INR(IG)<0) THEN
               CALL ONE_D_KERNEL(KEYG,KEMD,MLAYER,ZBND,LRYTH,HVK,KKH,KANIS,  &
                         KPRM,KRHO,KITG,KCHRG,NOB,NSR,ZOB,(ZSRH+ZSRL)/2.,    &
                         ZSRH,ZSRL,X,FKN)
               FC0(1:3,IG)=FKN(1:3)
               FC0(4:5,IG)=FKN(7:8)
               FC1(1:3,IG)=FKN(4:6)
               FC1(4:6,IG)=FKN(9:11)
               INR(IG)=1
            ENDIF
!
            DO J=1,5
               SDEL0(J)=FILT0(IJ)*FC0(J,IG)
               SDEL1(J)=FILT1(IJ)*FC1(J,IG)
               SUM0(J)=SUM0(J)+SDEL0(J)
               SUM1(J)=SUM1(J)+SDEL1(J)
            ENDDO
            SDEL1(6)=FILT1(IJ)*FC1(6,IG)
            SUM1(6)=SUM1(6)+SDEL1(6)
!
            DO J=1,5
               IF (CABS(SDEL0(J))>(1.E-28+CABS(SUM0(J)))*EPS) GOTO 100
               IF (CABS(SDEL1(J))>(1.E-28+CABS(SUM1(J)))*EPS) GOTO 100
            ENDDO
            IF (CABS(SDEL1(6))>(1.E-28+CABS(SUM1(6)))*EPS) GOTO 100
!
!****   Proper EXIT of upper convolution loop upon convergence
!
            EXIT
!
  100    ENDDO Upper_convolution_loop
!
         NC(K)=NC(K)+I
!
         HF(1:3,K)=SUM0(1:3)
         HF(7:8,K)=SUM0(4:5)
         HF(4:6,K)=SUM1(1:3)
         HF(9:11,K)=SUM1(4:6)
!
         RRG(K)=R
!
      ENDDO R_loop
!
      RETURN
!
!  111    FORMAT (1X,'Convolution truncated for argument of kernel ',
!       'function going towards zero',/,'for distance ',F11.3,' M')
!  222    FORMAT (1X,'Convolution truncated for argument of kernel ',
!     'function going towards infinity',/,'for distance ',F11.3,' M')
!
   END SUBROUTINE HFILL
!
!
!     B L O C K   D A T A   J 0 C O E F
!
!     BLOCK DATA J0COF CONTAINS THE FILTERCOEFFICIENTS OF THE
!     J0 TRANSFORM USED IN THE SUBROUTINE HFIL
!
!     15-per-decade filters for an opening angle of analyticity
!     of 0.32 pi with an optimized shift of 0.1415557141054993.
!
!     Accuracy of the filter: 0.4001E-08
!
!
      BLOCK DATA J0COF
      REAL :: FILT0(401),J01(76),J02(76),J03(76),J04(76),J05(76),   &
                    J06(21)
      EQUIVALENCE (FILT0(1),J01(1)),(FILT0(77),J02(1)),   &
                (FILT0(153),J03(1)),(FILT0(229),J04(1)),   &
                (FILT0(305),J05(1)),(FILT0(381),J06(1))
      COMMON /J0BLK/ FILT0
!
      DATA J01 /   &
     2.87065431E-18, 3.34693720E-18, 3.90224228E-18, 4.54968047E-18,   &
     5.30453798E-18, 6.18463723E-18, 7.21075761E-18, 8.40712614E-18,   &
     9.80198944E-18, 1.14282806E-17, 1.33243970E-17, 1.55351063E-17,   &
     1.81126042E-17, 2.11177461E-17, 2.46214843E-17, 2.87065431E-17,   &
     3.34693720E-17, 3.90224228E-17, 4.54968047E-17, 5.30453798E-17,   &
     6.18463723E-17, 7.21075761E-17, 8.40712614E-17, 9.80198944E-17,   &
     1.14282806E-16, 1.33243970E-16, 1.55351063E-16, 1.81126042E-16,   &
     2.11177461E-16, 2.46214843E-16, 2.87065431E-16, 3.34693720E-16,   &
     3.90224228E-16, 4.54968047E-16, 5.30453798E-16, 6.18463723E-16,   &
     7.21075761E-16, 8.40712614E-16, 9.80198944E-16, 1.14282806E-15,   &
     1.33243970E-15, 1.55351063E-15, 1.81126042E-15, 2.11177461E-15,   &
     2.46214843E-15, 2.87065431E-15, 3.34693720E-15, 3.90224228E-15,   &
     4.54968047E-15, 5.30453798E-15, 6.18463723E-15, 7.21075761E-15,   &
     8.40712614E-15, 9.80198944E-15, 1.14282806E-14, 1.33243970E-14,   &
     1.55351063E-14, 1.81126042E-14, 2.11177461E-14, 2.46214843E-14,   &
     2.87065431E-14, 3.34693720E-14, 3.90224228E-14, 4.54968047E-14,   &
     5.30453798E-14, 6.18463723E-14, 7.21075761E-14, 8.40712614E-14,   &
     9.80198944E-14, 1.14282806E-13, 1.33243970E-13, 1.55351063E-13,   &
     1.81126042E-13, 2.11177461E-13, 2.46214843E-13, 2.87065431E-13/
      DATA J02 /   &
     3.34693720E-13, 3.90224228E-13, 4.54968047E-13, 5.30453798E-13,   &
     6.18463723E-13, 7.21075761E-13, 8.40712614E-13, 9.80198944E-13,   &
     1.14282806E-12, 1.33243970E-12, 1.55351063E-12, 1.81126042E-12,   &
     2.11177461E-12, 2.46214843E-12, 2.87065431E-12, 3.34693720E-12,   &
     3.90224228E-12, 4.54968047E-12, 5.30453798E-12, 6.18463723E-12,   &
     7.21075761E-12, 8.40712614E-12, 9.80198944E-12, 1.14282806E-11,   &
     1.33243970E-11, 1.55351063E-11, 1.81126042E-11, 2.11177461E-11,   &
     2.46214843E-11, 2.87065431E-11, 3.34693720E-11, 3.90224228E-11,   &
     4.54968047E-11, 5.30453798E-11, 6.18463723E-11, 7.21075761E-11,   &
     8.40712614E-11, 9.80198944E-11, 1.14282806E-10, 1.33243970E-10,   &
     1.55351063E-10, 1.81126042E-10, 2.11177461E-10, 2.46214843E-10,   &
     2.87065431E-10, 3.34693720E-10, 3.90224228E-10, 4.54968047E-10,   &
     5.30453798E-10, 6.18463723E-10, 7.21075761E-10, 8.40712614E-10,   &
     9.80198944E-10, 1.14282806E-09, 1.33243970E-09, 1.55351063E-09,   &
     1.81126042E-09, 2.11177461E-09, 2.46214843E-09, 2.87065431E-09,   &
     3.34693720E-09, 3.90224228E-09, 4.54968047E-09, 5.30453798E-09,   &
     6.18463723E-09, 7.21075761E-09, 8.40712614E-09, 9.80198944E-09,   &
     1.14282806E-08, 1.33243970E-08, 1.55351063E-08, 1.81126042E-08,   &
     2.11177461E-08, 2.46214843E-08, 2.87065431E-08, 3.34693720E-08/
      DATA J03 /   &
     3.90224228E-08, 4.54968047E-08, 5.30453798E-08, 6.18463723E-08,   &
     7.21075761E-08, 8.40712614E-08, 9.80198944E-08, 1.14282806E-07,   &
     1.33243970E-07, 1.55351063E-07, 1.81126042E-07, 2.11177461E-07,   &
     2.46214843E-07, 2.87065431E-07, 3.34693720E-07, 3.90224228E-07,   &
     4.54968047E-07, 5.30453798E-07, 6.18463723E-07, 7.21075761E-07,   &
     8.40712614E-07, 9.80198944E-07, 1.14282806E-06, 1.33243970E-06,   &
     1.55351063E-06, 1.81126042E-06, 2.11177461E-06, 2.46214843E-06,   &
     2.87065431E-06, 3.34693720E-06, 3.90224228E-06, 4.54968047E-06,   &
     5.30453798E-06, 6.18463722E-06, 7.21075761E-06, 8.40712613E-06,   &
     9.80198943E-06, 1.14282806E-05, 1.33243970E-05, 1.55351063E-05,   &
     1.81126041E-05, 2.11177460E-05, 2.46214841E-05, 2.87065428E-05,   &
     3.34693716E-05, 3.90224222E-05, 4.54968037E-05, 5.30453783E-05,   &
     6.18463698E-05, 7.21075721E-05, 8.40712551E-05, 9.80198844E-05,   &
     1.14282791E-04, 1.33243945E-04, 1.55351024E-04, 1.81125979E-04,   &
     2.11177361E-04, 2.46214684E-04, 2.87065180E-04, 3.34693322E-04,   &
     3.90223598E-04, 4.54967048E-04, 5.30452215E-04, 6.18461213E-04,   &
     7.21071783E-04, 8.40706310E-04, 9.80188952E-04, 1.14281223E-03,   &
     1.33241460E-03, 1.55347086E-03, 1.81119738E-03, 2.11167469E-03,   &
     2.46199007E-03, 2.87040334E-03, 3.34653944E-03, 3.90161188E-03/
      DATA J04 /   &
     4.54868137E-03, 5.30295454E-03, 6.18212771E-03, 7.20678044E-03,   &
     8.40082307E-03, 9.79200041E-03, 1.14124506E-02, 1.32993111E-02,   &
     1.54953546E-02, 1.80496165E-02, 2.10179485E-02, 2.44633830E-02,   &
     2.84561142E-02, 3.30727806E-02, 3.83945388E-02, 4.45031197E-02,   &
     5.14736016E-02, 5.93619503E-02, 6.81843807E-02, 7.78842097E-02,   &
     8.82800769E-02, 9.89874216E-02, 1.09303673E-01, 1.18048811E-01,   &
     1.23361519E-01, 1.22476901E-01, 1.11572863E-01, 8.58971633E-02,   &
     4.06059055E-02,-2.69568319E-02,-1.12628810E-01,-1.98185246E-01,   &
    -2.44343000E-01,-1.94732733E-01,-1.24397970E-02, 2.35873580E-01,   &
     3.12450410E-01,-9.44123562E-03,-3.87660057E-01, 4.49548570E-03,   &
     4.13817274E-01,-4.18831226E-01, 2.40369307E-01,-1.00474404E-01,   &
     3.41489331E-02,-1.00624245E-02, 2.68559099E-03,-6.73153626E-04,   &
     1.63267246E-04,-3.90482717E-05, 9.28958411E-06,-2.20560148E-06,   &
     5.23277296E-07,-1.24112646E-07, 2.94349396E-08,-6.98103957E-09,   &
     1.65593565E-09,-3.92966591E-10, 9.33610703E-11,-2.22470443E-11,   &
     5.34223603E-12,-1.30809232E-12, 3.35731723E-13,-9.54220365E-14,   &
     3.24134978E-14,-1.37441203E-14, 7.00930351E-15,-3.98362871E-15,   &
     2.38179010E-15,-1.45447107E-15, 8.95658593E-16,-5.53328136E-16,   &
     3.42267983E-16,-2.11819831E-16, 1.31113348E-16,-8.11613944E-17/
      DATA J05 /   &
     5.02435622E-17,-3.11033761E-17, 1.92543144E-17,-1.19194862E-17,   &
     7.37882574E-18,-4.56781773E-18, 2.82773434E-18,-1.75052547E-18,   &
     1.08367304E-18,-6.70841339E-19, 4.15288250E-19,-2.57086605E-19,   &
     1.59144885E-19,-9.85214433E-20, 6.09902700E-20,-3.77563781E-20,   &
     2.33724121E-20,-1.44688262E-20, 8.95718061E-21,-5.54478256E-21,   &
     3.43252926E-21,-2.12492682E-21, 1.31542300E-21,-8.14320058E-22,   &
     5.04109447E-22,-3.12071796E-22, 1.93186129E-22,-1.19592958E-22,   &
     7.40346923E-23,-4.58307182E-23, 2.83717624E-23,-1.75636974E-23,   &
     1.08726976E-23,-6.73080403E-24, 4.16674143E-24,-2.57944426E-24,   &
     1.59675850E-24,-9.88482145E-25, 6.11925287E-25,-3.78815693E-25,   &
     2.34507926E-25,-1.45173411E-25, 8.98703877E-26,-5.56326389E-26,   &
     3.44396857E-26,-2.13200736E-26, 1.31983062E-26,-8.17048271E-27,   &
     5.05798105E-27,-3.13105129E-27, 1.93829404E-27,-1.19991126E-27,   &
     7.42783257E-28,-4.59823919E-28, 2.84656426E-28,-1.76218064E-28,   &
     1.09092857E-28,-6.75345043E-29, 4.18044194E-29,-2.58802253E-29,   &
     1.60212885E-29,-9.91806183E-30, 6.13982768E-30,-3.80089214E-30,   &
     2.35278363E-30,-1.45650281E-30, 9.01655563E-31,-5.58174493E-31,   &
     3.45540779E-31,-2.13916879E-31, 1.32426333E-31,-8.19729908E-32,   &
     5.07457960E-32,-3.14144410E-32, 1.94472683E-32,-1.20389291E-32/
      DATA J06 /   &
     7.45275953E-33,-4.61366813E-33, 2.85600623E-33,-1.76802491E-33,   &
     1.09450461E-33,-6.77558513E-34, 4.19445951E-34,-2.59660080E-34,   &
     1.60743847E-34,-9.95055086E-35, 6.15993712E-35,-3.81333929E-35,   &
     2.36066622E-35,-1.46138190E-35, 9.04675557E-36,-5.60022625E-36,   &
     3.46684701E-36,-2.14616839E-36, 1.32859582E-36,-8.22473604E-37,   &
     5.09156200E-37/
!
   END BLOCK DATA J0COF
!
!
!     B L O C K   D A T A   J 1 C O E F
!
!     BLOCK DATA J1COF CONTAINS THE FILTERCOEFFICIENTS OF THE
!     J1 TRANSFORM USED IN THE SUBROUTINE HFIL
!
!     15-per-decade filters for an opening angle of analyticity
!     of 0.32 pi with a shift of 0.1415557141054993 optimized
!     for the Jo fitlers.
!
!     Accuracy of the filters: 0.8001E-07
!
      BLOCK DATA J1COF
      REAL :: FILT1(401),J11(76),J12(76),J13(76),J14(76),J15(76),   &
                    J16(21)
      EQUIVALENCE (FILT1(1),J11(1)),(FILT1(77),J12(1)),   &
                (FILT1(153),J13(1)),(FILT1(229),J14(1)),   &
                (FILT1(305),J15(1)),(FILT1(381),J16(1))
      COMMON /J1BLK/ FILT1
!
      DATA J11 /   &
     2.68415363E-35, 3.64872140E-35, 4.95991275E-35, 6.74228909E-35,   &
     9.16517377E-35, 1.24587375E-34, 1.69358645E-34, 2.30218756E-34,   &
     3.12949338E-34, 4.25409682E-34, 5.78283370E-34, 7.86093195E-34,   &
     1.06858081E-33, 1.45258215E-33, 1.97457683E-33, 2.68415363E-33,   &
     3.64872140E-33, 4.95991275E-33, 6.74228909E-33, 9.16517377E-33,   &
     1.24587375E-32, 1.69358645E-32, 2.30218756E-32, 3.12949338E-32,   &
     4.25409682E-32, 5.78283370E-32, 7.86093195E-32, 1.06858081E-31,   &
     1.45258215E-31, 1.97457683E-31, 2.68415363E-31, 3.64872140E-31,   &
     4.95991275E-31, 6.74228909E-31, 9.16517377E-31, 1.24587375E-30,   &
     1.69358645E-30, 2.30218756E-30, 3.12949338E-30, 4.25409682E-30,   &
     5.78283370E-30, 7.86093195E-30, 1.06858081E-29, 1.45258215E-29,   &
     1.97457683E-29, 2.68415363E-29, 3.64872140E-29, 4.95991275E-29,   &
     6.74228909E-29, 9.16517377E-29, 1.24587375E-28, 1.69358645E-28,   &
     2.30218756E-28, 3.12949338E-28, 4.25409682E-28, 5.78283370E-28,   &
     7.86093195E-28, 1.06858081E-27, 1.45258215E-27, 1.97457683E-27,   &
     2.68415363E-27, 3.64872140E-27, 4.95991275E-27, 6.74228909E-27,   &
     9.16517377E-27, 1.24587375E-26, 1.69358645E-26, 2.30218756E-26,   &
     3.12949338E-26, 4.25409682E-26, 5.78283370E-26, 7.86093195E-26,   &
     1.06858081E-25, 1.45258215E-25, 1.97457683E-25, 2.68415363E-25/
      DATA J12 /   &
     3.64872140E-25, 4.95991275E-25, 6.74228909E-25, 9.16517377E-25,   &
     1.24587375E-24, 1.69358645E-24, 2.30218756E-24, 3.12949338E-24,   &
     4.25409682E-24, 5.78283370E-24, 7.86093195E-24, 1.06858081E-23,   &
     1.45258215E-23, 1.97457683E-23, 2.68415363E-23, 3.64872140E-23,   &
     4.95991275E-23, 6.74228909E-23, 9.16517377E-23, 1.24587375E-22,   &
     1.69358645E-22, 2.30218756E-22, 3.12949338E-22, 4.25409682E-22,   &
     5.78283370E-22, 7.86093195E-22, 1.06858081E-21, 1.45258215E-21,   &
     1.97457683E-21, 2.68415363E-21, 3.64872140E-21, 4.95991275E-21,   &
     6.74228909E-21, 9.16517377E-21, 1.24587375E-20, 1.69358645E-20,   &
     2.30218756E-20, 3.12949338E-20, 4.25409682E-20, 5.78283370E-20,   &
     7.86093195E-20, 1.06858081E-19, 1.45258215E-19, 1.97457683E-19,   &
     2.68415363E-19, 3.64872140E-19, 4.95991275E-19, 6.74228909E-19,   &
     9.16517377E-19, 1.24587375E-18, 1.69358645E-18, 2.30218756E-18,   &
     3.12949338E-18, 4.25409682E-18, 5.78283370E-18, 7.86093195E-18,   &
     1.06858081E-17, 1.45258215E-17, 1.97457683E-17, 2.68415363E-17,   &
     3.64872140E-17, 4.95991275E-17, 6.74228909E-17, 9.16517377E-17,   &
     1.24587375E-16, 1.69358645E-16, 2.30218756E-16, 3.12949338E-16,   &
     4.25409682E-16, 5.78283370E-16, 7.86093195E-16, 1.06858081E-15,   &
     1.45258215E-15, 1.97457683E-15, 2.68415363E-15, 3.64872140E-15/
      DATA J13 /   &
     4.95991275E-15, 6.74228909E-15, 9.16517377E-15, 1.24587375E-14,   &
     1.69358645E-14, 2.30218756E-14, 3.12949338E-14, 4.25409682E-14,   &
     5.78283370E-14, 7.86093195E-14, 1.06858081E-13, 1.45258215E-13,   &
     1.97457683E-13, 2.68415363E-13, 3.64872140E-13, 4.95991275E-13,   &
     6.74228909E-13, 9.16517376E-13, 1.24587375E-12, 1.69358645E-12,   &
     2.30218756E-12, 3.12949338E-12, 4.25409682E-12, 5.78283370E-12,   &
     7.86093196E-12, 1.06858081E-11, 1.45258215E-11, 1.97457683E-11,   &
     2.68415364E-11, 3.64872139E-11, 4.95991276E-11, 6.74228907E-11,   &
     9.16517379E-11, 1.24587375E-10, 1.69358646E-10, 2.30218755E-10,   &
     3.12949339E-10, 4.25409679E-10, 5.78283375E-10, 7.86093186E-10,   &
     1.06858082E-09, 1.45258213E-09, 1.97457686E-09, 2.68415357E-09,   &
     3.64872146E-09, 4.95991257E-09, 6.74228925E-09, 9.16517326E-09,   &
     1.24587379E-08, 1.69358631E-08, 2.30218763E-08, 3.12949297E-08,   &
     4.25409693E-08, 5.78283250E-08, 7.86093200E-08, 1.06858045E-07,   &
     1.45258208E-07, 1.97457575E-07, 2.68415318E-07, 3.64871807E-07,   &
     4.95991062E-07, 6.74227866E-07, 9.16516498E-07, 1.24587044E-06,   &
     1.69358305E-06, 2.30217687E-06, 3.12948076E-06, 4.25406197E-06,   &
     5.78278794E-06, 7.86081726E-06, 1.06856448E-05, 1.45254412E-05,   &
     1.97451926E-05, 2.68402673E-05, 3.64852005E-05, 4.95948712E-05/
      DATA J14 /   &
     6.74158915E-05, 9.16374058E-05, 1.24563151E-04, 1.69310235E-04,   &
     2.30135200E-04, 3.12785420E-04, 4.25122195E-04, 5.77727319E-04,   &
     7.85105978E-04, 1.06669197E-03, 1.44919742E-03, 1.96815477E-03,   &
     2.67256480E-03, 3.62687618E-03, 4.92028882E-03, 6.66798741E-03,   &
     9.02991900E-03, 1.22062442E-02, 1.64752875E-02, 2.21657575E-02,   &
     2.97327167E-02, 3.96513407E-02, 5.25658762E-02, 6.89409168E-02,   &
     8.93500131E-02, 1.13434944E-01, 1.40517821E-01, 1.66814097E-01,   &
     1.87264863E-01, 1.89364995E-01, 1.61060719E-01, 8.15845262E-02,   &
    -4.57409574E-02,-2.03869309E-01,-2.83167704E-01,-1.89808486E-01,   &
     1.51397346E-01, 3.39867954E-01, 5.39374572E-02,-4.74219029E-01,   &
     2.76081898E-01, 6.96051968E-02,-2.13923811E-01, 2.01080806E-01,   &
    -1.44372487E-01, 9.42258544E-02,-5.94817835E-02, 3.71071447E-02,   &
    -2.30417725E-02, 1.42803764E-02,-8.84350132E-03, 5.47488643E-03,   &
    -3.38902013E-03, 2.09774759E-03,-1.29844829E-03, 8.03698482E-04,   &
    -4.97462689E-04, 3.07912591E-04,-1.90587414E-04, 1.17967105E-04,   &
    -7.30176085E-05, 4.51954044E-05,-2.79744107E-05, 1.73152040E-05,   &
    -1.07175195E-05, 6.63377821E-06,-4.10608196E-06, 2.54152438E-06,   &
    -1.57311672E-06, 9.73705480E-07,-6.02690410E-07, 3.73044763E-07,   &
    -2.30901957E-07, 1.42920419E-07,-8.84628542E-08, 5.47554830E-08/
      DATA J15 /   &
    -3.38917724E-08, 2.09778486E-08,-1.29845713E-08, 8.03700578E-09,   &
    -4.97463186E-09, 3.07912709E-09,-1.90587442E-09, 1.17967112E-09,   &
    -7.30176101E-10, 4.51954048E-10,-2.79744108E-10, 1.73152041E-10,   &
    -1.07175195E-10, 6.63377821E-11,-4.10608196E-11, 2.54152438E-11,   &
    -1.57311672E-11, 9.73705480E-12,-6.02690410E-12, 3.73044763E-12,   &
    -2.30901957E-12, 1.42920419E-12,-8.84628542E-13, 5.47554830E-13,   &
    -3.38917724E-13, 2.09778486E-13,-1.29845713E-13, 8.03700578E-14,   &
    -4.97463186E-14, 3.07912709E-14,-1.90587442E-14, 1.17967112E-14,   &
    -7.30176101E-15, 4.51954048E-15,-2.79744108E-15, 1.73152041E-15,   &
    -1.07175195E-15, 6.63377821E-16,-4.10608196E-16, 2.54152438E-16,   &
    -1.57311672E-16, 9.73705480E-17,-6.02690410E-17, 3.73044763E-17,   &
    -2.30901957E-17, 1.42920419E-17,-8.84628542E-18, 5.47554830E-18,   &
    -3.38917724E-18, 2.09778486E-18,-1.29845713E-18, 8.03700578E-19,   &
    -4.97463186E-19, 3.07912709E-19,-1.90587442E-19, 1.17967112E-19,   &
    -7.30176101E-20, 4.51954048E-20,-2.79744108E-20, 1.73152041E-20,   &
    -1.07175195E-20, 6.63377821E-21,-4.10608196E-21, 2.54152438E-21,   &
    -1.57311672E-21, 9.73705480E-22,-6.02690410E-22, 3.73044763E-22,   &
    -2.30901957E-22, 1.42920419E-22,-8.84628542E-23, 5.47554830E-23,   &
    -3.38917724E-23, 2.09778486E-23,-1.29845713E-23, 8.03700578E-24/
      DATA J16 /   &
    -4.97463186E-24, 3.07912709E-24,-1.90587442E-24, 1.17967112E-24,   &
    -7.30176101E-25, 4.51954048E-25,-2.79744108E-25, 1.73152041E-25,   &
    -1.07175195E-25, 6.63377821E-26,-4.10608196E-26, 2.54152438E-26,   &
    -1.57311672E-26, 9.73705480E-27,-6.02690410E-27, 3.73044763E-27,   &
    -2.30901957E-27, 1.42920419E-27,-8.84628542E-28, 5.47554830E-28,   &
    -3.38917724E-28/

!
   END BLOCK DATA J1COF
!
!
   SUBROUTINE HFILH(KEYG,KEMD,MLAYER,ZBND,LRYTH,HVK,KKH,KANIS,KPRM,KITG,   &
                    KCHRG,NOB,NSR,RLO,RHI,ZOB,ZSRH,ZSRL,NRG,RRG,HF)
!
!****  HANKEL TRANSFORMATIONS BY DIGITAL LINEAR FILTERING
!      for computing normal responses
!
!      The filters used here yield an accuracy of about 0.4E-8.
!
!      This routine is based on a filtering routine provided by
!      N. Christensen.  Though the routine has been restructured,
!      it still retains the basic original designs of Christensen
!      because of their efficience.
!
!   Input parameters:
!
!      RLO:  real (*4), minimum of rho.
!      RHI:  real     , maximumof rho.
!
!      The parameters KEMD, MLAYER, ZBND, LRYTH, HVK, KKH, KANIS, KPRM,
!      KITG, KCHRG, NOB, NSR, ZOB,  ZSRH and ZSRL are to be passed
!      to routine kernel.  See routine kernel for their descriptions.
!
!
!   Output parameters:
!
!      NRG:  integer (*4), number of data point returned.
!      RRG:  real RRG(nhfil), the discrete values of rho on
!            logrithmic scale on which results of the Hankel
!            transforms are returned.
!      HF:   complex(11,nhfil), the nhfil columns of the
!            11 components of the Hankel transforms of the
!            Green's tensors.  Note that the values contained
!            in HF must be divided by rho in order to get the
!            actual Hankel transforms.
!
!****  CALLED by:  gridhf, gridcs
!
!****  CALLS    :  kernel
!
!
!
      IMPLICIT NONE
!
      INTEGER, PARAMETER :: NHFILM=301
!
      INTEGER, INTENT(IN) :: KEYG,KEMD,MLAYER,KANIS,KPRM,KITG,KCHRG,NOB,NSR
      INTEGER, INTENT(OUT) :: NRG
      REAL, INTENT(INOUT) :: RRG(NHFILM),RLO,RHI
      COMPLEX, INTENT(INOUT) :: HF(11,NHFILM)
!
      INTEGER ::  NC(NHFILM),INR(1001),NLO,NHI,NF,I0F,I0G,IGSH,   &
                  NLIM,KRHO
      REAL :: FILT0(600),FILT1(600),DEL,R1,E,R
      COMPLEX :: FC0(5,1001),FC1(6,1001),                         &
                 SUM0(5),SUM1(6),SDEL0(5),SDEL1(6),FKN(11)
      COMMON /J0BLK2/FILT0 /J1BLK2/FILT1
!
      REAL, PARAMETER :: EPS=1.E-7
      REAL :: X
      INTEGER ::  I,IG,IJ,J,K
!
!  -- Parameters to be passed to the routine kernel
!
      COMPLEX, INTENT(IN) :: KKH(0:MLAYER)
      REAL, INTENT(IN) :: LRYTH(MLAYER),HVK(0:MLAYER),ZBND(0:MLAYER),   &
                          ZOB,ZSRH,ZSRL
!
!  -- Parameter KRHO is required by routine ONE_D_KERNEL.
!     KRHO=1 means rho (or R in this routine) .ne. zero
!
      KRHO=1
!
!  -- Inititalizations
!
!     NLO, NHI, NRG, R1,  and E are determined by DEL,  RLO,  and RHI
!
      DEL=ALOG(10.)/50.
      NLO=INT(ALOG(RLO)/DEL+100.)-101
      IF (NLO<-100) NLO=-100
      NHI=INT(ALOG(RHI)/DEL+100.)-98
      IF (NHI>200) NHI=200
      NRG=NHI-NLO+1
      R1=EXP(NLO*DEL)
      E=EXP(DEL)
!
! -- I0G=I0F+NHI
!    NG=I0G+(NF-I0F)+abs(NLO)+1
!    NG=1001 is the dimension of the arrays INR, FC0,  and FC1
!
      NLIM=60; NF=600; I0F=401; I0G=701; INR=-1
!
      R=R1/E
      IGSH=INT(ALOG(R)/DEL+100.5)-100
!
      R_loop:  DO K=1,NRG   !  This loop computes the discreted values of
                            !  the Hankel integrals at discreted points of
                            !  R on a logarithmic scale determined by DEL.
                            !  All transforms are returned simultaneously.
!
         R=R*E
!
! --- The evaluation of IGSH has been moved to the top of the do loop
!     since the value of R may not be very accurate if it is large.
!        IGSH=INT(ALOG(R)/DEL+100.5)-100
!
         IGSH=IGSH+1
!
         X=E/R
         SUM0=(0.,0.);  SUM1=(0.,0.)
!
         Lower_convolution_loop:  DO I=1,NF
!
            IJ=I0F-I+1
!
! --- Calculation of convolution, arg. of kernel to zero
!
!   -- Check for limits to convolution, arg. of kernel to zero.
!      Exit if the IJ runs out of the filters range
!
            IF (IJ<1) THEN
!
!               WRITE (4,111) R
!
!**** EXIT lower convolution loop due to exhaustion of filters
!
               EXIT
!
            ENDIF
!
            X=X/E
            IG=I0G-IGSH-I+1
            IF (INR(IG)<0) THEN
               CALL ONE_D_KERNEL(KEYG,KEMD,MLAYER,ZBND,LRYTH,HVK,KKH,KANIS, &
                           KPRM,KRHO,KITG,KCHRG,NOB,NSR,ZOB,(ZSRH+ZSRL)/2., &
                           ZSRH,ZSRL,X,FKN)
               FC0(1:3,IG)=FKN(1:3)
               FC0(4:5,IG)=FKN(7:8)
               FC1(1:3,IG)=FKN(4:6)
               FC1(4:6,IG)=FKN(9:11)
               INR(IG)=1
            ENDIF
!
            DO J=1,5
               SDEL0(J)=FILT0(IJ)*FC0(J,IG)
               SDEL1(J)=FILT1(IJ)*FC1(J,IG)
               SUM0(J)=SUM0(J)+SDEL0(J)
               SUM1(J)=SUM1(J)+SDEL1(J)
            ENDDO
            SDEL1(6)=FILT1(IJ)*FC1(6,IG)
            SUM1(6)=SUM1(6)+SDEL1(6)
!
            IF (I>NLIM) THEN
               DO J=1,5
!
! --- Use 1.E-28 so that its product with EPS is larger
!     than 1.E-38 to avoid possible problems on some machines
!
                  IF (CABS(SDEL0(J))>(1.E-28+CABS(SUM0(J)))*EPS) GOTO 50
                  IF (CABS(SDEL1(J))>(1.E-28+CABS(SUM1(J)))*EPS) GOTO 50
               ENDDO
               IF (CABS(SDEL1(6))>(1.E-28+CABS(SUM1(6)))*EPS) GOTO 50
!
!****   Proper EXIT of lower convolution loop upon convergence
!
               EXIT
!
            ENDIF
!
   50    ENDDO Lower_convolution_loop
!
         NC(K)=I
!
! --- Calculation of convolution, arg. of kernel to infinity
!
         X=1./R
!
         Upper_convolution_loop:  DO I=1,NF
!
            IJ=I0F+I
!
! --- Check for limits to convolution, arg. of kernel to infinity.
!     Exit if the IJ runs out of the filters range
!
            IF (IJ>NF) THEN
!
!               WRITE (4,222) R
!
!****   EXIT upper convolution loop due to exhaustion of filters
!
               EXIT
!
            ENDIF
!
            X=X*E
            IG=I0G-IGSH+I
            IF (INR(IG)<0) THEN
               CALL ONE_D_KERNEL(KEYG,KEMD,MLAYER,ZBND,LRYTH,HVK,KKH,KANIS,  &
                         KPRM,KRHO,KITG,KCHRG,NOB,NSR,ZOB,(ZSRH+ZSRL)/2.,    &
                         ZSRH,ZSRL,X,FKN)
               FC0(1:3,IG)=FKN(1:3)
               FC0(4:5,IG)=FKN(7:8)
               FC1(1:3,IG)=FKN(4:6)
               FC1(4:6,IG)=FKN(9:11)
               INR(IG)=1
            ENDIF
!
            DO J=1,5
               SDEL0(J)=FILT0(IJ)*FC0(J,IG)
               SDEL1(J)=FILT1(IJ)*FC1(J,IG)
               SUM0(J)=SUM0(J)+SDEL0(J)
               SUM1(J)=SUM1(J)+SDEL1(J)
            ENDDO
            SDEL1(6)=FILT1(IJ)*FC1(6,IG)
            SUM1(6)=SUM1(6)+SDEL1(6)
!
            DO J=1,5
               IF (CABS(SDEL0(J))>(1.E-28+CABS(SUM0(J)))*EPS) GOTO 100
               IF (CABS(SDEL1(J))>(1.E-28+CABS(SUM1(J)))*EPS) GOTO 100
            ENDDO
            IF (CABS(SDEL1(6))>(1.E-28+CABS(SUM1(6)))*EPS) GOTO 100
!
!****   Proper EXIT of upper convolution loop upon convergence
!
            EXIT
!
  100    ENDDO Upper_convolution_loop
!
         NC(K)=NC(K)+I
!
         HF(1:3,K)=SUM0(1:3)
         HF(7:8,K)=SUM0(4:5)
         HF(4:6,K)=SUM1(1:3)
         HF(9:11,K)=SUM1(4:6)
!
         RRG(K)=R
!
      ENDDO R_loop
!
      RETURN
!
!  111    FORMAT (1X,'Convolution truncated for argument of kernel ',
!       'function going towards zero',/,'for distance ',F11.3,' M')
!  222    FORMAT (1X,'Convolution truncated for argument of kernel ',
!     'function going towards infinity',/,'for distance ',F11.3,' M')
!
   END SUBROUTINE HFILH
!
!
!     B L O C K   D A T A   J 0 C O E F
!
!     BLOCK DATA J0COF CONTAINS THE FILTERCOEFFICIENTS OF THE
!     J0 TRANSFORM USED IN THE SUBROUTINE HFIL
!
!     50-per-decade filters for functions with opening angle of
!     analyticity of 0.1 pi (optimized).
!     Accuracy of the filter: 056E-08
!
      BLOCK DATA J0COF2
! ------
      REAL FILT0(600),J01(76),J02(76),J03(76),J04(72),   &
                J05(76),J06(76),J07(76),J08(72)
      EQUIVALENCE (FILT0(1),J01(1)),(FILT0(77),J02(1)),   &
            (FILT0(153),J03(1)),(FILT0(229),J04(1)),   &
            (FILT0(301),J05(1)),(FILT0(377),J06(1)),   &
            (FILT0(453),J07(1)),(FILT0(529),J08(1))
      COMMON /J0BLK2/ FILT0
! ----------
      DATA J01 /   &
       4.60517018E-10, 4.82220517E-10, 5.04946869E-10, 5.28744282E-10,   &
       5.53663232E-10, 5.79756577E-10, 6.07079662E-10, 6.35690445E-10,   &
       6.65649613E-10, 6.97020713E-10, 7.29870287E-10, 7.64268014E-10,   &
       8.00286856E-10, 8.38003213E-10, 8.77497088E-10, 9.18852252E-10,   &
       9.62156424E-10, 1.00750146E-09, 1.05498354E-09, 1.10470338E-09,   &
       1.15676645E-09, 1.21128317E-09, 1.26836919E-09, 1.32814559E-09,   &
       1.39073916E-09, 1.45628268E-09, 1.52491517E-09, 1.59678220E-09,   &
       1.67203623E-09, 1.75083687E-09, 1.83335127E-09, 1.91975445E-09,   &
       2.01022969E-09, 2.10496890E-09, 2.20417303E-09, 2.30805250E-09,   &
       2.41682767E-09, 2.53072925E-09, 2.64999884E-09, 2.77488944E-09,   &
       2.90566595E-09, 3.04260577E-09, 3.18599936E-09, 3.33615088E-09,   &
       3.49337883E-09, 3.65801670E-09, 3.83041372E-09, 4.01093555E-09,   &
       4.19996512E-09, 4.39790338E-09, 4.60517018E-09, 4.82220517E-09,   &
       5.04946869E-09, 5.28744282E-09, 5.53663232E-09, 5.79756577E-09,   &
       6.07079662E-09, 6.35690445E-09, 6.65649613E-09, 6.97020713E-09,   &
       7.29870287E-09, 7.64268014E-09, 8.00286856E-09, 8.38003213E-09,   &
       8.77497088E-09, 9.18852252E-09, 9.62156424E-09, 1.00750146E-08,   &
       1.05498354E-08, 1.10470338E-08, 1.15676645E-08, 1.21128317E-08,   &
       1.26836919E-08, 1.32814559E-08, 1.39073916E-08, 1.45628268E-08/
      DATA J02 /   &
       1.52491517E-08, 1.59678220E-08, 1.67203623E-08, 1.75083687E-08,   &
       1.83335127E-08, 1.91975445E-08, 2.01022969E-08, 2.10496890E-08,   &
       2.20417303E-08, 2.30805250E-08, 2.41682767E-08, 2.53072925E-08,   &
       2.64999884E-08, 2.77488944E-08, 2.90566595E-08, 3.04260577E-08,   &
       3.18599936E-08, 3.33615088E-08, 3.49337883E-08, 3.65801670E-08,   &
       3.83041372E-08, 4.01093555E-08, 4.19996512E-08, 4.39790338E-08,   &
       4.60517018E-08, 4.82220517E-08, 5.04946869E-08, 5.28744282E-08,   &
       5.53663232E-08, 5.79756577E-08, 6.07079662E-08, 6.35690445E-08,   &
       6.65649613E-08, 6.97020713E-08, 7.29870287E-08, 7.64268014E-08,   &
       8.00286856E-08, 8.38003213E-08, 8.77497088E-08, 9.18852252E-08,   &
       9.62156424E-08, 1.00750146E-07, 1.05498354E-07, 1.10470338E-07,   &
       1.15676645E-07, 1.21128317E-07, 1.26836919E-07, 1.32814559E-07,   &
       1.39073916E-07, 1.45628268E-07, 1.52491517E-07, 1.59678220E-07,   &
       1.67203623E-07, 1.75083687E-07, 1.83335127E-07, 1.91975445E-07,   &
       2.01022969E-07, 2.10496890E-07, 2.20417303E-07, 2.30805250E-07,   &
       2.41682767E-07, 2.53072925E-07, 2.64999884E-07, 2.77488944E-07,   &
       2.90566595E-07, 3.04260577E-07, 3.18599936E-07, 3.33615088E-07,   &
       3.49337883E-07, 3.65801670E-07, 3.83041372E-07, 4.01093555E-07,   &
       4.19996512E-07, 4.39790338E-07, 4.60517018E-07, 4.82220517E-07/
      DATA J03 /   &
       5.04946869E-07, 5.28744282E-07, 5.53663232E-07, 5.79756577E-07,   &
       6.07079662E-07, 6.35690445E-07, 6.65649613E-07, 6.97020713E-07,   &
       7.29870287E-07, 7.64268014E-07, 8.00286856E-07, 8.38003213E-07,   &
       8.77497088E-07, 9.18852252E-07, 9.62156424E-07, 1.00750146E-06,   &
       1.05498354E-06, 1.10470338E-06, 1.15676645E-06, 1.21128317E-06,   &
       1.26836919E-06, 1.32814559E-06, 1.39073916E-06, 1.45628268E-06,   &
       1.52491517E-06, 1.59678220E-06, 1.67203623E-06, 1.75083687E-06,   &
       1.83335127E-06, 1.91975445E-06, 2.01022969E-06, 2.10496890E-06,   &
       2.20417303E-06, 2.30805250E-06, 2.41682767E-06, 2.53072924E-06,   &
       2.64999884E-06, 2.77488944E-06, 2.90566595E-06, 3.04260576E-06,   &
       3.18599935E-06, 3.33615088E-06, 3.49337882E-06, 3.65801670E-06,   &
       3.83041371E-06, 4.01093555E-06, 4.19996511E-06, 4.39790337E-06,   &
       4.60517017E-06, 4.82220515E-06, 5.04946868E-06, 5.28744280E-06,   &
       5.53663230E-06, 5.79756574E-06, 6.07079660E-06, 6.35690442E-06,   &
       6.65649610E-06, 6.97020709E-06, 7.29870283E-06, 7.64268009E-06,   &
       8.00286850E-06, 8.38003206E-06, 8.77497080E-06, 9.18852243E-06,   &
       9.62156414E-06, 1.00750145E-05, 1.05498353E-05, 1.10470337E-05,   &
       1.15676643E-05, 1.21128315E-05, 1.26836917E-05, 1.32814556E-05,   &
       1.39073913E-05, 1.45628264E-05, 1.52491513E-05, 1.59678216E-05/
      DATA J04 /   &
       1.67203618E-05, 1.75083681E-05, 1.83335120E-05, 1.91975437E-05,   &
       2.01022960E-05, 2.10496879E-05, 2.20417290E-05, 2.30805236E-05,   &
       2.41682750E-05, 2.53072905E-05, 2.64999862E-05, 2.77488919E-05,   &
       2.90566566E-05, 3.04260543E-05, 3.18599898E-05, 3.33615044E-05,   &
       3.49337833E-05, 3.65801612E-05, 3.83041305E-05, 4.01093479E-05,   &
       4.19996425E-05, 4.39790238E-05, 4.60516903E-05, 4.82220384E-05,   &
       5.04946718E-05, 5.28744108E-05, 5.53663032E-05, 5.79756347E-05,   &
       6.07079399E-05, 6.35690143E-05, 6.65649265E-05, 6.97020314E-05,   &
       7.29869829E-05, 7.64267488E-05, 8.00286252E-05, 8.38002520E-05,   &
       8.77496292E-05, 9.18851337E-05, 9.62155374E-05, 1.00750025E-04,   &
       1.05498216E-04, 1.10470179E-04, 1.15676462E-04, 1.21128108E-04,   &
       1.26836678E-04, 1.32814283E-04, 1.39073599E-04, 1.45627904E-04,   &
       1.52491099E-04, 1.59677741E-04, 1.67203072E-04, 1.75083054E-04,   &
       1.83334401E-04, 1.91974611E-04, 2.01022012E-04, 2.10495791E-04,   &
       2.20416041E-04, 2.30803801E-04, 2.41681103E-04, 2.53071014E-04,   &
       2.64997690E-04, 2.77486425E-04, 2.90563703E-04, 3.04257256E-04,   &
       3.18596124E-04, 3.33610711E-04, 3.49332857E-04, 3.65795900E-04,   &
       3.83034747E-04, 4.01085949E-04, 4.19987779E-04, 4.39780311E-04/
      DATA J05 /   &
       4.60505505E-04, 4.82207298E-04, 5.04931692E-04, 5.28726857E-04,   &
       5.53643225E-04, 5.79733606E-04, 6.07053288E-04, 6.35660164E-04,   &
       6.65614845E-04, 6.96980794E-04, 7.29824454E-04, 7.64215391E-04,   &
       8.00226436E-04, 8.37933843E-04, 8.77417440E-04, 9.18760804E-04,   &
       9.62051428E-04, 1.00738091E-03, 1.05484513E-03, 1.10454447E-03,   &
       1.15658399E-03, 1.21107368E-03, 1.26812866E-03, 1.32786943E-03,   &
       1.39042209E-03, 1.45591863E-03, 1.52449719E-03, 1.59630230E-03,   &
       1.67148523E-03, 1.75020425E-03, 1.83262493E-03, 1.91892051E-03,   &
       2.00927221E-03, 2.10386957E-03, 2.20291084E-03, 2.30660334E-03,   &
       2.41516383E-03, 2.52881894E-03, 2.64780555E-03, 2.77237126E-03,   &
       2.90277475E-03, 3.03928631E-03, 3.18218821E-03, 3.33177523E-03,   &
       3.48835506E-03, 3.65224884E-03, 3.82379158E-03, 4.00333264E-03,   &
       4.19123621E-03, 4.38788176E-03, 4.59366445E-03, 4.80899561E-03,   &
       5.03430310E-03, 5.27003166E-03, 5.51664322E-03, 5.77461721E-03,   &
       6.04445067E-03, 6.32665842E-03, 6.62177303E-03, 6.93034469E-03,   &
       7.25294099E-03, 7.59014644E-03, 7.94256181E-03, 8.31080334E-03,   &
       8.69550146E-03, 9.09729939E-03, 9.51685123E-03, 9.95481962E-03,   &
       1.04118729E-02, 1.08886819E-02, 1.13859152E-02, 1.19042351E-02,   &
       1.24442908E-02, 1.30067124E-02, 1.35921022E-02, 1.42010252E-02/
      DATA J06 /   &
       1.48339985E-02, 1.54914777E-02, 1.61738426E-02, 1.68813792E-02,   &
       1.76142602E-02, 1.83725219E-02, 1.91560376E-02, 1.99644872E-02,   &
       2.07973230E-02, 2.16537299E-02, 2.25325805E-02, 2.34323846E-02,   &
       2.43512313E-02, 2.52867241E-02, 2.62359084E-02, 2.71951897E-02,   &
       2.81602430E-02, 2.91259114E-02, 3.00860955E-02, 3.10336309E-02,   &
       3.19601552E-02, 3.28559646E-02, 3.37098600E-02, 3.45089847E-02,   &
       3.52386557E-02, 3.58821911E-02, 3.64207388E-02, 3.68331127E-02,   &
       3.70956440E-02, 3.71820590E-02, 3.70633982E-02, 3.67079922E-02,   &
       3.60815204E-02, 3.51471762E-02, 3.38659754E-02, 3.21972468E-02,   &
       3.00993519E-02, 2.75306906E-02, 2.44510522E-02, 2.08233821E-02,   &
       1.66160357E-02, 1.18055894E-02, 6.38027816E-03, 3.44107043E-04,   &
      -6.27833813E-03,-1.34364048E-02,-2.10473034E-02,-2.89896424E-02,   &
      -3.70968931E-02,-4.51512855E-02,-5.28788597E-02,-5.99466655E-02,   &
      -6.59634116E-02,-7.04851845E-02,-7.30281623E-02,-7.30904525E-02,   &
      -7.01852087E-02,-6.38868657E-02,-5.38915096E-02,-4.00908342E-02,   &
      -2.26566059E-02,-2.12886922E-03, 2.05037869E-02, 4.37494922E-02,   &
       6.56077059E-02, 8.36421404E-02, 9.51627029E-02, 9.75421306E-02,   &
       8.86770131E-02, 6.75717609E-02, 3.49752624E-02,-6.06439764E-03,   &
      -4.99310726E-02,-8.87120321E-02,-1.13257605E-01,-1.15162686E-01/
      DATA J07 /   &
      -8.95365553E-02,-3.79967711E-02, 2.91956022E-02, 9.33401582E-02,   &
       1.31238982E-01, 1.23296106E-01, 6.40923137E-02,-2.90651232E-02,   &
      -1.16218757E-01,-1.48978992E-01,-9.78740373E-02, 1.96927747E-02,   &
       1.33529906E-01, 1.56211304E-01, 5.26261838E-02,-1.06190954E-01,   &
      -1.74441242E-01,-6.40940077E-02, 1.27718733E-01, 1.75015876E-01,   &
      -9.43249426E-03,-1.92356894E-01,-8.51707929E-02, 1.72634174E-01,   &
       1.29946071E-01,-1.68973353E-01,-1.27072974E-01, 2.02695179E-01,   &
       5.59069073E-02,-2.35399765E-01, 1.03760280E-01, 1.50478122E-01,   &
      -2.59977858E-01, 1.64370256E-01, 2.30311231E-02,-1.75973825E-01,   &
       2.42721193E-01,-2.36689502E-01, 1.93948395E-01,-1.44015408E-01,   &
       1.01803808E-01,-7.10544426E-02, 5.00485543E-02,-3.56659226E-02,   &
       2.53377819E-02,-1.75701668E-02, 1.17221735E-02,-7.53086182E-03,   &
       4.73448763E-03,-2.96940386E-03, 1.87193402E-03,-1.18208479E-03,   &
       7.45850501E-04,-4.70556798E-04, 2.96908215E-04,-1.87335624E-04,   &
       1.18200714E-04,-7.45797008E-05, 4.70565083E-05,-2.96907435E-05,   &
       1.87335570E-05,-1.18200753E-05, 7.45796333E-06,-4.70565673E-06,   &
       2.96906868E-06,-1.87335569E-06, 1.18200753E-06,-7.45796332E-07,   &
       4.70565673E-07,-2.96906868E-07, 1.87335569E-07,-1.18200753E-07,   &
       7.45796332E-08,-4.70565673E-08, 2.96906868E-08,-1.87335569E-08/
      DATA J08 /   &
       1.18200753E-08,-7.45796332E-09, 4.70565673E-09,-2.96906868E-09,   &
       1.87335569E-09,-1.18200753E-09, 7.45796332E-10,-4.70565673E-10,   &
       2.96906868E-10,-1.87335569E-10, 1.18200753E-10,-7.45796332E-11,   &
       4.70565673E-11,-2.96906868E-11, 1.87335569E-11,-1.18200753E-11,   &
       7.45796332E-12,-4.70565673E-12, 2.96906868E-12,-1.87335569E-12,   &
       1.18200753E-12,-7.45796332E-13, 4.70565673E-13,-2.96906868E-13,   &
       1.87335569E-13,-1.18200753E-13, 7.45796332E-14,-4.70565673E-14,   &
       2.96906868E-14,-1.87335569E-14, 1.18200753E-14,-7.45796332E-15,   &
       4.70565673E-15,-2.96906868E-15, 1.87335569E-15,-1.18200753E-15,   &
       7.45796332E-16,-4.70565673E-16, 2.96906868E-16,-1.87335569E-16,   &
       1.18200753E-16,-7.45796332E-17, 4.70565673E-17,-2.96906868E-17,   &
       1.87335569E-17,-1.18200753E-17, 7.45796332E-18,-4.70565673E-18,   &
       2.96906868E-18,-1.87335569E-18, 1.18200753E-18,-7.45796332E-19,   &
       4.70565673E-19,-2.96906868E-19, 1.87335569E-19,-1.18200753E-19,   &
       7.45796332E-20,-4.70565673E-20, 2.96906868E-20,-1.87335569E-20,   &
       1.18200753E-20,-7.45796332E-21, 4.70565673E-21,-2.96906868E-21,   &
       1.87335569E-21,-1.18200753E-21, 7.45796332E-22,-4.70565673E-22,   &
       2.96906868E-22,-1.87335569E-22, 1.18200753E-22,-7.45796332E-23/

   END BLOCK DATA J0COF2
!
!
!     B L O C K   D A T A   J 1 C O E F
!
!     BLOCK DATA J0COF CONTAINS THE FILTERCOEFFICIENTS OF THE
!     J1 TRANSFORM USED IN THE SUBROUTINE HFIL
!
!     50-per-decade filters for functions with opening angle of
!     analyticity of 0.1 pi (optimized).
!     Accuracy of the filter: 056E-08
!
   BLOCK DATA J1COF2
! ------
      REAL FILT1(600),J11(76),J12(76),J13(76),J14(72),   &
                      J15(76),J16(76),J17(76),J18(72)
      EQUIVALENCE (FILT1(1),J11(1)),(FILT1(77),J12(1)),   &
                  (FILT1(153),J13(1)),(FILT1(229),J14(1)),   &
                  (FILT1(301),J15(1)),(FILT1(377),J16(1)),   &
                  (FILT1(453),J17(1)),(FILT1(529),J18(1))
      COMMON /J1BLK2/ FILT1
! ----------
      DATA J11 /   &
       2.30258509E-18, 2.52473435E-18, 2.76831616E-18, 3.03539831E-18,   &
       3.32824807E-18, 3.64935144E-18, 4.00143428E-18, 4.38748544E-18,   &
       4.81078212E-18, 5.27491770E-18, 5.78383225E-18, 6.34184595E-18,   &
       6.95369581E-18, 7.62457584E-18, 8.36018116E-18, 9.16675636E-18,   &
       1.00511485E-17, 1.10208651E-17, 1.20841383E-17, 1.32499942E-17,   &
       1.45283297E-17, 1.59299968E-17, 1.74668941E-17, 1.91520686E-17,   &
       2.09998256E-17, 2.30258509E-17, 2.52473435E-17, 2.76831616E-17,   &
       3.03539831E-17, 3.32824807E-17, 3.64935144E-17, 4.00143428E-17,   &
       4.38748544E-17, 4.81078212E-17, 5.27491770E-17, 5.78383225E-17,   &
       6.34184595E-17, 6.95369581E-17, 7.62457584E-17, 8.36018116E-17,   &
       9.16675636E-17, 1.00511485E-16, 1.10208651E-16, 1.20841383E-16,   &
       1.32499942E-16, 1.45283297E-16, 1.59299968E-16, 1.74668941E-16,   &
       1.91520686E-16, 2.09998256E-16, 2.30258509E-16, 2.52473435E-16,   &
       2.76831616E-16, 3.03539831E-16, 3.32824807E-16, 3.64935144E-16,   &
       4.00143428E-16, 4.38748544E-16, 4.81078212E-16, 5.27491770E-16,   &
       5.78383225E-16, 6.34184595E-16, 6.95369581E-16, 7.62457584E-16,   &
       8.36018116E-16, 9.16675636E-16, 1.00511485E-15, 1.10208651E-15,   &
       1.20841383E-15, 1.32499942E-15, 1.45283297E-15, 1.59299968E-15,   &
       1.74668941E-15, 1.91520686E-15, 2.09998256E-15, 2.30258509E-15/
      DATA J12 /   &
       2.52473435E-15, 2.76831616E-15, 3.03539831E-15, 3.32824807E-15,   &
       3.64935144E-15, 4.00143428E-15, 4.38748544E-15, 4.81078212E-15,   &
       5.27491770E-15, 5.78383225E-15, 6.34184595E-15, 6.95369581E-15,   &
       7.62457584E-15, 8.36018116E-15, 9.16675636E-15, 1.00511485E-14,   &
       1.10208651E-14, 1.20841383E-14, 1.32499942E-14, 1.45283297E-14,   &
       1.59299968E-14, 1.74668941E-14, 1.91520686E-14, 2.09998256E-14,   &
       2.30258509E-14, 2.52473435E-14, 2.76831616E-14, 3.03539831E-14,   &
       3.32824807E-14, 3.64935144E-14, 4.00143428E-14, 4.38748544E-14,   &
       4.81078212E-14, 5.27491770E-14, 5.78383225E-14, 6.34184595E-14,   &
       6.95369581E-14, 7.62457584E-14, 8.36018116E-14, 9.16675636E-14,   &
       1.00511485E-13, 1.10208651E-13, 1.20841383E-13, 1.32499942E-13,   &
       1.45283297E-13, 1.59299968E-13, 1.74668941E-13, 1.91520686E-13,   &
       2.09998256E-13, 2.30258509E-13, 2.52473435E-13, 2.76831616E-13,   &
       3.03539831E-13, 3.32824807E-13, 3.64935144E-13, 4.00143428E-13,   &
       4.38748544E-13, 4.81078212E-13, 5.27491770E-13, 5.78383225E-13,   &
       6.34184595E-13, 6.95369581E-13, 7.62457584E-13, 8.36018116E-13,   &
       9.16675636E-13, 1.00511485E-12, 1.10208651E-12, 1.20841383E-12,   &
       1.32499942E-12, 1.45283297E-12, 1.59299968E-12, 1.74668941E-12,   &
       1.91520686E-12, 2.09998256E-12, 2.30258509E-12, 2.52473435E-12/
      DATA J13 /   &
       2.76831616E-12, 3.03539831E-12, 3.32824807E-12, 3.64935144E-12,   &
       4.00143428E-12, 4.38748544E-12, 4.81078212E-12, 5.27491770E-12,   &
       5.78383225E-12, 6.34184595E-12, 6.95369581E-12, 7.62457584E-12,   &
       8.36018116E-12, 9.16675636E-12, 1.00511485E-11, 1.10208651E-11,   &
       1.20841383E-11, 1.32499942E-11, 1.45283297E-11, 1.59299968E-11,   &
       1.74668941E-11, 1.91520686E-11, 2.09998256E-11, 2.30258509E-11,   &
       2.52473435E-11, 2.76831616E-11, 3.03539831E-11, 3.32824807E-11,   &
       3.64935144E-11, 4.00143428E-11, 4.38748544E-11, 4.81078212E-11,   &
       5.27491770E-11, 5.78383225E-11, 6.34184595E-11, 6.95369580E-11,   &
       7.62457583E-11, 8.36018115E-11, 9.16675635E-11, 1.00511485E-10,   &
       1.10208651E-10, 1.20841383E-10, 1.32499942E-10, 1.45283297E-10,   &
       1.59299968E-10, 1.74668941E-10, 1.91520686E-10, 2.09998256E-10,   &
       2.30258509E-10, 2.52473434E-10, 2.76831616E-10, 3.03539831E-10,   &
       3.32824806E-10, 3.64935143E-10, 4.00143427E-10, 4.38748543E-10,   &
       4.81078211E-10, 5.27491769E-10, 5.78383223E-10, 6.34184593E-10,   &
       6.95369578E-10, 7.62457580E-10, 8.36018112E-10, 9.16675631E-10,   &
       1.00511484E-09, 1.10208651E-09, 1.20841383E-09, 1.32499941E-09,   &
       1.45283296E-09, 1.59299967E-09, 1.74668940E-09, 1.91520684E-09,   &
       2.09998254E-09, 2.30258506E-09, 2.52473431E-09, 2.76831612E-09/
      DATA J14 /   &
       3.03539826E-09, 3.32824801E-09, 3.64935136E-09, 4.00143419E-09,   &
       4.38748534E-09, 4.81078200E-09, 5.27491755E-09, 5.78383207E-09,   &
       6.34184573E-09, 6.95369554E-09, 7.62457552E-09, 8.36018078E-09,   &
       9.16675590E-09, 1.00511479E-08, 1.10208645E-08, 1.20841375E-08,   &
       1.32499933E-08, 1.45283286E-08, 1.59299954E-08, 1.74668925E-08,   &
       1.91520666E-08, 2.09998232E-08, 2.30258480E-08, 2.52473400E-08,   &
       2.76831575E-08, 3.03539781E-08, 3.32824746E-08, 3.64935071E-08,   &
       4.00143341E-08, 4.38748440E-08, 4.81078087E-08, 5.27491619E-08,   &
       5.78383043E-08, 6.34184377E-08, 6.95369318E-08, 7.62457268E-08,   &
       8.36017736E-08, 9.16675179E-08, 1.00511430E-07, 1.10208586E-07,   &
       1.20841304E-07, 1.32499847E-07, 1.45283183E-07, 1.59299830E-07,   &
       1.74668776E-07, 1.91520487E-07, 2.09998017E-07, 2.30258221E-07,   &
       2.52473089E-07, 2.76831200E-07, 3.03539331E-07, 3.32824205E-07,   &
       3.64934421E-07, 4.00142559E-07, 4.38747499E-07, 4.81076956E-07,   &
       5.27490260E-07, 5.78381409E-07, 6.34182412E-07, 6.95366956E-07,   &
       7.62454428E-07, 8.36014322E-07, 9.16671074E-07, 1.00510936E-06,   &
       1.10207992E-06, 1.20840591E-06, 1.32498989E-06, 1.45282152E-06,   &
       1.59298590E-06, 1.74667285E-06, 1.91518695E-06, 2.09995862E-06/
      DATA J15 /   &
       2.30255631E-06, 2.52469974E-06, 2.76827456E-06, 3.03534829E-06,   &
       3.32818793E-06, 3.64927914E-06, 4.00134736E-06, 4.38738094E-06,   &
       4.81065648E-06, 5.27476665E-06, 5.78365065E-06, 6.34162762E-06,   &
       6.95343331E-06, 7.62426025E-06, 8.35980174E-06, 9.16630019E-06,   &
       1.00506000E-05, 1.10202058E-05, 1.20833456E-05, 1.32490412E-05,   &
       1.45271839E-05, 1.59286192E-05, 1.74652380E-05, 1.91500774E-05,   &
       2.09974317E-05, 2.30229728E-05, 2.52438832E-05, 2.76790015E-05,   &
       3.03489816E-05, 3.32764675E-05, 3.64862850E-05, 4.00056513E-05,   &
       4.38644050E-05, 4.80952584E-05, 5.27340733E-05, 5.78201640E-05,   &
       6.33966284E-05, 6.95107116E-05, 7.62142035E-05, 8.35638748E-05,   &
       9.16219542E-05, 1.00456651E-04, 1.10142728E-04, 1.20762128E-04,   &
       1.32404658E-04, 1.45168743E-04, 1.59162247E-04, 1.74503369E-04,   &
       1.91321630E-04, 2.09758946E-04, 2.29970806E-04, 2.52127553E-04,   &
       2.76415794E-04, 3.03039927E-04, 3.32223821E-04, 3.64212642E-04,   &
       3.99274845E-04, 4.37704351E-04, 4.79822912E-04, 5.25982694E-04,   &
       5.76569083E-04, 6.32003737E-04, 6.92747904E-04, 7.59306017E-04,   &
       8.32229604E-04, 9.12121507E-04, 9.99640457E-04, 1.09550600E-03,   &
       1.20050384E-03, 1.31549152E-03, 1.44140461E-03, 1.57926325E-03,   &
       1.73017919E-03, 1.89536325E-03, 2.07613328E-03, 2.27392245E-03/
      DATA J16 /   &
       2.49028813E-03, 2.72692095E-03, 2.98565437E-03, 3.26847437E-03,   &
       3.57752939E-03, 3.91514019E-03, 4.28380958E-03, 4.68623176E-03,   &
       5.12530094E-03, 5.60411891E-03, 6.12600106E-03, 6.69448033E-03,   &
       7.31330839E-03, 7.98645318E-03, 8.71809182E-03, 9.51259761E-03,   &
       1.03745198E-02, 1.13085539E-02, 1.23195017E-02, 1.34122165E-02,   &
       1.45915325E-02, 1.58621751E-02, 1.72286459E-02, 1.86950815E-02,   &
       2.02650784E-02, 2.19414796E-02, 2.37261172E-02, 2.56195033E-02,   &
       2.76204632E-02, 2.97257032E-02, 3.19293069E-02, 3.42221513E-02,   &
       3.65912412E-02, 3.90189554E-02, 4.14822072E-02, 4.39515238E-02,   &
       4.63900585E-02, 4.87525553E-02, 5.09843050E-02, 5.30201419E-02,   &
       5.47835576E-02, 5.61860319E-02, 5.71267155E-02, 5.74926379E-02,   &
       5.71596563E-02, 5.59944121E-02, 5.38576081E-02, 5.06089630E-02,   &
       4.61142310E-02, 4.02546797E-02, 3.29393758E-02, 2.41205275E-02,   &
       1.38119230E-02, 2.11017094E-03,-1.07820632E-02,-2.45323484E-02,   &
      -3.86567852E-02,-5.25039734E-02,-6.52496779E-02,-7.59086262E-02,   &
      -8.33710480E-02,-8.64720931E-02,-8.41014913E-02,-7.53579184E-02,   &
      -5.97465042E-02,-3.74078185E-02,-9.35194375E-03, 2.23476721E-02,   &
       5.44667035E-02, 8.27324429E-02, 1.02205384E-01, 1.08009484E-01,   &
       9.64214846E-02, 6.62185168E-02, 2.00199394E-02,-3.48308154E-02/
      DATA J17 /   &
      -8.64498513E-02,-1.20266502E-01,-1.22852465E-01,-8.73164392E-02,   &
      -1.87454417E-02, 6.30026603E-02, 1.26367652E-01, 1.39041623E-01,   &
       8.51536602E-02,-1.86851784E-02,-1.20647421E-01,-1.54988583E-01,   &
      -8.53357097E-02, 5.42088071E-02, 1.60774254E-01, 1.32709510E-01,   &
      -2.60237018E-02,-1.69518174E-01,-1.30111549E-01, 7.31795405E-02,   &
       1.92473002E-01, 4.04161015E-02,-1.84470017E-01,-1.11036608E-01,   &
       1.68793258E-01, 1.32176928E-01,-1.82955230E-01,-1.00285243E-01,   &
       2.26406849E-01,-1.80287971E-02,-2.14944458E-01, 1.98547698E-01,   &
       1.53007645E-02,-2.17036005E-01, 2.79610498E-01,-2.15027208E-01,   &
       9.93616663E-02, 3.45980499E-03,-6.70269908E-02, 9.27734596E-02,   &
      -9.29901615E-02, 7.99912686E-02,-6.23721951E-02, 4.50807177E-02,   &
      -3.05435474E-02, 1.96162742E-02,-1.21638751E-02, 7.47164224E-03,   &
      -4.64145230E-03, 2.92310770E-03,-1.84788664E-03, 1.16608029E-03,   &
      -7.35473240E-04, 4.64060005E-04,-2.92802409E-04, 1.84744007E-04,   &
      -1.16565588E-04, 7.35478527E-05,-4.64055278E-05, 2.92799363E-05,   &
      -1.84743780E-05, 1.16565443E-05,-7.35478219E-06, 4.64055383E-06,   &
      -2.92799152E-06, 1.84743775E-06,-1.16565442E-06, 7.35478216E-07,   &
      -4.64055382E-07, 2.92799151E-07,-1.84743775E-07, 1.16565442E-07,   &
      -7.35478216E-08, 4.64055382E-08,-2.92799151E-08, 1.84743775E-08/
      DATA J18 /   &
      -1.16565442E-08, 7.35478216E-09,-4.64055382E-09, 2.92799151E-09,   &
      -1.84743775E-09, 1.16565442E-09,-7.35478216E-10, 4.64055382E-10,   &
      -2.92799151E-10, 1.84743775E-10,-1.16565442E-10, 7.35478216E-11,   &
      -4.64055382E-11, 2.92799151E-11,-1.84743775E-11, 1.16565442E-11,   &
      -7.35478216E-12, 4.64055382E-12,-2.92799151E-12, 1.84743775E-12,   &
      -1.16565442E-12, 7.35478216E-13,-4.64055382E-13, 2.92799151E-13,   &
      -1.84743775E-13, 1.16565442E-13,-7.35478216E-14, 4.64055382E-14,   &
      -2.92799151E-14, 1.84743775E-14,-1.16565442E-14, 7.35478216E-15,   &
      -4.64055382E-15, 2.92799151E-15,-1.84743775E-15, 1.16565442E-15,   &
      -7.35478216E-16, 4.64055382E-16,-2.92799151E-16, 1.84743775E-16,   &
      -1.16565442E-16, 7.35478216E-17,-4.64055382E-17, 2.92799151E-17,   &
      -1.84743775E-17, 1.16565442E-17,-7.35478216E-18, 4.64055382E-18,   &
      -2.92799151E-18, 1.84743775E-18,-1.16565442E-18, 7.35478216E-19,   &
      -4.64055382E-19, 2.92799151E-19,-1.84743775E-19, 1.16565442E-19,   &
      -7.35478216E-20, 4.64055382E-20,-2.92799151E-20, 1.84743775E-20,   &
      -1.16565442E-20, 7.35478216E-21,-4.64055382E-21, 2.92799151E-21,   &
      -1.84743775E-21, 1.16565442E-21,-7.35478216E-22, 4.64055382E-22,   &
      -2.92799151E-22, 1.84743775E-22,-1.16565442E-22, 7.35478216E-23/
!
   END BLOCK DATA J1COF2
!
!
   SUBROUTINE PRINT_CS (NW,CS_TYPE,M_RX,NTX_FD,NCRD,TX_CRDX,TX_CRDY,         &
                        TX_CRDZ,RAD,TR_OFF_X,TR_OFF_Y,TR_OFF_Z,MD_ANGLE,     &
                        N_RX,RX_X,RX_Y,RX_Z,SURFACE_RL,FRQ,SCALE,ENX,ENY,    &
                        ENZ,HNX,HNY,HNZ,ESX,ESY,ESZ,HSX,HSY,HSZ)
!
!****  Print out results for controlled sources problems
!
!
!   Input parameters:
!
!     CS_TYPE:   Integer(*4),  type of excitation and configuration.
!             See documentation "MARCO.DOC" for description.
!     M_RX:   Integer,  maximal number of receiver sites.
!     NTX_FD:  Integer,  number of excitations.
!     TX_CRDX, TX_CRDY, TX_CRDZ:   Real TX_CRDX(4,NTX_FD), TX_CRDY(4,NTX_FD),
!     TX_CRDZ(4,NTX_FD):
!             coordinates of electrodes (the end points of current bipoles
!             or loop corners) or the center coordinates of a current loop
!             or a magnetic dipole for all the excitations.   For various
!             values of CS_TYPE,  the four elements for the first index of
!             TX_CRDX, TX_CRDY,  and TX_CRDZ contain the following information:
!             CS_TYPE =2, and 3:  the first two elements of TX_CRDX etc.
!                      represent the two electrodes of the bipoles;
!                  =4: the arrays TX_CRDX etc. show the coordinates
!                      of the four corner of the rectangular loop.
!                  =5, and 6: the first elements of TX_CRDX etc. contain the
!                      coordinates of the centre of the circular
!                      loop;  and
!                  =7, 8, and 9: the first elements of TX_CRDX etc.
!                      contain the coordinates of the centre of the
!                      magnetic dipole.
!     RAD:    Real,  radius of the current loop as with CS_TYPE=5 and 6.
!     MD_ANGLE: Real MD_ANGLE(2,NTX_FD),  orientations of arbitrary magnetic
!             dipoles for ksrc=9 for each excitation.  For each excitation
!             the two elements of MD_ANGLE(1:2,*) contains the dip angle
!             MD_ANGLE(1,*) and the azimuthal angle MD_ANGLE(2,*) of the
!             magnetic dipole.  The dip angle is the angle from the negative
!             z-axis, i.e., from the axis up in the air (assuming the z axis
!             is pointing downwards).  The azimuthal angle is the angle from
!             the north,  the x-axis.  Thus for a vertical magnetic dipole
!             MD_ANGLE(1,*)=0 for pointing up air and MD_ANGLE(1,*)=180 for
!             pointing down.  A horizontal magnetic dipole pointing north will
!             have MD_ANGLE(1,*)=90 and MD_ANGLE(2,*)=0,  and a horizontal
!             magnetic dipole pointing east will have MD_ANGLE(1,*)=90 and
!             MD_ANGLE(2,*)=90.
!     N_RX:   Integer N_RX(NTX_FD),  number of receiver sites.
!     RX_X,RX_Y,RX_Z:  Real RX_X(M_RX,NTX_FD), RX_Y(M_RX,NTX_FD),
!             RX_Z(M_RX,NTX_FD),
!             receiver sites coordinates in the x, y, and z-directions
!             for the receiver sites,  respectively.
!     FRQ:    Real,  the frequency.
!     SCALE:  Real,  scaling factor.  If the model exceed 100 km in
!             dimensions,  it is scaled down to with the limit of 100 km
!             as required by the designed limits of the Hankel transforms.
!     ENX, ENY, ENZ, ESX, ESY, ESZ, HNX, HNY, HNZ, HSX, HSY, HSZ:
!             Complex(*8) ENX(M_RX,NTX_FD) etc.,  arrays used to read
!             stored field quantities.  They do not necessarily need to
!             be passed in the argurment list.  They are passed into
!             this routine in order to minimize memory requirements.
!             Note that they are defined differently from those in
!             routine PRINT_CS_EH.
!
!
!   Output parameter:  None.  This routine produces output files only.
!
!
!  Remarks:
!
!     Note that all components of the normal, scattered, and total
!     electric and magnetic fields are printed. Also the normalized
!     scattered fields against their normal components, and apparent
!     resistivities defined by Ex(y)/Hy(x) and their phases are printed
!     for references. Some of the them may have wierd values because
!     the normalized scattered fields and apparent resistivities are
!     not useful for some particular excitation. For example, for
!     loop-loop systems only the vertical magnetic fields is
!     useful, but all other components including apparent resistivies
!     are also printed for reference.
!
!     The electric and magnetic fields are multiplied by the
!     scaling factor SCALE**2 and SCALE, respectively, to
!     retrieve the true responses.  Also all geometric parameters
!     are back tramsformed
!
!     Results for the cases CS_TYPE=6, 7, and 8 are stored  as if
!     there were many receivers and only one excitation.
!
! --- Due to the two different coordinate systems for the input data
!     and for the computation,  output components are swaped in the
!     x and y directions,  and z-components are sign-reversed.
!     Unlike routine PRINT_CS_EH which prints results after the
!     coordinate system is transformed back to the input system
!     after the frequency domain computations,  this routine prints
!     the results during the computations.  Thus x and y are exchanged
!     the the sign of z-components are reversed.
!
!     Note that for CS_TYPE=9 all z-coordinates are translated back to
!     the coordinates relative to the ground level.
!
!**** Called by:  main
!
!**** Calls:      none
!
!
      IMPLICIT NONE
!
      REAL FRQ,SCALE,SCALE2,WMU,SURFACE_RL,TR_OFF_X,TR_OFF_Y,TR_OFF_Z
      INTEGER I,J,IEXCI,CS_TYPE,M_RX,NTX_FD,NCRD,NW
!
      COMPLEX ENX(M_RX,NTX_FD),ENY(M_RX,NTX_FD),ENZ(M_RX,NTX_FD),   &
              HNX(M_RX,NTX_FD),HNY(M_RX,NTX_FD),HNZ(M_RX,NTX_FD),   &
              ESX(M_RX,NTX_FD),ESY(M_RX,NTX_FD),ESZ(M_RX,NTX_FD),   &
              HSX(M_RX,NTX_FD),HSY(M_RX,NTX_FD),HSZ(M_RX,NTX_FD),   &
              EH1,EH2
      REAL  TX_CRDX(NCRD,NTX_FD),TX_CRDY(NCRD,NTX_FD),TX_CRDZ(NCRD,NTX_FD),  &
            RAD(NTX_FD),RX_X(M_RX,NTX_FD),RX_Y(M_RX,NTX_FD),RX_Z(M_RX,NTX_FD)
      INTEGER N_RX(NTX_FD)
      REAL :: MD_ANGLE(2,NTX_FD)
!
      SCALE2=SCALE**2
!
      WRITE (NW,*)' '
      WRITE (NW,*)'========== DETAILED RESULTS FOR REFERENCE USE ========='
      WRITE (NW,*)'Check file OUTPUT.OUT for model parameters'
!
      DO 100 IEXCI=1,NTX_FD
!
         IF (NTX_FD.GT.1.AND.CS_TYPE.NE.6.AND.CS_TYPE.NE.7.AND.CS_TYPE.NE.8) &
          WRITE (NW,1010) IEXCI
!
!         IF (CS_TYPE.EQ.5) WRITE (NW,1020)TX_CRDX(1,IEXCI)/SCALE,           &
!                                          TX_CRDY(1,IEXCI)/SCALE,           &
         IF (CS_TYPE.EQ.5) WRITE (NW,1020) TX_CRDY(1,IEXCI)/SCALE,           &
                                           TX_CRDX(1,IEXCI)/SCALE,           &
                                           TX_CRDZ(1,IEXCI)/SCALE,           &
                                           RAD(IEXCI)/SCALE
         IF (CS_TYPE.EQ.6.AND.IEXCI.EQ.1) WRITE (NW,1030) TR_OFF_Y/SCALE,    &
                                          TR_OFF_X/SCALE,TR_OFF_Z/SCALE,     &
                                          RAD(1)/SCALE
         IF ((CS_TYPE.EQ.7.OR.CS_TYPE.EQ.8).AND.IEXCI.EQ.1) WRITE (NW,1040)  &
                                          TR_OFF_Y/SCALE,TR_OFF_X/SCALE,     &
                                          TR_OFF_Z/SCALE,                    &
!
!     !!! This prints the first dipole only.  Mutltiprofiles must be parallel
!         for the time being
!
                                          (MD_ANGLE(J,IEXCI),J=1,2)
         IF (CS_TYPE.EQ.2.OR.CS_TYPE.EQ.3) WRITE (NW,1050)                   &
                            (TX_CRDY(I,IEXCI)/SCALE,TX_CRDX(I,IEXCI)/SCALE,  &
                             TX_CRDZ(I,IEXCI)/SCALE,I=1,2)
! (TX_CRDX(I,IEXCI)/SCALE,TX_CRDY(I,IEXCI)/SCALE,TX_CRDZ(I,IEXCI)/SCALE,I=1,2)
         IF (CS_TYPE.EQ.4) WRITE (NW,1060)                                   &
  (TX_CRDY(I,IEXCI)/SCALE,TX_CRDX(I,IEXCI)/SCALE,TX_CRDZ(I,IEXCI)/SCALE,I=1,4)
! (TX_CRDX(I,IEXCI)/SCALE,TX_CRDY(I,IEXCI)/SCALE,TX_CRDZ(I,IEXCI)/SCALE,I=1,4)
         IF (CS_TYPE.EQ.9) WRITE (NW,1070)                                   &
               TX_CRDY(1,IEXCI)/SCALE,TX_CRDX(1,IEXCI)/SCALE,                &
              (TX_CRDZ(1,IEXCI)-SURFACE_RL)/SCALE,(MD_ANGLE(J,IEXCI),J=1,2)
!               TX_CRDX(1,IEXCI)/SCALE,TX_CRDY(1,IEXCI)/SCALE,               &
!               TX_CRDZ(1,IEXCI)/SCALE,(MD_ANGLE(J,IEXCI),J=1,2)
!
!
         DO 50 I=1,N_RX(IEXCI)
!
            IF (CS_TYPE==9) THEN
               WRITE (NW,1090)                                          &
                      RX_Y(I,IEXCI)/SCALE,RX_X(I,IEXCI)/SCALE,          &
                      (RX_Z(I,IEXCI)-SURFACE_RL)/SCALE
!                      RX_X(I,IEXCI)/SCALE,RX_Y(I,IEXCI)/SCALE,         &
!                      RX_Z(I,IEXCI)/SCALE
            ELSE
               WRITE (NW,1090)                                          &
                      RX_Y(I,IEXCI)/SCALE,RX_X(I,IEXCI)/SCALE,          &
!                      RX_X(I,IEXCI)/SCALE,RX_Y(I,IEXCI)/SCALE,         &
                      RX_Z(I,IEXCI)/SCALE
            ENDIF
!
            WRITE (NW,1100)                                            &
                        ENY(I,IEXCI)*SCALE2,ENX(I,IEXCI)*SCALE2,       &
                       -ENZ(I,IEXCI)*SCALE2,                           &
!                        ENX(I,IEXCI)*SCALE2,ENY(I,IEXCI)*SCALE2,       &
!                        ENZ(I,IEXCI)*SCALE2,                           &
                        ESY(I,IEXCI)*SCALE2,ESX(I,IEXCI)*SCALE2,       &
                       -ESZ(I,IEXCI)*SCALE2,                           &
!                        ESX(I,IEXCI)*SCALE2,ESY(I,IEXCI)*SCALE2,       &
!                        ESZ(I,IEXCI)*SCALE2,                           &
                        (ENY(I,IEXCI)+ESY(I,IEXCI))*SCALE2,            &
                        (ENX(I,IEXCI)+ESX(I,IEXCI))*SCALE2,            &
                       -(ENZ(I,IEXCI)+ESZ(I,IEXCI))*SCALE2
!                        (ENX(I,IEXCI)+ESX(I,IEXCI))*SCALE2,            &
!                        (ENY(I,IEXCI)+ESY(I,IEXCI))*SCALE2,            &
!                        (ENZ(I,IEXCI)+ESZ(I,IEXCI))*SCALE2
!
            WRITE (NW,1110)                                            &
                        HNY(I,IEXCI)*SCALE,HNX(I,IEXCI)*SCALE,         &
                       -HNZ(I,IEXCI)*SCALE,HSY(I,IEXCI)*SCALE,         &
                        HSX(I,IEXCI)*SCALE,-HSZ(I,IEXCI)*SCALE,         &
                        (HNY(I,IEXCI)+HSY(I,IEXCI))*SCALE,             &
                        (HNX(I,IEXCI)+HSX(I,IEXCI))*SCALE,             &
                       -(HNZ(I,IEXCI)+HSZ(I,IEXCI))*SCALE
!                        HNX(I,IEXCI)*SCALE,HNY(I,IEXCI)*SCALE,         &
!                        HNZ(I,IEXCI)*SCALE,HSX(I,IEXCI)*SCALE,         &
!                        HSY(I,IEXCI)*SCALE,HSZ(I,IEXCI)*SCALE,         &
!                        (HNX(I,IEXCI)+HSX(I,IEXCI))*SCALE,             &
!                        (HNY(I,IEXCI)+HSY(I,IEXCI))*SCALE,             &
!                        (HNZ(I,IEXCI)+HSZ(I,IEXCI))*SCALE
!
            WRITE (NW,1120)                                                 &
              ESY(I,IEXCI)/(ENY(I,IEXCI)+CMPLX(SIGN(1.E-30,0.),REAL(ENY(I,IEXCI)))),  &
              ESX(I,IEXCI)/(ENX(I,IEXCI)+CMPLX(SIGN(1.E-30,0.),REAL(ENX(I,IEXCI)))),  &
              ESZ(I,IEXCI)/(ENZ(I,IEXCI)+CMPLX(SIGN(1.E-30,0.),REAL(ENZ(I,IEXCI)))),  &
              HSY(I,IEXCI)/(HNY(I,IEXCI)+CMPLX(SIGN(1.E-30,0.),REAL(HNY(I,IEXCI)))),  &
              HSX(I,IEXCI)/(HNX(I,IEXCI)+CMPLX(SIGN(1.E-30,0.),REAL(HNX(I,IEXCI)))),  &
              HSZ(I,IEXCI)/(HNZ(I,IEXCI)+CMPLX(SIGN(1.E-30,0.),REAL(HNZ(I,IEXCI))))
!              ESX(I,IEXCI)/(ENX(I,IEXCI)+SIGN(1.E-30,REAL(ENX(I,IEXCI)))),  &
!              ESY(I,IEXCI)/(ENY(I,IEXCI)+SIGN(1.E-30,REAL(ENY(I,IEXCI)))),  &
!              ESZ(I,IEXCI)/(ENZ(I,IEXCI)+SIGN(1.E-30,REAL(ENZ(I,IEXCI)))),  &
!              HSX(I,IEXCI)/(HNX(I,IEXCI)+SIGN(1.E-30,REAL(HNX(I,IEXCI)))),  &
!              HSY(I,IEXCI)/(HNY(I,IEXCI)+SIGN(1.E-30,REAL(HNY(I,IEXCI)))),  &
!              HSZ(I,IEXCI)/(HNZ(I,IEXCI)+SIGN(1.E-30,REAL(HNZ(I,IEXCI))))
!
! --- Print apparent resistivities for CSAMT applications
!
            IF (CS_TYPE==3) THEN
!
! --- To prevent overflow in computing EH1**2 and EH2**2,
!     use 1.E-25 instead of 1.E-30.
!
               WMU=78.9568352E-7*FRQ
               EH2=(ESX(I,IEXCI)+ENX(I,IEXCI))/(HSY(I,IEXCI)+HNY(I,IEXCI)+   &
                    CMPLX(SIGN(1.E-25,REAL(HSY(I,IEXCI)+HNY(I,IEXCI))),0.))
               EH1=(ESY(I,IEXCI)+ENY(I,IEXCI))/(HSX(I,IEXCI)+HNX(I,IEXCI)+   &
                    CMPLX(SIGN(1.E-25,REAL(HSX(I,IEXCI)+HNX(I,IEXCI))),0.))
!               EH1=(ESX(I,IEXCI)+ENX(I,IEXCI))/(HSY(I,IEXCI)+HNY(I,IEXCI)+  &
!                    SIGN(1.E-25,REAL(HSY(I,IEXCI)+HNY(I,IEXCI))))
!               EH2=(ESY(I,IEXCI)+ENY(I,IEXCI))/(HSX(I,IEXCI)+HNX(I,IEXCI)+  &
!                    SIGN(1.E-25,REAL(HSX(I,IEXCI)+HNX(I,IEXCI))))
!
               WRITE (NW,1130) CABS(EH1)**2/WMU,CABS(EH2)**2/WMU,   &
                           ATAN2(AIMAG(EH1),REAL(EH1)               &
                           +SIGN(1.E-30,REAL(EH1)))*180./3.1416,    &
                           ATAN2(AIMAG(EH2),REAL(EH2)               &
                           +SIGN(1.E-30,REAL(EH2)))*180./3.1416
!               WRITE (13) CABS(EH1)**2/WMU,CABS(EH2)**2/WMU,        &
!                           ATAN2(AIMAG(EH1),REAL(EH1)               &
!                           +SIGN(1.E-30,REAL(EH1)))*180./3.1416,    &
!                           ATAN2(AIMAG(EH2),REAL(EH2)               &
!                           +SIGN(1.E-30,REAL(EH2)))*180./3.1416
            ENDIF
!
   50    CONTINUE
  100 CONTINUE
!
      RETURN
!
 1010 FORMAT (//,'***** Excitation (or transmitter) #',I3,' *****')
 1020 FORMAT (//'Coordinates of the loop center: (',3F12.3,')',       &
           /'Loop radius:',20X,F12.3)
 1030 FORMAT (//'Transmitter-receiver separation in X:',F12.3,        &
               /'Transmitter-receiver separation in Y:',F12.3,        &
               /'Elevation difference:',16X,F12.3,                    &
               /'Transmitter radius:',13X,F12.3)
 1040 FORMAT (//'Transmitter-receiver separation in X:',F12.3,        &
               /'Transmitter-receiver separation in Y:',F12.3,        &
               /'Elevation difference:',16X,F12.3,                    &
               /'Dipole orientation:',5X,'Dip angle:',F7.2,' Deg.;',  &
                               '  Azimuthal angle:',F7.2,' Deg.')
 1050 FORMAT (//'Coordinates of the electrodes: (',3F12.3,')',        &
           ';'/'                               (',3F12.3,')')
 1060 FORMAT (//'Coordinates of the four corners of the loop:',       &
           /'   (',3F11.3,')',';   (',3F11.3,');',/'   (',3F11.3,     &
           ')',';   (',3F11.3,')')
 1070 FORMAT (//'Coordinates of the dipole:      (',3F12.3,')',       &
           /'Dipole orientation:',5X,'Dip angle:',F7.2,' Deg.;',      &
                               '  Azimuthal angle:',F7.2,' Deg.')
 1090 FORMAT (//'  Receiver:  (',3F12.3,')')
 1100 FORMAT (/4X,'Electric fields:'/10X,'Normal     Epx:',2E20.8,    &
           /10X,'           Epy:',2E20.8,/10X,                        &
           '           Epz:',2E20.8,/10X,'Scattered  Esx:',           &
           2E20.8,/10X,'           Esy:',2E20.8,/10X,                 &
           '           Esz:',2E20.8,/10X,'Total      Etx:',           &
           2E20.8,/10X,'           Ety:',2E20.8,/10X,                 &
           '           Etz:',2E20.8)
 1110 FORMAT (/4X,'Magnetic fields:'/10X,'Normal     Hpx:',2E20.8,    &
           /10X,'           Hpy:',2E20.8,/10X,                        &
           '           Hpz:',2E20.8,/10X,'Scattered  Hsx:',           &
           2E20.8,/10X,'           Hsy:',2E20.8,/10X,                 &
           '           Hsz:',2E20.8,/10X,'Total      Htx:',           &
           2E20.8,/10X,'           Hty:',2E20.8,/10X,                 &
           '           Htz:',2E20.8)
 1120 FORMAT (/4X,'Normalized scattered fields:',/10X,                &
           'Esx/Epx       :',2E20.8,/10X,'Esy/Epy       :',           &
           2E20.8,/10X,'Esz/Epz       :',2E20.8,/10X,                 &
           'Hsx/Hpx       :',2E20.8,/10X,'Hsy/Hpy       :',           &
           2E20.8,/10X,'Hsz/Hpz       :',2E20.8)
 1130 FORMAT (/4X,'Apparent resistivity (amplitudes): ',/6X,          &
           'by Ex/Hy :',F15.5,6X,'by Ey/Hx :',F15.5,/4X,              &
           'Phases: ',/6X,'by Ex/Hy :',F15.5,6X,'by Ey/Hx :',         &
           F15.5)
!
   END SUBROUTINE PRINT_CS
!
!
   SUBROUTINE PRINT_CS_EH(NW,M_RX,NFRQ,NTX_FD,N_RX,CS_TYPE,FRQM,OUTPUT_FMT, &
                          RX_X,RX_Y,RX_Z,TR_OFF_X,TR_OFF_Y,TR_OFF_Z,N_SIDE, &
                          NCRD,TX_CRDX,TX_CRDY,TX_CRDZ,RAD,MD_ANGLE,ENX,    &
                          ENY,ENZ,HNX,HNY,HNZ,ESX,ESY,ESZ,HSX,HSY,HSZ)
!
!****  Print the frequency domain results in files suitable for
!      plotting
!
!
!   Input parameters:
!
!     NW:
!     M_RX:   Integer,  maximal number of receiver sites.
!     NFRQ:   Integer,  number of frequencies.
!     NTX_FD: Integer,  number of excitations.
!     N_RX:   Integer N_RX(NTX_FD),  number of receiver sites.
!     CS_TYPE:   Integer,  type of excitation and configuration.  See
!             documentation "MARCO.DOC" for description.
!     FRQM:   Real FRQM(NFRQ), array for the frequencies.
!     RX_X,RX_Y,RX_Z:  Real RX_X(M_RX,NTX_FD), RX_Y(M_RX,NTX_FD),
!             RX_Z(RCP,NTX_FD),  receiver sites coordinates in the x, y,
!             and z-directions for the receiver sites,  respectively.
!     TR_OFF_X:    Real,  transmitter-receiver separation for moving current
!             loops or moving magnetic dipoles (CS_TYPE=6, 7, or 8).
!     TSRY:
!     TR_OFF_Z:    Real,  transmitter-receiver eleviation differentce for
!             moving current loops or moving magnetic dipoles
!             (CS_TYPE=6, 7, or 8) as in airborne or downhole measurements.
!     N_SIDE:
!     NCRD:
!     TX_CRDX, TX_CRDY, TX_CRDZ:   Real TX_CRDX(NCRD,NTX_FD),
!     TX_CRDY(NCRD,NTX_FD), TX_CRDZ(NCRD,NTX_FD):
!             coordinates of electrodes (the end points of current bipoles
!             or loop corners) or the center coordinates of a current loop
!             or a magnetic dipole for all the excitations.   For various
!             values of CS_TYPE,  the four elements for the first index of
!             TX_CRDX, TX_CRDY,  and TX_CRDZ contain the following information:
!             CS_TYPE =2, and 3:  the first two elements of TX_CRDX etc.
!                      represent the two electrodes of the bipoles;
!                     =4: the arrays TX_CRDX etc. show the coordinates
!                         of the four corner of the rectangular loop.
!                     =5, and 6: the first elements of TX_CRDX etc. contain the
!                         coordinates of the centre of the circular
!                         loop;  and
!                     =7, 8, and 9: the first elements of TX_CRDX etc.
!                         contain the coordinates of the centre of the
!                         magnetic dipole.
!     RAD:    Real,  radius of the current loop as with CS_TYPE=5 and 6.
!     MD_ANGLE: Real MD_ANGLE(2,NTX_FD),  orientations of arbitrary magnetic
!             dipoles for ksrc=9 for each excitation.  For each excitation
!             the two elements of MD_ANGLE(1:2,*) contains the dip angle
!             MD_ANGLE(1,*) and the azimuthal angle MD_ANGLE(2,*) of the
!             magnetic dipole.  The dip angle is the angle from the negative
!             z-axis, i.e., from the axis up in the air (assuming the z axis
!             is pointing downwards).  The azimuthal angle is the angle from
!             the north,  the x-axis.  Thus for a vertical magnetic dipole
!             MD_ANGLE(1,*)=0 for pointing up air and MD_ANGLE(1,*)=180 for
!             pointing down.  A horizontal magnetic dipole pointing north will
!             have MD_ANGLE(1,*)=90 and MD_ANGLE(2,*)=0,  and a horizontal
!             magnetic dipole pointing east will have MD_ANGLE(1,*)=90 and
!             MD_ANGLE(2,*)=90.
!     ENX, ENY, ENZ, HNX, HNY, HNZ, ESX, ESY, ESZ, HSX, HSY, HSZ:
!             Complex(*8) ENX(NFRQM,M_RX) etc.,  arrays used to read
!             stored field quantities.  They do not necessarily need to
!             be passed in the argurment list.  They are passed into
!             this routine in order to minimize memory requirements.
!             Note that they are defined differently from those in the
!             main program.
!
!   Output parameter:  None.  This routine produces output files only.
!
!
!   Remarks:
!
!     The scaling factor has been considered in writing the
!     EM fields in the temporary files.  The values for the
!     frequencies have been back-transformed, too.
!
!
!**** Called by:  main
!
!**** Calls:      none
!
!
      IMPLICIT NONE
!
	  INTEGER xyzxyz
      REAL, INTENT(IN) :: TR_OFF_X,TR_OFF_Y,TR_OFF_Z
      INTEGER, INTENT(IN) :: CS_TYPE,M_RX,NFRQ,NTX_FD,NCRD,NW,OUTPUT_FMT
      COMPLEX, INTENT(INOUT) :: ENX(NFRQ,M_RX),ENY(NFRQ,M_RX),   &
                                ENZ(NFRQ,M_RX),HNX(NFRQ,M_RX),   &
                                HNY(NFRQ,M_RX),HNZ(NFRQ,M_RX),   &
                                ESX(NFRQ,M_RX),ESY(NFRQ,M_RX),   &
                                ESZ(NFRQ,M_RX),HSX(NFRQ,M_RX),   &
                                HSY(NFRQ,M_RX),HSZ(NFRQ,M_RX)
      REAL, INTENT(IN) :: MD_ANGLE(2,NTX_FD),TX_CRDX(NCRD,NTX_FD),           &
                          TX_CRDY(NCRD,NTX_FD),TX_CRDZ(NCRD,NTX_FD),         &
                          RAD(NTX_FD),RX_X(M_RX,NTX_FD),RX_Y(M_RX,NTX_FD),   &
                          RX_Z(M_RX,NTX_FD),FRQM(NFRQ)
      INTEGER, INTENT(IN) :: N_RX(NTX_FD),N_SIDE(NTX_FD)
!
      INTEGER ::  I,IEXCI,IFRQ,J,K,L1,L
!
!   -- The arrays EH and EH2 are used for printing results.
!      RES is for print CSAMT apparent resistivities.
!
      COMPLEX, ALLOCATABLE :: EH(:,:,:,:),EH2(:,:,:,:)
      REAL, ALLOCATABLE    :: RES(:,:,:,:)
!
      ALLOCATE(EH(M_RX,NTX_FD,6,NFRQ),EH2(M_RX,NTX_FD,6,NFRQ))
!
! --- Read the stored results
!
      DO IFRQ=1,NFRQ
         DO L=1,6
            READ (11) ((EH(I,J,L,IFRQ),I=1,N_RX(J)),J=1,NTX_FD)
            READ (12) ((EH2(I,J,L,IFRQ),I=1,N_RX(J)),J=1,NTX_FD)
         ENDDO
      ENDDO
!
! --- Print results in sounding format
!
!
   IF (OUTPUT_FMT==1.OR.OUTPUT_FMT==3) THEN
!
      WRITE (NW,1000)
!
      Component_loop: DO L=1,6
!
      IF (L==1) WRITE (NW,1010)
      IF (L==2) WRITE (NW,1020)
      IF (L==3) WRITE (NW,1030)
      IF (L==4) WRITE (NW,1040)
      IF (L==5) WRITE (NW,1050)
      IF (L==6) WRITE (NW,1060)
!      WRITE (NW,1080)
!
      Excitation_loop:  DO IEXCI=1,NTX_FD
!********************************************************
!*                                                      *
!
         IF (NTX_FD>1.AND.CS_TYPE/=6.AND.CS_TYPE/=7.AND.CS_TYPE/=8) THEN
            WRITE (NW,1090) IEXCI
         ENDIF
!
         IF (CS_TYPE==5) WRITE (NW,1100) TX_CRDX(1,IEXCI),              &
                         TX_CRDY(1,IEXCI),TX_CRDZ(1,IEXCI),RAD(IEXCI)
         IF (CS_TYPE==6.AND.IEXCI==1) WRITE (NW,1110) TR_OFF_X,TR_OFF_Y,&
                                                       TR_OFF_Z,RAD(1)
         IF ((CS_TYPE==7.OR.CS_TYPE==8).AND.IEXCI==1) WRITE (NW,1120)   &
                                              TR_OFF_X,TR_OFF_Y,TR_OFF_Z, &
!
!     !!! This prints the first dipole only.  Mutltiprofiles must be parallel
!         for the time being
!
                                              (MD_ANGLE(J,IEXCI),J=1,2)
         IF (CS_TYPE==2.OR.CS_TYPE==3) WRITE (NW,1130)                  &
           (TX_CRDX(J,IEXCI),TX_CRDY(J,IEXCI),TX_CRDZ(J,IEXCI),J=1,2)
         IF (CS_TYPE==4) WRITE (NW,1140)                                &
      (TX_CRDX(J,IEXCI),TX_CRDY(J,IEXCI),TX_CRDZ(J,IEXCI),J=1,N_SIDE(IEXCI))
         IF (CS_TYPE==9) WRITE (NW,1150) TX_CRDX(1,IEXCI),              &
           TX_CRDY(1,IEXCI),TX_CRDZ(1,IEXCI),(MD_ANGLE(J,IEXCI),J=1,2)
!
         DO L1=1,2
!
! --- Assign the results in the corresponding arrays
!
            DO K=1,NFRQ
               DO J=1,N_RX(IEXCI)
!
!   --- The following design using the arrays ENX, ENS etc. are unnecessary
!       and may be changed according to the design for the profile files
!       OUTPUT.PEE etc.   Those arrays are designed orignally to reduce memory
!       but the use of EH2 for th eprofile files already eat up the memory.
!
                  IF (L1.EQ.1) THEN
                     ENX(K,J)=EH(J,IEXCI,1,K)
                     ENY(K,J)=EH(J,IEXCI,2,K)
                     ENZ(K,J)=EH(J,IEXCI,3,K)
                     HNX(K,J)=EH(J,IEXCI,4,K)
                     HNY(K,J)=EH(J,IEXCI,5,K)
                     HNZ(K,J)=EH(J,IEXCI,6,K)
                  ELSE
                     ESX(K,J)=EH2(J,IEXCI,1,K)
                     ESY(K,J)=EH2(J,IEXCI,2,K)
                     ESZ(K,J)=EH2(J,IEXCI,3,K)
                     HSX(K,J)=EH2(J,IEXCI,4,K)
                     HSY(K,J)=EH2(J,IEXCI,5,K)
                     HSZ(K,J)=EH2(J,IEXCI,6,K)
                  ENDIF
!
               ENDDO
            ENDDO
!
         ENDDO
!
         DO I=1,N_RX(IEXCI)
!
            WRITE (NW,1170) RX_X(I,IEXCI),RX_Y(I,IEXCI),  RX_Z(I,IEXCI)
!
            WRITE (NW,1175)
!
            DO IFRQ=1,NFRQ
!
               IF (L==1)                                                &
               WRITE (NW,1180) FRQM(IFRQ),REAL(ENX(IFRQ,I)+ESX(IFRQ,I)),    &
                               AIMAG(ENX(IFRQ,I)+ESX(IFRQ,I)),              &
                               REAL(ESX(IFRQ,I)),AIMAG(ESX(IFRQ,I))
!
               IF (L==2)                                                &
               WRITE (NW,1180) FRQM(IFRQ),REAL(ENY(IFRQ,I)+ESY(IFRQ,I)),    &
                               AIMAG(ENY(IFRQ,I)+ESY(IFRQ,I)),              &
                               REAL(ESY(IFRQ,I)),AIMAG(ESY(IFRQ,I))
!
               IF (L==3)                                                &
               WRITE (NW,1180) FRQM(IFRQ),REAL(ENZ(IFRQ,I)+ESZ(IFRQ,I)),    &
                               AIMAG(ENZ(IFRQ,I)+ESZ(IFRQ,I)),              &
                               REAL(ESZ(IFRQ,I)),AIMAG(ESZ(IFRQ,I))
!
               IF (L==4)                                                &
               WRITE (NW,1180) FRQM(IFRQ),REAL(HNX(IFRQ,I)+HSX(IFRQ,I)),    &
                               AIMAG(HNX(IFRQ,I)+HSX(IFRQ,I)),              &
                               REAL(HSX(IFRQ,I)),AIMAG(HSX(IFRQ,I))
!
               IF (L==5)                                                &
               WRITE (NW,1180) FRQM(IFRQ),REAL(HNY(IFRQ,I)+HSY(IFRQ,I)),    &
                               AIMAG(HNY(IFRQ,I)+HSY(IFRQ,I)),              &
                               REAL(HSY(IFRQ,I)),AIMAG(HSY(IFRQ,I))
!
               IF (L==6)                                                &
               WRITE (NW,1180) FRQM(IFRQ),REAL(HNZ(IFRQ,I)+HSZ(IFRQ,I)),    &
                               AIMAG(HNZ(IFRQ,I)+HSZ(IFRQ,I)),              &
                               REAL(HSZ(IFRQ,I)),AIMAG(HSZ(IFRQ,I))
!
            ENDDO
!
         ENDDO
!*                                                      *
!********************************************************
      ENDDO Excitation_loop
!
      ENDDO Component_loop
!
      REWIND (11)
      REWIND (12)
!
   ENDIF
!
   IF (OUTPUT_FMT==2.OR.OUTPUT_FMT==3) THEN
!
! --- Print results in profile format
!
      WRITE (NW,1005)
!
! --- Read the stored results for each component
!
!      DO IFRQ=1,NFRQ
!      DO L=1,6
!         READ (11) ((EH(I,J,L,IFRQ),I=1,N_RX(J)),J=1,NTX_FD)
!         READ (12) ((EH2(I,J,L,IFRQ),I=1,N_RX(J)),J=1,NTX_FD)
!      ENDDO
!      ENDDO
	   write(NW,*) N_RX(NTX_FD)
	   xyzxyz=0.0
       DO L1=1,6
!		 
		 xyzxyz=xyzxyz+1
!**         IF (L1==1) WRITE (NW,1190)
!**         IF (L1==2) WRITE (NW,1200)
!**         IF (L1==3) WRITE (NW,1210)
!**         IF (L1==4) WRITE (NW,1220)
!**         IF (L1==5) WRITE (NW,1230)
!**         IF (L1==6) WRITE (NW,1240)
!
!         WRITE (NW,1260)
!
         IF (CS_TYPE==6.OR.CS_TYPE==7.OR.CS_TYPE==8) THEN
!
!   ---  Only one receiver site per excitation
!
            IF (CS_TYPE==6) WRITE (NW,1110)                &
                            TR_OFF_X,TR_OFF_Y,TR_OFF_Z,RAD(1)
            IF (CS_TYPE==7.OR.CS_TYPE==8)                     &
               WRITE (NW,1120) TR_OFF_X,TR_OFF_Y,TR_OFF_Z, &
!
!     !!! This prints the first dipole only.  Mutltiprofiles must be parallel
!         for the time being
!
                                   (MD_ANGLE(J,1),J=1,2)
!
            DO IFRQ=1,NFRQ
!
               WRITE (NW,1280) FRQM(IFRQ)
!
               WRITE (NW,1285)
!
               DO IEXCI=1,NTX_FD
!
                  DO I=1,N_RX(IEXCI)
!********** uncheck                    WRITE (NW,1290) RX_X(I,IEXCI),RX_Y(I,IEXCI),  &
!                                        RX_Z(I,IEXCI),                &
!                           REAL(EH(I,IEXCI,L1,IFRQ)+EH2(I,IEXCI,L1,IFRQ)),   &
!                           AIMAG(EH(I,IEXCI,L1,IFRQ)+EH2(I,IEXCI,L1,IFRQ)),  &
!                           REAL(EH2(I,IEXCI,L1,IFRQ)),                       &
!                           AIMAG(EH2(I,IEXCI,L1,IFRQ))
                  ENDDO
               ENDDO
            ENDDO
!
         ELSE
!
            DO IEXCI=1,NTX_FD
!
               IF (NTX_FD>1) THEN
                  WRITE (NW,1270) IEXCI
               ENDIF
!
               IF (CS_TYPE==5) WRITE (NW,1100) TX_CRDX(1,IEXCI),          &
                               TX_CRDY(1,IEXCI),TX_CRDZ(1,IEXCI),RAD(IEXCI)
!**               IF (CS_TYPE==2.OR.CS_TYPE==3) WRITE (NW,1130)              &
!**                  (TX_CRDX(J,IEXCI),TX_CRDY(J,IEXCI),TX_CRDZ(J,IEXCI),J=1,2)
               IF (CS_TYPE==4) WRITE (NW,1140)                            &
        (TX_CRDX(J,IEXCI),TX_CRDY(J,IEXCI),TX_CRDZ(J,IEXCI),J=1,N_SIDE(IEXCI))
               IF (CS_TYPE==9) WRITE (NW,1150) TX_CRDX(1,IEXCI),          &
                   TX_CRDY(1,IEXCI),TX_CRDZ(1,IEXCI),(MD_ANGLE(J,IEXCI),J=1,2)
!
               DO IFRQ=1,NFRQ
!
!**                  WRITE (NW,1280) FRQM(IFRQ)
!
!**                  WRITE (NW,1285)
!
                  DO I=1,N_RX(IEXCI)
                     WRITE (NW,1290) xyzxyz,FRQM(IFRQ),TX_CRDX(1,IEXCI),TX_CRDY(1,IEXCI),TX_CRDZ(1,IEXCI),  &
					       RX_X(I,IEXCI),RX_Y(I,IEXCI),RX_Z(I,IEXCI),        &
                           REAL(EH(I,IEXCI,L1,IFRQ)+EH2(I,IEXCI,L1,IFRQ)),   &
                           AIMAG(EH(I,IEXCI,L1,IFRQ)+EH2(I,IEXCI,L1,IFRQ)),  &
                           REAL(EH2(I,IEXCI,L1,IFRQ)),                       &
                           AIMAG(EH2(I,IEXCI,L1,IFRQ))
!
                  ENDDO
               ENDDO
            ENDDO
!
         ENDIF
!
      ENDDO
!
      REWIND (11)
      REWIND (12)
!
   ENDIF
!
      DEALLOCATE(EH,EH2)
!
! --- Print CSAMT apparent resistivities
!
      IF (CS_TYPE==3) THEN
!
         REWIND (13)
!
         ALLOCATE(RES(4,M_RX,NTX_FD,NFRQ))
!
         WRITE (NW,1300)
!
         DO IFRQ=1,NFRQ
            DO IEXCI=1,NTX_FD
               DO I=1,N_RX(IEXCI)
                  READ (13) RES(1,I,IEXCI,IFRQ),RES(2,I,IEXCI,IFRQ),      &
                            RES(3,I,IEXCI,IFRQ),RES(4,I,IEXCI,IFRQ)
               ENDDO
            ENDDO
         ENDDO
!
         DO IEXCI=1,NTX_FD
!
            IF (NTX_FD.GT.1) WRITE (NW,1090) IEXCI
            WRITE (NW,1130)                                              &
                 (TX_CRDX(I,IEXCI),TX_CRDY(I,IEXCI),TX_CRDZ(I,IEXCI),I=1,2)
!
            DO I=1,N_RX(IEXCI)
!
               WRITE (NW,1170) RX_X(I,IEXCI),RX_Y(I,IEXCI),RX_Z(I,IEXCI)
               WRITE (NW,1310)
!
               DO IFRQ=1,NFRQ
                  WRITE (NW,1320) FRQM(IFRQ),                               &
                                  RES(1,I,IEXCI,IFRQ),RES(3,I,IEXCI,IFRQ),  &
                                  RES(2,I,IEXCI,IFRQ),RES(4,I,IEXCI,IFRQ)
               ENDDO
            ENDDO
         ENDDO
!
         DEALLOCATE(RES)
!
      ENDIF
!
      RETURN
!
 1000 FORMAT (//'==========  COMPONENTS IN SOUNDING FORMAT  ==========')
 1005 FORMAT (//'==========  COMPONENTS IN PROFILE FORMAT  ==========')
 1010 FORMAT (//'EAST COMPONENTS OF THE ELECTRIC FIELD (in V/m): ',        &
               /'--------------------------------------')
 1020 FORMAT (//'NORTH COMPONENTS OF THE ELECTRIC FIELD (in V/m): ',       &
               /'---------------------------------------')
 1030 FORMAT (//'VERTICAL COMPONENTS OF THE ELECTRIC FIELD (in V/m): ',    &
               /'-------------------------------------------')
 1040 FORMAT (//'EAST COMPONENTS OF THE MAGNETIC FIELD (in A/m): ',        &
               /'--------------------------------------')
 1050 FORMAT (//'NORTH COMPONENTS OF THE MAGNETIC FIELD (in A/m): ',       &
               /'---------------------------------------')
 1060 FORMAT (//'VERTICAL COMPONENTS OF THE MAGNETIC FIELD (in A/m): ',    &
               /'------------------------------------------')
! 1080 FORMAT (/'The following results are the total and ',           &
!            'scattered fields values in the format',                 &
!            /' Frequency  Real(total) Imaginary(total)',                &
!            '  Real(scattered) Imaginary(scattered)')
 1090 FORMAT (//,'***** Transmitter #',I3,' *****')
 1100 FORMAT (/'Coordinates of the loop center: (',3F12.2,')',         &
              /'Loop radius:',20X,F12.2)
 1110 FORMAT (/'Transmitter-receiver separation in X:',F12.2,          &
              /'Transmitter-receiver separation in Y:',F12.2,          &
              /'Elevation difference:',16X,F12.2,                      &
              /'Transmitter radius:  ',16X,F12.2)
 1120 FORMAT (/'Transmitter-receiver separation in X:',F12.2,          &
              /'Transmitter-receiver separation in Y:',F12.2,          &
              /'Elevation difference:',16X,F12.2,                      &
              /'Dipole orientation:',5X,'Dip angle:',F7.2,' Deg.;',    &
                               '  Azimuthal angle:',F7.2,' Deg.')
 1130 FORMAT (/'Coordinates of the electrodes: (',3F12.2,')',        &
            ';'/'                               (',3F12.2,')')
 1140 FORMAT (/'Coordinates of the corners of the loop:',            &
              /'   (',3F11.2,')',';   (',3F11.2,');',                &
              /'   (',3F11.2,')',';   (',3F11.2,');',                &
              /'   (',3F11.2,')',';   (',3F11.2,');',                &
              /'   (',3F11.2,')',';   (',3F11.2,');',                &
              /'   (',3F11.2,')',';   (',3F11.2,');',                &
              /'   (',3F11.2,')',';   (',3F11.2,');',                &
              /'   (',3F11.2,')',';   (',3F11.2,');',                &
              /'   (',3F11.2,')',';   (',3F11.2,')')
 1150 FORMAT (/'Coordinates of the dipole:      (',3F12.2,')',       &
              /'Dipole orientation:',5X,'Dip angle:',F7.2,' Deg.;',     &
                               '  Azimuthal angle:',F7.2,' Deg.')
 1170 FORMAT (//' --- Receiver:  (',3F12.2,')')
 1175 FORMAT (/'  Frequency              Total Field         ',                &
            '       Scattered Field',/' ')
! 1180 FORMAT (5E16.8)
 1180 FORMAT (G12.4,2X,2G14.5,2X,2G13.4)
 1190 FORMAT (//'EAST COMPONENTS OF THE TOTAL AND SCATTERED ELECTRIC ',   &
                'FIELD (in V/m):',                                        &
               /'----------------------------------------------------',   &
                '-----')
 1200 FORMAT (//'NORTH COMPONENTS OF THE TOTAL AND SCATTERED ELECTRIC ',  &
                'FIELD (in V/m):',                                        &
               /'-----------------------------------------------------',  &
                '-----')
 1210 FORMAT (//'VERTICAL COMPONENTS OF THE TOTAL AND SCATTERED ELECTRIC ', &
                'FIELD (in V/m):',                                          &
               /'--------------------------------------------------------', &
                '-----')
 1220 FORMAT (//'EAST COMPONENTS OF THE TOTAL AND SCATTERED MAGNETIC ',   &
                'FIELD (in A/m):',                                        &
               /'----------------------------------------------------',   &
                '-----')
 1230 FORMAT (//'NORTH COMPONENTS OF THE TOTAL AND SCATTERED MAGNETIC ',  &
                'FIELD (in A/m):',                                        &
               /'-----------------------------------------------------',  &
                '-----')
 1240 FORMAT (//'VERTICAL COMPONENTS OF THE TOTAL AND SCATTERED MAGNETIC ', &
                'FIELD (in A/m):',                                          &
               /'--------------------------------------------------------', &
                '-----')
! 1260 FORMAT (/'The following results are in the format',             &
!              /'E-coord. N-coord. V-coord.',                          &
!               ' Real(toatl) Imag.(total) Real(second.) Imag.(second.)')
 1270 FORMAT (//' ***** Transmitter #: ',I4,' *****')
 1280 FORMAT (//' --- Frequency: ',G14.5)
 1285 FORMAT (/'  Easting   Northing   Rel.-Level',                    &
               '          Total Field         Scattered Field',/' ')
! 1290 FORMAT (1PE10.3,2(1PE11.3),2(1PE13.5),2(1PE11.3))


!!!! working modified 1290 FORMAT (1PG11.4,2(1PG12.4),2X,2(1PE11.3),1X,2(1PE10.2))

 1290 FORMAT (1I4,4F13.2,1PG12.4,2(1PG13.4),2X,2(1PE12.3),1X,2(1PE11.2))



! 1290 FORMAT (G10.3,2(G11.3),1X,2G12.4,1X,2G11.3)
 1300 FORMAT (//'==========  APPARENT RESISTIVITIES ==========')
 1310 FORMAT (/'   Frequency     Res (Ex/Hy)  Phase (Ex/Hy) ',                &
               '    Res (Ey/Hx)   Phase (Ey/Hx)',/' ')
 1320 FORMAT (5G15.5)
!
   END SUBROUTINE PRINT_CS_EH
!
!
   SUBROUTINE PRINT_CS_DH (NW,CS_TYPE,NFRQ,FRQM,NCRD,NTX_FD,M_RX,N_RX,    &
                           RX_X,RX_Y,RX_Z,N_SIDE,TX_CRDX,TX_CRDY,TX_CRDZ, &
                           MD_ANGLE,RX_ANGLE,TR_OFF_X,TR_OFF_Y,TR_OFF_Z)
!
!****  Print the frequency domain results in a downhole coordinate system
!      defined by dip and azimuthal angles
!
!      This routine prints all the three-components of the magnetic field
!      and the axial electric field in the local coordinate system defined
!      by dip and azimuthal angles of the well.
!
!   Input parameters:
!
!     NW:
!     M_RX:   Integer,  maximal number of receiver sites.
!     NFRQ:   Integer,  number of frequencies.
!     NTX_FD:  Integer,  number of excitations.
!     N_RX:   Integer N_RX(NTX_FD),  number of receiver sites.
!     FRQM:   Real FRQM(NFRQ), array for the frequencies.
!     RX_X,RX_Y,RX_Z:  Real RX_X(M_RX,NTX_FD), RX_Y(M_RX,NTX_FD),
!             RX_Z(RCP,NTX_FD),  receiver sites coordinates in the x, y,
!             and z-directions for the receiver sites,  respectively.
!     TX_CRDX, TX_CRDY, TX_CRDZ:   Real TX_CRDX(1,NTX_FD), TX_CRDY(1,NTX_FD),
!             TX_CRDZ(1,NTX_FD):
!             coordinates of electrodes (the end points of current bipoles
!             or loop corners) or the center coordinates of a current loop
!             or a magnetic dipole for all the excitations.
!     MD_ANGLE: Real MD_ANGLE(2,NTX_FD),  orientations of arbitrary magnetic
!             dipoles for ksrc=9 for each excitation.  For each excitation
!             the two elements of MD_ANGLE(1:2,*) contains the dip angle
!             MD_ANGLE(1,*) and the azimuthal angle MD_ANGLE(2,*) of the
!             magnetic dipole.  The dip angle is the angle from the negative
!             z-axis, i.e., from the axis up in the air (assuming the z axis
!             is pointing downwards).  The azimuthal angle is the angle from
!             the north,  the North-axis.  Thus for a vertical magnetic dipole
!             MD_ANGLE(1,*)=0 for pointing up air and MD_ANGLE(1,*)=180 for
!             pointing down.  A horizontal magnetic dipole pointing north will
!             have MD_ANGLE(1,*)=90 and MD_ANGLE(2,*)=0,  and a horizontal
!             magnetic dipole pointing east will have MD_ANGLE(1,*)=90 and
!             MD_ANGLE(2,*)=90.
!     RX_ANGLE:
!     ENX, ENY, ENZ, HNX, HNY, HNZ, ESX, ESY, ESZ, HSX, HSY, HSZ:
!             Complex(*8) ENX(NFRQM,M_RX) etc.,  arrays used to read
!             stored field quantities.  They do not necessarily need to
!             be passed in the argurment list.  They are passed into
!             this routine in order to minimize memory requirements.
!             Note that they are defined differently from those in the
!             main program.
!
!   Output parameter:  None.  This routine produces output files only.
!
!
!   Remarks:
!
!     This routine is similar to PRINT_CS_EH except that this prints
!     profiles along the user-defined coordinates.
!
!
!**** Called by:  main
!
!**** Calls:      none
!
!
      IMPLICIT NONE
!
      INTEGER, INTENT(IN) :: CS_TYPE,M_RX,NFRQ,NTX_FD,NW,NCRD
      REAL, INTENT(IN) :: MD_ANGLE(2,NTX_FD),RX_ANGLE(2,M_RX,NTX_FD),      &
                          TX_CRDX(NCRD,NTX_FD),TX_CRDY(NCRD,NTX_FD),       &
                          TX_CRDZ(NCRD,NTX_FD),RX_X(M_RX,NTX_FD),          &
                          RX_Y(M_RX,NTX_FD),RX_Z(M_RX,NTX_FD),FRQM(NFRQ),  &
                          TR_OFF_X,TR_OFF_Y,TR_OFF_Z
      INTEGER, INTENT(IN) :: N_RX(NTX_FD),N_SIDE(NTX_FD)
!
      INTEGER :: I,IEXCI,IFRQ,J,L1,L
      REAL    :: DIP,AZIM
      COMPLEX :: H1,H2,H3,HX,HY,HZ,A1,A2
!      COMPLEX :: E1,E2,E3,EX,EY,EZ
!
!   -- The arrays EH and EH2 are used for printing results.
!
      COMPLEX, ALLOCATABLE :: EH(:,:,:,:),EH2(:,:,:,:)
!
      ALLOCATE(EH(M_RX,NTX_FD,6,NFRQ),EH2(M_RX,NTX_FD,6,NFRQ))
!
! --- Read the stored results for each component
!
      DO IFRQ=1,NFRQ
      DO L=1,6
         READ (11) ((EH(I,J,L,IFRQ),I=1,N_RX(J)),J=1,NTX_FD)
         READ (12) ((EH2(I,J,L,IFRQ),I=1,N_RX(J)),J=1,NTX_FD)
      ENDDO
      ENDDO
!
      WRITE (NW,1000)
!
      DO L1=1,4
!
         IF (L1==1) WRITE (NW,1210)
         IF (L1==2) WRITE (NW,1220)
         IF (L1==3) WRITE (NW,1230)
         IF (L1==4) WRITE (NW,1240)
!
         IF (CS_TYPE==6.OR.CS_TYPE==7.OR.CS_TYPE==8) THEN
!
!   ---  Only one receiver site per excitation
!
            IF (CS_TYPE==6)                                   &
               WRITE (NW,1110) TR_OFF_X,TR_OFF_Y,TR_OFF_Z
            IF (CS_TYPE==7.OR.CS_TYPE==8)                     &
               WRITE (NW,1120) TR_OFF_X,TR_OFF_Y,TR_OFF_Z,    &
!
!     !!! This prints the first dipole only.  Mutltiprofiles must be parallel
!         for the time being
!
                                  (MD_ANGLE(J,1),J=1,2)
            DO IFRQ=1,NFRQ
!
               WRITE (NW,1280) FRQM(IFRQ)
!
               WRITE (NW,1260)
!
               DO IEXCI=1,NTX_FD
!
!  --- Rotate the components in the output coordinate system to the
!      internal coordinate system
!
                  IF (L1==1) THEN
!     --    Electric fields
                     HY=EH(1,IEXCI,1,IFRQ)+EH2(1,IEXCI,1,IFRQ)
                     HX=EH(1,IEXCI,2,IFRQ)+EH2(1,IEXCI,2,IFRQ)
                     HZ=-(EH(1,IEXCI,3,IFRQ)+EH2(1,IEXCI,3,IFRQ))
                  ELSE
!     --    Magnetic fields
                     HY=EH(1,IEXCI,4,IFRQ)+EH2(1,IEXCI,4,IFRQ)
                     HX=EH(1,IEXCI,5,IFRQ)+EH2(1,IEXCI,5,IFRQ)
                     HZ=-(EH(1,IEXCI,6,IFRQ)+EH2(1,IEXCI,6,IFRQ))
                  ENDIF
!
                  DIP=RX_ANGLE(1,1,IEXCI)/180.*3.14159265359
                  AZIM=RX_ANGLE(2,1,IEXCI)/180.*3.14159265359
                  A1= COS(AZIM)*HX+SIN(AZIM)*HY
                  A2=-SIN(AZIM)*HX+COS(AZIM)*HY
                  H3= COS(DIP)*HZ+SIN(DIP)*A1
                  H1=-SIN(DIP)*HZ+COS(DIP)*A1
                  H2=A2
!
                  IF (L1==1.OR.L1==2)                                    &
                  WRITE (NW,1290) RX_X(1,IEXCI),RX_Y(1,IEXCI),           &
                                  RX_Z(1,IEXCI),RX_ANGLE(1,1,IEXCI),     &
                                  RX_ANGLE(2,1,IEXCI),REAL(H3),AIMAG(H3)
                  IF (L1==3)                                             &
                  WRITE (NW,1290) RX_X(1,IEXCI),RX_Y(1,IEXCI),           &
                                  RX_Z(1,IEXCI),RX_ANGLE(1,1,IEXCI),     &
                                  RX_ANGLE(2,1,IEXCI),REAL(H1),AIMAG(H1)
                  IF (L1==4)                                             &
                  WRITE (NW,1290) RX_X(1,IEXCI),RX_Y(1,IEXCI),           &
                                  RX_Z(1,IEXCI),RX_ANGLE(1,1,IEXCI),     &
                                  RX_ANGLE(2,1,IEXCI),REAL(H2),AIMAG(H2)

!
               ENDDO
            ENDDO
!
         ELSE
!
            DO IEXCI=1,NTX_FD
!
               IF (NTX_FD>1) THEN
                  WRITE (NW,1270) IEXCI
               ENDIF
!
               IF (CS_TYPE==2.OR.CS_TYPE==3) THEN
                  WRITE (NW,1130)                                            &
                  (TX_CRDX(J,IEXCI),TX_CRDY(J,IEXCI),TX_CRDZ(J,IEXCI),J=1,2)
               ELSE IF (CS_TYPE==4) THEN
                  WRITE (NW,1140)                                            &
      (TX_CRDX(J,IEXCI),TX_CRDY(J,IEXCI),TX_CRDZ(J,IEXCI),J=1,N_SIDE(IEXCI))
               ELSE IF (CS_TYPE==9) THEN
                  WRITE (NW,1150) TX_CRDX(1,IEXCI),                          &
                  TX_CRDY(1,IEXCI),TX_CRDZ(1,IEXCI),(MD_ANGLE(J,IEXCI),J=1,2)
               ENDIF
!
               DO IFRQ=1,NFRQ
!
                  WRITE (NW,1280) FRQM(IFRQ)
!
                  WRITE (NW,1260)
!
                  DO I=1,N_RX(IEXCI)
!
!  --- Rotate the components in the output coordinate system to the
!      internal coordinate system
!
                     IF (L1==1) THEN
!     --     Electric fields
                        HY=EH(I,IEXCI,1,IFRQ)+EH2(I,IEXCI,1,IFRQ)
                        HX=EH(I,IEXCI,2,IFRQ)+EH2(I,IEXCI,2,IFRQ)
                        HZ=-(EH(I,IEXCI,3,IFRQ)+EH2(I,IEXCI,3,IFRQ))
                     ELSE
!     --     Magnetic fields
                        HY=EH(I,IEXCI,4,IFRQ)+EH2(I,IEXCI,4,IFRQ)
                        HX=EH(I,IEXCI,5,IFRQ)+EH2(I,IEXCI,5,IFRQ)
                        HZ=-(EH(I,IEXCI,6,IFRQ)+EH2(I,IEXCI,6,IFRQ))
                     ENDIF
!
                     DIP=RX_ANGLE(1,I,IEXCI)/180.*3.14159265359
                     AZIM=RX_ANGLE(2,I,IEXCI)/180.*3.14159265359
                     A1= COS(AZIM)*HX+SIN(AZIM)*HY
                     A2=-SIN(AZIM)*HX+COS(AZIM)*HY
                     H3= COS(DIP)*HZ+SIN(DIP)*A1
                     H1=-SIN(DIP)*HZ+COS(DIP)*A1
                     H2=A2
!
                     IF (L1==1.OR.L1==2)                                    &
                     WRITE (NW,1290) RX_X(I,IEXCI),RX_Y(I,IEXCI),           &
                                     RX_Z(I,IEXCI),RX_ANGLE(1,I,IEXCI),     &
                                     RX_ANGLE(2,I,IEXCI),REAL(H3),AIMAG(H3)
                     IF (L1==3)                                             &
                     WRITE (NW,1290) RX_X(I,IEXCI),RX_Y(I,IEXCI),           &
                                     RX_Z(I,IEXCI),RX_ANGLE(1,I,IEXCI),     &
                                     RX_ANGLE(2,I,IEXCI),REAL(H1),AIMAG(H1)
                     IF (L1==4)                                             &
                     WRITE (NW,1290) RX_X(I,IEXCI),RX_Y(I,IEXCI),           &
                                     RX_Z(I,IEXCI),RX_ANGLE(1,I,IEXCI),     &
                                     RX_ANGLE(2,I,IEXCI),REAL(H2),AIMAG(H2)
!
                  ENDDO
               ENDDO
            ENDDO
!
         ENDIF
!
      ENDDO
!
      REWIND (11)
      REWIND (12)
!
      DEALLOCATE (EH,EH2)
!
      RETURN
!
 1000 FORMAT (//'==========  COMPONENTS IN LOCAL COORDINATE SYSTEMS  ==========')
 1110 FORMAT (/'Transmitter-receiver separation in X:',F12.2,          &
               /'Transmitter-receiver separation in Y:',F12.2,          &
               /'Elevation difference:',16X,F12.2)
 1120 FORMAT (/'Transmitter-receiver separation in X:',F12.2,          &
               /'Transmitter-receiver separation in Y:',F12.2,          &
               /'Elevation difference:',16X,F12.2,                      &
               /'Dipole orientation:',5X,'Dip angle:',F7.2,' Deg.;',    &
                               '  Azimuthal angle:',F7.2,' Deg.')
 1130 FORMAT (/'Coordinates of the electrodes: (',3F12.2,')',        &
            ';'/'                               (',3F12.2,')')
 1140 FORMAT (/'Coordinates of the corners of the loop:',            &
              /'   (',3F11.2,')',';   (',3F11.2,');',                &
              /'   (',3F11.2,')',';   (',3F11.2,');',                &
              /'   (',3F11.2,')',';   (',3F11.2,');',                &
              /'   (',3F11.2,')',';   (',3F11.2,');',                &
              /'   (',3F11.2,')',';   (',3F11.2,');',                &
              /'   (',3F11.2,')',';   (',3F11.2,');',                &
              /'   (',3F11.2,')',';   (',3F11.2,');',                &
              /'   (',3F11.2,')',';   (',3F11.2,')')
 1150 FORMAT (/'Coordinates of the dipole:      (',3F12.2,')',       &
              /'Dipole orientation:',5X,'Dip angle:',F7.2,' Deg.;',  &
                                '  Azimuthal angle:',F7.2,' Deg.')
 1155 FORMAT (/'Coordinates of the transmitter:      (',3F12.2,')')
 1210 FORMAT (//'AXIAL COMPONENT ',                                     &
               'OF THE TOTAL ELECTRIC FIELD (in V/m):',                 &
              /'---------------------',                                 &
               '-----------------------------------------')
 1220 FORMAT (//'AXIAL COMPONENT (C3) ',                                &
               'OF THE TOTAL MAGNETIC FIELD (in A/m):',                 &
              /'---------------------',                                 &
               '-----------------------------------------')
 1230 FORMAT (//'COMPONENT C1 (IN THE VERTICAL PLANE CONTAINING THE ',  &
               'DRILLHOLE) OF THE TOTAL MAGNETIC FIELD (in A/m):',                               &
              /'---------------------------------------------------',   &
               '----------------------------------------------------')
 1240 FORMAT (//'COMPONENT C2 (THE HORIZONTAL ONE) ',                   &
               'OF THE TOTAL MAGNETIC FIELD (in A/m):',                 &
              /'----------------------------------',                    &
               '-----------------------------------------')
 1260 FORMAT (/'  Easting   Northing  Rel.-Level    Dip_angle  Azim_Angle', &
               '      Total Field',/' ')
 1270 FORMAT (//' ***** Transmitter #: ',I4,' *****')
 1280 FORMAT (//' --- Frequency: ',G14.5)
! 1290 FORMAT (1PE10.3,2(1PE11.3),2(1PE11.3),2(1PE13.5))
 1290 FORMAT (1PG11.4,2(1PG12.4),2(G11.3),1X,2(1PE11.3))
!
   END SUBROUTINE PRINT_CS_DH
!
!
   SUBROUTINE PRINT_MT(NW,MT_PROFL,MT_STATN,XRMT,YRMT,SCALE,E0X,E0Y,H0X,  &
                       H0Y,FRQ,NPOL,ZMT,EXMT,EYMT,EZMT,HXMT,HYMT,HZMT)
!
!****  Print out the results in the forms needed by MT studies
!
!      Note that some parameters are multiplied/divided by the
!      scaling factor to retrieve the true responses
!
!      The parameter ktransc controls if the C-function should
!      be printed, Ktransc=1, yes; =0, no.
!
!     The parameters MT_PROFL and MT_STATN controls the total number of
!     profiles and the total number of receivers on each profile
!     respectively.
!
!     The apparent resistivities and phases are also stored in the
!     units 11 and 12, respectively, for generating plotting files.
!
!
      IMPLICIT NONE
!
      REAL FRQ,SCALE,ZMT
      INTEGER I,J,KTRNSC,L,LP1,LP2,MT_PROFL,MT_STATN,NPOL,NW
!
      COMPLEX H0X,H0Y,E0X,E0Y,HP0,EP0,WMU,Z01,Z02,                &
           EXMT(MT_PROFL,MT_STATN,2),EYMT(MT_PROFL,MT_STATN,2),   &
           EZMT(MT_PROFL,MT_STATN,2),HXMT(MT_PROFL,MT_STATN,2),   &
           HYMT(MT_PROFL,MT_STATN,2),HZMT(MT_PROFL,MT_STATN,2)
      REAL XRMT(MT_PROFL),YRMT(MT_STATN)
      PARAMETER (KTRNSC=0)
!
      COMPLEX, ALLOCATABLE :: ZXX(:,:),ZYX(:,:),ZXY(:,:),ZYY(:,:), &
                              TZX(:,:),TZY(:,:)
      REAL, ALLOCATABLE :: AMP1(:,:),AMP2(:,:),AMP3(:,:),          &
                           AMP4(:,:),PHA1(:,:),PHA2(:,:),          &
                           PHA3(:,:),PHA4(:,:)
!
      ALLOCATE(ZXX(MT_PROFL,MT_STATN),ZYX(MT_PROFL,MT_STATN),       &
               ZXY(MT_PROFL,MT_STATN),ZYY(MT_PROFL,MT_STATN),       &
               TZX(MT_PROFL,MT_STATN),TZY(MT_PROFL,MT_STATN),       &
               AMP1(MT_PROFL,MT_STATN),AMP2(MT_PROFL,MT_STATN),     &
               AMP3(MT_PROFL,MT_STATN),AMP4(MT_PROFL,MT_STATN),     &
               PHA1(MT_PROFL,MT_STATN),PHA2(MT_PROFL,MT_STATN),     &
               PHA3(MT_PROFL,MT_STATN),PHA4(MT_PROFL,MT_STATN))
!
!  -- Just to avoid forcheck message for EZMT
!
      EZMT(1,1,1)=EZMT(1,1,1)*1.
!
      WMU=CMPLX(0.,78.9568352E-7*FRQ)
!
!       NPOL controls the polarizations of the incident waves
!
      IF (NPOL.EQ.0.OR.NPOL.EQ.1) THEN
         LP1=1+NPOL
         LP2=1+NPOL
         IF (NPOL.EQ.0) WRITE (NW,1010)
         IF (NPOL.EQ.1) WRITE (NW,1020)
      ELSEIF (NPOL.EQ.2) THEN
         LP1=1
         LP2=2
      ENDIF
!
      IF (ABS(ZMT).GT..1) THEN
!
!  --- Note that the imaginary parts of H are not multiplied by
!      SCALE as in the main program for the 1D responses at the
!      earth's surface
!
         WRITE (NW,1030) REAL(H0X),AIMAG(H0X),REAL(H0Y),AIMAG(H0Y),   &
                         E0X*SCALE,E0Y*SCALE
      ENDIF
!
      WRITE (NW,1040)
      WRITE (NW,1050) (XRMT(MT_PROFL+1-I)/SCALE,I=1,MT_PROFL)
      WRITE (NW,1060)
      WRITE (NW,1050) (YRMT(I)/SCALE,I=1,MT_STATN)
!
      IF (ABS(ZMT).GT..1) THEN
         WRITE (NW,*) ' '
         WRITE (NW,*) 'All scattered fields are normalized with ',   &
                  'respect to the 1D fields at z=',ZMT/SCALE
      ENDIF
!

         WRITE (NW,1100)

      DO 600 L=LP1,LP2
         EP0=E0X
         HP0=H0X
         IF (L.EQ.1) EP0=E0Y
         IF (L.EQ.2) HP0=H0Y
         IF (L.EQ.1) THEN
            WRITE (NW,1080)
         ELSE
            WRITE (NW,1090)
         ENDIF
         WRITE (NW,1100)
         DO 50 I=1,MT_PROFL
            WRITE (NW,1070) (REAL(EXMT(MT_PROFL+1-I,J,L)/EP0),J=1,MT_STATN)
   50    CONTINUE
         WRITE (NW,1110)
         DO 100 I=1,MT_PROFL
            WRITE (NW,1070) (AIMAG(EXMT(MT_PROFL+1-I,J,L)/EP0),J=1,MT_STATN)
  100    CONTINUE
         WRITE (NW,1120)
         DO 150 I=1,MT_PROFL
            WRITE (NW,1070) (REAL(EYMT(MT_PROFL+1-I,J,L)/EP0),J=1,MT_STATN)
  150    CONTINUE
         WRITE (NW,1130)
         DO 200 I=1,MT_PROFL
            WRITE (NW,1070) (AIMAG(EYMT(MT_PROFL+1-I,J,L)/EP0),J=1,MT_STATN)
  200    CONTINUE
         WRITE (NW,1140)
         DO 250 I=1,MT_PROFL
            WRITE (NW,1070) (REAL(HXMT(MT_PROFL+1-I,J,L)/HP0),J=1,MT_STATN)
  250    CONTINUE
         WRITE (NW,1150)
         DO 300 I=1,MT_PROFL
            WRITE (NW,1070) (AIMAG(HXMT(MT_PROFL+1-I,J,L)/HP0),J=1,MT_STATN)
  300    CONTINUE
         WRITE (NW,1160)
         DO 350 I=1,MT_PROFL
            WRITE (NW,1070) (REAL(HYMT(MT_PROFL+1-I,J,L)/HP0),J=1,MT_STATN)
  350    CONTINUE
         WRITE (NW,1170)
         DO 400 I=1,MT_PROFL
            WRITE (NW,1070) (AIMAG(HYMT(MT_PROFL+1-I,J,L)/HP0),J=1,MT_STATN)
  400    CONTINUE
         WRITE (NW,1180)
         DO 450 I=1,MT_PROFL
            WRITE (NW,1070) (REAL(HZMT(MT_PROFL+1-I,J,L)/HP0),J=1,MT_STATN)
  450    CONTINUE
         WRITE (NW,1190)
         DO 500 I=1,MT_PROFL
            WRITE (NW,1070) (AIMAG(HZMT(MT_PROFL+1-I,J,L)/HP0),J=1,MT_STATN)
  500    CONTINUE
!
  600 CONTINUE
      DO 700 J=1,MT_STATN
         DO 650 I=1,MT_PROFL
            Z01=HYMT(I,J,1)/(HYMT(I,J,2)+H0Y)
            Z02=HXMT(I,J,1)+H0X-HXMT(I,J,2)*Z01
            ZXX(I,J)=(EXMT(I,J,1)-(EXMT(I,J,2)+E0X)*Z01)/Z02
            ZXY(I,J)=(EXMT(I,J,2)+E0X-ZXX(I,J)*HXMT(I,J,2))/(HYMT(I,J,2)+H0Y)
            ZYX(I,J)=(EYMT(I,J,1)+E0Y-EYMT(I,J,2)*Z01)/Z02
            ZYY(I,J)=(EYMT(I,J,2)-ZYX(I,J)*HXMT(I,J,2))/(HYMT(I,J,2)+H0Y)
            CALL COMP(ZXX(I,J)*CABS(ZXX(I,J)/WMU),AMP1(I,J),PHA1(I,J))
            CALL COMP(ZYX(I,J)*CABS(ZYX(I,J)/WMU),AMP2(I,J),PHA2(I,J))
            CALL COMP(ZXY(I,J)*CABS(ZXY(I,J)/WMU),AMP3(I,J),PHA3(I,J))
            CALL COMP(ZYY(I,J)*CABS(ZYY(I,J)/WMU),AMP4(I,J),PHA4(I,J))
            Z01=(HXMT(I,J,1)+H0X)*(HYMT(I,J,2)+H0Y)-HXMT(I,J,2)*HYMT(I,J,1)
            TZX(I,J)=(HZMT(I,J,1)*(HYMT(I,J,2)+H0Y)-HZMT(I,J,2)*            &
                                                           HYMT(I,J,1))/Z01
            TZY(I,J)=(HZMT(I,J,2)*(HXMT(I,J,1)+H0X)-HZMT(I,J,1)*            &
                                                            HXMT(I,J,2))/Z01
  650    CONTINUE
  700 CONTINUE
!
! --- Store the apparent resistivities and phases for later use
!
      WRITE (11) ((AMP1(I,J),I=1,MT_PROFL),J=1,MT_STATN)
      WRITE (11) ((AMP2(I,J),I=1,MT_PROFL),J=1,MT_STATN)
      WRITE (11) ((AMP3(I,J),I=1,MT_PROFL),J=1,MT_STATN)
      WRITE (11) ((AMP4(I,J),I=1,MT_PROFL),J=1,MT_STATN)
      WRITE (12) ((PHA1(I,J),I=1,MT_PROFL),J=1,MT_STATN)
      WRITE (12) ((PHA2(I,J),I=1,MT_PROFL),J=1,MT_STATN)
      WRITE (12) ((PHA3(I,J),I=1,MT_PROFL),J=1,MT_STATN)
      WRITE (12) ((PHA4(I,J),I=1,MT_PROFL),J=1,MT_STATN)
!
      WRITE (NW,1210)
      IF (NPOL.NE.1) THEN
         WRITE (NW,1220)
         DO 750 I=1,MT_PROFL
            WRITE (NW,1200) (REAL(ZXX(MT_PROFL+1-I,J))*SCALE,J=1,MT_STATN)
  750    CONTINUE
         WRITE (NW,1230)
         DO 800 I=1,MT_PROFL
            WRITE (NW,1200) (AIMAG(ZXX(MT_PROFL+1-I,J))*SCALE,J=1,MT_STATN)
  800    CONTINUE
         WRITE (NW,1240)
         DO 850 I=1,MT_PROFL
            WRITE (NW,1200) (REAL(ZYX(MT_PROFL+1-I,J))*SCALE,J=1,MT_STATN)
  850    CONTINUE
         WRITE (NW,1250)
         DO 900 I=1,MT_PROFL
            WRITE (NW,1200) (AIMAG(ZYX(MT_PROFL+1-I,J))*SCALE,J=1,MT_STATN)
  900    CONTINUE
      ENDIF
      IF (NPOL.NE.0) THEN
         WRITE (NW,1260)
         DO 950 I=1,MT_PROFL
            WRITE (NW,1200) (REAL(ZXY(MT_PROFL+1-I,J))*SCALE,J=1,MT_STATN)
  950    CONTINUE
         WRITE (NW,1270)
         DO 1000 I=1,MT_PROFL
            WRITE (NW,1200) (AIMAG(ZXY(MT_PROFL+1-I,J))*SCALE,J=1,MT_STATN)
 1000    CONTINUE
         WRITE (NW,1280)
         DO 1300 I=1,MT_PROFL
            WRITE (NW,1200) (REAL(ZYY(MT_PROFL+1-I,J))*SCALE,J=1,MT_STATN)
 1300    CONTINUE
         WRITE (NW,1290)
         DO 1350 I=1,MT_PROFL
            WRITE (NW,1200) (AIMAG(ZYY(MT_PROFL+1-I,J))*SCALE,J=1,MT_STATN)
 1350    CONTINUE
      ENDIF
      WRITE (NW,1310)
!
      DO 1500 L=LP1,LP2
         IF (L.EQ.1) THEN
            WRITE (NW,1320)
            DO 1360 I=1,MT_PROFL
               WRITE (NW,1070) (REAL(TZX(MT_PROFL+1-I,J)),J=1,MT_STATN)
 1360       CONTINUE
            WRITE (NW,1330)
            DO 1380 I=1,MT_PROFL
               WRITE (NW,1070) (AIMAG(TZX(MT_PROFL+1-I,J)),J=1,MT_STATN)
 1380       CONTINUE
         ELSE
            WRITE (NW,1340)
            DO 1400 I=1,MT_PROFL
               WRITE (NW,1070) (REAL(TZY(MT_PROFL+1-I,J)),J=1,MT_STATN)
 1400       CONTINUE
            WRITE (NW,1370)
            DO 1420 I=1,MT_PROFL
               WRITE (NW,1070) (AIMAG(TZY(MT_PROFL+1-I,J)),J=1,MT_STATN)
 1420       CONTINUE
         ENDIF
!
 1500 CONTINUE
!
      WRITE (NW,1390)
      IF (NPOL.NE.1) THEN
         WRITE (NW,1430)
         DO 1550 I=1,MT_PROFL
            WRITE (NW,1410) (AMP1(MT_PROFL+1-I,J),J=1,MT_STATN)
 1550    CONTINUE
         WRITE (NW,1440)
         DO 1600 I=1,MT_PROFL
            WRITE (NW,1410) (PHA1(MT_PROFL+1-I,J),J=1,MT_STATN)
 1600    CONTINUE
         WRITE (NW,1450)
         DO 1650 I=1,MT_PROFL
            WRITE (NW,1410) (AMP2(MT_PROFL+1-I,J),J=1,MT_STATN)
 1650    CONTINUE
         WRITE (NW,1460)
         DO 1700 I=1,MT_PROFL
            WRITE (NW,1410) (PHA2(MT_PROFL+1-I,J),J=1,MT_STATN)
 1700    CONTINUE
      ENDIF
      IF (NPOL.NE.0) THEN
         WRITE (NW,1470)
         DO 1750 I=1,MT_PROFL
            WRITE (NW,1410) (AMP3(MT_PROFL+1-I,J),J=1,MT_STATN)
 1750    CONTINUE
         WRITE (NW,1480)
         DO 1800 I=1,MT_PROFL
            WRITE (NW,1410) (PHA3(MT_PROFL+1-I,J),J=1,MT_STATN)
 1800    CONTINUE
         WRITE (NW,1490)
         DO 1850 I=1,MT_PROFL
            WRITE (NW,1410) (AMP4(MT_PROFL+1-I,J),J=1,MT_STATN)
 1850    CONTINUE
         WRITE (NW,1510)
         DO 1900 I=1,MT_PROFL
            WRITE (NW,1410) (PHA4(MT_PROFL+1-I,J),J=1,MT_STATN)
 1900    CONTINUE
      ENDIF
      IF (KTRNSC.NE.0) THEN
         WRITE (NW,1520)
         IF (NPOL.NE.1) THEN
            WRITE (NW,1530)
            DO 1920 I=1,MT_PROFL
              WRITE (NW,1200) (REAL(ZXX(MT_PROFL+1-I,J)/WMU)/SCALE,J=1,MT_STATN)
 1920       CONTINUE
            WRITE (NW,1540)
            DO 1940 I=1,MT_PROFL
               WRITE (NW,1200) (AIMAG(ZXX(MT_PROFL+1-I,J)/WMU)/SCALE,J=1,     &
                   MT_STATN)
 1940       CONTINUE
            WRITE (NW,1560)
            DO 1960 I=1,MT_PROFL
              WRITE (NW,1200) (REAL(ZYX(MT_PROFL+1-I,J)/WMU)/SCALE,J=1,MT_STATN)
 1960       CONTINUE
            WRITE (NW,1570)
            DO 1980 I=1,MT_PROFL
               WRITE (NW,1200) (AIMAG(ZYX(MT_PROFL+1-I,J)/WMU)/SCALE,J=1,   &
                   MT_STATN)
 1980       CONTINUE
         ENDIF
         IF (NPOL.EQ.0) THEN
            RETURN
         ENDIF
         WRITE (NW,1580)
         DO 2000 I=1,MT_PROFL
            WRITE (NW,1200) (REAL(ZXY(MT_PROFL+1-I,J)/WMU)/SCALE,J=1,MT_STATN)
 2000    CONTINUE
         WRITE (NW,1590)
         DO 2050 I=1,MT_PROFL
            WRITE (NW,1200) (AIMAG(ZXY(MT_PROFL+1-I,J)/WMU)/SCALE,J=1,MT_STATN)
 2050    CONTINUE
         WRITE (NW,1610)
         DO 2100 I=1,MT_PROFL
            WRITE (NW,1200) (REAL(ZYY(MT_PROFL+1-I,J)/WMU)/SCALE,J=1,MT_STATN)
 2100    CONTINUE
         WRITE (NW,1620)
         DO 2150 I=1,MT_PROFL
            WRITE (NW,1200) (AIMAG(ZYY(MT_PROFL+1-I,J)/WMU)/SCALE,J=1,MT_STATN)
 2150    CONTINUE
      ENDIF
!
      RETURN
!
 1010 FORMAT (/'The following results are for B-polarization only. ',   &
           'Corresponding results like    Zxy, Pxy, Cxy etc. are ignored.')
 1020 FORMAT (/'The following results are for E-polarization only. ',   &
           'Corresponding results like    Zyx, Pyx, Cyx etc. are ignored.')
 1030 FORMAT (//'1D responses due to the layers at ',   &
              'the receiver plane:',/2X,'Hox  Hoy =',4E16.8,/2X,   &
              'Eox  Eoy =',4E16.8)
 1040 FORMAT (//'Profile(s)       X = ')
 1050 FORMAT (2X,7F11.3)
 1060 FORMAT (/'Receivers  Y = ')
 1070 FORMAT (2X,7F11.6)
 1080 FORMAT (//1X,'Maps for incident wave E = 0 i + Eoy j  and ',   &
              'H = Hox i + 0 j')
 1090 FORMAT (//1X,'Maps for incident wave E = Eox i + 0 j  and ',   &
              'H = 0 i + Hoy j')
 1100 FORMAT (/1X,'Map for real Eax :')
 1110 FORMAT (/1X,'Map for imaginary Eax :')
 1120 FORMAT (/1X,'Map for real Eay :')
 1130 FORMAT (/1X,'Map for imaginary Eay :')
 1140 FORMAT (/1X,'Map for real Hax :')
 1150 FORMAT (/1X,'Map for imaginary Hax :')
 1160 FORMAT (/1X,'Map for real Hay :')
 1170 FORMAT (/1X,'Map for imaginary Hay :')
 1180 FORMAT (/1X,'Map for real Haz :')
 1190 FORMAT (/1X,'Map for imaginary Haz :')
 1200 FORMAT (2X,7E11.4)
 1210 FORMAT (/1X,'Maps for impedance Z defined by E=Z*H ','(in V/A)')
 1220 FORMAT (/5x,'Real Zxx')
 1230 FORMAT (/5X,'Imaginary Zxx')
 1240 FORMAT (/5x,'Real Zyx')
 1250 FORMAT (/5X,'Imaginary Zyx')
 1260 FORMAT (/5x,'Real Zxy')
 1270 FORMAT (/5X,'Imaginary Zxy')
 1280 FORMAT (/5x,'Real Zyy')
 1290 FORMAT (/5X,'Imaginary Zyy')
 1310 FORMAT (/1X,'Maps for magnetic transfer functions ',   &
                  'defined by Hz=(Tzx,Tzy)*(Hx,Hy)^T')
 1320 FORMAT (/5X,'Real Tzx :')
 1330 FORMAT (/5X,'Imaginary Tzx :')
 1340 FORMAT (/5X,'Real Tzy :')
 1370 FORMAT (/5X,'Imaginary Tzy :')
 1390 FORMAT (/1X,'Maps for apparent resistivities')
 1410 FORMAT (2X,7F11.3)
 1430 FORMAT (/5x,'Amplitude Rxx')
 1440 FORMAT (/5X,'Phase Pxx')
 1450 FORMAT (/5x,'Amplitude Ryx')
 1460 FORMAT (/5X,'PHASE Pyx')
 1470 FORMAT (/5x,'Amplitude Rxy')
 1480 FORMAT (/5X,'Phase Pxy')
 1490 FORMAT (/5x,'Amplitude Ryy')
 1510 FORMAT (/5X,'Phase Pyy')
 1520 FORMAT (/1X,'Maps for transfer functions C defined by C=Z/iwu')
 1530 FORMAT (/5x,'Real Cxx')
 1540 FORMAT (/5X,'Imaginary Cxx')
 1560 FORMAT (/5x,'Real Cyx')
 1570 FORMAT (/5X,'Imaginary Cyx')
 1580 FORMAT (/5x,'Real Cxy')
 1590 FORMAT (/5X,'Imaginary Cxy')
 1610 FORMAT (/5x,'Real Cyy')
 1620 FORMAT (/5X,'Imaginary Cyy')
!
CONTAINS
!
!  Subroutine calculating the amplitude and phase of a complex number
!
      SUBROUTINE COMP(C,AMPL,PHASE)
      IMPLICIT NONE
      REAL A,AMPL,B,PHASE
      COMPLEX C
      A=REAL(C)
      B=AIMAG(C)
      AMPL=SQRT(A*A+B*B)
      IF (ABS(A).LT.1.E-10.AND.ABS(B).LT.1.E-10) THEN
         PHASE=0.
         RETURN
      ENDIF
      PHASE=ATAN2(B,A)*180./3.1416
      END SUBROUTINE COMP
!
   END SUBROUTINE PRINT_MT
!
!
   SUBROUTINE PRINT_MT_RES(MT_PROFL,MT_STATN,XRMT,YRMT,NFRQ,FRQM,SCALE,   &
                           TITLE,NFRQM)
!
!      Print out the apparent resistivities and phases in files
!      suitable for plotting
!
!     The parameters MT_PROFL and MT_STATN controls the total number of
!     profiles and the total number of receivers on each profile
!     respectively.
!
!     The apparent resistivities and phases are stored in the
!     units 11 and 12, respectively.
!
!
      IMPLICIT NONE
!
      INTEGER I,IFRQ,J,K,MT_PROFL,MT_STATN,NFRQ,NFRQM
      REAL SCALE
!
      CHARACTER*80 TITLE
      REAL XRMT(MT_PROFL),YRMT(MT_STATN),FRQM(NFRQ)
!
      REAL,  ALLOCATABLE :: APP(:,:,:,:)
!
      ALLOCATE(APP(MT_PROFL,MT_STATN,4,NFRQM))
!
      WRITE (51,1010) TITLE
      WRITE (52,1020) TITLE
      WRITE (53,1030) TITLE
      WRITE (54,1040) TITLE
      WRITE (55,1050) TITLE
      WRITE (56,1060) TITLE
      DO 100 I=1,6
         WRITE (50+I,1070)
  100 CONTINUE
!
! --- Read the apparent resistivities stored in the temporary file
!
      DO 200 IFRQ=1,NFRQ
         DO 150 K=1,4
            READ (11) ((APP(I,J,K,IFRQ),I=1,MT_PROFL),J=1,MT_STATN)
  150    CONTINUE
  200 CONTINUE
!
! --- Print apparent resistivities along the X-profiles
!
      WRITE (51,1080)
!
      DO 300 IFRQ=1,NFRQ
!
         WRITE (51,1090) FRQM(IFRQ)*SCALE**2
!
         DO 250 I=1,MT_PROFL
!
            WRITE (51,1100) XRMT(I)/SCALE
!
            DO 220 J=1,MT_STATN
!
               WRITE (51,1110) YRMT(J)/SCALE,(APP(I,J,K,IFRQ),K=1,4)
!
  220       CONTINUE
  250    CONTINUE
  300 CONTINUE
!
!
! --- Print apparent resistivities along the y-profiles
!
      WRITE (52,1120)
!
      DO 400 IFRQ=1,NFRQ
!
         WRITE (52,1090) FRQM(IFRQ)*SCALE**2
!
         DO 350 J=1,MT_STATN
!
            WRITE (52,1130) YRMT(J)/SCALE
!
            DO 320 I=1,MT_PROFL
!
               WRITE (52,1110) XRMT(I)/SCALE,(APP(I,J,K,IFRQ),K=1,4)
!
  320       CONTINUE
  350    CONTINUE
  400 CONTINUE
!
! --- Print apparent resistivities vs. frequencies for each
!     receiver site.
!
      WRITE (55,1140)
!
      DO 500 I=1,MT_PROFL
         DO 450 J=1,MT_STATN
!
            WRITE (55,1150) XRMT(I)/SCALE,YRMT(J)/SCALE
!
            DO 420 IFRQ=1,NFRQ
!
               WRITE (55,1160) FRQM(IFRQ)*SCALE**2,      &
                               (APP(I,J,K,IFRQ),K=1,4)
!
  420       CONTINUE
  450    CONTINUE
  500 CONTINUE
!
!
! --- Read the phases stored in the temporary file
!
      DO 600 IFRQ=1,NFRQ
         DO 550 K=1,4
            READ (12) ((APP(I,J,K,IFRQ),I=1,MT_PROFL),J=1,MT_STATN)
  550    CONTINUE
  600 CONTINUE
!
! --- Print apparent resistivities along the X-profiles
!
      WRITE (53,1170)
!
      DO 700 IFRQ=1,NFRQ
!
         WRITE (53,1090) FRQM(IFRQ)*SCALE**2
!
         DO 650 I=1,MT_PROFL
!
            WRITE (53,1180) XRMT(I)/SCALE
!
            DO 620 J=1,MT_STATN
!
               WRITE (53,1190) YRMT(J)/SCALE,(APP(I,J,K,IFRQ),K=1,4)
!
  620       CONTINUE
  650    CONTINUE
  700 CONTINUE
!
! --- Print phases along the y-profiles
!
      WRITE (54,1200)
!
      DO 800 IFRQ=1,NFRQ
!
         WRITE (54,1090) FRQM(IFRQ)*SCALE**2
!
         DO 750 J=1,MT_STATN
!
            WRITE (54,1210) YRMT(J)/SCALE
!
            DO 720 I=1,MT_PROFL
!
               WRITE (54,1190) XRMT(I)/SCALE,(APP(I,J,K,IFRQ),K=1,4)
!
  720       CONTINUE
  750    CONTINUE
  800 CONTINUE
!
! --- Print phases vs. frequencies for each receiver site.
!
      WRITE (56,1220)
!
      DO 900 I=1,MT_PROFL
         DO 850 J=1,MT_STATN
!
            WRITE (56,1150) XRMT(I)/SCALE,YRMT(J)/SCALE
!
            DO 820 IFRQ=1,NFRQ
!
               WRITE (56,1230) FRQM(IFRQ)*SCALE**2,             &
                               (APP(I,J,K,IFRQ),K=1,4)
!
  820       CONTINUE
  850    CONTINUE
  900 CONTINUE
!
      RETURN
!
 1010 FORMAT (/'Apparent Resistivities along the profile X ',   &
           'for model: ',A)
 1020 FORMAT (/'Apparent Resistivities along the profile Y ',   &
           'for model: ',A)
 1030 FORMAT (/'Phases along the profile X for model: ',A)
 1040 FORMAT (/'Phases along the profile Y for model: ',A)
 1050 FORMAT (/'Apparent resistivities vs. frequencies at ',   &
               'each site for model: ',A)
 1060 FORMAT (/'Phases vs. frequencies at ','each site for model: ',A)
 1070 FORMAT (/'Check file MARCO.OUT for more model information.')
 1080 FORMAT (/'Apparent resistivities along the X-profiles ',   &
           'in the format',/,                                    &
           '         Y          Rho_xx          Rho_yx',         &
           '         Rho_xy         Rho_yy')
 1090 FORMAT (//'***** Frequency= ',F15.6)
 1100 FORMAT (/'*** X= ',F15.3)
 1120 FORMAT (/'Apparent resistivities along the Y-profiles ',   &
           'in the format',/,                                    &
           '         X          Rho_xx          Rho_yx',         &
           '         Rho_xy         Rho_yy')
 1110 FORMAT (F15.3,4F16.4)
 1130 FORMAT (/'*** Y= ',F15.3)
 1140 FORMAT (/'Apparent resistivities vs. frequencies for each ',   &
           'receiver site',/'in the format',/,                       &
           '         Freq        Rho_xx          Rho_yx',            &
           '         Rho_xy         Rho_yy')
 1150 FORMAT (/'***** X=',F15.3,3X,'Y=',F15.3)
 1160 FORMAT (F15.6,4F16.4)
 1170 FORMAT (/'Phases along the X-profiles ','in the format',/,   &
           '         Y          Phi_xx          Phi_yx',           &
           '         Phi_xy         Phi_yy')
 1180 FORMAT (/'*** X= ',F15.3)
 1190 FORMAT (5F15.3)
 1200 FORMAT (/'Phases along the Y-profiles ','in the format',/,   &
           '         X          Phi_xx          Phi_yx',           &
           '         Phi_xy         Phi_yy')
 1210 FORMAT (/'*** Y= ',F15.3)
 1220 FORMAT (/'Phases vs. frequencies for each ','receiver site',  &
           /'in the format',/,                                      &
           '         Freq        Phi_xx          Phi_yx',           &
           '         Phi_xy         Phi_yy')
 1230 FORMAT (F15.6,4F15.3)
!
   END SUBROUTINE PRINT_MT_RES
!
!
   SUBROUTINE PRINT_JS(NW,CS_TYPE,SCALE,NTX_FD,NPOL,LP1,LP2,KSYMM,   &
                       NEQ,NMAX,MBODY,NBMAX,NBODY,NBLCK,           &
                       EMT,JST,EJGS,NCT,NET,NCELL,NX,NY,NZ,        &
                       BLX,BLY,BLZ,XBL,YBL,ZBL,E0X,E0Y)
!
!**** Print out the internal scattering currents of all the blocks.
!     The results will be normalized  with the incident electric
!     fields at the earth's surface (1D fields) for plane wave
!     excitations (MT).  Note that the blocks are numbered
!     in the sequence of the input data in MARCO.DAT. In each block
!     the scattering currents are printed in a sequence like
!        (((Js(i,j,k),k=1,nz),j=1,ny),i=1,nx).
!     Each line in jsblock represent the three components (complex)
!     of the scattering currents in a cell.
!
!
      IMPLICIT NONE
!
      REAL BX,BY,SCALE,SCALE2
      INTEGER I,IB,IEXCI,IQ,J,KPOL,CS_TYPE,KSYMM,L,LP1,LP2,MBODY,NBMAX,   &
           NBODY,NCB,NCS,NEQ,NMAX,NPOL,NQ,NW
      INTEGER NTX_FD
      COMPLEX EMT(NMAX),JST(NMAX,MBODY),EJGS(4*NMAX*MBODY),E0X,E0Y
      INTEGER NX(NBMAX,MBODY),NY(NBMAX,MBODY),NZ(NBMAX,MBODY),            &
           NCELL(NBMAX,MBODY),NCT(MBODY),NET(MBODY),NBLCK(MBODY)
      REAL BLX(NBMAX,MBODY),BLY(NBMAX,MBODY),BLZ(NBMAX,MBODY),            &
        XBL(NBMAX,MBODY),YBL(NBMAX,MBODY),ZBL(NBMAX,MBODY)
!
      IF (CS_TYPE.EQ.1) THEN
         WRITE (NW,1010)
         SCALE2=1.
      ELSE
         WRITE (NW,1020)
         SCALE2=SCALE**2
         E0X=(1.,0.)
         E0Y=(1.,0.)
      ENDIF
!
      WRITE (NW,1030)
!
      REWIND (20)
!
      IF (KSYMM.EQ.1.AND.CS_TYPE.NE.1) THEN
         NQ=4
      ELSE
         NQ=1
      ENDIF
!
      DO 100 IEXCI=1,NTX_FD
!
         DO 50 KPOL=LP1,LP2
!
! ---- Read jst from unit 20 for multiple excitations
!
            IF (KSYMM.EQ.1.AND.CS_TYPE.NE.1) THEN
               READ (20) (EJGS(I),I=1,4*NEQ)
            ELSEIF (NTX_FD.GT.1.OR.NPOL.EQ.2) THEN
               IF (CS_TYPE.NE.1) WRITE (NW,1040) IEXCI
               DO 10 IB=1,NBODY
                  READ (20) (EMT(I),I=1,NET(IB))
                  DO 5 J=1,NET(IB)
                     JST(J,IB)=EMT(J)
    5             CONTINUE
   10          CONTINUE
            ENDIF
!
            DO 40 IQ=1,NQ
!
! ---- Note that the numbering of the quadrants here is different
!      from the numbering of the quadrants in the routines EICSGS,
!      MTRX_GS, and SCAT_EH_CSGS.  See explanantions for Figure I at
!      the beginning of the program
!
               IF (IQ.EQ.2) THEN
!
                  BX=-1.
!       IQGS=4
                  BY=1.
               ELSEIF (IQ.EQ.3) THEN
!
                  BX=-1.
!       IQGS=1
                  BY=-1.
               ELSEIF (IQ.EQ.4) THEN
!
                  BX=1.
                  BY=-1.
               ELSE
!
                  BX=1.
!       IQGS=3
                  BY=1.
               ENDIF
!       IQGS=2
!
!
               IF (CS_TYPE.EQ.1) THEN
                  IF (KPOL.EQ.1) WRITE (NW,1050)
                  IF (KPOL.EQ.2) WRITE (NW,1060)
               ELSE
                  IF (KSYMM.EQ.1) WRITE (NW,1070) IQ
               ENDIF
!
               NCS=0
!
               DO 20 IB=1,NBODY
!
                  IF (IB.GT.1) NCS=NCS+NCT(IB-1)
!
                  WRITE (NW,1080) IB
!
                  NCB=0
!
                  DO 15 L=1,NBLCK(IB)
!
                     WRITE (NW,1090) L,NX(L,IB),NY(L,IB),NZ(L,IB),     &
                         BLX(L,IB)*NX(L,IB)/SCALE,BLY(L,IB)*NY(L,IB)   &
                         /SCALE,BLZ(L,IB)*NZ(L,IB)/SCALE,BX*XBL(L,IB)  &
                         /SCALE,BY*YBL(L,IB)/SCALE,ZBL(L,IB)/SCALE
!
                     IF (L.GT.1) NCB=NCB+NCELL(L-1,IB)
                     IF (KSYMM.EQ.1.AND.CS_TYPE.NE.1) THEN
                        DO 12 I=NCS+NCB+1,NCS+NCB+NCELL(L,IB)
                           WRITE (NW,1100)                    &
                           (EJGS(12*(I-1)+3*(IQ-1)+J),J=1,3)
   12                   CONTINUE
                     ELSEIF (KPOL.EQ.1) THEN
                        WRITE (NW,1100)                       &
                        (JST(I,IB)/E0Y*SCALE2,I=3*NCB+1,3*    &
                        (NCB+NCELL(L,IB)))
                     ELSE
                        WRITE (NW,1100)                       &
                        (JST(I,IB)/E0X*SCALE2,I=3*NCB+1,3*    &
                        (NCB+NCELL(L,IB)))
                     ENDIF
!
   15             CONTINUE
   20          CONTINUE
   40       CONTINUE
   50    CONTINUE
  100 CONTINUE
!
      RETURN
!
 1010 FORMAT (///10X,                                                 &
           'The internal scattering currents of all the blocks'/10X,  &
           ' normalized with the incident electric fields at',/20X,   &
           'the earths surface')
 1020 FORMAT (///10X,                                                 &
           'The internal scattering currents of all the blocks'/10X,  &
           ' in each cell')
 1030 FORMAT (//3X,                                                   &
           'Note that in each block the scattering currents are '/3X, &
           'printed in a sequence of',/8X,                            &
           '(((Js(i,j,k),k=1,nz),j=1,ny),i=1,nx)',/3X,                &
           'Each line represent the x, y, and z-components ',/3X,     &
           '(complex) of the scattering currents in a cell.')
 1040 FORMAT (//'******* For Excitation (or transmitter) #',I3,' *******')
 1050 FORMAT (///                                                     &
       '******** For incident wave E = 0 i + Eoy j  and '             &
       ,'H = Hox i + 0 j')
 1060 FORMAT (///                                                     &
       '******** For incident wave E = Eox i + 0 j  and '             &
       ,'H = 0 i + Hoy j')
 1070 FORMAT (//'   **** Quadrant #',I2)
 1080 FORMAT (//'----- Substructure #',I3)
 1090 FORMAT (/'  --- Block #',I3,                                    &
              /'        Discretization:    ',3I12,                    &
              /'        Dimensions:        ',3F12.3,                  &
              /'        Center coordinates:',3F12.3,/' ')
 1100 FORMAT (3X,6E12.4)
!
   END SUBROUTINE PRINT_JS
!
!
      SUBROUTINE ROI_2_MARCO(surface_rl,   &
                             MXTX,MXRX,MXLYR,MXFRQ,NFRQ,FREQ,NTX,SX,SY,NRX,   &
                             RX,RY,RZ,RDIP,RPHI,IDH,NLYR,THK,RES,CHRG,CTAU,   &
                             CFREQ,COLE,DO3D,TRGT_BLCK,BLCK_NX,BLCK_NY,       &
                             BLCK_LX,BLCK_LY,BLCK_CX,BLCK_CY,BLCK_CZ,DO_3D,   &
                             COLE_COLE,KAUTO,DESB,DCHRSB,DTAUSB,DCFRSB,       &
                             MLAYER,KANIS,RES_EARTH,CHRG_EARTH,TAU_EARTH,     &
                             FRQC_EARTH,DIELC_EARTH,DCHRG_EARTH,DTAU_EARTH,   &
                             DFRQC_EARTH,HVK,LRYTH,KTEM,FRQM,CS_TYPE,M_RX,    &
                             NTX_FD,TX_CRDX,TX_CRDY,TX_CRDZ,NCRD,N_RX,RX_X,   &
                             RX_Y,RX_Z,RX_ANGLE)
!      SUBROUTINE ROI_2_MARCO(SURFACE_RL,MXTX,MXRX,MXLYR,MXFRQ,NFRQ,FREQ,NTX,  &
!                             SX,SY,NRX,RX,RY,RZ,RDIP,RPHI,IDH,NLYR,THK,RES,   &
!                             CHRG,CTAU,CFREQ,COLE,DO3D,TRGT_BLCK,BLCK_NX,     &
!                             BLCK_NY,BLCK_LX,BLCK_LY,BLCK_CX,BLCK_CY,BLCK_CZ, &
!                             DO_3D,COLE_COLE,KAUTO,DESB,DCHRSB,DTAUSB,DCFRSB, &
!                             MLAYER,KANIS,RES_EARTH,CHRG_EARTH,TAU_EARTH,     &
!                             FRQC_EARTH,DIELC_EARTH,DCHRG_EARTH,DTAU_EARTH,   &
!                             DFRQC_EARTH,HVK,LRYTH,KTEM,FRQM,CS_TYPE,M_RX,    &
!                             NTX_FD,TX_CRDX,TX_CRDY,TX_CRDZ,NCRD,N_RX,RX_X,   &
!                             RX_Y,RX_Z,RX_ANGLE)
!
!****  Converting AMIRA input data to Marco parameters
!
! Due to different coordinate systems between Leroi and Marco,
! all x and y coordinates are switched.
!
! Note that the arrays TX_CRDX etc are defined by M_RX due to the
! design for moving loop configurations.
!
! Parameter NSX is refered to as NSXL in the calling routine due
! to conflict with the NSX of the super block of Marco.
!
!**** Called by: MAIN
!
!**** Calls:     None
!
      IMPLICIT NONE
!
      INTEGER I,J,KANIS,COLE_COLE,KAUTO,CS_TYPE,KTEM,                   &
              MLAYER,M_RX,MXFRQ,MXLYR,MXRX,MXTX,NCRD,NFRQ
      INTEGER NLYR,TRGT_BLCK,NTMP,NTX,DO_3D,NTX_FD,IDH
      REAL TMP
!
      LOGICAL COLE,DO3D
      REAL SX(4,MXTX),SY(4,MXTX),RDIP(MXRX,MXTX),RPHI(MXRX,MXTX),        &
           RX(MXRX,MXTX),RY(MXRX,MXTX),RZ(MXRX,MXTX),RES(MXLYR),         &
           THK(MXLYR),CHRG(MXLYR),CFREQ(MXLYR),CTAU(MXLYR),FREQ(MXFRQ),  &
           RX_ANGLE(2,M_RX,NTX_FD)
      INTEGER NRX(MXTX)
!
      REAL RES_EARTH(MLAYER),CHRG_EARTH(MLAYER),TAU_EARTH(MLAYER),       &
           FRQC_EARTH(MLAYER),DIELC_EARTH(MLAYER),DCHRG_EARTH(MLAYER),   &
           DTAU_EARTH(MLAYER),DFRQC_EARTH(MLAYER),LRYTH(MLAYER),         &
           HVK(0:MLAYER)
!
      INTEGER BLCK_NX(TRGT_BLCK),BLCK_NY(TRGT_BLCK)
      REAL BLCK_LX(TRGT_BLCK),BLCK_LY(TRGT_BLCK),BLCK_CX(TRGT_BLCK),     &
           BLCK_CY(TRGT_BLCK),BLCK_CZ(TRGT_BLCK),DESB(TRGT_BLCK),        &
           DCHRSB(TRGT_BLCK),DTAUSB(TRGT_BLCK),DCFRSB(TRGT_BLCK),        &
           SURFACE_RL
      INTEGER N_RX(NTX_FD)
      REAL RX_X(M_RX,NTX_FD),RX_Y(M_RX,NTX_FD),RX_Z(M_RX,NTX_FD)
!  -- Only for quadrilateral loops (NCRD=4)
      REAL TX_CRDX(4,NTX_FD),TX_CRDY(4,NTX_FD),TX_CRDZ(4,NTX_FD)
      REAL FRQM(NFRQ)
!
      IF (DO3D) THEN
         DO_3D=1
      ELSE
         DO_3D=0
      ENDIF
      IF (COLE) THEN
         COLE_COLE=1
      ELSE
         COLE_COLE=0
      ENDIF
!
      KAUTO=1
      KTEM=0
!-- NFRQ is the same parameter used by Leroi and Marco
      DO I=1,NFRQ
         FRQM(I)=FREQ(I)
      ENDDO
!
      CS_TYPE=4
      NCRD=4
      NTX_FD=NTX
      DO I=1,NTX
         DO J=1,4
            TX_CRDX(J,I)=SY(J,I)
            TX_CRDY(J,I)=SX(J,I)
            TX_CRDZ(J,I)=0.+SURFACE_RL
         ENDDO
      ENDDO
!
      DO J=1,NTX
         N_RX(J)=NRX(J)
         DO I=1,NRX(J)
            RX_X(I,J)=RY(I,J)
            RX_Y(I,J)=RX(I,J)
!
!  --  Change the sign of the vertical coordinate
!
            RX_Z(I,J)=-RZ(I,J)+SURFACE_RL
            IF (IDH==1) THEN
               RX_ANGLE(1,I,J)=RDIP(I,J)
               RX_ANGLE(2,I,J)=RPHI(I,J)
            ENDIF
         ENDDO
      ENDDO
!
      MLAYER=ABS(NLYR)
      KANIS=0
      HVK(0)=1.
      DO I=1,MLAYER
         RES_EARTH(I)=RES(I)
         HVK(I)=1.
         IF (I/=NLYR) LRYTH(I)=THK(I)
         CHRG_EARTH(I)=CHRG(I)
         TAU_EARTH(I)=CTAU(I)
         FRQC_EARTH(I)=CFREQ(I)
         DIELC_EARTH(I)=1.
         DCHRG_EARTH(I)=0.
         DTAU_EARTH(I)=1.
         DFRQC_EARTH(I)=0.
      ENDDO
!
      DO I=1,TRGT_BLCK
         DESB(I)=1.
         DCHRSB(I)=0.
         DTAUSB(I)=1.
         DCFRSB(I)=0.
      ENDDO
!
! -- Switch the x and y coordinates for the 3D blocks.
!
      DO I=1,TRGT_BLCK
         NTMP=BLCK_NX(I)
         BLCK_NX(I)=BLCK_NY(I)
         BLCK_NY(I)=NTMP
         TMP=BLCK_LX(I)
         BLCK_LX(I)=BLCK_LY(I)
         BLCK_LY(I)=TMP
         TMP=BLCK_CX(I)
         BLCK_CX(I)=BLCK_CY(I)
         BLCK_CY(I)=TMP
!  -- Note that BLCK_CZ etc. need not be converted since it is the depth to the
!     earth's surface that is input.  It ISN'T a relative level.
         BLCK_CZ(I)=0+BLCK_CZ(I)
      ENDDO
!
      RETURN
      END
!**** End of ROI_2_MARCO

      FUNCTION BES1 (Y)
      REAL BES1,F,THETA,Y,Z
!     ------------------
!  Calculates J1(X) for X > -3.

!***  Called by ROI_HEDCLR

!  For small Y, J1(Y) = Y/2 is a good approximation.
!  LMBDA > 0 is the Hankel transform variable.

!  Calculate J1 for Y > 0

      IF (Y<0.1) THEN
         BES1=0.5*Y
      ELSEIF (Y<=3.0) THEN
         Z=Y*Y/3/3
         F=.5+Z*(-.56249975+Z*(.21093573+Z*(-.03954289+Z*(.00443319+Z*(-   &
           .00031761+.00001109*Z)))))
         BES1=F*Y
      ELSE
         Z=3/Y
         F=.79788456+  &
           Z*(.00000156+Z*(.01659667+Z*(.00017105+Z*(-.00249511+  &
           Z*(.00113653-.00020033*Z)))))
         THETA=Y-2.35619449+  &
               Z*(.12499612+Z*(.00005650+Z*(-.00637879+Z*(.00074348+  &
               Z*(.00079824-.00029166*Z)))))
         BES1=F*COS(THETA)/SQRT(Y)
      ENDIF

      RETURN
      END
! END OF BES1

      SUBROUTINE ROI_BZAIR (MRX,RXL,RYL,SXL,SYL,PRM)
!
      IMPLICIT NONE
!
      REAL A,B,CLP,FAC,R,SLP,T,T11,T12,T21,T22,X,X1,X2,XREL,XRT,XSLH,  &
           XTCNTR,Y,Y1
      REAL Y2,YREL,YRT,YSLH,YTCNTR
      INTEGER JR,MRX
!    ------------------------------------------
!*** called by ROI_UTEM

! Computes the static limit (frequency = 0, or T = infinity, or
!  (conductivity = 0) of the vertical magnetic inductance at
!  point (XR, YR) in nanoteslas per amp. due to a rectangular loop.
!  FAC = 1.0E9 * MU / 4PI  =  100.

!         MRX - number of receivers
!    RXL, RYL - arrays of X,Y coordinates of the receivers.
!    SXL, SYL - arrays containing the coordinates of the Tx corners.
!         PRM - output DC vertical field

      REAL SXL(4),SYL(4),PRM(MRX),RXL(MRX),RYL(MRX)
      DATA FAC /100./
      T (A,B) = SQRT (A*A + B*B) / (A*B)

!  Compute the sine & cosine of the angle that the segment 2-3 makes with
!  the Y axis.  Compute sidelengths of loop and the position of the
!  receivers relative to the Tx loop centre.

      X=SXL(3)-SXL(2)
      Y=SYL(3)-SYL(2)
      R=SQRT(X**2+Y**2)
      SLP=X/R
      CLP=Y/R
      IF (ABS(SLP)<1.0E-4) SLP=0.
      IF (ABS(CLP)<1.0E-4) CLP=0.
      XSLH=SQRT((SXL(2)-SXL(1))**2+(SYL(2)-SYL(1)))/2.
      YSLH=R/2.

      XTCNTR=(SXL(1)+SXL(2)+SXL(3)+SXL(4))/4.
      YTCNTR=(SYL(1)+SYL(2)+SYL(3)+SYL(4))/4.
      DO JR=1,MRX
         XREL=RXL(JR)-XTCNTR
         YREL=RYL(JR)-YTCNTR
         XRT=CLP*XREL-SLP*YREL
         YRT=SLP*XREL+CLP*YREL

         X1=XRT+XSLH
         X2=XRT-XSLH
         Y1=YRT+YSLH
         Y2=YRT-YSLH

         T11=0.
         T12=0.
         T21=0.
         T22=0.

         IF (ABS(X1*Y1)>0.1) T11=T(X1,Y1)
         IF (ABS(X2*Y2)>0.1) T22=T(X2,Y2)
         IF (ABS(X1*Y2)>0.1) T12=T(X1,Y2)
         IF (ABS(X2*Y1)>0.1) T21=T(X2,Y1)

         PRM(JR)=FAC*(T11+T22-T12-T21)
      ENDDO
      RETURN
      END
!  END OF ROI_BZAIR

      SUBROUTINE ROI_CLPRX (NTX,SX,SY,MXRX,NRX,RX,RY,WTX,WRX)
!
      IMPLICIT NONE
!
      REAL CTH,DIST,STH,X1,X2,XSL,Y1,Y2,YSL
      INTEGER J,JS,JX,JY,MRX,MXRX,NGP,NTX,NX,NY
!     ----------------------------------------------------

!  Gaussian integration of the scattered vertical magnetic dipole response
!  over the area of a coincident loop is used to compute the coincident loop
!  response.  Upon imput of the transmitter / receiver corner coordinates,
!  (SX(J), SY(J), J=1,4), ROI_CLPRX returns the number of integration points
!  (pseudo-receivers), NRX, as well as the location (RX, RY), and weights
!  WRX.  This routine assumes counter-clockwise ordering of the receiver
!  vertices from the lower left corner; e.g., J=1 is the lower left corner,
!  J=2, the lower right, and J=3, the upper right.

!  One might be tempted to arrange the number of integration points
!  according to the dimensions of the transmitting loop.  However, the long
!  dimensions of the transmitter usually are along strike and hence, the
!  response gradient will generally vary more rapidly along the short
!  dimension of the loop.  This routine will provide for the user to change
!  the number of integration points in either direction but is set up
!  initially for equal distribution.

!  GLX(J) and GLW(J) are the Jth position and weight respectively for a
!  Gaussian rule.  To change the number of points from the 4 point
!  rule initially specified, the user will have to change the values of
!  NGP below, as well as putting the required values of GLX and GLW
!  into data statements.

!***  Called by MAIN

      PARAMETER (NGP=4)
      REAL SX(4,NTX),SY(4,NTX),WTX(NTX),WRX(MXRX),RX(MXRX,NTX),   &
           RY(MXRX,NTX),X(NGP),Y(NGP),GLX(NGP),GLW(NGP)
      INTEGER NRX(NTX)
      DATA (GLX(J), J=1,4) /.3399810,.8611363,-.3399810,-.8611363/
      DATA (GLW(J), J=1,4) /.6521452,.3478548,.6521452,.3478548/
!    DATA (GLX(J), J=1,6) /.2386192, .6612094, .9324695,
!   *                       -.2386192,-.6612094,-.9324695/
!    DATA (GLW(J), J=1,6) /.4679139, .3607615, .1713245,
!   *                        .4679139, .3607615, .1713245/

      DIST (X1,Y1,X2,Y2) = SQRT ((X1-X2)**2 + (Y1-Y2)**2)

      NX=NGP
      NY=NGP
      MRX=1+NX*NY
      WRX(1)=0.

      DO JS=1,NTX
         NRX(JS)=MRX
         RX(1,JS)=(SX(1,JS)+SX(2,JS)+SX(3,JS)+SX(4,JS))/4.
         RY(1,JS)=(SY(1,JS)+SY(2,JS)+SY(3,JS)+SY(4,JS))/4.

!  Compute side-lengths, rotation, and basic weight factor.

         XSL=DIST(SX(2,JS),SY(2,JS),SX(1,JS),SY(1,JS))
         YSL=DIST(SX(2,JS),SY(2,JS),SX(3,JS),SY(3,JS))
         CTH=(SX(2,JS)-SX(1,JS))/XSL
         STH=(SY(2,JS)-SY(1,JS))/XSL
         WTX(JS)=XSL*YSL/4.

!  Set up GL points for coordinate system with origin at (SX(1), SY(1)),
!  and rotation angle = 0

         DO J=1,NX
            X(J)=(GLX(J)+1.)*XSL/2.
         ENDDO
         DO J=1,NY
            Y(J)=(GLX(J)+1.)*YSL/2.
         ENDDO

!  Compute location of integration points plus weights.

         DO JX=1,NX
            DO JY=1,NY
               J=1+(JY+(JX-1)*NY)
               WRX(J)=GLW(JX)*GLW(JY)
               RX(J,JS)=SX(1,JS)+(X(JX)*CTH)-(Y(JY)*STH)
               RY(J,JS)=SY(1,JS)+(X(JX)*STH)+(Y(JY)*CTH)
            ENDDO
         ENDDO
      ENDDO

      RETURN
      END
!  END OF ROI_CLPRX

      SUBROUTINE ROI_CLRSP (MXFRQ,MXTX,NTX,MXRX,NFRQ,NRX,WTX,WRX,HFD)
!
      IMPLICIT NONE
!
      REAL CLSUM
      INTEGER JC,JF,JR,JS,MXFRQ,MXRX,MXTX,NFRQ,NTX
!     -----------------------------------------------------------

!  Integrates vertical magnetic dipole responses over area of coincident
!  loop for each of NTX positions.  It requires weights WRX and WTX to have
!  been set by a previous call to ROI_CLPRX.  On entry, HFD is the 3 component
!  magnetic dipole response at each of NRX points.
!  Upon exit, NRX = 1 and HFD is the coincident loop response.
!  NFRQ is the number of frequencies.

!***  Called by MAIN

      REAL WTX(NTX),WRX(MXRX),HFD(MXFRQ,3,MXRX,MXTX)
      INTEGER NRX (NTX)

      DO JS=1,NTX
         DO JF=1,NFRQ
            CLSUM=0.
            DO JR=1,NRX(JS)
               CLSUM=CLSUM+WTX(JS)*WRX(JR)*HFD(JF,3,JR,JS)
               DO JC=1,3
                  HFD(JF,JC,JR,JS)=0.
               ENDDO
            ENDDO
            HFD(JF,3,1,JS)=CLSUM
         ENDDO
         NRX(JS)=1
      ENDDO

      RETURN
      END
!  END OF ROI_CLRSP

      FUNCTION COSTRN (WF,YFRQ,NFRQ,T)
      REAL COSTRN,CUBVAL,DELCOS,FAC,ROI_ZXFINPL6,ROI_ZXFINPL8,FRCT,  &
           T,TOL,VAL,WCOS,WJ0,WJ1,WS,YS,YTYM
      INTEGER I,J1,K68,KFHIGH,KFLOW,MYMAX,NDEC,NFRQ,NPHF
!     --------------------------------

!***  Called by ROI_TDPULS, ROI_UTEM

!  LAST MODIFICATION DATE: July, 1995

!  Produces time-domain value at time T by cosine transformation of
!  NFRQ frequency-domain values contained in cubic spline array YFRQ.
!  Array WF contains the LOG (base e) of the angular frequency values.

!  The routine uses filter coefficients derived from the Niels Christensen
!  fast Hankel transform routine FILCOA at a spacing of 12 points per decade
!  and omega = 0.3.  Various filters were tested using a vertical magnetic
!  dipole receiver in a very large circular for which accurate frequency
!  and time-domain solutions were programmed.  This particular filter gave
!  the overall best accuracy for 1/2 spaces ranging in resistivity from
!  .1 to 10,000 ohm-m for times renging from .01 to 50 msec.
!
!
!   K(W,T) = (2/PI) * F(W) * COS(WT) dW
!
!  Letting X = WT, the above becomes
!
!   K(W,T) = (2/PI*T) * F(X/T) * COS(X) dX
!
!  From Abramowitz and Stegun, COS(X) = SQRT(X*PI/2) * J(-1/2:X).
!  Filter Coefficients are used to represent X**(1/2) * J(-1/2:X)
!
!   COSTRN = SQRT (2/PI) * SUM(i) { WCOS(i) * F [X(i) /T] }

      DOUBLE PRECISION DELTA,Y1,Y,TD
      REAL WF(NFRQ),YFRQ(4,NFRQ)

!**** Parameters for polynomial interpolation.  1/FRCT is the portion
!     for cubic splining. Due to the fact that high order polynomials
!     are inaccurate at the end points 1/FRCT must be no less than
!     1/10.  The parameter NPHF controls the switch between polynomial
!     interpolations and cubic spline interpolation at the high
!     frequency end.  NPHF must be greater or equal 2. K68 is the
!     switch between the 6-point and 8-point polynomial interpolations.
!
!     FRCT=1 cause the routine to use the spline interpolation only.
!
      PARAMETER (MYMAX=200,NPHF=3,FRCT=1./4.,K68=8)
      REAL YFRQ2(MYMAX)
!
!****
      COMMON /FILTER/ DELCOS,WCOS(-200:99), WJ0(283), WJ1(283), WS(266)
      DATA FAC /.7978846/, TOL /1.0E-4/, NDEC /12/
      DATA KFLOW, KFHIGH /-200, 99/

!**** Assign yfrq2
      DO I=1,NFRQ
         YFRQ2(I)=YFRQ(1,I)
      ENDDO

      DELTA=DLOG(10.D0)/DBLE(NDEC)
      TD=DBLE(T)
      YTYM=0.
      Y1=-DLOG(TD)-DBLE(DELCOS)

!  Begin right side convolution at weight 0.
!  Stop when frequency domain array is exhausted.

      DO J1=0,KFHIGH
         Y=Y1+J1*DELTA
         YS=SNGL(Y)
         IF (YS>WF(NFRQ)) THEN
            EXIT
         ENDIF
         IF (YS<WF(1)) YS=WF(1)
!*****
!     print *,'Ys=',exp(ys)/2./3.1415926
!
! -- Use the polynomial interpolation only for the intermediate
!  frequencies.  Polynomial interpolations are inaccurate at
!  at the two end points.  Thus NPHF must be greater than 2
!  and FRCT must be no less than 1/10.
!
         IF (YS>=(WF(1)+(WF(NFRQ)-WF(1))*FRCT).AND.YS<WF(NFRQ-NPHF))  &
             THEN
            IF (K68==6) VAL=WCOS(J1)*ROI_ZXFINPL6(WF,YFRQ2,NFRQ,YS)
            IF (K68==8) VAL=WCOS(J1)*ROI_ZXFINPL8(WF,YFRQ2,NFRQ,YS)
         ELSE
            VAL=WCOS(J1)*CUBVAL(WF,YFRQ,NFRQ,YS)
         ENDIF
!*****
!      VAL = WCOS(J1) * CUBVAL (WF,YFRQ,NFRQ,YS)
         YTYM=YTYM+VAL
      ENDDO

      Y=Y1

!  Begin left side convolution at weight -1.
!  When log angular frequency is less than WF(3), check convergence.
!  Continue left usingfact that impulse B is inversely proportional to
!  frequency as freq -> 0; i.e., step response B is constant.

      DO J1=-1,KFLOW,-1
         Y=Y1+J1*DELTA
         YS=SNGL(Y)
         IF (YS<=WF(NFRQ)) THEN
            IF (YS<WF(1)) YS=WF(1)
!*****
            IF (YS>=(WF(1)+(WF(NFRQ)-WF(1))*FRCT).AND.YS<WF(NFRQ-NPHF))  &
                THEN
               IF (K68==6) VAL=WCOS(J1)*ROI_ZXFINPL6(WF,YFRQ2,NFRQ,YS)
               IF (K68==8) VAL=WCOS(J1)*ROI_ZXFINPL8(WF,YFRQ2,NFRQ,YS)
            ELSE
               VAL=WCOS(J1)*CUBVAL(WF,YFRQ,NFRQ,YS)
            ENDIF
!*****
!      VAL = WCOS(J1) * CUBVAL (WF,YFRQ,NFRQ,YS)
            YTYM=YTYM+VAL
            IF ((Y<WF(3))) THEN
               IF (ABS(VAL)<TOL*ABS(YTYM)) THEN
                  EXIT
               ENDIF
            ENDIF
         ENDIF
      ENDDO

      COSTRN=FAC*YTYM/T

      RETURN
      END
!  END OF COSTRN

      FUNCTION CUBDER (XKNOT, COEF, KNOT, X1)
      REAL CUBDER,H,X1
      INTEGER I,KNOT,NDUMMY
!     ---------------------------------------

!  Evaluates the first derivative of a function from its cubic spline
!  interpolation.

!***    Called by ROI_TDSET
!***    Calls ROI_INTERV

!         KNOT - total number of knots including endpoints.
!     XKNOT(I), I = 1,KNOT - location of the knots.  The rightmost data
!                            point used to calculate coefficients is not
!                            used.
!     COEF(J,I), J = 1,4; I = 1,KNOT = Jth derivative at H = 0
!                                      where  H = X - XKNOT(I)
!******************************************************************************
!******************************************************************************

      REAL XKNOT(KNOT), COEF(4,KNOT)

!  Find index i of largest breakpoint to the left of X1.

      CALL ROI_INTERV(XKNOT,KNOT-1,X1,I,NDUMMY)
      H=X1-XKNOT(I)

      CUBDER=(COEF(4,I)*H/2.+COEF(3,I))*H+COEF(2,I)
      RETURN
      END
!  END OF CUBDER

      FUNCTION CUBINT (XKNOT, COEF, KNOT, X1, X2)
      REAL CUBINT,H,H1,H2,X1,X2
      INTEGER I,I1,I2,KNOT,NDUMMY
!   ------------------------------------------

!***  Called by
!***  Calls  ROI_INTERV

!Integrates a function from X1 to X2 using its cubic spline representation.
!
!    KNOT - total number of knots including endpoints.
!
!   XKNOT(I), I = 1,KNOT - LOCATION OF THE KNOTS.  THE RIGHTMOST DATA
!                          POINT USED TO CALCULATE COEFFICIENTS IS NOT
!                          INCLUDED.
!
!   COEF(J,I), J = 1,4; I = 1,KNOT
!
!            THE COEFFICIENTS OF THE CUBIC SPLINE REPRESENT THE
!            INDEFINITE INTEGRAL OF F, ON THE I'TH ROI_INTERVAL, AS:
!
!     INTGR [ F(X) ] = COEF(4,I)/24 * H**4  +  COEF(3,I)/6 * H**3  +
!                      COEF(2,I)/2 * H**2  +  COEF(1,I) * H
!
!                        WITH  H = X - XKNOT(K)
!
!THIS IS A MODIFICATION OF THE FUNCTION PPVALU IN THE BOOK
!"A PRACTICAL GUIDE TO SPLINES"  BY !. DE BOOR

!*********************************************************************
      REAL XKNOT(KNOT), COEF(4,KNOT)

!FIND THE INDICES I1 AND I2 OF LARGEST BREAKPOINTS TO THE LEFT OF X1
!AND X2 RESPECTIVELY.
!
      CALL ROI_INTERV(XKNOT,KNOT-1,X1,I1,NDUMMY)
      CALL ROI_INTERV(XKNOT,KNOT-1,X2,I2,NDUMMY)
      H1=X1-XKNOT(I1)
      H2=X2-XKNOT(I2)
      CUBINT=(((COEF(4,I2)*H2/4.0+COEF(3,I2))*H2/3.0+COEF(2,I2))  &
             *H2/2.0+COEF(1,I2))  &
             *H2-(((COEF(4,I1)*H1/4.0+COEF(3,I1))*H1/3.0+COEF(2,I1))  &
             *H1/2.0+COEF(1,I1))*H1

!INCLUDE INTEGRALS OVER ROI_INTERVENING ROI_INTERVALS.

      IF (I2==I1) THEN
         RETURN
      ENDIF

      DO I=I1,I2-1
         H=XKNOT(I+1)-XKNOT(I)
         CUBINT=CUBINT+(((COEF(4,I)*H/4.0+COEF(3,I))*H/3.0+COEF(2,I))  &
                *H/2.0+COEF(1,I))*H
      ENDDO
      RETURN
      END
!END OF CUBINT

      SUBROUTINE ROI_CUBSPL (XNOT, C, N, IBCBEG, IBCEND)
!     ----------------------------------------------

!***  Called by TEM, ROI_HSHTRP, ROI_QHTKER

!  Calculates coefficients for cubic spline interpolation.
!  Call function CUBVAL to evaluate function values after interpolation.
!  From  * A PRACTICAL GUIDE TO SPLINES *  by Carl de Boor.

!             INPUT
!             -----
!
!     N = number of data points. assumed to be > 1.
!
!  (XNOT(I), C(1,I), I=1,...,N) = abscissae and ordinates of the data points.
!                                 XNOT is assumed to be strictly increasing.
!
!     IBCBEG, IBCEND = boundary condition indicators, and
!     C(2,1), C(2,N) = boundary condition information. Specifically,
!
!     IBCBEG = 0  No boundary condition at XNOT(1) is given.  In this case,
!                 the not-a-knot condition is used, i.e. the jump in the
!                 third derivative across XNOT(2) is forced to zero.  Thus
!                 first and the second cubic polynomial pieces are made to
!                 coincide.
!     IBCBEG = 1  the slope at XNOT(1) is made to equal C(2,1),
!                 supplied by input.
!     IBCBEG = 2  the second derivative at XNOT(1) is made to equal C(2,1),
!                 supplied by input.
!
!     IBCEND = 0, 1, or 2 has analogous meaning concerning the boundary
!                 condition at XNOT(n), with the additional information
!                 taken from C(2,n).
!
!          OUTPUT
!          ------
!
!     C(J,I), J=1,...,4; I=1,...,L (= N-1) = the polynomial coefficients
!         of the cubic interpolating spline with interior knots (or joints)
!         XNOT(2), ..., XNOT(N-1).
!
!        In the interval: (XNOT(I) - XNOT(I+1)), the spline F is given by:
!
!        F(X) = C(1,I) + H* (C(2,I) + H* (C(3,I) + H* C(4,I)/3.) /2.)
!
!     where H = X - XNOT(I).  FUNCTION  *CUBVAL* may be
!     used to evaluate F or its derivatives from XNOT,C, L = N-1,
!     AND K=4.
!******************************************************************************
!******************************************************************************
!
      IMPLICIT NONE
!
      INTEGER IBCBEG,IBCEND,N,   I,J,L,M
      REAL C(4,N),XNOT(N),DIVDF1,DIVDF3,DXNOT,G
      SAVE

!  A tridiagonal linear system for the unknown slopes S(I) of F at
!  XNOT(I), I=1,...,N, is generated and then solved by Gauss elimination,
!  with S(I) ending up in C(2,I), ALL I.
!  C(3,.) AND C(4,.) are used initially for temporary storage.

!  Compute first differences of XNOT sequence and store in C(3,.).
!  Also, compute first divided difference of data and store in C(4,.).

      L=N-1
      DO M=2,N
         C(3,M)=XNOT(M)-XNOT(M-1)
         C(4,M)=(C(1,M)-C(1,M-1))/C(3,M)
      ENDDO

!  Construct first equation from the boundary condition, of the form
!  C(4,1)*S(1) + C(3,1)*S(2) = C(2,1)

      IF (IBCBEG<1) THEN
         IF (N>2) THEN

!  Not-a-knot condition at left end and N > 2.

            C(4,1)=C(3,3)
            C(3,1)=C(3,2)+C(3,3)
            C(2,1)=((C(3,2)+2.*C(3,1))*C(4,2)*C(3,3)+C(3,2)**2*C(4,3))  &
                   /C(3,1)
            GOTO 100
         ELSE

!  No condition at left end and N = 2.

            C(4,1)=1.
            C(3,1)=1.
            C(2,1)=2.*C(4,2)
            GOTO 400
         ENDIF
      ELSEIF (IBCBEG==1) THEN

!  Slope prescribed at left end.

         C(4,1)=1.
         C(3,1)=0.
      ELSE

!  Second derivative prescribed at left end.

         C(4,1)=2.
         C(3,1)=1.
         C(2,1)=3.*C(4,2)-C(3,2)*C(2,1)/2.
      ENDIF
      IF (N==2) THEN
         GOTO 400
      ENDIF

!  if there are interior knots, generate the corresponding equations and
!  perform the forward pass of Gauss elimination, after which the M-TH
!  equation reads    C(4,M)*S(M) + C(3,M)*S(M+1) = C(2,M).

  100 DO M=2,L
         G=-C(3,M+1)/C(4,M-1)
         C(2,M)=G*C(2,M-1)+3.*(C(3,M)*C(4,M+1)+C(3,M+1)*C(4,M))
         C(4,M)=G*C(3,M-1)+2.*(C(3,M)+C(3,M+1))
      ENDDO

!  Construct last equation from the second boundary condition, of the form
!  (-G*C(4,N-1))*S(N-1) + C(4,N)*S(N) = C(2,N)
!  If slope is prescribed at right end, one can go directly to back-
!  substitution, since C array happens to be set up just right for it
!  at this point.

      IF (IBCEND<1) THEN
         IF (N/=3.OR.IBCBEG/=0) THEN

!  Not-a-knot and N > 2, and either N > 3 or also not-a-knot at
!  left end point.

            G=C(3,N-1)+C(3,N)
            C(2,N)=((C(3,N)+2.*G)*C(4,N)*C(3,N-1)+C(3,N)**2*(C(1,N-1)-C(  &
                   1,N-2))/C(3,N-1))/G
            G=-G/C(4,N-1)
            C(4,N)=C(3,N-1)
            GOTO 500
         ENDIF
      ELSEIF (IBCEND==1) THEN
         GOTO 600
      ELSE
         GOTO 300
      ENDIF

!  Either (N=3 and not-a-knot also at left) or (N=2 and not not-a-
!  knot at left end point).

  200 C(2,N)=2.*C(4,N)
      C(4,N)=1.
      G=-1./C(4,N-1)
      GOTO 500

!  Second derivative prescribed at right endpoint.

  300 C(2,N)=3.*C(4,N)+C(3,N)*C(2,N)/2.
      C(4,N)=2.
      G=-1./C(4,N-1)
      GOTO 500
  400 IF (IBCEND<1) THEN
         IF (IBCBEG>0) THEN
            GOTO 200
         ENDIF

!  Not-a-knot at right endpoint and at left endpoint and N = 2.

         C(2,N)=C(4,N)
         GOTO 600
      ELSEIF (IBCEND==1) THEN
         GOTO 600
      ELSE
         GOTO 300
      ENDIF

!  Complete forward pass of Gauss elimination.

  500 C(4,N)=G*C(3,N-1)+C(4,N)
      C(2,N)=(G*C(2,N-1)+C(2,N))/C(4,N)

!  Perform back substitution.

  600 J=L
  700 C(2,J)=(C(2,J)-C(3,J)*C(2,J+1))/C(4,J)
      J=J-1
      IF (J>0) THEN
         GOTO 700
      ENDIF

!  Generate cubic coefficients in each interval, i.e., the derivatives at its
!  left endpoint, from value and slope at its endpoints.

      DO I=2,N
         DXNOT=C(3,I)
         DIVDF1=(C(1,I)-C(1,I-1))/DXNOT
         DIVDF3=C(2,I-1)+C(2,I)-2.*DIVDF1
         C(3,I-1)=2.*(DIVDF1-C(2,I-1)-DIVDF3)/DXNOT
         C(4,I-1)=(DIVDF3/DXNOT)*(6./DXNOT)
      ENDDO

      RETURN
      END
!  END OF ROI_CUBSPL

      FUNCTION CUBVAL (XKNOT, COEF, KNOT, X1)
      REAL CUBVAL,H,X1
      INTEGER I,KNOT,NDUMMY
!   ---------------------------------------

!***    CALLED BY HNKEVL, HNKEVN, ROI_HSLYR, TEM
!***    CALLS ROI_INTERV

!EVALUATES A FUNCTION AT X1 FROM FROM ITS CUBIC SPLINE REPRESENTATION.
!
!    KNOT - TOTAL NUMBER OF KNOTS INCLUDING ENDPOINTS.
!
!   XKNOT(I), I = 1,KNOT - LOCATION OF THE KNOTS.  THE RIGHTMOST DATA
!                          POINT USED TO CALCULATE COEFFICIENTS IS NOT
!                          INCLUDED.
!
!   COEF(J,I), J = 1,4; I = 1,KNOT
!
!            THE COEFFICIENTS OF THE CUBIC SPLINE ON THE I'TH ROI_INTERVAL.
!            REPRESENT F AS:
!
!              F(X) = COEF(4,I)/6 * H**3  +  COEF(3,I)/2 * H**2  +
!                     COEF(2,I) * H  +  COEF(1,I)
!
!                        WITH  H = X - XKNOT(I)
!
!THIS IS A MODIFICATION OF THE FUNCTION PPVALU IN THE BOOK
!"A PRACTICAL GUIDE TO SPLINES"  BY C. DE BOOR
!
!           METHOD
!           ------
!
!THE ROI_INTERVAL INDEX  I , APPROPRIATE FOR  X , IS FOUND THROUGH A CALL TO
!ROI_INTERV . THE FORMULA FOR F IS EVALUATED USING NESTED MULTIPLICATION.
!******************************************************************************
!******************************************************************************

      REAL XKNOT(KNOT), COEF(4,KNOT)
!
!FIND INDEX  I  OF LARGEST BREAKPOINT TO THE LEFT OF  X1.
!
      CALL ROI_INTERV(XKNOT,KNOT-1,X1,I,NDUMMY)
      H=X1-XKNOT(I)

      CUBVAL=((COEF(4,I)*H/3.0+COEF(3,I))*0.5*H+COEF(2,I))*H+COEF(1,I)
      RETURN
      END
!END OF CUBVAL

      SUBROUTINE ROI_DLTCF (NDGTS,CFLT)
!
      IMPLICIT NONE
!
      INTEGER I,K,K1,K2,MXDGTS,NDGTS,NH
!   ----------------------------

!*** CALLED BY ROI_HSBOSS

!  Computes filter coefficients in double precision for doing
!  inverse Laplace transforms.

!  INPUT:   NDGTS - must be an even integer whose maximum value is the
!  -----            number of digits carried by a double precision word.
!                   exceeding this value will produce nonsensical results.
!                   It also is the length of the filter.

!  OUTPUT:   CFLT - filter coefficients calculated by this subroutine
!  ------
!
!   REFERENCES:
!        H. Stehfest.  Algorithm 368:  Numerical inversion of Laplace
!              transforms.  Comm. ACM, 13 (1970), 47-49.
!
!              Remark on Algorithm 368, Comm. Acm, 13 (1970), p. 624.
!************************************************************************

      PARAMETER (MXDGTS=16)
      DOUBLE PRECISION CFLT(MXDGTS),G(MXDGTS),H(MXDGTS),FI,SN

!  Calculate CFLT-array

      G(1)=1.D0
      NH=NDGTS/2
      DO I=2,NDGTS
         G(I)=G(I-1)*DBLE(I)
      ENDDO
      H(1)=2.D0/G(NH-1)
      DO I=2,NH
         FI=DBLE(I)
         IF (I==NH) THEN
            H(I)=FI**NH*G(2*I)/(G(I)*G(I-1))
         ELSE
            H(I)=FI**NH*G(2*I)/(G(NH-I)*G(I)*G(I-1))
         ENDIF
      ENDDO
      SN=DBLE(2*(NH-2*(NH/2))-1)
      DO I=1,NDGTS
         CFLT(I)=0.D0
         K1=(I+1)/2
         K2=I
         IF (K2>NH) K2=NH
         DO K=K1,K2
            IF ((2*K-I)==0) THEN
               CFLT(I)=CFLT(I)+H(K)/G(I-K)
            ELSEIF (I==K) THEN
               CFLT(I)=CFLT(I)+H(K)/G(2*K-I)
            ELSE
               CFLT(I)=CFLT(I)+H(K)/(G(I-K)*G(2*K-I))
            ENDIF
         ENDDO
         CFLT(I)=SN*CFLT(I)
         SN=-SN
      ENDDO

      RETURN
      END
!  END OF ROI_DLTCF

      SUBROUTINE ROI_FDREAD (ND,MXFRQ,MXRX,MXTX,NFRQ,NRX,NTX,CDNT,HFD)
!
      IMPLICIT NONE
!
      INTEGER JC,JF,JR,JS,MXFRQ,MXRX,MXTX,ND,NFRQ,NTX
!     ------------------------------------------------------------

!  Reads frequency-domain scattered impulse magnetic field data
!  (imaginary components) from logical UNIT ND into
!  array HFD for conversion to time-domain by SUBROUTINE ROI_TDPULS.


!*** Called by MAIN

!          NFRQ - number of frequencies
!           NRX - number of receivers
!           NTX - number of transmitters
!          CDNT - true for coincident loop option.
!  HFD(I,J,K,L) - Jth component of the imaginary frequency-domain impulse
!                 response magnetic field (H) for transmitter L, at
!                 receiver K for frequency I.

      REAL HFD(MXFRQ,3,MXRX,MXTX)
      INTEGER NRX(MXTX)
      LOGICAL CDNT

      DO JF=1,NFRQ
         DO JS=1,NTX
            DO JR=1,NRX(JS)
               IF (CDNT) THEN
                  READ (ND,*) HFD(JF,3,1,JS)
               ELSE
                  READ (ND,*) (HFD(JF,JC,JR,JS),JC=1,3)
               ENDIF
            ENDDO
         ENDDO
      ENDDO
      RETURN
      END
!  END OF ROI_FDREAD

      SUBROUTINE ROI_HEDCLR (XFP,YFP,NFTRP,XFN,YFN,NFTRPN,YFPC,NFPC,YFNC,   &
                         NFNC,TXRAD,CDNT,MAYBE,NEGC)
!
      IMPLICIT NONE
!
      REAL BES1,TXRAD,X,X1
      INTEGER J1,MXFN,MXFP,NFNC,NFPC,NFTRP,NFTRPN
!     ---------------------------------------------------------------

!  Converts the lambda-t spectrum for the horizontal electric dipole (HED)
!  to that due to a horizontal circular loop representation (CLR)

!***  Called by ROI_HSLYR, ROI_HVMD, and ROI_ZVMD
!***  Calls BES1, ROI_CUBSPL

!     NFTRP is the number of XFP, YFP pairs to be converted
!     NFTRPN is the number of XFN, YFN pairs to be converted
!
!     The result is NFPC Pairs of XFP,YFPC and NFNC pairs of XFN,YFNC.
!
!     TXRAD = radius of equivalent circular loop
!     MAYBE = .FALSE> => the the circular loop approximation definitely
!     won't work.
!     For Cole-Cole models, the validity of the circular loop
!     approximation requires that the YFNC does not oscillate near the
!     beginning.

      PARAMETER (MXFP=120, MXFN=80)
      REAL XFP(MXFP),YFP(4,MXFP),XFN(MXFN),YFN(4,MXFN),YFPC(4,MXFP),   &
           YFNC(4,MXFN)
      LOGICAL CDNT, MAYBE, NEGC

      MAYBE=.TRUE.
      NFPC=0
      NFNC=0
      NEGC=.FALSE.

      DO J1=1,NFTRP
         X=TXRAD*EXP(XFP(J1))
         X1=BES1(X)

!  If the Bessel function is negative, then for strictly positive lambda - t
!  spectra, that simply means earlier attenuation and the CLA (circular loop
!  approximation) is possibly valid.  However, if the original spectrum has
!  negative values as lambda increases, then a sign change invoked by a
!  negative X1 for lambda smaller than that associated with the fifth
!  original negative value makes the CLA invalid.

         IF (X1<=0) THEN
            IF (NFTRPN==0) THEN
               EXIT
            ENDIF
            MAYBE=.FALSE.
!****************************************
            RETURN
!****************************************
         ENDIF

         NFPC=J1
         YFPC(1,J1)=YFP(1,J1)+ALOG(X1)
         IF (CDNT) YFPC(1,J1)=YFPC(1,J1)+XFP(J1)
      ENDDO
      CALL ROI_CUBSPL(XFP,YFPC,NFPC,0,0)

      IF (NFTRPN>0) THEN
         DO J1=1,NFTRPN
            X=TXRAD*XFN(J1)
            X1=BES1(X)
            IF (X1<0) THEN
               IF (NFNC>4) THEN
                  EXIT
               ENDIF
               MAYBE=.FALSE.
!****************************************
               RETURN
!****************************************
            ENDIF

            YFNC(1,J1)=YFN(1,J1)*X1
            IF (CDNT) YFNC(1,J1)=YFNC(1,J1)*XFN(J1)
            NFNC=J1
         ENDDO

         CALL ROI_CUBSPL(XFN,YFNC,NFNC,0,0)
         NEGC=.TRUE.
      ENDIF

      RETURN
      END
!  END OF ROI_HEDCLR

      SUBROUTINE ROI_HSBOSS (MXTYM,NTYRP,TRP,NLYR,RES,THK,ICOLE,CHRG,CTAU,   &
                         CFREQ,SXL,SYL,MRX,RXL,RYL,RZL,CDNT,DWNHL,COLE,   &
                         STEP,BLE)
!
      IMPLICIT NONE
!
      REAL CLP,DIST,RHOMAX,RMX,SLP,X1,X2,XCMP,XREL,XSL,XTCNTR,XTD,Y1,Y2,  &
           YCMP,YREL,YSL,YTCNTR
      INTEGER J1,JR,JT,MRX,MXDGT,MXLYR,MXRX,MXTYM,NDGTS,NLYR,NTYRP
!     -----------------------------------------------------------------

!  Computes BLE(JT,JR,JC), the JC'th component of the step B response of a
!  layered earth at time at time index JT, receiver index JR.
!  JC = 1,2,3 = the X,Y,Z, or East, North, and vertical components
!  respectively.

!***  Called by ROI_TDPULS, ROI_UTEM
!***  Calls DLTC, ROI_HSLYR, ROI_ZHSLYR

!  The display coordinate system is left-handed with:
!  X positive to the East (right),
!  Y positive to the North (up in plan), and Z positive down.

!  The sign convention is that vertical B is positive upwards for receivers
!  inside the loop or smoke ring.  The East (X) component is positive
!  eastwards and the North component is positive northwards.

!   NTYRP - the number of times for which the response is needed.
!     TRP - array of response times
!    NLYR - number of layers
!     RES - array of layer resistivities
!     THK - array of layer thicknesses
!  SXL, SYL - arrays of (X,Y) values for transmitter corners, numbered from
!           lower left, counter-clockwise.
!     XSL - width of transmitter loop
!     YSL - length of transmitter loop
!     MRX - number of receivers
!     RXL - X coordinates of receivers in original coordinate system
!     RYL - Y coordinates of receivers in original coordinate system
!     RZL - Z coordinates of receivers in original coordinate system
!   DWNHL - true if at least 1 of the RZL not equal to 0
!     XRT - X coordinates of receivers in Tx loop coordinate system
!     YRT - Y coordinates of receivers in Tx loop coordinate system
!     SLP - sine of the angle that the segment conecting vertices 2-3
!           makes with the Y axis.  If SXL(3) < SXL(2); SLP < 0.
!     CLP - cosine of that angle.

      PARAMETER (MXRX=50, MXLYR=20, MXDGT=16)
      LOGICAL COLE, DWNHL
      DOUBLE PRECISION CFLT(MXDGT)
      REAL MU0,RES(MXLYR),CNDR(MXLYR),THK(MXLYR),CHRG(MXLYR),   &
           CTAU(MXLYR),CFREQ(MXLYR),CALF(MXLYR),RXL(MXRX),RYL(MXRX),   &
           RZL(MXRX),XRT(MXRX),YRT(MXRX),SXL(4),SYL(4),TRP(NTYRP),   &
           BLE(MXTYM,MXRX,3)
      INTEGER ICOLE(MXLYR)
      LOGICAL STEP, CDNT
      DATA MU0 /12.56637E-7/, NDGTS /16/

      DIST (X1,Y1,X2,Y2) = SQRT ((X1-X2)**2 + (Y1-Y2)**2)

!  Set inverse Laplace transform filter.

      CALL ROI_DLTCF(NDGTS,CFLT)

!  For coincident loop, compute sidelengths and maximum horizontal distance.
!  Otherwise,
!  Compute the sine & cosine of the angle that the segment 2-3 makes with
!  the Y axis.  Compute sidelengths of loop and the position of the
!  receivers relative to the Tx loop centre.

      XSL=DIST(SXL(2),SYL(2),SXL(1),SYL(1))
      X1=SXL(3)-SXL(2)
      Y1=SYL(3)-SYL(2)
      YSL=SQRT(X1**2+Y1**2)
      RHOMAX=1.25*SQRT(XSL**2+YSL**2)

      IF (.NOT.CDNT) THEN
         SLP=X1/YSL
         CLP=Y1/YSL
         IF (ABS(SLP)<1.0E-4) SLP=0.
         IF (ABS(CLP)<1.0E-4) CLP=0.

         XTCNTR=(SXL(1)+SXL(2)+SXL(3)+SXL(4))/4.
         YTCNTR=(SYL(1)+SYL(2)+SYL(3)+SYL(4))/4.
         DO JR=1,MRX
            XREL=RXL(JR)-XTCNTR
            YREL=RYL(JR)-YTCNTR
            XRT(JR)=CLP*XREL-SLP*YREL
            YRT(JR)=SLP*XREL+CLP*YREL
         ENDDO


         RHOMAX=XSL/2.
         DO JR=1,MRX
            RMX=(ABS(XRT(JR))+XSL/2.0)**2+(ABS(YRT(JR))+YSL/2.0)**2
            RHOMAX=AMAX1(RHOMAX,RMX)
         ENDDO
         RHOMAX=1.25*SQRT(RHOMAX)
      ENDIF

!  Set layer constants.

      DO J1=1,NLYR
         CNDR(J1)=MU0/RES(J1)
         ICOLE(J1)=0
         CALF(J1)=0.
         IF (COLE) THEN
            IF (CHRG(J1)>0) THEN
               ICOLE(J1)=1
               CALF(J1)=1.-CHRG(J1)
            ENDIF
         ENDIF
      ENDDO

!  If all receivers are on the surface, compute primary fields using
!  ROI_HSLYR.  If any receivers are subsurface, then ROI_ZHSLYR must be used.

      IF (DWNHL) THEN
         CALL ROI_ZHSLYR(NTYRP,TRP,CNDR,THK,ICOLE,CALF,CTAU,CFREQ,NLYR,     &
                     NDGTS,CFLT,XSL,YSL,MRX,XRT,YRT,RZL,COLE,RHOMAX,BLE)
      ELSE
         CALL ROI_HSLYR(NTYRP,TRP,CNDR,THK,ICOLE,CALF,CTAU,CFREQ,NLYR,NDGTS,&
                    CFLT,XSL,YSL,MRX,XRT,YRT,XTD,COLE,RHOMAX,STEP,CDNT,     &
                    BLE)
      ENDIF

!  Rotate the fields from the Tx loop system to the original
!  coordinate system for roving receiver systems.

      IF (.NOT.CDNT) THEN
         DO JR=1,MRX
            DO JT=1,NTYRP
               XCMP=BLE(JT,JR,1)
               YCMP=BLE(JT,JR,2)
               BLE(JT,JR,1)=(XCMP*CLP)+(YCMP*SLP)
               BLE(JT,JR,2)=-(XCMP*SLP)+(YCMP*CLP)
            ENDDO
         ENDDO
      ENDIF
      RETURN
      END
!  END OF ROI_HSBOSS

      SUBROUTINE ROI_HSLYR (NTYRP,TRP,CNDR,THK,ICOLE,CALF,CTAU,CFREQ,NLYR,  &
                        NDGTS,CFLT,XSL,YSL,MRX,XRT,YRT,XTD,COLE,RHOMAX,     &
                        STEP,CDNT,BLE)
!
      IMPLICIT NONE
!
      REAL BRHO,CLR,CUBVAL,CVDFAC,ERR,FLMIN,FNGMX,HSTHNK,RHOMAX,T,TOL,  &
           TXRAD,VFAC,VFAC0,VMDFAC,XCMP,XFPMID,XNGMX,XSL,XTD
      REAL Y1,Y2,Y3,YCMP,YSL,YY,ZCLP,ZCMP
      INTEGER IRX,J,JC,JDIP,JR,JT,MRX,MXDGT,MXFN,MXFP,MXHNK,MXLYR,MXRX,  &
              MXTX,MXTX1,MXTYM,NDGTS,NDIP,NDX,NDY
      INTEGER NFNC,NFPC,NFTRP,NFTRPN,NLYR,NRTRP,NTYRP
!     ----------------------------------------------------------------

!***  Called by ROI_HSBOSS
!***  Calls ROI_HEDCLR, ROI_HSHTRP, ROI_QHTKER, CUBVAL

!***  OUTPUT: YTR
!***   INPUT: ALL OTHERS

!  Calculates the instantaneous layered 1/2 space response BLE(JT,JR,JC)
!  See ROI_HSBOSS for variable identification.

      PARAMETER (MXTYM=75, MXRX=50, MXLYR=20, MXTX=400, MXTX1=100,     &
                 MXHNK=200, MXFP=120, MXFN=80, MXDGT=16)
      REAL XHNK(MXHNK),YHNK(4,MXHNK),BLE(MXTYM,MXRX,3),TRP(MXTYM),     &
           XRT(MXRX),YRT(MXRX),RHO(MXTX,0:MXRX),XFP(MXFP),YFP(4,MXFP), &
           XFN(MXFN),YFN(4,MXFN),VTXRX(MXTX,0:MXRX),HTXRX(MXTX,2),     &
           CLRHO(MXTX1),RX(MXTX1),RY(MXTX1),XFAC(MXTX1),YFAC(MXTX1),   &
           CNDR(MXLYR),THK(MXLYR),CALF(MXLYR),CTAU(MXLYR),CFREQ(MXLYR),&
           YFPC(4,MXFP),YFNC(4,MXFN)
      DOUBLE PRECISION CFLT(MXDGT)
      INTEGER ICOLE(MXLYR)
      LOGICAL STEP, COLE, NEG, NEGC, CDNT, VMD, MAYBE
      SAVE
      DATA VFAC0 /1.E-7/, TOL /.001/

!  VFAC0 = MU / (4 PI)

!  Set-up electric dipole integration parameters to simulate finite
!  loop source.  However, for late times, adding HED responses will give
!  numerical chaos but the circular loop response (CLR) will be accurate.
!  Then, set up the Hankel transform kernel in (t-lambda) space.

      TXRAD=SQRT(XSL*YSL/3.14159)
      VMDFAC=2.*XSL*YSL*VFAC0/TXRAD
      CVDFAC=XSL*YSL*VMDFAC
      IF (CDNT) THEN
         CALL ROI_SETCLP(XSL,YSL,CLRHO,RX,RY,XFAC,YFAC,NDX,NDY,COLE)
      ELSE
         CALL ROI_SETRHO(XSL,YSL,XRT,YRT,MRX,VTXRX,HTXRX,RHO,NDIP,COLE)
      ENDIF

      XTD=20.
      VFAC=VFAC0
      VMD=.FALSE.
      XFPMID=SQRT(.1*CNDR(1)/TRP(1))

      DO JT=1,NTYRP
         T=TRP(JT)
         DO JC=1,3
            DO JR=1,MRX
               BLE(JT,JR,JC)=0.
            ENDDO
         ENDDO

         CALL ROI_QHTKER(T,CNDR,THK,ICOLE,CALF,CTAU,CFREQ,COLE,NLYR,NDGTS,  &
                     CFLT,XFP,YFP,NFTRP,XFPMID,XFN,YFN,NFTRPN,NEG,XTD,  &
                     XNGMX,FNGMX,FLMIN,STEP,CDNT,VMD,TXRAD)

         IF (CDNT) THEN
!                        COINCIDENT LOOP CASE
!  Set up interpolant of inverse Hankel transform for the horizontal
!  electric dipole function.  Then, integrate this dipole-dipole response
!  around the Tx loop to get the response for each loop segment.  Then
!  integrate each loop segment response around the loop to get the
!  coincident loop response.  This procedure is accomplished as
!  one weighted sum.

            BRHO=.1

            IF (VMD) THEN
               IRX=0
               ZCLP=HSTHNK(BRHO,IRX,XFP,YFP,NFTRP,XFPMID,XFN,YFN,NFTRPN,  &
                    NEG,XNGMX,FNGMX,FLMIN,VMD,TXRAD)
               BLE(JT,1,3)=CVDFAC*ZCLP
            ELSE
               ZCLP=0.
               IRX=1
               CALL ROI_HSHTRP(IRX,RHOMAX,XHNK,YHNK,NRTRP,XFP,YFP,NFTRP,  &
                           XFPMID,XFN,YFN,NFTRPN,NEG,XNGMX,FNGMX,FLMIN,  &
                           VMD,TXRAD)

               DO J=1,NDY
                  Y1=CUBVAL(XHNK,YHNK,NRTRP,CLRHO(J))
                  Y2=CUBVAL(XHNK,YHNK,NRTRP,RX(J))
                  Y3=CUBVAL(XHNK,YHNK,NRTRP,RY(J))
                  ZCLP=ZCLP+XFAC(J)*(Y1-Y2)+YFAC(J)*(Y1-Y3)
               ENDDO
               DO J=NDY+1,NDX
                  Y1=CUBVAL(XHNK,YHNK,NRTRP,CLRHO(J))
                  Y2=CUBVAL(XHNK,YHNK,NRTRP,RX(J))
                  ZCLP=ZCLP+XFAC(J)*(Y1-Y2)
               ENDDO
               BLE(JT,1,3)=VFAC0*ZCLP

!  Check to see if CLR approximation can be used.
!  Convert YFP to CLR from coincident loop HED

               CALL ROI_HEDCLR(XFP,YFP,NFTRP,XFN,YFN,NFTRPN,YFPC,NFPC,YFNC,  &
                           NFNC,TXRAD,CDNT,MAYBE,NEGC)
               IF (MAYBE) THEN
                  IRX=0
                  CLR=CVDFAC*HSTHNK(BRHO,IRX,XFP,YFPC,NFPC,XFPMID,XFN,  &
                      YFNC,NFNC,NEGC,XNGMX,FNGMX,FLMIN,VMD,TXRAD)
                  ERR=ABS(BLE(JT,1,3)-CLR)-(TOL*CLR)
                  IF (ERR<0.) VMD=.TRUE.
               ENDIF
            ENDIF

!  ROI_HSLYR option for coincident loop is finished.

         ELSE
!                ROVING RECEIVER CASE
!  Check to see if CLR approximation is valid.  If not,
!  set up the interpolant of the inverse Hankel transform for both
!  components.  Then integrate the dipole - dipole response over the
!  Tx loop area for each receiver unless VMD is true.

            DO IRX=0,1
               IF (.NOT.VMD) THEN
                  CALL ROI_HSHTRP(IRX,RHOMAX,XHNK,YHNK,NRTRP,XFP,YFP,NFTRP,  &
                     XFPMID,XFN,YFN,NFTRPN,NEG,XNGMX,FNGMX,FLMIN,VMD,TXRAD)
                  IF (IRX==0) CALL ROI_HVMD(XFP,YFP,NFTRP,XFPMID,XFN,YFN,    &
                      NFTRPN,NEG,XNGMX,FNGMX,FLMIN,XHNK,YHNK,NRTRP,RHO,      &
                      VTXRX,NDIP,VMDFAC,VMD,TXRAD)
               ENDIF
               DO JR=1,MRX
                  XCMP=0.
                  YCMP=0.
                  ZCMP=0.
                  IF (VMD) THEN
                     VFAC=VMDFAC
                     BRHO=SQRT(XRT(JR)**2+YRT(JR)**2)
                     BRHO=AMAX1(BRHO,0.01)
                     YY=HSTHNK(BRHO,IRX,XFP,YFP,NFTRP,XFPMID,XFN,YFN,  &
                        NFTRPN,NEG,XNGMX,FNGMX,FLMIN,VMD,TXRAD)

                     IF (IRX==0) THEN
                        ZCMP=YY
                     ELSE
                        XCMP=YY*ABS(XRT(JR))
                        YCMP=YY*ABS(YRT(JR))
                     ENDIF

                  ELSE
                     DO JDIP=1,NDIP
                        BRHO=RHO(JDIP,JR)
                        IF (BRHO<XHNK(1)) BRHO=XHNK(1)
                        IF (BRHO<=XHNK(NRTRP)) THEN
                           YY=CUBVAL(XHNK,YHNK,NRTRP,BRHO)
                        ELSE
                           YY=0.
                        ENDIF
                        IF (IRX==0) THEN
                           ZCMP=ZCMP+VTXRX(JDIP,JR)*YY
                        ELSE
                           XCMP=XCMP+HTXRX(JDIP,1)*YY
                           YCMP=YCMP+HTXRX(JDIP,2)*YY
                        ENDIF
                     ENDDO
                  ENDIF

                  IF (IRX==0) THEN
                     BLE(JT,JR,3)=VFAC*ZCMP
                  ELSE
                     IF (XRT(JR)>.01) BLE(JT,JR,1)=VFAC*XCMP
                     IF (XRT(JR)<-.01) BLE(JT,JR,1)=-VFAC*XCMP

                     IF (YRT(JR)>.01) BLE(JT,JR,2)=VFAC*YCMP
                     IF (YRT(JR)<-.01) BLE(JT,JR,2)=-VFAC*YCMP
                  ENDIF

               ENDDO
            ENDDO
         ENDIF
      ENDDO
      RETURN
      END
!  END OF ROI_HSLYR

      SUBROUTINE ROI_HSHTRP (IRX,RHOMAX,XHNK,YHNK,NRTRP,XFP,YFP,NFTRP,   &
                         XFPMID,XFN,YFN,NFTRPN,NEG,XNGMX,FNGMX,FLMIN,   &
                         VMD,TXRAD)
!
      IMPLICIT NONE
!
      REAL A,B,FLMIN,FNGMX,GS8,GSH,GSQ,GSTEP,HSTHNK,PCT,R12,R14,R18,R34,  &
           R38,R58,R78,RHO,RHOMAX,TXRAD
      REAL XFPMID,XNGMX,Y,Y12,Y14,Y18,Y34,Y38,Y58,Y78
      INTEGER IDX,IRX,J,MXFN,MXFP,MXHNK,NFTRP,NFTRPN,NRTRP
!     -----------------------------------------------------------------

!***   Called by ROI_HSLYR
!***   Calls ROI_CUBSPL, HSTHNK

!  Calculates an interpolating array, YHNK(4,j) for values of the
!  step function tem Hankel transform for the dipole-dipole response
!  of a layered 1/2 space as a function of RHO, the separation distance.

!**  OUTPUT: NRTRP, XHNK, YHNK
!**   INPUT: all others

!          IRX = 0  vertical receiver (use J1 for HED source)
!              = 1  horizontal receiver (use J0 for HED source)
!
!       RHOMAX - maximum distance between receivers and tx loop element.
!         XHNK - array of rho values for interpolation
!         YHNK - array of function values corresponding to XHNK
!        NRTRP - the number of interpolation points required
!
      PARAMETER (MXHNK=200, MXFP=120, MXFN=80)
      REAL XHNK(MXHNK),YHNK(4,MXHNK),XFP(MXFP),YFP(4,MXFP),XFN(MXFN),   &
           YFN(4,MXFN)
      LOGICAL NEG,VMD

      PCT (A,B) = ABS (A-B) - 0.25* ABS ( AMIN1 (A,B))

!  Decide whether vertical magnetic (finite) or horizontal electric dipole
!  representation is to be used.   For a horizontal electric dipole,
!  J1 (IDX = 1) is used for the vertical magnetic fields and J0 (IDX = 0)
!  is used for the horizontal magnetic fields.  For a vertical magnetic
!  dipole (finite radius), the opposite is true.
!  Calculate R > 0 points.  Terminate process for R > RHOMAX.
!  Advance R by 40 metres but cut intervals in half (down to a minimum
!  of 5 metres) if the drop off is more than 25 percent of value.

      IDX=1-IRX

      GSTEP=40.
      GSH=GSTEP/2.
      GSQ=GSTEP/4.
      GS8=GSTEP/8.

      XHNK(1)=0.01
      YHNK(1,1)=HSTHNK(XHNK(1),IDX,XFP,YFP,NFTRP,XFPMID,XFN,YFN,NFTRPN,  &
                NEG,XNGMX,FNGMX,FLMIN,VMD,TXRAD)
      NRTRP=1

      DO J=2,MXHNK
         RHO=XHNK(NRTRP)+GSTEP
         Y=HSTHNK(RHO,IDX,XFP,YFP,NFTRP,XFPMID,XFN,YFN,NFTRPN,NEG,XNGMX,  &
           FNGMX,FLMIN,VMD,TXRAD)
         IF (PCT(YHNK(1,NRTRP),Y)>0.) THEN
            R12=RHO-GSH
            Y12=HSTHNK(R12,IDX,XFP,YFP,NFTRP,XFPMID,XFN,YFN,NFTRPN,NEG,  &
                XNGMX,FNGMX,FLMIN,VMD,TXRAD)

            IF (PCT(YHNK(1,NRTRP),Y12)>0.) THEN
               R14=R12-GSQ
               Y14=HSTHNK(R14,IDX,XFP,YFP,NFTRP,XFPMID,XFN,YFN,NFTRPN,  &
                   NEG,XNGMX,FNGMX,FLMIN,VMD,TXRAD)

               IF (PCT(YHNK(1,NRTRP),Y14)>0.) THEN
                  R18=R14-GS8
                  Y18=HSTHNK(R18,IDX,XFP,YFP,NFTRP,XFPMID,XFN,YFN,  &
                      NFTRPN,NEG,XNGMX,FNGMX,FLMIN,VMD,TXRAD)
                  NRTRP=NRTRP+1
                  XHNK(NRTRP)=R18
                  YHNK(1,NRTRP)=Y18
               ENDIF

               NRTRP=NRTRP+1
               XHNK(NRTRP)=R14
               YHNK(1,NRTRP)=Y14

               IF (PCT(Y12,Y14)>0.) THEN
                  R38=R14+GS8
                  Y38=HSTHNK(R38,IDX,XFP,YFP,NFTRP,XFPMID,XFN,YFN,  &
                      NFTRPN,NEG,XNGMX,FNGMX,FLMIN,VMD,TXRAD)
                  NRTRP=NRTRP+1
                  XHNK(NRTRP)=R38
                  YHNK(1,NRTRP)=Y38
               ENDIF
            ENDIF

            NRTRP=NRTRP+1
            XHNK(NRTRP)=R12
            YHNK(1,NRTRP)=Y12

            IF (PCT(Y12,Y)>0.) THEN
               R34=RHO-GSQ
               Y34=HSTHNK(R34,IDX,XFP,YFP,NFTRP,XFPMID,XFN,YFN,NFTRPN,  &
                   NEG,XNGMX,FNGMX,FLMIN,VMD,TXRAD)
               IF (PCT(Y12,Y34)>0.) THEN
                  R58=R34-GS8
                  Y58=HSTHNK(R58,IDX,XFP,YFP,NFTRP,XFPMID,XFN,YFN,  &
                      NFTRPN,NEG,XNGMX,FNGMX,FLMIN,VMD,TXRAD)
                  NRTRP=NRTRP+1
                  XHNK(NRTRP)=R58
                  YHNK(1,NRTRP)=Y58
               ENDIF
               NRTRP=NRTRP+1
               XHNK(NRTRP)=R34
               YHNK(1,NRTRP)=Y34
               IF (PCT(Y,Y34)>0.) THEN
                  R78=R34+GS8
                  Y78=HSTHNK(R78,IDX,XFP,YFP,NFTRP,XFPMID,XFN,YFN,  &
                      NFTRPN,NEG,XNGMX,FNGMX,FLMIN,VMD,TXRAD)
                  NRTRP=NRTRP+1
                  XHNK(NRTRP)=R78
                  YHNK(1,NRTRP)=Y78
               ENDIF
            ENDIF
         ENDIF
         NRTRP=NRTRP+1
         XHNK(NRTRP)=RHO
         YHNK(1,NRTRP)=Y

         IF (XHNK(NRTRP)>=RHOMAX) THEN
            EXIT
         ENDIF

      ENDDO
      CALL ROI_CUBSPL(XHNK,YHNK,NRTRP,0,0)

      RETURN
      END
!  END OF ROI_HSHTRP

      FUNCTION HSTHNK (HDIST,IDX,XFP,YFP,NFTRP,XFPMID,XFN,YFN,NFTRPN,   &
                       NEG,XNGMX,FNGMX,FLMIN,VMD,TXRAD)
      REAL F,FLMIN,FNGMX,FWMAX,HDIST,HSTHNK,HVAL,TXRAD,XFPBEG,XFPMID,  &
           XNGMX,XS,XSL
      INTEGER I,IDX,IRMAX,MXFN,MXFP,NFMAX,NFTRP,NFTRPN,NGVAL,NLBEG,  &
              NPVAL,NRBEG
!     ---------------------------------------------------------------

!***   Called by ROI_HSHTRP
!***   Calls ROI_HSVALP, HSVALN

!  Computes the inverse HANKEL transform (J0 or J1) of the function
!  Y (X * HDIST), interpolated by YFP (XFP) and YFN (XFN)  (Cole-Cole case)
!  using filter coefficients taken from Walt Anderson's subprogram, ZHANKS.
!  It uses the fact that the inverse Laplace transform must be positive
!  for real resistivities, thus damping the effect of roundoff error.
!  It starts from the midpoint of the positive portion, XFPMID.

!  REF: Anderson, W.L., 1979, Geophysics, vol 44, 1287-1305.
!*********************************************************************

!         HDIST - Hankel transform argument.  HDIST MUST BE .GE. 0.

!       IDX = 0   computes J0 transform -  FUN(X) * J0 (HDIST*X)
!                 vertical H from VMD; horizontal H from HED
!                 horizontal E from HED
!           = 1   computes J1 transform -  FUN(X) * J1 (HDIST*X)
!                 horizontal H from VMD; vertical H from HED

      PARAMETER (MXFP=120, MXFN=80)
      REAL XFP(MXFP),YFP(4,MXFP),XFN(MXFN),YFN(4,MXFN)
      DOUBLE PRECISION E,ER,X1,X,XRMAX
      LOGICAL JUMP, NEG, VMD
      DATA E/1.221402758160169834D0/,ER/.818730753077981859D0/

!        E = DEXP(.2D0), ER = 1.0D0/E

!  Initialize kernel abscissa generation WRT B.
!  Start at filter weight NRBEG. Total number of weights = NFMAX.

      NFMAX=283
      NPVAL=0
      NGVAL=0
      FWMAX=0.
      HVAL=0.
      NRBEG=117
      XFPBEG=EXP(XFP(5))
      X1=0.447492291194338237D-01/DBLE(HDIST)

  100 IF (X1>XFPMID) THEN
         X1=X1*ER
         NRBEG=NRBEG-1
         GOTO 100
      ENDIF

  200 IF (X1<XFPBEG) THEN
         X1=X1*E
         NRBEG=NRBEG+1
         GOTO 200
      ENDIF
      NLBEG=NRBEG-1
      X=X1

!  Begin right side convolution at weight NRBEG.  End when XFP range is
!  exceeded or JUMP is TRUE.

      DO I=NRBEG,NFMAX
         X=X*E
         XSL=ALOG(SNGL(X))
         IF (XSL>XFP(NFTRP)) THEN
            EXIT
         ENDIF
         CALL ROI_HSVALP(I,XSL,XFP,YFP,NFTRP,IDX,HVAL,FWMAX,NPVAL,JUMP,  &
                     FLMIN,VMD,TXRAD)
         IRMAX=I
         XRMAX=X
         IF ((JUMP).AND.(.NOT.NEG)) THEN
            EXIT
         ENDIF
      ENDDO

!  Continue with left-side convolution at weight NLBEG.  End when
!  JUMP is TRUE and at least 10 function evaluations have occured - or
!  when the filter coefficient or XFP range has been exceeded.

      X=X1
      XSL=ALOG(SNGL(X1))
      DO I=NLBEG,2,-1
         CALL ROI_HSVALP(I,XSL,XFP,YFP,NFTRP,IDX,HVAL,FWMAX,NPVAL,JUMP,  &
                     FLMIN,VMD,TXRAD)
         X=X*ER
         XSL=ALOG(SNGL(X))
         IF (XSL<XFP(2)) THEN
            EXIT
         ENDIF
         IF (JUMP.AND.(NPVAL>=10)) THEN
            EXIT
         ENDIF
      ENDDO

!  Add in negative portion.

      IF (NEG) THEN
         X=XRMAX
         F=0.
         DO I=IRMAX+1,NFMAX
            X=X*E
            XS=SNGL(X)
            IF (XS>XFN(NFTRPN)) THEN
               EXIT
            ENDIF
            CALL HSVALN(I,XS,XFN,YFN,NFTRPN,XNGMX,FNGMX,IDX,HVAL,F,  &
                        NGVAL,JUMP,VMD,TXRAD)
            IF (JUMP) THEN
               EXIT
            ENDIF
         ENDDO
      ENDIF

!  Convergence achieved or filter worn out

      HSTHNK=HVAL/HDIST
      IF (IDX==1) HSTHNK=HSTHNK/HDIST

      RETURN
      END
!  END OF HSTHNK

      SUBROUTINE ROI_HSVALP (I,XSL,XFP,YFP,NFTRP,IDX,HVAL,FWMAX,NPVAL,JUMP,   &
                         FLMIN,VMD,TXRAD)
!
      IMPLICIT NONE
!
      REAL AFW,AHVAL,BES1,CUBVAL,DELCOS,F,FLMIN,FW,FWMAX,HVAL,TMAX,TOL,  &
           TXRAD,WCOS,WJ0,WJ1,WS,XSL
      INTEGER I,IDX,MXFP,NFTRP,NPVAL
!     -----------------------------------------------------------------

!***  Called by HSTHNK
!***  Calls CUBVAL

!  Evaluates and accumulates function calls for Hankel transformation for
!  the positive part of the kernel ( stored in log-log form).

!        I - filter point index
!      XSL - the point at which the function interpolated by YFP (XFP)
!            is to be evaluated.
!    NFTRP - number of knots
!     HVAL - cumulative value of hankel transform process.
!    FWMAX - magnitude of largest contribution to hval.
!    NPVAL - number of function evaluations
!     JUMP - convergence indicator based on both maximum and accumulated
!            values.
!      IDX = 0   computes J0 transform -  FUN(X) * J0(B*X)
!          = 1   computes J1 transform -  FUN(X) * J1(B*X)

      PARAMETER (MXFP=120)
      COMMON /FILTER/ DELCOS,WCOS(-200:99), WJ0(283), WJ1(283), WS(266)
      REAL XFP(MXFP),YFP(4,MXFP)
      LOGICAL JUMP, VMD
      DATA TOL /0.001/

      NPVAL=NPVAL+1
      JUMP=.FALSE.
      IF (XSL<XFP(1)) THEN
         F=FLMIN*XSL**2
         IF (VMD) F=F*BES1(XSL*TXRAD)
      ELSE
         F=CUBVAL(XFP,YFP,NFTRP,XSL)
         F=EXP(F)
      ENDIF

      IF (IDX==0) THEN
         FW=F*WJ0(I)
      ELSE
         FW=F*WJ1(I)
      ENDIF

      HVAL=HVAL+FW
      AFW=ABS(FW)
      AHVAL=ABS(HVAL)
      FWMAX=AMAX1(AFW,FWMAX)
      TMAX=TOL*AMIN1(FWMAX,AHVAL)
      IF (AFW<TMAX) JUMP=.TRUE.

      RETURN
      END
!  END OF ROI_HSVALP

      SUBROUTINE HSVALN (I,X,XFN,YFN,NFTRPN,XNGMX,FNGMX,IDX,HVAL,F,   &
                         NGVAL,JUMP,VMD,TXRAD)
!
      IMPLICIT NONE
!
      REAL BES1,CUBVAL,DELCOS,F,FNGMX,FW,HVAL,OLDF,TOL,TXRAD,WCOS,WJ0,  &
           WJ1,WS,X,XNGMX
      INTEGER I,IDX,MXFN,NFTRPN,NGVAL
!     -----------------------------------------------------------------

!***  Called by HSTHNK
!***  Calls CUBVAL

!  Evaluates and accumulates function calls for Hankel transformation for
!  the negative part of the kernel.

!        I - filter point index
!        X - the point at which the function interpolated by YFN (XFN)
!            is to be evaluated.
!   NFTRPN - number of knots in yfn.
!        F - value of yfa from previous call.
!    NGVAL - number of calls to hsvaln
!     HVAL - cumulative value of hankel transform process.
!     JUMP - convergence indicator based on both maximum and accumulated
!            values.
!      IDX = 0   computes J0 transform -  FUN(X) * J0(B*X)
!          = 1   computes J1 transform -  FUN(X) * J1(B*X)

      PARAMETER (MXFN=80)
      COMMON /FILTER/ DELCOS,WCOS(-200:99), WJ0(283), WJ1(283), WS(266)
      REAL XFN(MXFN),YFN(4,MXFN)
      LOGICAL JUMP, VMD
      DATA TOL /0.001/

      NGVAL=NGVAL+1
      JUMP=.FALSE.
      OLDF=ABS(F)
      IF (X<XNGMX) THEN
         F=CUBVAL(XFN,YFN,NFTRPN,X)
      ELSE
         F=FNGMX/X
         IF (VMD) F=F*BES1(X*TXRAD)
      ENDIF

      IF (IDX==0) THEN
         FW=F*WJ0(I)
      ELSE
         FW=F*WJ1(I)
      ENDIF

      HVAL=HVAL+FW
      IF (ABS(FW)<(TOL*ABS(HVAL))) JUMP=.TRUE.
      IF ((ABS(F)>OLDF).OR.(NGVAL<4)) JUMP=.FALSE.

      RETURN
      END
!  END OF HSVALN

      SUBROUTINE ROI_HVMD (XFP,YFP,NFTRP,XFPMID,XFN,YFN,NFTRPN,NEG,XNGMX,   &
                       FNGMX,FLMIN,XHNK,YHNK,NRTRP,RHO,VTXRX,NDIP,   &
                       VMDFAC,VMD,TXRAD)
!
      IMPLICIT NONE
!
      REAL BRHO,CLR,CUBVAL,ERR,FLMIN,FNGMX,HSTHNK,TOL,TXRAD,VFAC0,  &
           VMDFAC,XFPMID,XNGMX,YY,ZCMP,ZLOOP
      INTEGER IRX,J1,J2,JDIP,MXFN,MXFP,MXHNK,MXRX,MXTX,NDIP,NFNC,NFPC,  &
              NFTRP,NFTRPN,NRTRP
!     -----------------------------------------------------------------

!  Compares the vertical impulse B field at a receiver in the middle
!  of a rectangular loop with that generated by a circular loop of the
!  same moment.  If they are within 1 percent

!  VMD IS TRUE

!  and the fields from then on are computed as due to a circular loop.

!  XFP, YFP, NFTRP, XFPMID, XFN, YFN, NFTRPN, NEG, XNGMX, FNGMX, and FLMIN
!  are all variables arising from SUBROUTINE ROI_QHTKER.

!  XHNK, YHNK, and NRTRP arise from SUBROUTINE ROI_HSHTRP.
!  RHO, VTXRX AND NDIP are distances and coupling factors between the loop
!  (divided into NDIP segments) and a receiver.
!  Testing VMD is what this subroutine is about.

!***  Called by ROI_HSLYR
!***  Calls ROI_HEDCLR, HSTHNK, CUBVAL

      PARAMETER (MXRX=50, MXTX=400, MXHNK=200, MXFP=120, MXFN=80)
      REAL XHNK(MXHNK),YHNK(4,MXHNK),RHO(MXTX,0:MXRX),XFP(MXFP),   &
           YFP(4,MXFP),YFPC(4,MXFP),XFN(MXFN),YFN(4,MXFN),YFNC(4,MXFN),   &
           VTXRX(MXTX,0:MXRX)
      LOGICAL CDNT, VMD, NEG, MAYBE, NEGC
      DATA VFAC0 /1.E-7/, TOL /.001/

!  VFAC0 = MU / (4 PI);  VMDFAC = 2. * TXAREA * VFAC0 / TXRAD

      CDNT=.FALSE.
      VMD=.FALSE.
      BRHO=0.1
      IRX=0

!  Set ROI_QHTKER CLR representation YDP from ROI_QHTKER HED representation YFP.
!  If MAYBE is false, VMD is false so leave already.

      CALL ROI_HEDCLR(XFP,YFP,NFTRP,XFN,YFN,NFTRPN,YFPC,NFPC,YFNC,NFNC,  &
                  TXRAD,CDNT,MAYBE,NEGC)
      IF (MAYBE) THEN

         CLR=VMDFAC*HSTHNK(BRHO,IRX,XFP,YFPC,NFPC,XFPMID,XFN,YFNC,NFNC,  &
             NEGC,XNGMX,FNGMX,FLMIN,VMD,TXRAD)
         ZCMP=0.
         DO JDIP=1,NDIP
            BRHO=RHO(JDIP,0)
            IF (BRHO<XHNK(1)) BRHO=XHNK(1)
            IF (BRHO<=XHNK(NRTRP)) THEN
               YY=CUBVAL(XHNK,YHNK,NRTRP,BRHO)
            ELSE
               YY=0.
            ENDIF
            ZCMP=ZCMP+VTXRX(JDIP,0)*YY
         ENDDO

         ZLOOP=VFAC0*ZCMP
         ERR=ABS(ZLOOP-CLR)-(TOL*CLR)

!  If the loop response is within 1 percent of the circular loop response,
!  then the CLR representation will be used back in ROI_HSLYR.

         IF (ERR<0.) THEN
            VMD=.TRUE.
            NEG=NEGC
            NFTRP=NFPC
            NFTRPN=NFNC
            DO J1=1,NFPC
               DO J2=1,4
                  YFP(J2,J1)=YFPC(J2,J1)
               ENDDO
            ENDDO

            IF (NEG) THEN
               DO J1=1,NFNC
                  DO J2=1,4
                     YFN(J2,J1)=YFNC(J2,J1)
                  ENDDO
               ENDDO
            ENDIF
         ENDIF
      ENDIF

      RETURN
      END
!  END OF ROI_HVMD

      SUBROUTINE ROI_INTERV (XT, LXT, X, LEFT, MFLAG)
!   ------------------------------------------

!***   CALLED BY CUBVAL, CUBINT, CUBDER

!from  * A PRACTICAL GUIDE TO SPLINES *  by C. DE BOOR
!computes  LEFT = MAX( I , 1 .LE. I .LE. LXT  .AND.  XT(I) .LE. X )  .
!
!           INPUT
!           -----
!     XT - a real sequence, of length  LXT, assumed to be non-decreasing.
!    LXT - number of terms in the sequence  XT .
!      X - the point whose location with respect to the sequence XT is
!          to be determined.
!
!           OUTPUT
!           ------
!    LEFT, MFLAG.....are both integers, whose value is:
!
!      1     -1      IF               X .LT.  XT(1)
!      I      0      IF   XT(I)  .LE. X .LT. XT(I+1)
!     LXT     1      IF  XT(LXT) .LE. X
!
!      In particular, MFLAG = 0 is the 'usual' case.  MFLAG .NE. 0
!      indicates that X  lies outside the halfopen interval
!      XT(1) .LE. Y .LT. XT(LXT) . The asymmetric treatment of the
!      interval is due to the decision to make all pp functions
!      continuous from the right.
!
!           METHOD
!           ------
!
!The program is designed to be efficient in the common situation that
!it is called repeatedly, with  x  taken from an increasing or decreasing
!sequence. This will happen, e.g., when a pp function is to be grapged.
!THE FIRST GUESS FOR  LEFT  IS THEREFORE TAKEN TO BE THE VALUE RETURNED AT
!THE PREVIOUS CALL AND STORED IN THE  L O C A L  VARIABLE ILO. A FIRST
!CHECK ASCERTAINS THAT  ILO .LT. LXT (THIS IS NECESSARY SINCE THE PRESENT
!CALL MAY HAVE NOTHING TO DO WITH THE PREVIOUS CALL).
!THEN, IF XT(ILO) .LE. XT(ILO+1),
!WE SET  LEFT = ILO  AND ARE DONE AFTER JUST THREE COMPARISONS.
!OTHERWISE, WE REPEATEDLY DOUBLE THE DIFFERENCE  ISTEP = IHI - ILO
!WHILE ALSO MOVING  ILO  AND  IHI  IN THE DIRECTION OF  X , UNTIL
!                    XT(ILO) .LE. X .LT. XT(IHI) ,
!AFTER WHICH WE USE BISECTION TO GET, IN ADDITION, ILO+1 = IHI .
!LEFT = ILO  IS THEN RETURNED.
!******************************************************************************
!******************************************************************************
!
      IMPLICIT NONE
!
      INTEGER LEFT,LXT,MFLAG,IHI,ILO,ISTEP,MIDDLE
      REAL X,XT(LXT)
      SAVE ILO

      DATA ILO /1/

      IHI=ILO+1
      IF (IHI>=LXT) THEN
         IF (X>=XT(LXT)) THEN
            GOTO 500
         ENDIF
         IF (LXT<=1) THEN
            GOTO 300
         ENDIF
         ILO=LXT-1
         IHI=LXT
      ENDIF
!
      IF (X>=XT(IHI)) THEN

!NOW X .GE. XT(IHI) . INCREASE  IHI  TO CAPTURE  X .

         ISTEP=1
   50    ILO=IHI
         IHI=ILO+ISTEP
         IF (IHI>=LXT) THEN
            IF (X>=XT(LXT)) THEN
               GOTO 500
            ENDIF
            IHI=LXT
         ELSEIF (X>=XT(IHI)) THEN
            ISTEP=ISTEP*2
            GOTO 50
         ENDIF
      ELSE
         IF (X>=XT(ILO)) THEN
            GOTO 400
         ENDIF
!
!NOW X .LT. XT(ILO) . DECREASE  ILO  TO CAPTURE  X .
!
         ISTEP=1
  100    IHI=ILO
         ILO=IHI-ISTEP
         IF (ILO<=1) THEN
            ILO=1
            IF (X<XT(1)) THEN
               GOTO 300
            ENDIF
         ELSEIF (X<XT(ILO)) THEN
            ISTEP=ISTEP*2
            GOTO 100
         ENDIF
      ENDIF
!
!NOW XT(ILO) .LE. X .LT. XT(IHI) . NARROW THE ROI_INTERVAL.
!
  200 MIDDLE=(ILO+IHI)/2
      IF (MIDDLE==ILO) THEN
         GOTO 400
      ENDIF

!NOTE. IT IS ASSUMED THAT MIDDLE = ILO IN CASE IHI = ILO+1 .

      IF (X<XT(MIDDLE)) THEN
         IHI=MIDDLE
      ELSE
         ILO=MIDDLE
      ENDIF
      GOTO 200

! SET OUTPUT AND RETURN.

  300 MFLAG=-1
      LEFT=1
      RETURN

  400 MFLAG=0
      LEFT=ILO
      RETURN

  500 MFLAG=1
      LEFT=LXT
      RETURN
      END
!END OF ROI_INTERV

      SUBROUTINE ROI_QHTKER (T,CNDR,THK,ICOLE,CALF,CTAU,CFREQ,COLE,NLYR,   &
                         NDGTS,CFLT,XFP,YFP,NFTRP,XFPMID,XFN,YFN,   &
                         NFTRPN,NEG,XTD,XNGMX,FNGMX,FLMIN,STEP,CDNT,   &
                         VMD,TXRAD)
!
      IMPLICIT NONE
!
      REAL AYF,AYFMX,DIF,FJMP,FLMIN,FMAX,FNGMX,FQ,QINC,QINCN,QINCR,  &
           QLPTD,QSNTD,T,TOL,TOLC,TXRAD,X,X0,XFPMID
      REAL XMAX,XNGMX,XPT,XTD
      INTEGER J,JDF,JL,JMAX,JMID,JMIN,JN,JQ,JSTART,JT,LONG,MXDGT,MXFN,  &
              MXFP,MXLYR,NDGTS,NFTRP,NFTRP1,NFTRPN,NLYR
      INTEGER NPTS
!     ----------------------------------------------------------------

!***   Called by ROI_HSLYR
!***   Calls  ROI_CUBSPL, QLPTD, QSNTD

!**  OUTPUT: XFP, XFN, YFP, YFN, NFTRP, NFTRPN, XFPMID, NEG, XTD
!**   INPUT: ALL OTHERS

!  Calculates values of the step response TEM Hankel transform kernel for
!  electric dipole transmitter of unit length.  For late times, a circular
!  loop approximation is more accurate than adding up HED contributions of
!  opposite sign.  BES1 is used to transform the HED spectrum to the
!  horizontal circular loop approximation
!  For real conductivity models, an inverse Laplace transform procedure
!  (QLPTD) is used.  The results are positive and are stored as logs in
!  YFP(1,J) as a function of the log (Hankel transform variable), XFP(J).
!  Cole-Cole models (COLE = .TRUE.) produce negatives for large XFP.
!  These are stored in YFN(1,J) as a function of XFN(J).  Splines are
!  drawn to allow interpolated values to be used.
!
!  For negatives, QLPTD is not sufficiently accurate so a sine transform
!  (QSNTD) is used.  A backtrack into the positive numbers is done until
!  the two procedures achieve the same result.  XTD is the resulting
!  crossover point for the two methods.  To avoid excessive recalculation,
!  XTD is saved because as T increases, it moves just gradually to the left.
!  QSNTD takes about four times longer than QLPTD.  NEG is true only if
!  there is a negative portion.
!
!  For Cole-Cole cases, the negative part of the LAMBDA spectrum falls
!  to zero as 1/LAMBDA for large LAMBDA.  This can be used to shorten
!  the spectrum calculation by stopping the calculation when
!  LAMBDA * YFP approaches a negative constant and then using this
!  constant in SUBROUTINE HSVALN for large LAMBDA.
!
!     NFTRP - number of values of XFP and YFP to be used as knots.
!             All YFP are logs of positive numbers.
!    NFTRPN - number of values of XFN and YFN to be used as knots.
!             All YFN are negative except the first which is the same
!             as EXP( YFP(NFTRP) )
!******************************************************************************
!******************************************************************************
!
      PARAMETER (MXDGT=16, MXLYR=20, MXFP=120, MXFN=80)
      LOGICAL STEP, VMD, COLE, NEG, JUMP, CDNT, CDNTI
      DOUBLE PRECISION CFLT(MXDGT)
      REAL CNDR(MXLYR),THK(MXLYR),CALF(MXLYR),CTAU(MXLYR),CFREQ(MXLYR),   &
           XFP(MXFP),YFP(4,MXFP),XFN(MXFN),YFN(4,MXFN),YDF(MXFP),   &
           YL(MXFN)
      INTEGER ICOLE(MXLYR)
      SAVE
      DATA    TOL,   TOLC,   QINCN   &
           /1.0E-10, 0.005,  1.25/

      NPTS=11
      XPT=1./FLOAT(NPTS)
      QINCR=10**XPT

      CDNTI=CDNT
      IF (VMD) CDNTI=.FALSE.
      NEG=.FALSE.
      JSTART=60
      X0=XFPMID
      QINC=QINCR

!  Find starting abscissa X0 by requiring QLPTD > 0.  Start from midpoint
!  of positive part of previous pulse.

  100 IF ((COLE).AND.(X0>=XTD)) THEN
         FQ=QSNTD(X0,T,CNDR,THK,ICOLE,CALF,CTAU,CFREQ,NLYR,STEP,CDNTI,  &
            VMD,TXRAD)
      ELSE
         FQ=QLPTD(X0,T,CNDR,THK,ICOLE,CALF,CTAU,CFREQ,NLYR,NDGTS,CFLT,  &
            STEP,CDNTI,VMD,TXRAD)
      ENDIF
      IF (FQ<=0) THEN
         X0=0.1*X0
         GOTO 100
      ENDIF

      JMAX=JSTART
      JMIN=JSTART
      X=X0
      FMAX=FQ
      YFP(1,JSTART)=FQ
      XFP(JSTART)=X

      DO J=JSTART+1,MXFP
         X=X*QINC
         IF ((COLE).AND.(X>=XTD)) THEN
            FQ=QSNTD(X,T,CNDR,THK,ICOLE,CALF,CTAU,CFREQ,NLYR,STEP,CDNTI,  &
               VMD,TXRAD)
         ELSE
            FQ=QLPTD(X,T,CNDR,THK,ICOLE,CALF,CTAU,CFREQ,NLYR,NDGTS,CFLT,  &
               STEP,CDNTI,VMD,TXRAD)
         ENDIF
         FMAX=AMAX1(FMAX,FQ)
         JMAX=J
         XMAX=X
         XFP(J)=X
         YFP(1,J)=FQ
         IF (FQ<0) THEN
            EXIT
         ENDIF
!********************************

      ENDDO

!  Calculate values to the left of X0

      X=X0
      QINC=1.0/QINCR
      DO J=JSTART-1,1,-1
         JL=JSTART-J
         X=X*QINC
         IF ((COLE).AND.(X>=XTD)) THEN
            FQ=QSNTD(X,T,CNDR,THK,ICOLE,CALF,CTAU,CFREQ,NLYR,STEP,CDNTI,  &
               VMD,TXRAD)
         ELSE
            FQ=QLPTD(X,T,CNDR,THK,ICOLE,CALF,CTAU,CFREQ,NLYR,NDGTS,CFLT,  &
               STEP,CDNTI,VMD,TXRAD)
         ENDIF
         FLMIN=FQ/X**2
         YL(JL)=FLMIN
!**********************************************************************
         IF ((FQ<FMAX).AND.(JL>5)) THEN
            DIF=ABS(YL(JL)-YL(JL-4))
            IF (DIF<TOLC*FLMIN) THEN
               EXIT
            ENDIF
         ENDIF

         IF ((FQ<=TOL*FMAX).OR.(X<=1.0E-20)) THEN
            EXIT
         ENDIF
         JMIN=J
         XFP(J)=X
         YFP(1,J)=FQ
         FMAX=AMAX1(FMAX,FQ)
         IF (FQ<0.5*FMAX) QINC=0.7
      ENDDO

!  Clean up arrays.  For non-Cole-Cole case, store log values, go to
!  end of program, and draw cubic spline.

      NFTRP=JMAX-JMIN
      DO J=JMIN,JMAX
         JQ=J-JMIN+1
         XFP(JQ)=XFP(J)
         YFP(1,JQ)=YFP(1,J)
      ENDDO
      JMAX=NFTRP+1
!******************************************
      IF (COLE) THEN
!******************************************

!  for large X, the inverse sine transform is more accurate (but much
!  slower) than the inverse Laplace transform.  Backtrack for corrections
!  until the two methods agree.

         NFTRP1=JMAX
         XTD=AMIN1(XMAX,XTD)
         DO J=NFTRP1,1,-1
            IF (XFP(J)<XTD) THEN
               FQ=QSNTD(XFP(J),T,CNDR,THK,ICOLE,CALF,CTAU,CFREQ,NLYR,  &
                  STEP,CDNTI,VMD,TXRAD)
               DIF=ABS(YFP(1,J)-FQ)
               YFP(1,J)=FQ
               XTD=XFP(J)
               IF ((FQ>0).AND.(DIF<(TOLC*FQ))) THEN
                  EXIT
               ENDIF
            ENDIF
         ENDDO

!  NOW FILL IN THE NEGATIVES.  JUMP WHEN NEGATIVES HIT CONSTANT VALUE
!  OR GO POSITIVE, OR DON'T REALLY OCCUR AFTER FOUR MORE HITS.

         JUMP=.FALSE.
         QINC=QINCR
         LONG=NFTRP1+4
         AYFMX=0.
         DO J=NFTRP1+1,MXFP
            JDF=J-NFTRP1
            XFP(J)=XFP(J-1)*QINC
            XMAX=XFP(JMAX)
            YFP(1,J)=QSNTD(XFP(J),T,CNDR,THK,ICOLE,CALF,CTAU,CFREQ,NLYR,  &
                     STEP,CDNTI,VMD,TXRAD)
            XNGMX=XMAX
            FNGMX=XMAX*YFP(1,J)
            YDF(JDF)=FNGMX
            IF (YFP(1,J)<0) THEN
               NEG=.TRUE.
               JMAX=J

               IF (J>LONG) THEN
                  QINC=QINCN
                  AYF=ABS(YFP(1,J))
                  AYFMX=AMAX1(AYF,AYFMX)
                  FJMP=TOLC*ABS(FNGMX)
                  DIF=ABS(YDF(JDF)-YDF(JDF-1))  &
                      +ABS(YDF(JDF-2)-YDF(JDF-1))
                  IF (DIF<FJMP) JUMP=.TRUE.
                  IF (AYF<1.0E-4*AYFMX) JUMP=.TRUE.
               ENDIF

            ELSEIF (NEG) THEN
               JUMP=.TRUE.
            ELSE
               JMAX=J
               IF (J>=LONG) JUMP=.TRUE.
            ENDIF
            IF (JUMP) THEN
               EXIT
            ENDIF
         ENDDO
      ENDIF

!  Separate YFP into positive and negative portions.  Multiply by BES1
!  if circular loop approximation is to be used.
!  Draw spline for negative part and for log of positive part.

      DO J=1,JMAX
         X=XFP(J)
         FQ=YFP(1,J)
         IF (FQ>0) THEN
            XFP(J)=ALOG(X)
            YFP(1,J)=ALOG(FQ)
            NFTRP=J
         ENDIF
      ENDDO

      JMID=NFTRP/2
      XFPMID=EXP(XFP(JMID))
      CALL ROI_CUBSPL(XFP,YFP,NFTRP,0,0)

      NFTRPN=JMAX-NFTRP
      IF (NFTRPN<4) THEN
         NFTRPN=0
         NEG=.FALSE.
      ENDIF

      IF (NEG) THEN
         XFN(1)=EXP(XFP(NFTRP))
         YFN(1,1)=EXP(YFP(1,NFTRP))
         DO JN=2,NFTRPN
            JT=JN+NFTRP-1
            XFN(JN)=XFP(JT)
            YFN(1,JN)=YFP(1,JT)
         ENDDO
         CALL ROI_CUBSPL(XFN,YFN,NFTRPN,0,0)
      ENDIF

      RETURN
      END
!  END OF ROI_QHTKER

      DOUBLE PRECISION FUNCTION QLPFD (P,LMBDA,CNDR,THK,ICOLE,CALF,   &
                                       CTAU,CFREQ,NLYR)
      INTEGER J1,JJ,MXLYR,NLYR,NLYRT
!     -----------------------------------------------------------------

!***  Called by QLPTD

!  Computes the layered-earth impulse response kernel for the inverse
!  Laplace transform in double precision.

!       P - Laplace transform variable.
!   LMBDA - Hankel transform variable
!    NLYR - number of layers
!    CNDR - scaled conductivity
!     THK - layer thicknesses
!    ICOLE - C-C layer indicator array. (0 for pure real, 1 for C-C layer)
!     CALF - complementary chargeability array; ie., CALF(I) = 1.0 - CHRG(I)
!     CTAU - array of layer relaxation times (sec).
!    CFREQ - array of layer frequency parameters.

      PARAMETER (MXLYR=20)
      REAL CNDR(MXLYR),THK(MXLYR),CALF(MXLYR),CTAU(MXLYR),CFREQ(MXLYR),   &
           LMBDA
      DOUBLE PRECISION ONE,P,DLAM,DLAM2,QW,R0,R(MXLYR),DK(MXLYR),   &
                       DX(MXLYR),S(MXLYR),EP(MXLYR),E(MXLYR),F(MXLYR)
      INTEGER ICOLE(MXLYR)
      DATA ONE /1.0D0/

      DLAM=DBLE(LMBDA)
      DLAM2=DLAM*DLAM
      NLYRT=NLYR
      DO J1=1,NLYR
         DK(J1)=DBLE(CNDR(J1))
         IF (ICOLE(J1)==1) THEN
            QW=(P*DBLE(CTAU(J1)))**DBLE(CFREQ(J1))
            QW=(ONE+QW)/(ONE+DBLE(CALF(J1))*QW)
            DK(J1)=QW*DK(J1)
         ENDIF
         S(J1)=DSQRT(DLAM2+DK(J1)*P)
         IF (J1<NLYR) THEN
            DX(J1)=DBLE(2.*THK(J1))
            EP(J1)=DX(J1)*S(J1)
            IF (EP(J1)>70.D0) THEN
               NLYRT=J1
               E(J1)=0.
               EXIT
            ELSE
               E(J1)=DEXP(-EP(J1))
            ENDIF
         ENDIF
      ENDDO
      R0=(DLAM-S(1))/(DLAM+S(1))
      IF (NLYRT==1) THEN
         QLPFD=R0
!-----------------------------------------------------------------
         RETURN
!-----------------------------------------------------------------
      ENDIF
      DO J1=1,NLYRT-1
         R(J1)=(S(J1)-S(J1+1))/(S(J1)+S(J1+1))
      ENDDO
      F(NLYRT-1)=E(NLYRT-1)*R(NLYRT-1)
      IF (NLYRT>2) THEN
         DO J1=1,NLYRT-2
            JJ=NLYRT-1-J1
            F(JJ)=E(JJ)*(R(JJ)+F(JJ+1))/(ONE+R(JJ)*F(JJ+1))
         ENDDO
      ENDIF
      QLPFD=(R0+F(1))/(ONE+R0*F(1))

      RETURN
      END
!  END OF QLPFD

      FUNCTION QLPTD (LMBDA,T,CNDR,THK,ICOLE,CALF,CTAU,CFREQ,NLYR,   &
                      NDGTS,CFLT,STEP,CDNT,VMD,TXRAD)
      REAL BES1,QLPTD,SQTD,T,TXRAD
      INTEGER J,MXDGT,MXLYR,NDGTS,NLYR
!     ----------------------------------------------------------------

!***  Called by ROI_QHTKER
!***  Calls QLPFD

!  Computes the step inverse Laplace transform of QLPFD, the integrand
!  of the Hankel transform, for each value of T.

!   LMBDA - Hankel transform variable
!       T - Time (for inverse Laplace transform)
!   NDGTS - size of inverse Laplace transform filter
!    CFLT - filter coefficients

!  See MAIN for other definitions.

      PARAMETER (MXLYR=20, MXDGT=16)
      REAL CNDR(MXLYR),THK(MXLYR),CALF(MXLYR),CTAU(MXLYR),CFREQ(MXLYR),   &
           LMBDA
      DOUBLE PRECISION QLPFD,CFLT(MXDGT),DQTD,P,A,DQI
      INTEGER ICOLE(MXLYR)
      LOGICAL STEP, CDNT, VMD

      DQTD=0.0D+00
      A=DLOG(2.0D+00)/DBLE(T)
      DO J=1,NDGTS
         P=DBLE(J)*A
         DQI=CFLT(J)*QLPFD(P,LMBDA,CNDR,THK,ICOLE,CALF,CTAU,CFREQ,NLYR)
         IF (STEP) THEN
            DQTD=DQTD-DQI/P
         ELSE
            DQTD=DQTD+DQI
         ENDIF
      ENDDO
      DQTD=A*DQTD
      SQTD=SNGL(DQTD)
      IF (VMD) SQTD=SQTD*BES1(LMBDA*TXRAD)
      IF (CDNT) THEN
         QLPTD=SQTD
      ELSE
         QLPTD=SQTD*LMBDA
      ENDIF

      RETURN
      END
!  END OF QLPTD

      FUNCTION QSNFD (W,LMBDA,LMBSQ,CNDR,THK,ICOLE,CALF,CTAU,CFREQ,   &
                      NLYR,STEP)
      INTEGER J1,JJ,JL,MXLYR,NL2,NLYR,NLYRT
      REAL QSNFD,W
!     -----------------------------------------------------------------

!***  Called by QSNTD

!  COMPUTES THE IMAGINARY PART OF THE FREQUENCY DOMAIN LAYERED-EARTH
!  RESPONSE KERNEL FOR THE INVERSE SINE TRANSFORM.

!       W - frequency
!   LMBDA - Hankel transform variable
!    NLYR - number of layers
!    CNDR - scaled conductivity
!     THK - layer thicknesses
!    ICOLE - C-C layer indicator array. (0 for pure real, 1 for C-C layer)
!     CALF - complementary chargeability array; ie., CALF(I) = 1.0 - CHRG(I)
!     CTAU - array of layer relaxation times (sec).
!    CFREQ - array of layer frequency parameters.

      PARAMETER (MXLYR=20)
      REAL CNDR(MXLYR),THK(MXLYR),CALF(MXLYR),CTAU(MXLYR),CFREQ(MXLYR),   &
           LMBDA,LMBSQ
      COMPLEX P,CNDX(MXLYR),Q,R0,R(MXLYR),S(MXLYR),E(MXLYR),F(MXLYR),   &
              EP(MXLYR),QSN,ONE
      INTEGER ICOLE(MXLYR)
      LOGICAL STEP
      DATA ONE /(1., 0.)/

      P=CMPLX(0.0,-W)
      NLYRT=NLYR
      DO JL=1,NLYR
         CNDX(JL)=CMPLX(CNDR(JL),0.)
         IF (ICOLE(JL)==1) THEN
            Q=(P*CTAU(JL))**CFREQ(JL)
            Q=(ONE+Q)/(ONE+CALF(JL)*Q)
            CNDX(JL)=Q*CNDX(JL)
         ENDIF
         S(JL)=CSQRT(CMPLX(LMBSQ,0.)+CNDX(JL)*P)
         IF (JL<NLYR) THEN
            EP(JL)=2.*THK(JL)*S(JL)
            IF (REAL(EP(JL))>70.) THEN
               NLYRT=JL
               E(JL)=(0.,0.)
               EXIT
            ELSE
               E(JL)=CEXP(-EP(JL))
            ENDIF
         ENDIF
      ENDDO

      R0=(CMPLX(LMBDA,0.)-S(1))/(CMPLX(LMBDA,0.)+S(1))
      IF (NLYRT==1) THEN
         IF (STEP) THEN
            QSNFD=-AIMAG(R0/P)
         ELSE
            QSNFD=AIMAG(R0)
         ENDIF
!-----------------------------------------------------------------
         RETURN
!-----------------------------------------------------------------
      ENDIF
      DO J1=1,NLYRT-1
         R(J1)=(S(J1)-S(J1+1))/(S(J1)+S(J1+1))
      ENDDO
      F(NLYRT-1)=E(NLYRT-1)*R(NLYRT-1)
      NL2=NLYRT-2
      IF (NLYRT>2) THEN
         DO J1=1,NL2
            JJ=NLYRT-1-J1
            F(JJ)=E(JJ)*(R(JJ)+F(JJ+1))/(ONE+R(JJ)*F(JJ+1))
         ENDDO
      ENDIF
      QSN=(R0+F(1))/(ONE+R0*F(1))
      IF (STEP) THEN
         QSNFD=-AIMAG(QSN/P)
      ELSE
         QSNFD=AIMAG(QSN)
      ENDIF

      RETURN
      END
!  END OF QSNFD

      FUNCTION QSNTD (LMBDA,T,CNDR,THK,ICOLE,CALF,CTAU,CFREQ,NLYR,STEP,   &
                      CDNT,VMD,TXRAD)
      REAL BES1,DELCOS,QSN,QSNFD,QSNTD,S,T,TOL,TWOPI,TXRAD,WCOS,WJ0,WJ1,  &
           WS
      INTEGER I,MXLYR,NFUN,NLYR
!     ---------------------------------------------------------------

!***  Called by ROI_QHTKER
!***  Calls QSNFD

!  Performs the sine transform of the imaginary part of the frequency
!  domain layered earth impedance function, QSNFD, using Walt Anderson's
!  sine transform coefficients.

!   LMBDA - Hankel transform variable
!       T - time (for inverse sine transform)

      PARAMETER (MXLYR=20)
      REAL CNDR(MXLYR),THK(MXLYR),CALF(MXLYR),CTAU(MXLYR),CFREQ(MXLYR),   &
           LMBDA,LMBSQ
      DOUBLE PRECISION E,ER,Y1,Y,XWT190
      INTEGER ICOLE(MXLYR)
      LOGICAL STEP, CDNT, VMD
      COMMON /FILTER/ DELCOS,WCOS(-200:99), WJ0(283), WJ1(283), WS(266)
      DATA E/1.221402758160169834D0/,ER/.818730753077981859D0/
      DATA XWT190 /0.7374499923870277002D+00/
      DATA TOL /1.0E-4/, TWOPI /0.636619772/

      LMBSQ=LMBDA*LMBDA
      QSN=0.
      NFUN=18
      Y1=XWT190/DBLE(T)
      Y=Y1

      DO I=191,208
         Y=Y*E
         S=WS(I)*QSNFD(SNGL(Y),LMBDA,LMBSQ,CNDR,THK,ICOLE,CALF,CTAU,  &
           CFREQ,NLYR,STEP)
         QSN=QSN+S
      ENDDO

      DO I=209,266
         Y=Y*E
         S=WS(I)*QSNFD(SNGL(Y),LMBDA,LMBSQ,CNDR,THK,ICOLE,CALF,CTAU,  &
           CFREQ,NLYR,STEP)
         QSN=QSN+S
         NFUN=NFUN+1
!********************************************************
         IF (ABS(S)<=TOL*ABS(QSN)) THEN
            EXIT
         ENDIF
!********************************************************
      ENDDO

      Y=Y1*E
      DO I=190,1,-1
         Y=Y*ER
         S=WS(I)*QSNFD(SNGL(Y),LMBDA,LMBSQ,CNDR,THK,ICOLE,CALF,CTAU,  &
           CFREQ,NLYR,STEP)
         QSN=QSN+S
         NFUN=NFUN+1
!********************************************************
         IF (ABS(S)<=TOL*ABS(QSN)) THEN
            EXIT
         ENDIF
!********************************************************
      ENDDO

      QSN=TWOPI*QSN/T
      IF (VMD) QSN=QSN*BES1(LMBDA*TXRAD)
      IF (CDNT) THEN
         QSNTD=QSN
      ELSE
         QSNTD=LMBDA*QSN
      ENDIF

      RETURN
      END
!  END OF QSNTD
!
      SUBROUTINE ROI_READ (NR,ND,NW,MXTYM,MXTX,MXRX,MXLYR,MXFRQ,           &
                           NFRQ,FREQ,TITLE,NTEM3D,PRTSEC,IDH,CDNT,DWNHL,   &
                           IPRF,NCHNL,ITYM,TMS,TMSPR,WTMS,OFFTYM,RXAREA,   &
                           MDELYT,BASFRQ,NSX,BPLR,CRVSEG,TXON,TXAMP,NTX,   &
                           SX,SY,NRX,RX,RY,RZ,RE,RN,RDIP,RPHI,NLYR,NSHT,   &
                           THK,RES,COLE,ICOLE,CHRG,CTAU,CFREQ,KACC,KSYMM,  &
                           NSBM,NXMAX,NYMAX,NZMAX,TRGT_BLCK,BLCK_NX,       &
                           BLCK_NY,BLCK_NZ,BLCK_LX,BLCK_LY,BLCK_LZ,        &
                           BLCK_CX,BLCK_CY,BLCK_CZ,RSB,CHRSB,TAUSB,CFRSB)
!
!****  Reads in model and equipment data for ground based systems.
!      Performs some data conversion tasks
!
!  This routine is adapted from Leroi routine READLR and Marco routine
!  READATA.

!***  Called by MAIN
!***  Calls ROI_SETSYS, ROI_SETTX, SETCEL

!           NR - input unit number
!           ND - frequency-domain data file (used for repeats)
!           NW - output unit number.
!         NFRQ - number of frequency-domain solutions requred.   <-- Outtput
!         FREQ - frequency array for FD solutions.               <-- Outtput
!       NTEM3D = 2 => use old FD data, else, compute new model. |<-- In & Out
!              = 1 => compute new  sheet model.                 |  Assign
!              = 0 => ompute layered 1/2 space model only.      |  PRTSEC
!       PRTSEC - print scattered fields if true.       <-- Output, per NTEM3D
!          IDH - receiver option indicator
!         CDNT - True for coincident loop Tx-Rx only
!        DWNHL - true if any receivers are downhole; ie, RZ(*) > 0
!         IPRF - indicates profile or decay curve output
!        NCHNL - number of channels of time-domain receivers
!         ITYM - TDEM system indicator
!          TMS - channel times in sec from start of ramp.
!        TMSPR - channel times in ms from end of ramp (except for Sirotem)
!         WTMS - receiver channel widths in sec.
!       OFFTYM - time from start of ramp turnoff to start of turnon in sec.
!       RXAREA - receiver area
!       MDELYT - number of Sirotem channels within the ramp turnoff.
!       BASFRQ - base frequency for ROI_UTEM option.
!          NSX - number of transmitter current points to be specified
!         BPLR - true if transmitter waveform is bipolar
!       CRVSEG - waveform is cubic spline connecting specified points if TRUE.
!              - waveform is connected linear segments if FALSE.
!         TXON - specified abscissa time points for Tx waveform in sec.
!        TXAMP - transmitter current at TXON points
!          NTX - number of trasmitter loops.
!           SX - array of X coordinates of transmitter corners
!           SY - array of Y coordinates of transmitter corners
!          NRX - number of receivers for each transmitter loop
!           RX - array of X coordinates of receivers
!           RY - array of Y coordinates of receivers
!           RZ - array of Z coordinates of receivers
!         NLYR - number of layers including basement
!          THK - array of layer thicknesses
!          RES - array of layer resistivities
!         COLE - true if any resitivities or conductances are complex
!        ICOLE - indicates whether each resitivity or conductance is
!                complex or pure real
!         CHRG - chargeability of layers
!         CTAU - Cole-Cole time constant of layers
!        CFREQ - Cole-Cole frequency constant of layers
!                If the index of ICOLE, CHRG, CTAU or CFREQ > NLYR + 1,
!                these are the Cole-Cole parameters of the sheet(s)
!    KACC:    Integer,  accuracy level for the computation of the scattered
!             fields.  See documentation file "MARCO.DOC" for detail.
!    KSYMM:   Integer,  controlling parameter for the two-plane symmetry
!             for the 3D model.  KSYMM=1:  symmetric model;
!                                     =0:  non-sym-metric model.
!    NSBM:    Integer, maximal number of blocks.
!    NXMAX:   Integer,  maximal number of cells in the x-direction
!             in a block.
!    NYMAX:   Integer,  maximal number of cells in the y-direction
!             in a block.
!    NZMAX:   Integer,  maximal number of cells in the z-direction
!             in a block.
!    TRGT_BLCK:  Integer,  number of input blocks.
!    BLCK_NX: Integer BLCK_NX(TRGT_BLCK),  number of cells in the x-direction
!             of blocks.
!    BLCK_NY: Integer BLCK_NY(TRGT_BLCK),  number of cells in the y-direction
!             of blocks.
!    BLCK_NZ: Integer BLCK_NZ(TRGT_BLCK),  number of cells in the z-direction
!             of blocks.
!    BLCK_LX: Real BLCK_LX(TRGT_BLCK),  dimensions of the blocks in the
!             x-direction.
!    BLCK_LY: Real BLCK_LY(TRGT_BLCK),  dimensions of the blocks in the
!             y-direction.
!    BLCK_LZ: Real BLCK_LZ(TRGT_BLCK),  dimensions of the blocks in the
!             z-direction.
!    BLCK_CX: Real BLCK_CX(TRGT_BLCK),  x-coordinates of the block centres.
!    BLCK_CY: Real BLCK_CY(TRGT_BLCK),  y-coordinates of the block centres.
!    BLCK_CZ: Real BLCK_CZ(TRGT_BLCK),  z-coordinates of the block centres.
!    RSB:     Real RSB(TRGT_BLCK),  resistivities of the blocks.
!    CHRSB:   Real CHRSB(TRGT_BLCK),  chargeability of the blocks (if it
!             is polarisable).  Cole-Cole models are used to presents
!             polarisable models.
!    TAUSB:   Real TAUSB(TRGT_BLCK),  time constants of the blocks.
!    CFRSB:   Real CFRSB(TRGT_BLCK),  frequency constants of the blocks.
!
!******************************************************************************
!
      IMPLICIT NONE
!
      CHARACTER*80 INP,TITLE
      LOGICAL CDNT, DWNHL, COLE, BPLR, CRVSEG, PRTSEC, NEW
!
      REAL BASFRQ,COLTOL,OFFTYM,QCND,QCOLE,RESM,RXAREA,RXF,RYF,SXCNTR,  &
           SYCNTR,T0,ZTOP
      INTEGER IDH,IERR,II,IPRF,ISTOP,ITYM,J,J1,JC,JR,JS,KACC,COLE_COLE,KSYMM, &
              LAYER,MCOLE,MDELYT,MXFRQ,MXLYR,MXRX
      INTEGER MXTX,MXTYM,NCHNL,ND,NDR,NFRQ,NLYR,NR,TRGT_BLCK,NSBM,NSHT,NSX,  &
              NT3A,NTEM3D,NTX,NUMCEL,NUML,NW,NXMAX,NYMAX
      INTEGER NZMAX
      REAL TMS(MXTYM),WTMS(MXTYM),TMSPR(MXTYM),SX(4,MXTX),SY(4,MXTX),   &
           RX(MXRX,MXTX),RY(MXRX,MXTX),RZ(MXRX,MXTX),RE(MXRX,MXTX),     &
           RN(MXRX,MXTX),RDIP(MXRX,MXTX),RPHI(MXRX,MXTX),RES(MXLYR),    &
           THK(MXLYR),CHRG(MXLYR),CFREQ(MXLYR),CTAU(MXLYR),FREQ(MXFRQ), &
           TXON(MXTYM),TXAMP(4,MXTYM)
      INTEGER ICOLE(MXLYR),NRX(MXTX)
      DOUBLE PRECISION QFRQ,QFRQ6,QFRQ12,FQQ
!
! --- Marco 3D parameters:
!
      INTEGER BLCK_NX(NSBM),BLCK_NY(NSBM),BLCK_NZ(NSBM)
      REAL BLCK_LX(NSBM),BLCK_LY(NSBM),BLCK_LZ(NSBM),   &
           BLCK_CX(NSBM),BLCK_CY(NSBM),BLCK_CZ(NSBM),   &
           RSB(NSBM),CHRSB(NSBM),TAUSB(NSBM),CFRSB(NSBM)
!
      DATA  COLTOL /1.E-10/
!      DATA PI /3.141592654/

!  Initialise variables.
!  Next, set frequency file at 6 points per decade from 1 Hz to 100 kHz.
!  Initialise variables.  Then read and print the whole data file.

      CDNT=.FALSE.
      DWNHL=.FALSE.
      COLE=.FALSE.
      BPLR=.TRUE.
      CRVSEG=.FALSE.
      PRTSEC=.FALSE.
      NEW=.FALSE.
      NDR=NR
      NSHT=0
      DO JS=1,MXTX
         NRX(JS)=1
         DO JR=1,MXRX
            RX(JR,JS)=0.
            RY(JR,JS)=0.
            RZ(JR,JS)=0.
         ENDDO
      ENDDO

      WRITE (NW,'(T11,A/T11,A/)') 'INPUT DATA','----------'
  100 READ (NR,'(A)',END=200) INP
      WRITE (NW,'(1X,A)') INP
      GOTO 100
  200 REWIND NR
!
!  -- Skip the first two records
!
      READ (NR,'(A)') INP
      READ (NR,'(A)') INP
!
      WRITE (NW,1030)
      IERR=0
!      READ (NR,'(A)') TITLE       !  This has been moved to the main program
      WRITE (NW,'(/A)') TITLE

      READ (NR,*) NTEM3D,IPRF,ISTOP
      WRITE (NW,1010) NTEM3D,IPRF,ISTOP

!  ISTOP is used as a frequency setter later on in this routine.

      NT3A=ABS(NTEM3D)
      IF (NT3A==1) THEN
         OPEN (ND,FILE='OUTPUT.FRQ',STATUS='UNKNOWN')
      ELSEIF (NT3A==2) THEN
         OPEN (ND,FILE='OUTPUT.FRQ',STATUS='UNKNOWN')
      ENDIF

      IF (NTEM3D<0) PRTSEC=.TRUE.
      NTEM3D=ABS(NTEM3D)
      IF (NTEM3D==1) NEW=.TRUE.
      IF (NTEM3D==2) NDR=ND

!Set up time-domain system.

      READ (NR,*) NCHNL,ITYM,IDH
      NCHNL=MIN0(NCHNL,MXTYM)
      WRITE (NW,'(/A,I2,A,I3,A,I2)') ' NCHNL = ',NCHNL,';    ITYM =',  &
             ITYM,';    IDH =',IDH
      IF ((ITYM==9).AND.(IDH/=0)) THEN
         IERR=1
         WRITE (NW,'(/A/)')   &
           ' THE DOWNHOLE OPTION FOR ROI_UTEM HAS NOT YET BEEN IMPLEMENTED.'
      ENDIF

      IF (IDH==7) CDNT=.TRUE.
      IF (IDH==1) DWNHL=.TRUE.

      IF (CDNT) THEN
         IF (ITYM==9) THEN
            WRITE (NW,'(/A/)')  &
                    ' ROI_UTEM DOES NOT HAVE A COINCIDENT LOOP OPTION!'
            IERR=1
         ELSEIF (ITYM<0) THEN
            WRITE (NW,'(/A/)')  &
                    ' EM37 DOES NOT HAVE A COINCIDENT LOOP OPTION'
            IERR=1
         ENDIF
      ENDIF

      CALL ROI_SETSYS(NCHNL,ITYM,OFFTYM,RXAREA,CDNT,MDELYT,BASFRQ,TMS,TMSPR,  &
                  WTMS,NSX,BPLR,CRVSEG,TXON,TXAMP,NR,NW)

!  Transmitter - receiver information
!  -----------------------------------

      WRITE (NW,1210)
      READ (NDR,*) NTX
      IF (NTX>MXTX) THEN
         IERR=1
         WRITE (NW,1310) NTX
      ENDIF
      IF (NEW) WRITE (ND,'(2I3)') NTX
      IF (IDH==6) THEN
         READ (NDR,*) RXF,RYF
         IF (NEW) WRITE (ND,'(2G16.7)') RXF,RYF
         WRITE (NW,1020) RXF,RYF
      ENDIF

      DO JS=1,NTX
         DO JC=1,4
            READ (NDR,*) SX(JC,JS),SY(JC,JS)
            IF (NEW) WRITE (ND,'(2G16.7)') SX(JC,JS),SY(JC,JS)
         ENDDO
      ENDDO
      CALL ROI_SETTX(NTX,SX,SY)

      IF (IDH==6) THEN
         DO JS=1,NTX
            NRX(JS)=1
            SXCNTR=.25*(SX(1,JS)+SX(2,JS)+SX(3,JS)+SX(4,JS))
            SYCNTR=.25*(SY(1,JS)+SY(2,JS)+SY(3,JS)+SY(4,JS))
            RX(1,JS)=SXCNTR+RXF
            RY(1,JS)=SYCNTR+RYF
         ENDDO
      ELSEIF (.NOT.CDNT) THEN
         READ (NDR,*) (NRX(JS),JS=1,NTX)
         IF (NEW.AND.(IDH/=6)) WRITE (ND,'(20I3)') (NRX(JS),JS=1,NTX)
         DO JS=1,NTX
            IF (NRX(JS)>MXRX) THEN
               IERR=1
               WRITE (NW,1320) NRX(JS)
            ENDIF
            DO JR=1,NRX(JS)
               IF (DWNHL) THEN
                  READ (NDR,*) RE(JR,JS),RN(JR,JS),RZ(JR,JS),    &
                               RDIP(JR,JS),RPHI(JR,JS)
                  RX(JR,JS)=RE(JR,JS); RY(JR,JS)=RN(JR,JS)
                  IF (NEW.AND.(IDH/=6)) THEN
                     WRITE (ND,'(5G15.5)') RX(JR,JS),RY(JR,JS),RZ(JR,JS),   &
                                           RDIP(JR,JS),RPHI(JR,JS)
                  ENDIF
               ELSE
                  READ (NDR,*) RE(JR,JS),RN(JR,JS)
                  RX(JR,JS)=RE(JR,JS); RY(JR,JS)=RN(JR,JS)
                  IF (NEW.AND.(IDH/=6)) THEN
                     WRITE (ND,'(2G15.5)') RX(JR,JS),RY(JR,JS)
                  ENDIF
               ENDIF
            ENDDO
         ENDDO
      ENDIF
      DO JS=1,NTX
         IF (CDNT) THEN
            WRITE (NW,1220) JS
         ELSE
            WRITE (NW,1230) JS
         ENDIF
         WRITE (NW,1240)
         DO JC=1,4
            WRITE (NW,'(T13,I2,T21,F8.1,T32,F8.1)') JC,SX(JC,JS),  &
                   SY(JC,JS)
         ENDDO
         IF (.NOT.CDNT) THEN
            WRITE (NW,1250) JS
            DO JR=1,NRX(JS)
               WRITE (NW,1260) JR,RX(JR,JS),RY(JR,JS),RZ(JR,JS)
            ENDDO
         ENDIF
      ENDDO

!  Layered earth model
!  -------------------

      READ (NDR,*) NLYR
      IF (NEW) WRITE (ND,'(I6)') NLYR

      IF (NLYR<0) THEN
         COLE=.TRUE.
         NLYR=-NLYR
      ENDIF

!  IF COLE IS TRUE, READ DATA AS COLE-COLE PARAMETERS.
!  ---------------------------------------------------

      DO J1=1,MXLYR
         THK(J1)=0.
         RES(J1)=0.
         CHRG(J1)=0.
         CTAU(J1)=0.
         CFREQ(J1)=0.
         ICOLE(J1)=0
      ENDDO

      IF (COLE) THEN
         IF (NLYR>1) THEN
            DO J=1,NLYR-1
               READ (NDR,*) THK(J),RES(J),CHRG(J),CTAU(J),CFREQ(J)
               IF (NEW) WRITE (ND,'(5G13.5)') THK(J),RES(J),CHRG(J),  &
                   CTAU(J),CFREQ(J)
            ENDDO
         ENDIF
         READ (NDR,*) RES(NLYR),CHRG(NLYR),CTAU(NLYR),CFREQ(NLYR)
         IF (NEW) WRITE (ND,'(4G13.5)') RES(NLYR),CHRG(NLYR),CTAU(NLYR),  &
                         CFREQ(NLYR)

         MCOLE=0
         DO J1=1,NLYR
            ICOLE(J1)=0
            QCOLE=AMIN1(CHRG(J1),CTAU(J1),CFREQ(J1))
            IF (QCOLE>COLTOL) ICOLE(J1)=1
            MCOLE=MCOLE+ICOLE(J1)
         ENDDO
         IF (MCOLE==0) THEN
            WRITE (NW,1300)
            IERR=1
         ENDIF

      ELSE
         IF (NLYR>1) THEN
            DO J1=1,NLYR-1
               READ (NDR,*) THK(J1),RES(J1)
               IF (NEW) WRITE (ND,'(2G13.5)') THK(J1),RES(J1)
            ENDDO
         ENDIF
         READ (NDR,*) RES(NLYR)
         IF (NEW) WRITE (ND,'(G13.5)') RES(NLYR)
      ENDIF

!  Write out layered earth parameters

      WRITE (NW,1040)
      IF (COLE) THEN
         WRITE (NW,1050)
         DO J1=1,NLYR
            IF (J1==NLYR) THEN
               WRITE (NW,1060) NLYR,RES(NLYR),CHRG(NLYR),CTAU(NLYR),  &
                      CFREQ(NLYR)
            ELSE
               WRITE (NW,1070) J1,THK(J1),RES(J1),CHRG(J1),CTAU(J1),  &
                      CFREQ(J1)
            ENDIF
         ENDDO
      ELSE
         WRITE (NW,1080)
         DO J1=1,NLYR
            IF (J1<NLYR) THEN
               WRITE (NW,1090) J1,THK(J1),RES(J1)
            ELSE
               WRITE (NW,1100) NLYR,RES(NLYR)
            ENDIF
         ENDDO
      ENDIF

!  Read in TARGET parameters if NTEM3D = 1 or -1.

      IF (NTEM3D>0) THEN

! --- COLE_COLE is controled by NLYR

         IF (COLE) THEN
            COLE_COLE=1
         ELSE
            COLE_COLE=0
         ENDIF

         WRITE (NW,1110)
         READ (NDR,*) KSYMM,TRGT_BLCK,KACC
         IF (NEW) WRITE (ND,'(3I3)') KSYMM,TRGT_BLCK,KACC
         IF (KSYMM==1) WRITE (NW,'(A/A)')  &
              ' THE INPUT DATA ARE FOR THE FIRST QUADRANT ONLY,',  &
             ' SINCE THE SYMMETRY OPTION HAS BEEN SPECIFIED.'

         IF (KACC==1) THEN
            WRITE (NW,'(A)')   &
                     ' A FAST APPROXIMATE 3D SOLUTION WILL BE COMPUTED!'
         ELSE
            WRITE (NW,'(A,I3)') ' ACCURACY LEVEL: ',KACC
         ENDIF

         IF (TRGT_BLCK>NSBM) THEN
            WRITE (NW,1330) TRGT_BLCK,NSBM
            IERR=1
         ENDIF
         IF (TRGT_BLCK==1) WRITE (NW,1120)
         IF (TRGT_BLCK>1) WRITE (NW,1130) TRGT_BLCK

         NUMCEL=0
         DO II=1,TRGT_BLCK

            READ (NDR,*) BLCK_NX(II),BLCK_NY(II),BLCK_NZ(II)
            READ (NDR,*) BLCK_LX(II),BLCK_LY(II),BLCK_LZ(II)
            READ (NDR,*) BLCK_CX(II),BLCK_CY(II),ZTOP
            BLCK_CZ(II)=ZTOP+.5*BLCK_LZ(II)
            IF (NEW) WRITE (ND,'(3I4/3F12.3/3F12.3)') BLCK_NX(II),BLCK_NY(II),&
                            BLCK_NZ(II),BLCK_LX(II),BLCK_LY(II),BLCK_LZ(II),  &
                            BLCK_CX(II),BLCK_CY(II),ZTOP

            NUML=BLCK_NX(II)*BLCK_NY(II)*BLCK_NZ(II)
            NUMCEL=NUMCEL+NUML
            WRITE (NW,1140) II,NUML,BLCK_LX(II),BLCK_CX(II),BLCK_NX(II),      &
                            BLCK_LY(II),BLCK_CY(II),BLCK_NY(II),BLCK_LZ(II),  &
                            ZTOP,BLCK_NZ(II)

            IF (BLCK_NX(II)>NXMAX) THEN
               WRITE (NW,1340) BLCK_NX(II),NXMAX
               IERR=1
            ENDIF

            IF (BLCK_NY(II)>NYMAX) THEN
               WRITE (NW,1350) BLCK_NY(II),NYMAX
               IERR=1
            ENDIF

            IF (BLCK_NZ(II)>NZMAX) THEN
               WRITE (NW,1360) BLCK_NZ(II),NZMAX
               IERR=1
            ENDIF

            IF (COLE_COLE==0) THEN
               READ (NDR,*) RSB(II)
               IF (NEW) WRITE (ND,'(G12.4)') RSB(II)
               WRITE (NW,1150) RSB(II)
            ELSE
               READ (NDR,*) RSB(II),CHRSB(II),TAUSB(II),CFRSB(II)
               IF (NEW) WRITE (ND,'(4G12.4)') RSB(II),CHRSB(II),  &
                   TAUSB(II),CFRSB(II)
               WRITE (NW,1150) RSB(II)
               WRITE (NW,1160) CHRSB(II),TAUSB(II),CFRSB(II)
            ENDIF

         ENDDO

      ENDIF
      WRITE (NW,1170)
      IF (NTEM3D/=0) WRITE (NW,1180) NUMCEL
!=======================================================================
!  Set up frequencies for 3-D modelling at 6 points per decade from
!  1 Hz to 100 kHz.  If the product of the earliest computation time
!  times the square root of conductivity is less than .7e-6, then
!  extend the frequency range to 1 MHz using 12 points per decade
!  past 40 kHz to trace the roll overs better.
!  The user can force 12 points per decade from 1 Hz to 1 MHz by entering
!  ISTOP as a negative number.

      IF (NTEM3D/=0.AND.ISTOP<1) THEN
         IF (ISTOP<0) THEN
            ISTOP=-2
         ELSEIF (ISTOP==0) THEN
            T0=TMS(1)-(WTMS(1)/2.)

!  ---  Find the maximal resistivity

            RESM=0.
            DO LAYER=1,NLYR
               RESM=AMAX1(RESM,RES(LAYER))
            ENDDO
            QCND=T0/SQRT(RESM)
            IF (QCND<.7E-6) ISTOP=-1
         ENDIF

         QFRQ6=DEXP(DLOG(10.D0)/6.D0)
         QFRQ12=DEXP(DLOG(10.D0)/12.D0)
         QFRQ=QFRQ6
         FREQ(1)=1.
         IF (ISTOP==0) THEN
            WRITE (NW,1270)
            NFRQ=31
         ELSEIF (ISTOP==-1) THEN
            WRITE (NW,1280)
            NFRQ=45
         ELSEIF (ISTOP==-2) THEN
            WRITE (NW,1290)
            QFRQ=QFRQ12
            NFRQ=73
         ENDIF
         FQQ=DBLE(FREQ(1))
         DO J1=2,NFRQ
            FQQ=FQQ*QFRQ
            FREQ(J1)=SNGL(FQQ)
            IF ((ISTOP==-1).AND.(FQQ>.4D+05)) QFRQ=QFRQ12
         ENDDO

         IF (NTEM3D==1) THEN
            WRITE (NW,1190)
         ELSEIF (NTEM3D==2) THEN
            WRITE (NW,1200)
         ENDIF
      ENDIF

!----------------------------------------------------------------------
      IF (IERR==1) THEN
         WRITE (NW,'(//A)')   &
                    ' EXECUTION HALTED BECAUSE OF INCORRECT DATA ENTRY!'
         STOP
      ENDIF
!----------------------------------------------------------------------
      IF (ISTOP==1) THEN
         STOP
      ENDIF
!----------------------------------------------------------------------
      RETURN

 1010 FORMAT (' NTEM3D =',I3,';   IPRF =',I2,';   ISTOP =',I2)
 1020 FORMAT (/' RECEIVER  EAST OFFSET FROM TX CENTRE =',F7.1,            &
              ' METRES.'/' RECEIVER NORTH OFFSET FROM TX CENTRE =',F7.1,  &
              ' METRES.')
 1030 FORMAT (75('-'))
 1040 FORMAT (//10X,'+----------------------------------+'/10X,           &
              '+  LAYERED EARTH MODEL PARAMETERS  +'/10X,                 &
              '+----------------------------------+'/)
 1050 FORMAT (' LAYER    THICKNESS   RESISTIVITY',6X,'CHRG',10X,'CTAU',   &
              11X,'CFREQ'/' -----    ---------   -----------',6X,'----',  &
              10X,'----',11X,'-----')
 1060 FORMAT (I4,17X,G13.4,1X,G13.4,1X,G13.4,2X,G13.4)
 1070 FORMAT (I4,4X,2G13.4,1X,G13.4,1X,G13.4,2X,G13.4)
 1080 FORMAT (10X,' LAYER    THICKNESS   RESISTIVITY'/10X,                &
              ' -----    ---------   -----------')
 1090 FORMAT (10X,I4,4X,2G13.4)
 1100 FORMAT (10X,I4,17X,G13.4)
 1110 FORMAT (//10X,'+---------------------------+'/10X,                  &
              '+  3-D SOLUTION PARAMETERS  +'/10X,                        &
              '+---------------------------+'/)
 1120 FORMAT (/' THE 3-D MODEL IS CONSTRUCTED FROM ONE BLOCK.')
 1130 FORMAT (/' THE 3-D MODEL IS CONSTRUCTED FROM',I3,' BLOCKS.')
 1140 FORMAT (//25X,'DESCRIPTION OF BLOCK #',I3,'   (',I3,                &
              ' CELLS )'/25X,40('-')/20X,                                 &
              'DIMENSION   COORDINATES OF    CELL'/20X,                   &
              '(METRES)    TOP FACE CENTRE   DISCRETISATION'//            &
              '     EAST - WEST:',F11.1,F14.1,10X,                        &
              I3/'   NORTH - SOUTH:',F11.1,F14.1,10X,                     &
              I3/'           DEPTH:',F11.1,F14.1,10X,I3/)
 1150 FORMAT (10X,'RESISTIVITY:',G12.4,'OHM-METRES')
 1160 FORMAT (8X,'CHARGEABILITY:',G12.4/8X,'TIME CONSTANT:',G12.4,        &
              ' SEC'/3X,'FREQUENCY CONSTANT:',G12.4/)
 1170 FORMAT (/75('-')/T24,'END OF INPUT DATA DESCRIPTION'/75('-')//)
 1180 FORMAT (' THE TOTAL MODEL HAS BEEN DISCRETISED INTO',I5,' CELLS.')
 1190 FORMAT (/' MARCO WILL START BY COMPUTING NEW FREQUENCY-DOMAIN',     &
              ' RESPONSES.')
 1200 FORMAT (/' MARCO WILL COMPUTE TIME-DOMAIN RESPONSES FROM THE ',     &
              'FREQUENCY-DOMAIN DATA'/' CONTAINED IN FILE OUTPUT.FRQ')
 1210 FORMAT (//T11,'+-----------------------------------+'/T11,          &
              '+  SOURCE AND RECEIVER INFORMATION  +'/T11,                &
              '+-----------------------------------+')
 1220 FORMAT (//T11,'LOCATION OF COINCIDENT LOOP TRANSMITTER',I3/T11,     &
              '-----------------------------------------')
 1230 FORMAT (//T8,'LOCATION OF SURFACE RECTANGULAR LOOP TRANSMITTER',    &
              I3/T8,  &
              '---------------------------------------------------')
 1240 FORMAT (/T11,'CORNER',T24,'EAST',T35,'NORTH'/T11,'------',T24,      &
              '----',T34,'-----')
 1250 FORMAT (//T13,'RECEIVERS FOR TRANSMITTER',I3/T13,28('-')//T10,      &
              'RX INDEX',T24,'EAST',T34,'NORTH',T44,'DEPTH'/T10,          &
              '--------',T24,'----',T34,'-----',T44,'-----')
 1260 FORMAT (T13,I2,T22,F7.1,T32,F7.1,T42,F7.1)

 1270 FORMAT (' SCATTERED FIELD COMPUTATION USES 6 POINTS PER DECADE',    &
              ' FROM 1 HZ TO 100 KHZ.')
 1280 FORMAT (' SCATTERED FIELD COMPUTATION USES 6 POINTS PER DECADE',    &
              ' FROM 1 HZ TO 46 KHZ.'/' IT THEN USES 12 POINTS PER',      &
              ' DECADE UP TO 1 MHZ.')
 1290 FORMAT (' SCATTERED FIELD COMPUTATION USES 12 POINTS PER',          &
              ' DECADE FROM .1 HZ TO 1 MHZ.')
 1300 FORMAT (/' VALID POSITIVE COLE-COLE PARAMETERS HAVE NOT BEEN',      &
              ' ENTERED FOR ANY OF THE'/' LAYERS.  EITHER SET NLAYER',    &
              ' TO A POSITIVE NUMBER OR RESET THE C-C PARAMETERS'/        &
              ' FOR AT LEAST ONE OF THE LAYERS.'/)
 1310 FORMAT (/' ************ FATAL DATA INPUT ERROR ************'/       &
              ' NUMBERS OF TRANSMITTERS EXCEEDED THE LIMIT'/,             &
              ' INCREASE PARAMETER MXTX =',I4,' IN THE MAIN PROGRAM')
 1320 FORMAT (/' ************ FATAL DATA INPUT ERROR ************'/       &
              ' NUMBERS OF RECEIVERS EXCEEDED THE MAXIMUM LIMIT'/,        &
              ' ---> INCREASE PARAMETER MXRX =',I4,                       &
              ' IN THE MAIN PROGRAM'/                                     &
              ' AND IN ALL SUBROUTINES WHERE PARAMETER MXRX IS DEFINED')
 1330 FORMAT (/' ************ FATAL DATA INPUT ERROR ************'/       &
              ' THE NUMBER OF BLOCKS  EXCEEDS THE MAXIMUM LIMIT'/         &
              ' ---> INCREASE PARAMETER NSBM =',I4,                       &
              ' IN THE MAIN PROGRAM'/                                     &
              ' AND RECOMPILE, OR REDUCE TRGT_BLCK TO',I4)
 1340 FORMAT (/' ************ FATAL DATA INPUT ERROR ************'/       &
              ' THE NUMBER OF CELLS IN THE X-DIRECTION EXCEEDS THE',      &
              ' MAXIMUM LIMIT'/' ---> INCREASE PARAMETER NXMAX TO',I4,    &
              ' IN THE MAIN PROGRAM AND RECOMPILE,'/' OR REDUCE',         &
              ' BLCK_NX TO',I4)
 1350 FORMAT (/' ************ FATAL DATA INPUT ERROR ************'/       &
              ' THE NUMBER OF CELLS IN THE Y-DIRECTION EXCEEDS THE',      &
              ' MAXIMUM LIMIT'/' ---> INCREASE PARAMETER NYMAX TO',I4,    &
              ' IN THE MAIN PROGRAM AND RECOMPILE,'/' OR REDUCE',         &
              ' BLCK_NY TO',I4)
 1360 FORMAT (/' ************ FATAL DATA INPUT ERROR ************'/       &
              ' THE NUMBER OF CELLS IN THE Z-DIRECTION EXCEEDS THE',      &
              ' MAXIMUM LIMIT'/' ---> INCREASE PARAMETER NZMAX TO',I4,    &
              ' IN THE MAIN PROGRAM AND RECOMPILE,'/' OR REDUCE',         &
              ' BLCK_NZ TO',I4)

      END
!END OF READLR

      SUBROUTINE ROI_SETCLP (XSL,YSL,CLRHO,RX,RY,XFAC,YFAC,NDX,NDY,COLE)
!
      IMPLICIT NONE
!
      INTEGER J,MXTX1,NDX,NDY
      REAL RINT,RSQ,XL,XLSQ,XSL,YL,YLSQ,YSL
!     --------------------------------------------------------------

!***   CALLED BY ROI_HSLYR

!  Calculates distances (CLRHO) and integration factors for the double line
!  integral of the horizontal electric dipole-dipole TEM response around
!  a rectangular loop.  A uniform distribution is used.

!      PARAMETERS     ( * DENOTES INPUT PARAMETER )
!      ----------

!  *   XSL - length of tx loop in X direction
!  *   YSL - length of tx loop in Y direction
!    CLRHO - in-line dipole-dipole separation distances
!       RX - cross-loop (ysl) dipole-dipole separation distances along X
!       RX - cross-loop (xsl) dipole-dipole separation distances along Y
!     XFAC - intergation weight factors for X-side dipoles
!     YFAC - intergation weight factors for Y-side dipoles
!   ! COLE - denotes Cole-Cole (true) or real (false) model
!      NDX - number of dipole elements along XSL
!      NDY - number of dipole elements along YSL

      PARAMETER (MXTX1=100)
      REAL CLRHO(MXTX1), RX(MXTX1), RY(MXTX1), XFAC(MXTX1), YFAC(MXTX1)
      LOGICAL COLE

      XL=AMAX1(XSL,YSL)
      YL=AMIN1(XSL,YSL)
      XLSQ=XL*XL
      YLSQ=YL*YL

!  Set dipole distance, RINT

      RINT=10.0
      IF (COLE) RINT=5.0
      NDX=IFIX(XL/RINT)
      NDX=MAX0(2,NDX)
      NDX=MIN0(MXTX1,NDX)
      RINT=XL/FLOAT(NDX)
      NDY=IFIX(YL/RINT)
      RINT=SQRT(XL*YL/FLOAT(NDX*NDY))
      RSQ=RINT*RINT

!  Set inline distances and then cross-loop distances

      CLRHO(1)=0.01
      RX(1)=YL
      RY(1)=XL
      XFAC(1)=2.0*NDX*RSQ
      YFAC(1)=2.0*NDY*RSQ
      DO J=2,NDY
         CLRHO(J)=CLRHO(J-1)+RINT
         RX(J)=SQRT(CLRHO(J)**2+YLSQ)
         RY(J)=SQRT(CLRHO(J)**2+XLSQ)
         XFAC(J)=4.0*(NDX-J+1)*RSQ
         YFAC(J)=4.0*(NDY-J+1)*RSQ
      ENDDO
      DO J=NDY+1,NDX
         CLRHO(J)=CLRHO(J-1)+RINT
         RX(J)=SQRT(CLRHO(J)**2+YLSQ)
         XFAC(J)=4.0*(NDX-J+1)*RSQ
      ENDDO

      RETURN
      END
!  END OF ROI_SETCLP

      SUBROUTINE ROI_SETRHO (XSL,YSL,XRT,YRT,MRX,VTXRX,HTXRX,RHO,NDIP,COLE)
!
      IMPLICIT NONE
!
      REAL DELX,DELY,RINT,XD,XD1,XD3,XR,XSL,XTX0,YD,YD2,YD4,YR,YSL,YTX0
      INTEGER JR,JX,JY,JYP,MRX,MXRX,MXTX,NDH,NDIP,NDX,NDY
!     ------------------------------------------------------------------

!***   Called by ROI_HSLYR

!  Calculates distances (RHO) and coupling coefficients for computing the
!  vertical and horizontal magnetic fields due to a rectangular transmitting
!  loop which is represented as a perimeter integration of electric dipoles.
!  A uniform distribution is used.

!      PARAMETERS     ( * DENOTES INPUT PARAMETER )
!      ----------

!   *   XSL - LENGTH OF TX LOOP IN X DIRECTION
!   *   YSL - LENGTH OF TX LOOP IN Y DIRECTION
!   *   IRX - DENOTES RX ORIENTATION
!   *  MRX, XRT, YRT, CPHI, SPHI, ARE RECEIVER PARAMETERS DEFINED ELSEWHERE.

!      NDIP - NUMBER OF INTEGRATION POINTS

      PARAMETER (MXTX=400, MXRX=50)
      REAL RHO(MXTX,0:MXRX),VTXRX(MXTX,0:MXRX),HTXRX(MXTX,2),XRT(MXRX),   &
           YRT(MXRX),XTX(100),YTX(100)
      LOGICAL COLE

      RINT=10.
      IF (COLE) RINT=5.
      NDX=IFIX(XSL/RINT)
      NDX=MAX0(1,NDX)
      NDX=MIN0(100,NDX)
      NDY=IFIX(YSL/RINT)
      NDY=MAX0(1,NDY)
      NDY=MIN0(100,NDY)

      NDH=NDX+NDY
      NDIP=2*NDH
      DELX=XSL/FLOAT(NDX)
      DELY=YSL/FLOAT(NDY)

      XTX0=-0.5*(XSL+DELX)
      YTX0=-0.5*(YSL+DELY)

      DO JX=1,NDX
         XTX(JX)=XTX0+(DELX*JX)
         HTXRX(JX,1)=0.
         HTXRX(JX+NDH,1)=0.
         HTXRX(JX,2)=-DELX
         HTXRX(JX+NDH,2)=DELX
      ENDDO
      DO JY=1,NDY
         YTX(JY)=YTX0+(DELY*JY)
         JYP=JY+NDX
         HTXRX(JYP,1)=DELY
         HTXRX(JYP+NDH,1)=-DELY
         HTXRX(JYP,2)=0.
         HTXRX(JYP+NDH,2)=0.
      ENDDO

      DO JR=0,MRX
         XR=0.
         YR=0.
         IF (JR>0) THEN
            XR=ABS(XRT(JR))
            YR=ABS(YRT(JR))
         ENDIF
         DO JX=1,NDX
            XD=XR-XTX(JX)
            YD2=YR+0.5*YSL
            YD4=YR-0.5*YSL
            RHO(JX,JR)=SQRT(XD*XD+YD2*YD2)
            RHO(JX+NDH,JR)=SQRT(XD*XD+YD4*YD4)
            VTXRX(JX,JR)=YD2*DELX
            VTXRX(JX+NDH,JR)=-YD4*DELX
         ENDDO

         DO JX=1,NDY
            JY=JX+NDX
            YD=YR-YTX(JX)
            XD1=XR-0.5*XSL
            XD3=XR+0.5*XSL
            RHO(JY,JR)=SQRT(YD*YD+XD1*XD1)
            RHO(JY+NDH,JR)=SQRT(YD*YD+XD3*XD3)
            VTXRX(JY,JR)=-XD1*DELY
            VTXRX(JY+NDH,JR)=XD3*DELY
         ENDDO
      ENDDO

      RETURN
      END
!  END OF ROI_SETRHO

   SUBROUTINE ROI_SETSYS (NCHNL,ITYM,OFFTYM,RXAREA,CDNT,MDELYT,BASFRQ,TMS,  &
                        TMSPR,WTMS,NSX,BPLR,CRVSEG,TXON,TXAMP,NR,NW)
!     -----------------------------------------------------------------

!  Sets up delay times, window widths etc. for various systems.

!****  Called by READLR
!
!    NCHNL - number of channels of time-domain receivers
!     ITYM - TDEM system indicator
!   OFFTYM - time from start of ramp turnoff to start of turnon in sec.
!   RXAREA - receiver area
!     CDNT - True for coincident loop Tx-Rx only
!   MDELYT - number of Sirotem channels within the ramp turnoff.
!   BASFRQ - base frequency for UTEM option.
!      TMS - channel times in sec from end of TX waveform.
!    TMSPR - channel times in ms defined by instrument.
!     WTMS - receiver channel widths in sec.
!      NSX - number of transmitter current points to be specified
!     BPLR - true if transmitter waveform is bipolar
!   CRVSEG - waveform is cubic spline connecting specified points if TRUE.
!          - waveform is connected linear segments if FALSE.
!     TXON - specified abscissa time points for Tx waveform
!            input in ms, output in sec.
!    TXAMP - transmitter current at TXON points in amps
!       NR - input unit number
!       NW - output unit number.
!
 IMPLICIT NONE
 INTEGER, PARAMETER :: MXTYM=75, NSIRO=32, NEM37=20
 INTEGER NCHNL,ITYM,MDELYT,NSX,NR,NW,j,J1,JFIX,IRXW,IBPLR,ICURV,JC
 REAL RXAREA,BASFRQ,SPLT,UHIGH,TRMP,TRYS,EMFAC,OFFTYM,ONTYM,TS,WS, &
      TOUT,WIPE,WOUT,CLOW,ULOW,HIGH,T,T1,TOFF,OT
 LOGICAL SIROTM, CDNT, BPLR, CRVSEG
 REAL TMS(MXTYM),WTMS(MXTYM),TMSPR(MXTYM),TEM37(NEM37),    &
     WEM37(NEM37),REJEC(NSIRO),EARLY(NSIRO),WEARLY(NSIRO), &
     STAN(NSIRO),WSTAN(NSIRO),TXON(MXTYM),TXAMP(4,MXTYM)

 DATA EARLY /0.036,0.085,0.134,0.183,0.232,0.306,0.404,0.502,  &
             0.600,0.698,0.845,1.041,1.237,1.433,1.629,1.923,  &
             2.315,2.707,3.099,3.491,4.079,4.863,5.647,6.431,  &
         7.215,8.391,9.959,11.527,13.095,14.663,17.015,20.151/
 DATA WEARLY /5*0.04,5*0.09,5*0.19,5*0.39,5*0.78,5*1.56,2*3.13/
 DATA STAN /0.487,0.879,1.271,1.663,2.055,2.643,3.427,           &
      4.211,4.995,5.779,6.955,8.523,10.091,11.659,13.227,15.579, &
      18.715,21.851,24.987,28.123,32.827,39.099,45.371,51.643,   &
      57.915,67.323,79.867,92.411,104.96,117.50,136.32,161.40/
 DATA WSTAN /5*0.344,5*0.736,5*1.520,5*3.088,5*6.224,            &
             5*12.496,2*25.040/
 DATA TEM37 /0.0885,0.109,0.140,0.177,0.220,0.280,0.355,0.433,   &
            0.563,0.712,0.876,1.087,1.400,1.772,2.21,2.82,       &
            3.57,4.46,5.667,7.16/
 DATA WEM37 /0.017,0.024,0.037,0.037,0.049,0.072,0.077,0.099,   &
            0.142,0.156,0.172,0.250,0.378,0.367,0.400,0.720,    &
            0.780,1.000,1.420,1.560/
 DATA REJEC /12*10.,4*20.,2*30.,2*40.,2*50.,2*60.,2*80.,        &
                   2*100.,2*130.,2*180./

!  Initialise waveform variables

 RXAREA = 1.
 SIROTM = .FALSE.
 CRVSEG = .FALSE.
 BPLR = .TRUE.
 NSX = 4
 TXON = 0.
 TXAMP = 0.
 TXAMP(1,2:3) = 1.
 MDELYT = 0

 IF (ITYM == 9) THEN
   READ(NR,*) BASFRQ
   WRITE(NW,1010) BASFRQ
   IF (NCHNL .EQ. 20) THEN
     SPLT = SQRT (2.)
   ELSE
     NCHNL = 10
     SPLT = 2.
   ENDIF

   UHIGH = 0.5 / BASFRQ
   DO J1 = 1, NCHNL
     JC = NCHNL + 1 - J1
     ULOW = UHIGH / SPLT
     TMS(JC) = (UHIGH + ULOW) /2.
     WTMS(JC) = UHIGH - ULOW
     UHIGH = ULOW
   END DO

 ELSEIF (ITYM < 0) THEN
   RXAREA = 1000.
   NCHNL = 20
   READ(NR,*) TRMP, TRYS
   WRITE(NW,1015) TRMP, TRYS
   NCHNL = MIN0 (NCHNL,NEM37)
   EMFAC = 1.0
   IF(ITYM == -3) EMFAC = 10.0
   IF(ITYM == -2) EMFAC = 4.0
   OFFTYM = EMFAC * 10.
   TXON(2) = 2.*TRYS
   TXON(3) = OFFTYM
   TXON(4) = TXON(3) + TRMP
   DO J1 = 1,NCHNL
     TMSPR(J1) = EMFAC*TEM37(J1)
     WTMS(J1) = EMFAC*WEM37(J1)
   END DO

 ELSEIF ((ITYM == 0) .OR. (ITYM == 1)) THEN
   SIROTM = .TRUE.
   IF (CDNT) THEN
     READ(NR,*) TRMP,TRYS
     WRITE(NW,1021) TRMP,TRYS
   ELSE
     READ(NR,*) TRMP,TRYS,RXAREA
     WRITE(NW,1020) TRMP,TRYS,RXAREA
   ENDIF

   JFIX = 0
   NCHNL = MIN0 (NSIRO,NCHNL)
   OFFTYM = REJEC(NCHNL)
   TXON(2) = 2.*TRYS
   TXON(3) = OFFTYM
   TXON(4) = TXON(3) + TRMP

   DO J1 = 1,NCHNL
     IF (ITYM == 0) THEN
       TS = EARLY(J1)
       WS = WEARLY(J1)
     ELSE
       TS = STAN(J1)
       WS = WSTAN(J1)
     ENDIF

!  For Sirotem option, eliminate channels during turnoff.

     WIPE = TRMP + 0.5*WS
     IF (TS .LE. WIPE) THEN
       MDELYT = MDELYT + 1
       CYCLE
     ENDIF
     JFIX = JFIX + 1
     TMSPR(JFIX) = TS
     WTMS(JFIX) = WS
   END DO
   NCHNL = NCHNL - MDELYT

 ELSEIF ((ITYM == 2) .OR. (ITYM == 3)) THEN
   IF (CDNT) THEN
     READ(NR,*) IRXW,TRMP,TRYS,OFFTYM,ONTYM
     WRITE(NW,1025) IRXW,TRMP,TRYS,OFFTYM,ONTYM
   ELSE
     READ(NR,*) IRXW,TRMP,TRYS,OFFTYM,ONTYM,RXAREA
     WRITE(NW,1026) IRXW,TRMP,TRYS,OFFTYM,ONTYM,RXAREA
   ENDIF
   IF (ITYM == 3) THEN
     IRXW = 1
     ITYM = 2
     WRITE(NW,1100)
   ENDIF
   READ(NR,*) TMSPR(1:NCHNL)
   IF (IRXW .EQ. 1) THEN
     READ(NR,*) WTMS(1:NCHNL)
   ELSE
     WTMS = .15 * TMSPR
   ENDIF

   TXON(2) = TRYS
   TXON(3) = TXON(2) + ONTYM
   TXON(4) = TXON(3) + TRMP

   WRITE(NW,1035) TMSPR(1:NCHNL)
   WRITE(NW,1040) WTMS(1:NCHNL)

 ELSEIF (ITYM == 4) THEN
   IF (CDNT) THEN
     READ(NR,*) IRXW,IBPLR,ICURV,NSX,OFFTYM
     WRITE(NW,1028) IRXW,IBPLR,ICURV,NSX,OFFTYM
   ELSE
     READ(NR,*) IRXW,IBPLR,ICURV,NSX,OFFTYM,RXAREA
     WRITE(NW,1029) IRXW,IBPLR,ICURV,NSX,OFFTYM,RXAREA
   ENDIF
   IF (ICURV == 1) CRVSEG = .TRUE.
   IF (IBPLR == 1) BPLR = .FALSE.
   READ(NR,*) TMSPR(1:NCHNL)
   IF (IRXW == 1) THEN
     READ(NR,*) WTMS(1:NCHNL)
   ELSE
     WTMS = .15 * TMSPR
   ENDIF
   WRITE(NW,1035) TMSPR(1:NCHNL)
   WRITE(NW,1040) WTMS(1:NCHNL)
   READ(NR,*) (TXON(J),TXAMP(1,J), J=1,NSX)
   WRITE(NW,1042) TXON(1:NSX)
   WRITE(NW,1044) TXAMP(1,1:NSX)

   TXON(1) = 0.
   TXAMP(1,1) = 0.
   TXAMP(1,NSX) = 0.

 ENDIF
!=======================================================================
!=======================================================================
!  Convert all times to seconds.
!  EM37, Sirotem, and ITYM=2 options, have been converted to the bipolar
!  linear waveform option.  In EM37 and Sirotem, OFFTYM is defined as the
!  start of ramp turnoff but the waveform option starts OFFTYM from the end
!  of signal.  If early windows extend into ONTYM, reduce to 80 percent on
!  each side.  If late windows extend past OFFTYM, extend OFFTYM.

 IF (ITYM /= 9) THEN
   OFFTYM = 1.E-3 * OFFTYM
   DO J1 = 1,NCHNL
     TMS(J1) = 1.E-3 * TMSPR(J1)
     IF (SIROTM) TMS(J1) = 1.E-3* (TMSPR(J1) - TRMP)
     WTMS(J1) = 1.E-3 * WTMS(J1)
     T1 = TMS(J1)
     IF ( (WTMS(J1) /2.) > T1) WTMS(J1) = 1.6 * T1
     TOFF = TMS(J1) + .6 * WTMS(J1)
     IF (TOFF > OFFTYM) THEN
       OFFTYM = TOFF
       OT = 1000. * OFFTYM
       WRITE(NW,1085) J1,OT
     ENDIF
   END DO
 ENDIF

!  Write out system delay times and channel widths in ms.

 IF (ITYM < 0)  THEN
   WRITE (NW,'(/10X,A/)') ' EM37 CHANNEL DESCRIPTION'
 ELSEIF (ITYM == 0) THEN
   WRITE (NW,'(/10X,A/10X,A/)')                         &
        'EARLY TIME SIROTEM CHANNEL DESCRIPTION (MS)',  &
        '(RELATIVE TO END OF TX SIGNAL)'
 ELSEIF (ITYM == 1) THEN
   WRITE (NW,'(/10X,A/10X,A/)')                         &
        'STANDARD SIROTEM CHANNEL DESCRIPTION (MS)',    &
        '(RELATIVE TO END OF TX SIGNAL)'
 ELSEIF (ITYM < 9) THEN
   WRITE (NW,'(/10X,A/)') 'USER DEFINED CHANNEL DESCRIPTION (MS)'
 ELSEIF (ITYM == 9) THEN
   WRITE (NW,'(/10X,A/)') 'UTEM CHANNEL DESCRIPTION (MS)'
 ENDIF
 WRITE(NW,1050)

 DO J1 = 1, NCHNL
   TOUT = 1000. * TMS(J1)
   IF (ITYM == 9)  THEN
     JC = NCHNL+1 - J1
   ELSE
     JC = J1 + MDELYT
   ENDIF
   WOUT = 1000. * WTMS(J1)
   HIGH = TOUT + WOUT/2.
   CLOW = TOUT - WOUT/2.
   WRITE(NW,1055) JC,CLOW,HIGH,WOUT,TOUT
 END DO
 IF (MDELYT > 0) WRITE(NW,1060) MDELYT

!  Print waveform in ms vs. amps and then convert TXON to sec.

 IF (ITYM < 9) THEN
   WRITE(NW,1070)
   TXON = 1.E-3 * TXON
   DO J1 = 1,NSX
     T = 1000. * TXON(J1)
     WRITE(NW,1075) J1,T,TXAMP(1,J1)
   END DO
 ENDIF

 1010 FORMAT(' UTEM BASE FREQUENCY =',F6.1,' HZ.')
 1015 FORMAT(' EM37:  TRMP = ',F5.3,';   TRYS = ',F5.3)
 1020 FORMAT(' SIROTEM:  TRMP = ',F5.3,';   TRYS = ',F5.3,  &
             ';   RXAREA =',F7.0)
 1021 FORMAT(' SIROTEM:  TRMP = ',F5.3,';   TRYS = ',F5.3)
 1025 FORMAT(' USER:  IRXW =',I2,';   TRMP = ',F5.3,';   TRYS = ',F5.3/  &
            6X,'OFFTYM = ',F5.1,';   ONTYM =',F5.1)
 1026 FORMAT(' USER:  IRXW =',I2,';   TRMP = ',F5.3,';   TRYS = ',F5.3/  &
            6X,'OFFTYM = ',F5.1,';   ONTYM =',F5.1,';   RXAREA =',F7.0)
 1028 FORMAT(' ARBITRARY WAVEFORM:  IRXW =',I2,';   IBPLR =',I2,  &
             ';   ICURV =',I2,';   NSX =',I2/22X,'OFFTYM = ',F5.1)
 1029 FORMAT(' ARBITRARY WAVEFORM:  IRXW =',I2,';   IBPLR =',I2,  &
             ';   ICURV =',I2,';   NSX =',I2/  &
              22X,'OFFTYM = ',F5.1,';   RXAREA =',F7.0)
 1035 FORMAT(/'   TMS = ',6(G11.4),:,/(8X,6(G11.4)))
 1040 FORMAT(/'  WTMS = ',6(G11.4),:,/(8X,6(G11.4)))
 1042 FORMAT(/'  TXON = ',6(G11.4),:,/(8X,6(G11.4)))
 1044 FORMAT(/' TXAMP = ',6(G11.4),:,/(8X,6(G11.4)))

 1050 FORMAT(T11,  'CHANNEL    OPEN     CLOSE     WIDTH     CENTRE'/  &
               T11,'-------    ----     -----     -----     ------')
 1055 FORMAT(T13,I2,T20,F6.2,T30,F6.2,T40,F6.2,T50,F6.2)
 1060 FORMAT(/' THE FIRST ',I2,' SIROTEM CHANNELS HAVE BEEN DELETED ',  &
             'BECAUSE THEY FALL'/' WITHIN THE RAMP TURNOFF.')
 1070 FORMAT(/12X,'+------------------------+'/  &
              12X,'+  TRANSMITTER WAVEFORM  +'/  &
              12X,'+------------------------+'//  &
              14X,'TXON (MS)    TXAMP (AMP)'/  &
              14X,'---------    -----------')
 1075 FORMAT(8X,I3,F9.2,5X,F9.2)
 1085 FORMAT(/' RECEIVER WINDOW OF CHANNEL',I3,' EXTENDS PAST OFFTYM.'/  &
              ' OFFTYM ADJUSTED TO',F7.2,' MS.'/)
 1100 FORMAT(/' THE OLD ITYM = 3 OPTION HAS BEEN REPLACED BY SETTING'/  &
              ' ITYM = 2, AND IRXW = 1.'/  &
             ' THE PROGRAM HAS DONE THIS FOR YOU ON THIS OCCASION.'/  &
             ' IT EXPECTS TO READ IN RECEIVER WINDOW WIDTHS FROM YOUR',  &
             ' INPUT DATA FILE.'/)
 END SUBROUTINE ROI_SETSYS

      SUBROUTINE ROI_SETTX (NTX,SX,SY)
!
      IMPLICIT NONE
!
      REAL CTH,SEG12,SEG32,STH
      INTEGER J,JS,M1,M2,M3,M3T,M4,NTX
!     ----------------------------

!  Orders the input vertices of a quadrilateral such that the lower left-hand
!  vertex is 1 and the rest are ordered in counter-clockwise fashion.
!  If the input quadrilateral is not a rectangle, ROI_SETTX makes one by using
!  the segment 2-3 as one side, and requiring that segment 1-2 is
!  perpendicular to this with the original length of segment 1-2.  Having
!  fixed vertices 1, 2 & 3, vertex 4 is then fixed.

!***  Called by READLR

      REAL SX(4,NTX), SY(4,NTX), SXT(3), SYT(3)
      INTEGER V(3)

!  Find the 2 rightmost vertices and give the top one the number 3 and the
!  other the number 2.  Then, of the remaining 2 vertices, give the bottom
!  one the number 1.

      DO JS=1,NTX
         M3=1
         M2=2
         DO J=3,4
            IF (SX(M2,JS)>SX(M3,JS)) THEN
               M3T=M3
               M3=M2
               M2=M3T
            ENDIF
            IF (SX(J,JS)>SX(M2,JS)) M2=J
         ENDDO

!  M3 and M2 are now the indices of the 2 rightmost points.
!  Assign the one with the biggest Y as V(3) and the other as V(2).

         IF (SY(M3,JS)>SY(M2,JS)) THEN
            V(3)=M3
            V(2)=M2
         ELSE
            V(3)=M2
            V(2)=M3
         ENDIF

!  Find vertex 1 by requiring SY(1) < SY(4)

         M1=0
         DO J=1,4
            IF ((J/=M3).AND.(J/=M2)) THEN
               IF (M1==0) THEN
                  M1=J
               ELSE
                  M4=J
               ENDIF
            ENDIF
         ENDDO

         V(1)=M1
         IF (SY(M1,JS)>SY(M4,JS)) V(1)=M4

         DO J=1,3
            SXT(J)=SX(V(J),JS)
            SYT(J)=SY(V(J),JS)
         ENDDO
         DO J=2,3
            SX(J,JS)=SXT(J)
            SY(J,JS)=SYT(J)
         ENDDO

!  If necessary, re-position vertex 1 so that SEG12 is perpendicular
!  to SEG23

         SEG12=SQRT((SX(2,JS)-SXT(1))**2+(SY(2,JS)-SYT(1))**2)
         SEG32=SQRT((SX(2,JS)-SX(3,JS))**2+(SY(2,JS)-SY(3,JS))**2)

         STH=(SX(3,JS)-SX(2,JS))/SEG32
         CTH=SQRT(1.-STH**2)
         SY(1,JS)=STH*SEG12+SY(2,JS)
         SX(1,JS)=SX(2,JS)-SEG12*CTH

!Now find vertex 4.

         SX(4,JS)=SX(3,JS)+SX(1,JS)-SX(2,JS)
         SY(4,JS)=SY(3,JS)+SY(1,JS)-SY(2,JS)
      ENDDO

      RETURN
      END
!END OF ROI_SETTX

      SUBROUTINE ROI_TDPULS (NW,DO3D,IPRF,PRTSEC,IDH,CDNT,DWNHL,MXTX,ITYM, &
                         NCHNL,TMS,WTMS,OFFTYM,MDELYT,TMSPR,NSX,BPLR,      &
                         CRVSEG,TXON,TXAMP,NFRQ,FREQ,HFD,NTX,SX,SY,NRX,    &
                         RX,RY,RZ,RXAREA,NLYR,RES,THK,COLE,ICOLE,CHRG,     &
                         CTAU,CFREQ,TITLE,RDIP,RPHI,DOWNHOLE)
!
!  ------------------------------------------------------------------
!
!  Converts scattered field frequency-domain step H data in array HFD to
!  time-domain step b(t) data, and convolves this with impulse system Tx-Rx
!  to produce the dB/dt measured by the system.
!  It computes the layered earth primary time-domain step dB/dt and also
!  convolves it with an impulse system.
!  It adds the two together to get the "observed" system response and
!  then computes the percentage scattered effect.
!  Extant system choices are EM37, Sirotem, and user-defined bipolar
!  rectangular, and arbitrary waveform

!*** Called by MAIN
!*** Calls ROI_HSBOSS, ROI_CUBSPL, COSTRN, ROI_TDSET, TDSREC, ROI_WRMIRA,
!          ROI_WRPLS

!    MXTX & MXRX are the maximum dimensions for transmitters and
!                receivers respectively.
!     NTX - number of transmitters
!    ITYM - indicates which time-domain system is to be used.
!   NCHNL - number of channels
!     TMS - receiver delay times in sec (end of TX signal)
!    WTMS - receiver channel widths in sec.
!  OFFTYM - actual offtime + ramp turnoff in sec.
!  MDELYT - number of Sirotem channels within the ramp turnoff.
!   TMSPR - array containing the receiver delay times in ms from top of
!           ramp for Sirotem and from bottom of ramp for EM37 and
!           user-defined systems.
!     NSX - number of transmitter current points to be specified
!    BPLR - true if transmitter waveform is bipolar
!  CRVSEG - waveform is cubic spline connecting specified points if TRUE.
!         - waveform is connected linear segments if FALSE.
!    TXON - specified abscissa time points for Tx waveform in sec.
!   TXAMP - transmitter current at TXON points
!    NFRQ - number of frequency domain-values
!    FREQ - array of NFRQ frequencies.
!  SX, SY - arrays containing the coordinates of the Tx corners.
!     NRX - number of receivers
!  RXAREA - area of receivers
!    DO3D - true if NTEM3D = 1
!  PRTSEC - print scattered fields if true.
!    NLYR - number of layers
!     RES - layer resistivities
!     THK - layer thicknesses
!    IPRF - indicates profile or decay curve output
!      NW - output unit number

!  HFD(I,J,K) - Kth component of the imaginary frequency-domain impulse
!               response magnetic field (H) at receiver J for frequency I.
!  BLE(I,J,K) - Kth component of the layered-earth, time-domain step response
!               magnetic induction (B) at receiver J for time I.
!  CHRG, CTAU, & CFREQ are the layer Cole-Cole parameters.
!  RX, RY, RZ - arrays containing the X,Y,Z locations of the receivers.
!   DWNHL - true if any of the RZ do not = 0.
!
      IMPLICIT NONE
!
      REAL COSTRN,EXTENT,FACBLE,OFFTYM,PULSE,RXAREA,SXAV,SYAV,T,T0,TWOPI
      INTEGER IDH,IPRF,ITYM,J1,JC,JF,JR,JS,JT,KMPF,KMPS,KSR,KTX,KTXFXD,  &
              LPRT,MDELYT,MRX,MXFRQ,MXLYR,MXRX
      INTEGER MXRXL,MXTX,MXTYM,NA,NCHNL,NFRQ,NLYR,NPLS,NSX,NTPL,NTX,     &
              NTYRP,NW
!
      PARAMETER (MXTYM=75, MXRX=50, MXRXL=100, MXFRQ=75, MXLYR=20)
      REAL TMS(MXTYM),WTMS(MXTYM),TMSPR(MXTYM),TRP(MXTYM),TXON(MXTYM),   &
           TXAMP(4,MXTYM),BLE(MXTYM,MXRX,3),FREQ(MXFRQ),XFRQ(4,MXFRQ),   &
           FAC(MXFRQ),WF(MXFRQ),HFD(MXFRQ,3,MXRX,MXTX),YPRM(4,MXTYM),    &
           YSEC(4,MXTYM),RX(MXRX,MXTX),RY(MXRX,MXTX),RZ(MXRX,MXTX),      &
           RXL(MXRXL),RYL(MXRXL),RZL(MXRXL),SX(4,MXTX),SY(4,MXTX),       &
! -- RZLWR is the z-coordinate for printing. 1D computation of Leroi
!    does not recognise negative z-coordinates.
                                 RZLWR(MXRXL),                           &
           SXL(4),SYL(4),RES(MXLYR),THK(MXLYR),CHRG(MXLYR),CTAU(MXLYR),  &
           CFREQ(MXLYR),BTDSC(MXTYM,MXRXL,3),PBTDSC(MXTYM,MXRXL,3),      &
           BTD(MXTYM,MXRXL,3),BTDPRM(MXTYM,MXRXL,3),                     &
           RDIP(MXRX,MXTX),RPHI(MXRX,MXTX),RDIPL(MXRX),RPHIL(MXRX),      &
           HTMPX,HTMPY,HTMPZ,AA1,AA2,DIP,AZIM
      INTEGER NRX(MXTX),ICOLE(MXLYR),DOWNHOLE
      DOUBLE PRECISION QTYM
      LOGICAL COLE,STEP,CDNT,DWNHL,DO3D,BPLR,CRVSEG,PRTSEC,SOLE,ENOUGH
      CHARACTER*80 TITLE
      DATA TWOPI /6.283185/

!  FAC = RXAREA * 4PIE-7 * 10**6 / (2PI * FRQ)

      NA=22
      OPEN (NA,FILE='AMIRA.FMT',STATUS='UNKNOWN')

!  Set up time interpolation.  PULSE = 1 ontym + 1 offtime = 1/2 bipolar
!  pulse.  Compute responses past NPLS half bipolar pulses.
!  NTYRP is the number of points over the NPLS cycles.
!  NTPL is the number of points spanned by PULSE.
!  Spline the transmitter waveform for CRVSEG = .TRUE.

      FACBLE=RXAREA*1.0E6
      IF (CRVSEG) CALL ROI_CUBSPL(TXON,TXAMP,NSX,0,0)
      IF (ITYM<0) RXAREA=1000.

      QTYM=DLOG(10.D0)/12.D0
      QTYM=DEXP(QTYM)
      NPLS=4
      PULSE=TXON(NSX)+OFFTYM

      T0=(TMS(1)-WTMS(1)/2.)/SNGL(QTYM)
      EXTENT=NPLS*PULSE*SNGL(QTYM)

!  Use ROI_TRPSET to compute the interpolation time set so that the exact
!  frequencies for which 3-D frequency-domain exists are accessed.
!  Compute the time-domain impulse layered-earth response BLE.
!  FACBLE is a conversion factor which produces microvolts per amp for
!  user systems & Sirotem - or nano-volts per amp per sq. m. for EM-37.

      CALL ROI_TRPSET(MXTYM,T0,EXTENT,PULSE,QTYM,NTYRP,NTPL,TRP)

      IF (DO3D) THEN
         DO JF=1,NFRQ
            WF(JF)=ALOG(TWOPI*FREQ(JF))
            FAC(JF)=RXAREA*.2/FREQ(JF)
         ENDDO
      ENDIF

!  Set up profile print for coincident loop and central loop and any other
!  locked receiver-transmitter system.

      ENOUGH=.FALSE.
      SOLE=.FALSE.
      IF (CDNT.OR.(IDH==6)) SOLE=.TRUE.

      DO KTX=1,NTX
         MRX=NRX(KTX)
         DO J1=1,4
            SXL(J1)=SX(J1,KTX)
            SYL(J1)=SY(J1,KTX)
         ENDDO
         DO J1=1,MRX
            RXL(J1)=RX(J1,KTX)
            RYL(J1)=RY(J1,KTX)
! -- RZL is the z-coordintate for computation and RZLWR is the z-coordinate
!    for printing. This is because 1D computations of Leroi do not
!    recognise negative  z-coordinates.
            RZL(J1)=abs(RZ(J1,KTX))
            RZLWR(J1)=RZ(J1,KTX)
         ENDDO

         IF (SOLE.AND.(KTX>1)) ENOUGH=.TRUE.
         IF (.NOT.ENOUGH) THEN
            STEP=.FALSE.
            CALL ROI_HSBOSS(MXTYM,NTYRP,TRP,NLYR,RES,THK,ICOLE,CHRG,CTAU,  &
                        CFREQ,SXL,SYL,MRX,RXL,RYL,RZL,CDNT,DWNHL,COLE,     &
                        STEP,BLE)
         ENDIF
!
!  --- Rotate the components in the output coordinate system to the
!      internal coordinate system
!
         IF (DOWNHOLE==1) THEN
!
!   --- Note that the x and y components are NOT exchanged
!
            DO JT=1,MXTYM
            DO J1=1,MRX
               HTMPX=BLE(JT,J1,1)
               HTMPY=BLE(JT,J1,2)
               HTMPZ=BLE(JT,J1,3)
               DIP=RDIP(J1,KTX)/180.*3.14159265359
               AZIM=RPHI(J1,KTX)/180.*3.14159265359
               AA1= COS(AZIM)*HTMPX+SIN(AZIM)*HTMPY
               AA2=-SIN(AZIM)*HTMPX+COS(AZIM)*HTMPY
               BLE(JT,J1,3)= COS(DIP)*HTMPZ+SIN(DIP)*AA1
               BLE(JT,J1,1)=-SIN(DIP)*HTMPZ+COS(DIP)*AA1
               BLE(JT,J1,2)=AA2
            ENDDO
            ENDDO
            DO J1=1,MRX
               RDIPL(J1)=RDIP(J1,KTX)
               RPHIL(J1)=RPHI(J1,KTX)
            ENDDO
         ENDIF
!
         KSR=KTX
         DO JR=1,MRX
            IF (.NOT.SOLE) KSR=JR
            KMPS=1
            KMPF=3
            IF (CDNT) KMPS=3
            DO JC=KMPS,KMPF

!  Convolve the layered earth impulse response in BLE with the system
!  and stick the result back into BTD.

               IF (.NOT.ENOUGH) THEN
                  DO JT=1,NTYRP
                     T=TRP(JT)
                     YPRM(1,JT)=FACBLE*BLE(JT,JR,JC)
                  ENDDO
                  STEP=.FALSE.
                  CALL ROI_TDSET(MXTYM,MXRXL,JC,JR,NTPL,NTYRP,TRP,NPLS,  &
                             PULSE,NCHNL,TMS,WTMS,BPLR,CRVSEG,NSX,TXON,  &
                             TXAMP,YPRM,STEP,BTDPRM)
               ENDIF

!  If DO3D is true,
!  Convert scattered frequency-domain impulse H to frequency-domain step B
!  micro-voltage by multiplying it by FAC = 10**6 * RXAREA mu /omega.
!  Spline it as a function of log (omega) (array WF).
!  Transform each component to time domain using COSTRN.
!  Convolve it with the system waveform.  BTDSC contains the result.

               IF (DO3D) THEN
                  DO JF=1,NFRQ
                     XFRQ(1,JF)=HFD(JF,JC,JR,KTX)*FAC(JF)
                  ENDDO
                  XFRQ(2,1)=0.
                  CALL ROI_CUBSPL(WF,XFRQ,NFRQ,1,0)

                  DO JT=1,NTYRP
                     T=TRP(JT)
                     YSEC(1,JT)=COSTRN(WF,XFRQ,NFRQ,T)
                  ENDDO
                  STEP=.TRUE.
                  CALL ROI_TDSET(MXTYM,MXRXL,JC,KSR,NTPL,NTYRP,TRP,NPLS,  &
                             PULSE,NCHNL,TMS,WTMS,BPLR,CRVSEG,NSX,TXON,   &
                             TXAMP,YSEC,STEP,BTDSC)

!  Compute total response & percent scattered response.

                  DO JT=1,NCHNL
                     BTD(JT,KSR,JC)=BTDSC(JT,KSR,JC)+BTDPRM(JT,JR,JC)
                     IF (ABS(BTD(JT,KSR,JC))>1.E-30) THEN
                        PBTDSC(JT,KSR,JC)=100.*BTDSC(JT,KSR,JC)  &
                           /BTD(JT,KSR,JC)
                     ELSE
                        PBTDSC(JT,KSR,JC)=0.
                     ENDIF
                  ENDDO
               ELSE
                  DO JT=1,NCHNL
                     BTD(JT,KSR,JC)=BTDPRM(JT,JR,JC)
                  ENDDO
               ENDIF
            ENDDO
         ENDDO

!  Print results for multiple receiver geometries

         IF (.NOT.SOLE) THEN
            IF (DO3D) THEN
               LPRT=1
               IF (DOWNHOLE==0)                                            &
               CALL ROI_WRPLS(NW,MXTYM,MXRXL,KTX,ITYM,NCHNL,MDELYT,TMSPR,  &
                              MRX,RXL,RYL,RZLWR,CDNT,DWNHL,TITLE,LPRT,BTD,IPRF)
               IF (DOWNHOLE==1)                                            &
               CALL ROI_WRPLSDH(NW,MXTYM,MXRXL,KTX,ITYM,NCHNL,MDELYT,TMSPR, &
                                MRX,RXL,RYL,RZLWR,RDIPL,RPHIL,CDNT,DWNHL,     &
                                TITLE,LPRT,BTD,IPRF)

               IF (DOWNHOLE==0)                                            &
               CALL ROI_WRMIRA(NA,KTX,MXTYM,MXRXL,ITYM,NCHNL,MDELYT,MRX,   &
                               RXL,RYL,RZLWR,CDNT,DWNHL,TITLE,BTD)
               IF (DOWNHOLE==1)                                            &
               CALL ROI_WRMIRADH(NA,KTX,MXTYM,MXRXL,ITYM,NCHNL,MDELYT,MRX,  &
                               RXL,RYL,RZLWR,RDIPL,RPHIL,CDNT,DWNHL,TITLE,BTD)

!  Print scattered fields if required.

               IF (PRTSEC) THEN
                  LPRT=2
                  IF (DOWNHOLE==0)                                            &
                  CALL ROI_WRPLS(NW,MXTYM,MXRXL,KTX,ITYM,NCHNL,MDELYT,TMSPR,  &
                             MRX,RXL,RYL,RZLWR,CDNT,DWNHL,TITLE,LPRT,BTDSC,IPRF)
                  IF (DOWNHOLE==1)                                            &
                  CALL ROI_WRPLSDH(NW,MXTYM,MXRXL,KTX,ITYM,NCHNL,MDELYT,TMSPR,&
                                   MRX,RXL,RYL,RZLWR,RDIPL,RPHIL,CDNT,DWNHL,    &
                                   TITLE,LPRT,BTDSC,IPRF)
               ENDIF

!  Print percent scattered fields.

               LPRT=3
               IF (DOWNHOLE==0)                                            &
               CALL ROI_WRPLS(NW,MXTYM,MXRXL,KTX,ITYM,NCHNL,MDELYT,TMSPR,  &
                          MRX,RXL,RYL,RZLWR,CDNT,DWNHL,TITLE,LPRT,PBTDSC,IPRF)
               IF (DOWNHOLE==1)                                              &
               CALL ROI_WRPLSDH(NW,MXTYM,MXRXL,KTX,ITYM,NCHNL,MDELYT,TMSPR,  &
                          MRX,RXL,RYL,RZLWR,RDIPL,RPHIL,CDNT,DWNHL,TITLE,LPRT, &
                          PBTDSC,IPRF)
            ELSE
               IPRF=1
               LPRT=0
               IF (DOWNHOLE==0)                                            &
               CALL ROI_WRPLS(NW,MXTYM,MXRXL,KTX,ITYM,NCHNL,MDELYT,TMSPR,  &
                          MRX,RXL,RYL,RZLWR,CDNT,DWNHL,TITLE,LPRT,BTDPRM,IPRF)
               IF (DOWNHOLE==1)                                            &
               CALL ROI_WRPLSDH(NW,MXTYM,MXRXL,KTX,ITYM,NCHNL,MDELYT,TMSPR,  &
                          MRX,RXL,RYL,RZLWR,RDIPL,RPHIL,CDNT,DWNHL,TITLE,LPRT, &
                          BTDPRM,IPRF)
               IF (DOWNHOLE==0)                                               &
               CALL ROI_WRMIRA(NA,KTX,MXTYM,MXRXL,ITYM,NCHNL,MDELYT,MRX,RXL,  &
                           RYL,RZLWR,CDNT,DWNHL,TITLE,BTDPRM)
               IF (DOWNHOLE==1)                                               &
               CALL ROI_WRMIRADH(NA,KTX,MXTYM,MXRXL,ITYM,NCHNL,MDELYT,MRX,RXL,&
                           RYL,RZLWR,RDIPL,RPHIL,CDNT,DWNHL,TITLE,BTDPRM)
            ENDIF

         ENDIF
      ENDDO

!  Print results for single receiver or coincident loop profiles so that
!  the net result is presented like a single transmitter with multiple
!  receivers, where NTX replaces MRX.
!  If PRTSEC is true, print scattered fields.
!  Then print percent scattered fields.  First set local receiver
!  positions as though for 1 transmitter
!  If CDNT is true, then assign receiver position to loop centre.


      IF (SOLE) THEN
         DO JS=1,NTX
            IF (CDNT) THEN
               SXAV=SX(1,JS)+SX(2,JS)+SX(3,JS)+SX(4,JS)
               SYAV=SY(1,JS)+SY(2,JS)+SY(3,JS)+SY(4,JS)
               RXL(JS)=SXAV/4.
               RYL(JS)=SYAV/4.
            ELSE
               RXL(JS)=RX(1,JS)
               RYL(JS)=RY(1,JS)
            ENDIF
         ENDDO

         KTXFXD=-1
         LPRT=1
         CALL ROI_WRPLS(NW,MXTYM,MXRXL,KTXFXD,ITYM,NCHNL,MDELYT,TMSPR,NTX, &
                    RXL,RYL,RZLWR,CDNT,DWNHL,TITLE,LPRT,BTD,IPRF)

         IF (PRTSEC) THEN
            LPRT=2
            CALL ROI_WRPLS(NW,MXTYM,MXRXL,KTXFXD,ITYM,NCHNL,MDELYT,TMSPR,  &
                       NTX,RXL,RYL,RZLWR,CDNT,DWNHL,TITLE,LPRT,BTDSC,IPRF)
         ENDIF

         IF (DO3D) THEN
            LPRT=3
            CALL ROI_WRPLS(NW,MXTYM,MXRXL,KTXFXD,ITYM,NCHNL,MDELYT,TMSPR,  &
                       NTX,RXL,RYL,RZLWR,CDNT,DWNHL,TITLE,LPRT,PBTDSC,  &
                       IPRF)
         ENDIF

         KTX=1
         CALL ROI_WRMIRA(NA,KTXFXD,MXTYM,MXRXL,ITYM,NCHNL,MDELYT,NTX,RXL,  &
                     RYL,RZLWR,CDNT,DWNHL,TITLE,BTD)
      ENDIF

      RETURN
      END
!  END OF ROI_TDPULS

      SUBROUTINE ROI_TRPSET (MXTYM,T0,EXTENT,PULSE,QTYM,NTYRP,NTPL,TRP)
!
      IMPLICIT NONE
!
      REAL DELCOS,EXTENT,PULSE,T0,TWOPI,WCOS,WJ0,WJ1,WS
      INTEGER J1,MXTYM,NTPL,NTYRP
!     -------------------------------------------------------------

!  Sets up interpolation times for FD -> TD transform which use the
!  exact 6 points per decade frequency-domain data plus 6 per decade
!  interpolated values.  These are based on a 12 point per decade
!  cosine filter derived from the Niels Christensen routine FILCOA
!  with OMEGA = .3 PI and shift DELCOS.

!***  Called from ROI_TDPULS

!       TRP - array of time values for FD -> TD transformations
!     MXTYM - maximum dimension of TRP array
!     NTYRP - number of values in TRP
!        T0 - the earliest time for which time-domain output is required.
!    EXTENT - the latest time for which time-domain output is required.
!     PULSE - time length of one signal pulse
!      NTPL - number of TRP values in 1 PULSE
!      QTYM - spacing parameter for TRP


      REAL TRP(MXTYM)
      DOUBLE PRECISION TBASE,QTYM, TQ
      COMMON /FILTER/ DELCOS,WCOS(-200:99), WJ0(283), WJ1(283), WS(266)
      DATA TWOPI /6.2831853/

      TBASE=DEXP(DBLE(-DELCOS))/DBLE(TWOPI)
      DO J1=1,MXTYM
         IF (TBASE<T0) THEN
            EXIT
         ENDIF
         TBASE=TBASE/QTYM
      ENDDO

      TQ=TBASE
      TRP(1)=SNGL(TQ)
      DO J1=2,MXTYM
         NTYRP=J1
         TQ=TQ*QTYM
         TRP(J1)=SNGL(TQ)
         IF (TRP(J1)<PULSE) NTPL=J1+2
!*********************************************
         IF (TRP(J1)>EXTENT) THEN
            RETURN
         ENDIF
!*********************************************
      ENDDO
      END
!  END OF ROI_TRPSET

      SUBROUTINE ROI_TDSET (MXTYM,MXRX,JC,JR,NTPL,NTYRP,TRP,NPLS,PULSE,   &
                        NCHNL,TMS,WTMS,BPLR,CRVSEG,NSX,TXON,TXAMP,YT,     &
                        STEP,BT)
!
      IMPLICIT NONE
!
      REAL CUBDER,CUBINT,CUBVAL,PULSE,T,TBEG,TEND,TP,TXCNVC,TXCNVL,YP
      INTEGER ICOMB,JC,JPL,JR,JT,MXRX,MXT1,MXTYM,NCHNL,NCNV,NPLS,NSX,  &
              NTPL,NTYRP
!     ----------------------------------------------------------------

!  Sets up the convolution of time-domain step b(t) data, YT, with a the
!  transmitter waveform which can be composed of linear segments,
!  curved segments, bipolar, or monopolar to produce system output BT.

!***  Called by ROI_TDPULS
!***  Calls ROI_CUBSPL, CUBVAL, CUBINT, CUBDER, TXCNVC, TXCNVL

!      JC - component index (1 => X; 2 => Y; 3 => Z)
!      JR - receiver index
!    NTPL - number of time interpolation points in 1 off-time + 1 on time.
!   NTYRP - total number of time interpolation points
!     TRP - array of time interpolation points
!    NPLS - number of half bipolar pulses or single monopolar pulses
!   NCHNL - number of channels
!     TMS - receiver delay times in sec (from top of ramp)
!    WTMS - receiver channel widths in sec.
!     NSX - number of transmitter current points to be specified
!    BPLR - true if transmitter waveform is bipolar
!  CRVSEG - waveform is connected linear segments if FALSE.
!         - waveform is cubic spline connecting specified points if TRUE.
!    TXON - specified abscissa time points for Tx waveform in sec.
!   TXAMP - transmitter current at TXON points
!      YT - raw time-domain data
!    STEP - true only if YT is step response h(t)
!      BT - output containing convolved time-domain responses

      PARAMETER (MXT1=100)
      REAL TRP(MXTYM),YT(4,MXTYM),BT(MXTYM,MXRX,3),TMS(MXTYM),   &
           WTMS(MXTYM),YPOS(4,MXT1),TXON(MXTYM),TXAMP(4,MXTYM)
      LOGICAL STEP,BPLR,CRVSEG

!  Spline the result for each receiver component separately.
!  Accumulate the effect of all step response pulses.
!  Take account of whether the pulse is bipolar or repeated with the same
!  sign.

      CALL ROI_CUBSPL(TRP,YT,NTYRP,0,0)
      DO JT=1,NTPL
         T=TRP(JT)
         YPOS(1,JT)=CUBVAL(TRP,YT,NTYRP,T)
         ICOMB=1
         DO JPL=2,NPLS
            IF (BPLR) ICOMB=-ICOMB
            TP=T+(JPL-1)*PULSE
            YP=CUBVAL(TRP,YT,NTYRP,TP)
            YPOS(1,JT)=YPOS(1,JT)+ICOMB*YP
         ENDDO
      ENDDO
      CALL ROI_CUBSPL(TRP,YPOS,NTPL,0,0)

!  Spline the combined pulses with the Tx waveform.  Use TXCNVL for
!  linear segments and TXCNVC for smooth Tx waveforms.

      DO JT=1,NTPL
         T=TRP(JT)+TXON(NSX)
         IF (CRVSEG) THEN
            YT(1,JT)=TXCNVC(T,NTPL,TRP,YPOS,NSX,TXON,TXAMP)
         ELSE
            YT(1,JT)=TXCNVL(T,NTPL,TRP,YPOS,NSX,TXON,TXAMP)
         ENDIF
         IF (T>PULSE) THEN
            NCNV=JT
            EXIT
         ENDIF
      ENDDO
      CALL ROI_CUBSPL(TRP,YT,NCNV,0,0)

!The impulse response averaged over the receiver windows is simply
!the step response difference at the edges divided by the width.

      IF (STEP) THEN
         DO JT=1,NCHNL
            T=TMS(JT)
            IF (T<100.*WTMS(JT)) THEN
               TBEG=T-0.5*WTMS(JT)
               TEND=TBEG+WTMS(JT)
               BT(JT,JR,JC)=(CUBVAL(TRP,YT,NCNV,TBEG)-           &
                             CUBVAL(TRP,YT,NCNV,TEND))/WTMS(JT)
            ELSE
               BT(JT,JR,JC)=-CUBDER(TRP,YT,NCNV,T)
            ENDIF
         ENDDO

      ELSE
         DO JT=1,NCHNL
            T=TMS(JT)
            IF (T<100.*WTMS(JT)) THEN
               TBEG=T-0.5*WTMS(JT)
               TEND=TBEG+WTMS(JT)
               BT(JT,JR,JC)=CUBINT(TRP,YT,NCNV,TBEG,TEND)/WTMS(JT)
            ELSE
               BT(JT,JR,JC)=CUBVAL(TRP,YT,NCNV,T)
            ENDIF
         ENDDO
      ENDIF

      RETURN
      END
!  END OF ROI_TDSET

      FUNCTION TXCNVC (T,NTPL,TRP,YPOS,NSX,TXON,TXAMP)
      REAL CUBDER,CUBINT,CUBVAL,DEL,DELS,T,T0,TAU,TXCNVC,X,X1,X2,Y
      INTEGER IT1,IT2,J,J1,JS,MXTYM,NCNV,NDUMMY,NPT,NSX,NTPL
!     ------------------------------------------------

!***  Called by TEM
!***  Calls ROI_CUBSPL, ROI_INTERV, CUBVAL, CUBINT

!  Convolves an input earth STEP response function (B or dB/dt) with the
!  derivative of the source waveform to produce the system IMPULSE
!  response (B or dB/dt) of the earth.

!  The input STEP response function must be contained in a splined array
!  described by ordinate array YPOS, with time in abscissa array TRP.

!  The transmitter source function must be input as a splined array of
!    NSX values of time (abscissa) TXON and current TXAMP.

!   TXCNVC (T) = INT (T0 -> T) { [d TXAMP (T - x) /dT] * YPOS (x)  dx }

!     where  T is convolution time measured from the beginning of the
!     source waveform.  It is also the upper limit of convolution in sec.

!
!  WARNING:  This routine works with the derivative of TXAMP so make sure
!            that enough source points have been included to make this
!            accurate.  (For a half-sine, 11 points works well.)

      PARAMETER (MXTYM=75)
      REAL TRP(MXTYM),YPOS(4,MXTYM),TXON(MXTYM),TXAMP(4,MXTYM),   &
           XCNV(MXTYM),YCNV(4,MXTYM)

!  Set abscissa points for convolution.
!  First, set lower limit, T0, for convolution integration.
!  T0 cannot be less than TRP(1).  Locate the interval numbers for T0 and T.

      T0=T-TXON(NSX)
      T0=AMAX1(TRP(1),T0)
      CALL ROI_INTERV(TRP,NTPL-1,T,IT2,NDUMMY)
      CALL ROI_INTERV(TRP,NTPL-1,T0,IT1,NDUMMY)
      X1=TRP(IT1+1)-T0
      X2=TRP(IT1+1)-TRP(IT1)
      IF (X1<0.001*X2) THEN
         IT1=IT1+1
         T0=TRP(IT1)
      ENDIF

      XCNV(1)=T0
      NCNV=IT2-IT1+2
      DELS=TXON(NSX)/FLOAT(NSX-1)

!  Set abscissae for convolution.

      IF (NCNV<NSX) THEN
         NCNV=NSX
         DO JS=2,NCNV-1
            XCNV(JS)=XCNV(JS-1)+DELS
         ENDDO
      ELSE
         JS=1
         DO J=IT1+1,IT2
            DEL=TRP(J)-TRP(J-1)

            IF (DEL>=DELS) THEN
               NPT=IFIX((T-XCNV(JS))/DELS)+1
               DEL=(T-XCNV(JS))/FLOAT(NPT)
               DO J1=2,NPT
                  JS=JS+1
                  XCNV(JS)=XCNV(JS-1)+DEL
               ENDDO
               NCNV=JS+1
               EXIT
            ENDIF

            JS=JS+1
            XCNV(JS)=TRP(J)
         ENDDO
      ENDIF

      XCNV(NCNV)=T

!  Compute step function - source function derivative convolution product.

      DO J=1,NCNV
         TAU=XCNV(J)
         X=T-TAU
         Y=CUBVAL(TRP,YPOS,NTPL,TAU)
         YCNV(1,J)=-Y*CUBDER(TXON,TXAMP,NSX,X)
      ENDDO

      CALL ROI_CUBSPL(XCNV,YCNV,NCNV,0,0)
      TXCNVC=CUBINT(XCNV,YCNV,NCNV,T0,T)
      RETURN
      END
!  END OF TXCNVC

      FUNCTION TXCNVL (T,NTPL,TRP,YPOS,NSX,TXON,TXAMP)
      REAL ALF,CUBINT,CUBVAL,DELT,SEG,SUM,T,TB,TEND,TM,TOL,TXCNVL
      INTEGER JT,MXTYM,NSX,NTPL
!     ------------------------------------------------

!***  Called by STEM
!***  Calls CUBINT, CUBVAL

!  Convolves an input earth STEP response function (B or dB/dt) with the
!  derivative of the source waveform to produce the system IMPULSE
!  response (B or dB/dt) of the earth.

!  The input STEP response function must be contained in a splined array
!  of NTPL values of time (abscissa) TRP and ordinate YPOS.

!  The source waveform is assumed to be composed of linear segments.

!              T - convolution time in sec measured from the beginning
!                  of the source waveform.
!      TRP, YPOS - abscissa & ordinate values of step response function to
!                  be convolved.
!           NTPL - number of values in TRP and YPOS
!    TXON, TXAMP - abscissa & ordinate values of source waveform
!                  in sec & amps respectively
!            NSX - number of points in TXON & TXAMP

      PARAMETER (MXTYM=75)
      REAL TRP(MXTYM),YPOS(4,MXTYM),TXON(MXTYM),TXAMP(4,MXTYM)

!  Compute TXDIF & DELTA.  We want the turnoff pulse to give a positive
!  response which is why ALF is proportional to the negative slope.

      SUM=0.
      DO JT=2,NSX
         ALF=TXAMP(1,JT-1)-TXAMP(1,JT)
         TOL=1.E-4*ABS(TXAMP(1,JT))
         IF (ABS(ALF)>=TOL) THEN
            DELT=TXON(JT)-TXON(JT-1)
            TB=T-TXON(JT)
            TEND=TB+DELT
            TM=TB+(DELT/2.)
            IF (DELT<1.E-3*TB) THEN
               SEG=ALF*CUBVAL(TRP,YPOS,NTPL,TM)
            ELSE
               SEG=ALF*CUBINT(TRP,YPOS,NTPL,TB,TEND)/DELT
            ENDIF
            SUM=SUM+SEG
         ENDIF
      ENDDO
      TXCNVL=SUM

      RETURN
      END
!  END OF TXCNVL

      SUBROUTINE ROI_UTEM (NW,MXTX,NCHNL,BASFRQ,NFRQ,FREQ,HFD,NTX,SX,SY,   &
                           NRX,RX,RY,RZ,DO3D,NLYR,RES,THK,COLE,ICOLE,      &
                           CHRG,CTAU,CFREQ,TITLE,IPRF)
!
      IMPLICIT NONE
!
      REAL BASFRQ,BSEC,COSTRN,CUBINT,CUBVAL,DELTA,FACBLE,ONTYM,QTYM,  &
           SPLT,T,T1,TF,TH,TL,TP1,TWOPI,XTRANS
      INTEGER ICOMB,IPRF,ITYM,J1,JC,JF,JP,JR,JS,JT,KTX,MDELYT,MRX,MXCH,  &
              MXFRQ,MXLYR,MXRX,MXTX,MXTYM,NA
      INTEGER NCHNL,NFRQ,NLYR,NPL,NTP1,NTX,NTYRP,NW
!     -----------------------------------------------------------------

!***  Calls ROI_BZAIR, COSTRN, ROI_CUBSPL, CUBVAL, CUBINT,
!           ROI_HSBOSS, ROI_UTEMWR, ROI_WRMIRA
!***  Called by MAIN

!  Converts scattered field frequency-domain step H data in array HFD to
!  time-domain step b(t) data, and convolves this with the ROI_UTEM system.
!  It computes the layered earth primary time-domain step dB/dt and also
!  convolves it with the ROI_UTEM system.
!  It adds the two together to get the "observed" system response and
!  then computes the percentage scattered effect.

!         NTX - number of transmitters
!       NCHNL - number of channels.  The program will limit the number
!               of channels if the last begins earlier than 0.01 ms.
!      BASFRQ - base frequency for ROI_UTEM system
!        NFRQ - number of frequency domain-values
!        FREQ - array of NFRQ frequencies.
!      SX, SY - arrays containing the coordinates of the Tx corners.
!         NRX - number of receivers
!   RX, RY RZ - arrays of X,Y,Z coordinates of the receivers.
!        DO3D = F => do layered earth computation only
!        NLYR - number of layers
!         RES - layer resistivities
!         THK - layer thicknesses
!        IPRF - indicates profile or decay curve output
!        IPRF - indicates profile or decay curve output
!          NW - output unit number
!  HFD(I,J,K) - Kth component of the imaginary frequency-domain impulse
!               response magnetic field (H) at receiver J for frequency I.
!  BLE(I,J,K) - Kth component of the layered-earth, time-domain step response
!               magnetic induction (B) at receiver J for frequency I.
!  CHRG, CTAU, & CFREQ are the layer Cole-Cole parameters.


      PARAMETER (MXTYM=75, MXCH=20, MXRX=50, MXFRQ=75, MXLYR=20)
      REAL TMS(MXCH),LOW(MXCH),HIGH(MXCH),TRP(MXTYM),BLE(MXTYM,MXRX,3),  &
           TMPX(4,MXTYM),XTYM(4,MXTYM),BTD(MXTYM,MXRX,3),FREQ(MXFRQ),    &
           XFRQ(4,MXFRQ),FAC(MXFRQ),WF(MXFRQ),HFD(MXFRQ,3,MXRX,MXTX),    &
           RX(MXRX,NTX),RY(MXRX,NTX),RZ(MXRX,NTX),PRM(MXRX),RXL(MXRX),   &
           RYL(MXRX),RZL(MXRX),SX(4,NTX),SY(4,NTX),SXL(4),SYL(4),        &
           RES(MXLYR),THK(MXLYR),CHRG(MXLYR),CTAU(MXLYR),CFREQ(MXLYR)
      INTEGER NRX(NTX),ICOLE(MXLYR)
      LOGICAL LOOK, STEP, DO3D, COLE, CDNT, DWNHL
      CHARACTER*80 TITLE
      DATA TWOPI /6.283185/

      NA=22
      OPEN (NA,FILE='AMIRA.FMT',STATUS='UNKNOWN')

      ITYM=9
      STEP=.TRUE.
      CDNT=.FALSE.
      MDELYT=0
!***********************************************
      DWNHL=.FALSE.
      DO JR=1,MXRX
         RZL(JR)=0.
         DO JS=1,MXTX
            RZ(JR,JS)=0.
         ENDDO
      ENDDO
!***********************************************

!  Set up the channels and decay time array at 10 points per decade.
!  Assume 2 bipolar pulses (NPL = 4.  TP1 is the array time covering a
!  single ontym.  TF is the array time covering TP1 + (NPL-1) ontyms.

      SPLT=2.
      IF (NCHNL/=10) THEN
         NCHNL=20
         SPLT=SQRT(2.)
      ENDIF

      NPL=4
      ONTYM=0.5/BASFRQ
      TF=4.*ONTYM
      HIGH(1)=ONTYM
      LOW(1)=ONTYM/SPLT
      TMS(1)=SQRT(HIGH(1)*LOW(1))

      DO JC=2,NCHNL
         HIGH(JC)=LOW(JC-1)
         LOW(JC)=HIGH(JC)/SPLT
         TMS(JC)=SQRT(HIGH(JC)*LOW(JC))
      ENDDO

!  Set up time interpolation array and frequency factors.
!  Convert frequency-domain impulse H to frequency-domain step B by
!  multiplying it by FAC = mu /omega.  Express in nanoteslas per amp.
!  Spline it as a function of log (omega) (array WF).

      QTYM=10.**.1
      TRP(1)=LOW(NCHNL)/QTYM
      LOOK=.TRUE.
      DO JT=2,MXTYM
         TRP(JT)=TRP(JT-1)*QTYM
         IF (LOOK.AND.(TRP(JT)>ONTYM)) THEN
            NTP1=JT
            TP1=TRP(JT)
            LOOK=.FALSE.
            TF=TP1+(NPL-1)*ONTYM
         ENDIF
         IF (TRP(JT)>TF) THEN
            NTYRP=JT
!************************************
            EXIT
!************************************
         ENDIF
      ENDDO

      DO JF=1,NFRQ
         WF(JF)=ALOG(TWOPI*FREQ(JF))
         FAC(JF)=200./FREQ(JF)
      ENDDO
      FACBLE=1.0E9

!  FAC = 4PIE-7 * 10**9 / (2PI * FREQ)
!  FACBLE is a nanotesla conversion factor.
!  Compute the DC magnetic field for each receiver.
!  Compute the time-domain step layered-earth response BLE.
!  Transform each component to time domain using COSTRN.
!  Add in layered earth field.

      DO KTX=1,NTX
         MRX=NRX(KTX)
         DO J1=1,4
            SXL(J1)=SX(J1,KTX)
            SYL(J1)=SY(J1,KTX)
         ENDDO
         DO J1=1,MRX
            RXL(J1)=RX(J1,KTX)
            RYL(J1)=RY(J1,KTX)
            RZL(J1)=RZ(J1,KTX)
         ENDDO
         CALL ROI_BZAIR(MRX,RXL,RYL,SXL,SYL,PRM)
         CALL ROI_HSBOSS(MXTYM,NTYRP,TRP,NLYR,RES,THK,ICOLE,CHRG,CTAU,CFREQ, &
                     SXL,SYL,MRX,RXL,RYL,RZL,CDNT,DWNHL,COLE,STEP,BLE)
         DO JR=1,NRX(KTX)
            DO JC=1,3
               IF (DO3D) THEN
                  DO JF=1,NFRQ
                     XFRQ(1,JF)=HFD(JF,JC,JR,KTX)*FAC(JF)
                  ENDDO
                  CALL ROI_CUBSPL(WF,XFRQ,NFRQ,0,0)
               ENDIF
               DO JT=1,NTYRP
                  T=TRP(JT)
                  BSEC=0.
                  IF (DO3D) BSEC=COSTRN(WF,XFRQ,NFRQ,T)
                  TMPX(1,JT)=BSEC+(FACBLE*BLE(JT,JR,JC))
               ENDDO
               CALL ROI_CUBSPL(TRP,TMPX,NTYRP,0,0)

!  Add the effects of different pulses and then average over each channel.
!  Remember that the transient is doubled because the pulse does a double
!  jump from ON to -ON.  The Z component must also include the primary
!  DC magnetic field which is opposite in sign from the transient.

               DO JT=1,NTP1
                  ICOMB=1
                  T1=TRP(JT)
                  XTYM(1,JT)=CUBVAL(TRP,TMPX,NTYRP,T1)
                  DO JP=1,NPL-1
                     ICOMB=-ICOMB
                     T=T1+JP*ONTYM
                     XTYM(1,JT)=XTYM(1,JT)  &
                        +ICOMB*CUBVAL(TRP,TMPX,NTYRP,T)
                  ENDDO
               ENDDO
               CALL ROI_CUBSPL(TRP,XTYM,NTP1,0,0)

!  Integrate response over receiver windows

               DO JT=1,NCHNL
                  TH=HIGH(JT)
                  TL=LOW(JT)
                  DELTA=TH-TL
                  XTRANS=CUBINT(TRP,XTYM,NTP1,TL,TH)/DELTA
                  IF (JC<3) THEN
                     BTD(JT,JR,JC)=2.*XTRANS
                  ELSE
                     BTD(JT,JR,JC)=PRM(JR)-(2.*XTRANS)
                  ENDIF
               ENDDO
            ENDDO
         ENDDO

!  Write un-normalised ROI_UTEM output to NA and NW.  However, at the end of
!  ROI_UTEMWR, the Z-component of BTD has been normalised so make another
!  call to ROI_WRMIRA to write this onto NA.

         ITYM=9
         CALL ROI_WRMIRA(NA,KTX,MXTYM,MXRX,ITYM,NCHNL,MDELYT,MRX,RXL,RYL,   &
                         RZL,CDNT,DWNHL,TITLE,BTD)
         CALL ROI_UTEMWR(NW,KTX,MXTYM,MXRX,NCHNL,TMS,MRX,RXL,RYL,RZL,TITLE, &
                         DWNHL,IPRF,PRM,BTD)
         ITYM=8
         CALL ROI_WRMIRA(NA,KTX,MXTYM,MXRX,ITYM,NCHNL,MDELYT,MRX,RXL,RYL,   &
                         RZL,CDNT,DWNHL,TITLE,BTD)

      ENDDO

      RETURN
      END
!  END OF ROI_UTEM

      SUBROUTINE ROI_UTEMWR (NW,KTX,MXTYM,MXRX,NCHNL,TMS,MRX,RXL,RYL,RZL,   &
                         TITLE,DWNHL,IPRF,PRM,BTD)
!
      IMPLICIT NONE
!
      INTEGER IC,INDPR,IPRF,JC,JR,JT,KTX,MRX,MXRX,MXTYM,NCHNL,NW
!     -----------------------------------------------------------------

!***  Called by ROI_UTEM
!***  Calls ROI_UTWRTM, ROI_WRMIRA

!  Prints the results of ROI_UTEM computations.
!
!             KTX - transmitter number
!             MRX - Number of receivers
!   RXL, RYL, RZL - array of X,Y coordinates of the receivers.
!             PRM - array of DC vertical magnetic fields for each receiver.
!           NCHNL - number of channels.  The program will limit the number
!                   of channels if the last begins earlier than 0.01 ms.
!             TMS - array of times at channel midpoints
!            IPRF - indicates profile or decay curve output
!              NW - output unit number
!  BTD (JT,JR,JC) (JT = 1,NCHNL, JR = 1,MRX, JC = 1,3) -
!                 - 3D array of time-domain X component ROI_UTEM responses
!                   for channel JT, receiver JR, and component JC

      REAL TMS(NCHNL),PRM(MRX),RXL(MRX),RYL(MRX),RZL(MRX),   &
            BTD(MXTYM,MXRX,3)
      LOGICAL DWNHL
      CHARACTER*80 TITLE

      WRITE (NW,'(/2X,A)') TITLE
      WRITE (NW,1010) KTX

!  Sum over components.  JC = 1, 2, 3 are the X, Y, and Z components
!  respectively.  JC = 4 is the Z component, normalised to the
!  primary field.

      DO JC=1,4
         IC=JC
         INDPR=0
         IF (JC==1) THEN
            WRITE (NW,1020) KTX
         ELSEIF (JC==2) THEN
            WRITE (NW,1030) KTX
         ELSEIF (JC==3) THEN
            WRITE (NW,1040) KTX
            INDPR=1
         ELSEIF (JC==4) THEN
            WRITE (NW,1050) KTX
            IC=3
            INDPR=0
            DO JT=1,NCHNL
               DO JR=1,MRX
                  BTD(JT,JR,3)=100*BTD(JT,JR,3)/PRM(JR)
               ENDDO
            ENDDO
         ENDIF

         IF (IPRF==1) THEN
            CALL ROI_UTWRTM(NW,KTX,MXTYM,MXRX,IC,NCHNL,TMS,MRX,RXL,RYL,  &
                        INDPR,PRM,BTD)
         ELSE
            CALL ROI_UTWRPF(NW,MXTYM,MXRX,IC,NCHNL,TMS,MRX,RXL,RYL,RZL,  &
                        DWNHL,BTD)
         ENDIF

      ENDDO
      RETURN

 1010 FORMAT (/'  ROI_UTEM OUTPUT FOR TRANSMITTER #',I2,//  &
              '  THE OUTPUT IS MAGNETIC INDUCTION IN NANOTESLAS PER AMP'  &
              /'  BENEATH EACH RECEIVER POSITION')
 1020 FORMAT (/10X,'X (EAST) COMPONENT FOR TRANSMITTER #',I2/10X,  &
              '-------------------------------')
 1030 FORMAT (//10X,'Y (NORTH) COMPONENT FOR TRANSMITTER #',I2/10X,  &
              '-------------------------------')
 1040 FORMAT (//10X,'VERTICAL COMPONENT FOR TRANSMITTER #',I2/10X,  &
              '-------------------------------')
 1050 FORMAT (//5X,'VERTICAL COMPONENT NORMALISED TO PRIMARY FOR ',  &
              'TRANSMITTER #',I2/5X,53('-'))
      END
!  END OF ROI_UTEMWR

      SUBROUTINE ROI_UTWRTM (NW,KTX,MXTYM,MXRX,IC,NCHNL,TMS,MRX,RXL,RYL,   &
                         INDPR,PRM,BTD)
!
      IMPLICIT NONE
!
      INTEGER IC,INDPR,IP,J1,J2,JE,JF,JR,JS,JT,KTX,MRX,MXRX,MXRXT,MXTYM,  &
              NBLKS,NCHNL,NRXA,NRXEL,NW
      REAL RXMAX,TJ
!     ----------------------------------------------------------------

!**!  Called by ROI_UTEMWR.   Decay curve printout for each channel.

      PARAMETER (MXRXT=40)
      REAL TMS(NCHNL),RXL(MRX),RYL(MRX),BTD(MXTYM,MXRX,3),PRM(MRX),   &
           TMAX(MXRXT)
      INTEGER KRX(MXRXT),KILL(MXRXT)

      RXMAX=0.
      DO JR=1,MRX
         TMAX(JR)=0.
         DO JT=1,NCHNL
            TMAX(JR)=AMAX1(TMAX(JR),ABS(BTD(JT,JR,IC)))
         ENDDO
         RXMAX=AMAX1(RXMAX,TMAX(JR))
      ENDDO
      IF (RXMAX<1.0E-20) THEN
         IF (IC==1) WRITE (NW,'(/2A,I2)') ' NIL X (EAST) COMPONENT',      &
                           ' RESPONSE FOR THIS MODEL FOR TRANSMITTER: ',  &
                           KTX
         IF (IC==2) WRITE (NW,'(/2A,I2)') ' NIL Y (NORTH) COMPONENT',     &
                           ' RESPONSE FOR THIS MODEL FOR TRANSMITTER: ',  &
                           KTX
         IF (IC==3) WRITE (NW,'(/2A,I2)') ' NIL VERTICAL COMPONENT',      &
                           ' RESPONSE FOR THIS MODEL FOR TRANSMITTER: ',  &
                           KTX
!****************************************************************
         RETURN
!****************************************************************
      ENDIF

      NRXA=0
      NRXEL=0
      DO JR=1,MRX
         IF (TMAX(JR)>1.0E-20) THEN
            NRXA=NRXA+1
            KRX(NRXA)=JR
         ELSE
            NRXEL=NRXEL+1
            KILL(NRXEL)=JR
         ENDIF
      ENDDO

      NBLKS=NRXA/5
      IF (MOD(NRXA,5)>0) NBLKS=NBLKS+1

      DO J1=1,NBLKS
         JS=1+(J1-1)*5
         JF=JS+4
         JF=MIN0(JF,NRXA)
         WRITE (NW,1010) (RXL(J2),J2=KRX(JS),KRX(JF))
         WRITE (NW,1020) (RYL(J2),J2=KRX(JS),KRX(JF))
         WRITE (NW,'(3X)')
         DO JT=NCHNL,1,-1
            TJ=1000.*TMS(JT)
            IP=3
            IF (TJ>.9999) IP=2
            IF (TJ>9.999) IP=1
            IF (IP==1) WRITE (NW,1030) JT,TJ,  &
                (BTD(JT,JR,IC),JR=KRX(JS),KRX(JF))
            IF (IP==2) WRITE (NW,1040) JT,TJ,  &
                (BTD(JT,JR,IC),JR=KRX(JS),KRX(JF))
            IF (IP==3) WRITE (NW,1050) JT,TJ,  &
                (BTD(JT,JR,IC),JR=KRX(JS),KRX(JF))
         ENDDO
         IF (INDPR==1) WRITE (NW,1060) (PRM(JR),JR=JS,JF)
         IF (J1<NBLKS) WRITE (NW,1070)
      ENDDO

!  Report nil responses
      IF (NRXEL>0) THEN
         WRITE (NW,'(3X)')
         DO JE=1,NRXEL
            JR=KILL(JE)
            WRITE (NW,'(2A,I2,A,F6.0,A,F6.0)')  &
                   ' NIL RESPONSE FROM RECE','IVER ',JE,' AT (X,Y): ',  &
                   RXL(JR),', ',RYL(JR)
         ENDDO
      ENDIF


      RETURN

 1010 FORMAT (/7X,5F13.1)
 1020 FORMAT ('CHNL  TIME',F10.1,4F13.1)
 1030 FORMAT (I3,F8.1,5G13.4)
 1040 FORMAT (I3,F8.2,5G13.4)
 1050 FORMAT (I3,F8.3,5G13.4)
 1060 FORMAT (/'  PRIMARY: ',5G13.4)
 1070 FORMAT (76('-'))
      END
!  END OF ROI_UTWRTM

      SUBROUTINE ROI_UTWRPF (NW,MXTYM,MXRX,IC,NCHNL,TMS,MRX,RXL,RYL,RZL,   &
                         DWNHL,BTD)
!
      IMPLICIT NONE
!
      INTEGER IC,J1,J2,JB,JF,JR,JT,KRX,KRY,KRZ,MRX,MXRX,MXTYM,NBLKS,  &
              NCHNL,NW
!     ---------------------------------------------------------------

!**!  Called by ROI_UTEMWR.   Profile printout for each channel.

      REAL BTD(MXTYM,MXRX,3),RXL(MRX),RYL(MRX),RZL(MRX),TMS(NCHNL)
      LOGICAL DWNHL
      CHARACTER*7 CHN(20)
      DATA CHN/ 'CHNL  1','CHNL  2','CHNL  3','CHNL  4','CHNL  5',    &
       'CHNL  6','CHNL  7','CHNL  8','CHNL  9','CHNL 10','CHNL 11',   &
       'CHNL 12','CHNL 13','CHNL 14','CHNL 15','CHNL 16','CHNL 17',   &
       'CHNL 18','CHNL 19','CHNL 20'/

      IF (IC==1) WRITE (NW,1010)
      IF (IC==2) WRITE (NW,1020)
      IF (IC==3) WRITE (NW,1030)
      NBLKS=2
      IF (NCHNL==20) NBLKS=4

      DO J1=1,NBLKS
         JB=1+(J1-1)*5
         JF=JB+4
         JF=MIN0(JF,NCHNL)

         IF (DWNHL) THEN
            WRITE (NW,1050) (CHN(J2),J2=JB,JF)
            WRITE (NW,1070) (TMS(J2),J2=JB,JF)
         ELSE
            WRITE (NW,1040) (CHN(J2),J2=JB,JF)
            WRITE (NW,1060) (TMS(J2),J2=JB,JF)
         ENDIF
         WRITE (NW,'(3X)')
         DO JR=1,MRX
            KRX=IFIX(RXL(JR))
            KRY=IFIX(RYL(JR))
            KRZ=IFIX(RZL(JR))
            IF (DWNHL) THEN
               WRITE (NW,1090) JR,KRX,KRY,KRZ,(BTD(JT,JR,IC),JT=JB,JF)
            ELSE
               WRITE (NW,1080) JR,KRX,KRY,(BTD(JT,JR,IC),JT=JB,JF)
            ENDIF
         ENDDO
         WRITE (NW,'(3X)')
      ENDDO
      RETURN

 1010 FORMAT (8X,'X (EAST) COMPONENT IN PROFILE FORM.  CHANNEL TIMES ',  &
              'ARE IN MS'/)
 1020 FORMAT (8X,'Y (NORTH) COMPONENT IN PROFILE FORM.  CHANNEL TIMES ', &
              'ARE IN MS'/)
 1030 FORMAT (8X,'VERTICAL COMPONENT IN PROFILE FORM.  CHANNEL TIMES ',  &
              'ARE IN MS'/)
 1040 FORMAT (5X,'REC.  REC.',2X,5(A:,5X))
 1050 FORMAT (5X,'REC.  REC.  REC.',2X,5(A:,5X))
 1060 FORMAT (5X,'XPOS  YPOS',F9.2,4F12.2)
 1070 FORMAT (5X,'XPOS  YPOS  ZPOS',F9.2,4F12.2)
 1080 FORMAT (I3,2I6,5G12.4)
 1090 FORMAT (I3,3I6,5G12.4)
      END
!  END OF ROI_UTWRPF
!
      SUBROUTINE ROI_WRPLS (NW,MXTYM,MXRX,KTX,ITYM,NCHNL,MDELYT,TMSPR,MRX, &
                        RXL,RYL,RZL,CDNT,DWNHL,TITLE,LPRT,BTD,IPRF)
!
      IMPLICIT NONE
!
      INTEGER IPRF,ITYM,J,J1,J2,J3,JC,JDP,JF,JS,KMPF,KMPS,KTX,LPRT,  &
              MDELYT,MRX,MXRX,MXTYM,NBLKS,NCHNL
      INTEGER NW
!     ----------------------------------------------------------------

!  Prints out BTD (microvolts/amp) for Sirotem and user-defined impulse
!  time-domain EM systems.
!  For EM37, BTD is in nanovolts per amp per square metre.

!**!  Called by ROI_TDPULS

!   MXRX and MXTYM are the maximum dimensions for receiver and time-channel
!                  arrays respectively.
!   RXL, RYL, RZL - arrays containing the X,Y,Z locations of the receivers.
!
!      NW - output unit number
!     KTX - transmitter index.  If KTX = -1, then single receiver fixed distanced
!           Tx-Rx output in single Tx, multiple Rx format.
!    ITYM - indicates which time-domain system is to be used.
!   NCHNL - number of channels
!  MDELYT - number of Sirotem channels within the ramp turnoff.
!   TMSPR - array containing the receiver delay times in ms from top of
!           ramp for Sirotem and from bottom of ramp for EM37 and
!           user-defined systems.
!     MRX - number of receivers if KTX > 0.  Otherwise, the number of locked
!           transmitter-receiver positions.
!    IPRF - indicates profile or decay curve output
!    LPRT - field component print option.
!    CDNT - coincident loop indicator
!   DWNHL - downhole receiver indicator

      REAL BTD(MXTYM,MXRX,3),RXL(MXRX),RYL(MXRX),RZL(MXRX),TMSPR(MXTYM)
      LOGICAL CDNT, DWNHL
      CHARACTER*80 TITLE

!  Set up printout. The maximum number of receiver columns is 5.
!  Don't print out RZL if all receivers are on the surface.

      NBLKS=MRX/5
      IF (MOD(MRX,5)>0) NBLKS=NBLKS+1
      KMPS=1
      KMPF=3
      IF (CDNT) KMPS=3

      DO JC=KMPS,KMPF
         WRITE (NW,'(/2X,A/)') TITLE
         IF (LPRT==0) WRITE (NW,1010)
         IF (KTX>1) THEN
            IF (LPRT==1) WRITE (NW,1020) KTX
            IF (LPRT==2) WRITE (NW,1030) KTX
            IF (LPRT==3) WRITE (NW,1040) KTX
         ELSE
            IF (LPRT==1) WRITE (NW,1050)
            IF (LPRT==2) WRITE (NW,1060)
            IF (LPRT==3) WRITE (NW,1070)
         ENDIF
         IF (ITYM<0) THEN
            WRITE (NW,1080)
         ELSEIF (ITYM<2) THEN
            WRITE (NW,1090)
         ELSE
            WRITE (NW,1100)
         ENDIF
!*********************************************************************
!  Check to see if profile report is needed
         IF (IPRF==2) THEN
            CALL ROI_WRPLSP(NW,MXTYM,MXRX,JC,NCHNL,MDELYT,TMSPR,MRX,RXL,RYL,  &
                        RZL,DWNHL,CDNT,BTD)
!*********************************************************************
         ELSE
            IF (CDNT) THEN
               WRITE (NW,1110)
            ELSE
               IF (JC==1) WRITE (NW,1120)
               IF (JC==2) WRITE (NW,1130)
               IF (JC==3) WRITE (NW,1140)
            ENDIF

            DO J1=1,NBLKS
               IF (J1>1) WRITE (NW,'(3X)')
               JS=1+(J1-1)*5
               JF=JS+4
               JF=MIN0(JF,MRX)
               WRITE (NW,'(2X)')

               IF (DWNHL) THEN
                  WRITE (NW,'(11X,F8.0,4F13.0)') (RXL(J),J=JS,JF)
                  WRITE (NW,'(6X,A,F8.0,4F13.0)') 'DELAY',  &
                         (RYL(J),J=JS,JF)
                  WRITE (NW,'(A,F8.0,4F13.0)') 'CHNL   TIME',  &
                         (RZL(J),J=JS,JF)
                  WRITE (NW,'(2X)')
               ELSE
                  WRITE (NW,'(6X,A,F8.0,4F13.0)') 'DELAY',  &
                         (RXL(J),J=JS,JF)
                  WRITE (NW,'(A,F8.0,4F13.0)') 'CHNL   TIME',  &
                         (RYL(J),J=JS,JF)
                  WRITE (NW,'(2X)')
               ENDIF

               DO J2=1,NCHNL
                  JDP=J2+MDELYT
                  IF (TMSPR(J2)<.1) THEN
                     WRITE (NW,1180) JDP,TMSPR(J2),  &
                            (BTD(J2,J3,JC),J3=JS,JF)
                  ELSEIF (TMSPR(J2)<1.) THEN
                     WRITE (NW,1170) JDP,TMSPR(J2),  &
                            (BTD(J2,J3,JC),J3=JS,JF)
                  ELSEIF (TMSPR(J2)<10.) THEN
                     WRITE (NW,1160) JDP,TMSPR(J2),  &
                            (BTD(J2,J3,JC),J3=JS,JF)
                  ELSE
                     WRITE (NW,1150) JDP,TMSPR(J2),  &
                            (BTD(J2,J3,JC),J3=JS,JF)
                  ENDIF
               ENDDO
            ENDDO
         ENDIF
      ENDDO
      RETURN
 1010 FORMAT ('  LAYERED EARTH TIME-DOMAIN RESPONSE WITH NO 3-D',  &
              ' STRUCTURE'/)
 1020 FORMAT ('  TOTAL TIME-DOMAIN OUTPUT FOR TRANSMITTER',I3/)
 1030 FORMAT ('  SCATTERED RESPONSE (VORTEX + GALVANIC, NO 1/2 SPACE)',  &
              ' FOR TRANSMITTER',I3/)
 1040 FORMAT ('  PERCENT TARGET EFFECT (VORTEX + GALVANIC) / TOTAL',  &
              ' FOR TRANSMITTER',I3/)
 1050 FORMAT ('  TOTAL TIME-DOMAIN OUTPUT'/)
 1060 FORMAT ('  SCATTERED RESPONSE (VORTEX + GALVANIC, NO 1/2 SPACE)'/)
 1070 FORMAT ('  PERCENT TARGET EFFECT (VORTEX + GALVANIC) / TOTAL'/)
 1080 FORMAT (8X,'EM37 dB/dt CHANNELS IN NAN0-VOLTS PER AMP PER METRE',  &
              ' SQUARED'/8X,  &
              '-------------------------------------------------',  &
              '--------')
 1090 FORMAT (8X,'SIROTEM CHANNELS IN MICRO-VOLTS PER AMP'/8X,  &
              '---------------------------------------')
 1100 FORMAT (8X,'USER-DEFINED SYSTEM CHANNELS IN MICRO-VOLTS PER AMP'/8  &
              X,'---------------------------------------------------')
 1110 FORMAT (8X,'THE COINCIDENT LOOP RESPONSE IS PRINTED UNDER EACH ',  &
              'CENTRE POSITION.'/8X,'CHANNEL TIMES ARE IN MS.'/)
 1120 FORMAT (8X,'THE X (EAST) COMPONENT IS PRINTED UNDER EACH ',  &
              'RECEIVER POSITION.'/8X,'CHANNEL TIMES ARE IN MS.'/)
 1130 FORMAT (8X,'THE Y (NORTH) COMPONENT IS PRINTED UNDER EACH ',  &
              'RECEIVER POSITION.'/8X,'CHANNEL TIMES ARE IN MS.'/)
 1140 FORMAT (8X,'THE VERTICAL COMPONENT IS PRINTED UNDER EACH ',  &
              'RECEIVER POSITION.'/8X,'CHANNEL TIMES ARE IN MS.'/)
 1150 FORMAT (I3,F8.1,7G13.4)
 1160 FORMAT (I3,F8.2,7G13.4)
 1170 FORMAT (I3,F8.3,7G13.4)
 1180 FORMAT (I3,F8.4,7G13.4)
      END
!  END OF ROI_WRPLS
!
      SUBROUTINE ROI_WRPLSDH (NW,MXTYM,MXRX,KTX,ITYM,NCHNL,MDELYT,TMSPR,MRX,   &
                        RXL,RYL,RZL,RDIPL,RPHIL,CDNT,DWNHL,TITLE,LPRT,BTD,IPRF)
!
      IMPLICIT NONE
!
      INTEGER IPRF,ITYM,J,J1,J2,J3,JC,JDP,JF,JS,KMPF,KMPS,KTX,LPRT,  &
              MDELYT,MRX,MXRX,MXTYM,NBLKS,NCHNL
      INTEGER NW
!     ----------------------------------------------------------------

!  Prints out BTD (microvolts/amp) for Sirotem and user-defined impulse
!  time-domain EM systems.
!  For EM37, BTD is in nanovolts per amp per square metre.

!**!  Called by ROI_TDPULS

!   MXRX and MXTYM are the maximum dimensions for receiver and time-channel
!                  arrays respectively.
!   RXL, RYL, RZL - arrays containing the X,Y,Z locations of the receivers.
!
!      NW - output unit number
!     KTX - transmitter index.  If KTX = -1, then single receiver fixed distanced
!           Tx-Rx output in single Tx, multiple Rx format.
!    ITYM - indicates which time-domain system is to be used.
!   NCHNL - number of channels
!  MDELYT - number of Sirotem channels within the ramp turnoff.
!   TMSPR - array containing the receiver delay times in ms from top of
!           ramp for Sirotem and from bottom of ramp for EM37 and
!           user-defined systems.
!     MRX - number of receivers if KTX > 0.  Otherwise, the number of locked
!           transmitter-receiver positions.
!    IPRF - indicates profile or decay curve output
!    LPRT - field component print option.
!    CDNT - coincident loop indicator
!   DWNHL - downhole receiver indicator

      REAL BTD(MXTYM,MXRX,3),RXL(MXRX),RYL(MXRX),RZL(MXRX),TMSPR(MXTYM),  &
           RDIPL(MXRX),RPHIL(MXRX)
      LOGICAL CDNT, DWNHL
      CHARACTER*80 TITLE

!  Set up printout. The maximum number of receiver columns is 5.
!  Don't print out RZL if all receivers are on the surface.

      NBLKS=MRX/5
      IF (MOD(MRX,5)>0) NBLKS=NBLKS+1
      KMPS=1
      KMPF=3
      IF (CDNT) KMPS=3

      DO JC=KMPS,KMPF
         WRITE (NW,'(/2X,A/)') TITLE
         IF (LPRT==0) WRITE (NW,1010)
         IF (KTX>1) THEN
            IF (LPRT==1) WRITE (NW,1020) KTX
            IF (LPRT==2) WRITE (NW,1030) KTX
            IF (LPRT==3) WRITE (NW,1040) KTX
         ELSE
            IF (LPRT==1) WRITE (NW,1050)
            IF (LPRT==2) WRITE (NW,1060)
            IF (LPRT==3) WRITE (NW,1070)
         ENDIF
         IF (ITYM<0) THEN
            WRITE (NW,1080)
         ELSEIF (ITYM<2) THEN
            WRITE (NW,1090)
         ELSE
            WRITE (NW,1100)
         ENDIF
!*********************************************************************
!  Check to see if profile report is needed
         IF (IPRF==2) THEN
            CALL ROI_WRPLSPDH(NW,MXTYM,MXRX,JC,NCHNL,MDELYT,TMSPR,MRX,RXL,  &
                             RYL,RZL,RDIPL,RPHIL,DWNHL,CDNT,BTD)
!*********************************************************************
         ELSE
            IF (CDNT) THEN
               WRITE (NW,1110)
            ELSE
               IF (JC==1) WRITE (NW,1120)
               IF (JC==2) WRITE (NW,1130)
               IF (JC==3) WRITE (NW,1140)
            ENDIF

            DO J1=1,NBLKS
               IF (J1>1) WRITE (NW,'(3X)')
               JS=1+(J1-1)*5
               JF=JS+4
               JF=MIN0(JF,MRX)
               WRITE (NW,'(2X)')

               IF (DWNHL) THEN
                  WRITE (NW,'(11X,F8.0,4F13.0)') (RXL(J),J=JS,JF)
                  WRITE (NW,'(6X,A,F8.0,4F13.0)') 'DELAY',  &
                         (RYL(J),J=JS,JF)
                  WRITE (NW,'(A,F8.0,4F13.0)') 'CHNL   TIME',  &
                         (RZL(J),J=JS,JF)
                  WRITE (NW,'(11X,F8.0,4F13.0)') (RDIPL(J),J=JS,JF)
                  WRITE (NW,'(11X,F8.0,4F13.0)') (RPHIL(J),J=JS,JF)
                  WRITE (NW,'(2X)')
               ELSE
                  WRITE (NW,'(6X,A,F8.0,4F13.0)') 'DELAY',  &
                         (RXL(J),J=JS,JF)
                  WRITE (NW,'(A,F8.0,4F13.0)') 'CHNL   TIME',  &
                         (RYL(J),J=JS,JF)
                  WRITE (NW,'(2X)')
               ENDIF

               DO J2=1,NCHNL
                  JDP=J2+MDELYT
                  IF (TMSPR(J2)<.1) THEN
                     WRITE (NW,1180) JDP,TMSPR(J2),  &
                            (BTD(J2,J3,JC),J3=JS,JF)
                  ELSEIF (TMSPR(J2)<1.) THEN
                     WRITE (NW,1170) JDP,TMSPR(J2),  &
                            (BTD(J2,J3,JC),J3=JS,JF)
                  ELSEIF (TMSPR(J2)<10.) THEN
                     WRITE (NW,1160) JDP,TMSPR(J2),  &
                            (BTD(J2,J3,JC),J3=JS,JF)
                  ELSE
                     WRITE (NW,1150) JDP,TMSPR(J2),  &
                            (BTD(J2,J3,JC),J3=JS,JF)
                  ENDIF
               ENDDO
            ENDDO
         ENDIF
      ENDDO
      RETURN
 1010 FORMAT ('  LAYERED EARTH TIME-DOMAIN RESPONSE WITH NO 3-D',  &
              ' STRUCTURE'/)
 1020 FORMAT ('  TOTAL TIME-DOMAIN OUTPUT FOR TRANSMITTER',I3/)
 1030 FORMAT ('  SCATTERED RESPONSE (VORTEX + GALVANIC, NO 1/2 SPACE)',  &
              ' FOR TRANSMITTER',I3/)
 1040 FORMAT ('  PERCENT TARGET EFFECT (VORTEX + GALVANIC) / TOTAL',  &
              ' FOR TRANSMITTER',I3/)
 1050 FORMAT ('  TOTAL TIME-DOMAIN OUTPUT'/)
 1060 FORMAT ('  SCATTERED RESPONSE (VORTEX + GALVANIC, NO 1/2 SPACE)'/)
 1070 FORMAT ('  PERCENT TARGET EFFECT (VORTEX + GALVANIC) / TOTAL'/)
 1080 FORMAT (8X,'EM37 dB/dt CHANNELS IN NAN0-VOLTS PER AMP PER METRE',  &
              ' SQUARED'/8X,  &
              '-------------------------------------------------',  &
              '--------')
 1090 FORMAT (8X,'SIROTEM CHANNELS IN MICRO-VOLTS PER AMP'/8X,  &
              '---------------------------------------')
 1100 FORMAT (8X,'USER-DEFINED SYSTEM CHANNELS IN MICRO-VOLTS PER AMP'/8  &
              X,'---------------------------------------------------')
 1110 FORMAT (8X,'THE COINCIDENT LOOP RESPONSE IS PRINTED UNDER EACH ',  &
              'CENTRE POSITION.'/8X,'CHANNEL TIMES ARE IN MS.'/)
 1120 FORMAT (8X,'C1 (NORMAL COMPONENT) IS PRINTED UNDER EACH ',  &
              'RECEIVER POSITION.'/8X,'CHANNEL TIMES ARE IN MS.'/)
 1130 FORMAT (8X,'C2 (HORIZONTAL COMPONENT) IS PRINTED UNDER EACH ',  &
              'RECEIVER POSITION.'/8X,'CHANNEL TIMES ARE IN MS.'/)
 1140 FORMAT (8X,'C3 (AXIAL COMPONENT) IS PRINTED UNDER EACH ',  &
              'RECEIVER POSITION.'/8X,'CHANNEL TIMES ARE IN MS.'/)
 1150 FORMAT (I3,F8.1,7G13.4)
 1160 FORMAT (I3,F8.2,7G13.4)
 1170 FORMAT (I3,F8.3,7G13.4)
 1180 FORMAT (I3,F8.4,7G13.4)
      END
!  END OF ROI_WRPLSDH
!
      SUBROUTINE ROI_WRPLSP (NW,MXTYM,MXRX,JC,NCHNL,MDELYT,TMSPR,MRX,RXL,   &
                         RYL,RZL,DWNHL,CDNT,BTD)
!
      IMPLICIT NONE
!
      INTEGER J1,J2,JB,JC,JF,JR,JT,KRX,KRY,KRZ,MDELYT,MRX,MXRX,MXTYM,  &
              NBLKS,NCHNL,NW
!     ---------------------------------------------------------------

!  Print profile output for pulse systems.

!**!  Called by ROI_WRPLS

      REAL BTD(MXTYM,MXRX,3),RXL(MXRX),RYL(MXRX),RZL(MXRX),TMSPR(MXTYM)
      LOGICAL DWNHL,CDNT
      CHARACTER*7 CHN(40)
      DATA CHN/ 'CHNL  1','CHNL  2','CHNL  3','CHNL  4','CHNL  5',   &
       'CHNL  6','CHNL  7','CHNL  8','CHNL  9','CHNL 10','CHNL 11',   &
       'CHNL 12','CHNL 13','CHNL 14','CHNL 15','CHNL 16','CHNL 17',   &
       'CHNL 18','CHNL 19','CHNL 20','CHNL 21','CHNL 22','CHNL 23',   &
       'CHNL 24','CHNL 25','CHNL 26','CHNL 27','CHNL 28','CHNL 29',   &
       'CHNL 30','CHNL 31','CHNL 32','CHNL 33','CHNL 34','CHNL 35',   &
       'CHNL 36','CHNL 37','CHNL 38','CHNL 39','CHNL 40'/

      IF (CDNT) THEN
         WRITE (NW,1010)
      ELSE
         IF (JC==1) WRITE (NW,1020)
         IF (JC==2) WRITE (NW,1030)
         IF (JC==3) WRITE (NW,1040)
      ENDIF
      NBLKS=NCHNL/5
      IF (MOD(NCHNL,5)>0) NBLKS=NBLKS+1

      DO J1=1,NBLKS
         JB=1+(J1-1)*5
         JF=JB+4
         JF=MIN0(JF,NCHNL)

         IF (DWNHL) THEN
            WRITE (NW,1060) (CHN(J2+MDELYT),J2=JB,JF)
            WRITE (NW,1080) (TMSPR(J2+MDELYT),J2=JB,JF)
         ELSE
            WRITE (NW,1050) (CHN(J2+MDELYT),J2=JB,JF)
            WRITE (NW,1070) (TMSPR(J2+MDELYT),J2=JB,JF)
         ENDIF
         WRITE (NW,'(3X)')
         DO JR=1,MRX
            KRX=IFIX(RXL(JR))
            KRY=IFIX(RYL(JR))
            KRZ=IFIX(RZL(JR))
            IF (DWNHL) THEN
               WRITE (NW,1100) JR,KRX,KRY,KRZ,(BTD(JT,JR,JC),JT=JB,JF)
            ELSE
               WRITE (NW,1090) JR,KRX,KRY,(BTD(JT,JR,JC),JT=JB,JF)
            ENDIF
         ENDDO
         WRITE (NW,'(3X)')
      ENDDO
      RETURN

 1010 FORMAT (8X,'COINCIDENT LOOP OUTPUT IN PROFILE FORM.  CHANNEL',  &
              ' TIMES ARE IN MS'/)
 1020 FORMAT (8X,'X (EAST) COMPONENT IN PROFILE FORM.  CHANNEL TIMES ',  &
              'ARE IN MS'/)
 1030 FORMAT (8X,'Y (NORTH) COMPONENT IN PROFILE FORM.  CHANNEL TIMES ',  &
              'ARE IN MS'/)
 1040 FORMAT (8X,'VERTICAL COMPONENT IN PROFILE FORM.  CHANNEL TIMES ',  &
              'ARE IN MS'/)
 1050 FORMAT (5X,'REC.  REC.',2X,5(A:,5X))
 1060 FORMAT (5X,'REC.  REC.  REC.',2X,5(A:,5X))
 1070 FORMAT (5X,'XPOS  YPOS',F9.2,4F12.2)
 1080 FORMAT (5X,'XPOS  YPOS  ZPOS',F9.2,4F12.2)
 1090 FORMAT (I3,2I6,5G12.4)
 1100 FORMAT (I3,3I6,5G12.4)
      END
!  END OF ROI_WRPLSP
!
      SUBROUTINE ROI_WRPLSPDH (NW,MXTYM,MXRX,JC,NCHNL,MDELYT,TMSPR,MRX,RXL,   &
                         RYL,RZL,RDIPL,RPHIL,DWNHL,CDNT,BTD)
!
      IMPLICIT NONE
!
      INTEGER J1,J2,JB,JC,JF,JR,JT,KRX,KRY,KRZ,MDELYT,MRX,MXRX,MXTYM,  &
              NBLKS,NCHNL,NW,KDP,KAZ
!     ---------------------------------------------------------------

!  Print profile output for pulse systems.

!**!  Called by ROI_WRPLS

      REAL BTD(MXTYM,MXRX,3),RXL(MXRX),RYL(MXRX),RZL(MXRX),TMSPR(MXTYM), &
           RDIPL(MXRX),RPHIL(MXRX)
      LOGICAL DWNHL,CDNT
      CHARACTER*7 CHN(40)
      DATA CHN/ 'CHNL  1','CHNL  2','CHNL  3','CHNL  4','CHNL  5',   &
       'CHNL  6','CHNL  7','CHNL  8','CHNL  9','CHNL 10','CHNL 11',   &
       'CHNL 12','CHNL 13','CHNL 14','CHNL 15','CHNL 16','CHNL 17',   &
       'CHNL 18','CHNL 19','CHNL 20','CHNL 21','CHNL 22','CHNL 23',   &
       'CHNL 24','CHNL 25','CHNL 26','CHNL 27','CHNL 28','CHNL 29',   &
       'CHNL 30','CHNL 31','CHNL 32','CHNL 33','CHNL 34','CHNL 35',   &
       'CHNL 36','CHNL 37','CHNL 38','CHNL 39','CHNL 40'/

      IF (CDNT) THEN
         WRITE (NW,1010)
      ELSE
         IF (JC==1) WRITE (NW,1020)
         IF (JC==2) WRITE (NW,1030)
         IF (JC==3) WRITE (NW,1040)
      ENDIF
      NBLKS=NCHNL/5
      IF (MOD(NCHNL,5)>0) NBLKS=NBLKS+1

      DO J1=1,NBLKS
         JB=1+(J1-1)*5
         JF=JB+4
         JF=MIN0(JF,NCHNL)

         IF (DWNHL) THEN
            WRITE (NW,1060) (CHN(J2+MDELYT),J2=JB,JF)
            WRITE (NW,1080) (TMSPR(J2+MDELYT),J2=JB,JF)
         ELSE
            WRITE (NW,1050) (CHN(J2+MDELYT),J2=JB,JF)
            WRITE (NW,1070) (TMSPR(J2+MDELYT),J2=JB,JF)
         ENDIF
         WRITE (NW,'(3X)')
         DO JR=1,MRX
            KRX=IFIX(RXL(JR))
            KRY=IFIX(RYL(JR))
            KRZ=IFIX(RZL(JR))
            KDP=IFIX(RDIPL(JR))
            KAZ=IFIX(RPHIL(JR))
            IF (DWNHL) THEN
               WRITE (NW,1100) JR,KRX,KRY,KRZ,KDP,KAZ,(BTD(JT,JR,JC),JT=JB,JF)
            ELSE
               WRITE (NW,1090) JR,KRX,KRY,(BTD(JT,JR,JC),JT=JB,JF)
            ENDIF
         ENDDO
         WRITE (NW,'(3X)')
      ENDDO
      RETURN

 1010 FORMAT (8X,'COINCIDENT LOOP OUTPUT IN PROFILE FORM.  CHANNEL',  &
              ' TIMES ARE IN MS'/)
 1020 FORMAT (8X,'C1 (NORMAL COMPONENT) IN PROFILE FORM.  CHANNEL TIMES ',  &
              'ARE IN MS'/)
 1030 FORMAT (8X,'C2 (HORIZONTAL COMPONENT) IN PROFILE FORM.  CHANNEL TIMES ', &
              'ARE IN MS'/)
 1040 FORMAT (8X,'C3 (AXIAL COMPONENT) IN PROFILE FORM.  CHANNEL TIMES ',  &
              'ARE IN MS'/)
 1050 FORMAT (5X,'REC.  REC.',2X,5(A:,5X))
 1060 FORMAT (5X,'REC.  REC.  REC.  REC.  REC.',2X,5(A:,5X))
 1070 FORMAT (5X,'XPOS  YPOS',F9.2,4F12.2)
 1080 FORMAT (5X,'XPOS  YPOS  ZPOS  DIP   AZIM',F9.2,4F12.2)
 1090 FORMAT (I3,2I6,5G12.4)
 1100 FORMAT (I3,5I6,5G12.4)
      END
!  END OF ROI_WRPLSPDH
!
      SUBROUTINE ROI_WRMIRA (NA,KTX,MXTYM,MXRX,ITYM,NCHNL,MDELYT,MRX,RXL,   &
                         RYL,RZL,CDNT,DWNHL,TITLE,BTD)
!
      IMPLICIT NONE
!
      INTEGER ITYM,J,JC,JR,JT,KTX,KTXA,MDELYT,MRX,MXRX,MXTYM,NA,NCHNL
!     ----------------------------------------------------------------

!  Writes out data in AMIRA format

!**!  Called by ROI_UTEMWR, ROI_TDPULS

!       KTX - transmitter index.  If KTX = -1, then single receiver fixed
!             distanced Tx-Rx output in single Tx, multiple Rx format.
!      ITYM - EM system indicator
!     NCHNL - number of time delay channels
!    MDELYT - number of Sirotem channels before the ramp turnoff is completed
!       MRX - number of receivers for transmitter KTX.  If KTX = -1, there is
!             only one receiver but MRX becomes the number of fixed separation
!             Tx-Rx positions
!  RXL, RYL - X,Y coordinates for these receivers
!       RZL - the depth for downhole receivers
!      CDNT - true for coincident loop Tx-Rx
!     DWNHL - true if any receivers are below surface.
!       BTD - time domain response at time JT, receiver JR, component JC

      REAL BTD(MXTYM,MXRX,3),RXL(MRX),RYL(MRX),RZL(MRX)
      LOGICAL CDNT, DWNHL
      CHARACTER TITLE*80, UNITS(-3:9)*8, CHN(54)*5, F(-3:9)*1, C(0:4)*1
      DATA CHN /'  CH1','  CH2','  CH3','  CH4','  CH5','  CH6',   &
                '  CH7','  CH8','  CH9',' CH10',' CH11',' CH12',   &
                ' CH13',' CH14',' CH15',' CH16',' CH17',' CH18',   &
                ' CH19',' CH20',' CH21',' CH22',' CH23',' CH24',   &
                ' CH25',' CH26',' CH27',' CH28',' CH29',' CH30',   &
                ' CH31',' CH32',' CH33',' CH34',' CH35',' CH36',   &
                ' CH37',' CH38',' CH39',' CH40',' CH41',' CH42',   &
                ' CH43',' CH44',' CH45',' CH46',' CH47',' CH48',   &
                ' CH49',' CH50',' CH51',' CH52',' CH53',' CH54'/
      DATA F /'L','M','H','E','S','U','*','A','*','*','*','*','Y'/
      DATA C /'C','X','Y','Z','N'/
      DATA UNITS /'(nV/Am2)','(nV/Am2)','(nV/Am2)','(uV/A)  ',   &
                  '(uV/A)  ','(uV/A)  ','(******)','(uV)    ',   &
                  '(******)','(******)','(******)','(******)',   &
                  '(nT/A)  '/

      KTXA=ABS(KTX)
      IF ((KTXA==1).AND.(ITYM/=8)) WRITE (NA,'(A)') TITLE

!  Coincident loop results

      IF (CDNT) THEN
         WRITE (NA,'(2A)') 'UNITS:(uV/A)  C:C F:',F(ITYM)
         WRITE (NA,'(60A)') ' LOOP  LINE  STN  NCH',(CHN(J),J=1,NCHNL)
         WRITE (NA,'(2A)') '\\ MARCO OUTPUT - COINCIDENT LOOP ',          &
                     'SURVEY: U:= USER DEFINED;   A:=ARBITRARY WAVEFORM'
         IF (MDELYT>0) WRITE (NA,'(A,I2,2A)') '\\ THE FIRST',MDELYT,      &
             ' CHANNELS HAVE BEEN DELETED BECAUSE THEY OCCUR',            &
             ' BEFORE RAMP TURN-OFF IS COMPLETE.'

         DO JR=1,MRX
            WRITE (NA,'(I2,F9.1,A,F9.1,A,I4,54G13.4)') KTXA,RYL(JR),'N',  &
                   RXL(JR),'E',NCHNL,(BTD(JT,JR,3),JT=1,NCHNL)
         ENDDO

!  In loop results

      ELSEIF ((KTX<0).AND.(.NOT.CDNT)) THEN
         WRITE (NA,'(2A)') 'UNITS:(uV/A)   C:I  F:',F(ITYM)
         WRITE (NA,'(60A)') ' LOOP  LINE  STN C NCH',(CHN(J),J=1,NCHNL)
         WRITE (NA,'(2A)') '\\ MARCO OUTPUT - MOVING SINGLE TX-RX  ',    &
                     'SURVEY: U:= USER DEFINED;   A:=ARBITRARY WAVEFORM'
         IF (MDELYT>0) WRITE (NA,'(A,I2,2A)') '\\ THE FIRST',MDELYT,     &
             ' CHANNELS HAVE BEEN DELETED BECAUSE THEY OCCUR',           &
             ' BEFORE RAMP TURN-OFF IS COMPLETE.'

         DO JC=1,3
            DO JR=1,MRX
               WRITE (NA,'(I2,F9.1,A,F9.1,A,2X,A,I4,54G13.4)') KTXA,  &
                      RYL(JR),'N',RXL(JR),'E',C(JC),NCHNL,  &
                      (BTD(JT,JR,JC),JT=1,NCHNL)
            ENDDO
         ENDDO

!  Downhole survey results

      ELSEIF (DWNHL) THEN
         IF (KTX==1) THEN
            WRITE (NA,'(4A)') ' UNITS:',UNITS(ITYM),'   F:',F(ITYM)
            WRITE (NA,'(51A)') ' LOOP LINE STN LSIDE C NCH',  &
                   (CHN(J),J=1,NCHNL)
            WRITE (NA,'(2A)') '\\ MARCO OUTPUT - DOWNHOLE SURVEY: U:= ',  &
                   'USER DEFINED;   A:=ARBITRARY WAVEFORM;   Y:=ROI_UTEM'
            WRITE (NA,'(A)') '\\ THE LSIDE COLUMN IS FOR RECEIVER DEPTH'
         ENDIF
         IF (MDELYT>0) WRITE (NA,'(A,I2,2A)') '\\ THE FIRST',MDELYT,     &
             ' CHANNELS HAVE BEEN DELETED BECAUSE THEY OCCUR',           &
             ' BEFORE RAMP TURN-OFF IS COMPLETE.'
         DO JC=1,3
            DO JR=1,MRX
               WRITE (NA,'(I2,F9.1,A,F9.1,A,F9.1,2X,A,I4,54G13.4)') KTX, &
                      RYL(JR),'N',RXL(JR),'E',RZL(JR),C(JC),NCHNL,       &
                      (BTD(JT,JR,JC),JT=1,NCHNL)
            ENDDO
         ENDDO

!  Surface survey results

      ELSE
         IF ((KTX==1).AND.(ITYM/=8)) THEN
            WRITE (NA,'(4A)') ' UNITS:',UNITS(ITYM),'   F:',F(ITYM)
            WRITE (NA,'(51A)') ' LOOP LINE STN C NCH',(CHN(J),J=1,NCHNL)
            WRITE (NA,'(2A)') '\\ MARCO OUTPUT - SURFACE SURVEY: U:= ',  &
                   'USER DEFINED;   A:=ARBITRARY WAVEFORM;   Y:=ROI_UTEM'
         ENDIF
         IF (MDELYT>0) WRITE (NA,'(A,I2,2A)') '\\ THE FIRST',MDELYT,     &
             ' CHANNELS HAVE BEEN DELETED BECAUSE THEY OCCUR BEFORE',    &
             ' RAMP TURN-OFF IS COMPLETE.'
         IF (ITYM/=8) THEN
            DO JC=1,3
               DO JR=1,MRX
                  WRITE (NA,'(I2,F9.1,A,F9.1,A,2X,A,I4,54G13.4)') KTX,   &
                         RYL(JR),'N',RXL(JR),'E',C(JC),NCHNL,            &
                         (BTD(JT,JR,JC),JT=1,NCHNL)
               ENDDO
            ENDDO

         ELSE

!  Normalised Z component ROI_UTEM results

            IF (KTXA==1) WRITE (22,'(A)')   &
             '\\ROI_UTEM SURVEY - N MEANS THE NORMALISED VERTICAL COMPONENT'
            JC=4
            DO JR=1,MRX
               WRITE (NA,'(I2,F9.1,A,F9.1,A,2X,A,I4,54G13.4)') KTX,  &
                      RYL(JR),'N',RXL(JR),'E',C(JC),NCHNL,  &
                      (BTD(JT,JR,3),JT=1,NCHNL)
            ENDDO
         ENDIF
      ENDIF

      RETURN
      END
!END OF ROI_WRMIRA
!
      SUBROUTINE ROI_WRMIRADH (NA,KTX,MXTYM,MXRX,ITYM,NCHNL,MDELYT,MRX,RXL, &
                               RYL,RZL,RDIPL,RPHIL,CDNT,DWNHL,TITLE,BTD)
!
      IMPLICIT NONE
!
      INTEGER ITYM,J,JC,JR,JT,KTX,KTXA,MDELYT,MRX,MXRX,MXTYM,NA,NCHNL
!     ----------------------------------------------------------------

!  Writes out data in AMIRA format

!**!  Called by ROI_UTEMWR, ROI_TDPULS

!       KTX - transmitter index.  If KTX = -1, then single receiver fixed
!             distanced Tx-Rx output in single Tx, multiple Rx format.
!      ITYM - EM system indicator
!     NCHNL - number of time delay channels
!    MDELYT - number of Sirotem channels before the ramp turnoff is completed
!       MRX - number of receivers for transmitter KTX.  If KTX = -1, there is
!             only one receiver but MRX becomes the number of fixed separation
!             Tx-Rx positions
!  RXL, RYL - X,Y coordinates for these receivers
!       RZL - the depth for downhole receivers
!      CDNT - true for coincident loop Tx-Rx
!     DWNHL - true if any receivers are below surface.
!       BTD - time domain response at time JT, receiver JR, component JC

      REAL BTD(MXTYM,MXRX,3),RXL(MRX),RYL(MRX),RZL(MRX),           &
           RDIPL(MXRX),RPHIL(MXRX)
      LOGICAL CDNT, DWNHL
      CHARACTER TITLE*80, UNITS(-3:9)*8, CHN(54)*5, F(-3:9)*1, C(0:4)*2
      DATA CHN /'  CH1','  CH2','  CH3','  CH4','  CH5','  CH6',   &
                '  CH7','  CH8','  CH9',' CH10',' CH11',' CH12',   &
                ' CH13',' CH14',' CH15',' CH16',' CH17',' CH18',   &
                ' CH19',' CH20',' CH21',' CH22',' CH23',' CH24',   &
                ' CH25',' CH26',' CH27',' CH28',' CH29',' CH30',   &
                ' CH31',' CH32',' CH33',' CH34',' CH35',' CH36',   &
                ' CH37',' CH38',' CH39',' CH40',' CH41',' CH42',   &
                ' CH43',' CH44',' CH45',' CH46',' CH47',' CH48',   &
                ' CH49',' CH50',' CH51',' CH52',' CH53',' CH54'/
      DATA F /'L','M','H','E','S','U','*','A','*','*','*','*','Y'/
      DATA C /'C','C1','C2','C3','N'/
      DATA UNITS /'(nV/Am2)','(nV/Am2)','(nV/Am2)','(uV/A)  ',   &
                  '(uV/A)  ','(uV/A)  ','(******)','(uV)    ',   &
                  '(******)','(******)','(******)','(******)',   &
                  '(nT/A)  '/

      KTXA=ABS(KTX)
      IF ((KTXA==1).AND.(ITYM/=8)) WRITE (NA,'(A)') TITLE

!  Coincident loop results

      IF (CDNT) THEN
         WRITE (NA,'(2A)') 'UNITS:(uV/A)  C:C F:',F(ITYM)
         WRITE (NA,'(60A)') ' LOOP  LINE  STN  NCH',(CHN(J),J=1,NCHNL)
         WRITE (NA,'(2A)') '\\ MARCO OUTPUT - COINCIDENT LOOP ',         &
                     'SURVEY: U:= USER DEFINED;   A:=ARBITRARY WAVEFORM'
         IF (MDELYT>0) WRITE (NA,'(A,I2,2A)') '\\ THE FIRST',MDELYT,     &
             ' CHANNELS HAVE BEEN DELETED BECAUSE THEY OCCUR',           &
             ' BEFORE RAMP TURN-OFF IS COMPLETE.'

         DO JR=1,MRX
            WRITE (NA,'(I2,F9.1,A,F9.1,A,I4,54G13.4)') KTXA,RYL(JR),'N', &
                   RXL(JR),'E',NCHNL,(BTD(JT,JR,3),JT=1,NCHNL)
         ENDDO

!  In loop results

      ELSEIF ((KTX<0).AND.(.NOT.CDNT)) THEN
         WRITE (NA,'(2A)') 'UNITS:(uV/A)   C:I  F:',F(ITYM)
         WRITE (NA,'(60A)') ' LOOP  LINE  STN C NCH',(CHN(J),J=1,NCHNL)
         WRITE (NA,'(2A)') '\\ MARCO OUTPUT - MOVING SINGLE TX-RX  ',  &
                     'SURVEY: U:= USER DEFINED;   A:=ARBITRARY WAVEFORM'
         IF (MDELYT>0) WRITE (NA,'(A,I2,2A)') '\\ THE FIRST',MDELYT,   &
             ' CHANNELS HAVE BEEN DELETED BECAUSE THEY OCCUR',         &
             ' BEFORE RAMP TURN-OFF IS COMPLETE.'

         DO JC=1,3
            DO JR=1,MRX
               WRITE (NA,'(I2,F9.1,A,F9.1,A,2X,A,I4,54G13.4)') KTXA,  &
                      RYL(JR),'N',RXL(JR),'E',C(JC),NCHNL,  &
                      (BTD(JT,JR,JC),JT=1,NCHNL)
            ENDDO
         ENDDO

!  Downhole survey results

      ELSEIF (DWNHL) THEN
         IF (KTX==1) THEN
            WRITE (NA,'(4A)') ' UNITS:',UNITS(ITYM),'   F:',F(ITYM)
            WRITE (NA,'(51A)') ' LOOP LINE STN LSIDE C NCH',  &
                   (CHN(J),J=1,NCHNL)
            WRITE (NA,'(2A)') '\\ MARCO OUTPUT - DOWNHOLE SURVEY: U:= ',  &
                   'USER DEFINED;   A:=ARBITRARY WAVEFORM;   Y:=ROI_UTEM'
            WRITE (NA,'(A)') '\\ THE LSIDE COLUMN IS FOR RECEIVER DEPTH'
         ENDIF
         IF (MDELYT>0) WRITE (NA,'(A,I2,2A)') '\\ THE FIRST',MDELYT,  &
             ' CHANNELS HAVE BEEN DELETED BECAUSE THEY OCCUR',  &
             ' BEFORE RAMP TURN-OFF IS COMPLETE.'
         DO JC=1,3
            DO JR=1,MRX
!
!  -- Doesn't seem to work without using a separate format statement
!               WRITE (NA,'(I2,F9.1,A,F9.1,A,F9.1,A,F9.1,A,F9.1,A,     &
!                      2X,A,I4,54G13.4)') KTX,RYL(JR),'N',RXL(JR),'E', &
!                      RZL(JR),'Z',RDIPL(JR),'DIP',RPHIL(JR),'AZIM',    &
!                      C(JC),NCHNL,(BTD(JT,JR,JC),JT=1,NCHNL)
               WRITE (NA,1000) KTX,RYL(JR),'N',RXL(JR),'E',            &
                      RZL(JR),'Z',RDIPL(JR),'DIP',RPHIL(JR),'AZIM',    &
                      C(JC),NCHNL,(BTD(JT,JR,JC),JT=1,NCHNL)
            ENDDO
         ENDDO

!  Surface survey results

      ELSE
         IF ((KTX==1).AND.(ITYM/=8)) THEN
            WRITE (NA,'(4A)') ' UNITS:',UNITS(ITYM),'   F:',F(ITYM)
            WRITE (NA,'(51A)') ' LOOP LINE STN C NCH',(CHN(J),J=1,NCHNL)
            WRITE (NA,'(2A)') '\\ MARCO OUTPUT - SURFACE SURVEY: U:= ',  &
                   'USER DEFINED;   A:=ARBITRARY WAVEFORM;   Y:=ROI_UTEM'
         ENDIF
         IF (MDELYT>0) WRITE (NA,'(A,I2,2A)') '\\ THE FIRST',MDELYT,  &
             ' CHANNELS HAVE BEEN DELETED BECAUSE THEY OCCUR BEFORE',  &
             ' RAMP TURN-OFF IS COMPLETE.'
         IF (ITYM/=8) THEN
            DO JC=1,3
               DO JR=1,MRX
                  WRITE (NA,'(I2,F9.1,A,F9.1,A,2X,A,I4,54G13.4)') KTX,  &
                         RYL(JR),'N',RXL(JR),'E',C(JC),NCHNL,           &
                         (BTD(JT,JR,JC),JT=1,NCHNL)
               ENDDO
            ENDDO

         ELSE

!  Normalised Z component ROI_UTEM results

            IF (KTXA==1) WRITE (22,'(A)')   &
             '\\ROI_UTEM SURVEY - N MEANS THE NORMALISED VERTICAL COMPONENT'
            JC=4
            DO JR=1,MRX
               WRITE (NA,'(I2,F9.1,A,F9.1,A,2X,A,I4,54G13.4)') KTX,  &
                      RYL(JR),'N',RXL(JR),'E',C(JC),NCHNL,           &
                      (BTD(JT,JR,3),JT=1,NCHNL)
            ENDDO
         ENDIF
      ENDIF

      RETURN
 1000 FORMAT(I2,F9.1,A,F9.1,A,F9.1,A,F9.1,A,F9.1,A,2X,A,I4,54G13.4)
      END
!END OF ROI_WRMIRADH
!
      SUBROUTINE ROI_ZHSLYR (NTYRP,TRP,CNDR,THK,ICOLE,CALF,CTAU,CFREQ,NLYR,  &
                         NDGTS,CFLT,XSL,YSL,MRX,XRT,YRT,RZL,COLE,RHOMAX,BLE)
!
      IMPLICIT NONE
!
      REAL BRHO,CUBVAL,DEPTH,RHOMAX,T,TXRAD,VFAC,VFAC0,VMDFAC,XCMP,   &
           XFPMID,XSL,XTD,YCMP,YSL,YY,ZCMP,ZHSHNK,ZREL
      INTEGER IRX,JC,JDIP,JL,JR,JT,LYR,MRX,MXDGT,MXFN,MXFP,MXHNK,MXLYR,  &
              MXRX,MXTX,MXTYM,NDGTS,NDIP,NFTHX,NFTRP
      INTEGER NFTRPN,NLYR,NRTRP,NTYRP
!     ----------------------------------------------------------------

!  Computes BLE(JT,JR,JC), the layered earth dB/dt for a unit step current
!  for NTYRP values of time (JT) for MRX receivers (JR), for
!  X,Y,Z components (JC=1,2,3 respectively).  The receivers can be on the
!  surface or underground.  Thus this routine takes MRX times as long as
!  equivalent surface subroutine ROI_HSLYR because the receiver responses have
!  to be individually computed.  Note, that this routine will work for any
!  number of layers up to that specified by MXLYR.

!**!  Called by ROI_HSBOSS
!**!  Calls ROI_ZHSTRP, ZHSHNK, ROI_ZQHTKR, ROI_ZVMD, CUBVAL

!    NTYRP - number of times at which BLE is computed.
!      TRP - aray of these times in sec.
!     CNDR - product of magnetic permeability * conductivity for each layer
!      THK - thickness of each layer
!     COLE - true if complex resistivities are used
!    ICOLE - C-C layer indicator array. (0 for pure real, 1 for C-C layer)
!     CALF - complementary chargeability array; ie., CALF(I) = 1.0 - CHRG(I)
!     CTAU - array of layer relaxation times (sec).
!    CFREQ - array of layer frequency parameters.
!     NLYR - number of layers
!    NDGTS - number of terms for inverse Laplace transform
!     CFLT - coefficients for inverse Laplace transform
!      MRX - number of receivers
!   RHOMAX - maximum horizontal distance for Hankel interpolation.
!   XRT,YRT,RZL are the coordinates of the receivers
!   RHO, VTXRX,HTXRX, & NDIP, defined in ROI_SETRHO are used for integrating
!      the dipole fields around the transmitter loop.
!
!*!  OUTPUT: BLE
!*!   INPUT: all others

      PARAMETER (MXLYR=20, MXTX=400, MXHNK=200, MXFP=120, MXFN=80,        &
                 MXTYM=75, MXRX=50, MXDGT=16)
      LOGICAL COLE, NEG, HOPE, VMD
      REAL RHO(MXTX,0:MXRX),VTXRX(MXTX,0:MXRX),HTXRX(MXTX,2),TRP(MXTYM),  &
           XRT(MXRX),YRT(MXRX),RZL(MXRX),CNDR(MXLYR),THK(MXLYR),          &
           CALF(MXLYR),CTAU(MXLYR),CFREQ(MXLYR),                          &
           BLE(MXTYM,MXRX,3),XHNK(MXHNK),YHNK(4,MXHNK),XFP(MXFP),         &
           YFP(4,MXFP),XFN(MXFN),YFN(4,MXFN),XFHX(MXFP),YFHX(4,MXFP)
      INTEGER ICOLE(MXLYR)
      DOUBLE PRECISION CFLT(MXDGT)
      DATA VFAC0 /1.E-7/

!  VFAC0 = MU / (4 PI)

!  Compute receiver depths relative to top of the layer in which they are.
!  Sum over receivers and interpolation times.  First, set up electric
!  dipole integration parameters to simulate finite loop source.

      TXRAD=SQRT(XSL*YSL/3.14159)
      VMDFAC=2.*XSL*YSL*VFAC0/TXRAD
      CALL ROI_SETRHO(XSL,YSL,XRT,YRT,MRX,VTXRX,HTXRX,RHO,NDIP,COLE)

      DO JR=1,MRX
         VMD=.FALSE.
         ZREL=RZL(JR)
         LYR=0
         DEPTH=0.
         IF (RZL(JR)>0.) LYR=1
         IF (NLYR>1) THEN
            DO JL=1,NLYR-1
               DEPTH=DEPTH+THK(JL)
               IF (RZL(JR)>(DEPTH-1.0E-6)) THEN
                  LYR=JL+1
                  ZREL=RZL(JR)-DEPTH
               ENDIF
            ENDDO
         ENDIF

         XTD=20.
         XFPMID=SQRT(.1*CNDR(1)/TRP(1))
         DO JT=1,NTYRP
            T=TRP(JT)
            VFAC=VFAC0
            HOPE=.TRUE.

            DO JC=1,3
               BLE(JT,JR,JC)=0.
            ENDDO
            XCMP=0.
            YCMP=0.
            ZCMP=0.

!  Set up dipole dipole fields in t-lambda space.  For small lambda,
!  the response must be positive.  Otherwise, response = 0.

            CALL ROI_ZQHTKR(T,ZREL,LYR,CNDR,THK,ICOLE,CALF,CTAU,CFREQ,COLE,  &
                        NLYR,NDGTS,CFLT,XFP,YFP,NFTRP,XFPMID,XFN,YFN,        &
                        NFTRPN,NEG,XTD,XFHX,YFHX,NFTHX,HOPE,VMD,TXRAD)

            IF (HOPE) THEN

!  Set up interpolant for hankel transform kernel for horizontal component
!  and integrate dipole-dipole response over transmitter loop.

               DO IRX=0,1
                  IF (.NOT.VMD) THEN
                     CALL ROI_ZHSTRP(IRX,RHOMAX,XHNK,YHNK,NRTRP,XFP,YFP,     &
                        NFTRP,XFPMID,XFN,YFN,NFTRPN,NEG,LYR,NFTHX,XFHX,      &
                        YFHX)
                     IF (IRX==0) CALL ROI_ZVMD(XFP,YFP,NFTRP,XFPMID,XFN,YFN, &
                         NFTRPN,NEG,LYR,NFTHX,XFHX,YFHX,XHNK,YHNK,NRTRP,     &
                         RHO,VTXRX,NDIP,VMDFAC,VMD,TXRAD)
                  ENDIF

                  IF (VMD) THEN
                     VFAC=VMDFAC

                     BRHO=SQRT(XRT(JR)**2+YRT(JR)**2)
                     BRHO=AMAX1(BRHO,0.01)
                     YY=ZHSHNK(BRHO,IRX,VMD,XFP,YFP,NFTRP,XFPMID,XFN,  &
                        YFN,NFTRPN,NEG,LYR,NFTHX,XFHX,YFHX)

                     IF (IRX==0) THEN
                        ZCMP=YY
                     ELSE
                        XCMP=YY*ABS(XRT(JR))
                        YCMP=YY*ABS(YRT(JR))
                     ENDIF

                  ELSE
                     DO JDIP=1,NDIP
                        BRHO=RHO(JDIP,JR)
                        IF ((BRHO<XHNK(1)).OR.(BRHO>=XHNK(NRTRP))) THEN
                           YY=0.
                        ELSE
                           YY=CUBVAL(XHNK,YHNK,NRTRP,BRHO)
                        ENDIF
                        IF (IRX==0) THEN
                           ZCMP=ZCMP+YY*VTXRX(JDIP,JR)
                        ELSE
                           XCMP=XCMP+HTXRX(JDIP,1)*YY
                           YCMP=YCMP+HTXRX(JDIP,2)*YY
                        ENDIF
                     ENDDO
                  ENDIF
               ENDDO
               IF (XRT(JR)>.01) BLE(JT,JR,1)=VFAC*XCMP
               IF (XRT(JR)<-.01) BLE(JT,JR,1)=-VFAC*XCMP

               IF (YRT(JR)>.01) BLE(JT,JR,2)=VFAC*YCMP
               IF (YRT(JR)<-.01) BLE(JT,JR,2)=-VFAC*YCMP

               BLE(JT,JR,3)=VFAC*ZCMP
            ENDIF

         ENDDO
      ENDDO

      RETURN
      END
!  END OF ROI_ZHSLYR

      SUBROUTINE ROI_ZHSTRP (IRX,RHOMAX,XHNK,YHNK,NRTRP,XFP,YFP,NFTRP,   &
                             XFPMID,XFN,YFN,NFTRPN,NEG,LYR,NFTHX,XFHX,YFHX)
!
      IMPLICIT NONE
!
      REAL A,B,GS8,GSH,GSQ,GSTEP,PCT,R12,R14,R18,R34,R38,R58,R78,RHO,  &
           RHOMAX,XFPMID,Y,Y12,Y14
      REAL Y18,Y34,Y38,Y58,Y78,ZHSHNK
      INTEGER IRX,J,LYR,MXFN,MXFP,MXHNK,NFTHX,NFTRP,NFTRPN,NRTRP
!     ---------------------------------------------------------------

!**!   Called by ROI_ZHSLYR
!**!   Calls ROI_CUBSPL, ZHSHNK

!  Calculates an interpolating array, YHNK(4,J) for values of the
!  step function TEM Hankel transform for the dipole-dipole response
!  of a layered 1/2 space as a function of RHO, the separation distance.

!*!  OUTPUT: NRTRP, XHNK, YHNK
!*!   INPUT: all others

!          IRX = 0  vertical receiver (use J1 for HED source)
!              = 1  horizontal receiver (use J0 for HED source)

!       RHOMAX - maximum distance between receivers and Tx loop element.
!         XHNK - array of rho values for interpolation
!         YHNK - array of function values corresponding to XHNK
!        NRTRP - the number of interpolation points required
!
      PARAMETER (MXHNK=200, MXFP=120, MXFN=80)
      REAL XHNK(MXHNK),YHNK(4,MXHNK),XFP(MXFP),YFP(4,MXFP),XFN(MXFN),   &
           YFN(4,MXFN),XFHX(MXFP),YFHX(4,MXFP)
      LOGICAL NEG, VMD

      PCT (A,B) = ABS (A-B) - 0.25* ABS ( AMIN1 (A,B))

!  Decide whether vertical magnetic (finite) or horizontal electric dipole
!  representation is to be used.   For a horizontal electric dipole,
!  J1 (IDX = 1) is used for the vertical magnetic fields and J0 (IDX = 0)
!  is used for the horizontal magnetic fields.  For a finite vertical
!  magnetic dipole (circular loop) the opposite is true.
!  Calculate R > 0 points.  Terminate process for R > RHOMAX.
!  Advance R by 40 metres but cut intervals in half (down to a minimum
!  of 5 metres) if the drop off is more than 25 percent of value.

      VMD=.FALSE.

      GSTEP=40.
      GSH=GSTEP/2.
      GSQ=GSTEP/4.
      GS8=GSTEP/8.

      XHNK(1)=0.01
      YHNK(1,1)=ZHSHNK(XHNK(1),IRX,VMD,XFP,YFP,NFTRP,XFPMID,XFN,YFN,  &
                NFTRPN,NEG,LYR,NFTHX,XFHX,YFHX)
      NRTRP=1
      DO J=2,MXHNK
         RHO=XHNK(NRTRP)+GSTEP
         Y=ZHSHNK(RHO,IRX,VMD,XFP,YFP,NFTRP,XFPMID,XFN,YFN,NFTRPN,NEG,  &
           LYR,NFTHX,XFHX,YFHX)
         IF (PCT(YHNK(1,NRTRP),Y)>0.) THEN
            R12=RHO-GSH
            Y12=ZHSHNK(R12,IRX,VMD,XFP,YFP,NFTRP,XFPMID,XFN,YFN,NFTRPN,  &
                NEG,LYR,NFTHX,XFHX,YFHX)
            IF (PCT(YHNK(1,NRTRP),Y12)>0.) THEN
               R14=R12-GSQ
               Y14=ZHSHNK(R14,IRX,VMD,XFP,YFP,NFTRP,XFPMID,XFN,YFN,  &
                   NFTRPN,NEG,LYR,NFTHX,XFHX,YFHX)
               IF (PCT(YHNK(1,NRTRP),Y14)>0.) THEN
                  R18=R14-GS8
                  Y18=ZHSHNK(R18,IRX,VMD,XFP,YFP,NFTRP,XFPMID,XFN,YFN,  &
                      NFTRPN,NEG,LYR,NFTHX,XFHX,YFHX)
                  NRTRP=NRTRP+1
                  XHNK(NRTRP)=R18
                  YHNK(1,NRTRP)=Y18
               ENDIF

               NRTRP=NRTRP+1
               XHNK(NRTRP)=R14
               YHNK(1,NRTRP)=Y14

               IF (PCT(Y12,Y14)>0.) THEN
                  R38=R14+GS8
                  Y38=ZHSHNK(R38,IRX,VMD,XFP,YFP,NFTRP,XFPMID,XFN,YFN,  &
                      NFTRPN,NEG,LYR,NFTHX,XFHX,YFHX)
                  NRTRP=NRTRP+1
                  XHNK(NRTRP)=R38
                  YHNK(1,NRTRP)=Y38
               ENDIF
            ENDIF

            NRTRP=NRTRP+1
            XHNK(NRTRP)=R12
            YHNK(1,NRTRP)=Y12
            IF (PCT(Y12,Y)>0.) THEN
               R34=RHO-GSQ
               Y34=ZHSHNK(R34,IRX,VMD,XFP,YFP,NFTRP,XFPMID,XFN,YFN,  &
                   NFTRPN,NEG,LYR,NFTHX,XFHX,YFHX)
               IF (PCT(Y12,Y34)>0.) THEN
                  R58=R34-GS8
                  Y58=ZHSHNK(R58,IRX,VMD,XFP,YFP,NFTRP,XFPMID,XFN,YFN,  &
                      NFTRPN,NEG,LYR,NFTHX,XFHX,YFHX)
                  NRTRP=NRTRP+1
                  XHNK(NRTRP)=R58
                  YHNK(1,NRTRP)=Y58
               ENDIF
               NRTRP=NRTRP+1
               XHNK(NRTRP)=R34
               YHNK(1,NRTRP)=Y34
               IF (PCT(Y,Y34)>0.) THEN
                  R78=R34+GS8
                  Y78=ZHSHNK(R78,IRX,VMD,XFP,YFP,NFTRP,XFPMID,XFN,YFN,  &
                      NFTRPN,NEG,LYR,NFTHX,XFHX,YFHX)
                  NRTRP=NRTRP+1
                  XHNK(NRTRP)=R78
                  YHNK(1,NRTRP)=Y78
               ENDIF
            ENDIF
         ENDIF
         NRTRP=NRTRP+1
         XHNK(NRTRP)=RHO
         YHNK(1,NRTRP)=Y

         IF (XHNK(NRTRP)>=RHOMAX) THEN
            EXIT
         ENDIF

      ENDDO
      CALL ROI_CUBSPL(XHNK,YHNK,NRTRP,0,0)
      RETURN
      END
!  END OF ROI_ZHSTRP

      FUNCTION ZHSHNK (HDIST,IRX,VMD,XFP,YFP,NFTRP,XFPMID,XFN,YFN,   &
                       NFTRPN,NEG,LYR,NFTHX,XFHX,YFHX)
      REAL F,FWMAX,HDIST,HVAL,XFPBEG,XFPMID,XS,XSL,ZHSHNK
      INTEGER I,IDX,IRMAX,IRX,LYR,MXFN,MXFP,NFMAX,NFTHX,NFTRP,NFTRPN,  &
              NGVAL,NLBEG,NPVAL,NRBEG
!     ---------------------------------------------------------------

!**!   CALLED BY ROI_ZHSTRP
!**!   CALLS ROI_ZHSPVL, ROI_ZHSNVL, ROI_ZHNKHX

!  Computes the inverse Hankel transform (J0 or J1) of the function
!  Y (X * HDIST), interpolated by YFP (XFP)  and YFN (XFN)  (COLE-COLE case)
!  using filter coefficients taken from Walt Anderson's subprogram, ZHANKS.
!  It uses the fact that the inverse Laplace transform must be positive
!  for real resistivities, thus damping the effect of roundoff error.
!  It starts from the midpoint of the positive portion, XFPMID.
!
!  REF: Anderson, W.L., 1979, GEOPHYSICS, VOL 44, P. 1287-1305.
!*********************************************************************

!         HDIST - Hankel transform argument.  HDIST must be .GE. 0.
!
!           IRX = 0, compute vertical component of H
!               = 1, compute horizontal component of H
!
!       IDX = 0   computes J0 transform -  FUN(X) * J0 (HDIST*X)
!                 vertical H from VMD; horizontal H from HED
!           = 1   computes J1 transform -  FUN(X) * J1 (HDIST*X)
!                 horizontal H from VMD; vertical H from HED

      PARAMETER (MXFP=120, MXFN=80)
      REAL XFP(MXFP),YFP(4,MXFP),XFN(MXFN),YFN(4,MXFN),XFHX(MXFP),   &
           YFHX(4,MXFP)
      DOUBLE PRECISION E,ER,X1,X,XRMAX
      LOGICAL JUMP, NEG, VMD
      DATA E/1.221402758160169834D0/,ER/.818730753077981859D0/

!        E = DEXP(.2D0), ER = 1.0D0/E

!  Initialize kernel abscissa generation wrt B.
!  Start at filter weight nrbeg. total number of weights = NFMAX.

      IDX=0
      IF ((VMD).AND.(IRX==1)) IDX=1
      IF ((.NOT.VMD).AND.(IRX==0)) IDX=1

      NFMAX=283
      NPVAL=0
      NGVAL=0
      FWMAX=0.
      HVAL=0.
      NRBEG=117
      XFPBEG=EXP(XFP(5))
      X1=0.447492291194338237D-01/DBLE(HDIST)

  100 IF (X1>XFPMID) THEN
         X1=X1*ER
         NRBEG=NRBEG-1
         GOTO 100
      ENDIF

  200 IF (X1<XFPBEG) THEN
         X1=X1*E
         NRBEG=NRBEG+1
         GOTO 200
      ENDIF
      NLBEG=NRBEG-1
      X=X1

!  Begin right side convolution at weight NRBEG.  End when range is
!  exceeded or JUMP is true.  Determine which component to use.
!  If subsurface horizontal receiver section, then

      IF ((IRX==1).AND.(LYR>0)) THEN
         DO I=NRBEG,NFMAX
            X=X*E
            XS=SNGL(X)
            IF (XS>XFHX(NFTHX)) THEN
               EXIT
            ENDIF
            CALL ROI_ZHNKHX(I,XS,IDX,XFHX,YFHX,NFTHX,HVAL,FWMAX,NPVAL,JUMP)
            IRMAX=I
            XRMAX=X
            IF (JUMP) THEN
               EXIT
            ENDIF
         ENDDO

!  Continue with left-side convolution at weight NLBEG.  End when
!  jump is true and at least 10 function evaluations have occured - or
!  when the filter coefficient or XFP range has been exceeded.

         X=X1
         IF (X<XFHX(2)) THEN
            GOTO 300
         ENDIF
         DO I=NLBEG,2,-1
            XS=SNGL(X)
            CALL ROI_ZHNKHX(I,XS,IDX,XFHX,YFHX,NFTHX,HVAL,FWMAX,NPVAL,JUMP)
            X=X*ER
            IF (JUMP.AND.(NPVAL>=10)) THEN
               GOTO 300
            ENDIF
         ENDDO
      ENDIF

!  Vertical and surface receiver section

      DO I=NRBEG,NFMAX
         X=X*E
         XSL=ALOG(SNGL(X))
         IF (XSL>XFP(NFTRP)) THEN
            EXIT
         ENDIF
         CALL ROI_ZHSPVL(I,XSL,IDX,XFP,YFP,NFTRP,HVAL,FWMAX,NPVAL,JUMP)
         IRMAX=I
         XRMAX=X
         IF ((JUMP).AND.(.NOT.NEG)) THEN
            EXIT
         ENDIF
      ENDDO

!  Continue with left-side convolution at weight NLBEG.  End when
!  JUMP is true and at least 10 function evaluations have occured - or
!  when the filter coefficient or XFP range has been exceeded.

      X=X1
      XSL=ALOG(SNGL(X1))
      DO I=NLBEG,2,-1
         CALL ROI_ZHSPVL(I,XSL,IDX,XFP,YFP,NFTRP,HVAL,FWMAX,NPVAL,JUMP)
         X=X*ER
         XSL=ALOG(SNGL(X))
         IF (XSL<XFP(2)) THEN
            EXIT
         ENDIF
         IF (JUMP.AND.(NPVAL>=10)) THEN
            EXIT
         ENDIF
      ENDDO

!  Add in negative portion.

      IF (NEG) THEN
         X=XRMAX
         F=0.
         DO I=IRMAX+1,NFMAX
            X=X*E
            XS=SNGL(X)
            IF (XS>XFN(NFTRPN)) THEN
               EXIT
            ENDIF
            CALL ROI_ZHSNVL(I,XS,IDX,XFN,YFN,NFTRPN,HVAL,F,NGVAL,JUMP)
            IF (JUMP) THEN
               EXIT
            ENDIF
         ENDDO
      ENDIF

!  Convergence achieved or filter worn out

  300 ZHSHNK=HVAL/HDIST
      IF (IDX==1) ZHSHNK=ZHSHNK/HDIST

      RETURN
      END
!  END OF ZHSHNK

      SUBROUTINE ROI_ZHNKHX (I,XS,IDX,XFHX,YFHX,NFTHX,HVAL,FWMAX,NPVAL,JUMP)
!
      IMPLICIT NONE
!
      REAL AFW,AHVAL,CUBVAL,DELCOS,F,FW,FWMAX,HVAL,TMAX,TOL,WCOS,WJ0,  &
           WJ1,WS,XS
      INTEGER I,IDX,MXFP,NFTHX,NPVAL
!     ------------------------------------------------------------------

!**!  Called by ZHSHNK
!**!  Calls  CUBVAL, ROI_ZQSNTD, ROI_ZQLPTD

!  Evaluates and accumulates function calls for Hankel transformation for
!  the horizontal part of the kernel (for subsurface receivers).

!        I - filter point index
!       XS - the point at which the function interpolated by YFP (XFP)
!            is to be evaluated.
!    NFTHX - number of knots
!     HVAL - cumulative value of hankel transform process.
!    FWMAX - magnitude of largest contribution to HVAL.
!    NPVAL - number of function evaluations
!     JUMP - convergence indicator based on both maximum and accumulated
!            values.

      PARAMETER (MXFP=120)
      COMMON /FILTER/ DELCOS,WCOS(-200:99), WJ0(283), WJ1(283), WS(266)
      REAL XFHX(MXFP),YFHX(4,MXFP)
      LOGICAL JUMP
      DATA TOL /0.001/

      NPVAL=NPVAL+1
      JUMP=.FALSE.
      F=CUBVAL(XFHX,YFHX,NFTHX,XS)
      IF (IDX==0) THEN
         FW=F*WJ0(I)
      ELSE
         FW=F*WJ1(I)
      ENDIF

      HVAL=HVAL+FW
      AFW=ABS(FW)
      AHVAL=ABS(HVAL)
      FWMAX=AMAX1(AFW,FWMAX)
      TMAX=TOL*AMIN1(FWMAX,AHVAL)
      IF (AFW<TMAX) JUMP=.TRUE.
      RETURN
      END
!  END OF ROI_ZHNKHX

      SUBROUTINE ROI_ZHSPVL (I,XSL,IDX,XFP,YFP,NFTRP,HVAL,FWMAX,NPVAL,JUMP)
!
      IMPLICIT NONE
!
      REAL AFW,AHVAL,CUBVAL,DELCOS,F,FW,FWMAX,HVAL,TMAX,TOL,WCOS,WJ0,  &
           WJ1,WS,XSL
      INTEGER I,IDX,MXFP,NFTRP,NPVAL
!     -----------------------------------------------------------------

!**!  Called by ZHSHNK
!**!  Calls  CUBVAL

!  Evaluates and accumulates function calls for Hankel transformation for
!  the positive part of the kernel ( STORED IN LOG-LOG FORM).

!        I - filter point index
!      XSL - the point at which the function interpolated by YFP (XFP)
!            is to be evaluated.
!    NFTRP - number of knots
!     HVAL - cumulative value of hankel transform process.
!    FWMAX - magnitude of largest contribution to hval.
!    NPVAL - number of function evaluations
!     JUMP - convergence indicator based on both maximum and accumulated
!            values.
!      IDX = 0   computes J0 transform -  FUN(X) * J0(B*X)
!          = 1   computes J1 transform -  FUN(X) * J1(B*X)

      PARAMETER (MXFP=120)
      COMMON /FILTER/ DELCOS,WCOS(-200:99), WJ0(283), WJ1(283), WS(266)
      REAL XFP(MXFP),YFP(4,MXFP)
      LOGICAL JUMP
      DATA TOL /0.001/

      NPVAL=NPVAL+1
      JUMP=.FALSE.
      F=CUBVAL(XFP,YFP,NFTRP,XSL)
      F=EXP(F)

      IF (IDX==0) THEN
         FW=F*WJ0(I)
      ELSE
         FW=F*WJ1(I)
      ENDIF

      HVAL=HVAL+FW
      AFW=ABS(FW)
      AHVAL=ABS(HVAL)
      FWMAX=AMAX1(AFW,FWMAX)
      TMAX=TOL*AMIN1(FWMAX,AHVAL)
      IF (AFW<TMAX) JUMP=.TRUE.

      RETURN
      END
!  END OF ROI_ZHSPVL

      SUBROUTINE ROI_ZHSNVL (I,X,IDX,XFN,YFN,NFTRPN,HVAL,F,NGVAL,JUMP)
!
      IMPLICIT NONE
!
      REAL CUBVAL,DELCOS,F,FW,HVAL,OLDF,TOL,WCOS,WJ0,WJ1,WS,X
      INTEGER I,IDX,MXFN,NFTRPN,NGVAL
!     -----------------------------------------------------------------

!**!  Called by ZHSHNK
!**!  Calls  CUBVAL

!  Evaluates and accumulates function calls for Hankel transformation for
!  the negative part of the kernel.

!        I - filter point index
!        X - the point at which the function interpolated by YFN (XFN)
!            is to be evaluated.
!   NFTRPN - number of knots in yfn.
!        F - value of yfa from previous call.
!    NGVAL - number of calls to zhsnvl
!     HVAL - cumulative value of hankel transform process.
!     JUMP - convergence indicator based on both maximum and accumulated
!            values.
!      IDX = 0   computes J0 transform -  FUN(X) * J0(B*X)
!          = 1   computes J1 transform -  FUN(X) * J1(B*X)

      PARAMETER (MXFN=80)
      COMMON /FILTER/ DELCOS,WCOS(-200:99), WJ0(283), WJ1(283), WS(266)
      REAL XFN(MXFN),YFN(4,MXFN)
      LOGICAL JUMP
      DATA TOL /0.001/

      NGVAL=NGVAL+1
      JUMP=.FALSE.
      OLDF=ABS(F)
      F=CUBVAL(XFN,YFN,NFTRPN,X)

      IF (IDX==0) THEN
         FW=F*WJ0(I)
      ELSE
         FW=F*WJ1(I)
      ENDIF

      HVAL=HVAL+FW
      IF (ABS(FW)<(TOL*ABS(HVAL))) JUMP=.TRUE.
      IF ((ABS(F)>OLDF).OR.(NGVAL<4)) JUMP=.FALSE.

      RETURN
      END
!  END OF ROI_ZHSNVL

      SUBROUTINE ROI_ZQHTKR (T,ZREL,LYR,CNDR,THK,ICOLE,CALF,CTAU,CFREQ,COLE,   &
                         NLYR,NDGTS,CFLT,XFP,YFP,NFTRP,XFPMID,XFN,YFN,         &
                         NFTRPN,NEG,XTD,XFHX,YFHX,NFTHX,HOPE,VMD,TXRAD)
!
      IMPLICIT NONE
!
      REAL AYF,AYFMX,DIF,FMAX,HORIZ,QINC,QINCL,QINCN,QINCR,T,TOL,TOL0,    &
           TOLC,TXRAD,VERT,X,X0,XFPMID,XMAX,XTD
      REAL ZREL
      INTEGER J,JMAX,JMID,JMIN,JN,JQ,JSTART,JT,LONG,LYR,MXDGT,MXFN,MXFP,  &
              MXLYR,NDGTS,NFTHX,NFTRP,NFTRPN,NLYR
!     -------------------------------------------------------------------

!**!   Called by ROI_ZHSLYR
!**!   Calls ROI_CUBSPL, ROI_ZQLPTD, ROI_ZQSNTD

!*!  OUTPUT: XFP, XFN, YFP, YFN, NFTRP, NFTRPN, XFPMID, NEG, XTD,
!*!          XFHX, YFHX, NFTHX
!*!   INPUT: all others

!  Calculates values of the step response TEM Hankel transform kernel for
!  electric dipole transmitter of unit length.  For late times, a circular
!  loop approximation is more accurate than adding up HED contributions of
!  opposite sign.  BES1 is used to transform the HED spectrum to the
!  horizontal circular loop approximation
!  For real conductivity models, an inverse Laplace transform procedure
!  (ROI_ZQLPTD) is used.  The results are positive and are stored as LOGS in
!  YFP(1,J) as a function of the LOG (Hankel transform variable), XFP(J).
!  COLE-COLE models (COLE = .TRUE.) produce negatives for large XFP.
!  These are stored in YFN(1,J) as a function of XFN(J).  Splines are
!  drawn to allow interpolated values to be used.
!
!  For negatives, ROI_ZQLPTD is not sufficiently accurate so a sine transform
!  (ROI_ZQSNTD) is used.  A backtrack into the positive numbers is done until
!  the two procedures achieve the same result.  XTD is the resulting
!  crossover point for the two methods.  To avoid excessive recalculation,
!  XTD is saved because as T increases, it moves just gradually to the left.
!  ROI_ZQSNTD takes about four times longer than ROI_ZQSNTD.  NEG IS true only if
!  there is a negative PORTION.
!
!     NFTRP - number of values of XFP and YFP to be used as knots.
!             All YFP are LOGS of positive numbers.
!    NFTRPN - number of values of XFN and YFN to be used as knots.
!             All YFN are negative except the first which is the same
!             as EXP( YFP(NFTRP) )
!     NFTHX - number of values of XFHX and YFHX to be used as KNOTS.
!             When receiver is subsurface, these are used to store values
!             of the horizontal component.
!******************************************************************************

      PARAMETER (MXDGT=16, MXLYR=20, MXFP=120, MXFN=80)
      LOGICAL COLE, NEG, JUMP, HOPE, VMD
      DOUBLE PRECISION CFLT(MXDGT)
      REAL CNDR(MXLYR),THK(MXLYR),CALF(MXLYR),CTAU(MXLYR),CFREQ(MXLYR),      &
           XFP(MXFP),YFP(4,MXFP),XFN(MXFN),YFN(4,MXFN),XFHX(MXFP),YFHX(4,MXFP)
      INTEGER ICOLE(MXLYR)
      SAVE
      DATA    TOL0,   TOL,   TOLC,   QINCR, QINCL, QINCN   &
           / 1.E-25, 1.E-10, 0.005,  1.122, 0.891, 1.25/

      DO J=1,MXFP
         XFP(J)=0.
         YFP(1,J)=0.
         XFHX(J)=0.
         YFHX(1,J)=0.
         IF (J<=MXFN) THEN
            XFN(J)=0.
            YFN(1,J)=0.
         ENDIF
      ENDDO
      NEG=.FALSE.
      JSTART=60
      X0=XFPMID
      QINC=QINCR

!  Find starting abscissa X0 by requiring QLPTD > 0.  Start from midpoint
!  of positive part of previous pulse.

  100 IF ((COLE).AND.(X0>=XTD)) THEN
         CALL ROI_ZQSNTD(X0,T,ZREL,LYR,CNDR,THK,ICOLE,CALF,CTAU,CFREQ,NLYR,  &
                     VMD,TXRAD,VERT,HORIZ)
      ELSE
         CALL ROI_ZQLPTD(X0,T,ZREL,LYR,CNDR,THK,ICOLE,CALF,CTAU,CFREQ,NLYR,  &
                     NDGTS,CFLT,VMD,TXRAD,VERT,HORIZ)
      ENDIF
      IF (VERT<=1.0E-15) THEN
         IF (X0<(1.0E-4*XFPMID)) THEN
            HOPE=.FALSE.
!*****************************************
            RETURN
!*****************************************
         ELSE
            X0=0.1*X0
            GOTO 100
         ENDIF
      ENDIF

!  Calculate values to the right of X0, until response is negative.

      JMAX=JSTART
      JMIN=JSTART
      X=X0
      FMAX=VERT
      YFP(1,JSTART)=VERT
      YFHX(1,JSTART)=HORIZ
      XFP(JSTART)=X

      DO J=JSTART+1,MXFP
         X=X*QINC
         IF ((COLE).AND.(X>=XTD)) THEN
            CALL ROI_ZQSNTD(X,T,ZREL,LYR,CNDR,THK,ICOLE,CALF,CTAU,CFREQ,  &
                        NLYR,VMD,TXRAD,VERT,HORIZ)
         ELSE
            CALL ROI_ZQLPTD(X,T,ZREL,LYR,CNDR,THK,ICOLE,CALF,CTAU,CFREQ,  &
                        NLYR,NDGTS,CFLT,VMD,TXRAD,VERT,HORIZ)
         ENDIF
!**********************************************************************
         IF (VERT<TOL0) THEN
            EXIT
         ENDIF
!**********************************************************************
         FMAX=AMAX1(FMAX,VERT)
         JMAX=J
         XMAX=X
         XFP(J)=X
         YFP(1,J)=VERT
         YFHX(1,J)=HORIZ

      ENDDO

!  Calculate values to the left of X0

      X=X0
      QINC=QINCL
      DO J=JSTART-1,1,-1
         X=X*QINC
         IF ((COLE).AND.(X>=XTD)) THEN
            CALL ROI_ZQSNTD(X,T,ZREL,LYR,CNDR,THK,ICOLE,CALF,CTAU,CFREQ,  &
                        NLYR,VMD,TXRAD,VERT,HORIZ)
         ELSE
            CALL ROI_ZQLPTD(X,T,ZREL,LYR,CNDR,THK,ICOLE,CALF,CTAU,CFREQ,  &
                        NLYR,NDGTS,CFLT,VMD,TXRAD,VERT,HORIZ)
         ENDIF
!**********************************************************************
         IF ((VERT<=TOL*FMAX).OR.(X<=1.0E-15)) THEN
            EXIT
         ENDIF
         JMIN=J
         XFP(J)=X
         YFP(1,J)=VERT
         YFHX(1,J)=HORIZ
         FMAX=AMAX1(FMAX,VERT)
         IF (VERT<0.5*FMAX) QINC=0.7
         IF (VERT<0.01*FMAX) QINC=0.55
         IF (VERT<0.1E-4*FMAX) QINC=0.31
      ENDDO

!  Clean up arrays.  For non-Cole-Cole case, store LOG values, go to
!  end of program, and draw cubic spline.

      NFTRP=JMAX-JMIN+1
      IF (NFTRP<6) THEN
         HOPE=.FALSE.
!*************************************
         RETURN
!*************************************
      ENDIF
      DO J=JMIN,JMAX
         JQ=J-JMIN+1
         XFP(JQ)=XFP(J)
         YFP(1,JQ)=YFP(1,J)
         YFHX(1,JQ)=YFHX(1,J)
      ENDDO
      JMAX=NFTRP
!******************************************
      IF (COLE) THEN
!******************************************

!  For large X, the inverse sine transform is more accurate (but much
!  slower) than the inverse Laplace transform.  Backtrack for corrections
!  until the two methods agree.   If a negative occurs, then the field
!  probably hasn't penetrated.  Abandon and try a later time.

         XTD=AMIN1(XMAX,XTD)
         DO J=NFTRP,1,-1
            IF (XFP(J)<XTD) THEN
               CALL ROI_ZQSNTD(XFP(J),T,ZREL,LYR,CNDR,THK,ICOLE,CALF,CTAU,  &
                           CFREQ,NLYR,VMD,TXRAD,VERT,HORIZ)
               IF (VERT<TOL0) THEN
                  HOPE=.FALSE.
!*****************************************
                  RETURN
!*****************************************
               ENDIF

               DIF=ABS(YFP(1,J)-VERT)
               YFP(1,J)=VERT
               YFHX(1,J)=HORIZ
               XTD=XFP(J)
               IF ((VERT>0).AND.(DIF<(TOLC*VERT))) THEN
                  EXIT
               ENDIF
            ENDIF
         ENDDO

!  Now fill in the negatives.  Jump when:  negatives reach a peak and
!  then decrease by 5 orders of magnitude, or, turn positive, or, don't
!  extend past four more points.

         JUMP=.FALSE.
         QINC=QINCR
         LONG=NFTRP+4
         AYFMX=0.
         DO J=NFTRP+1,MXFP
            IF (J>LONG) QINC=QINCN
            XFP(J)=XFP(J-1)*QINC
            XFHX(J)=XFP(J)
            XMAX=XFP(JMAX)
            CALL ROI_ZQSNTD(XFP(J),T,ZREL,LYR,CNDR,THK,ICOLE,CALF,CTAU,  &
                        CFREQ,NLYR,VMD,TXRAD,VERT,HORIZ)
            YFP(1,J)=VERT
            YFHX(1,J)=HORIZ
            IF (YFP(1,J)<0) THEN
               NEG=.TRUE.
               JMAX=J
               AYF=ABS(YFP(1,J))
               AYFMX=AMAX1(AYF,AYFMX)
               IF (AYF<1.0E-4*AYFMX) JUMP=.TRUE.
            ELSEIF (NEG) THEN
               JUMP=.TRUE.
            ELSE
               JMAX=J
               IF (J>=LONG) JUMP=.TRUE.
            ENDIF
            IF (JUMP) THEN
               EXIT
            ENDIF
         ENDDO
      ENDIF

!  Make Bessel corrections.  Separate YFP into positive and negative
!  portions.  Draw spline for negative part and for LOG of positive
!  part.  Draw spline for horizontal part, YFHX.

      NFTHX=JMAX
      DO J=1,JMAX
         XFHX(J)=XFP(J)
         X=XFP(J)
         IF (YFP(1,J)>0) THEN
            XFP(J)=ALOG(X)
            YFP(1,J)=ALOG(YFP(1,J))
            NFTRP=J
         ENDIF
      ENDDO
      JMID=NFTRP/2
      XFPMID=EXP(XFP(JMID))
      CALL ROI_CUBSPL(XFP,YFP,NFTRP,0,0)
      CALL ROI_CUBSPL(XFHX,YFHX,NFTHX,0,0)

      NFTRPN=JMAX-NFTRP
      IF (NFTRPN<4) THEN
         NFTRPN=0
         NEG=.FALSE.
      ENDIF
      IF (NEG) THEN
         XFN(1)=EXP(XFP(NFTRP))
         YFN(1,1)=EXP(YFP(1,NFTRP))
         DO JN=2,NFTRPN
            JT=JN+NFTRP-1
            XFN(JN)=XFP(JT)
            YFN(1,JN)=YFP(1,JT)
         ENDDO
         CALL ROI_CUBSPL(XFN,YFN,NFTRPN,0,0)
      ENDIF

      RETURN
      END
!  END OF ROI_ZQHTKR

      SUBROUTINE ROI_ZQLPFD (P,ZREL,LYR,LMBDA,CNDR,THK,ICOLE,CALF,CTAU,   &
                         CFREQ,NLYR,VERTF,HORIZF)
!
      IMPLICIT NONE
!
      INTEGER J,J1,LYR,MXLYR,NLYR,NLYRT
      REAL ZREL
!     -----------------------------------------------------------------


!**!  CALLED BY ROI_ZQLPTD

!  Double precision computation of VERTF & HORIZF, the vertical and
!  horizontal components of the frequency-domain layered-earth response
!  kernel.

!       P - Laplace transform variable.
!     LYR - number of layer containing receiver.
!    ZREL - receiver depth relative to top of layer LYR.
!   LMBDA - Hankel transform variable
!    NLYR - number of layers
!    CNDR - scaled conductivity
!     THK - layer thicknesses
!    ICOLE - C-C layer indicator ARRAY. (0 for pure real, 1 for C-C layer)
!     CALF - complementary chargeability array; ie., CALF(I) = 1.0 - CHRG(I)
!     CTAU - array of layer relaxation times (sec).
!    CFREQ - array of layer frequency parameters.

      PARAMETER (MXLYR=20)
      REAL CNDR(MXLYR),THK(MXLYR),CALF(MXLYR),CTAU(MXLYR),CFREQ(MXLYR),  &
           LMBDA
      DOUBLE PRECISION ZERO,ONE,P,DLAM,DLAM2,QW,R0,R(MXLYR),DK(MXLYR),   &
                       ZRD,DX(MXLYR),S(MXLYR),EP(MXLYR),E(MXLYR),        &
                       F0,F(MXLYR),VERTF,HORIZF,PROJ,EXCUM,EXLYR,A,B
      INTEGER ICOLE(MXLYR)
      DATA ONE /1.0D0/, ZERO /0.0D0/

      DLAM=DBLE(LMBDA)
      DLAM2=DLAM*DLAM
      ZRD=DBLE(ZREL)
      NLYRT=NLYR
      DO J1=1,NLYR
         DK(J1)=DBLE(CNDR(J1))
         IF (ICOLE(J1)==1) THEN
            QW=(P*DBLE(CTAU(J1)))**DBLE(CFREQ(J1))
            QW=(ONE+QW)/(ONE+DBLE(CALF(J1))*QW)
            DK(J1)=QW*DK(J1)
         ENDIF
         S(J1)=DSQRT(DLAM2+DK(J1)*P)
         IF (J1<NLYR) THEN
            DX(J1)=DBLE(2.*THK(J1))
            EP(J1)=DX(J1)*S(J1)
            IF (EP(J1)>6.D1) THEN
               NLYRT=J1
               E(J1)=ZERO
               IF (LYR>NLYRT) THEN
                  VERTF=ZERO
                  HORIZF=ZERO
!*******************************************************
                  RETURN
!*******************************************************
               ENDIF
               EXIT
            ELSE
               E(J1)=DEXP(-EP(J1))
            ENDIF
         ENDIF
      ENDDO
      R0=(DLAM-S(1))/(DLAM+S(1))
      IF (NLYRT==1) THEN
         IF (ZREL<1.0E-6) THEN
            VERTF=DLAM*R0
            HORIZF=VERTF
         ELSE
            B=(ONE+R0)*DEXP(-S(1)*ZRD)
            VERTF=DLAM*B
            HORIZF=-S(1)*B
         ENDIF
!---------------
         RETURN
!---------------
      ENDIF

      DO J1=1,NLYRT-1
         R(J1)=(S(J1)-S(J1+1))/(S(J1)+S(J1+1))
      ENDDO
      F(NLYRT)=ZERO
      F(NLYRT-1)=E(NLYRT-1)*R(NLYRT-1)
      IF (NLYRT>2) THEN
         DO J=NLYRT-2,1,-1
            F(J)=E(J)*(R(J)+F(J+1))/(ONE+R(J)*F(J+1))
         ENDDO
      ENDIF
      F0=(R0+F(1))/(ONE+R0*F(1))
      IF (LYR==0) THEN
         VERTF=DLAM*F0
         HORIZF=VERTF
      ELSE
         EXCUM=ZERO
         PROJ=(ONE+R0)/(ONE+R0*F(1))
         DO J=1,LYR-1
            PROJ=PROJ*(ONE+R(J))/(ONE+R(J)*F(J+1))
            EXCUM=EXCUM+S(J)*DX(J)
         ENDDO
         EXCUM=0.5D0*EXCUM
         EXLYR=S(LYR)*ZRD
         IF ((EXCUM+EXLYR)<6.D1) THEN
            A=PROJ*DEXP(EXLYR-EXCUM)*F(LYR)
            B=PROJ*DEXP(-(EXCUM+EXLYR))
            VERTF=DLAM*(A+B)
            HORIZF=S(LYR)*(A-B)
         ELSE
            VERTF=ZERO
            HORIZF=ZERO
         ENDIF
      ENDIF

!---------------
      RETURN
!---------------
      END
!  END OF ROI_ZQLPFD

      SUBROUTINE ROI_ZQLPTD (LMBDA,T,ZREL,LYR,CNDR,THK,ICOLE,CALF,CTAU,   &
                         CFREQ,NLYR,NDGTS,CFLT,VMD,TXRAD,VERT,HORIZ)
!
      IMPLICIT NONE
!
      REAL BES1,HORIZ,T,TXRAD,VERT,XB,ZREL
      INTEGER J,LYR,MXDGT,MXLYR,NDGTS,NLYR
!     ----------------------------------------------------------------

!**!  CALLED BY ROI_ZQHTKR
!**!  CALLS ROI_ZQLPFD

!  Computes VERT, and HORIZ, the inverse Laplace transform of VERTF and
!  HORIZF respectively.  VERT & HORIZ are the vertical and horizontal
!  components of the integrand of the Hankel transform, for each value of T.

!   LMBDA - Hankel transform variable
!       T - time (for inverse Laplace transform)
!   NDGTS - size of inverse Laplace transform filter
!    CFLT - filter coefficients

!  See ROI_ZQLPFD for other definitions.

      PARAMETER (MXLYR=20, MXDGT=16)
      REAL CNDR(MXLYR),THK(MXLYR),CALF(MXLYR),CTAU(MXLYR),CFREQ(MXLYR),   &
           LMBDA
      DOUBLE PRECISION VERTF,HORIZF,CFLT(MXDGT),DQTDV,DQTDH,P,A
      INTEGER ICOLE(MXLYR)
      LOGICAL VMD

      DQTDV=0.0D+00
      DQTDH=0.0D+00
      A=DLOG(2.0D+00)/DBLE(T)
      DO J=1,NDGTS
         P=DBLE(J)*A
         CALL ROI_ZQLPFD(P,ZREL,LYR,LMBDA,CNDR,THK,ICOLE,CALF,CTAU,CFREQ,  &
                     NLYR,VERTF,HORIZF)

         DQTDV=DQTDV+CFLT(J)*VERTF
         DQTDH=DQTDH+CFLT(J)*HORIZF
      ENDDO
      VERT=SNGL(A*DQTDV)
      HORIZ=SNGL(A*DQTDH)
      IF (ABS(VERT)<1.0E-25) VERT=0.
      IF (ABS(HORIZ)<1.0E-25) HORIZ=0.
      IF (VMD) THEN
         XB=BES1(LMBDA*TXRAD)
         VERT=VERT*XB
         HORIZ=HORIZ*XB
      ENDIF
      RETURN
      END
!  END OF ROI_ZQLPTD

      SUBROUTINE ROI_ZQSNFD (W,ZREL,LYR,LMBDA,LMBSQ,CNDR,THK,ICOLE,CALF,   &
                         CTAU,CFREQ,NLYR,VERTF,HORIZF)
!
      IMPLICIT NONE
!
      REAL EXRL,F0,HORIZF,VERTF,W,ZREL
      INTEGER J,J1,JL,LYR,MXLYR,NLYR,NLYRT
!     -----------------------------------------------------------------

!**!  CALLED BY ROI_ZQSNTD

!  Computes VERTF & HORIZF, the vertical and horizontal components of the
!  imaginary parts of the frequency domain layered-earth response kernel
!  for the inverse sine transform.

!       W - frequency
!     LYR - number of layer containing receiver.
!    ZREL - receiver depth relative to top of layer LYR.
!   LMBDA - Hankel transform variable
!    NLYR - number of layers
!    CNDR - scaled conductivity
!     THK - layer thicknesses
!    ICOLE - C-C layer indicator array. (0 for pure real, 1 for C-C layer)
!     CALF - complementary chargeability array; ie., CALF(I) = 1.0 - CHRG(I)
!     CTAU - array of layer relaxation times (sec).
!    CFREQ - array of layer frequency parameters.

      PARAMETER (MXLYR=20)
      REAL CNDR(MXLYR),THK(MXLYR),CALF(MXLYR),CTAU(MXLYR),CFREQ(MXLYR),   &
           LMBDA,LMBSQ
      COMPLEX P,CNDX(MXLYR),Q,R0,R(MXLYR),S(MXLYR),E(MXLYR),F(MXLYR),   &
              EP(MXLYR),A,B,PROJ,EXCUM,EXLYR,ZERO,ONE
      INTEGER ICOLE(MXLYR)
      DATA ZERO /(0.,0.)/, ONE /(1.,0.)/

      P=CMPLX(0.0,-W)
      NLYRT=NLYR
      DO JL=1,NLYR
         CNDX(JL)=CMPLX(CNDR(JL),0.)
         IF (ICOLE(JL)==1) THEN
            Q=(P*CTAU(JL))**CFREQ(JL)
            Q=(ONE+Q)/(ONE+CALF(JL)*Q)
            CNDX(JL)=Q*CNDX(JL)
         ENDIF
         S(JL)=CSQRT(CMPLX(LMBSQ,0.)+CNDX(JL)*P)
         IF (JL<NLYR) THEN
            EP(JL)=2.*THK(JL)*S(JL)
            IF (REAL(EP(JL))>60.) THEN
               NLYRT=JL
               E(JL)=ZERO
               IF (LYR>NLYRT) THEN
                  VERTF=0.
                  HORIZF=0.
!*******************************************************
                  RETURN
!*******************************************************
               ENDIF
               EXIT
            ELSE
               E(JL)=CEXP(-EP(JL))
            ENDIF
         ENDIF
      ENDDO

      R0=(CMPLX(LMBDA,0.)-S(1))/(CMPLX(LMBDA,0.)+S(1))
      IF (NLYRT==1) THEN
         IF (ZREL<1.0E-6) THEN
            VERTF=LMBDA*AIMAG(R0)
            HORIZF=VERTF
         ELSE
            B=(ONE+R0)*CEXP(-S(1)*ZREL)
            VERTF=LMBDA*AIMAG(B)
            HORIZF=-AIMAG(S(1)*B)
         ENDIF
!-----------------------------------------------------------------
         RETURN
!-----------------------------------------------------------------
      ENDIF
      DO J1=1,NLYRT-1
         R(J1)=(S(J1)-S(J1+1))/(S(J1)+S(J1+1))
      ENDDO
      F(NLYRT)=ZERO
      F(NLYRT-1)=E(NLYRT-1)*R(NLYRT-1)
      IF (NLYRT>2) THEN
         DO J=NLYRT-2,1,-1
            F(J)=E(J)*(R(J)+F(J+1))/(ONE+R(J)*F(J+1))
         ENDDO
      ENDIF
      F0=AIMAG((R0+F(1))/(ONE+R0*F(1)))
      IF (LYR==0) THEN
         VERTF=LMBDA*F0
         HORIZF=VERTF
      ELSE
         EXCUM=ZERO
         PROJ=(ONE+R0)/(ONE+R0*F(1))
         DO J=1,LYR-1
            PROJ=PROJ*(ONE+R(J))/(ONE+R(J)*F(J+1))
            EXCUM=EXCUM+S(J)*2.*THK(J)
         ENDDO
         EXCUM=0.5*EXCUM
         EXLYR=S(LYR)*ZREL
         EXRL=REAL(EXCUM+EXLYR)
         IF (EXRL<60.) THEN
            A=PROJ*CEXP(EXLYR-EXCUM)*F(LYR)
            B=PROJ*CEXP(-(EXLYR+EXCUM))
            VERTF=LMBDA*AIMAG(A+B)
            HORIZF=AIMAG(S(LYR)*(A-B))
         ELSE
            VERTF=0.
            HORIZF=0.
         ENDIF
      ENDIF
!---------------------------
      RETURN
!---------------------------
      END
!  END OF ROI_ZQSNFD

      SUBROUTINE ROI_ZQSNTD (LMBDA,T,ZREL,LYR,CNDR,THK,ICOLE,CALF,CTAU,   &
                             CFREQ,NLYR,VMD,TXRAD,VERT,HORIZ)
!
      IMPLICIT NONE
!
      REAL BES1,DELCOS,HORIZ,HORIZF,SH,SV,T,TOL,TWOPI,TXRAD,VERT,VERTF,  &
           WCOS,WJ0,WJ1,WS,XB,ZREL
      INTEGER I,LYR,MXLYR,NFUN,NLYR
!     ----------------------------------------------------------

!**!  Called by ROI_ZQHTKR
!**!  Calls ROI_ZQSNFD

!  Calculates VERT & HORIZ, the sine transforms of the imaginary part of the
!  frequency domain layered earth impedance functions, VERTF & HORIZF, for
!  vertical and horizontal receivers.  Walt Anderson's sine transform
!  coefficients are used..

!   LMBDA - Hankel transform variable
!       T - time (for inverse sine transform)

      PARAMETER (MXLYR=20)
      REAL CNDR(MXLYR),THK(MXLYR),CALF(MXLYR),CTAU(MXLYR),CFREQ(MXLYR),   &
           LMBDA,LMBSQ
      DOUBLE PRECISION E,ER,Y1,Y,XWJ190
      INTEGER ICOLE(MXLYR)
      LOGICAL VMD
      COMMON /FILTER/ DELCOS,WCOS(-200:99), WJ0(283), WJ1(283), WS(266)
      DATA E/1.221402758160169834D0/,ER/.818730753077981859D0/
      DATA XWJ190 /0.7374499923870277002D+00/
      DATA TOL /1.0E-4/, TWOPI /0.636619772/

      LMBSQ=LMBDA*LMBDA
      VERT=0.
      HORIZ=0.
      NFUN=18
      Y1=XWJ190/DBLE(T)
      Y=Y1

      DO I=191,208
         Y=Y*E
         CALL ROI_ZQSNFD(SNGL(Y),ZREL,LYR,LMBDA,LMBSQ,CNDR,THK,ICOLE,CALF,  &
                     CTAU,CFREQ,NLYR,VERTF,HORIZF)
         VERT=VERT+WS(I)*VERTF
         HORIZ=HORIZ+WS(I)*HORIZF
      ENDDO

      DO I=209,266
         Y=Y*E
         CALL ROI_ZQSNFD(SNGL(Y),ZREL,LYR,LMBDA,LMBSQ,CNDR,THK,ICOLE,CALF,  &
                     CTAU,CFREQ,NLYR,VERTF,HORIZF)
         SV=WS(I)*VERTF
         VERT=VERT+SV
         SH=WS(I)*HORIZF
         HORIZ=HORIZ+SH
         NFUN=NFUN+1
!****************************************************************
         IF (ABS(SV)<=TOL*ABS(VERT)) THEN
            IF ((ABS(SH)<=TOL*ABS(HORIZ)).OR.  &
                (ABS(HORIZ)<1.0E-3*ABS(VERT))) THEN
               EXIT
            ENDIF
         ENDIF
!****************************************************************
      ENDDO

      Y=Y1*E
      DO I=190,1,-1
         Y=Y*ER
         CALL ROI_ZQSNFD(SNGL(Y),ZREL,LYR,LMBDA,LMBSQ,CNDR,THK,ICOLE,CALF,  &
                     CTAU,CFREQ,NLYR,VERTF,HORIZF)
         SV=WS(I)*VERTF
         VERT=VERT+SV
         SH=WS(I)*HORIZF
         HORIZ=HORIZ+SH
         NFUN=NFUN+1
!****************************************************************
         IF (ABS(SV)<=TOL*ABS(VERT)) THEN
            IF ((ABS(SH)<=TOL*ABS(HORIZ)).OR.  &
                (ABS(HORIZ)<1.0E-3*ABS(VERT))) THEN
               EXIT
            ENDIF
         ENDIF
!****************************************************************
      ENDDO

      VERT=TWOPI*VERT/T
      HORIZ=TWOPI*HORIZ/T
      IF (ABS(VERT)<1.0E-20) VERT=0.
      IF (ABS(HORIZ)<1.0E-20) HORIZ=0.

      IF (VMD) THEN
         XB=BES1(LMBDA*TXRAD)
         VERT=VERT*XB
         HORIZ=HORIZ*XB
      ENDIF

      RETURN
      END
!  END OF ROI_ZQSNTD

      SUBROUTINE ROI_ZVMD (XFP,YFP,NFTRP,XFPMID,XFN,YFN,NFTRPN,NEG,LYR,   &
                       NFTHX,XFHX,YFHX,XHNK,YHNK,NRTRP,RHO,VTXRX,NDIP,    &
                       VMDFAC,VMD,TXRAD)
!
      IMPLICIT NONE
!
      REAL BES1,BRHO,CLR,CUBVAL,ERR,TOL,TXRAD,VFAC0,VMDFAC,     &
           X,XFPMID,YY,ZCMP,ZHSHNK,ZLOOP
      INTEGER IRX,J1,J2,JDIP,LYR,MXFN,MXFP,MXHNK,MXRX,MXTX,NDIP,NFNC,  &
              NFPC,NFTHX,NFTRP,NFTRPN,NRTRP
!     -----------------------------------------------------------------

!  Compares the vertical impulse B field at the downhole receiver due to a
!  rectangular loop on the surface with that generated by a circular loop
!  with the same area.  If they are within 1 percent

!  VMD IS TRUE

!  and the fields from then on are computed as due to a CLR

!  XFP, YFP, NFTRP, XFPMID, XFN, YFN, NFTRPN, NEG, NFTHX,XFHX and YFHX
!  are all variables arising from SUBROUTINE ROI_ZQHTKR associated with the
!  vertical and horizontal components of the lambda - t spectrum.
!  The receiver is in layer LYR.

!  XHNK, YHNK, and NRTRP arise from inverse Hankel transforms performed by
!  SUBROUTINE ROI_ZHSTRP.
!  RHO, VTXRX AND NDIP are distances and coupling factors between the loop
!  (divided into NDIP segments) and a receiver.
!  Testing CLR is what this subroutine is about.

!**!  Called by ROI_ZHSLYR
!**!  Calls ROI_HEDCLR, ZHSHNK, CUBVAL

      PARAMETER (MXRX=50, MXTX=400, MXHNK=200, MXFP=120, MXFN=80)
      REAL XHNK(MXHNK),YHNK(4,MXHNK),RHO(MXTX,0:MXRX),XFP(MXFP),          &
           YFP(4,MXFP),XFN(MXFN),YFN(4,MXFN),YFPC(4,MXFP),YFNC(4,MXFN),   &
           VTXRX(MXTX,0:MXRX),XFHX(MXFP),YFHX(4,MXFP)
      LOGICAL VMD, VMDT, NEG, NEGC, CDNT, MAYBE
      DATA VFAC0 /1.E-7/, TOL /.001/, VMDT /.TRUE./

!  VFAC0 = MU / (4 PI);  VMDFAC = 2. * TXAREA * VFAC0 / TXRAD

      CDNT=.FALSE.
      VMD=.FALSE.
      BRHO=0.1
      IRX=0

!  Set ROI_ZQHTKR CLR representation YFPC and YFNC from ROI_ZQHTKR HED
!  representation YFP and YFN.
!  If MAYBE is false, VMD is false so leave already.

      CALL ROI_HEDCLR(XFP,YFP,NFTRP,XFN,YFN,NFTRPN,YFPC,NFPC,YFNC,NFNC,  &
                  TXRAD,CDNT,MAYBE,NEGC)
      IF (MAYBE) THEN

         CLR=VMDFAC*ZHSHNK(BRHO,IRX,VMDT,XFP,YFPC,NFPC,XFPMID,XFN,YFNC,  &
             NFNC,NEG,LYR,NFTHX,XFHX,YFHX)
         ZCMP=0.
         DO JDIP=1,NDIP
            BRHO=RHO(JDIP,0)
            IF (BRHO<XHNK(1)) BRHO=XHNK(1)
            IF (BRHO<=XHNK(NRTRP)) THEN
               YY=CUBVAL(XHNK,YHNK,NRTRP,BRHO)
            ELSE
               YY=0.
            ENDIF
            ZCMP=ZCMP+VTXRX(JDIP,0)*YY
         ENDDO

         ZLOOP=VFAC0*ZCMP
         ERR=ABS(ZLOOP-CLR)-(TOL*CLR)

!  If the loop response is within 1 percent of the CLR response, then
!  the CLR representation will be used back in ROI_HSLYR.
!  Thus, YFP must be reset to YDP and YFHX must be converted to dipole form.

         IF (ERR<0.) THEN
            VMD=.TRUE.
            NEG=NEGC
            NFTRP=NFPC
            NFTRPN=NFNC
            DO J1=1,NFPC
               DO J2=1,4
                  YFP(J2,J1)=YFPC(J2,J1)
               ENDDO
            ENDDO
            DO J1=1,NFTHX
               X=TXRAD*XFHX(J1)
               YFHX(1,J1)=YFHX(1,J1)*BES1(X)
            ENDDO
            CALL ROI_CUBSPL(XFHX,YFHX,NFTHX,0,0)

            IF (NFTRPN>4) THEN
               DO J1=1,NFNC
                  DO J2=1,4
                     YFN(J2,J1)=YFNC(J2,J1)
                  ENDDO
               ENDDO
            ENDIF
         ENDIF
      ENDIF

      RETURN
      END
!  END OF ROI_ZVMD

!****************!  BLOCK  ********************************************

      BLOCK DATA
      REAL DELCOS,WCOS,WJ0,WJ1,WS
      INTEGER J,L
!     ----------
!  Filter coefficients to compute J0 & J1 inverse Hankel, NC cosine,
!  and Anderson sine transforms.

      COMMON /FILTER/ DELCOS,WCOS(-200:99), WJ0(283), WJ1(283), WS(266)

!  Niels Christensen shifted cosine filter:
!  12 points per decade, OMEGA = .3 PI

      DATA DELCOS /.00632173 /
      DATA (WCOS (L), L =-200,-156)/   &
       3.27764748749E-18, 3.97096058632E-18, 4.81092858166E-18,   &
       5.82857304036E-18, 7.06147744874E-18, 8.55517523993E-18,   &
       1.03648314276E-17, 1.25572799515E-17, 1.52134919784E-17,   &
       1.84315663162E-17, 2.23303523839E-17, 2.70538395400E-17,   &
       3.27764748749E-17, 3.97096058632E-17, 4.81092858166E-17,   &
       5.82857304036E-17, 7.06147744874E-17, 8.55517523993E-17,   &
       1.03648314276E-16, 1.25572799515E-16, 1.52134919784E-16,   &
       1.84315663162E-16, 2.23303523839E-16, 2.70538395400E-16,   &
       3.27764748749E-16, 3.97096058632E-16, 4.81092858166E-16,   &
       5.82857304036E-16, 7.06147744874E-16, 8.55517523993E-16,   &
       1.03648314276E-15, 1.25572799515E-15, 1.52134919784E-15,   &
       1.84315663162E-15, 2.23303523839E-15, 2.70538395400E-15,   &
       3.27764748749E-15, 3.97096058632E-15, 4.81092858166E-15,   &
       5.82857304036E-15, 7.06147744874E-15, 8.55517523993E-15,   &
       1.03648314276E-14, 1.25572799515E-14, 1.52134919784E-14/
      DATA (WCOS (L), L =-155,-111)/   &
       1.84315663162E-14, 2.23303523839E-14, 2.70538395400E-14,   &
       3.27764748749E-14, 3.97096058632E-14, 4.81092858166E-14,   &
       5.82857304036E-14, 7.06147744874E-14, 8.55517523993E-14,   &
       1.03648314276E-13, 1.25572799515E-13, 1.52134919784E-13,   &
       1.84315663162E-13, 2.23303523839E-13, 2.70538395400E-13,   &
       3.27764748749E-13, 3.97096058632E-13, 4.81092858166E-13,   &
       5.82857304036E-13, 7.06147744874E-13, 8.55517523993E-13,   &
       1.03648314276E-12, 1.25572799515E-12, 1.52134919784E-12,   &
       1.84315663162E-12, 2.23303523839E-12, 2.70538395400E-12,   &
       3.27764748749E-12, 3.97096058632E-12, 4.81092858166E-12,   &
       5.82857304036E-12, 7.06147744874E-12, 8.55517523993E-12,   &
       1.03648314276E-11, 1.25572799515E-11, 1.52134919784E-11,   &
       1.84315663162E-11, 2.23303523839E-11, 2.70538395400E-11,   &
       3.27764748749E-11, 3.97096058632E-11, 4.81092858166E-11,   &
       5.82857304036E-11, 7.06147744874E-11, 8.55517523993E-11/
      DATA (WCOS (L), L =-110,-66)/   &
       1.03648314276E-10, 1.25572799515E-10, 1.52134919784E-10,   &
       1.84315663162E-10, 2.23303523839E-10, 2.70538395400E-10,   &
       3.27764748749E-10, 3.97096058632E-10, 4.81092858166E-10,   &
       5.82857304036E-10, 7.06147744874E-10, 8.55517523993E-10,   &
       1.03648314276E-09, 1.25572799515E-09, 1.52134919784E-09,   &
       1.84315663162E-09, 2.23303523839E-09, 2.70538395400E-09,   &
       3.27764748749E-09, 3.97096058632E-09, 4.81092858166E-09,   &
       5.82857304036E-09, 7.06147744874E-09, 8.55517523993E-09,   &
       1.03648314276E-08, 1.25572799515E-08, 1.52134919784E-08,   &
       1.84315663162E-08, 2.23303523839E-08, 2.70538395400E-08,   &
       3.27764748749E-08, 3.97096058632E-08, 4.81092858166E-08,   &
       5.82857304036E-08, 7.06147744874E-08, 8.55517523992E-08,   &
       1.03648314276E-07, 1.25572799515E-07, 1.52134919784E-07,   &
       1.84315663162E-07, 2.23303523839E-07, 2.70538395400E-07,   &
       3.27764748748E-07, 3.97096058631E-07, 4.81092858163E-07/
      DATA (WCOS (L), L =-65,-21)/   &
       5.82857304032E-07, 7.06147744866E-07, 8.55517523979E-07,   &
       1.03648314273E-06, 1.25572799511E-06, 1.52134919777E-06,   &
       1.84315663149E-06, 2.23303523815E-06, 2.70538395358E-06,   &
       3.27764748674E-06, 3.97096058499E-06, 4.81092857928E-06,   &
       5.82857303614E-06, 7.06147744122E-06, 8.55517522657E-06,   &
       1.03648314038E-05, 1.25572799093E-05, 1.52134919033E-05,   &
       1.84315661826E-05, 2.23303521464E-05, 2.70538391177E-05,   &
       3.27764741237E-05, 3.97096045276E-05, 4.81092834413E-05,   &
       5.82857261799E-05, 7.06147669760E-05, 8.55517390427E-05,   &
       1.03648290523E-04, 1.25572757278E-04, 1.52134844670E-04,   &
       1.84315529598E-04, 2.23303286305E-04, 2.70537973035E-04,   &
       3.27763997594E-04, 3.97094723005E-04, 4.81090482791E-04,   &
       5.82853080445E-04, 7.06140233231E-04, 8.55504167951E-04,   &
       1.03645938870E-03, 1.25568576016E-03, 1.52127408052E-03,   &
       1.84302307509E-03, 2.23279769616E-03, 2.70496162210E-03/
      DATA (WCOS (L), L =-20,24)/   &
       3.27689631886E-03, 3.96962511374E-03, 4.80855324839E-03,   &
       5.82435024343E-03, 7.05396657593E-03, 8.54182367870E-03,   &
       1.03410843805E-02, 1.25150721296E-02, 1.51384287367E-02,   &
       1.82981828574E-02, 2.20932012652E-02, 2.66326428704E-02,   &
       3.20280504750E-02, 3.83817031757E-02, 4.57529090015E-02,   &
       5.41138165506E-02, 6.32336060872E-02, 7.25429239280E-02,   &
       8.07814005943E-02, 8.56648215301E-02, 8.29754131995E-02,   &
       6.61728839009E-02, 2.49099879313E-02,-5.25662370332E-02,   &
      -1.77257695902E-01,-3.38275600250E-01,-4.82415902998E-01,   &
      -4.55992280486E-01,-7.52812327135E-02, 6.65970979261E-01,   &
       8.99170503986E-01,-3.96592370781E-01,-1.38198747238E+00,   &
       1.66395693227E+00,-9.30334922154E-01, 3.30012032268E-01,   &
      -8.19311720454E-02, 1.48662188728E-02,-2.13960121462E-03,   &
       2.89777944084E-04,-4.10252655190E-05, 5.96303531789E-06,   &
      -8.72916816254E-07, 1.28031659199E-07,-1.87886052472E-08/
      DATA (WCOS (L), L =25,69)/   &
       2.75763186999E-09,-4.04758530392E-10, 5.94101668614E-11,   &
      -8.72020580969E-12, 1.27995006152E-12,-1.87869546474E-13,   &
       2.75750390141E-14,-4.04729332639E-15, 5.94004630834E-16,   &
      -8.70764639675E-17, 1.27459963186E-17,-1.82944370627E-18,   &
       2.67836880337E-19,-3.04833935943E-20, 1.64313000801E-21,   &
       3.01142825752E-21,-5.21478596825E-22, 1.37002813677E-21,   &
      -6.52797182652E-22, 1.40079856288E-22,-1.40667671784E-22,   &
       1.70033730143E-23,-2.74453364807E-23, 2.41787117103E-23,   &
      -1.78716987481E-23, 4.99883433782E-24,-4.06084044984E-24,   &
       2.89670334941E-24,-8.77965537372E-25, 1.21194987045E-25,   &
      -1.74181776862E-25, 1.50307641169E-25,-1.09826064382E-25,   &
       3.14586965779E-26,-2.51308231025E-26, 1.77594485992E-26,   &
      -1.17543940755E-26, 8.42024121640E-28,-1.10510759608E-27,   &
       9.31619291992E-28,-6.75339996352E-28, 1.97531071217E-28,   &
      -1.55371775135E-28, 1.08953022579E-28,-7.17780762223E-29/
      DATA (WCOS (L), L =70,99)/   &
       2.55398099963E-29,-6.99012347840E-30, 5.76787420019E-30,   &
      -4.15016624873E-30, 1.23507827864E-30,-9.59703688264E-31,   &
       6.68070421281E-31,-4.37770918800E-31, 1.57257106203E-31,   &
      -1.06708053061E-31, 3.57322505765E-32,-2.54887457918E-32,   &
       7.72541668811E-33,-5.92277283725E-33, 4.09438835539E-33,   &
      -1.32259081936E-33, 1.67919911757E-33,-2.76812163102E-34,   &
       2.21131777864E-34, 5.28010221339E-35, 1.03429563330E-34,   &
      -7.40916006860E-36, 9.72409086858E-36,-8.19752817047E-36,   &
      -2.58911797964E-36,-3.98829026336E-36, 1.78104494324E-37,   &
      -3.32579083872E-37, 3.00732538418E-37,-2.24730545742E-37/

!  J0 Bessel filter
!  ----------------

      DATA   &
      WJ0(  1) / 2.1969100E-11/,  WJ0(  2) / 4.1201162E-09/,   &
      WJ0(  3) /-6.1322978E-09/,  WJ0(  4) / 7.2479289E-09/,   &
      WJ0(  5) /-7.9821625E-09/,  WJ0(  6) / 8.5778984E-09/,   &
      WJ0(  7) /-9.1157295E-09/,  WJ0(  8) / 9.6615249E-09/,   &
      WJ0(  9) /-1.0207546E-08/,  WJ0( 10) / 1.0796633E-08/,   &
      WJ0( 11) /-1.1393033E-08/,  WJ0( 12) / 1.2049873E-08/,   &
      WJ0( 13) /-1.2708789E-08/,  WJ0( 14) / 1.3446466E-08/,   &
      WJ0( 15) /-1.4174300E-08/,  WJ0( 16) / 1.5005577E-08/,   &
      WJ0( 17) /-1.5807160E-08/,  WJ0( 18) / 1.6747135E-08/,   &
      WJ0( 19) /-1.7625961E-08/,  WJ0( 20) / 1.8693427E-08/,   &
      WJ0( 21) /-1.9650839E-08/,  WJ0( 22) / 2.0869789E-08/,   &
      WJ0( 23) /-2.1903555E-08/,  WJ0( 24) / 2.3305308E-08/,   &
      WJ0( 25) /-2.4407377E-08/,  WJ0( 26) / 2.6033678E-08/,   &
      WJ0( 27) /-2.7186774E-08/,  WJ0( 28) / 2.9094334E-08/,   &
      WJ0( 29) /-3.0266804E-08/,  WJ0( 30) / 3.2534015E-08/,   &
      WJ0( 31) /-3.3672073E-08/,  WJ0( 32) / 3.6408935E-08/,   &
      WJ0( 33) /-3.7425021E-08/,  WJ0( 34) / 4.0787921E-08/,   &
      WJ0( 35) /-4.1543242E-08/,  WJ0( 36) / 4.5756842E-08/,   &
      WJ0( 37) /-4.6035233E-08/,  WJ0( 38) / 5.1425076E-08/
      DATA   &
      WJ0( 39) /-5.0893895E-08/,  WJ0( 40) / 5.7934898E-08/,   &
      WJ0( 41) /-5.6086570E-08/,  WJ0( 42) / 6.5475248E-08/,   &
      WJ0( 43) /-6.1539914E-08/,  WJ0( 44) / 7.4301994E-08/,   &
      WJ0( 45) /-6.7117043E-08/,  WJ0( 46) / 8.4767834E-08/,   &
      WJ0( 47) /-7.2583120E-08/,  WJ0( 48) / 9.7366566E-08/,   &
      WJ0( 49) /-7.7553608E-08/,  WJ0( 50) / 1.1279873E-07/,   &
      WJ0( 51) /-8.1416722E-08/,  WJ0( 52) / 1.3206915E-07/,   &
      WJ0( 53) /-8.3217216E-08/,  WJ0( 54) / 1.5663186E-07/,   &
      WJ0( 55) /-8.1482582E-08/,  WJ0( 56) / 1.8860592E-07/,   &
      WJ0( 57) /-7.3963143E-08/,  WJ0( 58) / 2.3109673E-07/,   &
      WJ0( 59) /-5.7243707E-08/,  WJ0( 60) / 2.8867453E-07/,   &
      WJ0( 61) /-2.6163525E-08/,  WJ0( 62) / 3.6808774E-07/,   &
      WJ0( 63) / 2.7049872E-08/,  WJ0( 64) / 4.7932616E-07/,   &
      WJ0( 65) / 1.1407365E-07/,  WJ0( 66) / 6.3720626E-07/,   &
      WJ0( 67) / 2.5241960E-07/,  WJ0( 68) / 8.6373490E-07/,   &
      WJ0( 69) / 4.6831434E-07/,  WJ0( 70) / 1.1916346E-06/,   &
      WJ0( 71) / 8.0099716E-07/,  WJ0( 72) / 1.6696015E-06/,   &
      WJ0( 73) / 1.3091334E-06/,  WJ0( 74) / 2.3701475E-06/,   &
      WJ0( 75) / 2.0803830E-06/,  WJ0( 76) / 3.4012978E-06/
      DATA   &
      WJ0( 77) / 3.2456774E-06/,  WJ0( 78) / 4.9240402E-06/,   &
      WJ0( 79) / 5.0005196E-06/,  WJ0( 80) / 7.1783538E-06/,   &
      WJ0( 81) / 7.6367633E-06/,  WJ0( 82) / 1.0522038E-05/,   &
      WJ0( 83) / 1.1590021E-05/,  WJ0( 84) / 1.5488635E-05/,   &
      WJ0( 85) / 1.7510398E-05/,  WJ0( 86) / 2.2873835E-05/,   &
      WJ0( 87) / 2.6368007E-05/,  WJ0( 88) / 3.3864388E-05/,   &
      WJ0( 89) / 3.9610390E-05/,  WJ0( 90) / 5.0230377E-05/,   &
      WJ0( 91) / 5.9397375E-05/,  WJ0( 92) / 7.4612122E-05/,   &
      WJ0( 93) / 8.8951412E-05/,  WJ0( 94) / 1.1094809E-04/,   &
      WJ0( 95) / 1.3308026E-04/,  WJ0( 96) / 1.6511335E-04/,   &
      WJ0( 97) / 1.9895671E-04/,  WJ0( 98) / 2.4587195E-04/,   &
      WJ0( 99) / 2.9728180E-04/,  WJ0(100) / 3.6629770E-04/,   &
      WJ0(101) / 4.4402012E-04/,  WJ0(102) / 5.4589362E-04/,   &
      WJ0(103) / 6.6298834E-04/,  WJ0(104) / 8.1375346E-04/,   &
      WJ0(105) / 9.8971627E-04/,  WJ0(106) / 1.2132772E-03/,   &
      WJ0(107) / 1.4772052E-03/,  WJ0(108) / 1.8092023E-03/,   &
      WJ0(109) / 2.2045122E-03/,  WJ0(110) / 2.6980811E-03/,   &
      WJ0(111) / 3.2895354E-03/,  WJ0(112) / 4.0238765E-03/,   &
      WJ0(113) / 4.9080201E-03/,  WJ0(114) / 6.0010999E-03/
      DATA   &
      WJ0(115) / 7.3216879E-03/,  WJ0(116) / 8.9489222E-03/,   &
      WJ0(117) / 1.0919448E-02/,  WJ0(118) / 1.3340696E-02/,   &
      WJ0(119) / 1.6276399E-02/,  WJ0(120) / 1.9873312E-02/,   &
      WJ0(121) / 2.4233626E-02/,  WJ0(122) / 2.9555699E-02/,   &
      WJ0(123) / 3.5990071E-02/,  WJ0(124) / 4.3791529E-02/,   &
      WJ0(125) / 5.3150319E-02/,  WJ0(126) / 6.4341374E-02/,   &
      WJ0(127) / 7.7506721E-02/,  WJ0(128) / 9.2749991E-02/,   &
      WJ0(129) / 1.0980561E-01/,  WJ0(130) / 1.2791555E-01/,   &
      WJ0(131) / 1.4525829E-01/,  WJ0(132) / 1.5820085E-01/,   &
      WJ0(133) / 1.6058576E-01/,  WJ0(134) / 1.4196084E-01/,   &
      WJ0(135) / 8.9781225E-02/,  WJ0(136) /-1.0238278E-02/,   &
      WJ0(137) /-1.5083434E-01/,  WJ0(138) /-2.9059574E-01/,   &
      WJ0(139) /-2.9105437E-01/,  WJ0(140) /-3.7973244E-02/,   &
      WJ0(141) / 3.8273716E-01/,  WJ0(142) / 2.2014119E-01/,   &
      WJ0(143) /-4.7342634E-01/,  WJ0(144) / 1.9331133E-01/,   &
      WJ0(145) / 5.3839527E-02/,  WJ0(146) /-1.1909845E-01/,   &
      WJ0(147) / 9.9317051E-02/,  WJ0(148) /-6.6152625E-02/,   &
      WJ0(149) / 4.0703241E-02/,  WJ0(150) /-2.4358315E-02/,   &
      WJ0(151) / 1.4476533E-02/,  WJ0(152) /-8.6198067E-03/
      DATA   &
      WJ0(153) / 5.1597054E-03/,  WJ0(154) /-3.1074602E-03/,   &
      WJ0(155) / 1.8822342E-03/,  WJ0(156) /-1.1456545E-03/,   &
      WJ0(157) / 7.0004346E-04/,  WJ0(158) /-4.2904227E-04/,   &
      WJ0(159) / 2.6354444E-04/,  WJ0(160) /-1.6215439E-04/,   &
      WJ0(161) / 9.9891280E-05/,  WJ0(162) /-6.1589039E-05/,   &
      WJ0(163) / 3.7996921E-05/,  WJ0(164) /-2.3452250E-05/,   &
      WJ0(165) / 1.4479572E-05/,  WJ0(166) /-8.9417426E-06/,   &
      WJ0(167) / 5.5227520E-06/,  WJ0(168) /-3.4114253E-06/,   &
      WJ0(169) / 2.1074102E-06/,  WJ0(170) /-1.3019229E-06/,   &
      WJ0(171) / 8.0433620E-07/,  WJ0(172) /-4.9693682E-07/,   &
      WJ0(173) / 3.0702418E-07/,  WJ0(174) /-1.8969219E-07/,   &
      WJ0(175) / 1.1720069E-07/,  WJ0(176) /-7.2412497E-08/,   &
      WJ0(177) / 4.4740283E-08/,  WJ0(178) /-2.7643004E-08/,   &
      WJ0(179) / 1.7079403E-08/,  WJ0(180) /-1.0552634E-08/,   &
      WJ0(181) / 6.5200312E-09/,  WJ0(182) /-4.0284598E-09/,   &
      WJ0(183) / 2.4890232E-09/,  WJ0(184) /-1.5378695E-09/,   &
      WJ0(185) / 9.5019037E-10/,  WJ0(186) /-5.8708693E-10/,   &
      WJ0(187) / 3.6273937E-10/,  WJ0(188) /-2.2412348E-10/,   &
      WJ0(189) / 1.3847792E-10/,  WJ0(190) /-8.5560822E-11/
      DATA   &
      WJ0(191) / 5.2865472E-11/,  WJ0(192) /-3.2664392E-11/,   &
      WJ0(193) / 2.0182947E-11/,  WJ0(194) /-1.2470979E-11/,   &
      WJ0(195) / 7.7057674E-12/,  WJ0(196) /-4.7611715E-12/,   &
      WJ0(197) / 2.9415274E-12/,  WJ0(198) /-1.8170081E-12/,   &
      WJ0(199) / 1.1221034E-12/,  WJ0(200) /-6.9271065E-13/,   &
      WJ0(201) / 4.2739743E-13/,  WJ0(202) /-2.6344389E-13/,   &
      WJ0(203) / 1.6197105E-13/,  WJ0(204) /-9.9147443E-14/,   &
      WJ0(205) / 6.0487998E-14/,  WJ0(206) /-3.6973097E-14/,   &
      WJ0(207) / 2.2817965E-14/,  WJ0(208) /-1.4315546E-14/,   &
      WJ0(209) / 9.1574731E-15/,  WJ0(210) /-5.9567236E-15/,   &
      WJ0(211) / 3.9209968E-15/,  WJ0(212) /-2.5911739E-15/,   &
      WJ0(213) / 1.6406939E-15/,  WJ0(214) /-8.8248588E-16/,   &
      WJ0(215) / 3.0195409E-16/,  WJ0(216) / 2.2622634E-17/,   &
      WJ0(217) /-8.0942554E-17/,  WJ0(218) /-3.7172362E-17/,   &
      WJ0(219) / 1.9299542E-16/,  WJ0(220) /-3.3388159E-16/,   &
      WJ0(221) / 4.6174116E-16/,  WJ0(222) /-5.8627359E-16/,   &
      WJ0(223) / 7.2227765E-16/,  WJ0(224) /-8.7972942E-16/,   &
      WJ0(225) / 1.0211793E-15/,  WJ0(226) /-1.0940039E-15/,   &
      WJ0(227) / 1.0789555E-15/,  WJ0(228) /-9.7089712E-16/
      DATA   &
      WJ0(229) / 7.4110925E-16/,  WJ0(230) /-4.1700094E-16/,   &
      WJ0(231) / 8.5977186E-17/,  WJ0(232) / 1.3396469E-16/,   &
      WJ0(233) /-1.7838411E-16/,  WJ0(234) / 4.8975422E-17/,   &
      WJ0(235) / 1.9398153E-16/,  WJ0(236) /-5.0046989E-16/,   &
      WJ0(237) / 8.3280983E-16/,  WJ0(238) /-1.1544640E-15/,   &
      WJ0(239) / 1.4401527E-15/,  WJ0(240) /-1.6637066E-15/,   &
      WJ0(241) / 1.7777129E-15/,  WJ0(242) /-1.7322187E-15/,   &
      WJ0(243) / 1.5247247E-15/,  WJ0(244) /-1.1771155E-15/,   &
      WJ0(245) / 6.9747912E-16/,  WJ0(246) /-1.2088956E-16/,   &
      WJ0(247) /-4.8382956E-16/,  WJ0(248) / 1.0408292E-15/,   &
      WJ0(249) /-1.5220450E-15/,  WJ0(250) / 1.9541596E-15/,   &
      WJ0(251) /-2.4107447E-15/,  WJ0(252) / 2.9241439E-15/,   &
      WJ0(253) /-3.5176476E-15/,  WJ0(254) / 4.2276126E-15/,   &
      WJ0(255) /-5.0977852E-15/,  WJ0(256) / 6.1428456E-15/,   &
      WJ0(257) /-7.3949966E-15/,  WJ0(258) / 8.8597605E-15/,   &
      WJ0(259) /-1.0515959E-14/,  WJ0(260) / 1.2264584E-14/,   &
      WJ0(261) /-1.3949870E-14/,  WJ0(262) / 1.5332491E-14/,   &
      WJ0(263) /-1.6146782E-14/,  WJ0(264) / 1.6084121E-14/,   &
      WJ0(265) /-1.4962524E-14/,  WJ0(266) / 1.2794804E-14/
      DATA   &
      WJ0(267) /-9.9286703E-15/,  WJ0(268) / 6.8825810E-15/,   &
      WJ0(269) /-4.0056108E-15/,  WJ0(270) / 1.5965079E-15/,   &
      WJ0(271) /-7.2732957E-18/,  WJ0(272) /-4.0433218E-16/,   &
      WJ0(273) /-6.5679655E-16/,  WJ0(274) / 3.3011866E-15/,   &
      WJ0(275) /-7.3545914E-15/,  WJ0(276) / 1.2394851E-14/,   &
      WJ0(277) /-1.7947696E-14/,  WJ0(278) / 2.3774302E-14/,   &
      WJ0(279) /-3.0279168E-14/,  WJ0(280) / 3.9252832E-14/,   &
      WJ0(281) /-5.5510504E-14/,  WJ0(282) / 9.0505369E-14/,   &
      WJ0(283) /-1.7064873E-13/

!  J1 Bessel filter
!  ----------------
      DATA   &
      WJ1(  1) /-4.2129714E-16/,  WJ1(  2) / 5.3667029E-15/,   &
      WJ1(  3) /-7.1183963E-15/,  WJ1(  4) / 8.9478502E-15/,   &
      WJ1(  5) /-1.0767891E-14/,  WJ1(  6) / 1.2362265E-14/,   &
      WJ1(  7) /-1.3371129E-14/,  WJ1(  8) / 1.3284178E-14/,   &
      WJ1(  9) /-1.1714302E-14/,  WJ1( 10) / 8.4134741E-15/,   &
      WJ1( 11) /-3.7726725E-15/,  WJ1( 12) /-1.4263879E-15/,   &
      WJ1( 13) / 6.1279162E-15/,  WJ1( 14) /-9.1102764E-15/,   &
      WJ1( 15) / 9.9696405E-15/,  WJ1( 16) /-9.3649953E-15/,   &
      WJ1( 17) / 8.6009021E-15/,  WJ1( 18) /-8.9749849E-15/,   &
      WJ1( 19) / 1.1153987E-14/,  WJ1( 20) /-1.4914820E-14/,   &
      WJ1( 21) / 1.9314023E-14/,  WJ1( 22) /-2.3172389E-14/,   &
      WJ1( 23) / 2.5605477E-14/,  WJ1( 24) /-2.6217555E-14/,   &
      WJ1( 25) / 2.5057767E-14/,  WJ1( 26) /-2.2485538E-14/,   &
      WJ1( 27) / 1.9022752E-14/,  WJ1( 28) /-1.5198083E-14/,   &
      WJ1( 29) / 1.1422464E-14/,  WJ1( 30) /-7.9323958E-15/,   &
      WJ1( 31) / 4.8421405E-15/,  WJ1( 32) /-2.1875032E-15/,   &
      WJ1( 33) /-3.2177842E-17/,  WJ1( 34) / 1.8637565E-15/,   &
      WJ1( 35) /-3.3683644E-15/,  WJ1( 36) / 4.6132218E-15/,   &
      WJ1( 37) /-5.6209538E-15/,  WJ1( 38) / 6.4192841E-15/
      DATA   &
      WJ1( 39) /-6.8959930E-15/,  WJ1( 40) / 6.9895791E-15/,   &
      WJ1( 41) /-6.5355936E-15/,  WJ1( 42) / 5.6125161E-15/,   &
      WJ1( 43) /-4.1453932E-15/,  WJ1( 44) / 2.6358827E-15/,   &
      WJ1( 45) /-9.5104372E-16/,  WJ1( 46) / 1.4600474E-16/,   &
      WJ1( 47) / 5.6166517E-16/,  WJ1( 48) / 8.2899247E-17/,   &
      WJ1( 49) / 5.0032097E-16/,  WJ1( 50) / 4.3752206E-16/,   &
      WJ1( 51) / 2.1052292E-15/,  WJ1( 52) /-9.5451973E-16/,   &
      WJ1( 53) / 6.4004435E-15/,  WJ1( 54) /-2.1926176E-15/,   &
      WJ1( 55) / 1.1651003E-14/,  WJ1( 56) / 5.8415431E-16/,   &
      WJ1( 57) / 1.8044665E-14/,  WJ1( 58) / 1.0755745E-14/,   &
      WJ1( 59) / 3.0159021E-14/,  WJ1( 60) / 3.3506137E-14/,   &
      WJ1( 61) / 5.8709351E-14/,  WJ1( 62) / 8.1475198E-14/,   &
      WJ1( 63) / 1.2530007E-13/,  WJ1( 64) / 1.8519112E-13/,   &
      WJ1( 65) / 2.7641786E-13/,  WJ1( 66) / 4.1330822E-13/,   &
      WJ1( 67) / 6.1506209E-13/,  WJ1( 68) / 9.1921663E-13/,   &
      WJ1( 69) / 1.3698462E-12/,  WJ1( 70) / 2.0447426E-12/,   &
      WJ1( 71) / 3.0494476E-12/,  WJ1( 72) / 4.5501003E-12/,   &
      WJ1( 73) / 6.7870249E-12/,  WJ1( 74) / 1.0126237E-11/,   &
      WJ1( 75) / 1.5104976E-11/,  WJ1( 76) / 2.2536053E-11/
      DATA   &
      WJ1( 77) / 3.3617369E-11/,  WJ1( 78) / 5.0153839E-11/,   &
      WJ1( 79) / 7.4818172E-11/,  WJ1( 80) / 1.1161804E-10/,   &
      WJ1( 81) / 1.6651222E-10/,  WJ1( 82) / 2.4840924E-10/,   &
      WJ1( 83) / 3.7058109E-10/,  WJ1( 84) / 5.5284355E-10/,   &
      WJ1( 85) / 8.2474466E-10/,  WJ1( 86) / 1.2303750E-09/,   &
      WJ1( 87) / 1.8355034E-09/,  WJ1( 88) / 2.7382503E-09/,   &
      WJ1( 89) / 4.0849866E-09/,  WJ1( 90) / 6.0940897E-09/,   &
      WJ1( 91) / 9.0913019E-09/,  WJ1( 92) / 1.3562651E-08/,   &
      WJ1( 93) / 2.0233058E-08/,  WJ1( 94) / 3.0184243E-08/,   &
      WJ1( 95) / 4.5029477E-08/,  WJ1( 96) / 6.7176302E-08/,   &
      WJ1( 97) / 1.0021488E-07/,  WJ1( 98) / 1.4950371E-07/,   &
      WJ1( 99) / 2.2303207E-07/,  WJ1(100) / 3.3272690E-07/,   &
      WJ1(101) / 4.9636623E-07/,  WJ1(102) / 7.4049802E-07/,   &
      WJ1(103) / 1.1046805E-06/,  WJ1(104) / 1.6480103E-06/,   &
      WJ1(105) / 2.4585015E-06/,  WJ1(106) / 3.6677163E-06/,   &
      WJ1(107) / 5.4714551E-06/,  WJ1(108) / 8.1626422E-06/,   &
      WJ1(109) / 1.2176782E-05/,  WJ1(110) / 1.8166180E-05/,   &
      WJ1(111) / 2.7099222E-05/,  WJ1(112) / 4.0428804E-05/,   &
      WJ1(113) / 6.0307295E-05/,  WJ1(114) / 8.9971509E-05/
      DATA   &
      WJ1(115) / 1.3420195E-04/,  WJ1(116) / 2.0021123E-04/,   &
      WJ1(117) / 2.9860417E-04/,  WJ1(118) / 4.4545290E-04/,   &
      WJ1(119) / 6.6423154E-04/,  WJ1(120) / 9.9073281E-04/,   &
      WJ1(121) / 1.4767050E-03/,  WJ1(122) / 2.2016806E-03/,   &
      WJ1(123) / 3.2788147E-03/,  WJ1(124) / 4.8837294E-03/,   &
      WJ1(125) / 7.2596809E-03/,  WJ1(126) / 1.0788355E-02/,   &
      WJ1(127) / 1.5973322E-02/,  WJ1(128) / 2.3612041E-02/,   &
      WJ1(129) / 3.4655329E-02/,  WJ1(130) / 5.0608139E-02/,   &
      WJ1(131) / 7.2827749E-02/,  WJ1(132) / 1.0337889E-01/,   &
      WJ1(133) / 1.4207357E-01/,  WJ1(134) / 1.8821315E-01/,   &
      WJ1(135) / 2.2996815E-01/,  WJ1(136) / 2.5088501E-01/,   &
      WJ1(137) / 2.0334627E-01/,  WJ1(138) / 6.0665451E-02/,   &
      WJ1(139) /-2.0275684E-01/,  WJ1(140) /-3.5772336E-01/,   &
      WJ1(141) /-1.8280528E-01/,  WJ1(142) / 4.7014633E-01/,   &
      WJ1(143) / 7.2991233E-03/,  WJ1(144) /-3.0614594E-01/,   &
      WJ1(145) / 2.4781735E-01/,  WJ1(146) /-1.1149185E-01/,   &
      WJ1(147) / 2.5985386E-02/,  WJ1(148) / 1.0850279E-02/,   &
      WJ1(149) /-2.2830216E-02/,  WJ1(150) / 2.4644647E-02/,   &
      WJ1(151) /-2.2895284E-02/,  WJ1(152) / 2.0197032E-02/
      DATA   &
      WJ1(153) /-1.7488968E-02/,  WJ1(154) / 1.5057670E-02/,   &
      WJ1(155) /-1.2953923E-02/,  WJ1(156) / 1.1153254E-02/,   &
      WJ1(157) /-9.6138436E-03/,  WJ1(158) / 8.2952091E-03/,   &
      WJ1(159) /-7.1628359E-03/,  WJ1(160) / 6.1882911E-03/,   &
      WJ1(161) /-5.3482056E-03/,  WJ1(162) / 4.6232054E-03/,   &
      WJ1(163) /-3.9970544E-03/,  WJ1(164) / 3.4560119E-03/,   &
      WJ1(165) /-2.9883671E-03/,  WJ1(166) / 2.5840860E-03/,   &
      WJ1(167) /-2.2345427E-03/,  WJ1(168) / 1.9323046E-03/,   &
      WJ1(169) /-1.6709584E-03/,  WJ1(170) / 1.4449655E-03/,   &
      WJ1(171) /-1.2495408E-03/,  WJ1(172) / 1.0805480E-03/,   &
      WJ1(173) /-9.3441131E-04/,  WJ1(174) / 8.0803898E-04/,   &
      WJ1(175) /-6.9875782E-04/,  WJ1(176) / 6.0425623E-04/,   &
      WJ1(177) /-5.2253529E-04/,  WJ1(178) / 4.5186651E-04/,   &
      WJ1(179) /-3.9075516E-04/,  WJ1(180) / 3.3790860E-04/,   &
      WJ1(181) /-2.9220915E-04/,  WJ1(182) / 2.5269020E-04/,   &
      WJ1(183) /-2.1851585E-04/,  WJ1(184) / 1.8896331E-04/,   &
      WJ1(185) /-1.6340753E-04/,  WJ1(186) / 1.4130796E-04/,   &
      WJ1(187) /-1.2219719E-04/,  WJ1(188) / 1.0567099E-04/,   &
      WJ1(189) /-9.1379829E-05/,  WJ1(190) / 7.9021433E-05/
      DATA   &
      WJ1(191) /-6.8334411E-05/,  WJ1(192) / 5.9092727E-05/,   &
      WJ1(193) /-5.1100906E-05/,  WJ1(194) / 4.4189914E-05/,   &
      WJ1(195) /-3.8213580E-05/,  WJ1(196) / 3.3045497E-05/,   &
      WJ1(197) /-2.8576356E-05/,  WJ1(198) / 2.4711631E-05/,   &
      WJ1(199) /-2.1369580E-05/,  WJ1(200) / 1.8479514E-05/,   &
      WJ1(201) /-1.5980308E-05/,  WJ1(202) / 1.3819097E-05/,   &
      WJ1(203) /-1.1950174E-05/,  WJ1(204) / 1.0334008E-05/,   &
      WJ1(205) /-8.9364157E-06/,  WJ1(206) / 7.7278364E-06/,   &
      WJ1(207) /-6.6827083E-06/,  WJ1(208) / 5.7789252E-06/,   &
      WJ1(209) /-4.9973714E-06/,  WJ1(210) / 4.3215168E-06/,   &
      WJ1(211) /-3.7370660E-06/,  WJ1(212) / 3.2316575E-06/,   &
      WJ1(213) /-2.7946014E-06/,  WJ1(214) / 2.4166538E-06/,   &
      WJ1(215) /-2.0898208E-06/,  WJ1(216) / 1.8071891E-06/,   &
      WJ1(217) /-1.5627811E-06/,  WJ1(218) / 1.3514274E-06/,   &
      WJ1(219) /-1.1686576E-06/,  WJ1(220) / 1.0106060E-06/,   &
      WJ1(221) /-8.7392954E-07/,  WJ1(222) / 7.5573752E-07/,   &
      WJ1(223) /-6.5353004E-07/,  WJ1(224) / 5.6514529E-07/,   &
      WJ1(225) /-4.8871385E-07/,  WJ1(226) / 4.2261922E-07/,   &
      WJ1(227) /-3.6546334E-07/,  WJ1(228) / 3.1603733E-07/
      DATA   &
      WJ1(229) /-2.7329580E-07/,  WJ1(230) / 2.3633470E-07/,   &
      WJ1(231) /-2.0437231E-07/,  WJ1(232) / 1.7673258E-07/,   &
      WJ1(233) /-1.5283091E-07/,  WJ1(234) / 1.3216174E-07/,   &
      WJ1(235) /-1.1428792E-07/,  WJ1(236) / 9.8831386E-08/,   &
      WJ1(237) /-8.5465224E-08/,  WJ1(238) / 7.3906733E-08/,   &
      WJ1(239) /-6.3911436E-08/,  WJ1(240) / 5.5267922E-08/,   &
      WJ1(241) /-4.7793375E-08/,  WJ1(242) / 4.1329702E-08/,   &
      WJ1(243) /-3.5740189E-08/,  WJ1(244) / 3.0906612E-08/,   &
      WJ1(245) /-2.6726738E-08/,  WJ1(246) / 2.3112159E-08/,   &
      WJ1(247) /-1.9986423E-08/,  WJ1(248) / 1.7283419E-08/,   &
      WJ1(249) /-1.4945973E-08/,  WJ1(250) / 1.2924650E-08/,   &
      WJ1(251) /-1.1176694E-08/,  WJ1(252) / 9.6651345E-09/,   &
      WJ1(253) /-8.3580023E-09/,  WJ1(254) / 7.2276491E-09/,   &
      WJ1(255) /-6.2501675E-09/,  WJ1(256) / 5.4048823E-09/,   &
      WJ1(257) /-4.6739155E-09/,  WJ1(258) / 4.0418060E-09/,   &
      WJ1(259) /-3.4951848E-09/,  WJ1(260) / 3.0224896E-09/,   &
      WJ1(261) /-2.6137226E-09/,  WJ1(262) / 2.2602382E-09/,   &
      WJ1(263) /-1.9545596E-09/,  WJ1(264) / 1.6902214E-09/,   &
      WJ1(265) /-1.4616324E-09/,  WJ1(266) / 1.2639577E-09/
      DATA   &
      WJ1(267) /-1.0930165E-09/,  WJ1(268) / 9.4519326E-10/,   &
      WJ1(269) /-8.1736201E-10/,  WJ1(270) / 7.0681933E-10/,   &
      WJ1(271) /-6.1122712E-10/,  WJ1(272) / 5.2856342E-10/,   &
      WJ1(273) /-4.5707937E-10/,  WJ1(274) / 3.9526268E-10/,   &
      WJ1(275) /-3.4180569E-10/,  WJ1(276) / 2.9557784E-10/,   &
      WJ1(277) /-2.5560176E-10/,  WJ1(278) / 2.2103233E-10/,   &
      WJ1(279) /-1.9113891E-10/,  WJ1(280) / 1.6528993E-10/,   &
      WJ1(281) /-1.4294012E-10/,  WJ1(282) / 1.2361991E-10/,   &
      WJ1(283) /-8.2740939E-11/

!  Set Anderson sine filter weights
!  --------------------------------

      DATA (WS(J),J=1,76)/   &
       -1.1113940E-09,-1.3237246E-12, 1.5091739E-12,-1.6240954E-12,   &
        1.7236636E-12,-1.8227727E-12, 1.9255992E-12,-2.0335514E-12,   &
        2.1473541E-12,-2.2675549E-12, 2.3946842E-12,-2.5292661E-12,   &
        2.6718110E-12,-2.8227693E-12, 2.9825171E-12,-3.1514006E-12,   &
        3.3297565E-12,-3.5179095E-12, 3.7163306E-12,-3.9256378E-12,   &
        4.1464798E-12,-4.3794552E-12, 4.6252131E-12,-4.8845227E-12,   &
        5.1582809E-12,-5.4474462E-12, 5.7530277E-12,-6.0760464E-12,   &
        6.4175083E-12,-6.7783691E-12, 7.1595239E-12,-7.5618782E-12,   &
        7.9864477E-12,-8.4344110E-12, 8.9072422E-12,-9.4067705E-12,   &
        9.9349439E-12,-1.0493731E-11, 1.1084900E-11,-1.1709937E-11,   &
        1.2370354E-11,-1.3067414E-11, 1.3802200E-11,-1.4575980E-11,   &
        1.5390685E-11,-1.6249313E-11, 1.7155934E-11,-1.8115250E-11,   &
        1.9131898E-11,-2.0209795E-11, 2.1352159E-11,-2.2561735E-11,   &
        2.3840976E-11,-2.5192263E-11, 2.6618319E-11,-2.8122547E-11,   &
        2.9709129E-11,-3.1382870E-11, 3.3149030E-11,-3.5013168E-11,   &
        3.6981050E-11,-3.9058553E-11, 4.1251694E-11,-4.3566777E-11,   &
        4.6010537E-11,-4.8590396E-11, 5.1314761E-11,-5.4193353E-11,   &
        5.7236720E-11,-6.0455911E-11, 6.3861222E-11,-6.7461492E-11,   &
        7.1265224E-11,-7.5279775E-11, 7.9512249E-11,-8.3971327E-11/
      DATA (WS(J),J=77,152)/   &
       8.8668961E-11,-9.3621900E-11, 9.8851764E-11,-1.0438319E-10,   &
       1.1024087E-10,-1.1644680E-10, 1.2301979E-10,-1.2997646E-10,   &
       1.3733244E-10,-1.4510363E-10, 1.5330772E-10,-1.6196550E-10,   &
       1.7110130E-10,-1.8074257E-10, 1.9091922E-10,-2.0166306E-10,   &
       2.1300756E-10,-2.2498755E-10, 2.3763936E-10,-2.5100098E-10,   &
       2.6511250E-10,-2.8001616E-10, 2.9575691E-10,-3.1238237E-10,   &
       3.2994314E-10,-3.4849209E-10, 3.6808529E-10,-3.8878042E-10,   &
       4.1063982E-10,-4.3372666E-10, 4.5811059E-10,-4.8386049E-10,   &
       5.1105728E-10,-5.3977672E-10, 5.7011632E-10,-6.0215516E-10,   &
       6.3601273E-10,-6.7175964E-10, 7.0955028E-10,-7.4942601E-10,   &
       7.9161025E-10,-8.3606980E-10, 8.8317110E-10,-9.3270330E-10,   &
       9.8533749E-10,-1.0404508E-09, 1.0993731E-09,-1.1605442E-09,   &
       1.2267391E-09,-1.2942905E-09, 1.3691677E-09,-1.4429912E-09,   &
       1.5288164E-09,-1.6077524E-09, 1.7085998E-09,-1.7890471E-09,   &
       1.9129068E-09,-1.9857116E-09, 2.1491608E-09,-2.1926779E-09,   &
       2.4312660E-09,-2.3959044E-09, 2.7872500E-09,-2.5610596E-09,   &
       3.2762318E-09,-2.6082940E-09, 4.0261453E-09,-2.3560563E-09,   &
       5.3176554E-09,-1.3960161E-09, 7.7708747E-09, 1.1853546E-09,   &
       1.2760851E-08, 7.4264707E-09, 2.3342187E-08, 2.1869851E-08/
      DATA (WS(J),J=153,228)/   &
       4.6306744E-08, 5.4631686E-08, 9.6763087E-08, 1.2823337E-07,   &
       2.0832812E-07, 2.9280540E-07, 4.5580888E-07, 6.5992437E-07,   &
       1.0056815E-06, 1.4779183E-06, 2.2284335E-06, 3.2994604E-06,   &
       4.9485823E-06, 7.3545473E-06, 1.1001083E-05, 1.6380539E-05,   &
       2.4469550E-05, 3.6469246E-05, 5.4441527E-05, 8.1176726E-05,   &
       1.2113828E-04, 1.8066494E-04, 2.6954609E-04, 4.0202288E-04,   &
       5.9969995E-04, 8.9437312E-04, 1.3338166E-03, 1.9886697E-03,   &
       2.9643943E-03, 4.4168923E-03, 6.5773518E-03, 9.7855105E-03,   &
       1.4539361E-02, 2.1558670E-02, 3.1871864E-02, 4.6903518E-02,   &
       6.8559512E-02, 9.9170152E-02, 1.4120770E-01, 1.9610835E-01,   &
       2.6192603E-01, 3.2743321E-01, 3.6407406E-01, 3.1257559E-01,   &
       9.0460168E-02,-3.6051039E-01,-8.6324760E-01,-8.1178720E-01,   &
       5.2205241E-01, 1.5449873E+00,-1.1817933E+00,-2.6759896E-01,   &
       8.0869203E-01,-6.2757149E-01, 3.4062630E-01,-1.5885304E-01,   &
       7.0472984E-02,-3.1624462E-02, 1.4894068E-02,-7.4821176E-03,   &
       4.0035936E-03,-2.2543784E-03, 1.3160358E-03,-7.8636604E-04,   &
       4.7658745E-04,-2.9125817E-04, 1.7885105E-04,-1.1012416E-04,   &
       6.7910334E-05,-4.1914054E-05, 2.5881544E-05,-1.5985851E-05,   &
       9.8751880E-06,-6.1008526E-06, 3.7692543E-06,-2.3287953E-06/
      DATA (WS(J),J=229,266)/   &
       1.4388425E-06,-8.8899353E-07, 5.4926991E-07,-3.3937048E-07,   &
       2.0968284E-07,-1.2955437E-07, 8.0046336E-08,-4.9457371E-08,   &
       3.0557711E-08,-1.8880390E-08, 1.1665454E-08,-7.2076428E-09,   &
       4.4533423E-09,-2.7515696E-09, 1.7001092E-09,-1.0504494E-09,   &
       6.4904567E-10,-4.0102999E-10, 2.4778763E-10,-1.5310321E-10,   &
       9.4600354E-11,-5.8453314E-11, 3.6119400E-11,-2.2320056E-11,   &
       1.3793460E-11,-8.5242656E-12, 5.2675102E-12,-3.2543076E-12,   &
       2.0097689E-12,-1.2405412E-12, 7.6530538E-13,-4.7191929E-13,   &
       2.9084993E-13,-1.7923661E-13, 1.1018948E-13,-6.7885902E-14,   &
       4.2025050E-14,-2.1314731E-14/

      END
!END OF BLOCK DATA
!
!
       REAL FUNCTION ROI_ZXFINPL6(A,FC,L,X)
      INTEGER I,I1,ICN2,II,L,NINT,NINTM
      REAL X
!
!***!  Interpolation of the frequency domain solutions
!
!    Six-point polynomial interpolations.  Unlike six-point
!    Lagrangian interpolations, the  abscissae do not need
!    to be equally spaced (in a logrithmic scale).
!
!    Tests have shown that five-point interpolations yielded
!    an accuracy of about 10^(-3) for the 6-per-decade filtering
!    results and about 10^(-4) for the 10-per-decade filtering
!    results. With a six-point interpolation the accuracy is
!    improved by almost an order of magnitude and the accuracy
!    approaches that of the 10-per-decade filtering.
!
!    This routine is identical to ROI_ZXFINPL8 except that this
!    is six-point interpolation.
!
! Input parameters:
!
!   X:      Real(*4),  interpolating point (frequency).
!   L:      Integer(*4),  number of grid points in frequency.
!   A:      Real A(L),  array for grid points.
!   FC:     Real FC(L), array for the values of the function
!           at the grid points.
!
! Output parameter:
!
!   Real,  interpolated function value.
!
!
!**** Called by:  COSTRN
!
!**** Calls:      none
!
!
      PARAMETER (NINT=6,NINTM=10)
      REAL A(L),XA(NINT)
      REAL FC(L),F,YA(NINTM),DY
!
! --- Sorting
!
      IF (X<=A(1)) THEN
         I=1
      ELSEIF (X>=A(L)) THEN
         I=L
      ELSE
         DO I=1,L-1
            IF (X>=A(I).AND.X<=A(I+1)) THEN
               EXIT
            ENDIF
         ENDDO
      ENDIF
!
      IF (I<=3) THEN
         ICN2=1
      ELSEIF (I>=L-3) THEN
         ICN2=L-5
      ELSE
         ICN2=I-2
      ENDIF
!
      DO II=1,NINT
         I1=ICN2+II-1
         XA(II)=A(I1)
         YA(II)=FC(I1)
      ENDDO
!
      CALL ROI_ZXPOL(XA,YA,NINT,X,F,DY)
!
      ROI_ZXFINPL6=F
!
      RETURN
      END
!
!**** End of ROI_ZXFINPL6
!
!
      REAL FUNCTION ROI_ZXFINPL8(A,FC,L,X)
      INTEGER I,I1,ICN2,II,L,NINT,NINTM
      REAL X
!
!
!***!  Interpolation of the frequency domain or the time domain results
!
!    Eight-point polynomial interpolations.
!
!    Tests have shown that both eight-point polynomial interpolation
!    and eight-point rational interpolation yield an accuracy of
!    about 10^(-6) in most cases both for the 6- and 10-per-decade
!    filtering,  with the latter showing slightly higher accuracy.
!    For the 6-per-decade filtering rational interpolations
!    appeared to be a bit more accurate in most cases.  However,
!    the rational interpolation resulted in abrupt jump in errors
!    very often,  which makes the interpolated results extremely
!    unreliable (errors often jumped up to 1 %).
!
!
! Input parameters:
!
!   X:      Real(*4),  interpolating point (frequency or time).
!   L:      Integer(*4),  number of grid points in frequency or time.
!   A:      Real A(L),  array for grid points.
!   FC:     Real FC(L), array for the values of the function
!           at the grid points.
!
! Output parameter:
!
!   Real,  interpolated function value.
!
!
!**** Called by:  COSTRN
!
!**** Calls:      INTERPO_POLINT
!
!
      PARAMETER (NINT=8,NINTM=10)
      REAL A(L),XA(NINT)
      REAL FC(L),F,YA(NINTM),DY
!
      IF (X<=A(1)) THEN
         I=1
      ELSEIF (X>=A(L)) THEN
         I=L
      ELSE
         DO I=1,L-1
            IF (X>=A(I).AND.X<=A(I+1)) THEN
               EXIT
            ENDIF
         ENDDO
      ENDIF
!
      IF (I<=4) THEN
         ICN2=1
      ELSEIF (I>=L-4) THEN
         ICN2=L-7
!         ICN2=L-6
      ELSE
         ICN2=I-3
      ENDIF
!
      DO II=1,NINT
         I1=ICN2+II-1
         XA(II)=A(I1)
         YA(II)=FC(I1)
      ENDDO
!
      CALL ROI_ZXPOL(XA,YA,NINT,X,F,DY)
!
      ROI_ZXFINPL8=F
!
      RETURN
      END
!
!**** End of ROI_ZXFINPL8
!
!
      SUBROUTINE ROI_ZXPOL(XA,YA,N,X,Y,DY)
!
      IMPLICIT NONE
!
      REAL DIF,DIFT,HO,HP,TINY,X
      INTEGER I,M,N,NMAX,NS
!**** Polynomial interpolation
!
!   modified from Press et al., Numerical recipes, p.82
!
!   This routine is identical to INTERPO_POLINT except that ROI_ZXPOL
!   interpolates a real function
!
      PARAMETER (NMAX=10,TINY=1.E-30)
      REAL XA(N)
      REAL YA(N),Y,DY,C(NMAX),D(NMAX),W,DEN
      NS=1
      DIF=ABS(X-XA(1))
      DO I=1,N
         DIFT=ABS(X-XA(I))
         IF (DIFT<DIF) THEN
            NS=I
            DIF=DIFT
         ENDIF
         C(I)=YA(I)
         D(I)=YA(I)
      ENDDO
      Y=YA(NS)
      NS=NS-1
      DO M=1,N-1
         DO I=1,N-M
            HO=XA(I)-X
            HP=XA(I+M)-X
            W=C(I+1)-D(I)
            DEN=HO-HP
            IF (ABS(DEN)<TINY) THEN
               STOP 'Error in routine ROI_ZXPOL: two identical XA!'
            ENDIF
            DEN=W/DEN
            D(I)=HP*DEN
            C(I)=HO*DEN
         ENDDO
         IF (2*NS<N-M) THEN
            DY=C(NS+1)
         ELSE
            DY=D(NS)
            NS=NS-1
         ENDIF
         Y=Y+DY
      ENDDO
      RETURN
      END
!
!**** End of ROI_ZXPOL
!

