CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Project quadrant from input PIC to output BUF (for byte data).
C
      SUBROUTINE PROJECT_QUAD(PIC,buf,INTERP,INCLUDE,INC,INCo,
     &		LBEG,SBEG,A,B,DL,DS,NLI,NSI,NLO,NSO,ROW)
      BYTE PIC(NSI,NLI),BUF(NSO,INCo)
      INTEGER*4 INTERP,INCLUDE,INC,INCo,LBEG,SBEG,NLI,NSI,NLO,NSO,ROW
      REAL*8 DL,DS

      COMMON/SCALING/SCALE_FACTOR
      REAL*8 SCALE_FACTOR

      REAL*8 X,Y,RLINE,RSAMP
      REAL*4 A(4),B(4)
      INTEGER*4 L,S,IL,IS,LEND,SEND,LL
      INTEGER*4 D1,D2,D3,D4,IVAL,IND

      INCLUDE 'fortport'

      LEND = LBEG + INC - 1
      SEND = SBEG + INC - 1
      IF (LEND.GT.NLO) LEND=NLO
      IF (SEND.GT.NSO) SEND=NSO
      IND = 1

      DO 30 L=LBEG,LEND
      LL = L - ROW + 1

      DO 30 S=SBEG,SEND
      IVAL=0				!Clear DN
      IF (INTERP.EQ.1) THEN
        CALL PSUB(INCLUDE,L,S,rline,rsamp,ind)
        IF (IND.EQ.0) THEN
           IF (INCLUDE.EQ.0) GOTO 30
           RSAMP = SCALE_FACTOR*(S + DS) !RRP FR89270
           RLINE = SCALE_FACTOR*(L + DL) !RRP FR89270
        ENDIF
      ELSEIF (INTERP.EQ.2) THEN
        RSAMP = A(1) + A(2)*S + A(3)*L + A(4)*L*S
        RLINE = B(1) + B(2)*S + B(3)*L + B(4)*L*S
      ELSEIF (INTERP.EQ.3) THEN
        RSAMP = SCALE_FACTOR*(S + DS) !RRP FR89270
        RLINE = SCALE_FACTOR*(L + DL) !RRP FR89270
      ELSE
        GOTO 30
      ENDIF

      IS = RSAMP
      IL = RLINE
      IF (IL.LT.1.OR.IS.LT.1) GOTO 30           !Point off image
      IF (IL.GE.NLI.OR.IS.GE.NSI) GOTO 30

C     ....Compute pixel using bilinear interpolation
      D1 = BYTE2INT(PIC(IS,IL))         !upper left pixel
      D2 = BYTE2INT(PIC(IS+1,IL))       !upper right pixel
      D3 = BYTE2INT(PIC(IS,IL+1))       !lower left pixel
      D4 = BYTE2INT(PIC(IS+1,IL+1))     !lower right pixel
      X = RSAMP - IS
      Y = RLINE - IL
      IVAL = D1 + (D2-D1)*X + (D3-D1)*Y + (D1-D2-D3+D4)*X*Y
CCC      IVAL = INTERP
CCC      IF (IND.EQ.0) IVAL=3
CCC      IF (INC.EQ.32) IVAL=32
CCC      IF (INC.EQ.16) IVAL=64
CCC      IF (INC.EQ.8) IVAL=128
CCC      IF (INC.EQ.4) IVAL=196
CCC      IF (INTERP.EQ.1) IVAL=255
   30 BUF(S,LL) = int2byte(IVAL)

      RETURN
      END


      SUBROUTINE PXCONE(MODE,NTRAK,ITKDM,PTRAK,CONER,EPSLON,OVLIM,
     +                   MXJET,NJET,PJET,IPASS,IJMUL,IERR)
*.*********************************************************
*. ------
*. PXCONE
*. ------
*.
*.********** Pre Release Version 26.2.93
*.
*. Lifted from the following web page
*.   http://aliceinfo.cern.ch/alicvs/viewvc/JETAN/pxcone.F?view=markup&pathrev=v4-05-04
*.
*. on 17/10/2006 by G. Salam.
*.
*. Driver for the Cone  Jet finding algorithm of L.A. del Pozo.
*. Based on algorithm from D.E. Soper.
*. Finds jets inside cone of half angle CONER with energy > EPSLON.
*. Jets which receive more than a fraction OVLIM of their energy from
*. overlaps with other jets are excluded.
*. Output jets are ordered in energy.
*. If MODE.EQ.2 momenta are stored as (eta,phi,<empty>,pt)
*. Usage     :
*.
*.      INTEGER  ITKDM,MXTRK
*.      PARAMETER  (ITKDM=4.or.more,MXTRK=1.or.more)
*.      INTEGER  MXJET, MXTRAK, MXPROT
*.      PARAMETER  (MXJET=10,MXTRAK=500,MXPROT=500)
*.      INTEGER  IPASS (MXTRAK),IJMUL (MXJET)
*.      INTEGER  NTRAK,NJET,IERR,MODE
*.      DOUBLE PRECISION  PTRAK (ITKDM,MXTRK),PJET (5,MXJET)
*.      DOUBLE PRECISION  CONER, EPSLON, OVLIM
*.      NTRAK = 1.to.MXTRAK
*.      CONER   = ...
*.      EPSLON  = ...
*.      OVLIM   = ...
*.      CALL PXCONE (MODE,NTRAK,ITKDM,PTRAK,CONER,EPSLON,OVLIM,MXJET,
*.     +             NJET,PJET,IPASS,IJMUL,IERR)
*.
*. INPUT     :  MODE      1=>e+e-, 2=>hadron-hadron
*. INPUT     :  NTRAK     Number of particles
*. INPUT     :  ITKDM     First dimension of PTRAK array
*. INPUT     :  PTRAK     Array of particle 4-momenta (Px,Py,Pz,E)
*. INPUT     :  CONER     Cone size (half angle) in radians
*. INPUT     :  EPSLON    Minimum Jet energy (GeV)
*. INPUT     :  OVLIM     Maximum fraction of overlap energy in a jet
*. INPUT     :  MXJET     Maximum possible number of jets
*. OUTPUT    :  NJET      Number of jets found
*. OUTPUT    :  PJET      5-vectors of jets
*. OUTPUT    :  IPASS(k)  Particle k belongs to jet number IPASS(k)
*.                        IPASS = -1 if not assosciated to a jet
*. OUTPUT    :  IJMUL(i)  Jet i contains IJMUL(i) particles
*. OUTPUT    :  IERR      = 0 if all is OK ;   = -1 otherwise
*.
*. CALLS     : PXSEAR, PXSAME, PXNEW, PXTRY, PXORD, PXUVEC, PXOLAP
*. CALLED    : User
*.
*. AUTHOR    :  L.A. del Pozo
*. CREATED   :  26-Feb-93
*. LAST MOD  :   2-Mar-93
*.
*. Modification Log.
*. 25-Feb-07: G P Salam   - fix bugs concerning 2pi periodicity in eta phi mode
*.                        - added commented code to get consistent behaviour
*.                          regardless of particle order (replaces n-way
*.                          midpoints with 2-way midpoints however...)
*. 2-Jan-97: M Wobisch    - fix bug concerning COS2R in eta phi mode
*. 4-Apr-93: M H Seymour  - Change 2d arrays to 1d in PXTRY & PXNEW
*. 2-Apr-93: M H Seymour  - Major changes to add boost-invariant mode
*. 1-Apr-93: M H Seymour  - Increase all array sizes
*. 30-Mar-93: M H Seymour - Change all REAL variables to DOUBLE PRECISION
*. 30-Mar-93: M H Seymour - Change OVLIM into an input parameter
*. 2-Mar-93: L A del Pozo - Fix Bugs in PXOLAP
*. 1-Mar-93: L A del Pozo - Remove Cern library routine calls
*. 1-Mar-93: L A del Pozo - Add Print out of welcome and R and Epsilon
*.
*.*********************************************************
C+SEQ,DECLARE.
*** External Arrays
      INTEGER  ITKDM,MXJET,NTRAK,NJET,IERR,MODE
      INTEGER  IPASS (NTRAK),IJMUL (MXJET)
      DOUBLE PRECISION  PTRAK (ITKDM,NTRAK),PJET (5,MXJET),
     +     CONER, EPSLON, OVLIM
*** Internal Arrays
      INTEGER MXPROT, MXTRAK
      PARAMETER (MXPROT=5000, MXTRAK=5000)
      DOUBLE PRECISION PP(4,MXTRAK), PU(3,MXTRAK), PJ(4,MXPROT)
      LOGICAL JETLIS(MXPROT,MXTRAK)
*** Used in the routine.
      DOUBLE PRECISION COSR,COS2R, VSEED(3), VEC1(3), VEC2(3),PTSQ,PPSQ,
     +     COSVAL,PXMDPI
cMWobisch
      DOUBLE PRECISION RSEP
cMWobisch
      LOGICAL UNSTBL
      INTEGER I,J,N,MU,N1,N2, ITERR, NJTORG
      INTEGER NCALL, NPRINT
      DOUBLE PRECISION ROLD, EPSOLD, OVOLD
      SAVE NCALL,NPRINT,ROLD, EPSOLD, OVOLD
      DATA NCALL,NPRINT /0,0/
      DATA ROLD,EPSOLD,OVOLD/0.,0.,0./

cMWobisch
c***************************************
      RSEP  = 2D0
c***************************************
cMWobisch
      IERR=0
*
*** INITIALIZE
      IF(NCALL.LE.0)  THEN
         ROLD = 0.
         EPSOLD = 0.
         OVOLD = 0.
      ENDIF
      NCALL = NCALL + 1
*
*** Print welcome and Jetfinder parameters
      IF((CONER.NE.ROLD .OR. EPSLON.NE.EPSOLD .OR. OVLIM.NE.OVOLD)
     +     .AND. NPRINT.LE.10) THEN
         WRITE (6,*)
         WRITE (6,*) ' *********** PXCONE: Cone Jet-finder ***********'
         WRITE (6,*) '    Written by Luis Del Pozo of OPAL'
         WRITE (6,*) '    Modified for eta-phi by Mike Seymour'
         WRITE (6,*) '    Includes bug fixes by Wobisch, Salam'
         WRITE(6,1000)'   Cone Size R = ',CONER,' Radians'
         WRITE(6,1001)'   Min Jet energy Epsilon = ',EPSLON,' GeV'
         WRITE(6,1002)'   Overlap fraction parameter = ',OVLIM
         WRITE (6,*) '    PXCONE is not a supported product and is'
         WRITE (6,*) '    is provided for comparative purposes only'
         WRITE (6,*) ' ***********************************************'
cMWobisch
         IF (RSEP .lt. 1.999) THEN
            WRITE(6,*) ' '
            WRITE (6,*) ' ******************************************'
            WRITE (6,*) ' ******************************************'
            WRITE(6,*) ' M Wobisch: private change !!!!!!!!!!!! '
            WRITE(6,*) '      Rsep is set to ',RSEP
            WRITE(6,*) ' this is ONLY meaningful in a NLO calculation'
            WRITE(6,*) '      ------------------------  '
            WRITE(6,*) '  please check what you''re doing!!'
            WRITE(6,*) '   or ask:  Markus.Wobisch@desy.de --'
            WRITE (6,*) ' ******************************************'
            WRITE (6,*) ' ******************************************'
            WRITE (6,*) ' ******************************************'
            WRITE(6,*) ' '
            WRITE(6,*) ' '
         ENDIF
cMWobisch

         WRITE (6,*)
1000     FORMAT(A18,F5.2,A10)
1001     FORMAT(A29,F5.2,A5)
1002     FORMAT(A33,F5.2)
         NPRINT = NPRINT + 1
         ROLD=CONER
         EPSOLD=EPSLON
         OVOLD=OVLIM
      ENDIF
*
*** Copy calling array PTRAK  to internal array PP(4,NTRAK)
*
      IF (NTRAK .GT. MXTRAK) THEN
         WRITE (6,*) ' PXCONE: Ntrak too large: ',NTRAK
         IERR=-1
         RETURN
      ENDIF
      IF (MODE.NE.2) THEN
         DO  100 I=1, NTRAK
            DO  101 J=1,4
               PP(J,I)=PTRAK(J,I)
101         CONTINUE
100      CONTINUE
      ELSE
