!----------------------------------------------------------------------
subroutine  DC3D0(ALPHA,X,Y,Z,DEPTH,DIP,POT1,POT2,POT3,POT4, &
                  UX,UY,UZ,UXX,UYX,UZX,UXY,UYY,UZY,UXZ,UYZ,UZZ,IRET)
!********************************************************************
!*****                                                          *****
!*****    DISPLACEMENT AND STRAIN AT DEPTH                      *****
!*****    DUE TO BURIED POINT SOURCE IN A SEMIINFINITE MEDIUM   *****
!*****                         CODED BY  Y.OKADA ... SEP.1991   *****
!*****                         REVISED     NOV.1991, MAY.2002   *****
!--------------------------------------------------------------------
!-----                     converted to Fortran90 (free form)   -----
!-----                                T. Miyashita, Jan. 2020   -----
!--------------------------------------------------------------------
!*****                                                          *****
!********************************************************************
!
!***** INPUT
!*****   ALPHA : MEDIUM CONSTANT  (LAMBDA+MYU)/(LAMBDA+2*MYU)
!*****   X,Y,Z : COORDINATE OF OBSERVING POINT
!*****   DEPTH : SOURCE DEPTH
!*****   DIP   : DIP-ANGLE (DEGREE)
!*****   POT1-POT4 : STRIKE-, DIP-, TENSILE- AND INFLATE-POTENCY
!*****       POTENCY=(  MOMENT OF DOUBLE-COUPLE  )/MYU     FOR POT1,2
!*****       POTENCY=(INTENSITY OF ISOTROPIC PART)/LAMBDA  FOR POT3
!*****       POTENCY=(INTENSITY OF LINEAR DIPOLE )/MYU     FOR POT4
!
!***** OUTPUT
!*****   UX, UY, UZ  : DISPLACEMENT ( UNIT=(UNIT OF POTENCY) /
!*****               :                     (UNIT OF X,Y,Z,DEPTH)**2  )
!*****   UXX,UYX,UZX : X-DERIVATIVE ( UNIT= UNIT OF POTENCY) /
!*****   UXY,UYY,UZY : Y-DERIVATIVE        (UNIT OF X,Y,Z,DEPTH)**3  )
!*****   UXZ,UYZ,UZZ : Z-DERIVATIVE
!*****   IRET        : return CODE
!*****               :   =0....NORMAL
!*****               :   =1....SINGULAR
!*****               :   =2....POSITIVE Z WAS GIVEN
    implicit none

    ! arguments
    real*8, intent(in) :: ALPHA,X,Y,Z,DEPTH,DIP,POT1,POT2,POT3,POT4
    real*8, intent(out) :: UX,UY,UZ,UXX,UYX,UZX,UXY,UYY,UZY,UXZ,UYZ,UZZ
    integer, intent(out) :: IRET

    ! local variables
    real*8 :: ALP(5)
    real*8 :: U(12),DUA(12),DUB(12),DUC(12)
    real*8 :: DU
    real*8 :: SD,CD,R
    real*8 :: XX,YY,ZZ,DD
    ! parameters
    real*8, parameter :: EPS=1.0d-6
    ! loop counter
    integer :: I

    ! initialization
    U(1:12) = 0.0d0
    DUA(1:12) = 0.0d0
    DUB(1:12) = 0.0d0
    DUC(1:12) = 0.0d0
    call varout(U,UX,UY,UZ,UXX,UYX,UZX,UXY,UYY,UZY,UXZ,UYZ,UZZ)

!### CAUTION ### if X,Y,D ARE SUFFICIENTLY SMALL, THEY ARE SET TO ZERO
    XX=X
    YY=Y
    ZZ=Z
    DD=DEPTH+Z
    if(dabs(XX)<EPS) XX=0.0d0
    if(dabs(YY)<EPS) YY=0.0d0
    if(dabs(DD)<EPS) DD=0.0d0
!-----
    IRET=0
    if(Z>0.0d0) then
      IRET=2
      return
    endif
!-----
    R=dsqrt(XX*XX+YY*YY+DD*DD)
    if (R==0.0d0) then !IN CASE OF SINGULAR (R=0)
      IRET=1
      return
    endif

!**********************************************************************
!*****   CALCULATE STATION GEOMETRY CONSTANTS FOR POINT SOURCE    *****
!**********************************************************************
    call assign_alpha(ALPHA,ALP)
    call DCCON0(DIP,SD,CD)
!======================================
!=====  REAL-SOURCE CONTRIBUTION  =====
!======================================
!-----
    call UA0(XX,YY,DD,POT1,POT2,POT3,POT4,SD,CD,ALP,DUA)
!-----
    do 222 I=1,12
      if(I<10) U(I)=U(I)-DUA(I)
      if(I>=10) U(I)=U(I)+DUA(I)
222 enddo
!=======================================
!=====  IMAGE-SOURCE CONTRIBUTION  =====
!=======================================
    DD=DEPTH-Z
    call UA0(XX,YY,DD,POT1,POT2,POT3,POT4,SD,CD,ALP,DUA)
    call UB0(XX,YY,DD,ZZ,POT1,POT2,POT3,POT4,SD,CD,ALP,DUB)
    call UC0(XX,YY,DD,ZZ,POT1,POT2,POT3,POT4,SD,CD,ALP,DUC)
!-----
    do 333 I=1,12
      DU=DUA(I)+DUB(I)+ZZ*DUC(I)
      if(I>=10) DU=DU+DUC(I-9)
      U(I)=U(I)+DU
333 enddo
!=====
    call varout(U,UX,UY,UZ,UXX,UYX,UZX,UXY,UYY,UZY,UXZ,UYZ,UZZ)
    return
end subroutine DC3D0
!----------------------------------------------------------------------

!----------------------------------------------------------------------
subroutine  UA0(X,Y,D,POT1,POT2,POT3,POT4,SD,CD,ALP,U)
!********************************************************************
!*****    DISPLACEMENT AND STRAIN AT DEPTH (PART-A)             *****
!*****    DUE TO BURIED POINT SOURCE IN A SEMIINFINITE MEDIUM   *****
!********************************************************************
!
!***** INPUT
!*****   X,Y,D : STATION COORDINATES IN FAULT SYSTEM
!*****   POT1-POT4 : STRIKE-, DIP-, TENSILE- AND INFLATE-POTENCY
!***** OUTPUT
!*****   U(12) : DISPLACEMENT AND THEIR DERIVATIVES
    implicit none

    ! arguments
    real*8, intent(in) :: X,Y,D
    real*8, intent(in) :: POT1,POT2,POT3,POT4
    real*8, intent(in) :: SD,CD
    real*8, intent(in) :: ALP(5)
    real*8, intent(out) :: U(12)

    ! local variables
    real*8 :: DU(12)
    real*8 :: P,Q,S,T
    real*8 :: R, R2, R3, R5
    real*8 :: S2D,C2D
    real*8 :: QR,QRX
    real*8 :: XY,X2,Y2,D2,A3,A5,B3,C3
    real*8 :: UY,VY,WY,UZ,VZ,WZ
    ! parameters
    real*8, parameter :: PI2=6.283185307179586D0
    real*8, parameter :: F0=0.0d0, F1=1.0d0, F3=3.0d0, F5=5.0d0
    ! loop counter
    integer :: I

    U(1:12)=0.0d0
    DU(1:12)=0.0d0

    call DCCON1(X,Y,D,SD,CD,R,P,Q,S,T)
    S2D=2.0d0*SD*CD
    C2D=CD*CD-SD*SD

    XY=X*Y
    X2=X*X
    Y2=Y*Y
    D2=D*D

    R2=R**2.0d0
    R3=R**3.0d0
    R5=R**5.0d0
    QR=F3*Q/R5      ! 3q/(R^5)
    QRX=F5*QR*X/R2  ! 15qx/(R^7)

! -- Eq.(8), p.1024 --
    A3=F1-F3*X2/R2
    A5=F1-F5*X2/R2
    B3=F1-F3*Y2/R2
    C3=F1-F3*D2/R2
!-----
    ! -- Tab.4 and 5, pp.1027-1028 --
    UY=SD-F5*Y*Q/R2   ! U  in Tab.4
    UZ=CD+F5*D*Q/R2   ! U' in Tab.5
    VY=S -F5*Y*P*Q/R2 ! V  in Tab.4
    VZ=T +F5*D*P*Q/R2 ! V' in Tab.5
    WY=UY+SD          ! W  in Tab. 4
    WZ=UZ+CD          ! W' in Tab.5
!-----
!======================================
!=====  STRIKE-SLIP CONTRIBUTION  =====
!======================================
    if(POT1/=F0) then
      DU( 1)= ALP(1)*Q/R3    +ALP(2)*X2*QR
      DU( 2)= ALP(1)*X/R3*SD +ALP(2)*XY*QR
      DU( 3)=-ALP(1)*X/R3*CD +ALP(2)*X*D*QR
      DU( 4)= X*QR*(-ALP(1) +ALP(2)*(F1+A5) )
      DU( 5)= ALP(1)*A3/R3*SD +ALP(2)*Y*QR*A5
      DU( 6)=-ALP(1)*A3/R3*CD +ALP(2)*D*QR*A5
      DU( 7)= ALP(1)*(SD/R3-Y*QR) +ALP(2)*F3*X2/R5*UY
      DU( 8)= F3*X/R5*(-ALP(1)*Y*SD +ALP(2)*(Y*UY+Q) )
      DU( 9)= F3*X/R5*( ALP(1)*Y*CD +ALP(2)*D*UY )
      DU(10)= ALP(1)*(CD/R3+D*QR) +ALP(2)*F3*X2/R5*UZ
      DU(11)= F3*X/R5*( ALP(1)*D*SD +ALP(2)*Y*UZ )
      DU(12)= F3*X/R5*(-ALP(1)*D*CD +ALP(2)*(D*UZ-Q) )
      do 222 I=1,12
        U(I)=U(I)+POT1/PI2*DU(I)
 222  enddo
    endif
!===================================
!=====  DIP-SLIP CONTRIBUTION  =====
!===================================
    if(POT2/=F0) then
      DU( 1)=              ALP(2)*X*P*QR
      DU( 2)= ALP(1)*S/R3 +ALP(2)*Y*P*QR
      DU( 3)=-ALP(1)*T/R3 +ALP(2)*D*P*QR
      DU( 4)=              ALP(2)*P*QR*A5
      DU( 5)=-ALP(1)*F3*X*S/R5 -ALP(2)*Y*P*QRX
      DU( 6)= ALP(1)*F3*X*T/R5 -ALP(2)*D*P*QRX
      DU( 7)=                            ALP(2)*F3*X/R5*VY
      DU( 8)= ALP(1)*(S2D/R3-F3*Y*S/R5) +ALP(2)*(F3*Y/R5*VY+P*QR)
      DU( 9)=-ALP(1)*(C2D/R3-F3*Y*T/R5) +ALP(2)*F3*D/R5*VY
      DU(10)=                            ALP(2)*F3*X/R5*VZ
      DU(11)= ALP(1)*(C2D/R3+F3*D*S/R5) +ALP(2)*F3*Y/R5*VZ
      DU(12)= ALP(1)*(S2D/R3-F3*D*T/R5) +ALP(2)*(F3*D/R5*VZ-P*QR)
      do 333 I=1,12
        U(I)=U(I)+POT2/PI2*DU(I)
 333  enddo
    endif
!========================================
!=====  TENSILE-FAULT CONTRIBUTION  =====
!========================================
    if(POT3/=F0) then
      DU( 1)= ALP(1)*X/R3      -ALP(2)*X*Q*QR
      DU( 2)= ALP(1)*T/R3      -ALP(2)*Y*Q*QR
      DU( 3)= ALP(1)*S/R3      -ALP(2)*D*Q*QR
      DU( 4)= ALP(1)*A3/R3     -ALP(2)*Q*QR*A5
      DU( 5)=-ALP(1)*F3*X*T/R5 +ALP(2)*Y*Q*QRX
      DU( 6)=-ALP(1)*F3*X*S/R5 +ALP(2)*D*Q*QRX
      DU( 7)=-ALP(1)*F3*XY/R5           -ALP(2)*X*QR*WY
      DU( 8)= ALP(1)*(C2D/R3-F3*Y*T/R5) -ALP(2)*(Y*WY+Q)*QR
      DU( 9)= ALP(1)*(S2D/R3-F3*Y*S/R5) -ALP(2)*D*QR*WY
      DU(10)= ALP(1)*F3*X*D/R5          -ALP(2)*X*QR*WZ
      DU(11)=-ALP(1)*(S2D/R3-F3*D*T/R5) -ALP(2)*Y*QR*WZ
      DU(12)= ALP(1)*(C2D/R3+F3*D*S/R5) -ALP(2)*(D*WZ-Q)*QR
      do 444 I=1,12
        U(I)=U(I)+POT3/PI2*DU(I)
 444  enddo
    endif
!=========================================
!=====  INFLATE SOURCE CONTRIBUTION  =====
!=========================================
    if(POT4/=F0) then
      DU( 1)=-ALP(1)*X/R3
      DU( 2)=-ALP(1)*Y/R3
      DU( 3)=-ALP(1)*D/R3
      DU( 4)=-ALP(1)*A3/R3
      DU( 5)= ALP(1)*F3*XY/R5
      DU( 6)= ALP(1)*F3*X*D/R5
      DU( 7)= DU(5)
      DU( 8)=-ALP(1)*B3/R3
      DU( 9)= ALP(1)*F3*Y*D/R5
      DU(10)=-DU(6)
      DU(11)=-DU(9)
      DU(12)= ALP(1)*C3/R3
      do 555 I=1,12
        U(I)=U(I)+POT4/PI2*DU(I)
 555  enddo
    endif
    return
end subroutine  UA0
!----------------------------------------------------------------------

