      subroutine asc2eph (DEascii)

!C
!C      ASC2EPH creates a binary format JPL Planetary Ephemeris file from
!C      one or more ascii text files.
!C
!C $ Disclaimer
!C
!C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
!C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
!C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
!C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
!C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
!C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
!C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
!C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
!C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
!C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
!C
!C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
!C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
!C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
!C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
!C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
!C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
!C
!C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
!C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
!C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
!C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
!C
!C
!C      This program, 'asc2eph', requires (via standard input) an ascii
!C      header file ('header.XXX'), followed by one or more ascii ephemeris
!C      data files ('ascSYYYY.XXX').  All files must have the same ephemeris
!C      number, XXX.  Further, the data files must be consecutive in time
!C      with no gaps between them.
!C
!C      By default, the output ephemeris will span the same interval as the input
!C      text file(s).  If you are interested in only a portion of data, set the
!C      below T1 and T2 to the begin and end times of the span you desire.  T1
!C      and T2 must be specified in  Julian Ephemeris Days (ET).
!C
!C      A sample sequence of files might be:
!C
!C        header.405  asc+1920.405 asc+1940.405 asc+1960.405 asc+1980.405
!C
!C      This program is written in standard Fortran-77.
!C
!C **********************************************************************************
!C
!C                                    *** NOTE ***
!C
!C      However, the units in which the length of a direct access record is specified
!C      are PROCESSOR DEPENDENT.  The parameter NRECL, the number of units per word,
!C      controls the length of a record in the direct access ephemeris.
!C      The user MUST select the correct value of NRECL by editing one of the
!C      comemnted lines defining PARAMETER (NRECL) below.
!C
!C **********************************************************************************
!C
!C     Updated 02 March  2013 to accommodate more than 400 dynamical parameters
!C     Updated 02 August 2013 to accommodate reading of TT-TDB
!C     Updated 15 August 2013 to accommodate negative Julian dates
!C
!C **********************************************************************************

      USE mdl_planets
      IMPLICIT NONE

      INTEGER NRECL

!C *****  The user must choose one of the following statements  *****
!C            ( Usually NRECL = 4 is used on Unix platforms)

      PARAMETER ( NRECL = 4 )
!C      PARAMETER ( NRECL = 1 )

      INTEGER OLDMAX
      PARAMETER ( OLDMAX = 400)
      INTEGER NMAX
      PARAMETER ( NMAX = 1000)

!C **********************************************************************************

       CHARACTER*6  CNAM (NMAX)
       CHARACTER*6  TTL  (14,3)
       CHARACTER*12 HEADER

       DOUBLE PRECISION  AU
       DOUBLE PRECISION  CVAL (NMAX)
       DOUBLE PRECISION  DB(3000)
       DOUBLE PRECISION  DB2Z
       DOUBLE PRECISION  EMRAT
       DOUBLE PRECISION  SS   (3)
       DOUBLE PRECISION  T1, T2

       INTEGER  I, IRECSZ, IN
       INTEGER  J
       INTEGER  K,KK,KP2,KSIZE
       INTEGER  IPT (3,12)                         ! Pointers to number of coefficients for bodies
       INTEGER  LPT(3)                             ! Pointer to number of coefficients for lunar librations
       INTEGER  RPT(3)                             ! Pointer to number of coefficients for lunar euler angel rates
       INTEGER  TPT(3)                             ! Pointer to number of coefficients for TT-TDB
       INTEGER  N, NCON, NROUT, NCOEFF, NRW, NUMDE, REC_DB
       INTEGER  OUT

       LOGICAL  FIRST
       DATA     FIRST / .TRUE. /
! ----------------------------------------------------------------------
      CHARACTER (LEN=100) :: DEascii
      INTEGER UNIT_de ,UNIT_dat, ios, ios_line, ios_data, i_DB, SS_i, AllocateStatus
      DOUBLE PRECISION SS_value
      CHARACTER (LEN=1000) :: line_ith
! ----------------------------------------------------------------------

      UNIT_de  = 9

! ----------------------------------------------------------------------
! Allocatable arrays: CVAL_2, DB_array
! ----------------------------------------------------------------------
      ALLOCATE (CVAL_2(NMAX), STAT = AllocateStatus)
! ----------------------------------------------------------------------
! variable init, NUMDE, EMRAT ,AU
NUMDE = 0
EMRAT = 0.d0
AU = 0.d0

Do i = 1, NMAX
CNAM(I) = "      "
Enddo

!C ***********************************************************************
!C
!C     By default, the output ephemeris will span the same interval as the
!C     input ascii data file(s).  The user may reset these to other JED's.
!C
       DB2Z = -99999999.d0
       T1   = -99999999.d0
       T2   =  99999999.d0

       IF(NRECL .NE. 1 .AND. NRECL .NE. 4) THEN
         WRITE(*,*)'*** ERROR: User did not set NRECL ***'
         STOP
       ENDIF

!C      Write a fingerprint to the screen.

!C        WRITE(*,*) ' JPL ASCII-TO-DIRECT-I/O program. ' //
!C      &            ' Last modified 15-Aug-2013.'

! ----------------------------------------------------------------------
! Open DE ascii data file
      OPEN (UNIT=UNIT_de,FILE=DEascii,IOSTAT=ios)
      IF (ios /= 0) THEN
         PRINT *, "Error in opening file:", DEascii
         PRINT *, "OPEN IOSTAT=", ios
      END IF
! ----------------------------------------------------------------------

!C      Read the size and number of main ephemeris records.
!C        (from header.xxx)

!       READ  (*,'(6X,I6)')  KSIZE
       READ (UNIT=UNIT_de,FMT='(6X,I6)',IOSTAT=ios_line) KSIZE  				!777
!       WRITE (*,100)              KSIZE
100    FORMAT(/'KSIZE =',I6)

       IRECSZ = NRECL * KSIZE

!C      Now for the alphameric heading records (GROUP 1010)

!       CALL  NXTGRP ( HEADER )
       CALL  NXTGRP ( HEADER , UNIT_de )

       IF (HEADER .NE. 'GROUP   1010')  THEN
          CALL  ERRPRT ( 1010, 'NOT HEADER' )
       ENDIF

!       READ (*,'(14A6)')    TTL
       READ (UNIT=UNIT_de,FMT='(14A6)',IOSTAT=ios_line) TTL  					!777
!       WRITE(*,'(/(14A6))') TTL

!c      Read start, end and record span  (GROUP 1030)

!       CALL  NXTGRP ( HEADER )
       CALL  NXTGRP ( HEADER , UNIT_de )

       IF ( HEADER .NE. 'GROUP   1030' ) THEN
          CALL ERRPRT ( 1030, 'NOT HEADER' )
       ENDIF

