C   Last modified 08/06/2005

C   This code computes Fourier components of the reflection
C   function for a semi-infinite particulate slab characterized by the single
C   scattering albedo ALB and coefficients appearing in the expansion
C   of the phase function in Legendre polynomials (file 10).
C   The computation is based on the rigorous solution of the radiative
C   transfer equation as described in the paper
C
C   M. I. MISHCHENKO, J. M. DLUGACH, E. G. YANOVITSKIJ,
C   AND N. T. ZAKHAROVA, BIDIRECTIONAL REFLECTANCE OF FLAT,
C   OPTICALLY THICK PARTICULATE LAYERS:  AN EFFICIENT RADIATIVE
C   TRANSFER SOLUTION AND APPLICATIONS TO SNOW AND SOIL SURFACES,
C   J. QUANT. SPECTROSC. RADIAT. TRANSFER, VOL. 63, 409-432 (1999).
C
C   The paper is available upon reuest from Michael Mishchenko
C   (send a mesage to michael.i.mishchenko@nasa.gov) and
C   is also available in the .pdf format at
C   http://www.giss.nasa.gov/staff/mmishchenko/publications/index.html
C   The code was developed by Michael Mishchenko and
C   Nadia Zakharova at the NASA
C   Goddard Institute for Space Studies, New York.  The development
C   of the code was supported by the NASA Radiation Science Program.

C   The code can be used without limitations in any not-for-
C   profit scientific research.  The only request is that in any
C   publication using the code the source of the code be acknowledged
C   and relevant references be made.

C   We would highly appreciate informing us of any problems encountered
C   with this code.  Please send your message to Michael Mishchenko
C   at michael.i.mishchenko@nasa.gov.

C   MMAX1 Fourier components of the reflection function are computed
C   sequentially and each of them is given by the array R(I,J), where
C   I numbers the values of the cosine of the reflection zenith
C   angle (mu) and J numbers the values of the cosine of the illumination
C   zenith angle (mu_0).  Both mu and mu_0 take the values of the
C   division points of a quadrature formula of order NG
C   on the interval (0,1].  The Fourier components can be used to compute
C   the reflection function for any azimuth angle phi via Eq. (2), in
C   which m_max=MMAX1-1.  To compute the reflection function for
C   mu and/or mu_0 values different from the quadrature division points
C   on the interval (0,1] used to solve the radiative transfer equation,
C   an interpolation procedure must be used.  The interpolation code is
C   available at the same web site.
C   The Fourier components of the reflection function are writen in file 11.

C   By default, MMAX1 is equal to the number of numerically
C   significant coefficients in the Legendre expansion of the
C   phase function [i.e., MMAX1=s_max+1, where s_max is the upper
C   summation limit in Eq. (6)].  However, if the specified value of
C   the parameter NSEP is 1, then the first-order-scattering
C   contribution to the Fourier components of the reflection function is
C   separated (Section 3.7 of the above paper) and only the first MMAX2
C   modified Fourier components of the reflection function are computed
C   [MMAX2=m_1+1, where m_1 is the upper summation limit in Eq. (47)].

C   The code also computes the spherical (Bond) albedo and the values
C   of the plane albedo for MU_0 given by the quadrature division points
C   [Eqs. (12) and (11) of the above paper].
C   If only these albedos are required (not the complete reflection
C   function), then the line
C
C     DO M1=1,MMAX1
C
C   in the main program should be modified as follows:
C
C     DO M1=1,1
C
C   This will save a major fraction of CPU time.

C   The parameter NG should be increased simultaneously in all
C   PARAMETER statements until the reflection function values converge
C   within the desired accuracy.  Messages
C
C     WARNING:  I(MU) HAS NOT CONVERGED.
C
C   and
C
C     WARNING:  NUMERICAL CONERGENCE HAS NOT BEEN REACHED.
C     TRY A LARGER NG.
C
C   may be indicators that the NG value chosen is too small and should
C   be increased.

C   WHILE THE COMPUTER PROGRAM HAS BEEN TESTED FOR A VARIETY OF CASES,
C   IT IS NOT INCONCEIVABLE THAT IT CONTAINS UNDETECTED ERRORS. ALSO,
C   INPUT PARAMETERS CAN BE USED WHICH ARE OUTSIDE THE ENVELOPE OF
C   VALUES FOR WHICH RESULTS ARE COMPUTED ACCURATELY. FOR THIS REASON,
C   THE AUTHORS AND THEIR ORGANIZATION DISCLAIM ALL LIABILITY FOR
C   ANY DAMAGES THAT MAY RESULT FROM THE USE OF THE PROGRAM.

      SUBROUTINE BRF(ALB, MMAX1, AL1, NSEP,
     *   IERR, X, GLOBAL, ALBEDO, RZERO_, R_)
!f2py intent(in) AL1, MMAX1, AL1, NSEP
!f2py intent(out) IERR, X, GLOBAL, ALBEDO, R_, RZERO_

      IMPLICIT REAL*8 (A-H,O-Z)
      PARAMETER (NG=100, LMAX1=700)
      REAL*8 X(NG),W(NG),WW(NG),AL1(LMAX1),X1(NG),W1(NG)
      REAL*4 R(NG,NG),ALBEDO(NG),RZERO(NG,NG)
      REAL*4 R_(LMAX1,NG,NG),RZERO_(NG,NG)
      COMMON /RMATR/ R,RZERO

      IERR = 0

c      open (6,file='refl.print')
C      open (10,file='spher.write')
c      open (11,file='refl.write')

C***  SEPARATE FIRST-ORDER SCATTERING? (1 FOR YES)

C      NSEP=1
C      IF (NSEP.EQ.1) PRINT 1020
C 1020 FORMAT ('FIRST-ORDER SCATTERING IS SEPARATED')
C      WRITE (11,*) NSEP

C***  SPECIFY NUMERICAL ACCURACY

      EP=1D-5

C***  COMPUTATION OF THE QUADRATURE DIVISION POINTS ON THE INTERVAL
C***  (0,1) (GAUSS) OR (0,1] (MARK) (Section 3.5)

      NMU=NG
c     CALL MARK (NMU,X,W,1,0)
c     CALL GAUSS (NMU,1,0,X,W)

C***  SPECIAL QUADRATURE FORMULA GIVEN BY EQ. (43)

      CALL GAUSS (NMU,0,0,X,W)
      PI=DACOS(-1D0)
      DO I=1,NG
         X1(I)=PI*X(I)/4D0+PI/4D0
         W1(I)=PI*W(I)/4D0
         W1(I)=W1(I)*DSIN(X1(I))
         X1(I)=DCOS(X1(I))
      ENDDO
      DO I=1,NG
         X(I)=X1(NG-I+1)
         W(I)=W1(NG-I+1)
      ENDDO

C      WRITE (11,1501) NMU
C      WRITE (11,1502) X
C      PRINT 7446,NG
C 7446 FORMAT('NUMBER OF MU- AND MU_0-VALUES = ',I3)
C      PRINT 7447
C 7447 FORMAT ('MU- AND MU_0-VALUES:')
C      WRITE (6,7448) X
C 7448 FORMAT (5D15.8)
      DO I=1,NG
         WW(I)=DSQRT(W(I))
      ENDDO

C***  READ IN SINGLE-SCATTERING ALBEDO AND LEGENDRE
C***  EXPANSION COEFFICIENTS

C      READ (10,*) ALB,MMAX1
      IF (ALB.GT.1D0) PRINT 1010
 1010 FORMAT ('SINGLE-SCATTERING ALBEDO EXCEEDS 1. ',
     $        'EXECUTION TERMINATED.')
      IF (ALB.GT.1D0) IERR = 1010
      IF (ALB.GT.1D0) RETURN
      IF (MMAX1.GT.LMAX1) IERR = 1000
      IF (MMAX1.GT.LMAX1) RETURN
C      AL1(2)=0D0
C      DO L=1,MMAX1
C         READ (10,*) AL1(L)
C      ENDDO
 1000 FORMAT ('INCREASE LMAX1 IN ALL PARAMETER STATEMENTS!')
      G=AL1(2)/3D0
      PRINT 1200, ALB,G
 1200 FORMAT('SINGLE-SCATTERING ALBEDO = ',D18.12,
     +       '  G = ', D12.6)
C      WRITE (11,1501) MMAX1,ALB
C      WRITE (11,1502) (AL1(M1), M1=1,MMAX1)
C 1501 FORMAT (I5,D15.8)
C 1502 FORMAT (6D15.8)

C***  COMPUTATION OF FOURIER COMPONENTS OF THE REFLECTION FUNCTION
C***  (SECTION 3.3)

      IFLAG=1
      DO M1=1,MMAX1
         print * ,m1
         M=M1-1
         CALL PHAS (M,MMAX1,AL1,X,WW)
         IF (M.EQ.0) CALL F_I (ALB,X,W,WW,EP)
         IF (M.NE.0) CALL RENRM2
         CALL RMINF (M,X,WW,EP,ALB,MMAX1,AL1,IFLAG,NSEP)
         IF (M.NE.0) GO TO 80
         GLOBAL=0D0
         DO J=1,NG
            ALBEDO(J)=0D0
            DO I=1,NG
               ALBEDO(J)=ALBEDO(J)+W(I)*X(I)*RZERO(I,J)*2D0
            ENDDO
            GLOBAL=GLOBAL+ALBEDO(J)*W(J)*X(J)*2D0
         ENDDO
         PRINT 6100, GLOBAL
C         WRITE (6,*) RZERO(NG,NG)
         DO I=1,NG
            DO J=1,NG
               RZERO_(I, J) = RZERO(I, J)
            ENDDO
         ENDDO

 6100    FORMAT('SPHERICAL (BOND) ALBEDO = ',D12.6)
   80    CONTINUE
C         WRITE (11,*) IFLAG
C         DO I=1,NG
C            WRITE (11,1502) (R(I,J), J=1,I)
C         ENDDO
         DO I=1,NG
            DO J=1,NG
               R_(M1, I, J) = R(I, J)
            ENDDO
         ENDDO
         MMAX2=M1
         IF (IFLAG.EQ.0) GO TO 450
      ENDDO
  450 CONTINUE
C      PRINT 6200
C 6200 FORMAT ('PLANE ALBEDO VALUES:')
C      WRITE (6,7448) ALBEDO
C      itime=mclock()
C      time=dfloat(itime)/6000d0
C      print 1001,time
C 1001 format (' time =',f8.2,' min')
C     copy results in the returned variables

      RETURN
      END

C*******************************************************************

      SUBROUTINE F_I(ALB,X,W,WW,EPSL)
      PARAMETER (NG=100)
      IMPLICIT REAL*8 (A-H,O-Z)
      REAL*8 PH1(NG,NG),PH2(NG,NG),RNRM(NG),
     &       X(NG),DI(NG),DNI(NG),DI1(NG),DNI1(NG),
     &       XMN(NG),XMNN(NG),W(NG),WW(NG),
     &       PR(NG,NG),PT(NG,NG)
      COMMON /PH/ PH1,PH2,RNRM
      COMMON /IPARA/ DI,DNI

C__ RENORMALIZATION OF THE ZEROTH FOURIER COMPONENT OF THE PHASE
C__ FUNCTION (SECTION 3.6)

      DO I=1,NG
         WI=1D0/WW(I)
         DO J=1,NG
            WJ=WI/WW(J)
            PR(I,J)=PH1(I,J)*WJ
            PT(I,J)=PH2(I,J)*WJ
         ENDDO
      ENDDO
      DO K=1,NG
         S=0D0
         DO I=1,NG
            S=S+W(I)*(PR(I,K)+PT(I,K))
         ENDDO
         EP=(2D0-S)/(PT(K,K)*W(K)) + 1D0
         RNRM(K)=EP
         PH2(K,K)=PH2(K,K)*EP
      ENDDO

C__ CALCULATION OF THE ASYMPTOTIC INTERNAL FIELD (SECTION 3.4)

      IF (ALB.LT.0.7999D0) GO TO 2
      IF (DABS(ALB-1D0).GT.1D-10) GO TO 1
      DO I=1,NG
         DI(I) = WW(I)
         DNI(I) = WW(I)
      END DO
      GO TO 2

    1 DO I=1,NG
         DI(I) = 2D0*WW(I)
         DNI(I) = 0.5D0*WW(I)
      END DO
      EPS = 0.1D0*EPSL
      DDK = DSQRT(1D0-ALB)
      DDK1 = DDK
      LMAX=400
      DO L = 1,LMAX

C_______________ Eq. (38)
         DDK=0.5D0*(DDK+DDK1)
         DDK1=DDK
         DO I=1,NG
            DI1(I) = DI(I)
            DNI1(I) = DNI(I)
            XMN(I) = ALB*0.5D0/(1D0-DDK*X(I))
            XMNN(I) = ALB*0.5D0/(1D0+DDK*X(I))
         END DO
         DO I=1,NG
            SUM = 0D0
            SUMN= 0D0
            DO J=1,NG
               SUM  = SUM + DI1(J)*PH2(I,J) + DNI1(J)*PH1(I,J)
               SUMN = SUMN + DI1(J)*PH1(I,J) + DNI1(J)*PH2(I,J)
            END DO
            DI(I) = SUM*XMN(I)
            DNI(I)= SUMN*XMNN(I)
         END DO

C_______________ Eq. (39)
         SINT= 0D0
         DO I=1,NG
            SINT = SINT + (DI(I)+DNI(I))*WW(I)
         END DO
         SINT=SINT*ALB*0.5D0
         DO I=1,NG
            DI(I) = DI(I)/SINT
            DNI(I)= DNI(I)/SINT
         END DO

C________________ Eq.(40)
         SUMK = 0D0
         DO I=1, NG
            SUMK = SUMK+WW(I)*X(I)*(DI(I)-DNI(I))
         END DO
         ZN = ALB*SUMK
         IF (ABS(ZN).GT.1D-8) DDK=2D0*(1D0-ALB)/ZN
C        WRITE (6,*) L,SUM,DDK
         G = 0D0
         DO I=1,NG
            G = MAX(G, DABS(DI(I)-DI1(I)))
            G = MAX(G, DABS(DNI(I)-DNI1(I)))
         END DO
         IF (G.LE.EPS)  GO TO 2
      END DO
      IF (L.EQ.LMAX) WRITE (6,1305)
C     WRITE (6, 1302) ALB, XLSUM
   2  CONTINUE
C     WRITE (6, 1303)(DI(I)*WW(I), I=1,NG)
C     WRITE (6, 1304)(DNI(I)*WW(I), I=1,NG)
 1302 FORMAT('  ALB = ', D12.6,
     +       '  XLSUM = ', D12.6 )
 1303 FORMAT('   DI = ', 5D12.6)
 1304 FORMAT('   DNI= ', 5D12.6)
 1305 FORMAT('WARNING:  I(MU) HAS NOT CONVERGED.')
 1306 FORMAT('   SUM= ',D12.6)
      SUM=0D0
      DO I=1,NG
         SUM=SUM+(DI(I)+DNI(I))*WW(I)
      ENDDO
      SUM=SUM*ALB*0.5D0
c     WRITE (6,1306) SUM
      RETURN
      END

C**************************************************************

      SUBROUTINE RENRM2