!----------------------------------------------------------------------
subroutine  UB0(X,Y,D,Z,POT1,POT2,POT3,POT4,SD,CD,ALP,U)
!********************************************************************
!*****    DISPLACEMENT AND STRAIN AT DEPTH (PART-B)             *****
!*****    DUE TO BURIED POINT SOURCE IN A SEMIINFINITE MEDIUM   *****
!********************************************************************
!
!***** INPUT
!*****   X,Y,D,Z : STATION COORDINATES IN FAULT SYSTEM
!*****   POT1-POT4 : STRIKE-, DIP-, TENSILE- AND INFLATE-POTENCY
!***** OUTPUT
!*****   U(12) : DISPLACEMENT AND THEIR DERIVATIVES
    implicit none

    ! arguments
    real*8, intent(in) :: X,Y,D,Z
    real*8, intent(in) :: POT1,POT2,POT3,POT4
    real*8, intent(in) :: SD,CD
    real*8, intent(in) :: ALP(5)
    real*8, intent(out) :: U(12)

    ! local variables
    real*8 :: DU(12)
    real*8 :: P,Q,S,T
    real*8 :: R, R2, R3, R5
    real*8 :: QR,QRX
    real*8 :: XY,X2,Y2,D2,A3,A5,B3,C3
    real*8 :: UY,VY,WY,UZ,VZ,WZ
    real*8 :: C,RD
    real*8 :: D12,D32,D33,D53,D54
    real*8 :: FI1,FI2,FI3,FI4,FI5
    real*8 :: FJ1,FJ2,FJ3,FJ4
    real*8 :: FK1,FK2,FK3
    ! parameters
    real*8, parameter :: PI2=6.283185307179586D0
    real*8, parameter :: F0=0.0d0, F1=1.0d0, F2=2.0d0, F3=3.0d0, F4=4.0d0, F5=5.0d0, F8=8.0d0, F9=9.0d0
    ! loop counter
    integer :: I

    DU(1:12)=0.0d0
    U(1:12)=0.0d0

    call DCCON1(X,Y,D,SD,CD,R,P,Q,S,T)
    XY=X*Y
    X2=X*X
    Y2=Y*Y
    D2=D*D

    R2=R**2.0d0
    R3=R**3.0d0
    R5=R**5.0d0
    QR=F3*Q/R5      ! 3q/(R^5)
    QRX=F5*QR*X/R2  ! 15qx/(R^7)

! -- Eq.(8), p.1024 --
    A3=F1-F3*X2/R2
    A5=F1-F5*X2/R2
    B3=F1-F3*Y2/R2
    C3=F1-F3*D2/R2
!-----
    ! -- Tab.4 and 5, pp.1027-1028 --
    UY=SD-F5*Y*Q/R2   ! U  in Tab.4
    UZ=CD+F5*D*Q/R2   ! U' in Tab.5
    VY=S -F5*Y*P*Q/R2 ! V  in Tab.4
    VZ=T +F5*D*P*Q/R2 ! V' in Tab.5
    WY=UY+SD          ! W  in Tab. 4
    WZ=UZ+CD          ! W' in Tab.5
!-----
    C=D+Z
    RD=R+D
    D12=F1/(R*RD*RD)
    D32=D12*(F2*R+D)/R2
    D33=D12*(F3*R+D)/(R2*RD)
    D53=D12*(F8*R2+F9*R*D+F3*D2)/(R2*R2*RD)
    D54=D12*(F5*R2+F4*R*D+D2)/R3*D12
!-----
    FI1= Y*(D12-X2*D33)
    FI2= X*(D12-Y2*D33)
    FI3= X/R3-FI2
    FI4=-XY*D32
    FI5= F1/(R*RD)-X2*D32
    FJ1=-F3*XY*(D33-X2*D54)
    FJ2= F1/R3-F3*D12+F3*X2*Y2*D54
    FJ3= A3/R3-FJ2
    FJ4=-F3*XY/R5-FJ1
    FK1=-Y*(D32-X2*D53)
    FK2=-X*(D32-Y2*D53)
    FK3=-F3*X*D/R5-FK2
!-----
!======================================
!=====  STRIKE-SLIP CONTRIBUTION  =====
!======================================
    if(POT1/=F0) then
      DU( 1)=-X2*QR  -ALP(3)*FI1*SD
      DU( 2)=-XY*QR  -ALP(3)*FI2*SD
      DU( 3)=-C*X*QR -ALP(3)*FI4*SD
      DU( 4)=-X*QR*(F1+A5) -ALP(3)*FJ1*SD
      DU( 5)=-Y*QR*A5      -ALP(3)*FJ2*SD
      DU( 6)=-C*QR*A5      -ALP(3)*FK1*SD
      DU( 7)=-F3*X2/R5*UY      -ALP(3)*FJ2*SD
      DU( 8)=-F3*XY/R5*UY-X*QR -ALP(3)*FJ4*SD
      DU( 9)=-F3*C*X/R5*UY     -ALP(3)*FK2*SD
      DU(10)=-F3*X2/R5*UZ  +ALP(3)*FK1*SD
      DU(11)=-F3*XY/R5*UZ  +ALP(3)*FK2*SD
      DU(12)= F3*X/R5*(-C*UZ +ALP(3)*Y*SD)
      do 222 I=1,12
        U(I)=U(I)+POT1/PI2*DU(I)
 222  enddo
    endif
!===================================
!=====  DIP-SLIP CONTRIBUTION  =====
!===================================
    if(POT2/=F0) then
      DU( 1)=-X*P*QR          +ALP(3)*FI3*SD*CD
      DU( 2)=-Y*P*QR          +ALP(3)*FI1*SD*CD
      DU( 3)=-C*P*QR          +ALP(3)*FI5*SD*CD
      DU( 4)=-P*QR*A5         +ALP(3)*FJ3*SD*CD
      DU( 5)= Y*P*QRX         +ALP(3)*FJ1*SD*CD
      DU( 6)= C*P*QRX         +ALP(3)*FK3*SD*CD
      DU( 7)=-F3*X/R5*VY      +ALP(3)*FJ1*SD*CD
      DU( 8)=-F3*Y/R5*VY-P*QR +ALP(3)*FJ2*SD*CD
      DU( 9)=-F3*C/R5*VY      +ALP(3)*FK1*SD*CD
      DU(10)=-F3*X/R5*VZ      -ALP(3)*FK3*SD*CD
      DU(11)=-F3*Y/R5*VZ      -ALP(3)*FK1*SD*CD
      DU(12)=-F3*C/R5*VZ      +ALP(3)*A3/R3*SD*CD
      do 333 I=1,12
        U(I)=U(I)+POT2/PI2*DU(I)
 333  enddo
    endif
!========================================
!=====  TENSILE-FAULT CONTRIBUTION  =====
!========================================
    if(POT3/=F0) then
      DU( 1)= X*Q*QR      -ALP(3)*FI3*SD*SD
      DU( 2)= Y*Q*QR      -ALP(3)*FI1*SD*SD
      DU( 3)= C*Q*QR      -ALP(3)*FI5*SD*SD
      DU( 4)= Q*QR*A5     -ALP(3)*FJ3*SD*SD
      DU( 5)=-Y*Q*QRX     -ALP(3)*FJ1*SD*SD
      DU( 6)=-C*Q*QRX     -ALP(3)*FK3*SD*SD
      DU( 7)= X*QR*WY     -ALP(3)*FJ1*SD*SD
      DU( 8)= QR*(Y*WY+Q) -ALP(3)*FJ2*SD*SD
      DU( 9)= C*QR*WY     -ALP(3)*FK1*SD*SD
      DU(10)= X*QR*WZ     +ALP(3)*FK3*SD*SD
      DU(11)= Y*QR*WZ     +ALP(3)*FK1*SD*SD
      DU(12)= C*QR*WZ     -ALP(3)*A3/R3*SD*SD
      do 444 I=1,12
        U(I)=U(I)+POT3/PI2*DU(I)
 444  enddo
    endif
!=========================================
!=====  INFLATE SOURCE CONTRIBUTION  =====
!=========================================
    if(POT4/=F0) then
      DU( 1)= ALP(3)*X/R3
      DU( 2)= ALP(3)*Y/R3
      DU( 3)= ALP(3)*D/R3
      DU( 4)= ALP(3)*A3/R3
      DU( 5)=-ALP(3)*F3*XY/R5
      DU( 6)=-ALP(3)*F3*X*D/R5
      DU( 7)= DU(5)
      DU( 8)= ALP(3)*B3/R3
      DU( 9)=-ALP(3)*F3*Y*D/R5
      DU(10)=-DU(6)
      DU(11)=-DU(9)
      DU(12)=-ALP(3)*C3/R3
      do 555 I=1,12
        U(I)=U(I)+POT4/PI2*DU(I)
 555  enddo
    endif
    return
end subroutine UB0
!----------------------------------------------------------------------

!----------------------------------------------------------------------
subroutine  UC0(X,Y,D,Z,POT1,POT2,POT3,POT4,SD,CD,ALP,U)
!********************************************************************
!*****    DISPLACEMENT AND STRAIN AT DEPTH (PART-B)             *****
!*****    DUE TO BURIED POINT SOURCE IN A SEMIINFINITE MEDIUM   *****
!********************************************************************
!
!***** INPUT
!*****   X,Y,D,Z : STATION COORDINATES IN FAULT SYSTEM
!*****   POT1-POT4 : STRIKE-, DIP-, TENSILE- AND INFLATE-POTENCY
!***** OUTPUT
!*****   U(12) : DISPLACEMENT AND THEIR DERIVATIVES
    implicit none

    ! arguments
    real*8, intent(in) :: X,Y,D,Z
    real*8, intent(in) :: POT1,POT2,POT3,POT4
    real*8, intent(in) :: SD,CD
    real*8, intent(in) :: ALP(5)
    real*8, intent(out) :: U(12)

    ! local variables
    real*8 :: DU(12)
    real*8 :: P,Q,S,T
    real*8 :: R, R2, R3, R5, R7
    real*8 :: S2D,C2D
    real*8 :: Q2,QR,QRX,QR5,QR7,DR5
    real*8 :: XY,X2,Y2,D2,C
    real*8 :: A3,A5,A7,B3,B5,B7,C3,C5,C7,D7
    ! parameters
    real*8, parameter :: PI2=6.283185307179586D0
    real*8, parameter :: F0=0.0d0, F1=1.0d0, F2=2.0d0, F3=3.0d0, F5=5.0d0, F7=7.0d0, F10=1.0d1, F15=1.5d1
    ! loop counter
    integer :: I

    U(1:12)=0.0d0
    DU(1:12)=0.0d0

    call DCCON1(X,Y,D,SD,CD,R,P,Q,S,T)
    XY=X*Y
    X2=X*X
    Y2=Y*Y
    D2=D*D

    R2=R**2.0d0
    R3=R**3.0d0
    R5=R**5.0d0
    QR=F3*Q/R5      ! 3q/(R^5)
    QRX=F5*QR*X/R2  ! 15qx/(R^7)

! -- Eq.(8), p.1024 --
    A3=F1-F3*X2/R2
    A5=F1-F5*X2/R2
    B3=F1-F3*Y2/R2
    C3=F1-F3*D2/R2
!-----
    S2D=2.0d0*SD*CD
    C2D=CD*CD-SD*SD
!-----
    C=D+Z
    Q2=Q*Q
    R7=R5*R2
    A7=F1-F7*X2/R2
    B5=F1-F5*Y2/R2
    B7=F1-F7*Y2/R2
    C5=F1-F5*D2/R2
    C7=F1-F7*D2/R2
    D7=F2-F7*Q2/R2
    QR5=F5*Q/R2
    QR7=F7*Q/R2
    DR5=F5*D/R2
!-----
!======================================
!=====  STRIKE-SLIP CONTRIBUTION  =====
!======================================
    if(POT1/=F0) then
      DU( 1)=-ALP(4)*A3/R3*CD  +ALP(5)*C*QR*A5
      DU( 2)= F3*X/R5*( ALP(4)*Y*CD +ALP(5)*C*(SD-Y*QR5) )
      DU( 3)= F3*X/R5*(-ALP(4)*Y*SD +ALP(5)*C*(CD+D*QR5) )
      DU( 4)= ALP(4)*F3*X/R5*(F2+A5)*CD   -ALP(5)*C*QRX*(F2+A7)
      DU( 5)= F3/R5*( ALP(4)*Y*A5*CD +ALP(5)*C*(A5*SD-Y*QR5*A7) )
      DU( 6)= F3/R5*(-ALP(4)*Y*A5*SD +ALP(5)*C*(A5*CD+D*QR5*A7) )
      DU( 7)= DU(5)
      DU( 8)= F3*X/R5*( ALP(4)*B5*CD -ALP(5)*F5*C/R2*(F2*Y*SD+Q*B7) )
      DU( 9)= F3*X/R5*(-ALP(4)*B5*SD +ALP(5)*F5*C/R2*(D*B7*SD-Y*C7*CD) )
      DU(10)= F3/R5*   (-ALP(4)*D*A5*CD +ALP(5)*C*(A5*CD+D*QR5*A7) )
      DU(11)= F15*X/R7*( ALP(4)*Y*D*CD  +ALP(5)*C*(D*B7*SD-Y*C7*CD) )
      DU(12)= F15*X/R7*(-ALP(4)*Y*D*SD  +ALP(5)*C*(F2*D*CD-Q*C7) )
      do 222 I=1,12
        U(I)=U(I)+POT1/PI2*DU(I)
 222  enddo
    endif
!===================================
!=====  DIP-SLIP CONTRIBUTION  =====
!===================================
    if(POT2/=F0) then
      DU( 1)= ALP(4)*F3*X*T/R5          -ALP(5)*C*P*QRX
      DU( 2)=-ALP(4)/R3*(C2D-F3*Y*T/R2) +ALP(5)*F3*C/R5*(S-Y*P*QR5)
      DU( 3)=-ALP(4)*A3/R3*SD*CD        +ALP(5)*F3*C/R5*(T+D*P*QR5)
      DU( 4)= ALP(4)*F3*T/R5*A5              -ALP(5)*F5*C*P*QR/R2*A7
      DU( 5)= F3*X/R5*(ALP(4)*(C2D-F5*Y*T/R2)-ALP(5)*F5*C/R2*(S-Y*P*QR7))
      DU( 6)= F3*X/R5*(ALP(4)*(F2+A5)*SD*CD  -ALP(5)*F5*C/R2*(T+D*P*QR7))
      DU( 7)= DU(5)
      DU( 8)= F3/R5*( ALP(4)*(F2*Y*C2D+T*B5) &
                     +ALP(5)*C*(S2D-F10*Y*S/R2-P*QR5*B7))
      DU( 9)= F3/R5*(ALP(4)*Y*A5*SD*CD-ALP(5)*C*((F3+A5)*C2D+Y*P*DR5*QR7))
      DU(10)= F3*X/R5*(-ALP(4)*(S2D-T*DR5) -ALP(5)*F5*C/R2*(T+D*P*QR7))
      DU(11)= F3/R5*(-ALP(4)*(D*B5*C2D+Y*C5*S2D) &
                     -ALP(5)*C*((F3+A5)*C2D+Y*P*DR5*QR7))
      DU(12)= F3/R5*(-ALP(4)*D*A5*SD*CD-ALP(5)*C*(S2D-F10*D*T/R2+P*QR5*C7))
      do 333 I=1,12
        U(I)=U(I)+POT2/PI2*DU(I)
 333  enddo
    endif
