cc ------------ dpmjet3.4 - authors: S.Roesler, R.Engel, J.Ranft -------
cc -------- phojet1.12-40 - authors: S.Roesler, R.Engel, J.Ranft -------
cc                                                      - oct'13 -------
cc ----------- pythia-6.4 - authors: Torbjorn Sjostrand, Lund'10 -------
cc ---------------------------------------------------------------------
cc                                  converted for use with FLUKA -------
cc                                                      - oct'13 -------

C...PYEVNT
C...Administers the generation of a high-pT event via calls to
C...a number of subroutines.

      SUBROUTINE PYEVNT

C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      INTEGER PYCOMP
      PARAMETER (MAXNUR=1000)
C...Commonblocks.
      include 'inc/pypart'
      include 'inc/pyjets'
      include 'inc/pyctag'
      include 'inc/pydat1'
      include 'inc/pydat2'
      include 'inc/pydat3'
      include 'inc/pypars'
      include 'inc/pyint1'
      include 'inc/pyint2'
      include 'inc/pyint4'
      include 'inc/pyint5'
C...Local array.
      DIMENSION VTX(4)

C...Optionally let PYEVNW do the whole job.
      IF(MSTP(81).GE.20) THEN
        CALL PYEVNW
        RETURN
      ENDIF

C...Stop if no subprocesses on.
      IF(MINT(121).EQ.1.AND.MSTI(53).EQ.1) THEN
        WRITE(MSTU(11),5100)
        CALL PYSTOP(1)
      ENDIF

C...Initial values for some counters.
      MSTU(1)=0
      MSTU(2)=0
      N=0
      MINT(5)=MINT(5)+1
      MINT(7)=0
      MINT(8)=0
      MINT(30)=0
      MINT(83)=0
      MINT(84)=MSTP(126)
      MSTU(24)=0
      MSTU70=0
      MSTJ14=MSTJ(14)
C...Normally, use K(I,4:5) colour info rather than /PYCTAG/.
      NCT=0
      MINT(33)=0

C...Let called routines know call is from PYEVNT (not PYEVNW).
      MINT(35)=1
      IF (MSTP(81).GE.10) MINT(35)=2

C...If variable energies: redo incoming kinematics and cross-section.
      MSTI(61)=0
      IF(MSTP(171).EQ.1) THEN
        CALL PYINKI(1)
        IF(MSTI(61).EQ.1) THEN
          MINT(5)=MINT(5)-1
          RETURN
        ENDIF
        IF(MINT(121).GT.1) CALL PYSAVE(3,1)
        CALL PYXTOT
      ENDIF

C...Loop over number of pileup events; check space left.
      IF(MSTP(131).LE.0) THEN
        NPILE=1
      ELSE
        CALL PYPILE(2)
        NPILE=MINT(81)
      ENDIF
      DO 270 IPILE=1,NPILE
        IF(MINT(84)+100.GE.MSTU(4)) THEN
          CALL PYERRM(11,
     &    '(PYEVNT:) no more space in PYJETS for pileup events')
          IF(MSTU(21).GE.1) GOTO 280
        ENDIF
        MINT(82)=IPILE

C...Generate variables of hard scattering.
        MINT(51)=0
        MSTI(52)=0
  100   CONTINUE
        IF(MINT(51).NE.0.OR.MSTU(24).NE.0) MSTI(52)=MSTI(52)+1
        MINT(31)=0
        MINT(39)=0
        MINT(51)=0
        MINT(57)=0
        CALL PYRAND
        IF(MSTI(61).EQ.1) THEN
          MINT(5)=MINT(5)-1
          RETURN
        ENDIF
        IF(MINT(51).EQ.2) RETURN
        ISUB=MINT(1)
        IF(MSTP(111).EQ.-1) GOTO 260

C...Loopback point if PYPREP fails, especially for junction topologies.
        NPREP=0
        MNT31S=MINT(31)
  110   NPREP=NPREP+1
        MINT(31)=MNT31S

        IF((ISUB.LE.90.OR.ISUB.GE.95).AND.ISUB.NE.99) THEN
C...Hard scattering (including low-pT):
C...reconstruct kinematics and colour flow of hard scattering.
          MINT31=MINT(31)
  120     MINT(31)=MINT31
          MINT(51)=0
          CALL PYSCAT
          IF(MINT(51).EQ.1) GOTO 100
          IPU1=MINT(84)+1
          IPU2=MINT(84)+2
          IF(ISUB.EQ.95) GOTO 140

C...Reset statistics on activity in event.
        DO 130 J=351,359
          MINT(J)=0
          VINT(J)=0D0
  130   CONTINUE

C...Showering of initial state partons (optional).
          NFIN=N
          ALAMSV=PARJ(81)
          PARJ(81)=PARP(72)
          IF(MSTP(61).GE.1.AND.MINT(47).GE.2.AND.MINT(111).NE.12)
     &    CALL PYSSPA(IPU1,IPU2)
          PARJ(81)=ALAMSV
          IF(MINT(51).EQ.1) GOTO 100

C...pT-ordered FSR off ISR (optional, must have at least 2 partons)
          IF (NPART.GE.2.AND.(MSTJ(41).EQ.11.OR.MSTJ(41).EQ.12)) THEN
            PTMAX=0.5*SQRT(PARP(71))*VINT(55)
            CALL PYPTFS(3,PTMAX,0D0,PTGEN)
          ENDIF

C...Showering of final state partons (optional).
          ALAMSV=PARJ(81)
          PARJ(81)=PARP(72)
          IF(MSTP(71).GE.1.AND.ISET(ISUB).GE.2.AND.ISET(ISUB).LE.10)
     &    THEN
            IPU3=MINT(84)+3
            IPU4=MINT(84)+4
            IF(ISET(ISUB).EQ.5) IPU4=-3
            QMAX=VINT(55)
            IF(ISET(ISUB).EQ.2) QMAX=SQRT(PARP(71))*VINT(55)
            CALL PYSHOW(IPU3,IPU4,QMAX)
          ELSEIF(ISET(ISUB).EQ.11) THEN
            CALL PYADSH(NFIN)
          ENDIF
          PARJ(81)=ALAMSV

C...Allow possibility for user to abort event generation.
          IVETO=0
          IF(IPILE.EQ.1.AND.MSTP(143).EQ.1) CALL PYVETO(IVETO)
          IF(IVETO.EQ.1) GOTO 100

C...Decay of final state resonances.
          MINT(32)=0
          IF(MSTP(41).GE.1.AND.ISET(ISUB).LE.10) CALL PYRESD(0)
          IF(MINT(51).EQ.1) GOTO 100
          MINT(52)=N

C...Multiple interactions - PYTHIA 6.3 intermediate style.
  140     IF(MSTP(81).GE.10.AND.MINT(50).EQ.1) THEN
            IF(ISUB.EQ.95) MINT(31)=MINT(31)+1
            CALL PYMIGN(6)
            IF(MINT(51).EQ.1) GOTO 100
            MINT(53)=N

C...Beam remnant flavour and colour assignments - new scheme.
            CALL PYMIHK
            IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5)
     &      GOTO 120
            IF(MINT(51).EQ.1) GOTO 100

C...Primordial kT and beam remnant momentum sharing - new scheme.
            CALL PYMIRM
            IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5)
     &      GOTO 120
            IF(MINT(51).EQ.1) GOTO 100
            IF(ISUB.EQ.95) MINT(31)=MINT(31)-1

C...Multiple interactions - PYTHIA 6.2 style.
          ELSEIF(MINT(111).NE.12) THEN
            IF (MSTP(81).GE.1.AND.MINT(50).EQ.1.AND.ISUB.NE.95) THEN
              CALL PYMULT(6)
              MINT(53)=N
            ENDIF

C...Hadron remnants and primordial kT.
            CALL PYREMN(IPU1,IPU2)
            IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5) GOTO
     &           110
            IF(MINT(51).EQ.1) GOTO 100
          ENDIF

        ELSEIF(ISUB.NE.99) THEN
C...Diffractive and elastic scattering.
          CALL PYDIFF

        ELSE
C...DIS scattering (photon flux external).
          CALL PYDISG
          IF(MINT(51).EQ.1) GOTO 100
        ENDIF

C...Check that no odd resonance left undecayed.
        MINT(54)=N
        IF(MSTP(111).GE.1) THEN
          NFIX=N
          DO 150 I=MINT(84)+1,NFIX
            IF(K(I,1).GE.1.AND.K(I,1).LE.10.AND.K(I,2).NE.21.AND.
     &      K(I,2).NE.22) THEN
              KCA=PYCOMP(K(I,2))
              IF(MWID(KCA).NE.0.AND.MDCY(KCA,1).GE.1) THEN
                CALL PYRESD(I)
                IF(MINT(51).EQ.1) GOTO 100
              ENDIF
            ENDIF
  150     CONTINUE
        ENDIF

C...Boost hadronic subsystem to overall rest frame.
C..(Only relevant when photon inside lepton beam.)
        IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(4,WTGAGA)

C...Recalculate energies from momenta and masses (if desired).
        IF(MSTP(113).GE.1) THEN
          DO 160 I=MINT(83)+1,N
            IF(K(I,1).GT.0.AND.K(I,1).LE.10) P(I,4)=SQRT(P(I,1)**2+
     &      P(I,2)**2+P(I,3)**2+P(I,5)**2)
  160     CONTINUE
          NRECAL=N
        ENDIF

C...Colour reconnection before string formation
        IF (MSTP(95).GE.2) CALL PYFSCR(MINT(84)+1)

C...Rearrange partons along strings, check invariant mass cuts.
        MSTU(28)=0
        IF(MSTP(111).LE.0) MSTJ(14)=-1
        CALL PYPREP(MINT(84)+1)
        MSTJ(14)=MSTJ14
        IF(MINT(51).EQ.1.AND.MSTU(24).EQ.1) THEN
          MSTU(24)=0
          GOTO 100
        ENDIF
        IF (MINT(51).EQ.1.AND.NPREP.LE.5) GOTO 110
        IF (MINT(51).EQ.1) GOTO 100
        IF(MSTP(112).EQ.1.AND.MSTU(28).EQ.3) GOTO 100
        IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) THEN
          DO 190 I=MINT(84)+1,N
            IF(K(I,2).EQ.94) THEN
              DO 180 I1=I+1,MIN(N,I+10)
                IF(K(I1,3).EQ.I) THEN
                  K(I1,3)=MOD(K(I1,4)/MSTU(5),MSTU(5))
                  IF(K(I1,3).EQ.0) THEN
                    DO 170 II=MINT(84)+1,I-1
                        IF(K(II,2).EQ.K(I1,2)) THEN
                          IF(MOD(K(II,4),MSTU(5)).EQ.I1.OR.
     &                    MOD(K(II,5),MSTU(5)).EQ.I1) K(I1,3)=II
                        ENDIF
  170               CONTINUE
                    IF(K(I+1,3).EQ.0) K(I+1,3)=K(I,3)
                  ENDIF
                ENDIF
  180         CONTINUE
            ENDIF
  190     CONTINUE
          CALL PYEDIT(12)
          CALL PYEDIT(14)
          IF(MSTP(125).EQ.0) CALL PYEDIT(15)
          IF(MSTP(125).EQ.0) MINT(4)=0
          DO 210 I=MINT(83)+1,N
            IF(K(I,1).EQ.11.AND.K(I,4).EQ.0.AND.K(I,5).EQ.0) THEN
              DO 200 I1=I+1,N
                IF(K(I1,3).EQ.I.AND.K(I,4).EQ.0) K(I,4)=I1
                IF(K(I1,3).EQ.I) K(I,5)=I1
  200         CONTINUE
            ENDIF
  210     CONTINUE
        ENDIF

C...Introduce separators between sections in PYLIST event listing.
        IF(IPILE.EQ.1.AND.MSTP(125).LE.0) THEN
          MSTU70=1
          MSTU(71)=N
        ELSEIF(IPILE.EQ.1) THEN
          MSTU70=3
          MSTU(71)=2
          MSTU(72)=MINT(4)
          MSTU(73)=N
        ENDIF

C...Go back to lab frame (needed for vertices, also in fragmentation).
        CALL PYFRAM(1)

C...Set nonvanishing production vertex (optional).
        IF(MSTP(151).EQ.1) THEN
          DO 220 J=1,4
            VTX(J)=PARP(150+J)*SQRT(-2D0*LOG(MAX(1D-10,PYR(0))))*
     &      SIN(PARU(2)*PYR(0))
  220     CONTINUE
          DO 240 I=MINT(83)+1,N
            DO 230 J=1,4
              V(I,J)=V(I,J)+VTX(J)
  230       CONTINUE
  240     CONTINUE
        ENDIF