C__  REMORMALIZATION OF HIGHER-ORDER FOURIER COMONENTS OF
C__  THE PHASE FUNCTION
      PARAMETER (NG=100)
      IMPLICIT REAL*8 (A-H,O-Z)
      REAL*8 PH1(NG,NG),PH2(NG,NG),RNRM(NG)
      COMMON /PH/ PH1,PH2,RNRM
      DO I=1,NG
         PH2(I,I)=PH2(I,I)*RNRM(I)
      ENDDO
      RETURN
      END

C**************************************************************

      SUBROUTINE FFR (ALB)
      PARAMETER (NG=100)
      IMPLICIT REAL*8 (A-H,O-Z)
      REAL*8 PH1(NG,NG),PH2(NG,NG),
     *       R(NG,NG),F(NG,NG),XX(NG),XXX(NG,NG),B(NG)
      COMMON /PH/ PH1,PH2
      COMMON /FR/ R,F,XX,XXX
      DO 100 I=1,NG
         XI=XX(I)
         DO 20 J=1,NG
            A=0D0
            DO 15 K=1,NG
               A=A+R(I,K)*PH1(K,J)
   15       CONTINUE
            B(J)=A
   20    CONTINUE
         DO 100 J=1,I
            A1=0D0
            A2=0D0
            A3=0D0
            DO 30 K=1,NG
               RKJ=R(K,J)
               A1=A1+R(I,K)*PH2(K,J)
               A2=A2+PH2(I,K)*RKJ
               A3=A3+B(K)*RKJ
   30       CONTINUE
            F(I,J)=ALB*(XXX(I,J)*PH1(I,J)+XX(J)*A1+XI*A2+A3)
  100 CONTINUE
      RETURN
      END

C**********************************************************************

      SUBROUTINE PHAS (M,MMAX1,AL1,X,WW)
C__  COMPUTATION OF FOURIER COMPONENTS OF THE PHASE FUNCTION
C__  (SECTION 3.2)
      PARAMETER (NG=100, LMAX1=700)
      IMPLICIT REAL*8 (A-H,O-Z)
      REAL*8 PH1(NG,NG),PH2(NG,NG),
     *       D1(LMAX1),AL1(LMAX1),
     *       P(LMAX1,NG),PP(LMAX1,NG),
     *       X(NG),WW(NG)
      COMMON /PH/ PH1,PH2
      LMIN=M+1
      DO I=1,NG
         XI=X(I)
         XXI=-XI
         WI=WW(I)
         CALL DD(XI,M,MMAX1,D1)
         DO L=LMIN,MMAX1
            DL=D1(L)*WI
            P(L,I)=DL
         ENDDO
         CALL DD(XXI,M,MMAX1,D1)
         DO L=LMIN,MMAX1
            DL=D1(L)*WI
            PP(L,I)=DL
         ENDDO
      ENDDO
      DO J=1,NG
         DO I=1,NG
           PH1(I,J)=0D0
           PH2(I,J)=0D0
           DO L=LMIN,MMAX1
              ALL=AL1(L)
              PH1(I,J)=PH1(I,J)+ALL*PP(L,I)*P(L,J)
              PH2(I,J)=PH2(I,J)+ALL*P(L,I)*P(L,J)
           ENDDO
         ENDDO
      ENDDO
      RETURN
      END

C**********************************************************************

C  CALCULATION OF GENERALIZED SPHERICAL FUNCTIONS THAT ARE NECESSARY
C  IN THE CALCULATION OF THE M-TH FOURIER COMPONENT OF THE PHASE MATRIX
C  (SECTION 3.2)

      SUBROUTINE DD(X,M,MMAX1,D1)
      PARAMETER (LMAX1=700)
      IMPLICIT REAL*8 (A-H,O-Z)
      REAL*8 D1(LMAX1)
      LMAX=MMAX1-1
      DX=1D0-X*X
      DDX=DSQRT(DX)
      IF (M.EQ.0) GO TO 10
      IF (M.EQ.1) GO TO 60
      IF (M.GE.2) GO TO 110
   10 L=1
      D1(L)=1D0
      IF (LMAX.LE.0) RETURN
      L=L+1
      D1(L)=X
      IF (LMAX.LE.1) RETURN
      L=L+1
      D1(L)=(3D0*X*X-1D0)*0.5D0
      IF (LMAX.LE.2) RETURN
      GO TO 160
   60 L=2
      D1(L)=DSQRT(0.5D0*DX)
      IF (LMAX.LE.1) RETURN
      L=L+1
      D1(L)=DSQRT(1.5D0*DX)*X
      IF (LMAX.LE.2) RETURN
      GO TO 160
  110 A=DX*0.25D0*DSQRT(6D0)
      X1=1D0+X
      B=X1*X1*0.25D0
      X1=1D0-X
      C=X1*X1*0.25D0
      IF (M.EQ.2) GO TO 140
      DO L=3,M
         A=A*DSQRT(DFLOAT(2*L-1)/DFLOAT(2*L))*DDX
      ENDDO

C************************************
      IF (A.LT.1D-302) A=0D0
C************************************

  140 M1=M+1
      D1(M)=0D0
      D1(M1)=A
      IF (LMAX.LE.2) RETURN
  160 M1=MAX(M+1,3)
      DM=DFLOAT(M*M)
      DM2=DFLOAT(2*M)
      DO L=M1,LMAX
         DL=DFLOAT(L)
         L1=L+1
         L2=L-1
         DL2=DFLOAT(L2)
         DL1=DFLOAT(2*L-1)
         DL3=DL2*DL2
         DDL=DL*DL
         A=DSQRT(DL3-DM)
         B=1D0/DSQRT(DDL-DM)
         C=DL1*X
         D1(L1)=(C*D1(L)-A*D1(L2))*B
      ENDDO
      RETURN
      END

C**********************************************************************
C    CALCULATION OF POINTS AND WEIGHTS OF GAUSSIAN QUADRATURE         *
C    FORMULA. IF IND1 = 0 - ON INTERVAL (-1,1), IF IND1 = 1 - ON      *
C    INTERVAL  (0,1). IF  IND2 = 1 RESULTS ARE PRINTED.               *
C    N - NUMBER OF POINTS                                             *
C    Z - DIVISION POINTS                                              *
C    W - WEIGHTS                                                      *
C**********************************************************************

      SUBROUTINE GAUSS ( N,IND1,IND2,Z,W )
      IMPLICIT REAL*8 (A-H,P-Z)
      REAL*8 Z(N),W(N)
      A=1D0
      B=2D0
      C=3D0
      IND=MOD(N,2)
      K=N/2+IND
      F=DFLOAT(N)
      DO 100 I=1,K
          M=N+1-I
          IF(I.EQ.1) X=A-B/((F+A)*F)
          IF(I.EQ.2) X=(Z(N)-A)*4D0+Z(N)
          IF(I.EQ.3) X=(Z(N-1)-Z(N))*1.6D0+Z(N-1)
          IF(I.GT.3) X=(Z(M+1)-Z(M+2))*C+Z(M+3)
          IF(I.EQ.K.AND.IND.EQ.1) X=0D0
          NITER=0
          CHECK=1D-16
   10     PB=1D0
          NITER=NITER+1
          IF (NITER.LE.100) GO TO 15
          CHECK=CHECK*10D0
   15     PC=X
          DJ=A
          DO 20 J=2,N
              DJ=DJ+A
              PA=PB
              PB=PC
   20         PC=X*PB+(X*PB-PA)*(DJ-A)/DJ
          PA=A/((PB-X*PC)*F)
          PB=PA*PC*(A-X*X)
          X=X-PB
          IF(DABS(PB).GT.CHECK*DABS(X)) GO TO 10
          Z(M)=X
          W(M)=PA*PA*(A-X*X)
          IF(IND1.EQ.0) W(M)=B*W(M)
          IF(I.EQ.K.AND.IND.EQ.1) GO TO 100
          Z(I)=-Z(M)
          W(I)=W(M)
  100 CONTINUE
      IF(IND2.NE.1) GO TO 110
      PRINT 1100,N
 1100 FORMAT(' ***  POINTS AND WEIGHTS OF GAUSSIAN QUADRATURE FORMULA',
     * ' OF ',I4,'-TH ORDER')
      DO 105 I=1,K
          ZZ=-Z(I)
  105     PRINT 1200,I,ZZ,I,W(I)
 1200 FORMAT(' ',4X,'X(',I4,') = ',F17.14,5X,'W(',I4,') = ',F17.14)
      GO TO 115
  110 CONTINUE
C     PRINT 1300,N
 1300 FORMAT(' GAUSSIAN QUADRATURE FORMULA OF ',I4,'-TH ORDER IS USED')
  115 CONTINUE
      IF(IND1.EQ.0) GO TO 140
      DO 120 I=1,N
  120     Z(I)=(A+Z(I))/B
  140 CONTINUE
      RETURN
      END

C********************************************************************

      SUBROUTINE RMINF (M,X,WW,EP,ALB,MMAX1,AL1,IFLAG,NSEP)
C  ITERATIVE SOLUTION OF THE AMBARTSUMIAN'S EQUATION (SECTION 3.3)
      PARAMETER (NG=100, LMAX1=700)
      IMPLICIT REAL*8 (A-H,O-Z)
      REAL*8 RR(NG,NG),F3(NG,NG),
     *       X(NG),XX(NG),XXX(NG,NG),WW(NG),A(NG),CC(NG,NG),
     *       PH1(NG,NG),PH2(NG,NG),DI(NG),DNI(NG),
     *       AL1(LMAX1)
      REAL*4 R(NG,NG),RZERO(NG,NG)
      COMMON /RMATR/ R,RZERO
      COMMON /PH/ PH1,PH2
      COMMON /FR/ RR,F3,XX,XXX
      COMMON /IPARA/ DI,DNI
      M1=M+1
      KPAR=0
      AAM1=0D0
      AAM2=0D0
      DO 1 I=M1,MMAX1
         AAM1=DMAX1(AAM1,AL1(I))
         AAM2=DMAX1(AAM2,AL1(I)/DFLOAT(2*I-1))
    1 CONTINUE
      IF (AAM1*AAM2.GT.EP) KPAR=1
      IF (KPAR.EQ.0) IFLAG=0
      DO I=1,NG
         XI=1D0/X(I)
         A(I)=XI
         XX(I)=XI*0.5D0
         DO J=1,I
            XJ=A(J)
            XIJ=XI*XJ*0.25D0
            XXX(I,J)=XIJ
            XXX(J,I)=XIJ
            XIJ=1D0/(XI+XJ)
            CC(I,J)=XIJ
            CC(J,I)=XIJ
         ENDDO
      ENDDO

C****  INITIAL APPROXIMATION  *****

      DO I=1,NG
         DO J=1,I
            RR(I,J)=ALB*XXX(I,J)*PH1(I,J)*CC(I,J)
            RR(J,I)=RR(I,J)
         ENDDO
      ENDDO
      NITER=0
      IF(KPAR.EQ.0) GO TO 100

C****   ITERATIONS   *****

   50 CALL FFR (ALB)
      NITER=NITER+1
      IF (NITER.GT.150) GO TO 100
      DELT=0D0
      DO I=1,NG
         WI=1D0/WW(I)
         DO J=1,I
            RRIJ=F3(I,J)*CC(I,J)
            DELT=DMAX1(DELT,DABS(RRIJ-RR(I,J))*WI/WW(J))
            RR(I,J)=RRIJ
            RR(J,I)=RRIJ
         ENDDO
      ENDDO
      IF (DELT.LE.EP) GO TO 100
      IF (M.EQ.0.AND.ALB.GE.0.8D0) CALL RENRM4 (X,WW,ALB,EP)
      GO TO 50
  100 CONTINUE
      IF (M.NE.0) GO TO 200
      DO J=1,NG
         WJ=WW(J)
         DO I=1,J
            WIJ=RR(I,J)/(WJ*WW(I))
            RZERO(I,J)=WIJ
            RZERO(J,I)=WIJ
         ENDDO
      ENDDO

C****  SUBTRACT THE FIRST-ORDER-SCATTERING CONTRIBUTION

  200 IF (NSEP.NE.1) GO TO 300
      DO I=1,NG
         DO J=1,I
            RRIJ=RR(I,J)-ALB*XXX(I,J)*PH1(I,J)*CC(I,J)
            RR(I,J)=RRIJ
            RR(J,I)=RRIJ
         ENDDO
      ENDDO

C****  RETURN TO MAIN PROGRAM

  300 DO J=1,NG
         WJ=WW(J)
         DO I=1,J
            WIJ=RR(I,J)/(WJ*WW(I))
            R(I,J)=WIJ
            R(J,I)=WIJ
         ENDDO
      ENDDO
      WRITE (6,2000) M, NITER
      IF (NITER.GE.150) WRITE (6,2001)
      IF (NITER.GE.150) WRITE (6,2002)
 2000 FORMAT('M=',I4,' NITER=',I4)
 2001 FORMAT('WARNING:  NUMERICAL CONERGENCE HAS NOT BEEN REACHED.')
 2002 FORMAT('TRY A LARGER NG.')
      RETURN
      END

C****************************************************************

      SUBROUTINE RENRM4 (X,WW,ALB,EP)
