C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
      SUBROUTINE FFT2D (A,B,NSIZ,ISGN,ITYPE,BUF,IDR)
C
C PURPOSE: PERFORM A TWO-DIMENSIONAL TRANSFORM FASTER THAN C06ADF ETC.
C
C AUTHOR: N.R.ARNOT Q.E.C
C         MODIFIED & TIDIED G.R.MANT  DARESBURY LABORATORY.
C
C LIMITATIONS:
C     (1) ARRAYS A,B MUST BE SQUARE
C     (2) DIMENSION N MUST BE COMPLETELY FACTORISABLE INTO 2,3,
C         AND 5. VIOLATION OF THIS CAUSES STOP WITH ERROR MESSAGE.
C         FACTORS OF 5 NOT YET IMPLEMENTED
C     (3) N MUST HAVE LESS THAN 9 FACTORS OF 2, 3, 4, OR 5 ONLY,
C         AND AT LEAST ONE OF THEM MUST BE 4
C
      REAL    A(1),B(1),BUF(1)
      INTEGER NSIZ,ISGN,ITYPE,IDR(1)
C
C A      : REAL PART
C B      : IMAGINARY PART
C BUF    : HOLDS SINES DURING THE TRANSFORM, AND IS A BUFFER DURING THE
C          UNSCRAMBLE. IT MUST BE OF SIZE AT LEAST (9*NSIZ)/4 +1
C NSIZ   : IS A SINGLE DIMENSION A(N,N)
C ISGN   : +VE FOR FORWARD TRANSFORM, NEGATIVE FOR REVERSE
C          (NORMALISATION CONSTANT IS 1/N**2 ON REVESE TRANSFORM)
C ITYPE  : +VE IF TRANSFORM DEFINED AS SUM FROM 0 TO (N-1)
C          -VE IF TRANSFORM DEFINED AS SUM FROM (-N/2) TO (N/2 +1)
C IDR    : HOLDS ASSORTED CONSTANTS DURING TRANSFORM AND DIGIT-
C          REVERSED SUBSCRIPTS DURING UNSCRAMBLE. IT MUST BE AT LEAST
C          N ELEMENTS LONG.
C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
C IMPLEMENTATION NOTE:
C  IF USERNM IS .TRUE. (DEFAULT .FALSE.) THE DEFAULT NORMALISATION DOES
C  NOT TAKE PLACE; INSTEAD, THE TRANSFORM IS CALCULATED AS A STRAIGHT
C  SUM & MULTIPLIED BY FORWRD (ISGN=+1) OR BAKWRD(ISGN=-1); DEFAULTS
C  OF THESE REAL VARIABLES ARE 1.0
C
C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
C LOCAL VARIABLES:
C
      REAL    FORWRD,BAKWRD
      INTEGER NFACS(9),IX(9),IR(5),IDRINC(9)
      LOGICAL CENTRZ,RDXFOU,NOTWID,REVTRN,USERNM
C
      DATA USERNM/.FALSE./,FORWRD/1.0/,BAKWRD/1.0/
C
C-----------------------------------------------------------------------
      PI=ACOS (-1.0)
      IF (NSIZ.GE.0) THEN
         N = NSIZ
         NNR = NSIZ
C========NNR NOT N IF N A POWER OF 2 BEST ON CDC MACHINES BUT WASTES CORE
      ELSE
         N = -NSIZ
         NNR = N + 1
      ENDIF
      CENTRZ = ITYPE.LT.0
      REVTRN = ISGN.LT.0
      SIN120 = SIN(PI/1.5)
      SIN72 = SIN(PI/2.5)
      COS72 = COS(PI/2.5)
      C2  = COS72**2 - SIN72**2
      S2 = 2.0*COS72*SIN72
C========FACTORISE N
      II = 3
      NFAC=0
      ITEMP=N
      IF (((N/4)*4).EQ.N) GOTO 4
      II = 1
      GOTO 13
   4  CONTINUE
      DO 10 I=2,5
        J=7-I
   5    JTEMP=ITEMP/J
        IF(JTEMP*J .NE. ITEMP) GOTO 10
        NFAC=NFAC+1
        IF (NFAC.LT.9) GOTO 6
        II = 2
        GOTO 13
  6     NFACS(NFAC) = J
        ITEMP = JTEMP
        GOTO 5
  10  CONTINUE
      IF (ITEMP.EQ.1) GOTO 20
C
C********************************************************************
C
  13  WRITE(6,14) II,N
  14  FORMAT(' FOURIER FATAL FACTORISATION FAILURE NO. ',I4,
     & 2X,7HWITH N=  ,I4 )
C   REASONS ARE 1 -> NO FACTOR OF 4,  2 -> N TOO LARGE, AND
C             3 -> N HAS A PRIME FACTOR GREATER THAN 5
      STOP
C
C********************************************************************
C
  20  CONTINUE
C
C  SET UP TWIDDLE FACTOR LOOKUP TABLE. TO AVOID THE NEED FOR MODULO
C  INTEGER ARITHMETIC OR CONDITIONAL CODE IT IS LARGER THAN NECESSARY
C  2.25 CYCLES OF A SIN CURVE SAMPLED AT TWOPI/N ARE USED, ONE OR
C  EVEN 0.5 COULD BE USED ON A SMALL COMPUTER.
C
      TPBN = 6.283185307/FLOAT(N)
      J = N/2
      DO 35 I=1,J
        BUF(I) = SIN(FLOAT(I-1)*TPBN)
  35  CONTINUE
      II = J
      J = J+1
      K = (9*N)/4 +1
      DO 36 I=J,K
        BUF(I) = -BUF(I-II)
  36  CONTINUE
C
C  FASTER BUT LESS ACCURATE COULD USE TRIG IDENTITIES FOR
C  SIN((N+1)X) AND COS((N+1)X)
C
C  CONJUGATE IF REVERSE TRANSFORM
      IF(.NOT.REVTRN) GOTO 75
      J = N*N
      DO 73 I=1,J
        B(I) = -B(I)
  73  CONTINUE
  75  CONTINUE
C  NOW START ACTUAL TRANSFORM. AN INTERNAL PROCEDURE IS USED TO DO A SET
C  OF NTRANS TRANSFORMS OF IFAC POINTAS, THE COORSD OF THE FIRST OF
C  WHICH ARE PASSED IN IX(). UNLESS NOTWID IS TRUE, THE REFERENCING
C  OPERATION IS ALSO DONE.
C     IRETRN (ASSIGNED) IS LABEL TO RETURN TO AFTER TRANSFORMS DONE,
C  ITRTYP IS LABEL OF CODE FOR CORRECT (2, 3, 4, OR 5 POINT) TRANSFORM.
C
      ITWINC = 1
      ISKIP = N
      ISPAN = N
      DO 300 NF = 1,NFAC
        IFAC = NFACS(NF)
        RDXFOU = IFAC.EQ.4
        NP1 = N/4
        ISPAN = ISPAN/IFAC
        ICSEP=ISPAN
        IRSEP = ICSEP*NNR
        IF1 = IFAC-1
C  USE IDR IN THIS LOOP TO HOLD THE TWIDDLE FACTOR INCREMENTS
C
C  PRESET THE FOLLOWING INFO IN IDR AS GROUPS OF IFAC LOCATIONS :-
C       1       -> COLUMN NO. OF FIRST POINT OF ELEMENTAL IFAC-POINT TRN
C       2       ->  TWIDDLE COEFFICIENT FOR 2ND POINT OF TRANSFORM NO. G
C   UPTO IFAC  -> TWIDDLE COEFFICIENT FOR IFAC'TH POINT,
C  WHERE G IS THE NUMBER OF THE GROUP.
C
        NPT = 0
        NP = 0
        NS = 1
        J = IFAC - 1
        DO 80 I = 1, N, IFAC
          IDR(I) = NP + NS
          DO 82 II=1, J
            IDR(I+II) = NPT * II
   82     CONTINUE
          NP = NP + 1
          NPT = NPT + ITWINC
          IF (NP.LT.ISPAN) GOTO 79
          NP = 0
          NPT = 0
          NS = NS + ISKIP
   79     CONTINUE
   80   CONTINUE
        IRBASE = 0
C  START OF OUTER LOOP OVER GROUP OF ROWS
  110   CONTINUE
        IRTW = 1
C       BIAS BY 1 FOR LOOKUP, BUF(1) = SIN(0) = IMAG(W/SUB 0/)
        JRTW = 0
C  INNER LOOP OVER ROWS IN GROUP
        DO 250 NROW = 1, ISPAN
C  INITIALISE ROW BASE COORDINATES ( OR FETCH ROWS FROM MS)
          IR(1) = (IRBASE+NROW-1)*NNR
          DO 115 I=2,IFAC
            IR(I) = IR(I-1) + IRSEP
  115     CONTINUE
C  TRANSFORM ALL COLS IN ROW SET, NO TWIDDLING.
          NOTWID = .TRUE.
          ISEP = IRSEP
          ISTRT = IR(1)
          NTINC = 1
          CALL PTRANS (A,B,N,NTINC,NOTWID,ISTRT,IF1,ISEP,IRTW,NP1,
     1                 BUF,IDR,SIN120,COS72,SIN72,C2,S2)
C  AND NOW FOR ROW TRANSFORMS AND TWIDDLING.
C    NOW DO THE TRANSFORMS ALONG THE ROWS, WITH TWIDDLING.
          IRTW = 1
          NOTWID = ISPAN.EQ.1
C   NOTWID ON FINAL TRANSFORM BOTH INCREASES SPEED AND ENSURES
C   THAT THE RESULTS FTN RECIEVES ARE NORMALISED IF FFTR4C USED
          NTINC = IFAC
          ISEP = ICSEP
          DO 130 IRSSEQ = 1, IFAC
            ISTRT = IR(IRSSEQ)
            CALL PTRANS (A,B,N,NTINC,NOTWID,ISTRT,IF1,ISEP,IRTW,NP1,
     1                   BUF,IDR,SIN120,COS72,SIN72,C2,S2)
            IRTW = IRTW + JRTW
  130     CONTINUE
          JRTW = JRTW + ITWINC
  250   CONTINUE
C  ADVANCE TO NEXT ROW SET IF NOT ALL DONE
        IRBASE = IRBASE + ISKIP
        IF (IRBASE.LT.N) GOTO 110
        ISKIP = ISKIP / IFAC
        ITWINC = ITWINC * IFAC
C  END ITERATION OVER FACTORS
  300 CONTINUE
C
C  NOW UNSCRAMBLE THE TRANSFORM. SET UP TABLE IN IDR(J) OF WHERE LINE
C  (OR COL) J SHOULD BE MOVED TO. IX HOLDE THE DIGITS OF THE VARIABLE-
C  RADIX COORDINATE AND IDRT IS ITS DIGIT REVERSED FORM AT ALL TIMES.
C   INITIALISATION...
C
      IX(1) = 0
      IDRINC(1) = 1
      DO 310 I = 2, NFAC
        IX(I) = 0
        J = I-1
        IDRINC(I) = IDRINC(J) * NFACS(J)
  310 CONTINUE
      J = 0
      IDRT = 1
      I4 = (N-1)/2 +1
C
C  NOTE IDRT BIASSED BY 1 FOR USE AS SUBSCRIPT, IS 0 IN THEORY.
C   IDRT ALSO CAUSES A CYCLIC SHIFT OF N/2 IF WE WANT A CENTRE-ZERO RES.
C  LOOP GENERATES THE TABLE IN IDR
C
  315 J = J + 1
      IF (CENTRZ) GOTO 316
      IDR(J) = IDRT
      GOTO 318
  316 I2 = IDRT + I4
      IF (I2.LE.N) GOTO 317
      IDR(J) = I2 - N
      GOTO 318
  317 IDR(J) = I2
  318 CONTINUE
      M = NFAC
C  INCREMENT SMALLEST DIGIT, CORRESPONDING BIG INCREMENT TO IDRT
  320 IX(M) = IX(M) +1
      IDRT = IDRT + IDRINC(M)
C  CARRY?
      IF(IX(M).LT.NFACS(M)) GOTO 315
C  YES. RESET TO 0 AND MOVE TO NEXT DIGIT; CORRECT IDRT
      IX(M) = 0
      IDRT = IDRT - NFACS(M)*IDRINC(M)
      M = M-1
      IF(M.NE.0) GOTO 320
C  WE EXIT WHEN WE HAVE 'GONE ROUND CLOCK' ONCE.
      FNPTS = 1.0 / FLOAT(N*N)
      IF (USERNM) FNPTS=FORWRD
      IF (USERNM.AND.REVTRN) FNPTS=BAKWRD
      FNPTS2=FNPTS
      IF(REVTRN) FNPTS2=-FNPTS
      NP1 = N +1
C
C  UNSCRAMBLE THE ARRAYS.
C
      DO 800 NROW = 1, N
        M=NROW
C  HAS THE ROW BEEN RESORTED ALREADY?
        IF (IDR(M).LT.0) GOTO 801
        MBASE = (M-1)*NNR
        I = M
        IRBASE = MBASE
C  MOVE LINE I TO BUFFER
        DO 810 J=1, N
          I2 = IRBASE + J
          BUF(J)=A(I2)
          BUF(J+NP1) = B(I2)
  810   CONTINUE
C  MARK ROW I AS SORTED, UPDATE I
  815   I2 = IDR(I)
        IDR(I) = -I2
        I = I2
        IRBASE = (I-1)*NNR
C  UNSCRAMBLE BUFFER TO LINE M, EXIT IF (NEW) I .EQ.M
C  ALSO PERFORM NORMALISATION ON REVERSE TRANSFORM, AND PRE-SHIFTING
C  IF CENTRE-ZERO BY USE OF POST-GRIDDING. THE TEST WHETHER TO MULTIPLY
C  BY -1 IS THAT EITHER (I-I4) OR (IREV-I4), NOT BOTH, IS ODD.
C  THIS CAN BE COLLAPSED TO A TEST FOR (I-I4 + IREV-I4) ODD, OR
C  SIMPLY ON (I+IREV)
        DO 820 J = 1, N
          NP = IABS(IDR(J))
          IREV = NP + MBASE
          IF (REVTRN.OR.USERNM) GOTO 825
          A1 = BUF(J)
          B1 = BUF(J+NP1)
          GOTO 827
  825     A1 = BUF(J) * FNPTS
          B1 = -BUF(J+NP1)*FNPTS
  827     IF (CENTRZ.AND.MOD(NP+I, 2).NE.0) GOTO 828
          A(IREV) = A1
          B(IREV) = B1
          GOTO 819
  828     A(IREV) = -A1
          B(IREV) = -B1
  819     CONTINUE
  820   CONTINUE
        IF (M.EQ.I) GOTO 801
C  NOT END OF CYCLE. MOVE LINE I TO BUFFER AND LINE M TO LINE I
        DO 830 J = 1, N
          I2 = IRBASE + J
          BUF(J) = A(I2)
          BUF(J+NP1) = B(I2)
          I4 = MBASE + J
          A(I2) = A(I4)
          B(I2) = B(I4)
  830   CONTINUE
        GOTO 815
  801   CONTINUE
  800 CONTINUE
      RETURN
      END
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
      SUBROUTINE PTRANS (A,B,N,NTINC,NOTWID,ISTRT,IF1,ISEP,IRTW,NP1,
     1                   BUF,IDR,SIN120,COS72,SIN72,C2,S2)
C
C PURPOSE: PROCEDURE FOR DOING A SET OF IFAC-POINT TRANSFORMS
C          STARTING WITH POINTA WHOSE COORDS ARE HELD IN IX()
C
      REAL A(1),B(1),BUF(1)
      INTEGER IDR(1)
      LOGICAL NOTWID
C
C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
C Local Variables:
C
      REAL    A1(2048),A2(2048),A3(2048),A4(2048),A23(2048)
      REAL    B1(2048),B2(2048),B3(2048),B4(2048),B23(2048)
      REAL    AA(2048),BB(2048),AK(2048),BK(2048),AJ(2048),BJ(2048)
      REAL    C(2048),S(2048),C2(2048),S2(2048)
      INTEGER IX1(2048),IX2(2048),IX3(2048),IX4(2048),IX5(2048)