!========================================
!=====  TENSILE-FAULT CONTRIBUTION  =====
!========================================
    if(POT3/=F0) then
      DU( 1)= F3*X/R5*(-ALP(4)*S +ALP(5)*(C*Q*QR5-Z))
      DU( 2)= ALP(4)/R3*(S2D-F3*Y*S/R2)+ALP(5)*F3/R5*(C*(T-Y+Y*Q*QR5)-Y*Z)
      DU( 3)=-ALP(4)/R3*(F1-A3*SD*SD)  -ALP(5)*F3/R5*(C*(S-D+D*Q*QR5)-D*Z)
      DU( 4)=-ALP(4)*F3*S/R5*A5 +ALP(5)*(C*QR*QR5*A7-F3*Z/R5*A5)
      DU( 5)= F3*X/R5*(-ALP(4)*(S2D-F5*Y*S/R2) &
                       -ALP(5)*F5/R2*(C*(T-Y+Y*Q*QR7)-Y*Z))
      DU( 6)= F3*X/R5*( ALP(4)*(F1-(F2+A5)*SD*SD) &
                       +ALP(5)*F5/R2*(C*(S-D+D*Q*QR7)-D*Z))
      DU( 7)= DU(5)
      DU( 8)= F3/R5*(-ALP(4)*(F2*Y*S2D+S*B5) &
                     -ALP(5)*(C*(F2*SD*SD+F10*Y*(T-Y)/R2-Q*QR5*B7)+Z*B5))
      DU( 9)= F3/R5*( ALP(4)*Y*(F1-A5*SD*SD) &
                     +ALP(5)*(C*(F3+A5)*S2D-Y*DR5*(C*D7+Z)))
      DU(10)= F3*X/R5*(-ALP(4)*(C2D+S*DR5) &
                       +ALP(5)*(F5*C/R2*(S-D+D*Q*QR7)-F1-Z*DR5))
      DU(11)= F3/R5*( ALP(4)*(D*B5*S2D-Y*C5*C2D) &
                     +ALP(5)*(C*((F3+A5)*S2D-Y*DR5*D7)-Y*(F1+Z*DR5)))
      DU(12)= F3/R5*(-ALP(4)*D*(F1-A5*SD*SD) &
                     -ALP(5)*(C*(C2D+F10*D*(S-D)/R2-Q*QR5*C7)+Z*(F1+C5)))
      do 444 I=1,12
        U(I)=U(I)+POT3/PI2*DU(I)
 444  enddo
    endif
!=========================================
!=====  INFLATE SOURCE CONTRIBUTION  =====
!=========================================
    if(POT4/=F0) then
      DU( 1)= ALP(4)*F3*X*D/R5
      DU( 2)= ALP(4)*F3*Y*D/R5
      DU( 3)= ALP(4)*C3/R3
      DU( 4)= ALP(4)*F3*D/R5*A5
      DU( 5)=-ALP(4)*F15*XY*D/R7
      DU( 6)=-ALP(4)*F3*X/R5*C5
      DU( 7)= DU(5)
      DU( 8)= ALP(4)*F3*D/R5*B5
      DU( 9)=-ALP(4)*F3*Y/R5*C5
      DU(10)= DU(6)
      DU(11)= DU(9)
      DU(12)= ALP(4)*F3*D/R5*(F2+C5)
      do 555 I=1,12
        U(I)=U(I)+POT4/PI2*DU(I)
 555  enddo
    endif
    return
end subroutine UC0
!----------------------------------------------------------------------

!----------------------------------------------------------------------
subroutine DC3D(ALPHA,X,Y,Z,DEPTH,DIP, &
                AL1,AL2,AW1,AW2,DISL1,DISL2,DISL3, &
                UX,UY,UZ,UXX,UYX,UZX,UXY,UYY,UZY,UXZ,UYZ,UZZ,IRET)