C...Perform hadronization (if desired).
        IF(MSTP(111).GE.1) THEN
          CALL PYEXEC
          IF(MSTU(24).NE.0) GOTO 100
        ENDIF
        IF(MSTP(113).GE.1) THEN
          DO 250 I=NRECAL,N
            IF(P(I,5).GT.0D0) P(I,4)=SQRT(P(I,1)**2+
     &      P(I,2)**2+P(I,3)**2+P(I,5)**2)
  250     CONTINUE
        ENDIF
        IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) CALL PYEDIT(14)

C...Store event information and calculate Monte Carlo estimates of
C...subprocess cross-sections.
  260   IF(IPILE.EQ.1) CALL PYDOCU

C...Set counters for current pileup event and loop to next one.
        MSTI(41)=IPILE
        IF(IPILE.GE.2.AND.IPILE.LE.10) MSTI(40+IPILE)=ISUB
        IF(MSTU70.LT.10) THEN
          MSTU70=MSTU70+1
          MSTU(70+MSTU70)=N
        ENDIF
        MINT(83)=N
        MINT(84)=N+MSTP(126)
        IF(IPILE.LT.NPILE) CALL PYFRAM(2)
  270 CONTINUE

C...Generic information on pileup events. Reconstruct missing history.
      IF(MSTP(131).EQ.1.AND.MSTP(133).GE.1) THEN
        PARI(91)=VINT(132)
        PARI(92)=VINT(133)
        PARI(93)=VINT(134)
        IF(MSTP(133).GE.2) PARI(93)=PARI(93)*XSEC(0,3)/VINT(131)
      ENDIF
      CALL PYEDIT(16)

C...Transform to the desired coordinate frame.
  280 CALL PYFRAM(MSTP(124))
      MSTU(70)=MSTU70
      PARU(21)=VINT(1)

C...Error messages
 5100 FORMAT(1X,'Error: no subprocess switched on.'/
     &1X,'Execution stopped.')

      RETURN
      END


C
C	MAIN PROGRAM TO CALULATE THE ELECTROSTATIC POTENTIAL
C
C	E.L. MEHLER  MAY 9, 1990, REVISED NOV 29, 1990
C	Revised to calculate pK only April, 1997
C
C	CALCULATE SELF-CONSISTENT CHARGE DISTRIBUTION OF
C	MACROMOLECULE AND pK OF IONIZABLE GROUPS.
C
C
C	SCREENING FUNCTION 1 = CONSTANT;
C                          2 = LINEAR;
C                          3 = WDS;
C	                   4 = SCALED
C			   5 Combined 3 & 4 according to SASA
C
      IMPLICIT REAL*8 (A-H,O-Z)
      CHARACTER FILTP*3,ANS*1,ATMM(100)*4,RES(100)*3,
     *NRES(100)*4,UNT*2,PCOD*4
      LOGICAL DEBUG,INGRP(1),VEPS,RESET
      REAL*8 RCUT(2),RCUT0(2),Q(100),RMIN0(3),RMAX0(3)
      REAL*4 ti,tim(2),dtime
      PARAMETER (INPT=5,IOUT=6)
      INCLUDE 'esp.inc'
      INCLUDE 'screen.inc'
      DATA DEBUG/.FALSE./,RCUT0/100.,900./,IPT,IPT2/0,0/,Q/100*0./
      DATA VEPS/.FALSE./,reset/.true./
      DATA IDB/0/
C     DATA NGRES/3,4,3,6,4,4,3,4,3,2,3,3,4,3,6,5,5,4,3,4/
C     DATA SMENV/0.,-18.453,6*0.,-12.832,4*0.,-13.492,8*0.,-8.368,3*0.,
C    *-11.420,5*0.,-11.420,3*0.,84*0./
C
C       RESGRP = code for residues which can be protonated
C       and/or are charged
C	In the program the residue type is stored as the position
C	in array RESGRP
C
C	INGRP = code of ionizable groups included in pK calculation
C	default is GLU, ASP, LYS, ARG and termini
C
C 1 'HIS'	'AM','HS','CM',2*'  ',
C 2 'HSE'	'AM','HS','CM',2*'  ',
C 3 'HSD'	'AM','HS','CM',2*'  ',
C 4 'GLU'	'AM','HP','CO','CM','  ',
C 5 'ASP'	'AM','CO','CM',2*'  ',
C 6 'TYR'	'AM','HP','RS','PH','CM',
C 7 'LYS'	'AM','HP','AS','CM','  ',
C 8 'ARG'	'AM','HP','GS','CM','  ',
C 9 'SER'	'AM','OL','CM',2*'  ',
C10 'THR'	'AM','OL','HP','CM','  ',
C11 'CYS'	'AM','TO','CM',2*'  ',
C12 'GLY'	'AM','CM',3*'  ',
C13 'ALA'	'AM','HP','CM',2*'  ',
C14 'LEU'	'AM','HP','CM',2*'  ',
C15 'ILE'	'AM','HP','CM',2*'  ',
C16 'VAL'	'AM','HP','CM',2*'  ',
C17 'TRP'	'AM','HP','RS','RS','CM',
C18 'GLN'	'AM','HP','AD','CM','  ',
C19 'ASN'	'AM','AD','CM',2*'  ',
C20 'PHE'	'AM','HP','RS','CM','  ',
C21 'PRO'	'AP','HP','CM',2*'  ',
C22 'MET'	'AM','HP','TE','CM','  ',
C23 'HSP'	'AM','HS','CM',2*'  ',
C24 'HSC'	'AM','HS','CM',2*'  ',
C25 'GDP'	5*'  ',
C26 'GTP'	5*'  ',
C27 'GDQ'	5*'  ',
C28 'GTQ'	5*'  ',
C29 'GDR'	5*'  ',
C30 'GTR'	5*'  ',
C31 'OCT'	'HP',4*'  ',
C32 'ALY'	'AM','HP','AS','CM','HP',
C33 'GRD'	'GR',4*'  '/
C34 'HOH'       'WT',4*'  '/

      DATA RESGRP/
     *'HIS','HSE','HSD','GLU','ASP',
     *'TYR','LYS','ARG','SER','THR',
     *'CYS','GLY','ALA','LEU','ILE',
     *'VAL','TRP','GLN','ASN','PHE',
     *'PRO','MET','HSP','HSC','GDP',
     *'GTP','GDQ','GTQ','GDR','GTR',
     *'OCT','ALY','GRD'/ !,'HOH'/
      DATA GTYP/
     *'AM','HS','CM',2*'  ',
     *'AM','HS','CM',2*'  ',
     *'AM','HS','CM',2*'  ',
     *'AM','HP','CO','CM','  ',
     *'AM','CO','CM',2*'  ',
     *'AM','HP','RS','PH','CM',
     *'AM','HP','AS','CM','  ',
     *'AM','HP','GS','CM','  ',
     *'AM','OL','CM',2*'  ',
     *'AM','OL','HP','CM','  ',
     *'AM','TO','CM',2*'  ',
     *'AM','CM',3*'  ',
     *'AM','HP','CM',2*'  ',
     *'AM','HP','CM',2*'  ',
     *'AM','HP','CM',2*'  ',
     *'AM','HP','CM',2*'  ',
     *'AM','HP','RS','RS','CM',
     *'AM','HP','AD','CM','  ',
     *'AM','AD','CM',2*'  ',
     *'AM','HP','RS','CM','  ',
     *'AP','HP','CM',2*'  ',
     *'AM','HP','TE','CM','  ',
     *'AM','HS','CM',2*'  ',
     *'AM','HS','CM',2*'  ',
     *30*'  ',
     *'HP',4*'  ',
     *'AM','HP','AS','CM','HP',
     *'GR',4*'  '/
c    *'WT',4*'  '/
c     DATA INGRP/IGRMX*.TRUE./
      DATA INGRP(1)/.TRUE./
C
C	INPUT
C
C
C	PHS	Starting pH
C	PHF	Final pH
C	DPH	pH steps
C	TEMP	Temperature (K)
C
C
C	Coordinate file type:	CHM Charm input coordinates
C				PDB Protein data bank coordinates (not yet implemented)
C
C	ANS,IDB Debug control swithches
C
      WRITE (IOUT,1001)
 1001 FORMAT('$ENTER COORDINATE FILE TYPE',
     *' (PDB,CHarMm): ')
      READ (INPT,'(A3,I4,A,I1)') FILTP,ISGRD,ANS,IDB
      IF (ANS.EQ.'D') DEBUG=.TRUE.
      RENV=10.
        ti=dtime(tim)
C
C	FETCH COORDINATES AND CHARGES
C
        write(*,*)'enteringin coorin.f'
        CALL COORIN(DEBUG,NATM,NGRP,INPT,IOUT,ATM,RES,
     *  NRES,Q,IPT,FILTP,INGRP,IRES,NPRES,NTRES,Q0,PCOD)
        write(*,*)'exiting coorin.f'
        write(*,*)'entering cntrl.f'
        CALL CNTRL(INPT,IOUT,IEPS,GI,RCUT,DEBUG,
     *  NGRP,NATM,PHS,PHF,DPH,TEMP,INGRP,IRES,Q0,IDB,
     * ITERM,BFS,ALF,VEPS,RESET,CRCUT,CDAMP,RENV,NTRES-NPRES,PCOD,ISGRD)
        write(*,*)'exiting cntrl.f'
      WRITE(IOUT,'(/)')
        ti=dtime(tim)
        write (iout,*) ' elapsed cpu time =',ti,' sec.'
      stop 1234
      CALL EXIT
      END


subroutine phenolsb(aepa,aifs,antes,antss,pdepth,bhfwsf,boots,cliname,cname,daa,&
                  & dae,dap,daynum,ddae,ddap,dgdde,dgdds,drs,dummy2,emrgflg,ems,&
                  & endphenol,first7,fps,gdda,gdde,gdds,gddwsf,gmethod,heads,   &
                  & hrs,ies,joints,lnpout,mats,pchron,pdate,seedbed,srs,tis,    &
                  & year)
!
!  the phenolsb subroutine ... finish description here.
!
!  inputs: aepa(c), aifs(c,r), antes(c,r), antss(c,r), boots(c,r),
!          dae(r), dap(r), daynum(r), ddae(20)(c), ddap(20)(c),
!          dgdde(20)(c), dgdds(20)(c),
!          drs(c,r), dummy2(15)(r), first7(c,r), fps(c,r),
!          gdde(r), gdds(r), heads(c,r), hrs(c,r), ies(c,r),
!          joints(c,r), mats(c,r), nolvs(c), pchron(r),
!          srs(c,r), tis(c,r)
!
! outputs: aifs(c,r), antes(c,r), antss(c,r), boots(c,r), ddae(20)(c),
!          ddap(20)(c), dgdde(20)(c), dgdds(20)(c),
!          drs(c,r), first7(c,r), fps(c,r), heads(c,r),
!          hrs(c,r), ies(c,r), joints(c,r), mats(c,r), nolvs(c),
!          srs(c,r), tis(c,r)
!
implicit none
!
include 'file.fi'
!
! Dummy arguments
!
real :: aepa,bhfwsf,gdda,gdde,gdds,pchron,pdepth
character(80) :: cliname
character(80) :: cname,seedbed
integer :: daa,dae,dap,daynum,emrgflg,first7,gmethod,pdate,year
logical :: endphenol
integer,dimension(4) :: aifs,antes,antss,boots,drs,ems,fps,heads,hrs,ies,joints,&
                      & mats,srs,tis
