      SUBROUTINE BERNINI(N)
C-----------------------------------)
C-- INITIALIZE THE BERNOULLI NUMBER,
C-- USED IN DILOGARITHM EXPANSION
C-----------------------------------)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON/BERNOULLI/B(18)
      COMMON/CONST/ZETA2
      COMMON/POLY/NBER

      NBER=N
      PI=4.D0*DATAN(1.D0)

      B(1)=-1.D0/2.D0
      B(2)=1.D0/6.D0
      B(3)=0.D0
      B(4)=-1.D0/30.D0
      B(5)=0.D0
      B(6)=1.D0/42.D0
      B(7)=0.D0
      B(8)=-1.D0/30.D0
      B(9)=0.D0
      B(10)=5.D0/66.D0
      B(11)=0.D0
      B(12)=-691.D0/2730.D0
      B(13)=0.D0
      B(14)=7.D0/6.D0
      B(15)=0.D0
      B(16)=-3617.D0/510.D0
      B(17)=0.D0
      B(18)=43867.D0/798.D0
      ZETA2=PI**2/6.D0

C-- DEVIDED BY (I+1)!, WHICH WILL BE USED IN DILOGRITHM
      DO 995 I=1,18
        B(I)=B(I)/FAC(I+1)
995   CONTINUE
      RETURN
      END

      DOUBLE PRECISION FUNCTION FAC(N)
C-- MATHEMATICAL FACTORIAL
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      FAC=1.D0
      IF(N.EQ.0) RETURN
      DO 986 I=1,N
        FAC=FAC*DFLOAT(I)
986   CONTINUE
      RETURN
      END

      DOUBLE COMPLEX FUNCTION CLI2(X)
C----------------------------------------------------)
C-- TAYLOR-EXPANSION FOR COMPLEX DILOGARITHM
C-- REFERENCE:
C--   Eq.(4.3) in Proc. R. Soc. Lond. A 459 (2003) 2807-2819
C-- CONVERGE WHEN |-CDLOG(1D0-X)|<2*PI
C----------------------------------------------------)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DOUBLE COMPLEX X,Z
      COMMON/BERNOULLI/B(18)
      COMMON/CONST/ZETA2
      COMMON/POLY/NBER

      N=NBER-1
      Z=-CDLOG(1.D0-X)
      CLI2=B(NBER)
      DO 111 I=N,1,-1
        CLI2=Z*CLI2+B(I)
111   CONTINUE
      CLI2=Z**2*CLI2+Z
      RETURN
      END

      DOUBLE COMPLEX FUNCTION LI2(X)
C-------------------------------------------------------------)
C-- COMPLEX DILOGARITHM (SPENCE-FUNCTION)
C-- SOME LINEAR TRANSFORMATIONS OF THE DILOGARITHM ARE ALSO USED
C-- REFERENCE:
C--   Eq.(3.2) TO Eq.(3.6) in
C--       Proc. R. Soc. Lond. A 459 (2003) 2807-2819
C-------------------------------------------------------------)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DOUBLE COMPLEX X,Y,CLI2
      COMMON/CONST/ZETA2
      ZERO=1.D-40
      XR=DREAL(X)
      XI=DIMAG(X)
      R2=XR*XR+XI*XI
      IF(R2.LE.ZERO)THEN
        LI2=X
        RETURN
      ENDIF
      RR=XR/R2
      IF(R2.EQ.1.D0.AND.XI.EQ.0.D0)THEN
        IF(XR.EQ.1.D0)THEN
          LI2=DCMPLX(ZETA2)
        ELSE
          LI2=-DCMPLX(ZETA2/2.D0)
        ENDIF
        RETURN
      ELSEIF(R2.GT.1.D0.AND.RR.GT.0.5D0)THEN
        Y=(X-1.D0)/X
        LI2=CLI2(Y)+ZETA2-CDLOG(X)*CDLOG(1.D0-X)+0.5D0*CDLOG(X)**2
        RETURN
      ELSEIF(R2.GT.1.D0.AND.RR.LE.0.5D0)THEN
        Y=1.D0/X
        LI2=-CLI2(Y)-ZETA2-0.5D0*CDLOG(-X)**2
        RETURN
      ELSEIF(R2.LE.1.D0.AND.XR.GT.0.5D0)THEN
        Y=1.D0-X
        LI2=-CLI2(Y)+ZETA2-CDLOG(X)*CDLOG(1.D0-X)
        RETURN
      ELSEIF(R2.LE.1.D0.AND.XR.LE.0.5D0)THEN
        Y=X
        LI2=CLI2(Y)
        RETURN
      ENDIF
      END

      DOUBLE COMPLEX FUNCTION MYMDL_CI(A,B,C)
C--------------------------------------------------)
C-- BASIC SCALAR INTEGRAL
C-- I(a,b,c) = Integrate[Log[a*x+b]/(x-c),{x,0,1}]
C--    = Log(a*c+b)*Log(1-1/c)-Li2(1-(a+b)/(a*c+b))+Li2(1-b/(a*c+b))
C-- REFERENCE:
C--   Phys. Rev. D 42 (1990) 3100
C--------------------------------------------------)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DOUBLE COMPLEX C,LI2

      MYMDL_CI = CDLOG(A*C+B)*CDLOG(1.D0-1.D0/C)
     &    -LI2(1.D0-(A+B)/(A*C+B))+LI2(1.D0-B/(A*C+B))
      RETURN
      END

      DOUBLE COMPLEX FUNCTION CJ(A,B,C)
C-----------------------------------------------------)
C-- BASIC SCALAR INTEGRAL
C-- J(a,b,c) = Integrate[Log[a*x*(1-x)-b]/(x-c),{x,0,1}]
C--   = Log(a*c*(1-c)-b)*Log(1-1/c)-Li2((c-1)/(c-ap))
C--    +Li2(c/(c-ap))-Li2((c-1)/(c-am))+Li2(c/(c-am))
C-- REFERENCE:
C--   Phys. Rev. D 42 (1990) 3100
C-----------------------------------------------------)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DOUBLE COMPLEX C,CB,AP,AM,LI2
      COMMON/CUTS/EPS,REPS
      CB = B*DCMPLX(1.D0,-REPS)
      C=DCMPLX(DREAL(C),DIMAG(C)/1.D3)
      CC = C
      AP = 0.5D0*(1.D0+CDSQRT(1.D0-4.D0*CB/A))
      AM = 0.5D0*(1.D0-CDSQRT(1.D0-4.D0*CB/A))
      CJ = CDLOG(A*CC*(1.D0-CC)-CB)*CDLOG(1.D0-1.D0/C)
     &    -LI2((CC-1.D0)/(CC-AP))+LI2(CC/(CC-AP))
     &    -LI2((CC-1.D0)/(CC-AM))+LI2(CC/(CC-AM))
      RETURN
      END

      SUBROUTINE INISCAL(AMQ,S,T,U,M1,M2,
     &    C0AB,C0AC,C0AD,C0BC,C0BD,C0CD,D0ABC,D0BAC,D0ACB)
C---------------------------------------------------------)
C-- ROUTINE USED TO CALCULATE SCALAR INTEGRAL
C-- COPIED FROM 'hpair' PROGRAM, by Michael Spira
C-- Website: http://tiger.web.psi.ch/proglist.html
C---------------------------------------------------------)
      IMPLICIT DOUBLE PRECISION (A-B,D-H,O-Z)
      IMPLICIT DOUBLE COMPLEX (C)
      DOUBLE PRECISION M1,M2
      DOUBLE COMPLEX D04
      DOUBLE COMPLEX C03
      DOUBLE COMPLEX LI2
      DOUBLE COMPLEX MYMDL_CI,CJ
      DOUBLE COMPLEX R,R0,X,XP,XM
      DOUBLE COMPLEX C0AB,C0AC,C0AD,C0BC,C0BD,C0CD,D0ABC,D0BAC,D0ACB
      DOUBLE PRECISION EPS, REPS
      COMMON/CUTS/ EPS,REPS

      EPS=1d-8
      REPS=1d-15
      CALL BERNINI(18)

      DQ2=AMQ**2

      CQ2=DQ2*DCMPLX(1.D0,-REPS)
      CA5 = CDSQRT(1.D0-4.D0*CQ2/S)
      C0AB = 0.5D0*CDLOG((CA5+1.D0)/(CA5-1.D0))**2/S*DQ2

      S1=M1**2
      S2=M2**2
      S5=S
      CA1 = CDSQRT(1.D0-4.D0*CQ2/S1)
      CA2 = CDSQRT(1.D0-4.D0*CQ2/S2)
      CA5 = CDSQRT(1.D0-4.D0*CQ2/S5)
      XLAM=DSQRT(S1**2+S2**2+S5**2-2.D0*(S1*S2+S1*S5+S2*S5))
      CB1=1.D0/XLAM*(S1-S2-S5)
      CB2=1.D0/XLAM*(S2-S1-S5)
      CB5=1.D0/XLAM*(S5-S1-S2)
      C0CD = -(
     &       LI2((1.D0+CB1)/(CA1+CB1)) - LI2((1.D0-CB1)/(CA1-CB1))
     &     - LI2((-1.D0+CB1)/(CA1+CB1)) + LI2((-1.D0-CB1)/(CA1-CB1))
     &     + LI2((1.D0+CB2)/(CA2+CB2)) - LI2((1.D0-CB2)/(CA2-CB2))
     &     - LI2((-1.D0+CB2)/(CA2+CB2)) + LI2((-1.D0-CB2)/(CA2-CB2))
     &     + LI2((1.D0+CB5)/(CA5+CB5)) - LI2((1.D0-CB5)/(CA5-CB5))
     &     - LI2((-1.D0+CB5)/(CA5+CB5)) + LI2((-1.D0-CB5)/(CA5-CB5))
     &       )/XLAM*DQ2
      S1=0.D0
      S2=M1**2
      S5=T
      CA2 = CDSQRT(1.D0-4.D0*CQ2/S2)
      CA5 = CDSQRT(1.D0-4.D0*CQ2/S5)
      XLAM=DSQRT(S1**2+S2**2+S5**2-2.D0*(S1*S2+S1*S5+S2*S5))
      CB2=1.D0/XLAM*(S2-S1-S5)
      CB5=1.D0/XLAM*(S5-S1-S2)
      C0AC = -(
     &       LI2((1.D0+CB2)/(CA2+CB2)) - LI2((1.D0-CB2)/(CA2-CB2))
     &     - LI2((-1.D0+CB2)/(CA2+CB2)) + LI2((-1.D0-CB2)/(CA2-CB2))
     &     + LI2((1.D0+CB5)/(CA5+CB5)) - LI2((1.D0-CB5)/(CA5-CB5))
     &     - LI2((-1.D0+CB5)/(CA5+CB5)) + LI2((-1.D0-CB5)/(CA5-CB5))
     &       )/XLAM*DQ2
      S1=0.D0
      S2=M2**2
      S5=U
      CA2 = CDSQRT(1.D0-4.D0*CQ2/S2)
      CA5 = CDSQRT(1.D0-4.D0*CQ2/S5)
      XLAM=DSQRT(S1**2+S2**2+S5**2-2.D0*(S1*S2+S1*S5+S2*S5))
      CB2=1.D0/XLAM*(S2-S1-S5)
      CB5=1.D0/XLAM*(S5-S1-S2)
      C0AD = -(
     &       LI2((1.D0+CB2)/(CA2+CB2)) - LI2((1.D0-CB2)/(CA2-CB2))
     &     - LI2((-1.D0+CB2)/(CA2+CB2)) + LI2((-1.D0-CB2)/(CA2-CB2))
     &     + LI2((1.D0+CB5)/(CA5+CB5)) - LI2((1.D0-CB5)/(CA5-CB5))
     &     - LI2((-1.D0+CB5)/(CA5+CB5)) + LI2((-1.D0-CB5)/(CA5-CB5))
     &       )/XLAM*DQ2
      S1=0.D0
      S2=M1**2
      S5=U
      CA2 = CDSQRT(1.D0-4.D0*CQ2/S2)
      CA5 = CDSQRT(1.D0-4.D0*CQ2/S5)
      XLAM=DSQRT(S1**2+S2**2+S5**2-2.D0*(S1*S2+S1*S5+S2*S5))
      CB2=1.D0/XLAM*(S2-S1-S5)
      CB5=1.D0/XLAM*(S5-S1-S2)
      C0BC = -(
     &       LI2((1.D0+CB2)/(CA2+CB2)) - LI2((1.D0-CB2)/(CA2-CB2))
     &     - LI2((-1.D0+CB2)/(CA2+CB2)) + LI2((-1.D0-CB2)/(CA2-CB2))
     &     + LI2((1.D0+CB5)/(CA5+CB5)) - LI2((1.D0-CB5)/(CA5-CB5))
     &     - LI2((-1.D0+CB5)/(CA5+CB5)) + LI2((-1.D0-CB5)/(CA5-CB5))
     &       )/XLAM*DQ2
      S1=0.D0
      S2=M2**2
      S5=T
      CA2 = CDSQRT(1.D0-4.D0*CQ2/S2)
      CA5 = CDSQRT(1.D0-4.D0*CQ2/S5)
      XLAM=DSQRT(S1**2+S2**2+S5**2-2.D0*(S1*S2+S1*S5+S2*S5))
      CB2=1.D0/XLAM*(S2-S1-S5)
      CB5=1.D0/XLAM*(S5-S1-S2)
      C0BD = -(
     &       LI2((1.D0+CB2)/(CA2+CB2)) - LI2((1.D0-CB2)/(CA2-CB2))
     &     - LI2((-1.D0+CB2)/(CA2+CB2)) + LI2((-1.D0-CB2)/(CA2-CB2))
     &     + LI2((1.D0+CB5)/(CA5+CB5)) - LI2((1.D0-CB5)/(CA5-CB5))
     &     - LI2((-1.D0+CB5)/(CA5+CB5)) + LI2((-1.D0-CB5)/(CA5-CB5))
     &       )/XLAM*DQ2
      Z=M1**2
      H=M2**2
      S1=S
      S2=Z
      S5=H
      XLAM=DSQRT(S1**2+S2**2+S5**2-2.D0*(S1*S2+S1*S5+S2*S5))
      XN=T*U-Z*H
      R0=CDSQRT(1.D0+4.D0*S*CQ2/XN)
      R=(1.D0+R0)/2.D0
      RR=DREAL(R0)
      D0ACB = 2.D0/XN/RR*(CJ(Z,AMQ**2,R)+CJ(H,AMQ**2,R)
     &                   -CJ(T,AMQ**2,R)-CJ(U,AMQ**2,R))*DQ2**2
      X=CDSQRT(1.D0+4.D0*XN/S/U**2*CQ2)
      X0=DSQRT(1.D0+4.D0*XN/S/U**2*DQ2)
      XP=-U/(T-U+XLAM)*(1.D0+X)
      XM=-U/(T-U+XLAM)*(1.D0-X)
      ALP=(S+Z-H+XLAM)/2.D0/S
      BET=(U-T+XLAM)/2.D0/S
      ZERO=0.D-15
      D0ABC = 1.D0/S/U/X0*(MYMDL_CI(S,ZERO,XP)-MYMDL_CI(T-H,S,(1.D0-XM)/(1.D0-ALP))
     &      -MYMDL_CI(Z-U,ZERO,XP/ALP)+MYMDL_CI(Z-U,ZERO,XP/BET)
     &      -MYMDL_CI(T-H,S,XP/BET)
     &      -CJ(S,AMQ**2,XP)+CJ(H,AMQ**2,(1.D0-XM)/(1.D0-ALP))
     &      +CJ(Z,AMQ**2,XP/ALP)-CJ(U,AMQ**2,XP/BET)
     &      +CJ(H,AMQ**2,XP/BET)
     &      -(MYMDL_CI(S,ZERO,XM)-MYMDL_CI(T-H,S,(1.D0-XP)/(1.D0-ALP))
     &      -MYMDL_CI(Z-U,ZERO,XM/ALP)+MYMDL_CI(Z-U,ZERO,XM/BET)
     &      -MYMDL_CI(T-H,S,XM/BET)
     &      -CJ(S,AMQ**2,XM)+CJ(H,AMQ**2,(1.D0-XP)/(1.D0-ALP))
     &      +CJ(Z,AMQ**2,XM/ALP)-CJ(U,AMQ**2,XM/BET)
     &      +CJ(H,AMQ**2,XM/BET)))*DQ2**2
      X=CDSQRT(1.D0+4.D0*XN/S/T**2*CQ2)
      X0=DSQRT(1.D0+4.D0*XN/S/T**2*DQ2)
      XP=-T/(U-T+XLAM)*(1.D0+X)
      XM=-T/(U-T+XLAM)*(1.D0-X)
      ALP=(S+Z-H+XLAM)/2.D0/S
      BET=(T-U+XLAM)/2.D0/S
      D0BAC = 1.D0/S/T/X0*(MYMDL_CI(S,ZERO,XP)-MYMDL_CI(U-H,S,(1.D0-XM)/(1.D0-ALP))
     &      -MYMDL_CI(Z-T,ZERO,XP/ALP)+MYMDL_CI(Z-T,ZERO,XP/BET)
     &      -MYMDL_CI(U-H,S,XP/BET)
     &      -CJ(S,AMQ**2,XP)+CJ(H,AMQ**2,(1.D0-XM)/(1.D0-ALP))
     &      +CJ(Z,AMQ**2,XP/ALP)-CJ(T,AMQ**2,XP/BET)
     &      +CJ(H,AMQ**2,XP/BET)
     &      -(MYMDL_CI(S,ZERO,XM)-MYMDL_CI(U-H,S,(1.D0-XP)/(1.D0-ALP))
     &      -MYMDL_CI(Z-T,ZERO,XM/ALP)+MYMDL_CI(Z-T,ZERO,XM/BET)
     &      -MYMDL_CI(U-H,S,XM/BET)
     &      -CJ(S,AMQ**2,XM)+CJ(H,AMQ**2,(1.D0-XP)/(1.D0-ALP))
     &      +CJ(Z,AMQ**2,XM/ALP)-CJ(T,AMQ**2,XM/BET)
     &      +CJ(H,AMQ**2,XM/BET)))*DQ2**2

      RETURN
      END

      DOUBLE COMPLEX FUNCTION FBoxEven(Q12,Q13,Q23,Q32,MQ)
