      subroutine fault_disp(alp,elon,elat,edep,strk,dip,length,wdt,
     &     disl1,disl2,rlon,rlat,dstmx,edsp,ndsp,zdsp,m,n)
c***********************************************************************
c
c***********************************************************************
      IMPLICIT NONE
      INTEGER, INTENT(IN):: m,n

      REAL(8),INTENT(IN):: alp,elat(n),elon(n),edep(n),strk(n),dip(n)
      REAL(8),INTENT(IN):: dstmx(n),length(n),wdt(n),disl1(n),disl2(n)
      REAL(8),INTENT(IN):: rlon(m),rlat(m)
      REAL(8),INTENT(OUT):: zdsp(m),edsp(m),ndsp(m)

C     Local variables

      LOGICAL:: USE_DC3D, POINT_SOURCE
      REAL(8) :: pi,dtr, tmp1, tmp2, odep,oy,ox, x, y, d, az, alp_dc3d
      REAL(8) :: u1, u2, u3, u11, u12, u13, u21, u22, u23, u31, u32, u33
      REAL(8) :: sd, cd, ss, cs
      INTEGER:: i, j, IRET

c     Use these options to experiment only
c     As of 25/05/15 both should be .FALSE. for the package
      USE_DC3D = .FALSE.
      POINT_SOURCE = .FALSE.

      pi  = 4.0D0*atan2(1.0D0,1.0D0)
      dtr = pi/180.0D0 ! degrees to radians

c Initialize displacements to zero
      do 50 j=1,m
         ndsp(j) = 0.0D0
         edsp(j) = 0.0D0
         zdsp(j) = 0.0D0
 50   continue

c Loop over faults
      do 200 i=1,n
c Translate the origin from fault center to Okada lower left corner
         cd = cos(dip(i)*dtr)
         sd = sin(dip(i)*dtr)
         ss = sin(strk(i)*dtr)
         cs = cos(strk(i)*dtr)
         ! Half 'diagonal length' of surface projection of the slip area
         tmp1 = 0.5D0*sqrt(length(i)**2 + (cd*wdt(i))**2)
         ! Angle of triangle connecting corners of surface projection of slip area
         tmp2 = atan2(cd*wdt(i), length(i))
         odep = edep(i) + 0.5D0*wdt(i)*sd ! Origin depth in Okada's reference frame

c        Compute origin for Okada reference frame
         oy = elat(i) - 1000.0D0*tmp1*cos(tmp2-strk(i)*dtr)
         ox = elon(i) + 1000.0D0*tmp1*sin(tmp2-strk(i)*dtr)

c Loop over displacement points
         do 100 j=1,m
c           Translate to new origin
            x = (rlon(j) - ox)*.001D0
            y = (rlat(j) - oy)*.001D0
            d = sqrt(x**2+y**2) ! Find distance from origin

c Skip this contribution of distance exceeds the threshhold
            IF(dstmx(i).gt.0. .and. d.gt.dstmx(i)) THEN
                goto 100
            END IF

c           Rotate into Okada reference frame, which has the strike
c           direction = positive x axis, with the origin at the deep end
c           of the slip with the most negative value along the x axis.
            az = 90.0D0-atan2(y,x)/dtr
            y = d*sin(dtr*(strk(i)-az))
            x = d*cos(dtr*(strk(i)-az))

            IF(USE_DC3D) THEN
                IF(POINT_SOURCE.eqv..FALSE.) THEN
                  alp_dc3d = 2.0D0/3.0D0 ! Different definition than in srectf
                  call DC3D(alp_dc3d, x, y, 0.0D0, odep, dip(i),0.0D0,
     &                   length(i), 0.0D0, wdt(i), disl1(i),
     &                   disl2(i), 0.0D0, u1, u2, u3, u11, u21, u31,
     &                   u12, u22, u32, u13, u23, u33, IRET)
                ELSE
c DC3D is not used but can be tried by modifying USE_DC3D above
c DC3D point source is not currently supported, but the following stop statement
c must be commented out for R to link with the code.
c                  stop('Need to implement point source')

                END IF

                IF(IRET .NE. 0) THEN
c The following stop must be commented out for R to compile the code
c                    stop('IRET != 0')
                END IF
            ELSE
                IF(POINT_SOURCE.eqv..FALSE.) THEN

                 call srectf(alp,x,y,odep,0.0D0,length(i),0.0D0,wdt(i),
     &               sd, cd, disl1(i),
     &               disl2(i),0.0D0,u1,u2,u3,u11,u12,u21,u22,u31,u32)
                ELSE
                 call spoint(alp, x, y, odep, sd, cd,
     &               disl1(i)*length(i)*wdt(i),
     &               disl2(i)*length(i)*wdt(i),
     &               0.0D0, u1,u2,u3,u11,u12,u21,u22,u31,u32)

                END IF
            END IF

             edsp(j) = edsp(j) - u2*cs + u1*ss
             ndsp(j) = ndsp(j) + u2*ss + u1*cs
             zdsp(j) = zdsp(j) + u3
 100     continue
 200  continue

      RETURN
      END

C********************************************************************   00570000
      SUBROUTINE  SPOINT(ALP,X,Y,DEP,SD,CD,POT1,POT2,POT3,              00530000
     *                   U1,U2,U3,U11,U12,U21,U22,U31,U32)              00540000
      IMPLICIT REAL(8) (A-H,O-Z)                                        00550000
C                                                                       00560000
C********************************************************************   00570000
C*****                                                          *****   00580000
C*****    SURFACE DISPLACEMENT,STRAIN,TILT                      *****   00590000
C*****    DUE TO BURIED POINT SOURCE IN A SEMIINFINITE MEDIUM   *****   00600000
C*****                         CODED BY  Y.OKADA ... JAN 1985   *****   00610000
C*****    (minor changes Gareth Davies to remove some divisions)*****   00620000
C********************************************************************   00630000
C                                                                       00640000
C***** INPUT                                                            00650000
C*****   ALP   : MEDIUM CONSTANT  MYU/(LAMDA+MYU)=1./((VP/VS)**2-1)     00660000
C*****   X,Y   : COORDINATE OF STATION                                  00670000
C*****   DEP     : SOURCE DEPTH                                         00680000
C*****   SD,CD : SIN,COS OF DIP-ANGLE                                   00690000
C*****          (CD=0.D0, SD=+/-1.D0 SHOULD BE GIVEN FOR VERTICAL FAULT)00700000
C*****   POT1,POT2,POT3 : STRIKE-, DIP- AND TENSILE-POTENCY             00710000
C*****       POTENCY=(  MOMENT OF DOUBLE-COUPLE  )/MYU    FOR POT1,2    00720000
C*****       POTENCY=(INTENSITY OF ISOTROPIC PART)/LAMDA  FOR POT3      00730000
C                                                                       00740000
C***** OUTPUT                                                           00750000
C*****   U1, U2, U3      : DISPLACEMENT ( UNIT=(UNIT OF POTENCY) /      00760000
C*****                   :                     (UNIT OF X,Y,D)**2  )    00770000
C*****   U11,U12,U21,U22 : STRAIN       ( UNIT= UNIT OF POTENCY) /      00780000
C*****   U31,U32         : TILT                (UNIT OF X,Y,D)**3  )    00790000
C                                                                       00800000
      DATA  F0,F1,F2,F3,F4,F5,F8,F9                                     00810000
     *      /0.D0, 1.D0, 2.D0, 3.D0, 4.D0, 5.D0, 8.D0, 9.D0/            00820000
      PI2=6.283185307179586D0                                           00830000
C-----                                                                  00840000
      D =DEP                                                            00850000
      P =Y*CD + D*SD                                                    00860000
      Q =Y*SD - D*CD                                                    00870000
      S =P*SD + Q*CD                                                    00880000
      X2=X*X                                                            00890000
      Y2=Y*Y                                                            00900000
      XY=X*Y                                                            00910000
      D2=D*D                                                            00920000
      R2=X2 + Y2 + D2                                                   00930000
      R =SQRT(R2)                                                       00940000
      R3=R *R2                                                          00950000
      R5=R3*R2                                                          00960000
      QR=F3*Q/R5                                                        00970000
      R2INV = 1.0D0/R2
      R5INV = 1.0D0/R5
      XR =F5*X2*R2INV                                                   00980000
      YR =F5*Y2*R2INV                                                   00990000
      XYR=F5*XY*R2INV                                                   01000000
      DR =F5*D *R2INV                                                   01010000
      RD =R + D                                                         01020000
      R12=F1/(R*RD*RD)                                                  01030000
      R32=R12*(F2*R + D)* R2INV                                         01040000
      R33=R12*(F3*R + D)/(R2*RD)                                        01050000
      R53=R12*(F8*R2 + F9*R*D + F3*D2)/(R2*R2*RD)                       01060000
      R54=R12*(F5*R2 + F4*R*D +    D2)/R3*R12                           01070000