!       READ (*,'(3F12.0)')  SS
       READ (UNIT=UNIT_de,FMT='(3F12.0)',IOSTAT=ios_line) SS  					!777

!c      Read number of constants and names of constants (GROUP 1040/4).

!       CALL  NXTGRP ( HEADER )
       CALL  NXTGRP ( HEADER , UNIT_de )

       IF ( HEADER .NE. 'GROUP   1040 ') THEN
          CALL ERRPRT ( 1040, 'NOT HEADER' )
       ENDIF

!       READ (*,'(I6)')    N
       READ (UNIT=UNIT_de,FMT='(I6)',IOSTAT=ios_line) N             			!777
!       READ (*,'(10A8)') (CNAM(I),I=1,N)
       READ (UNIT=UNIT_de,FMT='(10A8)',IOSTAT=ios_line) (CNAM(I),I=1,N)  		!777

       NCON = N

!C      Read number of values and values (GROUP 1041/4)

!       CALL  NXTGRP ( HEADER )
       CALL  NXTGRP ( HEADER , UNIT_de )										!777

       IF ( HEADER .NE. 'GROUP   1041' ) THEN
          CALL ERRPRT ( 1041, 'NOT HEADER' )
       ENDIF

!       READ (*,'(I6)')       N
       READ (UNIT=UNIT_de,FMT='(I6)')       N  									!777

!       READ (*,*)  (CVAL(I),I=1,N)
       READ (UNIT=UNIT_de,FMT=*)  (CVAL(I),I=1,N)    							!777

       DO  I = 1, N
           IF ( CNAM(I) .EQ. 'AU    ' )  AU    = CVAL(I)
           IF ( CNAM(I) .EQ. 'EMRAT ' )  EMRAT = CVAL(I)
           IF ( CNAM(I) .EQ. 'DENUM ' )  NUMDE = CVAL(I)
       END DO

!       WRITE (*,'(500(/2(A8,D24.16)))') (CNAM(I),CVAL(I),I=1,N)

!c      Zero out pointer arrays

       DO I = 1,3
         DO J = 1,12
           IPT(I,J) = 0
         ENDDO
         LPT(I) = 0
         RPT(I) = 0
         TPT(I) = 0
       ENDDO

!C      Read pointers needed by INTERP (GROUP 1050)

!       CALL  NXTGRP ( HEADER )
       CALL  NXTGRP ( HEADER , UNIT_de )										!777

       IF ( HEADER .NE. 'GROUP   1050' ) THEN
          CALL ERRPRT ( 1050, 'NOT HEADER' )
       ENDIF

!       WRITE(*,'(/)')

       DO I=1,3
!         READ (*,'(15I6)') (IPT(I,J),J=1,12),LPT(I),RPT(I),TPT(I)
         READ (UNIT=UNIT_de,FMT='(15I6)') (IPT(I,J),J=1,12),LPT(I),RPT(I),TPT(I)	!777
!         WRITE(*,'(15I5)')(IPT(I,J),J=1,12),LPT(I),RPT(I),TPT(I)
       ENDDO

!C C      Open direct-access output file ('JPLEPH')

!C        OPEN ( UNIT   = 12,
!C      .        FILE   = 'JPLEPH',
!C      .        ACCESS = 'DIRECT',
!C      .        FORM   = 'UNFORMATTED',
!C      .        RECL   = IRECSZ,
!C      .        STATUS = 'NEW' )

!C     Read and write the ephemeris data records (GROUP 1070).

!      CALL  NXTGRP ( HEADER )
      CALL  NXTGRP ( HEADER , UNIT_de )											!777

      IF ( HEADER .NE. 'GROUP   1070' ) CALL ERRPRT(1070,'NOT HEADER')

      NROUT  = 0
      IN     = 0
      OUT    = 0

   1  continue

!      READ(*,'(2I6)')NRW,NCOEFF
      READ(UNIT=UNIT_de,FMT='(2I6)')NRW,NCOEFF                                  !777
      IF(NRW .EQ. 0) GO TO 1

! ----------------------------------------------------------------------
! Allocatable arrays: DB_array
! ----------------------------------------------------------------------
      ALLOCATE (DB_array(10000,NCOEFF), STAT = AllocateStatus)
! ----------------------------------------------------------------------

      DO K=1,NCOEFF,3
        KP2 = MIN(K+2,NCOEFF)
!        READ(*,*,IOSTAT = IN)(DB(KK),KK=K,KP2)
        READ(UNIT=UNIT_de,FMT=*,IOSTAT = IN)(DB(KK),KK=K,KP2)                   !777
        IF(IN .NE. 0) STOP ' Error reading 1st set of coeffs'
      ENDDO

      DO WHILE (       ( IN    .EQ. 0 ) .AND. ( DB(2) .LT. T2) )

          IF ( 2*NCOEFF .NE. KSIZE ) THEN
             CALL ERRPRT(NCOEFF,' 2*NCOEFF not equal to KSIZE')
          ENDIF

!C         Skip this data block if the end of the interval is less
!C         than the specified start time or if the it does not begin
!C         where the previous block ended.

          IF  ( (DB(2) .GE. T1) .AND. (DB(1) .GE. DB2Z) ) THEN

             IF ( FIRST ) THEN

!C               Don't worry about the intervals overlapping
!C               or abutting if this is the first applicable
!C               interval.

                DB2Z  = DB(1)
                FIRST = .FALSE.
             ENDIF

             IF (DB(1) .NE. DB2Z ) THEN

!C               Beginning of current interval is past the end
!C               of the previous one.

                CALL ERRPRT (NRW, 'Records do not overlap or abut')
             ENDIF

             DB2Z  = DB(2)
             NROUT = NROUT + 1

! ----------------------------------------------------------------------
! Allocatable array DB_array has been introduced for storing the Chebyshev coefficients
! ----------------------------------------------------------------------
!             WRITE (12,REC=NROUT+2,IOSTAT=OUT) (DB(K),K=1,NCOEFF)
             DO i_DB = 1 , NCOEFF , 1
                DB_array(NROUT,i_DB) = DB(i_DB)
             END DO
! ----------------------------------------------------------------------

             IF ( OUT .NE. 0 ) THEN
                CALL ERRPRT (NROUT, 'th record not written because of error')
             ENDIF

!C            Save this block's starting date, its interval span, and its end
!C            date.

             IF (NROUT .EQ. 1) THEN
                SS(1) = DB(1)
                SS(3) = DB(2) - DB(1)
             ENDIF
             SS(2) = DB(2)

!C            Update the user as to our progress every 100th block.

             IF ( MOD(NROUT,100) .EQ. 1 ) THEN
                IF ( DB(1) .GE. T1 ) THEN
!C                    WRITE (*,271) NROUT, DB(2)
                ELSE
!C                    WRITE (*,*)
!C      &           ' Searching for first requested record...'
                ENDIF
             ENDIF