C------------------------------------------------------------)
C-- THE FORM FACTOR FOR BOX DIAGRAM, F
C-- INPUT:
C--    Q12 = P1.P2
C--    Q13 = P1.P3
C--    Q23 = P2.P3
C--    Q32 = P3.P3
C-- NOTE THAT IN MADGRAPH CONVENTION, P1 P2 P3 P4 ARE ALL INCOMING
C-- THUS T = (P1+P3)^2 = P3^2 + 2*P1.P3, SIMILAR FOR U
C-------------------------------------------------------------)
      IMPLICIT NONE

      DOUBLE PRECISION Q12,Q13,Q23,Q32,Q42
      DOUBLE PRECISION S,T,U,MQ,MQ2,SS,TT,UU,M1,M2
      DOUBLE PRECISION RHOC,RHOD,TAUQ,TT1,UU1,TT2,UU2,EPM
      DOUBLE COMPLEX C0AB,C0AC,C0AD,C0BC,C0BD,C0CD,D0ABC,D0BAC,D0ACB

      MQ2 = MQ**2

      S = 2*Q12
      T = Q32 + 2*Q13
      U = Q32 + 2*Q23
      Q42 = S + T + U - Q32

      SS = S/MQ2
      TT = T/MQ2
      UU = U/MQ2

      RHOC = Q32/MQ2
      RHOD = Q42/MQ2

      TAUQ = 4D0/SS
      TT1 = TT - RHOC
      UU1 = UU - RHOC
      TT2 = TT - RHOD
      UU2 = UU - RHOD

      CALL INISCAL(MQ,S,T,U,DSQRT(Q32),DSQRT(Q42),
     &     C0AB,C0AC,C0AD,C0BC,C0BD,C0CD,D0ABC,D0BAC,D0ACB)

      C0AB = C0AB/MQ2
      C0AC = C0AC/MQ2
      C0AD = C0AD/MQ2
      C0BC = C0BC/MQ2
      C0BD = C0BD/MQ2
      C0CD = C0CD/MQ2

      D0ABC = D0ABC/MQ2**2
      D0BAC = D0BAC/MQ2**2
      D0ACB = D0ACB/MQ2**2

      FBoxEven = 1D0/SS**2*(4D0*SS+8D0*SS*MQ2*C0AB
     &   -2D0*SS*(SS+RHOC+RHOD-8D0)*MQ2**2*(D0ABC+D0BAC+D0ACB)
     &   +(RHOC+RHOD-8D0)*MQ2*(TT1*C0AC+UU1*C0BC
     &   +TT2*C0BD+UU2*C0AD-(TT*UU-RHOC*RHOD)*MQ2*D0ACB))

      RETURN
      END

      DOUBLE COMPLEX FUNCTION FBoxEvenTop(Q12,Q13,Q23,Q32)
      IMPLICIT NONE

      DOUBLE PRECISION Q12,Q13,Q23,Q32
      DOUBLE COMPLEX FBoxEven

      INCLUDE 'coupl.inc'
      INCLUDE 'input.inc'

      FBoxEvenTop = FBoxEven(Q12,Q13,Q23,Q32,MDL_MT)

      RETURN
      END

      DOUBLE COMPLEX FUNCTION FBoxEvenBot(Q12,Q13,Q23,Q32)
      IMPLICIT NONE

      DOUBLE PRECISION Q12,Q13,Q23,Q32
      DOUBLE COMPLEX FBoxEven

      INCLUDE 'coupl.inc'
      INCLUDE 'input.inc'

      FBoxEvenBot = FBoxEven(Q12,Q13,Q23,Q32,MDL_MB)

      RETURN
      END

      DOUBLE COMPLEX FUNCTION GBoxEven(Q12,Q13,Q23,Q32,MQ)
      IMPLICIT NONE

      DOUBLE PRECISION Q12,Q13,Q23,Q32,Q42
      DOUBLE PRECISION S,T,U,MQ,MQ2,SS,TT,UU,M1,M2
      DOUBLE PRECISION RHOC,RHOD,TAUQ,TT1,UU1,TT2,UU2,PT2
      DOUBLE COMPLEX C0AB,C0AC,C0AD,C0BC,C0BD,C0CD,D0ABC,D0BAC,D0ACB
      DOUBLE COMPLEX GBoxEvenQ

      MQ2 = MQ**2

      S = 2*Q12
      T = Q32 + 2*Q13
      U = Q32 + 2*Q23
      Q42 = S + T + U - Q32

      SS = S/MQ2
      TT = T/MQ2
      UU = U/MQ2

      RHOC = Q32/MQ2
      RHOD = Q42/MQ2

      TAUQ = 4D0/SS
      TT1 = TT - RHOC
      UU1 = UU - RHOC
      TT2 = TT - RHOD
      UU2 = UU - RHOD

      PT2 = 2*Q13*Q23/Q12 - Q32

      CALL INISCAL(MQ,S,T,U,DSQRT(Q32),DSQRT(Q42),
     &     C0AB,C0AC,C0AD,C0BC,C0BD,C0CD,D0ABC,D0BAC,D0ACB)

      C0AB = C0AB/MQ2
      C0AC = C0AC/MQ2
      C0AD = C0AD/MQ2
      C0BC = C0BC/MQ2
      C0BD = C0BD/MQ2
      C0CD = C0CD/MQ2

      D0ABC = D0ABC/MQ2**2
      D0BAC = D0BAC/MQ2**2
      D0ACB = D0ACB/MQ2**2

      GBoxEvenQ = 1D0/(SS*(TT*UU-RHOC*RHOD))*(
     &  (TT**2+RHOC*RHOD-8D0*TT)*MQ2*
     &  (SS*C0AB+TT1*C0AC+TT2*C0BD-SS*TT*MQ2*D0BAC)
     &  +(UU**2+RHOC*RHOD-8D0*UU)*MQ2*
     &  (SS*C0AB+UU1*C0BC+UU2*C0AD-SS*UU*MQ2*D0ABC)
     &  -(TT**2+UU**2-2*RHOC*RHOD)*(TT+UU-8D0)*MQ2*C0CD
     &  -2D0*(TT+UU-8D0)*(TT*UU-RHOC*RHOD)*MQ2**2
     &     *(D0ABC+D0BAC+D0ACB))