!********************************************************************
!*****                                                          *****
!*****    DISPLACEMENT AND STRAIN AT DEPTH                      *****
!*****    DUE TO BURIED FINITE FAULT IN A SEMIINFINITE MEDIUM   *****
!*****              CODED BY  Y.OKADA ... SEP.1991              *****
!*****              REVISED ... NOV.1991, APR.1992, MAY.1993,   *****
!*****                          JUL.1993, MAY.2002              *****
!--------------------------------------------------------------------
!-----                     converted to Fortran90 (free form)   -----
!-----                                T. Miyashita, Jan. 2020   -----
!--------------------------------------------------------------------
!********************************************************************
!
!***** INPUT
!*****   ALPHA : MEDIUM CONSTANT  (LAMBDA+MYU)/(LAMBDA+2*MYU)
!*****   X,Y,Z : COORDINATE OF OBSERVING POINT
!*****   DEPTH : DEPTH OF REFERENCE POINT
!*****   DIP   : DIP-ANGLE (DEGREE)
!*****   AL1,AL2   : FAULT LENGTH RANGE
!*****   AW1,AW2   : FAULT WIDTH RANGE
!*****   DISL1-DISL3 : STRIKE-, DIP-, TENSILE-DISLOCATIONS
!
!***** OUTPUT
!*****   UX, UY, UZ  : DISPLACEMENT ( UNIT=(UNIT OF DISL)
!*****   UXX,UYX,UZX : X-DERIVATIVE ( UNIT=(UNIT OF DISL) /
!*****   UXY,UYY,UZY : Y-DERIVATIVE        (UNIT OF X,Y,Z,DEPTH,AL,AW) )
!*****   UXZ,UYZ,UZZ : Z-DERIVATIVE
!*****   IRET        : return CODE
!*****               :   =0....NORMAL
!*****               :   =1....SINGULAR
!*****               :   =2....POSITIVE Z WAS GIVEN
    implicit none

    ! arguments
    real*8, intent(in) :: ALPHA,X,Y,Z,DEPTH,DIP,AL1,AL2,AW1,AW2,DISL1,DISL2,DISL3
    real*8, intent(out) :: UX,UY,UZ,UXX,UYX,UZX,UXY,UYY,UZY,UXZ,UYZ,UZZ
    integer, intent(out) :: IRET

    ! local variables
    real*8 :: SD,CD
    real*8 :: XI(2),ET(2)
    integer :: KXI(2),KET(2)
    real*8 :: U(12),DU(12),DUA(12),DUB(12),DUC(12)
    real*8 :: DD1, DD2, DD3
    real*8 :: ZZ, D, P, Q, R12, R21, R22
    real*8 :: ALP(5)
    ! parameters
    real*8, parameter :: F0 = 0.0d0
    real*8, parameter :: EPS = 1.0d-6
    ! loop counters
    integer :: I,J,K

    ! initialization
    U(1:12) = 0.0d0
    DU(1:12) = 0.0d0
    DUA(1:12) = 0.0d0
    DUB(1:12) = 0.0d0
    DUC(1:12) = 0.0d0
    call varout(U,UX,UY,UZ,UXX,UYX,UZX,UXY,UYY,UZY,UXZ,UYZ,UZZ)

!-----
      IRET=0
    if(Z>0.0d0) then
      IRET=2
      return
    endif
!-----
    ZZ=Z
    DD1=DISL1
    DD2=DISL2
    DD3=DISL3
!### CAUTION ### if XI,ET,Q ARE SUFFICIENTLY SMALL, THEY ARE SET TO ZER0
    XI(1)=X-AL1
    XI(2)=X-AL2
    if(dabs(XI(1))<EPS) XI(1)=F0
    if(dabs(XI(2))<EPS) XI(2)=F0
!======================================
!=====  REAL-SOURCE CONTRIBUTION  =====
!======================================
    call assign_alpha(ALPHA,ALP)
    call DCCON0(DIP,SD,CD)
!-----
    D=DEPTH+Z
    P=Y*CD+D*SD
    Q=Y*SD-D*CD
    ET(1)=P-AW1
    ET(2)=P-AW2
    if(dabs(Q)<EPS)  Q=F0
    if(dabs(ET(1))<EPS) ET(1)=F0
    if(dabs(ET(2))<EPS) ET(2)=F0
!--------------------------------
!----- REJECT SINGULAR CASE -----
!--------------------------------
!----- ON FAULT EDGE
    if(Q==F0 .and. &
      (    (XI(1)*XI(2)<=F0 .and. ET(1)*ET(2)==F0) &
       .or.(ET(1)*ET(2)<=F0 .and. XI(1)*XI(2)==F0) )) then
      IRET=1
      return
    endif
!----- ON NEGATIVE EXTENSION OF FAULT EDGE
    KXI(1)=0
    KXI(2)=0
    KET(1)=0
    KET(2)=0
    R12=dsqrt(XI(1)*XI(1)+ET(2)*ET(2)+Q*Q)
    R21=dsqrt(XI(2)*XI(2)+ET(1)*ET(1)+Q*Q)
    R22=dsqrt(XI(2)*XI(2)+ET(2)*ET(2)+Q*Q)
    if(XI(1)<F0 .and. R21+XI(2)<EPS) KXI(1)=1
    if(XI(1)<F0 .and. R22+XI(2)<EPS) KXI(2)=1
    if(ET(1)<F0 .and. R12+ET(2)<EPS) KET(1)=1
    if(ET(1)<F0 .and. R22+ET(2)<EPS) KET(2)=1
!=====
    do 223 K=1,2
    do 222 J=1,2
      call UA(XI(J),ET(K),Q,DD1,DD2,DD3,KXI(K),KET(J),SD,CD,ALP,DUA)
!-----
      do 220 I=1,10,3
        DU(I)  =-DUA(I)
        DU(I+1)=-DUA(I+1)*CD+DUA(I+2)*SD
        DU(I+2)=-DUA(I+1)*SD-DUA(I+2)*CD
        if(I<10) cycle
        DU(I)  =-DU(I)
        DU(I+1)=-DU(I+1)
        DU(I+2)=-DU(I+2)
220   enddo
      do 221 I=1,12
        if(J+K/=3) U(I)=U(I)+DU(I)
        if(J+K==3) U(I)=U(I)-DU(I)
221   enddo
!-----
222 enddo
223 enddo
!=======================================
!=====  IMAGE-SOURCE CONTRIBUTION  =====
!=======================================
    D=DEPTH-Z
    P=Y*CD+D*SD
    Q=Y*SD-D*CD
    ET(1)=P-AW1
    ET(2)=P-AW2
    if(dabs(Q)<EPS)  Q=F0
    if(dabs(ET(1))<EPS) ET(1)=F0
    if(dabs(ET(2))<EPS) ET(2)=F0
!--------------------------------
!----- REJECT SINGULAR CASE -----
!--------------------------------
!----- ON FAULT EDGE
    if(Q==F0 .and. &
      (    (XI(1)*XI(2)<=F0 .and. ET(1)*ET(2)==F0) &
       .or.(ET(1)*ET(2)<=F0 .and. XI(1)*XI(2)==F0) )) then
      IRET=1
      call varout(U,UX,UY,UZ,UXX,UYX,UZX,UXY,UYY,UZY,UXZ,UYZ,UZZ)
      return
    endif
!----- ON NEGATIVE EXTENSION OF FAULT EDGE
    KXI(1)=0
    KXI(2)=0
    KET(1)=0
    KET(2)=0
    R12=dsqrt(XI(1)*XI(1)+ET(2)*ET(2)+Q*Q)
    R21=dsqrt(XI(2)*XI(2)+ET(1)*ET(1)+Q*Q)
    R22=dsqrt(XI(2)*XI(2)+ET(2)*ET(2)+Q*Q)
    if(XI(1)<F0 .and. R21+XI(2)<EPS) KXI(1)=1
    if(XI(1)<F0 .and. R22+XI(2)<EPS) KXI(2)=1
    if(ET(1)<F0 .and. R12+ET(2)<EPS) KET(1)=1
    if(ET(1)<F0 .and. R22+ET(2)<EPS) KET(2)=1
!=====
    do 334 K=1,2
    do 333 J=1,2
      call UA(XI(J),ET(K),Q   ,DD1,DD2,DD3,KXI(K),KET(J),SD,CD,ALP,DUA)
      call UB(XI(J),ET(K),Q   ,DD1,DD2,DD3,KXI(K),KET(J),SD,CD,ALP,DUB)
      call UC(XI(J),ET(K),Q,ZZ,DD1,DD2,DD3,KXI(K),KET(J),SD,CD,ALP,DUC)
!-----
      do 330 I=1,10,3
        DU(I)=DUA(I)+DUB(I)+Z*DUC(I)
        DU(I+1)=(DUA(I+1)+DUB(I+1)+Z*DUC(I+1))*CD &
               -(DUA(I+2)+DUB(I+2)+Z*DUC(I+2))*SD
        DU(I+2)=(DUA(I+1)+DUB(I+1)-Z*DUC(I+1))*SD &
               +(DUA(I+2)+DUB(I+2)-Z*DUC(I+2))*CD
        if(I<10) cycle
        DU(10)=DU(10)+DUC(1)
        DU(11)=DU(11)+DUC(2)*CD-DUC(3)*SD
        DU(12)=DU(12)-DUC(2)*SD-DUC(3)*CD
330   enddo
      do 331 I=1,12
        if(J+K/=3) U(I)=U(I)+DU(I)
        if(J+K==3) U(I)=U(I)-DU(I)
331   enddo
!-----
333 enddo
334 enddo
!=====
    call varout(U,UX,UY,UZ,UXX,UYX,UZX,UXY,UYY,UZY,UXZ,UYZ,UZZ)
    return
end subroutine DC3D
!----------------------------------------------------------------------

!----------------------------------------------------------------------
subroutine  UA(XI,ET,Q,DISL1,DISL2,DISL3,KXI,KET,SD,CD,ALP,U)
!
!********************************************************************
!*****    DISPLACEMENT AND STRAIN AT DEPTH (PART-A)             *****
!*****    DUE TO BURIED FINITE FAULT IN A SEMIINFINITE MEDIUM   *****
!********************************************************************
!
!***** INPUT
!*****   XI,ET,Q : STATION COORDINATES IN FAULT SYSTEM
!*****   DISL1-DISL3 : STRIKE-, DIP-, TENSILE-DISLOCATIONS
!*****   KXI,KET     : KXI=1, KET=1 MEANS R+XI<EPS, R+ET<EPS, RESPECTIVELY
!*****   SD,CD       : SIN, COS OF DIP-ANGLE
!*****   ALP         : COEFFICIENTS RELATED TO ALPHA VALUE
!***** OUTPUT
!*****   U(12) : DISPLACEMENT AND THEIR DERIVATIVES
!-----
    implicit none
    ! arguments
    real*8, intent(in) :: XI,ET,Q,DISL1,DISL2,DISL3
    integer, intent(in) :: KXI,KET
    real*8, intent(in) :: SD,CD
    real*8, intent(in) :: ALP(5)
    real*8, intent(out) :: U(12)
    ! local variables
    real*8 :: DU(12)
    real*8 :: R,Ytilde,Dtilde
    real*8 :: THETA,ALX,ALE
    real*8 :: X11,X32,Y11,Y32
    real*8 :: EY,EZ,FY,FZ,GY,GZ,HY,HZ
    real*8 :: XY,QX,QY
    real*8 :: XI2,Q2
    real*8 :: R3
    ! parameters
    real*8, parameter :: F0=0.0d0, F2=2.0d0
    real*8, parameter :: PI2=6.283185307179586d0
    ! loop counter
    integer :: I

    U(1:12) = 0.0d0
    DU(1:12) = 0.0d0

    call DCCON2(XI,ET,Q,SD,CD,R,Ytilde,Dtilde)
    call math_singularity(XI,ET,Q,R,KXI,KET,THETA,ALX,ALE)
    call eq14_xy(XI,ET,KXI,KET,R,X11,X32,Y11,Y32)
    call auxvar_derivative_yz(XI,Q,SD,CD,R,Ytilde,Dtilde,X11,X32,Y32, &
                              EY,EZ,FY,FZ,GY,GZ,HY,HZ)

    R3=R**3.0d0
    XI2=XI*XI
    Q2=Q*Q

    XY=XI*Y11
    QX=Q *X11
    QY=Q *Y11
!======================================
!=====  STRIKE-SLIP CONTRIBUTION  =====
!======================================
    if(DISL1/=F0) then
      DU( 1)= THETA/F2     +ALP(2)*XI*QY
      DU( 2)=               ALP(2)*Q/R
      DU( 3)= ALP(1)*ALE   -ALP(2)*Q*QY
      DU( 4)=-ALP(1)*QY    -ALP(2)*XI2*Q*Y32
      DU( 5)=              -ALP(2)*XI*Q/R3
      DU( 6)= ALP(1)*XY    +ALP(2)*XI*Q2*Y32
      DU( 7)= ALP(1)*XY*SD +ALP(2)*XI*FY+Dtilde/F2*X11
      DU( 8)=               ALP(2)*EY
      DU( 9)= ALP(1)*(CD/R+QY*SD) -ALP(2)*Q*FY
      DU(10)= ALP(1)*XY*CD        +ALP(2)*XI*FZ+Ytilde/F2*X11
      DU(11)=               ALP(2)*EZ
      DU(12)=-ALP(1)*(SD/R-QY*CD) -ALP(2)*Q*FZ
      do 222 I=1,12
        U(I)=U(I)+DISL1/PI2*DU(I)
 222  enddo
    endif
!======================================
!=====    DIP-SLIP CONTRIBUTION   =====
!======================================
    if(DISL2/=F0) then
      DU( 1)=             ALP(2)*Q/R
      DU( 2)= THETA/F2   +ALP(2)*ET*QX
      DU( 3)= ALP(1)*ALX -ALP(2)*Q*QX
      DU( 4)=            -ALP(2)*XI*Q/R3
      DU( 5)= -QY/F2     -ALP(2)*ET*Q/R3
      DU( 6)= ALP(1)/R   +ALP(2)*Q2/R3
      DU( 7)=             ALP(2)*EY
      DU( 8)= ALP(1)*Dtilde*X11+XY/F2*SD +ALP(2)*ET*GY
      DU( 9)= ALP(1)*Ytilde*X11          -ALP(2)*Q*GY
      DU(10)=             ALP(2)*EZ
      DU(11)= ALP(1)*Ytilde*X11+XY/F2*CD +ALP(2)*ET*GZ
      DU(12)=-ALP(1)*Dtilde*X11          -ALP(2)*Q*GZ
      do 333 I=1,12
        U(I)=U(I)+DISL2/PI2*DU(I)
 333  enddo
    endif
!========================================
!=====  TENSILE-FAULT CONTRIBUTION  =====
!========================================
    if(DISL3/=F0) then
      DU( 1)=-ALP(1)*ALE -ALP(2)*Q*QY
      DU( 2)=-ALP(1)*ALX -ALP(2)*Q*QX
      DU( 3)= THETA/F2   -ALP(2)*(ET*QX+XI*QY)
      DU( 4)=-ALP(1)*XY  +ALP(2)*XI*Q2*Y32
      DU( 5)=-ALP(1)/R   +ALP(2)*Q2/R3
      DU( 6)=-ALP(1)*QY  -ALP(2)*Q*Q2*Y32
      DU( 7)=-ALP(1)*(CD/R+QY*SD)  -ALP(2)*Q*FY
      DU( 8)=-ALP(1)*Ytilde*X11         -ALP(2)*Q*GY
      DU( 9)= ALP(1)*(Dtilde*X11+XY*SD) +ALP(2)*Q*HY
      DU(10)= ALP(1)*(SD/R-QY*CD)  -ALP(2)*Q*FZ
      DU(11)= ALP(1)*Dtilde*X11         -ALP(2)*Q*GZ
      DU(12)= ALP(1)*(Ytilde*X11+XY*CD) +ALP(2)*Q*HZ
      do 444 I=1,12
        U(I)=U(I)+DISL3/PI2*DU(I)
 444  enddo
    endif
    return
end subroutine UA
!----------------------------------------------------------------------

!----------------------------------------------------------------------
subroutine  UB(XI,ET,Q,DISL1,DISL2,DISL3,KXI,KET,SD,CD,ALP,U)
!********************************************************************
!*****    DISPLACEMENT AND STRAIN AT DEPTH (PART-B)             *****
!*****    DUE TO BURIED FINITE FAULT IN A SEMIINFINITE MEDIUM   *****
!********************************************************************
!
!***** INPUT
!*****   XI,ET,Q : STATION COORDINATES IN FAULT SYSTEM
!*****   DISL1-DISL3 : STRIKE-, DIP-, TENSILE-DISLOCATIONS
!*****   KXI,KET     : KXI=1, KET=1 MEANS R+XI<EPS, R+ET<EPS, RESPECTIVELY
!*****   SD,CD       : SIN, COS OF DIP-ANGLE
!*****   ALP         : COEFFICIENTS RELATED TO ALPHA VALUE
!***** OUTPUT
!*****   U(12) : DISPLACEMENT AND THEIR DERIVATIVES
!-----
    implicit none
    ! arguments
    real*8, intent(in) :: XI,ET,Q,DISL1,DISL2,DISL3
    integer, intent(in) :: KXI,KET
    real*8, intent(in) :: SD,CD
    real*8, intent(in) :: ALP(5)
    real*8, intent(out) :: U(12)
    ! local variables
    real*8 :: DU(12)
    real*8 :: R,Ytilde,Dtilde
    real*8 :: THETA,ALE
    real*8 :: X11,X32,Y11,Y32
    real*8 :: EY,EZ,FY,FZ,GY,GZ,HY,HZ
    real*8 :: X
    real*8 :: XY,QX,QY
    real*8 :: XI2,Q2
    real*8 :: R3
    real*8 :: RD,RD2
    real*8 :: D11
    real*8 :: AI1,AI2,AI3,AI4
    real*8 :: AJ1,AJ2,AJ3,AJ4,AJ5,AJ6
    real*8 :: AK1,AK2,AK3,AK4
    ! parameters
    real*8, parameter :: F0=0.0d0, F1=1.0d0, F2=2.0d0
    real*8, parameter :: PI2=6.283185307179586d0
    ! loop counter
    integer :: I
    ! unused (dummy) vars
    real*8 :: dum ! ALX

    U(1:12)=0.0d0
    DU(1:12)=0.0d0

    call DCCON2(XI,ET,Q,SD,CD,R,Ytilde,Dtilde)
    call math_singularity(XI,ET,Q,R,KXI,KET,THETA,dum,ALE)
    call eq14_xy(XI,ET,KXI,KET,R,X11,X32,Y11,Y32)
    call auxvar_derivative_yz(XI,Q,SD,CD,R,Ytilde,Dtilde,X11,X32,Y32, &
                              EY,EZ,FY,FZ,GY,GZ,HY,HZ)

    R3=R**3.0d0
    XI2=XI*XI
    Q2=Q*Q

    RD=R+Dtilde
    D11=F1/(R*RD)
    AJ2=XI*Ytilde/RD*D11
    AJ5=-(Dtilde+Ytilde*Ytilde/RD)*D11
    if(CD/=F0) then
      ! p.1034 (ii)
      if(XI==F0) then
        AI4=F0
      else
        X=dsqrt(XI2+Q2)
        AI4=F1/(CD*CD)*( XI/RD*SD*CD &
           +F2*datan((ET*(X+Q*CD)+X*(R+X)*SD)/(XI*(R+X)*CD)) )
      endif
      AI3=(Ytilde*CD/RD-ALE+SD*dlog(RD))/(CD*CD)
      AK1=XI*(D11-Y11*SD)/CD
      AK3=(Q*Y11-Ytilde*D11)/CD
      AJ3=(AK1-AJ2*SD)/CD
      AJ6=(AK3-AJ5*SD)/CD
    else
      RD2=RD*RD
      AI3=(ET/RD+Ytilde*Q/RD2-ALE)/F2
      AI4=XI*Ytilde/RD2/F2
      AK1=XI*Q/RD*D11
      AK3=SD/RD*(XI2*D11-F1)
      AJ3=-XI/RD2*(Q2*D11-F1/F2)
      AJ6=-Ytilde/RD2*(XI2*D11-F1/F2)
    endif
!-----
    XY=XI*Y11
    AI1=-XI/RD*CD-AI4*SD
    AI2= dlog(RD)+AI3*SD
    AK2= F1/R+AK3*SD
    AK4= XY*CD-AK1*SD
    AJ1= AJ5*CD-AJ6*SD
    AJ4=-XY-AJ2*CD+AJ3*SD
!=====
    QX=Q*X11
    QY=Q*Y11
!======================================
!=====  STRIKE-SLIP CONTRIBUTION  =====
!======================================
    if(DISL1/=F0) then
      DU( 1)=-XI*QY-THETA -ALP(3)*AI1*SD
      DU( 2)=-Q/R         +ALP(3)*Ytilde/RD*SD
      DU( 3)= Q*QY        -ALP(3)*AI2*SD
      DU( 4)= XI2*Q*Y32   -ALP(3)*AJ1*SD
      DU( 5)= XI*Q/R3     -ALP(3)*AJ2*SD
      DU( 6)=-XI*Q2*Y32   -ALP(3)*AJ3*SD
      DU( 7)=-XI*FY-Dtilde*X11 +ALP(3)*(XY+AJ4)*SD
      DU( 8)=-EY          +ALP(3)*(F1/R+AJ5)*SD
      DU( 9)= Q*FY        -ALP(3)*(QY-AJ6)*SD
      DU(10)=-XI*FZ-Ytilde*X11 +ALP(3)*AK1*SD
      DU(11)=-EZ          +ALP(3)*Ytilde*D11*SD
      DU(12)= Q*FZ        +ALP(3)*AK2*SD
      do 222 I=1,12
        U(I)=U(I)+DISL1/PI2*DU(I)
 222  enddo
    endif
!======================================
!=====    DIP-SLIP CONTRIBUTION   =====
!======================================
    if(DISL2/=F0) then
      DU( 1)=-Q/R         +ALP(3)*AI3*SD*CD
      DU( 2)=-ET*QX-THETA -ALP(3)*XI/RD*SD*CD
      DU( 3)= Q*QX        +ALP(3)*AI4*SD*CD
      DU( 4)= XI*Q/R3     +ALP(3)*AJ4*SD*CD
      DU( 5)= ET*Q/R3+QY  +ALP(3)*AJ5*SD*CD
      DU( 6)=-Q2/R3       +ALP(3)*AJ6*SD*CD
      DU( 7)=-EY          +ALP(3)*AJ1*SD*CD
      DU( 8)=-ET*GY-XY*SD +ALP(3)*AJ2*SD*CD
      DU( 9)= Q*GY        +ALP(3)*AJ3*SD*CD
      DU(10)=-EZ          -ALP(3)*AK3*SD*CD
      DU(11)=-ET*GZ-XY*CD -ALP(3)*XI*D11*SD*CD
      DU(12)= Q*GZ        -ALP(3)*AK4*SD*CD
      do 333 I=1,12
        U(I)=U(I)+DISL2/PI2*DU(I)
 333  enddo
    endif
!========================================
!=====  TENSILE-FAULT CONTRIBUTION  =====
!========================================
    if(DISL3/=F0) then
      DU( 1)= Q*QY              -ALP(3)*AI3*SD*SD
      DU( 2)= Q*QX              +ALP(3)*XI/RD*SD*SD
      DU( 3)= ET*QX+XI*QY-THETA -ALP(3)*AI4*SD*SD
      DU( 4)=-XI*Q2*Y32 -ALP(3)*AJ4*SD*SD
      DU( 5)=-Q2/R3     -ALP(3)*AJ5*SD*SD
      DU( 6)= Q*Q2*Y32  -ALP(3)*AJ6*SD*SD
      DU( 7)= Q*FY -ALP(3)*AJ1*SD*SD
      DU( 8)= Q*GY -ALP(3)*AJ2*SD*SD
      DU( 9)=-Q*HY -ALP(3)*AJ3*SD*SD
      DU(10)= Q*FZ +ALP(3)*AK3*SD*SD
      DU(11)= Q*GZ +ALP(3)*XI*D11*SD*SD
      DU(12)=-Q*HZ +ALP(3)*AK4*SD*SD
      do 444 I=1,12
        U(I)=U(I)+DISL3/PI2*DU(I)
 444  enddo
    endif
    return
end subroutine UB
!----------------------------------------------------------------------

!----------------------------------------------------------------------
subroutine  UC(XI,ET,Q,Z,DISL1,DISL2,DISL3,KXI,KET,SD,CD,ALP,U)
!********************************************************************
!*****    DISPLACEMENT AND STRAIN AT DEPTH (PART-C)             *****
!*****    DUE TO BURIED FINITE FAULT IN A SEMIINFINITE MEDIUM   *****
!********************************************************************
!
!***** INPUT
!*****   XI,ET,Q,Z   : STATION COORDINATES IN FAULT SYSTEM
!*****   DISL1-DISL3 : STRIKE-, DIP-, TENSILE-DISLOCATIONS
!*****   KXI,KET     : KXI=1, KET=1 MEANS R+XI<EPS, R+ET<EPS, RESPECTIVELY
!*****   SD,CD       : SIN, COS OF DIP-ANGLE
!*****   ALP         : COEFFICIENTS RELATED TO ALPHA VALUE
!***** OUTPUT
!*****   U(12) : DISPLACEMENT AND THEIR DERIVATIVES
    implicit none
    ! arguments
    real*8, intent(in) :: XI,ET,Z,Q,DISL1,DISL2,DISL3
    integer, intent(in) :: KXI,KET
    real*8, intent(in) :: SD,CD
    real*8, intent(in) :: ALP(5)
    real*8, intent(out) :: U(12)
    ! local variables
    real*8 :: DU(12)
    real*8 :: R,Ytilde,Dtilde
    real*8 :: X11,Y11,X32,Y32
    real*8 :: XY,QX,QY
    real*8 :: XI2,ET2,Q2
    real*8 :: R2,R3,R5
    real*8 :: C
    real*8 :: X53,Y53,Z32,Z53,H
    real*8 :: Y0,Z0
    real*8 :: PPY,PPZ
    real*8 :: QQ,QQY,QQZ,QR,CQX,CDR,YY0
    ! parameters
    real*8, parameter :: F0=0.0d0, F1=1.0d0, F2=2.0d0, F3=3.0d0
    real*8, parameter :: PI2=6.283185307179586d0
    ! loop counter
    integer :: I

    U(1:12) = 0.0d0
    DU(1:12) = 0.0d0

    call DCCON2(XI,ET,Q,SD,CD,R,Ytilde,Dtilde)
    call eq14_xy(XI,ET,KXI,KET,R,X11,X32,Y11,Y32)

    R2=R**2.0d0
    R3=R**3.0d0
    R5=R**5.0d0
    XI2=XI*XI
    ET2=ET*ET
    Q2=Q*Q
!-----
    C=Dtilde+Z
    X53=(8.D0*R2+9.D0*R*XI+F3*XI2)*X11*X11*X11/R2
    Y53=(8.D0*R2+9.D0*R*ET+F3*ET2)*Y11*Y11*Y11/R2
    H=Q*CD-Z
    Z32=SD/R3-H*Y32
    Z53=F3*SD/R5-H*Y53
    Y0=Y11-XI2*Y32
    Z0=Z32-XI2*Z53
    PPY=CD/R3+Q*Y32*SD
    PPZ=SD/R3-Q*Y32*CD
    QQ=Z*Y32+Z32+Z0
    QQY=F3*C*Dtilde/R5-QQ*SD
    QQZ=F3*C*Ytilde/R5-QQ*CD+Q*Y32
    XY=XI*Y11
    QX=Q*X11
    QY=Q*Y11
    QR=F3*Q/R5
    CQX=C*Q*X53
    CDR=(C+Dtilde)/R3
    YY0=Ytilde/R3-Y0*CD
!=====
!======================================
!=====  STRIKE-SLIP CONTRIBUTION  =====
!======================================
    if(DISL1/=F0) then
      DU( 1)= ALP(4)*XY*CD           -ALP(5)*XI*Q*Z32
      DU( 2)= ALP(4)*(CD/R+F2*QY*SD) -ALP(5)*C*Q/R3
      DU( 3)= ALP(4)*QY*CD           -ALP(5)*(C*ET/R3-Z*Y11+XI2*Z32)
      DU( 4)= ALP(4)*Y0*CD                  -ALP(5)*Q*Z0
      DU( 5)=-ALP(4)*XI*(CD/R3+F2*Q*Y32*SD) +ALP(5)*C*XI*QR
      DU( 6)=-ALP(4)*XI*Q*Y32*CD  +ALP(5)*XI*(F3*C*ET/R5-QQ)
      DU( 7)=-ALP(4)*XI*PPY*CD    -ALP(5)*XI*QQY
      DU( 8)= ALP(4)*F2*(Dtilde/R3-Y0*SD)*SD-Ytilde/R3*CD &
             -ALP(5)*(CDR*SD-ET/R3-C*Ytilde*QR)
      DU( 9)=-ALP(4)*Q/R3+YY0*SD  +ALP(5)*(CDR*CD+C*Dtilde*QR-(Y0*CD+Q*Z0)*SD)
      DU(10)= ALP(4)*XI*PPZ*CD    -ALP(5)*XI*QQZ
      DU(11)= ALP(4)*F2*(Ytilde/R3-Y0*CD)*SD+Dtilde/R3*CD -ALP(5)*(CDR*CD+C*Dtilde*QR)
      DU(12)=        YY0*CD    -ALP(5)*(CDR*SD-C*Ytilde*QR-Y0*SD*SD+Q*Z0*CD)
      do 222 I=1,12
        U(I)=U(I)+DISL1/PI2*DU(I)
 222  enddo
    endif
!======================================
!=====    DIP-SLIP CONTRIBUTION   =====
!======================================
    if(DISL2/=F0) then
      DU( 1)= ALP(4)*CD/R -QY*SD      -ALP(5)*C*Q/R3
      DU( 2)= ALP(4)*Ytilde*X11       -ALP(5)*C*ET*Q*X32
      DU( 3)=       -Dtilde*X11-XY*SD -ALP(5)*C*(X11-Q2*X32)
      DU( 4)=-ALP(4)*XI/R3*CD         +ALP(5)*C*XI*QR +XI*Q*Y32*SD
      DU( 5)=-ALP(4)*Ytilde/R3        +ALP(5)*C*ET*QR
      DU( 6)=        Dtilde/R3-Y0*SD  +ALP(5)*C/R3*(F1-F3*Q2/R2)
      DU( 7)=-ALP(4)*ET/R3+Y0*SD*SD   -ALP(5)*(CDR*SD-C*Ytilde*QR)
      DU( 8)= ALP(4)*(X11-Ytilde*Ytilde*X32) -ALP(5)*C*((Dtilde+F2*Q*CD)*X32-Ytilde*ET*Q*X53)
      DU( 9)=   XI*PPY*SD+Ytilde*Dtilde*X32  +ALP(5)*C*((Ytilde+F2*Q*SD)*X32-Ytilde*Q2*X53)
      DU(10)=   -Q/R3+Y0*SD*CD               -ALP(5)*(CDR*CD+C*Dtilde*QR)
      DU(11)= ALP(4)*Ytilde*Dtilde*X32       -ALP(5)*C*((Ytilde-F2*Q*SD)*X32+Dtilde*ET*Q*X53)
      DU(12)=-XI*PPZ*SD+X11-Dtilde*Dtilde*X32-ALP(5)*C*((Dtilde-F2*Q*CD)*X32-Dtilde*Q2*X53)
      do 333 I=1,12
        U(I)=U(I)+DISL2/PI2*DU(I)
 333  enddo
    endif
!========================================
!=====  TENSILE-FAULT CONTRIBUTION  =====
!========================================
    if(DISL3/=F0) then
      DU( 1)=-ALP(4)*(SD/R+QY*CD)        -ALP(5)*(Z*Y11-Q2*Z32)
      DU( 2)= ALP(4)*F2*XY*SD+Dtilde*X11 -ALP(5)*C*(X11-Q2*X32)
      DU( 3)= ALP(4)*(Ytilde*X11+XY*CD)  +ALP(5)*Q*(C*ET*X32+XI*Z32)
      DU( 4)= ALP(4)*XI/R3*SD+XI*Q*Y32*CD+ALP(5)*XI*(F3*C*ET/R5-F2*Z32-Z0)
      DU( 5)= ALP(4)*F2*Y0*SD-Dtilde/R3  +ALP(5)*C/R3*(F1-F3*Q2/R2)
      DU( 6)=-ALP(4)*YY0                 -ALP(5)*(C*ET*QR-Q*Z0)
      DU( 7)= ALP(4)*(Q/R3+Y0*SD*CD)     +ALP(5)*(Z/R3*CD+C*Dtilde*QR-Q*Z0*SD)
      DU( 8)=-ALP(4)*F2*XI*PPY*SD-Ytilde*Dtilde*X32 &
             +ALP(5)*C*((Ytilde+F2*Q*SD)*X32-Ytilde*Q2*X53)
      DU( 9)=-ALP(4)*(XI*PPY*CD-X11+Ytilde*Ytilde*X32) &
             +ALP(5)*(C*((Dtilde+F2*Q*CD)*X32-Ytilde*ET*Q*X53)+XI*QQY)
      DU(10)=  -ET/R3+Y0*CD*CD           -ALP(5)*(Z/R3*SD-C*Ytilde*QR-Y0*SD*SD+Q*Z0*CD)
      DU(11)= ALP(4)*F2*XI*PPZ*SD-X11+Dtilde*Dtilde*X32 &
             -ALP(5)*C*((Dtilde-F2*Q*CD)*X32-Dtilde*Q2*X53)
      DU(12)= ALP(4)*(XI*PPZ*CD+Ytilde*Dtilde*X32) &
             +ALP(5)*(C*((Ytilde-F2*Q*SD)*X32+Dtilde*ET*Q*X53)+XI*QQZ)
      do 444 I=1,12
        U(I)=U(I)+DISL3/PI2*DU(I)
 444  enddo
    endif
    return
end subroutine UC
!----------------------------------------------------------------------

!----------------------------------------------------------------------
subroutine  DCCON0(DIP,SD,CD)
!*******************************************************************
!*****   CALCULATE MEDIUM CONSTANTS AND FAULT-DIP CONSTANTS    *****
!*******************************************************************
!
!***** INPUT
!*****   DIP   : DIP-ANGLE (DEGREE)
!***** OUTPUT
!*****   SD,CD : SIN, COS OF DIP-ANGLE
    implicit none
    real*8, intent(in) :: DIP
    real*8, intent(out) :: SD,CD

    real*8, parameter :: F0=0.0d0, F1=1.0d0
    real*8, parameter :: PI2=6.283185307179586d0
    real*8, parameter :: EPS=1.0d-6
    real*8, parameter :: P18=PI2/360.D0
!-----
    SD=DSIN(DIP*P18)
    CD=DCOS(DIP*P18)
!### CAUTION ### if COS(DIP) IS SUFFICIENTLY SMALL, IT IS SET TO ZERO
    if(dabs(CD)<EPS) then
      CD=F0
      if(SD>F0) SD= F1
      if(SD<F0) SD=-F1
    endif
    return
end subroutine DCCON0
!----------------------------------------------------------------------

!----------------------------------------------------------------------
subroutine  DCCON1(X,Y,D,SD,CD,R,P,Q,S,T)
!**********************************************************************
!*****   CALCULATE STATION GEOMETRY CONSTANTS FOR POINT SOURCE    *****
!**********************************************************************
!***** INPUT
!*****   X,Y,D : STATION COORDINATES IN FAULT SYSTEM
!*****   SD,CD : SIN, COS OF DIP-ANGLE
    implicit none
    real*8, intent(in) :: X,Y,D
    real*8, intent(in) :: SD,CD
    real*8, intent(out) :: R
    real*8, intent(out) :: P,Q,S,T
!-----
    P=Y*CD+D*SD
    Q=Y*SD-D*CD
    S=P*SD+Q*CD
    T=P*CD-Q*SD
    R=dsqrt(X*X+Y*Y+D*D)
    return
end subroutine DCCON1
!----------------------------------------------------------------------

!----------------------------------------------------------------------
subroutine  DCCON2(XI,ET,Q,SD,CD,R,Ytilde,Dtilde)
!**********************************************************************
!*****   CALCULATE STATION GEOMETRY CONSTANTS FOR FINITE SOURCE   *****
!**********************************************************************
!***** INPUT
!*****   XI,ET,Q : STATION COORDINATES IN FAULT SYSTEM
!*****   SD,CD   : SIN, COS OF DIP-ANGLE
    implicit none
    real*8, intent(in) :: XI,ET,Q
    real*8, intent(in) :: SD,CD
    real*8, intent(out) :: R,Ytilde,Dtilde
!-----
    R = dsqrt(XI*XI+ET*ET+Q*Q)
    Ytilde = ET*CD+Q*SD
    Dtilde = ET*SD-Q*CD
    return
end subroutine DCCON2
!----------------------------------------------------------------------

!----------------------------------------------------------------------
subroutine math_singularity(XI,ET,Q,R,KXI,KET,THETA,ALX,ALE)
!***** INPUT
!*****   XI,ET,Q : STATION COORDINATES IN FAULT SYSTEM
!*****   KXI,KET : KXI=1, KET=1 MEANS R+XI<EPS, R+ET<EPS, RESPECTIVELY
    implicit none
    real*8, intent(in) :: XI,ET,Q,R
    integer, intent(in) :: KXI,KET
    real*8, intent(out) :: THETA,ALX,ALE

    ! p.1034 (i)
    if(Q==0.0d0) then
      THETA=0.0d0
    else
      THETA=datan(XI*ET/(Q*R))
    endif
    ! p.1034 (iii)
    if(KXI==1) then
      ALX=-dlog(R-XI)
    else
      ALX=dlog(R+XI)
    endif
    ! p.1034 (iv)
    if(KET==1) then
      ALE=-dlog(R-ET)
    else
      ALE=dlog(R+ET)
    endif

    return
end subroutine math_singularity
!----------------------------------------------------------------------

!----------------------------------------------------------------------
subroutine eq14_xy(XI,ET,KXI,KET,R,X11,X32,Y11,Y32)
!***** INPUT
!*****   XI,ET   : STATION COORDINATES IN FAULT SYSTEM
!*****   KXI,KET : KXI=1, KET=1 MEANS R+XI<EPS, R+ET<EPS, RESPECTIVELY
    implicit none
    real*8, intent(in) :: XI,ET
    integer, intent(in) :: KXI,KET
    real*8, intent(in) :: R
    real*8, intent(out) :: X11,X32,Y11,Y32

    X11 = 0.0d0
    X32 = 0.0d0
    Y11 = 0.0d0
    Y32 = 0.0d0
!-----
    if(KXI/=1) then
      X11=1.0d0/(R*(R+XI))        ! Eq.(14), p.1026
      X32=(2.0d0*R+XI)*X11*X11/R  ! Eq.(14), p.1026
    endif
!-----
    if(KET/=1) then
      Y11=1.0d0/(R*(R+ET))        ! Eq.(14), p.1026
      Y32=(2.0d0*R+ET)*Y11*Y11/R  ! Eq.(14), p.1026
    endif
!-----
    return
end subroutine eq14_xy
!----------------------------------------------------------------------

!----------------------------------------------------------------------
subroutine auxvar_derivative_yz(XI,Q,SD,CD,R,Ytilde,Dtilde,X11,X32,Y32, &
                                EY,EZ,FY,FZ,GY,GZ,HY,HZ)
!***** INPUT
!*****   XI,Q  : STATION COORDINATES IN FAULT SYSTEM
!*****   SD,CD : SIN, COS OF DIP-ANGLE
    implicit none
    ! arguments
    real*8, intent(in) :: XI,Q,SD,CD,R,Ytilde,Dtilde
    real*8, intent(in) :: X11,X32,Y32
    real*8, intent(out) :: EY,EZ,FY,FZ,GY,GZ,HY,HZ
    ! local variables
    real*8 :: R3
    R3 = R**3.0d0

    EY=SD/R-Ytilde*Q/R3           ! E  in Tab.8, p.1032
    EZ=CD/R+Dtilde*Q/R3           ! E' in Tab.9, p.1033
    FY=Dtilde/R3+XI*XI*Y32*SD     ! F  in Tab.8, p.1032
    FZ=Ytilde/R3+XI*XI*Y32*CD     ! F' in Tab.9, p.1033
    GY=2.0d0*X11*SD-Ytilde*Q*X32  ! G  in Tab.8, p.1032
    GZ=2.0d0*X11*CD+Dtilde*Q*X32  ! G' in Tab.9, p.1033
    HY=Dtilde*Q*X32+XI*Q*Y32*SD   ! H  in Tab.8, p.1032
    HZ=Ytilde*Q*X32+XI*Q*Y32*CD   ! H' in Tab.9, p.1033
    return
end subroutine auxvar_derivative_yz
!----------------------------------------------------------------------

!----------------------------------------------------------------------
subroutine assign_alpha(ALPHA,ALP)
!***** INPUT
!*****   ALPHA : MEDIUM CONSTANT  (LAMBDA+MYU)/(LAMBDA+2*MYU)
!***** OUTPUT
!*****   ALP   : COEFFICIENTS RELATED TO ALPHA VALUE
    implicit none
    real*8, intent(in) :: ALPHA
    real*8, intent(out) :: ALP(5)
    ALP(1)=(1.0d0-ALPHA)/2.0d0
    ALP(2)= ALPHA/2.0d0
    ALP(3)=(1.0d0-ALPHA)/ALPHA
    ALP(4)=1.0d0-ALPHA
    ALP(5)=ALPHA
    return
end subroutine assign_alpha
!----------------------------------------------------------------------

!----------------------------------------------------------------------
subroutine varout(U,UX,UY,UZ,UXX,UYX,UZX,UXY,UYY,UZY,UXZ,UYZ,UZZ)
    implicit none
    real*8, intent(in) :: U(12)
    real*8, intent(out) :: UX,UY,UZ,UXX,UYX,UZX,UXY,UYY,UZY,UXZ,UYZ,UZZ
    UX=U(1)
    UY=U(2)
    UZ=U(3)
    UXX=U(4)
    UYX=U(5)
    UZX=U(6)
    UXY=U(7)
    UYY=U(8)
    UZY=U(9)
    UXZ=U(10)
    UYZ=U(11)
    UZZ=U(12)
    return
end subroutine varout
!----------------------------------------------------------------------


SUBROUTINE pwindup (r_sat, eBodyX, r_rec, dphi)

! ----------------------------------------------------------------------
! SUBROUTINE: pwindup.f90
! ----------------------------------------------------------------------
! Purpose:
!  Phase wind-up effect
! ----------------------------------------------------------------------
! Input arguments:
! - r_sat: 			Satellite geocentric position vector (m)
! - eBF:			Satellite position unit vector in Body-Fixed frame
! - r_rec: 			Station (receiver) geocentric position vector (m)
!
! Output arguments:
! - dphi:			Phase wind-up correction (degrees)
! ----------------------------------------------------------------------
! Dr. Thomas D. Papanikolaou, Geoscience Australia        10 August 2016
! ----------------------------------------------------------------------

      USE mdl_precision
      USE mdl_num
      IMPLICIT NONE

! ----------------------------------------------------------------------
! Dummy arguments declaration
! ----------------------------------------------------------------------
! IN
      REAL (KIND = prec_d), INTENT(IN) :: r_sat(3), eBodyX(3), r_rec(3)
! OUT
      REAL (KIND = prec_d), INTENT(OUT) :: dphi
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Local variables declaration
! ----------------------------------------------------------------------
	  REAL (KIND = prec_d) :: Rrec_ENU(3), e_ENU(3)
	  REAL (KIND = prec_d) :: r_satrec(3), e_satrec(3)
	  REAL (KIND = prec_d) :: e_rSat(3)
	  REAL (KIND = prec_d) :: eBx(3), eBy(3), eBz(3)
	  REAL (KIND = prec_d), Dimension(3) :: eE, eN, eU
	  REAL (KIND = prec_d), Dimension(3) :: Dsat, Drec
	  REAL (KIND = prec_d) :: pdot, pcross(3)
	  REAL (KIND = prec_d) :: zeta, Dsat_norm, Drec_norm, cos_dphi, dphi_rad
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Satellite position unit vector
      e_rSat = (1.D0 / sqrt(r_sat(1)**2 + r_sat(2)**2 + r_sat(3)**2) ) * r_sat
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Satellite Body axes unit vectors ()
	  !Body-X unit vector : input argument (computed by yaw_attitude.f90)
	  eBx = eBodyX

	  ! Body-Z unit vector
	  eBz = - e_rSat

	  ! Body-Y unit vector
      CALL productcross(eBz,eBx , eBy)
	  !eBy = cp
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Station (receiver) position vector and unit vectors in local ENU system (East, North, Up)
CALL  ENU(r_rec, Rrec_ENU, eE, eN, eU)
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Satellite to station (receiver) unit vector
	  r_satrec = - r_sat + r_rec
! Unit vector (k)
      e_satrec = (1.D0 / sqrt(r_satrec(1)**2 + r_satrec(2)**2 + r_satrec(3)**2) ) * r_satrec
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Satellite dipole unit vector
! Dsat = eBF_x - e_satrec * ( dot_k_eXsat ) - cross_k_eYsat
      CALL productdot  (e_satrec, eBx, pdot)
	  CALL productcross(e_satrec, eBy, pcross)
      Dsat = eBx - e_satrec * pdot - pcross

! Receiver dipole unit vector
! Drec = eN - e_satrec * ( dot_k_eN ) - cross_k_eE
      CALL productdot  (e_satrec, eN, pdot)
	  CALL productcross(e_satrec, eE, pcross)
      Drec = eN - e_satrec * pdot + pcross
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Zeta
	  CALL productcross(Dsat, Drec, pcross)
      CALL productdot  (e_satrec, pcross, pdot)
      zeta = pdot
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Phase wind-up correction (dphi)
      CALL productdot  (Dsat, Drec, pdot)
	  Dsat_norm = sqrt( Dsat(1)**2 + Dsat(2)**2 + Dsat(3)**2 )
	  Drec_norm = sqrt( Drec(1)**2 + Drec(2)**2 + Drec(3)**2 )

      cos_dphi = pdot / ( Dsat_norm * Drec_norm )

      If (zeta > 0) then
	     dphi_rad = acos(cos_dphi)
	  else if (zeta < 0) then
	     dphi_rad = -1.0D0 * acos(cos_dphi)
      End If

! Output in radians
!dphi = dphi_rad

! convert in degrees
      dphi = dphi_rad * (180.D0 / PI_global )
! ----------------------------------------------------------------------

End subroutine


      SUBROUTINE CSQRTX(XX,Y)
C*******
C     ROUTINE TO FIND THE COMPLEX SQUARE ROOT OF X AND STORE IT IN Y
C*******
      DOUBLE PRECISION XX(2),X(2),Y(2),R
      X(1) = XX(1)
      X(2) = XX(2)
      R = DSQRT(X(1)**2+X(2)**2)
      Y(1) = DSQRT(DABS(X(1)+R)/2.)
      Y(2) = DSQRT(DABS(-X(1)+R)/2.)
      IF(X(2) .EQ. 0.0D0) RETURN
      Y(2) = DSIGN(Y(2),X(2))
      RETURN
      END


*       The integral of function using T.R

        Write(*,*)'Enter N even'
30      Read(*,*)N
        if(N.LT.2) stop
        H=1.0/N
        sum =exp(0.0)
        Do 10 I=1,N-1
        X=I*H
10      sum=sum+2*exp(x)
        Xint=(exp(1.0)+sum)*H/2.0
        exactI=exp(1.0)-1
        Error=exact-Xint
        write(*,*)N,Xint,exactI,error
        go to 30
*        stop
        end


	SUBROUTINE PONE(P0,PSI,R,P1,IMPOSS)
	IMPLICIT NONE
C
C    PONE calculates P1 given P0, PSI, and R using equation (13) of Dupont
C    (Biometrics, 1988; 44:1157-1168)
C
C  Arguments:
C	P0 is the probability that a control patient is exposed.
C	PSI is the odd ratio.
C	R is the correlation coefficient.
C	P1 is the probability that a case patient is exposed.
C	IMPOSS = 0 if a valid matched table exists for P0, PSI, and R
C		     1 otherwise
C
C  Locals:
C
	DOUBLE PRECISION Q0,TEMP1,TEMP2,TEMP3
	DOUBLE PRECISION P0,PSI,R,P1
	DOUBLE PRECISION P00,P01,P10,P11,TEMP4,Q1,PL,PU
	INTEGER IMPOSS
C
C-Code------------------------------------------------------------------
C
	Q0=1.-P0
	TEMP1=2.*PSI**2 * P0**2 + 2.*PSI*P0*Q0 + (PSI-1.)**2 *P0*Q0 * R**2
	TEMP2=(PSI-1.)*P0*Q0*R*SQRT(R**2 * (PSI-1.)**2 + 4.*PSI)
	TEMP3=2.*((PSI*P0+Q0)**2 + R**2*(PSI-1.)**2 *P0*Q0)
	P1=(TEMP1-TEMP2)/TEMP3
	Q1=1.-P1
	Q0=1.-P0
	TEMP4=R*SQRT(P1*P0*Q0*Q1)
C
C    The 4 possible outcomes for a matched pair have the following
C    probabilities.  P11,...,P00 are equations (2) through (5) of
C    Dupont (Biometrics, 1988; 44:1157-1168)
C
	P00=Q1*Q0+TEMP4
	P11=P1*P0+TEMP4
	P10=P1*Q0-TEMP4
	P01=P0*Q1-TEMP4
	PL=MIN(P00,P11,P10,P01)
	PU=MAX(P00,P11,P10,P01)
	IF (PL.LT.0. .OR. PU.GT.1.) THEN
	    IMPOSS=1
	ELSE
	    IMPOSS=0
	END IF
C
C    Done.
C
	RETURN
	END


C NCLFORTSTART
      SUBROUTINE DDEWTEMP(TK,RH,TDK)
C     NCL: tdk = dewtemp_trh (tk:numeric, rh:numeric)

c calculate the dew pt temperature [k]:
c input:
c     rh - relative humidty [%]
c     tk - temperature [k]
c output:
c     tdk- dew point temperature
c          equation used is Dutton p274 (6) [k]

      IMPLICIT NONE
      DOUBLE PRECISION RH,TK
      DOUBLE PRECISION TDK
c NCLEND

c local:
c     gc  - gas constant for water vapor [j/{kg-k}]
c           gcx [cal/{g-k}]
c     lhv - latent heat vap (Dutton top p273)

      DOUBLE PRECISION GC,GCX,LHV
      PARAMETER (GC=461.5D0)
      PARAMETER (GCX=GC/ (1000.D0*4.186D0))

      LHV = (597.3D0-0.57D0* (TK-273.D0))/GCX
      TDK = TK*LHV/ (LHV-TK*DLOG(RH*0.01D0))

      RETURN
      END


!
!  miscset.f90
!
!  Alex 9/13/2014
!
!  Miscellaneous setup for the BGKVDCF0D code.
!  constains generation of meshes and more.
!!!!!!!!!!!!!!!!!!!!!!!

module BGKVDCF0D_miscset

use nrtype ! contains kind parameters (DP), (DP), (I4B) etc.
implicit none

contains

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! SetDGblzmGnodes
!
! This subroutine sets up the notes used in various integrations and
! also used as ordimnates/nodal values
!
! This subroutine uses parameters set by SetUWbgkParams
!
! This subroutine sets arrays used in other programs -- must be exectured before
! subrouines setting meshes.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

subroutine SetDGblzmGnodes
use BGKVDCF0D_commvar, only: x_gauss_n, x_gauss_w, t_gauss_n, t_gauss_w, &
             x_lobat_n, x_lobat_w, t_lobat_n, t_lobat_w, k_c, k_b, d_c, d_b, &
             g_nds_all, g_wts_all, g_max_order, &
             moments_x_gauss_nodes,moments_x_gauss_weights,moments_x_gauss_order
use gaussian_mod
use gaussquad, only: gauss_rule

integer (I4B) :: loc_alloc_stat, info  ! local variable to keep the allocation status
real (DP), dimension (:), allocatable :: ugn, ugw ! scratch arrays to create gauss nodes...
real (DP), dimension (1:k_b) :: xb ! scratch array to use in the subroutine generating gauss-lobatto nodes.
real (DP), dimension (1:d_b) :: tb ! scratch array to use in the subroutine to generate gauss-Lobatto nodes.
integer (I4B) :: i ! local counter

!!! Prepare the Gaussian nodes and weights in x variables !!!!!!!!!!!!!!!!!!!!!!
!!! Allocate arrays for gaussian nodes and weights to inegration in the first variable
  allocate (x_gauss_n(1:max(k_c,1)), stat=loc_alloc_stat)
     !
     if (loc_alloc_stat >0) then
     print *, "SetDGblzmGnodes: Allocation error for variable (x_gauss_n)"
     end if
     !
  allocate (x_gauss_w(1:max(k_c,1)), stat=loc_alloc_stat)
     !
     if (loc_alloc_stat >0) then
     print *, "SetDGblzmGnodes: Allocation error for variable (x_gauss_w)"
     end if
     !
!!! Compute the gaussian nodes and weights for integration in the first variable
  if (k_c == 1) then
   x_gauss_n(:)= (/ 0.0_DP /)
   x_gauss_w(:)= (/ 2.0_DP /)
  else
   call GauLeg(Real(-1,DP),Real(1,DP),x_gauss_n,x_gauss_w)     ! the number of nodes/presition of the quadrature depends on the size of gnodes,gweights
  end if
!!!
!!! Prepare the Gaussian nodes and weights in u variables !!!!!!!!!!!!!!!!!!!!!!
!   first we need to allocate the arrays to store gauss nodes and weights:
!
  allocate (g_nds_all(1:g_max_order, 1:g_max_order), stat=loc_alloc_stat)
     !
     if (loc_alloc_stat >0) then
     print *, "SetDGblzmGnodes: Allocation error for variable (g_nds_all)"
     end if
     !
  allocate (g_wts_all(1:g_max_order, 1:g_max_order), stat=loc_alloc_stat)
     !
     if (loc_alloc_stat >0) then
     print *, "SetDGblzmGnodes: Allocation error for variable (g_wts_all)"
     end if
     !
!!! reset the arrays to zeros:
g_nds_all=0
g_wts_all=0
!!!
g_nds_all(1,1)=0.0_DP
g_wts_all(1,1)=2.0_DP
do i=2,g_max_order
 ! will need two scrap arrays...
 allocate (ugn(1:i), stat=loc_alloc_stat)
     !
     if (loc_alloc_stat >0) then
     print *, "SetDGblzmGnodes: Allocation error for variable (ugn), i=", i
     end if
 allocate (ugw(1:i), stat=loc_alloc_stat)
     !
     if (loc_alloc_stat >0) then
     print *, "SetDGblzmGnodes: Allocation error for variable (ugw), i=", i
     end if
call GauLeg(Real(-1,DP),Real(1,DP),ugn,ugw)
g_nds_all(1:i,i)=ugn
g_wts_all(1:i,i)=ugw
deallocate(ugn,ugw)
end do
!!! Prepare the Gaussian nodes and weights in t variables !!!!!!!!!!!!!!!!!!!!!!
!!! Allocate arrays for gaussian nodes and weights to inegration in the first variable
  allocate (t_gauss_n(1:max(d_c,1)), stat=loc_alloc_stat)
     !
     if (loc_alloc_stat >0) then
     print *, "SetDGblzmGnodes: Allocation error for variable (t_gauss_n)"
     end if
     !
  allocate (t_gauss_w(1:max(d_c,1)), stat=loc_alloc_stat)
     !
     if (loc_alloc_stat >0) then
     print *, "SetDGblzmGnodes: Allocation error for variable (t_gauss_w)"
     end if
     !
!!! Compute the gaussian nodes and weights for integration in the first variable
  if (d_c == 1) then
   t_gauss_n(:)= (/ 0.0_DP /)
   t_gauss_w(:)= (/ 2.0_DP /)
  else
   call GauLeg(Real(-1,DP),Real(1,DP),t_gauss_n,t_gauss_w)     ! the number of nodes/presition of the quadrature depends on the size of gnodes,gweights
  end if
!!!!!!!
!
! Next we will set the Gauss-Lobatto nodes used in the nodal formulation.
!!! Allocate arrays for gauss-lobatto nodes and weights
  allocate (t_lobat_n(1:max(d_b,1)), stat=loc_alloc_stat)
     !
     if (loc_alloc_stat >0) then
     print *, "SetDGblzmGnodes: Allocation error for variable (t_lobat_n)"
     end if
     !
  allocate (t_lobat_w(1:max(d_b,1)), stat=loc_alloc_stat)
     !
     if (loc_alloc_stat >0) then
     print *, "SetDGblzmGnodes: Allocation error for variable (t_lobat_w)"
     end if
   call gauss_rule(0, d_b, t_lobat_n, t_lobat_w, tb, 0.0_DP, 0.0_DP, 'B', info)
!!! Allocate arrays for gauss-lobatto nodes and weights
  allocate (x_lobat_n(1:max(k_b,1)), stat=loc_alloc_stat)
     !
     if (loc_alloc_stat >0) then
     print *, "SetDGblzmGnodes: Allocation error for variable (x_lobat_n)"
     end if
     !
  allocate (x_lobat_w(1:max(k_b,1)), stat=loc_alloc_stat)
     !
     if (loc_alloc_stat >0) then
     print *, "SetDGblzmGnodes: Allocation error for variable (x_lobat_w)"
     end if

   call gauss_rule(0, k_b, x_lobat_n, x_lobat_w, xb, 0.0_DP, 0.0_DP, 'B', info)
   ! We set the variables of moments_x_gauss_nodes, moments_x_gauss_weights,
   allocate (moments_x_gauss_nodes(1:moments_x_gauss_order), stat=loc_alloc_stat)
     !
     if (loc_alloc_stat >0) then
     print *, "SetDGblzmGnodes: Allocation error for variable (moments_x_gauss_nodes)"
     end if
     !
  allocate (moments_x_gauss_weights(1:moments_x_gauss_order), stat=loc_alloc_stat)
     !
     if (loc_alloc_stat >0) then
     print *, "SetDGblzmGnodes: Allocation error for variable (moments_x_gauss_nodes)"
     end if
 if (moments_x_gauss_order == 1) then
   moments_x_gauss_nodes(:)= (/ 0.0_DP /)
   moments_x_gauss_weights(:)= (/ 2.0_DP /)
  else
   call GauLeg(Real(-1,DP),Real(1,DP),moments_x_gauss_nodes,moments_x_gauss_weights)     ! the number of nodes/presition of the quadrature depends on the size of gnodes,gweights
  end if
 end subroutine SetDGblzmGnodes

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! SetDGVblzmmesh
!
! This subroutine sets up the meshes. Do not detouch from the main program
!
! This subroutine is highly dependent on the main program. It is created mainly
! to organize the main program.
!
! The subroutine can not be called before the parameters
! N,M, mesh_x_uniform, moments_x_gauss_order,
! are selected                               !!!!!
! CALL this SUBROUTINE before other subroutines use varaibles N,M.
!
! DO not call before arrays moments_x_gauss_nodes,moments_x_gauss_weights_x,moments_x_gauss_order
!          are selected!
!
! Most of the varaibles are looked up in the BGKDCF0D_commvar
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine SetBGK1Dmesh
use BGKVDCF0D_commvar, only:  xmesh_l, xmesh_r, N, x_L, x_R, &
                   mesh_x_uniform, x_nonuniform_mesh_type, &
                   moments_x_gauss_nodes

intrinsic Min, Max, MinVal

integer (I4B) :: loc_alloc_stat ! to keep allocation status
integer (I4B) ::  i,j       ! local counter
integer (I4B) :: sml,smr   ! parameters for umesh with small cells around zero sml -- levels of refinment and smr -- ratio of refinement
integer (I4B) :: mxgo,mugo      ! local variables to keep the order of the gauss integration for the moments
real (DP) :: dx ! local temp variables to store 1/3 smallest distance between nodes.
 ! first the mesh in x
 if (mesh_x_uniform) then
  allocate (xmesh_l(1:N), stat=loc_alloc_stat)
    !
  if (loc_alloc_stat >0) then
  print *, "SetDGVblzmmesh: Allocation error for variable (xmesh_l)"
  stop
  end if
     !
  xmesh_l = (/ (x_L + (x_R - x_L )/Real(N,DP)*i, i=0,N-1) /)
  !
  allocate (xmesh_r(1:N), stat=loc_alloc_stat)
    !
  if (loc_alloc_stat >0) then
  print *, "SetDGVblzmmesh: Allocation error for variable (xmesh_r)"
  stop
  end if
     !
  xmesh_r = (/ (x_L + (x_R - x_L )/Real(N,DP)*i, i=1,N) /)
  !
 else
  select case (x_nonuniform_mesh_type)
  case (1) ! use "the gauss nodes for evaluating moments in x" to set up the "mesh in x"
           ! interval [x_left,x_right] is divided in subintervals as to have gauss nodes at centerpoints
           ! (and some extra points need to be introduced to make this possible).
  mxgo = size(moments_x_gauss_nodes) ! temp remember order of the guass method for integration of moments ....
  dx=min(minval(moments_x_gauss_nodes(2:mxgo) - moments_x_gauss_nodes(1:mxgo-1)),&
                 moments_x_gauss_nodes(1)+Real(1,DP), Real(1,DP)-moments_x_gauss_nodes(mxgo))/Real(3,DP)
  !! allocate memory for the nodes in x
     allocate (xmesh_l(1:mxgo*2+1), stat=loc_alloc_stat)
     !
     if (loc_alloc_stat >0) then
     print *, "SetDGVblzmmesh: Allocation error for variable (xmesh_l)"
     stop
     end if
     !
!! allocate memory for the nodes in x
     allocate (xmesh_r(1:mxgo*2+1), stat=loc_alloc_stat)
     !
     if (loc_alloc_stat >0) then
     print *, "SetDGVblzmmesh: Allocation error for variable (xmesh_r)"
     stop
     end if
     !
  !! Now we set up the mesh in x:
  xmesh_l(1)=x_L
  do i=1,mxgo
  xmesh_l(2*i) = (x_R+x_L)/Real(2,DP) + (x_R-x_L)/Real(2,DP)*(moments_x_gauss_nodes(i) - dx)
  xmesh_l(2*i+1) = (x_R+x_L)/Real(2,DP) + (x_R-x_L)/Real(2,DP)*(moments_x_gauss_nodes(i) + dx)
  end do
  xmesh_r(1:2*mxgo)=xmesh_l(2:2*mxgo+1)
  xmesh_r(mxgo*2+1) = x_R
  N=mxgo*2+1 ! the new value of (N) in case somebody uses it directly...
  !! mesh in x is ready
  case (2) ! This mesh is to be used with diffusive boundary conditions
           ! and will make 1/8-1/4-1/2 refinement near the walls
           ! Only Static wall is implemented at this time!
           ! Requires N>=6 !!!
  !! allocate memory for the nodes in x
  if (N<6) then
    print *, "SetDGVblzmmesh: For the type 2 nonuniform mesh in x the number of mesh points has to be >=6 (xmesh_l)"
    stop
  end if
    allocate (xmesh_l(1:N), stat=loc_alloc_stat)
    !
    if (loc_alloc_stat >0) then
    print *, "SetDGVblzmmesh: Allocation error for variable (xmesh_l)"
    stop
    end if
    !
    allocate (xmesh_r(1:N), stat=loc_alloc_stat)
    !
    if (loc_alloc_stat >0) then
    print *, "SetDGVblzmmesh: Allocation error for variable (xmesh_r)"
    stop
    end if
    !
    dx=(x_R-x_L)/(Real(N-4,DP)-Real(1,DP)/Real(4,DP))
  !! Now we will set up the mesh in variable x:
    xmesh_l(1)=x_L
    xmesh_l(2)=x_L+dx/Real(8,DP)
    xmesh_l(3)=xmesh_l(2)+dx/Real(4,DP)
    xmesh_l(4)=xmesh_l(3)+dx/Real(2,DP)
     do i=5,N-3
      xmesh_l(i)=xmesh_l(i-1)+dx
     end do
    xmesh_r(N)=x_R
    xmesh_l(N)=xmesh_r(N)-dx/Real(8,DP)
    xmesh_l(N-1)=xmesh_l(N)-dx/Real(4,DP)
    xmesh_l(N-2)=xmesh_l(N-1)-dx/Real(2,DP)
    xmesh_r(1:N-1)=xmesh_l(2:N)
  !! end of the non-uniform mesh type 2.
  case (3) ! This mesh is to be used with diffusive boundary conditions
           ! and will make 1/4-1/2 refinement near the walls
           ! Only Static wall is implemented at this time!
           ! Requires N>=4 !!!
  !! allocate memory for the nodes in x
  if (N<4) then
    print *, "SetDGVblzmmesh: For the type 3 nonuniform mesh in x the number of mesh points has to be >=4 (xmesh_l)"
    stop
  end if
    allocate (xmesh_l(1:N), stat=loc_alloc_stat)
    !
    if (loc_alloc_stat >0) then
    print *, "SetDGVblzmmesh: Allocation error for variable (xmesh_l)"
    stop
    end if
    !
    allocate (xmesh_r(1:N), stat=loc_alloc_stat)
    !
    if (loc_alloc_stat >0) then
    print *, "SetDGVblzmmesh: Allocation error for variable (xmesh_r)"
    stop
    end if
    !
    dx=(x_R-x_L)/(Real(N-2,DP)-Real(1,DP)/Real(2,DP))
  !! Now we will set up the mesh in variable x:
    xmesh_l(1)=x_L
    xmesh_l(2)=x_L+dx/Real(4,DP)
    xmesh_l(3)=xmesh_l(2)+dx/Real(2,DP)
     do i=4,N-2
      xmesh_l(i)=xmesh_l(i-1)+dx
     end do
    xmesh_r(N)=x_R
    xmesh_l(N)=xmesh_r(N)-dx/Real(4,DP)
    xmesh_l(N-1)=xmesh_l(N)-dx/Real(2,DP)
    xmesh_r(1:N-1)=xmesh_l(2:N)
  !!! end of the non-uniform mesh type 3.
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  case default
    allocate (xmesh_l(1:3), stat=loc_alloc_stat)
     !
    if (loc_alloc_stat >0) then
    print *, "SetDGVblzmmesh: Allocation error for variable (xmesh_l)"
    stop
    end if
     !
    allocate (xmesh_r(1:3), stat=loc_alloc_stat)
     !
    if (loc_alloc_stat >0) then
    print *, "SetDGVblzmmesh: Allocation error for variable (xmesh_r)"
    stop
    end if
     !
    xmesh_l = (/ (x_L + (x_R-x_L)/Real(3,DP)*i, i=0,2) /)
    xmesh_r(1:2)=xmesh_l(2:3)
    xmesh_r(3) = x_R
    N=3 ! the new value of (N) in case somebody uses it directly...
    print *, "SetDGVblzmmesh: unsupported choice of non-uniform mesh. x_nonuniform_mesh_type= ", x_nonuniform_mesh_type
end select
 end if

 end subroutine SetBGK1Dmesh

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!1
!
!  Subroutine OldCreateUmesh
!  This subroutine is used to generate 1D meshes in the velocity variables
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

subroutine OldCreateUmesh(ugrid,ugrid_cap,mesh_u_uniform,u_nonuniform_mesh_type,u_L,u_R)
!
real (DP), dimension (:), intent (out)  :: ugrid
integer (I4B), dimension (:), intent (out)  :: ugrid_cap
logical, intent(in) :: mesh_u_uniform
integer (I4B), intent (in) :: u_nonuniform_mesh_type
real (DP), intent (out) :: u_L, u_R
! local variables:
integer (I4B) :: M ! number of cells in the grid
integer (I4B) :: i,j ! local counters
!!!!!!!!!!!!!!!!!!!!!!!
integer (I4B) :: smr, sml ! refinement parameters for mesh of type 3
real (DP) :: du
!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!1
M=size(ugrid,1)-1
ugrid_cap(1) = M+1
!
if (mesh_u_uniform) then
  ugrid = (/ (u_L + (u_R-u_L)/Real(M,DP)*i, i=0,M) /)
  else
  select case (u_nonuniform_mesh_type)
  case (1) ! Unsupported
     print *, "OldCreateUmesh: Unsupported type of mesh in velocity variable (u_nonuniform_mesh_type=1)"
     stop
  case (2) ! This mesh is to be used with diffusive boundary conditions
           ! and will include the velocity of the wall, u_{w}=0 as a mesh point
           ! Only Static wall is implemented at this time!
           !
 ! first, let us check that u_wall =0  is in the velocity interval
  if ((u_L > 0.0_DP) .or. (u_R < 0.0_DP)) then
    u_L = min (0.0_DP,u_L)
    u_R = max (0.0_DP,u_R)
  end if
  ! now we start to fill in the mesh:
  i=-M
  j=1
  ugrid(1)=u_L
  do while ( u_R - (u_R-u_L)/Real(M,DP)*i > (u_R-u_L)/Real(M,DP)/2 - 0.00000000001_DP )
  if (i*(u_R-u_L)/Real(M,DP)-u_L > (u_R-u_L)/Real(M,DP)/2) then
  j=j+1
  ugrid(j)=i*(u_R-u_L)/Real(M,DP)
  end if
  i=i+1
  end do
  ugrid(M+1)=u_R
  ! now we have filled in the mesh:
 case (3) ! This mesh is to be used with diffusive boundary conditions
           ! and will include the velocity of the wall, u_{w}=0 as a mesh point
           ! also it will surround $u=0$ with small cells. The sizes of the sell are obtained
           ! by refining the size of biggest cells $smr^{sml}$ times. Here $smr$ -- is the
           ! refinement factor and $sml$ is the total level of reinements.
           ! Only Static wall is implemented at this time!
           !
 ! First we set values for $smr$ and $sml$
 smr=10
 sml=2
 if (2*sml > M-2) then
  print *, "SetDGVblzmmesh: selected number of refinements 'sml' of mesh is too large for the given M"
  stop
 end if
   ! now we need to evaluate the size of the largest cell.
 du=(u_R-u_L)/((M-2*sml) + 2.0_DP/Real(smr,DP)* &
             (1.0_DP/(Real(smr,DP)**sml)-1.0_DP)/(1.0_DP/Real(smr,DP)-1.0_DP))
 ! now we start to fill in the mesh:
  j=1
  ugrid(1) = u_L
  do while (ugrid(j) < - du*(1.0_DP/(Real(smr,DP)**sml) - 1.0_DP)/(1.0_DP/Real(smr,DP)-1.0_DP)/Real(smr,DP) - 0.00000000001_DP )
  j=j+1
  ugrid(j)=ugrid(j-1)+du
  end do
  ! Now we fill in the small cells
  do i=1,sml
  j=j+1
  ugrid(j) = ugrid(j-1) + du/(Real(smr,DP)**i)
  end do
  ugrid(j)=0.0_DP ! Just to have it exact --- otherwise it is not zero, but 10^-13
  do i=sml,1,-1
  j=j+1
  ugrid(j) = ugrid(j-1) + du/(Real(smr,DP)**i)
  end do
  ! now the rest of the cells.
  do while (ugrid(j) < u_R - du - 0.00000000001_DP)
  j = j+1
  ugrid(j) = ugrid(j-1)+du
  end do
  ugrid(M+1) = u_R
 case default
     print *, "SetDGVblzmmesh: Unknown type of mesh"
     stop
  end select
 end if
end subroutine OldCreateUmesh

end module BGKVDCF0D_miscset


!==========================================================================
elemental function gsw_pot_enthalpy_from_pt_ice_poly (pt0_ice)
!==========================================================================
!
!  Calculates the potential enthalpy of ice from potential temperature of
!  ice (whose reference sea pressure is zero dbar).  This is a
!  compuationally efficient polynomial fit to the potential enthalpy of
!  ice.
!
!  pt0_ice  =  potential temperature of ice (ITS-90)              [ deg C ]
!
!  pot_enthalpy_ice  =  potential enthalpy of ice                  [ J/kg ]
!--------------------------------------------------------------------------

use gsw_mod_toolbox, only : gsw_pt_from_pot_enthalpy_ice_poly
use gsw_mod_toolbox, only : gsw_pt_from_pot_enthalpy_ice_poly_dh

use gsw_mod_kinds

implicit none

real (r8), intent(in) :: pt0_ice

real (r8) :: gsw_pot_enthalpy_from_pt_ice_poly

integer :: iteration
real (r8) :: df_dt, f, pot_enthalpy_ice
real (r8) :: pot_enthalpy_ice_mid, pot_enthalpy_ice_old

real (r8), parameter :: p0 = -3.333601570157700e5_r8
real (r8), parameter :: p1 =  2.096693916810367e3_r8
real (r8), parameter :: p2 =  3.687110754043292_r8
real (r8), parameter :: p3 =  4.559401565980682e-4_r8
real (r8), parameter :: p4 = -2.516011957758120e-6_r8
real (r8), parameter :: p5 = -1.040364574632784e-8_r8
real (r8), parameter :: p6 = -1.701786588412454e-10_r8
real (r8), parameter :: p7 = -7.667191301635057e-13_r8

! initial estimate of the potential enthalpy.
pot_enthalpy_ice = p0 + pt0_ice*(p1 + pt0_ice*(p2 + pt0_ice*(p3 &
                   + pt0_ice*(p4 + pt0_ice*(p5 + pt0_ice*(p6 &
                   + pt0_ice*p7))))))

df_dt = gsw_pt_from_pot_enthalpy_ice_poly_dh(pot_enthalpy_ice)

do iteration = 1, 5
    pot_enthalpy_ice_old = pot_enthalpy_ice
    f = gsw_pt_from_pot_enthalpy_ice_poly(pot_enthalpy_ice_old) - pt0_ice
    pot_enthalpy_ice = pot_enthalpy_ice_old - f/df_dt
    pot_enthalpy_ice_mid = 0.5_r8*(pot_enthalpy_ice + pot_enthalpy_ice_old)
    df_dt = gsw_pt_from_pot_enthalpy_ice_poly_dh(pot_enthalpy_ice_mid)
    pot_enthalpy_ice = pot_enthalpy_ice_old - f/df_dt
end do

! The error of this fit ranges between -6e-3 and 6e-3 J/kg over the potential
! temperature range of -100 to 2 deg C, or the potential enthalpy range of
! -5.7 x 10^5 to -3.3 x 10^5 J/kg.

gsw_pot_enthalpy_from_pt_ice_poly = pot_enthalpy_ice

return
end function

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


!***********************************************************************************************************************************
!**                                                S U B R O U T I N E   S H A D I N G                                            **
!***********************************************************************************************************************************

SUBROUTINE SHADING
  USE SHADEC; USE GLOBAL; USE GDAYC; USE SURFHE; USE GEOMC; USE SCREENC; USE LOGICC
  IMPLICIT NONE
  CHARACTER(1) :: BANK
  REAL         :: LOCAL,STANDARD,HOUR,TAUD,SINAL,A02,AZ00,A0,AX,ANG1,ANG2,TOPOANG,SFACT,HT,CLINE,SRED,STLEN,EDGE,EDAZ,SN,AZT
  INTEGER      :: IDAY,J

! Calculate solar altitude, declination, and local hour angle when short-wave solar radiation is provided as input

  IF (READ_RADIATION(JW)) THEN
    LOCAL    =  LONGIT(JW)
    STANDARD =  15.0*INT(LONGIT(JW)/15.0)
    HOUR     = (JDAY-INT(JDAY))*24.0
    IDAY     =  JDAY-((INT(JDAY/365))*365)
    !IDAY     =  IDAY+INT(INT(JDAY/365)/4)    SR 12/2018 IDAY FIX
    IDAY     =  IDAY-INT(INT(JDAY/365)/4)
    TAUD     = (2*PI*(IDAY-1))/365
    EQTNEW   =  0.170*SIN(4*PI*(IDAY-80)/373)-0.129*SIN(2*PI*(IDAY-8)/355)
    HH(JW)   =  0.261799*(HOUR-(LOCAL-STANDARD)*0.0666667+EQTNEW-12.0)
    DECL(JW) =  0.006918-0.399912*COS(TAUD)+0.070257*SIN(TAUD)-0.006758*COS(2*TAUD)+0.000907*SIN(2*TAUD)-0.002697*COS(3*TAUD)      &
                +0.001480*SIN(3*TAUD)
    SINAL    =  SIN(LAT(JW)*.0174533)*SIN(DECL(JW))+COS(LAT(JW)*.0174533)*COS(DECL(JW))*COS(HH(JW))
    A00(JW)  =  57.2957795*ASIN(SINAL)
  END IF

! If the sun is below the horizon, set SHADE(I) to 0

  IF (A00(JW) < 0.0) THEN
    SHADE(I) = 0.0
  ELSE

!** Calculate solar azimuth angle

    A02 = A00(JW)/57.2957795
    AX  = (SIN(DECL(JW))*COS(LAT(JW)*0.017453)-COS(DECL(JW))*COS(HH(JW))*SIN(LAT(JW)*0.017453))/COS(A02)
    IF (AX >  1.0) AX =  1.0
    IF (AX < -1.0) AX = -1.0
    AZT = ACOS(AX)
    IF (HH(JW) < 0.0) THEN
     AZ00 = AZT
    ELSE
     AZ00 = 2.0*PI-AZT
    END IF
    A0 = A02

!** Interpolate the topographic shade angle

    DO J=1,IANG-1
      IF (AZ00 > ANG(J) .AND. AZ00 <= ANG(J+1)) THEN
        ANG1    =  AZ00-ANG(J)
        ANG2    = (TOPO(I,J+1)-TOPO(I,J))/GAMA                 ! SW 10/17/05
        TOPOANG =  TOPO(I,J)+ANG2*ANG1
      END IF
    END DO
    IF (AZ00 > ANG(IANG) .AND. AZ00 <= 2*PI) THEN
      ANG1    =  AZ00-ANG(IANG)
      ANG2    = (TOPO(I,1)-TOPO(I,IANG))/GAMA                  ! SW 10/17/05
      TOPOANG =  TOPO(I,IANG)+ANG2*ANG1
    END IF

!** Complete topographic shading if solar altitude less than topo angle

    IF (A0 <= TOPOANG) THEN
      SFACT = 0.90
      GO TO 100
    END IF

!** No vegetative shading if azimuth angle is oriented parallel to stream

    IF (AZ00 == PHI0(I) .OR. AZ00 == PHI0(I)+PI .OR. AZ00+PI == PHI0(I)) THEN
      SFACT = 0.0
      GO TO 100
    END IF

!** Bank with the controlling vegetation

    IF (PHI0(I) > 0.0 .AND. PHI0(I) <= PI) THEN
      IF (AZ00 > PHI0(I)     .AND. AZ00 <= PHI0(I)+PI) BANK = 'L'
      IF (AZ00 > 0.0         .AND. AZ00 <= PHI0(I))    BANK = 'R'
      IF (AZ00 > PHI0(I)+PI  .AND. AZ00 <  2.0*PI)     BANK = 'R'
    ELSE IF (PHI0(I) > PI .AND. PHI0(I) <= 2.0*PI) THEN
      IF (AZ00 >= PHI0(I)    .AND. AZ00 < 2.0*PI)      BANK = 'L'
      IF (AZ00 >= 0.0        .AND. AZ00 < PHI0(I)-PI)  BANK = 'L'
      IF (AZ00 >= PHI0(I)-PI .AND. AZ00 < PHI0(I))     BANK = 'R'
    END IF

!** No topographic shading

    IF (BANK == 'L') THEN
      IF (TTLB(I) < ELWS(I)) THEN
        SFACT = 0.0
        GO TO 100
      ELSE
        HT    = TTLB(I)-ELWS(I)
        CLINE = CLLB(I)
        SRED  = SRLB2(I)
        IF (JDAYG > SRFJD1(I) .AND. JDAYG <= SRFJD2(I)) SRED = SRLB1(I)
      END IF
    ELSE
      IF (TTRB(I) < ELWS(I)) THEN
        SFACT = 0.0
        GO TO 100
      ELSE
        HT    = TTRB(I)-ELWS(I)
        CLINE = CLRB(I)
        SRED  = SRRB2(I)
        IF (JDAYG > SRFJD1(I) .AND. JDAYG <= SRFJD2(I)) SRED = SRRB1(I)
      END IF
    END IF
    STLEN = HT/TAN (A0)
    EDGE  = MAX (0.0,CLINE-BI(KT,I)/2.0)

!** Distance from vegetation to water edge on line parallel to azimuth

    EDAZ = EDGE/ABS(SIN(PHI0(I)-AZ00))
    IF (STLEN <= EDAZ) THEN
      SFACT = 0.0
      GO TO 100
    END IF

!** Distance shadow extends over water (perpendicular to segment orientation)

    SN    = MIN (HT*ABS (SIN (ABS (PHI0(I)-AZ00)))/TAN (A0)-EDGE,BI(KT,I))
    SFACT = SRED*SN/BI(KT,I)
100 CONTINUE
    SHADE(I) = MAX (0.0,1.0-SFACT)
    SHADE(I) = MIN(ABS(SHADEI(I)),SHADE(I))              ! SW 10/2/2017 Allows for fixed canopy cover over top of channel - only used if shade is less than shadei only valid for -0.99 and 0.0
  END IF
  RETURN
END SUBROUTINE SHADING