C-----                                                                  01080000
      A1= ALP*Y*(R12-X2*R33)                                            01090000
      A2= ALP*X*(R12-Y2*R33)                                            01100000
      A3= ALP*X/R3 - A2                                                 01110000
      A4=-ALP*XY*R32                                                    01120000
      A5= ALP*( F1/(R*RD) - X2*R32 )                                    01130000
      B1= ALP*(-F3*XY*R33      + F3*X2*XY*R54)                          01140000
      B2= ALP*( F1/R3 - F3*R12 + F3*X2*Y2*R54)                          01150000
      B3= ALP*( F1/R3 - F3*X2*R5INV) - B2                               01160000
      B4=-ALP*F3*XY*R5INV - B1                                          01170000
      C1=-ALP*Y*(R32 - X2*R53)                                          01180000
      C2=-ALP*X*(R32 - Y2*R53)                                          01190000
      C3=-ALP*F3*X*D*R5INV - C2                                         01200000
C-----                                                                  01210000
      U1 =F0                                                            01220000
      U2 =F0                                                            01230000
      U3 =F0                                                            01240000
      U11=F0                                                            01250000
      U12=F0                                                            01260000
      U21=F0                                                            01270000
      U22=F0                                                            01280000
      U31=F0                                                            01290000
      U32=F0                                                            01300000
C======================================                                 01310000
C=====  STRIKE-SLIP CONTRIBUTION  =====                                 01320000
C======================================                                 01330000
      IF(POT1.EQ.F0)   GO TO 200                                        01340000
      UN=POT1/PI2                                                       01350000
      QRX=QR*X                                                          01360000
      FX=F3*X*R5INV*SD                                                  01370000
      U1 =U1 - UN*( QRX*X + A1*SD )                                     01380000
      U2 =U2 - UN*( QRX*Y + A2*SD )                                     01390000
      U3 =U3 - UN*( QRX*D + A4*SD )                                     01400000
      U11=U11- UN*( QRX* (F2-XR)        + B1*SD )                       01410000
      U12=U12- UN*(-QRX*XYR      + FX*X + B2*SD )                       01420000
      U21=U21- UN*( QR*Y*(F1-XR)        + B2*SD )                       01430000
      U22=U22- UN*( QRX *(F1-YR) + FX*Y + B4*SD )                       01440000
      U31=U31- UN*( QR*D*(F1-XR)        + C1*SD )                       01450000
      U32=U32- UN*(-QRX*DR*Y     + FX*D + C2*SD )                       01460000
C======================================                                 01470000
C=====    DIP-SLIP CONTRIBUTION   =====                                 01480000
C======================================                                 01490000
  200 IF(POT2.EQ.F0)   GO TO 300                                        01500000
      UN=POT2/PI2                                                       01510000
      SDCD=SD*CD                                                        01520000
      QRP=QR*P                                                          01530000
      FS=F3*S*R5INV                                                     01540000
      U1 =U1 - UN*( QRP*X - A3*SDCD )                                   01550000
      U2 =U2 - UN*( QRP*Y - A1*SDCD )                                   01560000
      U3 =U3 - UN*( QRP*D - A5*SDCD )                                   01570000
      U11=U11- UN*( QRP*(F1-XR)        - B3*SDCD )                      01580000
      U12=U12- UN*(-QRP*XYR     + FS*X - B1*SDCD )                      01590000
      U21=U21- UN*(-QRP*XYR            - B1*SDCD )                      01600000
      U22=U22- UN*( QRP*(F1-YR) + FS*Y - B2*SDCD )                      01610000
      U31=U31- UN*(-QRP*DR*X           - C3*SDCD )                      01620000
      U32=U32- UN*(-QRP*DR*Y    + FS*D - C1*SDCD )                      01630000
C========================================                               01640000
C=====  TENSILE-FAULT CONTRIBUTION  =====                               01650000
C========================================                               01660000
  300 IF(POT3.EQ.F0)   GO TO 900                                        01670000
      UN=POT3/PI2                                                       01680000
      SDSD=SD*SD                                                        01690000
      QRQ=QR*Q                                                          01700000
      FQ=F2*QR*SD                                                       01710000
      U1 =U1 + UN*( QRQ*X - A3*SDSD )                                   01720000
      U2 =U2 + UN*( QRQ*Y - A1*SDSD )                                   01730000
      U3 =U3 + UN*( QRQ*D - A5*SDSD )                                   01740000
      U11=U11+ UN*( QRQ*(F1-XR)        - B3*SDSD )                      01750000
      U12=U12+ UN*(-QRQ*XYR     + FQ*X - B1*SDSD )                      01760000
      U21=U21+ UN*(-QRQ*XYR            - B1*SDSD )                      01770000
      U22=U22+ UN*( QRQ*(F1-YR) + FQ*Y - B2*SDSD )                      01780000
      U31=U31+ UN*(-QRQ*DR*X           - C3*SDSD )                      01790000
      U32=U32+ UN*(-QRQ*DR*Y    + FQ*D - C1*SDSD )                      01800000
C-----                                                                  01810000
  900 RETURN                                                            01820000
      END                                                               01830000
      SUBROUTINE  SRECTF(ALP,X,Y,DEP,AL1,AL2,AW1,AW2,                   01840000
     *                   SD,CD,DISL1,DISL2,DISL3,                       01850000
     *                   U1,U2,U3,U11,U12,U21,U22,U31,U32)              01860000
      IMPLICIT REAL(8) (A-H,O-Z)                                        01870000
C                                                                       01880000
C*********************************************************              01890000
C*****                                               *****              01900000
C*****    SURFACE DISPLACEMENT,STRAIN,TILT           *****              01910000
C*****    DUE TO RECTANGULAR FAULT IN A HALF-SPACE   *****              01920000
C*****              CODED BY  Y.OKADA ... JAN 1985   *****              01930000
C*****    (minor changes GD to remove some divisions)*****              01940000
C*********************************************************              01950000
C                                                                       01960000
C***** INPUT                                                            01970000
C*****   ALP     : MEDIUM CONSTANT  MYU/(LAMDA+MYU)=1./((VP/VS)**2-1)   01980000
C*****   X,Y     : COORDINATE OF STATION                                01990000
C*****   DEP     : SOURCE DEPTH                                         02000000
C*****   AL1,AL2 : FAULT LENGTH RANGE                                   02010000
C*****   AW1,AW2 : FAULT WIDTH RANGE                                    02020000
C*****   SD,CD   : SIN,COS OF DIP-ANGLE                                 02030000
C*****          (CD=0.D0, SD=+/-1.D0 SHOULD BE GIVEN FOR VERTICAL FAULT)02040000
C*****   DISL1,DISL2,DISL3 : STRIKE-, DIP- AND TENSILE-DISLOCATION      02050000
C                                                                       02060000
C***** OUTPUT                                                           02070000
C*****   U1, U2, U3      : DISPLACEMENT ( UNIT= UNIT OF DISL     )      02080000
C*****   U11,U12,U21,U22 : STRAIN       ( UNIT= UNIT OF DISL /          02090000
C*****   U31,U32         : TILT                 UNIT OF X,Y,,,AW )      02100000
C                                                                       02110000
C***** SUBROUTINE USED...SRECTG                                         02120000
C                                                                       02130000
      DIMENSION  U(9),DU(9)                                             02140000
      DATA  F0, F1 / 0.D0, 1.D0 /                                       02150000
C-----                                                                  02160000
      P = Y*CD + DEP*SD                                                 02170000
      Q = Y*SD - DEP*CD                                                 02180000
      DO 1111  I=1,9                                                    02190000
      U(I)=F0                                                           02200000
 1111 continue
