       subroutine rdfbin(fbfile, nphx, nex, npathx, nlegx,
     $      npaths, ne, npot, ihole, iorder, ilinit,
     $      rnrmav, xmu, edge,  potlbl, iz, phc, ck, xk, index,
     $      nleg, deg, reff, crit, ipot,
     $      rat, beta, eta, ri, achi, phchi)
c
c read path information from PAD-format feff.pad
c  arguments:
c   fbile   name of feff.pad file                             [in]
c   nphx    dimension of  potlbl, iz (both (0:nphx)           [in]
c             max # of potentials
c   nex     dimension of many energy arrays                   [in]
c             max # of energy points
c   npathx     dimension of index,nleg,ipot,deg,reff,crit,    [in]
c           rat,beta, eta, ri, achi, phchi
c             max # of paths
c   nlegx  dimension of  ipot, rat, beta,eta,ri              [in]
c            max # of legs in a path
c   npaths  number of paths read                             [out]
c   ne      maximum number of energy points read             [out]
c   npot    number of potentials read                        [out]
c   rnrmav  average norman radius                            [out]
c   edge    shift in edge energy (?)                         [out]
c   iorder  order of genfmt matrix used                      [out]
c   potlbl  array of potential labels                        [out]
c   iz      array of atomic numbers for potentials           [out]
c   phc     array of central atom phase shift (complex)      [out]
c   ck      array of wavenumbers/momentum (complex)          [out]
c   xk      array of wavenumbers/momentum (real)             [out]
c   index   array of path indices                            [out]
c   nleg    array:  number of legs in path                   [out]
c   deg     array:  path degeneracy                          [out]
c   reff    array:  half path length of path                 [out]
c   crit    array:  importance factor for path               [out]
c   ipot    array:  pots, in order, that make up the path    [out]
c   rat     array:  atomic positions of atoms in path        [out]
c   beta    array:  euler angle for path                     [out]
c   eta     array:  second euler angle for path              [out]
c   ri      array:  path leg distances for path              [out]
c   achi    array:  amplitude of chi for path                [out]
c   phchi   array:  phase of chi for path                    [out]
c
c notes:
c   the data in feff.pad is written completely in printable
c   ascii characters.  The file is however, highly formatted
c   and kept fairly small.  all text is stored as is, but most
c   numerical data in arrays (both real and complex) is stored
c   in a special Packed Ascii Data (PAD) format which uses 6
c   printable characters to represent a real number.
c
c   special markers in the first 1 or 2 characters of each line
c   give hints about the contents of the line:
c      #_    top 2 lines.  The first line must begin "#_feff.pad"
c      #"    title lines / plain text
c      #&    misc info about potentials, calc method
c      #@    potential labels and iz
c      ##    path index,  deg, reff, crit, ipots involved
c      !     PAD characters to be read as a real array
c      $     PAD characters to be read as a complex array
c
c copyright (c) 1999  matt newville:  jan 1999
c modified by alex ankudinov: feb 2000; few fixes for feff8.2
c------------------------------------------------------------------
       include '../HEADERS/const.h'
       integer nphx, nex, npathx, nlegx, npaths
       integer i, j, ivers, nexmax
       character*(*) fbfile
       character*(*) potlbl(0:nphx), filnam*128, str*128
c       character*(*) msg*256
       integer iorder,  index(npathx), nleg(npathx)
       integer ne, npot, ipot(nlegx,npathx), iz(0:nphx)
       integer istrln, ier1, ier2, ier3, nwords, npadx, nwordx
       real    deg(npathx), reff(npathx), crit(npathx)
       real    rnrmav, edge, xk(nex)
       double precision tmpdp
       parameter(nwordx = 20, nexmax = 256)
       character*20 words(nwordx)
       real     rat(3,nlegx,npathx), beta(nlegx,npathx)
       real     eta(nlegx,npathx),  ri(nlegx,npathx)
       real     achi(nex,npathx), phchi(nex,npathx)
c       real tmpr(nexmax)
       complex  phc(nex), ck(nex)
c       complex tmpc(nexmax)
       external  istrln

c open feff.pad
       filnam = ' '
       filnam = fbfile
       call triml(filnam)
       il     = istrln(filnam)
       if (filnam.eq.' ') filnam = 'feff.pad'
cc       print*, ' RDFBIN!  ', filnam(1:il),':',il
       open (unit=3, file=filnam, status='old', err=450)
 10    format(a)
c first line, must match  "#_feff.pad"
       read(3,10,err=920) str
       call triml(str)
       if ((str(1:10).ne.'#_feff.pad')) go to 900
c check version of feff.pad : only support version 3 here!!
       ivers = 0
       if ((str(1:14).eq.'#_feff.pad fil')) ivers = 1
       if ((str(1:14).eq.'#_feff.pad v02')) ivers = 2
       if ((str(1:14).eq.'#_feff.pad v03')) ivers = 3
       if (ivers.ne.3) go to 930
c second line:   npot, ne
       read(3,10,err=920) str
       call triml(str)
       if ((str(1:2).ne.'#_')) go to 900
       nwords = 3
       str    = str(3:)
       call bwords(str,nwords,words)
       if (nwords.ne.3) go to 905
       call str2in(words(1), npot,  ier1)
       call str2in(words(2), ne,    ier2)
       call str2in(words(3), npadx, ier3)
       if ((ier1.ne.0).or.(ier2.ne.0).or.(ier3.ne.0)) go to 910

c  read in misc stuff:  (rnrmav, edge, iorder )
       read(3,10,err=920) str
       call triml(str)
       if (str(1:2).ne.'#&') go to 900
       nwords = 6
       str    = str(3:)
       call bwords(str,nwords,words)
       if (nwords.ne.6) go to 905
       call str2in(words(1), ihole,  ier1)
       call str2in(words(2), iorder, ier2)
       call str2in(words(3), ilinit, ier3)
       if ((ier1.ne.0).or.(ier2.ne.0).or.(ier3.ne.0)) go to 910
       call str2re(words(4), rnrmav, ier1)
       call str2re(words(5), xmu   , ier2)
       call str2re(words(6), edge  , ier3)
       if ((ier1.ne.0).or.(ier2.ne.0).or.(ier3.ne.0)) go to 910
c  read pot label and iz line
       read(3,10,err=920) str
       call triml(str)
       if (str(1:2).ne.'#@') go to 900
       nwords = 2 * npot + 2
c  note: potlbl cannot be blank!!
       str    = str(3:)
       call bwords(str, nwords, words)
       if (nwords.ne.(2 + 2*npot)) go to 905
       do 200 i = 0, npot
          potlbl(i) = words(i+1)
          iz(i) = -1
          call str2in(words(2+npot+i),iz(i),ier1)
          if (ier1.ne.0)  go to 910
 200   continue

c read  numerical data that are the same for all paths
       call rdpadc(3,npadx, phc, ne)
       call rdpadc(3,npadx, ck,ne)
       call rdpadr(3,npadx, xk,ne)
       npaths = 0
c now, for each path:
       do 300  i = 1, npathx
          index(i) = 0
c  read path  info "##" line  and retrieve all the stuff from it
          read(3,10,end=450,err=920) str
          call triml(str)
          if (str(1:2).ne.'##')   go to 900
          nwords = nwordx
          str    = str(3:)
          call bwords(str,nwords,words)
          call str2in(words(1),  index(i), ier1)
          call str2in(words(2),  nleg(i), ier2)
          call str2re(words(3),  deg(i), ier3)
          if ((ier1.ne.0).or.(ier2.ne.0).or.(ier3.ne.0)) go to 910
          call str2dp(words(4),  tmpdp, ier2)
          reff(i) = real(tmpdp / bohr)
          call str2dp(words(5),  tmpdp, ier3)
          crit(i) = real(tmpdp)
          if ((ier1.ne.0).or.(ier2.ne.0).or.(ier3.ne.0)) go to 910
          npaths = npaths + 1
          do 230 j = 1, nleg(i)
             call str2in(words(5+j),ipot(j,i),ier1)
             if (ier1.ne.0) go to 910
 230      continue
c
c  next, read padded arrays for rat,beta, ..., achi, phchi
          call rdpadr(3,npadx, rat(1,1,i),3*nleg(i))
          call rdpadr(3,npadx, beta(1,i),   nleg(i))
          call rdpadr(3,npadx, eta(1,i),    nleg(i))
          call rdpadr(3,npadx, ri(1,i),     nleg(i))
          call rdpadr(3,npadx, achi(1, i),  ne)
          call rdpadr(3,npadx, phchi(1, i), ne)
c  fill in rest of achi and phchi with zeros
          do 270 j = ne+1, nex
             achi(j,i)  = 0
             phchi(j,i) = 0
 270      continue
 300    continue
 450    continue
       close(3)
cc       print*, ' RDFBIN done!'
       return
 900   call wlog (' -- rdfbin error: wrong format : at line')
       go to 990
 905   call wlog (' -- rdfbin error: missing data : at line')
       go to 990
 910   call wlog (' -- rdfbin error:   bad data   : at line')
       go to 990
 920   call wlog (' -- rdfbin error: unknown error: at line')
       go to 990
 930   call wlog (' -- rdfbin error: unknown version of feff.pad')
       go to 990

 990   call wlog (str)
       call par_stop(' -- fatal error reading feff.pad -- ')
       end


C$Procedure PCKEUL ( PCK, get Euler angles at time from PCK file )

      SUBROUTINE PCKEUL ( BODY, ET, FOUND, REF, EULANG )

C$ Abstract
C
C      This routine is obsolete.  It supports only the type 02 binary
C      PCK format.  It is maintained only for backward compatibility
C
C      Return Euler angles and their derivatives and their reference
C      frame, given an input time and body and reference frame from
C      a PCK binary file.
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$ Required_Reading
C
C      NAIF_IDS
C     ROTATION
C      TIME
C      PCK
C
C$ Keywords
C
C      TRANSFORMATION
C      ROTATION
C
C$ Declarations

      INTEGER              BODY
      DOUBLE PRECISION     ET
      LOGICAL              FOUND
      CHARACTER*(*)        REF
      DOUBLE PRECISION     EULANG   ( 6 )

C$ Brief_I/O
C
C      VARIABLE  I/O  DESCRIPTION
C      --------  ---  --------------------------------------------------
C      BODY       I   ID code of body
C      ET         I   Epoch of transformation
C      FOUND      O   True if ET, BODY found in a PCK file
C      REF        O   Name of inertial ref. frame of state
C      EULANG     O   Euler angles and their derivatives.
C
C$ Detailed_Input
C
C      BODY        is the integer ID code of the body for which the
C                  state transformation matrix is requested. Bodies
C                  are numbered according to the standard NAIF
C                  numbering scheme.  The numbering scheme is
C                  explained in the NAIF_IDS required reading file.
C
C      ET          is the epoch at which the state transformation
C                  matrix is requested.
C
C$ Detailed_Output
C
C      FOUND       if the Euler angles for the requested time
C                  and body are found in a PCK binary file,
C                  FOUND is true.  Otherwise, it's false.
C
C      REF         is the name of an inertial ref. frame.
C                  (See the routine CHGIRF for a full list of names.)
C
C      EULANG      the Euler angles and their derivatives at
C                  time ET. The rotation matrix is
C                  [ EULANG(3) ]  [EULANG(2)] [EULANG(1)]
C                               3            1           3
C
C                  and   dEULANG(1)/dt = EULANG(4)
C                        dEULANG(2)/dt = EULANG(5)
C                        dEULANG(3)/dt = EULANG(6)
C
C$ Parameters
C
C      None.
C
C$ Exceptions
C
C      None.
C
C$ Files
C
C      None.
C
C$ Particulars
C
C     None.
C
C$ Examples
C
C     Here we load a binary PCK files and use PCKEUL to get the
C     Euler angles.
C
C     C
C     C  Load binary PCK file.
C     C
C        CALL PCKLOF ('example.pck', HANDLE)
C
C     C  Call routine to get Euler angles phi, delta, w.
C
C        CALL PCKEUL ( BODY, ET, FOUND, REF, EULANG )
C
C     The Euler angles and their derivatives are returned
C     in EULANG.
C
C$ Restrictions
C
C      A binary PCK kernel must be loaded with PCKLOF before
C      calling this routine.
C
C$ Literature_References
C
C      None.
C
C$ Author_and_Institution
C
C      K. S. Zukor   (JPL)
C
C$ Version
C
C-    SPICELIB Version 2.0.1, 03-JAN-2014 (EDW)
C
C        Minor edits to Procedure; clean trailing whitespace.
C        Removed unneeded Revisions section.
C
C-    SPICELIB Version 2.0.0, 21-MAR-1995 (KSZ)
C
C        PCKEUL modified to check in.  PCKMAT takes
C        over for PCKEUL in many cases.  REF now a character.
C
C-    SPICELIB Version 1.1.0, 18-OCT-1994 (KSZ)
C
C        Fixed bug which incorrecly modded DW by two pi.
C
C-    SPICELIB Version 1.0.0, 11-MAR-1994 (KSZ)
C
C-&

C$ Index_Entries
C
C     get Euler angles and their derivatives
C
C-&

C
C     SPICELIB functions
C
      LOGICAL               RETURN

C
C     Parameters
C
C     ND    number of double precision components of descriptor
C     NI    number of integer components of descriptor
C     NR    component number of reference frame in integer
C           portion of descriptor
C     NS    size of a packed PCK segment descriptor
C     NT    component number of data type in integer portion
C           of descriptor
C
      INTEGER               ND
      PARAMETER           ( ND      =   2 )

      INTEGER               NI
      PARAMETER           ( NI     =    5 )

      INTEGER               NR
      PARAMETER           ( NR      =   2 )

      INTEGER               NS
      PARAMETER           ( NS      =   5 )

      INTEGER               NT
      PARAMETER           ( NT      =   3 )

      INTEGER               FILEN
      PARAMETER           ( FILEN   = 128 )

C
C  Local Variables
C

      CHARACTER*(40)  IDENT

      DOUBLE PRECISION      DCD     ( ND )
      DOUBLE PRECISION      DESCR   ( NS )
      DOUBLE PRECISION      RECORD  ( 130 )

      INTEGER     TYPE
      INTEGER     HANDLE
      INTEGER     ICD ( NI )
      INTEGER     IREF

C
C     Standard SPICE Error handling.
C
      IF ( RETURN () ) THEN
         RETURN
      ELSE
         CALL CHKIN ( 'PCKEUL' )
      END IF

C
C     Get a segment applicable to a specified body and epoch.
C
      CALL PCKSFS ( BODY, ET, HANDLE, DESCR, IDENT, FOUND )

      IF ( FOUND ) THEN

C
C        Look at parts of the descriptor.
C
         CALL DAFUS ( DESCR, ND, NI, DCD, ICD )
         TYPE   = ICD( NT )
         IREF   = ICD( NR )
         CALL IRFNAM ( IREF, REF )

         IF ( TYPE .EQ. 2 ) THEN

C
C           Read in Chebyshev coefficients from segment.
C
            CALL PCKR02 ( HANDLE, DESCR, ET, RECORD )

C
C           Call evaluation routine to get Euler angles
C           phi, delta, w.
C
            CALL PCKE02 ( ET, RECORD, EULANG )

         ELSE
C
C           If appropriate data was not found, found is false.
C
            FOUND = .FALSE.

         END IF

      END IF

      CALL CHKOUT ( 'PCKEUL' )
      RETURN
      END


!> \file
!> \author Merryn Tawhai, Alys Clark
!> \brief This module handles all geometry read/write/generation.
!>
!> \section LICENSE
!>
!>
!> Contributor(s):
!>
!>\Description
!> This module handles all all geometry read/write/generation.

module indices
  implicit none
!parameters
  ! indices for elem_ordrs
  integer :: num_ord=3,no_gen=1,no_hord=2,no_sord=3,no_type=4

  ! indices for node_fields
  integer :: num_nj,nj_aw_press,nj_bv_press,nj_conc1,&
     nj_conc2, nj_conc3,nj_mass,nj_loss,nj_loss_dif,&
     nj_loss_sed, nj_loss_imp
  ! indices for elem_field
  integer ::num_ne,ne_radius,ne_length,ne_vol,&
      ne_resist,ne_t_resist,ne_Vdot,ne_Vdot0,ne_a_A,&
       ne_dvdt,ne_radius_in,ne_radius_in0,&
       ne_radius_out,ne_radius_out0,ne_group,ne_Qdot,&
       ne_mass,ne_flow,ne_part_vel

  ! indices for unit_field
  integer :: num_nu,nu_vol,nu_comp,nu_conc2,nu_Vdot0,nu_Vdot1, &
       nu_Vdot2,nu_dpdt,nu_pe,nu_vt,nu_air_press,nu_conc1,nu_vent,&
       nu_vd,nu_perf,nu_blood_press,nu_conc3

  !indices for DPI
  integer :: nu_flow0, nu_flow1, nu_dpdt_0

  !indices for gas exchange field
! indices for gasex_field
  integer,parameter :: num_gx = 12
  integer,parameter :: ng_p_alv_o2=1      ! index for alveolar partial pressure of O2
  integer,parameter :: ng_p_alv_co2=2     ! index for alveolar partial pressure of CO2
  integer,parameter :: ng_p_ven_o2=3      ! index for local venous partial pressure of O2
  integer,parameter :: ng_p_ven_co2=4     ! index for local venous partial pressure of CO2
  integer,parameter :: ng_p_cap_o2=5      ! index for local end capillary partial pressure of O2
  integer,parameter :: ng_p_cap_co2=6     ! index for local end capillary partial pressure of CO2
  integer,parameter :: ng_source_o2=7     ! index for source (flux) of O2
  integer,parameter :: ng_source_co2=8    ! index for source (flux) of CO2
  integer,parameter :: ng_Vc=9            ! index for unit's capillary blood volume
  integer,parameter :: ng_sa=10           ! index for unit's capillary surface area
  integer,parameter :: ng_tt=11           ! index for transit time in unit
  integer,parameter :: ng_time=12         ! index for time elapsed for RBC in capillaries

  !model type
  character(len=60) :: model_type

public num_ord,no_gen,no_hord,no_sord,no_type

public num_nj,nj_aw_press,nj_bv_press, nj_conc1,nj_conc2,nj_conc3,&
       nj_mass,nj_loss,nj_loss_dif,nj_loss_sed,nj_loss_imp

public num_ne,ne_radius,ne_length,ne_vol,&
      ne_resist,ne_t_resist,ne_Vdot,ne_Vdot0,ne_a_A,&
      ne_dvdt,ne_radius_in,ne_radius_in0,ne_radius_out,&
      ne_radius_out0,ne_group,ne_Qdot,ne_mass,ne_flow,ne_part_vel

public num_nu,nu_vol,nu_comp, nu_conc2,nu_Vdot0,nu_Vdot1, &
       nu_Vdot2,nu_dpdt,nu_pe,nu_vt,nu_air_press,&
       nu_conc1,nu_vent,nu_vd,&
       nu_perf,nu_blood_press,nu_conc3

public num_gx, ng_p_alv_o2,ng_p_alv_co2,ng_p_ven_o2,ng_p_ven_co2, &
       ng_p_cap_o2, ng_p_cap_co2,ng_source_o2,ng_source_co2, &
       ng_Vc, ng_sa, ng_tt, ng_time

public nu_flow0

public model_type

!Interfaces
private
public define_problem_type,ventilation_indices, perfusion_indices, get_ne_radius, get_nj_conc1

contains

  !> Define problem type
  subroutine define_problem_type(PROBLEM_TYPE)
  !DEC$ ATTRIBUTES DLLEXPORT,ALIAS:"SO_DEFINE_PROBLEM_TYPE" :: DEFINE_PROBLEM_TYPE
    use other_consts, only: MAX_FILENAME_LEN, MAX_STRING_LEN
    use diagnostics, only: enter_exit

    character(len=MAX_FILENAME_LEN),intent(in) :: PROBLEM_TYPE

    character(len=60) :: sub_name

    select case (PROBLEM_TYPE)
      case ('gas_exchange')
        print *, 'You are solving a gas exchange model, setting up indices'
        call exchange_indices
      case ('gas_mix')
        print *, 'You are solving a gas mixing model, setting up indices'
        call gasmix_indices
      case ('gas_transfer')
        print *, 'You are solving a gas transfer model, setting up indices'
         call exchange_indices
      case ('perfusion')
        print *, 'You are solving a static perfusion model, setting up indices'
        call perfusion_indices
      case ('ventilation')
        print *, 'You are solving a ventilation model, setting up indices'
        call ventilation_indices
    end select
    model_type=TRIM(PROBLEM_TYPE)
    call enter_exit(sub_name,2)
  end subroutine define_problem_type

  !>Gas mixing indices
  subroutine exchange_indices
  !DEC$ ATTRIBUTES DLLEXPORT,ALIAS:"SO_GASMIX_INDICES" :: GASMIX_INDICES

    use diagnostics, only: enter_exit
    implicit none
    character(len=60) :: sub_name

    sub_name = 'exchange_indices'
    call enter_exit(sub_name,1)
    ! indices for elem_ordrs. These dont usually change.
    ! indices for node_field
    num_nj=3
    nj_conc1=2
    nj_conc2=3
    no_type=4

    ! indices for elem_field
    num_ne=9
    ne_radius=1
    ne_length=2
    ne_vol=3
    ne_resist=4
    ne_Vdot=5
    ne_Qdot=6
    ne_dvdt=7

    ne_mass = 12  ! encountered in part calc, HKSep6'18
    ne_part_vel = 14
    ne_flow = 6

    ! indices for unit_field
    num_nu=7
    nu_vol=1
    nu_comp=2
    nu_Vdot0=3
    nu_vd=4
    nu_perf=5
    nu_conc1=6
    nu_conc2=7
    nu_conc3=19

    call enter_exit(sub_name,2)
  end subroutine exchange_indices

  !>Gas mixing indices
  subroutine gasmix_indices
  !DEC$ ATTRIBUTES DLLEXPORT,ALIAS:"SO_GASMIX_INDICES" :: GASMIX_INDICES

    use diagnostics, only: enter_exit
    implicit none
    character(len=60) :: sub_name

    sub_name = 'gasmix_indices'
    call enter_exit(sub_name,1)
    ! indices for elem_ordrs. These dont usually change.
    ! indices for node_field
    num_nj=3
    nj_aw_press=2
    nj_conc1=3

!   nj_conc1=2
    nj_conc2=3
    nj_conc3=4

    ! indices for elem_field
    num_ne=9
    ne_radius=1
    ne_length=2
    ne_vol=3
    ne_resist=4
    ne_t_resist=5
    ne_Vdot=6
    ne_Vdot0=7
    ne_a_A=8
    ne_dvdt=9
    ! indices for unit_field
    num_nu=11
    nu_vol=1
    nu_comp=2
    nu_Vdot0=3
    nu_Vdot1=4
    nu_Vdot2=5
    nu_dpdt=6
    nu_pe=7
    nu_vt=8
    nu_air_press=9
    nu_conc1=10
    nu_vent=11

    !added for DPI calc, HBK, Aug 2018
    nu_flow0=3
    nu_flow1=4
    nu_dpdt_0 = 18
    nj_mass=6
    nj_loss=7
    nj_loss_dif=8
    nj_loss_sed=9
    nj_loss_imp=10

    call enter_exit(sub_name,2)
  end subroutine gasmix_indices

  !> Ventilation indices
  subroutine ventilation_indices
  !DEC$ ATTRIBUTES DLLEXPORT,ALIAS:"SO_VENTILATION_INDICES" :: VENTILATION_INDICES

    use diagnostics, only: enter_exit
    implicit none
    character(len=60) :: sub_name

    sub_name = 'ventilation_indices'
    call enter_exit(sub_name,1)
    ! indices for elem_ordrs. These dont usually change.
    ! indices for node_field
    num_nj=2 !number of nodal fields
    nj_aw_press=2 !air pressure
    ! indices for elem_field
    num_ne=8 !number of element fields
    ne_radius=1 !radius of airway
    ne_length=2 !length of airway
    ne_vol=3 !volume
    ne_resist=4 !resistance of airway
    ne_t_resist=5
    ne_Vdot=6 !Air flow, current time step
    ne_Vdot0=7 !air flow, last timestep
    ne_dvdt=8
    ! indices for unit_field
    num_nu=10
    nu_vol=1
    nu_comp=2
    nu_Vdot0=3
    nu_Vdot1=4
    nu_Vdot2=5
    nu_dpdt=6
    nu_pe=7
    nu_vt=8
    nu_air_press=9
    nu_vent=10
    call enter_exit(sub_name,2)
  end subroutine ventilation_indices
!
!######################################################################
!
!> Perfusion indices
  subroutine perfusion_indices
  !DEC$ ATTRIBUTES DLLEXPORT,ALIAS:"SO_PERFUSION_INDICES" :: PERFUSION_INDICES

    use diagnostics, only: enter_exit
    implicit none
    character(len=60) :: sub_name

    sub_name = 'perfusion_indices'
    call enter_exit(sub_name,1)

    ! indices for node_field
    num_nj=1
    nj_bv_press=1 !pressure in blood vessel
    ! indices for elem_field
    num_ne=9
    ne_radius=1 !strained average radius over whole element
    ne_radius_in=2 !strained radius into an element
    ne_radius_out=3 !strained radius out of an element
    ne_length=4!length of an elevent
    ne_radius_in0=5!unstrained radius into an element
    ne_radius_out0=6!unstrained radius out of an element
    ne_Qdot=7 !flow in an element
    ne_resist=8 !resistance of a blood vessel
    ne_group=9!Groups vessels into arteries (field=0), capillaries (field=1) and veins(field=2)
    !indices for units
    num_nu=2
    nu_perf=1
    nu_blood_press=2

     call enter_exit(sub_name,2)
  end subroutine perfusion_indices

  function get_ne_radius() result(res)
  !DEC$ ATTRIBUTES DLLEXPORT,ALIAS:"SO_GET_NE_RADIUS" :: GET_NE_RADIUS

    use diagnostics, only: enter_exit

    implicit none
    character(len=60) :: sub_name
    integer :: res

    sub_name = 'get_ne_radius'
    call enter_exit(sub_name,1)

    res=ne_radius

    call enter_exit(sub_name,2)
  end function get_ne_radius

  function get_nj_conc1() result(res)
  !DEC$ ATTRIBUTES DLLEXPORT,ALIAS:"SO_GET_NJ_CONC1" :: GET_NJ_CONC1

    use diagnostics, only: enter_exit
    implicit none
    character(len=60) :: sub_name
    integer :: res

    sub_name = 'get_nj_conc1'
    call enter_exit(sub_name,1)

    res = nj_conc1

    call enter_exit(sub_name,2)
  end function get_nj_conc1

end module indices


      PROGRAM NEC(INPUT,TAPE5=INPUT,OUTPUT,TAPE11,TAPE12,TAPE13,TAPE14,
     1TAPE15,TAPE16,TAPE20,TAPE21)
C
C     NUMERICAL ELECTROMAGNETICS CODE (NEC2)  DEVELOPED AT LAWRENCE
C     LIVERMORE LAB., LIVERMORE, CA.  (CONTACT G. BURKE AT 510-422-8414)
C     FILE CREATED 4/11/80.
C
C                ***********NOTICE**********
C     THIS COMPUTER CODE MATERIAL WAS PREPARED AS AN ACCOUNT OF WORK
C     SPONSORED BY THE UNITED STATES GOVERNMENT.  NEITHER THE UNITED
C     STATES NOR THE UNITED STATES DEPARTMENT OF ENERGY, NOR ANY OF
C     THEIR EMPLOYEES, NOR ANY OF THEIR CONTRACTORS, SUBCONTRACTORS, OR
C     THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR
C     ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY,
C     COMPLETENESS OR USEFULNESS OF ANY INFORMATION, APPARATUS, PRODUCT
C     OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD NOT
C     INFRINGE PRIVATELY-OWNED RIGHTS.
C
      INTEGER AIN,ATST,PNET,HPOL
      COMPLEX CM,FJ,VSANT,ETH,EPH,ZRATI,CUR,CURI,ZARRAY,ZRATI2
      COMPLEX EX,EY,EZ,ZPED,VQD,VQDS,T1,Y11A,Y12A,EPSC,U,U2,XX1,XX2
      COMPLEX AR1,AR2,AR3,EPSCF,FRATI
      COMMON /DATA/ LD,N1,N2,N,NP,M1,M2,M,MP,X(300),Y(300),Z(300),SI(300
     1),BI(300),ALP(300),BET(300),ICON1(300),ICON2(300),ITAG(300),ICONX(
     2300),WLAM,IPSYM
      COMMON /CMB/CM(4000)
      COMMON /MATPAR/ ICASE,NBLOKS,NPBLK,NLAST,NBLSYM,NPSYM,NLSYM,IMAT,I
     1CASX,NBBX,NPBX,NLBX,NBBL,NPBL,NLBL
      COMMON/SAVE/IP(600),KCOM,COM(19,5),EPSR,SIG,SCRWLT,SCRWRT,FMHZ
      COMMON /CRNT/ AIR(300),AII(300),BIR(300),BII(300),CIR(300),
     1 CII(300),CUR(900)
      COMMON /GND/ZRATI,ZRATI2,FRATI,CL,CH,SCRWL,SCRWR,NRADL,KSYMP,IFAR,
     1IPERF,T1,T2
      COMMON /ZLOAD/ ZARRAY(300),NLOAD,NLODF
      COMMON/YPARM/NCOUP,ICOUP,NCTAG(5),NCSEG(5),Y11A(5),Y12A(20)
      COMMON /SEGJ/ AX(30),BX(30),CX(30),JCO(30),JSNO,ISCON(50),NSCON,
     1IPCON(10),NPCON
      COMMON /VSORC/ VQD(30),VSANT(30),VQDS(30),IVQD(30),ISANT(30),
     1IQDS(30),NVQD,NSANT,NQDS
      COMMON/NETCX/ZPED,PIN,PNLS,NEQ,NPEQ,NEQ2,NONET,NTSOL,NPRINT,
     1MASYM,ISEG1(30),ISEG2(30),X11R(30),X11I(30),X12R(30),X12I(30),
     2X22R(30),X22I(30),NTYP(30),
      COMMON/FPAT/NTH,NPH,IPD,IAVP,INOR,IAX,THETS,PHIS,DTH,DPH,
     1RFLD,GNOR,CLT,CHT,EPSR2,SIG2,IXTYP,XPR6,PINR,PNLR,PLOSS,
     2NEAR,NFEH,NRX,NRY,NRZ,XNR,YNR,ZNR,DXNR,DYNR,DZNR
      COMMON /GGRID/ AR1(11,10,4),AR2(17,5,4),AR3(9,8,4),EPSCF,DXA(3),
     -DYA(3),XSA(3),YSA(3),NXA(3),NYA(3)
      COMMON/GWAV/U,U2,XX1,XX2,R1,R2,ZMH,ZPH
      DIMENSION CAB(1),SAB(1),X2(1),Y2(1),Z2(1)
      DIMENSION LDTYP(30),LDTAG(30),LDTAGF(30),LDTAGT(30),ZLR(30),
     1ZLI(30),ZLC(30)
      DIMENSION ATST(22),PNET(6),HPOL(3),IX(600)
      DIMENSION FNORM(200)
      DIMENSION T1X(1),T1Y(1),T1Z(1),T2X(1),T2Y(1),T2Z(1)
      EQUIVALENCE (CAB,ALP),(SAB,BET),(X2,SI),(Y2,ALP),(Z2,BET)
      EQUIVALENCE (T1X,SI),(T1Y,ALP),(T1Z,BET),(T2X,ICON1),(T2Y,ICON2),
     1 (T2Z,ITAG)
      DATA ATST/2HCE,2HFR,2HLD,2HGN,2HEX,2HNT,2HXQ,2HNE,2HGD,2HRP,2HCM,
     1 2HNX,2HEN,2HTL,2HPT,2HKH,2HNH,2HPQ,2HEK,2HWG,2HCP/
      DATA HPOL/6HLINEAR,5HRIGHT,4HLEFT/
      DATA PNET/6H      ,2H  ,6HSTRAIG,2HHT,6HCROSSE,1HD/
      DATA TA/1.745329252E-02/,CVEL/299.8/
      DATA LOADMX,NSMAX,NETMX/30,30,30/,NORMF/200/
      CALL SECOND(EXTIM)
      FJ=(0.,1.)
      LD=300
      NXA(1)=0
      IRESRV=4000
1     KCOM=0
2     KCOM=KCOM+1
      IF (KCOM.GT.5) KCOM=5
      READ(5,125)AIN,(COM(I,KCOM),I=1,19)
      IF(KCOM.GT.1)GO TO 3
      PRINT 126
      PRINT 127
      PRINT 128
3     PRINT 129, (COM(I,KCOM),I=1,19)
      IF (AIN.EQ.ATST(11)) GO TO 2
      IF (AIN.EQ.ATST(1)) GO TO 4
      PRINT 130
      STOP
4     CONTINUE
      DO 5 I=1,LD
5     ZARRAY(I)=(0.,0.)
      MPCNT=0
      IMAT=0
C
C     SET UP GEOMETRY DATA IN SUBROUTINE DATAGN
C
      CALL DATAGN
      IFLOW=1
      IF(IMAT.EQ.0)GO TO 326
C
C     CORE ALLOCATION FOR ARRAYS B, C, AND D FOR N.G.F. SOLUTION
C
      NEQ=N1+2*M1
      NEQ2=N-N1+2*(M-M1)+NSCON+2*NPCON
      CALL FBNGF(NEQ,NEQ2,IRESRV,IB11,IC11,ID11,IX11)
      GO TO 6
326   NEQ=N+2*M
      NEQ2=0
      IB11=1
      IC11=1
      ID11=1
      IX11=1
      ICASX=0
6     NPEQ=NP+2*MP
      PRINT 135
C
C     DEFAULT VALUES FOR INPUT PARAMETERS AND FLAGS
C
      IGO=1
      FMHZS=CVEL
      NFRQ=1
      RKH=1.
      IEXK=0
      IXTYP=0
      NLOAD=0
      NONET=0
      NEAR=-1
      IPTFLG=-2
      IPTFLQ=-1
      IFAR=-1
      ZRATI=(1.,0.)
      IPED=0
      IRNGF=0
      NCOUP=0
      ICOUP=0
      IF(ICASX.GT.0)GO TO 14
      FMHZ=CVEL
      NLODF=0
      KSYMP=1
      NRADL=0
      IPERF=0
C
C     MAIN INPUT SECTION - STANDARD READ STATEMENT - JUMPS TO APPRO-
C     PRIATE SECTION FOR SPECIFIC PARAMETER SET UP
C
14    READ(5,136)AIN,ITMP1,ITMP2,ITMP3,ITMP4,TMP1,TMP2,TMP3,TMP4,TMP5,
     1TMP6
      MPCNT=MPCNT+1
      PRINT 137, MPCNT,AIN,ITMP1,ITMP2,ITMP3,ITMP4,TMP1,TMP2,TMP3,TMP4,
     1TMP5,TMP6
      IF (AIN.EQ.ATST(2)) GO TO 16
      IF (AIN.EQ.ATST(3)) GO TO 17
      IF (AIN.EQ.ATST(4)) GO TO 21
      IF (AIN.EQ.ATST(5)) GO TO 24
      IF (AIN.EQ.ATST(6)) GO TO 28
      IF (AIN.EQ.ATST(14)) GO TO 28
      IF (AIN.EQ.ATST(15)) GO TO 31
      IF (AIN.EQ.ATST(18)) GO TO 319
      IF (AIN.EQ.ATST(7)) GO TO 37
      IF (AIN.EQ.ATST(8)) GO TO 32
      IF (AIN.EQ.ATST(17)) GO TO 208
      IF (AIN.EQ.ATST(9)) GO TO 34
      IF (AIN.EQ.ATST(10)) GO TO 36
      IF (AIN.EQ.ATST(16)) GO TO 305
      IF (AIN.EQ.ATST(19)) GO TO 320
      IF (AIN.EQ.ATST(12)) GO TO 1
      IF (AIN.EQ.ATST(20)) GO TO 322
      IF (AIN.EQ.ATST(21)) GO TO 304
      IF (AIN.NE.ATST(13)) GO TO 15
      CALL SECOND(TMP1)
      TMP1=TMP1-EXTIM
      PRINT 201, TMP1
      STOP
15    PRINT 138
      STOP
C
C     FREQUENCY PARAMETERS
C
16    IFRQ=ITMP1
      IF(ICASX.EQ.0)GO TO 8
      PRINT 303, AIN
      STOP
8     NFRQ=ITMP2
      IF (NFRQ.EQ.0) NFRQ=1
      FMHZ=TMP1
      DELFRQ=TMP2
      IF(IPED.EQ.1)ZPNORM=0.
      IGO=1
      IFLOW=1
      GO TO 14
C
C     MATRIX INTEGRATION LIMIT
C
305   RKH=TMP1
      IF(IGO.GT.2)IGO=2
      IFLOW=1
      GO TO 14
C
C     EXTENDED THIN WIRE KERNEL OPTION
C
320   IEXK=1
      IF(ITMP1.EQ.-1)IEXK=0
      IF(IGO.GT.2)IGO=2
      IFLOW=1
      GO TO 14
C
C     MAXIMUM COUPLING BETWEEN ANTENNAS
C
304   IF(IFLOW.NE.2)NCOUP=0
      ICOUP=0
      IFLOW=2
      IF(ITMP2.EQ.0)GO TO 14
      NCOUP=NCOUP+1
      IF(NCOUP.GT.5)GO TO 312
      NCTAG(NCOUP)=ITMP1
      NCSEG(NCOUP)=ITMP2
      IF(ITMP4.EQ.0)GO TO 14
      NCOUP=NCOUP+1
      IF(NCOUP.GT.5)GO TO 312
      NCTAG(NCOUP)=ITMP3
      NCSEG(NCOUP)=ITMP4
      GO TO 14
312   PRINT 313
      STOP
C
C     LOADING PARAMETERS
C
17    IF (IFLOW.EQ.3) GO TO 18
      NLOAD=0
      IFLOW=3
      IF (IGO.GT.2) IGO=2
      IF (ITMP1.EQ.(-1)) GO TO 14
18    NLOAD=NLOAD+1
      IF (NLOAD.LE.LOADMX) GO TO 19
      PRINT 139
      STOP
19    LDTYP(NLOAD)=ITMP1
      LDTAG(NLOAD)=ITMP2
      IF (ITMP4.EQ.0) ITMP4=ITMP3
      LDTAGF(NLOAD)=ITMP3
      LDTAGT(NLOAD)=ITMP4
      IF (ITMP4.GE.ITMP3) GO TO 20
      PRINT 140, NLOAD,ITMP3,ITMP4
      STOP
20    ZLR(NLOAD)=TMP1
      ZLI(NLOAD)=TMP2
      ZLC(NLOAD)=TMP3
      GO TO 14
C
C     GROUND PARAMETERS UNDER THE ANTENNA
C
21    IFLOW=4
      IF(ICASX.EQ.0)GO TO 10
      PRINT 303,AIN
      STOP
10    IF (IGO.GT.2) IGO=2
      IF (ITMP1.NE.(-1)) GO TO 22
      KSYMP=1
      NRADL=0
      IPERF=0
      GO TO 14
22    IPERF=ITMP1
      NRADL=ITMP2
      KSYMP=2
      EPSR=TMP1
      SIG=TMP2
      IF (NRADL.EQ.0) GO TO 23
      IF(IPERF.NE.2)GO TO 314
      PRINT 390
      STOP
314   SCRWLT=TMP3
      SCRWRT=TMP4
      GO TO 14
23    EPSR2=TMP3
      SIG2=TMP4
      CLT=TMP5
      CHT=TMP6
      GO TO 14
C
C     EXCITATION PARAMETERS
C
24    IF (IFLOW.EQ.5) GO TO 25
      NSANT=0
      NVQD=0
      IPED=0
      IFLOW=5
      IF (IGO.GT.3) IGO=3
25    MASYM=ITMP4/10
      IF (ITMP1.GT.0.AND.ITMP1.NE.5) GO TO 27
      IXTYP=ITMP1
      NTSOL=0
      IF(IXTYP.EQ.0)GO TO 205
      NVQD=NVQD+1
      IF(NVQD.GT.NSMAX)GO TO 206
      IVQD(NVQD)=ISEGNO(ITMP2,ITMP3)
      VQD(NVQD)=DCMPLX(TMP1,TMP2)
      IF(ABS(VQD(NVQD)).LT.1.D-20)VQD(NVQD)=(1.,0.)
      GO TO 207
205   NSANT=NSANT+1
      IF (NSANT.LE.NSMAX) GO TO 26
206   PRINT 141
      STOP
26    ISANT(NSANT)=ISEGNO(ITMP2,ITMP3)
      VSANT(NSANT)=DCMPLX(TMP1,TMP2)
      IF (ABS(VSANT(NSANT)).LT.1.E-20) VSANT(NSANT)=(1.,0.)
207   IPED=ITMP4-MASYM*10
      ZPNORM=TMP3
      IF (IPED.EQ.1.AND.ZPNORM.GT.0) IPED=2
      GO TO 14
27    IF (IXTYP.EQ.0.OR.IXTYP.EQ.5) NTSOL=0
      IXTYP=ITMP1
      NTHI=ITMP2
      NPHI=ITMP3
      XPR1=TMP1
      XPR2=TMP2
      XPR3=TMP3
      XPR4=TMP4
      XPR5=TMP5
      XPR6=TMP6
      NSANT=0
      NVQD=0
      THETIS=XPR1
      PHISS=XPR2
      GO TO 14
C
C     NETWORK PARAMETERS
C
28    IF (IFLOW.EQ.6) GO TO 29
      NONET=0
      NTSOL=0
      IFLOW=6
      IF (IGO.GT.3) IGO=3
      IF (ITMP2.EQ.(-1)) GO TO 14
29    NONET=NONET+1
      IF (NONET.LE.NETMX) GO TO 30
      PRINT 142
      STOP
30    NTYP(NONET)=2
      IF (AIN.EQ.ATST(6)) NTYP(NONET)=1
      ISEG1(NONET)=ISEGNO(ITMP1,ITMP2)
      ISEG2(NONET)=ISEGNO(ITMP3,ITMP4)
      X11R(NONET)=TMP1
      X11I(NONET)=TMP2
      X12R(NONET)=TMP3
      X12I(NONET)=TMP4
      X22R(NONET)=TMP5
      X22I(NONET)=TMP6
      IF (NTYP(NONET).EQ.1.OR.TMP1.GT.0.) GO TO 14
      NTYP(NONET)=3
      X11R(NONET)=-TMP1
      GO TO 14
C
C     PRINT CONTROL FOR CURRENT
C
31    IPTFLG=ITMP1
      IPTAG=ITMP2
      IPTAGF=ITMP3
      IPTAGT=ITMP4
      IF(ITMP3.EQ.0.AND.IPTFLG.NE.-1)IPTFLG=-2
      IF (ITMP4.EQ.0) IPTAGT=IPTAGF
      GO TO 14
C
C     WRITE CONTROL FOR CHARGE
C
319   IPTFLQ=ITMP1
      IPTAQ=ITMP2
      IPTAQF=ITMP3
      IPTAQT=ITMP4
      IF(ITMP3.EQ.0.AND.IPTFLQ.NE.-1)IPTFLQ=-2
      IF(ITMP4.EQ.0)IPTAQT=IPTAQF
      GO TO 14
C
C     NEAR FIELD CALCULATION PARAMETERS
C
208   NFEH=1
      GO TO 209
32    NFEH=0
209   IF (.NOT.(IFLOW.EQ.8.AND.NFRQ.NE.1)) GO TO 33
      PRINT 143
33    NEAR=ITMP1
      NRX=ITMP2
      NRY=ITMP3
      NRZ=ITMP4
      XNR=TMP1
      YNR=TMP2
      ZNR=TMP3
      DXNR=TMP4
      DYNR=TMP5
      DZNR=TMP6
      IFLOW=8
      IF (NFRQ.NE.1) GO TO 14
      GO TO (41,46,53,71,72), IGO
C
C     GROUND REPRESENTATION
C
34    EPSR2=TMP1
      SIG2=TMP2
      CLT=TMP3
      CHT=TMP4
      IFLOW=9
      GO TO 14
C
C     STANDARD OBSERVATION ANGLE PARAMETERS
C
36    IFAR=ITMP1
      NTH=ITMP2
      NPH=ITMP3
      IF (NTH.EQ.0) NTH=1
      IF (NPH.EQ.0) NPH=1
      IPD=ITMP4/10
      IAVP=ITMP4-IPD*10
      INOR=IPD/10
      IPD=IPD-INOR*10
      IAX=INOR/10
      INOR=INOR-IAX*10
      IF (IAX.NE.0) IAX=1
      IF (IPD.NE.0) IPD=1
      IF (NTH.LT.2.OR.NPH.LT.2) IAVP=0
      IF (IFAR.EQ.1) IAVP=0
      THETS=TMP1
      PHIS=TMP2
      DTH=TMP3
      DPH=TMP4
      RFLD=TMP5
      GNOR=TMP6
      IFLOW=10
      GO TO (41,46,53,71,78), IGO
C
C     WRITE NUMERICAL GREEN'S FUNCTION TAPE
C
322   IFLOW=12
      IF(ICASX.EQ.0)GO TO 301
      PRINT 302
      STOP
301   IRNGF=IRESRV/2
      GO TO (41,46,52,52,52),IGO
C
C     EXECUTE CARD  -  CALC. INCLUDING RADIATED FIELDS
C
37    IF (IFLOW.EQ.10.AND.ITMP1.EQ.0) GO TO 14
      IF (NFRQ.EQ.1.AND.ITMP1.EQ.0.AND.IFLOW.GT.7) GO TO 14
      IF (ITMP1.NE.0) GO TO 39
      IF (IFLOW.GT.7) GO TO 38
      IFLOW=7
      GO TO 40
38    IFLOW=11
      GO TO 40
39    IFAR=0
      RFLD=0.
      IPD=0
      IAVP=0
      INOR=0
      IAX=0
      NTH=91
      NPH=1
      THETS=0.
      PHIS=0.
      DTH=1.0
      DPH=0.
      IF (ITMP1.EQ.2) PHIS=90.
      IF (ITMP1.NE.3) GO TO 40
      NPH=2
      DPH=90.
40    GO TO (41,46,53,71,78), IGO
C
C     END OF THE MAIN INPUT SECTION
C
C     BEGINNING OF THE FREQUENCY DO LOOP
C
41    MHZ=1
C     CORE ALLOCATION FOR PRIMARY INTERACTON MATRIX.  (A)
      IF(IMAT.EQ.0)CALL FBLOCK(NPEQ,NEQ,IRESRV,IRNGF,IPSYM)
42    IF (MHZ.EQ.1) GO TO 44
      IF (IFRQ.EQ.1) GO TO 43
      FMHZ=FMHZ+DELFRQ
      GO TO 44
43    FMHZ=FMHZ*DELFRQ
44    FR=FMHZ/FMHZS
      WLAM=CVEL/FMHZ
      PRINT 145, FMHZ,WLAM
      PRINT 196,RKH
      IF(IEXK.EQ.1)WRITE(3,321)
C     FREQUENCY SCALING OF GEOMETRIC PARAMETERS
      FMHZS=FMHZ
      IF(N.EQ.0)GO TO 306
      DO 45 I=1,N
      X(I)=X(I)*FR
      Y(I)=Y(I)*FR
      Z(I)=Z(I)*FR
      SI(I)=SI(I)*FR
45    BI(I)=BI(I)*FR
306   IF(M.EQ.0)GO TO 307
      FR2=FR*FR
      J=LD+1
      DO 245 I=1,M
      J=J-1
      X(J)=X(J)*FR
      Y(J)=Y(J)*FR
      Z(J)=Z(J)*FR
245   BI(J)=BI(J)*FR2
307   IGO=2
C     STRUCTURE SEGMENT LOADING
46    PRINT 146
      IF(NLOAD.NE.0) CALL LOAD(LDTYP,LDTAG,LDTAGF,LDTAGT,ZLR,ZLI,ZLC)
      IF(NLOAD.EQ.0.AND.NLODF.EQ.0)WRITE(3,147)
      IF(NLOAD.EQ.0.AND.NLODF.NE.0)WRITE(3,327)
C     GROUND PARAMETER
      PRINT 148
      IF (KSYMP.EQ.1) GO TO 49
      FRATI=(1.,0.)
      IF (IPERF.EQ.1) GO TO 48
      IF(SIG.LT.0.) SIG=-SIG/(59.96*WLAM)
      EPSC=CMPLX(EPSR,-SIG*WLAM*59.96)
      ZRATI=1./CSQRT(EPSC)
      U=ZRATI
      U2=U*U
      IF (NRADL.EQ.0) GO TO 47
      SCRWL=SCRWLT/WLAM
      SCRWR=SCRWRT/WLAM
      T1=FJ*2367.067/FLOAT(NRADL)
      T2=SCRWR*FLOAT(NRADL)
      PRINT 170, NRADL,SCRWLT,SCRWRT
      PRINT 149
47    IF(IPERF.EQ.2)GO TO 328
      PRINT 391
      GO TO 329
328	  IF(NXA(1).EQ.0)READ(21)AR1,AR2,AR3,EPSCF,DXA,DYA,XSA,YSA,NXA,NYA
      FRATI=(EPSC-1.)/(EPSC+1.)
      IF(CABS((EPSCF-EPSC)/EPSC).LT.1.E-3)GO TO 330
      PRINT 393,EPSCF,EPSC
      STOP
330   PRINT 3,392
329   PRINT 150, EPSR,SIG,EPSC
      GO TO 50
48    PRINT 151
      GO TO 50
49    PRINT 152
50    CONTINUE
C * * *
C     FILL AND FACTOR PRIMARY INTERACTION MATRIX
C
      CALL SECOND (TIM1)
      IF(ICASX.NE.0)GO TO 324
      CALL CMSET(NEQ,CM,RKH,IEXK)
      CALL SECOND (TIM2)
      TIM=TIM2-TIM1
      CALL FACTRS(NPEQ,NEQ,CM,IP,IX,11,12,13,14)
      GO TO 323
C
C     N.G.F. - FILL B, C, AND D AND FACTOR D-C(INV(A)B)
C
324   CALL CMNGF(CM(IB11),CM(IC11),CM(ID11),NPBX,NEQ,NEQ2,RKH,IEXK)
      CALL SECOND (TIM2)
      TIM=TIM2-TIM1
      CALL FACGF(CM,CM(IB11),CM(IC11),CM(ID11),CM(IX11),IP,IX,NP,N1,MP,
     1M1,NEQ,NEQ2)
323   CALL SECOND (TIM1)
      TIM2=TIM1-TIM2
      PRINT 153, TIM,TIM2
      IGO=3
      NTSOL=0
      IF(IFLOW.NE.12)GO TO 53
C     WRITE N.G.F. FILE
52    CALL GFOUT
      GO TO 14
C
C     EXCITATION SET UP (RIGHT HAND SIDE, -E INC.)
C
53    NTHIC=1
      NPHIC=1
      INC=1
      NPRINT=0
54    IF (IXTYP.EQ.0.OR.IXTYP.EQ.5) GO TO 56
      IF (IPTFLG.LE.0.OR.IXTYP.EQ.4) WRITE(3,154)
      TMP5=TA*XPR5
      TMP4=TA*XPR4
      IF (IXTYP.NE.4) GO TO 55
      TMP1=XPR1/WLAM
      TMP2=XPR2/WLAM
      TMP3=XPR3/WLAM
      TMP6=XPR6/(WLAM*WLAM)
      PRINT 156, XPR1,XPR2,XPR3,XPR4,XPR5,XPR6
      GO TO 56
55    TMP1=TA*XPR1
      TMP2=TA*XPR2
      TMP3=TA*XPR3
      TMP6=XPR6
      IF (IPTFLG.LE.0) PRINT 155, XPR1,XPR2,XPR3,HPOL(IXTYP),XPR6
56    CALL ETMNS (TMP1,TMP2,TMP3,TMP4,TMP5,TMP6,IXTYP,CUR)
C
C     MATRIX SOLVING  (NETWK CALLS SOLVES)
C
      IF (NONET.EQ.0.OR.INC.GT.1) GO TO 60
      PRINT 158
      ITMP3=0
      ITMP1=NTYP(1)
      DO 59 I=1,2
      IF (ITMP1.EQ.3) ITMP1=2
      IF (ITMP1.EQ.2) PRINT 159
      IF (ITMP1.EQ.1) PRINT 160
      DO 58 J=1,NONET
      ITMP2=NTYP(J)
      IF ((ITMP2/ITMP1).EQ.1) GO TO 57
      ITMP3=ITMP2
      GO TO 58
57    ITMP4=ISEG1(J)
      ITMP5=ISEG2(J)
      IF (ITMP2.GE.2.AND.X11I(J).LE.0.) X11I(J)=WLAM*SQRT((X(ITMP5)-
     1 X(ITMP4))**2+(Y(ITMP5)-Y(ITMP4))**2+(Z(ITMP5)-Z(ITMP4))**2)
      PRINT 157, ITAG(ITMP4),ITMP4,ITAG(ITMP5),ITMP5,X11R(J),X11I(J),
     1X12R(J),X12I(J),X22R(J),X22I(J),PNET(2*ITMP2-1),PNET(2*ITMP2)
58    CONTINUE
      IF (ITMP3.EQ.0) GO TO 60
      ITMP1=ITMP3
59    CONTINUE
60    CONTINUE
      IF (INC.GT.1.AND.IPTFLG.GT.0) NPRINT=1
      CALL NETWK(CM,CM(IB11),CM(IC11),CM(ID11),IP,CUR)
      NTSOL=1
      IF (IPED.EQ.0) GO TO 61
      ITMP1=MHZ+4*(MHZ-1)
      IF (ITMP1.GT.(NORMF-3)) GO TO 61
      FNORM(ITMP1)=DREAL(ZPED)
      FNORM(ITMP1+1)=DIMAG(ZPED)
      FNORM(ITMP1+2)=ABS(ZPED)
      FNORM(ITMP1+3)=CANG(ZPED)
      IF (IPED.EQ.2) GO TO 61
      IF (FNORM(ITMP1+2).GT.ZPNORM) ZPNORM=FNORM(ITMP1+2)
61    CONTINUE
C
C     PRINTING STRUCTURE CURRENTS
C
      IF(N.EQ.0)GO TO 308
      IF (IPTFLG.EQ.(-1)) GO TO 63
      IF (IPTFLG.GT.0) GO TO 62
      PRINT 161
      PRINT 162
      GO TO 63
62    IF (IPTFLG.EQ.3.OR.INC.GT.1) GO TO 63
      PRINT 163, XPR3,HPOL(IXTYP),XPR6
63    PLOSS=0.
      ITMP1=0
      JUMP=IPTFLG+1
      DO 69 I=1,N
      CURI=CUR(I)*WLAM
      CMAG=CABS(CURI)
      PH=CANG(CURI)
      IF (NLOAD.EQ.0.AND.NLODF.EQ.0) GO TO 64
      IF (ABS(DREAL(ZARRAY(I))).LT.1.D-20) GO TO 64
      PLOSS=PLOSS+.5*CMAG*CMAG*REAL(ZARRAY(I))*SI(I)
64    IF (JUMP) 68,69,65
65    IF (IPTAG.EQ.0) GO TO 66
      IF (ITAG(I).NE.IPTAG) GO TO 69
66    ITMP1=ITMP1+1
      IF (ITMP1.LT.IPTAGF.OR.ITMP1.GT.IPTAGT) GO TO 69
      IF (IPTFLG.EQ.0) GO TO 68
      IF (IPTFLG.LT.2.OR.INC.GT.NORMF) GO TO 67
      FNORM(INC)=CMAG
      ISAVE=I
67    IF (IPTFLG.NE.3) PRINT 164, XPR1,XPR2,CMAG,PH,I
      GO TO 69
68    PRINT 165, I,ITAG(I),X(I),Y(I),Z(I),SI(I),CURI,CMAG,PH
69    CONTINUE
      IF(IPTFLQ.EQ.(-1))GO TO 308
      PRINT 315
      ITMP1=0
      FR=1.D-6/FMHZ
      DO 316 I=1,N
      IF(IPTFLQ.EQ.(-2))GO TO 318
      IF(IPTAQ.EQ.0)GO TO 317
      IF(ITAG(I).NE.IPTAQ)GO TO 316
317   ITMP1=ITMP1+1
      IF(ITMP1.LT.IPTAQF.OR.ITMP1.GT.IPTAQT)GO TO 316
318   CURI=FR*DCMPLX(-BII(I),BIR(I))
      CMAG=ABS(CURI)
      PH=CANG(CURI)
      PRINT 165,I,ITAG(I),X(I),Y(I),Z(I),SI(I),CURI,CMAG,PH
316   CONTINUE
308   IF(M.EQ.0)GO TO 310
      PRINT 197
      J=N-2
      ITMP1=LD+1
      DO 309 I=1,M
      J=J+3
      ITMP1=ITMP1-1
      EX=CUR(J)
      EY=CUR(J+1)
      EZ=CUR(J+2)
      ETH=EX*T1X(ITMP1)+EY*T1Y(ITMP1)+EZ*T1Z(ITMP1)
      EPH=EX*T2X(ITMP1)+EY*T2Y(ITMP1)+EZ*T2Z(ITMP1)
      ETHM=ABS(ETH)
      ETHA=CANG(ETH)
      EPHM=ABS(EPH)
      EPHA=CANG(EPH)
309   PRINT 198,I,X(ITMP1),Y(ITMP1),Z(ITMP1),ETHM,ETHA,EPHM,EPHA,EX,EY,
     1 EZ
310   IF (IXTYP.NE.0.AND.IXTYP.NE.5) GO TO 70
      TMP1=PIN-PNLS-PLOSS
      TMP2=100.*TMP1/PIN
      PRINT 166, PIN,TMP1,PLOSS,PNLS,TMP2
70    CONTINUE
      IGO=4
      IF(NCOUP.GT.0)CALL COUPLE(CUR,WLAM)
      IF (IFLOW.NE.7) GO TO 71
      IF (IXTYP.GT.0.AND.IXTYP.LT.4) GO TO 113
      IF (NFRQ.NE.1) GO TO 120
      PRINT 135
      GO TO 14
71    IGO=5
C
C     NEAR FIELD CALCULATION
C
72    IF (NEAR.EQ.(-1)) GO TO 78
      CALL NFPAT
      IF (MHZ.EQ.NFRQ) NEAR=-1
      IF (NFRQ.NE.1) GO TO 78
      PRINT 135
      GO TO 14
C
C     STANDARD FAR FIELD CALCULATION
C
78    IF(IFAR.EQ.-1)GO TO 113
      PINR=PIN
      PNLR=PNLS
      CALL RDPAT
113   IF (IXTYP.EQ.0.OR.IXTYP.GE.4) GO TO 119
      NTHIC=NTHIC+1
      INC=INC+1
      XPR1=XPR1+XPR4
      IF (NTHIC.LE.NTHI) GO TO 54
      NTHIC=1
      XPR1=THETIS
      XPR2=XPR2+XPR5
      NPHIC=NPHIC+1
      IF (NPHIC.LE.NPHI) GO TO 54
      NPHIC=1
      XPR2=PHISS
      IF (IPTFLG.LT.2) GO TO 119
C     NORMALIZED RECEIVING PATTERN PRINTED
      ITMP1=NTHI*NPHI
      IF (ITMP1.LE.NORMF) GO TO 114
      ITMP1=NORMF
      PRINT 181
114   TMP1=FNORM(1)
      DO 115 J=2,ITMP1
      IF (FNORM(J).GT.TMP1) TMP1=FNORM(J)
115   CONTINUE
      PRINT 182, TMP1,XPR3,HPOL(IXTYP),XPR6,ISAVE
      DO 118 J=1,NPHI
      ITMP2=NTHI*(J-1)
      DO 116 I=1,NTHI
      ITMP3=I+ITMP2
      IF (ITMP3.GT.ITMP1) GO TO 117
      TMP2=FNORM(ITMP3)/TMP1
      TMP3=DB20(TMP2)
      PRINT 183, XPR1,XPR2,TMP3,TMP2
      XPR1=XPR1+XPR4
116   CONTINUE
117   XPR1=THETIS
      XPR2=XPR2+XPR5
118   CONTINUE
      XPR2=PHISS
119   IF (MHZ.EQ.NFRQ) IFAR=-1
      IF (NFRQ.NE.1) GO TO 120
      PRINT 135
      GO TO 14
120   MHZ=MHZ+1
      IF (MHZ.LE.NFRQ) GO TO 42
      IF (IPED.EQ.0) GO TO 123
      IF(NVQD.LT.1)GO TO 199
      PRINT 184,IVQD(NVQD),ZPNORM
      GO TO 204
199   PRINT 184, ISANT(NSANT),ZPNORM
204   ITMP1=NFRQ
      IF (ITMP1.LE.(NORMF/4)) GO TO 121
      ITMP1=NORMF/4
      PRINT 185
121   IF (IFRQ.EQ.0) TMP1=FMHZ-(NFRQ-1)*DELFRQ
      IF (IFRQ.EQ.1) TMP1=FMHZ/(DELFRQ**(NFRQ-1))
      DO 122 I=1,ITMP1
      ITMP2=I+4*(I-1)
      TMP2=FNORM(ITMP2)/ZPNORM
      TMP3=FNORM(ITMP2+1)/ZPNORM
      TMP4=FNORM(ITMP2+2)/ZPNORM
      TMP5=FNORM(ITMP2+3)
      PRINT 186, TMP1,FNORM(ITMP2),FNORM(ITMP2+1),FNORM(ITMP2+2),
     1FNORM(ITMP2+3),TMP2,TMP3,TMP4,TMP5
      IF (IFRQ.EQ.0) TMP1=TMP1+DELFRQ
      IF (IFRQ.EQ.1) TMP1=TMP1*DELFRQ
122   CONTINUE
      PRINT 135
123   CONTINUE
      NFRQ=1
      MHZ=1
      GO TO 14
125   FORMAT (A2,13A6)
126   FORMAT  (1H1)
127   FORMAT (///,33X,36H************************************,//,36X,
     1 31HNUMERICAL ELECTROMAGNETICS CODE,//,33X,
     2 36H************************************)
128   FORMAT (////,37X,24H- - - - COMMENTS - - - -,//)
129   FORMAT (25X,13A6)
130   FORMAT (///,10X,34HINCORRECT LABEL FOR A COMMENT CARD)
135   FORMAT (/////)
136   FORMAT (A2,I3,3I5,6E10.3)
137   FORMAT (1X, 19H***** DATA CARD NO.,I3,3X,A2,1X,I3,3(1X,I5),
     1 6(1X,1P,E12.5))
138   FORMAT (///,10X,45HFAULTY DATA CARD LABEL AFTER GEOMETRY SECTION)
139   FORMAT (///,10X,48HNUMBER OF LOADING CARDS EXCEEDS STORAGE ALLOTTE
     1D)
140   FORMAT (///,10X,31HDATA FAULT ON LOADING CARD NO.=,I5,5X,11HITAG S
     1TEP1=,I5,29H  IS GREATER THAN ITAG STEP2=,I5)
141   FORMAT (///,10X,51HNUMBER OF EXCITATION CARDS EXCEEDS STORAGE ALLO
     1TTED)
142   FORMAT (///,10X,48HNUMBER OF NETWORK CARDS EXCEEDS STORAGE ALLOTTE
     1D)
143   FORMAT(///,10X,79HWHEN MULTIPLE FREQUENCIES ARE REQUESTED, ONLY ON
     1E NEAR FIELD CARD CAN BE USED -,/,10X,22HLAST CARD READ IS USED)
145   FORMAT (////,33X,33H- - - - - - FREQUENCY - - - - - -,//,36X,10HFR
     1EQUENCY=,1P,E11.4,4H MHZ,/,36X,11HWAVELENGTH=,E11.4,7H METERS)
146   FORMAT (///,30X,40H - - - STRUCTURE IMPEDANCE LOADING - - -)
147   FORMAT (/ ,35X,28HTHIS STRUCTURE IS NOT LOADED)
148   FORMAT (///,34X,31H- - - ANTENNA ENVIRONMENT - - -,/)
149   FORMAT (40X,21HMEDIUM UNDER SCREEN -)
150   FORMAT (40X,27HRELATIVE DIELECTRIC CONST.=,F7.3,/,40X,13HCONDUCTIV
     1ITY=,1P,E10.3,11H MHOS/METER,/,40X,28HCOMPLEX DIELECTRIC CONSTANT=
     1,2E12.5)
151   FORMAT (  42X,14HPERFECT GROUND)
152   FORMAT (  44X,10HFREE SPACE)
153   FORMAT (///,32X,25H- - - MATRIX TIMING - - -,//,24X,5HFILL=,F9.3,
     115H SEC.,  FACTOR=,F9.3,5H SEC.)
154   FORMAT (///,40X,22H- - - EXCITATION - - -)
155   FORMAT (/,4X,10HPLANE WAVE,4X,6HTHETA=,F7.2,11H DEG,  PHI=,F7.2,
     1 11H DEG,  ETA=,F7.2,13H DEG,  TYPE -,A6,15H=  AXIAL RATIO=,F6.3)
156   FORMAT (/,31X,17HPOSITION (METERS),14X,18HORIENTATION (DEG)=/,28X,
     11HX,12X,1HY,12X,1HZ,10X,5HALPHA,5X,4HBETA,4X,13HDIPOLE MOMENT,//
     2 ,4X,14HCURRENT SOURCE,1X,3(3X,F10.5),1X,2(3X,F7.2),4X,F8.3)
157   FORMAT (4X,4(I5,1X),1P,6(3X,E11.4),3X,A6,A2)
158   FORMAT (///,44X,24H- - - NETWORK DATA - - -)
159   FORMAT (/,6X,18H- FROM -    - TO -,11X,17HTRANSMISSION LINE,15X,36
     1H-  -  SHUNT ADMITTANCES (MHOS)  -  -,14X,4HLINE,/,6X,21HTAG  SEG.
     2   TAG  SEG.,6X,9HIMPEDANCE,6X,6HLENGTH,12X,11H- END ONE -,17X,11H
     3- END TWO -,12X,4HTYPE,/    ,6X,21HNO.   NO.   NO.   NO.,9X,4HOHMS
     4,8X,6HMETERS,9X, 4HREAL,10X,5HIMAG.,9X,4HREAL,10X,5HIMAG.)
160   FORMAT (/,6X,8H- FROM -,4X,6H- TO -,26X,45H-  -  ADMITTANCE MATRIX
     1 ELEMENTS (MHOS)  -  -,/    ,6X,21HTAG  SEG.   TAG  SEG.,13X,9H(ON
     2E,ONE),19X,    9H(ONE,TWO),19X,9H(TWO,TWO),/ ,6X,21HNO.   NO.   NO
     3.   NO.,8X,4HREAL,10X,5HIMAG.,9X,4HREAL,10X,5HIMAG.,9X,4HREAL,
     4 10X,5HIMAG.)
161   FORMAT (///,29X,33H- - - CURRENTS AND LOCATION - - -,//,33X,24HDIS
     1TANCES IN WAVELENGTHS)
162   FORMAT (  //,2X,4HSEG.,2X,3HTAG,4X,21HCOORD. OF SEG. CENTER,5X,
     1 4HSEG.,12X,26H- - - CURRENT (AMPS) - - -,/,2X,3HNO.,3X,3HNO.,
     2 5X,1HX,8X,1HY,8X,1HZ,6X,6HLENGTH,5X,4HREAL,8X,5HIMAG.,7X,4HMAG.,
     3 8X,5HPHASE)
163   FORMAT (///,33X,40H- - - RECEIVING PATTERN PARAMETERS - - -,/  ,43
     1X,4HETA=,F7.2,8H DEGREES,/,43X,6HTYPE -,A6,/,43X,12HAXIAL RATIO=,
     2 F6.3,//   ,11X,5HTHETA,6X,3HPHI,10X,13H-  CURRENT  -,9X,3HSEG,/
     3,11X,5H(DEG),5X,5H(DEG),7X,9HMAGNITUDE,4X,5HPHASE,6X,3HNO.,/)
164   FORMAT (10X,2(F7.2,3X),1X,1P,E11.4,3X,0P,F7.2,4X,I5)
165   FORMAT (1X,2I5,3F9.4,F9.5,1X,1P,3E12.4,0P,F9.3)
166   FORMAT (///,40X,24H- - - POWER BUDGET - - -,//    ,43X,15HINPUT PO
     1WER   =,1P,E11.4,6H WATTS,/ ,43X,15HRADIATED POWER=,E11.4,6H WATTS
     2,/,43X,15HSTRUCTURE LOSS=,E11.4,6H WATTS,/ ,43X,15HNETWORK LOSS  =
     3, E11.4,6H WATTS,/,43X,15HEFFICIENCY    =,0P,F7.2,8H PERCENT)
170   FORMAT (40X,25HRADIAL WIRE GROUND SCREEN,/,40X,   I5,6H WIRES,/,40
     1X,12HWIRE LENGTH=,F8.2,7H METERS,/,40X,12HWIRE RADIUS=,1P,E10.3,
     27H METERS)
181   FORMAT (///,4X,51HRECEIVING PATTERN STORAGE TOO SMALL,ARRAY TRUNCA
     1TED)
182   FORMAT (///,32X,40H- - - NORMALIZED RECEIVING PATTERN - - -,/,41X,
     121HNORMALIZATION FACTOR=,1P,E11.4,/,41X,4HETA=,0P,F7.2,8H DEGREES,
     2/,41X,6HTYPE -,A6,/,41X,12HAXIAL RATIO=,F6.3,/,41X,12HSEGMENT NO.=
     3,I5,//,21X,5HTHETA,6X,3HPHI,9X,13H-  PATTERN  -,/,21X,5H(DEG),5X,
     45H(DEG),8X,2HDB,8X,9HMAGNITUDE,/)
183   FORMAT (20X,2(F7.2,3X),1X,F7.2,4X,1P,E11.4)
184   FORMAT (///,36X,32H- - - INPUT IMPEDANCE DATA - - -,/   ,45X,18HSO
     1URCE SEGMENT NO.,I4,/  ,45X,21HNORMALIZATION FACTOR=,1P,E12.5,//
     2,7X,5HFREQ.,13X,34H-  -  UNNORMALIZED IMPEDANCE  -  -,21X,   32H-
     3 -  NORMALIZED IMPEDANCE  -  -,/    ,19X,10HRESISTANCE,4X,9HREACTA
     4NCE,6X,9HMAGNITUDE,4X,5HPHASE,7X,10HRESISTANCE,4X,9HREACTANCE,6X,
     5 9HMAGNITUDE,4X,5HPHASE,/    ,8X,3HMHZ,11X,4HOHMS,10X,4HOHMS,11X,
     6 4HOHMS,5X,7HDEGREES,47X,7HDEGREES,/)
185   FORMAT (///,4X,62HSTORAGE FOR IMPEDANCE NORMALIZATION TOO SMALL, A
     1RRAY TRUNCATED)
186   FORMAT (3X,F9.3,2X,1P,2(2X,E12.5),3X,E12.5,2X,0P,F7.2,2X,1P,2(2X,
     1 E12.5),3X,E12.5,2X,0P,F7.2)
196   FORMAT(   ////,20X,55HAPPROXIMATE INTEGRATION EMPLOYED FOR SEGMENT
     1S MORE THAN,F8.3,18H WAVELENGTHS APART)
197   FORMAT(   ////,41X,38H- - - - SURFACE PATCH CURRENTS - - - -,//,
     1 50X,23HDISTANCE IN WAVELENGTHS,/,50X,21HCURRENT IN AMPS/METER,
     1 //,28X,26H- - SURFACE COMPONENTS - -,19X,34H- - - RECTANGULAR COM
     1PONENTS - - -,/,6X,12HPATCH CENTER,6X,16HTANGENT VECTOR 1,3X,
     116HTANGENT VECTOR 2,11X,1HX,19X,1HY,19X,1HZ,/,5X,1HX,6X,1HY,6X,
     11HZ,5X,4HMAG.,7X,5HPHASE,3X,4HMAG.,7X,5HPHASE,3(4X,4HREAL,6X,
     1 6HIMAG. ))
198   FORMAT(1X,I4,/,1X,3F7.3,2(1P,E11.4,0P,F8.2),1P,6E10.2)
201   FORMAT(/,11H RUN TIME =,F10.3)
315   FORMAT(///,34X,28H- - - CHARGE DENSITIES - - -,//,36X,
     1 24HDISTANCES IN WAVELENGTHS,///,2X,4HSEG.,2X,3HTAG,4X,
     2 21HCOORD. OF SEG. CENTER,5X,4HSEG.,10X,
     3 31HCHARGE DENSITY (COULOMBS/METER),/,2X,3HNO.,3X,3HNO.,5X,1HX,8X,
     4 1HY,8X,1HZ,6X,6HLENGTH,5X,4HREAL,8X,5HIMAG.,7X,4HMAG.,8X,5HPHASE)
321   FORMAT( /,20X,42HTHE EXTENDED THIN WIRE KERNEL WILL BE USED)
303   FORMAT(/,9H ERROR - ,A2,32H CARD IS NOT ALLOWED WITH N.G.F.)
327   FORMAT(/,35X,31H LOADING ONLY IN N.G.F. SECTION)
302   FORMAT(48H ERROR - N.G.F. IN USE.  CANNOT WRITE NEW N.G.F.)
313   FORMAT(/,62H NUMBER OF SEGMENTS IN COUPLING CALCULATION (CP) EXCEE
     1DS LIMIT)
390   FORMAT(78H RADIAL WIRE G. S. APPROXIMATION MAY NOT BE USED WITH SO
     1MMERFELD GROUND OPTION)
391   FORMAT(40X,52HFINITE GROUND.  REFLECTION COEFFICIENT APPROXIMATION
     1)
392   FORMAT(40X,35HFINITE GROUND.  SOMMERFELD SOLUTION)
393   FORMAT(/,29H ERROR IN GROUND PARAMETERS -,/,41H COMPLEX DIELECTRIC
     1 CONSTANT FROM FILE IS,1P,2E12.5,/,32X,9HREQUESTED,2E12.5)
      END


!!  Copyright (C)  Stichting Deltares, 2012-2016.
!!
!!  This program is free software: you can redistribute it and/or modify
!!  it under the terms of the GNU General Public License version 3,
!!  as published by the Free Software Foundation.
!!
!!  This program is distributed in the hope that it will be useful,
!!  but WITHOUT ANY WARRANTY; without even the implied warranty of
!!  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!!  GNU General Public License for more details.
!!
!!  You should have received a copy of the GNU General Public License
!!  along with this program. If not, see <http://www.gnu.org/licenses/>.
!!
!!  contact: delft3d.support@deltares.nl
!!  Stichting Deltares
!!  P.O. Box 177
!!  2600 MH Delft, The Netherlands
!!
!!  All indications and logos of, and references to registered trademarks
!!  of Stichting Deltares remain the property of Stichting Deltares. All
!!  rights reserved.

      subroutine sedcar ( pmsa   , fl     , ipoint , increm , noseg  ,
     &                    noflux , iexpnt , iknmrk , noq1   , noq2   ,
     &                    noq3   , noq4   )
!>\file
!>       Sedimentation routine used for OOC, algae, BOD pools, bacteria etc.

!
!     Description of the module :
!
!        General water quality module for DELWAQ:
!        SEDIMENTATION FORMULATIONS
!        MODULE VALID FOR DETC, OOC, DIAT, AAP, BLOOM ALGAE
!
! Name    T   L I/O   Description                                    Units
! ----    --- -  -    -------------------                            -----
! CONC    R*4 1 I  concentration sedimenting material water        [gX/m3]
! DEPTH   R*4 1 I  DELWAQ depth                                        [m]
! FL (1)  R*4 1 O  sedimentation flux (water->mixinglayer)       [gX/m3/d]
! MINDEP  R*4 1 I  minimal depth for sedimentation                     [m]
! PSED    R*4 1 L  sedimentaion probability (0 - 1)                    [-]
! POTSED  R*4 1 L  potential sedimentation flux                  [gX/m2/d]
! TAU     R*4 1 I  calculated sheerstress                        [kg/m/s2]
! TAUVEL  R*4 1 I  total velocity calcualted from tau                [m/s]
! TCRSED  R*4 1 I  critical sheerstress sedimentation            [kg/m/s2]
! VCRSED  R*4 1 I  critical velocity sedimentation                   [m/s]
! VSED    R*4 1 O  first order sedimentaion rate (calculated)        [m/d]
! ZERSED  R*4 1 I  zeroth order sedimentation flux               [gX/m2/d]

!     Logical Units : -

!     Modules called : -

!     Name     Type   Library
!     ------   -----  ------------

      USE BottomSet     !  Module with definition of the waterbottom segments

      IMPLICIT REAL (A-H,J-Z)

      REAL     PMSA  ( * ) , FL    (*)
      INTEGER  IPOINT( * ) , INCREM(*) , NOSEG , NOFLUX,
     +         IEXPNT(4,*) , IKNMRK(*) , NOQ1, NOQ2, NOQ3, NOQ4

      REAL     MINDEP, MINDE2, DEPTH , DEPTH2

      LOGICAL, SAVE :: FIRST = .TRUE.
      LOGICAL       :: SW_PSEDMIN
      INTEGER       :: IDUMMY
      REAL   , SAVE :: PSEDMIN
      CHARACTER     :: CDUMMY
      INTEGER       :: IERR2
      INTEGER       :: LUNREP

      IF ( FIRST ) THEN
         CALL GETCOM('-psedmin', 2 , SW_PSEDMIN, IDUMMY, PSEDMIN, CDUMMY, IERR2)
         IF ( SW_PSEDMIN ) THEN
            CALL GETMLU(LUNREP)
            IF ( IERR2 .EQ. 0 ) THEN
               WRITE(LUNREP,*) ' option -psedmin found, value: ',PSEDMIN
            ELSE
               WRITE(LUNREP,*) ' ERROR: option -psedmin found but value not correct: ',PSEDMIN
            ENDIF
         ELSE
            PSEDMIN = 0.0
         ENDIF
         FIRST = .FALSE.
      ENDIF

      IP1  = IPOINT( 1)
      IP2  = IPOINT( 2)
      IP3  = IPOINT( 3)
      IP4  = IPOINT( 4)
      IP5  = IPOINT( 5)
      IP6  = IPOINT( 6)
      IP7  = IPOINT( 7)
      IP8  = IPOINT( 8)
      IP9  = IPOINT( 9)
      IP10 = IPOINT(10)
      IP11 = IPOINT(11)
      IP12 = IPOINT(12)

      IN1  = INCREM(1 )
      IN2  = INCREM(2 )
      IN3  = INCREM(3 )
      IN4  = INCREM(4 )
      IN5  = INCREM(5 )
      IN6  = INCREM(6 )
      IN7  = INCREM(7 )
      IN8  = INCREM(8 )
      IN9  = INCREM(9 )
      IN10 = INCREM(10)
      IN11 = INCREM(11)
      IN12 = INCREM(12)

      IFLUX = 0
      DO 9000 ISEG = 1 , NOSEG

!     zero output

      PMSA (IP10) = 0.0
      PMSA (IP11) = 0.0

!     sedimentation towards the bottom

      CALL DHKMRK(1,IKNMRK(ISEG),IKMRK1)
      IF (IKMRK1.EQ.1) THEN
      CALL DHKMRK(2,IKNMRK(ISEG),IKMRK2)
      IF ((IKMRK2.EQ.0).OR.(IKMRK2.EQ.3)) THEN
!
      CONC    = MAX (0.0, PMSA(IP1) )
      ZERSED  = PMSA(IP2 )
      VSED    = PMSA(IP3 )
      TAU     = PMSA(IP4 )
      TCRSED  = PMSA(IP5 )
      DEPTH   = PMSA(IP6 )
      DELT    = PMSA(IP7 )
      MINDEP  = PMSA(IP8 )

!***********************************************************************
!**** Processes connected to the SEDIMENTATION
!***********************************************************************

!     Calculate sedimenation probability

      IF (TAU .EQ. -1.0) THEN
          PSED = 1.0
      ELSEIF (TCRSED .LT. 1E-20 )  THEN
          PSED = 0.0
      ELSE
!         vergelijking met critische schuifspanning
          PSED = MAX ( 0.0, (1.0 - TAU/TCRSED) )
      ENDIF
      PSED = MAX( PSEDMIN, PSED )

!     Calculate potential sedimentation fluxes
!     No sedimentation when depth below min depth

      IF ( DEPTH .LT. MINDEP) THEN
         MAXSED       = 0.0
         FL( 1+IFLUX) = 0.0
      ELSE
         POTSED = ZERSED + ( VSED * CONC ) * PSED

!        limit sedimentation to available mass (M/L2/DAY)
         MAXSED = MIN (POTSED, CONC / DELT * DEPTH)

!        convert sedimentation to flux in M/L3/DAY
         FL( 1+IFLUX) =  MAXSED / DEPTH
      ENDIF

!     Output of calculated sedimentation rate
      PMSA (IP10) = PSED
      PMSA (IP11) = MAXSED
!
      ENDIF
      ENDIF
!
      IFLUX = IFLUX + NOFLUX
      IP1   = IP1   + IN1
      IP2   = IP2   + IN2
      IP3   = IP3   + IN3
      IP4   = IP4   + IN4
      IP5   = IP5   + IN5
      IP6   = IP6   + IN6
      IP7   = IP7   + IN7
      IP8   = IP8   + IN8
      IP10  = IP10  + IN10
      IP11  = IP11  + IN11
!
 9000 CONTINUE
!
      IP1  = IPOINT(1 )
      IP6  = IPOINT(6 )
      IP8  = IPOINT(8 )
      IP11 = IPOINT(11)

!.....Exchangeloop over de horizontale richting
      DO 8000 IQ=1,NOQ1+NOQ2

         PMSA(IP12) = 0.0

         IP12 = IP12 + IN12

 8000 CONTINUE

      IP9 = IP9 + ( NOQ1+NOQ2 ) * IN9

!.....Exchangeloop over de verticale richting
      DO 7000 IQ = NOQ1+NOQ2+1 , NOQ1+NOQ2+NOQ3+NOQ4

         IVAN  = IEXPNT(1,IQ)
         INAAR = IEXPNT(2,IQ)

         IF ( IVAN .GT. 0 .AND. INAAR .GT. 0 ) THEN

!           Zoek eerste kenmerk van- en naar-segmenten

            CALL DHKMRK(1,IKNMRK(IVAN ),IKMRKV)
            CALL DHKMRK(1,IKNMRK(INAAR),IKMRKN)
            IF (IKMRKV.EQ.1.AND.IKMRKN.EQ.3) THEN

!               Bodem-water uitwisseling: NUL FLUX OM OOK OUDE PDF's
!                                         TE KUNNEN GEBRUIKEN
!               Snelheid behoeft niet gezet (gebeurt in TRASED)

!               MAXSED = PMSA (IP11+(IVAN-1)*IN11)
!               CONC   = MAX (1E-20, PMSA(IP1+(IVAN-1)*IN1) )
!               PMSA(IP12) = MAXSED/86400./CONC
                FL ( 1 + (IVAN-1)*NOFLUX ) = 0.0

            ELSEIF (IKMRKV.EQ.1.AND.IKMRKN.EQ.1) THEN
!           IF (IKMRKV.EQ.1.AND.IKMRKN.EQ.1) THEN

!               Water-water uitwisseling
!rs             merk op: sedimentatie tussen waterlagen: geen taucr correctie,
!rs             alleen conversie van 1/d naar 1/s. Ten overvloede:
!rs             scu (s) en aux-timer (d) liggen dus vast!

                DEPTH  = PMSA(IP6+(IVAN -1)*IN6)
                DEPTH2 = PMSA(IP6+(INAAR-1)*IN6)
                MINDEP = PMSA(IP8+(IVAN -1)*IN8)
                MINDE2 = PMSA(IP8+(INAAR-1)*IN8)
                IF ( DEPTH .GT. MINDEP .AND. DEPTH2 .GT. MINDE2 ) THEN
                    PMSA(IP12) = PMSA(IP9)/86400.
                ELSE
                    PMSA(IP12) = 0.0
                ENDIF
            ELSE
                PMSA(IP12) = 0.0
            ENDIF

         ENDIF

         IP9 = IP9 + IN9
         IP12= IP12+ IN12

 7000 CONTINUE

!     Handle velocity to the delwaq-g bottom

      IP1  = IPOINT( 1)
      IP2  = IPOINT( 2)
      IP3  = IPOINT( 3)
      IP4  = IPOINT( 4)
      IP5  = IPOINT( 5)
      IP6  = IPOINT( 6)
      IP7  = IPOINT( 7)
      IP8  = IPOINT( 8)
      IP9  = IPOINT( 9)
      IP10 = IPOINT(10)
      IP11 = IPOINT(11)
      IP12 = IPOINT(12)

      DO IK = 1 , Coll%cursize

         IWA1 = Coll%set(IK)%fstwatsed
         IWA2 = Coll%set(IK)%lstwatsed

         DO IQ = IWA1,IWA2
            IWATER  = IEXPNT(1,IQ)

            CONC    = MAX (0.0, PMSA(IP1+(IWATER-1)*IN1) )
            ZERSED  = PMSA(IP2+(IWATER-1)*IN2)
            VSED    = PMSA(IP3+(IWATER-1)*IN3)
            TAU     = PMSA(IP4+(IWATER-1)*IN4)
            TCRSED  = PMSA(IP5+(IWATER-1)*IN5)
            DEPTH   = PMSA(IP6+(IWATER-1)*IN6)
            DELT    = PMSA(IP7+(IWATER-1)*IN7)
            MINDEP  = PMSA(IP8+(IWATER-1)*IN8)

!           Calculate sedimenation probability

            IF (TAU .EQ. -1.0) THEN
                PSED = 1.0
            ELSEIF (TCRSED .LT. 1E-20 )  THEN
                PSED = 0.0
            ELSE
!               vergelijking met critische schuifspanning
                PSED = MAX ( 0.0, (1.0 - TAU/TCRSED) )
            ENDIF

!           Bereken de potentiele sedimentatie fluxen
!           Geen sedimentatie onder een minimale diepte

            IF ( DEPTH .LT. MINDEP) THEN
               MAXSED       = 0.0
            ELSE
               POTSED = ZERSED + ( VSED * CONC ) * PSED

!              sedimenteer maximaal de aanwezige hoeveelheid (M/L2/DAY)
               MAXSED = MIN (POTSED, CONC / DELT * DEPTH)

            ENDIF

            IF ( CONC .GT. 1.E-10 ) THEN
               PMSA(IP12+(IQ-1)*IN12) = MAXSED/86400./CONC
            ENDIF

         ENDDO

      ENDDO
!
      RETURN
      END


module ConstantsModule
  use KindModule
  public
  ! -- constants
  integer(I4B), parameter :: IUSERFORMATSTRIP = -99
  integer(I4B), parameter :: IUSERFORMATWRAP = 99
  integer(I4B), parameter :: LENBIGLINE = 5000
  integer(I4B), parameter :: LENHUGELINE = 50000
  integer(I4B), parameter :: LENVARNAME = 16
  integer(I4B), parameter :: LENCOMPONENTNAME = 16
  integer(I4B), parameter :: LENSOLUTIONNAME = LENCOMPONENTNAME                         !< maximum length of the solution name
  integer(I4B), parameter :: LENMODELNAME = LENCOMPONENTNAME                            !< maximum length of the model name
  integer(I4B), parameter :: LENPACKAGENAME = LENCOMPONENTNAME                          !< maximum length of the package name
  integer(I4B), parameter :: LENEXCHANGENAME = LENCOMPONENTNAME                         !< maximum length of the exchange name
  integer(I4B), parameter :: LENMEMSEPARATOR = 1                                        !< maximum length of the memory path separator used, currently a '/'
  integer(I4B), parameter :: LENMEMPATH = 2*LENCOMPONENTNAME + LENMEMSEPARATOR          !< maximum length of the memory path
  integer(I4B), parameter :: LENMEMADDRESS = LENMEMPATH + LENMEMSEPARATOR + LENVARNAME  !< maximum length of the full memory address, including variable name
  integer(I4B), parameter :: LENAUXNAME = 16
  integer(I4B), parameter :: LENBOUNDNAME = 40
  integer(I4B), parameter :: LENBUDTXT = 16
  integer(I4B), parameter :: LENPACKAGETYPE = 7
  integer(I4B), parameter :: LENFTYPE = 5
  integer(I4B), parameter :: LENOBSNAME = 40
  integer(I4B), parameter :: LENOBSTYPE = 30
  integer(I4B), parameter :: LENTIMESERIESNAME = LENOBSNAME
  integer(I4B), parameter :: LENTIMESERIESTEXT = 12
  integer(I4B), parameter :: LENDATETIME = 30
  integer(I4B), parameter :: LINELENGTH = 300
  integer(I4B), parameter :: LENLISTLABEL = 500
  integer(I4B), parameter :: MAXCHARLEN = max(1000, LENBIGLINE)
  integer(I4B), parameter :: MAXOBSTYPES = 100
  integer(I4B), parameter :: NAMEDBOUNDFLAG = -9
  integer(I4B), parameter :: LENPAKLOC = 34
  integer(I4B), parameter :: IZERO = 0
  !
  ! -- file constants
  integer(I4B), parameter :: IUSTART = 1000
  integer(I4B), parameter :: IULAST = 10000
  !
  ! -- memory manager constants
  integer(I4B), public, parameter :: MAXMEMRANK = 3
  integer(I4B), public, parameter :: LENMEMTYPE = 50
  !
  ! -- real constants
  real(DP), parameter :: DZERO = 0.0_DP
  real(DP), parameter :: DQUARTER = 0.25_DP
  real(DP), parameter :: DONETHIRD = 1.0_DP / 3.0_DP
  real(DP), parameter :: DHALF = 0.5_DP
  real(DP), parameter :: DP6 = 0.6_DP
  real(DP), parameter :: DTWOTHIRDS = 2.0_DP / 3.0_DP
  real(DP), parameter :: DP7 = 0.7_DP
  real(DP), parameter :: DP9 = 0.9_DP
  real(DP), parameter :: DP99 = 0.99_DP
  real(DP), parameter :: DP999 = 0.999_DP

  real(DP), parameter :: DONE = 1.0_DP
  real(DP), parameter :: D1P1 = 1.1_DP
  real(DP), parameter :: DFIVETHIRDS = 5.0_DP / 3.0_DP
  real(DP), parameter :: DTWO = 2.0_DP
  real(DP), parameter :: DTHREE = 3.0_DP
  real(DP), parameter :: DFOUR = 4.0_DP
  real(DP), parameter :: DSIX = 6.0_DP
  real(DP), parameter :: DEIGHT = 8.0_DP
  real(DP), parameter :: DTEN = 1.0e1_DP
  real(DP), parameter :: DHUNDRED = 1.0e2_DP

  real(DP), parameter :: DEP3 = 1.0e3_DP
  real(DP), parameter :: DEP6 = 1.0e6_DP
  real(DP), parameter :: DEP9 = 1.0e9_DP
  real(DP), parameter :: DEP20 = 1.0e20_DP

  real(DP), parameter :: DHNOFLO = 1.e30_DP
  real(DP), parameter :: DHDRY = -1.e30_DP
  real(DP), parameter :: DNODATA = 3.0e30_DP

  real(DP), parameter :: DEM1  = 1.0e-1_DP
  real(DP), parameter :: D5EM2 = 5.0e-2_DP
  real(DP), parameter :: DEM2  = 1.0e-2_DP
  real(DP), parameter :: DEM3  = 1.0e-3_DP
  real(DP), parameter :: DEM4  = 1.0e-4_DP
  real(DP), parameter :: DEM5  = 1.0e-5_DP
  real(DP), parameter :: DEM6  = 1.0e-6_DP
  real(DP), parameter :: DEM7  = 1.0e-7_DP
  real(DP), parameter :: DEM8  = 1.0e-8_DP
  real(DP), parameter :: DEM9  = 1.0e-9_DP
  real(DP), parameter :: DEM10 = 1.0e-10_DP
  real(DP), parameter :: DEM12 = 1.0e-12_DP
  real(DP), parameter :: DEM14 = 1.0e-14_DP
  real(DP), parameter :: DEM15 = 1.0e-15_DP
  real(DP), parameter :: DEM20 = 1.0e-20_DP
  real(DP), parameter :: DEM30 = 1.0e-30_DP

  real(DP), parameter :: DPREC = EPSILON(1.0_DP)
  real(DP), parameter :: DSAME = DHUNDRED * DPREC

  real(DP), parameter :: DLNLOW = 0.995_DP
  real(DP), parameter :: DLNHIGH = 1.005_DP

  real(DP), parameter :: DPI = DFOUR * ATAN(DONE)
  real(DP), parameter :: DTWOPI = DTWO * DFOUR * ATAN(DONE)
  real(DP), parameter :: DPIO180 = datan(DONE)/4.5d1

  real(DP), parameter :: DGRAVITY = 9.80665_DP
  real(DP), parameter :: DCD = 0.61_DP

  character(len=10), dimension(3, 3), parameter :: cidxnames = reshape (       &
    [ '      NODE', '          ', '          ',                                &
      '     LAYER', '    CELL2D', '          ',                                &
      '     LAYER', '       ROW', '       COL'], [3,3])

  ! -- Enumerators used with TimeSeriesType
  ENUM, BIND(C)
    ! Sets UNDEFINED=0, STEPWISE=1, LINEAR=2, LINEAREND=3
    ENUMERATOR :: UNDEFINED, STEPWISE, LINEAR, LINEAREND
  END ENUM

  ! -- enumerators used with table objects
  ENUM, BIND(C)
    ! Sets TABLEFT=0, TABCENTER=1, TABRIGHT=2
    ENUMERATOR :: TABLEFT, TABCENTER, TABRIGHT
  END ENUM

  ENUM, BIND(C)
    ! Sets TABSTRING=0, TABUCSTRING=1, TABINTEGER=2, TABREAL=3
    ENUMERATOR :: TABSTRING, TABUCSTRING, TABINTEGER, TABREAL
  END ENUM

  ENUM, BIND(C)
    ! Sets VSUMMARY=0, VALL=1, VDEBUG=2
    ENUMERATOR :: VSUMMARY, VALL, VDEBUG
  END ENUM

  ENUM, BIND(C)
    ! Sets OSUNDEF=0, OSLINUX=1, OSMAC=2, OSWIN=3
    ENUMERATOR :: OSUNDEF, OSLINUX, OSMAC, OSWIN
  END ENUM

  ENUM, BIND(C)
    ! Sets MVALIDATE=0, MNORMAL=1, MRUN=2
    ENUMERATOR :: MVALIDATE, MNORMAL, MRUN
  END ENUM

end module ConstantsModule


!--------------------------------------------------------------------------------------
program HSwithSLHA
!--------------------------------------------------------------------------------------
! This example program is part of HiggsSignals (TS 29/01/2013).
!
! In this example we demonstrate how HiggsSignals can be run on SLHA files. The SLHA
! file has to contain the two HiggsBounds SLHA input blocks
!	HiggsBoundsInputHiggsCouplingsBosons
!	HiggsBoundsInputHiggsCouplingsFermions
! (see HiggsBounds (version 3 or more) manual for more details)
!
! Run with
!   ./HSwithSLHA npoints <stem>
! where npoints is the number of parameter points you would like to
! look at and each parameter point has a corresponding SLHA file
! e.g. the corresponding SLHA for the 5th point should be found at
!   <stem>.5
!
! Output:
! The HiggsSignals SLHA output blocks will be added to each SLHA file.
! The results are summarized in an additional file <stem>-fromHS
!
! We furthermore demonstrate how to get the signal rates directly from HiggsSignals
! after a successful run.
!--------------------------------------------------------------------------------------
  use io, only : HiggsSignals_SLHA_output, get_peakinfo_from_HSresults
  use pc_chisq, only : print_cov_mu_to_file, print_peaks_to_file
  implicit none
  integer :: nH,nHplus,ndf
  double precision :: Chisq, Chisq_mu, Chisq_mh, Pvalue
  double precision :: dCS(5),dBR(5)
  double precision :: R_H_WW, R_H_ZZ, R_H_gaga, R_H_tautau, R_H_bb, R_VH_bb, 			&
&                     totalrate, ggf_rate, hgaga_rate, gghgg_rate
  double precision, allocatable :: dMh(:), masses(:), dmasses(:)
  integer :: i,npoints
  integer,parameter :: fileid=78, fileid2=79
  character(len=8) :: istring
  character(len=300) :: inputfilename,outputfilename
  character(len=300) :: stem
  character(LEN=300) :: temp, tmpstring
  integer :: number_args, ios
!--------------------------------------------------------------------------------------
  nH=3
  nHplus=1

  allocate(dMh(nH),masses(nH),dmasses(nH))
!--Give estimates on (relative!) systematic uncertainties for:
!  dCS(1) - singleH				dBR(1) - gamma gamma
!  dCS(2) - VBF					dBR(2) - W W
!  dCS(3) - HW					dBR(3) - Z Z
!  dCS(4) - HZ					dBR(4) - tau tau
!  dCS(5) - ttH					dBR(5) - b bbar
!--Enter now the rate uncertainties for your model (typical MSSM estimates):
  dCS = (/ 0.20D0, 0.028D0, 0.037D0, 0.051D0, 0.12D0 /)
  dBR = (/ 0.054D0, 0.048D0, 0.048D0, 0.061D0, 0.028D0 /)
!--n.b. have to set theoretical uncertainties on Higgs masses dMh (in GeV) for h,H,A:
! These are default values. In SLHA mode, these values are read in from the Block "DMASS".
  dMh = (/ 2.0D0, 2.0D0, 0.0D0 /)
!----------------------------------- preprocessing --------------------------------------!
  number_args = IARGC()
  if( number_args .ne. 2)then
   stop "Incorrect number of arguments given to HSwithSLHA"
  endif
  ! Read arguments into text strings.
  i=1
  temp=""
  call GETARG(i,temp)
  read(temp,*) npoints
  i=i+1
  temp=""
  call GETARG(i,temp)
  stem = ""
  stem = trim(temp)
!------------------------------ HiggsSignals options ------------------------------------!
!---- Initialize HiggsSignals and pass the name of the experimental analysis folder  ----!
 call initialize_HiggsSignals(nH,nHplus,"latestresults")
!---- Set the output level (0: silent, 1: screen output, 2: even more output,...) 	 ----!
 call setup_output_level(1)
!---- Set the Higgs mass parametrization (1: box, 2:gaussian, 3:box+gaussian)	 	 ----!
 call setup_pdf(2)
!---- Set the assignment range for the peak-centered method (optional)				 ----!
 call setup_assignmentrange_massobservables(2.0D0)
!---- If the mass-centered chi^2 method is used, can specify the dm_theory treatment ----!
!     1: mass variation, 2: smearing of mu-plot with mass pdf
! call setup_mcmethod_dm_theory(1)
!---- Use symmetric rate errors? (0: original(default), 1: averaged-symmetrical)     ----!
! call setup_symmetricerrors(0)
!---- Are SM rate uncertainties included in signal strength measurements?            ----!
!    (0: no, 1: yes(default) )
! call setup_thu_observables(1)
!---- Allow anti-correlated signal strength measurements? (0: no, 1: yes(default) )  ----!
! call setup_anticorrelations_in_mu(1)
!----

  outputfilename=trim(adjustl(stem))//'-fromHS'
  open(fileid, file=trim(outputfilename))

  do i=1,npoints
   if(i.gt.99999999)stop'need to increase the size of istring in HSwithSLHA'
   write(istring,'(I8)')i
   inputfilename=trim(adjustl(stem))//'.'//trim(adjustl(istring))
!--Test if input file exists and is non-empty
   open(fileid2, file=inputfilename, form='formatted')
   read(fileid2,'(A)',iostat=ios) tmpstring

   if(ios.eq.0) then
    close(fileid2)

!-------------------------------- HiggsSignals run --------------------------------------!
!---- Feed HiggsSignals with the the model input using HiggsBounds subroutine	 	 ----!
    call HiggsBounds_input_SLHA(inputfilename)
!---- Checking the Higgs mass uncertainty           							 	 ----!
! The theoretical Higgs mass uncertainties are read in from the SLHA Block "DMASS"
! in the call of the subroutine HiggsBounds_input_SLHA. If the block "DMASS" is absent,
! they are set to zero. If the user wants to change the values obtained from the SLHA
! file, he/she can call the subroutine
! 	HiggsSignals_neutral_input_MassUncertainty
! AFTER reading in the SLHA file.
! Here, we only print out the values which have been stored already in
! HiggsBounds/HiggsSignals. If their sum is <= zero, the Block DMASS was probably absent
! and we set the default values as specified above.
!
    call get_neutral_Higgs_masses(masses, dmasses)
    write(*,*) "Neutral Higgs boson mass spectrum (from SLHA): "
    write(*,'(2X,A,F6.2,A,F4.2)') "mass(h0) = ",masses(1)," +- ",dmasses(1)
    write(*,'(2X,A,F6.2,A,F4.2)') "mass(H0) = ",masses(2)," +- ",dmasses(2)
    write(*,'(2X,A,F6.2,A,F4.2)') "mass(A0) = ",masses(3)," +- ",dmasses(3)
    if(sum(dmasses).le.0.0D0) then
     write(*,*) "BLOCK DMASS not found, changing mass uncertainies to ", dMh
 	 call HiggsSignals_neutral_input_MassUncertainty(dMh)
 	endif
!---- Set the production and decay rate uncertainties for the model			 	 	 ----!
    call setup_rate_uncertainties(dCS, dBR)
!---- Run HiggsSignals (runmode: 1 (peak-centered), 2 (mass-centered), 3 (both)
    call run_HiggsSignals(1, Chisq_mu, Chisq_mh, Chisq, ndf, Pvalue)
!----------------------------- HiggsSignals output --------------------------------------!
!---- Attach HiggsSignals SLHA blocks to SLHA file									 ----!
!   integer argument gives level of details:
!   0 : writes only HiggsSignalsResults block
!   else : writes all blocks
    call HiggsSignals_SLHA_output(1)
!---- Now, some examples of how to read out the signal rates. Note, that these subroutines
!     have to be called after run_HiggsSignals
!
!---- Get signal-rate ratios (without efficiencies) for lightest Higgs boson and LHC8----!
    call get_Rvalues(1, 3, R_H_WW, R_H_ZZ, R_H_gaga, R_H_tautau, R_H_bb, R_VH_bb)
!---- Get the total signal rate (without efficiencies)					 			 ----!
	call get_rates(1,3,25,(/11,12,13,14,15,21,22,23,24,25,31,32,33,34,35,				&
&							41,42,43,44,45,51,52,53,54,55/),totalrate)
!---- Get the gluon gluon fusion rate (without efficiencies)			 			 ----!
	call get_rates(1,3,1,(/10/),ggf_rate)
!---- Get the H -> gamma gamma rate (without efficiencies)				 			 ----!
	call get_rates(1,3,1,(/01/),hgaga_rate)
!	NEW SINCE HiggsSignals-1.1.0: more decay modes accessible via get_rates:
!	  Decay mode ID (Final state):  6 (Zgamma), 7 (cc), 8 (mumu), 9 (gg)
!---- Get the gg->H->gg (without efficiencies)				 			             ----!
	call get_rates(1,3,1,(/19/),gghgg_rate)

    write(*,'(A,F10.4)') "R_H_WW     = ", R_H_WW
    write(*,'(A,F10.4)') "R_H_ZZ     = ", R_H_ZZ
    write(*,'(A,F10.4)') "R_H_gaga   = ", R_H_gaga
    write(*,'(A,F10.4)') "R_H_tautau = ", R_H_tautau
    write(*,'(A,F10.4)') "R_H_bb     = ", R_H_bb
    write(*,'(A,F10.4)') "R_VH_bb    = ", R_VH_bb
    write(*,'(A,F10.4)') "totalrate  = ", totalrate
    write(*,'(A,F10.4)') "ggf_rate   = ", ggf_rate
    write(*,'(A,F10.4)') "h->gaga    = ", hgaga_rate
    write(*,'(A,F10.4)') "gg->h->gg  = ", gghgg_rate

!--This will collect the main HiggsSignals results together into one file
    write(fileid,*)i,Pvalue,Chisq,Chisq_mu,Chisq_mh,ndf
   else
    close(fileid2)
    call system("rm -f "//inputfilename)
   endif

  enddo

  close(fileid)
! call print_peaks_to_file
! call print_cov_mu_to_file

 call finish_HiggsSignals

end program HSwithSLHA