*** Converting to eta,phi,pt if necessary
         DO  104 I=1,NTRAK
            PTSQ=PTRAK(1,I)**2+PTRAK(2,I)**2
            PPSQ=(SQRT(PTSQ+PTRAK(3,I)**2)+ABS(PTRAK(3,I)))**2
            IF (PTSQ.LE.4.25E-18*PPSQ) THEN
               PP(1,I)=20
            ELSE
               PP(1,I)=0.5*LOG(PPSQ/PTSQ)
            ENDIF
            PP(1,I)=SIGN(PP(1,I),PTRAK(3,I))
            IF (PTSQ.EQ.0) THEN
               PP(2,I)=0
            ELSE
               PP(2,I)=ATAN2(PTRAK(2,I),PTRAK(1,I))
            ENDIF
            PP(3,I)=0
            PP(4,I)=SQRT(PTSQ)
            PU(1,I)=PP(1,I)
            PU(2,I)=PP(2,I)
            PU(3,I)=PP(3,I)
104      CONTINUE
      ENDIF
*
*** Zero output variables
*
      NJET=0
      DO 102 I = 1, NTRAK
         DO 103 J = 1, MXPROT
           JETLIS(J,I) = .FALSE.
103      CONTINUE
102   CONTINUE
      CALL PXZERV(4*MXPROT,PJ)
      CALL PXZERI(MXJET,IJMUL)
*
      IF (MODE.NE.2) THEN
         COSR = COS(CONER)
         COS2R = COS(CONER)
      ELSE
*** Purely for convenience, work in terms of 1-R**2
         COSR = 1-CONER**2
cMW -- select Rsep: 1-(Rsep*CONER)**2
         COS2R =  1-(RSEP*CONER)**2
cORIGINAL         COS2R =  1-(2*CONER)**2
      ENDIF
      UNSTBL = .FALSE.
      IF (MODE.NE.2) THEN
         CALL PXUVEC(NTRAK,PP,PU,IERR)
         IF (IERR .NE. 0) RETURN
      ENDIF
*** Look for jets using particle diretions as seed axes
*
      DO 110 N = 1,NTRAK
        DO 120 MU = 1,3
          VSEED(MU) = PU(MU,N)
120     CONTINUE
        CALL PXSEAR(MODE,COSR,NTRAK,PU,PP,VSEED,
     &                   NJET,JETLIS,PJ,UNSTBL,IERR)
         IF (IERR .NE. 0) RETURN
110   CONTINUE

cMW - for Rsep=1 goto 145
c      GOTO 145

*** Now look between all pairs of jets as seed axes.
c      NJTORG = NJET           ! GPS -- to get consistent behaviour (2-way midpnts)
c      DO 140 N1 = 1,NJTORG-1  ! GPS -- to get consistent behaviour (2-way midpnts)
      DO 140 N1 = 1,NJET-1
         VEC1(1)=PJ(1,N1)
         VEC1(2)=PJ(2,N1)
         VEC1(3)=PJ(3,N1)
         IF (MODE.NE.2) CALL PXNORV(3,VEC1,VEC1,ITERR)
C         DO 150 N2 = N1+1,NJTORG ! GPS -- to get consistent behaviour
         DO 150 N2 = N1+1,NJET
            VEC2(1)=PJ(1,N2)
            VEC2(2)=PJ(2,N2)
            VEC2(3)=PJ(3,N2)
            IF (MODE.NE.2) CALL PXNORV(3,VEC2,VEC2,ITERR)
            CALL PXADDV(3,VEC1,VEC2,VSEED,ITERR)
            IF (MODE.NE.2) THEN
               CALL PXNORV(3,VSEED,VSEED,ITERR)
            ELSE
               VSEED(1)=VSEED(1)/2
               !VSEED(2)=VSEED(2)/2
               ! GPS 25/02/07
               VSEED(2)=PXMDPI(VEC1(2)+0.5d0*PXMDPI(VEC2(2)-VEC1(2)))
            ENDIF
C---ONLY BOTHER IF THEY ARE BETWEEN 1 AND 2 CONE RADII APART
            IF (MODE.NE.2) THEN
              COSVAL=VEC1(1)*VEC2(1)+VEC1(2)*VEC2(2)+VEC1(3)*VEC2(3)
            ELSE
               IF (ABS(VEC1(1)).GE.20.OR.ABS(VEC2(1)).GE.20) THEN
                  COSVAL=-1000
               ELSE
                  COSVAL=1-
     +              ((VEC1(1)-VEC2(1))**2+PXMDPI(VEC1(2)-VEC2(2))**2)
               ENDIF
            ENDIF

            IF (COSVAL.LE.COSR.AND.COSVAL.GE.COS2R)
     +           CALL PXSEAR(MODE,COSR,NTRAK,PU,PP,VSEED,NJET,
     +           JETLIS,PJ,UNSTBL,IERR)
c            CALL PXSEAR(MODE,COSR,NTRAK,PU,PP,VSEED,NJET,
c     +           JETLIS,PJ,UNSTBL,IERR)
            IF (IERR .NE. 0) RETURN
150      CONTINUE
140   CONTINUE
      IF (UNSTBL) THEN
        IERR=-1
        WRITE (6,*) ' PXCONE: Too many iterations to find a proto-jet'
        RETURN
      ENDIF

 145  CONTINUE
*** Now put the jet list into order by jet energy, eliminating jets
*** with energy less than EPSLON.
       CALL PXORD(EPSLON,NJET,NTRAK,JETLIS,PJ)
*
*** Take care of jet overlaps
       CALL PXOLAP(MODE,NJET,NTRAK,JETLIS,PJ,PP,OVLIM)
*
*** Order jets again as some have been eliminated, or lost energy.
       CALL PXORD(EPSLON,NJET,NTRAK,JETLIS,PJ)
*
*** All done!, Copy output into output arrays
      IF (NJET .GT. MXJET) THEN
         WRITE (6,*) ' PXCONE:  Found more than MXJET jets'
         IERR=-1
         GOTO 99
      ENDIF
      IF (MODE.NE.2) THEN
         DO 300 I=1, NJET
            DO 310 J=1,4
               PJET(J,I)=PJ(J,I)
310         CONTINUE
300      CONTINUE
      ELSE
         DO 315 I=1, NJET
            PJET(1,I)=PJ(4,I)*COS(PJ(2,I))
            PJET(2,I)=PJ(4,I)*SIN(PJ(2,I))
            PJET(3,I)=PJ(4,I)*SINH(PJ(1,I))
            PJET(4,I)=PJ(4,I)*COSH(PJ(1,I))
 315     CONTINUE
      ENDIF
      DO 320 I=1, NTRAK
         IPASS(I)=-1
         DO 330 J=1, NJET
            IF (JETLIS(J,I)) THEN
               IJMUL(J)=IJMUL(J)+1
               IPASS(I)=J
            ENDIF
330      CONTINUE
320   CONTINUE
99    RETURN
      END
*CMZ :  1.06/00 28/02/94  15.44.44  by  P. Schleper
*-- Author :
C-----------------------------------------------------------------------
      SUBROUTINE PXNORV(N,A,B,ITERR)
      INTEGER I,N,ITERR
      DOUBLE PRECISION A(N),B(N),C
      C=0
      DO 10 I=1,N
        C=C+A(I)**2
 10   CONTINUE
      IF (C.LE.0) RETURN
      C=1/SQRT(C)
      DO 20 I=1,N
        B(I)=A(I)*C
 20   CONTINUE
      END
*CMZ :  2.00/00 10/01/95  10.17.57  by  P. Schleper
*CMZ :  1.06/00 15/03/94  12.17.46  by  P. Schleper
*-- Author :
*
C+DECK,PXOLAP.
      SUBROUTINE PXOLAP(MODE,NJET,NTRAK,JETLIS,PJ,PP,OVLIM)
*
*** Looks for particles assigned to more than 1 jet, and reassigns them
*** If more than a fraction OVLIM of a jet's energy is contained in
*** higher energy jets, that jet is neglected.
*** Particles assigned to the jet closest in angle (a la CDF, Snowmass).
C+SEQ,DECLARE.
      INTEGER MXTRAK, MXPROT
      PARAMETER (MXTRAK=5000,MXPROT=5000)
      INTEGER NJET, NTRAK, MODE
      LOGICAL JETLIS(MXPROT,MXTRAK)
      DOUBLE PRECISION PJ(4,MXPROT),PP(4,MXTRAK),PXMDPI
      INTEGER I,J,N,MU
      LOGICAL OVELAP
      DOUBLE PRECISION EOVER
      DOUBLE PRECISION OVLIM
      INTEGER ITERR, IJMIN, IJET(MXPROT), NJ
      DOUBLE PRECISION VEC1(3), VEC2(3), COST, THET, THMIN
      DATA IJMIN/0/
*
      IF (NJET.LE.1) RETURN
*** Look for jets with large overlaps with higher energy jets.
      DO 100 I = 2,NJET
*** Find overlap energy between jets I and all higher energy jets.
       EOVER = 0.0
       DO 110 N = 1,NTRAK
         OVELAP = .FALSE.
         DO 120 J= 1,I-1
           IF (JETLIS(I,N).AND.JETLIS(J,N)) THEN
            OVELAP = .TRUE.
           ENDIF
120      CONTINUE
         IF (OVELAP) THEN
           EOVER = EOVER + PP(4,N)
         ENDIF
110     CONTINUE
*** Is the fraction of energy shared larger than OVLIM?
        IF (EOVER.GT.OVLIM*PJ(4,I)) THEN
*** De-assign all particles from Jet I
            DO 130 N = 1,NTRAK
              JETLIS(I,N) = .FALSE.
130         CONTINUE
         ENDIF
100   CONTINUE
*** Now there are no big overlaps, assign every particle in
*** more than 1 jet to the closet jet.
*** Any particles now in more than 1 jet are assigned to the CLOSET
*** jet (in angle).
      DO 140 I=1,NTRAK
         NJ=0
         DO 150 J=1, NJET
         IF(JETLIS(J,I)) THEN
            NJ=NJ+1
            IJET(NJ)=J
         ENDIF
150      CONTINUE
         IF (NJ .GT. 1) THEN
*** Particle in > 1 jet - calc angles...
            VEC1(1)=PP(1,I)
            VEC1(2)=PP(2,I)
            VEC1(3)=PP(3,I)
            THMIN=0.
            DO 160 J=1,NJ
               VEC2(1)=PJ(1,IJET(J))
               VEC2(2)=PJ(2,IJET(J))
               VEC2(3)=PJ(3,IJET(J))
               IF (MODE.NE.2) THEN
                  CALL PXANG3(VEC1,VEC2,COST,THET,ITERR)
               ELSE
                  THET=(VEC1(1)-VEC2(1))**2+PXMDPI(VEC1(2)-VEC2(2))**2
               ENDIF
               IF (J .EQ. 1) THEN
                  THMIN=THET
                  IJMIN=IJET(J)
               ELSEIF (THET .LT. THMIN) THEN
                  THMIN=THET
                  IJMIN=IJET(J)
               ENDIF
160         CONTINUE
*** Assign track to IJMIN
            DO 170 J=1,NJET
               JETLIS(J,I) = .FALSE.
170         CONTINUE
            JETLIS(IJMIN,I)=.TRUE.
         ENDIF
140   CONTINUE
*** Recompute PJ
      DO 200 I = 1,NJET
        DO 210 MU = 1,4
          PJ(MU,I) = 0.0
210     CONTINUE
        DO 220 N = 1,NTRAK
          IF( JETLIS(I,N) ) THEN
             IF (MODE.NE.2) THEN
                DO 230 MU = 1,4
                   PJ(MU,I) = PJ(MU,I) + PP(MU,N)
230             CONTINUE
             ELSE
                PJ(1,I)=PJ(1,I)
     +               + PP(4,N)/(PP(4,N)+PJ(4,I))*(PP(1,N)-PJ(1,I))
c GPS 25/02/07
                PJ(2,I)=PXMDPI(PJ(2,I)
     +             + PP(4,N)/(PP(4,N)+PJ(4,I))*PXMDPI(PP(2,N)-PJ(2,I)))
c                PJ(2,I)=PJ(2,I)
c     +               + PP(4,N)/(PP(4,N)+PJ(4,I))*PXMDPI(PP(2,N)-PJ(2,I))
                PJ(4,I)=PJ(4,I)+PP(4,N)
             ENDIF
          ENDIF