C-----                                                                  02210000
      DO 5555  K=1,2                                                    02220000
       IF(K.EQ.1)  ET=P-AW1                                             02230000
       IF(K.EQ.2)  ET=P-AW2                                             02240000
       DO 4444  J=1,2                                                   02250000
        IF(J.EQ.1)  XI=X-AL1                                            02260000
        IF(J.EQ.2)  XI=X-AL2                                            02270000
        JK=J+K                                                          02280000
        IF(JK.NE.3)  SIGN= F1                                           02290000
        IF(JK.EQ.3)  SIGN=-F1                                           02300000
        CALL SRECTG(ALP,XI,ET,Q,SD,CD,DISL1,DISL2,DISL3,                02310000
     *           DU(1),DU(2),DU(3),DU(4),DU(5),DU(6),DU(7),DU(8),DU(9)) 02320000
        DO 3333  I=1,9                                                  02330000
         U(I)=U(I)+SIGN*DU(I)                                           02340000
 3333   CONTINUE                                                        02350000
 4444  CONTINUE                                                         02360000
 5555 CONTINUE                                                          02370000
      U1 =U(1)                                                          02380000
      U2 =U(2)                                                          02390000
      U3 =U(3)                                                          02400000
      U11=U(4)                                                          02410000
      U12=U(5)                                                          02420000
      U21=U(6)                                                          02430000
      U22=U(7)                                                          02440000
      U31=U(8)                                                          02450000
      U32=U(9)                                                          02460000
      RETURN                                                            02470000
      END                                                               02480000
      SUBROUTINE  SRECTG(ALP,XI,ET,Q,SD,CD,DISL1,DISL2,DISL3,           02490000
     *                   U1,U2,U3,U11,U12,U21,U22,U31,U32)              02500000
      IMPLICIT REAL(8) (A-H,O-Z)                                        02510000
C                                                                       02520000
C*********************************************************************  02530000
C*****                                                           *****  02540000
C*****  INDEFINITE INTEGRAL OF SURFACE DISPLACEMENT,STRAIN,TILT  *****  02550000
C*****  DUE TO RECTANGULAR FAULT IN A HALF-SPACE                 *****  02560000
C*****                          CODED BY  Y.OKADA ... JAN 1985   *****  02570000
C***** (minor changes GD to remove some divisions)               *****  02580000
C*********************************************************************  02590000
C                                                                       02600000
C***** INPUT                                                            02610000
C*****   ALP     : MEDIUM CONSTANT  MYU/(LAMDA+MYU)=1./((VP/VS)**2-1)   02620000
C*****   XI,ET,Q : FAULT COORDINATE                                     02630000
C*****   SD,CD   : SIN,COS OF DIP-ANGLE                                 02640000
C*****          (CD=0.D0, SD=+/-1.D0 SHOULD BE GIVEN FOR VERTICAL FAULT)02650000
C*****   DISL1,DISL2,DISL3 : STRIKE-, DIP- AND TENSILE-DISLOCATION      02660000
C                                                                       02670000
C***** OUTPUT                                                           02680000
C*****   U1, U2, U3      : DISPLACEMENT ( UNIT= UNIT OF DISL    )       02690000
C*****   U11,U12,U21,U22 : STRAIN       ( UNIT= UNIT OF DISL /          02700000
C*****   U31,U32         : TILT                 UNIT OF XI,ET,Q )       02710000
C                                                                       02720000
      DATA  F0,F1,F2/ 0.D0, 1.D0, 2.D0 /                                02730000
      PI2=6.283185307179586D0                                           02740000
C-----                                                                  02750000
      XI2=XI*XI                                                         02760000
      ET2=ET*ET                                                         02770000
      Q2=Q*Q                                                            02780000
      R2=XI2+ET2+Q2                                                     02790000
      R =DSQRT(R2)                                                      02800000
      R3=R*R2                                                           02810000
      D =ET*SD-Q*CD                                                     02820000
      Y =ET*CD+Q*SD                                                     02830000
      RET=R+ET                                                          02840000
      IF(RET.LT.F0)  RET=F0                                             02850000
      RD =R+D                                                           02860000
      RRD=F1/(R*RD)                                                     02870000
C-----                                                                  02880000
      IF( Q .NE.F0)  TT = DATAN( XI*ET/(Q*R) )                          02890000
      IF( Q .EQ.F0)  TT = F0                                            02900000
      IF(RET.NE.F0)  RE = F1/RET                                        02910000
      IF(RET.EQ.F0)  RE = F0                                            02920000
      IF(RET.NE.F0)  DLE= DLOG(RET)                                     02930000
      IF(RET.EQ.F0)  DLE=-DLOG(R-ET)                                    02940000
      RRX=F1/(R*(R+XI))                                                 02950000
      RINV = 1.0D0/R
      RRE=RE*RINV                                                       02960000
      AXI=(F2*R+XI)*RRX*RRX*RINV                                        02970000
      AET=(F2*R+ET)*RRE*RRE*RINV                                        02980000
      IF(CD.EQ.F0)  GO TO 20                                            02990000
C==============================                                         03000000
C=====   INCLINED FAULT   =====                                         03010000
C==============================                                         03020000
      CDINV = 1.0D0/CD
      TD=SD*CDINV                                                       03030000
      X =DSQRT(XI2+Q2)                                                  03040000
      IF(XI.EQ.F0)  A5=F0                                               03050000
      IF(XI.NE.F0)                                                      03060000
     *A5= ALP*F2*CDINV*DATAN((ET*(X+Q*CD)+X*(R+X)*SD) / (XI*(R+X)*CD))  03070000
      A4= ALP*CDINV*( DLOG(RD) - SD*DLE )                               03080000
      A3= ALP*(Y/RD*CDINV - DLE) + TD*A4                                03090000
      A1=-ALP*CDINV*XI/RD        - TD*A5                                03100000
      C1= ALP*CDINV*XI*(RRD - SD*RRE)                                   03110000
      C3= ALP*CDINV*(Q*RRE - Y*RRD)                                     03120000
      B1= ALP*CDINV*(XI2*RRD - F1)/RD - TD*C3                           03130000
      B2= ALP*CDINV*XI*Y*RRD/RD       - TD*C1                           03140000
      GO TO 30                                                          03150000
C==============================                                         03160000
C=====   VERTICAL FAULT   =====                                         03170000
C==============================                                         03180000
   20 RD2=RD*RD                                                         03190000
      F2INV = 1.0D0/F2
      RD2INV = 1.0D0/RD2
      RDINV = 1.0D0/RD
      A1=-ALP*F2INV*XI*Q*RD2INV                                         03200000
      A3= ALP*F2INV*( ET/RD + Y*Q*RD2INV - DLE )                        03210000
      A4=-ALP*Q*RDINV                                                   03220000
      A5=-ALP*XI*SD*RDINV                                               03230000
      B1= ALP*F2INV*  Q  *RD2INV*(F2*XI2*RRD - F1)                      03240000
      B2= ALP*F2INV*XI*SD*RD2INV*(F2*Q2 *RRD - F1)                      03250000
      C1= ALP*XI*Q*RRD*RDINV                                            03260000
      C3= ALP*SD*RDINV*(XI2*RRD - F1)                                   03270000
C-----                                                                  03280000
   30 A2=-ALP*DLE - A3                                                  03290000
      B3=-ALP*XI*RRE - B2                                               03300000
      B4=-ALP*( CD*RINV + Q*SD*RRE ) - B1                               03310000
      C2= ALP*(-SD*RINV + Q*CD*RRE ) - C3                               03320000
C-----                                                                  03330000
      U1 =F0                                                            03340000
      U2 =F0                                                            03350000
      U3 =F0                                                            03360000
      U11=F0                                                            03370000
      U12=F0                                                            03380000
      U21=F0                                                            03390000
      U22=F0                                                            03400000
      U31=F0                                                            03410000
      U32=F0                                                            03420000