C--Compared with hep-ph/9603205, I put the extra PT^2 in A2munu in the form factor
      GBoxEven = GBoxEvenQ/PT2

      RETURN
      END

      DOUBLE COMPLEX FUNCTION GBoxEvenTop(Q12,Q13,Q23,Q32)
      IMPLICIT NONE

      DOUBLE PRECISION Q12,Q13,Q23,Q32
      DOUBLE COMPLEX GBoxEven

      INCLUDE 'coupl.inc'
      INCLUDE 'input.inc'

      GBoxEvenTop = GBoxEven(Q12,Q13,Q23,Q32,MDL_MT)

      RETURN
      END

      DOUBLE COMPLEX FUNCTION GBoxEvenBot(Q12,Q13,Q23,Q32)
      IMPLICIT NONE

      DOUBLE PRECISION Q12,Q13,Q23,Q32
      DOUBLE COMPLEX GBoxEven

      INCLUDE 'coupl.inc'
      INCLUDE 'input.inc'

      GBoxEvenBot = GBoxEven(Q12,Q13,Q23,Q32,MDL_MB)

      RETURN
      END

      DOUBLE COMPLEX FUNCTION FBoxOdd(Q12,Q13,Q23,Q32,MQ)
      IMPLICIT NONE

      DOUBLE PRECISION Q12,Q13,Q23,Q32,Q42
      DOUBLE PRECISION S,T,U,MQ,MQ2,SS,TT,UU,M1,M2
      DOUBLE PRECISION RHOC,RHOD,TAUQ,TT1,UU1,TT2,UU2,EPM
      DOUBLE COMPLEX C0AB,C0AC,C0AD,C0BC,C0BD,C0CD,D0ABC,D0BAC,D0ACB

      MQ2 = MQ**2

      S = 2*Q12
      T = Q32 + 2*Q13
      U = Q32 + 2*Q23
      Q42 = S + T + U - Q32

      SS = S/MQ2
      TT = T/MQ2
      UU = U/MQ2

      RHOC = Q32/MQ2
      RHOD = Q42/MQ2

      TAUQ = 4D0/SS
      TT1 = TT - RHOC
      UU1 = UU - RHOC
      TT2 = TT - RHOD
      UU2 = UU - RHOD

      CALL INISCAL(MQ,S,T,U,DSQRT(Q32),DSQRT(Q42),
     &     C0AB,C0AC,C0AD,C0BC,C0BD,C0CD,D0ABC,D0BAC,D0ACB)

      C0AB = C0AB/MQ2
      C0AC = C0AC/MQ2
      C0AD = C0AD/MQ2
      C0BC = C0BC/MQ2
      C0BD = C0BD/MQ2
      C0CD = C0CD/MQ2

      D0ABC = D0ABC/MQ2**2
      D0BAC = D0BAC/MQ2**2
      D0ACB = D0ACB/MQ2**2

      FBoxOdd = 1D0/SS**2*(4D0*SS+8D0*SS*MQ2*C0AB
     &   -2D0*SS*(TT+UU)*MQ2**2*(D0ABC+D0BAC+D0ACB)
     &   +(RHOC+RHOD)*MQ2*(TT1*C0AC+UU1*C0BC
     &   +TT2*C0BD+UU2*C0AD-(TT*UU-RHOC*RHOD)*MQ2*D0ACB))

      RETURN
      END

      DOUBLE COMPLEX FUNCTION FBoxOddTop(Q12,Q13,Q23,Q32)
      IMPLICIT NONE

      DOUBLE PRECISION Q12,Q13,Q23,Q32
      DOUBLE COMPLEX FBoxOdd

      INCLUDE 'coupl.inc'
      INCLUDE 'input.inc'

      FBoxOddTop = FBoxOdd(Q12,Q13,Q23,Q32,MDL_MT)

      RETURN
      END

      DOUBLE COMPLEX FUNCTION FBoxOddBot(Q12,Q13,Q23,Q32)
      IMPLICIT NONE

      DOUBLE PRECISION Q12,Q13,Q23,Q32
      DOUBLE COMPLEX FBoxOdd

      INCLUDE 'coupl.inc'
      INCLUDE 'input.inc'

      FBoxOddBot = FBoxOdd(Q12,Q13,Q23,Q32,MDL_MB)

      RETURN
      END

      DOUBLE COMPLEX FUNCTION GBoxOdd(Q12,Q13,Q23,Q32,MQ)
      IMPLICIT NONE

      DOUBLE PRECISION Q12,Q13,Q23,Q32,Q42
      DOUBLE PRECISION S,T,U,MQ,MQ2,SS,TT,UU,M1,M2
      DOUBLE PRECISION RHOC,RHOD,TAUQ,TT1,UU1,TT2,UU2,PT2
      DOUBLE COMPLEX C0AB,C0AC,C0AD,C0BC,C0BD,C0CD,D0ABC,D0BAC,D0ACB
      DOUBLE COMPLEX GBoxOddQ

      MQ2 = MQ**2

      S = 2*Q12
      T = Q32 + 2*Q13
      U = Q32 + 2*Q23
      Q42 = S + T + U - Q32

      SS = S/MQ2
      TT = T/MQ2
      UU = U/MQ2

      RHOC = Q32/MQ2
      RHOD = Q42/MQ2

      TAUQ = 4D0/SS
      TT1 = TT - RHOC
      UU1 = UU - RHOC
      TT2 = TT - RHOD
      UU2 = UU - RHOD

      PT2 = 2*Q13*Q23/Q12 - Q32

      CALL INISCAL(MQ,S,T,U,DSQRT(Q32),DSQRT(Q42),
     &     C0AB,C0AC,C0AD,C0BC,C0BD,C0CD,D0ABC,D0BAC,D0ACB)

      C0AB = C0AB/MQ2
      C0AC = C0AC/MQ2
      C0AD = C0AD/MQ2
      C0BC = C0BC/MQ2
      C0BD = C0BD/MQ2
      C0CD = C0CD/MQ2

      D0ABC = D0ABC/MQ2**2
      D0BAC = D0BAC/MQ2**2
      D0ACB = D0ACB/MQ2**2

      GBoxOddQ = 1D0/(SS*(TT*UU-RHOC*RHOD))*(
     &  (TT**2+RHOC*RHOD)*MQ2*
     &  (SS*C0AB+TT1*C0AC+TT2*C0BD-SS*TT*MQ2*D0BAC)
     &  +(UU**2+RHOC*RHOD)*MQ2*
     &  (SS*C0AB+UU1*C0BC+UU2*C0AD-SS*UU*MQ2*D0ABC)
     &  -(TT**2+UU**2-2*RHOC*RHOD)*(TT+UU)*MQ2*C0CD
     &  -2D0*(TT+UU)*(TT*UU-RHOC*RHOD)*MQ2**2
     &     *(D0ABC+D0BAC+D0ACB))

      GBoxOdd = GBoxOddQ/PT2

      RETURN
      END

      DOUBLE COMPLEX FUNCTION GBoxOddTop(Q12,Q13,Q23,Q32)
      IMPLICIT NONE

      DOUBLE PRECISION Q12,Q13,Q23,Q32
      DOUBLE COMPLEX GBoxOdd

      INCLUDE 'coupl.inc'
      INCLUDE 'input.inc'

      GBoxOddTop = GBoxOdd(Q12,Q13,Q23,Q32,MDL_MT)

      RETURN
      END

      DOUBLE COMPLEX FUNCTION GBoxOddBot(Q12,Q13,Q23,Q32)
      IMPLICIT NONE

      DOUBLE PRECISION Q12,Q13,Q23,Q32
      DOUBLE COMPLEX GBoxOdd

      INCLUDE 'coupl.inc'
      INCLUDE 'input.inc'

      GBoxOddBot = GBoxOdd(Q12,Q13,Q23,Q32,MDL_MB)

      RETURN
      END

      DOUBLE COMPLEX FUNCTION FBoxSA(Q12,Q13,Q23,Q32,MQ)
      IMPLICIT NONE

      DOUBLE PRECISION Q12,Q13,Q23,Q32,Q42
      DOUBLE PRECISION S,T,U,MQ,MQ2,SS,TT,UU,M1,M2
      DOUBLE PRECISION RHOC,RHOD,TAUQ,TT1,UU1,TT2,UU2,EPM
      DOUBLE COMPLEX C0AB,C0AC,C0AD,C0BC,C0BD,C0CD,D0ABC,D0BAC,D0ACB

      MQ2 = MQ**2

      S = 2*Q12
      T = Q32 + 2*Q13
      U = Q32 + 2*Q23
      Q42 = S + T + U - Q32

      SS = S/MQ2
      TT = T/MQ2
      UU = U/MQ2

      RHOC = Q32/MQ2
      RHOD = Q42/MQ2

      TAUQ = 4D0/SS
      TT1 = TT - RHOC
      UU1 = UU - RHOC
      TT2 = TT - RHOD
      UU2 = UU - RHOD

      CALL INISCAL(MQ,S,T,U,DSQRT(Q32),DSQRT(Q42),
     &     C0AB,C0AC,C0AD,C0BC,C0BD,C0CD,D0ABC,D0BAC,D0ACB)

      C0AB = C0AB/MQ2
      C0AC = C0AC/MQ2
      C0AD = C0AD/MQ2
      C0BC = C0BC/MQ2
      C0BD = C0BD/MQ2
      C0CD = C0CD/MQ2

      D0ABC = D0ABC/MQ2**2
      D0BAC = D0BAC/MQ2**2
      D0ACB = D0ACB/MQ2**2

      FBoxSA = 1D0/SS**2*(-2D0*SS*(SS+RHOC-RHOD)*MQ2**2
     &   *(D0ABC+D0BAC+D0ACB)
     &   +(RHOC-RHOD)*MQ2*(TT1*C0AC+UU1*C0BC
     &   +TT2*C0BD+UU2*C0AD-(TT*UU-RHOC*RHOD)*MQ2*D0ACB))

      RETURN
      END

      DOUBLE COMPLEX FUNCTION FBoxSATop(Q12,Q13,Q23,Q32)
      IMPLICIT NONE

      DOUBLE PRECISION Q12,Q13,Q23,Q32
      DOUBLE COMPLEX FBoxSA

      INCLUDE 'coupl.inc'
      INCLUDE 'input.inc'

      FBoxSATop = FBoxSA(Q12,Q13,Q23,Q32,MDL_MT)

      RETURN
      END

      DOUBLE COMPLEX FUNCTION FBoxSABot(Q12,Q13,Q23,Q32)
      IMPLICIT NONE

      DOUBLE PRECISION Q12,Q13,Q23,Q32
      DOUBLE COMPLEX FBoxSA

      INCLUDE 'coupl.inc'
      INCLUDE 'input.inc'

      FBoxSABot = FBoxSA(Q12,Q13,Q23,Q32,MDL_MB)

      RETURN
      END

      DOUBLE COMPLEX FUNCTION GBoxSA(Q12,Q13,Q23,Q32,MQ)
      IMPLICIT NONE

      DOUBLE PRECISION Q12,Q13,Q23,Q32,Q42
      DOUBLE PRECISION S,T,U,MQ,MQ2,SS,TT,UU,M1,M2
      DOUBLE PRECISION RHOC,RHOD,TAUQ,TT1,UU1,TT2,UU2,PT2
      DOUBLE COMPLEX C0AB,C0AC,C0AD,C0BC,C0BD,C0CD,D0ABC,D0BAC,D0ACB
      DOUBLE COMPLEX GBoxSAQ

      MQ2 = MQ**2

      S = 2*Q12
      T = Q32 + 2*Q13
      U = Q32 + 2*Q23
      Q42 = S + T + U - Q32

      SS = S/MQ2
      TT = T/MQ2
      UU = U/MQ2

      RHOC = Q32/MQ2
      RHOD = Q42/MQ2

      TAUQ = 4D0/SS
      TT1 = TT - RHOC
      UU1 = UU - RHOC
      TT2 = TT - RHOD
      UU2 = UU - RHOD

      PT2 = 2*Q13*Q23/Q12 - Q32

      CALL INISCAL(MQ,S,T,U,DSQRT(Q32),DSQRT(Q42),
     &     C0AB,C0AC,C0AD,C0BC,C0BD,C0CD,D0ABC,D0BAC,D0ACB)

      C0AB = C0AB/MQ2
      C0AC = C0AC/MQ2
      C0AD = C0AD/MQ2
      C0BC = C0BC/MQ2
      C0BD = C0BD/MQ2
      C0CD = C0CD/MQ2

      D0ABC = D0ABC/MQ2**2
      D0BAC = D0BAC/MQ2**2
      D0ACB = D0ACB/MQ2**2

      GBoxSAQ = 1D0/(SS*(TT*UU-RHOC*RHOD))*(
     &  -(TT**2-RHOC*RHOD)*MQ2*
     &  (SS*C0AB+TT1*C0AC+TT2*C0BD-SS*TT*MQ2*D0BAC)
     &  +(UU**2-RHOC*RHOD)*MQ2*
     &  (SS*C0AB+UU1*C0BC+UU2*C0AD-SS*UU*MQ2*D0ABC)
     &  +((TT+UU)**2-4*RHOC*RHOD)*(TT-UU)*MQ2*C0CD
     &  +2D0*(TT-UU)*(TT*UU-RHOC*RHOD)*MQ2**2
     &     *(D0ABC+D0BAC+D0ACB))

      GBoxSA = GBoxSAQ/PT2

      RETURN
      END

      DOUBLE COMPLEX FUNCTION GBoxSATop(Q12,Q13,Q23,Q32)
      IMPLICIT NONE

      DOUBLE PRECISION Q12,Q13,Q23,Q32
      DOUBLE COMPLEX GBoxSA

      INCLUDE 'coupl.inc'
      INCLUDE 'input.inc'

      GBoxSATop = GBoxSA(Q12,Q13,Q23,Q32,MDL_MT)

      RETURN
      END

      DOUBLE COMPLEX FUNCTION GBoxSABot(Q12,Q13,Q23,Q32)
      IMPLICIT NONE

      DOUBLE PRECISION Q12,Q13,Q23,Q32
      DOUBLE COMPLEX GBoxSA

      INCLUDE 'coupl.inc'
      INCLUDE 'input.inc'

      GBoxSABot = GBoxSA(Q12,Q13,Q23,Q32,MDL_MB)

      RETURN
      END


module Utils
    use Const
    use omp_lib
    implicit none

contains

    pure function norm2(x) result(a)
        real(mpc), dimension(:), intent(in) :: x
        real(mpc) :: a
        a = sqrt(sum(x**2))
    end function norm2

    pure function zeron(n) result(z)
        integer, intent(in) :: n
        real(mpc), dimension(n) :: z
        z = 0.0_mpc
    end function

    function identity(x) result(x1)
        real(mpc), intent(in), dimension(:) :: x
        real(mpc), dimension(size(x)) :: x1
        x1 = x
    end function

    function dyad_product(a,b) result(c)
        real(mpc), intent(in), dimension(:) :: a,b
        real(mpc), dimension(size(a),size(b)) :: c
        c = spread(a,dim=2,ncopies=size(b)) * spread(b,dim=1,ncopies=size(a))
    end function dyad_product

    pure function symplprod(a,b) result(c)
        real(mpc), intent(in), dimension(:) :: a
        real(mpc), intent(in), dimension(size(a)) :: b
        real(mpc), dimension(size(a)) :: c
        integer :: i,j,k,n
        n = size(a)
        c = 0
        do i = 1, n
            do j = 1, n
                do k = 1, n
                    c(i) = c(i) + asimeps(i,j,k)*a(j)*b(k)
                end do
            end do
        end do
    contains
        ! вроде должно работать
        pure function asimeps(i,j,k) result(e)
            integer, intent(in) :: i,j,k
            integer :: e
            e = (k-j)*(j-i)*(k-i)
            e = e/abs(e)
        end function asimeps
    end function

    subroutine reverse_cols(a)
        real(mpc), dimension(:, :), intent(inout) :: a
!         real(mpc), dimension(size(a,1), size(a, 2)) :: a1
        integer :: i, m
        m = size(a, 1)
        forall (i = 1:m/2) a(i, :) = a(m+1-i, :)
    end subroutine reverse_cols

    subroutine swap(a, i, j, a_cols)
        real(mpc), dimension(:, :) :: a
        integer :: i, j,k
        logical :: a_cols, cols
        intent(in) ::  i, j, a_cols
        optional :: a_cols
        real(mpc) :: tmp
        cols = .FALSE.
        if(present(a_cols)) cols = a_cols

        if (cols) then
            ! вроде присваивает разным кускам массива
            do k = 1, size(a,2)
                tmp = a(i,k)
                a(i,k) = a(j,k)
                a(j,k) = tmp
            end do
        else
            do k = 1, size(a,1)
                tmp = a(k,i)
                a(k,i) = a(k,j)
                a(k,j) = tmp
            end do
        end if

    end subroutine swap

    ! joins 2 arrays size by side
    function joinarr_sbs(a, b) result(c)
        real(mpc), intent(in), dimension(:)         :: a, b
        real(mpc), dimension(max(size(a), size(b)), 2) :: c
        integer :: i

        do i = 1, size(c,1)
            c(i,1) = a(i)
            c(i,2) = b(i)
        end do
    end function joinarr_sbs

end module Utils


*
*     -------------------------------------------------------------
*      N I N E
*     -------------------------------------------------------------
*
*                                                                  *
*     THIS PACKAGE DETERMINES THE VALUES OF 9j COEFFICIENT         *
*                                                                  *
*     |  J1/2  J2/2  J3/2 |                                        *
*     |  L1/2  L2/2  L3/2 |                                        *
*     |  K1/2  K2/2  K3/2 |                                        *
*                                                                  *
*     Written by G. Gaigalas,                                      *
*     Vilnius,  Lithuania                             March 1995   *
*
      SUBROUTINE NINE(J1,J2,J3,L1,L2,L3,K1,K2,K3,I,IN,AA)
      IMPLICIT DOUBLEPRECISION (A-H,O-Z)
      COMMON/CONSTS/ZERO,TENTH,HALF,ONE,TWO,THREE,FOUR,SEVEN,ELEVEN,EPS
      IF(I.EQ.1) THEN
        IN=0
        IF(ITTK(J1,J2,J3).EQ.0)RETURN
        IF(ITTK(L1,L2,L3).EQ.0)RETURN
        IF(ITTK(K1,K2,K3).EQ.0)RETURN
        IF(ITTK(J1,L1,K1).EQ.0)RETURN
        IF(ITTK(J2,L2,K2).EQ.0)RETURN
        IF(ITTK(J3,L3,K3).EQ.0)RETURN
        IN=1
        RETURN
      ENDIF
      IF(J1*J2*J3*L1*L2*L3*K1*K2*K3.EQ.0) THEN
        IN=1
        CALL NINE0(J1,J2,J3,L1,L2,L3,K1,K2,K3,AA)
      ELSE
        N1=IABS(J1-K3)
        N2=IABS(L3-J2)
        N3=IABS(L1-K2)
        N4=IABS(J2-L3)
        N5=IABS(K2-L1)
        N6=IABS(J1-K3)
        MAX=MAX0(N1,N2,N3,N4,N5,N6)
        N1=J1+K3
        N2=L3+J2
        N3=J2+L3
        N4=K2+L1
        N5=J1+K3
        N6=L1+K2
        MIN=MIN0(N1,N2,N3,N4,N5,N6)
        IN=1
        AA=ZERO
        DO 1 IX=MAX,MIN,2
          CALL SIXJ(J1,J2,J3,L3,K3,IX,0,S1)
          CALL SIXJ(L1,L2,L3,J2,IX,K2,0,S2)
          CALL SIXJ(K1,K2,K3,IX,J1,L1,0,S3)
          X=S1*S2*S3*DBLE(IX+1)
          IF(MOD(IX,2).NE.0) X=-X
          AA=X+AA
    1   CONTINUE
      ENDIF
      RETURN
      END


	PROGRAM REALTEST
C
C	TESTS TO FIND SIGN OF PHASE OF A SIGNAL
C
	REAL DATA(1025)
	DATA A /1./
	DATA HARM /128./
C
	DO N = 1,1025
	  DATA(N) = A*COSD(360.*HARM*(N-1)/1024.)
	ENDDO
	PRINT*,'PHASE=0.'
	CALL REALFT(DATA,512,1)


!==========================================================================
module gsw_mod_teos10_constants
!==========================================================================

use gsw_mod_kinds

implicit none

real (r8), parameter :: db2pa = 1.0e4_r8
real (r8), parameter :: rec_db2pa = 1.0e-4_r8

real (r8), parameter :: pa2db = 1.0e-4_r8
real (r8), parameter :: rec_pa2db = 1.0e4_r8

real (r8), parameter :: pi = 3.141592653589793_r8
real (r8), parameter :: deg2rad = pi/180.0_r8
real (r8), parameter :: rad2deg = 180.0_r8/pi

real (r8), parameter :: gamma = 2.26e-7_r8

!  cp0  =  The "specific heat" for use                         [ J/(kg K) ]
!          with Conservative Temperature

real (r8), parameter :: gsw_cp0 = 3991.86795711963_r8

!  T0  =  the Celcius zero point.                                     [ K ]

real (r8), parameter :: gsw_t0 = 273.15_r8

!  P0  =  Absolute Pressure of one standard atmosphere.              [ Pa ]

real (r8), parameter :: gsw_p0 = 101325.0_r8

!  SSO  =  Standard Ocean Reference Salinity.                      [ g/kg ]

real (r8), parameter :: gsw_sso = 35.16504_r8
real (r8), parameter :: gsw_sqrtsso = 5.930011804372737_r8

!  uPS  =  unit conversion factor for salinities                   [ g/kg ]

real (r8), parameter :: gsw_ups = gsw_sso/35.0_r8

!  sfac  =  1/(40*gsw_ups)

real (r8), parameter :: gsw_sfac = 0.0248826675584615_r8

!  deltaS = 24, offset = deltaS*gsw_sfac

real (r8), parameter :: offset = 5.971840214030754e-1_r8

!  C3515  =  Conductivity at (SP=35, t_68=15, p=0)                [ mS/cm ]

real (r8), parameter :: gsw_c3515 = 42.9140_r8

!  SonCl  =  SP to Chlorinity ratio                           [ (g/kg)^-1 ]

real (r8), parameter :: gsw_soncl = 1.80655_r8