C  SOBOLEV-VAN DE HULST RENORMALIZATION (SECTION 3.3)
      PARAMETER (NG=100)
      IMPLICIT REAL*8 (A-H,O-Z)
      REAL*8 RR(NG,NG),RW(NG,NG),T(NG),
     &       W(NG),WW(NG),X(NG),DI(NG),DNI(NG),
     &       DIW(NG),DNIW(NG)
      COMMON /FR/ RR
      COMMON /IPARA/ DI,DNI
      DELT=0.1*EP
      FACTOR=0.5D0
      IF (ALB.LT.0.995D0) FACTOR=0.1D0
      IF (ALB.LT.0.95D0) FACTOR=0.05D0
      DO 10 J=1,NG
         WWJ=WW(J)
         W(J)=WWJ*WWJ
         WWJ=1D0/WWJ
         DIW(J) = DI(J)*WWJ
         DNIW(J) = DNI(J)*WWJ
         DO 10 I=1,J
            RWIJ=RR(I,J)*WWJ/WW(I)
            RW(I,J)=RWIJ
            RW(J,I)=RWIJ
   10 CONTINUE
      MRI=0
   20 MRI=MRI+1
      IF (MRI.GT.200) WRITE (500)
  500 FORMAT ('RENORMALIZATION DIVERGES, REDUCE "FACTOR" IN
     & SUBROUTINE RENRM4')
      IF (MRI.GT.200) GO TO 60
      U=0D0
      DO 30 I=1,NG
         TI=0D0
         DO 25 J=1,NG
            TI=TI+W(J)*X(J)*DIW(J)*RW(I,J)
   25    CONTINUE
         T(I)=DNIW(I)-2D0*TI
         U=DMAX1(U,DABS(T(I)))
   30 CONTINUE
 1000 FORMAT('   NIT=',I3)
c     WRITE (6,*) MRI,U
      IF (U.LE.DELT) GO TO 60
      DO 50 I=1,NG
         TI=T(I)
         DIWI=DIW(I)
         DO 50 J=1,I
            RWIJ=RW(I,J)+FACTOR*(DIW(J)*TI+DIWI*T(J))
            RW(I,J)=RWIJ
            RW(J,I)=RWIJ
   50 CONTINUE
      GO TO 20
   60 DO 70 J=1,NG
         WWJ=WW(J)
         DO 70 I=1,NG
            WWIJ=WW(I)*WWJ
            RR(I,J)=RW(I,J)*WWIJ
   70 CONTINUE
      RETURN
      END

C**********************************************************************
C    CALCULATION OF POINTS AND WEIGHTS OF THE MARKOV QUADRATURE       *
C    FORMULA. IF IND1 = 0 - ON INTERVAL (-1,1], IF IND1 = 1 - ON      *
C    INTERVAL  (0,1].                                                 *
C    N - NUMBER OF POINTS                                             *
C    X - DIVISION POINTS                                              *
C    W - WEIGHTS                                                      *
C**********************************************************************

      SUBROUTINE MARK (N,X,W,IND1,IND2)
      IMPLICIT REAL*8 (A-H,O-Z)
      EXTERNAL F
      REAL*8 X(N),W(N)
      N=N-1
      BBB=0.01 D0
      IF (N.GE.30) BBB=0.001 D0
      IF (N.GE.100) BBB=0.00015 D0
      IF (N.GE.200) BBB=0.00003 D0
      TOL=1D-15
      E=2D0
      DN=DFLOAT(N)
      DD=2D0*DN+1D0
      A=-1D0
      K=0
      DD=DD*DD
      YB=F(A,N)
   10 Y=YB
      B=A
   15 B=B+BBB
      IF (1D0-B.LE.1D-15) GO TO 100
      YB=F(B,N)
      IF (Y/YB.GE.0D0) GO TO 15
      K=K+1
      XX=ZEROIN(A,B,F,TOL,N)
      IF (K.GE.2) BBB=(XX-X(K-1))*0.2D0
      X(K)=XX
      D=FF(XX,N)
      C=D*2D0*(DN+1D0)*DN
      WW=4D0*(1D0+XX)*DD/(C*C)
      W(K)=WW
      E=E-WW
      A=B
      GO TO 10
  100 K=K+1
      W(K)=E
      X(K)=1D0
      IF (IND2.NE.1) GO TO 130
      M=2*(K-1)
      A=0D0
      DM=DFLOAT(M)
      DO 120 I=1,K
  120     A=A+W(I)*DABS(X(I))**DM
      B=0.5D0*DFLOAT(M+1)
      A=A*B
  130 IF (IND1.NE.1) GO TO 140
      DO 135 I=1,K
           W(I)=0.5D0*W(I)
  135      X(I)=0.5D0*(X(I)+1D0)
  140 N=K
      RETURN
      END

C***********************************************************************

      DOUBLE PRECISION FUNCTION F(X,N)
      IMPLICIT REAL*8 (A-H,O-Z)
      A=1D0
      B=X
      DO 10 I=1,N
           C=B
           DI=DFLOAT(I)
           B=((2D0*DI+1D0)*X*B-DI*A)/(DI+1D0)
   10      A=C
      DN=DFLOAT(N)
      F=(A-B)/(1D0-X)
      RETURN
      END

C***********************************************************************

      DOUBLE PRECISION FUNCTION FF(X,N)
      IMPLICIT REAL*8 (A-H,O-Z)
      M=N-1
      A=1D0
      B=X
      DO 10 I=1,M
           C=B
           DI=DFLOAT(I)
           B=((2D0*DI+1D0)*X*B-DI*A)/(DI+1D0)
   10      A=C
      DN=DFLOAT(N)
      FF=(A-B)/(1D0-X)
      RETURN
      END

C***********************************************************************

      DOUBLE PRECISION FUNCTION ZEROIN (AX,BX,F,TOL,N)
      IMPLICIT REAL*8 (A-H,O-Z)
      EPS=1D0
   10 EPS=0.5D0*EPS
      TOL1=1D0+EPS
      IF (TOL1.GT.1D0) GO TO 10
   15 A=AX
      B=BX
      FA=F(A,N)
      FB=F(B,N)
   20 C=A
      FC=FA
      D=B-A
      E=D
   30 IF (DABS(FC).GE.DABS(FB)) GO TO 40
   35 A=B
      B=C
      C=A
      FA=FB
      FB=FC
      FC=FA
   40 TOL1=2D0*EPS*DABS(B)+0.5D0*TOL
      XM=0.5D0*(C-B)
      IF (DABS(XM).LE.TOL1) GO TO 90
   44 IF (FB.EQ.0D0) GO TO 90
   45 IF (DABS(E).LT.TOL1) GO TO 70
   46 IF (DABS(FA).LE.DABS(FB)) GO TO 70
   47 IF (A.NE.C) GO TO 50
   48 S=FB/FA
      P=2D0*XM*S
      Q=1D0-S
      GO TO 60
   50 Q=FA/FC
      R=FB/FC
      S=FB/FA
      P=S*(2D0*XM*Q*(Q-R)-(B-A)*(R-1D0))
      Q=(Q-1D0)*(R-1D0)*(S-1D0)
   60 IF (P.GT.0D0) Q=-Q
      P=DABS(P)
      IF ((2D0*P).GE.(3D0*XM*Q-DABS(TOL1*Q))) GO TO 70
   64 IF (P.GE.DABS(0.5D0*E*Q)) GO TO 70
   65 E=D
      D=P/Q
      GO TO 80
   70 D=XM
      E=D
   80 A=B
      FA=FB
      IF (DABS(D).GT.TOL1) B=B+D
      IF (DABS(D).LE.TOL1) B=B+DSIGN(TOL1,XM)
      FB=F(B,N)
      IF ((FB*(FC/DABS(FC))).GT.0D0) GO TO 20
   85 GO TO 30
   90 ZEROIN=B
      RETURN
      END


      REAL FUNCTION BEAMCORQ( Gamma_PT , Q2_PT, Icheck, Ierr)
      Implicit None
C     ---------------------------------------------------------------
C     Input: Gamma_PT : gamma, calculated with the PT method ...
C                      ... in RADIANS !!
C            Q2_PT    : Let's make the correction Q2 dependent...
C            Icheck   2: Default  !
C                     1: Lower Correction
C                     3: Higher Correction
C     Output: Ierr
C             1: Gamma not in Radians??
C             2: Q2 out of range
C
C     Purpose: Correct MonteCarlo for wrong beampipe simulation in 96/97
C     Author: N. Tuning 08/04/00
C
C     Changed from beamcor.f to beamcorq.f 15/04/00
C     Version 2.2 16/04/00
C     --------------------
C
C     How does the correction factor look?? Plot this:
C     PAW> opt logx
C     PAW> null 0.01 3.2 0.5 1.5
C     PAW> fun/pl beamcorq.f(x,20.,2,0) 0.01 3.2 s
C     PAW> atit 'Gamma?PT! (rad)' 'Beampipe Corr. Factor'
C     ---------------------------------------------------------------
      Real    BEAMCOR1, BEAMCOR2, BEAMCOR3
      Real    Gamma_PT, Q2_PT, X
      Integer Icheck, Ierr

      Real Shift_Lowg, Scale_Lowg, Slope_Lowg
      Real Shift_Higg, Scale_Higg, Slope_Higg
      Data Shift_Lowg, Scale_Lowg, Slope_Lowg / 0.85, 14., 4.5 /
      Data Shift_Higg, Scale_Higg, Slope_HIgg / 0.25,  4., 5.  /
      Real Q2shift
      Real Shift_Lowg2, Shift_Higg2
      Logical First
      Data    First/.TRUE./
C     --------------------------------------------------------------
      If (First) Then
         First=.false.
         Write(*,*) '=========================================='
         Write(*,*) ' This is Beampipe Correction version v2.2 '
         Write(*,*) '                                          '
         Write(*,*) ' Date 16/04/2000 (N.Tuning)               '
         Write(*,*) ' Only to be used for 1996/1997 analysis   '
         Write(*,*) '                                          '
         Write(*,*) '=========================================='
      EndIf

      Ierr = 0
      BEAMCORQ = 1.
C     =============
      IF (Gamma_PT.LE.0.) THEN
         Ierr = 1
         Write(*,*) 'Gamma_Pt le 0 !! (beamcorq.f):',Gamma_PT
         RETURN
      ELSEIF (Gamma_PT.GT.3.2) THEN
         Ierr = 1
         Write(*,*) 'Gamma_Pt > Pi !! (beamcorq.f):',Gamma_PT
         Write(*,*) '(gamma should bne in radians, not in degrees...)'
         RETURN
      ENDIF

      IF (Q2_PT.LE.0.) THEN
         Ierr = 2
         Write(*,*) 'Q2 le 0. !!(beamcorq.f):',Q2_PT
         RETURN
      ENDIF

C     ===================
      X = log10(Gamma_PT)
C     ===================
      Q2shift = 0.002*(log10(Q2_PT)-1.6)

      Shift_Higg2 = Shift_Higg+Q2shift
      Shift_Lowg2 = Shift_Lowg+Q2shift

      BeamCor1 =
     +     Scale_Higg*(
     +     ( exp( Slope_Higg*(x+Shift_Higg2))
     +     - exp(-Slope_Higg*(x+Shift_Higg2)))    /
     +     ( exp( Slope_Higg*(x+Shift_Higg2))
     +     + exp(-Slope_Higg*(x+Shift_Higg2)))  -1 )
     +
     +     -1.*Scale_Lowg*(
     +     ( exp( Slope_Lowg*(x+Shift_Lowg2))
     +     - exp(-Slope_Lowg*(x+Shift_Lowg2)))      /
     +     ( exp( Slope_Lowg*(x+Shift_Lowg2))
     +     + exp(-Slope_Lowg*(x+Shift_Lowg2)))    -1 )

      BeamCor2 = 1. + (1./100)*BeamCor1

C---
C Systematic Check:
C---
      If (Icheck.eq.1) Then
         BeamCor3 = Beamcor2 + 0.01/(Gamma_PT+0.09)
      ElseIf (Icheck.eq.3) Then
         BeamCor3 = Beamcor2 - 0.01/(Gamma_PT+0.09)
      Else
         BeamCor3 = Beamcor2
      EndIf

      If (BeamCor3.gt.0.) Then
C     ==========================
         BeamCorQ = 1./BeamCor3
C     ===========================
      Else
         Write(*,100)
     +        Beamcor1,Beamcor2,BeamCor3,
     +        gamma_pt,Q2_PT,Q2shift,
     +        Icheck
      EndIf
 100  FORMAT('ERROR beamcorq.f beamcor3:',6F12.5,I3)
      End


module particle

  implicit none

  private

  public :: particle__init, particle__solv

  logical, save :: is_init = .false.
  integer, save :: ndim, np, nsp, nxgs, nxge, nygs, nyge, nys, nye
  real(8), save :: delx, delt, u0, c, d_delx
  real(8), allocatable :: q(:), r(:)

contains

  subroutine particle__init(ndim_in,np_in,nsp_in,nxgs_in,nxge_in,nygs_in,nyge_in,nys_in,nye_in, &
                            delx_in,delt_in,c_in,q_in,r_in)

    integer, intent(in) :: ndim_in, np_in, nsp_in
    integer, intent(in) :: nxgs_in, nxge_in, nygs_in, nyge_in, nys_in, nye_in
    real(8), intent(in) :: delx_in, delt_in, c_in, q_in(nsp_in), r_in(nsp_in)

    ndim  = ndim_in
    np    = np_in
    nsp   = nsp_in
    nxgs  = nxgs_in
    nxge  = nxge_in
    nygs  = nygs_in
    nyge  = nyge_in
    nys   = nys_in
    nye   = nye_in
    delx  = delx_in
    delt  = delt_in
    c     = c_in
    allocate(q(nsp))
    allocate(r(nsp))
    q     = q_in
    r     = r_in
    d_delx = 1./delx

    is_init = .true.

  end subroutine particle__init

  subroutine particle__solv(gp,up,uf,cumcnt,nxs,nxe)

    integer, intent(in)  :: nxs, nxe
    integer, intent(in)  :: cumcnt(nxgs:nxge+1,nys:nye,nsp)
    real(8), intent(in)  :: up(ndim,np,nys:nye,nsp)
    real(8), intent(in)  :: uf(6,nxgs-2:nxge+2,nys-2:nye+2)
    real(8), intent(out) :: gp(ndim,np,nys:nye,nsp)

    integer :: i, j, ii, isp
    real(8) :: dh, sh(-1:1,2)
    real(8) :: fac1, fac2, txxx, fac1r, fac2r, gam, igam
    real(8) :: bpx, bpy, bpz, epx, epy, epz
    real(8) :: uvm1, uvm2, uvm3, uvm4, uvm5, uvm6
    real(8) :: tmp(1:6,nxs-1:nxe+1,nys-1:nye+1)

    if(.not.is_init)then
       write(6,*)'Initialize first by calling particle__init()'
       stop
    endif

    !fields at (i+1/2, j+1/2)
!$OMP PARALLEL DO PRIVATE(i,j)
    do j=nys-1,nye+1
    do i=nxs-1,nxe+1
       tmp(1,i,j) = 0.5*(+uf(1,i,j)+uf(1,i,j+1))
       tmp(2,i,j) = 0.5*(+uf(2,i,j)+uf(2,i+1,j))
       tmp(3,i,j) = 0.25*(+uf(3,i,j)  +uf(3,i+1,j) &
                          +uf(3,i,j+1)+uf(3,i+1,j+1))
       tmp(4,i,j) = 0.5*(+uf(4,i,j)+uf(4,i+1,j))
       tmp(5,i,j) = 0.5*(+uf(5,i,j)+uf(5,i,j+1))
       tmp(6,i,j) = uf(6,i,j)
    enddo
    enddo
!OMP END PARALLEL DO

!$OMP PARALLEL DO PRIVATE(ii,i,j,isp,sh,dh,gam,igam,fac1,fac2,txxx,fac1r,fac2r, &
!$OMP                     bpx,bpy,bpz,epx,epy,epz,uvm1,uvm2,uvm3,uvm4,uvm5,uvm6)
    do j=nys,nye
    do i=nxs,nxe

       isp=1

       fac1 = q(isp)/r(isp)*0.5*delt
       txxx = fac1*fac1
       fac2 = q(isp)*delt/r(isp)

       do ii=cumcnt(i,j,isp)+1,cumcnt(i+1,j,isp)

          !second order shape function
          dh = up(1,ii,j,isp)*d_delx-0.5-i
          sh(-1,1) = 0.5*(0.5-dh)*(0.5-dh)
          sh( 0,1) = 0.75-dh*dh
          sh(+1,1) = 0.5*(0.5+dh)*(0.5+dh)

          dh = up(2,ii,j,isp)*d_delx-0.5-j
          sh(-1,2) = 0.5*(0.5-dh)*(0.5-dh)
          sh( 0,2) = 0.75-dh*dh
          sh(+1,2) = 0.5*(0.5+dh)*(0.5+dh)

          bpx = +(+tmp(1,i-1,j-1)*sh(-1,1)+tmp(1,i,j-1)*sh(0,1)+tmp(1,i+1,j-1)*sh(+1,1))*sh(-1,2) &
                +(+tmp(1,i-1,j  )*sh(-1,1)+tmp(1,i,j  )*sh(0,1)+tmp(1,i+1,j  )*sh(+1,1))*sh( 0,2) &
                +(+tmp(1,i-1,j+1)*sh(-1,1)+tmp(1,i,j+1)*sh(0,1)+tmp(1,i+1,j+1)*sh(+1,1))*sh(+1,2)

          bpy = +(+tmp(2,i-1,j-1)*sh(-1,1)+tmp(2,i,j-1)*sh(0,1)+tmp(2,i+1,j-1)*sh(+1,1))*sh(-1,2) &
                +(+tmp(2,i-1,j  )*sh(-1,1)+tmp(2,i,j  )*sh(0,1)+tmp(2,i+1,j  )*sh(+1,1))*sh( 0,2) &
                +(+tmp(2,i-1,j+1)*sh(-1,1)+tmp(2,i,j+1)*sh(0,1)+tmp(2,i+1,j+1)*sh(+1,1))*sh(+1,2)

          bpz = +(+tmp(3,i-1,j-1)*sh(-1,1)+tmp(3,i,j-1)*sh(0,1)+tmp(3,i+1,j-1)*sh(+1,1))*sh(-1,2) &
                +(+tmp(3,i-1,j  )*sh(-1,1)+tmp(3,i,j  )*sh(0,1)+tmp(3,i+1,j  )*sh(+1,1))*sh( 0,2) &
                +(+tmp(3,i-1,j+1)*sh(-1,1)+tmp(3,i,j+1)*sh(0,1)+tmp(3,i+1,j+1)*sh(+1,1))*sh(+1,2)

          epx = +(+tmp(4,i-1,j-1)*sh(-1,1)+tmp(4,i,j-1)*sh(0,1)+tmp(4,i+1,j-1)*sh(+1,1))*sh(-1,2) &
                +(+tmp(4,i-1,j  )*sh(-1,1)+tmp(4,i,j  )*sh(0,1)+tmp(4,i+1,j  )*sh(+1,1))*sh( 0,2) &
                +(+tmp(4,i-1,j+1)*sh(-1,1)+tmp(4,i,j+1)*sh(0,1)+tmp(4,i+1,j+1)*sh(+1,1))*sh(+1,2)

          epy = +(+tmp(5,i-1,j-1)*sh(-1,1)+tmp(5,i,j-1)*sh(0,1)+tmp(5,i+1,j-1)*sh(+1,1))*sh(-1,2) &
                +(+tmp(5,i-1,j  )*sh(-1,1)+tmp(5,i,j  )*sh(0,1)+tmp(5,i+1,j  )*sh(+1,1))*sh( 0,2) &
                +(+tmp(5,i-1,j+1)*sh(-1,1)+tmp(5,i,j+1)*sh(0,1)+tmp(5,i+1,j+1)*sh(+1,1))*sh(+1,2)

          epz = +(+tmp(6,i-1,j-1)*sh(-1,1)+tmp(6,i,j-1)*sh(0,1)+tmp(6,i+1,j-1)*sh(+1,1))*sh(-1,2) &
                +(+tmp(6,i-1,j  )*sh(-1,1)+tmp(6,i,j  )*sh(0,1)+tmp(6,i+1,j  )*sh(+1,1))*sh( 0,2) &
                +(+tmp(6,i-1,j+1)*sh(-1,1)+tmp(6,i,j+1)*sh(0,1)+tmp(6,i+1,j+1)*sh(+1,1))*sh(+1,2)

          !accel.
          uvm1 = up(3,ii,j,isp)+fac1*epx
          uvm2 = up(4,ii,j,isp)+fac1*epy
          uvm3 = up(5,ii,j,isp)+fac1*epz

          !rotate
          gam = dsqrt(c*c+uvm1*uvm1+uvm2*uvm2+uvm3*uvm3)
          igam = 1./gam
          fac1r = fac1*igam
          fac2r = fac2/(gam+txxx*(bpx*bpx+bpy*bpy+bpz*bpz)*igam)

          uvm4 = uvm1+fac1r*(+uvm2*bpz-uvm3*bpy)
          uvm5 = uvm2+fac1r*(+uvm3*bpx-uvm1*bpz)
          uvm6 = uvm3+fac1r*(+uvm1*bpy-uvm2*bpx)

          uvm1 = uvm1+fac2r*(+uvm5*bpz-uvm6*bpy)
          uvm2 = uvm2+fac2r*(+uvm6*bpx-uvm4*bpz)
          uvm3 = uvm3+fac2r*(+uvm4*bpy-uvm5*bpx)

          !accel.
          gp(3,ii,j,isp) = uvm1+fac1*epx
          gp(4,ii,j,isp) = uvm2+fac1*epy
          gp(5,ii,j,isp) = uvm3+fac1*epz

          !move
          gam = 1./dsqrt(1.0+(+gp(3,ii,j,isp)*gp(3,ii,j,isp) &
                               +gp(4,ii,j,isp)*gp(4,ii,j,isp) &
                               +gp(5,ii,j,isp)*gp(5,ii,j,isp))/(c*c))

          gp(1,ii,j,isp) = up(1,ii,j,isp)+gp(3,ii,j,isp)*delt*gam
          gp(2,ii,j,isp) = up(2,ii,j,isp)+gp(4,ii,j,isp)*delt*gam

       enddo

       isp=2

       fac1 = q(isp)/r(isp)*0.5*delt
       txxx = fac1*fac1
       fac2 = q(isp)*delt/r(isp)

       do ii=cumcnt(i,j,isp)+1,cumcnt(i+1,j,isp)

          !second order shape function
          dh = up(1,ii,j,isp)*d_delx-0.5-i
          sh(-1,1) = 0.5*(0.5-dh)*(0.5-dh)
          sh( 0,1) = 0.75-dh*dh
          sh(+1,1) = 0.5*(0.5+dh)*(0.5+dh)

          dh = up(2,ii,j,isp)*d_delx-0.5-j
          sh(-1,2) = 0.5*(0.5-dh)*(0.5-dh)
          sh( 0,2) = 0.75-dh*dh
          sh(+1,2) = 0.5*(0.5+dh)*(0.5+dh)

          bpx = +(+tmp(1,i-1,j-1)*sh(-1,1)+tmp(1,i,j-1)*sh(0,1)+tmp(1,i+1,j-1)*sh(+1,1))*sh(-1,2) &
                +(+tmp(1,i-1,j  )*sh(-1,1)+tmp(1,i,j  )*sh(0,1)+tmp(1,i+1,j  )*sh(+1,1))*sh( 0,2) &
                +(+tmp(1,i-1,j+1)*sh(-1,1)+tmp(1,i,j+1)*sh(0,1)+tmp(1,i+1,j+1)*sh(+1,1))*sh(+1,2)

          bpy = +(+tmp(2,i-1,j-1)*sh(-1,1)+tmp(2,i,j-1)*sh(0,1)+tmp(2,i+1,j-1)*sh(+1,1))*sh(-1,2) &
                +(+tmp(2,i-1,j  )*sh(-1,1)+tmp(2,i,j  )*sh(0,1)+tmp(2,i+1,j  )*sh(+1,1))*sh( 0,2) &
                +(+tmp(2,i-1,j+1)*sh(-1,1)+tmp(2,i,j+1)*sh(0,1)+tmp(2,i+1,j+1)*sh(+1,1))*sh(+1,2)

          bpz = +(+tmp(3,i-1,j-1)*sh(-1,1)+tmp(3,i,j-1)*sh(0,1)+tmp(3,i+1,j-1)*sh(+1,1))*sh(-1,2) &
                +(+tmp(3,i-1,j  )*sh(-1,1)+tmp(3,i,j  )*sh(0,1)+tmp(3,i+1,j  )*sh(+1,1))*sh( 0,2) &
                +(+tmp(3,i-1,j+1)*sh(-1,1)+tmp(3,i,j+1)*sh(0,1)+tmp(3,i+1,j+1)*sh(+1,1))*sh(+1,2)

          epx = +(+tmp(4,i-1,j-1)*sh(-1,1)+tmp(4,i,j-1)*sh(0,1)+tmp(4,i+1,j-1)*sh(+1,1))*sh(-1,2) &
                +(+tmp(4,i-1,j  )*sh(-1,1)+tmp(4,i,j  )*sh(0,1)+tmp(4,i+1,j  )*sh(+1,1))*sh( 0,2) &
                +(+tmp(4,i-1,j+1)*sh(-1,1)+tmp(4,i,j+1)*sh(0,1)+tmp(4,i+1,j+1)*sh(+1,1))*sh(+1,2)

          epy = +(+tmp(5,i-1,j-1)*sh(-1,1)+tmp(5,i,j-1)*sh(0,1)+tmp(5,i+1,j-1)*sh(+1,1))*sh(-1,2) &
                +(+tmp(5,i-1,j  )*sh(-1,1)+tmp(5,i,j  )*sh(0,1)+tmp(5,i+1,j  )*sh(+1,1))*sh( 0,2) &
                +(+tmp(5,i-1,j+1)*sh(-1,1)+tmp(5,i,j+1)*sh(0,1)+tmp(5,i+1,j+1)*sh(+1,1))*sh(+1,2)

          epz = +(+tmp(6,i-1,j-1)*sh(-1,1)+tmp(6,i,j-1)*sh(0,1)+tmp(6,i+1,j-1)*sh(+1,1))*sh(-1,2) &
                +(+tmp(6,i-1,j  )*sh(-1,1)+tmp(6,i,j  )*sh(0,1)+tmp(6,i+1,j  )*sh(+1,1))*sh( 0,2) &
                +(+tmp(6,i-1,j+1)*sh(-1,1)+tmp(6,i,j+1)*sh(0,1)+tmp(6,i+1,j+1)*sh(+1,1))*sh(+1,2)

          !accel.
          uvm1 = up(3,ii,j,isp)+fac1*epx
          uvm2 = up(4,ii,j,isp)+fac1*epy
          uvm3 = up(5,ii,j,isp)+fac1*epz

          !rotate
          gam = dsqrt(c*c+uvm1*uvm1+uvm2*uvm2+uvm3*uvm3)
          igam = 1./gam
          fac1r = fac1*igam
          fac2r = fac2/(gam+txxx*(bpx*bpx+bpy*bpy+bpz*bpz)*igam)

          uvm4 = uvm1+fac1r*(+uvm2*bpz-uvm3*bpy)
          uvm5 = uvm2+fac1r*(+uvm3*bpx-uvm1*bpz)
          uvm6 = uvm3+fac1r*(+uvm1*bpy-uvm2*bpx)

          uvm1 = uvm1+fac2r*(+uvm5*bpz-uvm6*bpy)
          uvm2 = uvm2+fac2r*(+uvm6*bpx-uvm4*bpz)
          uvm3 = uvm3+fac2r*(+uvm4*bpy-uvm5*bpx)

          !accel.
          gp(3,ii,j,isp) = uvm1+fac1*epx
          gp(4,ii,j,isp) = uvm2+fac1*epy
          gp(5,ii,j,isp) = uvm3+fac1*epz

          !move
          gam = 1./dsqrt(1.0+(+gp(3,ii,j,isp)*gp(3,ii,j,isp) &
                              +gp(4,ii,j,isp)*gp(4,ii,j,isp) &
                              +gp(5,ii,j,isp)*gp(5,ii,j,isp))/(c*c))

          gp(1,ii,j,isp) = up(1,ii,j,isp)+gp(3,ii,j,isp)*delt*gam
          gp(2,ii,j,isp) = up(2,ii,j,isp)+gp(4,ii,j,isp)*delt*gam

       enddo

    enddo
    enddo
!$OMP END PARALLEL DO

    if(ndim == 6)then
!$OMP WORKSHARE
      gp(6,:,:,:) = up(6,:,:,:)
!$OMP END WORKSHARE
    endif

  end subroutine particle__solv

end module particle


      subroutine initwave(srelflg,r,pot,nr,nv,ist,l,energy,y,escale,
     &     core,b,allp1)
c
      implicit none
c
c---- mode flags:
c
      logical srelflg           ! scalar relativistic if true
      logical core              ! core full relativistic if true
c
c---- input:
c
      integer l                 ! angular momentum number
      complex*16 energy         ! energy
      integer nr,ist
      real*8 pot(nr)          ! potential
      real*8 r(2)          ! radial grid
      real*8 escale
      integer nv
c
c---- output:
c
      real*8 y(nv)
c
c The fine structure constant is taken from the 1986 recommended values
c of the fundamental physical constants, Physics Today August 1992.
c c is the speed of light in Hartree.
c It is half of the speed of light in Ryd unit,
c --- xgz
      real*8 c,c2
      parameter (c=137.0359895d0,c2=c*c)
c
c---- local variables:
c
      complex*16 v0,a2,a3
      complex*16 y1,y2
      real*8 z,z0,al,alp1,allp1,b,v1,a1,rl,x
      logical rel
c
c---- the following common block is used by initwave, to comunicate with
c     dfv. It is also used by psowave of the lkkr main code for
c     the same reasons.
c
!     common /dfbits/ b,allp1
!     save /dfbits/
c
      z0=pot(2)
      if(nr.eq.4) z0=z0+pot(nr)
      z0=dble(int(abs(z0)+0.1d0))
      z=escale*z0
      rel=srelflg
      if(z.lt.0.5d0) rel=.false.
      allp1=abs(l*(l+1))
      x=r(ist)
      if(rel) then
	if(core) then
        b=c
	  allp1=l
	v0=escale*(energy-pot(1))+c2
c----- full-relativistic initial conditions
	  al=sqrt(allp1*allp1-z*z/c2)
	  rl=x**al
	  a1=al+allp1
	  a2=(-2.d0*v0*z/c2+(c2+v0)*a1/z)/(2.d0*al+1.d0)
	  a3=(-2.d0*v0*a1+c2-v0)/(b*(2.d0*al+1.d0))
          y1=rl*(1.d0+a2*x)
	  y2=rl*(a1*b/z+a3*x)
	else
        b=0.25d0/c2
c
c----- semi-relativistic initial conditions
c
c    note starting values are different from the non-relativistic case
c    the ratio of r2/r1 at the first grid point is determined by
c    kh equation 15
c
        y1=1.0d0
        y2=2.0d0*c2*(sqrt(allp1+1.0d0-z*z/c2)-1.0d0)/z
	endif
      else
        b=0.0d0
c
c----- find taylor series for v-e = -z/r - v0 -v1r
c
	v0=escale*(energy-pot(1))
	v1=2.d0*escale*pot(2)*pot(3)
	v0=v0-0.5d0*v1*(r(1)+r(2))
        al=dfloat(l)
        alp1=al+1.0d0
        a1=-z/alp1
        a2=(-z*a1-v0)/(2.0d0*al+3.0d0)
        a3=-(-a1*(z*z-(3.0d0*al+4.0d0)*v0)+(2.0d0*al+3.0d0)*
     >             v1)/(3.0d0*(al+2.0d0)*(2.0d0*al+3.0d0))
        rl=x**al
        y1=(x*rl)*(1.0d0+x*(a1+x*(a2+x*a3)))
        y2=rl*(al+x*(alp1*a1+x*((al+2.0d0)*a2+x*(al+3.0d0)*a3)))
      endif
      if(nv.eq.2) then
	y(1)=dreal(y1)
	y(2)=dreal(y2)
      else
	y(1)=dreal(y1)
	y(2)=dimag(y1)
	y(3)=dreal(y2)
	y(4)=dimag(y2)
      endif
c
      return
      end


      SUBROUTINE FEER
C
C     DRIVER FOR THE FEER (FAST EIGENVALUE EXTRACTION ROUTINE) METHOD.
C     THIS ROUTINE WAS CALLED FCNTL BEFORE
C
C     GIVEN A REAL SYMETRIC MATRIX, FEER WILL SOLVE FOR THE EIGENVALUES
C     AND EIGENVECTORS AROUND THE CENTER OF INTEREST
C
C     DEFINITION OF INPUT AND OUTPUT PARAMETERS
C
C     IFKAA(7) = 101, MATRIX GINO BLOCK FOR THE INPUT STIFFNESS MATRIX K
C     IFMAA(7) = 102, MATRIX GINO BLOCK FOR THE INPUT MASS MATRIX M
C     IFLELM(7)= 201, MATRIX GINO BLOCK FOR THE OUTPUT EIGENVALUES
C     IFLVEC(7)= 202, MATRIX GINO BLOCK FOR THE OUTPUT EIGENVECTORS
C            ? = 203
C     DMPFLE   = 204, EIGENVALUE SUMMARY FILE
C     SR1FLE-SR8FLE = 301-308, SCRATCH FILES REQUIRED INTERNALLY
C     XLMBDA   =  INPUT, CENTER OF RANGE OF INTEREST.
C                 (USER SPECIFIED SHIFT)
C     NEIG     =  NUMBER OF DESIRED EIGENVALUES AROUND THE CENTER
C                 OF INTEREST. (EIGENVALUES SPECIFIED BY USER)
C     NORD     =  PROBLEM SIZE (SET INTERNALLY USING THE DIMENSION OF
C                 THE STIFFNESS MATRIX)
C     MORD     =  ORDER OF THE REDUCED PROBLEM (SET INTERNALLY)
C     NORTHO   =  NO. OF ORTHOGONAL VECTORS IN PRESENT SET (INCLUDE
C                 PREVISOUSLY COMPUTED VECTORS)
C     EPXM     =  ZERO MASS CRITERIA TO DETERMINE RANK
C     EPX      =  ORTHOGONALITY CONVERGENCE CRITERIA
C     IBK      =  BUCKLING OPTION INDICATOR (SET INTERNALLY)
C     CRITF    =  THE USER SPECIFIED (OR DEFAULT) DESIRED THEORETICAL
C                 ACCURACY OF THE EIGENVALUES EXPRESSED AS A PERCENTAGE
C     LAMBDA   =  VALUE OF THE SHIFT ACTUALLY USED (D.P.)
C     CNDFLG   =  TERMINATION INDICATOR
C     ITER     =  NO. OF STARTING POINTS USED
C     IOPTF    =  SPECIFIED SHIFT OPTION INDICATOR, SET INTERNALLY
C     NOCHNG   =  THEORETICAL ERROR PARAMETER
C     IFSET    =  INTERNALLY COMPUTED SHIFT INDICTOR
C     NONUL    =  NO. OF VETOR ITERATIONS
C     MRANK    =  MATRIX RANK OF THE PROBLEM
C     IND,LMBDA,IDAIG = NOT ACTIVEATED
C
C     EIGENVALUES AND EIGENVECTORS WILL BE STORED ON THE ACTUAL SR1FLE
C     AND SR2FLE. THE SELECTION OF ACCURATE EIGENVALUES AND VECTORS WILL
C     PUT THEM ON IFLELM AND IFLVEC IN THE CORRECT SEQUENCE AT THE END
C     OF PROCESSING
C
C     IFLELM        CONTAINS (K+LAMBDA*M) OR KAA
C     IFLVEC        CONTAINS THE LOWER TRIANGLE L OR C
C     SR4FLE        IS USED AS SCRATCH IN SDCOMP
C     SR5FLE        IS USED AS SCRATCH IN SDCOMP
C     SR6FLE        IS USED AS SCRATCH IN SDCOMP
C     SR7FLE        CONTAINS THE VECTORS WHICH ARE USED TO ORTHOGONALIZE
C     SR8FLE        CONTAINS THE CONTITIONED MAA MATRIX
C     IFLRVA = 301
C     IFLRVC = 302
C     MCBLT         LOWER TRAINGULAR MATRIX L CONTROL BLOCK
C     MCBSMA        CONTITIONED MASTRIX M CONTROL BLOCK
C     MCBVEC        ORTHOGONAL VECTOR FILE CONTROL BLOCK
C     MCBRM         TRIAL VECTOR V OR C(INVERSE-TRANSPOSE)*V CONTROL
C                   BLOCK
C
      INTEGER          SYSBUF    ,CNDFLG   ,SR8FLE   ,NAME(3)  ,
     1                 DMPFLE    ,IZ(12)   ,TIMED    ,STURM    ,
     2                 T1        ,T2       ,T3       ,TIMET    ,
     3                 MCB(7)    ,ICR(2)   ,JCR(2)
      DOUBLE PRECISION LAMBDA    ,LMBDA    ,DZ(1)    ,DRSN     ,
     1                 DRSM      ,EPXM     ,SCALE    ,DSM
      DIMENSION        TMT(4)    ,TML(4)
      CHARACTER        UFM*23    ,UWM*25   ,UIM*29
      COMMON  /XMSSG / UFM       ,UWM      ,UIM
      COMMON  /BLANK / IPROB(2)  ,NUMMOD   ,ICASE
      COMMON  /FEERCX/ IFKAA(7)  ,IFMAA(7) ,IFLELM(7),IFLVEC(7),
     1                 SR1FLE    ,SR2FLE   ,SR3FLE   ,SR4FLE   ,
     2                 SR5FLE    ,SR6FLE   ,SR7FLE   ,SR8FLE   ,
     3                 DMPFLE    ,NORD     ,XLMBDA   ,NEIG     ,
     4                 MORD      ,IBK      ,CRITF    ,NORTHO   ,
     5                 IFLRVA    ,IFLRVC
      COMMON  /FEERXX/ LAMBDA    ,CNDFLG   ,ITER     ,TIMED    ,
     1                 L16       ,IOPTF    ,EPX      ,NOCHNG   ,
     2                 IND       ,LMBDA    ,IFSET    ,NZERO    ,
     3                 NONUL     ,IDIAG    ,MRANK    ,ISTART   ,
     4                 NZ3
      COMMON  /REIGKR/ OPTION(2)
      COMMON  /ZZZZZZ/ Z(1)
      COMMON  /NTIME / LNTIME    ,TCONS(15)
      COMMON  /OPINV / MCBLT(7)  ,MCBSMA(7),MCBVEC(7),MCBRM(7)
      COMMON  /SYSTEM/ KSYSTM(65)
      COMMON  /PACKX / ITP1      ,ITP2     ,IIP      ,NNP      ,
     1                 INCRP
      COMMON  /UNPAKX/ IPRC      ,II       ,NN       ,INCR
      COMMON  /NAMES / RD        ,RDREW    ,WRT      ,WRTREW   ,
     1                 REW       ,NOREW    ,EOFNRW
      COMMON  /STURMX/ STURM     ,SHFTPT   ,KEEP(2)
      EQUIVALENCE      (IZ(1),Z(1),DZ(1))  ,(KSYSTM( 1),SYSBUF),
     1                 (KSYSTM(2),    IO)  ,(KSYSTM(55),IPREC ),
     2                 (TCONS(8) ,TMT(1))  ,(TCONS(12) ,TML(4)),
     3                 (KSYSTM(40), NBPW)
      DATA     NAME  / 4HFEER,2*2H   /     ,IBEGN/ 4HBEGN   /
      DATA     IEND  / 4HEND         /     ,MODE / 4HMODE   /
      DATA     I1,I2 , I3,I4,I0      /  1H1,1H2,1H3,1H4,1H  /
      DATA     ICR   / 4HPASS,4HFAIL /, JCR/4HFREQ,4HBUCK   /
C
C     SET PRECISION DIGITS TO 12, ALL MACHINES (NEW 1/92)
C
      IT  = 12
      EPX = 10.**(2-IT)
      DSM = 10.0D0**(-2*IT/3)
      NAME(3)  = IBEGN
      CALL CONMSG (NAME,3,0)
      CALL FEERDD
C
C     INITIALIZE FEERCX
C     DEFINITION OF INTERNAL PARAMETERS
C
      IBK   = 0
      IF (IPROB(1) .NE. MODE) IBK = 1
      IOPTF = IBK
      TIMED = 0
      TIMET = 0
      CALL SSWTCH (16,L16)
      IF (L16 .EQ. 1) WRITE (IO,10)
   10 FORMAT (//,' *** DIAG16 - ALL TERMS USED ARE DESCRIBED IN ',
     1       'PROGRAMMER MANUAL  P. 4.48-19I THRU K',/)
      LAMBDA = -XLMBDA
      IF (IBK    .EQ.   0) GO TO 40
      IF (XLMBDA .EQ. 0.0) GO TO 30
      CALL PAGE2 (3)
      WRITE  (IO,20) UWM
   20 FORMAT (A25,' 2388', /5X,'USER SPECIFIED RANGE NOT USED FOR FEER',
     1       ' BUCKLING. THE ROOTS OF LOWEST MAGNITUDE ARE OBTAINED')
   30 LAMBDA = 0.0D+0
   40 IFSET  = 0
      IF (XLMBDA.EQ.0. .AND. IBK.EQ.0) IFSET = 1
      IF (IFSET .EQ. 1) IOPTF = 1
      CNDFLG = 0
      NODCMP = 0
      CALL RDTRL (IFKAA(1))
      CALL RDTRL (IFMAA(1))
      IFK   = IFKAA(1)
      IFM   = IFMAA(1)
      IPRC  = IPREC
      NORD  = IFKAA(2)
      INCR  = 1
      INCRP = INCR
      ITP1  = IPRC
      ITP2  = IPRC
      NZ    = KORSZ(Z)
      IBUF1 = NZ    - SYSBUF
      IBUF2 = IBUF1 - SYSBUF
      NTOT  = IPRC*(5*NORD+1) + 4*SYSBUF - NZ
      IF (NTOT .GT. 0) CALL MESAGE (-8,NTOT,NAME)
      CALL KLOCK (ISTART)
      MRANK = 0
      CALL GOPEN  (IFM,Z(IBUF1),RDREW)
      CALL MAKMCB (MCB,SR8FLE,NORD,6,IPRC)
      CALL GOPEN  (SR8FLE,Z(IBUF2),WRTREW)
      MCB(2) = 0
      MCB(6) = 0
      IF (IPRC .EQ. 2) GO TO 90
      DO 80 J = 1,NORD
      II = 0
      CALL UNPACK (*60,IFM,Z(1))
      NT = NN - II + 1
      EPXM = 0.0D+0
      IF (II.LE.J .AND. NN.GE.J) EPXM = Z(J-II+1)*DSM
      NTZ = 0
      DO 50 JJ = 1,NT
      IF (ABS(Z(JJ)) .GT. EPXM) GO TO 50
      Z(JJ) = 0.
      NTZ   = NTZ + 1
   50 CONTINUE
      IF (NTZ .LT. NT) MRANK = MRANK + 1
      GO TO 70
   60 II  = 1
      NN  = 1
      NT  = 1
      Z(1)= 0.
   70 IIP = II
      NNP = NN
      CALL PACK (Z(1),SR8FLE,MCB(1))
   80 CONTINUE
      GO TO 140
   90 DO 130 J = 1,NORD
      II = 0
      CALL UNPACK (*110,IFM,DZ(1))
      NT = NN - II + 1
      EPXM = 0.0D+0
      IF (II.LE.J .AND. NN.GE.J) EPXM = DZ(J-II+1)*DSM
      NTZ = 0
      DO 100 JJ = 1,NT
      IF (DABS(DZ(JJ)) .GT. EPXM) GO TO 100
      DZ(JJ) = 0.0D+0
      NTZ = NTZ + 1
  100 CONTINUE
      IF (NTZ .LT. NT) MRANK = MRANK + 1
      GO TO 120
  110 II = 1
      NN = 1
      NT = 1
      DZ(1) = 0.0D+0
  120 IIP = II
      NNP = NN
      CALL PACK (DZ(1),SR8FLE,MCB(1))
  130 CONTINUE
  140 CALL WRTTRL (MCB)
      MORD = 2*(NEIG-NORTHO) + 10
      MRK  = MRANK - NORTHO
      NZERO= NORTHO
      IF (MORD .GT.   MRK) MORD = MRK
      IF (NEIG .LE. MRANK) GO TO 160
      CALL PAGE2 (3)
      WRITE  (IO,150) UWM
  150 FORMAT (A25,' 2385', /5X,'DESIRED NUMBER OF EIGENVALUES EXCEED ',
     1       'THE EXISTING NUMBER, ALL EIGENSOLUTIONS WILL BE SOUGHT.')
  160 CALL CLOSE (SR8FLE,NOREW)
      CALL CLOSE (IFM,REW)
      DO 170 I = 1,7
      MCBSMA(I) = MCB(I)
  170 IFMAA(I)  = MCBSMA(I)
      IFM = IFMAA(1)
      IF (IBK .EQ. 0) GO TO 180
C
C     SET UP TO DECOMPOSE KAA
C
      IFLELM(1) = IFKAA(1)
      GO TO 210
  180 IF (IFSET .EQ. 0) GO TO 200
C
C     CALCULATE INITIAL SHIFT
C
      CALL GOPEN (IFK,Z(IBUF1),RDREW)
      CALL GOPEN (IFM,Z(IBUF2),RDREW)
      CALL FRMAX (IFK,IFM,NORD,IPRC,DRSN,DRSM)
      CALL CLOSE (IFK,REW)
      CALL CLOSE (IFM,REW)
      SCALE  = DBLE(FLOAT(NORD))*10.0D0**(-IT)*DRSM
      LAMBDA = 10.0D0**(-IT/3)*DRSN
      IF (LAMBDA .LT. SCALE) LAMBDA = SCALE
C
C     CALL IN ADD LINK TO FORM  (K+LAMBDA*M)
C
  200 NAME(2) = I1
      CALL CONMSG (NAME,3,0)
      CALL FEER1
      NAME(3) = IEND
      CALL CONMSG (NAME,3,0)
C
C     CALL IN SDCOMP TO DECOMPOSE THIS MATRIX
C
  210 NODCMP  = NODCMP + 1
      SHFTPT  = DABS(LAMBDA)
      NAME(2) = I2
      NAME(3) = IBEGN
      CALL CONMSG (NAME,3,0)
      CALL FEER2 (ISING)
      NAME(3) = IEND
      CALL CONMSG (NAME,3,0)
      IK = IBK   + 1
      IJ = ISING + 1
      IF (ISING.NE.1 .AND. L16.EQ.0) GO TO 230
      CALL PAGE2 (4)
      WRITE  (IO,220) JCR(IK),NORD,MRANK,MORD,NORTHO,NEIG,NZERO,XLMBDA,
     1                LAMBDA,ICR(IJ)
  220 FORMAT ('0*** DIAG 16 OUTPUT FOR FEER ANALYSIS, OPTION =',A4, /5X,
     1       'ORDER =',I5,',  MAX RANK =',I5,',  REDUCED ORDER =',I5,
     2       ',  ORTH VCT =',I5,',  NEIG =',I4,',  NZERO =',I4, /5X,
     3       'USER SHIFT =',1P,E16.8,',  INTERNAL SHIFT =',D16.8,
     4       ',  SINGULARITY CHECK ',A4)
  230 IF (ISING .EQ. 0) GO TO 300
C
C     SINGULAR MATRIX. ADJUST LAMBDA
C
      IF (IBK .EQ. 1) GO TO 500
      CNDFLG = CNDFLG + 1
      IF (NODCMP .EQ. 3) GO TO 520
      LAMBDA = 100.0D0*LAMBDA
      GO TO 200
C
C     DETERMINE THE TIME REQUIRED TO COMPLETE FEER PROCESS
C
  300 CALL TMTOGO (T1)
      XM  = MORD
      XMP = NORTHO
      XN  = NORD
      XI  = IFSET
      IFL = MCBLT(1)
      CALL GOPEN (IFL,Z(IBUF1),RDREW)
      NTMS = 0
      DO 310 I = 1,NORD
      II = 0
      CALL UNPACK (*310,IFL,Z(1))
      NTMS = NTMS + NN - II + 1
  310 CONTINUE
      CALL CLOSE (IFL,REW)
      XT = NTMS
      SP = (XT*(1.-XI)*(XM+XMP)+2.*XM) + XN*(2.+XI)*.5*(3.*XM**2+2.*XMP)
     1   + (16.+11.*XI*.5)*XN*XM + 14.*XM**2
C
C     OBTAIN TRIDIAGONAL REDUCTION
C
      NAME(2) = I3
      NAME(3) = IBEGN
      CALL CONMSG (NAME,3,0)
      CALL FEER3
      NAME(3) = IEND
      CALL CONMSG (NAME,3,0)
      IF (CNDFLG .NE. 3) GO TO 330
      CALL PAGE2 (3)
      WRITE  (IO,320) UWM
  320 FORMAT (A25,' 2389', /5X,'PROBLEM SIZE REDUCED - NO MORE TRIAL ',
     1       'VECTORS CAN BE OBTAINED.')
  330 IF (MORD .EQ. 0) GO TO 350
      CALL TMTOGO (T2)
      TIMET = T3 - T1
C
C     OBTAIN EIGENVALUES AND EIGENVECTORS
C
      NAME(2) = I4
      NAME(3) = IBEGN
      CALL CONMSG (NAME,3,0)
      CALL FEER4 (IT)
      NAME(3) = IEND
      CALL CONMSG (NAME,3,0)
      CALL TMTOGO (T3)
      IF (L16 .NE. 0) WRITE (IO,340) T1,T2,T3,SP
  340 FORMAT (' FEER COMPLETE,  T1,T2,T3 =',3I9,',  SP = ',1P,E16.8)
      IF (CNDFLG .NE. 4) GO TO 370
  350 WRITE  (IO,360) UFM
  360 FORMAT (A23,' 2391, PROGRAM LOGIC ERROR IN FEER')
      GO TO 540
  370 IF (MORD+NZERO .GE. NEIG) GO TO 390
      NPR = NEIG - MORD - NZERO
      CALL PAGE2 (3)
      WRITE  (IO,380) UWM,NPR,NEIG
  380 FORMAT (A25,' 2390', /4X,I5,' FEWER ACCURATE EIGENSOLUTIONS THAN',
     1       ' THE',I5,' REQUESTED HAVE BEEN FOUND.')
      CNDFLG = 1
      GO TO 420
  390 IF (MORD+NZERO .EQ. NEIG) GO TO 420
      NPR = MORD + NZERO - NEIG
      CALL PAGE2 (3)
      WRITE  (IO,400) UIM,NPR,NEIG
  400 FORMAT (A29,' 2392', /4X,I5,' MORE ACCURATE EIGENSOLUTIONS THAN ',
     1       'THE',I5,' REQUESTED HAVE BEEN FOUND.')
      IF (L16 .EQ. 0) WRITE (IO,410)
  410 FORMAT (5X,'USE DIAG 16 TO DETERMINE ERROR BOUNDS')
  420 CALL GOPEN (DMPFLE,Z(IBUF1),WRTREW)
C
C    SET IZ(1) TO 2 (FOR INVPWR) THEN IZ(7) TO 1 (POINTS TO FEER METHOD)
C
      IZ(1) = 2
      IZ(2) = MORD + NZERO
      IZ(3) = ITER
      IZ(4) = 0
      IZ(5) = NODCMP
      IZ(6) = NONUL
      IZ(7) = 1
      IZ(8) = CNDFLG
      IZ(9) = 0
      IZ(10)= 0
      IZ(11)= 0
      IZ(12)= 0
      CALL WRITE (DMPFLE,IZ,12,1)
      CALL CLOSE (DMPFLE,REW)
      CRITF = XN*10.0**(-IT)
      NAME(2) = I0
      CALL CONMSG (NAME,3,0)
      RETURN
C
  500 WRITE  (IO,510) UFM
  510 FORMAT (A23,' 2436, SINGULAR MATRIX IN FEER BUCKLING SOLUTION.')
      GO TO 540
  520 WRITE  (IO,530) UFM
  530 FORMAT (A23,' 2386', /5X,'STIFFNESS MATRIX SINGULARITY CANNOT BE',
     1       ' REMOVED BY SHIFTING.')
  540 CALL MESAGE (-37,0,NAME)
      RETURN
      END


!	Find individual residuals for weighted sums.
!	catobsrange provides ranges of underlying item categories that correspond to
!	choices provides number of choices per item.
!	distmap connects distractors to item scores.
!   observed item categories.
!	Response scores are in dat.
!	Raw responses are in distdat.
!	numcat provides ranges for underlying observations.
!	numcatobs provides ranges for observed scores.
!	beta is the parameter vector.
!	distprob gives conditional distractor probabilities.
!	lintran is the linear transformation for the latent vector.
!	postdensity contains posterior weights.
!	theta contains posterior quadrature points.
!	wtsumdist is a matrix used to compute linear combinations of the observations.

!   covreswtdist is the estimated covariance matrix of reswtdist.
!   fitwtdist is the estimated mean of the weighted sum.
!   obswtdist is the observed weighted sum.

!   reswtdist is the raw individual residual for the weighted sum.
!   sdreswtdist is the estimated standard error of the elements of reswtdist.
!   zreswtdist is the ratio of elements of reswtdist and sdreswtdist.

subroutine reswtsumdist(catobsrange,choices,dat,distdat,distmap,numcat,numcatobs,beta,&
	distprob,lintran,postdensity,theta,wtsumdist,&
    covreswtdist,fitwtdist,obswtdist,reswtdist,sdreswtdist,zreswtdist)
implicit none
interface

!	Multinomial covariance matrix.
!	density is vector of probabilities.
!	meanth is vector of means.
!	quadpoint is array of weights.
    function mcovth(density,meanth,quadpoint)
        implicit none
        real(kind=8),intent(in)::density(:),meanth(:),quadpoint(:,:)
        real(kind=8)::mcovth(size(meanth),size(meanth))
    end function mcovth
!	Multinomial mean.
!	density is vector of probabilities
!	quadpoint is array of weights.
    function mmeanth(density,quadpoint)
        implicit none
        real(kind=8),intent(in)::density(:),quadpoint(:,:)
        real(kind=8)::mmeanth(size(quadpoint,1))
    end function mmeanth
!	probvec is used to compute underlying item probabilities.
!   numcat indicates the number of underlying categories per item.
!	mask indicates which items were presented.
!	locations provides location parameters and scales provides scale factors.
!	theta is the value of the latent vector.
    function probvec(numcat,mask,locations,scales,theta)
        implicit none
        integer,intent(in)::numcat(:)
        logical,intent(in)::mask(:)
        real(kind=8),intent(in)::locations(:),scales(:,:),theta(:)
        real(kind=8)::probvec(size(locations))
    end function probvec
!	probvecobsall is used to compute observed item probabilities given the latent vector.
!	catobsrange is the table of ranges of underlying categories per observed category.
!	numcat provides the number of underlying categories per item, and numcatobs provides the number
!		of observed categories per item.
!	mask indicates which items were presented.
!	probcat is the vector of underlying item probabilities.
	function probvecobsall(catobsrange,numcatobs,mask,probcat)
		implicit none
		integer,intent(in)::catobsrange(:,:),numcatobs(:)
		logical,intent(in)::mask(:)
		real(kind=8),intent(in)::probcat(:)
		real(kind=8)::probvecobsall(sum(numcatobs))
	end function probvecobsall

!	probvecobsdist is used to compute observed item distractor probabilities given the latent vector.
!	choices is the number of choices per item.
!	numcatobs provides the number of observed categories per item.
!	mask indicates which items were presented.
!	distprob provides distractor probabilities.
!	probcatobs is the vector of item probabilities.
    function probvecobsdist(choices,distmap,numcatobs,mask,distprob,probcatobs)
        implicit none

        integer,intent(in)::choices(:),distmap(:),numcatobs(:)
        logical,intent(in)::mask(:)
        real(kind=8),intent(in)::distprob(:),probcatobs(:)
        real(kind=8)::probvecobsdist(sum(choices))
    end function probvecobsdist
end interface
integer,intent(in)::catobsrange(:,:),choices(:),dat(:,:),distdat(:,:),distmap(:),numcat(:),numcatobs(:)

real(kind=8),intent(in)::beta(:),distprob(:),lintran(:,:),postdensity(:,:),theta(:,:,:),wtsumdist(:,:)
real(kind=8),intent(out)::covreswtdist(:,:,:),fitwtdist(:,:),obswtdist(:,:),reswtdist(:,:),sdreswtdist(:,:),zreswtdist(:,:)
!	item is an item.
!	ncat is the total number of underlying categories.
!	obs is observation number.
!   quad counts quadrature points.
!	resp is a single response.
!	respdist is a single distractor response.
!	row is a row counter.

integer::item,ncat,obs,quad,resp(size(numcatobs)),respdist(size(choices)),row
!   datamask is for identification of item responses for observations.
logical::datamask(size(choices))

!   covar is the covariance matrix of the differences of observed and duplicate sums.
!   covquad is the covariance matrix of sums given the latent vector.
!   covquaditem is the covariance matrix of weighted sums for items given the latent vector.

!	locations is for location parameters.

!	meanquad is for means for quadrature points.

!	newtheta is lintran(theta).
!	probcat is used for underlying marginal conditional probabilities.
!   probcatobs is used for marginal conditional probabilities of observations.
!	probcatobsdist is used for marginal conditional probabilities of original observations.
!	scales is for scale parameters.

real(kind=8)::covar(size(wtsumdist,1),size(wtsumdist,1))
real(kind=8)::covquad(size(wtsumdist,1),size(wtsumdist,1),size(postdensity,1)),&
    covquaditem(size(wtsumdist,1),size(wtsumdist,1),size(numcatobs),size(postdensity,1))
real(kind=8)::locations(sum(numcat))
real(kind=8)::meanquad(size(wtsumdist,1),size(postdensity,1)),meanquaditem(size(wtsumdist,1),size(numcatobs),size(postdensity,1))
real(kind=8)::newtheta(size(lintran,1))

real(kind=8)::probcat(sum(numcat)),probcatobs(sum(numcatobs)),probcatobsdist(sum(choices))
real(kind=8)::scales(size(lintran,1),sum(numcat))

!	Set up parameter arrays for simplified processing.
ncat=sum(numcat)
!	Item scale parameters.
locations=beta(1:ncat)
scales=reshape(beta(ncat+1:ncat*(1+size(lintran,1))),(/size(lintran,1),ncat/))

covar=0.0_8
covquad=0.0_8
covquaditem=0.0_8

covreswtdist=0.0_8
fitwtdist=0.0_8
obswtdist=0.0_8

reswtdist=0.0_8
sdreswtdist=0.0_8
zreswtdist=0.0_8

!	Obtain results for each observation.
obsloop:do obs=1,size(postdensity,2)

    resp=dat(:,obs)
	respdist=distdat(:,obs)

    datamask=.false.
    do item=1,size(numcat)
        if(resp(item)>=0.and.resp(item)<numcatobs(item))datamask(item)=.true.
    end do

!	Cycle through quadrature points.
    covar=0.0_8
    covquad=0.0_8
    covquaditem=0.0_8

    meanquad=0.0_8
    meanquaditem=0.0_8

    do quad=1,size(postdensity,1)
        newtheta=matmul(lintran,theta(:,quad,obs))

! Probability computation.

        probcat=probvec(numcat,datamask,locations,scales,newtheta)
        probcatobs=probvecobsall(catobsrange,numcatobs,datamask,probcat)

		probcatobsdist=probvecobsdist(choices,distmap,numcatobs,datamask,distprob,probcatobs)

        if(size(wtsumdist,1)>0)then
            row=1

            do item=1,size(choices)
                if(.not.datamask(item).and.any(wtsumdist(:,row:row+choices(item)-1)/=0.0_8))&
                    cycle obsloop
                if(datamask(item)) then

                    meanquaditem(:,item,quad)=mmeanth(probcatobsdist(row:row+choices(item)-1),wtsumdist(:,row:row+choices(item)-1))
                    meanquad(:,quad)=meanquad(:,quad)+meanquaditem(:,item,quad)
                    covquaditem(:,:,item,quad)=&
                        mcovth(probcatobsdist(row:row+choices(item)-1),meanquaditem(:,item,quad),&
                        wtsumdist(:,row:row+choices(item)-1))

                    covquad(:,:,quad)=covquad(:,:,quad)+covquaditem(:,:,item,quad)
                    if(quad==1)obswtdist(:,obs)=obswtdist(:,obs)+wtsumdist(:,row+respdist(item))

				end if
                row=row+choices(item)
            end do
            covar=covar+postdensity(quad,obs)*covquad(:,:,quad)

        end if
    end do

!	mean and covariance.

    fitwtdist(:,obs)=mmeanth(postdensity(:,obs),meanquad)

    reswtdist(:,obs)=obswtdist(:,obs)-fitwtdist(:,obs)

    covreswtdist(:,:,obs)=mcovth(postdensity(:,obs),fitwtdist(:,obs),meanquad)+covar
    do row=1,size(wtsumdist,1)
        sdreswtdist(row,obs)=sqrt(covreswtdist(row,row,obs))
        if(sdreswtdist(row,obs)>0.0_8)zreswtdist(row,obs)=reswtdist(row,obs)/sdreswtdist(row,obs)
    end do
end do obsloop
return
end subroutine reswtsumdist


      SUBROUTINE SLALS0( ICOMPQ, NL, NR, SQRE, NRHS, B, LDB, BX, LDBX,
     $                   PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM,
     $                   POLES, DIFL, DIFR, Z, K, C, S, WORK, INFO )
*
*  -- LAPACK routine (version 3.1) --
*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
*     November 2006
*
*     .. Scalar Arguments ..
      INTEGER            GIVPTR, ICOMPQ, INFO, K, LDB, LDBX, LDGCOL,
     $                   LDGNUM, NL, NR, NRHS, SQRE
      REAL               C, S
*     ..
*     .. Array Arguments ..
      INTEGER            GIVCOL( LDGCOL, * ), PERM( * )
      REAL               B( LDB, * ), BX( LDBX, * ), DIFL( * ),
     $                   DIFR( LDGNUM, * ), GIVNUM( LDGNUM, * ),
     $                   POLES( LDGNUM, * ), WORK( * ), Z( * )
*     ..
*
*  Purpose
*  =======
*
*  SLALS0 applies back the multiplying factors of either the left or the
*  right singular vector matrix of a diagonal matrix appended by a row
*  to the right hand side matrix B in solving the least squares problem
*  using the divide-and-conquer SVD approach.
*
*  For the left singular vector matrix, three types of orthogonal
*  matrices are involved:
*
*  (1L) Givens rotations: the number of such rotations is GIVPTR; the
*       pairs of columns/rows they were applied to are stored in GIVCOL;
*       and the C- and S-values of these rotations are stored in GIVNUM.
*
*  (2L) Permutation. The (NL+1)-st row of B is to be moved to the first
*       row, and for J=2:N, PERM(J)-th row of B is to be moved to the
*       J-th row.
*
*  (3L) The left singular vector matrix of the remaining matrix.
*
*  For the right singular vector matrix, four types of orthogonal
*  matrices are involved:
*
*  (1R) The right singular vector matrix of the remaining matrix.
*
*  (2R) If SQRE = 1, one extra Givens rotation to generate the right
*       null space.
*
*  (3R) The inverse transformation of (2L).
*
*  (4R) The inverse transformation of (1L).
*
*  Arguments
*  =========
*
*  ICOMPQ (input) INTEGER
*         Specifies whether singular vectors are to be computed in
*         factored form:
*         = 0: Left singular vector matrix.
*         = 1: Right singular vector matrix.
*
*  NL     (input) INTEGER
*         The row dimension of the upper block. NL >= 1.
*
*  NR     (input) INTEGER
*         The row dimension of the lower block. NR >= 1.
*
*  SQRE   (input) INTEGER
*         = 0: the lower block is an NR-by-NR square matrix.
*         = 1: the lower block is an NR-by-(NR+1) rectangular matrix.
*
*         The bidiagonal matrix has row dimension N = NL + NR + 1,
*         and column dimension M = N + SQRE.
*
*  NRHS   (input) INTEGER
*         The number of columns of B and BX. NRHS must be at least 1.
*
*  B      (input/output) REAL array, dimension ( LDB, NRHS )
*         On input, B contains the right hand sides of the least
*         squares problem in rows 1 through M. On output, B contains
*         the solution X in rows 1 through N.
*
*  LDB    (input) INTEGER
*         The leading dimension of B. LDB must be at least
*         max(1,MAX( M, N ) ).
*
*  BX     (workspace) REAL array, dimension ( LDBX, NRHS )
*
*  LDBX   (input) INTEGER
*         The leading dimension of BX.
*
*  PERM   (input) INTEGER array, dimension ( N )
*         The permutations (from deflation and sorting) applied
*         to the two blocks.
*
*  GIVPTR (input) INTEGER
*         The number of Givens rotations which took place in this
*         subproblem.
*
*  GIVCOL (input) INTEGER array, dimension ( LDGCOL, 2 )
*         Each pair of numbers indicates a pair of rows/columns
*         involved in a Givens rotation.
*
*  LDGCOL (input) INTEGER
*         The leading dimension of GIVCOL, must be at least N.
*
*  GIVNUM (input) REAL array, dimension ( LDGNUM, 2 )
*         Each number indicates the C or S value used in the
*         corresponding Givens rotation.
*
*  LDGNUM (input) INTEGER
*         The leading dimension of arrays DIFR, POLES and
*         GIVNUM, must be at least K.
*
*  POLES  (input) REAL array, dimension ( LDGNUM, 2 )
*         On entry, POLES(1:K, 1) contains the new singular
*         values obtained from solving the secular equation, and
*         POLES(1:K, 2) is an array containing the poles in the secular
*         equation.
*
*  DIFL   (input) REAL array, dimension ( K ).
*         On entry, DIFL(I) is the distance between I-th updated
*         (undeflated) singular value and the I-th (undeflated) old
*         singular value.
*
*  DIFR   (input) REAL array, dimension ( LDGNUM, 2 ).
*         On entry, DIFR(I, 1) contains the distances between I-th
*         updated (undeflated) singular value and the I+1-th
*         (undeflated) old singular value. And DIFR(I, 2) is the
*         normalizing factor for the I-th right singular vector.
*
*  Z      (input) REAL array, dimension ( K )
*         Contain the components of the deflation-adjusted updating row
*         vector.
*
*  K      (input) INTEGER
*         Contains the dimension of the non-deflated matrix,
*         This is the order of the related secular equation. 1 <= K <=N.
*
*  C      (input) REAL
*         C contains garbage if SQRE =0 and the C-value of a Givens
*         rotation related to the right null space if SQRE = 1.
*
*  S      (input) REAL
*         S contains garbage if SQRE =0 and the S-value of a Givens
*         rotation related to the right null space if SQRE = 1.
*
*  WORK   (workspace) REAL array, dimension ( K )
*
*  INFO   (output) INTEGER
*          = 0:  successful exit.
*          < 0:  if INFO = -i, the i-th argument had an illegal value.
*
*  Further Details
*  ===============
*
*  Based on contributions by
*     Ming Gu and Ren-Cang Li, Computer Science Division, University of
*       California at Berkeley, USA
*     Osni Marques, LBNL/NERSC, USA
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ONE, ZERO, NEGONE
      PARAMETER          ( ONE = 1.0E0, ZERO = 0.0E0, NEGONE = -1.0E0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I, J, M, N, NLP1
      REAL               DIFLJ, DIFRJ, DJ, DSIGJ, DSIGJP, TEMP
*     ..
*     .. External Subroutines ..
      EXTERNAL           SCOPY, SGEMV, SLACPY, SLASCL, SROT, SSCAL,
     $                   XERBLA
*     ..
*     .. External Functions ..
      REAL               SLAMC3, SNRM2
      EXTERNAL           SLAMC3, SNRM2
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      INFO = 0
*
      IF( ( ICOMPQ.LT.0 ) .OR. ( ICOMPQ.GT.1 ) ) THEN
         INFO = -1
      ELSE IF( NL.LT.1 ) THEN
         INFO = -2
      ELSE IF( NR.LT.1 ) THEN
         INFO = -3
      ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN
         INFO = -4
      END IF
*
      N = NL + NR + 1
*
      IF( NRHS.LT.1 ) THEN
         INFO = -5
      ELSE IF( LDB.LT.N ) THEN
         INFO = -7
      ELSE IF( LDBX.LT.N ) THEN
         INFO = -9
      ELSE IF( GIVPTR.LT.0 ) THEN
         INFO = -11
      ELSE IF( LDGCOL.LT.N ) THEN
         INFO = -13
      ELSE IF( LDGNUM.LT.N ) THEN
         INFO = -15
      ELSE IF( K.LT.1 ) THEN
         INFO = -20
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'SLALS0', -INFO )
         RETURN
      END IF
*
      M = N + SQRE
      NLP1 = NL + 1
*
      IF( ICOMPQ.EQ.0 ) THEN
*
*        Apply back orthogonal transformations from the left.
*
*        Step (1L): apply back the Givens rotations performed.
*
         DO 10 I = 1, GIVPTR
            CALL SROT( NRHS, B( GIVCOL( I, 2 ), 1 ), LDB,
     $                 B( GIVCOL( I, 1 ), 1 ), LDB, GIVNUM( I, 2 ),
     $                 GIVNUM( I, 1 ) )
   10    CONTINUE
*
*        Step (2L): permute rows of B.
*
         CALL SCOPY( NRHS, B( NLP1, 1 ), LDB, BX( 1, 1 ), LDBX )
         DO 20 I = 2, N
            CALL SCOPY( NRHS, B( PERM( I ), 1 ), LDB, BX( I, 1 ), LDBX )
   20    CONTINUE
*
*        Step (3L): apply the inverse of the left singular vector
*        matrix to BX.
*
         IF( K.EQ.1 ) THEN
            CALL SCOPY( NRHS, BX, LDBX, B, LDB )
            IF( Z( 1 ).LT.ZERO ) THEN
               CALL SSCAL( NRHS, NEGONE, B, LDB )
            END IF
         ELSE
            DO 50 J = 1, K
               DIFLJ = DIFL( J )
               DJ = POLES( J, 1 )
               DSIGJ = -POLES( J, 2 )
               IF( J.LT.K ) THEN
                  DIFRJ = -DIFR( J, 1 )
                  DSIGJP = -POLES( J+1, 2 )
               END IF
               IF( ( Z( J ).EQ.ZERO ) .OR. ( POLES( J, 2 ).EQ.ZERO ) )
     $              THEN
                  WORK( J ) = ZERO
               ELSE
                  WORK( J ) = -POLES( J, 2 )*Z( J ) / DIFLJ /
     $                        ( POLES( J, 2 )+DJ )
               END IF
               DO 30 I = 1, J - 1
                  IF( ( Z( I ).EQ.ZERO ) .OR.
     $                ( POLES( I, 2 ).EQ.ZERO ) ) THEN
                     WORK( I ) = ZERO
                  ELSE
                     WORK( I ) = POLES( I, 2 )*Z( I ) /
     $                           ( SLAMC3( POLES( I, 2 ), DSIGJ )-
     $                           DIFLJ ) / ( POLES( I, 2 )+DJ )
                  END IF
   30          CONTINUE
               DO 40 I = J + 1, K
                  IF( ( Z( I ).EQ.ZERO ) .OR.
     $                ( POLES( I, 2 ).EQ.ZERO ) ) THEN
                     WORK( I ) = ZERO
                  ELSE
                     WORK( I ) = POLES( I, 2 )*Z( I ) /
     $                           ( SLAMC3( POLES( I, 2 ), DSIGJP )+
     $                           DIFRJ ) / ( POLES( I, 2 )+DJ )
                  END IF
   40          CONTINUE
               WORK( 1 ) = NEGONE
               TEMP = SNRM2( K, WORK, 1 )
               CALL SGEMV( 'T', K, NRHS, ONE, BX, LDBX, WORK, 1, ZERO,
     $                     B( J, 1 ), LDB )
               CALL SLASCL( 'G', 0, 0, TEMP, ONE, 1, NRHS, B( J, 1 ),
     $                      LDB, INFO )
   50       CONTINUE
         END IF
*
*        Move the deflated rows of BX to B also.
*
         IF( K.LT.MAX( M, N ) )
     $      CALL SLACPY( 'A', N-K, NRHS, BX( K+1, 1 ), LDBX,
     $                   B( K+1, 1 ), LDB )
      ELSE
*
*        Apply back the right orthogonal transformations.
*
*        Step (1R): apply back the new right singular vector matrix
*        to B.
*
         IF( K.EQ.1 ) THEN
            CALL SCOPY( NRHS, B, LDB, BX, LDBX )
         ELSE
            DO 80 J = 1, K
               DSIGJ = POLES( J, 2 )
               IF( Z( J ).EQ.ZERO ) THEN
                  WORK( J ) = ZERO
               ELSE
                  WORK( J ) = -Z( J ) / DIFL( J ) /
     $                        ( DSIGJ+POLES( J, 1 ) ) / DIFR( J, 2 )
               END IF
               DO 60 I = 1, J - 1
                  IF( Z( J ).EQ.ZERO ) THEN
                     WORK( I ) = ZERO
                  ELSE
                     WORK( I ) = Z( J ) / ( SLAMC3( DSIGJ, -POLES( I+1,
     $                           2 ) )-DIFR( I, 1 ) ) /
     $                           ( DSIGJ+POLES( I, 1 ) ) / DIFR( I, 2 )
                  END IF
   60          CONTINUE
               DO 70 I = J + 1, K
                  IF( Z( J ).EQ.ZERO ) THEN
                     WORK( I ) = ZERO
                  ELSE
                     WORK( I ) = Z( J ) / ( SLAMC3( DSIGJ, -POLES( I,
     $                           2 ) )-DIFL( I ) ) /
     $                           ( DSIGJ+POLES( I, 1 ) ) / DIFR( I, 2 )
                  END IF
   70          CONTINUE
               CALL SGEMV( 'T', K, NRHS, ONE, B, LDB, WORK, 1, ZERO,
     $                     BX( J, 1 ), LDBX )
   80       CONTINUE
         END IF
*
*        Step (2R): if SQRE = 1, apply back the rotation that is
*        related to the right null space of the subproblem.
*
         IF( SQRE.EQ.1 ) THEN
            CALL SCOPY( NRHS, B( M, 1 ), LDB, BX( M, 1 ), LDBX )
            CALL SROT( NRHS, BX( 1, 1 ), LDBX, BX( M, 1 ), LDBX, C, S )
         END IF
         IF( K.LT.MAX( M, N ) )
     $      CALL SLACPY( 'A', N-K, NRHS, B( K+1, 1 ), LDB, BX( K+1, 1 ),
     $                   LDBX )
*
*        Step (3R): permute rows of B.
*
         CALL SCOPY( NRHS, BX( 1, 1 ), LDBX, B( NLP1, 1 ), LDB )
         IF( SQRE.EQ.1 ) THEN
            CALL SCOPY( NRHS, BX( M, 1 ), LDBX, B( M, 1 ), LDB )
         END IF
         DO 90 I = 2, N
            CALL SCOPY( NRHS, BX( I, 1 ), LDBX, B( PERM( I ), 1 ), LDB )
   90    CONTINUE
*
*        Step (4R): apply back the Givens rotations performed.
*
         DO 100 I = GIVPTR, 1, -1
            CALL SROT( NRHS, B( GIVCOL( I, 2 ), 1 ), LDB,
     $                 B( GIVCOL( I, 1 ), 1 ), LDB, GIVNUM( I, 2 ),
     $                 -GIVNUM( I, 1 ) )
  100    CONTINUE
      END IF
*
      RETURN
*
*     End of SLALS0
*
      END


SUBROUTINE BuildLinearSystem(Nx,Ny,Nz,PHI,output,GridStruct,alpha,beta,gamma)
! By Allan P. Engsig-Karup.
!
! Form: output = A PHI
!
! where A is the system matrix and phi the current guess
!
USE Precision
USE Constants
USE DataTypes
USE GlobalVariables, ONLY: GhostGridX, GhostGridY, GhostGridZ, &
	swenseONOFF, Wavefield, Uneumann,IncWaveType ! FIXME: Wavefield is a problem here?? due to Multigrid algorithm
IMPLICIT NONE
TYPE (Level_def), INTENT(IN) :: GridStruct
INTEGER::Gidx, Gidx2, Nx, Ny, Nz, i, j, k, alpha, beta, gamma
REAL(KIND=long), DIMENSION(Nx*Ny*Nz), INTENT(OUT) :: output
REAL(KIND=long), DIMENSION(Nx*Ny*Nz) :: dpdy, ddpdyy, dpdx, ddpdxx, dpds, ddpdsdx, ddpdsdy, ddpdss, tmp !GD: addition for cross derivatives
REAL(KIND=long), DIMENSION(Nx*Ny*Nz), INTENT(IN) :: PHI
!
INTEGER :: Gidx3 !Index to look for boundaries

!print*,'PHI=',PHI
!read*

Gidx3  = 1
Gidx   = 0
output = zero

! Determine derivatives explicitly
IF (Nx>1) THEN
	CALL DiffXEven(PHI,dpdx,1,Nx,Ny,Nz,GridStruct%DiffStencils,alpha)
	CALL DiffXEven(PHI,ddpdxx,2,Nx,Ny,Nz,GridStruct%DiffStencils,alpha)
    ! DISCRETIZATION CHOICE MADE HERE FOR MIXED DERIVATIVE
	!CALL DiffZArbitrary(dpdx,ddpdsdx,1,Nx,Ny,Nz,GridStruct%DiffStencils,gamma)
    !GD: modification for correct treatment of cross derivatives...
    CALL DiffXEven_CD(PHI,tmp,GridStruct%DiffStencils%IndexesX_XZorXY(:,:,:,:,1),&
    	GridStruct%DiffStencils%StencilsX_XZorXY(:,:,:,:,1),Nx,Ny,Nz,alpha)
    CALL DiffZArbitrary_CD(tmp,ddpdsdx,GridStruct%DiffStencils%IndexesZ_XZorYZ(:,:,:,:,1),&
    	GridStruct%DiffStencils%StencilsZ_XZorYZ(:,:,:,:,1),Nx,Ny,Nz,gamma)
ENDIF

IF (Ny>1) THEN
	CALL DiffYEven(PHI,dpdy,1,Nx,Ny,Nz,GridStruct%DiffStencils,beta)
	CALL DiffYEven(PHI,ddpdyy,2,Nx,Ny,Nz,GridStruct%DiffStencils,beta)
    ! DISCRETIZATION CHOICE MADE HERE FOR MIXED DERIVATIVE
	!CALL DiffZArbitrary(dpdy,ddpdsdy,1,Nx,Ny,Nz,GridStruct%DiffStencils,gamma)
    !GD: modification for correct treatment of cross derivatives...
    CALL DiffYEven_CD(PHI,tmp,GridStruct%DiffStencils%IndexesY_YZorXY(:,:,:,:,1),&
    	GridStruct%DiffStencils%StencilsY_YZorXY(:,:,:,:,1),Nx,Ny,Nz,beta)
    CALL DiffZArbitrary_CD(tmp,ddpdsdy,GridStruct%DiffStencils%IndexesZ_XZorYZ(:,:,:,:,2),&
    	GridStruct%DiffStencils%StencilsZ_XZorYZ(:,:,:,:,2),Nx,Ny,Nz,gamma)
ENDIF

CALL DiffZArbitrary(PHI,dpds,1,Nx,Ny,Nz,GridStruct%DiffStencils,gamma)
CALL DiffZArbitrary(PHI,ddpdss,2,Nx,Ny,Nz,GridStruct%DiffStencils,gamma)

! DISTINGUISH BETWEEN 2D AND 3D PROBLEMS BELOW (FOR EFFICIENCY)
! FIXME: REMOVE INDEX GIDX? FROM LOOPS BY USING ARRAYS
IF (Nx==1) THEN
  i=1
  DO j = 1+GhostGridY, Ny-GhostGridY
	DO k = 1, Nz
!		Gidx = Gidx + 1
		Gidx  = k + (i-1)*Nz + (j-1)*Nx*Nz
       IF (k==Nz) THEN
			! FREE SURFACE
			output(Gidx) = PHI(Gidx)
		ELSE IF (k==1) THEN
			! BOTTOM, DIRECT KIN. BOTTOM CONDITION
			output(Gidx) = (GridStruct%dsigmanew(k+GhostGridZ,i,j,5) + &
			   GridStruct%hy(i,j)*GridStruct%dsigmanew(k+GhostGridZ,i,j,4) )*dpds(Gidx+GhostGridZ)+&
			   GridStruct%hy(i,j)*dpdy(Gidx+GhostGridZ)
            ! GD: SWENSE addition comes here
            IF (swenseONOFF/=0) THEN
				output(Gidx) = output(Gidx) + (Wavefield%Pz_I_bp(Gidx3)+GridStruct%hy(i,j)*Wavefield%Py_I_bp(Gidx3))
            	Gidx3 = Gidx3+1
            ENDIF
		ELSE
			! INTERIOR POINTS
			output(Gidx) = ddpdyy(Gidx) + GridStruct%dsigmanew(k,i,j,3)*dpds(Gidx) + &
			   two*( GridStruct%dsigmanew(k,i,j,4)*ddpdsdy(Gidx) ) + &
			   (GridStruct%dsigmanew(k,i,j,4)**2+GridStruct%dsigmanew(k,i,j,5)**2)*ddpdss(Gidx)
		END IF
	END DO
  END DO
ELSE IF (Ny==1) THEN
  j=1
  DO i = 1+GhostGridX, Nx-GhostGridX
	DO k = 1, Nz
!		Gidx = Gidx + 1
		Gidx  = k + (i-1)*Nz + (j-1)*Nx*Nz
        IF (k==Nz) THEN
			! FREE SURFACE
			output(Gidx) = PHI(Gidx)
		ELSE IF (k==1) THEN
			! BOTTOM, DIRECT KIN. BOTTOM CONDITION
			output(Gidx) = GridStruct%hx(i,j)*dpdx(Gidx+GhostGridZ) + (GridStruct%dsigmanew(k+GhostGridZ,i,j,5) + &
			   GridStruct%hx(i,j)*GridStruct%dsigmanew(k+GhostGridZ,i,j,2) )*dpds(Gidx+GhostGridZ)
            ! GD: SWENSE addition comes here
            IF (swenseONOFF/=0) THEN
				output(Gidx) = output(Gidx) + (Wavefield%Pz_I_bp(Gidx3)+GridStruct%hx(i,j)*Wavefield%Px_I_bp(Gidx3))
            	Gidx3 = Gidx3+1
            ENDIF
		ELSE
			! INTERIOR POINTS
			output(Gidx) = ddpdxx(Gidx) + two*GridStruct%dsigmanew(k,i,j,2)*ddpdsdx(Gidx) + &
			   (GridStruct%dsigmanew(k,i,j,2)**2+GridStruct%dsigmanew(k,i,j,5)**2)*ddpdss(Gidx) + &
               GridStruct%dsigmanew(k,i,j,3)*dpds(Gidx)
		END IF
	END DO
  END DO
ELSE
  DO j = 1+GhostGridY, Ny-GhostGridY
	DO i = 1+GhostGridX, Nx-GhostGridX
		DO k = 1, Nz
!			Gidx = Gidx + 1
			Gidx  = k + (i-1)*Nz + (j-1)*Nx*Nz
            IF (k==Nz) THEN
				! FREE SURFACE
				output(Gidx) = PHI(Gidx)
			ELSE IF (k==1) THEN
				! BOTTOM, DIRECT KIN. BOTTOM CONDITION
				output(Gidx) = (GridStruct%dsigmanew(k+GhostGridZ,i,j,5) + &
				   GridStruct%hx(i,j)*GridStruct%dsigmanew(k+GhostGridZ,i,j,2) + &
				   GridStruct%hy(i,j)*GridStruct%dsigmanew(k+GhostGridZ,i,j,4) )*dpds(Gidx+GhostGridZ)+&
				   GridStruct%hx(i,j)*dpdx(Gidx+GhostGridZ)+GridStruct%hy(i,j)*dpdy(Gidx+GhostGridZ)
                ! GD: SWENSE addition comes here
                IF (swenseONOFF/=0) THEN
                    output(Gidx) = output(Gidx) + (Wavefield%Pz_I_bp(Gidx3)+GridStruct%hx(i,j)*Wavefield%Px_I_bp(Gidx3) &
                    	+GridStruct%hy(i,j)*Wavefield%Py_I_bp(Gidx3))
                    Gidx3 = Gidx3+1
                ENDIF
			ELSE
				! INTERIOR POINTS
				output(Gidx) = ddpdxx(Gidx) + ddpdyy(Gidx) + GridStruct%dsigmanew(k,i,j,3)*dpds(Gidx) + &
				   two*(GridStruct%dsigmanew(k,i,j,2)*ddpdsdx(Gidx) + GridStruct%dsigmanew(k,i,j,4)*ddpdsdy(Gidx) ) + &
				   (GridStruct%dsigmanew(k,i,j,2)**2+GridStruct%dsigmanew(k,i,j,4)**2+GridStruct%dsigmanew(k,i,j,5)**2) &
                   *ddpdss(Gidx)
			END IF
		END DO
	END DO
  END DO
ENDIF

! NOTE: IF waves are generated by an inhogogenious Neumann boundary condition
! the array Uneumann below is ~=0. The array is updated from
! waveGenerationFromPaddleSignal.f90 called from Runge_Kutta_4.
 !
  ! West  boundary
  IF (GhostGridX==1) THEN
    i = 1
    DO j = 1+GhostGridY, Ny-GhostGridY
  	  DO k = 1, Nz
      !GD: no Neumann condition on bottom points (in horizontal plane) !DO k = 1+GhostGridZ, Nz
      !But keep this loop from 1 to Nz for SWENSE (use of Gidx3...)
		Gidx  = k + (i-1)*Nz + (j-1)*Nx*Nz
		Gidx2  = k + (i-1+1)*Nz + (j-1)*Nx*Nz
		output(Gidx) = dpdx(Gidx2) !+ Uneumann(k,j)
        ! GD: SWENSE addition comes here
        IF (swenseONOFF/=0) THEN
            output(Gidx) = output(Gidx) + Wavefield%Px_I_bp(Gidx3)
          	Gidx3 = Gidx3+1
        ENDIF
	  END DO
    END DO
    ! East  boundary
    i = Nx
    DO j = 1+GhostGridY, Ny-GhostGridY
  	  DO k = 1, Nz
      !GD: no Neumann condition on bottom points (in horizontal plane) !DO k = 1+GhostGridZ, Nz
      !But keep this loop from 1 to Nz for SWENSE (use of Gidx3...)
		Gidx = k + (i-1)*Nz + (j-1)*Nx*Nz
		Gidx2 = k + (i-1-1)*Nz + (j-1)*Nx*Nz
		output(Gidx) = dpdx(Gidx2)
        ! GD: SWENSE addition comes here
        IF (swenseONOFF/=0) THEN
            output(Gidx) = output(Gidx) + Wavefield%Px_I_bp(Gidx3)
            Gidx3 = Gidx3+1
        ENDIF
	  END DO
    END DO
  ENDIF
  IF (GhostGridY==1) THEN
    ! South boundary
    j = 1
    DO i = 1+GhostGridX, Nx-GhostGridX
	  DO k = 1, Nz
      !GD: no Neumann condition on bottom points (in horizontal plane) !DO k = 1+GhostGridZ, Nz
      !But keep this loop from 1 to Nz for SWENSE (use of Gidx3...)
		Gidx  = k + (i-1)*Nz + (j-1)*Nx*Nz
		Gidx2 = k + (i-1)*Nz + (j-1+1)*Nx*Nz
		output(Gidx) = dpdy(Gidx2)
        ! GD: SWENSE addition comes here
        IF (swenseONOFF/=0) THEN
            output(Gidx) = output(Gidx) + Wavefield%Py_I_bp(Gidx3)
            Gidx3 = Gidx3+1
        ENDIF
	  END DO
    END DO
    ! North boundary
    j = Ny
    DO i = 1+GhostGridX, Nx-GhostGridX
	  DO k = 1, Nz
      !GD: no Neumann condition on bottom points (in horizontal plane) !DO k = 1+GhostGridZ, Nz
      !But keep this loop from 1 to Nz for SWENSE (use of Gidx3...)
		Gidx  = k + (i-1)*Nz + (j-1)*Nx*Nz
		Gidx2 = k + (i-1)*Nz + (j-1-1)*Nx*Nz
		output(Gidx) = dpdy(Gidx2)
        ! GD: SWENSE addition comes here
        IF (swenseONOFF/=0) THEN
            output(Gidx) = output(Gidx) + Wavefield%Py_I_bp(Gidx3)
            Gidx3 = Gidx3+1
        ENDIF
	  END DO
    END DO
  ENDIF
  IF (GhostGridX+GhostGridY==2) THEN
    ! Four corner type points in domain (ghost points)
    i = 1; j = 1;
    DO k = 1, Nz
        ! FIXME: change to form below: Gidx = Gidx + 1
		Gidx = k + (i-1)*Nz + (j-1)*Nx*Nz
		output(Gidx)  = PHI(Gidx)
    END DO
    i = Nx; j = 1;
    DO k = 1, Nz
		Gidx = k + (i-1)*Nz + (j-1)*Nx*Nz
		output(Gidx)  = PHI(Gidx)
    END DO
    i = 1; j = Ny;
    DO k = 1, Nz
		Gidx = k + (i-1)*Nz + (j-1)*Nx*Nz
		output(Gidx)  = PHI(Gidx)
	END DO
	i = Nx; j = Ny;
	DO k = 1, Nz
		Gidx = k + (i-1)*Nz + (j-1)*Nx*Nz
		output(Gidx)  = PHI(Gidx)
	END DO
    ! GD: FIXME the ghost corners on the bottom not treated ?
    ! FIXME: 2D case have to be treated also... (remove the two corner points at the bottom)
    k=1;j=1
    DO i=1,Nx
      Gidx = k + (i-1)*Nz + (j-1)*Nx*Nz
      output(Gidx)  = PHI(Gidx)
    ENDDO
    !
    k=1;j=Ny
    DO i=1,Nx
      Gidx = k + (i-1)*Nz + (j-1)*Nx*Nz
      output(Gidx)  = PHI(Gidx)
    ENDDO
    k=1;i=1
    DO j=1,Ny
      Gidx = k + (i-1)*Nz + (j-1)*Nx*Nz
      output(Gidx)  = PHI(Gidx)
    ENDDO
    !
    k=1;i=Nx
    DO j=1,Ny
      Gidx = k + (i-1)*Nz + (j-1)*Nx*Nz
      output(Gidx)  = PHI(Gidx)
    ENDDO
  ENDIF
  !
  ! GD: 2D cases bottom corners have to be treated
  IF ((GhostGridX==1).AND.(Ny==1)) THEN
    k = 1; j = 1; i=1
    Gidx  = k + (i-1)*Nz + (j-1)*Nx*Nz
    output(Gidx)  = PHI(Gidx)
	!
    k = 1; j = 1; i=Nx
    Gidx  = k + (i-1)*Nz + (j-1)*Nx*Nz
    output(Gidx)  = PHI(Gidx)
  ENDIF
  IF ((GhostGridY==1).AND.(Nx==1)) THEN
    k = 1; i = 1; j=1
    Gidx  = k + (i-1)*Nz + (j-1)*Nx*Nz
    output(Gidx)  = PHI(Gidx)
    !
    k = 1; i = 1; j=Ny
    Gidx  = k + (i-1)*Nz + (j-1)*Nx*Nz
    output(Gidx)  = PHI(Gidx)
  ENDIF

!print*,'output=',output
!read*

END SUBROUTINE BuildLinearSystem