220     CONTINUE
200   CONTINUE
      RETURN
      END
*CMZ :  2.00/00 10/01/95  10.17.57  by  P. Schleper
*CMZ :  1.06/00 14/03/94  15.37.45  by  P. Schleper
*-- Author :
*
C+DECK,PXORD.
       SUBROUTINE PXORD(EPSLON,NJET,NTRAK,JETLIS,PJ)
*
*** Routine to put jets into order and eliminate tose less than EPSLON
C+SEQ,DECLARE.
      INTEGER MXTRAK,MXPROT
      PARAMETER (MXTRAK=5000,MXPROT=5000)
       INTEGER I, J, INDEX(MXPROT)
       DOUBLE PRECISION PTEMP(4,MXPROT), ELIST(MXPROT)
       INTEGER NJET,NTRAK
       LOGICAL JETLIS(MXPROT,MXTRAK)
       LOGICAL LOGTMP(MXPROT,MXTRAK)
       DOUBLE PRECISION EPSLON,PJ(4,MXPROT)
*** Puts jets in order of energy: 1 = highest energy etc.
*** Then Eliminate jets with energy below EPSLON
*
*** Copy input arrays.
      DO 100 I=1,NJET
         DO 110 J=1,4
            PTEMP(J,I)=PJ(J,I)
110      CONTINUE
         DO 120 J=1,NTRAK
            LOGTMP(I,J)=JETLIS(I,J)
120      CONTINUE
100   CONTINUE
      DO 150 I=1,NJET
         ELIST(I)=PJ(4,I)
150   CONTINUE
*** Sort the energies...
      CALL PXSORV(NJET,ELIST,INDEX,'I')
*** Fill PJ and JETLIS according to sort ( sort is in ascending order!!)
      DO 200 I=1, NJET
         DO 210 J=1,4
            PJ(J,I)=PTEMP(J,INDEX(NJET+1-I))
210      CONTINUE
         DO 220 J=1,NTRAK
            JETLIS(I,J)=LOGTMP(INDEX(NJET+1-I),J)
220      CONTINUE
200   CONTINUE
** Jets are now in order
*** Now eliminate jets with less than Epsilon energy
      DO 300, I=1, NJET
         IF (PJ(4,I) .LT. EPSLON) THEN
            NJET=NJET-1
            PJ(4,I)=0.
         ENDIF
300   CONTINUE
      RETURN
      END

********************************************************************
*CMZ :  2.00/00 10/01/95  10.17.57  by  P. Schleper
*CMZ :  1.06/00 14/03/94  15.37.44  by  P. Schleper
*-- Author :
C+DECK,PXSEAR.
      SUBROUTINE PXSEAR(MODE,COSR,NTRAK,PU,PP,VSEED,NJET,
     +                JETLIS,PJ,UNSTBL,IERR)
*
C+SEQ,DECLARE.
      INTEGER MXTRAK, MXPROT
      PARAMETER (MXTRAK=5000,MXPROT=5000)
      INTEGER NTRAK, IERR, MODE
      DOUBLE PRECISION COSR,PU(3,MXTRAK),PP(4,MXTRAK),VSEED(3)
      LOGICAL UNSTBL
      LOGICAL JETLIS(MXPROT,MXTRAK)
      INTEGER NJET
      DOUBLE PRECISION  PJ(4,MXPROT)
*** Using VSEED as a trial axis , look for a stable jet.
*** Check stable jets against those already found and add to PJ.
*** Will try up to MXITER iterations to get a stable set of particles
*** in the cone.
      INTEGER MU,N,ITER
      LOGICAL PXSAME,PXNEW,OK
      LOGICAL NEWLIS(MXTRAK),OLDLIS(MXTRAK)
      DOUBLE PRECISION OAXIS(3),NAXIS(3),PNEW(4)
      INTEGER MXITER
      PARAMETER(MXITER = 30)
*
      DO 100 MU=1,3
        OAXIS(MU) = VSEED(MU)
100   CONTINUE
      DO 110 N = 1,NTRAK
        OLDLIS(N) = .FALSE.
110   CONTINUE
      DO 120 ITER = 1,MXITER
        CALL PXTRY(MODE,COSR,NTRAK,PU,PP,OAXIS,NAXIS,PNEW,NEWLIS,OK)
*** Return immediately if there were no particles in the cone.
       IF (.NOT.OK) THEN
         RETURN
       ENDIF
       IF(PXSAME(NEWLIS,OLDLIS,NTRAK)) THEN
*** We have a stable jet.
             IF (PXNEW(NEWLIS,JETLIS,NTRAK,NJET)) THEN
*** And the jet is a new one. So add it to our arrays.
*** Check arrays are big anough...
             IF (NJET .EQ. MXPROT) THEN
             WRITE (6,*) ' PXCONE:  Found more than MXPROT proto-jets'
                IERR = -1
                RETURN
             ENDIF
               NJET = NJET + 1
               DO 130 N = 1,NTRAK
                 JETLIS(NJET,N) = NEWLIS(N)
130            CONTINUE
               DO 140 MU=1,4
                 PJ(MU,NJET)=PNEW(MU)
140          CONTINUE
             ENDIF
             RETURN
       ENDIF
*** The jet was not stable, so we iterate again
       DO 150 N=1,NTRAK
         OLDLIS(N)=NEWLIS(N)
150    CONTINUE
       DO 160 MU=1,3
         OAXIS(MU)=NAXIS(MU)
160    CONTINUE
120   CONTINUE
      UNSTBL = .TRUE.
      RETURN
      END
*CMZ :  1.06/00 28/02/94  15.44.44  by  P. Schleper
*-- Author :
C-----------------------------------------------------------------------
      SUBROUTINE PXSORV(N,A,K,OPT)
C     Sort A(N) into ascending order
C     OPT = 'I' : return index array K only
C     OTHERWISE : return sorted A and index array K
C-----------------------------------------------------------------------
      INTEGER NMAX
      PARAMETER (NMAX=5000)
*
*      INTEGER N,I,J,K(N),IL(NMAX),IR(NMAX)
*LUND
      INTEGER N,I,J,K(NMAX),IL(NMAX),IR(NMAX)
      CHARACTER OPT
*
*      DOUBLE PRECISION A(N),B(NMAX)
      DOUBLE PRECISION A(NMAX),B(NMAX)
*LUND
      IF (N.GT.NMAX) STOP 'Sorry, not enough room in Mike''s PXSORV'
      IL(1)=0
      IR(1)=0
      DO 10 I=2,N
      IL(I)=0
      IR(I)=0
      J=1
   2  IF(A(I).GT.A(J)) GO TO 5
   3  IF(IL(J).EQ.0) GO TO 4
      J=IL(J)
      GO TO 2
   4  IR(I)=-J
      IL(J)=I
      GO TO 10
   5  IF(IR(J).LE.0) GO TO 6
      J=IR(J)
      GO TO 2
   6  IR(I)=IR(J)
      IR(J)=I
  10  CONTINUE
      I=1
      J=1
      GO TO 8
  20  J=IL(J)
   8  IF(IL(J).GT.0) GO TO 20
   9  K(I)=J
      B(I)=A(J)
      I=I+1
      IF(IR(J)) 12,30,13
  13  J=IR(J)
      GO TO 8
  12  J=-IR(J)
      GO TO 9
  30  IF(OPT.EQ.'I') RETURN
      DO 31 I=1,N
  31  A(I)=B(I)
 999  END

*********************************************************************
*CMZ :  2.00/00 10/01/95  10.17.57  by  P. Schleper
*CMZ :  1.06/00 14/03/94  15.37.44  by  P. Schleper
*-- Author :
*
C+DECK,PXTRY.
       SUBROUTINE PXTRY(MODE,COSR,NTRAK,PU,PP,OAXIS,NAXIS,
     +                  PNEW,NEWLIS,OK)
*
C+SEQ,DECLARE.
      INTEGER MXTRAK
      PARAMETER (MXTRAK=5000)
       INTEGER NTRAK,MODE
*** Note that although PU and PP are assumed to be 2d arrays, they
*** are used as 1d in this routine for efficiency
       DOUBLE PRECISION COSR,PU(3*MXTRAK),PP(4*MXTRAK),OAXIS(3),PXMDPI
       LOGICAL OK
       LOGICAL NEWLIS(MXTRAK)
       DOUBLE PRECISION NAXIS(3),PNEW(4)
*** Finds all particles in cone of size COSR about OAXIS direction.
*** Calculates 4-momentum sum of all particles in cone (PNEW) , and
*** returns this as new jet axis NAXIS (Both unit Vectors)
       INTEGER N,MU,NPU,NPP
       DOUBLE PRECISION COSVAL,NORMSQ,NORM
*
       OK = .FALSE.
       DO 100 MU=1,4
          PNEW(MU)=0.0
100    CONTINUE
       NPU=-3
       NPP=-4
       DO 110 N=1,NTRAK
          NPU=NPU+3
          NPP=NPP+4
          IF (MODE.NE.2) THEN
             COSVAL=0.0
             DO 120 MU=1,3
                COSVAL=COSVAL+OAXIS(MU)*PU(MU+NPU)
120          CONTINUE
          ELSE
             IF (ABS(PU(1+NPU)).GE.20.OR.ABS(OAXIS(1)).GE.20) THEN
                COSVAL=-1000
             ELSE
                COSVAL=1-
     +           ((OAXIS(1)-PU(1+NPU))**2+PXMDPI(OAXIS(2)-PU(2+NPU))**2)
             ENDIF
          ENDIF
          IF (COSVAL.GE.COSR)THEN
             NEWLIS(N) = .TRUE.
             OK = .TRUE.
             IF (MODE.NE.2) THEN
                DO 130 MU=1,4
                   PNEW(MU) = PNEW(MU) + PP(MU+NPP)
130             CONTINUE
             ELSE
                PNEW(1)=PNEW(1)
     +              + PP(4+NPP)/(PP(4+NPP)+PNEW(4))*(PP(1+NPP)-PNEW(1))
c                PNEW(2)=PNEW(2)
c     +              + PP(4+NPP)/(PP(4+NPP)+PNEW(4))
c     +               *PXMDPI(PP(2+NPP)-PNEW(2))
! GPS 25/02/07
                PNEW(2)=PXMDPI(PNEW(2)
     +              + PP(4+NPP)/(PP(4+NPP)+PNEW(4))
     +               *PXMDPI(PP(2+NPP)-PNEW(2)))
                PNEW(4)=PNEW(4)+PP(4+NPP)
             ENDIF
          ELSE
             NEWLIS(N)=.FALSE.
          ENDIF
110   CONTINUE
*** If there are particles in the cone, calc new jet axis
       IF (OK) THEN
          IF (MODE.NE.2) THEN
             NORMSQ = 0.0
             DO 140 MU = 1,3
                NORMSQ = NORMSQ + PNEW(MU)**2
140          CONTINUE
             NORM = SQRT(NORMSQ)
          ELSE
             NORM = 1
          ENDIF
          DO 150 MU=1,3
             NAXIS(MU) = PNEW(MU)/NORM
150       CONTINUE
       ENDIF
       RETURN
       END

*********************************************************************
*CMZ :  2.00/00 10/01/95  10.17.57  by  P. Schleper
*CMZ :  1.06/00 28/02/94  15.44.44  by  P. Schleper
*-- Author :
C+DECK,PXUVEC.
*
       SUBROUTINE PXUVEC(NTRAK,PP,PU,IERR)
*
*** Routine to calculate unit vectors PU of all particles PP
C+SEQ,DECLARE.
      INTEGER MXTRAK
      PARAMETER (MXTRAK=5000)
      INTEGER NTRAK, IERR
      DOUBLE PRECISION PP(4,MXTRAK)
      DOUBLE PRECISION PU(3,MXTRAK)
      INTEGER N,MU
      DOUBLE PRECISION MAG
       DO 100 N=1,NTRAK
          MAG=0.0
          DO 110 MU=1,3
             MAG=MAG+PP(MU,N)**2
110       CONTINUE
          MAG=SQRT(MAG)
          IF (MAG.EQ.0.0) THEN
             WRITE(6,*)' PXCONE: An input particle has zero mod(p)'
             IERR=-1
             RETURN
          ENDIF
          DO 120 MU=1,3
           PU(MU,N)=PP(MU,N)/MAG