!  valence_factor  =  valence factor of sea salt of Reference Composition
!                                                              [ unitless ]

real (r8), parameter :: gsw_valence_factor = 1.2452898_r8

!  atomic_weight = mole-weighted atomic weight of sea salt of Reference
!                  Composition                                    [ g/mol ]

real (r8), parameter :: gsw_atomic_weight = 31.4038218_r8

end module

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


    subroutine anoxic(t)
!   ********************
    use constante, only: cp_oxic, cp_anoxic
!   C/P molar ratio: cp_oxic = 200 , cp_anoxic = 4000 (traditionnaly)
!   => ratio of what is buried in POC
    implicit none
    include 'combine_foam.inc'

    do i=1,nbasin
        call DOfA(var(11,i),DOA(i))
        cp_burial(i)=(cp_oxic*cp_anoxic)/ &
                   ((1-DOA(i))*cp_anoxic+DOA(i)*cp_oxic)
        if (cp_burial(i).gt.cp_anoxic) then
            cp_burial(i)=cp_anoxic
        endif
    enddo
    return
    end


      SUBROUTINE solver(amat, b, m)
      USE stel_kinds
      USE laprec
      IMPLICIT NONE
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER, INTENT(in) :: m
      REAL(rprec), INTENT(inout) :: amat(m,*), b(m,*)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER, PARAMETER :: nrhs = 1
      INTEGER :: info
      INTEGER, ALLOCATABLE :: ipiv(:)
C-----------------------------------------------
      info = 0
      ALLOCATE (ipiv(m))

!     Compute the solution to a REAL system of linear equations
!       A * X = B,
!     WHERE A is an N-by-N matrix and X and B are N-by-NRHS matrices.
!
!     FACTOR AMATRIX INTO LU FORM
!     AND SOLVE BY GAUSSIAN ELIMINATION
!
      CALL la_gesv (m, nrhs, amat, m, ipiv, b, m, info)
      IF (info .ne. 0) PRINT *, ' Condition No. = 0 in Solver'

      DEALLOCATE (ipiv)

      END SUBROUTINE solver


module GreenCheetah
    implicit none

    integer,parameter,private   :: dp = kind(1.d0)

    ! Effective mass: Semicond. Sci. Technol. 27 (2012) 035021
    ! InGaAs = 0.041

    real(dp),parameter  :: hbar = 1.054571817E-34   ! J.s
    real(dp),parameter  :: Planck = 6.62607015E-34  ! J.s
    real(dp),parameter  :: mass = 9.1093837015E-31  ! kg
    real(dp),parameter  :: exrg = 1.602176634E-19   ! C
    real(dp),parameter  :: kB = 1.380649E-23        ! J/K
    real(dp),parameter  :: eta = 1E-15
    real(dp),parameter  :: pi = 3.14159265358979323

    type,public :: Green
        real,allocatable    :: Pot(:,:)
        integer             :: nr,nc
        real(dp)            :: hex,hey
        real(dp)            :: dx,dy
        real                :: efm

        real(dp)            :: FermiEnergy
        real(dp)            :: FermiWaveLength
        real(dp)            :: FermiWaveVector

        contains

        procedure           :: DOS
        procedure           :: SGM
        procedure           :: EnergySweep
        procedure           :: MagneticSweep
        procedure           :: transmission
        procedure           :: getFermi
        procedure,private   :: Hamiltonian
        procedure,private   :: leadGreensFunction
        procedure,private   :: tfun

        final                :: GreenDestructor
    end type

    interface Green
        procedure   :: GreenConstructor
    end interface

    contains

    !------------------------------------------------------!
    !             CONSTRUCTOR AND DESTRUCTOR               !
    !------------------------------------------------------!
    function GreenConstructor(V,Height,Width,efm,flag) result(self)
        implicit none

        real(dp),intent(in) :: V(:,:)
        real,intent(in)     :: Height, Width
        real,intent(in)     :: efm              ! Effective mass
        logical,intent(in)  :: flag
        type(Green)         :: self

        integer             :: nr,nc,s(2)

        s = shape(V)
        nr = s(1)
        nc = s(2)

        allocate(self%Pot(nr,nc))
        self%Pot = V
        self%nr = nr
        self%nc = nc
        self%dx = Height/nr
        self%dy = Width/nc
        self%efm = efm
        self%hex = ((hbar/self%dx**2)*(hbar/(efm*mass)))/exrg
        self%hey = ((hbar/self%dy**2)*(hbar/(efm*mass)))/exrg

        if (flag) then
            write(*,*) "-----------------------------------"
            write(*,*) "Lattice constants in y and x [nm]:"
            write(*,*) self%dy/1E-9
            write(*,*) self%dx/1E-9
            write(*,*) ""
            write(*,*) "Hopping energies in y and x [meV]:"
            write(*,*) self%hey/1E-3
            write(*,*) self%hex/1E-3
            write(*,*) "-----------------------------------"
        end if

    end function

    subroutine GreenDestructor(self)
        implicit none

        type(Green)         :: self

        deallocate(self%Pot)
    end subroutine

    !------------------------------------------------------!
    !                PRIVATE MODULE FUNCTIONS              !
    !------------------------------------------------------!

    !----- Lead Green's function -----!
    function leadGreensFunction(self,E) result(G)
        use linalg
        use omp_lib

        implicit none

        class(Green),intent(in) :: self
        real,intent(in)         :: E
        complex(dp)             :: G(self%nr,self%nc)

        real(dp),parameter      :: pi = 3.14159265358979323
        complex(dp)             :: p,q
        integer                 :: i,j,n
        real(dp)                :: Vx,Vy

        complex(dp)    :: U(self%nr,self%nc)

        Vx = -self%hex
        Vy = -self%hey

        G = 0.0
        q = 2*abs(Vx)
        !-$OMP PARALLEL DO PRIVATE(i,p) SHARED(G)
        do i = 1,self%nr
            p = E + 2*real(Vx+Vy)+2*abs(Vy)*cos(pi*cmplx(i,0)/(self%nr+1)) + cmplx(0,1E-9)
            G(i,i) = (2.0*p/(q*q))*(cmplx(1.0,0)-sqrt(1-q*q/(p*p)))
        end do
        !-$OMP END PARALLEL DO

        ! Transformation Unitary Matrix U
        !-$OMP PARALLEL DO PRIVATE(i,j) SHARED(U)
        do j = 1,self%nc
        do i = 1,self%nr
            U(i,j) = sqrt(cmplx(2.0,0)/(self%nr+1))*sin((j*pi/(self%nr+1))*i)
        end do
        end do
        !-$OMP END PARALLEL DO

        G = tri(U,G,transpose(U))

    end function

    !----- Hamiltonian -----!
    function Hamiltonian(self,n) result(H)
        use omp_lib
        implicit none

        class(Green),intent(in) :: self
        integer,intent(in)      :: n
        complex(dp)             :: H(self%nr,self%nc)

        integer     :: s,i

        H = 0.0

        !$OMP PARALLEL PRIVATE(i) SHARED(H)
        !$OMP DO
        do i = 1,self%nr
            H(i,i) = 2.0*(self%hex + self%hey) + self%pot(i,n)

            if (i > 1) then
                H(i,i-1) = -self%hey
            end if
            if (i < self%nr) then
                H(i,i+1) = -self%hey
            end if
        end do
        !$OMP END DO
        !$OMP END PARALLEL
    end function

    !------------------------------------------------------!
    !                   PUBLIC FUNCTIONS                   !
    !------------------------------------------------------!

    !------ Density of States -----!
    function DOS(self,Energy,B,flag) result(D)
        use linalg
        implicit none

        class(Green),intent(in) :: self
        real,intent(in)         :: Energy
        real,intent(in)         :: B
        logical,intent(in)      :: flag
        real(dp)                :: D(self%nr,self%nc)

        integer                 :: n,k,j

        real(dp)                :: I(self%nr, self%nr)
        complex(dp)             :: V(self%nr, self%nr)
        complex(dp)             :: Ho(self%nr, self%nr)
        complex(dp)             :: Gnn(self%nr, self%nr)
        complex(dp)             :: Gl(self%nr, self%nr)
        complex(dp)             :: Gr(self%nr, self%nr)
        complex(dp)             :: G(self%nr, self%nr)
        complex(dp)             :: Sigma(self%nr, self%nr)
        complex(dp)             :: P(self%nr, self%nr)
        complex(dp)             :: M(self%nr, self%nr, self%nc+1)

        complex(dp)             :: VB

        if (flag .eqv. .True.) then
            write(*,*) "-----------------------------------"
            write(*,*) "Local density of states"
            write(*,*) "  Energy [meV]......:",Energy/1E-3
            write(*,*) "  Magnetic field [T]:",B
            write(*,*) "-----------------------------------"
        end if

        ! Indentity and perturbation matrices
        ! Coupling matrix
        V = 0.0
        I = 0.0
        VB = cmplx(0,exrg*B*self%dx*self%dy/hbar)
        do n = 1,self%nr
            V(n,n) = -self%hex*exp(n*VB)
            I(n,n) = 1.0
        end do

        ! Lead Green's function
        Gr = self%leadGreensFunction(Energy)
        M(:,:,self%nc+1) = Gr

        ! Backward Propagation
        Gnn = Gr
        do j = self%nc,1,-1
            Sigma = tri(V,Gnn,conjg(V))
            Gnn = GAssembly(Energy,self%Hamiltonian(j),Sigma,eta)
            M(:,:,j) = Gnn
        end do

        ! Forward + Merging
        Gnn = Gr
        do j = 1,self%nc
            ! Forward
            Sigma = tri(conjg(V),Gnn,V)
            Gnn = GAssembly(Energy,self%Hamiltonian(j),Sigma,eta)

            ! Merging
            Sigma = tri(V,M(:,:,j+1),conjg(V))
            P = I - matmul(Gnn,Sigma)
            G = solve(P,Gnn)

            ! DOS
            do k = 1,self%nr
                D(k,j) = -imag(G(k,k))
            end do
        end do
    end function

    !------- Energy Sweep ------!
    subroutine EnergySweep(self,Emin,Emax,B,T)
        use omp_lib
        implicit none

        class(Green),intent(in) :: self
        real,intent(in)         :: Emin, Emax
        real,intent(in)         :: B
        real,intent(inout)      :: T(:)

        integer     :: i, sz
        real        :: Energy

        sz = size(T)
        write(*,*) "* Energy sweep [meV] from",Emin/1E-3,"to",Emax/1E-3
        write(*,*) "  Steps:",sz
        write(*,*) "  Magnetic field [T]:",B

        !$OMP PARALLEL DO PRIVATE(i,Energy) SHARED(T)
        do i = 1,sz
            Energy = Emin + (Emax-Emin)*real(i-1)/(sz-1)

            T(i) = self%Transmission(Energy,B)
        end do
        !$OMP END PARALLEL DO
    end subroutine

    !------ Magnetic Sweep -------!
    subroutine MagneticSweep(self,Bmin,Bmax,Energy,T)
        use omp_lib
        implicit none

        class(Green),intent(in) :: self
        real,intent(in)         :: Bmin, Bmax
        real,intent(in)         :: Energy
        real,intent(inout)      :: T(:)

        integer     :: i,sz
        real        :: B

        sz = size(T)

        write(*,*) "* Magnetic sweep [T] from",Bmin,"to",Bmax
        write(*,*) "  Steps:",sz
        write(*,*) "  Energy [meV]:",Energy/1E-3

        !$OMP PARALLEL DO PRIVATE(i,B) SHARED(T)
        do i = 1,sz
            B = Bmin + (Bmax-Bmin)*real(i-1)/(sz-1)

            T(i) = self%Transmission(Energy,B)
        end do
        !$OMP END PARALLEL DO
    end subroutine

    !------ Transmission Function ------!
    function Transmission(self,Energy,B) result(T)
        use linalg
        implicit none

        class(Green),intent(in) :: self
        real,intent(in)         :: Energy
        real,intent(in)         :: B
        real                    :: T

        real                    :: I(self%nr,self%nr)
        complex(dp)             :: V(self%nr,self%nr)
        complex(dp)             :: G_lead(self%nr,self%nr)
        complex(dp)             :: G_nn(self%nr,self%nr)
        complex(dp)             :: G_Ln(self%nr,self%nr)
        complex(dp)             :: S(self%nr,self%nr)
        complex(dp)             :: Sigma(self%nr,self%nr)
        complex(dp)             :: G(self%nr,self%nr)
        complex(dp)             :: P(self%nr,self%nr)
        complex(dp)             :: Gama(self%nr,self%nr)
        integer                 :: m,n,k,sz

        complex(dp)             :: VB

        ! Coupling matrix
        V = 0.0
        I = 0.0
        VB = cmplx(0,exrg*B*self%dx*self%dy/hbar)
        do n = 1,self%nr
            V(n,n) = -self%hex*exp(n*VB)
            I(n,n) = 1.0
        end do

        !** Begin with left lead
        G_lead = self%leadGreensFunction(Energy)
        G_nn = G_lead
        G_Ln = G_lead

        ! Loop over columns
        ! Sigma = V+.G_nn.V
        ! G_nn = [(E+i.eta).I - H - S]^(-1)
        ! G_Ln = G_Ln.V.G_nn
        do n = 1,self%nc
            Sigma = tri(conjg(V),G_nn,V)
            G_nn = GAssembly(Energy,self%Hamiltonian(n),Sigma,eta)
            G_Ln = tri(G_Ln,V,G_nn)
        end do

        !** Add right lead
        ! [G_lead.V.G_nn.V).G_nn = G_lead
        ! G = G_Ln.V.G_nn
        Sigma = tri(conjg(V),G_nn,V)
        P = I - matmul(G_lead,Sigma)
        G_nn = solve(P,G_lead)
        G = tri(G_Ln,V,G_nn)

        !** Compute Gamma matrix
        ! S = V+.G_lead.V
        ! Gamma = i.(S-S+)
        Sigma = tri(conjg(V),G_lead,V)
        Gama = cmplx(0,1)*(Sigma - conjg(Sigma))

        !** Compute trace
        ! r = Trace(Gama.G.Gama.G+)
        P = matmul(matmul(Gama,G),matmul(Gama,conjg(G)))
        T = 0
        do k = 1,self%nr
            T = T + real(P(k,k))
        end do
    end function

    !------ Transmission Function Fast ------!
    function tfun(self,Energy,B,G_lead,V,Id,Pot) result(T)
        use linalg
        implicit none

        class(Green),intent(in) :: self
        real,intent(in)         :: Energy
        real,intent(in)         :: B
        complex(dp),intent(in)  :: G_lead(self%nr,self%nr)
        complex(dp),intent(in)  :: V(self%nr,self%nr)
        real,intent(in)         :: Id(self%nr,self%nr)
        real,intent(in)         :: Pot(self%nr,self%nc)
        real                    :: T

        complex(dp)             :: H(self%nr,self%nr)
        complex(dp)             :: G_nn(self%nr,self%nr)
        complex(dp)             :: G_Ln(self%nr,self%nr)
        complex(dp)             :: S(self%nr,self%nr)
        complex(dp)             :: Sigma(self%nr,self%nr)
        complex(dp)             :: G(self%nr,self%nr)
        complex(dp)             :: P(self%nr,self%nr)
        complex(dp)             :: Gama(self%nr,self%nr)
        integer                 :: m,n,k,sz,i

        complex(dp)             :: VB

        !** Build fundamental Hamiltonian
        H = 0.0
        do i = 1,self%nr
            H(i,i) = 2.0*(self%hex + self%hey)

            if (i > 1) then
                H(i,i-1) = -self%hey
            end if
            if (i < self%nr) then
                H(i,i+1) = -self%hey
            end if
        end do

        !** Begin with left lead
        G_nn = G_lead
        G_Ln = G_lead

        ! Loop over columns
        ! Sigma = V+.G_nn.V
        ! G_nn = [(E+i.eta).I - H - S]^(-1)
        ! G_Ln = G_Ln.V.G_nn
        do n = 1,self%nc
            ! Build Hamiltonian
            do i = 1,self%nr
                H(i,i) = H(i,i) + Pot(i,n)
            end do

            Sigma = tri(conjg(V),G_nn,V)
            G_nn = GAssembly(Energy,H,Sigma,eta)
            G_Ln = tri(G_Ln,V,G_nn)

            ! Recover Hamiltonian
            do i = 1,self%nr
                H(i,i) = H(i,i) - Pot(i,n)
            end do
        end do

        !** Add right lead
        ! [G_lead.V.G_nn.V).G_nn = G_lead
        ! G = G_Ln.V.G_nn
        Sigma = tri(conjg(V),G_nn,V)
        P = Id - matmul(G_lead,Sigma)
        G_nn = solve(P,G_lead)
        G = tri(G_Ln,V,G_nn)

        !** Compute Gamma matrix
        ! S = V+.G_lead.V
        ! Gamma = i.(S-S+)
        Sigma = tri(conjg(V),G_lead,V)
        Gama = cmplx(0,1)*(Sigma - conjg(Sigma))

        !** Compute trace
        ! r = Trace(Gama.G.Gama.G+)
        P = matmul(matmul(Gama,G),matmul(Gama,conjg(G)))
        T = 0
        do k = 1,self%nr
            T = T + real(P(k,k))
        end do
    end function

    !--- Get Fermi energy, wavelength, and wavevector ---!
    subroutine getFermi(self,n2D,flag)
        implicit none

        class(Green),intent(inout)  :: self
        real,intent(in)             :: n2D  ! [cm^-2]
        logical,intent(in)          :: flag

        self%FermiWaveLength = sqrt(2E-4*pi/n2D)
        self%FermiWaveVector = 2*pi/self%FermiWaveLength
        self%FermiEnergy = ((hbar*self%FermiWaveVector)**2/(2*mass*self%efm))

        if (flag) then
            write(*,*) "Fermi Energy [meV] = ",self%FermiEnergy/(1E-3*exrg)
            write(*,*) "Fermi Wavelength [nm] = ",self%FermiWaveLength/1E-9
            write(*,*) "Fermi Wavevector [1/nm] = ",1E-9*self%FermiWavevector
        end if
    end subroutine

    !--- Scanning Gate Microscopy (SGM) ---!
    function SGM(self,Energy,B,flag) result(D)
        use linalg
        use omp_lib
        implicit none

        class(Green),intent(in) :: self
        real,intent(in)         :: Energy
        real,intent(in)         :: B
        logical,intent(in)      :: flag
        real(dp)                :: D(self%nr,self%nc)

        integer                 :: n,k,j,ri,rj,tip_pos

        real(dp)                :: I(self%nr, self%nr)
        complex(dp)             :: V(self%nr, self%nr)
        complex(dp)             :: Ho(self%nr, self%nr)
        complex(dp)             :: Gnn(self%nr, self%nr)
        complex(dp)             :: Gnnn(self%nr, self%nr)
        complex(dp)             :: GLn(self%nr, self%nr)
        complex(dp)             :: GnR(self%nr, self%nr)
        complex(dp)             :: GLnn(self%nr, self%nr)
        complex(dp)             :: Gl(self%nr, self%nr)
        complex(dp)             :: Gr(self%nr, self%nr)
        complex(dp)             :: G(self%nr, self%nr)
        complex(dp)             :: Sigma(self%nr, self%nr)
        complex(dp)             :: Sigma1(self%nr, self%nr)
        complex(dp)             :: Sigma2(self%nr, self%nr)
        complex(dp)             :: P(self%nr, self%nr)
        complex(dp)             :: M(self%nr, self%nr, self%nc+1)
        complex(dp)             :: Q(self%nr, self%nr, self%nc+1)
        complex(dp)             :: Gama(self%nr,self%nr)

        complex(dp)             :: VB

        if (flag .eqv. .True.) then
            write(*,*) "-----------------------------------"
            write(*,*) "Scanning Gate Microscopy"
            write(*,*) "  Energy [meV]......:",Energy/1E-3
            write(*,*) "  Magnetic field [T]:",B
            write(*,*) "-----------------------------------"
        end if

        ! Indentity and perturbation matrices
        ! Coupling matrix
        V = 0.0
        I = 0.0
        VB = cmplx(0,exrg*B*self%dx*self%dy/hbar)
        do n = 1,self%nr
            V(n,n) = -self%hex*exp(n*VB)
            I(n,n) = 1.0
        end do

        ! Lead Green's function
        Gr = self%leadGreensFunction(Energy)
        M(:,:,self%nc+1) = Gr
        Q(:,:,self%nc+1) = Gr

        ! Backward Propagation
        Gnn = Gr
        GnR = Gr
        do j = self%nc,1,-1
            Sigma = tri(V,Gnn,conjg(V))
            Gnn = GAssembly(Energy,self%Hamiltonian(j),Sigma,eta)
            GnR = tri(Gnn,V,Gnr)
            M(:,:,j) = Gnn
            Q(:,:,j) = Gnr
        end do

        ! Forward + Merging
        Gnn = Gr
        GLn = Gr
        do j = 1,self%nc
            write(*,*) j
            ! Merge
            Sigma1 = tri(conjg(V),Gnn,V)
            Sigma2 = tri(V,M(:,:,j+1),conjg(V))
            Gnnn = GAssembly(Energy,self%Hamiltonian(j),Sigma1,Sigma2,eta)
            GLnn = tri(GLn,V,Gnnn)
            GnR = tri(Gnnn,V,Q(:,:,j+1))

            ! Forward
            Gnn = GAssembly(Energy,self%Hamiltonian(j),Sigma1,eta)
            GLn = tri(GLn,V,Gnn)

            ! Transmission
            do tip_pos = 1,self%nr
                ! Green's function of Tip
                do rj = 1,self%nr
                    do ri = 1,self%nr
                        G(ri,rj) = GLnn(ri,tip_pos)*GnR(tip_pos,rj)
                    end do
                end do
                !** Compute Gamma matrix
                ! S = V+.G_lead.V
                ! Gamma = i.(S-S+)
                Sigma = tri(conjg(V),Gr,V)
                Gama = cmplx(0,1)*(Sigma - conjg(Sigma))

                !** Compute trace
                ! r = Trace(Gama.G.Gama.G+)
                P = matmul(matmul(Gama,G),matmul(Gama,conjg(G)))
                D(tip_pos,j) = 0
                do k = 1,self%nr
                    D(tip_pos,j) = D(tip_pos,j) + real(P(k,k))
                end do
            end do
        end do
    end function