C======================================                                 03430000
C=====  STRIKE-SLIP CONTRIBUTION  =====                                 03440000
C======================================                                 03450000
      IF(DISL1.EQ.F0)  GO TO 200                                        03460000
      UN=DISL1/PI2                                                      03470000
      REQ=RRE*Q                                                         03480000
      R3INV=1.0D0/R3
      U1 =U1 - UN*( REQ*XI +   TT    + A1*SD )                          03490000
      U2 =U2 - UN*( REQ*Y  + Q*CD*RE + A2*SD )                          03500000
      U3 =U3 - UN*( REQ*D  + Q*SD*RE + A4*SD )                          03510000
      U11=U11+ UN*( XI2*Q*AET - B1*SD )                                 03520000
      U12=U12+ UN*( XI2*XI*( D/(ET2+Q2)*R3INV - AET*SD ) - B2*SD )      03530000
      U21=U21+ UN*( XI*Q*R3INV*CD + (XI*Q2*AET - B2)*SD )               03540000
      U22=U22+ UN*( Y *Q*R3INV*CD + (Q*SD*(Q2*AET-F2*RRE)               03550000
     *                            -(XI2+ET2)*R3INV*CD - B4)*SD )        03560000
      U31=U31+ UN*(-XI*Q2*AET*CD + (XI*Q*R3INV - C1)*SD )               03570000
      U32=U32+ UN*( D*Q/R3*CD + (XI2*Q*AET*CD - SD/R + Y*Q/R3 - C2)*SD )03580000
C===================================                                    03590000
C=====  DIP-SLIP CONTRIBUTION  =====                                    03600000
C===================================                                    03610000
  200 IF(DISL2.EQ.F0)  GO TO 300                                        03620000
      UN=DISL2/PI2                                                      03630000
      SDCD=SD*CD                                                        03640000
      U1 =U1 - UN*( Q/R             - A3*SDCD )                         03650000
      U2 =U2 - UN*( Y*Q*RRX + CD*TT - A1*SDCD )                         03660000
      U3 =U3 - UN*( D*Q*RRX + SD*TT - A5*SDCD )                         03670000
      U11=U11+ UN*( XI*Q*R3INV            + B3*SDCD )                   03680000
      U12=U12+ UN*( Y *Q*R3INV - SD/R     + B1*SDCD )                   03690000
      U21=U21+ UN*( Y *Q*R3INV + Q*CD*RRE + B1*SDCD )                   03700000
      U22=U22+ UN*( Y*Y*Q*AXI - (F2*Y*RRX + XI*CD*RRE)*SD + B2*SDCD )   03710000
      U31=U31+ UN*( D *Q*R3INV + Q*SD*RRE + C3*SDCD )                   03720000
      U32=U32+ UN*( Y*D*Q*AXI - (F2*D*RRX + XI*SD*RRE)*SD + C1*SDCD )   03730000
C========================================                               03740000
C=====  TENSILE-FAULT CONTRIBUTION  =====                               03750000
C========================================                               03760000
  300 IF(DISL3.EQ.F0)  GO TO 900                                        03770000
      UN=DISL3/PI2                                                      03780000
      SDSD=SD*SD                                                        03790000
      U1 =U1 + UN*( Q2*RRE                       - A3*SDSD )            03800000
      U2 =U2 + UN*(-D*Q*RRX - SD*(XI*Q*RRE - TT) - A1*SDSD )            03810000
      U3 =U3 + UN*( Y*Q*RRX + CD*(XI*Q*RRE - TT) - A5*SDSD )            03820000
      U11=U11- UN*( XI*Q2*AET             + B3*SDSD )                   03830000
      U12=U12- UN*(-D*Q*R3INV - XI2*Q*AET*SD + B1*SDSD )                03840000
      U21=U21- UN*( Q2*(CD*R3INV + Q*AET*SD) + B1*SDSD )                03850000
      U22=U22- UN*((Y*CD-D*SD)*Q2*AXI - F2*Q*SD*CD*RRX                  03860000
     *                      - (XI*Q2*AET - B2)*SDSD )                   03870000
      U31=U31- UN*( Q2*(SD*R3INV - Q*AET*CD) + C3*SDSD )                03880000
      U32=U32- UN*((Y*SD+D*CD)*Q2*AXI + XI*Q2*AET*SD*CD                 03890000
     *                       - (F2*Q*RRX - C1)*SDSD )                   03900000
C-----                                                                  03910000
  900 RETURN                                                            03920000
      END                                                               03930000


SUBROUTINE sfnum_light
!======================================
! Stacking Fault Number light
!======================================
! A computationally cheaper algorithm to return the SFN.
! The derivatives are not calculated in order to improve the performance.
!======================================

   USE PARACLUSTER
   USE CLUSTER
   USE POTENTIAL
   USE ENFORCE
   USE DISTANCE
   USE META

   IMPLICIT NONE

   integer               :: i, j, itypik, mminusn_pwr
   double precision      :: ratio_ton, ratio_tom
   double precision      :: dij, ratio
   real(8), dimension(3) :: rij0 ! 3 possible cases: atoms A-A, B-B, A-B
   real(8), dimension(3) :: dij0 ! 3 possible cases: atoms A-A, B-B, A-B

   if (ipas.eq.1) write(*,*) '> sfnum_light: first calculation of SFN.'

   ! IMPROVEMENT: All this could become global! ++++++++++++++++++++++++++++
   mminusn_pwr = msf_pwr - nsf_pwr

   ! Evaluating the values of rij0 parameter in dependence of atom pair kind
   rij0 = dist * rsf * dsqrt(2.d0) ! rij0 and dist are 3 element vectors

   ! Evaluating the ref distance for the couple of atoms (THIS IS DIFFERENT)
   dij0 = dist * dsf * dsqrt(2.d0)
   ! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

   do i = 1, natom-1
      do j = i+1, natom

         ! Checking what kind of atoms the couple i,j is made of
         if      ((itype(i).eq.1).and.(itype(j).eq.1)) then
            itypik = 1  ! same metal A
         else if ((itype(i).eq.2).and.(itype(j).eq.2)) then
            itypik = 2  ! same metal B
         else
            itypik = 3  ! A-B interaction
         end if

         ! Calculating the distance between atom i and atom j
         dij = pair_dist (i,j) - dij0(itypik)

         ! Calculating the analytic SFN
         ratio = dij/rij0(itypik)
         ! I need to rise to (X_pwr-1) for the derivative
         ratio_ton = ratio**(nsf_pwr)
         ratio_tom = ratio_ton*(ratio**(mminusn_pwr))

         ! The sum of these s(i,j) is the analytic coord no.
         ssf(i,j) = (1.d0-ratio_ton)/(1.d0-ratio_tom)  ! this is f(rij)
         ssf(j,i) = ssf(i,j)

      end do ! on j
   end do ! on i

   ! LP: Calculating the sum of ssf(i,j), which is SFNatom(i,j), global.
   ! This is the coord num of any single atom i
   SFNatom(:) = 0.d0 ! Initializing
   do i = 1, natom
      do j = 1, natom
         if (j.ne.i) SFNatom(i) = SFNatom(i) + ssf(i, j)
      end do
   end do

END SUBROUTINE sfnum_light


C    Copyright(C) 1999-2020 National Technology & Engineering Solutions
C    of Sandia, LLC (NTESS).  Under the terms of Contract DE-NA0003525 with
C    NTESS, the U.S. Government retains certain rights in this software.
C
C    See packages/seacas/LICENSE for details

      subroutine tinvit(nm,n,d,e,e2,m,w,ind,z,
     x                  ierr,rv1,rv2,rv3,rv4,rv6)

      integer i,j,m,n,p,q,r,s,ii,ip,jj,nm,its,tag,ierr,group
      double precision d(n),e(n),e2(n),w(m),z(nm,m),
     x       rv1(n),rv2(n),rv3(n),rv4(n),rv6(n)
      double precision u,v,uk,xu,x0,x1,eps2,eps3,eps4,norm,order,epslon,
     x       pythag
      integer ind(m)

c     this subroutine is a translation of the inverse iteration tech-
c     nique in the algol procedure tristurm by peters and wilkinson.
c     handbook for auto. comp., vol.ii-linear algebra, 418-439(1971).

c     this subroutine finds those eigenvectors of a tridiagonal
c     symmetric matrix corresponding to specified eigenvalues,
c     using inverse iteration.

c     on input

c        nm must be set to the row dimension of two-dimensional
c          array parameters as declared in the calling program
c          dimension statement.

c        n is the order of the matrix.

c        d contains the diagonal elements of the input matrix.

c        e contains the subdiagonal elements of the input matrix
c          in its last n-1 positions.  e(1) is arbitrary.

c        e2 contains the squares of the corresponding elements of e,
c          with zeros corresponding to negligible elements of e.
c          e(i) is considered negligible if it is not larger than
c          the product of the relative machine precision and the sum
c          of the magnitudes of d(i) and d(i-1).  e2(1) must contain
c          0.0d0 if the eigenvalues are in ascending order, or 2.0d0
c          if the eigenvalues are in descending order.  if  bisect,
c          tridib, or  imtqlv  has been used to find the eigenvalues,
c          their output e2 array is exactly what is expected here.