120       CONTINUE
100    CONTINUE
       RETURN
       END
*CMZ :  1.06/00 28/02/94  15.44.44  by  P. Schleper
*-- Author :
C-----------------------------------------------------------------------
      SUBROUTINE PXZERI(N,A)
      INTEGER I,N,A(N)
      DO 10 I=1,N
        A(I)=0
 10   CONTINUE
      END
*CMZ :  1.06/00 28/02/94  15.44.44  by  P. Schleper
*-- Author :
C-----------------------------------------------------------------------
C     This is a set of routines written by Mike Seymour to provide the
C     services presumably normally provided by standard OPAL routines
C     PXZERV zeroes a vector
C     PXZERI zeroes a vector of integers
C     PXNORV normalizes a vector
C     PXADDV adds two vectors
C     PXSORV sorts a vector (copied from HERWIG)
C     PXANG3 finds the angle (and its cosine) between two vectors
C     PXMDPI moves its argument onto the range [-pi,pi)
C-----------------------------------------------------------------------
      SUBROUTINE PXZERV(N,A)
      INTEGER I,N
      DOUBLE PRECISION A(N)
      DO 10 I=1,N
        A(I)=0
 10   CONTINUE
      END
*-- Author :
C-----------------------------------------------------------------------
      SUBROUTINE PXADDV(N,A,B,C,ITERR)
      INTEGER I,N,ITERR
      DOUBLE PRECISION A(N),B(N),C(N)
      DO 10 I=1,N
        C(I)=A(I)+B(I)
 10   CONTINUE
      END
*CMZ :  1.06/00 28/02/94  15.44.44  by  P. Schleper
*-- Author :
C-----------------------------------------------------------------------
      SUBROUTINE PXANG3(A,B,COST,THET,ITERR)
      INTEGER ITERR
      DOUBLE PRECISION A(3),B(3),C,COST,THET
      C=(A(1)**2+A(2)**2+A(3)**2)*(B(1)**2+B(2)**2+B(3)**2)
      IF (C.LE.0) RETURN
      C=1/SQRT(C)
      COST=(A(1)*B(1)+A(2)*B(2)+A(3)*B(3))*C
      THET=ACOS(COST)
      END
*CMZ :  1.06/00 14/03/94  15.41.57  by  P. Schleper
*-- Author :    P. Schleper   28/02/94
       LOGICAL FUNCTION PXNEW(TSTLIS,JETLIS,NTRAK,NJET)
*
      INTEGER MXTRAK,MXPROT
      PARAMETER (MXTRAK=5000,MXPROT=5000)
       INTEGER NTRAK,NJET
*** Note that although JETLIS is assumed to be a 2d array, it
*** it is used as 1d in this routine for efficiency
       LOGICAL TSTLIS(MXTRAK),JETLIS(MXPROT*MXTRAK)
*** Checks to see if TSTLIS entries correspond to a jet already found
*** and entered in JETLIS
       INTEGER N, I, IN
       LOGICAL MATCH
*
       PXNEW = .TRUE.
       DO 100 I = 1,NJET
          MATCH = .TRUE.
          IN=I-MXPROT
          DO 110 N = 1,NTRAK
            IN=IN+MXPROT
            IF(TSTLIS(N).NEQV.JETLIS(IN)) THEN
             MATCH = .FALSE.
             GO TO 100
            ENDIF
110       CONTINUE
          IF (MATCH) THEN
           PXNEW = .FALSE.
           RETURN
          ENDIF
100    CONTINUE
       RETURN
       END
*CMZ :  1.06/00 14/03/94  15.41.57  by  P. Schleper
*-- Author :    P. Schleper   28/02/94
       LOGICAL FUNCTION PXSAME(LIST1,LIST2,N)
*
       LOGICAL LIST1(*),LIST2(*)
       INTEGER N
*** Returns T if the first N elements of LIST1 are the same as the
*** first N elements of LIST2.
       INTEGER I
*
       PXSAME = .TRUE.
       DO 100 I = 1,N
        IF ( LIST1(I).NEQV.LIST2(I) ) THEN
          PXSAME = .FALSE.
          RETURN
        ENDIF
100    CONTINUE
       RETURN
       END
*CMZ :  1.06/00 28/02/94  15.44.44  by  P. Schleper
*-- Author :
C-----------------------------------------------------------------------
      FUNCTION PXMDPI(PHI)
      IMPLICIT NONE
C---RETURNS PHI, MOVED ONTO THE RANGE [-PI,PI)
      DOUBLE PRECISION PXMDPI,PHI,PI,TWOPI,THRPI,EPS
      PARAMETER (PI=3.141592654,TWOPI=6.283185307,THRPI=9.424777961)
      PARAMETER (EPS=1E-15)
      PXMDPI=PHI
      IF (PXMDPI.LE.PI) THEN
        IF (PXMDPI.GT.-PI) THEN
          GOTO 100
        ELSEIF (PXMDPI.GT.-THRPI) THEN
          PXMDPI=PXMDPI+TWOPI
        ELSE
          PXMDPI=-MOD(PI-PXMDPI,TWOPI)+PI
        ENDIF
      ELSEIF (PXMDPI.LE.THRPI) THEN
        PXMDPI=PXMDPI-TWOPI
      ELSE
        PXMDPI=MOD(PI+PXMDPI,TWOPI)-PI
      ENDIF
 100  IF (ABS(PXMDPI).LT.EPS) PXMDPI=0
      END


      subroutine qc25c(f,a,b,c,result,abserr,krul,neval)
c***begin prologue  qc25c
c***date written   810101   (yymmdd)
c***revision date  830518   (yymmdd)
c***category no.  h2a2a2,j4
c***keywords  25-point clenshaw-curtis integration
c***author  piessens,robert,appl. math. & progr. div. - k.u.leuven
c           de doncker,elise,appl. math. & progr. div. - k.u.leuven
c***purpose  to compute i = integral of f*w over (a,b) with
c            error estimate, where w(x) = 1/(x-c)
c***description
c
c        integration rules for the computation of cauchy
c        principal value integrals
c        standard fortran subroutine
c        real version
c
c        parameters
c           f      - real
c                    function subprogram defining the integrand function
c                    f(x). the actual name for f needs to be declared
c                    e x t e r n a l  in the driver program.
c
c           a      - real
c                    left end point of the integration interval
c
c           b      - real
c                    right end point of the integration interval, b.gt.a
c
c           c      - real
c                    parameter in the weight function
c
c           result - real
c                    approximation to the integral
c                    result is computed by using a generalized
c                    clenshaw-curtis method if c lies within ten percent
c                    of the integration interval. in the other case the
c                    15-point kronrod rule obtained by optimal addition
c                    of abscissae to the 7-point gauss rule, is applied.
c
c           abserr - real
c                    estimate of the modulus of the absolute error,
c                    which should equal or exceed abs(i-result)
c
c           krul   - integer
c                    key which is decreased by 1 if the 15-point
c                    gauss-kronrod scheme has been used
c
c           neval  - integer
c                    number of integrand evaluations
c
c***references  (none)
c***routines called  qcheb,qk15w,qwgtc
c***end prologue  qc25c
c
      real a,abserr,ak22,amom0,amom1,amom2,b,c,cc,
     *  centr,cheb12,cheb24,qwgtc,f,fval,hlgth,p2,p3,p4,
     *  resabs,resasc,result,res12,res24,u,x
      integer i,isym,k,kp,krul,neval
c
      dimension x(11),fval(25),cheb12(13),cheb24(25)
c
      external f,qwgtc
c
c           the vector x contains the values cos(k*pi/24),
c           k = 1, ..., 11, to be used for the chebyshev series
c           expansion of f
c
      data x(1),x(2),x(3),x(4),x(5),x(6),x(7),x(8),x(9),x(10),
     *  x(11)/
     *     0.9914448613738104e+00,     0.9659258262890683e+00,
     *     0.9238795325112868e+00,     0.8660254037844386e+00,
     *     0.7933533402912352e+00,     0.7071067811865475e+00,
     *     0.6087614290087206e+00,     0.5000000000000000e+00,
     *     0.3826834323650898e+00,     0.2588190451025208e+00,
     *     0.1305261922200516e+00/
c
c           list of major variables
c           ----------------------
c           fval   - value of the function f at the points
c                    cos(k*pi/24),  k = 0, ..., 24
c           cheb12 - chebyshev series expansion coefficients,
c                    for the function f, of degree 12
c           cheb24 - chebyshev series expansion coefficients,
c                    for the function f, of degree 24
c           res12  - approximation to the integral corresponding
c                    to the use of cheb12
c           res24  - approximation to the integral corresponding
c                    to the use of cheb24
c           qwgtc - external function subprogram defining
c                    the weight function
c           hlgth  - half-length of the interval
c           centr  - mid point of the interval
c
c
c           check the position of c.
c
c***first executable statement  qc25c
      cc = (0.2e+01*c-b-a)/(b-a)
      if(abs(cc).lt.0.11e+01) go to 10
c
c           apply the 15-point gauss-kronrod scheme.
c
      krul = krul-1
      call qk15w(f,qwgtc,c,p2,p3,p4,kp,a,b,result,abserr,
     *  resabs,resasc)
      neval = 15
      if (resasc.eq.abserr) krul = krul+1
      go to 50
c
c           use the generalized clenshaw-curtis method.
c
   10 hlgth = 0.5e+00*(b-a)
      centr = 0.5e+00*(b+a)
      neval = 25
      fval(1) = 0.5e+00*f(hlgth+centr)
      fval(13) = f(centr)
      fval(25) = 0.5e+00*f(centr-hlgth)
      do 20 i=2,12
        u = hlgth*x(i-1)
        isym = 26-i
        fval(i) = f(u+centr)
        fval(isym) = f(centr-u)
   20 continue
c
c           compute the chebyshev series expansion.
c
      call qcheb(x,fval,cheb12,cheb24)
c
c           the modified chebyshev moments are computed
c           by forward recursion, using amom0 and amom1
c           as starting values.
c
      amom0 = alog(abs((0.1e+01-cc)/(0.1e+01+cc)))
      amom1 = 0.2e+01+cc*amom0
      res12 = cheb12(1)*amom0+cheb12(2)*amom1
      res24 = cheb24(1)*amom0+cheb24(2)*amom1
      do 30 k=3,13
        amom2 = 0.2e+01*cc*amom1-amom0
        ak22 = (k-2)*(k-2)
        if((k/2)*2.eq.k) amom2 = amom2-0.4e+01/(ak22-0.1e+01)
        res12 = res12+cheb12(k)*amom2
        res24 = res24+cheb24(k)*amom2
        amom0 = amom1
        amom1 = amom2
   30 continue
      do 40 k=14,25
        amom2 = 0.2e+01*cc*amom1-amom0
        ak22 = (k-2)*(k-2)
        if((k/2)*2.eq.k) amom2 = amom2-0.4e+01/
     *  (ak22-0.1e+01)
        res24 = res24+cheb24(k)*amom2
        amom0 = amom1
        amom1 = amom2
   40 continue
      result = res24
      abserr = abs(res24-res12)
   50 return
      end


subroutine driver(km,jm,im,              &
     beta, sigma, g, dt, Cpd, tau_inf, alpha,         &
     T, q, p, ps, solin, Ts,             &
     Tinc, Tdot, SrfRadFlx, swhr, swflx_out, lwhr, lwflx_out, up_out, down_out, tau_out)
!-----------------------------!
!  CliMT driver for grey gas  !
!  radiation scheme           !
!  J.L. Mitchell 10Mar05      !
!_____________________________!

!! Note: tau_inf here is the BROADBAND optical depth

! In
integer im,jm,km
!f2py intent(in,hide) im,jm,km
real(8),                     intent(in) :: sigma, g, dt, Cpd, tau_inf, alpha, beta
real(8),dimension(km,jm,im), intent(in) :: T, q, p
real(8),dimension(jm,im),    intent(in) :: Ts, ps, solin

! Out
real(8),dimension(km,jm,im), intent(out) :: Tinc,Tdot, lwflx_out, lwhr, up_out, down_out, tau_out
real(8),dimension(km,jm,im), intent(out) :: swflx_out, swhr
real(8),dimension(jm,im)   , intent(out) :: SrfRadFlx

! Local
real(8),dimension(0:km,jm,im) :: plev, tau, lwflx, up, down