271          FORMAT (I6, ' EPHEMERIS RECORDS WRITTEN.  LAST JED = ', F12.2)

          ENDIF

!          READ (*,'(2I6)',IOSTAT =IN) NRW, NCOEFF
          READ (UNIT=UNIT_de,FMT='(2I6)',IOSTAT =IN) NRW, NCOEFF                !777

          IF(IN .EQ. 0)then
            DO K=1,NCOEFF,3
              KP2 = MIN(K+2,NCOEFF)
!              READ(*,*,IOSTAT = IN)(DB(KK),KK=K,KP2)
              READ(UNIT=UNIT_de,FMT=*,IOSTAT = IN) (DB(KK),KK=K,KP2)            !777
              IF(IN .NE. 0) STOP ' Error reading nth set of coeffs'
            ENDDO
          ENDIF

      END DO

!      WRITE (*,275) NROUT, DB(2)
275   FORMAT(I6, ' EPHEMERIS RECORDS WRITTEN.  LAST JED = ',F12.2)

!C     Write header records onto output file.

!C      NROUT = 1

!      PRINT *, "SS asc2eph WRITE", SS(1), SS(2), SS(3)

!C      IF(NCON .LE. OLDMAX)THEN
!C          WRITE(12,REC=1,IOSTAT=OUT) TTL,(CNAM(I),I=1,OLDMAX),SS,NCON,AU,
!C      &              EMRAT,IPT,NUMDE,LPT,RPT,TPT
!C      ELSE
!C         K = OLDMAX+1
!C          WRITE(12,REC=1,IOSTAT=OUT) TTL,(CNAM(I),I=1,OLDMAX),SS,NCON,AU,
!C      &              EMRAT,IPT,NUMDE,LPT,(CNAM(J),J=K,NCON),RPT,TPT
!C      ENDIF

!C       IF ( OUT .NE. 0 ) THEN
!C           CALL ERRPRT ( NROUT, 'st record not written because of error')
!C       ENDIF

!C      NROUT = 2

!C       IF(NCON .LE. OLDMAX) THEN
!C          WRITE(12,REC=2,IOSTAT=OUT)(CVAL(I),I=1,OLDMAX)
!C       ELSE
!C          WRITE(12,REC=2,IOSTAT=OUT)(CVAL(I),I=1,NCON)
!C       ENDIF

!C       IF ( OUT .NE. 0 ) THEN
!C           CALL ERRPRT ( NROUT, 'nd record not written because of error')
!C       ENDIF

!C     We're through.  Wrap it up.

!      CLOSE (12)
!      STOP ' OK'
      CLOSE (UNIT_de)

! ----------------------------------------------------------------------
! Module mdl_planets.f90 variables
! ----------------------------------------------------------------------
      TTL_2 = TTL
      CNAM_2 = CNAM
! ----------------------------------------------------------------------
!C       SS_1 = SS(1)
!C       SS_2 = SS(2)
!C       SS_3 = SS(3)
      DO SS_i = 1 , 3
         SS_value = SS(SS_i)
         SS_2(SS_i) = SS_value
      END DO
! ----------------------------------------------------------------------
      NCON_2 = NCON
      AU_2 = AU
      EMRAT_2 = EMRAT
      IPT_2 = IPT
      NUMDE_2 = NUMDE
      LPT_2 = LPT
      RPT_2 = RPT
      TPT_2 = TPT
      CVAL_2 = CVAL
!      DB_array
! ----------------------------------------------------------------------

      END

      SUBROUTINE  ERRPRT (I, MSG)

      CHARACTER*(*)  MSG
      INTEGER        I

      WRITE (*,200)  I, MSG
200   FORMAT('ERROR #',I8,2X,A50)

!      STOP ' ERROR '
      END

      SUBROUTINE  NXTGRP ( HEADER , UNIT_de )
!      SUBROUTINE  NXTGRP ( HEADER )

      CHARACTER*(*)  HEADER
      CHARACTER*12   BLANK
      INTEGER UNIT_de

!C     Start with nothing.

      HEADER = ' '

!C     The next non-blank line we encounter is a header record.
!C     The group header and data are seperated by a blank line.

      DO WHILE ( HEADER .EQ. ' ' )
!          READ (*,'(A)') HEADER
          READ (UNIT=UNIT_de,FMT='(A)') HEADER
      ENDDO

!C     Found the header.  Read the blank line so we can get at the data.

!      IF ( HEADER .NE. 'GROUP   1070' )READ (*, '(A)') BLANK
      IF ( HEADER .NE. 'GROUP   1070' ) READ (UNIT=UNIT_de,FMT='(A)') BLANK

      RETURN
      END