c        m is the number of specified eigenvalues.

c        w contains the m eigenvalues in ascending or descending order.

c        ind contains in its first m positions the submatrix indices
c          associated with the corresponding eigenvalues in w --
c          1 for eigenvalues belonging to the first submatrix from
c          the top, 2 for those belonging to the second submatrix, etc.

c     on output

c        all input arrays are unaltered.

c        z contains the associated set of orthonormal eigenvectors.
c          any vector which fails to converge is set to zero.

c        ierr is set to
c          zero       for normal return,
c          -r         if the eigenvector corresponding to the r-th
c                     eigenvalue fails to converge in 5 iterations.

c        rv1, rv2, rv3, rv4, and rv6 are temporary storage arrays.

c     calls pythag for  dsqrt(a*a + b*b) .

c     questions and comments should be directed to burton s. garbow,
c     mathematics and computer science div, argonne national laboratory

c     this version dated august 1983.

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

      ierr = 0
      if (m .eq. 0) go to 1001
      tag = 0
      order = 1.0d0 - e2(1)
      q = 0
c     .......... establish and process next submatrix ..........
  100 p = q + 1

      do 120 q = p, n
         if (q .eq. n) go to 140
         if (e2(q+1) .eq. 0.0d0) go to 140
  120 continue
c     .......... find vectors by inverse iteration ..........
  140 tag = tag + 1
      s = 0

      do 920 r = 1, m
         if (ind(r) .ne. tag) go to 920
         its = 1
         x1 = w(r)
         if (s .ne. 0) go to 510
c     .......... check for isolated root ..........
         xu = 1.0d0
         if (p .ne. q) go to 490
         rv6(p) = 1.0d0
         go to 870
  490    norm = dabs(d(p))
         ip = p + 1

         do 500 i = ip, q
  500    norm = dmax1(norm, dabs(d(i))+dabs(e(i)))
c     .......... eps2 is the criterion for grouping,
c                eps3 replaces zero pivots and equal
c                roots are modified by eps3,
c                eps4 is taken very small to avoid overflow ..........
         eps2 = 1.0d-3 * norm
         eps3 = epslon(norm)
         uk = q - p + 1
         eps4 = uk * eps3
         uk = eps4 / dsqrt(uk)
         s = p
  505    group = 0
         go to 520
c     .......... look for close or coincident roots ..........
  510    if (dabs(x1-x0) .ge. eps2) go to 505
         group = group + 1
         if (order * (x1 - x0) .le. 0.0d0) x1 = x0 + order * eps3
c     .......... elimination with interchanges and
c                initialization of vector ..........
  520    v = 0.0d0

         do 580 i = p, q
            rv6(i) = uk
            if (i .eq. p) go to 560
            if (dabs(e(i)) .lt. dabs(u)) go to 540
c     .......... warning -- a divide check may occur here if
c                e2 array has not been specified correctly ..........
            xu = u / e(i)
            rv4(i) = xu
            rv1(i-1) = e(i)
            rv2(i-1) = d(i) - x1
            rv3(i-1) = 0.0d0
            if (i .ne. q) rv3(i-1) = e(i+1)
            u = v - xu * rv2(i-1)
            v = -xu * rv3(i-1)
            go to 580
  540       xu = e(i) / u
            rv4(i) = xu
            rv1(i-1) = u
            rv2(i-1) = v
            rv3(i-1) = 0.0d0
  560       u = d(i) - x1 - xu * v
            if (i .ne. q) v = e(i+1)
  580    continue

         if (u .eq. 0.0d0) u = eps3
         rv1(q) = u
         rv2(q) = 0.0d0
         rv3(q) = 0.0d0
c     .......... back substitution
c                for i=q step -1 until p do -- ..........
  600    do 620 ii = p, q
            i = p + q - ii
            rv6(i) = (rv6(i) - u * rv2(i) - v * rv3(i)) / rv1(i)
            v = u
            u = rv6(i)
  620    continue
c     .......... orthogonalize with respect to previous
c                members of group ..........
         if (group .eq. 0) go to 700
         j = r

         do 680 jj = 1, group
  630       j = j - 1
            if (ind(j) .ne. tag) go to 630
            xu = 0.0d0

            do 640 i = p, q
  640       xu = xu + rv6(i) * z(i,j)

            do 660 i = p, q
  660       rv6(i) = rv6(i) - xu * z(i,j)

  680    continue

  700    norm = 0.0d0

         do 720 i = p, q
  720    norm = norm + dabs(rv6(i))

         if (norm .ge. 1.0d0) go to 840
c     .......... forward substitution ..........
         if (its .eq. 5) go to 830
         if (norm .ne. 0.0d0) go to 740
         rv6(s) = eps4
         s = s + 1
         if (s .gt. q) s = p
         go to 780
  740    xu = eps4 / norm

         do 760 i = p, q
  760    rv6(i) = rv6(i) * xu
c     .......... elimination operations on next vector
c                iterate ..........
  780    do 820 i = ip, q
            u = rv6(i)
c     .......... if rv1(i-1) .eq. e(i), a row interchange
c                was performed earlier in the
c                triangularization process ..........
            if (rv1(i-1) .ne. e(i)) go to 800
            u = rv6(i-1)
            rv6(i-1) = rv6(i)
  800       rv6(i) = u - rv4(i) * rv6(i-1)
  820    continue

         its = its + 1
         go to 600
c     .......... set error -- non-converged eigenvector ..........
  830    ierr = -r
         xu = 0.0d0
         go to 870
c     .......... normalize so that sum of squares is
c                1 and expand to full order ..........
  840    u = 0.0d0

         do 860 i = p, q
  860    u = pythag(u,rv6(i))

         xu = 1.0d0 / u

  870    do 880 i = 1, n
  880    z(i,r) = 0.0d0

         do 900 i = p, q
  900    z(i,r) = rv6(i) * xu

         x0 = x1
  920 continue

      if (q .lt. n) go to 100
 1001 return
      end


!*==slartgs.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief \b SLARTGS generates a plane rotation designed to introduce a bulge in implicit QR iteration for the bidiagonal SVD problem.
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download SLARTGS + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE SLARTGS( X, Y, SIGMA, CS, SN )
!
!       .. Scalar Arguments ..
!       REAL                    CS, SIGMA, SN, X, Y
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> SLARTGS generates a plane rotation designed to introduce a bulge in
!> Golub-Reinsch-style implicit QR iteration for the bidiagonal SVD
!> problem. X and Y are the top-row entries, and SIGMA is the shift.
!> The computed CS and SN define a plane rotation satisfying
!>
!>    [  CS  SN  ]  .  [ X^2 - SIGMA ]  =  [ R ],
!>    [ -SN  CS  ]     [    X * Y    ]     [ 0 ]
!>
!> with R nonnegative.  If X^2 - SIGMA and X * Y are 0, then the
!> rotation is by PI/2.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] X
!> \verbatim
!>          X is REAL
!>          The (1,1) entry of an upper bidiagonal matrix.
!> \endverbatim
!>
!> \param[in] Y
!> \verbatim
!>          Y is REAL
!>          The (1,2) entry of an upper bidiagonal matrix.
!> \endverbatim
!>
!> \param[in] SIGMA
!> \verbatim
!>          SIGMA is REAL
!>          The shift.
!> \endverbatim
!>
!> \param[out] CS
!> \verbatim
!>          CS is REAL
!>          The cosine of the rotation.
!> \endverbatim
!>
!> \param[out] SN
!> \verbatim
!>          SN is REAL
!>          The sine of the rotation.
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date November 2017
!
!> \ingroup auxOTHERcomputational
!
!  =====================================================================
      SUBROUTINE SLARTGS(X,Y,Sigma,Cs,Sn)
      IMPLICIT NONE
!*--SLARTGS94
!
!  -- LAPACK computational routine (version 3.8.0) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     November 2017
!
!     .. Scalar Arguments ..
      REAL Cs , Sigma , Sn , X , Y
!     ..
!
!  ===================================================================
!
!     .. Parameters ..
      REAL NEGONE , ONE , ZERO
      PARAMETER (NEGONE=-1.0E0,ONE=1.0E0,ZERO=0.0E0)
!     ..
!     .. Local Scalars ..
      REAL r , s , thresh , w , z