! Input pressures are at midlevel, need p on level surfaces
plev(1:km-1,:,:) = ( p(1:km-1,:,:) + p(2:km,:,:) )/2.
plev(0     ,:,:) = 0.
plev(km    ,:,:) = ps

! Set profile of optical depth
do k=0,km
   tau(k,:,:) = tau_inf/beta*(1.- ( plev(k,:,:)/ps )**alpha )
enddo

! Loop over lat and lon
do i=1,im
   do j=1,jm
      call grey_gas(km,beta,sigma,T(:,j,i), tau(:,j,i), Ts(j,i),  &
                    lwflx(:,j,i), up(:,j,i), down(:,j,i))
   enddo
enddo

Tdot = g/Cpd*(lwflx(1:km,:,:)-lwflx(0:km-1,:,:))/        &
              (plev(1:km,:,:)-plev(0:km-1,:,:))/100.
lwflx_out = -lwflx(0:km-1,:,:)
up_out    = -up(0:km-1,:,:)
down_out  = down(0:km-1,:,:)
tau_out   = tau(0:km-1,:,:) * beta
! Surface radiative flux
SrfRadFlx = -lwflx(km,:,:) + solin

Tinc = Tdot*2.*dt
Tdot = Tdot*86400.
lwhr = Tdot

do k=1,km
swflx_out(k,:,:) = solin
enddo
swhr = 0.

end subroutine driver

! - - - > midlevel
! ----- > surfaces

!- - - - - - - - - - - - kappa(0),T(0)                  TOP OF ATMOSPHERE
!----------------------- press(0),tau(0),up/down(0)
!- - - - - - - - - - - - kappa(1),T(1)
!----------------------- press(1)
!- - - - - - - - - - - -   ..
!-----------------------   ..
!- - - - - - - - - - - -   ..
!-----------------------   ..
!- - - - - - - - - - - - kappa(nlev)
!----------------------- press(nlev)
!- - - - - - - - - - - - kappa(nlev+1)                  SURFACE


!!********************************************************************************
!! Subroutine BLUE_COMP computes innovation term for data assimilation
!! Expects as inputs
!!     1) EFDC predictions on a grid (EFDC.csv)
!!     2) Observation data on a grid (CODAR.csv)

!! Originally developed for Codar assimilation September 2014
!! by Fearghal O'Donncha
!! Modified Sept 13 2016 for application to temperature data