C
C-----------------------------------------------------------------------
C
      IF (NOTWID) THEN
         DO 100 NTR = 1, N, NTINC
            IX1(NTR) = ISTRT + NTR
 100     CONTINUE
      ELSE
         DO 150 NTR = 1, N, NTINC
 208        IX1(NTR) = ISTRT + IDR(NTR)
 150     CONTINUE
      ENDIF
      DO 180 NTR = 1, N, NTINC
         IX2(NTR) = IX1(NTR) + ISEP
         IX3(NTR) = IX2(NTR) + ISEP
         IX4(NTR) = IX3(NTR) + ISEP
         IX5(NTR) = IX4(NTR) + ISEP
 180  CONTINUE

C
      GOTO (200,300,400,500),IF1
C
C========TWO POINT TRANSFORM
C
 200  DO 2000 NTR = 1, N, NTINC
         A2(NTR) = A(IX2(NTR))
         B2(NTR) = B(IX2(NTR))
 2000 CONTINUE
C
      DO 2002 NTR = 1, N, NTINC
         A(IX2(NTR)) = A(IX1(NTR))-A2(NTR)
         A(IX1(NTR)) = A(IX1(NTR))+A2(NTR)
         B(IX2(NTR)) = B(IX1(NTR))-B2(NTR)
         B(IX1(NTR)) = B(IX1(NTR))+B2(NTR)
 2002 CONTINUE
      GOTO 6000
C
C========THREE POINT TRANSFORM. NOTE COS120=-0.5, LET COMPILER OPTIMISE
C       *0.5 IF POSSIBLE
C
 300  DO 3000 NTR = 1, N, NTINC
         A1(NTR) = A(IX1(NTR))
         A23(NTR) = A(IX2(NTR))+A(IX3(NTR))
 3000 CONTINUE
      DO 3001 NTR = 1, N, NTINC
         A(IX1(NTR)) = A1(NTR)+A23(NTR)
 3001 CONTINUE
      DO 3002 NTR = 1, N, NTINC
         A1(NTR) = -0.5*A23(NTR) +A1(NTR)
         A23(NTR) = (A(IX2(NTR))-A(IX3(NTR)))*SIN120
         B1(NTR) = B(IX1(NTR))
         B23(NTR) = B(IX2(NTR)) + B(IX3(NTR))
 3002 CONTINUE
      DO 3003 NTR = 1, N, NTINC
         B(IX1(NTR)) = B1(NTR)+B23(NTR)
 3003 CONTINUE
      DO 3004 NTR = 1, N, NTINC
         B1(NTR) = -0.5*B23(NTR) + B1(NTR)
         B23(NTR) = (B(IX2(NTR))-B(IX3(NTR)))*SIN120
 3004 CONTINUE
C
      DO 3005 NTR = 1, N, NTINC
         A(IX2(NTR)) = A1(NTR)-B23(NTR)
 3005 CONTINUE
      DO 3006 NTR = 1, N, NTINC
         A(IX3(NTR)) = A1(NTR)+B23(NTR)
 3006 CONTINUE
      DO 3007 NTR = 1, N, NTINC
         B(IX2(NTR)) = B1(NTR)+A23(NTR)
 3007 CONTINUE
      DO 3008 NTR = 1, N, NTINC
         B(IX3(NTR)) = B1(NTR)-A23(NTR)
 3008   CONTINUE
      GOTO 6000
C
C========FOUR POINT TRANSFORM; DO AS PAIR OF TWO POINT ONES WITH PI/2 TWIDDLE
C
 400  DO 4000 NTR = 1, N, NTINC
         A1(NTR) = A(IX1(NTR))+A(IX3(NTR))
         A3(NTR) = A(IX1(NTR))-A(IX3(NTR))
         A2(NTR) = A(IX2(NTR))+A(IX4(NTR))
         A4(NTR) = A(IX2(NTR))-A(IX4(NTR))
 4000 CONTINUE
C
      DO 4001 NTR = 1, N, NTINC
         B1(NTR) = B(IX1(NTR))+B(IX3(NTR))
         B3(NTR) = B(IX1(NTR))-B(IX3(NTR))
         B2(NTR) = B(IX2(NTR))+B(IX4(NTR))
         B4(NTR) = B(IX2(NTR))-B(IX4(NTR))
 4001 CONTINUE
C
      DO 4002 NTR = 1, N, NTINC
         A(IX1(NTR)) = A1(NTR)+A2(NTR)
 4002 CONTINUE
      DO 4003 NTR = 1, N, NTINC
         A(IX3(NTR)) = A1(NTR)-A2(NTR)
 4003 CONTINUE
      DO 4004 NTR = 1, N, NTINC
         B(IX1(NTR)) = B1(NTR)+B2(NTR)
 4004 CONTINUE
      DO 4005 NTR = 1, N, NTINC
         B(IX3(NTR)) = B1(NTR)-B2(NTR)
 4005 CONTINUE
C
      DO 4006 NTR = 1, N, NTINC
         A(IX2(NTR)) = A3(NTR)-B4(NTR)
 4006 CONTINUE
      DO 4007 NTR = 1, N, NTINC
         A(IX4(NTR)) = A3(NTR)+B4(NTR)
 4007 CONTINUE
      DO 4008 NTR = 1, N, NTINC
         B(IX2(NTR)) = B3(NTR)+A4(NTR)
 4008 CONTINUE
      DO 4009 NTR = 1, N, NTINC
         B(IX4(NTR)) = B3(NTR)-A4(NTR)
 4009 CONTINUE
      GOTO 6000
C
C  FIVE POINT TRANSFORM NOT YET IMPLEMENTED.
C
 500  DO 5000 NTR = 1, N, NTINC
C
         A1(NTR)=A(IX2(NTR))+A(IX5(NTR))
         A3(NTR)=A(IX2(NTR))-A(IX5(NTR))
         B1(NTR)=B(IX2(NTR))+B(IX5(NTR))
         B3(NTR)=B(IX2(NTR))-B(IX5(NTR))
 5000 CONTINUE
C
      DO 5001 NTR = 1, N, NTINC
         A2(NTR)=A(IX3(NTR))+A(IX4(NTR))
         A4(NTR)=A(IX3(NTR))-A(IX4(NTR))
         B2(NTR)=B(IX3(NTR))+B(IX4(NTR))
         B4(NTR)=B(IX3(NTR))-B(IX4(NTR))
 5001 CONTINUE
C
      DO 5002 NTR = 1, N, NTINC
         AA(NTR)=A(IX1(NTR))
         BB(NTR)=B(IX1(NTR))
         A(IX1(NTR))=AA(NTR)+A1(NTR)+A2(NTR)
         B(IX1(NTR))=BB(NTR)+B1(NTR)+B2(NTR)
 5002 CONTINUE
C
      DO 5003 NTR = 1, N, NTINC
         AK(NTR)=A1(NTR)*COS72+A2(NTR)*C2(NTR)+AA(NTR)
         BK(NTR)=B1(NTR)*COS72+B2(NTR)*C2(NTR)+BB(NTR)
         AJ(NTR)=A3(NTR)*SIN72+A4(NTR)*S2(NTR)
         BJ(NTR)=B3(NTR)*SIN72+B4(NTR)*S2(NTR)
 5003 CONTINUE
C
      DO 5004 NTR = 1, N, NTINC
         A(IX2(NTR))=AK(NTR)-BJ(NTR)
 5004 CONTINUE
      DO 5005 NTR = 1, N, NTINC
         A(IX5(NTR))=AK(NTR)+BJ(NTR)
 5005 CONTINUE
      DO 5006 NTR = 1, N, NTINC
         B(IX2(NTR))=BK(NTR)+AJ(NTR)
 5006 CONTINUE
      DO 5007 NTR = 1, N, NTINC
         B(IX5(NTR))=BK(NTR)-AJ(NTR)
 5007 CONTINUE
C
      DO 5008 NTR = 1, N, NTINC
         AK(NTR)=A1(NTR)*C2(NTR)+A2(NTR)*COS72+AA(NTR)
         BK(NTR)=B1(NTR)*C2(NTR)+B2(NTR)*COS72+BB(NTR)
         AJ(NTR)=A3(NTR)*S2(NTR)-A4(NTR)*SIN72
         BJ(NTR)=B3(NTR)*S2(NTR)-B4(NTR)*SIN72
 5008 CONTINUE
C
      DO 5009 NTR = 1, N, NTINC
         A(IX3(NTR))=AK(NTR)-BJ(NTR)
 5009 CONTINUE
      DO 5010 NTR = 1, N, NTINC
         A(IX4(NTR))=AK(NTR)+BJ(NTR)
 5010 CONTINUE
      DO 5011 NTR = 1, N, NTINC
         B(IX3(NTR))=BK(NTR)+AJ(NTR)
 5011 CONTINUE
      DO 5012 NTR = 1, N, NTINC
         B(IX4(NTR))=BK(NTR)-AJ(NTR)
 5012 CONTINUE
C
C  TWIDDLING
C
C  THIS CODE IS OPTIMAL FOR A LARGE MACHINE (LOOPS AND CONDITIONALS
C  EXPENSIVE - ESPECIALLY TRUE OF CDC 66/7600) BUT IF IX'S WERE MADE
C  INTO AN ARRAY, THE TWIDDLE CODE COULD BE GREATLY SHRUNK BY MAKING
C  IT INTO A LOOP.
C
 6000 IF (.NOT.NOTWID) THEN
         GOTO (220,330,440,550),IF1

 550     DO 5500 NTR = 1, N, NTINC
            ITW = IRTW + IDR(NTR+4)
            S(NTR) = BUF(ITW)
            C(NTR) = BUF(ITW+NP1)
 5500    CONTINUE
         DO 5501 NTR = 1, N, NTINC
            A4(NTR) = A(IX5(NTR))
            B4(NTR) = B(IX5(NTR))
 5501    CONTINUE
         DO 5502 NTR = 1, N, NTINC
            A(IX5(NTR)) = A4(NTR)*C(NTR) - B4(NTR)*S(NTR)
            B(IX5(NTR)) = A4(NTR)*S(NTR) + B4(NTR)*C(NTR)
 5502    CONTINUE
C
 440     DO 4400 NTR = 1, N, NTINC
            ITW = IRTW + IDR(NTR+3)
            S(NTR) = BUF(ITW)
            C(NTR) = BUF(ITW+NP1)
 4400    CONTINUE
         DO 4401 NTR = 1, N, NTINC
            A4(NTR) = A(IX4(NTR))
            B4(NTR) = B(IX4(NTR))
 4401    CONTINUE
         DO 4402 NTR = 1, N, NTINC
            A(IX4(NTR)) = A4(NTR)*C(NTR) - B4(NTR)*S(NTR)
            B(IX4(NTR)) = A4(NTR)*S(NTR) + B4(NTR)*C(NTR)
 4402    CONTINUE
C
 330     DO 3300 NTR = 1, N, NTINC
            ITW = IRTW + IDR(NTR+2)
            S(NTR) = BUF(ITW)
            C(NTR) = BUF(ITW+NP1)
 3300    CONTINUE
         DO 3301 NTR = 1, N, NTINC
            A4(NTR) = A(IX3(NTR))
            B4(NTR) = B(IX3(NTR))
 3301    CONTINUE
         DO 3302 NTR = 1, N, NTINC
            A(IX3(NTR)) = A4(NTR)*C(NTR) - B4(NTR)*S(NTR)
            B(IX3(NTR)) = A4(NTR)*S(NTR) + B4(NTR)*C(NTR)
 3302    CONTINUE
C
 220     DO 2200 NTR = 1, N, NTINC
            ITW = IRTW + IDR(NTR+1)
            S(NTR) = BUF(ITW)
            C(NTR) = BUF(ITW+NP1)
 2200    CONTINUE
         DO 2201 NTR = 1, N, NTINC
            A4(NTR) = A(IX2(NTR))
            B4(NTR) = B(IX2(NTR))
 2201    CONTINUE
         DO 2202 NTR = 1, N, NTINC
            A(IX2(NTR)) = A4(NTR)*C(NTR) - B4(NTR)*S(NTR)
            B(IX2(NTR)) = A4(NTR)*S(NTR) + B4(NTR)*C(NTR)
 2202    CONTINUE
         DO 2203 NTR = 1, N, NTINC
            A4(NTR) = A(IX1(NTR))
            B4(NTR) = B(IX1(NTR))
 2203    CONTINUE
         DO 2204 NTR = 1, N, NTINC
            S(NTR) = BUF(IRTW)
            C(NTR) = BUF(IRTW+NP1)
 2204    CONTINUE
         DO 2205 NTR = 1, N, NTINC
            A(IX1(NTR)) = A4(NTR)*C(NTR) - B4(NTR)*S(NTR)
            B(IX1(NTR)) = A4(NTR)*S(NTR) + B4(NTR)*C(NTR)
 2205    CONTINUE
      ENDIF
      RETURN
      END


*DECK DGAMI
      DOUBLE PRECISION FUNCTION DGAMI (A, X)
C***BEGIN PROLOGUE  DGAMI
C***PURPOSE  Evaluate the incomplete Gamma function.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C7E
C***TYPE      DOUBLE PRECISION (GAMI-S, DGAMI-D)
C***KEYWORDS  FNLIB, INCOMPLETE GAMMA FUNCTION, SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C Evaluate the incomplete gamma function defined by
C
C DGAMI = integral from T = 0 to X of EXP(-T) * T**(A-1.0) .
C
C DGAMI is evaluated for positive values of A and non-negative values
C of X.  A slight deterioration of 2 or 3 digits accuracy will occur
C when DGAMI is very large or very small, because logarithmic variables
C are used.  The function and both arguments are double precision.
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  DGAMIT, DLNGAM, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770701  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C***END PROLOGUE  DGAMI
      DOUBLE PRECISION A, X, FACTOR, DLNGAM, DGAMIT
C***FIRST EXECUTABLE STATEMENT  DGAMI
      IF (A .LE. 0.D0) CALL XERMSG ('SLATEC', 'DGAMI',
     +   'A MUST BE GT ZERO', 1, 2)
      IF (X .LT. 0.D0) CALL XERMSG ('SLATEC', 'DGAMI',
     +   'X MUST BE GE ZERO', 2, 2)
C
      DGAMI = 0.D0
      IF (X.EQ.0.0D0) RETURN
C
C THE ONLY ERROR POSSIBLE IN THE EXPRESSION BELOW IS A FATAL OVERFLOW.
      FACTOR = EXP (DLNGAM(A) + A*LOG(X))
C
      DGAMI = FACTOR * DGAMIT (A, X)
C
      RETURN
      END