!     ..
!     .. External Subroutines ..
      EXTERNAL SLARTGP
!     ..
!     .. External Functions ..
      REAL SLAMCH
      EXTERNAL SLAMCH
!     .. Executable Statements ..
!
      thresh = SLAMCH('E')
!
!     Compute the first column of B**T*B - SIGMA^2*I, up to a scale
!     factor.
!
      IF ( (Sigma==ZERO .AND. ABS(X)<thresh) .OR.                       &
     &     (ABS(X)==Sigma .AND. Y==ZERO) ) THEN
         z = ZERO
         w = ZERO
      ELSEIF ( Sigma==ZERO ) THEN
         IF ( X>=ZERO ) THEN
            z = X
            w = Y
         ELSE
            z = -X
            w = -Y
         ENDIF
      ELSEIF ( ABS(X)<thresh ) THEN
         z = -Sigma*Sigma
         w = ZERO
      ELSE
         IF ( X>=ZERO ) THEN
            s = ONE
         ELSE
            s = NEGONE
         ENDIF
         z = s*(ABS(X)-Sigma)*(s+Sigma/X)
         w = s*Y
      ENDIF
!
!     Generate the rotation.
!     CALL SLARTGP( Z, W, CS, SN, R ) might seem more natural;
!     reordering the arguments ensures that if Z = 0 then the rotation
!     is by PI/2.
!
      CALL SLARTGP(w,z,Sn,Cs,r)
!
!
!     End SLARTGS
!
      END SUBROUTINE SLARTGS


!------------------------------------------------------------------------------
!!  module: decomp_2d_fft_2d
!------------------------------------------------------------------------------
!!
!! - last modified: fabien margairaz ( fabien.margairaz@gmail.com ), 20/05/2014
!!
!! - description:
!!  - this code uese the FFTW (version 3.x)
!!
!------------------------------------------------------------------------------

module decomp_2d_fft_2d

  use decomp_2d  ! 2D decomposition module

  implicit none

  include "fftw3.f"

  ! Make everything private unless declared public
  private

  ! engine-specific global variables
  ! integer, save :: plan_type = FFTW_MEASURE
  integer, save :: plan_type = FFTW_ESTIMATE

  ! FFTW plans
  integer*8, save :: plan_fx,plan_bx,plan_fy,plan_by
  integer*8, save :: plan_fxb,plan_bxb,plan_fyb,plan_byb

  ! This file contains common code shared by all FFT engines
  integer, parameter, public :: DECOMP_2D_FFT_FORWARD = -1
  integer, parameter, public :: DECOMP_2D_FFT_BACKWARD = 1

  ! The libary can only be initialised once
  logical, save :: initialised = .false.

  ! Global size of the FFT
  integer, save :: nx_fft,ny_fft,nx_fftb,ny_fftb,nz_fft

  ! 2D processor grid
  integer, save, dimension(2) :: dims

  ! Decomposition objects
  TYPE(DECOMP_INFO), save :: ph  ! physical space
  TYPE(DECOMP_INFO), save :: sp,spg  ! spectral space

  TYPE(DECOMP_INFO), save :: phb  ! physical space
  TYPE(DECOMP_INFO), save :: spb,spgb  ! spectral space

  ! Workspace to store the intermediate Y-pencil data
  complex(mytype), allocatable, dimension(:,:,:) :: wk_4x,wk_4xb

  public :: decomp_2d_fft_2d_init,decomp_2d_fft_2d_finalize, &
       execute_decomp_2d_fft_2d,execute_decomp_2d_fft_2d_big, &
       decomp_2d_fft_2d_get_size,decomp_2d_fft_2d_get_sp_info

  ! Declare generic interfaces to handle different inputs
  interface decomp_2d_fft_2d_init
     module procedure fft_2d_init_noarg
     module procedure fft_2d_init_general
  end interface

  interface execute_decomp_2d_fft_2d
     module procedure fft_2d_r2c
     module procedure fft_2d_c2r
  end interface

  interface execute_decomp_2d_fft_2d_big
     module procedure fft_2d_r2c_big
     module procedure fft_2d_c2r_big
  end interface