!! To enable compilation without dependencies on Blas libraries
!! wrap DA code in compiler flag sepecified
#ifdef key_da
Subroutine  BLUE_COMP(NDAPOINTS, PMATRIX_R1, PMATRIX_R2, PMATRIX_A)
    IMPLICIT NONE
    INTEGER,PARAMETER::ip=4,wp=8

    INTEGER(ip) IC,JC, IPIVSIZE
    INTEGER(ip) NR,NL,EFDCSIZE,SZCOD,FILEND,ii,info,i,j,LDA,M,N,LWORK

    INTEGER(ip),ALLOCATABLE,DIMENSION(:)::MODEL_I,MODEL_J,CODAR_I,CODAR_J
    INTEGER(ip),ALLOCATABLE,DIMENSION(:)::IPIV
    REAL(wp),ALLOCATABLE,DIMENSION(:):: U,V,SIGMAU,SIGMAV,U_COD,V_COD,CODAR,EFDC
    REAL(wp),ALLOCATABLE,DIMENSION(:):: Xinn, WORK
    INTEGER(ip),ALLOCATABLE,DIMENSION(:,:) :: H
    REAL(wp),ALLOCATABLE,DIMENSION(:,:) :: P,R
    REAL(wp),ALLOCATABLE,DIMENSION(:,:) :: temp
    REAL(wp),ALLOCATABLE,DIMENSION(:,:) :: XinnInv,A
    REAL(wp),ALLOCATABLE,DIMENSION(:) :: KH
    REAL(wp),ALLOCATABLE,DIMENSION(:) :: Xf
    INTEGER(ip),ALLOCATABLE,DIMENSION(:) :: I_VEC,J_VEC
    INTEGER, INTENT(IN)::NDAPOINTS
    REAL PMATRIX_R1, PMATRIX_R2, PMATRIX_A
    ! Read the data

      open(1,FILE='EFDC_state.csv',status='old')
      open(2,FILE='CODAR.csv',status='old')
      nr = 0   ! nr = number of observations
      nl = 0   ! nl = number of model points

      EFDCSIZE = NDAPOINTS
      SZCOD = NDAPOINTS
      ALLOCATE(MODEL_I(EFDCSIZE))
      ALLOCATE(MODEL_J(EFDCSIZE))
      ALLOCATE(U(EFDCSIZE))
      ALLOCATE(V(EFDCSIZE))

      do II =1,EFDCSIZE       ! READ EFDC FILE
        READ(1,*) I,J,U(II),V(II)
        MODEL_I(II) = I
        model_j(II) = J
        nl = nl + 1   ! size of EFDC
      END DO
      CLOSE(1)
      ALLOCATE(U_COD(SZCOD))
      ALLOCATE(V_COD(SZCOD))
      ALLOCATE(SIGMAU(SZCOD))
      ALLOCATE(SIGMAV(SZCOD))
      ALLOCATE(CODAR_I(SZCOD))
      ALLOCATE(CODAR_J(SZCOD))
      ! SKIP header file
      READ(2,*)
      DO II = 1,10000     ! READ CODAR DATA TO UNKNOWN FILE END
        READ(2,*,IOSTAT=FILEND) I,J,U_COD(II),V_COD(II),SIGMAU(II),SIGMAV(II)
        IF (FILEND.LT.0)GOTO 111
        CODAR_I(II) = I
        CODAR_J(II) = J
        nr = nr +1       ! size of codar
      END DO    ! END READ CODAR FILES
    111     CONTINUE
      CLOSE(2)
      ALLOCATE(H(2*nr,2*nl))
      CALL HMATRIX(NL,NR,CODAR_I,CODAR_J,MODEL_I,MODEL_J,H)

      allocate(P(2*NL,2*NL))
      CALL PMATRIX(NL, MODEL_I, MODEL_J, P, PMATRIX_R1, PMATRIX_R2, PMATRIX_A )

      ALLOCATE(R(2*NR,2*NR))

      CALL RMATRIX(NR,SIGMAU,SIGMAV,R)

    !! COMPUTE BLUE

    ALLOCATE(EFDC(2*NL))
    ALLOCATE(CODAR(2*NR))
    ALLOCATE(I_VEC(2*NL))
    ALLOCATE(J_VEC(2*NL))
    ALLOCATE(Xf(2*NL))

    Allocate(temp(2*NR,2*NL))
    Allocate(XinnInv(2*NR,2*NR))
    Allocate(KH(2*NR))

    I_VEC = [MODEL_I,MODEL_I]
    J_VEC = [MODEL_J,MODEL_J]
    CODAR = [U_COD,V_COD]
    EFDC = [U,V]
    ALLOCATE(Xinn(2*NR))
    Xinn =  CODAR - matmul(H,EFDC) ! Difference between observations and model state
    temp = matmul(H,P)             ! map model covariance matrix to observations

    XinnInv = (matmul(temp,transpose(H)))  + R

    ! compute inverse of Xinn using LAPACK
    ! DGETRF computes an LU factorization of a general M-by-N matrix A
    ! using partial pivoting with row exchange

    M = 2*NR  ! NUMBER OF ROWS OF MATRIX
    N = 2*NR  ! NUMBER OF COLUMNS OF MATRIX
    LDA = max(1,M)
    IPIVSIZE = min(M,N)
    LWORK =  max(1,N) !N*N

    ALLOCATE(A(2*NR,2*NR))
    ALLOCATE (IPIV(IPIVSIZE))
    ALLOCATE(WORK(N))
    A = XinnInv

    CALL DGETRF(M,N,A,LDA,IPIV,INFO)
    if (info == 0)write(*,*) 'LU decomposition successful', M, N, LDA
    if (info < 0 )  write(*,*) "LU decomposition: illegal value"
    if (info < 0 )  write(*,11) INFO,INFO
    11 FORMAT('LU decomposition: U(',I4,',',I4,') = 0)')

    ! DGETRI computes the inverse of a matrix using the LU factorization
    ! computed by DGETRF
    CALL DGETRI(N,A,LDA,IPIV,WORK,LWORK,INFO)   ! (http://www.netlib.org/lapack/explore-3.1.1-html/dgetri.f.html)
    !  DGETRI computes the inverse of a matrix using the LU factorization
    !  computed by DGETRF.

    if (info /= 0 ) then
      stop 'Matrix Inversion Failed'
    ELSE
      Write(*,*) 'Inverse Succesful'
    end if

    KH = matmul(A,Xinn)
    temp = matmul(P,transpose(H))
    Xf = EFDC + matmul(temp,KH)

    open(4,File='BLUE.csv',status='unknown')
    ! Write header file to the Innovation file
    Write(4,*) 'I, J, UpdateState, EFDC, CODAR'
    do  I = 1,2*NR
       write(4,444) I_VEC(I),J_VEC(I),XF(i), EFDC(i), CODAR(i)
    end do

    close(4)
444 FORMAT(2I5, 3F14.6)
END Subroutine  BLUE_COMP
#endif


c routines to calculate the electron density for the
c Local Interstellar Medium
c
c JMC 26 August-11 Sep. 2000
c     25 October 2001: modified to change weighting scheme
c                      so that the ranking is LHB: LSB: LDR
c                      (LHB overrides LSB and LDR; LSB overrides LDR)
c     16 November 2001: added Loop I component with weighting scheme
c		        LHB:LOOPI:LSB:LDR
c		        LHB   overides everything,
c			LOOPI overrides LSB and LDR
c			LSB   overrides LDR
c			LISM  overrides general Galaxy
c     20 November 2001: The LOOPI component is truncated below z=0
c
c after discussions with Shami Chatterjee
c the sizes, locations and densities of the LISM components
c are based largely on work by Toscano et al. 1999
c and Bhat et al. 1999

	real function ne_LISM(x,y,z,FLISM,wLISM,
     .                       wldr, wlhb,wlsb,wloopI)
	implicit none
	real x,y,z,FLISM
        integer wLISM

	real
     .    aldr,bldr,cldr,xldr,yldr,zldr,thetaldr,neldr0,Fldr,
     .    alsb,blsb,clsb,xlsb,ylsb,zlsb,thetalsb,nelsb0,Flsb,
     .    alhb,blhb,clhb,xlhb,ylhb,zlhb,thetalhb,nelhb0,Flhb,
     .    xlpI,ylpI,zlpI,rlpI,drlpI,nelpI,FlpI,dnelpI,dFlpI
        common/nelismparms/
     .    aldr,bldr,cldr,xldr,yldr,zldr,thetaldr,neldr0,Fldr,
     .    alsb,blsb,clsb,xlsb,ylsb,zlsb,thetalsb,nelsb0,Flsb,
     .    alhb,blhb,clhb,xlhb,ylhb,zlhb,thetalhb,nelhb0,Flhb,
     .    xlpI,ylpI,zlpI,rlpI,drlpI,nelpI,FlpI,dnelpI,dFlpI

        logical first
	data first /.true./

c functions:

	real neLDRQ1
	real neLSB
	real neLHB2
	real neLOOPI

c other variables:

	real nelsbxyz, nelhbxyz, neldrq1xyz, neloopIxyz
	real FLDRQ1r, FLSBr, FLHBr, FLOOPIr		! 'r' for returned value
	integer wLDR, wLSB, wLHB, wLOOPI

	if(first) then					! read parameters for LISM
	  open(11,file='nelism.inp',status='unknown')
	  read(11,*)
	  read(11,*) aldr,bldr,cldr
	  read(11,*) xldr,yldr,zldr
	  read(11,*) thetaldr,neldr0,Fldr

	  read(11,*) alsb,blsb,clsb
	  read(11,*) xlsb,ylsb,zlsb
	  read(11,*) thetalsb,nelsb0,Flsb

	  read(11,*) alhb,blhb,clhb
	  read(11,*) xlhb,ylhb,zlhb
	  read(11,*) thetalhb,nelhb0,Flhb

	  read(11,*) xlpI,ylpI,zlpI
	  read(11,*) rlpI,drlpI
	  read(11,*) nelpI,dnelpI,FlpI,dFlpI

   	  write(99,*) xlpI,ylpI,zlpI
 	  write(99,*) rlpI,drlpI
 	  write(99,*) nelpI,dnelpI,FlpI,dFlpI

	  first=.false.
	endif

	neldrq1xyz = neLDRQ1(x,y,z,FLDRQ1r,wLDR)	! low density region in Q1
	nelsbxyz   = neLSB(x,y,z,FLSBr,wLSB)		! Local Super Bubble
	nelhbxyz = neLHB2(x,y,z,FLHBr,wLHB)		! Local Hot Bubble
	neloopIxyz = neLOOPI(x,y,z,FLOOPIr,wLOOPI)	! Loop I

c weight the terms so that the LHB term overrides the other
c terms (we want the density to be low in the LHB, lower than
c in the other terms.

 	ne_LISM =   (1-wLHB)   *
     .           (
     .             (1-wLOOPI) * (wLSB*nelsbxyz + (1-wLSB)*neldrq1xyz)
     .         +     wLOOPI * neloopIxyz
     .           )
     .         +     wLHB  * nelhbxyz

 	FLISM = (1-wLHB) *
     .          (
     .             (1-wLOOPI) * (wLSB*FLSBr + (1-wLSB)*FLDRQ1r)
     .         +     wLOOPI * FLOOPIr
     .          )
     .         +     wLHB  * FLHBr

c return the maximum weight of any of the terms for
c combining with additional terms external to this routine.

	wLISM = max(wLOOPI, max(wLDR, max(wLSB, wLHB)))

c temporary next 3 lines:
c	ne_LISM = nelhbxyz
c	flism = flhb
c	wlism = wlhb

c	write(97,"(9(f8.3,1x))") wLDR, wLSB, wLHB,
c    .      nelsbxyz, neldrq1xyz,nelhbxyz,
c    .      flsb, fldrq1, flhb

	return
	end

	real function  neLDRQ1(x,y,z,FLDRQ1r,wLDRQ1) 	! Low Density Region in Q1
	implicit none
	real x,y,z,FLDRQ1r
	integer wLDRQ1

c input:
c 	x,y,z = coordinates w.r.t. Galaxy as in TC93, CL00
c output:
c	neLDRQ1 = electron density in local hot bubble that
c	        is modeled as an ellipsoidal trough.
c	FLDRQ1 = fluctuation parameter
c	wLDRQ1  = weight of LDRQ1 component used to combine
c		with other components of electron density.
c		wLDRQ1 =  1  at and inside the annular ridge
c		     <  1  outside the annular ridge
c	             -> 0  far outside the annular ridge
c	e.g. total electron density would be evaluated as
c            ne = (1-wLDRQ1)*ne_other + neLDRQ1
	real
     .    aldr,bldr,cldr,xldr,yldr,zldr,thetaldr,neldr0,Fldr,
     .    alsb,blsb,clsb,xlsb,ylsb,zlsb,thetalsb,nelsb0,Flsb,
     .    alhb,blhb,clhb,xlhb,ylhb,zlhb,thetalhb,nelhb0,Flhb,
     .    xlpI,ylpI,zlpI,rlpI,drlpI,nelpI,FlpI,dnelpI,dFlpI
        common/nelismparms/
     .    aldr,bldr,cldr,xldr,yldr,zldr,thetaldr,neldr0,Fldr,
     .    alsb,blsb,clsb,xlsb,ylsb,zlsb,thetalsb,nelsb0,Flsb,
     .    alhb,blhb,clhb,xlhb,ylhb,zlhb,thetalhb,nelhb0,Flhb,
     .    xlpI,ylpI,zlpI,rlpI,drlpI,nelpI,FlpI,dnelpI,dFlpI

	real aa,bb,cc			! scales of ellipsoidal ridge
	real netrough			! ne of annulus, trough
	real Ftrough			! fluctuation parameters
c	real xldr, yldr, zldr		! center of ellipsoid
	real theta 			! position angle of major axis,
					!    measured from x axis
					!    (x axis points toward l=90)

	real q

	real ap, bp, cp, dp
	real s, c

        real radian
        parameter(radian = 57.29577951)

	logical first
	data first /.true./
	save

c	data aa, bb, cc       	/ 0.6, 0.40, 0.3 / 	! GUESS
c	data xldr, yldr, zldr 	/ 0.6, 7.86, 0. / 	! GUESS
c	data theta		/ -45. / 		! GUESS

c	data netrough  /0.010/		! GUESS
c	data Ftrough   / 2./		! GUESS

	aa=aldr
	bb=bldr
	cc=cldr
	theta=thetaldr
	netrough =neldr0
	Ftrough=Fldr

	if(first) then
	  s = sin(theta/radian)
	  c = cos(theta/radian)
	  ap = (c/aa)**2 + (s/bb)**2
	  bp = (s/aa)**2 + (c/bb)**2
	  cp = 1./cc**2
	  dp =  2.*c*s*(1./aa**2 - 1./bb**2)
	  first = .false.
c	  write(6,*) aa,bb,cc,theta,ap,bp,cp,dp
	endif

	neLDRQ1 = 0.
	wLDRQ1 = 0
	FLDRQ1r = 0.
	q = (x-xldr)**2*ap
     .    + (y-yldr)**2*bp
     .    + (z-zldr)**2*cp
     .    + (x-xldr)*(y-yldr)*dp
	  if(q .le. 1.0) then	! inside
	    neLDRQ1 = netrough
	    FLDRQ1r = Ftrough
	    wLDRQ1 = 1
	  endif

	return
	end

	real function neLSB(x,y,z,FLSBr,wLSB)	! Local Super Bubble
	implicit none
	real x,y,z,FLSBr
	integer wLSB
c input:
c 	x,y,z = coordinates w.r.t. Galaxy as in TC93, CL00
c output:
c	neLSB = electron density in local hot bubble that
c	        is modeled as an ellisoidal trough.
c	FLSB = fluctuation parameter
c	wLSB  = weight of LSB component used to combine
c		with other components of electron density.
c		wLSB =  1  at and inside the annular ridge
c		     <  1  outside the annular ridge
c	             -> 0  far outside the annular ridge
c	e.g. total electron density would be evaluated as
c            ne = (1-wLSB)*ne_other + neLSB

	real
     .    aldr,bldr,cldr,xldr,yldr,zldr,thetaldr,neldr0,Fldr,
     .    alsb,blsb,clsb,xlsb,ylsb,zlsb,thetalsb,nelsb0,Flsb,
     .    alhb,blhb,clhb,xlhb,ylhb,zlhb,thetalhb,nelhb0,Flhb,
     .    xlpI,ylpI,zlpI,rlpI,drlpI,nelpI,FlpI,dnelpI,dFlpI
        common/nelismparms/
     .    aldr,bldr,cldr,xldr,yldr,zldr,thetaldr,neldr0,Fldr,
     .    alsb,blsb,clsb,xlsb,ylsb,zlsb,thetalsb,nelsb0,Flsb,
     .    alhb,blhb,clhb,xlhb,ylhb,zlhb,thetalhb,nelhb0,Flhb,
     .    xlpI,ylpI,zlpI,rlpI,drlpI,nelpI,FlpI,dnelpI,dFlpI

	real aa,bb,cc			! scales of ellipsoidal ridge
	real netrough			! ne of annulus, trough
	real Ftrough			! fluctuation parameters
c	real xlsb, ylsb, zlsb		! center of ellipsoid
	real theta 			! position angle of major axis,
					!    measured from x axis
					!    (x axis points toward l=90)

	real q

	real ap, bp, cp, dp
	real s, c

        real radian
        parameter(radian = 57.29577951)

	logical first
	data first /.true./
	save

c	data aa, bb, cc       	/ 0.6, 0.25, 0.3 / 	! GUESS
c	data xlsb, ylsb, zlsb 	/ -0.7, 9.0, 0. / 	! GUESS
c	data theta		/ 150. / 		! GUESS

c	data netrough  /0.01/		! GUESS
c	data Ftrough   / 1./		! GUESS

	aa=alsb
	bb=blsb
	cc=clsb
	theta=thetalsb
	netrough=nelsb0
	Ftrough=Flsb

	if(first) then
	  s = sin(theta/radian)
	  c = cos(theta/radian)
	  ap = (c/aa)**2 + (s/bb)**2
	  bp = (s/aa)**2 + (c/bb)**2
	  cp = 1./cc**2
	  dp =  2.*c*s*(1./aa**2 - 1./bb**2)
	  first = .false.
c	  write(6,*) aa,bb,cc,theta,ap,bp,cp,dp
	endif

	neLSB = 0.
	wLSB = 0
	FLSBr = 0.
	q = (x-xlsb)**2*ap
     .    + (y-ylsb)**2*bp
     .    + (z-zlsb)**2*cp
     .    + (x-xlsb)*(y-ylsb)*dp
	  if(q .le. 1.0) then	! inside
	    neLSB = netrough
	    FLSBr = Ftrough
	    wLSB = 1
	  endif

	return
	end

	real function neLHB(x,y,z,FLHBr,wLHB)	! Local Hot Bubble
	implicit none
	real x,y,z,FLHBr
	integer wLHB
c input:
c 	x,y,z = coordinates w.r.t. Galaxy as in TC93, CL00
c output:
c	neLHB = electron density in local hot bubble that
c	        is modeled as an ellisoidal trough.
c	FLHB = fluctuation parameter
c	wLHB  = weight of LBH component used to combine
c		with other components of electron density.
c		wLBH =  1  at and inside the annular ridge
c		     <  1  outside the annular ridge
c	             -> 0  far outside the annular ridge
c	e.g. total electron density would be evaluated as
c            ne = (1-wLHB)*ne_other + neLHB

	real
     .    aldr,bldr,cldr,xldr,yldr,zldr,thetaldr,neldr0,Fldr,
     .    alsb,blsb,clsb,xlsb,ylsb,zlsb,thetalsb,nelsb0,Flsb,
     .    alhb,blhb,clhb,xlhb,ylhb,zlhb,thetalhb,nelhb0,Flhb,
     .    xlpI,ylpI,zlpI,rlpI,drlpI,nelpI,FlpI,dnelpI,dFlpI
        common/nelismparms/
     .    aldr,bldr,cldr,xldr,yldr,zldr,thetaldr,neldr0,Fldr,
     .    alsb,blsb,clsb,xlsb,ylsb,zlsb,thetalsb,nelsb0,Flsb,
     .    alhb,blhb,clhb,xlhb,ylhb,zlhb,thetalhb,nelhb0,Flhb,
     .    xlpI,ylpI,zlpI,rlpI,drlpI,nelpI,FlpI,dnelpI,dFlpI

	real aa,bb,cc			! scales of ellipsoidal ridge
	real netrough			! ne of annulus, trough
	real Ftrough			! fluctuation parameters
c	real xlhb, ylhb, zlhb		! center of ellipsoid
	real theta 			! position angle of major axis,
					!    measured from x axis
					!    (x axis points toward l=90)
	real q

	real ap, bp, cp, dp
	real s, c

        real radian
        parameter(radian = 57.29577951)

	logical first
	data first /.true./

c	data aa, bb, cc       	/ 0.15, 0.08, 0.2 /
c	data xlhb, ylhb, zlhb 	/ 0., 8.5, 0. /
c	data theta		/ 135. /

c	data netrough  /0.005/
c	data Ftrough   / 1./

	save

	aa=alhb
	bb=blhb
	cc=clhb
	theta=thetalhb
	netrough=nelhb0
	Ftrough=Flhb

	if(first) then
	  s = sin(theta/radian)
	  c = cos(theta/radian)
	  ap = (c/aa)**2 + (s/bb)**2
	  bp = (s/aa)**2 + (c/bb)**2
	  cp = 1./cc**2
	  dp = 2.*c*s*(1./aa**2 - 1./bb**2)
	  first = .false.
c	  write(6,*) aa,bb,cc,theta,ap,bp,cp,dp
	endif

	neLHB = 0.
	wLHB = 0
	FLHBr = 0.
	q = (x-xlhb)**2*ap
     .    + (y-ylhb)**2*bp
     .    + (z-zlhb)**2*cp
     .    + (x-xlhb)*(y-ylhb)*dp
	  if(q .le. 1.0) then	! inside
	    neLHB = netrough
	    FLHBr = Ftrough
	    wLHB = 1
	  endif

	return
	end

	real function neLHB2(x,y,z,FLHBr,wLHB)	! Local Hot Bubble
c LHB modeled as a cylinder
c the cylinder slants in the y direction vs. z as described by parameter yzslope
c the cylinder cross-sectional size in the 'a' direction (major axis)
c       varies with z, tending to zero at its smallest z point.
	implicit none
	real x,y,z,FLHBr
	integer wLHB
c input:
c 	x,y,z = coordinates w.r.t. Galaxy as in TC93, CL00
c output:
c	neLHB2 = electron density in local hot bubble that
c	        is modeled as an ellisoidal trough.
c	FLHB = fluctuation parameter
c	wLHB  = weight of LBH component used to combine
c		with other components of electron density.
c		wLHB =  1  at and inside the annular ridge
c		     <  1  outside the annular ridge
c	             -> 0  far outside the annular ridge
c	e.g. total electron density would be evaluated as
c            ne = (1-wLHB)*ne_other + neLHB2

	real
     .    aldr,bldr,cldr,xldr,yldr,zldr,thetaldr,neldr0,Fldr,
     .    alsb,blsb,clsb,xlsb,ylsb,zlsb,thetalsb,nelsb0,Flsb,
     .    alhb,blhb,clhb,xlhb,ylhb,zlhb,thetalhb,nelhb0,Flhb,
     .    xlpI,ylpI,zlpI,rlpI,drlpI,nelpI,FlpI,dnelpI,dFlpI
        common/nelismparms/
     .    aldr,bldr,cldr,xldr,yldr,zldr,thetaldr,neldr0,Fldr,
     .    alsb,blsb,clsb,xlsb,ylsb,zlsb,thetalsb,nelsb0,Flsb,
     .    alhb,blhb,clhb,xlhb,ylhb,zlhb,thetalhb,nelhb0,Flhb,
     .    xlpI,ylpI,zlpI,rlpI,drlpI,nelpI,FlpI,dnelpI,dFlpI

	real aa,bb,cc			! scales of ellipsoidal ridge
	real netrough			! ne of annulus, trough
	real Ftrough			! fluctuation parameters
c	real xlhb, ylhb, zlhb		! center of ellipsoid
	real theta 			! slant angle in yz plane of cylinder
					!    measured from z axis
	real qxy, qz

        real radian
        parameter(radian = 57.29577951)

	logical first
	data first /.true./

	real yzslope

	real yaxis
	save

	aa=alhb
	bb=blhb
	cc=clhb
	theta=thetalhb
	netrough=nelhb0
	Ftrough=Flhb

	if(first) then
	  yzslope = tan(theta/radian)
	  first = .false.
	endif

	neLHB2 = 0.
	wLHB = 0
	FLHBr = 0.
	yaxis = ylhb + yzslope*z
c cylinder has cross sectional area = constant for z>0
c area -> 0 for z<0 by letting aa->0 linearly for z<0:
c (0.001 = 1 pc is to avoid divide by zero)
	if(z .le. 0. .and. z .ge. zlhb-clhb) then
	  aa = 0.001 + (alhb-0.001)*(1. - (1./(zlhb-clhb))*z)
	else
	  aa = alhb
	endif
c	write(99, *) x, y, z, aa, bb, cc
	qxy =  ( (x-xlhb)/aa )**2 + ( (y-yaxis)/bb )**2
	qz =  abs(z-zlhb)/cc
	if(qxy .le. 1.0 .and. qz .le. 1.0) then ! inside
	    neLHB2 = netrough
	    FLHBr = Ftrough
	    wLHB = 1
	endif

	return
	end

	real function neLOOPI(x,y,z,FLOOPI,wLOOPI)	! Loop I
c component is a spheroid truncated for z<0.
	implicit none
	real x,y,z,FLOOPI
	integer wLOOPI
c input:
c 	x,y,z = coordinates w.r.t. Galaxy as in TC93, CL00
c output:
c	neLOOPI = electron density in LOOP I that
c	        is modeled as an ellisoidal trough
c		with an enhanced shell
c	FLOOPI = fluctuation parameter
c	wLOOPI  = weight of LOOP I component used to combine
c		with other components of electron density.
c		wLOOPI =  1  at and inside the annular ridge
c		       <  1  outside the annular ridge

	real
     .    aldr,bldr,cldr,xldr,yldr,zldr,thetaldr,neldr0,Fldr,
     .    alsb,blsb,clsb,xlsb,ylsb,zlsb,thetalsb,nelsb0,Flsb,
     .    alhb,blhb,clhb,xlhb,ylhb,zlhb,thetalhb,nelhb0,Flhb,
     .    xlpI,ylpI,zlpI,rlpI,drlpI,nelpI,FlpI,dnelpI,dFlpI
        common/nelismparms/
     .    aldr,bldr,cldr,xldr,yldr,zldr,thetaldr,neldr0,Fldr,
     .    alsb,blsb,clsb,xlsb,ylsb,zlsb,thetalsb,nelsb0,Flsb,
     .    alhb,blhb,clhb,xlhb,ylhb,zlhb,thetalhb,nelhb0,Flhb,
     .    xlpI,ylpI,zlpI,rlpI,drlpI,nelpI,FlpI,dnelpI,dFlpI

	real r
	real a1, a2
	logical first
	data first /.true./
	save

	if(first) then
	  a1 = rlpI
	  a2 = rlpI+drlpI
	  first = .false.
	endif

        if(z .lt. 0.) then
	  neLOOPI = 0.
	  FLOOPI = 0.
	  wLOOPI = 0
          return
        endif
	r = sqrt( (x-xlpI)**2 + (y-ylpI)**2 + (z-zlpI)**2)
        if(r .gt. a2) then 	! outside Loop I
	  neLOOPI = 0.
	  FLOOPI = 0.
	  wLOOPI = 0
	else if(r .le. a1) then	! inside volume
	    neLOOPI= nelpI
	    FLOOPI = FlpI
	    wLOOPI = 1
c           write(99,*) x,y,z, r, neLOOPI, ' inside volume'
	else			! inside boundary shell
	    neLOOPI= dnelpI
	    FLOOPI = dFlpI
	    wLOOPI = 1
c           write(99,*) x,y,z,r, neLOOPI, ' inside shell'
	endif

	return
	end


*DECK RFFTF1
      SUBROUTINE RFFTF1 (N, C, CH, WA, IFAC)
C***BEGIN PROLOGUE  RFFTF1
C***PURPOSE  Compute the forward transform of a real, periodic sequence.
C***LIBRARY   SLATEC (FFTPACK)
C***CATEGORY  J1A1
C***TYPE      SINGLE PRECISION (RFFTF1-S, CFFTF1-C)
C***KEYWORDS  FFTPACK, FOURIER TRANSFORM
C***AUTHOR  Swarztrauber, P. N., (NCAR)
C***DESCRIPTION
C
C   Subroutine RFFTF1 computes the Fourier coefficients of a real
C   periodic sequence (Fourier analysis).  The transform is defined
C   below at output parameter C.
C
C   The arrays WA and IFAC which are used by subroutine RFFTB1 must be
C   initialized by calling subroutine RFFTI1.
C
C   Input Arguments
C
C   N       the length of the array R to be transformed.  The method
C           is most efficient when N is a product of small primes.
C           N may change so long as different work arrays are provided.
C
C   C       a real array of length N which contains the sequence
C           to be transformed.
C
C   CH      a real work array of length at least N.
C
C   WA      a real work array which must be dimensioned at least N.
C
C   IFAC    an integer work array which must be dimensioned at least 15.
C
C           The WA and IFAC arrays must be initialized by calling
C           subroutine RFFTI1, and different WA and IFAC arrays must be
C           used for each different value of N.  This initialization
C           does not have to be repeated so long as N remains unchanged.
C           Thus subsequent transforms can be obtained faster than the
C           first.  The same WA and IFAC arrays can be used by RFFTF1
C           and RFFTB1.
C
C   Output Argument
C
C   C       C(1) = the sum from I=1 to I=N of R(I)
C
C           If N is even set L = N/2; if N is odd set L = (N+1)/2
C
C             then for K = 2,...,L
C
C                C(2*K-2) = the sum from I = 1 to I = N of
C
C                     C(I)*COS((K-1)*(I-1)*2*PI/N)
C
C                C(2*K-1) = the sum from I = 1 to I = N of
C
C                    -C(I)*SIN((K-1)*(I-1)*2*PI/N)
C
C           If N is even
C
C                C(N) = the sum from I = 1 to I = N of
C
C                     (-1)**(I-1)*C(I)
C
C   Notes:  This transform is unnormalized since a call of RFFTF1
C           followed by a call of RFFTB1 will multiply the input
C           sequence by N.
C
C           WA and IFAC contain initialization calculations which must
C           not be destroyed between calls of subroutine RFFTF1 or
C           RFFTB1.
C
C***REFERENCES  P. N. Swarztrauber, Vectorizing the FFTs, in Parallel
C                 Computations (G. Rodrigue, ed.), Academic Press,
C                 1982, pp. 51-83.
C***ROUTINES CALLED  RADF2, RADF3, RADF4, RADF5, RADFG
C***REVISION HISTORY  (YYMMDD)
C   790601  DATE WRITTEN
C   830401  Modified to use SLATEC library source file format.
C   860115  Modified by Ron Boisvert to adhere to Fortran 77 by
C           changing dummy array size declarations (1) to (*).
C   881128  Modified by Dick Valent to meet prologue standards.
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900131  Routine changed from subsidiary to user-callable.  (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  RFFTF1
      DIMENSION CH(*), C(*), WA(*), IFAC(*)
C***FIRST EXECUTABLE STATEMENT  RFFTF1
      NF = IFAC(2)
      NA = 1
      L2 = N
      IW = N
      DO 111 K1=1,NF
         KH = NF-K1
         IP = IFAC(KH+3)
         L1 = L2/IP
         IDO = N/L2
         IDL1 = IDO*L1
         IW = IW-(IP-1)*IDO
         NA = 1-NA
         IF (IP .NE. 4) GO TO 102
         IX2 = IW+IDO
         IX3 = IX2+IDO
         IF (NA .NE. 0) GO TO 101
         CALL RADF4 (IDO,L1,C,CH,WA(IW),WA(IX2),WA(IX3))
         GO TO 110
  101    CALL RADF4 (IDO,L1,CH,C,WA(IW),WA(IX2),WA(IX3))
         GO TO 110
  102    IF (IP .NE. 2) GO TO 104
         IF (NA .NE. 0) GO TO 103
         CALL RADF2 (IDO,L1,C,CH,WA(IW))
         GO TO 110
  103    CALL RADF2 (IDO,L1,CH,C,WA(IW))
         GO TO 110
  104    IF (IP .NE. 3) GO TO 106
         IX2 = IW+IDO
         IF (NA .NE. 0) GO TO 105
         CALL RADF3 (IDO,L1,C,CH,WA(IW),WA(IX2))
         GO TO 110
  105    CALL RADF3 (IDO,L1,CH,C,WA(IW),WA(IX2))
         GO TO 110
  106    IF (IP .NE. 5) GO TO 108
         IX2 = IW+IDO
         IX3 = IX2+IDO
         IX4 = IX3+IDO
         IF (NA .NE. 0) GO TO 107
         CALL RADF5 (IDO,L1,C,CH,WA(IW),WA(IX2),WA(IX3),WA(IX4))
         GO TO 110
  107    CALL RADF5 (IDO,L1,CH,C,WA(IW),WA(IX2),WA(IX3),WA(IX4))
         GO TO 110
  108    IF (IDO .EQ. 1) NA = 1-NA
         IF (NA .NE. 0) GO TO 109
         CALL RADFG (IDO,IP,L1,IDL1,C,C,C,CH,CH,WA(IW))
         NA = 1
         GO TO 110
  109    CALL RADFG (IDO,IP,L1,IDL1,CH,CH,CH,C,C,WA(IW))
         NA = 0
  110    L2 = L1
  111 CONTINUE
      IF (NA .EQ. 1) RETURN
      DO 112 I=1,N
         C(I) = CH(I)
  112 CONTINUE
      RETURN
      END


      SUBROUTINE PSLAED1( N, N1, D, ID, Q, IQ, JQ, DESCQ, RHO, WORK,
     $                    IWORK, INFO )
*
*  -- ScaLAPACK auxiliary routine (version 1.7) --
*     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
*     and University of California, Berkeley.
*     December 31, 1998
*
*     .. Scalar Arguments ..
      INTEGER            ID, INFO, IQ, JQ, N, N1
      REAL               RHO
*     ..
*     .. Array Arguments ..
      INTEGER            DESCQ( * ), IWORK( * )
      REAL               D( * ), Q( * ), WORK( * )
*     ..
*
*  Purpose
*  =======
*
*  PSLAED1 computes the updated eigensystem of a diagonal
*  matrix after modification by a rank-one symmetric matrix,
*  in parallel.
*
*    T = Q(in) ( D(in) + RHO * Z*Z' ) Q'(in) = Q(out) * D(out) * Q'(out)
*
*     where Z = Q'u, u is a vector of length N with ones in the
*     N1 and N1 + 1 th elements and zeros elsewhere.
*
*     The eigenvectors of the original matrix are stored in Q, and the
*     eigenvalues are in D.  The algorithm consists of three stages:
*
*        The first stage consists of deflating the size of the problem
*        when there are multiple eigenvalues or if there is a zero in
*        the Z vector.  For each such occurence the dimension of the
*        secular equation problem is reduced by one.  This stage is
*        performed by the routine PSLAED2.
*
*        The second stage consists of calculating the updated
*        eigenvalues. This is done by finding the roots of the secular
*        equation via the routine SLAED4 (as called by PSLAED3).
*        This routine also calculates the eigenvectors of the current
*        problem.
*
*        The final stage consists of computing the updated eigenvectors
*        directly using the updated eigenvalues.  The eigenvectors for
*        the current problem are multiplied with the eigenvectors from
*        the overall problem.
*
*  Arguments
*  =========
*
*  N       (global input) INTEGER
*          The order of the tridiagonal matrix T.  N >= 0.
*
*
*  N1      (input) INTEGER
*          The location of the last eigenvalue in the leading
*          sub-matrix.
*          min(1,N) <= N1 <= N.
*
*  D       (global input/output) REAL array, dimension (N)
*          On entry,the eigenvalues of the rank-1-perturbed matrix.
*          On exit, the eigenvalues of the repaired matrix.
*
*  ID      (global input) INTEGER
*          Q's global row/col index, which points to the beginning
*          of the submatrix which is to be operated on.
*
*  Q       (local output) REAL array,
*          global dimension (N, N),
*          local dimension ( LLD_Q, LOCc(JQ+N-1))
*          Q  contains the orthonormal eigenvectors of the symmetric
*          tridiagonal matrix.
*
*  IQ      (global input) INTEGER
*          Q's global row index, which points to the beginning of the
*          submatrix which is to be operated on.
*
*  JQ      (global input) INTEGER
*          Q's global column index, which points to the beginning of
*          the submatrix which is to be operated on.
*
*  DESCQ   (global and local input) INTEGER array of dimension DLEN_.
*          The array descriptor for the distributed matrix Z.
*
*  RHO    (input) REAL
*         The subdiagonal entry used to create the rank-1 modification.
*
*  WORK    (local workspace/output) REAL array,
*          dimension 6*N + 2*NP*NQ
*
*  IWORK   (local workspace/output) INTEGER array,
*          dimension 7*N + 8*NPCOL + 2
*
*  INFO    (global output) INTEGER
*          = 0:  successful exit
*          < 0:  If the i-th argument is an array and the j-entry had
*                an illegal value, then INFO = -(i*100+j), if the i-th
*                argument is a scalar and had an illegal value, then
*                INFO = -i.
*          > 0:  The algorithm failed to compute the ith eigenvalue.
*
*  =====================================================================
*
*     .. Parameters ..
*
      INTEGER            BLOCK_CYCLIC_2D, DLEN_, DTYPE_, CTXT_, M_, N_,
     $                   MB_, NB_, RSRC_, CSRC_, LLD_
      PARAMETER          ( BLOCK_CYCLIC_2D = 1, DLEN_ = 9, DTYPE_ = 1,
     $                   CTXT_ = 2, M_ = 3, N_ = 4, MB_ = 5, NB_ = 6,
     $                   RSRC_ = 7, CSRC_ = 8, LLD_ = 9 )
      REAL               ZERO, ONE
      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            COL, COLTYP, IBUF, ICTOT, ICTXT, IDLMDA, IIQ,
     $                   INDCOL, INDROW, INDX, INDXC, INDXP, INDXR, INQ,
     $                   IPQ, IPQ2, IPSM, IPU, IPWORK, IQ1, IQ2, IQCOL,
     $                   IQQ, IQROW, IW, IZ, J, JC, JJ2C, JJC, JJQ, JNQ,
     $                   K, LDQ, LDQ2, LDU, MYCOL, MYROW, NB, NN, NN1,
     $                   NN2, NP, NPCOL, NPROW, NQ
*     ..
*     .. Local Arrays ..
      INTEGER            DESCQ2( DLEN_ ), DESCU( DLEN_ )
*     ..
*     .. External Functions ..
      INTEGER            NUMROC
      EXTERNAL           NUMROC
*     ..
*     .. External Subroutines ..
      EXTERNAL           BLACS_GRIDINFO, DESCINIT, INFOG1L, INFOG2L,
     $                   PSGEMM, PSLAED2, PSLAED3, PSLAEDZ, PSLASET,
     $                   PXERBLA, SCOPY
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
*     ..
*     .. Executable Statements ..
*
*       This is just to keep ftnchek and toolpack/1 happy
      IF( BLOCK_CYCLIC_2D*CSRC_*CTXT_*DLEN_*DTYPE_*LLD_*MB_*M_*NB_*N_*
     $    RSRC_.LT.0 )RETURN
*
*
*     Test the input parameters.
*
      CALL BLACS_GRIDINFO( DESCQ( CTXT_ ), NPROW, NPCOL, MYROW, MYCOL )
      INFO = 0
      IF( NPROW.EQ.-1 ) THEN
         INFO = -( 600+CTXT_ )
      ELSE IF( N.LT.0 ) THEN
         INFO = -1
      ELSE IF( ID.GT.DESCQ( N_ ) ) THEN
         INFO = -4
      ELSE IF( N1.GE.N ) THEN
         INFO = -2
      END IF
      IF( INFO.NE.0 ) THEN
         CALL PXERBLA( DESCQ( CTXT_ ), 'PSLAED1', -INFO )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( N.EQ.0 )
     $   RETURN
*
*     The following values are  integer pointers which indicate
*     the portion of the workspace used by a particular array
*     in PSLAED2 and PSLAED3.
*
      ICTXT = DESCQ( CTXT_ )
      NB = DESCQ( NB_ )
      LDQ = DESCQ( LLD_ )
*
      CALL INFOG2L( IQ-1+ID, JQ-1+ID, DESCQ, NPROW, NPCOL, MYROW, MYCOL,
     $              IIQ, JJQ, IQROW, IQCOL )
*
      NP = NUMROC( N, DESCQ( MB_ ), MYROW, IQROW, NPROW )
      NQ = NUMROC( N, DESCQ( NB_ ), MYCOL, IQCOL, NPCOL )
*
      LDQ2 = MAX( NP, 1 )
      LDU = LDQ2
*
      IZ = 1
      IDLMDA = IZ + N
      IW = IDLMDA + N
      IPQ2 = IW + N
      IPU = IPQ2 + LDQ2*NQ
      IBUF = IPU + LDU*NQ
*     (IBUF est de taille 3*N au maximum)
*
      ICTOT = 1
      IPSM = ICTOT + NPCOL*4
      INDX = IPSM + NPCOL*4
      INDXC = INDX + N
      INDXP = INDXC + N
      INDCOL = INDXP + N
      COLTYP = INDCOL + N
      INDROW = COLTYP + N
      INDXR = INDROW + N
*
      CALL DESCINIT( DESCQ2, N, N, NB, NB, IQROW, IQCOL, ICTXT, LDQ2,
     $               INFO )
      CALL DESCINIT( DESCU, N, N, NB, NB, IQROW, IQCOL, ICTXT, LDU,
     $               INFO )
*
*     Form the z-vector which consists of the last row of Q_1 and the
*     first row of Q_2.
*
      IPWORK = IDLMDA
      CALL PSLAEDZ( N, N1, ID, Q, IQ, JQ, LDQ, DESCQ, WORK( IZ ),
     $              WORK( IPWORK ) )
*
*     Deflate eigenvalues.
*
      IPQ = IIQ + ( JJQ-1 )*LDQ
      CALL PSLAED2( ICTXT, K, N, N1, NB, D, IQROW, IQCOL, Q( IPQ ), LDQ,
     $              RHO, WORK( IZ ), WORK( IW ), WORK( IDLMDA ),
     $              WORK( IPQ2 ), LDQ2, WORK( IBUF ), IWORK( ICTOT ),
     $              IWORK( IPSM ), NPCOL, IWORK( INDX ), IWORK( INDXC ),
     $              IWORK( INDXP ), IWORK( INDCOL ), IWORK( COLTYP ),
     $              NN, NN1, NN2, IQ1, IQ2 )
*
*     Solve Secular Equation.
*
      IF( K.NE.0 ) THEN
         CALL PSLASET( 'A', N, N, ZERO, ONE, WORK( IPU ), 1, 1, DESCU )
         CALL PSLAED3( ICTXT, K, N, NB, D, IQROW, IQCOL, RHO,
     $                 WORK( IDLMDA ), WORK( IW ), WORK( IZ ),
     $                 WORK( IPU ), LDQ2, WORK( IBUF ), IWORK( INDX ),
     $                 IWORK( INDCOL ), IWORK( INDROW ), IWORK( INDXR ),
     $                 IWORK( INDXC ), IWORK( ICTOT ), NPCOL, INFO )
*
*     Compute the updated eigenvectors.
*
         IQQ = MIN( IQ1, IQ2 )
         IF( NN1.GT.0 ) THEN
            INQ = IQ - 1 + ID
            JNQ = JQ - 1 + ID + IQQ - 1
            CALL PSGEMM( 'N', 'N', N1, NN, NN1, ONE, WORK( IPQ2 ), 1,
     $                   IQ1, DESCQ2, WORK( IPU ), IQ1, IQQ, DESCU,
     $                   ZERO, Q, INQ, JNQ, DESCQ )
         END IF
         IF( NN2.GT.0 ) THEN
            INQ = IQ - 1 + ID + N1
            JNQ = JQ - 1 + ID + IQQ - 1
            CALL PSGEMM( 'N', 'N', N-N1, NN, NN2, ONE, WORK( IPQ2 ),
     $                   N1+1, IQ2, DESCQ2, WORK( IPU ), IQ2, IQQ,
     $                   DESCU, ZERO, Q, INQ, JNQ, DESCQ )
         END IF
*
         DO 10 J = K + 1, N
            JC = IWORK( INDX+J-1 )
            CALL INFOG1L( JQ-1+JC, NB, NPCOL, MYCOL, IQCOL, JJC, COL )
            CALL INFOG1L( JC, NB, NPCOL, MYCOL, IQCOL, JJ2C, COL )
            IF( MYCOL.EQ.COL ) THEN
               IQ2 = IPQ2 + ( JJ2C-1 )*LDQ2
               INQ = IPQ + ( JJC-1 )*LDQ
               CALL SCOPY( NP, WORK( IQ2 ), 1, Q( INQ ), 1 )
            END IF
   10    CONTINUE
      END IF
*
   20 CONTINUE
      RETURN
*
*     End of PSLAED1
*
      END


c-------------------------------------
      function diskdf3intez(ep,am,ez)
      parameter (pi=3.1415926535,nrmax=1000)

      psi00 = pot(0.0,0.0)
      rc=rcirc(am)
      call omekap(rc,fomega,fkappa)
      vc=rc*fomega
      ec=pot(rc,0.0)+0.5*vc*vc
      if (am.lt.0.) ec=2*psi00-ec
      sr2=sigr2(rc)
      sz2=sigz2(rc)
      if (sz2.gt.0.) then
        fvert=fnamidden(rc)*exp(-ez/sz2)
        diskdf3intez=fomega/fkappa*sqrt(2/pi/sr2)*exp(-(ep-ec)/sr2)*fvert
      else
        diskdf3intez=0
        endif
      return
      end