!########################################################
!     Program  : AHMIPT
!     TYPE     : Main program
!     PURPOSE  : Solve the Attractive Hubbard Model using IPT
!     AUTHORS  : Adriano Amaricci
!########################################################
program hmipt
  USE DMFT_IPT
  USE DMFT_TOOLS
  USE SCIFOR
  implicit none
  integer    :: i,ik,Lk,iloop
  logical    :: converged
  complex(8) :: det,zeta1,zeta2,x1,x2
  real(8)    :: delta,n,D,wmix,fmesh
  !
  complex(8),allocatable          :: sigma(:,:),fg(:,:),wf0(:,:),calG(:,:),sold(:,:)
  complex(8),allocatable          :: zeta(:)
  !
  real(8),allocatable :: wt(:),epsik(:),wr(:),wm(:),tau(:)

  call parse_input_variable(D,"wband","inputIPT.in",default=1d0)
  call parse_input_variable(wmix,"wmix","inputIPT.in",default=0.75d0)
  call parse_input_variable(Lk,"Lk","inputIPT.in",default=1000)
  call read_input("inputIPT.in")

  allocate(wr(L))
  wr = linspace(-wmax,wmax,L,mesh=fmesh)
  print*,fmesh
  allocate(fg(2,L),sigma(2,L))
  allocate(wf0(2,L),calG(2,L))
  allocate(zeta(L),sold(2,L))

  allocate(wt(Lk),epsik(Lk))
  call bethe_lattice(wt,epsik,Lk,D)

  call get_initial_sigma

  iloop=0 ; converged=.false.
  do while (.not.converged)
     iloop=iloop+1
     write(*,"(A,i5)",advance="no")"DMFT-loop",iloop
     fg=zero
     zeta(:) = cmplx(wr(:),eps,8) + xmu - sigma(1,:)
     do i=1,L
        zeta1 = zeta(i)
        zeta2 = conjg(zeta(L+1-i))
        x1 = 0.5d0*((zeta1+zeta2) + sqrt((zeta1-zeta2)**2 - 4.d0*conjg(sigma(2,L+1-i))*sigma(2,i) ))
        x2 = 0.5d0*((zeta1+zeta2) - sqrt((zeta1-zeta2)**2 - 4.d0*conjg(sigma(2,L+1-i))*sigma(2,i) ))
        fg(1,i) = zeta2/(x2-x1)*(gfbether(wr(i),x1,D)-gfbether(wr(i),x2,D))
        fg(2,i) =-conjg(sigma(2,L+1-i))/(x2-x1)*(gfbether(wr(i),x1,D)-gfbether(wr(i),x2,D))
        ! do ik=1,Lk
        !    det = (zeta1-epsik(ik))*(zeta2-epsik(ik)) + conjg(sigma(2,L+1-i))*sigma(2,i)
        !    fg(1,i)=fg(1,i) + wt(ik)*(zeta2-epsik(ik))/det
        !    fg(2,i)=fg(2,i) - wt(ik)*conjg(sigma(2,L+1-i))/det
        ! enddo
     enddo
     delta=-uloc*trapz(fmesh,dimag(fg(2,:))*fermi(wr,beta))/pi
     n    =-trapz(fmesh,dimag(fg(1,:))*fermi(wr,beta))/pi

     !get the Weiss Field \calG0^-1(w) = Gloc^-1 + Sigma + Sigma_HFB
     do i=1,L
        det     = fg(1,i)*conjg(fg(1,L+1-i)) + conjg(fg(2,L+1-i))*fg(2,i)
        wf0(1,i)= conjg(fg(1,L+1-i))/det  + sigma(1,i)   +  uloc*(n-0.5d0)
        wf0(2,i)= conjg(fg(2,L+1-i))/det  + sigma(2,i)   + delta
     end do
     do i=1,L
        det      =  wf0(1,i)*conjg(wf0(1,L+1-i)) + conjg(wf0(2,L+1-i))*wf0(2,i)
        calG(1,i)=  conjg(wf0(1,L+1-i))/det
        calG(2,i)=  conjg(wf0(2,L+1-i))/det
     end do

     write(*,"(3f14.9)",advance="no")2.d0*n,delta,delta/uloc
     sold=sigma
     sigma =  ipt_solve_real_sc(calG(1:2,:),wr,delta,L)
     sigma = wmix*sigma + (1.d0-wmix)*sold
     converged = check_convergence(sigma(1,:)+sigma(2,:),eps=dmft_error,N1=Nsuccess,N2=Nloop)
  enddo

  call splot("observables.ipt",xmu,uloc,dble(iloop),n,delta/uloc,delta)
  call splot("G_realw.ipt",wr,-dimag(fg(1,:))/pi,dreal(fg(1,:)))
  call splot("F_realw.ipt",wr,-dimag(fg(2,:))/pi,dreal(fg(2,:)))
  call splot("Sigma_realw.ipt",wr,sigma(1,:))
  call splot("Self_realw.ipt",wr,sigma(2,:))
  call splot("calG0_realw.ipt",wr,calG(1,:))
  call splot("calF0_realw.ipt",wr,calG(2,:))

contains

  subroutine get_initial_sigma()
    logical                :: check1,check2,check
    inquire(file="Sigma_realw.ipt",exist=check1)
    inquire(file="Self_realw.ipt",exist=check2)
    check=check1.AND.check2
    if(check)then
       write(*,*)"Reading Sigma in input:"
       call sread("Sigma_realw.ipt",wr,sigma(1,:))
       call sread("Self_realw.ipt",wr,sigma(2,:))
    else
       print*,"Using Hartree-Fock self-energy"
       print*,"===================================="
       n=0.5d0 ;  delta=deltasc
       sigma(2,:)=-delta ; sigma(1,:)=zero ; sold=sigma
    endif
  end subroutine get_initial_sigma

end program hmipt


      subroutine runCY_00lllll(k,l,Xtwiddle,Gtwiddle,Shat7,N0)
      implicit none
C---  Expression for extension of Eq. 5.60a
C---  Calculates C00llll
C---  Small terms of order Xtwiddle(0,k)*Ciiiiii,Xtwiddle(0,0)*Ciiiiiii
C---  Denominator Gtwiddle(k,l)
      include 'pvCnames.f'
      include 'pvCv.f'
      include 'Carraydef.f'
      include 'Carrays.f'
      integer ep,N0,k,l,np
      parameter(np=2)
      double precision Xtwiddle(0:np,0:np),Gtwiddle(np,np)
      double complex Shat7(np,z6max,-2:0)

      do ep=-2,0
      Cv(czziiiii(z5(l,l,l,l,l))+N0,ep)=
     . (Gtwiddle(k,1)*Shat7(1,z6(l,l,l,l,l,l),ep)
     . +Gtwiddle(k,2)*Shat7(2,z6(l,l,l,l,l,l),ep)
     . +Xtwiddle(k,0)*Cv(ciiiiii(z6(l,l,l,l,l,l))+N0,ep)
     . -Xtwiddle(0,0)*Cv(ciiiiiii(z7(k,l,l,l,l,l,l))+N0,ep))
     . /(12d0*Gtwiddle(k,l))
      enddo

      return
      end


module eval_crust_neutrino
    use neutrino_def

    ! number of neutrino flavors, in addition to electron neutrino
    real(dp), parameter :: cn_dn = 2.0_dp
    real(dp), parameter :: cn_snthtw = 0.2319_dp
    real(dp), parameter :: cn_cv = 0.5_dp + 2.0_dp*cn_snthtw
    real(dp), parameter :: cn_ca = 0.5_dp
    real(dp), parameter :: cn_cvp = 1.0_dp - cn_cv
    real(dp), parameter :: cn_cap = 1.0_dp - cn_ca

    contains

    subroutine emissivity(rho,T,ionic,chi,Tcn,include_channel,eps)
        use constants_def
        use nucchem_def, only: composition_info_type
        real(dp), intent(in) :: rho,T,chi
        type(composition_info_type), intent(in) :: ionic
        real(dp), intent(in) :: Tcn
        logical, dimension(num_crust_nu_channels) :: include_channel
        type(crust_neutrino_emissivity_channels), intent(out) :: eps
        real(dp) :: Tme
        real(dp) :: rY,lambda, nn, kn

        Tme  = Melectron*clight2/boltzmann
        rY = rho*ionic%Ye
        lambda = T/Tme

        call clear_epsilon
        if (include_channel(icrust_nu_pair))  &
                & call pair(T,rY,eps% pair)
        if (include_channel(icrust_nu_photo)) &
                &   call photo(eps% photo,rY,lambda)
        if (include_channel(icrust_nu_plasma)) &
                &   call plasma(T,rY,eps% plasma)
        if (include_channel(icrust_nu_brems)) &
                &   call bremsstrahlung(rho,T,ionic,eps% brems)
        if (include_channel(icrust_nu_pbf)) then
            nn = rho*ionic%Yn/amu/(1.0-chi)
            kn = (1.5*pi**2*nn)**onethird / cm_to_fm
            call pbf(kn,T,Tcn,eps% pbf)
        end if
        eps% total = eps% pair + eps% photo + eps% plasma + eps% brems + eps% pbf

        contains
        subroutine clear_epsilon()
            eps% total = 0.0_dp
            eps% pair = 0.0_dp
            eps% photo = 0.0_dp
            eps% plasma = 0.0_dp
            eps% brems = 0.0_dp
            eps% pbf = 0.0_dp
        end subroutine clear_epsilon
    end subroutine emissivity

    subroutine plasma(t,r,q)
        ! plasma.f
        ! modified from formulae routine
        ! Itoh et al. ApJSS 102: 411 (1996)
        !
        ! Input:        t = temperature [K]
        !                       r = density*Ye [g cm**-3]
        ! Returns:  q = plasma neutrino emissivity [ergs/g/s]
        !
        real(dp), intent(in) :: t, r
        real(dp), intent(out) :: q
        real(dp) :: rdouble,x,y,enum,fxy,lamb,gamd,gam,ft,fl,qap
        ! equation (4.1)
        real(dp), parameter :: cvd = cn_cv**2 + cn_dn*cn_cvp**2

        ! equations (4.9)-(4.10)
        rdouble = log10(2.0_dp*r)
        x = (  17.5_dp + rdouble - 3.0_dp*t )/6.0_dp
        y = ( -24.5_dp + rdouble + 3.0_dp*t )/6.0_dp
        enum = min(0.0_dp,y-1.6_dp+1.25_dp*x)
        if (abs(x)>0.7_dp .or. y < 0.0_dp) then
            fxy = 1.0_dp
        else
            fxy = 1.05_dp + (0.39_dp -1.25_dp*x - 0.35_dp*sin(4.5_dp*x) &
            & -0.3_dp*exp(-(4.5_dp*x + 0.9_dp)**2)) &
            & * exp(-(enum/(0.57-0.25*x))**2)
        end if

        ! equation (2.10)
        lamb = 1.686e-10*t

        ! equations (4.6)-(4.8)
        gamd = 1.1095e11*r/((t**2)*sqrt(1.0+(1.019e-6*r)**(2./3.)))
        gam = sqrt(gamd)
      ft   = 2.4 + 0.6*sqrt(gam) + 0.51*gam + 1.25*gam**1.5
      fl   = (8.6*gamd + 1.35*(gam**(7./2.)))/(225. - 17.*gam + gamd )

        ! equation (4.5)
      if (abs(sqrt(gamd)) > 700.0) then
        qap=0.0
      else
        qap = fxy*(fl+ft)*exp(-gam)*(gamd**3)*(lamb**9)*3.0e21
      end if
        q = qap*cvd
    end subroutine plasma

    subroutine pair(temp, rhom, qpai )
        use constants_def, only: onethird
        ! pair.f
        ! modified from mkfit routine
        ! Itoh et al. ApJSS 102: 411 (1996)
        !
        !   input:      temp = temperature [K]
        !                       rhom = rho*Ye           [g cm**-3]
        ! output:       qpai = pair neutrino emissivity [ergs cm**-3 s**-1]
        !
        real(dp), intent(in) :: temp,rhom
        real(dp), intent(out) :: qpai
        real(dp) :: lam,xi,qp1,qp2,qp,fp1,fp2,fp,axi,g

        real(dp), parameter :: a0 =  6.002e19, a1 =  2.084e20, a2 =  1.872e21
        real(dp), parameter :: b1 =  9.383e-1, b2 = -4.141e-1, b3 =  5.829e-2, c =  5.5924e0
        real(dp), parameter :: bh1 =  1.2383, bh2 = -0.8141, bh3 =  0.0, ch =  4.9924
        real(dp), parameter :: coep = (cn_cv**2 + cn_ca**2) + cn_dn*(cn_cvp**2 + cn_cap**2)
        real(dp), parameter :: coem = (cn_cv**2 - cn_ca**2) + cn_dn*(cn_cvp**2 - cn_cap**2)

        ! equations (2.9)-(2.10)
        lam = temp/5.9302e9
        xi = ( rhom*1.0e-9 )**( onethird )/lam

        ! equation (2.6)
        qp1 = 10.74800*lam**2 + 0.3967*sqrt(lam) + 1.005
        qp2 = rhom/(7.692e7*lam**3 + 9.715e6*sqrt(lam))
        qp = (1.0/qp1)*(1.0 + qp2)**(-0.3)

        axi = a0+a1*xi+a2*xi**2

        ! equation (2.7)
        if (xi > 100.0) then
            fp1 = 0.0
        else if (temp < 1.0e10) then
            fp1 = axi*exp(-c*xi)
        else
            fp1 = axi*exp(-ch*xi)
        end if

        if (temp < 1.0e10) then
            fp2 = xi**3 + b1/lam + b2/( lam**2 ) + b3/( lam**3 )
        else
            fp2 = xi**3 + bh1/lam + bh2/( lam**2 ) + bh3/( lam**3 )
        end if
        fp = fp1/fp2

        ! equation (2.8)
        g = 1.0 - 13.04*lam**2 + 133.5*lam**4 +  1534.0*lam**6 + 918.6*lam**8

        ! equation (2.5)
        if ( lam < 7.0e-3 ) then
            qpai = 0.0
        else
            qpai = 0.5*coep*(1.0 + coem/coep*qp)*g*exp(-2.0/lam)*fp
        end if
    end subroutine pair

    subroutine photo(qpho,rhom,lamb)
        use constants_def,only: onethird
        real(dp), intent(in) :: rhom,lamb
        real(dp), intent(out) :: qpho
        real(dp) :: qp,xi,fp
        ! equation (3.2)
        real(dp), parameter :: coe1 = 0.5_dp*(( cn_cv**2 + cn_ca**2 ) + cn_dn*( cn_cvp**2 + cn_cap**2 ) )
        real(dp), parameter :: coe2 =  ((cn_cv**2 - cn_ca**2)  &
                & + cn_dn*(cn_cvp**2 - cn_cap**2))/((cn_cv**2 + cn_ca**2) + cn_dn*(cn_cvp**2 + cn_cap**2))

        qp = cqp(rhom,lamb)
        xi = ( rhom*1.e-9_dp )**( onethird )/lamb
        call cfp(fp,lamb,xi)
      qpho = coe1*(1.0_dp - coe2*qp)*rhom*lamb**5*fp

        contains
        function cqp(rhom,lamb) result(qp)
            real(dp), intent(in) :: rhom, lamb
            real(dp) :: qp
            qp = 0.666_dp*(1.0_dp + 2.045_dp*lamb)**(-2.066_dp)  &
            &   *(1.0_dp + rhom*(1.875e8_dp*lamb + 1.653e8_dp*lamb**2 &
            &   + 8.499e8_dp*lamb**3 - 1.604e8_dp*lamb**4)**(-1))**(-1)
        end function cqp

    end subroutine photo

    subroutine cfp(fp,lamb,xi)
    ! cfp.f
    ! modified from cfp routine
    ! Itoh et al. ApJSS 102: 411 (1996)
    !
    ! input:    temp = temperature [K]
    !                   lamb = T/m_e
    !                   xi = normalized Fermi momentum
    !   returns: fp = fitting function (eq. [3.4]-[3.8])
    !
        real(dp),intent(in) :: lamb,xi
        real(dp),intent(out) :: fp
      real(dp) :: a(0:2), cc(0:2,0:6), d(0:2,1:5)
        real(dp) :: pjt,tau, c, temp
        real(dp), parameter :: pi = 3.141592654_dp
        real(dp), parameter :: b(3) = [ 6.290e-3_dp, 7.483e-3_dp, 3.061e-4_dp ]
        integer :: i, j, k

        temp = lamb*5.9302e9_dp
        if (temp < 1.0e7_dp) then
            ! print *, 'WARNING: temperature < 1.0e7 K'
            fp = 0.0
            return
        else if (temp < 1.0e8) then
            include 'c7-8.par'
            include 'd7-8.par'
            c = 0.5654 + log10(temp/1.0e7_dp)
            tau = log10(temp/1.0e7_dp)
        else if (temp < 1.0e9_dp) then
            include 'c8-9.par'
        include 'd8-9.par'
        c   =  1.5654_dp
        tau = log10(temp/1.0e8_dp)
      else
        include 'c9.par'
        include 'd9.par'
        c   =  1.5654_dp
        tau = log10(temp/1.0e9_dp)
      endif

        do j = 0, 2
            a(j)  = 0.5_dp*cc(j,0) + 0.5_dp*cc(j,6)*cos(10.0_dp*pi*tau)
          do k = 1, 5
            pjt = pi*real(k,dp)*tau
            a(j)= a(j) + cc(j,k)*cos(5.0_dp/3.0_dp*pjt) &
                & +d(j,k)*sin( 5.0_dp/3.0_dp*pjt )
            end do
        end do

        if ( c*xi > 100.0_dp ) then
            fp = 0.d0
        endif

        fp = (a(0) + a(1)*xi + a(2)*xi**2)*exp(-c*xi) &
             &    / (xi**3 + b(1)/lamb+ b(2)/lamb**2 + b(3)/lamb**3)
    end subroutine cfp

    subroutine pbf(kF,T,Tns,qpbf)
        use constants_def
        ! pair-breaking and formation emissivity. Based on fmal. published by
        ! Yakovlev & collaborators.
        !
        ! Reduction factor follows recommendation of Steiner & Reddy (2009).
        real(dp), intent(in) :: kF,T,Tns
        real(dp), intent(out) :: qpbf
        real(dp), parameter :: qpbf_pre = 1.17e21_dp
        real(dp) :: mstar, xF, eF, R, tau, v, v2, F1, F2, F3, F, reduct

        tau = T/Tns
        qpbf = 0.0_dp
        if (kF == 0.0_dp .or. tau > 1.0_dp .or. tau < 0.01_dp ) return
        xF = kF*hbarc_n/Mn_n
        eF = sqrt(1.0_dp+xF**2)
        mstar = eF
        v = sqrt(1.0_dp-tau)*(1.456_dp-0.157_dp/sqrt(tau)+1.764_dp/tau)
        v2 = v**2
        F1 = v2*(0.602_dp + v2*(0.5942_dp + 0.288_dp*v2))
        F2 = sqrt(0.5547+sqrt(0.4453_dp**2+0.01130_dp*v2))
        F3 = exp(-sqrt(4.0_dp*v2+2.245_dp**2)+2.245_dp)
        F = F1*F2*F3
        reduct = (xF/eF)**2
        qpbf = qpbf_pre *(cn_dn+1)* mstar*xF*(T/1.0e9_dp)**7 * F*reduct
    end subroutine pbf

    subroutine bremsstrahlung(rho,T,ionic,qbrems)
        use constants_def
        use nucchem_def, only: composition_info_type
        real(dp), intent(in) :: rho,T
        type(composition_info_type), intent(in) :: ionic
        real(dp), intent(out) :: qbrems
        real(dp), parameter :: threefourth = 3.0_dp/4.0_dp,  &
        & GF = 1.436d-49, Cp2 = 1.675_dp
        real(dp) :: qbrems_pre
        real(dp) :: re, kF, tau, eta, Zbareta, A, B, L

        qbrems_pre =  8.0_dp*pi*GF**2*finestructure**2* &
            & Cp2*(boltzmann/hbar/clight)**6/567.0_dp/hbar/amu
        re = (threefourth/pi*amu/rho/ionic%Ye)**onethird
        kF = (threepisquare*rho*ionic%Ye/amu)**onethird
        tau = 0.5_dp*boltzmann*T/hbar/clight/kF
        eta = (ionic%A/ionic%Z)**onethird/re/cm_to_fm
        Zbareta = ionic%Z * eta
        A = 0.269_dp + 20.0_dp*tau + 0.0168_dp*ionic%Z + 0.00121_dp*eta &
            & - 0.0356_dp*Zbareta + 0.0137_dp*ionic%Z2*tau + 1.54_dp*Zbareta*tau
        B = 1.0_dp + 180.0_dp*tau**2 + 0.483_dp*tau*ionic%Z  &
            & + 20.0_dp*tau*Zbareta*eta + 4.31e-5_dp*ionic%Z2
        L = A/B**threefourth
        qbrems = qbrems_pre*T**6*ionic%Z2*rho*L*(1.0_dp-ionic%Yn)/ionic%A
    end subroutine bremsstrahlung