C    @(#)kmp_wydt.f	20.5 2/28/00
        integer function kmp_wydt (i,j)

        include 'ipfinc/parametr.inc'
        include 'ipfinc/bus.inc'
        include 'ipfinc/arcntl.inc'
        include 'ipfinc/qsdup.inc'
        include 'ipfinc/qksrt.inc'

        integer MAXWYEDELTA
        parameter (MAXWYEDELTA = 500)
        common /wye_delta/ num_wye_delta, lwye_delta(3,MAXWYEDELTA),
     &                     wye_delta(MAXWYEDELTA)

        integer MAXPTIRECORDS
        parameter (MAXPTIRECORDS = 16000)
        common /scratch/ count, array(4,MAXBUS), htable_2(MAXBUS),
     &                   nextptr_2(MAXBUS), count_newbus,
     &                   newbusno(MAXBUS), count_newzone,
     &                   newzoneno(MAXCZN), count_newown,
     &                   newownno(MAXOWN),  tempc(MAXPTIRECORDS),
     &                   sort_tempc(MAXPTIRECORDS), txflag(MAXBUS),
     &                   txindex(2,MAXWYEDELTA), procnode(MAXBUS),
     &                   vangle(MAXBUS), itemp(MAXBUS)
        integer array, count, htable_2, count_newbus, newbusno,
     &          count_newzone, newzoneno, count_newown, newownno,
     &          sort_tempc, txflag, txindex, procnode
        character tempc*80

        character id1*1, id2*1
c
c       Sort fields:
c       1. base1 (High to Low)
c       2. base2 (High to Low)
c       3. bus1
c       4. bus2
c       5. id
c
        k1 = lwye_delta(1,i)
        m1 = lwye_delta(1,j)
        kmp_wydt = -100.0 * (base(k1) - base(m1))
        if (kmp_wydt .eq. 0) then
          k2 = lwye_delta(2,i)
          m2 = lwye_delta(2,j)
          kmp_wydt = -100.0 * (base(k2) - base(m2))
          if (kmp_wydt .eq. 0) then
            kmp_wydt = kompr (bus(k1), bus(m1), junk)
            if (kmp_wydt .eq. 0) then
              kmp_wydt = kompr (bus(k2), bus(m2), junk)
              if (kmp_wydt .eq. 0) then
                id1 = char (lwye_delta(3,i))
                id2 = char (lwye_delta(3,j))
                kmp_wydt = kompr (id1, id2, junk)
              endif
            endif
          endif
        endif
        return
        end


!-----------------------------------------------------------------------
!     Program:       DIAGNO
!     Authors:       S. Lazerson (PPPL)
!     Date:          07/23/2012
!     Description:   The DIAGNO code calculates sythetic magnetic
!                    diagnostics for a given equilibrium using a
!                    virtual casing principle or a volume integral over
!                    the plasma current density.
!     References:    S.A. Lazerson, PPCF, Vol. 55, 025014 (2013)
!                    S.A. Lazerson, PPCF, Vol. 54, 122002 (2012)
!                    H.J. Gardner, Nuclear Fusion, Vol. 30, No. 8 (1990)
!                    V.D. Shfranov and L.E. Zakharov, Nuclear Fusion,
!                         Vol. 12 (1972)
!                    L.E. Zakharov, Nuclear Fusion, Vol. 13 (1973)
!                    M. Drevlak et al., Nuclear Fusion, Vol. 45 (2005)
!                    J.D. Hanson and S.P. Hirshman, Phys. Plas.,
!                         Vol 9, No. 10 (2002)
!
!-----------------------------------------------------------------------
      program diagno
!-----------------------------------------------------------------------
!     Libraries
!-----------------------------------------------------------------------
      USE diagno_runtime
      USE diagno_input_mod
      USE mpi_params
      USE mpi_inc
      USE virtual_casing_mod, ONLY: free_virtual_casing
!-----------------------------------------------------------------------
!     Local Variables
!          numargs      Number of input arguments
!          iseq         Index
!          arg_len      Length of input strings
!          arg1         Input file
!          args         Input arguments
!-----------------------------------------------------------------------
      implicit none
      logical :: lbench
      integer numargs,i,ier
      integer, parameter :: arg_len =256
      character*(arg_len) :: arg1
      character*(arg_len),allocatable,dimension(:) :: args
!-----------------------------------------------------------------------
!     Begin Program
!-----------------------------------------------------------------------
    myworkid = master
#if defined(MPI_OPT)
    CALL MPI_INIT(ierr_mpi)
    CALL MPI_COMM_DUP( MPI_COMM_WORLD, MPI_COMM_DIAGNO, ierr_mpi)
    CALL MPI_COMM_RANK(MPI_COMM_DIAGNO, myworkid, ierr_mpi)
    CALL MPI_COMM_SIZE(MPI_COMM_DIAGNO, nprocs_diagno, ierr_mpi)
    CALL MPI_COMM_SPLIT_TYPE(MPI_COMM_DIAGNO, MPI_COMM_TYPE_SHARED, 0, MPI_INFO_NULL, MPI_COMM_SHARMEM, ierr_mpi)
    CALL MPI_COMM_RANK(MPI_COMM_SHARMEM, myid_sharmem, ierr_mpi)
#endif
    IF (myworkid == master) THEN
       numargs=0
       arg1=''
       lbench  = .false.
       lverb   = .true.
       lvmec   = .false.
       lpies   = .false.
       lspec   = .false.
       lcoil   = .false.
       lvac    = .false.
       lmut    = .false.
       lskip_flux  = .FALSE.
       lskip_rogo  = .FALSE.

       ! First Handle the input arguments
       CALL GETCARG(1, arg1, numargs)
       ALLOCATE(args(numargs))
       ! Cycle through Arguments
       i=1
       DO WHILE (i <= numargs)
          call GETCARG(i,args(i),numargs)
          select case (args(i))
             case ("-noverb")  ! No Verbose Output
                lverb=.false.
             case ("-mutual")  ! Calc Mutual Induction
                lmut=.true.
             case ("-bench")  ! Calc Mutual Induction
                lbench=.true.
             case ("-vac")  ! Vacuum Fields only
                lvac=.true.
             case ("-vmec")
                i = i + 1
                lvmec = .true.
                lpies = .false.
                lspec = .false.
                CALL GETCARG(i,id_string,numargs)
             case ("-pies")
                i = i + 1
                lpies = .true.
                lvmec = .false.
                lspec = .false.
                CALL GETCARG(i,id_string,numargs)
             case ("-spec")
                i = i + 1
                lspec = .true.
                lpies = .false.
                lvmec = .false.
                CALL GETCARG(i,id_string,numargs)
             case ("-coil")
                i = i + 1
                lcoil  = .true.
                CALL GETCARG(i,coil_string,numargs)
             case ("-help","-h") ! Output Help message
               write(6,'(A,F5.2,A)')' Magnetic Diagnostic Code (v.',DIAGNO_VERSION,')'
               write(6,*)' Usage: xdiagno <options>'
               write(6,*)'    <options>'
               write(6,*)'     -vmec ext:    VMEC input/wout extension'
               !write(6,*)'     -pies ext:    PIES input extension (must have &INDATA namelist)'
               !write(6,*)'     -spec ext:    SPEC input extension (must have &INDATA namelist)'
               write(6,*)'     -coil file:   Coils. File'
               write(6,*)'     -vac:         Vacuum Field Only'
               write(6,*)'     -mutual:      Mutual Induction Calc'
               write(6,*)'     -noverb:      Supress all screen output'
               write(6,*)'     -help:        Output help message'
               stop
         end select
         i = i + 1
       END DO
       DEALLOCATE(args)
       id_string = TRIM(id_string)
       id_string = ADJUSTL(id_string)
       coil_string = TRIM(coil_string)
       coil_string = ADJUSTL(coil_string)
    ELSE
       lverb = .false. ! Shutup the workers
       lskip_flux  = .FALSE.
       lskip_rogo  = .FALSE.
    END IF

#if defined(MPI_OPT)
    CALL MPI_BCAST(id_string, 256, MPI_CHARACTER, master, MPI_COMM_DIAGNO, ierr_mpi)
    IF (ierr_mpi /= MPI_SUCCESS) CALL handle_err(MPI_BCAST_ERR, 'diagno_main', ierr_mpi)
    CALL MPI_BCAST(coil_string, 256, MPI_CHARACTER, master, MPI_COMM_DIAGNO, ierr_mpi)
    IF (ierr_mpi /= MPI_SUCCESS) CALL handle_err(MPI_BCAST_ERR, 'diagno_main', ierr_mpi)
    CALL MPI_BCAST(lbench, 1, MPI_LOGICAL, master, MPI_COMM_DIAGNO, ierr_mpi)
    IF (ierr_mpi /= MPI_SUCCESS) CALL handle_err(MPI_BCAST_ERR, 'diagno_main', ierr_mpi)
    CALL MPI_BCAST(lvmec, 1, MPI_LOGICAL, master, MPI_COMM_DIAGNO, ierr_mpi)
    IF (ierr_mpi /= MPI_SUCCESS) CALL handle_err(MPI_BCAST_ERR, 'diagno_main', ierr_mpi)
    CALL MPI_BCAST(lpies, 1, MPI_LOGICAL, master, MPI_COMM_DIAGNO, ierr_mpi)
    IF (ierr_mpi /= MPI_SUCCESS) CALL handle_err(MPI_BCAST_ERR, 'diagno_main', ierr_mpi)
    CALL MPI_BCAST(lspec, 1, MPI_LOGICAL, master, MPI_COMM_DIAGNO, ierr_mpi)
    IF (ierr_mpi /= MPI_SUCCESS) CALL handle_err(MPI_BCAST_ERR, 'diagno_main', ierr_mpi)
    CALL MPI_BCAST(lcoil, 1, MPI_LOGICAL, master, MPI_COMM_DIAGNO, ierr_mpi)
    IF (ierr_mpi /= MPI_SUCCESS) CALL handle_err(MPI_BCAST_ERR, 'diagno_main', ierr_mpi)
    CALL MPI_BCAST(lvac, 1, MPI_LOGICAL, master, MPI_COMM_DIAGNO, ierr_mpi)
    IF (ierr_mpi /= MPI_SUCCESS) CALL handle_err(MPI_BCAST_ERR, 'diagno_main', ierr_mpi)
    CALL MPI_BCAST(lmut, 1, MPI_LOGICAL, master, MPI_COMM_DIAGNO, ierr_mpi)
    IF (ierr_mpi /= MPI_SUCCESS) CALL handle_err(MPI_BCAST_ERR, 'diagno_main', ierr_mpi)
#endif

      ! Read the Input file
      if(lverb) write(6,'(A)')'============================================'
      if(lverb) write(6,'(A,F5.2,A)')'=========  D I A G N O  (v.',DIAGNO_VERSION,')  ========='
      if(lverb) write(6,'(A)')' - Reading input file'
      call read_diagno_input(id_string,ier)        !-----  Read diagno.control File -----

      IF (lbench) THEN
         CALL diagno_bench
      ELSE

         ! Read the equilibrium file
         IF (lvmec .and. .not. lvac) THEN
            if(lverb) write(6,'(A)')' - Reading equilibrium surface'
            CALL diagno_init_vmec
         ELSE IF (lpies .and. .not. lvac) THEN
            if(lverb) write(6,'(A)')' - Reading equilibrium surface'
            !CALL diagno_init_pies
            stop '!!!!!!! PIES Support pending !!!!!!'
         ELSE IF (lspec .and. .not. lvac) THEN
            if(lverb) write(6,'(A)')' - Reading equilibrium surface'
            CALL diagno_init_spec
         END IF

         ! Read the Coils file
         IF (lcoil) CALL diagno_init_coil

         ! Calculate diagnostic response
         if(lverb) write(6,*)' - Calculating diagnostic responses'
         IF (LEN_TRIM(bfield_points_file) > 1) CALL diagno_bfield
         IF (LEN_TRIM(bprobes_file) > 1) CALL diagno_bprobes
         IF (LEN_TRIM(mirnov_file) > 1) CALL diagno_mirnov
         IF (LEN_TRIM(seg_rog_file) > 1) CALL diagno_rogowski_new
         IF (LEN_TRIM(flux_diag_file) > 1) CALL diagno_flux

      END IF

      ! Do Cleanup
      IF (lvmec) THEN
         CALL free_virtual_casing(MPI_COMM_SHARMEM)
      ELSE IF (lpies) THEN
      ELSE IF (lspec) THEN
      ELSE IF (lcoil) THEN
      ELSE
      END IF
      if(lverb) write(6,*)'============  DIAGNO Complete  ==========='
      if(lverb) write(6,*)'=========================================='
#if defined(MPI_OPT)
    ierr_mpi=0
    CALL MPI_FINALIZE(ierr_mpi)
    IF (ierr_mpi /= MPI_SUCCESS) CALL handle_err(MPI_FINE_ERR, 'diagno_main', ierr_mpi)
#endif
!-----------------------------------------------------------------------
!     End Program
!-----------------------------------------------------------------------
      end program diagno


c $Id: getspin.f,v 1.1 2012/11/29 21:00:08 jwebb Exp $
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
      integer function getspin(iityp,itag)
c
c     Revision : 1.0
c
cinput ityp   : ID of particle
cinput itag   : flag for return value
c
c output: $2*J_{tot}$ of particle
c
c     This subroutine converts global ityp to maximum spin and optionally
c     chooses a random projection ({\tt itag=-1}).
c
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
c
      implicit none
      include 'comres.f'
c
      integer ityp,iityp,jtot,itag
      real*8 ranf
c
      ityp=abs(iityp)

      if(ityp.ge.nucleon.and.ityp.le.maxbar) then
         jtot=Jres(ityp)
      elseif(ityp.ge.offmeson.and.ityp.le.maxmeson) then
         jtot=Jmes(ityp)
      elseif(ityp.gt.1000.and.ityp.lt.1e8) then
c... quick and dirty fix for PDGID+1000 codes:
c... needs to be modified if spin is needed
         getspin=0
         return
      else
         write(6,*)'undefined total isospin in getspin:'
         write(6,*)'ityp: ',iityp
         stop
      endif
c
      if(itag.eq.1) then
         getspin=jtot
      elseif(itag.eq.-1) then
         getspin=jtot-2*int(ranf(0)*(jtot+1))
      else
         write(6,*)'itag-error in getspin.f'
         stop
      endif

      return
      end


      subroutine gentdp(iz,igrp,matnum,spec_num,sia_iter,
     2     ispecies,ncsp)
!***********************************************************************
!  Copyright, 2004,  The  Regents  of the  University of California.
!  This program was prepared by the Regents of the University of
!  California at Los Alamos National Laboratory (the University) under
!  contract No. W-7405-ENG-36 with the U.S. Department of Energy (DOE).
!  All rights in the program are reserved by the DOE and the University.
!  Permission is granted to the public to copy and use this software
!  without charge, provided that this Notice and any statement of
!  authorship are reproduced on all copies. Neither the U.S. Government
!  nor the University makes any warranty, express or implied, or
!  assumes any liability or responsibility for the use of this software.
C***********************************************************************
CD1
CD1  PURPOSE
CD1
CD1  This subroutine sets up for and calls the necessary routines to
CD1  solve the tracer equations with full jacobian (unsymmetric, 2n
CD1  by 2n).
CD1
C***********************************************************************
CD2
CD2  REVISION HISTORY
CD2
CD2 $Log:   /pvcs.config/fehm90/src/gentdp.f_a  $
!D2
!D2    Rev 2.5   06 Jan 2004 10:43:06   pvcs
!D2 FEHM Version 2.21, STN 10086-2.21-00, Qualified October 2003
!D2
!D2    Rev 2.4   29 Jan 2003 09:06:42   pvcs
!D2 FEHM Version 2.20, STN 10086-2.20-00
!D2
!D2    Rev 2.3   14 Nov 2001 13:09:34   pvcs
!D2 FEHM Version 2.12, STN 10086-2.12-00
!D2
!D2    Rev 2.2   06 Jun 2001 13:24:16   pvcs
!D2 FEHM Version 2.11, STN 10086-2.11-00
!D2
!D2    Rev 2.1   30 Nov 2000 12:02:40   pvcs
!D2 FEHM Version 2.10, STN 10086-2.10-00
!D2
!D2    Rev 2.0   Fri May 07 14:41:54 1999   pvcs
!D2 FEHM Version 2.0, SC-194 (Fortran 90)
CD2
CD2    Rev 1.13   Fri May 24 09:55:24 1996   hend
CD2 Updated trac for mdnodes
CD2
CD2    Rev 1.12   Thu Apr 25 12:17:32 1996   hend
CD2 Added 2 necessary lines after calls to coneq1
CD2
CD2    Rev 1.11   Thu Mar 21 13:18:24 1996   hend
CD2 Fixed for new coneq1 calling sequence
CD2
CD2    Rev 1.10   Mon Mar 04 15:04:58 1996   hend
CD2 Fixed for new solver
CD2
CD2    Rev 1.9   Fri Jan 12 17:49:16 1996   llt
CD2 changed mmgetblk agruments
CD2
CD2    Rev 1.8   Wed Jan 10 12:26:18 1996   hend
CD2 Added Prolog
CD2
CD2    Rev 1.7   08/18/95 10:18:10   llt
CD2 full_solution was already defined, removed for cray
CD2
CD2    Rev 1.6   08/07/95 13:50:46   awolf
CD2 New call requires matnum and nspecies and iz
CD2 Check is iz = 1 or 0 and devides routine work based on that
CD2 parameter. dpdpta calls now require and arguement "call dpdpta()
CD2
CD2    Rev 1.5   03/24/95 00:07:52   gaz
CD2 gaz took out reference to fdum1(not used)
CD2
CD2    Rev 1.3   05/11/94 16:07:16   llt
CD2 bug fixes - gaz
CD2
CD2    Rev 1.2   03/23/94 14:41:10   robinson
CD2 Additional cleanup of memory management
CD2
CD2    Rev 1.1   03/18/94 15:47:34   gaz
CD2 Added solve_new and cleaned up memory management.
CD2
CD2    Rev 1.0   01/20/94 10:24:30   pvcs
CD2 original version in process of being certified
CD2
CD2 c 18-mar-94 gaz added mmget..."b"
CD2
C***********************************************************************
CD3
CD3  REQUIREMENTS TRACEABILITY
CD3
CD3  2.3.4 Solute-transport equations
CD3  2.5.2 Solve nonlinear equation set at each time step
CD3
C***********************************************************************
CD4
CD4  SPECIAL COMMENTS AND REFERENCES
CD4
CD4 Requirements from SDN: 10086-RD-2.20-00
CD4   SOFTWARE REQUIREMENTS DOCUMENT (RD) for the
CD4   FEHM Application Version 2.20
CD4
C***********************************************************************
c Note dpdp is only implemented for one species

      use comcouple
      use comrxnb
      use comrxni
      use davidi
      use comji
      use comhi
      use comgi
      use comfi
      use comei
      use comdi
      use comci
      use combi
      use comdti
      use comai

      implicit none

      integer igrp, iz, matnum, ncsp, sia_iter, neqp1, idof_sol
      integer i
      real*8 fdm, fdum2, tolls, tollr
      real*8, allocatable :: sto5(:)
      real*8, allocatable :: dum(:)
      real*8, allocatable :: diag(:,:)
      real*8, allocatable :: diagi(:,:)
      real*8, allocatable :: rdum(:)
      integer iflg
      parameter(fdm=20.0)
      integer iter_counter,spec_num,full_solution,tol_value
      integer spec_numf
      integer matnumf
      integer spec_numm
      integer matnumm
      integer ispecies
      integer kgmres_sol
      integer totmat

      if(iz.eq.0) then
         call thermc(neq)
c
c     adjust storage
c

         neqp1=neq+1
         fdum2=0.
         matnumf = matnum
         spec_numf = spec_num
         call coneq1(0,matnumf,spec_numf)
         matnumm = matnum+ncsp*2+1
         spec_numm = spec_num+1
         call coneq1(neq,matnumm,spec_numm)
c        if (imdnode.ne.0) call coneq1mdnode(matnum,spec_num)
c
c     now get coupling for influence terms
c
         call dpdpta(ispecies,spec_numf,matnumf,spec_numm,matnumm)

      elseif(iz.eq.1) then
c
c     normalize the equations
c
         totmat = ncsp*2
         idof_sol = totmat
         allocate(diag(idof_sol,idof_sol))
         allocate(diagi(idof_sol,idof_sol))
         allocate(rdum(idof_sol))
         call normal_dof(neq,a,bp,nelm,nmat,nrhs,nelmdg,
     &        nmatb,idof_sol,diag,diagi,rdum,0,fdum2)
         deallocate(diag)
         deallocate(diagi)
         deallocate(rdum)
         if(nmatb(1).lt.0 ) then
            if (iout .ne. 0) then
               write(iout,*) '   '
               write(iout, 100)
               write(iout,*) '   '
               write(iout,'(i8,3g12.3)')
     &              abs(nmatb(1)),(cord(abs(nmatb(1)),i),i=1,3)
            end if
            if(iptty.gt.0)then
               write(iptty,*) '   '
               write(iptty, 100)
               write(iptty,*) '   '
               write(iptty,'(i8,3g12.3)')
     &              abs(nmatb(1)),(cord(abs(nmatb(1)),i),i=1,3)
            endif
            iad=maxit
            return
         endif
 100     format ('*singular matrix found during normalization *')

         fdum=sqrt(fdum2)
         if(sia_iter.eq.0)fzero(igrp)=fdum
         tolls = max(fzero(igrp),min(g1*fdum,g2*fdum2))
         tollr=g3*tolls
         iter=maxsolve
         call storage_derivatives(1,1)

         if(irdof.eq.0.or.irdof.ne.0) then
            if (idof_sol.lt.6) then
               allocate(dum(neq*idof_sol*4))
            else if (idof_sol.eq.6) then
               allocate(dum(neq*idof_sol*5))
            else
               allocate(dum(neq*idof_sol*idof_sol))
            endif

            if (igauss .gt.1) then
               call solve_new(neq,a,b,bp,nmat_sol,nb,nrhs_sol,
     1              nelm,nop,north,tollr,irb,iirb,npvt,gmres,
     2              dum,piv,h,c,ss,g,y,iter,iback,idof_sol,
     3              iptty,maxor,accm)
            else
               call solve_new(neq,a,b,bp,nmat_sol,nmat_sol,nrhs_sol,
     1              nelm,nelm,north,tollr,irb,iirb,npvt,gmres,
     2              dum,piv,h,c,ss,g,y,iter,iback,idof_sol,
     3              iptty,maxor,accm)
            end if
            itert=itert+iter
            minkt=minkt+mink
         else
            allocate(sto5(neq*2))
            if (igauss .gt.1) then
               call  rdof_new(neq,a,b,bp,nmat,nb,nrhs,nelm,nop,north
     *              ,tollr,irb,iirb,npvt,gmres,dum,piv
     *              ,h,c,ss,g,y,iter,iback,2,iptty,maxor
     *              ,overf,irdof,icoupl,0,sto5,accm)
            else
               call  rdof_new(neq,a,b,bp,nmat,nmat,nrhs,nelm,nelm,north
     *              ,tollr,irb,iirb,npvt,gmres,dum,piv
     *              ,h,c,ss,g,y,iter,iback,2,iptty,maxor
     *              ,overf,irdof,icoupl,0,sto5,accm)
            end if
            deallocate(sto5)
            itert=itert+iter
            minkt=minkt+mink
         endif
         deallocate(dum)
         call storage_derivatives(0,1)
 999     continue
      endif

      return
      end


      SUBROUTINE stkex( buf, lbuf, ibuf, scr, lscr, iscr,
     &                    istop, nready )
c mod Oct 02 - Trim/median stack bombed when first trace was zero
c mod 11 Mar 03 - Add panel.
c mod Apr 09 - Allow unsigned nsamps
c mod 15 June 09 - Apr 09 was done wrong!
c mmod 12 Apr 10 - Use end mute integer mils rather than real second (word 48)
c
      PARAMETER (IAPSIZ = 500000)
      DIMENSION buf(111), lbuf(111), ibuf(111),
     &          scr(111), lscr(111), iscr(111)
      INTEGER*2 ibuf, iscr
      COMMON /readt/ itunit, numhdr, numdat, ihunit, ireeln, jntrcs,
     *               ifmt, nskip, secs, lrenum, isrcf, idtype,
     *               nfskip, jform, itxsi, itxdel, nfktrc, norigtr,
     *               nrskip, nfiles
      COMMON /sioap/ iasgnd, irelse, in, iout, nextad, lapsiz, ifree,
     *     iuseap
      COMMON /segyptr/ llsegptr, lrseqptr, lshotptr, lshtrptr, lrpnptr,
     *                 lrptrptr, itridptr, ldisptr,  lwbdptr,  lsxcoptr,
     *                 lrxcoptr, idelmptr, istmptr,  iendmptr, isampptr,
     *                 isiptr,   iyrptr,   idayptr,  ihrptr,   iminptr,
     *                 isecptr,  igmtptr,  ldelsptr, lsmusptr, lemusptr,
     *                 lsisptr,  lwbtsptr, lgatptr,  lssmsptr, lesmsptr,
     *                 lsbptr,   ifoldptr, icvleptr, lespnptr
      COMMON /trim/ lunparams, nlists, nwrds, luntrim
      COMMON /apmem/ apdata(IAPSIZ)
      PARAMETER (isize = 262144 )
      COMMON /transp/ tarray(isize)
      DIMENSION xxt(90), trhdr(60)
      DATA mlists/0/, mindel/40000/, last/0/, ntraces/0/
      SAVE

      IF( istop .EQ. -1 ) GOTO 90                                       ! means end, but no trace in buf
      nready = 0
      IF( ibuf(itridptr) .EQ. 2 .AND. lbuf(51) .NE. -1 ) RETURN
      IF( lbuf(7) .EQ. 0 ) THEN
          no = lbuf(3)
          itrno = lbuf(4)
      ELSE
          no = lbuf(6)
          itrno = lbuf(7)
      ENDIF
      si = buf(lsisptr)
c      nsamps = ibuf(isampptr)
      nsamps = numdat
      delay = buf(ldelsptr)
      idelay = NINT(delay / buf(lsisptr)) + 1
      IF( mlists .EQ. 0 ) THEN
          CALL podisc( lunparams, 1, 0 )                                ! get the first parameter list from disk
          CALL rddisc( lunparams, lscr, nwrds, istat )
          mlists = mlists + 1
          lprint = lscr(1)
          savein = scr(2)
          saveout = scr(3)
          IF( savein .NE. 0 ) pct = 1. - (savein / 100.)
          IF( saveout .NE. 0 ) pct = 1. - (saveout / 100.)
          panel = scr(4)
          nxxts = lscr(6)
          IF( nxxts .GT. 0 ) THEN
              DO i = 1, nxxts
                 xxt(i) = scr(5+i)
              ENDDO
          ENDIF
c****     make sure the "ap" gets initialize
          CALL inap( buf(numhdr+1), nsamps )
      ENDIF
      iout = 0                                                          ! force the data out of the ap
      CALL rlseap( buf(numhdr+1), nsamps )
c****
c****  Collect all the traces on disk until End-of-Gather or End-of-Job
c****
      nwrds = nsamps + numhdr
      CALL wrdisc( luntrim, buf(1), nwrds )
      ntraces = ntraces + 1
      mindel = MIN( mindel, idelay )
      last = MAX( last, idelay-1+nsamps )
      IF( ntraces .EQ. 1 ) THEN                                         ! save the first trace header
          DO i = 1, 60
             trhdr(i) = buf(i)
          ENDDO
      ENDIF
      IF( panel .EQ. 0. .AND. lbuf(51) .NE. -1 .AND. istop .EQ. 0 ) THEN
          nready = 0
          RETURN
      ENDIF
c****
c**** A stack panel is a progressive stack.  Each input trace of the
c**** gather is added to the stack and the current stacked trace is
c**** output.  Let's do the entire sum for each new trace so that
c**** things like mutes can be honored.
c****
      IF( panel .NE. 0. ) THEN
c****     The summed output goes in buf.
c****     The trace from disk goes in scr.
c****     The divisor goes in apdata
c****     let's assume all traces in the gather have the same trace
c****     length and delay.  Should/could check, but ....
c****     So nsamps is still good!
          DO i = 1, nsamps
             buf(numhdr+i) = 0.
             apdata(nextad+i-1) = 0.
          ENDDO
          CALL podisc( luntrim, 0, 0 )
          DO j = 1, ntraces
             CALL rddisc( luntrim, scr, numhdr+nsamps, istat )
c             muteend = NINT((scr(48)-delay) / si)
             muteend = NINT((iscr(57)*1000.-delay) / si)
             DO i = muteend+1, nsamps-muteend
                buf(numhdr+i) = buf(numhdr+i) + scr(numhdr+i)
                apdata(nextad+i-1) = apdata(nextad+i-1) + 1.
             ENDDO
          ENDDO
          DO i = 1, nsamps
             buf(numhdr+i) = buf(numhdr+i) / apdata(nextad+i-1)
          ENDDO
          lbuf(7) = ntraces
          in = 0                                                        ! the data is not in the "ap"
          nready = 1
          RETURN
      ENDIF
c****
c**** Do the whole dataset, make sure everything has the same delay
c**** and length.  Start by adding the pads.
c****
   90 CONTINUE
      CALL podisc( luntrim, 0, 0 )
      nsamps = last - mindel+1
c****
c****  trim stack here  (save inner traces or save outer traces)
c****
      IF( savein+saveout .NE. 0. ) THEN
          IF( nsamps*ntraces+nextad .GT. IAPSIZ ) THEN
              PRINT *,' ***  ERROR  ***  Not enoygh memory for TRIM.'
              PRINT *,' Decrease the record length.'
              PRINT *,' Make sure there is an end-of-gather flag.'
              STOP
          ENDIF
          index = nextad
          DO i = 1, ntraces
             CALL rddisc( luntrim, scr, numhdr, istat )
c             npts = iscr(isampptr)
             CALL ushort2long( iscr(isampptr), npts )
             delay = scr(ldelsptr)
             idelay = NINT(delay / scr(lsisptr))
c****        make every trace start at the same time
             IF( idelay .GT. mindel ) THEN
                 n = idelay - mindel
                 DO j = 1, n
                    apdata(index+j) = 0.
                 ENDDO
                 index = index + n
             ENDIF
             CALL rddisc( luntrim, apdata(index+1), npts, istat )
             index = index + npts
c****        make sure every trace ends at the same time
c****          last is from 1, as if no delay
             n = last - npts
             IF( n .GT. 0 ) THEN
                 DO j = 1, n
                    apdata(index+j) = 0.
                 ENDDO
                 index = index + n
             ENDIF
          ENDDO
          DO i = 1, nsamps
             n = 0
             index = nextad
             DO j = 1, ntraces
                IF( apdata(index+i) .NE. 0. ) THEN
                    n = n + 1
                    scr(n) = apdata(index+i)
                ENDIF
                index = index + nsamps
             ENDDO
             buf(numhdr+i) = 0.
             IF( n .LE. 0 ) GOTO 1000
             rn = FLOAT(n)
             rn2 = rn / 2.
             mid = NINT(rn2)
             itemp = rn*pct/2.
             divisor = 0.
             IF( n .GT. 1 ) CALL sort( n, scr )
             n1 = mid - itemp
             IF( n1 .LE. 0 ) n1 = 1
             n2 = mid + itemp
             IF( n2 .GT. n ) n2 = n
             IF( AND(lprint,8) .NE. 0 ) PRINT *,
     &          ' n=',n,' n1=',n1,' n2=',n2,' itemp=',itemp
             IF( saveout .EQ. 0. ) THEN
                 DO j = n1, n2
                    buf(numhdr+i) = buf(numhdr+i) + scr(j)
                    divisor = divisor + 1.
                 ENDDO
             ELSE
                 DO j = 1, n1
                    buf(numhdr+i) = buf(numhdr+i) + scr(j)
                    divisor = divisor + 1.
                 ENDDO
                 DO j = n2, n
                    buf(numhdr+i) = buf(numhdr+i) + scr(j)
                    divisor = divisor + 1.
                 ENDDO
             ENDIF
             IF( divisor .NE. 0. ) buf(numhdr+i) = buf(numhdr+i)/divisor
 1000        CONTINUE
         ENDDO
      ENDIF
c****
c****   XXT here - inner/outer muting
c****
c	 print *,' nxxts=',nxxts,' xxt=',(xxt(i),i=1,6)
      IF( nxxts .GT. 0 ) THEN
          DO i = 1, last
             scr(i) = 0.                                                ! the output trace
             apdata(nextad+i) = 0.                                      ! the divisor trace
          ENDDO
          DO i = 1, ntraces
             CALL rddisc( luntrim, buf, numhdr, istat )
             si = buf(lsisptr)
c             nsamps = ibuf(isampptr)
             CALL ushort2long( ibuf(isampptr), nsamps )
             delay = buf(ldelsptr)
             idelay = NINT(delay / buf(lsisptr)) + 1
             x = ABS(FLOAT(lbuf(ldisptr)))
c	 print *,' si=',si,' nsamps=',nsamps,' idelay=',idelay
             CALL rddisc( luntrim, buf, nsamps, istat )
             indexo = idelay - mindel
             indexap = nextad + indexo
             ixxt = 1
c	 print *,' input=',(buf(j),j=1,10)
             DO j = 1, nsamps
                time = FLOAT(j-1)*si + delay
c	 print *,' time=',time,' ixxt=',ixxt,' xxt=',xxt(ixxt+2)
                IF( time .GE. xxt(ixxt+2) .AND. ixxt+3 .LT. nxxts )
     &              ixxt = ixxt + 3
                IF( x .GE. xxt(ixxt) .AND. x .LE. xxt(ixxt+1) ) THEN
                    scr(indexo+j) = scr(indexo+j) + buf(j)
                    apdata(indexap+j) = apdata(indexap+j) + 1
                ENDIF
             ENDDO
          ENDDO
c	 print *,' lats=',last
          DO i = 1, last
             IF( apdata(nextad+i) .NE. 0. ) THEN
                 buf(numhdr+i) = scr(i) / apdata(nextad+i)
             ELSE
                 buf(numhdr+i) = 0.
             ENDIF
          ENDDO
      ENDIF
c****
c****
c**** Do the trace header before leaving
c****
      DO i = 1, 60
         buf(i) = trhdr(i)
      ENDDO
      lbuf(3) = 0
      lbuf(4) = 0
      lbuf(6) = no
      lbuf(7) = 1
      lbuf(10) = 0
      lbuf(15) = 1
c****  the fold is not ntraces, but worry about it later
      lbuf(17) = NINT(divisor)                                          ! the number of traces in the stack (fold)
      ibuf(55) = NINT(mindel*si*1000.)
      ibuf(58) = nsamps
      numdat = nsamps
      lbuf(51) = 0
      mindel = 40000
      last = 0
      ntraces = 0
      notrcs = 1
      nready = 1
      CALL podisc( luntrim, 0, 0 )
      RETURN
      END