contains !=======================================================================

  !------------------------------------------------------------------------------
  !! subroutine: initialise fft_2d module
  !------------------------------------------------------------------------------
  !!
  !! - last modified: fabien margairaz ( fabien.margairaz@gmail.com ), 20/05/2014
  !!
  !! - description:
  !!
  !------------------------------------------------------------------------------

  subroutine fft_2d_init_noarg

    implicit none

    call fft_2d_init_general(nx_global, ny_global, nz_global)

    return
  end subroutine fft_2d_init_noarg

  !------------------------------------------------------------------------------
  !! subroutine: initialise fft_2d module
  !------------------------------------------------------------------------------
  !!
  !! - last modified: fabien margairaz ( fabien.margairaz@gmail.com ), 20/05/2014
  !!
  !! - description:
  !!
  !------------------------------------------------------------------------------
  subroutine fft_2d_init_general(nx, ny, nz)

    implicit none

    integer, intent(IN) :: nx,ny,nz

    logical, dimension(2) :: dummy_periods
    integer, dimension(2) :: dummy_coords
    integer :: status, errorcode, ierror

    if (initialised) then
       errorcode = 4
       call decomp_2d_abort(errorcode,&
            'FFT library should only be initialised once')
    end if

    nx_fft = nx
    ny_fft = ny

    nx_fftb = 3*nx/2
    ny_fftb = 3*ny/2

    nz_fft = nz

    ! determine the processor grid in use
    call MPI_CART_GET(DECOMP_2D_COMM_CART_X, 2, &
         dims, dummy_periods, dummy_coords, ierror)

    ! for c2r/r2c interface:
    ! if in physical space, a real array is of size: nx*ny*nz
    ! in spectral space, the complex array is of size: (nx/2+1)*ny*nz
    call decomp_info_init(nx,ny,nz,ph)
    call decomp_info_init(nx/2+1,ny,nz,sp)
    call decomp_info_init(nx/2+1,ny,nz+2*dims(2),spg)

    call decomp_info_init(3*nx/2,3*ny/2,nz,phb)
    call decomp_info_init(3*nx/4+1,3*ny/2,nz,spb)
    call decomp_info_init(3*nx/4+1,3*ny/2,nz+2*dims(2),spgb)

    allocate(wk_4x(sp%xsz(1),sp%xsz(2),0:sp%xsz(3)+1), STAT=status)
    allocate(wk_4xb(spb%xsz(1),spb%xsz(2),0:spb%xsz(3)+1), STAT=status)

    if (status /= 0) then
       errorcode = 3
       call decomp_2d_abort(errorcode,&
            'Out of memory when initialising FFT')
    end if

    wk_4x = (0._mytype,0._mytype)
    wk_4xb = (0._mytype,0._mytype)

    call init_fft_engine

    initialised = .true.

    return
  end subroutine fft_2d_init_general

  !------------------------------------------------------------------------------
  !! subroutine: finalise 2d FFT module
  !------------------------------------------------------------------------------
  !!
  !! - last modified: fabien margairaz ( fabien.margairaz@gmail.com ), 20/05/2014
  !!
  !! - description:
  !!
  !------------------------------------------------------------------------------
  subroutine decomp_2d_fft_2d_finalize

    implicit none

    call decomp_info_finalize(ph)
    call decomp_info_finalize(sp)
    call decomp_info_finalize(spg)
    deallocate(wk_4x)

    call decomp_info_finalize(phb)
    call decomp_info_finalize(spb)
    call decomp_info_finalize(spgb)
    deallocate(wk_4xb)

    call finalize_fft_engine

    initialised = .false.

    return
  end subroutine decomp_2d_fft_2d_finalize

  !------------------------------------------------------------------------------
  !! subroutine: gives size of 2d FFT variables
  !------------------------------------------------------------------------------
  !!
  !! - last modified: fabien margairaz ( fabien.margairaz@gmail.com ), 20/05/2014
  !!
  !! - description:
  !!  - return the size, starting/ending index of the distributed array
  !!    whose global size is (nx/2+1)*ny*nz, for defining data structures
  !!    in r2c and c2r interfaces
  !!
  !------------------------------------------------------------------------------
  subroutine decomp_2d_fft_2d_get_size(istart, iend, isize)

    implicit none
    integer, dimension(3), intent(OUT) :: istart, iend, isize

    istart = sp%zst
    iend   = sp%zen
    isize  = sp%zsz

    return
  end subroutine decomp_2d_fft_2d_get_size

  !------------------------------------------------------------------------------
  !! subroutine: gives 2Decomp info for spectral space
  !------------------------------------------------------------------------------
  !!
  !! - last modified: fabien margairaz ( fabien.margairaz@gmail.com ), 20/05/2014
  !!
  !! - description:
  !!  - return the sp
  !!
  !------------------------------------------------------------------------------
  subroutine decomp_2d_fft_2d_get_sp_info(dcp_out)
    implicit none

    TYPE(DECOMP_INFO),intent(OUT) :: dcp_out
    dcp_out = sp

    return
  end subroutine decomp_2d_fft_2d_get_sp_info

  !------------------------------------------------------------------------------
  !! subroutine: build FFT plan in y
  !------------------------------------------------------------------------------
  !!
  !! - last modified: fabien margairaz ( fabien.margairaz@gmail.com ), 20/05/2014
  !!
  !! - description:
  !!  - return a FFTW3 plan for 1D c2c FFTs in Y direction
  !!
  !------------------------------------------------------------------------------
  subroutine c2c_1d_y_plan(plan1, decomp, isign)
    implicit none

    integer*8, intent(OUT) :: plan1
    TYPE(DECOMP_INFO), intent(IN) :: decomp
    integer, intent(IN) :: isign

    complex(mytype), allocatable, dimension(:) :: a1

    allocate(a1(decomp%ysz(2)))

    call dfftw_plan_dft_1d(plan1,decomp%ysz(2),a1,a1,isign,plan_type);

    deallocate(a1)

    return
  end subroutine c2c_1d_y_plan

  !------------------------------------------------------------------------------
  !! subroutine: build FFT plan in x
  !------------------------------------------------------------------------------
  !!
  !! - last modified: fabien margairaz ( fabien.margairaz@gmail.com ), 20/05/2014
  !!
  !! - description:
  !!  - return a FFTW3 plan for 1D r2c FFTs in X direction
  !!
  !------------------------------------------------------------------------------
  subroutine r2c_1d_x_plan(plan1, decomp_ph, decomp_sp)

    implicit none

    integer*8, intent(OUT) :: plan1
    TYPE(DECOMP_INFO), intent(IN) :: decomp_ph
    TYPE(DECOMP_INFO), intent(IN) :: decomp_sp

    real(mytype), allocatable, dimension(:) :: a1
    complex(mytype), allocatable, dimension(:) :: a2

    allocate(a1(decomp_ph%xsz(1)))
    allocate(a2(decomp_sp%xsz(1)))

    call dfftw_plan_dft_r2c_1d(plan1,decomp_ph%xsz(1),a1,a2,plan_type)

    deallocate(a1,a2)

    return
  end subroutine r2c_1d_x_plan

  !------------------------------------------------------------------------------
  !! subroutine: build FFT plan in x
  !------------------------------------------------------------------------------
  !!
  !! - last modified: fabien margairaz ( fabien.margairaz@gmail.com ), 20/05/2014
  !!
  !! - description:
  !!  - return a FFTW3 plan for 1D c2r FFTs in X direction
  !!
  !------------------------------------------------------------------------------
  subroutine c2r_1d_x_plan(plan1, decomp_sp, decomp_ph)

    implicit none

    integer*8, intent(OUT) :: plan1
    TYPE(DECOMP_INFO), intent(IN) :: decomp_sp
    TYPE(DECOMP_INFO), intent(IN) :: decomp_ph

    complex(mytype), allocatable, dimension(:) :: a1
    real(mytype), allocatable, dimension(:) :: a2

    allocate(a1(decomp_sp%xsz(1)))
    allocate(a2(decomp_ph%xsz(1)))

    call dfftw_plan_dft_c2r_1d(plan1,decomp_ph%xsz(1),a1,a2,plan_type)

    deallocate(a1,a2)

    return
  end subroutine c2r_1d_x_plan

  !------------------------------------------------------------------------------
  !! subroutine: initialise FFT engine
  !------------------------------------------------------------------------------
  !!
  !! - last modified: fabien margairaz ( fabien.margairaz@gmail.com ), 20/05/2014
  !!
  !! - description:
  !!  - this routine performs one-time initialisations for the FFT engine
  !!
  !------------------------------------------------------------------------------
  subroutine init_fft_engine

    implicit none

    if (nrank==0) then
       write(*,*) ' '
       write(*,*) '***** Using the FFTW (version 3.x) engine *****'
       write(*,*) ' '
    end if

    ! For R2C/C2R tranforms
    call r2c_1d_x_plan(plan_fx, ph, sp)
    call c2c_1d_y_plan(plan_fy, sp, FFTW_FORWARD )
    call c2c_1d_y_plan(plan_by, sp, FFTW_BACKWARD)
    call c2r_1d_x_plan(plan_bx, sp, ph)

    ! For R2C/C2R tranforms
    call r2c_1d_x_plan(plan_fxb, phb, spb)
    call c2c_1d_y_plan(plan_fyb, spb, FFTW_FORWARD )
    call c2c_1d_y_plan(plan_byb, spb, FFTW_BACKWARD)
    call c2r_1d_x_plan(plan_bxb, spb, phb)

    return
  end subroutine init_fft_engine

  !------------------------------------------------------------------------------
  !! subroutine: finalise FFT engine
  !------------------------------------------------------------------------------
  !!
  !! - last modified: fabien margairaz ( fabien.margairaz@gmail.com ), 20/05/2014
  !!
  !! - description:t
  !!  - this routine performs one-time finalisations for the FFT engine
  !!
  !------------------------------------------------------------------------------
  subroutine finalize_fft_engine

    implicit none

    call dfftw_destroy_plan(plan_fx)
    call dfftw_destroy_plan(plan_bx)
    call dfftw_destroy_plan(plan_fy)
    call dfftw_destroy_plan(plan_by)

    call dfftw_destroy_plan(plan_fxb)
    call dfftw_destroy_plan(plan_bxb)
    call dfftw_destroy_plan(plan_fyb)
    call dfftw_destroy_plan(plan_byb)

    return
  end subroutine finalize_fft_engine

  !------------------------------------------------------------------------------
  !! subroutine: compute multiple 1d fft in y
  !------------------------------------------------------------------------------
  !!
  !! - last modified: fabien margairaz ( fabien.margairaz@gmail.com ), 20/05/2014
  !!
  !! - description:
  !!  - c2c transform, multiple 1D FFTs in y direction
  !!
  !------------------------------------------------------------------------------
  subroutine c2c_1d_y(inout,plan1,decomp)

    implicit none

    complex(mytype), dimension(:,:,:), intent(INOUT) :: inout
    integer*8, intent(IN) :: plan1
    TYPE(DECOMP_INFO), intent(IN) :: decomp

    complex(mytype), dimension(decomp%ysz(2)) :: tmp
    integer :: i,k

    !$OMP PARALLEL DO PRIVATE(TMP)
    do k=1,decomp%ysz(3)
       do i=1,decomp%ysz(1)
          tmp=inout(i,:,k)
          call dfftw_execute_dft(plan1, tmp, tmp)
          inout(i,:,k)=tmp
       enddo
    enddo
    !$OMP END PARALLEL DO

    return
  end subroutine c2c_1d_y

  !------------------------------------------------------------------------------
  !! subroutine: compute multiple 1d fft in x
  !------------------------------------------------------------------------------
  !!
  !! - last modified: fabien margairaz ( fabien.margairaz@gmail.com ), 20/05/2014
  !!
  !! - description:
  !!  - r2c transform, multiple 1D FFTs in x direction
  !!
  !------------------------------------------------------------------------------
  subroutine r2c_1d_x(input,output,plan1,decomp)

    implicit none

    real(mytype), dimension(:,:,:), intent(IN)  ::  input
    complex(mytype), dimension(:,:,:), intent(OUT) :: output
    integer*8, intent(IN) :: plan1
    TYPE(DECOMP_INFO), intent(IN) :: decomp

    integer :: k,j

    !$OMP PARALLEL DO
    do k=1,decomp%xsz(3)
       do j=1,decomp%xsz(2)
          call dfftw_execute_dft_r2c(plan1,input(:,j,k),output(:,j,k))
       enddo
    enddo
    !$OMP END PARALLEL DO

    return
  end subroutine r2c_1d_x

  !------------------------------------------------------------------------------
  !! subroutine: compute multiple 1d fft in x
  !------------------------------------------------------------------------------
  !!
  !! - last modified: fabien margairaz ( fabien.margairaz@gmail.com ), 20/05/2014
  !!
  !! - description:
  !!  - c2r transform, multiple 1D FFTs in x direction
  !!
  !------------------------------------------------------------------------------
  subroutine c2r_1d_x(input,output,plan1,decomp)

    implicit none

    complex(mytype), dimension(:,:,:), intent(IN)  ::  input
    real(mytype), dimension(:,:,:), intent(OUT) :: output
    integer*8, intent(IN) :: plan1
    TYPE(DECOMP_INFO), intent(IN) :: decomp

    integer :: k,j

    !$OMP PARALLEL DO
    do k=1,decomp%xsz(3)
       do j=1,decomp%xsz(2)
          call dfftw_execute_dft_c2r(plan1,input(:,j,k),output(:,j,k))
       enddo
    enddo
    !$OMP END PARALLEL DO

    return

  end subroutine c2r_1d_x

  !------------------------------------------------------------------------------
  !! subroutine: compute multiple 2d FFT
  !------------------------------------------------------------------------------
  !!
  !! - last modified: fabien margairaz ( fabien.margairaz@gmail.com ), 20/05/2014
  !!
  !! - description:
  !!  - forward 2d FFT based on X-prencil
  !!  - input: X-prencil/physical space
  !!  - output: Y-prencil/specrtal space
  !!
  !------------------------------------------------------------------------------
  subroutine fft_2d_r2c(in_r,out_c,GFLAG)
    implicit none

    real(mytype), dimension(:,:,:), intent(IN) :: in_r
    complex(mytype), dimension(:,:,:), intent(OUT) :: out_c
    logical,intent(IN) :: GFLAG

    if(GFLAG)then
       ! ===== 1D FFTs in X =====
       call r2c_1d_x(in_r,wk_4x,plan_fx,spg)

       ! ===== Swap X --> Y; 1D FFTs in Y =====
       if (dims(1)>1) then
          call transpose_x_to_y(wk_4x,out_c,spg)
          call c2c_1d_y(out_c,plan_fy,spg)
       else
          out_c = wk_4x
          call c2c_1d_y(out_c,plan_fy,spg)
       end if
    else
        ! ===== 1D FFTs in X =====
       call r2c_1d_x(in_r,wk_4x(:,:,1:sp%xsz(3)),plan_fx,sp)

       ! ===== Swap X --> Y; 1D FFTs in Y =====
       if (dims(1)>1) then
          call transpose_x_to_y(wk_4x(:,:,1:sp%xsz(3)),out_c,sp)
          call c2c_1d_y(out_c,plan_fy,sp)
       else
          out_c = wk_4x
          call c2c_1d_y(out_c,plan_fy,sp)
       end if
    endif

    return
  end subroutine fft_2d_r2c

  !------------------------------------------------------------------------------
  !! subroutine: compute multiple 2d FFT
  !------------------------------------------------------------------------------
  !!
  !! - last modified: fabien margairaz ( fabien.margairaz@gmail.com ), 20/05/2014
  !!
  !! - description:
  !!  - backward 2d FFT based on Y-prencil
  !!  - input: Y-prencil/spectral space
  !!  - output: X-prencil/physical space
  !!
  !------------------------------------------------------------------------------
  subroutine fft_2d_c2r(in_c,out_r,GFLAG)
    implicit none

    complex(mytype), dimension(:,:,:), intent(INOUT) :: in_c
    real(mytype), dimension(:,:,:), intent(OUT) :: out_r
    logical,intent(IN) :: GFLAG

    if(GFLAG)then
       ! ===== 1D FFTs in Y =====
       call c2c_1d_y(in_c,plan_by,spg)

       ! ===== Swap Y --> X; 1D FFTs in X =====
       if (dims(1)>1) then
          call transpose_y_to_x(in_c,wk_4x,spg)
          call c2r_1d_x(wk_4x,out_r,plan_bx,spg)
       else
          call c2r_1d_x(in_c,out_r,plan_bx,spg)
       end if
    else
       ! ===== 1D FFTs in Y =====
       call c2c_1d_y(in_c,plan_by,sp)

       ! ===== Swap Y --> X; 1D FFTs in X =====
       if (dims(1)>1) then
          call transpose_y_to_x(in_c,wk_4x(:,:,1:sp%xsz(3)),sp)
          call c2r_1d_x(wk_4x(:,:,1:sp%xsz(3)),out_r,plan_bx,sp)
       else
          call c2r_1d_x(in_c,out_r,plan_bx,sp)
       end if
    endif
    return
  end subroutine fft_2d_c2r

  !------------------------------------------------------------------------------
  !! subroutine: compute multiple 2d FFT for big
  !------------------------------------------------------------------------------
  !!
  !! - last modified: fabien margairaz ( fabien.margairaz@gmail.com ), 20/05/2014
  !!
  !! - description:
  !!  - forward 2d FFT based on X-prencil
  !!  - input: X-prencil/physical space
  !!  - output: Y-prencil/specrtal space
  !!
  !------------------------------------------------------------------------------
  subroutine fft_2d_r2c_big(in_r,out_c,GFLAG)
    implicit none

    real(mytype), dimension(:,:,:), intent(IN) :: in_r
    complex(mytype), dimension(:,:,:), intent(OUT) :: out_c
    logical,intent(IN) :: GFLAG

    if(GFLAG)then
       ! ===== 1D FFTs in X =====
       call r2c_1d_x(in_r,wk_4xb,plan_fxb,spgb)

       ! ===== Swap X --> Y; 1D FFTs in Y =====
       if (dims(1)>1) then
          call transpose_x_to_y(wk_4xb,out_c,spgb)
          call c2c_1d_y(out_c,plan_fyb,spgb)
       else
          out_c = wk_4xb
          call c2c_1d_y(out_c,plan_fyb,spgb)
       end if
    else
        ! ===== 1D FFTs in X =====
       call r2c_1d_x(in_r,wk_4xb(:,:,1:sp%xsz(3)),plan_fxb,spb)

       ! ===== Swap X --> Y; 1D FFTs in Y =====
       if (dims(1)>1) then
          call transpose_x_to_y(wk_4xb(:,:,1:sp%xsz(3)),out_c,spb)
          call c2c_1d_y(out_c,plan_fyb,spb)
       else
          out_c = wk_4xb
          call c2c_1d_y(out_c,plan_fyb,spb)
       end if
    endif

    return
  end subroutine fft_2d_r2c_big

  !------------------------------------------------------------------------------
  !! subroutine: compute multiple 2d FFT for big
  !------------------------------------------------------------------------------
  !!
  !! - last modified: fabien margairaz ( fabien.margairaz@gmail.com ), 20/05/2014
  !!
  !! - description:
  !!  - backward 2d FFT based on Y-prencil
  !!  - input: Y-prencil/spectral space
  !!  - output: X-prencil/physical space
  !!
  !------------------------------------------------------------------------------
  subroutine fft_2d_c2r_big(in_c,out_r,GFLAG)
    implicit none

    complex(mytype), dimension(:,:,:), intent(INOUT) :: in_c
    real(mytype), dimension(:,:,:), intent(OUT) :: out_r
    logical,intent(IN) :: GFLAG

    if(GFLAG)then
       ! ===== 1D FFTs in Y =====
       call c2c_1d_y(in_c,plan_byb,spgb)

       ! ===== Swap Y --> X; 1D FFTs in X =====
       if (dims(1)>1) then
          call transpose_y_to_x(in_c,wk_4xb,spgb)
          call c2r_1d_x(wk_4x,out_r,plan_bxb,spgb)
       else
          call c2r_1d_x(in_c,out_r,plan_bxb,spgb)
       end if
    else
       ! ===== 1D FFTs in Y =====
       call c2c_1d_y(in_c,plan_byb,spb)

       ! ===== Swap Y --> X; 1D FFTs in X =====
       if (dims(1)>1) then
          call transpose_y_to_x(in_c,wk_4xb(:,:,1:sp%xsz(3)),spb)
          call c2r_1d_x(wk_4xb(:,:,1:sp%xsz(3)),out_r,plan_bxb,spb)
       else
          call c2r_1d_x(in_c,out_r,plan_bxb,spb)
       end if
    endif
    return
  end subroutine fft_2d_c2r_big

end module decomp_2d_fft_2d