end module eval_crust_neutrino


MODULE m_integrVEQ

! ----------------------------------------------------------------------
! MODULE: m_integrVEQ.f95
! ----------------------------------------------------------------------
! Purpose:
!  Module for numerical integration of the Variational Equations
! ----------------------------------------------------------------------
! Author :	Dr. Thomas Papanikolaou
!			Cooperative Research Centre for Spatial Information, Australia
! Created:	22 January 2018
! ----------------------------------------------------------------------

      IMPLICIT NONE
      !SAVE

Contains

SUBROUTINE integr_VEQ (MJDo, tsec_start, ro, vo, arc, integID, step, Nparam, orbc, Smatrix, Pmatrix)

! ----------------------------------------------------------------------
! SUBROUTINE: integr_VEQ
! ----------------------------------------------------------------------
! Purpose:
!  Variational Equations solution based on Runge-Kutta numerical integration methods
! ----------------------------------------------------------------------
! Input arguments:
! - to:			Initial Epoch: Modified Julian Day (MJD) in Terrestrial Time (including the fraction of the day)
! - ro: 		Satellite position vector (m) in ICRF
! - vo: 		Satellite velocity vector (m/sec) in ICRF
! - arc:		Orbit arc lenth (seconds)
! - integID: 	Numerical integration method ID number
! 				RK7. RKN7(6)8:	Runge-Kutta-Nystrom 7th order
! 				RK4. RK4:			Runge-Kutta 4th order
! 				RK8.  RK8(7)13:	Runge-Kutta 8th order
! - step: 		Numerical Integrator Stepsize (seconds)
! - Nparam:		Number of parameters to be estimated through the sensitivity matrix
!
! Output arguments:
! - orbc: 		Satellite orbit array in ICRF including the following per epoch:
!               - Modified Julian Day number in TT (including the fraction of the day)
!				- Seconds since 00h in TT
!				- Position vector (m)
!				- Velocity vector (m/sec)
!- Smatrix:		State transition matrix (6*Epochs x 6)
!- Pmatrix:		Sensitivity matrix      (6*Epochs x Np)
! ----------------------------------------------------------------------
! Author :	Dr. Thomas Papanikolaou
!			Cooperative Research Centre for Spatial Information, Australia
! Created:	22 January 2018
! ----------------------------------------------------------------------

      USE mdl_precision
      USE mdl_num
      USE mdl_param
      USE mdl_config
      USE m_veq_rkn768
      USE m_veqC2T
      use pod_yaml
      IMPLICIT NONE

! ----------------------------------------------------------------------
! Dummy arguments declaration
! ----------------------------------------------------------------------
! IN
      REAL (KIND = prec_d), INTENT(IN) :: MJDo, tsec_start
      REAL (KIND = prec_d), INTENT(IN), DIMENSION(3) :: ro, vo
      REAL (KIND = prec_d), INTENT(IN) :: arc
      INTEGER (KIND = prec_int2), INTENT(IN) :: integID
      REAL (KIND = prec_d), INTENT(IN) :: step
	  INTEGER (KIND = prec_int8), INTENT(IN) :: Nparam
! ----------------------------------------------------------------------
! OUT
      REAL (KIND = prec_d), DIMENSION(:,:), ALLOCATABLE, INTENT(OUT) :: orbc, Smatrix, Pmatrix
!      REAL (KIND = prec_d), DIMENSION(:,:), ALLOCATABLE, INTENT(OUT) :: Smatrix_T, Pmatrix_T
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Local variables declaration
! ----------------------------------------------------------------------
      INTEGER (KIND = prec_int8) :: Nepochs
      INTEGER (KIND = prec_int8) :: i, j, iparam, i1, j1
      INTEGER (KIND = prec_int2) :: AllocateStatus, DeAllocateStatus
      REAL (KIND = prec_d) :: lamda_h
      REAL (KIND = prec_d) :: to_sec, tmax, TT, TTo, t
      REAL (KIND = prec_d), DIMENSION(6) :: Zq
      REAL (KIND = prec_d), DIMENSION(3) :: er
      REAL (KIND = prec_d) :: mjd_0, mjd_th, mjdn
      REAL (KIND = prec_d), DIMENSION(3) :: rto, vto, rth, vth
      REAL (KIND = prec_d), DIMENSION(8) :: Zo
      REAL (KIND = prec_d), DIMENSION(6) :: yo, yn, ey
! ----------------------------------------------------------------------
      REAL (KIND = prec_d), DIMENSION(6,6) :: veqZo, veqZ, veqZ_T
      REAL (KIND = prec_d), DIMENSION(:,:), ALLOCATABLE :: veqPo, veqP, veqP_T
      INTEGER (KIND = prec_int2) :: Nveq_rv
      REAL (KIND = prec_d), DIMENSION(:,:), ALLOCATABLE :: Smatrix_T, Pmatrix_T
      CHARACTER (LEN=100) :: mesg
!      LOGICAL stored
! ----------------------------------------------------------------------
      REAL (KIND = prec_d), DIMENSION(3) :: delta_v
	  REAL (KIND = prec_d) :: mjd_ti_pulse, mjd_tj
      INTEGER (KIND = prec_int8) :: N_PULSE_epochs, i1_pulse
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Matrices (Smatrix, Pmatrix) dimension of Variational Equations solution regarding the velocity vector rows
Nveq_rv = 6
IF (.not. yml_write_partial_velocities) THEN
	Nveq_rv = 3
END IF
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Initial Conditions
! ----------------------------------------------------------------------
! Time conversion to seconds (MJD from days to seconds)

! Initial Epoch's Fraction of the day (in seconds)
to_sec = tsec_start !to_sec = (MJDo - INT(MJDo)) * (24.D0 * 3600.D0)

! Final Epoch
tmax = to_sec + arc

! Number of epochs
Nepochs = INT(arc / ABS(step)) + 1

! ----------------------------------------------------------------------
! Dynamic allocatable arrays
! ----------------------------------------------------------------------
ALLOCATE (orbc(Nepochs,8), STAT = AllocateStatus)
if (AllocateStatus .ne. 0) then
        write(mesg, *) "Not enough memory - failed to allocate orbc, dimension = (", Nepochs, ",8)"
        call report ('FATAL', pgrm_name, 'integr_VEQ', mesg, 'src/fortran/m_integrVEQ.f95', 1)
end if
!ALLOCATE (Smatrix(Nepochs,6*6+2), STAT = AllocateStatus)
ALLOCATE (Smatrix(Nepochs,6*Nveq_rv+2), STAT = AllocateStatus)
if (AllocateStatus .ne. 0) then
        write(mesg, *) "Not enought memory - failed to allocate Smatrix, dimension=(", &
                Nepochs, ",", 6*Nveq_rv+2, ")"
        call report ('FATAL', pgrm_name, 'integr_VEQ', mesg, 'src/fortran/m_integrVEQ.f95', 1)
end if
!ALLOCATE (Pmatrix(Nepochs,Nparam*6+2), STAT = AllocateStatus)
ALLOCATE (Pmatrix(Nepochs,Nparam*Nveq_rv+2), STAT = AllocateStatus)
if (AllocateStatus .ne. 0) then
        write(mesg, *) "Not enough memory - failed to allocate Pmatrix, dimension=(", &
                Nepochs, ",", Nparam*Nveq_rv+2, ")"
        call report ('FATAL', pgrm_name, 'integr_VEQ', mesg, 'src/fortran/m_integrVEQ.f95', 1)
end if
If (Nparam /= 0) Then
ALLOCATE (veqPo(6,Nparam), STAT = AllocateStatus)
if (AllocateStatus .ne. 0) then
        write(mesg, *) "Not enought memory - failed to allocate veqPo, dimension = (6,", &
                Nparam, ")"
        call report ('FATAL', pgrm_name, 'integr_VEQ', mesg, 'src/fortran/m_integrVEQ.f95', 1)
end if
Else
ALLOCATE (veqPo(6,1), STAT = AllocateStatus)
if (AllocateStatus .ne. 0) then
        write(mesg, *) "Not enough memory - failed to allocate veqPo, dimension = (6,1)"
        call report ('FATAL', pgrm_name, 'integr_VEQ', mesg, 'src/fortran/m_integrVEQ.f95', 1)
end if
End IF
Smatrix = 0.0D0
Pmatrix = 0.0D0
! Sensitivity Matrix Initial values: veqPo = 0(6xNp)
veqPo = 0.0D0

ALLOCATE (Smatrix_T(Nepochs,6*Nveq_rv+2), STAT = AllocateStatus)
if (AllocateStatus .ne. 0) then
        write(mesg, *) "Not enough memory - failed to allocate Smatrix_T, dimension=(", &
                Nepochs, ",", 6*Nveq_rv+2, ")"
        call report ('FATAL', pgrm_name, 'integr_VEQ', mesg, 'src/fortran/m_integrVEQ.f95', 1)
end if
ALLOCATE (Pmatrix_T(Nepochs,Nparam*Nveq_rv+2), STAT = AllocateStatus)
if (AllocateStatus .ne. 0) then
        write(mesg, *) "Not enough memory - failed to allocate Pmatrix_T, dimension=(", &
                Nepochs, ",", Nparam*Nveq_rv+2, ")"
        call report ('FATAL', pgrm_name, 'integr_VEQ', mesg, 'src/fortran/m_integrVEQ.f95', 1)
end if
Smatrix_T = 0.d0
Pmatrix_T = 0.d0

! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Initial state vector into the orbit array
! ----------------------------------------------------------------------
orbc(1,1) = MJDo
orbc(1,2) = to_sec
orbc(1,3:5) = ro
orbc(1,6:8) = vo
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! VEQ matrices initial conditions
! ----------------------------------------------------------------------
! State Transition Matrix Initial values: veqZo = I (6x6)
veqZo(1,1:6) = (/ 1.D0, 0.D0, 0.D0, 0.D0, 0.D0, 0.D0 /)
veqZo(2,1:6) = (/ 0.D0, 1.D0, 0.D0, 0.D0, 0.D0, 0.D0 /)
veqZo(3,1:6) = (/ 0.D0, 0.D0, 1.D0, 0.D0, 0.D0, 0.D0 /)
veqZo(4,1:6) = (/ 0.D0, 0.D0, 0.D0, 1.D0, 0.D0, 0.D0 /)
veqZo(5,1:6) = (/ 0.D0, 0.D0, 0.D0, 0.D0, 1.D0, 0.D0 /)
veqZo(6,1:6) = (/ 0.D0, 0.D0, 0.D0, 0.D0, 0.D0, 1.D0 /)

! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! VEQ matrices initial epoch values
! ----------------------------------------------------------------------
! State Transition Matrix
Smatrix(1,1) = MJDo
Smatrix(1,2) = to_sec
Smatrix(1,  3:8) = veqZo(1,1:6)
Smatrix(1, 9:14) = veqZo(2,1:6)
Smatrix(1,15:20) = veqZo(3,1:6)
IF (Nveq_rv == 6) Then
Smatrix(1,21:26) = veqZo(4,1:6)
Smatrix(1,27:32) = veqZo(5,1:6)
Smatrix(1,33:38) = veqZo(6,1:6)
End IF

! Sensitivity matrix
Pmatrix(1,1) = MJDo
Pmatrix(1,2) = to_sec
!i = 1
!Pmatrix(1, 2+(i-1)*6+1 : 2+(i-1)*6+6 ) = (/ veqPo(1,i), veqPo(2,i), veqPo(3,i), veqPo(4,i), veqPo(5,i), veqPo(6,i) /)
!Do iparam = 1 , Nparam
!   Pmatrix(1, 2+(iparam-1)*6+1 : 2+(iparam-1)*6+6 ) = &
!   (/ veqPo(1,iparam), veqPo(2,iparam), veqPo(3,iparam), veqPo(4,iparam), veqPo(5,iparam), veqPo(6,iparam) /)
!End Do
i1 = 0
iparam = 0
!Do i1 = 1 , 6
Do i1 = 1 , Nveq_rv
Do iparam = 1 , Nparam
   Pmatrix(1, 2+(i1-1)*Nparam+iparam) = veqPo(i1,iparam)
   !(/ veqP(1,iparam), veqP(2,iparam), veqP(3,iparam), veqP(4,iparam), veqP(5,iparam), veqP(6,iparam) /)