end module


#include "eiscor.h"
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! DOFDFI (Double Orthogonal hessenberg Factored Doubleshift Francis Iteration)
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! This routine computes one iteration of Francis' doubleshift
! algorithm on an orthogonal upper hessenberg matrix that is stored as a
! product of givens rotations and a diagonal matrix.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! INPUT VARIABLES:
!
!  COMPZ           CHARACTER
!                    'N': no eigenvectors
!                    'I': eigenvectors, initializing Z to the identity
!                    'V': eigenvectors, assume Z already initialized
!
!  N               INTEGER
!                    dimension of matrix
!
!  STR             INTEGER
!                    index of the top most givens rotation where
!                    the iteration begins
!
!  STP             INTEGER
!                    index of the bottom most givens rotation where
!                    the iteration ends
!
!  Q               REAL(8) array of dimension (2*(N-1))
!                    array of generators for givens rotations
!
!  D               REAL(8) array of dimension (2*N)
!                    array of generators for complex diagonal matrix
!
!  Z               REAL(8) array of dimension (N,N)
!                    if COMPZ = 'N' unused
!                    if COMPZ = 'I' stores eigenvectors in Z
!                    if COMPZ = 'V' update Z to store eigenvectors
!
!  ITCNT           INTEGER
!                   Contains the number of iterations since last deflation
!
! OUTPUT VARIABLES:
!
!  INFO            INTEGER
!                    INFO = 0 implies successful computation
!                    INFO = -1 implies COMPZ is invalid
!                    INFO = -3 implies STR is invalid
!                    INFO = -4 implies STP is invalid
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine DOFDFI(COMPZ,N,STR,STP,Q,D,Z,ITCNT,INFO)

  implicit none

  ! input variables
  character, intent(in) :: COMPZ
  integer, intent(in) :: N, STR, STP
  integer, intent(inout) :: ITCNT, INFO
  real(8), intent(inout) :: Q(2*(N-1)), D(2*N), Z(N,N)

  ! compute variables
  integer :: ii, ind
  real(8) :: s1, s2
  real(8) :: b1(2), b2(2), b3(2), temp(2)
  real(8) :: block(2,2)
  complex(8) :: eigs(2), h(2,2)

  ! initialize INFO
  INFO = 0

  ! check input in debug mode
  if (DEBUG) then

    ! check COMPZ
    if ((COMPZ.NE.'N').AND.(COMPZ.NE.'I').AND.(COMPZ.NE.'V')) then
      INFO = -1
      call UARERR(__FILE__,__LINE__,"COMPZ must be 'N', 'I' or 'V'",INFO,INFO)
      return
    end if

    ! check STR
    if ((STR < 1).OR.(STR > N-1)) then
      INFO = -3
      call UARERR(__FILE__,__LINE__,"STR must be 1 <= STR <= N-1",INFO,INFO)
      return
    end if

    ! check STP
    if ((STP < STR).OR.(STP > N-1)) then
      INFO = -4
      call UARERR(__FILE__,__LINE__,"STP must be STR <= STP <= N-1",INFO,INFO)
      return
    end if

  end if

  ! compute a nonzero shift
  ! shifts +1
  if((mod(ITCNT+1,11) == 0).AND.(ITCNT.NE.0))then
    eigs(1) = cmplx(1d0,0d0,kind=8)
    eigs(2) = cmplx(1d0,0d0,kind=8)

  ! shifts -1
  else if((mod(ITCNT+1,16) == 0).AND.(ITCNT.NE.0))then
    eigs(1) = cmplx(-1d0,0d0,kind=8)
    eigs(2) = cmplx(-1d0,0d0,kind=8)

  ! random shift
  else if((mod(ITCNT+1,21) == 0).AND.(ITCNT.NE.0))then
    call random_number(s1)
    call random_number(s2)
    eigs(1) = cmplx(s1,s2,kind=8)
    eigs(2) = cmplx(s1,-s2,kind=8)

  ! wilkinson shifts
  else
    ! get 2x2 block
    call DOFTDB(N,STP,Q,D,block,INFO)

    ! check INFO in debug mode
    if (DEBUG) then
      call UARERR(__FILE__,__LINE__,"DOFTDB failed",INFO,INFO)
      if (INFO.NE.0) then
        return
      end if
    end if

    ! compute eigenvalues and eigenvectors
    call DTTEEV(block,eigs,h,INFO)

    ! check INFO in debug mode
    if (DEBUG) then
      call UARERR(__FILE__,__LINE__,"DTTEEV failed",INFO,INFO)
      if (INFO.NE.0) then
        return
      end if
    end if

  end if

  ! two real shifts
  if ((aimag(eigs(1)).EQ.0d0).AND.(aimag(eigs(2)).EQ.0d0)) then

    ! first shift
    eigs(1) = cmplx(sign(1d0,dble(eigs(1))),0d0,kind=8)

    ! build first bulge
    temp(1) = dble(eigs(1))
    temp(2) = aimag(eigs(1))
    call DOFCFT('S',N,STR,Q,D,temp,b1,b2,INFO)

    ! check INFO in debug mode
    if (DEBUG) then
      call UARERR(__FILE__,__LINE__,"DOFCFT failed",INFO,INFO)
      if (INFO.NE.0) then
        return
      end if
    end if

    ! fusion to initialize first bulge
    ind = 2*(STR-1)
    b3(1) = b1(1)
    b3(2) = -b1(2)
    call DARFGR('R',b3,Q((ind+1):(ind+2)),INFO)

    ! check INFO in debug mode
    if (DEBUG) then
      call UARERR(__FILE__,__LINE__,"DARFGR failed",INFO,INFO)
      if (INFO.NE.0) then
        return
      end if
    end if

    ! first bulge update eigenvectors
    if (COMPZ .NE. 'N')then
      h(1,1) = b1(1)
      h(2,1) = b1(2)
      h(1,2) = -h(2,1)
      h(2,2) = h(1,1)
      Z(:,STR:(STR+1)) = matmul(Z(:,STR:(STR+1)),h)
    end if

    ! first bulge through D
    call DARGTD('R',D((ind+1):(ind+4)),b1,INFO)

    ! check INFO in debug mode
    if (DEBUG) then
      call UARERR(__FILE__,__LINE__,"DARGTD failed",INFO,INFO)
      if (INFO.NE.0) then
        return
      end if
    end if

    ! first bulge through Q
    call DARGTO(Q((ind+1):(ind+2)),Q((ind+3):(ind+4)),b1,INFO)

    ! check INFO in debug mode
    if (DEBUG) then
      call UARERR(__FILE__,__LINE__,"DARGTO failed",INFO,INFO)
      if (INFO.NE.0) then
        return
      end if
    end if

    ! second shift
    eigs(2) = cmplx(sign(1d0,dble(eigs(2))),0d0,kind=8)

    ! build bulge
    temp(1) = dble(eigs(2))
    temp(2) = aimag(eigs(2))
    call DOFCFT('S',N,STR,Q,D,temp,b2,b3,INFO)

    ! check INFO in debug mode
    if (DEBUG) then
      call UARERR(__FILE__,__LINE__,"DOFCFT failed",INFO,INFO)
      if (INFO.NE.0) then
        return
      end if
    end if

    ! fusion to initialize second bulge
    b3(1) = b2(1)
    b3(2) = -b2(2)
    call DARFGR('R',b3,Q((ind+1):(ind+2)),INFO)

    ! check INFO in debug mode
    if (DEBUG) then
      call UARERR(__FILE__,__LINE__,"DARFGR failed",INFO,INFO)
      if (INFO.NE.0) then
        return
      end if
    end if

    ! main chasing loop
    do ii=STR,(STP-2)

      ! set ind
      ind = 2*(ii-1)

      ! first bulge update eigenvectors
      if (COMPZ .NE. 'N')then
        h(1,1) = b1(1)
        h(2,1) = b1(2)
        h(1,2) = -h(2,1)
        h(2,2) = h(1,1)
        Z(:,(ii+1):(ii+2)) = matmul(Z(:,(ii+1):(ii+2)),h)
      end if

      ! first bulge through D
      call DARGTD('R',D((ind+3):(ind+6)),b1,INFO)

      ! check INFO in debug mode
      if (DEBUG) then
        call UARERR(__FILE__,__LINE__,"DARGTD failed",INFO,INFO)
        if (INFO.NE.0) then
          return
        end if
      end if

      ! first bulge through Q
      call DARGTO(Q((ind+3):(ind+4)),Q((ind+5):(ind+6)),b1,INFO)

      ! check INFO in debug mode
      if (DEBUG) then
        call UARERR(__FILE__,__LINE__,"DARGTO failed",INFO,INFO)
        if (INFO.NE.0) then
          return
        end if
      end if

      ! second bulge update eigenvectors
      if (COMPZ .NE. 'N')then
        h(1,1) = b2(1)
        h(2,1) = b2(2)
        h(1,2) = -h(2,1)
        h(2,2) = h(1,1)
        Z(:,ii:(ii+1)) = matmul(Z(:,ii:(ii+1)),h)
      end if

      ! second bulge through D
      call DARGTD('R',D((ind+1):(ind+4)),b2,INFO)

      ! check INFO in debug mode
      if (DEBUG) then
        call UARERR(__FILE__,__LINE__,"DARGTD failed",INFO,INFO)
        if (INFO.NE.0) then
          return
        end if
      end if

      ! second bulge through Q
      call DARGTO(Q((ind+1):(ind+2)),Q((ind+3):(ind+4)),b2,INFO)

      ! check INFO in debug mode
      if (DEBUG) then
        call UARERR(__FILE__,__LINE__,"DARGTO failed",INFO,INFO)
        if (INFO.NE.0) then
          return
        end if
      end if

    end do

    ! set ind
    ind = 2*(stp-2)

    ! first bulge update eigenvectors
    if (COMPZ .NE. 'N')then
      h(1,1) = b1(1)
      h(2,1) = b1(2)
      h(1,2) = -h(2,1)
      h(2,2) = h(1,1)
      Z(:,STP:(STP+1)) = matmul(Z(:,STP:(STP+1)),h)
    end if

    ! first bulge through D
    call DARGTD('R',D((ind+3):(ind+6)),b1,INFO)

    ! check INFO in debug mode
    if (DEBUG) then
      call UARERR(__FILE__,__LINE__,"DARGTD failed",INFO,INFO)
      if (INFO.NE.0) then
        return
      end if
    end if

    ! first bulge fuse with Q
    call DARFGR('L',Q((ind+3):(ind+4)),b1,INFO)

    ! check INFO in debug mode
    if (DEBUG) then
      call UARERR(__FILE__,__LINE__,"DARFGR failed",INFO,INFO)
      if (INFO.NE.0) then
        return
      end if
    end if

    ! second bulge update eigenvectors
    if (COMPZ .NE. 'N')then
      h(1,1) = b2(1)
      h(2,1) = b2(2)
      h(1,2) = -h(2,1)
      h(2,2) = h(1,1)
      Z(:,(STP-1):STP) = matmul(Z(:,(STP-1):STP),h)
    end if

    ! second bulge through D
    call DARGTD('R',D((ind+1):(ind+4)),b2,INFO)

    ! check INFO in debug mode
    if (DEBUG) then
      call UARERR(__FILE__,__LINE__,"DARGTD failed",INFO,INFO)
      if (INFO.NE.0) then
        return
      end if
    end if

    ! second bulge through Q
    call DARGTO(Q((ind+1):(ind+2)),Q((ind+3):(ind+4)),b2,INFO)

    ! check INFO in debug mode
    if (DEBUG) then
      call UARERR(__FILE__,__LINE__,"DARGTO failed",INFO,INFO)
      if (INFO.NE.0) then
        return
      end if
    end if

    ! set index
    ind = 2*(stp-1)

    ! last bulge update eigenvectors
    if (COMPZ .NE. 'N')then
      h(1,1) = b2(1)
      h(2,1) = b2(2)
      h(1,2) = -h(2,1)
      h(2,2) = h(1,1)
      Z(:,STP:(STP+1)) = matmul(Z(:,STP:(STP+1)),h)
    end if

    ! last bulge through D
    call DARGTD('R',D((ind+1):(ind+4)),b2,INFO)

    ! check INFO in debug mode
    if (DEBUG) then
      call UARERR(__FILE__,__LINE__,"DARGTD failed",INFO,INFO)
      if (INFO.NE.0) then
        return
      end if
    end if

    ! last bulge fuse with Q
    call DARFGR('L',Q((ind+1):(ind+2)),b2,INFO)

    ! check INFO in debug mode
    if (DEBUG) then
      call UARERR(__FILE__,__LINE__,"DARFGR failed",INFO,INFO)
      if (INFO.NE.0) then
        return
      end if
    end if

    ! update ITCNT
    ITCNT = ITCNT + 1

  ! complex conjugate pair
  else

    ! normalize shifts
    if (abs(eigs(1)).EQ.0d0) then
      eigs(1) = cmplx(0d0,1d0,kind=8)
    end if
    eigs(1) = eigs(1)/abs(eigs(1))

    ! build bulge
    temp(1) = dble(eigs(1))
    temp(2) = aimag(eigs(1))
    call DOFCFT('D',N,STR,Q,D,temp,b1,b2,INFO)

    ! check INFO in debug mode
    if (DEBUG) then
      call UARERR(__FILE__,__LINE__,"DOFCFT failed",INFO,INFO)
      if (INFO.NE.0) then
        return
      end if
    end if

    ! turnover to initialize bulge
    ind = 2*(STR-1)
    temp(1) = b2(1)
    temp(2) = -b2(2)
    b3(1) = b1(1)
    b3(2) = -b1(2)
    call DARGTO(temp,b3,Q((ind+1):(ind+2)),INFO)

    ! check INFO in debug mode
    if (DEBUG) then
      call UARERR(__FILE__,__LINE__,"DARGTO failed",INFO,INFO)
      if (INFO.NE.0) then
        return
      end if
    end if

    ! fusion to finish initialization
    call DARFGR('R',b3,Q((ind+3):(ind+4)),INFO)

    ! check INFO in debug mode
    if (DEBUG) then
      call UARERR(__FILE__,__LINE__,"DARFGR failed",INFO,INFO)
      if (INFO.NE.0) then
        return
      end if
    end if

    ! update b3
    b3 = Q((ind+1):(ind+2))

    ! update Q
    Q((ind+1):(ind+2)) = temp

    ! main chasing loop
    do ii=str,(stp-2)

      ! set ind
      ind = 2*(ii-1)

      ! first bulge update eigenvectors
      if (COMPZ .NE. 'N')then
        h(1,1) = b1(1)
        h(2,1) = b1(2)
        h(1,2) = -h(2,1)
        h(2,2) = h(1,1)
        Z(:,(ii+1):(ii+2)) = matmul(Z(:,(ii+1):(ii+2)),h)
      end if

      ! first bulge through D
      call DARGTD('R',D((ind+3):(ind+6)),b1,INFO)

      ! check INFO in debug mode
      if (DEBUG) then
        call UARERR(__FILE__,__LINE__,"DARGTD failed",INFO,INFO)
        if (INFO.NE.0) then
          return
        end if
      end if

      ! first bulge through Q
      call DARGTO(Q((ind+3):(ind+4)),Q((ind+5):(ind+6)),b1,INFO)

      ! check INFO in debug mode
      if (DEBUG) then
        call UARERR(__FILE__,__LINE__,"DARGTO failed",INFO,INFO)
        if (INFO.NE.0) then
          return
        end if
      end if

      ! second bulge update eigenvectors
      if (COMPZ .NE. 'N')then
        h(1,1) = b2(1)
        h(2,1) = b2(2)
        h(1,2) = -h(2,1)
        h(2,2) = h(1,1)
        Z(:,ii:(ii+1)) = matmul(Z(:,ii:(ii+1)),h)
      end if

      ! second bulge through D
      call DARGTD('R',D((ind+1):(ind+4)),b2,INFO)

      ! check INFO in debug mode
      if (DEBUG) then
        call UARERR(__FILE__,__LINE__,"DARGTD failed",INFO,INFO)
        if (INFO.NE.0) then
          return
        end if
      end if

      ! second bulge through Q
      call DARGTO(Q((ind+1):(ind+2)),Q((ind+3):(ind+4)),b2,INFO)

      ! check INFO in debug mode
      if (DEBUG) then
        call UARERR(__FILE__,__LINE__,"DARGTO failed",INFO,INFO)
        if (INFO.NE.0) then
          return
        end if
      end if

      ! push b3 down
      call DARGTO(b3,b1,b2,INFO)

      ! check INFO in debug mode
      if (DEBUG) then
        call UARERR(__FILE__,__LINE__,"DARGTO failed",INFO,INFO)
        if (INFO.NE.0) then
          return
        end if
      end if

    ! update bulges
      temp = b2
      b2 = b3
      b3 = b1
      b1 = temp

    end do

    ! set ind
    ind = 2*(stp-2)

    ! first bulge update eigenvectors
    if (COMPZ .NE. 'N')then
      h(1,1) = b1(1)
      h(2,1) = b1(2)
      h(1,2) = -h(2,1)
      h(2,2) = h(1,1)
      Z(:,STP:(STP+1)) = matmul(Z(:,STP:(STP+1)),h)
    end if

    ! first bulge through D
    call DARGTD('R',D((ind+3):(ind+6)),b1,INFO)

    ! check INFO in debug mode
    if (DEBUG) then
      call UARERR(__FILE__,__LINE__,"DARGTD failed",INFO,INFO)
      if (INFO.NE.0) then
        return
      end if
    end if

    ! first bulge fuse with Q
    call DARFGR('L',Q((ind+3):(ind+4)),b1,INFO)

    ! check INFO in debug mode
    if (DEBUG) then
      call UARERR(__FILE__,__LINE__,"DARFGR failed",INFO,INFO)
      if (INFO.NE.0) then
        return
      end if
    end if

    ! second bulge update eigenvectors
    if (COMPZ .NE. 'N')then
      h(1,1) = b2(1)
      h(2,1) = b2(2)
      h(1,2) = -h(2,1)
      h(2,2) = h(1,1)
      Z(:,(STP-1):STP) = matmul(Z(:,(STP-1):STP),h)
    end if

    ! second bulge through D
    call DARGTD('R',D((ind+1):(ind+4)),b2,INFO)

    ! check INFO in debug mode
    if (DEBUG) then
      call UARERR(__FILE__,__LINE__,"DARGTD failed",INFO,INFO)
      if (INFO.NE.0) then
        return
      end if
    end if

    ! second bulge through Q
    call DARGTO(Q((ind+1):(ind+2)),Q((ind+3):(ind+4)),b2,INFO)

    ! check INFO in debug mode
    if (DEBUG) then
      call UARERR(__FILE__,__LINE__,"DARGTO failed",INFO,INFO)
      if (INFO.NE.0) then
        return
      end if
    end if

    ! fuse b2 and b3
    call DARFGR('L',b3,b2,INFO)

    ! check INFO in debug mode
    if (DEBUG) then
      call UARERR(__FILE__,__LINE__,"DARFGR failed",INFO,INFO)
      if (INFO.NE.0) then
        return
      end if
    end if

    ! set index
    ind = 2*(stp-1)

    ! last bulge update eigenvectors
    if (COMPZ .NE. 'N')then
      h(1,1) = b3(1)
      h(2,1) = b3(2)
      h(1,2) = -h(2,1)
      h(2,2) = h(1,1)
      Z(:,STP:(STP+1)) = matmul(Z(:,STP:(STP+1)),h)
    end if

    ! last bulge through D
    call DARGTD('R',D((ind+1):(ind+4)),b3,INFO)

    ! check INFO in debug mode
    if (DEBUG) then
      call UARERR(__FILE__,__LINE__,"DARGTD failed",INFO,INFO)
      if (INFO.NE.0) then
        return
      end if
    end if

    ! last bulge fuse with Q
    call DARFGR('L',Q((ind+1):(ind+2)),b3,INFO)

    ! check INFO in debug mode
    if (DEBUG) then
      call UARERR(__FILE__,__LINE__,"DARFGR failed",INFO,INFO)
      if (INFO.NE.0) then
        return
      end if
    end if

    ! update ITCNT
    ITCNT = ITCNT + 1

  end if ! end of doubleshift step