integer,dimension(20) :: ddae,ddap
real,dimension(20) :: dgdde,dgdds
real,dimension(30) :: dummy2
real,dimension(15,5) :: gddwsf
real,dimension(100,2) :: lnpout
!
! Local variables
!
real :: adjgdd
integer :: i,j,row
integer,dimension(4) :: pdatearr
!
!debe changed upgm variable name 'bc0growdepth' to phenologymms variable name
!of 'pdepth' to maintain consistency with phenologymms code.
!debe added for writing out phenology info to a file.
!
!debe changed dimensions of dummy 2 array for stressed and non-stressed values.
!debe added bhfwsf to the call to each crop's phenol subroutine to
! implement daily water stress effect on time of reaching a growth stage
!debe added initialized gddwsf array
!
!debe added this variable to stop the call to phenol
!debe added cliname to write the climate location name to phenol.out
!
!     + + + argument definitions + + +
!     adjgdd - the adjusted gdd required to enter the growth stage.
!     aepa - the parameter for duration of anthesis (i.e., gdd from start
!            to end of anthesis
!     aifs - awns initials formed growth stage for spring barley and winter
!            barley. this array includes daynum, year, month and day of when
!            this stage was reached.
!     antes - end of anthesis growth stage. this array includes daynum, year,
!             month and day of when this stage was reached.
!     antss - start of anthesis growth stage. this array includes daynum, year,
!             month and day of when this stage was reached.
!     bhfwsf - water stress factor ratio (0-1).  this is read in daily.
!     boots - booting growth stage. this array includes daynum, year,
!             month and day of when this stage was reached.  booting is
!            defined as flag leaf has completed its growth.
!     cliname - the name of the location for the climate data.
!     cname - crop name.
!     daa - days after anthesis.
!     dae - days after emergence.
!     dap - days after planting.
!     daynum - the current day numbered from jan 1.
!     ddae - an array holding the dae for each growth stage.
!     ddap - an array holding the dap for each growth stage.
!     dgdde - an array holding the gdde for each growth stage.
!     dgdds - an array holding the gdds for each growth stage.
!     drs - double ridge growth stage. this array includes daynum, year,
!             month and day of when this stage was reached.
!     dummy2 - an array to hold the gdd values, both under stressed
!              and non- stressed conditions,required to reach each growth
!              stage of the current crop.
!     emrgflg - a flag to determine if the new emerge subroutine should be
!               called (emrgflg=1) or to proceed with the weps/upgm method
!               of achieving emergence (emrgflg=0).
!     ems - day when emergence occurred. this array includes daynum, year,
!             month and day of when this event occurred.
!     endphenol - a flag to indicate if this subroutine should be called
!                 again on the next day.
!     first7 - used to set the value of aepa the first time phenolsb is called.
!     fps - flower primordium initiation growth stage. this array includes
!           daynum, year, month and day of when this stage was reached.
!     gdda - growing degree days from anthesis.
!     gdde - growing degree days from emergence.
!     gdds - growing degree days from seeding.
!     gddwsf - an array to hold the gn and gs gdd values plus the high and
!              low water stress factor values.  these are used in calculating
!              the slope of the line for each growth stage and this is then
!              used to calculate the adjusted gdd value for the current
!              growth stage.
!              column one contains the gn values and is y2.
!              column two contains the gs value and is y1.
!              column three contains wsfhi (high water stress) and is x1.
!              column four contains wsflo (low water stress) and is x2.
!              column five contains the adjgdd value for the stage.
!     gmethod - selects the method whereby gdd will be calculated.  a value
!               of 1 corresponds to method 1 in phenologymms and is used
!               for crops such as winter wheat, winter barley and proso
!               millet. a value of 2 corresponds to method 2 in
!               phenologymms and is used for crops such as corn, sorghum
!               and sunflower.  a value of 3 is the way that weps/upgm
!               calculated ggd for the day.
!     heads - heading growth stage. this array includes daynum, year,
!             month and day of when this stage was reached.
!     hrs - time to harvest ripe growth stage. this array includes daynum,
!           year, month and day of when this stage was reached.
!     ies - start of internode elongation growth stage. this array includes
!           daynum, year, month and day of when this stage was reached.
!     joints - jointing growth stage. this array includes daynum, year,
!             month and day of when this stage was reached.
!     lnpout - an array used in writing out daynum and the number of leaves
!              on that day.  the values are written each time a new leaf has
!              appeared.
!     mats - physiological maturity growth stage. this array includes daynum,
!            year, month and day of when this stage was reached.
!     pchron - phyllochron value which is the number of gdd per leaf.
!     pdate - planting date.
!     pdepth - depth of growing point at time of planting (m).
!              bc0growdepth is assed into pdepth.
!     seedbed - contains the soil moisture condition of the seedbed.
!     srs - single ridge growth stage. this array includes daynum, year,
!           month and day of when this stage was reached.
!     tis - start of tillering growth stage. this array includes daynum, year,
!           month and day of when this stage was reached.
!     year - year.

!     + + + local variable definitions + + +
!     i - this tells which row is to be read in from the dummy2 array.
!     j - a counter variable for outputting the leaf number array.
!     pdatearr - the planting date array. it contains the daynum,
!                year, month and day that planting occurred.
!     row - this holds the row to be filled in the gddwsf array in the
!           water_stress subroutine.

! initialize local variables
j = 1
!debe initialize planting date array
do i = 1,4
  pdatearr(i) = 0
end do
pdatearr(2) = year

if (first7==0) then
  aepa = 120.        ! this is the value for crops which use method 1
                     ! for gdd calculation.
  first7 = 1
end if

! emergence has occurred so fill the first row in the gddwsf array (only
! print for the first period from e to tiller initiation):
if ((ems(1)/=999).and.(tis(1)==999)) then
  row = 1
  i = 1
  call water_stress(adjgdd,bhfwsf,dummy2,gddwsf,row,i)
end if
!
! *******   fill growth stage arrays   *******
!debe added code to change the adjusted value in gddwsf only when
! the growth stage has been reached.

!  start of tillering:
if (tis(1)==999) then
  row = 2
  i = 2
  call water_stress(adjgdd,bhfwsf,dummy2,gddwsf,row,i)
  if (gdde>=gddwsf(2,5)) then
     tis(1) = daynum
     tis(2) = year
     call date1(tis)
     ddap(2) = dap
     ddae(2) = dae
     dgdds(2) = gdds
     dgdde(2) = gdde
     print *,'tis = ',tis
  end if
end if

!  single ridge growth stage:
!  single ridge occurs dummy2(3) gdd after vernalization, which is
!  assumed to have occurred by midwinter (jan. 1 or july 1) for winter
!  wheat, or after emergence for spring wheat and spring barley.
!debe accumulate gdd simultaneously with that accumulated for tis stage.
if (srs(1)==999) then
  row = 3
  i = 3
  call water_stress(adjgdd,bhfwsf,dummy2,gddwsf,row,i)
  if (gdde>=gddwsf(3,5)) then
     srs(1) = daynum
     srs(2) = year
     call date1(srs)
     ddap(3) = dap
     ddae(3) = dae
     dgdds(3) = gdds
     dgdde(3) = gdde
     print *,'srs = ',srs
  end if

!  double ridge growth stage:
!  double ridge occurs dummy2(4) gdd phyllochrons after single ridge growth
!  stage.  do not allow additional stages to occur on same day dr
!  is reached.
else if (drs(1)==999) then
  row = 4
  i = 4
  call water_stress(adjgdd,bhfwsf,dummy2,gddwsf,row,i)
  if (gdde>=(gddwsf(3,5)+gddwsf(4,5))) then
     drs(1) = daynum
     drs(2) = year
     call date1(drs)
     ddap(4) = dap
     ddae(4) = dae
     dgdds(4) = gdds
     dgdde(4) = gdde
     print *,'drs = ',drs
  end if

!  flower primordium initiation:
!  flower primordium initiation begins 0.3 phyllochrons after
!  double ridge.
else if (fps(1)==999) then
  if (gdde>=(gddwsf(3,5)+gddwsf(4,5)+(0.3*pchron))) then
     fps(1) = daynum
     fps(2) = year
     call date1(fps)
     ddap(7) = dap
     ddae(7) = dae
     dgdds(7) = gdds
     dgdde(7) = gdde
     print *,'fps = ',fps
  end if

!  awn initials formed stage:
!debe combine aifs and ies stage because they can occur on the same day.
else if ((aifs(1)==999).and.(ies(1)==999)) then
!debe changed following code so that the correct row in gddwsf array will be
! filled with the awn initials information on the row for awn initials
! (row 7) and row 5 will be skipped because fps is on that row and
! filled with zeros.  need to read in value in row 5 in the dummy2 array.
  row = 7
  i = 5
!debe changed the following code to add rows 3 and 4 to row 7 in gddwsf array.
  call water_stress(adjgdd,bhfwsf,dummy2,gddwsf,row,i)
!debe changed last row to be added to rows 3 and 4 to row 7 in gddwsf because
! row 5 was left filled with zeros in the fps stage and ies stage corresponds
! to row 6.  the aifs stage needs to be in row 7.
  if (gdde>=(gddwsf(3,5)+gddwsf(4,5)+gddwsf(7,5))) then
     aifs(1) = daynum
     aifs(2) = year
     call date1(aifs)
     ddap(5) = dap
     ddae(5) = dae
     dgdds(5) = gdds
     dgdde(5) = gdde
     print *,'aifs = ',aifs
  end if

!  start of internode elongation:
!  internode elongation begins dummy2(5) gdd phyllochrons after double ridge
!  growth stage.
!debe combined this stage with awn initials formed.
!debe changed the following code so that the correct row in gddwsf array is
! filled with the start of internode elongation information on the row for
! internode elongation and row 5 is skipped because fps is in that row and
! filled with zeros.  need to read in value in row 5 in the dummy2 array.
  row = 6
  i = 5
  call water_stress(adjgdd,bhfwsf,dummy2,gddwsf,row,i)
!debe changed last row to be added to rows 3 and 4 to be row 6 in gddwsf
! because row 5 was left filled with zeros in the fps stage.
  if (gdde>=(gddwsf(3,5)+gddwsf(4,5)+gddwsf(6,5))) then
     ies(1) = daynum
     ies(2) = year
     call date1(ies)
     ddap(6) = dap
     ddae(6) = dae
     dgdds(6) = gdds
     dgdde(6) = gdde
     print *,'ies = ',ies
  end if

!  jointing growth stage prediction:
else if (joints(1)==999) then
  row = 8
  i = 6
  call water_stress(adjgdd,bhfwsf,dummy2,gddwsf,row,i)
!debe changed following code to add rows 7 and 8 of gddwsf array to
! rows 3 and 4 because row 7 is for awn initials formed and row 8 is for
! jointing.
  if (gdde>=(gddwsf(3,5)+gddwsf(4,5)+gddwsf(7,5)+gddwsf(8,5))) then
     joints(1) = daynum
     joints(2) = year
     call date1(joints)
     ddap(8) = dap
     ddae(8) = dae
     dgdds(8) = gdds
     dgdde(8) = gdde
     print *,'joints = ',joints
  end if

!  booting growth stage: this is defined as flag leaf has
!  completed its growth.
else if (boots(1)==999) then
  row = 9
  i = 7
  call water_stress(adjgdd,bhfwsf,dummy2,gddwsf,row,i)
!debe changed following code to add rows 7, 8 and 9 of gddwsf array to
! rows 3 and 4 because row 7 is for awn initials formed and row 8 is for
! jointing and row 9 is for booting.
  if (gdde>=(gddwsf(3,5)+gddwsf(4,5)+gddwsf(7,5)+gddwsf(8,5)+gddwsf(9,5))) then
     boots(1) = daynum
     boots(2) = year
     call date1(boots)
     ddap(9) = dap
     ddae(9) = dae
     dgdds(9) = gdds
     dgdde(9) = gdde
     print *,'boots = ',boots
  end if

!  heading growth stage:
!  if enough gdd have passed, then heading begins.  go to
!  code for next stage since anthesis is allowed to occur on same day
!  as heading if enough degree-days accumulated today.
else if (heads(1)==999) then
  row = 10
  i = 8
  call water_stress(adjgdd,bhfwsf,dummy2,gddwsf,row,i)
!debe changed following code to add rows 7,8,9 and 10 of gddwsf array to
! rows 3 and 4 because row 7 is for awn initials formed, row 8 is for
! jointing, row 9 is for booting and 10 is for heading.
  if (gdde>=(gddwsf(3,5)+gddwsf(4,5)+gddwsf(7,5)+gddwsf(8,5)+gddwsf(9,5)        &
    & +gddwsf(10,5))) then
     heads(1) = daynum
     heads(2) = year
     call date1(heads)
     ddap(10) = dap
     ddae(10) = dae
     dgdds(10) = gdds
     dgdde(10) = gdde
     print *,'heads = ',heads
  end if

!  beginnning of anthesis:
!  allow end of anthesis to occur on same day if enough degree-days have
!  accumulated today.
else if (antss(1)==999) then
  row = 11
  i = 9
  call water_stress(adjgdd,bhfwsf,dummy2,gddwsf,row,i)
!debe changed following code to add rows 7, 8, 9, 10 and 11 of gddwsf array
! to rows 3 and 4 because row 7 is for awn initials formed, row 8 is for
! jointing, row 9 is for booting, row 10 is for heading and row 11 is for
! anthesis starts.
  if (gdde>=(gddwsf(3,5)+gddwsf(4,5)+gddwsf(7,5)+gddwsf(8,5)+gddwsf(9,5)        &
    & +gddwsf(10,5)+gddwsf(11,5))) then
     antss(1) = daynum
     antss(2) = year
     call date1(antss)
     ddap(11) = dap
     ddae(11) = dae
     dgdds(11) = gdds
     dgdde(11) = gdde
     print *,'antss = ',antss
  end if

!  end of anthesis:
else if (antes(1)==999) then
!      no row in dummy2 array corresponds to antes.
!debe changed following code to add the correct rows in gddwsf array as
! noted above.  anthesis ends is the same additions as anthesis starts with
! the additional value of the aepa parameter.
  if (gdde>=(gddwsf(3,5)+gddwsf(4,5)+gddwsf(7,5)+gddwsf(8,5)+gddwsf(9,5)        &
    & +gddwsf(10,5)+gddwsf(11,5)+aepa)) then
     antes(1) = daynum
     antes(2) = year
     call date1(antes)
     ddap(12) = dap
     ddae(12) = dae
     dgdds(12) = gdds
     dgdde(12) = gdde
     print *,'antes = ',antes
  end if

!  physiological maturity:
else if (mats(1)==999) then
  row = 13
  i = 10
  call water_stress(adjgdd,bhfwsf,dummy2,gddwsf,row,i)
!debe changed following code to add rows 7, 8, 9, 10, 11 and 13 of gddwsf
! array to rows 3 and 4 because row 7 is for awn initials formed, row 8
! is for jointing, row 9 is for booting, row 10 is for heading, row 11 is for
! anthesis starts and row 13 is for physiological maturity.  row 12 is used
! for anthesis ends and is left filled with zeros in gddwsf array.
  if (gdde>=(gddwsf(3,5)+gddwsf(4,5)+gddwsf(7,5)+gddwsf(8,5)+gddwsf(9,5)        &
    & +gddwsf(10,5)+gddwsf(11,5)+gddwsf(13,5))) then
     mats(1) = daynum
     mats(2) = year
     call date1(mats)
     ddap(13) = dap
     ddae(13) = dae
     dgdds(13) = gdds
     dgdde(13) = gdde
     print *,'mats = ',mats
  end if

! time to harvest ripe:
else if (hrs(1)==999) then
  row = 14
  i = 11
  call water_stress(adjgdd,bhfwsf,dummy2,gddwsf,row,i)
!debe changed following code to add rows 7, 8, 9, 10, 11, 13 and 14 of gddwsf
! array to rows 3 and 4 because row 7 is for awn initials formed, row 8
! is for jointing, row 9 is for booting, row 10 is for heading, row 11 is for
! anthesis starts, row 13 is for physiological maturity and row 14 is for
! harvest ready.  row 12 is used for anthesis ends and is left filled with
! zeros in gddwsf array.
  if (gdde>=(gddwsf(3,5)+gddwsf(4,5)+gddwsf(7,5)+gddwsf(8,5)+gddwsf(9,5)        &
    & +gddwsf(10,5)+gddwsf(11,5)+gddwsf(13,5)+gddwsf(14,5))) then
     hrs(1) = daynum
     hrs(2) = year
     call date1(hrs)
     ddap(14) = dap
     ddae(14) = dae
     dgdds(14) = gdds
     dgdde(14) = gdde
     print *,'hrs = ',hrs
  end if
end if

!
! *******   output data   *******
! output information from each crop's phenol subroutine.
! print to the screen:
if (hrs(1)/=999) then
  print *,'crop is: ',cname
  print *,'gdds = ',gdds
  print *,'dap = ',dap
  print *,'gdde = ',gdde
  print *,'dae = ',dae
  print *,'gdda = ',gdda
  print *,'daa = ',daa
  print *,'year = ',year
!
!! fill pdatearr
  pdatearr(1) = pdate
  call date1(pdatearr)
!
!  heading for leaf number table
  write (luophenol,1000) cname

!  write out a table with leaf numbers by doy
  do while (lnpout(j,2)<dgdde(9)/pchron)
     write (luophenol,1100) lnpout(j,1),lnpout(j,2)
     j = j + 1
  end do

! convert integer boots(1) to a real number
  write (luophenol,1100) real(boots(1)),dgdde(9)/pchron

!debe add items to print to the output file phenol.out
  write (luophenol,1200) cname,cliname,pdepth,pdatearr(1),pdatearr(3),          &
                       & pdatearr(4),gmethod,emrgflg,seedbed,bhfwsf

  write (luophenol,1300) pdatearr(1),pdatearr(3),pdatearr(4),ems(1),ems(3),     &
                       & ems(4),ddap(1),dgdds(1),tis(1),tis(3),tis(4),ddap(2),  &
                       & ddae(2),dgdds(2),dgdde(2),dgdde(2)/pchron,srs(1),srs(3)&
                       & ,srs(4),ddap(3),ddae(3),dgdds(3),dgdde(3),dgdde(3)     &
                       & /pchron,drs(1),drs(3),drs(4),ddap(4),ddae(4),dgdds(4), &
                       & dgdde(4),dgdde(4)/pchron,fps(1),fps(3),fps(4),ddap(7), &
                       & ddae(7),dgdds(7),dgdde(7),dgdde(7)/pchron,ies(1),ies(3)&
                       & ,ies(4),ddap(6),ddae(6),dgdds(6),dgdde(6),dgdde(6)     &
                       & /pchron,aifs(1),aifs(3),aifs(4),ddap(5),ddae(5),       &
                       & dgdds(5),dgdde(5),dgdde(5)/pchron,joints(1),joints(3), &
                       & joints(4),ddap(8),ddae(8),dgdds(8),dgdde(8),dgdde(8)   &
                       & /pchron,boots(1),boots(3),boots(4),ddap(9),ddae(9),    &
                       & dgdds(9),dgdde(9),dgdde(9)/pchron,heads(1),heads(3),   &
                       & heads(4),ddap(10),ddae(10),dgdds(10),dgdde(10),dgdde(9)&
                       & /pchron,antss(1),antss(3),antss(4),ddap(11),ddae(11),  &
                       & dgdds(11),dgdde(11),dgdde(9)/pchron,antes(1),antes(3), &
                       & antes(4),ddap(12),ddae(12),dgdds(12),dgdde(12),dgdde(9)&
                       & /pchron,mats(1),mats(3),mats(4),ddap(13),ddae(13),     &
                       & dgdds(13),dgdde(13),dgdde(9)/pchron,hrs(1),hrs(3),     &
                       & hrs(4),ddap(14),ddae(14),dgdds(14),dgdde(14),dgdde(9)  &
                       & /pchron

! debe added writing out and formatting of the gddwsf array
  write (luophenol,1400) gddwsf(1,1),gddwsf(1,2),gddwsf(1,3),gddwsf(1,4),       &
                       & gddwsf(1,5),gddwsf(2,1),gddwsf(2,2),gddwsf(2,3),       &
                       & gddwsf(2,4),gddwsf(2,5),gddwsf(3,1),gddwsf(3,2),       &
                       & gddwsf(3,3),gddwsf(3,4),gddwsf(3,5),gddwsf(4,1),       &
                       & gddwsf(4,2),gddwsf(4,3),gddwsf(4,4),gddwsf(4,5),       &
                       & gddwsf(5,1),gddwsf(5,2),gddwsf(5,3),gddwsf(5,4),       &
                       & gddwsf(5,5),gddwsf(6,1),gddwsf(6,2),gddwsf(6,3),       &
                       & gddwsf(6,4),gddwsf(6,5),gddwsf(7,1),gddwsf(7,2),       &
                       & gddwsf(7,3),gddwsf(7,4),gddwsf(7,5),gddwsf(8,1),       &
                       & gddwsf(8,2),gddwsf(8,3),gddwsf(8,4),gddwsf(8,5),       &
                       & gddwsf(9,1),gddwsf(9,2),gddwsf(9,3),gddwsf(9,4),       &
                       & gddwsf(9,5),gddwsf(10,1),gddwsf(10,2),gddwsf(10,3),    &
                       & gddwsf(10,4),gddwsf(10,5),gddwsf(11,1),gddwsf(11,2),   &
                       & gddwsf(11,3),gddwsf(11,4),gddwsf(11,5),gddwsf(12,1),   &
                       & gddwsf(12,2),gddwsf(12,3),gddwsf(12,4),gddwsf(12,5),   &
                       & gddwsf(13,1),gddwsf(13,2),gddwsf(13,3),gddwsf(13,4),   &
                       & gddwsf(13,5),gddwsf(14,1),gddwsf(14,2),gddwsf(14,3),   &
                       & gddwsf(14,4),gddwsf(14,5),gddwsf(15,1),gddwsf(15,2),   &
                       & gddwsf(15,3),gddwsf(15,4),gddwsf(15,5)

  endphenol = .true.

end if
 1000 format (42x,a14)
 1100 format (40x,f5.1,6x,f4.1)

 1200 format ('crop name =',2x,a15,/x,'climate location =',2x,a128,/x,          &
             &'planting depth =',2x,f5.3,'(m)',/x,'planting date =',2x,i3,':',  &
            & i2,'/',i2,/x,'gdd method =',2x,i1,/x,'emergence method used =',2x,&
            & i1,/x,'seedbed soil moisture =',2x,a17,/x,'water stress factor =',&
            & 2x,f3.1,/x)

 1300 format (' phenological event',7x,'day of year',2x,'date',2x,'dap',5x,     &
            & 'dae',5x,'gdd ap',5x,'gdd ae',5x,'nolvs',/1x'planting date',18x,  &
            & i4,2x,i2,'/',i2,/1x,'emergence',22x,i4,2x,i2,'/',i2,1x,i4,13x,    &
            & f6.1,/1x,'first tiller',19x,i4,2x,i2,'/',i2,1x,i4,4x,i4,5x,f6.1,  &
            & 5x,f6.1,4x,f6.1,/1x,'single ridge',19x,i4,2x,i2,'/',i2,1x,i4,4x,  &
            & i4,5x,f6.1,5x,f6.1,4x,f6.1,/1x,'double ridge',19x,i4,2x,i2,'/',i2,&
            & 1x,i4,4x,i4,5x,f6.1,5x,f6.1,4x,f6.1,/1x,                          &
             &'floret primordia init begins',3x,i4,2x,i2,'/',i2,1x,i4,4x,i4,5x, &
            & f6.1,5x,f6.1,4x,f6.1,/1x,'stem elongation begins',9x,i4,2x,i2,'/',&
            & i2,1x,i4,4x,i4,5x,f6.1,5x,f6.1,4x,f6.1,/1x,'awn initials formed', &
            & 12x,i4,2x,i2,'/',i2,1x,i4,4x,i4,5x,f6.1,5x,f6.1,4x,f6.1,/1x,      &
             &'jointing',23x,i4,2x,i2,'/',i2,1x,i4,4x,i4,5x,f6.1,5x,f6.1,4x,    &
            & f6.1,/1x,'booting',24x,i4,2x,i2,'/',i2,1x,i4,4x,i4,5x,f6.1,5x,    &
            & f6.1,4x,f6.1,/1x,'heading',24x,i4,2x,i2,'/',i2,1x,i4,4x,i4,5x,    &
            & f6.1,5x,f6.1,4x,f6.1,/1x,'anthesis starts',16x,i4,2x,i2,'/',i2,1x,&
            & i4,4x,i4,5x,f6.1,5x,f6.1,4x,f6.1,/1x,'anthesis ends',18x,i4,2x,i2,&
             &'/',i2,1x,i4,4x,i4,5x,f6.1,5x,f6.1,4x,f6.1,/1x,                   &
             &'physiological maturity',9x,i4,2x,i2,'/',i2,1x,i4,4x,i4,5x,f6.1,  &
            & 5x,f6.1,4x,f6.1,/1x,'harvest ready',18x,i4,2x,i2,'/',i2,1x,i4,4x, &
            & i4,5x,f6.1,5x,f6.1,4x,f6.1,/1x)

!  heading for gddwsf array
 1400 format (/2x,39x,'gddwsf array',/1x,'phenological event',12x,'gn gdd',2x,  &
             &'gs gdd',2x,'wsfhi',2x,'wsflo',2x,'adjgdd',/1x,'emergence',22x,   &
            & f5.1,3x,f5.1,3x,f3.1,4x,f3.1,4x,f5.1,/1x,'first tiller',19x,f5.1, &
            & 3x,f5.1,3x,f3.1,4x,f3.1,4x,f5.1,/1x,'single ridge',19x,f5.1,3x,   &
            & f5.1,3x,f3.1,4x,f3.1,4x,f5.1,/1x,'double ridge',19x,f5.1,3x,f5.1, &
            & 3x,f3.1,4x,f3.1,4x,f5.1,/1x,'floret primordia init begins',3x,    &
            & f5.1,3x,f5.1,3x,f3.1,4x,f3.1,4x,f5.1,/1x,'stem elongation begins',&
            & 9x,f5.1,3x,f5.1,3x,f3.1,4x,f3.1,4x,f5.1,/1x,'awn initials formed',&
            & 12x,f5.1,3x,f5.1,3x,f3.1,4x,f3.1,4x,f5.1,/1x,'jointing',23x,f5.1, &
            & 3x,f5.1,3x,f3.1,4x,f3.1,4x,f5.1,/1x,'booting',24x,f5.1,3x,f5.1,3x,&
            & f3.1,4x,f3.1,4x,f5.1,/1x,'heading',24x,f5.1,3x,f5.1,3x,f3.1,4x,   &
            & f3.1,4x,f5.1,/1x,'anthesis starts',16x,f5.1,3x,f5.1,3x,f3.1,4x,   &
            & f3.1,4x,f5.1,/1x,'anthesis ends',18x,f5.1,3x,f5.1,3x,f3.1,4x,f3.1,&
            & 4x,f5.1,/1x,'physiological maturity',9x,f5.1,3x,f5.1,3x,f3.1,4x,  &
            & f3.1,4x,f5.1,/1x,'harvest ready',18x,f5.1,3x,f5.1,3x,f3.1,4x,f3.1,&
            & 4x,f5.1,/1x,'row 15',25x,f5.1,3x,f5.1,3x,f3.1,4x,f3.1,6x,f3.1,/1x)
!
end subroutine phenolsb


!*******************************************************************************
!  File sxrch_mc.f
!  Contains module sxrch_mc
!           SUBROUTINE sxrch_mc_model_compute
!           FUNCTION emissivity_model
!
!  Module is part of the V3FIT stellarator equilibrium reconstruction code.
!  The postfix _mc in the name indicates Model Compute
!  The module contains the subroutine sxrch_mc_model_compute
!  Both an sxrch_desc and a model are needed for this computation.

!*******************************************************************************
!  MODULE sxrch_mc
!    (sxrch - Soft X-Ray Model Compute Calculations)
! SECTION I.     VARIABLE DECLARATIONS
! SECTION II.    INTERFACE BLOCKS
! SECTION III.   MAIN COMPUTATIONAL SUBROUTINE
! SECTION IV.    _OLD (SUPERCEDED) CODE
! SECTION X.  COMMENTS FOR DIFFERENT REVISIONS
!*******************************************************************************
      MODULE sxrch_mc

!*******************************************************************************
! SECTION I. VARIABLE DECLARATIONS
!*******************************************************************************

!-------------------------------------------------------------------------------
!  Type declarations, constants, utilities
!-------------------------------------------------------------------------------
      USE stel_kinds
      USE v3f_global
      USE vmec_utils
      USE read_wout_mod

!-------------------------------------------------------------------------------
!  sxrch Derived Type
!-------------------------------------------------------------------------------
      USE sxrch_T

!-------------------------------------------------------------------------------
!  Model Derived Types
!-------------------------------------------------------------------------------
      USE model_T

!------------------------------------------------------------------------------
      IMPLICIT NONE

!*******************************************************************************
! SECTION II.  INTERFACE BLOCKS
!*******************************************************************************

!-------------------------------------------------------------------------------
!-------------------------------------------------------------------------------
      CONTAINS

!*******************************************************************************
! SECTION III.  MAIN COMPUTATIONAL SUBROUTINE
!*******************************************************************************
!-------------------------------------------------------------------------------
!  Compute an sxrch signal
!
!    Information comes from the sxrch_desc and the model
!-------------------------------------------------------------------------------
!-------------------------------------------------------------------------------
!  Actual computation of the model signal is in this subroutine
!    s_type = diagnostic
!      d_type = sxrch
!        Soft X-Ray Chord Diagnostic
!        signal_model_compute_sxrch
!
!-------------------------------------------------------------------------------

      SUBROUTINE sxrch_mc_model_compute(a_sxrch,a_model,mod_signal,            &
     &   mod_sigma)

!-------------------------------------------------------------------------------
! ARGUMENTS
! a_sxrch        - type sxrch_desc - holds sxr chord info
! a_model       - type model - holds eq_state and density model information
! mod_signal    - output of the generated signal
! mod_sigma     - output sigma
!-------------------------------------------------------------------------------
      TYPE (sxrch_desc), INTENT (inout)     :: a_sxrch
      TYPE (model), INTENT (inout), TARGET :: a_model
      REAL(rprec), POINTER, DIMENSION(:) :: mod_signal, mod_sigma

!-------------------------------------------------------------------------------
! local variables
!-------------------------------------------------------------------------------
      CHARACTER(len=*), PARAMETER :: sub_name =                                &
     &  'sxrch_mc_model_compute'

!-------------------------------------------------------------------------------
! cyl2flx declarations  - used for the subroutine cyl2flx call
!-------------------------------------------------------------------------------
      REAL(rprec), DIMENSION(3) :: r_cyl(1:3)=0.0
      REAL(rprec), DIMENSION(3) :: xcart, dxcart
      INTEGER :: points

!-------------------------------------------------------------------------------
! other declarations
!
!-------------------------------------------------------------------------------
      INTEGER       :: istat1
      REAL(rprec)   :: dx               ! integration step size
      INTEGER       :: ipoints          ! number of integration points
      INTEGER       :: istep
      REAL(rprec), DIMENSION(:), ALLOCATABLE :: sxrem_array

!-------------------------------------------------------------------------------
!  START OF EXECUTABLE CODE
!-------------------------------------------------------------------------------
!  Allocate data and sigma
         IF (ASSOCIATED(mod_signal)) THEN
           DEALLOCATE(mod_signal,mod_sigma, stat=istat1)
           CALL assert_eq(0,istat1,sub_name //                                 &
     &                     'mod_signal, sigma dealloc')
         ENDIF
         ALLOCATE(mod_signal(1),mod_sigma(1),stat=istat1)
         CALL assert_eq(0,istat1,sub_name // 'mod_signal, sigma alloc')

!  Allocate space for sxrem_array
         ipoints=100
         ALLOCATE(sxrem_array(ipoints),stat=istat1)
         CALL assert_eq(0,istat1,sub_name // 'alloc sxrem_array')

         dxcart = (a_sxrch % xcart_f - a_sxrch % xcart_i)/ipoints
         dx = SQRT(dxcart(1) ** 2 + dxcart(2) ** 2 + dxcart(3) ** 2)
         DO istep=1,ipoints
            xcart = a_sxrch % xcart_i + istep * dxcart
            r_cyl(1) = SQRT(xcart(1) ** 2 + xcart(2) ** 2)
            r_cyl(2) = ATAN2(xcart(2),xcart(1))
            r_cyl(3) = xcart(3)
            sxrem_array(istep) =                                               &
     &         model_get_sxrem_xcyl(a_model,r_cyl) * dx
         ENDDO
         mod_signal(1)=SUM(sxrem_array)
         DEALLOCATE(sxrem_array,stat=istat1)
         CALL assert_eq(0,istat1,sub_name // 'dealloc sxrem_array')

! make up a sigma
!         mod_sigma(1)=0.5   Changed to zero JDH 2011-10-17
         mod_sigma(1)=0.0

      END SUBROUTINE sxrch_mc_model_compute

!*******************************************************************************
! SECTION X.  COMMENTS FOR DIFFERENT REVISIONS
!*******************************************************************************
!
!  JDH 2009-03-03. First version of module. Based on coding from previous
!    module signal_model
!
!  GJH 2010-01-20. SXR version of coding based on module mddc_mc
!
!  JDH 2011-07-28
!    Refactoring - move emissivity function to the model. Test.
!    Moved to _old - sxrch_mc_model_compute_old and emissivity_model_old
!
!  JDH 2011-08-01
!    Refactor sxrc -> sxrch
!
!  JDH 2011-09-08
!    Remove old code. Use eq_get_flux instead of cyl2flx.
!
!  JDH 2011-10-17
!     Change to cartesian coordinates in sxrch
!
!  JDH 2011-10-25
!     Some refactoring, changed s_array to sxrem_array.

      END MODULE sxrch_mc


c     Response function factor = 0.89060
      subroutine avhrr13(z0, p0, t0, u0, ux, nlev,
     *co2, n2o, f11, f12, ch4,
     *od, wght, ntau)
      INCLUDE "avhrr.inc"
      real co2, n2o, ch4, f11, f12
      real z0(mm)
      real od(1,mm)
      real wght(1)
      integer ntau,nlev
      real wi(8),xi(8),p0(mq),p(mm),t0(mq),t(mm),bnu(mm),u0(mq),u(mm),
     *ux(mq),uo3(mm),tau(6,mm),tauo3(6,mm),delw,x(mm,8),y(mm,8),
     *sx(6,mm),sy(6,mm),f(6),fac(mm),tsx(mq),tsy(mq),fo3(6)
      data xi /.01986,.10167,.23723,.40828,
     *         .59172,.76277,.89833,.98014/
      data wi /.05062,.11119,.15685,.18134,
     *         .18134,.15685,.11119,.05062/
      tb=0
      nlyr = nlev-1
      if(nlyr.GT.mm)then
        write (*,*) 'error: increase mm to at least', nlyr
        write (*,*) '       in avhrr.inc'
        return
      end if
      if(nlev.GT.mq)then
        write (*,*) 'error: increase mq to at least', nlev
        write (*,*) '       in avhrr.inc'
        return
      end if
      omega=16300.0
      delw=600.0
      sigma=5.67e-05
      sconst=1.368e+06
      tsun=5710.0
      fsun=sigma*tsun**4
      mlv=nlyr
      do 5 m=1,nlyr
        t(m)=(t0(m)+t0(m+1))/2.0
        p(m)=(p0(m)+p0(m+1))/2.0
        call flux_13(bnu(m),omega,t(m))
        fac(m)=z0(m+1)-z0(m)
        u(m)=fac(m)*(u0(m)+u0(m+1))/2.0
        uo3(m)=fac(m)*(ux(m)+ux(m+1))/2.0
 5    continue
      do 7 m=1,nlev
        tsx(m)=0.0
        tsy(m)=0.0
 7    continue
      call flux_13(back,omega,t0(1))
      call flux_13(bsun,omega,tsun)
      bsun=bsun/fsun*sconst
      call ck_13(ni,mlv,u,delw,f,p,t,tau)
      call cko3_13(no3,mlv,uo3,delw,fo3,p,t,tauo3)
c     **fo3=1.0000**
      do 10 m=1,nlyr
        do i=1,ni
          tau(i,m)=tau(i,m)+tauo3(1,m)
        end do
 10   continue
      do 90 i=1,ni
        do 30 m=nlyr,1,-1
          do 20 j=1,8
           if(m.eq.nlyr)then
c           y(m,j)=bnu(m)*(1.0-exp(-tau(i,m)/xi(j)))
            y(m,j)=bsun*0.6*exp(-tau(i,m)/xi(j))+
     *             bnu(m)*(1.0-exp(-tau(i,m)/xi(j)))
           else
            y(m,j)=y(m+1,j)*exp(-tau(i,m)/xi(j))+
     *      bnu(m)*(1.0-exp(-tau(i,m)/xi(j)))
           end if
 20       continue
 30     continue
        do 50 m=1,nlyr
          sx(i,m)=0.0
          sy(i,m)=0.0
          do 40 j=1,8
           if(m.eq.1)then
            x(m,j)=(0.10*y(m,j)+0.90*back)*exp(-tau(i,m)/xi(j))+
     *      bnu(m)*(1.0-exp(-tau(i,m)/xi(j)))
           else
            x(m,j)=x(m-1,j)*exp(-tau(i,m)/xi(j))+
     *      bnu(m)*(1.0-exp(-tau(i,m)/xi(j)))
           end if
 40       continue
 50     continue
        do 70 m=1,nlyr
          do 60 j=1,8
            sx(i,m)=sx(i,m)+2.0*x(m,j)*wi(j)*xi(j)
            sy(i,m)=sy(i,m)+2.0*y(m,j)*wi(j)*xi(j)
 60       continue
 70     continue
        do 80 m=1,nlyr
           tsx(m+1)=tsx(m+1)+sx(i,m)*delw*f(i)
           tsy(m)=tsy(m)+sy(i,m)*delw*f(i)
 80     continue
c        tb=tb+(0.10*tsy(1))+0.90*back*delw*f(i)
        tb=tb+back*delw*f(i)
c        tsx(1)=tsx(1)+0.10*tsy(1)
c        tsy(nlev)=tsy(nlev)+bsun*0.60*delw*f(i)
 90   continue
      tb=0.10*tsy(1)+0.90*tb
      tsx(1)=tb
      tsy(nlev)=tsy(nlev)+bsun*0.60*delw
      do 95 m=1,nlev
cbm         write(6,100)m-1,tsx(m),tb-tsx(m),tsy(m)
 95   continue
      do i1=1,1
       do m=1,nlyr
        od(1+(i1-1),m) =
     *tau(i1,m)
        wght(1+(i1-1)) =
     *f(i1)
       enddo
      enddo
      ntau=1
 100  format(i3,3f15.7)
      end
c *********************************************************************
      subroutine flux_13(bnu,omega,t)
      INCLUDE "avhrr.inc"
      bnu=0.0
      z=3.14159
      bnu=z/1000.0*((2.*6.625e-27)*(2.997925e+10)**2
     *    *omega**3)/(exp(min(88.0,1.4388*omega/t))-1.0)
      return
      end
c *********************************************************************
      subroutine ck_13(ni,mlv,u,delw,f,p,t,tau)
      INCLUDE "avhrr.inc"
      real f(6),k(mm),tau(6,mm),delw,p(mm),t(mm),u(mm)
      ni=1
      f(1)=1.000000
      k(1)=0.0
      do i=1,ni
        do m=1,mlv
          tau(i,m)=0.0
        end do
      end do
      return
      end
c *********************************************************************
      subroutine cko3_13(ni,mlv,u,delw,f,p,t,tau)
      INCLUDE "avhrr.inc"
      real f(6),k(mm),tau(6,mm),delw,p(mm),t(mm),u(mm)
      ni=1
      f(1)=1.000000
      k(1)=4.35e-21*6.023e+23/47.9982
      do i=1,ni
        do m=1,mlv
          tau(i,m)=k(i)*u(m)
        end do
      end do
      return
      end


! ===========================================================================================================
module xx_prospino_subroutine
  use xx_kinds
  use xx_public_variables
  use xx_pass_integ
  use xx_integral_ng
  use xx_integral_ns
  use xx_integral_nn
  use xx_integral_ll
  use xx_integral_tb
  use xx_integral_lq
  use xx_integral_le
  use xx_integral_hh
  use xx_integral_ht
  use xx_initialize
  use xx_in_out
  implicit none
  private :: GET_UNITS_READ_WRITE
  public :: PROSPINO, PROSPINO_OPEN_CLOSE
contains
! ------------------------------
  subroutine PROSPINO(inlo,isq_ng_in,icoll_in,energy_in,i_error_in,final_state_in,ipart1_in,ipart2_in,isquark1_in,isquark2_in)

    implicit none

    integer,                  intent(in) :: inlo,isq_ng_in,icoll_in,i_error_in,ipart1_in,ipart2_in,isquark1_in,isquark2_in
    real(kind=double)                    :: energy_in
    character(len=2),         intent(in) :: final_state_in

    integer                              :: n0,n1,ns,ii_min,ii_max,ns_min,ns_max
    integer                              :: nin1,nin2,ndat1,ndat2,ndat3
    integer                              :: isquark1_min,isquark1_max
    integer                              :: isquark2_min,isquark2_max
    integer                              :: i_lofast,ifast,inext_sq
    integer,dimension(4)                 :: ivegas
    real(kind=double)                    :: run0,run1,kfac,ms1_print,ms2_print,kng
    real(kind=double), dimension(-1:22)  :: fct,rel
    real(kind=double), dimension(1:20)   :: unimass
    real(kind=double), dimension(0:99)   :: lowmass
    character(len=2)                     :: final_state_new
    logical                              :: lvalid_global,lvalid_iteration

    integer           :: ilo_common, inlo_common, ionlylo_common, idg_common, ing_common
    common/CONST5/       ilo_common, inlo_common, ionlylo_common, idg_common, ing_common        ! to fill idg_common and ing_common

    integer           :: i_lofast_common                                                        ! only communicating with initpdf.f
    common/I_LOFAST/     i_lofast_common

    fct(-1:22) = 0.0                                                                            ! initialize cross section and rel. error
    rel(-1:22) = 0.0
    kfac       = 0.0
    kng        = 0.0

    isquark1_min = 0                                                                            ! initialize squark loop
    isquark1_max = 0
    isquark2_min = 0
    isquark2_max = 0
    inext_sq     = 0                                                                            ! initialize squark-sum indicator in loop

    icoll           = icoll_in                                                                  ! move input into public variables
    isq_ng          = isq_ng_in
    final_state     = final_state_in
    final_state_new = final_state_in                                                            ! copy for second select statement
!----------------------------------------------------------------------------------------
    i_ngtest = 0     ! test degenerate squark masses : default[0] , test[1]             !
!----------------------------------------------------------------------------------------
    if (i_ngtest == 1 ) print*, " PROSPINO: i_ngtest in testing mode ",i_ngtest

!----------------------------------------------------------------------------------------
    i_lofast = 0     ! run fast sq-gl Born terms : default[0] , test[1]                 !
!----------------------------------------------------------------------------------------
    if (i_lofast == 1 ) then
       print*, " PROSPINO: i_lofast in testing mode, sorry ",i_lofast
       call HARD_STOP                                                                           ! mode only for testing
    end if
    i_lofast_common = i_lofast

    if ( (abs(isquark1_in) > 4).or.(abs(isquark2_in) > 4) ) then                                ! protect against
       print*, " PROSPINO: for heavy-flavor squarks please use the final_state flag "
       call HARD_STOP
    end if

    if (inlo == 0) then
       ii_max = 0
    else if (inlo == 1 ) then
       ii_max = 11
    else
       print*, " PROSPINO: inlo not set correctly?, continue in LO mode "
       ii_max = 0
    end if

    if (i_error_in == 0) then
       ns_min = 0
       ns_max = 0
    else if (i_error_in == 1) then
       ns_min = -10
       ns_max = +10
    else
       print*, " PROSPINO: i_error_in not set correctly?, continue with central scale "
       ns_min = 0
       ns_max = 0
    end if

    if ( (icoll < 0).or.(icoll > 1)) then                                                   ! set the collider energy Tevatron/LHC
       print*, " PROSPINO: icoll not set correctly?, continue LHC "
       icoll = 1
    end if
    sc = energy_in**2

!----------------------------------------------------------------------------------------
    ifla_le = 1       ! specify the incoming quark flavor for LQ+lepton                 !
                      !  d[2], s[3], b[5], u[1], c[4]                                   !
!----------------------------------------------------------------------------------------
    if (final_state == 'le') then
       print*, " LQ+lepton final state "
       print*, "  R violating coupling and mixing normalized to unity "
       print*, "  incoming quark set in Xprospino_subroutine.f90 = ",ifla_le
    end if

    call GET_UNITS_READ_WRITE(nin1,nin2,ndat1,ndat2,ndat3)                                      ! obtain units from where the OPEN_CLOSE routine got them

    call INIT_GLOBAL(ipart1_in,ipart2_in,lvalid_global)                                         ! output lvalid_global, possibly skip s
    if (.not. lvalid_global) then
       print*, " MAIN: problem inside INIT_GLOBAL, cycle "
       return
    end if

    do n1   = 0,0,200                                                                           ! can be used to shift MSSM masses
    do n0   = 0,0,150                                                                           ! in routine INIT_SUSY (Xinitialize.f90)
    do ns   = ns_min,ns_max,10                                                                  ! change both scales simultaneously

       run0 = n0
       run1 = n1
       scafac = 2.0**(ns/10.0)

       call INIT_SUSY(nin1,nin2,ipart1_in,ipart2_in,isq_ng_in,run0,run1,unimass,lowmass)        ! get spectrum and initialize mass arrays.
       call DAT3(ndat3,lowmass,unimass)                                                         ! print out variables and model parameters

       ms1_print = ms                                                                           ! default mode
       ms2_print = ms
       idg_common  = 1                                                                          ! make this the sq-gl default mode
       if (isq_ng == 0) then                                                                    ! only mass degenerate case
          ing_common = 0                                                                        ! for sq-gl only
          ii_min = 0                                                                            ! for new channels only
          isquark1_min =  9
          isquark1_max =  9
          isquark2_min =  9
          isquark2_max =  9
       else if (isq_ng == 1) then                                                               ! also different squark masses
          ing_common =  1                                                                       ! for sq-gl only
          ii_min = -1                                                                           ! for new channels only
          if ( (isquark1_in == 0).and.(isquark2_in == 0).and.          &                        ! summing mode for two external squarks
                (final_state == 'ss')                    ) then
             isquark1_min = -4                                                                  ! including sbottoms in the final state
             isquark1_max =  4
             isquark2_min = -4
             isquark2_max =  4
             ms1_print = ms
             ms2_print = ms
          else if ( (isquark1_in == 0).and.(isquark2_in == 0).and.     &                        ! summing mode for two external squarks
                (final_state == 'sb')                    ) then
             isquark1_min = -5                                                                  ! including sbottoms in the final state
             isquark1_max =  5
             isquark2_min = -5
             isquark2_max =  5
             ms1_print = ms
             ms2_print = ms
          else if ( (isquark1_in == 0).and.(isquark2_in == 0).and.     &                        ! one external squark to sum over
                    ((final_state == 'sg').or.                         &
                     (final_state == 'ns')                  ) ) then
             isquark1_min = -4                                                                  ! no sbottoms in initial state
             isquark1_max =  4
             isquark2_min =  9
             isquark2_max =  9
             ms1_print = ms
          else if ((final_state == 'sb').or.                           &                        ! run individual channels if they exist
                   (final_state == 'ss').or.                           &
                   (final_state == 'sg').or.                           &
                   (final_state == 'ns')                 ) then
             isquark1_min = isquark1_in
             isquark1_max = isquark1_in
             isquark2_min = isquark2_in
             isquark2_max = isquark2_in
             ms1_print = msq(isquark1_min)
             ms2_print = msq(isquark2_min)
          else                                                                                ! default, nothing to sum over
             isquark1_min =  9
             isquark1_max =  9
             isquark2_min =  9
             isquark2_max =  9
          end if
       else
          print*, " PROSPINO: isq_ng not set correctly? ",isq_ng
          call HARD_STOP
       end if

       fct(20:22) = 0.0                                                                         ! initialize in case of loops
       do isquark1 = isquark1_min,isquark1_max,1                                                ! note this is always a loop
       do isquark2 = isquark2_min,isquark2_max,1                                                !    so `cycle' is the way out
          if ( (isquark1 == 0).or.(isquark2 == 0) ) cycle                                       ! just a tag for summing in isquark_in
          if ( (isquark1 /= isquark1_min) .or. (isquark2 /= isquark2_min) )  inext_sq = 1

          print*, " running with  final_state = ",final_state
          print*, "               ipart*_in   = ",ipart1_in,ipart2_in
          print*, "               isquark*    = ",isquark1,isquark2

          select case (final_state)                                                             ! setup for old prospino
          case ('gg')
             call INIT_IFAST(1,inext_sq,ifast)
             call FILL_COMMONS_SQ_GL(inlo,scafac)
             call INTEGGG( ifast, fct(-1:-1), rel(-1:-1), fct(0:0), rel(0:0), fct(20:20), rel(20:20) )
          case ('sb')
             idg_common = 0
             if ((isquark1 == isquark1_max).and.(isquark2 == isquark2_max)) idg_common = 1
             call INIT_IFAST(1,inext_sq,ifast)
             call FILL_COMMONS_SQ_GL(inlo,scafac)
             call INTEGSB( ifast, fct(-1:-1), rel(-1:-1), fct(0:0), rel(0:0), fct(20:20), rel(20:20) )
          case ('sg')
             idg_common = 0
             if (isquark1 == isquark1_max) idg_common = 1
             call INIT_IFAST(1,inext_sq,ifast)
             call FILL_COMMONS_SQ_GL(inlo,scafac)
             call INTEGSG( ifast, fct(-1:-1), rel(-1:-1), fct(0:0), rel(0:0), fct(20:20), rel(20:20) )
          case ('ss')
             if (isquark2 < isquark1) cycle
             idg_common = 0
             if ((isquark1 == isquark1_max).and.(isquark2 == isquark2_max)) idg_common = 1
             call INIT_IFAST(1,inext_sq,ifast)
             call FILL_COMMONS_SQ_GL(inlo,scafac)
             call INTEGSS( ifast, fct(-1:-1), rel(-1:-1), fct(0:0), rel(0:0), fct(20:20), rel(20:20) )
          case ('xx')
             call INIT_IFAST(1,inext_sq,ifast)
             call FILL_COMMONS_SQ_GL(inlo,scafac)
             call INTEGST( ifast, fct(0:0) , rel(0:0) , fct(20:20) , rel(20:20) )
          case default                                                                          ! below the new channels

!----------------------------------------------------------------------------------------------
!                  ii = -1    born consistent with non-degenerate squarks                     !
!                       0,1   born consistent[0] , nlo-type[1]                                !
!                       2     virtual correction                                              !
!                       3     real gluon emission                                             !
!                       4     subtraction term, crossed channels...                           !
!                       20    complete nlo (only sum of 1...9)                                !
!                       21    summed born term for non-degenerate squarks                     !
!                       22    summed born term multipled with squark-degenerate K factor      !
!----------------------------------------------------------------------------------------------
             do ii=ii_min,ii_max,1
                if ( (isquark1/=isquark1_max).and.(ii/=-1) ) cycle                              ! only run complete mode once

                print*, "               ii          = ",ii
                call INIT_ITERATION(lvalid_iteration)                                           ! always needed (pdf initialization...)
                if (.not. lvalid_iteration) cycle

                call INIT_ALPHAS                                                                ! initialize alpha_s, check Xget_pdf.f
                call INIT_VEGAS(i_lofast,ivegas)
                call INIT_IFAST(0,inext_sq,ifast)

                select case (final_state_new)                                                   ! the actual vegas integration
                case('ng')
                   call INTEG(IFCT_NG_X12,dim(ii),ivegas,ifast,fct(ii),rel(ii))
                case('ns')
                   call INTEG(IFCT_NS_X12,dim(ii),ivegas,ifast,fct(ii),rel(ii))
                case('nn')
                   call INTEG(IFCT_NN_X12,dim(ii),ivegas,ifast,fct(ii),rel(ii))
                case('ll')
                   call INTEG(IFCT_LL_X12,dim(ii),ivegas,ifast,fct(ii),rel(ii))
                case('tb','bb')
                   call INTEG(IFCT_TB_X12,dim(ii),ivegas,ifast,fct(ii),rel(ii))
                case('lq')
                   call INTEG(IFCT_LQ_X12,dim(ii),ivegas,ifast,fct(ii),rel(ii))
                case('le')
                   call INTEG(IFCT_LE_X12,dim(ii),ivegas,ifast,fct(ii),rel(ii))
                case('hh')
                   call INTEG(IFCT_HH_X12,dim(ii),ivegas,ifast,fct(ii),rel(ii))
                case('ht')
                   call INTEG(IFCT_HT_X12,dim(ii),ivegas,ifast,fct(ii),rel(ii))
                end select                                                                      ! close final_state_new
                print*, " MAIN: check number attempts stopped early ",n_faulty                  ! non-fatal errors kept track of

                if (abs(fct(ii))<1.e-20) then                                                   ! reject obvious garbage
                   fct(ii) = 0.0
                   rel(ii) = 0.0
                else if (abs(rel(ii))<1.e-20) then
                   rel(ii) = 0.0
                end if
             end do                                                                             ! close the ii loop

             if ((final_state=='hh').or.(final_state=='ht')) then                               ! compute K factor for 2HDM, #22 not needed
                fct(22) = fct(3)
                fct(3)  = 0.0
             end if

             fct(20) = sum( fct(1:11) )                                                         ! sum all nlo contributions
             if ( fct(20)>1.e-20 )                                                            &
                  rel(20) = abs( sqrt( sum( rel(1:9)**2*fct(1:9)**2 ) )/fct(20) )               ! relative error added in quadrature

          end select                                                                            ! close final_state

          fct(21) = fct(21) + fct(-1)
          rel(21) = rel(21) + rel(-1)**2*fct(-1)**2

       end do                                                                                ! close the isquark1 loop
       end do                                                                                ! close the isquark2 loop

       if ((abs(fct(21)))>1.D-12) rel(21) = abs( sqrt( rel(21) )/fct(21) )                      ! just like formula for rel(20)
       if ((abs(fct(0)))>1.D-12)     kfac = fct(20)/fct(0)                                      ! compute k factor, avoid core dump

       if ((final_state/='hh').and.(final_state/='ht')) then                                    ! means for all SUSY channels
          fct(22) = fct(21) * kfac                                                              ! scale new LO result by K factor
          if ((abs(fct(0)))>1.D-12)     kng  = fct(21)/fct(0)                                   ! compute factor between two born results
       else                                                                                ! fct(22) set before for Higgs channels
          fct(22) = fct(22) + fct(20)
          if ((abs(fct(20)))>1.D-12)    kng  = fct(22)/fct(20)                                  ! compute factor between two NLO results
       end if

       call DAT1(ndat1,run0,run1,ms1_print,ms2_print,fct,rel,kfac,kng)                          ! short results output file
       call DAT2(ndat2,run0,run1,ms1_print,ms2_print,fct,rel,kfac,kng)                          ! long results output file

    end do                                                                                ! close the ns loop
    end do                                                                                ! close the n0 loop
    end do                                                                                ! close the n1 loop

    return

  end subroutine PROSPINO

! ------------------------------
! open (status=0) or close (status=1) all input and output files
  subroutine PROSPINO_OPEN_CLOSE(status)

    implicit none

    integer, intent(in) :: status
    integer             :: nin1,nin2,ndat1,ndat2,ndat3

    character(len=20), parameter :: form1="(/,a121)"

    call GET_UNITS_READ_WRITE(nin1,nin2,ndat1,ndat2,ndat3)

    if (status == 0 ) then
       open(unit=nin2,  file="prospino.in.les_houches", action="read" )                         ! open all files here
       open(unit=ndat1, file="prospino.dat",            action="write")
       open(unit=ndat2, file="prospino.dat2",           action="write")
       open(unit=ndat3, file="prospino.dat3",           action="write")
    else if (status == 1) then
       if ((final_state=='hh').or.(final_state=='ht')) then
       write(ndat1, fmt=form1)                                                                 &
       "    i1 i2  dummy0 dummy1 scafac  m1    m2      angle LO[pb]   rel_error NLO[pb]   rel_error   K    NLO_SUSY[pb]           "
       else
       write(ndat1, fmt=form1)                                                                 &
       "    i1 i2  dummy0 dummy1 scafac  m1    m2      angle LO[pb]   rel_error NLO[pb]   rel_error   K    LO_ms[pb] NLO_ms[pb]   "
       end if

       close(nin1)                                                                              ! close all input/output files
       close(nin2)
       close(ndat1)
       close(ndat2)
       close(ndat3)
    else
       print*, " something wrong with input/output status "
       call HARD_STOP
    end if

  end subroutine PROSPINO_OPEN_CLOSE

! ------------------------------
! set these at one point in the program
  subroutine GET_UNITS_READ_WRITE(nin1,nin2,ndat1,ndat2,ndat3)

    implicit none

    integer, intent(out) :: nin1,nin2,ndat1,ndat2,ndat3

    nin1  = 95                                                                                ! set all the input/output unit numbers
    nin2  = 96
    ndat1 = 97
    ndat2 = 98
    ndat3 = 99

  end subroutine GET_UNITS_READ_WRITE

end module xx_prospino_subroutine


        SUBROUTINE ZCLWRT(ROOT,PASS,NS,NSPEC,WAVE,DATA,EPS,ERR,
     *                    NBINS,ET,EPSET,BCK,BCKID,ISTAT)
*
*  Module number:
*
*  Module name: ZCLWRT
*
*  Keyphrase:
*  ----------
*       Write results of calibration
*
*  Description:
*  ------------
*       This routine writes the output data files containing the
*       calibrated data.  Up to seven files are written. They are
*               <rootname>.c0h  wavelengths
*               <rootname>.c1h  flux
*               <rootname>.cqh  data quality vectors
*               <rootname>.c2h  propagated statistical error
*               <rootname>.c3h  special diodes
*               <rootname>.c4h  special diodes data quality
*               <rootname>.c5h  background
*       On input to this routine the .C1H file is already opened to
*       the correct group if PASS=FIRST
*
*  FORTRAN name: zclwrt.for
*
*  Keywords of accessed files and tables:
*  --------------------------------------
*  Name                         I/O     Description / Comments
*       <root>.c1h              I/O     Output flux file, also used
*                                       as template for other files
*       <root>.c0h              O       wavelength file
*       <root>.cqh              O       data quality file
*       <root>.c2h              O       propagated statistical errors
*       <root>.c3h              O       special diodes
*       <root>.c4h              O       special diodes data quality
*       <root>.c5h              O       background
*
*  Subroutines Called:
*  -------------------
*  CDBS:
*	zogpar
*  SDAS:
*	uipl1*, uimopn, uimclo, uuimcp, ZMSPUT
*  Others:
*
*
*  History:
*  --------
*  Version      Date        Author          Description
*       1       Feb 89  D. Lindler      Designed and coded
*	1.1	Sep 90	S. Hulbert	Put image creation into new
*					routine (zimcpy) and change how
*					DATAMIN/DATAMAX are updated
*	1.2	Feb 91	S. Hulbert	Changed datatype of c3h/c4h back to
*					real*4
*	1.3	Sep 91	S. Hulbert	Implemented PASS flag
*       1.4     Feb 94  J. Eisenhamer   Added background output.
*       1.5     Oct 96  M. De La Pena   Added FBMD
*-------------------------------------------------------------------------------
*
* Input parameters
*
*       root - rootname of the observation (ch*64)
*       pass - integer variable = 1 for first call, -1 for last
*       ns - number of sample positions in each output spectrum
*       nspec - number of output spectra
*       fadc - processing flag for application of disp. coef.
*       wave - wavelength array (real*8)
*       data - flux array (real*4)
*       eps - data quality array (real*4)
*       err - statistical error array (real*4)
*       nbins - number of substep bins
*       et - extracted data array (real*4)
*       epset -  extracted data quality array (real*4)
*       bck - Background that was subtracted (real*4)
*       bckid - Bin to use to find group information.
*
* Output parameter
*
*       istat - error status (integer)
*
*******************************************************************************
        CHARACTER*64 ROOT
        INTEGER PASS
        INTEGER NS,NSPEC,ISTAT,NBINS,BCKID
        DOUBLE PRECISION WAVE(NS,NSPEC)
        REAL DATA(NS,NSPEC),EPS(NS,NSPEC),ERR(NS,NSPEC),BCK(NS)
        REAL ET(24,7),EPSET(24,7)
C--------------------------------------------------------------------------
C
C     FILE I/O ACCESS MODES
C
      INTEGER   RDONLY
      PARAMETER (RDONLY = 1)
      INTEGER   RDWRIT
      PARAMETER (RDWRIT = 2)
C
C     CODES FOR DATA TYPES
C
      INTEGER   TYINT
      PARAMETER (TYINT = 4)
      INTEGER   TYREAL
      PARAMETER (TYREAL = 6)
      INTEGER   TYDOUB
      PARAMETER (TYDOUB = 7)
C
C     ZMSPUT DESTINATIONS -- CB, DAO, 4-SEP-87
C
      INTEGER STDOUT
      PARAMETER (STDOUT = 1)
      INTEGER STDERR
      PARAMETER (STDERR = 2)
C
C----------------------------------------------------------------------------
C
C                       /HRSIO/
C Common Block containting input/output parameters
C
C   IDS(20) - input file IDs
C               1 - .shh
C               2 - .ulh
C               3 - .d0h
C               4 - .q0h
C               5 - .x0h
C               6 - .xqh
C               7 - .c0h
C               8 - .c1h
C               9 - .cqh
C               10 - .c2h
C               11 - .c3h
C               12 - .c4h
C               13 - .c5h
C   GCOUNT(20) - group counts for input files
C   MERGE - Number of bins merged in output spectra
C   OBSRPT - observation repeats
C   NGOUT - number of output groups
C   NGSDT - number of output groups for the special diode files
C   READNO - readout number
C   NSOUT - number of samples in output data sets
C
        INTEGER IDS(20),MERGE,OBSRPT,NGOUT,GCOUNT(20),READNO,NSOUT,NGSDT
        COMMON /HRSIO/ IDS,GCOUNT,MERGE,OBSRPT,NGOUT,READNO,NSOUT,NGSDT
C
C                       /HRSFLG/
C Common block containing processing flags
C
C Initial values = 'PERFORM' or 'OMIT'
C final values = 'COMPLETE', 'PERFORM' or 'OMIT'
C
        CHARACTER*12 FPPC,FDIO,FPHC,FVIG,FDOP,FADC,FIAC,FVAC,FHEL,
     *            FBCK,FMNF,FMDF,FECH,FFLX,FEXP,FMAP,FDQI,FMER,
     *            FPLY,FGWC,FBMD
        COMMON /HRSFLG/FPPC,FDIO,FPHC,FVIG,FDOP,FADC,FIAC,FVAC,FHEL,
     *            FBCK,FMNF,FMDF,FECH,FFLX,FEXP,FMAP,FDQI,FMER,
     *            FPLY,FGWC,FBMD
C
C-------------------------------------------------------------------------
C
C LOCAL VARIABLES
C
        INTEGER FIRST
        PARAMETER (FIRST = 1)
        INTEGER LAST
        PARAMETER (LAST = -1)
C
        CHARACTER*30 BUNIT
        CHARACTER*80 CONTXT
        INTEGER IGOUT,ISPEC,IGSDT,IBIN, NSD
	INTEGER ISTAT1, ISTAT2
        REAL DMIN,DMAX
	DOUBLE PRECISION MINWAV,MAXWAV,MINWV0,MAXWV0
	LOGICAL WAVFLG
        DATA NSD /12/
C---------------------------------------------------------------------------
C
C if first call, open output files using the c1h file as a template
C
      IF (PASS.EQ.FIRST) THEN
C
C set up group pointers
C
         IGOUT=1
         IGSDT=1
C                                                             ---- open .c0h
C calculate minimum and maximum wavelength and put in c1h header
C before we create wavelength file (only if FADC = perform)
C
	 WAVFLG = .FALSE.
         IF (FADC.EQ.'PERFORM')THEN
	    CALL DMNMAX(WAVE,NS*NSPEC,MINWV0,IMIN,MAXWV0,IMAX)
            CALL UHDPSD(IDS(8),'MINWAVE',MINWV0,ISTAT1)
            CALL UHDPSD(IDS(8),'MAXWAVE',MAXWV0,ISTAT2)
            IF (ISTAT1.NE.0 .OR. ISTAT2.NE.0) THEN
	         CONTXT = 'ERROR updating MINWAVE/MAXWAVE keywords'
		 GO TO 1000
	    ENDIF
C
            CALL ZIMCPY(ROOT, 'c0h', IGOUT, NGOUT, TYDOUB, NS,
     $			IDS(8), 'WAV', 'ANGSTROMS', IDS(7), ISTAT)
            IF (ISTAT .NE. 0) GO TO 1000
         ENDIF
C                                                             ---- open .cqh
         CALL ZIMCPY(ROOT, 'cqh', IGOUT, NGOUT, TYINT, NS,
     $			IDS(8), 'FDQ', '        ', IDS(9), ISTAT)
         IF (ISTAT .NE. 0) GO TO 1000
C                                                             ---- open .c2h
C get bunits from c1h file
C
         CALL UHDGST(IDS(8),'BUNIT',BUNIT,ISTAT)
         CALL ZIMCPY(ROOT, 'c2h', IGOUT, NGOUT, TYREAL, NS,
     $			IDS(8), 'ERR', BUNIT, IDS(10), ISTAT)
         IF (ISTAT .NE. 0) GO TO 1000
C
C figure out bunits
C
	 IF (FEXP.EQ.'PERFORM')THEN
	    BUNIT = 'COUNTS/S'
	 ELSE
	    BUNIT = 'COUNTS  '
	 ENDIF
C                                                             ---- open .c5h
         IF(FBCK.EQ.'PERFORM')THEN
            CALL ZIMCPY(ROOT, 'c5h', IGOUT, NGOUT, TYREAL, NS,
     $           IDS(8), 'BCK', BUNIT, IDS(13), ISTAT)
            IF (ISTAT .NE. 0) GO TO 1000
            CALL ZNOFLG(IDS(13),ISTAT)
         ENDIF
C                                                             ---- open .c3h
         CALL ZIMCPY(ROOT, 'c3h', IGSDT, NGSDT, TYREAL, NSD,
     $	             IDS(8), 'SPD', BUNIT, IDS(11), ISTAT)
         IF (ISTAT .NE. 0) GO TO 1000
C        	                                             ---- open .c4h
         CALL ZIMCPY(ROOT, 'c4h', IGSDT, NGSDT, TYINT, NSD,
     $	             IDS(8), 'SPQ', '        ', IDS(12), ISTAT)
         IF (ISTAT .NE. 0) GO TO 1000
C
      ENDIF
C
C ******************** START LOOP ON SPECTRA **************************
C
      DO 500 ISPEC=1,NSPEC
C
C Point to the proper group
C
         IF (IGOUT .EQ. 1) GO TO 600
C                                                             ---- .c1h
C calculate datamin/datamax for group igout-1
C
	 CALL UUMNMX(IDS(8),DMIN,DMAX,ISTAT)
         IF(ISTAT.NE.0)THEN
            CONTXT='ERROR calculating datamin/datamax for .c1h file'
            GO TO 999
         ENDIF
C
C point to group igout passing in the min/max values for group igout-1
C for closing/writing purposes
C
         CALL UUOPGR(IDS(8),IGOUT,DMIN,DMAX,IDS(3),ISTAT)
         IF(ISTAT.NE.0)THEN
            CONTXT='ERROR changing group within .c1h file'
            GO TO 999
         ENDIF
C                                                             ---- .c0h
         IF(FADC.EQ.'PERFORM')THEN
	    CALL UUMNMX(IDS(7),DMIN,DMAX,ISTAT)
            IF(ISTAT.NE.0)THEN
               CONTXT='ERROR calculating datamin/datamax for .c0h file'
               GO TO 999
            ENDIF
            CALL UUOPGR(IDS(7),IGOUT,DMIN,DMAX,IDS(8),ISTAT)
            IF(ISTAT.NE.0)THEN
               CONTXT='ERROR changing group within .c0h file'
               GO TO 999
            ENDIF
         ENDIF
C                                                             ---- .cqh
	 CALL UUMNMX(IDS(9),DMIN,DMAX,ISTAT)
         IF(ISTAT.NE.0)THEN
            CONTXT='ERROR calculating datamin/datamax for .cqh file'
            GO TO 999
         ENDIF
         CALL UUOPGR(IDS(9),IGOUT,DMIN,DMAX,IDS(8),ISTAT)
         IF(ISTAT.NE.0)THEN
            CONTXT='ERROR changing group within .cqh file'
            GO TO 999
         ENDIF
C                                                             ---- .c2h
	 CALL UUMNMX(IDS(10),DMIN,DMAX,ISTAT)
         IF(ISTAT.NE.0)THEN
            CONTXT='ERROR calculating datamin/datamax for .c2h file'
            GO TO 999
         ENDIF
         CALL UUOPGR(IDS(10),IGOUT,DMIN,DMAX,IDS(8),ISTAT)
            IF(ISTAT.NE.0)THEN
                CONTXT='ERROR changing group within .c2h file'
                GO TO 999
         ENDIF
C                                                             ---- .c5h
         IF(FBCK.EQ.'PERFORM')THEN
            CALL UUMNMX(IDS(13),DMIN,DMAX,ISTAT)
            IF(ISTAT.NE.0)THEN
               CONTXT='ERROR calculating datamin/datamax for .c5h file'
               GO TO 999
            ENDIF
            CALL UUOPGR(IDS(13),IGOUT,DMIN,DMAX,IDS(8),ISTAT)
            IF(ISTAT.NE.0)THEN
               CONTXT='ERROR changing group within .c5h file'
               GO TO 999
            ENDIF
         ENDIF
C
C Write the data
C
  600    CALL UIPL1R(IDS(8),DATA(1,ISPEC),ISTAT)
         IF(ISTAT.NE.0)THEN
            CONTXT='ERROR: Error writing to .C1H file'
            GO TO 999
         ENDIF
C
         IF(FADC.EQ.'PERFORM')THEN
C
C keep track of the minimum and maximum wavelengths for the
C entire observation just to satisfy the ridiculous needs
C of the archive
C
	    CALL DMNMAX(WAVE,NS*NSPEC,MINWAV,IMIN,MAXWAV,IMAX)
	    IF (MINWAV.LT.MINWV0) MINWV0 = MINWAV
	    IF (MAXWAV.GT.MAXWV0) MAXWV0 = MAXWAV
	    IF (.NOT.WAVFLG) WAVFLG = .TRUE.
C
            CALL UIPL1D(IDS(7),WAVE(1,ISPEC),ISTAT)
            IF(ISTAT.NE.0)THEN
               CONTXT='ERROR: Error writing to .C0H file'
               GO TO 999
            ENDIF
         ENDIF
C
         CALL UIPL1R(IDS(9),EPS(1,ISPEC),ISTAT)
         IF(ISTAT.NE.0)THEN
            CONTXT='ERROR: Error writing to .CQH file'
            GO TO 999
         ENDIF
C
         CALL UIPL1R(IDS(10),ERR(1,ISPEC),ISTAT)
         IF(ISTAT.NE.0)THEN
            CONTXT='ERROR: Error writing to .C2H file'
            GO TO 999
         ENDIF
C
         IF(FBCK.EQ.'PERFORM')THEN
            CALL UIPL1R(IDS(13),BCK,ISTAT)
            IF(ISTAT.NE.0)THEN
               CONTXT='ERROR: Error writing to .C5H file'
               GO TO 999
            ENDIF
         ENDIF
C
C update group parameters
C
         CALL ZOGPAR(IDS(8),ISPEC,'c1h',ISTAT)
         IF(ISTAT.NE.0) GO TO 1000
C
         IF(FADC.EQ.'PERFORM')THEN
            CALL ZOGPAR(IDS(7),ISPEC,'c0h',ISTAT)
            IF(ISTAT.NE.0) GO TO 1000
         ENDIF
C
         CALL ZOGPAR(IDS(9),ISPEC,'cqh',ISTAT)
         IF(ISTAT.NE.0) GO TO 1000
C
         CALL ZOGPAR(IDS(10),ISPEC,'c2h',ISTAT)
         IF(ISTAT.NE.0) GO TO 1000
C
         IF(FBCK.EQ.'PERFORM')THEN
            IF(BCKID.EQ.0)BCKID=ISPEC
            CALL ZOGPAR(IDS(13),BCKID,'c5h',ISTAT)
            IF(ISTAT.NE.0) GO TO 1000
         ENDIF
C
C increment group pointer
C
         IGOUT=IGOUT+1
500   CONTINUE
C
C ******************** END LOOP ON SPECTRA ****************************
C
C ***************** START LOOP ON SUBSTEP BINS *************************
C
      DO 700 IBIN = 1, NBINS
C
C Point to the proper group
C
        IF (IGSDT .EQ. 1) GO TO 800
C                                                         ---- .c3h
	CALL UUMNMX(IDS(11),DMIN,DMAX,ISTAT)
        IF(ISTAT.NE.0)THEN
           CONTXT='ERROR calculating datamin/datamax for .c3h file'
           GO TO 999
        ENDIF
        CALL UUOPGR(IDS(11),IGSDT,DMIN,DMAX,IDS(8),ISTAT)
        IF (ISTAT.NE.0)THEN
           CONTXT='ERROR changing group within .c3h file'
           GO TO 999
        ENDIF
C                                                             ---- .c4h
	CALL UUMNMX(IDS(12),DMIN,DMAX,ISTAT)
        IF(ISTAT.NE.0)THEN
           CONTXT='ERROR calculating datamin/datamax for .c4h file'
           GO TO 999
        ENDIF
        CALL UUOPGR(IDS(12),IGSDT,DMIN,DMAX,IDS(8),ISTAT)
        IF (ISTAT.NE.0)THEN
           CONTXT='ERROR changing group within .c4h file'
           GO TO 999
        ENDIF
C
C Write the data
C
  800   CALL UIPL1R(IDS(11),ET(1,IBIN),ISTAT)
        IF (ISTAT.NE.0) THEN
           CONTXT='ERROR: Error writing to .C3H file'
           GO TO 999
        ENDIF
C
        CALL UIPL1R(IDS(12),EPSET(1,IBIN),ISTAT)
        IF (ISTAT.NE.0) THEN
           CONTXT='ERROR: Error writing to .C4H file'
           GO TO 999
        ENDIF
C
C write group parameters
C
        CALL ZOGPAR(IDS(11),IBIN,'c3h',ISTAT)
        IF(ISTAT.NE.0) GO TO 1000
C
        CALL ZOGPAR(IDS(12),IBIN,'c4h',ISTAT)
        IF(ISTAT.NE.0) GO TO 1000
C
C increment group pointer
C
        IGSDT=IGSDT+1
700   CONTINUE
C
C Force the computation of datamin/datamax for the last group
C of each image and update MINWAVE and MAXWAVE, if necessary
C
      IF (IGOUT .GT. NGOUT .AND. IGSDT .GT. NGSDT) THEN
         DO 101 I = 7, 13
             IF (I.EQ.7 .AND. FADC.EQ.'OMIT') GO TO 101
C            IF (I.EQ.13 .AND. FBCK.EQ.'OMIT') GO TO 101
             IF (I.EQ.13 .AND. ((FBCK.EQ.'OMIT') .OR.
     *                          (FBCK.EQ.'SKIPPED'))) GO TO 101
	     CALL UUMNMX(IDS(I),DMIN,DMAX,ISTAT)
             IF (ISTAT .NE. 0) GO TO 1000
	     IF (WAVFLG) THEN
                 CALL UHDPSD(IDS(I),'MINWAVE',MINWV0,ISTAT)
                 CALL UHDPSD(IDS(I),'MAXWAVE',MAXWV0,ISTAT)
                 IF (ISTAT1.NE.0 .OR. ISTAT2.NE.0) THEN
	             CONTXT = 'ERROR updating MINWAVE/MAXWAVE keywords'
		     GO TO 1000
		 ENDIF
	     ENDIF
101      CONTINUE
      ENDIF
C
C *********************************************************************
      ISTAT=0
      GO TO 1000
  999 CALL ZMSPUT(CONTXT,STDOUT+STDERR,0,ISTAT)
      ISTAT=1
 1000 RETURN
      END