End Do
End Do
i1 = 0
!print *,"Pmatrix(1,:)", Pmatrix(1,:)
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! VEQ matrices transformation from celestial to terrestrial reference system
! ----------------------------------------------------------------------
! Transformation of state transition matrix and sensitivity matrix at initial epoch
CALL veqC2T (MJDo, to_sec, veqZo, veqPo, veqZ_T, veqP_T)

! State Transition Matrix in itrs
Smatrix_T(1,1) = MJDo
Smatrix_T(1,2) = to_sec
Smatrix_T(1,  3:8) = veqZ_T(1,1:6)
Smatrix_T(1, 9:14) = veqZ_T(2,1:6)
Smatrix_T(1,15:20) = veqZ_T(3,1:6)
IF (Nveq_rv == 6) Then
Smatrix_T(1,21:26) = veqZ_T(4,1:6)
Smatrix_T(1,27:32) = veqZ_T(5,1:6)
Smatrix_T(1,33:38) = veqZ_T(6,1:6)
End IF

! Sensitivity matrix in ITRS
Pmatrix_T(1,1) = MJDo
Pmatrix_T(1,2) = to_sec
i1 = 0
iparam = 0
!Do i1 = 1 , 6
Do i1 = 1 , Nveq_rv
Do iparam = 1 , Nparam
   Pmatrix_T(1, 2+(i1-1)*Nparam+iparam) = veqP_T(i1,iparam)
End Do
End Do
i1 = 0
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Numerical integration methods
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Runge-Kutta-Nystrom RKN7(6)-8 method
! ----------------------------------------------------------------------
If (integID == RK7) Then

! RKN7(6)-8 lamda parameter for stepsize control
lamda_h = 0.001D0

!i = 1
!Do t = to_sec , step , tmax-1

TT = to_sec
Do j = 1 , Nepochs-1

	! Epoch to
    Zo(1) = orbc(j,1)
    Zo(2) = orbc(j,2)
    Zo(3:8) = orbc(j,3:8)

! ----------------------------------------------------------------------
!print *,"VEQ INEGR RKN768 Step", TT
    ! Numerical integration for the next epoch
    !Call integr_rkn768(Zo, step, lamda_h, Zq, er)
	Call veq_rkn768(Zo, veqZo, veqPo, step, lamda_h, Nparam, Zq, er, veqZ, veqP)

	! Next epoch TT (to+h)
    TT = TT + step

	! Seconds since 00h
	TTo = TT
	If (TT >= 86400.D0) Then
		TTo = TT - INT(TT / 86400.D0) * 86400.D0
	End IF
	If (TT < 0.D0) Then
		TTo = TT + (INT(ABS(TT)/86400.D0)+1) * 86400.D0
	End IF

	! MJD and Seconds
	orbc(j+1,1) = INT(MJDo) + TT / (24.0D0 * 3600.0D0)
	orbc(j+1,2) = TTo

	! State vector at the next epoch TT (to+h) in the GCRS
	orbc(j+1,3:8) = Zq
!	print *,"orbc t", orbc(j+1,1:2)
!	print *,"orbc r", orbc(j+1,3:5)

	! VEQ matrices at the next epoch TT (to+h)
	! State Transition Matrix
	Smatrix(j+1,1) = orbc(j+1,1)
	Smatrix(j+1,2) = orbc(j+1,2)
	Smatrix(j+1,  3:8) = veqZ(1,1:6)
	Smatrix(j+1, 9:14) = veqZ(2,1:6)
	Smatrix(j+1,15:20) = veqZ(3,1:6)
IF (Nveq_rv == 6) Then
	Smatrix(j+1,21:26) = veqZ(4,1:6)
	Smatrix(j+1,27:32) = veqZ(5,1:6)
	Smatrix(j+1,33:38) = veqZ(6,1:6)
END IF

	! Sensitivity matrix
	Pmatrix(j+1,1) = orbc(j+1,1)
	Pmatrix(j+1,2) = orbc(j+1,2)
	!Do iparam = 1 , Nparam
	!   Pmatrix(j+1, 2+(iparam-1)*6+1 : 2+(iparam-1)*6+6 ) = &
	!   (/ veqP(1,iparam), veqP(2,iparam), veqP(3,iparam), veqP(4,iparam), veqP(5,iparam), veqP(6,iparam) /)
	!End Do

	i1 = 0
	iparam = 0
	!Do i1 = 1 , 6
	Do i1 = 1 , Nveq_rv
	Do iparam = 1 , Nparam
	   Pmatrix(j+1, 2+(i1-1)*Nparam+iparam) = veqP(i1,iparam)
	End Do
	End Do
!print *,"m_integrVEQf03: j,Nepochs",j,Nepochs
!print *,"m_integrVEQf03: Nparam ", Nparam
!print *,"m_integrVEQf03: veqP   ", veqP(1,:)
!print *,"m_integrVEQf03: Pmatrix", Pmatrix(j+1,3:Nparam+2)
!print *,"m_integrVEQf03: veqPo  ", veqPo
!print *,"m_integrVEQf03: veqP   ", veqP
!print *,"m_integrVEQf03: Pmatrix", Pmatrix(j+1,:)

    ! Initial VEQ arrays at next epoch numerical integration
    veqZo = veqZ
    veqPo = veqP

! ----------------------------------------------------------------------
! VEQ matrices transformation from celestial to terrestrial reference system
	mjd_th = INT(MJDo) + TT / (24.0D0 * 3600.0D0)
	CALL veqC2T (mjd_th, TTo, veqZ, veqP, veqZ_T, veqP_T)
! State Transition Matrix in itrs at the next epoch TT (to+h)
	Smatrix_T(j+1,1) = orbc(j+1,1)
	Smatrix_T(j+1,2) = orbc(j+1,2)
	Smatrix_T(j+1,  3:8) = veqZ_T(1,1:6)
	Smatrix_T(j+1, 9:14) = veqZ_T(2,1:6)
	Smatrix_T(j+1,15:20) = veqZ_T(3,1:6)
IF (Nveq_rv == 6) Then
	Smatrix_T(j+1,21:26) = veqZ_T(4,1:6)
	Smatrix_T(j+1,27:32) = veqZ_T(5,1:6)
	Smatrix_T(j+1,33:38) = veqZ_T(6,1:6)
END IF
! Sensitivity matrix in ITRS
	Pmatrix_T(j+1,1) = orbc(j+1,1)
	Pmatrix_T(j+1,2) = orbc(j+1,2)
	i1 = 0
	iparam = 0
	Do i1 = 1 , Nveq_rv
	Do iparam = 1 , Nparam
	   Pmatrix_T(j+1, 2+(i1-1)*Nparam+iparam) = veqP_T(i1,iparam)
	End Do
	End Do
! ----------------------------------------------------------------------

End DO
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Runge-Kutta RK8(7)-13 method
! ----------------------------------------------------------------------
Else If (integID == RK8) Then

TT = to_sec
yn = 0.d0
Do j = 1 , Nepochs-1
	! Epoch to
    mjd_0 = orbc(j,1)
    yo = orbc(j,3:8)

    ! Numerical integration for computation of the state vector at next epoch
    !Call integr_rk87 (mjd_0, yo, step, mjdn, yn, ey)

	! Next epoch TT (to+h)
    TT = TT + step

	! Seconds since 00h
	TTo = TT
	If (TT >= 86400.D0) Then
		TTo = TT - INT(TT / 86400.D0) * 86400.D0
	End IF

	! MJD and Seconds
	orbc(j+1,1) = INT(MJDo) + TT / (24.0D0 * 3600.0D0)
	orbc(j+1,2) = TTo

	! State vector at the next epoch TT (to+h) in the GCRS
	orbc(j+1,3:8) = yn

	! VEQ matrices at the next epoch TT (to+h)
	! State Transition Matrix
	Smatrix(j+1,1) = orbc(j+1,1)
	Smatrix(j+1,2) = orbc(j+1,2)
	Smatrix(j+1,  3:8) = veqZ(1,1:6)
	Smatrix(j+1, 9:14) = veqZ(2,1:6)
	Smatrix(j+1,15:20) = veqZ(3,1:6)
IF (Nveq_rv == 6) Then
	Smatrix(j+1,21:26) = veqZ(4,1:6)
	Smatrix(j+1,27:32) = veqZ(5,1:6)
	Smatrix(j+1,33:38) = veqZ(6,1:6)
END IF

	! Sensitivity matrix
	Pmatrix(j+1,1) = orbc(j+1,1)
	Pmatrix(j+1,2) = orbc(j+1,2)
	!Do iparam = 1 , Nparam
	!   Pmatrix(j+1, 2+(iparam-1)*6+1 : 2+(iparam-1)*6+6 ) = &
	!   (/ veqP(1,iparam), veqP(2,iparam), veqP(3,iparam), veqP(4,iparam), veqP(5,iparam), veqP(6,iparam) /)
	!End Do
        !stored = .false.
        !if (allocated(veqP)) then
        !if (size(veqP, 1) == Nveq_rv) then
        !if (size(veqP, 2) == Nparam) then
	!Do i1 = 1 , 6
	Do i1 = 1 , Nveq_rv
	Do iparam = 1 , Nparam
	   Pmatrix(j+1, 2+(i1-1)*Nparam+iparam) = veqP(i1,iparam)
	End Do
	End Do
        !stored = .true.
        !End If
        !End If
        !End If
        !if (.not.stored) then
        !        DO i1 = 1, Nveq_rv
        !        Do iparam = 1, Nparam
        !        Pmatrix (j+1, 2+(i1-1)*Nparam+iparam) = 0.d0
        !        End Do
        !        End Do
        !End if
End DO
! ----------------------------------------------------------------------

End If

! ----------------------------------------------------------------------
! VEQ Reference System
IF (yml_veq_refsys == ITRF) THEN
	Smatrix = Smatrix_T
	Pmatrix = Pmatrix_T
END IF
! ----------------------------------------------------------------------

 100 End Subroutine

End Module


      subroutine hdrive(alpha,m,xlen,run,peak)
c
c     + + + PURPOSE + + +
c     Computes the runoff hydrograph on a plane using the
c     kinematic wave model.  The solution is by the method
c     of characteristics.
c     The lateral inflow (rainfall excess) is presented as a
c     positive step function up to a given time and is zero
c     thereafter. (If step value is given as zero, it is set
c     to 1.e-8.)
c
c     Called from IRS.
c     Author(s): Shirley, Stone
c     Reference in User Guide:
c
c     Changes:
c
c     Version: This module recoded from WEPP version 91.10.
c     Date recoded: 04/26/91 - 04/29/91.
c     Recoded by: Charles R. Meyer.
c
c     + + + KEYWORDS + + +
c
c     + + + ARGUMENT DECLARATIONS + + +
      real alpha, m, xlen, run, peak
c
c     + + + ARGUMENT DEFINITIONS + + +
c     alpha  - depth discharge coefficient
c     m      - depth discharge exponent
c     xlen   - length of equivalent plane
c     run    - runoff volume
c     peak   - peak discharge
c
c     + + + PARAMETERS + + +
c
      include 'pmxelm.inc'
      include 'pmxtim.inc'
      include 'pmxpln.inc'
c
c     + + + COMMON BLOCKS + + +
      include 'cdata3.inc'
c     modify: dt, nqt
c
      include 'chydrol.inc'
c       read: durexr
c      write: durrun
c
      include 'cintgrl.inc'
c      write: ii
c
      include 'cpass2.inc'
c        read: t(mxtime)
      include 'cpass3.inc'
c        read: ns
c       write: nq
      include 'cpass4.inc'
c      modify: tq1(mxtime),q(mxtime),qtot(mxtime)
c
c     + + + LOCAL VARIABLES + + +
      real qsum, qlast, qtmax, t1, t2, d
      integer begrun, i
c
c     + + + LOCAL DEFINITIONS + + +
c     begrun - flag for beginning of runoff
c     qsum   - sum of all Q(I)'s
c     qlast  - value of the last Q(I)
c     i      - counter in L0 Loop
c     qtmax  - 95% of runoff volume used to stop hydrograph computations
c     t1     - previous value of T2
c     t2     - current time step
c     d      - flow depth
c
c     + + + SUBROUTINES CALLED + + +
c     bgnrnd
c
c     + + + FUNCTION DECLARATIONS + + +
      real hdepth
c
c     + + + END SPECIFICATIONS + + +
c
c
c******************************************************************
c                                                                 *
c     Subroutine INIT reads in plane parameters and rainfall      *
c     excess values, c and initializes for calls to subroutine h. *
c     Subroutine h computes depth of flow on the plane.           *
c                                                                 *
c******************************************************************
c
c
      peak = 0.
      begrun = 0
      nqt = 0
      ii = 1
c
      call bgnrnd(1842.)
c
      dt = 60.
      nq = ns + 10
      qsum = 0.
      qlast = 0.
c
      do 10 i = 1, mxtime
        qtot(i) = 0.
   10 continue
c
      qtmax = .95 * run
c
c     *** BEGIN L0 LOOP ***
c
c     Step through the rainfall excess times, get the flow depth and compute
c     the hydrograph.
c
      i = 0
   20 i = i + 1
c
      if (i.le.(ns+1)) then
        t2 = t(i)
      else
        t2 = t2 + dt
      end if
c
      d = hdepth(t2,xlen)
      tq1(i) = t2
c
      if (begrun.eq.0.and.d.gt.0.) then
        begrun = 1
      end if
c
      q(i) = alpha * d ** m
c
      if (i.gt.1) then
        qsum = qsum + (q(i)+qlast) * (t2-t1) / 2.0
c       warning from ftnchek
c       Variables may be used before set in module HDRIVE:
c       T1
        qtot(i+1) = qsum
      end if
c
      qlast = q(i)
      t1 = t2
      if (q(i).gt.peak) peak = q(i)
c
c     *** END L0 LOOP ***
      if ((i.lt.(mxtime-1)).and.(i.lt.ns+200).and.
     1    ((qtot(i+1)/xlen).lt.qtmax)) go to 20
c
c
      nqt = i + 1
      tq1(nqt) = t2 + dt
      d = hdepth(tq1(nqt),len)
      q(nqt) = alpha * d ** m
c
      peak = peak / xlen
c
      return
      end


*     SB10ID EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2020 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, MMAX, PMAX
      PARAMETER        ( NMAX = 10, MMAX = 10, PMAX = 10 )
      INTEGER          LDA, LDAK, LDB, LDBK, LDC, LDCK, LDD, LDDK
      PARAMETER        ( LDA  = NMAX, LDAK = NMAX, LDB  = NMAX,
     $                   LDBK = NMAX, LDC  = PMAX, LDCK = MMAX,
     $                   LDD  = PMAX, LDDK = MMAX )
      INTEGER          LIWORK
      PARAMETER        ( LIWORK = MAX( 2*NMAX, NMAX*NMAX, MMAX, PMAX ) )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = 4*NMAX*NMAX + MMAX*MMAX + PMAX*PMAX +
     $                            2*MMAX*NMAX + NMAX*PMAX + 4*NMAX +
     $                            MAX( 10*NMAX*NMAX + 8*NMAX + 5,
     $                                    NMAX*PMAX + 2*NMAX ) )
*     .. Local Scalars ..
      DOUBLE PRECISION FACTOR
      INTEGER          I, INFO, J, M, N, NK, NP