end subroutine DOFDFI


! This file is part of DASH.
! SPDX-Identifier: MIT
!
! Copyright 2001 Science and Technology Facilities Council
! Copyright 2001 Cambridge Crystallographic Data Centre
!
! Permission is hereby granted, free of charge, to any person obtaining a copy
! of this software and associated documentation files (the "Software"), to deal
! in the Software without restriction, including without limitation the rights
! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is
! furnished to do so, subject to the following conditions:
!
! The above copyright notice and this permission notice shall be included in
! all copies or substantial portions of the Software.
!
! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
! SOFTWARE.
!
!*****************************************************************************
!
      SUBROUTINE FRAC2PDB(MATRIX,A,B,C,ALFA,BETA,GAMA)

! Same as LatticeCellParameters2Lattice_2()

      REAL MATRIX(3,3)
      REAL A, B, C, ALFA, BETA, GAMA
      REAL RADEG, CA, CB, CG, SG, VOLU
      DATA RADEG /1.7453292519943296E-2/
! This routine will create the conversion matrix for fractional to orthogonal
! coordinates as defined in the PDB manual (i.e. a along X)
      CA = COS(ALFA*RADEG)
      CB = COS(BETA*RADEG)
      CG = COS(GAMA*RADEG)
      SG = SIN(GAMA*RADEG)
      VOLU = A*B*C*SQRT(1.0-CA*CA-CB*CB-CG*CG+2.0*CA*CB*CG)
      MATRIX(1,1) = A
      MATRIX(2,1) = 0.0
      MATRIX(3,1) = 0.0
      MATRIX(1,2) = B*CG
      MATRIX(2,2) = B*SG
      MATRIX(3,2) = 0.0
      MATRIX(1,3) = C*CB
      MATRIX(2,3) = C*(CA-CB*CG)/SG
      MATRIX(3,3) = VOLU/(A*B*SG)

      END SUBROUTINE FRAC2PDB
!
!*****************************************************************************
!


! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!
! The Reaction Rates File
!
! Generated by KPP-2.2.3 symbolic chemistry Kinetics PreProcessor
!       (http://www.cs.vt.edu/~asandu/Software/KPP)
! KPP is distributed under GPL, the general public licence
!       (http://www.gnu.org/copyleft/gpl.html)
! (C) 1995-1997, V. Damian & A. Sandu, CGRER, Univ. Iowa
! (C) 1997-2005, A. Sandu, Michigan Tech, Virginia Tech
!     With important contributions from:
!        M. Damian, Villanova University, USA
!        R. Sander, Max-Planck Institute for Chemistry, Mainz, Germany
!
! File                 : kpp_achem_gas_Rates.f90
! Time                 : Thu Jun 11 11:33:46 2015
! Working directory    : /gpfsm/dnb32/adarmeno/models/geos-5/heracles-UNSTABLE-DEV_MICROPHYSICS/src/GEOSgcs_GridComp/GEOSgcm_GridComp/GEOSagcm_GridComp/GEOSphV
! Equation file        : kpp_achem_gas.kpp
! Output root filename : kpp_achem_gas
!
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

MODULE kpp_achem_gas_Rates

  USE kpp_achem_gas_Parameters
  USE kpp_achem_gas_Global
  IMPLICIT NONE

CONTAINS

! Begin Rate Law Functions from KPP_HOME/util/UserRateLaws

!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!  User-defined Rate Law functions
!  Note: the default argument type for rate laws, as read from the equations file, is single precision
!        but all the internal calculations are performed in double precision
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

!~~~>  Arrhenius
   REAL(kind=dp) FUNCTION ARR( A0,B0,C0 )
      REAL A0,B0,C0
      ARR =  DBLE(A0) * EXP(-DBLE(B0)/TEMP) * (TEMP/300.0_dp)**DBLE(C0)
   END FUNCTION ARR

!~~~> Simplified Arrhenius, with two arguments
!~~~> Note: The argument B0 has a changed sign when compared to ARR
   REAL(kind=dp) FUNCTION ARR2( A0,B0 )
      REAL A0,B0
      ARR2 =  DBLE(A0) * EXP( DBLE(B0)/TEMP )
   END FUNCTION ARR2

   REAL(kind=dp) FUNCTION EP2(A0,C0,A2,C2,A3,C3)
      REAL A0,C0,A2,C2,A3,C3
      REAL(kind=dp) K0,K2,K3
      K0 = DBLE(A0) * EXP(-DBLE(C0)/TEMP)
      K2 = DBLE(A2) * EXP(-DBLE(C2)/TEMP)
      K3 = DBLE(A3) * EXP(-DBLE(C3)/TEMP)
      K3 = K3*CFACTOR*1.0E6_dp
      EP2 = K0 + K3/(1.0_dp+K3/K2 )
   END FUNCTION EP2

   REAL(kind=dp) FUNCTION EP3(A1,C1,A2,C2)
      REAL A1, C1, A2, C2
      REAL(kind=dp) K1, K2
      K1 = DBLE(A1) * EXP(-DBLE(C1)/TEMP)
      K2 = DBLE(A2) * EXP(-DBLE(C2)/TEMP)
      EP3 = K1 + K2*(1.0E6_dp*CFACTOR)
   END FUNCTION EP3

   REAL(kind=dp) FUNCTION FALL ( A0,B0,C0,A1,B1,C1,CF)
      REAL A0,B0,C0,A1,B1,C1,CF
      REAL(kind=dp) K0, K1
      K0 = DBLE(A0) * EXP(-DBLE(B0)/TEMP)* (TEMP/300.0_dp)**DBLE(C0)
      K1 = DBLE(A1) * EXP(-DBLE(B1)/TEMP)* (TEMP/300.0_dp)**DBLE(C1)
      K0 = K0*CFACTOR*1.0E6_dp
      K1 = K0/K1
      FALL = (K0/(1.0_dp+K1))*   &
           DBLE(CF)**(1.0_dp/(1.0_dp+(LOG10(K1))**2))
   END FUNCTION FALL

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

  ELEMENTAL REAL(kind=dp) FUNCTION k_3rd(temp,cair,k0_300K,n,kinf_300K,m,fc)

    INTRINSIC LOG10

    REAL(kind=dp), INTENT(IN) :: temp      ! temperature [K]
    REAL(kind=dp), INTENT(IN) :: cair      ! air concentration [molecules/cm3]
    REAL, INTENT(IN) :: k0_300K   ! low pressure limit at 300 K
    REAL, INTENT(IN) :: n         ! exponent for low pressure limit
    REAL, INTENT(IN) :: kinf_300K ! high pressure limit at 300 K
    REAL, INTENT(IN) :: m         ! exponent for high pressure limit
    REAL, INTENT(IN) :: fc        ! broadening factor (usually fc=0.6)
    REAL(kind=dp) :: zt_help, k0_T, kinf_T, k_ratio

    zt_help = 300._dp/temp
    k0_T    = k0_300K   * zt_help**(n) * cair ! k_0   at current T
    kinf_T  = kinf_300K * zt_help**(m)        ! k_inf at current T
    k_ratio = k0_T/kinf_T
    k_3rd   = k0_T/(1._dp+k_ratio)*fc**(1._dp/(1._dp+LOG10(k_ratio)**2))

  END FUNCTION k_3rd

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

  ELEMENTAL REAL(kind=dp) FUNCTION k_arr (k_298,tdep,temp)
    ! Arrhenius function

    REAL,     INTENT(IN) :: k_298 ! k at T = 298.15K
    REAL,     INTENT(IN) :: tdep  ! temperature dependence
    REAL(kind=dp), INTENT(IN) :: temp  ! temperature

    INTRINSIC EXP

    k_arr = k_298 * EXP(tdep*(1._dp/temp-3.3540E-3_dp)) ! 1/298.15=3.3540e-3

  END FUNCTION k_arr

!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!  End of User-defined Rate Law functions
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

! End Rate Law Functions from KPP_HOME/util/UserRateLaws

! Begin INLINED Rate Law Functions

real(dp) function k_DMS_OH(c_O2, T)
    !
    ! reaction rate for OH addition pathway:
    ! DMS + OH = 0.75SO2 + 0.25MSA
    !

    implicit none

    ! inputs
    real(dp), intent(in) :: c_O2
    real(dp), intent(in) :: T

    ! local

    ! rate
    !k_DMS_OH = c_O2 * 1.7d-42 * exp(7810_dp/T) / &
    !           (1_dp + c_O2 * 5.5d-31 * exp(7460_dp/T))

    k_DMS_OH = c_O2 * 1.7d-11 * exp(7810_dp/T) / &
               (1.0d31 + c_O2 * 5.5d0 * exp(7460_dp/T))

end function k_DMS_OH

real(dp) function k_SO2_OH(c_air, T)
    !
    ! reaction rate for:
    ! SO2 + OH  = H2SO4
    !

    implicit none

    ! inputs
    real(dp), intent(in) :: c_air
    real(dp), intent(in) :: T

    ! local
    real(dp) :: k_0, k_inf

    ! rate
    k_0   = 3.0d-31 * (300_dp/T)**3.3
    k_inf = 1.5d-12

    k_SO2_OH = ((k_0 * c_air) / (1.0_dp + k_0 * c_air / k_inf)) * &
                0.6_dp**(1.0_dp / (1.0_dp + (log10(k_0 * c_air / k_inf))**2))

end function k_SO2_OH

! End INLINED Rate Law Functions

! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!
! Update_SUN - update SUN light using TIME
!   Arguments :
!
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

  SUBROUTINE Update_SUN()
      !USE kpp_achem_gas_Parameters
      !USE kpp_achem_gas_Global

    IMPLICIT NONE

    REAL(kind=dp) :: SunRise, SunSet
    REAL(kind=dp) :: Thour, Tlocal, Ttmp
    ! PI - Value of pi
    REAL(kind=dp), PARAMETER :: PI = 3.14159265358979d0

    SunRise = 4.5_dp
    SunSet  = 19.5_dp
    Thour = TIME/3600.0_dp
    Tlocal = Thour - (INT(Thour)/24)*24

    IF ((Tlocal>=SunRise).AND.(Tlocal<=SunSet)) THEN
       Ttmp = (2.0*Tlocal-SunRise-SunSet)/(SunSet-SunRise)
       IF (Ttmp.GT.0) THEN
          Ttmp =  Ttmp*Ttmp
       ELSE
          Ttmp = -Ttmp*Ttmp
       END IF
       SUN = ( 1.0_dp + COS(PI*Ttmp) )/2.0_dp
    ELSE
       SUN = 0.0_dp
    END IF

 END SUBROUTINE Update_SUN

! End of Update_SUN function
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!
! Update_RCONST - function to update rate constants
!   Arguments :
!
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

SUBROUTINE Update_RCONST ( )

! Begin INLINED RCONST

! End INLINED RCONST

  RCONST(1) = (1.2d-11*exp(-260.0d0/temp))
  RCONST(2) = (k_DMS_OH(c_O2,temp))
  RCONST(3) = (1.9d-13*exp(520.0d0/temp))
  RCONST(4) = (k_SO2_OH(c_air,temp))
  RCONST(5) = (1.7d-12*exp(-710.0d0/temp))

END SUBROUTINE Update_RCONST

! End of Update_RCONST function
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!
! Update_PHOTO - function to update photolytical rate constants
!   Arguments :
!
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

SUBROUTINE Update_PHOTO ( )

   USE kpp_achem_gas_Global

END SUBROUTINE Update_PHOTO

! End of Update_PHOTO function
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

END MODULE kpp_achem_gas_Rates


!
!   FnVFNRet.f90
!
!
!   Created by Kurt Mitman on 10/10/14.
!
!

DOUBLE PRECISION FUNCTION FnVFNRet(bsav)

USE Params
USE Globals
USE funcs
USE Procedures

IMPLICIT NONE

DOUBLE PRECISION, INTENT(IN) :: bsav
DOUBLE PRECISION             :: cons,qltemp,qltemp2
DOUBLE PRECISION             :: vals(2)
INTEGER                      :: inds(2)

call basefun(GridB,nb,bsav,vals,inds)

cons=gliq-FnQb(bsav,gPh*ghouse-gmort)*bsav

if(cons .GT. cmin) then

FnVFNRet = -1.0d0*(uown(cons,ghouse,gij)+bet*(vals(1)*sum(gvals*EVownRet(inds(1),gil,ginds,gih,gij))+vals(2)*sum(gvals*EVownRet(inds(2),gil,ginds,gih,gij))))

else

FnVFNRet = 1.0d10+10.0d0*(cmin-cons)

endif

END FUNCTION FnVFNRet


        subroutine planck2(temp,x,bratio,bp,bt)

        real*4 expo,temp
        real*4 bp,bt,bratio

        a=1.43880/x
        c=(1.1910627e-5/x)/x**4

        bp=dplnck(temp,x)

        if(bratio.eq.1.)then
           bt=dtplanck(temp,x)
           return
        else
           expo=c/bp+1.
           bp=c/(bratio*expo-1.)
           bt=bp*bp*bratio*a*expo/c/temp/temp
        end if
	return

        end


! fortran_free_source

module pfc1Dfuns

implicit none

contains

!============================================================================
! function to compute the conveyance coef at the western face
! the convention used here is that 'in' refers to cell 'i'
! and 'out' refers to cell 'i-1', which is the western cell

FUNCTION F_CC( xin,  dxin,  hin, zin, &
              xout, dxout, hout, zout )  Result( CC )
use shared, only: K_input, n_mann_input, b_pfc_input, h_pfc_min
use pfc1dfuns2
implicit none
REAL :: xin,  xout   ! coordinate of the ith cell and the WESTERN cell center
REAL :: dxin, dxout  ! cell sizes
REAL :: hin,  hout   ! thicknesses at cell center
REAL :: zin,  zout   ! elevations  at cell center
REAL :: CC   !, F_hp_face, F_hs_face  <----these now in a module
! dummy vars
REAL :: hpw !thickness in the PAVEMENT at the western face
REAL :: hsw !thickness on the SURFACE at the western face
REAL :: Sfw !magnitude of hydraulic gradient at the western face
logical :: error
!-------------------------------------------

! Intermediate quantities
hpw =  F_hp_face(dxin, hin, zin, dxout, hout, zout, b_pfc_input)
hsw =  F_hs_face(dxin, hin, zin, dxout, hout, zout, b_pfc_input)
Sfw =  sqrt( ( ( hout + zout - hin - zin ) * 2. / &
                (dxout + dxin) ) ** 2 )

! Set hpw to small but positive and with enough range
!   left to allow further calcs.zero if negative
if( hpw .LT. TINY( hpw ) ) then
    hpw   =  h_pfc_min
end if

!Conveyance coefficient itself
if( hsw .GT. 0.0 ) then
   CC  = 1. / abs( xin - xout ) *                       &
            (   K_input * hpw +                               &
              1./ n_mann_input * hsw ** (5./3.) /  sqrt(Sfw) )
else
! only PFC flow
   CC  = 1. / abs( xin - xout ) *                       &
            (   K_input * hpw  )
end if

! ERROR CHECKING FOR CONVEYANCE COEFS
if( (CC .GT. HUGE(CC) ) .OR. (CC .LT. -HUGE(CC) ) ) then
    error = .true.
else
    error = .false.
endif

!Output the parts of the calculation if the error is true
if( error .eqv. .true. ) then
    write(*,*) 'Problem with 1D conveyance coefficient!'
    print *, '       K = ', K_input
    print *, '      hp = ', hpw
    print *, '  n_mann = ', n_mann_input
    print *, '      hs = ', hsw
    print *, '      Sf = ', Sfw
    print *, '     xin = ', xin
    print *, '    xout = ', xout
    print *, '      CC = ', CC
    write(*,*) 'Stopping Program'
    STOP
endif

END FUNCTION
!======================================================================

!======================================================================
!Function to switch the porosity on/off if the
!  water is in/out of the pavement
FUNCTION F_por(h)
USE shared, only: b_pfc_input, por_input
IMPLICIT NONE
REAL h, F_por
if     ( h >= b_pfc_input ) then
                        F_por = 1.
ELSEIF ( h < b_pfc_input )  then
                        F_por = 1./por_input
end if
END function F_por
!======================================================================

!======================================================================
!       \\\\\\\\\\                                       //////////
                      END MODULE pfc1Dfuns
!       //////////                                       \\\\\\\\\\\
!======================================================================


      SUBROUTINE DT_RACO(Wx,Wy,Wz)

C***********************************************************************
C Direction cosines of random uniform (isotropic) direction in three   *
C dimensional space                                                    *
C Processed by S. Roesler, 20.11.95                                    *
C***********************************************************************

      IMPLICIT NONE
      DOUBLE PRECISION cfe , DT_RNDM , OHALF , ONE , sfe , TWO , Wx ,
     &                 Wy , Wz , x , x2 , y , y2 , z , ZERO
      SAVE
      PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0)

 100  x = TWO*DT_RNDM(Wx) - ONE
      y = DT_RNDM(x)
      x2 = x*x
      y2 = y*y
      IF ( x2+y2.GT.ONE ) GOTO 100

      cfe = (x2-y2)/(x2+y2)
      sfe = TWO*x*y/(x2+y2)
C z = 1/2 [ 1 + cos (theta) ]
      z = DT_RNDM(x)
C 1/2 sin (theta)
      Wz = SQRT(z*(ONE-z))
      Wx = TWO*Wz*cfe
      Wy = TWO*Wz*sfe
      Wz = TWO*z - ONE

      END SUBROUTINE


c---------------------------------------------------------------------
c---------------------------------------------------------------------

       subroutine  initialize

c---------------------------------------------------------------------
c---------------------------------------------------------------------

c---------------------------------------------------------------------
c This subroutine initializes the field variable u using
c tri-linear transfinite interpolation of the boundary values
c---------------------------------------------------------------------

       include 'header.h'

       integer c, i, j, k, m, ii, jj, kk, ix, iy, iz
       double precision  xi, eta, zeta, Pface(5,3,2), Pxi, Peta,
     >                   Pzeta, temp(5)

c---------------------------------------------------------------------
c  Later (in compute_rhs) we compute 1/u for every element. A few of
c  the corner elements are not used, but it convenient (and faster)
c  to compute the whole thing with a simple loop. Make sure those
c  values are nonzero by initializing the whole thing here.
c---------------------------------------------------------------------
      do c = 1, ncells
         do kk = -1, IMAX
            do jj = -1, IMAX
               do ii = -1, IMAX
                  u(ii, jj, kk, 1, c) = 1.0
                  u(ii, jj, kk, 2, c) = 0.0
                  u(ii, jj, kk, 3, c) = 0.0
                  u(ii, jj, kk, 4, c) = 0.0
                  u(ii, jj, kk, 5, c) = 1.0
               end do
            end do
         end do
      end do

c---------------------------------------------------------------------
c first store the "interpolated" values everywhere on the grid
c---------------------------------------------------------------------
       do  c=1, ncells
          kk = 0
          do  k = cell_low(3,c), cell_high(3,c)
             zeta = dble(k) * dnzm1
             jj = 0
             do  j = cell_low(2,c), cell_high(2,c)
                eta = dble(j) * dnym1
                ii = 0
                do   i = cell_low(1,c), cell_high(1,c)
                   xi = dble(i) * dnxm1

                   do ix = 1, 2
                      call exact_solution(dble(ix-1), eta, zeta,
     >                                    Pface(1,1,ix))
                   end do

                   do    iy = 1, 2
                      call exact_solution(xi, dble(iy-1) , zeta,
     >                                    Pface(1,2,iy))
                   end do

                   do    iz = 1, 2
                      call exact_solution(xi, eta, dble(iz-1),
     >                                    Pface(1,3,iz))
                   end do

                   do   m = 1, 5
                      Pxi   = xi   * Pface(m,1,2) +
     >                        (1.0d0-xi)   * Pface(m,1,1)
                      Peta  = eta  * Pface(m,2,2) +
     >                        (1.0d0-eta)  * Pface(m,2,1)
                      Pzeta = zeta * Pface(m,3,2) +
     >                        (1.0d0-zeta) * Pface(m,3,1)

                      u(ii,jj,kk,m,c) = Pxi + Peta + Pzeta -
     >                          Pxi*Peta - Pxi*Pzeta - Peta*Pzeta +
     >                          Pxi*Peta*Pzeta

                   end do
                   ii = ii + 1
                end do
                jj = jj + 1
             end do
             kk = kk+1
          end do
       end do

c---------------------------------------------------------------------
c now store the exact values on the boundaries
c---------------------------------------------------------------------

c---------------------------------------------------------------------
c west face
c---------------------------------------------------------------------
       c = slice(1,1)
       ii = 0
       xi = 0.0d0
       kk = 0
       do  k = cell_low(3,c), cell_high(3,c)
          zeta = dble(k) * dnzm1
          jj = 0
          do   j = cell_low(2,c), cell_high(2,c)
             eta = dble(j) * dnym1
             call exact_solution(xi, eta, zeta, temp)
             do   m = 1, 5
                u(ii,jj,kk,m,c) = temp(m)
             end do
             jj = jj + 1
          end do
          kk = kk + 1
       end do

c---------------------------------------------------------------------
c east face
c---------------------------------------------------------------------
       c  = slice(1,ncells)
       ii = cell_size(1,c)-1
       xi = 1.0d0
       kk = 0
       do   k = cell_low(3,c), cell_high(3,c)
          zeta = dble(k) * dnzm1
          jj = 0
          do   j = cell_low(2,c), cell_high(2,c)
             eta = dble(j) * dnym1
             call exact_solution(xi, eta, zeta, temp)
             do   m = 1, 5
                u(ii,jj,kk,m,c) = temp(m)
             end do
             jj = jj + 1
          end do
          kk = kk + 1
       end do

c---------------------------------------------------------------------
c south face
c---------------------------------------------------------------------
       c = slice(2,1)
       jj = 0
       eta = 0.0d0
       kk = 0
       do  k = cell_low(3,c), cell_high(3,c)
          zeta = dble(k) * dnzm1
          ii = 0
          do   i = cell_low(1,c), cell_high(1,c)
             xi = dble(i) * dnxm1
             call exact_solution(xi, eta, zeta, temp)
             do   m = 1, 5
                u(ii,jj,kk,m,c) = temp(m)
             end do
             ii = ii + 1
          end do
          kk = kk + 1
       end do

c---------------------------------------------------------------------
c north face
c---------------------------------------------------------------------
       c = slice(2,ncells)
       jj = cell_size(2,c)-1
       eta = 1.0d0
       kk = 0
       do   k = cell_low(3,c), cell_high(3,c)
          zeta = dble(k) * dnzm1
          ii = 0
          do   i = cell_low(1,c), cell_high(1,c)
             xi = dble(i) * dnxm1
             call exact_solution(xi, eta, zeta, temp)
             do   m = 1, 5
                u(ii,jj,kk,m,c) = temp(m)
             end do
             ii = ii + 1
          end do
          kk = kk + 1
       end do

c---------------------------------------------------------------------
c bottom face
c---------------------------------------------------------------------
       c = slice(3,1)
       kk = 0
       zeta = 0.0d0
       ii = 0
       do   i =cell_low(1,c), cell_high(1,c)
          xi = dble(i) *dnxm1
          jj = 0
          do   j = cell_low(2,c), cell_high(2,c)
             eta = dble(j) * dnym1
             call exact_solution(xi, eta, zeta, temp)
             do   m = 1, 5
                u(ii,jj,kk,m,c) = temp(m)
             end do
             jj = jj + 1
          end do
          ii = ii + 1
       end do

c---------------------------------------------------------------------
c top face
c---------------------------------------------------------------------
       c = slice(3,ncells)
       kk = cell_size(3,c)-1
       zeta = 1.0d0
       ii = 0
       do   i =cell_low(1,c), cell_high(1,c)
          xi = dble(i) * dnxm1
          jj = 0
          do   j = cell_low(2,c), cell_high(2,c)
             eta = dble(j) * dnym1
             call exact_solution(xi, eta, zeta, temp)
             do   m = 1, 5
                u(ii,jj,kk,m,c) = temp(m)
             end do
             jj = jj + 1
          end do
          ii = ii + 1
       end do

       return
       end

       subroutine lhsinit

       include 'header.h'

       integer i, j, k, d, c, n

c---------------------------------------------------------------------
c loop over all cells
c---------------------------------------------------------------------
       do  c = 1, ncells

c---------------------------------------------------------------------
c         first, initialize the start and end arrays
c---------------------------------------------------------------------
          do  d = 1, 3
             if (cell_coord(d,c) .eq. 1) then
                start(d,c) = 1
             else
                start(d,c) = 0
             endif
             if (cell_coord(d,c) .eq. ncells) then
                end(d,c) = 1
             else
                end(d,c) = 0
             endif
          end do

c---------------------------------------------------------------------
c     zap the whole left hand side for starters
c---------------------------------------------------------------------
          do  n = 1, 15
             do  k = 0, cell_size(3,c)-1
                do  j = 0, cell_size(2,c)-1
                   do  i = 0, cell_size(1,c)-1
                      lhs(i,j,k,n,c) = 0.0d0
                   end do
                end do
             end do
          end do

c---------------------------------------------------------------------
c next, set all diagonal values to 1. This is overkill, but convenient
c---------------------------------------------------------------------
          do   n = 1, 3
             do   k = 0, cell_size(3,c)-1
                do   j = 0, cell_size(2,c)-1
                   do   i = 0, cell_size(1,c)-1
                      lhs(i,j,k,5*n-2,c) = 1.0d0
                   end do
                end do
             end do
          end do

       end do

      return
      end


SUBROUTINE DiffZArbitrary(var,varZ,order,Nx,Ny,Nz,DiffStencils,gamma)
!
! Explicit order differentiation in Z-direction.
!
! Full rank stencils always applied.
!
! By Allan P. Engsig-Karup.
USE Precision
USE DataTypes
IMPLICIT NONE
TYPE (Diff_def) :: DiffStencils
INTEGER :: Nx, Ny, Nz, rank, order, gamma,i,j,k
REAL(KIND=long), DIMENSION(Nz,Nx,Ny) :: var, varZ
rank = 2*gamma+1
DO j = 1, Ny
	DO i = 1, Nx
		DO k = 1, gamma
			varZ(k,i,j) = DOT_PRODUCT(DiffStencils%StencilZ(k,1:rank,order),var(1:rank,i,j))
		END DO
	END DO
END DO
DO j = 1, Ny
	DO i = 1, Nx
		DO k = gamma+1, Nz-gamma
			varZ(k,i,j) = DOT_PRODUCT(DiffStencils%StencilZ(k,1:rank,order),var(k-gamma:k+gamma,i,j))
		END DO
	END DO
END DO
DO j = 1, Ny
	DO i = 1, Nx
		DO k = Nz-gamma+1, Nz
			varZ(k,i,j) = DOT_PRODUCT(DiffStencils%StencilZ(k,1:rank,order),var(Nz+1-rank:Nz,i,j))
		END DO
	END DO
END DO
END SUBROUTINE DiffZArbitrary


c -----------------------------------------------------------------------------
*dk midpt
      subroutine midpt(x,x1,x2,nn)

c...  This routine finds the midpoint x along the shorter great circle
c...  arc between points x1 and x2 on the unit sphere.

      integer, intent(in) :: nn
      real, intent(inout) :: x(nn,3)
      real, intent(in)    :: x1(nn,3), x2(nn,3)

      do j=1,3
         x(1,j) = x1(1,j) + x2(1,j)
      end do

      xnorm = 1./sqrt(x(1,1)**2 + x(1,2)**2 + x(1,3)**2)

      do j=1,3
         x(1,j) = xnorm*x(1,j)
      end do

      end

c -----------------------------------------------------------------------------
*dk grdgen
      subroutine grdgen(xn,nt)
      implicit none
c...  This routine generates the nodal coordinates xn for an
c...  icosahedral grid on the unit sphere.  The grid resolution
c...  corresponds to a subdivision of the edges of the original
c...  icosahedral triangles into nt equal parts.

c...  Note: nt is input as mt

      integer, intent(inout) :: nt
      real, intent(inout) :: xn((nt+1),(nt+1),10,3)

      real     :: fifthpi, w, cosw, sinw, lvt, nn, phi
      integer  :: id, k, i1, i2, j1, j2, l, l2, m, sgn

      fifthpi = 0.4*asin(1.)
      w       = 2.0*acos(1./(2.*sin(fifthpi)))
      cosw    = cos(w)
      sinw    = sin(w)
      lvt     = 1.45*log(real(nt))
      nn      = (nt+1)**2*10

 900  format (I4,I4,I4,I4,F12.8)

      do id=1,10

         sgn = 1.
         if(id .ge. 6) sgn = -1.
         phi = (2*mod(id, 5) - 3 + (id - 1)/5)*fifthpi

         xn(   1,   1,id,1) =  0.
         xn(   1,   1,id,2) =  0.
         xn(   1,   1,id,3) =  sgn
         xn(nt+1,   1,id,1) =  sinw*cos(phi)
         xn(nt+1,   1,id,2) =  sinw*sin(phi)
         xn(nt+1,   1,id,3) =  cosw*sgn
         xn(   1,nt+1,id,1) =  sinw*cos(phi + fifthpi + fifthpi)
         xn(   1,nt+1,id,2) =  sinw*sin(phi + fifthpi + fifthpi)
         xn(   1,nt+1,id,3) =  cosw*sgn
         xn(nt+1,nt+1,id,1) =  sinw*cos(phi + fifthpi)
         xn(nt+1,nt+1,id,2) =  sinw*sin(phi + fifthpi)
         xn(nt+1,nt+1,id,3) = -cosw*sgn

c         do k=0,nint(lvt-1)
c         do k=0,int(lvt-1)
         do k=0,lvt-1

            m  = 2**k
            l  = nt/m
            l2 = l/2

c...        rows of diamond--

            do j1=1,m+1
               do j2=1,m
                     i1 = (j1-1)*l + 1
                     i2 = (j2-1)*l + l2 + 1
                     call midpt(xn(i1,i2,id,1),xn(i1,i2-l2,id,1),
     &                          xn(i1,i2+l2,id,1),nn)
               end do
            end do

c...        columns of diamond--

            do j1=1,m+1
               do j2=1,m
                     i1 = (j2-1)*l + l2 + 1
                     i2 = (j1-1)*l + 1
                     call midpt(xn(i1,i2,id,1),xn(i1-l2,i2,id,1),
     &                          xn(i1+l2,i2,id,1),nn)
               end do
            end do

c...        diagonals of diamond--

            do j1=1,m
               do j2=1,m
                     i1 = (j1-1)*l + l2 + 1
                     i2 = (j2-1)*l + l2 + 1
                     call midpt(xn(i1,i2,id,1),xn(i1-l2,i2+l2,id,1),
     &                          xn(i1+l2,i2-l2,id,1),nn)
               end do
            end do

         end do

      end do

c...

      do k=1,3
         do id=1,10
            do j1=1,nt+1
               do i1=1,nt+1
                  write(6, 900) i1,j1,id,k,xn(i1,j1,id,k)
               enddo
            enddo
         enddo
      enddo

      end

c -----------------------------------------------------------------------------
*dk grdgen
      subroutine grdgentest(nt)
      implicit none
c...  This routine generates the nodal coordinates xn for an
c...  icosahedral grid on the unit sphere.  The grid resolution
c...  corresponds to a subdivision of the edges of the original
c...  icosahedral triangles into nt equal parts.

c...  Note: nt is input as mt

      integer, intent(inout) :: nt
      real                   :: xn((nt+1),(nt+1),10,3)

      real     :: fifthpi, w, cosw, sinw, lvt, nn, phi
      integer  :: id, k, i1, i2, j1, j2, l, l2, m, sgn

      fifthpi = 0.4*asin(1.)
      w       = 2.0*acos(1./(2.*sin(fifthpi)))
      cosw    = cos(w)
      sinw    = sin(w)
      lvt     = 1.45*log(real(nt))
      nn      = (nt+1)**2*10

 900  format (I4,I4,I4,I4,F12.8)
 901  format (F16.8,F16.8,F16.8)
 902  format (I4,I4,F16.8,F16.8,F16.8)

      do id=1,1

         sgn = 1.
         if(id .ge. 6) sgn = -1.
         phi = (2*mod(id, 5) - 3 + (id - 1)/5)*fifthpi

         xn(   1,   1,id,1) =  0.
         xn(   1,   1,id,2) =  0.
         xn(   1,   1,id,3) =  sgn
         write(6, 901) xn(1,1,id,1),xn(1,1,id,2),xn(1,1,id,3)
         xn(nt+1,   1,id,1) =  sinw*cos(phi)
         xn(nt+1,   1,id,2) =  sinw*sin(phi)
         xn(nt+1,   1,id,3) =  cosw*sgn
         write(6, 901) xn(nt+1,1,id,1),xn(nt+1,1,id,2),xn(nt+1,1,id,3)
         xn(   1,nt+1,id,1) =  sinw*cos(phi + fifthpi + fifthpi)
         xn(   1,nt+1,id,2) =  sinw*sin(phi + fifthpi + fifthpi)
         xn(   1,nt+1,id,3) =  cosw*sgn
         write(6, 901) xn(1,nt+1,id,1),xn(1,nt+1,id,2),xn(1,nt+1,id,3)
         xn(nt+1,nt+1,id,1) =  sinw*cos(phi + fifthpi)
         xn(nt+1,nt+1,id,2) =  sinw*sin(phi + fifthpi)
         xn(nt+1,nt+1,id,3) = -cosw*sgn
         write(6, 901) xn(nt+1,nt+1,id,1),xn(nt+1,nt+1,id,3),
     &        xn(nt+1,1,id,2)

c         do k=0,nint(lvt-1)
c         do k=0,int(lvt-1)
         do k=0,lvt-1

            m  = 2**k
            l  = nt/m
            l2 = l/2

c...        rows of diamond--

            do j1=1,m+1
               do j2=1,m
                     i1 = (j1-1)*l + 1
                     i2 = (j2-1)*l + l2 + 1
                     call midpt(xn(i1,i2,id,1),xn(i1,i2-l2,id,1),
     &                          xn(i1,i2+l2,id,1),nn)
                     write(6, 902) i1,i2,xn(i1,i2,id,1),xn(i1,i2,id,2),
     &                    xn(i1,i2,id,3)
               end do
            end do

c...        columns of diamond--

            do j1=1,m+1
               do j2=1,m
                     i1 = (j2-1)*l + l2 + 1
                     i2 = (j1-1)*l + 1
                     call midpt(xn(i1,i2,id,1),xn(i1-l2,i2,id,1),
     &                          xn(i1+l2,i2,id,1),nn)
                     write(6, 901) xn(i1,i2,id,1),xn(i1,i2,id,2),
     &                    xn(i1,i2,id,3)
               end do
            end do

c...        diagonals of diamond--

            do j1=1,m
               do j2=1,m
                     i1 = (j1-1)*l + l2 + 1
                     i2 = (j2-1)*l + l2 + 1
                     call midpt(xn(i1,i2,id,1),xn(i1-l2,i2+l2,id,1),
     &                          xn(i1+l2,i2-l2,id,1),nn)
                     write(6, 901) xn(i1,i2,id,1),xn(i1,i2,id,2),
     &                    xn(i1,i2,id,3)
               end do
            end do

         end do

      end do

      end