*     .. Local Arrays ..
      LOGICAL          BWORK(2*NMAX)
      INTEGER          IWORK(LIWORK)
      DOUBLE PRECISION A(LDA,NMAX), AK(LDA,NMAX), B(LDB,MMAX),
     $                 BK(LDBK,PMAX), C(LDC,NMAX), CK(LDCK,NMAX),
     $                 D(LDD,MMAX), DK(LDDK,PMAX), DWORK(LDWORK),
     $                 RCOND( 2 )
*     .. External Subroutines ..
      EXTERNAL         SB10ID
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, M, NP
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99990 ) N
      ELSE IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
         WRITE ( NOUT, FMT = 99989 ) M
      ELSE IF ( NP.LT.0 .OR. NP.GT.PMAX ) THEN
         WRITE ( NOUT, FMT = 99988 ) NP
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N )
         READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,NP )
         READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,NP )
         READ ( NIN, FMT = * ) FACTOR
         CALL SB10ID( N, M, NP, A, LDA, B, LDB, C, LDC, D, LDD,
     $                FACTOR, NK, AK, LDAK, BK, LDBK, CK, LDCK,
     $                DK, LDDK, RCOND, IWORK, DWORK, LDWORK,
     $                BWORK, INFO )
         IF ( INFO.EQ.0 ) THEN
            WRITE ( NOUT, FMT = 99997 )
            DO 10 I = 1, NK
               WRITE ( NOUT, FMT = 99992 ) ( AK(I,J), J = 1,NK )
   10       CONTINUE
            WRITE ( NOUT, FMT = 99996 )
            DO 20 I = 1, NK
               WRITE ( NOUT, FMT = 99992 ) ( BK(I,J), J = 1,NP )
   20       CONTINUE
            WRITE ( NOUT, FMT = 99995 )
            DO 30 I = 1, M
               WRITE ( NOUT, FMT = 99992 ) ( CK(I,J), J = 1,NK )
   30       CONTINUE
            WRITE ( NOUT, FMT = 99994 )
            DO 40 I = 1, M
               WRITE ( NOUT, FMT = 99992 ) ( DK(I,J), J = 1,NP )
   40       CONTINUE
            WRITE( NOUT, FMT = 99993 )
            WRITE( NOUT, FMT = 99991 ) ( RCOND(I), I = 1, 2 )
         ELSE
            WRITE( NOUT, FMT = 99998 ) INFO
         END IF
      END IF
      STOP
*
99999 FORMAT (' SB10ID EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (/' INFO on exit from SB10ID =',I2)
99997 FORMAT (/' The controller state matrix AK is'/)
99996 FORMAT (/' The controller input matrix BK is'/)
99995 FORMAT (/' The controller output matrix CK is'/)
99994 FORMAT (/' The controller matrix DK is'/)
99993 FORMAT (/' The estimated condition numbers are'/)
99992 FORMAT (10(1X,F9.4))
99991 FORMAT ( 2(1X,D12.5))
99990 FORMAT (/' N is out of range.',/' N = ',I5)
99989 FORMAT (/' M is out of range.',/' M = ',I5)
99988 FORMAT (/' NP is out of range.',/' NP = ',I5)
      END


!*****************************************************************************
!
! Rokko: Integrated Interface for libraries of eigenvalue decomposition
!
! Copyright (C) 2012-2020 by Rokko Developers https://github.com/t-sakashita/rokko
!
! Distributed under the Boost Software License, Version 1.0. (See accompanying
! file LICENSE_1_0.txt or copy at http://www.boost.org/license_1_0.txt)
!
!*****************************************************************************

program main
  use mpi
  implicit none
  integer, parameter :: n = 8, nb = 1
  integer :: provided, ierr, myrank, nprocs
  integer :: icontxt, npcol, nprow, desc(9)
  integer :: i, j, info
  real(4), allocatable :: a(:, :), z(:,:), w(:)
  integer :: lwork, liwork
  real(4), allocatable :: work(:)
  integer, allocatable :: iwork(:)

  call MPI_init_thread(MPI_THREAD_MULTIPLE, provided, ierr)
  call MPI_comm_rank(MPI_COMM_WORLD, myrank, ierr)
  call MPI_comm_size(MPI_COMM_WORLD, nprocs, ierr)
  nprow = int(sqrt(1. * nprocs + 0.5))
  npcol = int(1. * nprocs / nprow)
  if (myrank == 0) then
     print *, "n =", n
     print *, "nprocs =", nprocs
     print *, "nprow =", nprow
     print *, "npcol =", npcol
     if ((nprocs /= nprow * npcol) .or. (mod(n, nprow) /= 0) .or. &
          (mod(n, npcol) /= 0)) then
        print *, "incompatible matrix size and number of processes"
        call MPI_Abort(MPI_COMM_WORLD, 127, ierr)
     end if
  end if
  call BLACS_get(0, 0, icontxt)
  call BLACS_gridinit(icontxt, 'R', nprow, npcol)

  call descinit(desc, n, n, nb, nb, 0, 0, icontxt, n/nprow, info)
  allocate(a(n/nprow, n/npcol), z(n/nprow, n/npcol), w(n))
  do j = 1, n
     do i = 1, n
        call pselset(a, i, j, desc, real(min(i, j)))
     end do
  end do

  lwork = -1
  liwork = 1
  allocate(work(1), iwork(1))
  call pssyevd('V', 'U', n, a, 1, 1, desc, w, z, 1, 1, desc, work, lwork, iwork, liwork, info)
  lwork = int(work(1))
  liwork = iwork(1)
  deallocate(work, iwork)
  allocate(work(lwork), iwork(liwork))

  call pssyevd('V', 'U', n, a, 1, 1, desc, w, z, 1, 1, desc, work, lwork, iwork, liwork, info)
  if (myrank == 0) then
     print *, "eigenvalues:", w(:)
  end if

  deallocate(a, z, w, work, iwork)
  call BLACS_gridexit(icontxt)
  call MPI_finalize(ierr)
end program main


*--#[ log:
*	$Id: ffcrr.f,v 1.5 1995/11/10 19:04:23 gj Exp $
*	$Log: ffcrr.f,v $
c Revision 1.5  1995/11/10  19:04:23  gj
c Added nicer logging header...
c
c Revision 1.4  1995/10/17  06:55:07  gj
c Fixed ieps error in ffdcrr (ffcxs4.f), added real case in ffcrr, debugging
c info in ffxd0, and warned against remaining errors for del2=0 in ffrot4
c (ffxd0h.f)
c
c Revision 1.3  1995/10/06  09:17:20  gj
c Found stupid typo in ffxc0p which caused the result to be off by pi^2/3 in
c some equal-mass cases.  Added checks to ffcxs4.f ffcrr.f.
c
*--#] log:

*###[ ffcrr:
	subroutine ffcrr(crr,ipi12,cy,cy1,cz,cz1,cdyz,ld2yzz,cd2yzz,czz,
     +					czz1,isoort,ieps,ier)
***#[*comment:***********************************************************
*									*
*	calculates R as defined in appendix b:				*
*									*
*			/1   log(y-y1+ieps) - log(y0-y1+ieps)		*
*	r(y0,y1,iesp) = \ dy --------------------------------		*
*			/0		y-y0				*
*									*
*	    = li2(c1) - li2(c2) 					*
*		+ eta(-y1,1/(y0-y1))*log(c1)				*
*		- eta(1-y1,1/(y0-y1))*log(c2)				*
*	with								*
*	    c1 = y0 / (y0-y1), c2 = (y0-1) / (y0-y1)			*
*									*
*	the factors pi^2/12 are passed separately in the integer ipi12	*
*	ier is a status flag: 0=ok, 1=numerical problems, 2=error	*
*									*
*	Input:	cy	(complex)					*
*		cy1	(complex)	1-y				*
*		cz	(complex)					*
*		cz1	(complex)	1-z				*
*		cdyz	(complex)	y-z				*
*		ieps	(integer)	denotes sign imaginary part of	*
*					argument logs (0: don't care;	*
*					+/-1: add -ieps to z; +/-2:	*
*					direct in dilogs, no eta's)	*
*									*
*	Output	crr	(complex)	R modulo factors pi^2/12	*
*		ipi12	(integer)	these factors			*
*		ier	(integer)	lost ier digits, >100: error	*
*									*
***#]*comment:***********************************************************
*  #[ declarations:
	implicit none
*
*	arguments
*
	integer ipi12,isoort,ieps,ier
	logical ld2yzz,lreal
	DOUBLE COMPLEX crr(7),cy,cy1,cz,cz1,cdyz,cd2yzz,czz,czz1
*
*	local variables
*
	DOUBLE COMPLEX cfact,cc1,cc2,cc1p,cc2p,carg1,carg2,carg3,
     +		cli1,cli2,cli3,clo1,clo2,clo3,clog1p,clog2p,chill,
     +		cd2,cd21,cd2n,cd21n1,cc1n,cterm,ctot,zfflo1,clog1,clog2,
     +		cc,cli4,clo4
	DOUBLE COMPLEX ctroep,zfflog
	DOUBLE PRECISION xa,xr,absc,xprec,bndtay,ffbnd
	DOUBLE PRECISION y,y1,z,z1,dyz,d2yzz,zz,zz1
	integer i,nffeta,nffet1,iclas1,iclas2,n1,n2,n3,ntot,
     +		i2pi,n3p
	external zfflog,zfflo1,ffbnd,nffeta,nffet1
	save xprec,bndtay
*
*	common blocks
*
	include 'ff.h'
*
*	statement function
*
	absc(cc) = abs(DBLE(cc)) + abs(DIMAG(cc))
*  #] declarations:
*  #[ initialisations:
	data xprec /-1D0/
	if ( xprec .ne. precx ) then
	    xprec = precx
	    bndtay = ffbnd(2,18,xn2inv)
*	    print *,'bndtay = ',bndtay
	endif
*  #] initialisations:
*  #[ real case:
	if ( DIMAG(cy).eq.0 .and. DIMAG(cy1).eq.0 .and. DIMAG(cz).eq.0
     +		.and. DIMAG(cz1).eq.0 ) then
	    y  = DBLE(cy)
	    y1 = DBLE(cy1)
	    z  = DBLE(cz)
	    z1 = DBLE(cz1)
	    dyz = DBLE(cdyz)
	    d2yzz = DBLE(cd2yzz)
	    zz = DBLE(czz)
	    zz1 = DBLE(czz1)
	    call ffcxr(crr,ipi12,y,y1,z,z1,dyz,ld2yzz,d2yzz,zz,zz1,
     +		.FALSE.,0D0,ieps,ier)
	    return
	endif
*  #] real case:
*  #[ arguments:
*
*	get the arguments
*
	xa = absc(cdyz)
	if ( xa .eq. 0 ) then
	    return
*	This line is for 68000 compilers that have a limited range for
*	complex division (Absoft, Apollo, Gould NP1):
	elseif ( DBLE(cdyz) .lt. xclogm .or. DIMAG(cdyz) .lt. xclogm
     +		.or. 1/xa .lt. xclogm ) then
	    ctroep = cdyz*DBLE(1/xa)
	    cfact = 1/ctroep
	    cfact = DBLE(1/xa)*cfact
	else
	    cfact = 1/cdyz
	endif
	cc1 = cy * cfact
	cc2 = - cy1 * cfact
*
*	see if we just need the real part
*
	lreal = mod(isoort,5) .eq. 0
*  #] arguments:
*  #[ which area?:
*
*	determine the area:	1={|x|<=1,Re(x)<=1/2},
*				2={|1-x|<=1,Re(x)>1/2}
*				3={|x|>1,|1-x|>1}
*
	xr = DBLE(cc1)
	xa = absc(cc1)
	if ( xa .gt. 1 .and. xa .lt. 1+sqrt(2.) ) then
*	    we need a more accurate estimate
	    xa = xr**2 + DIMAG(cc1)**2
	endif
	if ( ld2yzz .and. absc(cc1+1) .lt. xloss/2 ) then
	    iclas1 = 4
	    cc1p = cc1
	elseif ( xa .le. 1 .and. xr .le. 0.5 ) then
	    iclas1 = 1
	    cc1p = cc1
	elseif ( xa .lt. 1+sqrt(2.) .and. xa .lt. 2*xr ) then
	    iclas1 = 2
	    cc1p = -cz * cfact
	    if ( abs(DIMAG(cc1p)) .lt. precc*abs(DBLE(cc1p)) )
     +		cc1p = DBLE(cc1p)
	else
	    iclas1 = 3
	    if ( 1/xa .lt. xclogm ) then
		ctroep = cc1*DBLE(1/xa)
		ctroep = 1/ctroep
		cc1p = ctroep*DBLE(1/xa)
	    else
		cc1p = 1/cc1
	    endif
	endif
	xr = DBLE(cc2)
	xa = absc(cc2)
	if ( xa .gt. 1 .and. xa .lt. 1+sqrt(2.) ) then
	    xa = xr**2 + DIMAG(cc2)**2
	endif
	if ( ld2yzz .and. absc(cc2+1) .lt. xloss ) then
	    iclas2 = 4
	    cc2p = cc2
	elseif ( xa .le. 1 .and. xr .le. 0.5 ) then
	    iclas2 = 1
	    cc2p = cc2
	elseif ( xa .lt. 1+sqrt(2.) .and. xa .lt. 2*xr ) then
	    iclas2 = 2
	    cc2p = cz1 * cfact
	    if ( abs(DIMAG(cc2p)) .lt. precc*abs(DBLE(cc2p)) )
     +		cc2p = DBLE(cc2p)
	else
	    iclas2 = 3
	    if ( 1/xa .lt. xclogm ) then
		ctroep = cc2*DBLE(1/xa)
		ctroep = 1/ctroep
		cc2p = ctroep*DBLE(1/xa)
	    else
		cc2p = 1/cc2
	    endif
	endif
*
*	throw together if they are close
*
	if ( iclas1 .ne. iclas2 .and. absc(cc1-cc2) .lt. 2*xloss )
     +		then
*	    we don't want trouble with iclasn = 4
	    if ( iclas1 .eq. 4 ) iclas1 = 1
	    if ( iclas2 .eq. 4 ) iclas2 = 1
	    if ( iclas1 .eq. iclas2 ) goto 5
*	    go on
	    if ( iclas1 .le. iclas2 ) then
		iclas2 = iclas1
		if ( iclas1 .eq. 1 ) then
		    cc2p = cc2
		else
		    cc2p = cz1*cfact
		endif
	    else
		iclas1 = iclas2
		if ( iclas1 .eq. 1 ) then
		    cc1p = cc1
		else
		    cc1p = -cz*cfact
		endif
	    endif
	endif
    5	continue
*  #] which area?:
*  #[ eta's:
*
*	get eta1 and eta2
*
	if ( abs(ieps) .ge. 2 .or. isoort .eq. -2 ) then
	    n1 = 0
	    n2 = 0
	else
	if ( DIMAG(cz) .eq. 0 .or. DIMAG(cz1) .eq. 0 ) then
	    if ( DIMAG(cz1) .eq. 0 ) then
		if ( DIMAG(cz) .eq. 0 ) then
*		    cz is really real, the hard case:
		    if ( cz .eq. 0 ) then
*			multiplied with log(1), so don't care:
			n1 = 0
*			look at ieps for guidance
*			n2 = nffet1(DCMPLX(DBLE(0),DBLE(ieps)),cfact,cfact,ier) = 0
			n2 = 0
		    elseif ( cz1 .eq. 0 ) then
			n1 = nffet1(DCMPLX(DBLE(0),DBLE(ieps)),cfact,
     +				-cfact,ier)
			n2 = 0
		    else
			n1 = nffet1(DCMPLX(DBLE(0),DBLE(ieps)),cfact,
     +				-cz*cfact,ier)
			n2 = nffet1(DCMPLX(DBLE(0),DBLE(ieps)),cfact,
     +				cz1*cfact,ier)
		    endif
		else
		    n1 = nffet1(-cz,cfact,-cz*cfact,ier)
		    n2 = nffet1(-cz,cfact,cz1*cfact,ier)
		endif
	    else
		n1 = nffet1(cz1,cfact,-cz*cfact,ier)
		n2 = nffet1(cz1,cfact,cz1*cfact,ier)
	    endif
	else
*	    the imaginary part of cc1, cc1p is often very unstable.
*	    make sure it agrees with the actual sign used.
	    if ( iclas1 .eq. 2 ) then
		if ( DIMAG(cc1p) .eq. 0 ) then
*		    if y (or y1 further on) is purely imaginary
*		    give a random shift, this will also be used in
*		    the transformation terms.  Checked 7-mar-94 that it
*		    is independent of the sign used.
		    if ( DBLE(cy).eq.0 ) cy = cy +
     +			isgnal*DBLE(precc)*DIMAG(cy)
		    n1 = nffet1(-cz,cfact,DCMPLX(DBLE(0),ieps*DBLE(cy)),
     +			ier)
		else
		    n1 = nffet1(-cz,cfact,cc1p,ier)
		endif
	    else
		if ( DIMAG(cc1) .eq. 0 ) then
		    if ( DBLE(cy1).eq.0 ) cy1 = cy1 +
     +			isgnal*DBLE(precc)*DIMAG(cy)
		    n1 = nffet1(-cz,cfact,DCMPLX(DBLE(0),
     +					-ieps*DBLE(cy1)),ier)
		else
		    n1 = nffet1(-cz,cfact,-cc1,ier)
		endif
	    endif
	    if ( iclas2 .eq. 2 ) then
		if ( DIMAG(cc2p) .eq. 0 ) then
		    if ( DBLE(cy).eq.0 ) cy = cy +
     +			isgnal*DBLE(precc)*DIMAG(cy)
		    n2 = nffet1(cz1,cfact,DCMPLX(DBLE(0),ieps*DBLE(cy)),
     +			ier)
		else
		    n2 = nffet1(cz1,cfact,cc2p,ier)
		endif
	    else
		if ( DIMAG(cc2) .eq. 0 ) then
		    if ( DBLE(cy1).eq.0 ) cy1 = cy1 +
     +			isgnal*DBLE(precc)*DIMAG(cy)
		    n2 = nffet1(cz1,cfact,DCMPLX(DBLE(0),
     +					-ieps*DBLE(cy1)),ier)
		else
		    n2 = nffet1(cz1,cfact,-cc2,ier)
		endif
	    endif
	endif
	endif
*  #] eta's:
*  #[ calculations:
*	3-oct-1995 changed code to only use second criterium if the
*	Taylor expansion is used - otherwise the Hill identity will
*	only make things worse
	if ( iclas1 .eq. iclas2 .and. isoort .ne. -2 .and.
     +		( absc(cc1p-cc2p) .lt. 2*xloss*absc(cc1p)
     +		.or. lreal .and. abs(DBLE(cc1p-cc2p)) .lt. 2*xloss*
     +			abs(DBLE(cc1p)) .and. (abs(DBLE(cc2p)) +
     +			DIMAG(cc2p)**2/4) .lt. xloss .and.
     +			abs(DIMAG(cc2p)) .lt. bndtay ) ) then
*	    Close together:
* -#[	    handle dilog's:
	    if ( .not. lreal .and. absc(cc2p) .gt. xloss
     +		 .or. lreal .and. ( (abs(DBLE(cc2p)) + DIMAG(cc2p)**2/4)
     +			.gt. xloss .or. abs(DIMAG(cc2p)) .gt. bndtay ) )
     +		then
*--#[		Hill identity:
*
*		Use the Hill identity to get rid of the cancellations.
*
*
*	    first get the arguments:
*
		if ( iclas1 .eq. 1 .or. iclas1 .eq. 4 ) then
		    carg1 = 1/cy
		    carg2 = 1/cz1
		    carg3 = carg2/cc1p
		elseif ( iclas1 .eq. 2 ) then
		    carg1 = 1/cz
		    carg2 = 1/cy1
		    carg3 = carg2/cc1p
		elseif ( iclas1 .eq. 3 ) then
		    carg1 = 1/cy1
		    carg3 = 1/cz1
		    carg2 = carg3*cc1p
		endif
		call ffzli2(cli1,clo1,carg1,ier)
		call ffzli2(cli2,clo2,carg2,ier)
		call ffzli2(cli3,clo3,carg3,ier)
		if ( absc(cc2p) .lt. xloss ) then
		    clog2p = zfflo1(cc2p,ier)
		else
		    clog2p = zfflog(1-cc2p,0,czero,ier)
		endif
		chill = clo1*clog2p
*--#]		Hill identity:
	    else
*--#[		Taylor expansion:
*
*		if the points are close to zero do a Taylor
*		expansion of the first and last dilogarithm
*
*			Li2(cc1p) - Li2(cc2p)
*			  = sum cc1p^i ( 1-(1-cd2)^i ) /i^2
*
*		with cd2 = 1-cc2p/cc1p = ...
*
		if ( iclas1 .eq. 1 .or. iclas1 .eq. 4 ) then
		    cd2 = 1/cy
		elseif ( iclas1 .eq. 2 ) then
		    cd2 = 1/cz
		elseif ( iclas1 .eq. 3 ) then
		    cd2 = 1/cy1
		endif
		cd21 = 1-cd2
		cd21n1 = 1
		cc1n = cc1p
		cd2n = cd2
		ctot = cc1p*cd2
		do 50 i=2,20
		    cc1n = cc1n*cc1p
		    cd21n1 = cd21n1*cd21
		    cd2n = cd2n + cd2*cd21n1
		    cterm = cc1n*cd2n*DBLE(xn2inv(i))
		    ctot = ctot + cterm
		    if ( absc(cterm) .le. precc*absc(ctot) .or.
     +			 lreal .and. abs(DBLE(cterm)) .le. precc*
     +				abs(DBLE(ctot)) ) goto 51
   50		continue
   51		continue
		cli1 = ctot
		cli2 = 0
		cli3 = 0
		chill = 0
*		for the eta+transformation section we also need
		if ( iclas1.ne.1 .or. n1.ne.0 .or. n2.ne.0 )
     +			clo1 = zfflo1(cd2,ier)
		if ( iclas1.eq.2 ) clo2 = zfflo1(1/cy1,ier)
*--#]		Taylor expansion:
	    endif
*
* -#]	    handle dilog's:
* -#[	    handle eta + transformation terms:
	    if ( iclas1.eq.1 .or. iclas1.eq.4 ) then
*--#[		no transformation:
*
*		no transformation was made.
*
*		crr(5) = 0
		if ( n1 .ne. n2 ) then
		    if ( absc(cc1) .lt. xclogm ) then
			call fferr(23,ier)
		    else
*			imaginary part not checked
			ier = ier + 50
			crr(5) = (n1-n2)*c2ipi*zfflog(cc1,ieps,-cy,ier)
		    endif
		endif
*		crr(6) = 0
*		crr(7) = 0
		if ( n2.ne.0 ) then
		    crr(6) = - n2*c2ipi*clo1
		    n3 = nffeta(cc2,1/cc1,ier)
		    if ( n3 .ne. 0 ) then
			crr(7) = n2*n3*c2ipi**2
*		    else
*			crr(7) = 0
		    endif
		endif
*--#]		no transformation:
	    elseif ( iclas1 .eq. 2 ) then
*--#[		transform 1-x:
*
*		we tranformed to 1-x for both dilogs
*
		if ( absc(cc1p) .lt. xloss ) then
		    clog1 = zfflo1(cc1p,ier)
		else
		    clog1 = zfflog(cc1,ieps,-cy,ier)
		endif
		if ( DIMAG(cc2p).eq.0 ) then
		    if ( DIMAG(cc1p).eq.0 ) then
*			use the ieps instead
			n3 = 0
		    else
			n3 = nffet1(DCMPLX(DBLE(0),ieps*DBLE(cy)),
     +				1/cc1p,cc2p/cc1p,ier)
		    endif
		else
		    if ( DIMAG(cc1p).eq.0 ) then
			n3 =nffet1(cc2p,DCMPLX(DBLE(0),-ieps*DBLE(cy1)),
     +				cc2p/cc1p,ier)
		    else
			n3 = nffet1(cc2p,1/cc1p,cz,ier)
		    endif
		endif
		ntot = n1-n2-n3
		crr(5) = (ntot*c2ipi + clo1)*clog1
		clog2p = zfflog(cc2p,ieps,cy,ier)
		crr(6) = clo2*(n2*c2ipi - clog2p)
*--#]		transform 1-x:
	    elseif ( iclas1 .eq. 3 ) then
*--#[		transform 1/x:
*
*		we transformed to 1/x for both dilogs
*
		clog2p = zfflog(-cc2p,ieps,cy1,ier)
		if ( DIMAG(cc2p).eq.0 .or. DIMAG(cc1).eq.0 ) then
*		    we chose the eta's already equal, no worry.
		    n3 = 0
		    n3p = 0
		else
		    n3 = nffet1(-cc2p,-cc1,-cy/cy1,ier)
		    n3p = nffet1(cc2p,cc1,-cy/cy1,ier)
		endif
		if ( n3.ne.0 .or. n3p.ne.0 .or. n1.ne.n2 ) then
*		    for the time being the normal terms, I'll have to think of
*		    something smarter one day
		    clog1p = zfflog(-cc1p,ieps,-cy,ier)
		    crr(5) = -clog1p**2/2
		    crr(6) = +clog2p**2/2
		    crr(7) = (n1*zfflog(cc1,ieps,cy,ier) -
     +				n2*zfflog(cc2,ieps,-cy1,ier))*c2ipi
		else
		    crr(5) = clo1*(n2*c2ipi + clog2p - clo1/2)
		endif
*--#]		transform 1/x:
	    endif
* -#]	    handle eta + transformation terms:
* -#[	    add up:
	    if ( iclas1 .eq. 1 .or. iclas1 .eq. 4 ) then
		crr(1) = cli1
		crr(2) = cli2
		crr(3) = - cli3
		crr(4) = chill
	    else
		crr(1) = - cli1
		crr(2) = - cli2
		crr(3) = cli3
		crr(4) = - chill
	    endif
* -#]	    add up:
	else
*	    Normal case:
* -#[	    handle dilogs:
*
*	    the dilogs will not come close together so just go on
*	    only the special case cc1p ~ (-1,0) needs special attention
*
	    if ( iclas1 .ne. 4 .or. .not. ld2yzz ) then
		call ffzli2(cli1,clo1,cc1p,ier)
	    else
		cd2 = cd2yzz + czz
		if ( absc(cd2) .lt. xloss*absc(cd2yzz) ) then
		    cd2 = cy + cdyz
		endif
		cd2 = cd2/cdyz
		cfact = 1/(2-cd2)
		call ffzli2(cli1,clo1,cd2*cfact,ier)
		call ffzli2(cli3,clo3,-cd2*cfact,ier)
		call ffzli2(cli4,clo4,cd2,ier)
	    endif
	    if ( iclas2 .ne. 4 .or. .not. ld2yzz ) then
		call ffzli2(cli2,clo2,cc2p,ier)
	    else
		if ( iclas1 .eq. 4 ) call fferr(26,ier)
		cd2 = cd2yzz - czz1
		if ( absc(cd2) .lt. xloss*absc(cd2yzz) ) then
		    cd2 = cdyz - cy1
		endif
		cd2 = cd2/cdyz
		cfact = 1/(2-cd2)
		call ffzli2(cli2,clo2,cd2*cfact,ier)
		call ffzli2(cli3,clo3,-cd2*cfact,ier)
		call ffzli2(cli4,clo4,cd2,ier)
	    endif
* -#]	    handle dilogs:
* -#[	    handle eta terms:
*
*	    the eta's
*
	    if ( n1 .ne. 0 ) then
		if ( iclas1 .ne. 2 .or. absc(cc1p) .gt. xloss ) then
		    if ( DBLE(cc1) .gt. -abs(DIMAG(cc1)) ) then
			clog1 = zfflog(cc1,ieps,cy,ier)
		    else
*			take apart the factor i*pi^2
			if ( iclas1 .eq. 4 ) then
			    clog1 = zfflo1(cd2,ier)
			else
			    clog1 = zfflog(-cc1,0,cy,ier)
			endif
			if ( DIMAG(cc1) .lt. 0 ) then
			    i2pi = -1
			elseif ( DIMAG(cc1) .gt. 0 ) then
			    i2pi = +1
			elseif ( DBLE(cy)*ieps .lt. 0 ) then
			    i2pi = -1
			elseif ( DBLE(cy)*ieps .gt. 0 ) then
			    i2pi = +1
			else
			    call fferr(51,ier)
			    i2pi = 0
			endif
			ipi12 = ipi12 - n1*24*i2pi
		    endif
		else
		    clog1 = zfflo1(cc1p,ier)
		endif
		crr(5) = n1*c2ipi*clog1
*	    else
*		crr(5) = 0
	    endif
	    if ( n2 .ne. 0 ) then
		if ( iclas2 .ne. 2 .or. absc(cc2p) .gt. xloss ) then
		    if ( DBLE(cc2) .gt. -abs(DIMAG(cc2)) ) then
			clog2 = zfflog(cc2,ieps,cy,ier)
		    else
*			take apart the factor i*pi^2
			if ( iclas2 .eq. 4 ) then
			    clog2 = zfflo1(cd2,ier)
			else
			    clog2 = zfflog(-cc2,0,czero,ier)
			endif
			if ( DIMAG(cc2) .lt. 0 ) then
			    i2pi = -1
			elseif ( DIMAG(cc2) .gt. 0 ) then
			    i2pi = +1
			elseif ( DBLE(cy)*ieps .lt. 0 ) then
			    i2pi = -1
			elseif ( DBLE(cy)*ieps .gt. 0 ) then
			    i2pi = +1
			else
			    call fferr(51,ier)
			    i2pi = 0
			endif
			ipi12 = ipi12 + n2*24*i2pi
		    endif
		else
		    clog2 = zfflo1(cc2p,ier)
		endif
		crr(6) = n2*c2ipi*clog2
*	    else
*		crr(6) = 0
	    endif
* -#]	    handle eta terms:
* -#[	    handle transformation terms:
*
*	    transformation of cc1
*
	    if ( iclas1 .eq. 1 ) then
*		crr(3) = 0
	    elseif( iclas1 .eq. 2 ) then
		cli1 = -cli1
		ipi12 = ipi12 + 2
		crr(3) = - clo1*zfflog(cc1p,ieps,cy,ier)
	    elseif ( iclas1 .eq. 3 ) then
		cli1 = -cli1
		ipi12 = ipi12 - 2
		clog1p = zfflog(-cc1p,ieps,cy1,ier)
		crr(3) = - clog1p**2/2
	    elseif ( iclas1 .eq. 4 ) then
*		Note that this sum does not cause problems as d2<<1
		crr(3) = -cli3 - cli4 + clo4*zfflog(cfact,0,czero,ier)
		ipi12 = ipi12 - 1
	    else
		call fferr(25,ier)
	    endif
*
*	    transformation of cc2
*
	    if ( iclas2 .eq. 1 ) then
	    elseif( iclas2 .eq. 2 ) then
		cli2 = -cli2
		ipi12 = ipi12 - 2
		crr(4) = clo2*zfflog(cc2p,ieps,cy,ier)
	    elseif ( iclas2 .eq. 3 ) then
		cli2 = -cli2
		ipi12 = ipi12 + 2
		clog2p = zfflog(-cc2p,ieps,cy1,ier)
		crr(4) = clog2p**2/2
	    elseif ( iclas2 .eq. 4 ) then
*		Note that this sum does not cause problems as d2<<1
		crr(4) = cli3 + cli4 - clo4*zfflog(cfact,0,czero,ier)
		ipi12 = ipi12 + 1
	    else
		call fferr(27,ier)
	    endif
* -#]	    handle transformation terms:
* -#[	    sum:
	    crr(1) = cli1
	    crr(2) = - cli2
	    crr(6) = - crr(6)
*	    crr(7) = 0
* -#]	    sum:
	endif
*  #] calculations:
*###] ffcrr:
	end


C     ----------------------------------------------------------------
C     $Revision: 4074 $
C     $Date: 2014-04-23 14:13:52 -0700 (Wed, 23 Apr 2014) $
C     ----------------------------------------------------------------
C     Diagonal ODE example. Nonstiff case: alpha = 10/NEQ.
C     ----------------------------------------------------------------
C
C     Include MPI-Fortran header file for MPI_COMM_WORLD, MPI types.
C
      IMPLICIT NONE
C
      INCLUDE "mpif.h"
C
C The following declaration specification should match C type long int.
      INTEGER*8 NLOCAL, NEQ, IOUT(25), IPAR(2)
      PARAMETER (NLOCAL=2)
C
      INTEGER IER, MYPE, NPES, NOUT, LNST, LNFE, LNNI, LNCF, LNETF
      INTEGER METH, ITMETH, IATOL, ITASK, JOUT
      INTEGER I, NST, NFE, NNI, NCFN, NETF
      DOUBLE PRECISION Y(128), ROUT(10), RPAR(1)
      DOUBLE PRECISION ATOL, RTOL, DTOUT, T, ALPHA, TOUT
      DOUBLE PRECISION ERMAX, ERRI, GERMAX
C
      DATA ATOL/1.0D-10/, RTOL/1.0D-5/, DTOUT/0.1D0/, NOUT/10/
      DATA LNST/3/, LNFE/4/, LNNI/7/, LNCF/6/, LNETF/5/
C
C     Get NPES and MYPE.  Requires initialization of MPI.
      CALL MPI_INIT(IER)
      IF (IER .NE. 0) THEN
        WRITE(6,5) IER
 5      FORMAT(///' MPI_ERROR: MPI_INIT returned IER = ', I5)
        STOP
        ENDIF
      CALL MPI_COMM_SIZE(MPI_COMM_WORLD, NPES, IER)
      IF (IER .NE. 0) THEN
        WRITE(6,6) IER
 6      FORMAT(///' MPI_ERROR: MPI_COMM_SIZE returned IER = ', I5)
        CALL MPI_ABORT(MPI_COMM_WORLD, 1, IER)
        STOP
        ENDIF
      CALL MPI_COMM_RANK(MPI_COMM_WORLD, MYPE, IER)
      IF (IER .NE. 0) THEN
        WRITE(6,7) IER
 7      FORMAT(///' MPI_ERROR: MPI_COMM_RANK returned IER = ', I5)
        CALL MPI_ABORT(MPI_COMM_WORLD, 1, IER)
        STOP
        ENDIF
C
C     Set input arguments.
      NEQ = NPES * NLOCAL
      T = 0.0D0
      METH = 1
      ITMETH = 1
      IATOL = 1
      ITASK = 1
c     Set parameter ALPHA
      ALPHA  = 10.0D0 / NEQ
C
C     Load IPAR and RPAR
      IPAR(1) = NLOCAL
      IPAR(2) = MYPE
      RPAR(1) = ALPHA
C
      DO 10 I = 1, NLOCAL
  10    Y(I) = 1.0D0
C
      IF (MYPE .EQ. 0) THEN
        WRITE(6,11) NEQ, ALPHA
  11    FORMAT('Diagonal test problem:'//' NEQ = ', I3, /
     1         ' parameter alpha = ', F8.3)
        WRITE(6,12)
  12    FORMAT(' ydot_i = -alpha*i * y_i (i = 1,...,NEQ)')
        WRITE(6,13) RTOL, ATOL
  13    FORMAT(' RTOL, ATOL = ', 2E10.1)
        WRITE(6,14)
  14    FORMAT(' Method is ADAMS/FUNCTIONAL')
        WRITE(6,15) NPES
  15    FORMAT(' Number of processors = ', I3//)
        ENDIF
C
      CALL FNVINITP(MPI_COMM_WORLD, 1, NLOCAL, NEQ, IER)
C
      IF (IER .NE. 0) THEN
        WRITE(6,20) IER
  20    FORMAT(///' SUNDIALS_ERROR: FNVINITP returned IER = ', I5)
        CALL MPI_FINALIZE(IER)
        STOP
        ENDIF
C
      CALL FCVMALLOC(T, Y, METH, ITMETH, IATOL, RTOL, ATOL,
     1               IOUT, ROUT, IPAR, RPAR, IER)
C
      IF (IER .NE. 0) THEN
        WRITE(6,30) IER
  30    FORMAT(///' SUNDIALS_ERROR: FCVMALLOC returned IER = ', I5)
        CALL MPI_ABORT(MPI_COMM_WORLD, 1, IER)
        STOP
        ENDIF
C
C     Loop through tout values, call solver, print output, test for failure.
      TOUT = DTOUT
      DO 70 JOUT = 1, NOUT
C
        CALL FCVODE(TOUT, T, Y, ITASK, IER)
C
        IF (MYPE .EQ. 0) WRITE(6,40) T, IOUT(LNST), IOUT(LNFE)
  40    FORMAT(' t = ', D10.2, 5X, 'no. steps = ', I5,
     &         '   no. f-s = ', I5)
C
        IF (IER .NE. 0) THEN
          WRITE(6,60) IER, IOUT(15)
  60      FORMAT(///' SUNDIALS_ERROR: FCVODE returned IER = ', I5, /,
     &           '                 Linear Solver returned IER = ', I5)
          CALL MPI_ABORT(MPI_COMM_WORLD, 1, IER)
          STOP
          ENDIF
C
        TOUT = TOUT + DTOUT
  70    CONTINUE
C
C     Get max. absolute error in the local vector.
      ERMAX = 0.0D0
      DO 75 I = 1, NLOCAL
        ERRI  = Y(I) - EXP(-ALPHA * (MYPE * NLOCAL + I) * T)
        ERMAX = MAX(ERMAX, ABS(ERRI))
  75    CONTINUE
C     Get global max. error from MPI_REDUCE call.
      CALL MPI_REDUCE(ERMAX, GERMAX, 1, MPI_DOUBLE_PRECISION, MPI_MAX,
     1                0, MPI_COMM_WORLD, IER)
      IF (IER .NE. 0) THEN
        WRITE(6,80) IER
  80    FORMAT(///' MPI_ERROR: MPI_REDUCE returned IER = ', I5)
        CALL MPI_ABORT(MPI_COMM_WORLD, 1, IER)
        STOP
        ENDIF
      IF (MYPE .EQ. 0) WRITE(6,85) GERMAX
  85  FORMAT(/'Max. absolute error is ', E10.2/)
C
C     Print final statistics.
      NST = IOUT(LNST)
      NFE = IOUT(LNFE)
      NNI = IOUT(LNNI)
      NCFN = IOUT(LNCF)
      NETF = IOUT(LNETF)
      IF (MYPE .EQ. 0) WRITE (6,90) NST, NFE, NNI, NCFN, NETF
  90  FORMAT(/'Final statistics:'//
     &       ' number of steps = ', I5, 5X, /,
     &       ' number of f evals. = ', I5/
     &       ' number of nonlinear iters. = ', I5/
     &       ' number of nonlinear conv. failures = ', I3/
     &       ' number of error test failures = ', I3)
C
C     Free the memory and finalize MPI.
      CALL FCVFREE
      CALL MPI_FINALIZE(IER)
      IF (IER .NE. 0) THEN
        WRITE(6,95) IER
 95     FORMAT(///' MPI_ERROR: MPI_FINALIZE returned IER = ', I5)
        STOP
        ENDIF
C
      STOP
      END
C
C     ------------------------------------------------------------------------
C
      SUBROUTINE FCVFUN(T, Y, YDOT, IPAR, RPAR, IER)
C     Routine for right-hand side function f
C
      IMPLICIT NONE
C
C The following declaration specification should match C type long int.
      INTEGER*8 IPAR(*)
      INTEGER IER, MYPE, NLOCAL, I
      DOUBLE PRECISION T, Y(*), YDOT(*), RPAR(*)
      DOUBLE PRECISION ALPHA
C
      NLOCAL = IPAR(1)
      MYPE = IPAR(2)
      ALPHA = RPAR(1)
C
      DO I = 1, NLOCAL
         YDOT(I) = -ALPHA * (MYPE * NLOCAL + I) * Y(I)
      ENDDO
C
      IER = 0
C
      RETURN
      END


program P11441
    implicit none
    integer :: size
    integer, dimension(0:100000) :: partial_sum
    integer :: queries
    integer :: start, end
    integer :: i

    read *, size
    read *, (partial_sum(i), i = 1, size)

    do i = 1, size
        partial_sum(i) = partial_sum(i) + partial_sum(i - 1)
    end do

    read *, queries
    do i = 1, queries
        read *, start, end
        write (*, '(I0)') partial_sum(end) - partial_sum(start - 1)
    end do
end program P11441


!*****************************************************************************
!
! Rokko: Integrated Interface for libraries of eigenvalue decomposition
!
! Copyright (C) 2012-2019 by Rokko Developers https://github.com/t-sakashita/rokko
!
! Distributed under the Boost Software License, Version 1.0. (See accompanying
! file LICENSE_1_0.txt or copy at http://www.boost.org/license_1_0.txt)
!
!*****************************************************************************

program generate_eigen_vector
  use rokko
  implicit none
  integer :: dim
  type(rokko_eigen_vector) :: vec

  dim = 5
  print *,"dimension = ", dim

  call rokko_construct(vec, dim)

  print *, "vec (0-started index):"
  call rokko_generate0(vec, func0)
  call rokko_print(vec)
  print *, "vec (1-started index):"
  call rokko_generate(vec, func)
  call rokko_print(vec)

  call rokko_destruct(vec)

contains

  function func0(i)
    implicit none
    double precision :: func0
    integer, intent(in) :: i
    func0 = dble(2*(i+1))
  end function func0

  function func(i)
    implicit none
    double precision :: func
    integer, intent(in) :: i
    func = dble(2*i)
  end function func

end program generate_eigen_vector


      double complex function a6vQLlc(st,j1,j2,j3,j4,j5,j6,za,zb)
****************************************************
* virtual amplitude for leading color
* 0->q(p1)+qb(p2)+glu(p3)+gam(p4)+lb*p5)+l(p6)
* where one photon is coming from quark line
****************************************************
      implicit none
      include 'constants.f'
      include 'zprods_decl.f'
      character*14 st
      integer j1,j2,j3,j4,j5,j6
      double complex a6treeQLlc,vQLlc,fQLlc
c-----
      a6vQLlc = a6treeQLlc(st,j1,j2,j3,j4,j5,j6,za,zb)
     .         *vQLlc(st,j1,j2,j3,j4,j5,j6)
c-----
      a6vQLlc = a6vQLlc+fQLlc(st,j1,j2,j3,j4,j5,j6,za,zb)
c-----
      return
      end

      double complex function vQLlc(st,j1,j2,j3,j4,j5,j6)
c-----divergent part
      implicit none
      include 'constants.f'
      include 'sprods_com.f'
      include 'epinv.f'
      include 'scale.f'
      include 'epinv2.f'
      integer j1,j2,j3,j4,j5,j6
      double complex Lnrat,xl13,xl23,xl456
      character*14 st
      double precision t
c-----
      xl13=Lnrat(musq,-s(j1,j3))
      xl23=Lnrat(musq,-s(j2,j3))
      xl456=Lnrat(musq,-t(j4,j5,j6))
c-----
      vQLlc = -3D0
     .        -(epinv*epinv2+epinv*xl13+half*xl13**2)
     .        -(epinv*epinv2+epinv*xl23+half*xl23**2)
     .        -(3D0/2D0)*(epinv+xl456)
c-----
      return
      end

      double complex function fQLlc(st,j1,j2,j3,j4,j5,j6,za,zb)
c-----finite part
      implicit none
      character*14 st
      integer j1,j2,j3,j4,j5,j6
      include 'constants.f'
      include 'zprods_decl.f'
      include 'sprods_com.f'
      double complex Lsm1,L0,L1
      double precision t
c-----
      if(st.eq.'q+qb-g+g+lb-l+') then
c-----(+-++-+)
      fQLlc =
     .       - za(j2,j5)**2/(za(j1,j3)*za(j2,j3)*za(j4,j5)*za(j4,j6))
     .         *Lsm1(-s(j1,j3),-t(j4,j5,j6),-s(j2,j3),-t(j4,j5,j6))
     .       - za(j1,j2)*za(j2,j5)
     .         *( za(j5,j4)*zb(j4,j1) + za(j5,j6)*zb(j6,j1) )
     .         /(za(j1,j3)*za(j2,j3)*za(j4,j5)*za(j4,j6))
     .         *L0(-s(j2,j3),-t(j4,j5,j6))/t(j4,j5,j6)
     .       + za(j1,j2)**2
     .         *( za(j5,j2)*zb(j2,j1) + za(j5,j3)*zb(j3,j1) )
     .         *( za(j5,j4)*zb(j4,j1) + za(j5,j6)*zb(j6,j1) )
     .         /(2D0*za(j1,j3)*za(j2,j3)*za(j4,j5)*za(j4,j6))
     .         *L1(-s(j2,j3),-t(j4,j5,j6))/t(j4,j5,j6)**2
c-----
      elseif(st.eq.'q+qb-g+g-lb-l+') then
c-----(+-+--+)
      fQLlc =
     .       +  (za(j2,j1)*zb(j1,j6)+ za(j2,j3)*zb(j3,j6))
     .         *(za(j2,j4)*zb(j4,j6)+ za(j2,j5)*zb(j5,j6))
     .         /(t(j4,j5,j6)*za(j1,j3)*za(j2,j3)*zb(j4,j5)*zb(j4,j6))
     .         *Lsm1(-s(j1,j3),-t(j4,j5,j6),-s(j2,j3),-t(j4,j5,j6))
     .       - za(j2,j1)*zb(j1,j6)
     .         *(za(j2,j4)*zb(j4,j6) + za(j2,j5)*zb(j5,j6))
     .         /(za(j1,j3)*za(j2,j3)*zb(j4,j5)*zb(j4,j6))
     .         *L0(-s(j2,j3),-t(j4,j5,j6))/t(j4,j5,j6)
     .       - zb(j1,j2)**2*zb(j1,j6)**2
     .         /(2D0*za(j1,j3)*za(j2,j3)*zb(j4,j5)*zb(j4,j6))
     .         *L1(-s(j2,j3),-t(j4,j5,j6))/t(j4,j5,j6)**2
c-----
      else
      write(6,*) 'unimplemented st',st
      stop
      endif
c-----
      return
      end


**==effnew.spg  processed by SPAG 4.50J  at 14:50 on 30 Jun 1995
      FUNCTION EFFNEW(I,T,Z,N)
      IMPLICIT NONE
C*** Start of declarations inserted by SPAG
      REAL EFFNEW , f1 , f2 , f3 , T , t3 , xx , Z
      INTEGER I , N
C*** End of declarations inserted by SPAG

      EFFNEW =0.

      t3 = .001*T/Z**2
      xx = .4342*LOG(t3)
      IF ( t3.LE.1. ) THEN
         f1 = .266
         f2 = .13
         f3 = .13
      ELSEIF ( (t3-1.E5).GE.0. ) THEN
         f1 = .80
         f2 = .71
         f3 = .07
      ELSE
         f1 = .266 + .1068*xx - .074*SIN(1.2566*xx)
         f2 = .130 + .1160*xx - .074*SIN(1.2566*xx)
         f3 = .130 - .012*xx + .05*EXP(-(xx-2.)*(xx-2.))
      ENDIF
      IF ( I.EQ.2 .OR. I.EQ.3 ) EFFNEW = 8.*(1.-f1)
      IF ( I.EQ.10 .OR. I.EQ.11 ) EFFNEW = 18.*(1.-f2)
      IF ( I.GE.12 .AND. I.LE.17 ) EFFNEW = 18.*(1.-3.*f3-f2)
      IF ( I.GE.18 ) EFFNEW = (28.-N+Z)*1.8*(1.-3.*f3-f2)
      RETURN
      END