      MODULE m_grdrsvac
      use m_juDFT
c----------------------------------------------------------------------
c     for a function defined on a vacuum layer
c     the in-plane derivatives are evaluated in real space
c
c     based on 'rhzgrd' coded by t.asada. june,1995.
c---------------------------------------------------------------------
      CONTAINS
      SUBROUTINE grdrsvac(
     >                    ro,bmat,xmax1,xmax2,ndvgrd,
     <                    dxro,dyro)

c----------------------------------------------------------------------
c
c input:
c  ro(0:xmax1*xmax2-1)
c   any quantity stored in the 2-dim box (xmax1 x xmax2)
c  bmat
c   bravais matrix of reciprocal space
c  ndvgrd
c   number of points used when calculating derivative (3 <= ndvgrd <= 6)
c
c output:
c  dxro(0:xmax1*xmax2-1) , dxro(0:xmax1*xmax2-1)
c   (d ro / d x) , (d ro /d y)  in non-internal coordinates
c
c----------------------------------------------------------------------
c
      USE m_constants, ONLY : pimach
      IMPLICIT NONE
c     ..
c     .. Scalar arguments ..
      INTEGER, INTENT (IN) :: xmax1,xmax2,ndvgrd
c     ..
c     .. Array arguments ..
      REAL,    INTENT (IN)  :: ro(0:xmax1*xmax2-1)
      REAL,    INTENT (IN)  :: bmat(3,3)
c     ..
c     .. Array output ..
      REAL,    INTENT (OUT) :: dxro(0:xmax1*xmax2-1)
      REAL,    INTENT (OUT) :: dyro(0:xmax1*xmax2-1)
c     ..
c     .. Locals ..
      INTEGER :: xmax(2)
      INTEGER :: direction,xyz(2),x1,x2,i,ii(-3:2)
      REAL    :: pi
      REAL    :: dx
      REAL    :: drointern(0:xmax1*xmax2-1,2)

      pi = pimach()

      xmax(1)= xmax1
      xmax(2)= xmax2
      DO i=1,2
        IF ( xmax(i) < 3 ) THEN
           CALL juDFT_error("grid to small",calledby="grdrsvac")
        END IF
      END DO
      IF ( (ndvgrd < 3) .or. (ndvgrd > 6) ) THEN
         CALL juDFT_error("ndvgrd notin [3,6]",calledby="grdrsvac")
      ENDIF

      DO direction=1,2

        dx= 1./REAL(xmax(direction))

        DO x1=0,xmax(1)-1
          DO x2=0,xmax(2)-1

            DO i= -3,2
              xyz(1)= x1
              xyz(2)= x2
              xyz(direction)= xyz(direction)+i
              ! make use of periodic boundary cond. in interstitial:
              IF ( xyz(direction) < 0 ) THEN
                xyz(direction)= xyz(direction)+xmax(direction)
              END IF
              IF ( xyz(direction) >= xmax(direction) ) THEN
                xyz(direction)= xyz(direction)-xmax(direction)
              END IF
              ! find coordinates in 1-dim array ro:
              ii(i)= xyz(2)*xmax(1) + xyz(1)
            END DO

            IF (ndvgrd.EQ.3) THEN
              drointern(ii(0),direction)=
     &          df3( ro(ii(-1)),
     &               ro(ii(0)),ro(ii(1)), dx)
            ELSEIF (ndvgrd.EQ.4) THEN
              drointern(ii(0),direction)=
     &          df4( ro(ii(-1)),
     &               ro(ii(0)),ro(ii(1)),ro(ii(2)), dx)
            ELSEIF (ndvgrd.EQ.5) THEN
              drointern(ii(0),direction)=
     &           df5( ro(ii(-2)),ro(ii(-1)),
     &                ro(ii(0)),ro(ii(1)),ro(ii(2)), dx)
            ELSEIF (ndvgrd.EQ.6) THEN
              drointern(ii(0),direction)=
     &          df6( ro(ii(-3)),ro(ii(-2)),ro(ii(-1)),
     &               ro(ii(0)),ro(ii(1)),ro(ii(2)), dx)
            ENDIF

          END DO
        END DO

      END DO

      DO i=0,xmax(1)*xmax(2)-1

        dxro(i)=   bmat(1,1)*drointern(i,1)
     &           + bmat(2,1)*drointern(i,2)
        dxro(i)= dxro(i)/(2.*pi)
        dyro(i)=   bmat(1,2)*drointern(i,1)
     &           + bmat(2,2)*drointern(i,2)
        dyro(i)= dyro(i)/(2.*pi)

      END DO

      END SUBROUTINE grdrsvac
!--------------------------------------------------------------------
! Functions: formulae for 1st deriv.:
!
      REAL FUNCTION df3(g1,f0,f1,d)             ! three point formula
        REAL g1,f0,f1,d
        df3 = (-1*g1-0*f0+f1)/ (2*d)
      END FUNCTION df3

      REAL FUNCTION df4(g1,f0,f1,f2,d)          ! four point formula
        REAL g1,f0,f1,f2,d
        df4 = (-2*g1-3*f0+6*f1-f2)/ (6*d)
      END FUNCTION df4

      REAL FUNCTION df5(g2,g1,f0,f1,f2,d)       ! five point formula
        REAL g2,g1,f0,f1,f2,d
        df5 = (2*g2-16*g1-0*f0+16*f1-2*f2)/ (24*d)
      END FUNCTION df5

      REAL FUNCTION df6(g3,g2,g1,f0,f1,f2,d)   ! six point formula
        REAL g3,g2,g1,f0,f1,f2,d
        df6 = (-4*g3+30*g2-120*g1+40*f0+60*f1-6*f2)/ (120*d)
      END FUNCTION df6

!----------------------------------------------------------------------
      END MODULE m_grdrsvac


      module rjk

      implicit none (type, external)

      contains

      SUBROUTINE RKBESL(X,ALPHA,NB,IZE,BK,NCALC)
C-------------------------------------------------------------------
C
C  This FORTRAN 77 routine calculates modified Bessel functions
C  of the second kind, K SUB(N+ALPHA) (X), for non-negative
C  argument X, and non-negative order N+ALPHA, with or without
C  exponential scaling.
C
C  Explanation of variables in the calling sequence
C
C  Description of output values ..
C
C X     - Working precision non-negative real argument for which
C         K's or exponentially scaled K's (K*EXP(X))
C         are to be calculated.  If K's are to be calculated,
C         X must not be greater than XMAX (see below).
C ALPHA - Working precision fractional part of order for which
C         K's or exponentially scaled K's (K*EXP(X)) are
C         to be calculated.  0 .LE. ALPHA .LT. 1.0.
C NB    - Integer number of functions to be calculated, NB .GT. 0.
C         The first function calculated is of order ALPHA, and the
C         last is of order (NB - 1 + ALPHA).
C IZE   - Integer type.  IZE = 1 if unscaled K's are to be calculated,
C         and 2 if exponentially scaled K's are to be calculated.
C BK    - Working precision output vector of length NB.  If the
C         routine terminates normally (NCALC=NB), the vector BK
C         contains the functions K(ALPHA,X), ... , K(NB-1+ALPHA,X),
C         or the corresponding exponentially scaled functions.
C         If (0 .LT. NCALC .LT. NB), BK(I) contains correct function
C         values for I .LE. NCALC, and contains the ratios
C         K(ALPHA+I-1,X)/K(ALPHA+I-2,X) for the rest of the array.
C NCALC - Integer output variable indicating possible errors.
C         Before using the vector BK, the user should check that
C         NCALC=NB, i.e., all orders have been calculated to
C         the desired accuracy.  See error returns below.
C
C
C*******************************************************************
C*******************************************************************
C
C Explanation of machine-dependent constants
C
C   beta   = Radix for the floating-point system
C   minexp = Smallest representable power of beta
C   maxexp = Smallest power of beta that overflows
C   EPS    = The smallest positive floating-point number such that
C            1.0+EPS .GT. 1.0
C   XMAX   = Upper limit on the magnitude of X when IZE=1;  Solution
C            to equation:
C               W(X) * (1-1/8X+9/128X**2) = beta**minexp
C            where  W(X) = EXP(-X)*SQRT(PI/2X)
C   SQXMIN = Square root of beta**minexp
C   XINF   = Largest positive machine number; approximately
C            beta**maxexp
C   XMIN   = Smallest positive machine number; approximately
C            beta**minexp
C
C
C     Approximate values for some important machines are:
C
C                          beta       minexp      maxexp      EPS
C
C  CRAY-1        (S.P.)      2        -8193        8191    7.11E-15
C  Cyber 180/185
C    under NOS   (S.P.)      2         -975        1070    3.55E-15
C  IEEE (IBM/XT,
C    SUN, etc.)  (S.P.)      2         -126         128    1.19E-7
C  IEEE (IBM/XT,
C    SUN, etc.)  (D.P.)      2        -1022        1024    2.22D-16
C  IBM 3033      (D.P.)     16          -65          63    2.22D-16
C  VAX           (S.P.)      2         -128         127    5.96E-8
C  VAX D-Format  (D.P.)      2         -128         127    1.39D-17
C  VAX G-Format  (D.P.)      2        -1024        1023    1.11D-16
C
C
C                         SQXMIN       XINF        XMIN      XMAX
C
C CRAY-1        (S.P.)  6.77E-1234  5.45E+2465  4.59E-2467 5674.858
C Cyber 180/855
C   under NOS   (S.P.)  1.77E-147   1.26E+322   3.14E-294   672.788
C IEEE (IBM/XT,
C   SUN, etc.)  (S.P.)  1.08E-19    3.40E+38    1.18E-38     85.337
C IEEE (IBM/XT,
C   SUN, etc.)  (D.P.)  1.49D-154   1.79D+308   2.23D-308   705.342
C IBM 3033      (D.P.)  7.35D-40    7.23D+75    5.40D-79    177.852
C VAX           (S.P.)  5.42E-20    1.70E+38    2.94E-39     86.715
C VAX D-Format  (D.P.)  5.42D-20    1.70D+38    2.94D-39     86.715
C VAX G-Format  (D.P.)  7.46D-155   8.98D+307   5.57D-309   706.728
C
C*******************************************************************
C*******************************************************************
C
C Error returns
C
C  In case of an error, NCALC .NE. NB, and not all K's are
C  calculated to the desired accuracy.
C
C  NCALC .LT. -1:  An argument is out of range. For example,
C       NB .LE. 0, IZE is not 1 or 2, or IZE=1 and ABS(X) .GE.
C       XMAX.  In this case, the B-vector is not calculated,
C       and NCALC is set to MIN0(NB,0)-2  so that NCALC .NE. NB.
C  NCALC = -1:  Either  K(ALPHA,X) .GE. XINF  or
C       K(ALPHA+NB-1,X)/K(ALPHA+NB-2,X) .GE. XINF.  In this case,
C       the B-vector is not calculated.  Note that again
C       NCALC .NE. NB.
C
C  0 .LT. NCALC .LT. NB: Not all requested function values could
C       be calculated accurately.  BK(I) contains correct function
C       values for I .LE. NCALC, and contains the ratios
C       K(ALPHA+I-1,X)/K(ALPHA+I-2,X) for the rest of the array.
C
C
C Intrinsic functions required are:
C
C     ABS, AINT, EXP, INT, LOG, MAX, MIN, SINH, SQRT
C
C
C Acknowledgement
C
C  This program is based on a program written by J. B. Campbell
C  (2) that computes values of the Bessel functions K of real
C  argument and real order.  Modifications include the addition
C  of non-scaled functions, parameterization of machine
C  dependencies, and the use of more accurate approximations
C  for SINH and SIN.
C
C References: "On Temme's Algorithm for the Modified Bessel
C              Functions of the Third Kind," Campbell, J. B.,
C              TOMS 6(4), Dec. 1980, pp. 581-586.
C
C             "A FORTRAN IV Subroutine for the Modified Bessel
C              Functions of the Third Kind of Real Order and Real
C              Argument," Campbell, J. B., Report NRC/ERB-925,
C              National Research Council, Canada.
C
C  Latest modification: May 30, 1989
C
C  Modified by: W. J. Cody and L. Stoltz
C               Applied Mathematics Division
C               Argonne National Laboratory
C               Argonne, IL  60439
C
C-------------------------------------------------------------------
      INTEGER I,IEND,ITEMP,IZE,J,K,M,MPLUS1,NB,NCALC
CS    REAL
      DOUBLE PRECISION
     1    A,ALPHA,BLPHA,BK,BK1,BK2,C,D,DM,D1,D2,D3,ENU,EPS,ESTF,ESTM,
     2    EX,FOUR,F0,F1,F2,HALF,ONE,P,P0,Q,Q0,R,RATIO,S,SQXMIN,T,TINYX,
     3    TWO,TWONU,TWOX,T1,T2,WMINF,X,XINF,XMAX,XMIN,X2BY4,ZERO
      DIMENSION BK(1),P(8),Q(7),R(5),S(4),T(6),ESTM(6),ESTF(7)
C---------------------------------------------------------------------
C  Mathematical constants
C    A = LOG(2.D0) - Euler's constant
C    D = SQRT(2.D0/PI)
C---------------------------------------------------------------------
CS    DATA HALF,ONE,TWO,ZERO/0.5E0,1.0E0,2.0E0,0.0E0/
CS    DATA FOUR,TINYX/4.0E0,1.0E-10/
CS    DATA A/ 0.11593151565841244881E0/,D/0.797884560802865364E0/
CD    DATA HALF,ONE,TWO,ZERO/0.5D0,1.0D0,2.0D0,0.0D0/
CD    DATA FOUR,TINYX/4.0D0,1.0D-10/
CD    DATA A/ 0.11593151565841244881D0/,D/0.797884560802865364D0/
C---------------------------------------------------------------------
C  Machine dependent parameters
C---------------------------------------------------------------------
CS    DATA EPS/1.19E-7/,SQXMIN/1.08E-19/,XINF/3.40E+38/
CS    DATA XMIN/1.18E-38/,XMAX/85.337E0/
CD    DATA EPS/2.22D-16/,SQXMIN/1.49D-154/,XINF/1.79D+308/
CD    DATA XMIN/2.23D-308/,XMAX/705.342D0/
C---------------------------------------------------------------------
C  P, Q - Approximation for LOG(GAMMA(1+ALPHA))/ALPHA
C                                         + Euler's constant
C         Coefficients converted from hex to decimal and modified
C         by W. J. Cody, 2/26/82
C  R, S - Approximation for (1-ALPHA*PI/SIN(ALPHA*PI))/(2.D0*ALPHA)
C  T    - Approximation for SINH(Y)/Y
C---------------------------------------------------------------------
CS    DATA P/ 0.805629875690432845E00,    0.204045500205365151E02,
CS   1        0.157705605106676174E03,    0.536671116469207504E03,
CS   2        0.900382759291288778E03,    0.730923886650660393E03,
CS   3        0.229299301509425145E03,    0.822467033424113231E00/
CS    DATA Q/ 0.294601986247850434E02,    0.277577868510221208E03,
CS   1        0.120670325591027438E04,    0.276291444159791519E04,
CS   2        0.344374050506564618E04,    0.221063190113378647E04,
CS   3        0.572267338359892221E03/
CS    DATA R/-0.48672575865218401848E+0,  0.13079485869097804016E+2,
CS   1       -0.10196490580880537526E+3,  0.34765409106507813131E+3,
CS   2        0.34958981245219347820E-3/
CS    DATA S/-0.25579105509976461286E+2,  0.21257260432226544008E+3,
CS   1       -0.61069018684944109624E+3,  0.42269668805777760407E+3/
CS    DATA T/ 0.16125990452916363814E-9, 0.25051878502858255354E-7,
CS   1        0.27557319615147964774E-5, 0.19841269840928373686E-3,
CS   2        0.83333333333334751799E-2, 0.16666666666666666446E+0/
CS    DATA ESTM/5.20583E1, 5.7607E0, 2.7782E0, 1.44303E1, 1.853004E2,
CS   1          9.3715E0/
CS    DATA ESTF/4.18341E1, 7.1075E0, 6.4306E0, 4.25110E1, 1.35633E0,
CS   1          8.45096E1, 2.0E1/
CD    DATA P/ 0.805629875690432845D00,    0.204045500205365151D02,
CD   1        0.157705605106676174D03,    0.536671116469207504D03,
CD   2        0.900382759291288778D03,    0.730923886650660393D03,
CD   3        0.229299301509425145D03,    0.822467033424113231D00/
CD    DATA Q/ 0.294601986247850434D02,    0.277577868510221208D03,
CD   1        0.120670325591027438D04,    0.276291444159791519D04,
CD   2        0.344374050506564618D04,    0.221063190113378647D04,
CD   3        0.572267338359892221D03/
CD    DATA R/-0.48672575865218401848D+0,  0.13079485869097804016D+2,
CD   1       -0.10196490580880537526D+3,  0.34765409106507813131D+3,
CD   2        0.34958981245219347820D-3/
CD    DATA S/-0.25579105509976461286D+2,  0.21257260432226544008D+3,
CD   1       -0.61069018684944109624D+3,  0.42269668805777760407D+3/
CD    DATA T/ 0.16125990452916363814D-9, 0.25051878502858255354D-7,
CD   1        0.27557319615147964774D-5, 0.19841269840928373686D-3,
CD   2        0.83333333333334751799D-2, 0.16666666666666666446D+0/
CD    DATA ESTM/5.20583D1, 5.7607D0, 2.7782D0, 1.44303D1, 1.853004D2,
CD   1          9.3715D0/
CD    DATA ESTF/4.18341D1, 7.1075D0, 6.4306D0, 4.25110D1, 1.35633D0,
CD   1          8.45096D1, 2.0D1/
C---------------------------------------------------------------------
      EX = X
      ENU = ALPHA
      NCALC = MIN(NB,0)-2
      IF ((NB .GT. 0) .AND. ((ENU .GE. ZERO) .AND. (ENU .LT. ONE))
     1     .AND. ((IZE .GE. 1) .AND. (IZE .LE. 2)) .AND.
     2     ((IZE .NE. 1) .OR. (EX .LE. XMAX)) .AND.
     3     (EX .GT. ZERO))  THEN
            K = 0
            IF (ENU .LT. SQXMIN) ENU = ZERO
            IF (ENU .GT. HALF) THEN
                  K = 1
                  ENU = ENU - ONE
            END IF
            TWONU = ENU+ENU
            IEND = NB+K-1
            C = ENU*ENU
            D3 = -C
            IF (EX .LE. ONE) THEN
C---------------------------------------------------------------------
C  Calculation of P0 = GAMMA(1+ALPHA) * (2/X)**ALPHA
C                 Q0 = GAMMA(1-ALPHA) * (X/2)**ALPHA
C---------------------------------------------------------------------
                  D1 = ZERO
                  D2 = P(1)
                  T1 = ONE
                  T2 = Q(1)
                  DO 10 I = 2,7,2
                     D1 = C*D1+P(I)
                     D2 = C*D2+P(I+1)
                     T1 = C*T1+Q(I)
                     T2 = C*T2+Q(I+1)
   10             CONTINUE
                  D1 = ENU*D1
                  T1 = ENU*T1
                  F1 = LOG(EX)
                  F0 = A+ENU*(P(8)-ENU*(D1+D2)/(T1+T2))-F1
                  Q0 = EXP(-ENU*(A-ENU*(P(8)+ENU*(D1-D2)/(T1-T2))-F1))
                  F1 = ENU*F0
                  P0 = EXP(F1)
C---------------------------------------------------------------------
C  Calculation of F0 =
C---------------------------------------------------------------------
                  D1 = R(5)
                  T1 = ONE
                  DO 20 I = 1,4
                     D1 = C*D1+R(I)
                     T1 = C*T1+S(I)
   20             CONTINUE
                  IF (ABS(F1) .LE. HALF) THEN
                        F1 = F1*F1
                        D2 = ZERO
                        DO 30 I = 1,6
                           D2 = F1*D2+T(I)
   30                   CONTINUE
                        D2 = F0+F0*F1*D2
                     ELSE
                        D2 = SINH(F1)/ENU
                  END IF
                  F0 = D2-ENU*D1/(T1*P0)
                  IF (EX .LE. TINYX) THEN
C--------------------------------------------------------------------
C  X.LE.1.0E-10
C  Calculation of K(ALPHA,X) and X*K(ALPHA+1,X)/K(ALPHA,X)
C--------------------------------------------------------------------
                        BK(1) = F0+EX*F0
                        IF (IZE .EQ. 1) BK(1) = BK(1)-EX*BK(1)
                        RATIO = P0/F0
                        C = EX*XINF
                        IF (K .NE. 0) THEN
C--------------------------------------------------------------------
C  Calculation of K(ALPHA,X) and X*K(ALPHA+1,X)/K(ALPHA,X),
C  ALPHA .GE. 1/2
C--------------------------------------------------------------------
                              NCALC = -1
                              IF (BK(1) .GE. C/RATIO) GO TO 500
                              BK(1) = RATIO*BK(1)/EX
                              TWONU = TWONU+TWO
                              RATIO = TWONU
                        END IF
                        NCALC = 1
                        IF (NB .EQ. 1) GO TO 500
C--------------------------------------------------------------------
C  Calculate  K(ALPHA+L,X)/K(ALPHA+L-1,X),  L  =  1, 2, ... , NB-1
C--------------------------------------------------------------------
                        NCALC = -1
                        DO 80 I = 2,NB
                           IF (RATIO .GE. C) GO TO 500
                           BK(I) = RATIO/EX
                           TWONU = TWONU+TWO
                           RATIO = TWONU
   80                   CONTINUE
                        NCALC = 1
                        GO TO 420
                     ELSE
C--------------------------------------------------------------------
C  1.0E-10 .LT. X .LE. 1.0
C--------------------------------------------------------------------
                        C = ONE
                        X2BY4 = EX*EX/FOUR
                        P0 = HALF*P0
                        Q0 = HALF*Q0
                        D1 = -ONE
                        D2 = ZERO
                        BK1 = ZERO
                        BK2 = ZERO
                        F1 = F0
                        F2 = P0
  100                   D1 = D1+TWO
                        D2 = D2+ONE
                        D3 = D1+D3
                        C = X2BY4*C/D2
                        F0 = (D2*F0+P0+Q0)/D3
                        P0 = P0/(D2-ENU)
                        Q0 = Q0/(D2+ENU)
                        T1 = C*F0
                        T2 = C*(P0-D2*F0)
                        BK1 = BK1+T1
                        BK2 = BK2+T2
                        IF ((ABS(T1/(F1+BK1)) .GT. EPS) .OR.
     1                     (ABS(T2/(F2+BK2)) .GT. EPS))  GO TO 100
                        BK1 = F1+BK1
                        BK2 = TWO*(F2+BK2)/EX
                        IF (IZE .EQ. 2) THEN
                              D1 = EXP(EX)
                              BK1 = BK1*D1
                              BK2 = BK2*D1
                        END IF
                        WMINF = ESTF(1)*EX+ESTF(2)
                  END IF
               ELSE IF (EPS*EX .GT. ONE) THEN
C--------------------------------------------------------------------
C  X .GT. ONE/EPS
C--------------------------------------------------------------------
                  NCALC = NB
                  BK1 = ONE / (D*SQRT(EX))
                  DO 110 I = 1, NB
                     BK(I) = BK1
  110             CONTINUE
                  GO TO 500
               ELSE
C--------------------------------------------------------------------
C  X .GT. 1.0
C--------------------------------------------------------------------
                  TWOX = EX+EX
                  BLPHA = ZERO
                  RATIO = ZERO
                  IF (EX .LE. FOUR) THEN
C--------------------------------------------------------------------
C  Calculation of K(ALPHA+1,X)/K(ALPHA,X),  1.0 .LE. X .LE. 4.0
C--------------------------------------------------------------------
                        D2 = AINT(ESTM(1)/EX+ESTM(2))
                        M = INT(D2)
                        D1 = D2+D2
                        D2 = D2-HALF
                        D2 = D2*D2
                        DO 120 I = 2,M
                           D1 = D1-TWO
                           D2 = D2-D1
                           RATIO = (D3+D2)/(TWOX+D1-RATIO)
  120                   CONTINUE
C--------------------------------------------------------------------
C  Calculation of I(|ALPHA|,X) and I(|ALPHA|+1,X) by backward
C    recurrence and K(ALPHA,X) from the wronskian
C--------------------------------------------------------------------
                        D2 = AINT(ESTM(3)*EX+ESTM(4))
                        M = INT(D2)
                        C = ABS(ENU)
                        D3 = C+C
                        D1 = D3-ONE
                        F1 = XMIN
                        F0 = (TWO*(C+D2)/EX+HALF*EX/(C+D2+ONE))*XMIN
                        DO 130 I = 3,M
                           D2 = D2-ONE
                           F2 = (D3+D2+D2)*F0
                           BLPHA = (ONE+D1/D2)*(F2+BLPHA)
                           F2 = F2/EX+F1
                           F1 = F0
                           F0 = F2
  130                   CONTINUE
                        F1 = (D3+TWO)*F0/EX+F1
                        D1 = ZERO
                        T1 = ONE
                        DO 140 I = 1,7
                           D1 = C*D1+P(I)
                           T1 = C*T1+Q(I)
  140                   CONTINUE
                        P0 = EXP(C*(A+C*(P(8)-C*D1/T1)-LOG(EX)))/EX
                        F2 = (C+HALF-RATIO)*F1/EX
                        BK1 = P0+(D3*F0-F2+F0+BLPHA)/(F2+F1+F0)*P0
                        IF (IZE .EQ. 1) BK1 = BK1*EXP(-EX)
                        WMINF = ESTF(3)*EX+ESTF(4)
                     ELSE
C--------------------------------------------------------------------
C  Calculation of K(ALPHA,X) and K(ALPHA+1,X)/K(ALPHA,X), by backward
C  recurrence, for  X .GT. 4.0
C--------------------------------------------------------------------
                        DM = AINT(ESTM(5)/EX+ESTM(6))
                        M = INT(DM)
                        D2 = DM-HALF
                        D2 = D2*D2
                        D1 = DM+DM
                        DO 160 I = 2,M
                           DM = DM-ONE
                           D1 = D1-TWO
                           D2 = D2-D1
                           RATIO = (D3+D2)/(TWOX+D1-RATIO)
                           BLPHA = (RATIO+RATIO*BLPHA)/DM
  160                   CONTINUE
                        BK1 = ONE/((D+D*BLPHA)*SQRT(EX))
                        IF (IZE .EQ. 1) BK1 = BK1*EXP(-EX)
                        WMINF = ESTF(5)*(EX-ABS(EX-ESTF(7)))+ESTF(6)
                  END IF
C--------------------------------------------------------------------
C  Calculation of K(ALPHA+1,X) from K(ALPHA,X) and
C    K(ALPHA+1,X)/K(ALPHA,X)
C--------------------------------------------------------------------
                  BK2 = BK1+BK1*(ENU+HALF-RATIO)/EX
            END IF
C--------------------------------------------------------------------
C  Calculation of 'NCALC', K(ALPHA+I,X), I  =  0, 1, ... , NCALC-1,
C  K(ALPHA+I,X)/K(ALPHA+I-1,X), I  =  NCALC, NCALC+1, ... , NB-1
C--------------------------------------------------------------------
            NCALC = NB
            BK(1) = BK1
            IF (IEND .EQ. 0) GO TO 500
            J = 2-K
            IF (J .GT. 0) BK(J) = BK2
            IF (IEND .EQ. 1) GO TO 500
            M = MIN(INT(WMINF-ENU),IEND)
            DO 190 I = 2,M
               T1 = BK1
               BK1 = BK2
               TWONU = TWONU+TWO
               IF (EX .LT. ONE) THEN
                     IF (BK1 .GE. (XINF/TWONU)*EX) GO TO 195
                     GO TO 187
                  ELSE
                     IF (BK1/EX .GE. XINF/TWONU) GO TO 195
               END IF
  187          CONTINUE
               BK2 = TWONU/EX*BK1+T1
               ITEMP = I
               J = J+1
               IF (J .GT. 0) BK(J) = BK2
  190       CONTINUE
  195       M = ITEMP
            IF (M .EQ. IEND) GO TO 500
            RATIO = BK2/BK1
            MPLUS1 = M+1
            NCALC = -1
            DO 410 I = MPLUS1,IEND
               TWONU = TWONU+TWO
               RATIO = TWONU/EX+ONE/RATIO
               J = J+1
               IF (J .GT. 1) THEN
                     BK(J) = RATIO
                  ELSE
                     IF (BK2 .GE. XINF/RATIO) GO TO 500
                     BK2 = RATIO*BK2
               END IF
  410       CONTINUE
            NCALC = MAX(MPLUS1-K,1)
            IF (NCALC .EQ. 1) BK(1) = BK2
            IF (NB .EQ. 1) GO TO 500
  420       J = NCALC+1
            DO 430 I = J,NB
               IF (BK(NCALC) .GE. XINF/BK(I)) GO TO 500
               BK(I) = BK(NCALC)*BK(I)
               NCALC = I
  430       CONTINUE
      END IF
  500 RETURN
C---------- Last line of RKBESL ----------
      END subroutine rkbesl

      end module rjk


 SUBROUTINE POLATEV2(IPOPT,IGDTNUMI,IGDTMPLI,IGDTLENI, &
                     IGDTNUMO,IGDTMPLO,IGDTLENO, &
                     MI,MO,KM,IBI,LI,UI,VI, &
                     NO,RLAT,RLON,CROT,SROT,IBO,LO,UO,VO,IRET)
!$$$  SUBPROGRAM DOCUMENTATION BLOCK
!
! $Revision: 74685 $
!
! SUBPROGRAM:  POLATEV2   INTERPOLATE VECTOR FIELDS (NEIGHBOR)
!   PRGMMR: IREDELL       ORG: W/NMC23       DATE: 96-04-10
!
! ABSTRACT: THIS SUBPROGRAM PERFORMS NEIGHBOR INTERPOLATION
!           FROM ANY GRID TO ANY GRID FOR VECTOR FIELDS.
!           OPTIONS ALLOW CHOOSING THE WIDTH OF THE GRID SQUARE
!           (IPOPT(1)) TO SEARCH FOR VALID DATA, WHICH DEFAULTS TO 1
!           (IF IPOPT(1)=-1).  ODD WIDTH SQUARES ARE CENTERED ON
!           THE NEAREST INPUT GRID POINT; EVEN WIDTH SQUARES ARE
!           CENTERED ON THE NEAREST FOUR INPUT GRID POINTS.
!           SQUARES ARE SEARCHED FOR VALID DATA IN A SPIRAL PATTERN
!           STARTING FROM THE CENTER.  NO SEARCHING IS DONE WHERE
!           THE OUTPUT GRID IS OUTSIDE THE INPUT GRID.
!           ONLY HORIZONTAL INTERPOLATION IS PERFORMED.
!
!           THE INPUT AND OUTPUT GRIDS ARE DEFINED BY THEIR GRIB 2 GRID
!           DEFINITION TEMPLATE AS DECODED BY THE NCEP G2 LIBRARY.  THE
!           CODE RECOGNIZES THE FOLLOWING PROJECTIONS, WHERE
!           "IGDTNUMI/O" IS THE GRIB 2 GRID DEFINTION TEMPLATE NUMBER
!           FOR THE INPUT AND OUTPUT GRIDS, RESPECTIVELY:
!             (IGDTNUMI/O=00) EQUIDISTANT CYLINDRICAL
!             (IGDTNUMI/O=01) ROTATED EQUIDISTANT CYLINDRICAL. "E" AND
!                             NON-"E" STAGGERED
!             (IGDTNUMI/O=10) MERCATOR CYLINDRICAL
!             (IGDTNUMI/O=20) POLAR STEREOGRAPHIC AZIMUTHAL
!             (IGDTNUMI/O=30) LAMBERT CONFORMAL CONICAL
!             (IGDTNUMI/O=40) GAUSSIAN CYLINDRICAL
!
!           THE INPUT AND OUTPUT VECTORS ARE ROTATED SO THAT THEY ARE
!           EITHER RESOLVED RELATIVE TO THE DEFINED GRID
!           IN THE DIRECTION OF INCREASING X AND Y COORDINATES
!           OR RESOLVED RELATIVE TO EASTERLY AND NORTHERLY DIRECTIONS,
!           AS DESIGNATED BY THEIR RESPECTIVE GRID DEFINITION SECTIONS.
!
!           AS AN ADDED BONUS THE NUMBER OF OUTPUT GRID POINTS
!           AND THEIR LATITUDES AND LONGITUDES ARE ALSO RETURNED
!           ALONG WITH THEIR VECTOR ROTATION PARAMETERS.
!           ON THE OTHER HAND, THE OUTPUT CAN BE A SET OF STATION POINTS
!           IF IGDTNUMO<0, IN WHICH CASE THE NUMBER OF POINTS
!           AND THEIR LATITUDES AND LONGITUDES MUST BE INPUT
!           ALONG WITH THEIR VECTOR ROTATION PARAMETERS.
!
!           INPUT BITMAPS WILL BE INTERPOLATED TO OUTPUT BITMAPS.
!           OUTPUT BITMAPS WILL ALSO BE CREATED WHEN THE OUTPUT GRID
!           EXTENDS OUTSIDE OF THE DOMAIN OF THE INPUT GRID.
!           THE OUTPUT FIELD IS SET TO 0 WHERE THE OUTPUT BITMAP IS OFF.
!
! PROGRAM HISTORY LOG:
!   96-04-10  IREDELL
! 1999-04-08  IREDELL  SPLIT IJKGDS INTO TWO PIECES
! 2001-06-18  IREDELL  INCLUDE SPIRAL SEARCH OPTION
! 2002-01-17  IREDELL  SAVE DATA FROM LAST CALL FOR OPTIMIZATION
! 2006-01-04  GAYNO    MINOR BUG FIX
! 2007-10-30  IREDELL  SAVE WEIGHTS AND THREAD FOR PERFORMANCE
! 2012-06-26  GAYNO    FIX OUT-OF-BOUNDS ERROR.  SEE NCEPLIBS
!                      TICKET #9.
! 2015-01-27  GAYNO    REPLACE CALLS TO GDSWIZ WITH NEW MERGED
!                      ROUTINE GDSWZD.
! 2015-07-13  GAYNO    CONVERT TO GRIB 2. REPLACE GRIB 1 KGDS ARRAYS
!                      WITH GRIB 2 GRID DEFINITION TEMPLATE ARRAYS.
!
! USAGE:    CALL POLATEV2(IPOPT,IGDTNUMI,IGDTMPLI,IGDTLENI, &
!                         IGDTNUMO,IGDTMPLO,IGDTLENO, &
!                         MI,MO,KM,IBI,LI,UI,VI, &
!                         NO,RLAT,RLON,CROT,SROT,IBO,LO,UO,VO,IRET)
!
!   INPUT ARGUMENT LIST:
!     IPOPT    - INTEGER (20) INTERPOLATION OPTIONS
!                IPOPT(1) IS WIDTH OF SQUARE TO EXAMINE IN SPIRAL SEARCH
!                (DEFAULTS TO 1 IF IPOPT(1)=-1)
!     IGDTNUMI - INTEGER GRID DEFINITION TEMPLATE NUMBER - INPUT GRID.
!                CORRESPONDS TO THE GFLD%IGDTNUM COMPONENT OF THE
!                NCEP G2 LIBRARY GRIDMOD DATA STRUCTURE:
!                  00 - EQUIDISTANT CYLINDRICAL
!                  01 - ROTATED EQUIDISTANT CYLINDRICAL.  "E"
!                       AND NON-"E" STAGGERED
!                  10 - MERCATOR CYCLINDRICAL
!                  20 - POLAR STEREOGRAPHIC AZIMUTHAL
!                  30 - LAMBERT CONFORMAL CONICAL
!                  40 - GAUSSIAN EQUIDISTANT CYCLINDRICAL
!     IGDTMPLI - INTEGER (IGDTLENI) GRID DEFINITION TEMPLATE ARRAY -
!                INPUT GRID. CORRESPONDS TO THE GFLD%IGDTMPL COMPONENT
!                OF THE NCEP G2 LIBRARY GRIDMOD DATA STRUCTURE
!                (SECTION 3 INFO).  SEE COMMENTS IN ROUTINE
!                IPOLATEV FOR COMPLETE DEFINITION.
!     IGDTLENI - INTEGER NUMBER OF ELEMENTS OF THE GRID DEFINITION
!                TEMPLATE ARRAY - INPUT GRID.  CORRESPONDS TO THE GFLD%IGDTLEN
!                COMPONENT OF THE NCEP G2 LIBRARY GRIDMOD DATA STRUCTURE.
!     IGDTNUMO - INTEGER GRID DEFINITION TEMPLATE NUMBER - OUTPUT GRID.
!                CORRESPONDS TO THE GFLD%IGDTNUM COMPONENT OF THE
!                NCEP G2 LIBRARY GRIDMOD DATA STRUCTURE. IGDTNUMO<0
!                MEANS INTERPOLATE TO RANDOM STATION POINTS.
!                OTHERWISE, SAME DEFINITION AS "IGDTNUMI".
!     IGDTMPLO - INTEGER (IGDTLENO) GRID DEFINITION TEMPLATE ARRAY -
!                OUTPUT GRID. CORRESPONDS TO THE GFLD%IGDTMPL COMPONENT
!                OF THE NCEP G2 LIBRARY GRIDMOD DATA STRUCTURE.
!                (SECTION 3 INFO).  SEE COMMENTS IN ROUTINE
!                IPOLATEV FOR COMPLETE DEFINITION.
!     IGDTLENO - INTEGER NUMBER OF ELEMENTS OF THE GRID DEFINITION
!                TEMPLATE ARRAY - OUTPUT GRID.  CORRESPONDS TO THE GFLD%IGDTLEN
!                COMPONENT OF THE NCEP G2 LIBRARY GRIDMOD DATA STRUCTURE.
!     MI       - INTEGER SKIP NUMBER BETWEEN INPUT GRID FIELDS IF KM>1
!                OR DIMENSION OF INPUT GRID FIELDS IF KM=1
!     MO       - INTEGER SKIP NUMBER BETWEEN OUTPUT GRID FIELDS IF KM>1
!                OR DIMENSION OF OUTPUT GRID FIELDS IF KM=1
!     KM       - INTEGER NUMBER OF FIELDS TO INTERPOLATE
!     IBI      - INTEGER (KM) INPUT BITMAP FLAGS
!     LI       - LOGICAL*1 (MI,KM) INPUT BITMAPS (IF SOME IBI(K)=1)
!     UI       - REAL (MI,KM) INPUT U-COMPONENT FIELDS TO INTERPOLATE
!     VI       - REAL (MI,KM) INPUT V-COMPONENT FIELDS TO INTERPOLATE
!     RLAT     - REAL (MO) OUTPUT LATITUDES IN DEGREES (IF IGDTNUMO<0)
!     RLON     - REAL (MO) OUTPUT LONGITUDES IN DEGREES (IF IGDTNUMO<0)
!     CROT     - REAL (MO) VECTOR ROTATION COSINES (IF IGDTNUMO<0)
!     SROT     - REAL (MO) VECTOR ROTATION SINES (IF IGDTNUMO<0)
!                (UGRID=CROT*UEARTH-SROT*VEARTH;
!                 VGRID=SROT*UEARTH+CROT*VEARTH)
!
!   OUTPUT ARGUMENT LIST:
!     NO       - INTEGER NUMBER OF OUTPUT POINTS (ONLY IF IGDTNUMO>=0)
!     RLAT     - REAL (MO) OUTPUT LATITUDES IN DEGREES (IF IGDTNUMO>=0)
!     RLON     - REAL (MO) OUTPUT LONGITUDES IN DEGREES (IF IGDTNUMO>=0)
!     CROT     - REAL (NO) VECTOR ROTATION COSINES (IF IGDTNUMO>=0)
!     SROT     - REAL (NO) VECTOR ROTATION SINES (IF IGDTNUMO>=0)
!                (UGRID=CROT*UEARTH-SROT*VEARTH;
!                 VGRID=SROT*UEARTH+CROT*VEARTH)
!     IBO      - INTEGER (KM) OUTPUT BITMAP FLAGS
!     LO       - LOGICAL*1 (MO,KM) OUTPUT BITMAPS (ALWAYS OUTPUT)
!     UO       - REAL (MO,KM) OUTPUT U-COMPONENT FIELDS INTERPOLATED
!     VO       - REAL (MO,KM) OUTPUT V-COMPONENT FIELDS INTERPOLATED
!     IRET     - INTEGER RETURN CODE
!                0    SUCCESSFUL INTERPOLATION
!                2    UNRECOGNIZED INPUT GRID OR NO GRID OVERLAP
!                3    UNRECOGNIZED OUTPUT GRID
!
! SUBPROGRAMS CALLED:
!   CHECK_GRIDS2V CHECK IF INPUT OR OUTPUT GRIDS HAVE CHANGED
!   GDSWZD        GRID DESCRIPTION SECTION WIZARD
!   IJKGDS0       SET UP PARAMETERS FOR IJKGDS1
!   IJKGDS1       RETURN FIELD POSITION FOR A GIVEN GRID POINT
!   MOVECT        MOVE A VECTOR ALONG A GREAT CIRCLE
!   POLFIXV       MAKE MULTIPLE POLE VECTOR VALUES CONSISTENT
!
! ATTRIBUTES:
!   LANGUAGE: FORTRAN 90
!
!$$$
!
 USE GDSWZD_MOD
!
 IMPLICIT NONE
!
 INTEGER,            INTENT(IN   ) :: IPOPT(20)
 INTEGER,            INTENT(IN   ) :: IGDTNUMI, IGDTLENI
 INTEGER,            INTENT(IN   ) :: IGDTMPLI(IGDTLENI)
 INTEGER,            INTENT(IN   ) :: IGDTNUMO, IGDTLENO
 INTEGER,            INTENT(IN   ) :: IGDTMPLO(IGDTLENO)
 INTEGER,            INTENT(IN   ) :: IBI(KM),MI,MO,KM
 INTEGER,            INTENT(INOUT) :: NO
 INTEGER,            INTENT(  OUT) :: IRET, IBO(KM)
!
 LOGICAL*1,          INTENT(IN   ) :: LI(MI,KM)
 LOGICAL*1,          INTENT(  OUT) :: LO(MO,KM)
!
 REAL,               INTENT(IN   ) :: UI(MI,KM),VI(MI,KM)
 REAL,               INTENT(INOUT) :: CROT(MO),SROT(MO)
 REAL,               INTENT(INOUT) :: RLAT(MO),RLON(MO)
 REAL,               INTENT(  OUT) :: UO(MO,KM),VO(MO,KM)
!
 REAL,               PARAMETER     :: FILL=-9999.
!
 INTEGER                           :: IJKGDSA(20)
 INTEGER                           :: I1,J1,IXS,JXS,MX
 INTEGER                           :: KXS,KXT,IX,JX,NX
 INTEGER                           :: MSPIRAL,N,K,NK,NV,IJKGDS1
 INTEGER,                     SAVE :: NOX=-1,IRETX=-1
 INTEGER,        ALLOCATABLE, SAVE :: NXY(:)
!
 LOGICAL                           :: SAME_GRIDI, SAME_GRIDO
!
 REAL                              :: CX,SX,CM,SM,UROT,VROT
 REAL                              :: XPTS(MO),YPTS(MO)
 REAL                              :: CROI(MI),SROI(MI)
 REAL                              :: XPTI(MI),YPTI(MI),RLOI(MI),RLAI(MI)
 REAL,           ALLOCATABLE, SAVE :: RLATX(:),RLONX(:),XPTSX(:),YPTSX(:)
 REAL,           ALLOCATABLE, SAVE :: CROTX(:),SROTX(:),CXY(:),SXY(:)
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  SET PARAMETERS
 IRET=0
 MSPIRAL=MAX(IPOPT(1),1)
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 CALL CHECK_GRIDS2V(IGDTNUMI,IGDTMPLI,IGDTLENI, &
                    IGDTNUMO,IGDTMPLO,IGDTLENO, &
                    SAME_GRIDI,SAME_GRIDO)
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  SAVE OR SKIP WEIGHT COMPUTATION
 IF(IRET.EQ.0.AND.(IGDTNUMO.LT.0.OR..NOT.SAME_GRIDI.OR..NOT.SAME_GRIDO))THEN
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  COMPUTE NUMBER OF OUTPUT POINTS AND THEIR LATITUDES AND LONGITUDES.
   IF(IGDTNUMO.GE.0) THEN
     CALL GDSWZD(IGDTNUMO,IGDTMPLO,IGDTLENO, 0,MO,FILL,XPTS,YPTS,RLON,RLAT, &
                 NO,CROT,SROT)
     IF(NO.EQ.0) IRET=3
   ENDIF
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  LOCATE INPUT POINTS
   CALL GDSWZD(IGDTNUMI,IGDTMPLI,IGDTLENI,-1,NO,FILL,XPTS,YPTS,RLON,RLAT,NV)
   IF(IRET.EQ.0.AND.NV.EQ.0) IRET=2
   CALL GDSWZD(IGDTNUMI,IGDTMPLI,IGDTLENI, 0,MI,FILL,XPTI,YPTI,RLOI,RLAI, &
               NV,CROI,SROI)
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  ALLOCATE AND SAVE GRID DATA
   IF(NOX.NE.NO) THEN
     IF(NOX.GE.0) DEALLOCATE(RLATX,RLONX,XPTSX,YPTSX,CROTX,SROTX,NXY,CXY,SXY)
     ALLOCATE(RLATX(NO),RLONX(NO),XPTSX(NO),YPTSX(NO), &
              CROTX(NO),SROTX(NO),NXY(NO),CXY(NO),SXY(NO))
     NOX=NO
   ENDIF
   IRETX=IRET
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  COMPUTE WEIGHTS
   IF(IRET.EQ.0) THEN
     CALL IJKGDS0(IGDTNUMI,IGDTMPLI,IGDTLENI,IJKGDSA)
!$OMP PARALLEL DO PRIVATE(N,CM,SM) SCHEDULE(STATIC)
     DO N=1,NO
       RLONX(N)=RLON(N)
       RLATX(N)=RLAT(N)
       XPTSX(N)=XPTS(N)
       YPTSX(N)=YPTS(N)
       CROTX(N)=CROT(N)
       SROTX(N)=SROT(N)
       IF(XPTS(N).NE.FILL.AND.YPTS(N).NE.FILL) THEN
         NXY(N)=IJKGDS1(NINT(XPTS(N)),NINT(YPTS(N)),IJKGDSA)
         IF(NXY(N).GT.0) THEN
           CALL MOVECT(RLAI(NXY(N)),RLOI(NXY(N)),RLAT(N),RLON(N),CM,SM)
           CXY(N)=CM*CROI(NXY(N))+SM*SROI(NXY(N))
           SXY(N)=SM*CROI(NXY(N))-CM*SROI(NXY(N))
         ENDIF
       ELSE
         NXY(N)=0
       ENDIF
     ENDDO
   ENDIF
 ENDIF
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  INTERPOLATE OVER ALL FIELDS
 IF(IRET.EQ.0.AND.IRETX.EQ.0) THEN
   IF(IGDTNUMO.GE.0) THEN
     NO=NOX
     DO N=1,NO
       RLON(N)=RLONX(N)
       RLAT(N)=RLATX(N)
       CROT(N)=CROTX(N)
       SROT(N)=SROTX(N)
     ENDDO
   ENDIF
   DO N=1,NO
     XPTS(N)=XPTSX(N)
     YPTS(N)=YPTSX(N)
   ENDDO
!$OMP PARALLEL DO &
!$OMP PRIVATE(NK,K,N,I1,J1,IXS,JXS,MX,KXS,KXT,IX,JX,NX) &
!$OMP PRIVATE(CM,SM,CX,SX,UROT,VROT) SCHEDULE(STATIC)
   DO NK=1,NO*KM
     K=(NK-1)/NO+1
     N=NK-NO*(K-1)
     UO(N,K)=0
     VO(N,K)=0
     LO(N,K)=.FALSE.
     IF(NXY(N).GT.0) THEN
       IF(IBI(K).EQ.0.OR.LI(NXY(N),K)) THEN
         UROT=CXY(N)*UI(NXY(N),K)-SXY(N)*VI(NXY(N),K)
         VROT=SXY(N)*UI(NXY(N),K)+CXY(N)*VI(NXY(N),K)
         UO(N,K)=CROT(N)*UROT-SROT(N)*VROT
         VO(N,K)=SROT(N)*UROT+CROT(N)*VROT
         LO(N,K)=.TRUE.
! SPIRAL AROUND UNTIL VALID DATA IS FOUND.
       ELSEIF(MSPIRAL.GT.1) THEN
         I1=NINT(XPTS(N))
         J1=NINT(YPTS(N))
         IXS=SIGN(1.,XPTS(N)-I1)
         JXS=SIGN(1.,YPTS(N)-J1)
         DO MX=2,MSPIRAL**2
           KXS=SQRT(4*MX-2.5)
           KXT=MX-(KXS**2/4+1)
           SELECT CASE(MOD(KXS,4))
           CASE(1)
             IX=I1-IXS*(KXS/4-KXT)
             JX=J1-JXS*KXS/4
           CASE(2)
             IX=I1+IXS*(1+KXS/4)
             JX=J1-JXS*(KXS/4-KXT)
           CASE(3)
             IX=I1+IXS*(1+KXS/4-KXT)
             JX=J1+JXS*(1+KXS/4)
           CASE DEFAULT
             IX=I1-IXS*KXS/4
             JX=J1+JXS*(KXS/4-KXT)
           END SELECT
           NX=IJKGDS1(IX,JX,IJKGDSA)
           IF(NX.GT.0) THEN
             IF(LI(NX,K)) THEN
               CALL MOVECT(RLAI(NX),RLOI(NX),RLAT(N),RLON(N),CM,SM)
               CX=CM*CROI(NX)+SM*SROI(NX)
               SX=SM*CROI(NX)-CM*SROI(NX)
               UROT=CX*UI(NX,K)-SX*VI(NX,K)
               VROT=SX*UI(NX,K)+CX*VI(NX,K)
               UO(N,K)=CROT(N)*UROT-SROT(N)*VROT
               VO(N,K)=SROT(N)*UROT+CROT(N)*VROT
               LO(N,K)=.TRUE.
               EXIT
             ENDIF
           ENDIF
         ENDDO
       ENDIF
     ENDIF
   ENDDO
   DO K=1,KM
     IBO(K)=IBI(K)
     IF(.NOT.ALL(LO(1:NO,K))) IBO(K)=1
   ENDDO
   IF(IGDTNUMO.EQ.0) CALL POLFIXV(NO,MO,KM,RLAT,RLON,IBO,LO,UO,VO)
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 ELSE
   IF(IRET.EQ.0) IRET=IRETX
   IF(IGDTNUMO.GE.0) NO=0
 ENDIF
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 END SUBROUTINE POLATEV2
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 SUBROUTINE CHECK_GRIDS2V(IGDTNUMI,IGDTMPLI,IGDTLENI, &
                          IGDTNUMO,IGDTMPLO,IGDTLENO, &
                          SAME_GRIDI, SAME_GRIDO)
!$$$  SUBPROGRAM DOCUMENTATION BLOCK
!
! SUBPROGRAM:  CHECK_GRIDS2V   CHECK GRID INFORMATION
!   PRGMMR: GAYNO       ORG: W/NMC23       DATE: 2015-07-13
!
! ABSTRACT: DETERMINE WHETHER THE INPUT OR OUTPUT GRID SPECS
!           HAVE CHANGED.
!
! PROGRAM HISTORY LOG:
! 2015-07-13  GAYNO     INITIAL VERSION
!
! USAGE:  CALL CHECK_GRIDS2V(IGDTNUMI,IGDTMPLI,IGDTLENI, &
!                            IGDTNUMO,IGDTMPLO, &
!                            IGDTLENO, SAME_GRIDI, SAME_GRIDO)
!
!   INPUT ARGUMENT LIST:
!     IGDTNUMI - INTEGER GRID DEFINITION TEMPLATE NUMBER - INPUT GRID.
!                CORRESPONDS TO THE GFLD%IGDTNUM COMPONENT OF THE
!                NCEP G2 LIBRARY GRIDMOD DATA STRUCTURE.
!     IGDTMPLI - INTEGER (IGDTLENI) GRID DEFINITION TEMPLATE ARRAY -
!                INPUT GRID. CORRESPONDS TO THE GFLD%IGDTMPL COMPONENT
!                OF THE NCEP G2 LIBRARY GRIDMOD DATA STRUCTURE.
!     IGDTLENI - INTEGER NUMBER OF ELEMENTS OF THE GRID DEFINITION
!                TEMPLATE ARRAY - INPUT GRID.  CORRESPONDS TO THE GFLD%IGDTLEN
!                COMPONENT OF THE NCEP G2 LIBRARY GRIDMOD DATA STRUCTURE.
!     IGDTNUMO - INTEGER GRID DEFINITION TEMPLATE NUMBER - OUTPUT GRID.
!                CORRESPONDS TO THE GFLD%IGDTNUM COMPONENT OF THE
!                NCEP G2 LIBRARY GRIDMOD DATA STRUCTURE.
!     IGDTMPLO - INTEGER (IGDTLENO) GRID DEFINITION TEMPLATE ARRAY -
!                OUTPUT GRID. CORRESPONDS TO THE GFLD%IGDTMPL COMPONENT
!                OF THE NCEP G2 LIBRARY GRIDMOD DATA STRUCTURE.
!     IGDTLENO - INTEGER NUMBER OF ELEMENTS OF THE GRID DEFINITION
!                TEMPLATE ARRAY - OUTPUT GRID.  CORRESPONDS TO THE GFLD%IGDTLEN
!                COMPONENT OF THE NCEP G2 LIBRARY GRIDMOD DATA STRUCTURE.
!
!   OUTPUT ARGUMENT LIST:
!     SAME_GRIDI  - WHEN TRUE, THE INPUT GRID HAS NOT CHANGED BETWEEN CALLS.
!     SAME_GRIDO  - WHEN TRUE, THE OUTPUT GRID HAS NOT CHANGED BETWEEN CALLS.
!
! ATTRIBUTES:
!   LANGUAGE: FORTRAN 90
!
!$$$
 IMPLICIT NONE
!
 INTEGER,        INTENT(IN   ) :: IGDTNUMI, IGDTLENI
 INTEGER,        INTENT(IN   ) :: IGDTMPLI(IGDTLENI)
 INTEGER,        INTENT(IN   ) :: IGDTNUMO, IGDTLENO
 INTEGER,        INTENT(IN   ) :: IGDTMPLO(IGDTLENO)
!
 LOGICAL,        INTENT(  OUT) :: SAME_GRIDI, SAME_GRIDO
!
 INTEGER, SAVE                 :: IGDTNUMI_SAVE=-9999
 INTEGER, SAVE                 :: IGDTLENI_SAVE=-9999
 INTEGER, SAVE                 :: IGDTMPLI_SAVE(1000)=-9999
 INTEGER, SAVE                 :: IGDTNUMO_SAVE=-9999
 INTEGER, SAVE                 :: IGDTLENO_SAVE=-9999
 INTEGER, SAVE                 :: IGDTMPLO_SAVE(1000)=-9999
!
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 SAME_GRIDI=.FALSE.
 IF(IGDTNUMI==IGDTNUMI_SAVE)THEN
   IF(IGDTLENI==IGDTLENI_SAVE)THEN
     IF(ALL(IGDTMPLI==IGDTMPLI_SAVE(1:IGDTLENI)))THEN
       SAME_GRIDI=.TRUE.
     ENDIF
   ENDIF
 ENDIF
!
 IGDTNUMI_SAVE=IGDTNUMI
 IGDTLENI_SAVE=IGDTLENI
 IGDTMPLI_SAVE(1:IGDTLENI)=IGDTMPLI
 IGDTMPLI_SAVE(IGDTLENI+1:1000)=-9999
!
 SAME_GRIDO=.FALSE.
 IF(IGDTNUMO==IGDTNUMO_SAVE)THEN
   IF(IGDTLENO==IGDTLENO_SAVE)THEN
     IF(ALL(IGDTMPLO==IGDTMPLO_SAVE(1:IGDTLENO)))THEN
       SAME_GRIDO=.TRUE.
     ENDIF
   ENDIF
 ENDIF
!
 IGDTNUMO_SAVE=IGDTNUMO
 IGDTLENO_SAVE=IGDTLENO
 IGDTMPLO_SAVE(1:IGDTLENO)=IGDTMPLO
 IGDTMPLO_SAVE(IGDTLENO+1:1000)=-9999
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 END SUBROUTINE CHECK_GRIDS2V


  subroutine ek_ribbon
     ! This subroutine is used to caculate energy dispersion
     ! for 1D wire system.
     ! Copyright (c) 2010 QuanSheng Wu. All rights reserved.

     use wmpi
     use para
     implicit none

     integer :: mdim
     integer :: ndim1

     ! loop index
     integer :: i
     integer :: j
     integer :: m
     integer :: l

     ! wave vector
     real(Dp) :: k

     real(dp) :: emin, emax
     real(Dp) :: kmax=0.5d0

     integer :: lwork

     ! the indices of the smallest and largest
     ! eigenvalues to be returned
     integer :: il,iu

     !the lower and upper bounds of the interval
     !to be searched for eigenvalues
     real(Dp) :: vl,vu

     !The absolute error tolerance for the eigenvalues
     real(Dp) :: abstol

     ! parameters for zheev
     integer :: info,ierr,ifail

     ! energy dispersion
     real(Dp),allocatable :: ekribbon(:,:)
     real(Dp),allocatable :: ekribbon_mpi(:,:)
     real(Dp),allocatable ::  rwork(:)
     integer,allocatable ::  iwork(:)
     complex(Dp),allocatable :: work(:)

     !> color for plot, surface state weight
     real(dp), allocatable :: surf_weight(:, :)
     real(dp), allocatable :: surf_weight_mpi(:, :)

     ! eigenvalue
     real(Dp),allocatable :: eigenvalue(:)

     ! hamiltonian slab
     complex(Dp),allocatable ::z(:,:)
     complex(Dp),allocatable ::CHamk(:,:)

     Ndim1=Num_wann*nslab1*nslab2
     lwork=64*Ndim1

     allocate(ekribbon(Ndim1,Nk1))
     allocate(ekribbon_mpi(Ndim1,Nk1))
     allocate(z(Ndim1,Ndim1))
     allocate(CHamk(Ndim1,Ndim1))
     allocate(rwork(7*Ndim1))
     allocate(work(lwork))
     allocate(iwork(5*Ndim1))
     allocate(eigenvalue(Ndim1))

     allocate( surf_weight (Ndim1, Nk1))
     allocate( surf_weight_mpi (Ndim1, Nk1))

     ierr = 0

     ! sweep k
     ekribbon=0.0d0
     ekribbon_mpi=0.0d0
     surf_weight= 0d0
     surf_weight_mpi= 0d0

     kmax=0.5d0

     abstol=1e-10
     vl= omegamin
     vu= omegamax
     il= (NumOccupied-2)*Nslab1*Nslab2
     iu= (NumOccupied+2)*Nslab1*Nslab2
     mdim=iu-il+1

     if (cpuid==0) write(stdout, *)'number of bands calculating: ',mdim

     do i=1+cpuid, Nk1, num_cpu
        if (cpuid==0) write(stdout, *) "Ribbonek the i'th kpoint", i, Nk1
        k=kmax*real(i-1)/(Nk1-1)
        chamk=0.0d0
        call ham_ribbon(k,Chamk)
        eigenvalue=0.0d0

        ! diagonal Chamk
        call eigensystem_c('V', 'U', Ndim1, CHamk, eigenvalue)

        ! only eigenvalues are computed
        ! the eigenvalues with indices il through iu will be found
        !call zheevx('N','I','U',Ndim1,Chamk,Ndim1,vl,vu,il,iu,abstol,&
        !mdim,eigenvalue,z,Ndim1,work,lwork,rwork,iwork,ifail,info)

        ekribbon(:,i)=eigenvalue

        do j=1, Nslab1* Nslab2* Num_wann  !< bands
           do m=1, Nslab2
              do l=1, Num_wann  !< sum over orbitals
                 surf_weight(j, i)= surf_weight(j, i) &
                 + abs(CHamk((m-1)*Num_wann+ l , j))**2 & ! first slab
                 + abs(CHamk(Num_wann*Nslab1*Nslab2 -(m-1)*Num_wann- l+ 1, j))**2 !& ! last slab
              enddo ! m
           enddo ! l

           do m=1, Nslab1
              do l=1, Num_wann  !< sum over orbitals
                 surf_weight(j, i)= surf_weight(j, i) &
                 + abs(CHamk((m-1)*Num_wann*Nslab2+ l , j))**2 & ! first slab
                 + abs(CHamk(Num_wann*Nslab1*Nslab2 -(m-1)*Num_wann*Nslab2- l+ 1, j))**2 !& ! last slab
              enddo ! m
           enddo ! l

           surf_weight(j, i)= sqrt(surf_weight(j, i))
        enddo ! j

        if (cpuid.eq.0) write(stdout,'(a2,i4,f12.5,f10.2,a2)')'k',i,ekribbon(1,i)
     enddo
#if defined (MPI)
     call mpi_allreduce(ekribbon,ekribbon_mpi,size(ekribbon),&
                       mpi_dp,mpi_sum,mpi_cmw,ierr)
     call mpi_allreduce(surf_weight, surf_weight_mpi,size(surf_weight),&
                       mpi_dp,mpi_sum,mpi_cmw,ierr)
#else
     ekribbon_mpi= ekribbon
     surf_weight_mpi= surf_weight
#endif
     surf_weight= surf_weight_mpi/ maxval(surf_weight_mpi)

     if (cpuid.eq.0) then
        open(unit=100, file='ribbonek.dat',status='unknown')
        do j=1, Ndim1
           do i=1,Nk1
              k=-kmax*real(Nk1-i)/(Nk1-1)
              write(100,'(2f15.7, i8)')k,ekribbon_mpi(j,Nk1-i+1), &
                 int(255-surf_weight(j, Nk1-i+1)*255d0)
           enddo
           do i=1,Nk1
              k=kmax*real(i-1)/(Nk1-1)
              write(100,'(2f15.7, i8)')k,ekribbon_mpi(j,i), &
                 int(255-surf_weight(j, i)*255d0)
           enddo
           write(100, *)' '
        enddo

        close(100)
        write(stdout,*) 'calculate energy band  done'
     endif

     emin= minval(ekribbon_mpi)-0.5d0
     emax= maxval(ekribbon_mpi)+0.5d0
     !> write script for gnuplot
     if (cpuid==0) then
        open(unit=118, file='ribbonek.gnu')
        write(118, '(a)')'#set terminal  postscript enhanced color'
        write(118, '(a)')"#set output 'ribbonek.eps'"
        write(118, '(3a)')'#set terminal  pngcairo truecolor enhanced', &
           '# font ",36" size 1920, 1680'
        write(118, '(3a)')'set terminal  png truecolor enhanced', &
           '  font ",36" size 1920, 1680'
        write(118, '(a)')"set output 'ribbonek.png'"
        write(118,'(2a)') 'set palette defined ( 0  "green", ', &
           '5 "yellow", 10 "red" )'
        write(118, '(a)')'set style data linespoints'
        write(118, '(a)')'unset ztics'
        write(118, '(a)')'unset key'
        write(118, '(a)')'set pointsize 0.8'
        write(118, '(a)')'set border lw 3 '
        write(118, '(a)')'set view 0,0'
        write(118, '(a)')'#set xtics offset 0, -1'
        write(118, '(a)')'set ylabel offset -1, 0 '
        write(118, '(a)')'set ylabel "Energy (eV)"'
        write(118, '(a)')'set xrange [-0.5:0.5]'
        write(118, '(a, f10.5, a, f10.5, a)')'set yrange [', emin, ':', emax, ']'
        write(118, '(a)')'rgb(r,g,b) = int(r)*65536 + int(g)*256 + int(b)'
        write(118, '(2a)')"plot 'ribbonek.dat' u 1:2:(rgb(255,$3, 3)) ",  &
            "w lp lw 2 pt 7  ps 1 lc rgb variable"

        close(118)
     endif

     return
  end subroutine ek_ribbon


!***********************************************************************
!                                                                      *
      REAL(KIND(0.0D0)) FUNCTION RINT (I, J, K)
!                                                                      *
!   The value of RINT is an approximation to:                          *
!                                                                      *
!              k                                                       *
!         I ( r  *  ( P (r)*P (r) + Q (r)*Q (r) ; 0 to infinity)       *
!                      i     j       i     j                           *
!                                                                      *
!   where   I ( G(r) ; range )  denotes  the  integral  of G(r) over   *
!   range.                                                             *
!                                                                      *
!   Call(s) to: [LIB92]: QUAD.                                         *
!                                                                      *
!   Written by Farid A Parpia, at Oxford   Last updated: 05 Oct 1992   *
!                                                                      *
!***********************************************************************
!...Translated by Pacific-Sierra Research 77to90  4.3E  10:50:22   2/14/04
!...Modified by Charlotte Froese Fischer
!                     Gediminas Gaigalas  10/05/17
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY:  DOUBLE
      USE GRID_C
      USE TATB_C, ONLY: TA, MTP
      USE WAVE_C
!-----------------------------------------------
!   I n t e r f a c e   B l o c k s
!-----------------------------------------------
      USE quad_I
      IMPLICIT NONE
!-----------------------------------------------
!   G l o b a l   P a r a m e t e r s
!-----------------------------------------------
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER  :: I
      INTEGER  :: J
      INTEGER, INTENT(IN) :: K
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: L
      REAL(DOUBLE) :: RESULT
!-----------------------------------------------
!
!
!   Determine the maximum tabulation point for the integrand
!
      MTP = MIN(MF(I),MF(J))
!
!   Tabulate the integrand as required for SUBROUTINE QUAD; the
!   value at the first tabulation point is arbitrary
!
      TA(1) = 0.0D00
      DO L = 2, MTP
         TA(L) = R(L)**K*(PF(L,I)*PF(L,J) + QF(L,I)*QF(L,J))*RP(L)
      END DO
!
!   Perform the quadrature
!
      CALL QUAD (RESULT)
      RINT = RESULT
!
      RETURN
!
      END FUNCTION RINT


!! R305 literal-constant
!    is int-literal-constant
!    or real-literal-constant
!    or complex-literal-constant
!    or logical-literal-constant
!    or char-literal-constant
!    or boz-literal-constant

  complex :: c
  logical :: l
  character(5) :: str

  i = 13
  i = 13_4

  r = 3.1415
  r = 3.1415_8

  c = (-1.0_4, +2.0_4)

  l = .TRUE.
  l = .FALSE._4

  str = "hello"
  str = 1_"hello"

  z = Z"abcdef"
  o = O'01234567'
  b = B'0110'

end


MODULE Subrotinas_MG_GS

   CONTAINS

   SUBROUTINE Atualiza_Variaveis_MG_GS_P( Lx_o, Ly_o, &
                                          Nx_o, Ny_o, &
                                          tol_o, &
                                          ite_down_o, ite_up_o, &
                                          max_ciclos_V_o, ht, Re, Tn_o )

      USE Variaveis_Solvers_P

      IMPLICIT NONE

      INTEGER, INTENT(IN) :: Nx_o, Ny_o, ite_down_o, ite_up_o, max_ciclos_V_o, Tn_o
      DOUBLE PRECISION, INTENT(IN) :: Lx_o, Ly_o, tol_o, ht, Re

      INTEGER :: level
      DOUBLE PRECISION :: hx, hy

      Lx = Lx_o
      Ly = Ly_o
      Nx = Nx_o
      Ny = Ny_o
      tol = tol_o
      ite_down = ite_down_o
      ite_up   = ite_up_o
      max_ciclos_V = max_ciclos_V_o
      Tn = Tn_o

      ! Calculando o numero de niveis
      Levels = LOG( DBLE(Nx))/LOG( DBLE(2) )

      ! lv_if => duas dimensoes 1: inicio da malha, 2: fim da malha
      ALLOCATE( lv_if(Levels, 2), lv_nx(Levels), lv_ny(Levels), normas_L2(max_ciclos_V, Tn) )

      ! Inicio da primeira malha comeca em 1
      lv_if(1,1) = 1

      ! Fim da primeira malha termina em Nx*Ny
      lv_if(1,2) = Nx*Ny

      ! Para cada nivel de malha
      DO level = 1, Levels

         ! Calcula o Nx e Ny de cada nivel de malha
         lv_nx(level) = Nx/(2**(level-1))
         lv_ny(level) = Ny/(2**(level-1))

         ! O inicio e fim da primeira malha ja foram calculados
         IF ( level > 1 ) THEN

            ! Calculando o indice que define o fim do vetor
            lv_if(level,2) = lv_if(level-1,2) + lv_nx(level)*lv_ny(level)

            ! Calculando o indice que define o inicio do vetor
            lv_if(level,1) = lv_if(level-1,2) + 1

         END IF

         !write(*,*) "Para P", level, lv_if(level, 1), lv_if(level,2)

      END DO

      ! Alocando as variaveis
      ! lv_if( Levels, 2 ) => comprimento total do array com todas as malhas
      ALLOCATE( u( lv_if( Levels, 2 ), Tn ) , &
                f( lv_if( Levels, 2 ), Tn ) , &
                bp( lv_if( Levels, 2 ), Tn ) &
              )

     ! Para evitar lixo numerico na memoria
     u(:, :) = 0.0d0
     f(:, :) = 0.0d0
     bp(:, :) = 0.0d0

     !-------------------------- matriz A de P --------------------------------
     ALLOCATE( A(Levels) )

     ! Inicializando a matriz A de U
     DO level = 1, Levels

         hx  = Lx/DBLE( lv_nx(level) )
         hy  = Ly/DBLE( lv_ny(level) )

         CALL A(level) % init( lv_nx(level), lv_ny(level), &
                               hx, hy, ht, &
                               Re)

         ! Atribuindo um stencil a cada volume de A
         CALL A(level) % atribui_stencils()

         ! Calculandos os coeficientes e posicoes dos stencils
         CALL A(level) % stencils_p()
         !-------------------------- matriz A de P --------------------------------
     END DO

   END SUBROUTINE Atualiza_Variaveis_MG_GS_P

   SUBROUTINE RESTRICAO_P (fina, grossa, Nxf, Nxg, Nyg)
      IMPLICIT NONE

      INTEGER, INTENT(IN)                           :: Nxf, Nxg, Nyg
      DOUBLE PRECISION, DIMENSION(:), INTENT(IN)    :: fina
      DOUBLE PRECISION, DIMENSION(:), INTENT(INOUT) :: grossa

      ! Declaracao de variaveis interna a esta rotina
      INTEGER :: pg, pf

      DO pg = 1, Nxg * Nyg

         ! Deduzido de if = 2ig - 1, jg = 2jg - 1 e Nf = 2Nxg
         pf = 2 * pg + 2 * FLOOR( DBLE(pg-1)/Nxg ) * Nxg - 1

         ! Fazendo a restricao dos nos internos de acordo com o stencil escolhido
         grossa(pg) = &
        ( fina(pf) + fina(pf + 1 ) + fina(pf + Nxf) + fina(pf + Nxf + 1) )/4.0d0

      END DO

   END SUBROUTINE RESTRICAO_P

   SUBROUTINE Prolongacao_P (fina, grossa, Nxf, Nxg, Nyg )
      IMPLICIT NONE

      INTEGER, INTENT(IN)                            :: Nxf, Nxg, Nyg
      DOUBLE PRECISION, DIMENSION(:), INTENT(IN)     :: grossa
      DOUBLE PRECISION, DIMENSION(:), INTENT(INOUT)  :: fina

      ! Declaracao de variaveis interna a esta rotina
      INTEGER :: p, pf, pg

      ! Volumes no CENTRO recebem stencil 5, mas ja foram considerados
      DO p = 1, (Nxg-2)*(Nyg-2)

         pg = p + 2*FLOOR( DBLE(p-1)/DBLE(Nxg-2) ) + Nxg + 1
         pf = 2 * pg + 2 * FLOOR( DBLE(pg-1)/Nxg ) * Nxg - 1

         fina(pf)           = fina(pf)           + ( 9.0d0 * grossa(pg) + 3.0d0 * grossa(pg - 1) + 3.0d0 * grossa(pg - Nxg ) + grossa(pg - Nxg - 1 ) )/16.0d0
         fina(pf+1)         = fina(pf+1)         + ( 9.0d0 * grossa(pg) + 3.0d0 * grossa(pg + 1) + 3.0d0 * grossa(pg - Nxg ) + grossa(pg - Nxg + 1 ) )/16.0d0
         fina(pf + Nxf)     = fina(pf + Nxf)     + ( 9.0d0 * grossa(pg) + 3.0d0 * grossa(pg - 1) + 3.0d0 * grossa(pg + Nxg ) + grossa(pg + Nxg - 1 ) )/16.0d0
         fina(pf + Nxf + 1) = fina(pf + Nxf + 1) + ( 9.0d0 * grossa(pg) + 3.0d0 * grossa(pg + 1) + 3.0d0 * grossa(pg + Nxg ) + grossa(pg + Nxg + 1 ) )/16.0d0

      END DO

      ! Canto SOUTH WEST
      pg = 1
      pf = 2 * pg + 2 * FLOOR( DBLE(pg-1)/Nxg ) * Nxg - 1
      ! Usando Neumann dp/dt = 0 entao p-1 = p e p-nx = p
      fina(pf)           = fina(pf)           + ( 9.0d0 * grossa(pg) + 3.0d0 * grossa(pg    ) + 3.0d0 * grossa(pg       ) + grossa(pg           ) )/16.0d0
      fina(pf+1)         = fina(pf+1)         + ( 9.0d0 * grossa(pg) + 3.0d0 * grossa(pg + 1) + 3.0d0 * grossa(pg       ) + grossa(pg       + 1 ) )/16.0d0
      fina(pf + Nxf)     = fina(pf + Nxf)     + ( 9.0d0 * grossa(pg) + 3.0d0 * grossa(pg    ) + 3.0d0 * grossa(pg + Nxg ) + grossa(pg + Nxg     ) )/16.0d0
      fina(pf + Nxf + 1) = fina(pf + Nxf + 1) + ( 9.0d0 * grossa(pg) + 3.0d0 * grossa(pg + 1) + 3.0d0 * grossa(pg + Nxg ) + grossa(pg + Nxg + 1 ) )/16.0d0

      ! Contorno SOUTH recebe stencil 2
      DO pg = 2, Nxg - 1
         pf = 2 * pg + 2 * FLOOR( DBLE(pg-1)/Nxg ) * Nxg - 1
         ! Usando Neumann dp/dt = 0 entao p - Nx = p
         fina(pf)           = fina(pf)           + ( 9.0d0 * grossa(pg) + 3.0d0 * grossa(pg - 1) + 3.0d0 * grossa(pg       ) + grossa(pg       - 1 ) )/16.0d0
         fina(pf+1)         = fina(pf+1)         + ( 9.0d0 * grossa(pg) + 3.0d0 * grossa(pg + 1) + 3.0d0 * grossa(pg       ) + grossa(pg       + 1 ) )/16.0d0
         fina(pf + Nxf)     = fina(pf + Nxf)     + ( 9.0d0 * grossa(pg) + 3.0d0 * grossa(pg - 1) + 3.0d0 * grossa(pg + Nxg ) + grossa(pg + Nxg - 1 ) )/16.0d0
         fina(pf + Nxf + 1) = fina(pf + Nxf + 1) + ( 9.0d0 * grossa(pg) + 3.0d0 * grossa(pg + 1) + 3.0d0 * grossa(pg + Nxg ) + grossa(pg + Nxg + 1 ) )/16.0d0

      END DO

      ! Canto SOUTH EAST  recebe stencil 3
      pg = Nxg
      pf = 2 * pg + 2 * FLOOR( DBLE(pg-1)/Nxg ) * Nxg - 1
      ! Usando Neumann dp/dt = 0 entao p+1 = p e p-nx = p
      fina(pf)           = fina(pf)           + ( 9.0d0 * grossa(pg) + 3.0d0 * grossa(pg - 1) + 3.0d0 * grossa(pg       ) + grossa(pg       - 1 ) )/16.0d0
      fina(pf+1)         = fina(pf+1)         + ( 9.0d0 * grossa(pg) + 3.0d0 * grossa(pg    ) + 3.0d0 * grossa(pg       ) + grossa(pg           ) )/16.0d0
      fina(pf + Nxf)     = fina(pf + Nxf)     + ( 9.0d0 * grossa(pg) + 3.0d0 * grossa(pg - 1) + 3.0d0 * grossa(pg + Nxg ) + grossa(pg + Nxg - 1 ) )/16.0d0
      fina(pf + Nxf + 1) = fina(pf + Nxf + 1) + ( 9.0d0 * grossa(pg) + 3.0d0 * grossa(pg    ) + 3.0d0 * grossa(pg + Nxg ) + grossa(pg + Nxg + 1 ) )/16.0d0

      ! Contorno WEST recebe stencil 4
      DO pg = 1 + Nxg, Nxg *( Nyg - 2 ) + 1, Nxg
          pf = 2 * pg + 2 * FLOOR( DBLE(pg-1)/Nxg ) * Nxg - 1
          ! Usando Neumann dp/dt = 0 entao p-1 = p
          fina(pf)           = fina(pf)           + ( 9.0d0 * grossa(pg) + 3.0d0 * grossa(pg    ) + 3.0d0 * grossa(pg - Nxg ) + grossa(pg - Nxg     ) )/16.0d0
          fina(pf+1)         = fina(pf+1)         + ( 9.0d0 * grossa(pg) + 3.0d0 * grossa(pg + 1) + 3.0d0 * grossa(pg - Nxg ) + grossa(pg - Nxg + 1 ) )/16.0d0
          fina(pf + Nxf)     = fina(pf + Nxf)     + ( 9.0d0 * grossa(pg) + 3.0d0 * grossa(pg    ) + 3.0d0 * grossa(pg + Nxg ) + grossa(pg + Nxg     ) )/16.0d0
          fina(pf + Nxf + 1) = fina(pf + Nxf + 1) + ( 9.0d0 * grossa(pg) + 3.0d0 * grossa(pg + 1) + 3.0d0 * grossa(pg + Nxg ) + grossa(pg + Nxg + 1 ) )/16.0d0

      END DO

      ! Contorno EAST recebe stencil 6
      DO pg = 2 * Nxg, Nxg * (Nyg - 1), Nxg
            pf = 2 * pg + 2 * FLOOR( DBLE(pg-1)/Nxg ) * Nxg - 1
            ! Usando Neumann dp/dt = 0 entao p+1 = p
            fina(pf)           = fina(pf)           + ( 9.0d0 * grossa(pg) + 3.0d0 * grossa(pg - 1) + 3.0d0 * grossa(pg - Nxg ) + grossa(pg - Nxg - 1 ) )/16.0d0
            fina(pf+1)         = fina(pf+1)         + ( 9.0d0 * grossa(pg) + 3.0d0 * grossa(pg    ) + 3.0d0 * grossa(pg - Nxg ) + grossa(pg - Nxg     ) )/16.0d0
            fina(pf + Nxf)     = fina(pf + Nxf)     + ( 9.0d0 * grossa(pg) + 3.0d0 * grossa(pg - 1) + 3.0d0 * grossa(pg + Nxg ) + grossa(pg + Nxg - 1 ) )/16.0d0
            fina(pf + Nxf + 1) = fina(pf + Nxf + 1) + ( 9.0d0 * grossa(pg) + 3.0d0 * grossa(pg    ) + 3.0d0 * grossa(pg + Nxg ) + grossa(pg + Nxg     ) )/16.0d0

      END DO

     ! Canto NORTH WEST recebe stencil 7
     pg = Nxg *( Nyg - 1 ) + 1
     pf = 2 * pg + 2 * FLOOR( DBLE(pg-1)/Nxg ) * Nxg - 1
     ! Usando Neumann dp/dt = 0 entao p-1 = p, p+nx = p
     fina(pf)           = fina(pf)           + ( 9.0d0 * grossa(pg) + 3.0d0 * grossa(pg    ) + 3.0d0 * grossa(pg - Nxg ) + grossa(pg - Nxg     ) )/16.0d0
     fina(pf+1)         = fina(pf+1)         + ( 9.0d0 * grossa(pg) + 3.0d0 * grossa(pg + 1) + 3.0d0 * grossa(pg - Nxg ) + grossa(pg - Nxg + 1 ) )/16.0d0
     fina(pf + Nxf)     = fina(pf + Nxf)     + ( 9.0d0 * grossa(pg) + 3.0d0 * grossa(pg    ) + 3.0d0 * grossa(pg       ) + grossa(pg           ) )/16.0d0
     fina(pf + Nxf + 1) = fina(pf + Nxf + 1) + ( 9.0d0 * grossa(pg) + 3.0d0 * grossa(pg + 1) + 3.0d0 * grossa(pg       ) + grossa(pg       + 1 ) )/16.0d0

     ! Contorno NORTH recebe stencil 8
     DO pg = Nxg *( Nyg - 1 ) + 2, Nxg * Nyg - 1
         pf = 2 * pg + 2 * FLOOR( DBLE(pg-1)/Nxg ) * Nxg - 1
         ! Usando Neumann dp/dt = 0 entao p+nx = p
         fina(pf)           = fina(pf)           + ( 9.0d0 * grossa(pg) + 3.0d0 * grossa(pg - 1) + 3.0d0 * grossa(pg - Nxg ) + grossa(pg - Nxg - 1 ) )/16.0d0
         fina(pf+1)         = fina(pf+1)         + ( 9.0d0 * grossa(pg) + 3.0d0 * grossa(pg + 1) + 3.0d0 * grossa(pg - Nxg ) + grossa(pg - Nxg + 1 ) )/16.0d0
         fina(pf + Nxf)     = fina(pf + Nxf)     + ( 9.0d0 * grossa(pg) + 3.0d0 * grossa(pg - 1) + 3.0d0 * grossa(pg       ) + grossa(pg       - 1 ) )/16.0d0
         fina(pf + Nxf + 1) = fina(pf + Nxf + 1) + ( 9.0d0 * grossa(pg) + 3.0d0 * grossa(pg + 1) + 3.0d0 * grossa(pg       ) + grossa(pg       + 1 ) )/16.0d0

     END DO

     ! Canto NORTH EAST recebe stencil 9
     pg = Nxg * Nyg
     pf = 2 * pg + 2 * FLOOR( DBLE(pg-1)/Nxg ) * Nxg - 1
     ! Usando Neumann dp/dt = 0 entao p+1 =p e p+nx = p
     fina(pf)           = fina(pf)           + ( 9.0d0 * grossa(pg) + 3.0d0 * grossa(pg - 1) + 3.0d0 * grossa(pg - Nxg ) + grossa(pg - Nxg - 1 ) )/16.0d0
     fina(pf+1)         = fina(pf+1)         + ( 9.0d0 * grossa(pg) + 3.0d0 * grossa(pg    ) + 3.0d0 * grossa(pg - Nxg ) + grossa(pg - Nxg     ) )/16.0d0
     fina(pf + Nxf)     = fina(pf + Nxf)     + ( 9.0d0 * grossa(pg) + 3.0d0 * grossa(pg - 1) + 3.0d0 * grossa(pg       ) + grossa(pg       - 1 ) )/16.0d0
     fina(pf + Nxf + 1) = fina(pf + Nxf + 1) + ( 9.0d0 * grossa(pg) + 3.0d0 * grossa(pg    ) + 3.0d0 * grossa(pg       ) + grossa(pg           ) )/16.0d0

   END SUBROUTINE Prolongacao_P

   SUBROUTINE calcula_residuo_p(A, u, b, r)

        USE ClassMatrizA

       IMPLICIT NONE

       TYPE ( MatrizA ), INTENT(IN) :: A
       DOUBLE PRECISION, DIMENSION(:), INTENT(INOUT) :: r
       DOUBLE PRECISION, DIMENSION(:), INTENT(IN) :: u, b

       INTEGER :: p, stencil, ite, se ! se = elemento do stencil
       DOUBLE PRECISION :: ax, ux, sm, correcao ! Soma dos componentes do stencil

       DO p = 1, A % Nx * A % Ny

           ! Obtendo o stencil do volume
           stencil = A % v(p)

           ! Para cada coeficiente do stencil da matriz
           ! Lembrando que o primeiro e sempre ap e Gauss-Seidel
           ! e definido como
           ! u(p) = (aw * u(p-1) + ae * u(p+1) + as * u(p-Nx) ... + b(p)) / ap
           ! O codigo abaixo soma aw * u(p-1) + ae * u(p+1) + as * u(p-Nx) ...
           sm = 0.0d0
           DO se = 2, SIZE(A % s(stencil) % p) !(comeca em 2 porque nao considera o ap)

               ! ax =     aw,     ae,       as,      an,     aww,        ann, etc...
               ! ux = u(p-1), u(p+1),  u(p-Nx), u(p+Nx),  u(p-2),  u(p+2*Nx), etc...
               ! Logo
               ! ax * ux = aw * u(p-1), ae * u(p+1), as * u(p-Nx), etc...

               ax = A % s(stencil) % c(se)
               ux = u(p + A % s(stencil) % p(se))

               sm = sm +  ax * ux

           END DO

           ! Obtendo o ap
           ax = A % s(stencil) % c(1)

           ! Somando b(p) e subtraindo ap * up para compor o residuo
           r(p) = sm + b(p) - ax * u(p)

       END DO

   END SUBROUTINE calcula_residuo_p

   SUBROUTINE gs_p( A, u, b, iteracoes )

       USE ClassMatrizA

       IMPLICIT NONE

       TYPE ( MatrizA ), INTENT(IN) :: A
       DOUBLE PRECISION, DIMENSION(:), INTENT(INOUT) :: u
       DOUBLE PRECISION, DIMENSION(:), INTENT(IN) :: b
       INTEGER, INTENT(IN) :: iteracoes

       INTEGER :: p, stencil, ite, se ! se = elemento do stencil
       DOUBLE PRECISION :: ax, ux, sm ! Soma dos componentes do stencil

       DO ite = 1, iteracoes

           DO p = 1, A % Nx * A % Ny

               ! Obtendo o stencil do volume
               stencil = A % v(p)

               ! Para cada coeficiente do stencil da matriz
               ! Lembrando que o primeiro e sempre ap e Gauss-Seidel
               ! e definido como
               ! u(p) = (aw * u(p-1) + ae * u(p+1) + as * u(p-Nx) ... + b(p)) / ap
               ! O codigo abaixo soma aw * u(p-1) + ae * u(p+1) + as * u(p-Nx) ...
               sm = 0.0d0
               DO se = 2, SIZE(A % s(stencil) % p) !(comeca em 2 porque nao considera o ap)

                   ! ax =     aw,     ae,       as,      an,     aww,        ann, etc...
                   ! ux = u(p-1), u(p+1),  u(p-Nx), u(p+Nx),  u(p-2),  u(p+2*Nx), etc...
                   ! Logo
                   ! ax * ux = aw * u(p-1), ae * u(p+1), as * u(p-Nx), etc...

                   ax = A % s(stencil) % c(se)
                   ux = u(p + A % s(stencil) % p(se))

                   sm = sm +  ax * ux

                   !if (A % s(stencil) % p(se) .eq. -1) then
                   !write(*,*) p, ax, A % s(stencil) % p(se)
                   !end if
               !    write(*,*) p, ax

               END DO

               ! Obtendo o ap
               ax = A % s(stencil) % c(1)

               ! Somando b(p) e divindo por ap para completar o Gauss-Seidel
               u(p) = (sm + b(p))/ax

              ! write(*,*) p, ax, b(p), u(p)

           END DO
           !write(*,*)
           !call exit()

       END DO

   END SUBROUTINE gs_p

   SUBROUTINE MG_GS_P( u_o, f_o, ciclos_V, t)

      USE Variaveis_Solvers_P

      INTEGER, INTENT(IN) :: ciclos_V, t

      ! u_o = estimativa inicial (pressao)
      DOUBLE PRECISION, DIMENSION(:), INTENT(INOUT) :: u_o

      ! termo fonte ( div (ut, vt) )
      DOUBLE PRECISION, DIMENSION(:), INTENT(IN) :: f_o

      INTEGER :: level, ciclo, iteracao

      11 FORMAT( 1X, "Multigrid P => Ciclo:", 1X, I3, 3X, "Parada:", 1X, 1PE16.10, 3X, "Norma L2:", 1X,  1PE16.10, 3X, "(Norma L2)**(1/ciclo)", 1X, 1PE16.10)

      ! Atualizando a primeira malha do vetor u, ou seja,
      !  u (lv_if(1,1):lv_if(1,2)) = u_o(:) => estimativa inicial e a pressao
      !  calculada em um passo de tempo anterior
      u(lv_if(1,1):lv_if(1,2), t) = u_o(:)

      DO ciclo = 1, 1 !max_ciclos_V

         bp(lv_if(1,1):lv_if(1,2), t) = f_o(:)

         CALL calcula_residuo_p ( A(1), &
                                  u(lv_if(1,1):lv_if(1,2), t), &
                                  bp(lv_if(1,1):lv_if(1,2), t), &
                                  f(lv_if(1,1):lv_if(1,2), t) )
         norma_L2 = DSQRT(SUM(f(lv_if(1,1):lv_if(1,2), t) * f(lv_if(1,1):lv_if(1,2), t)))
         normas_L2(ciclo, t) = norma_L2
         !WRITE(*, 11) ciclo, normas_L2(ciclo)/normas_L2(1), normas_L2(ciclo), (normas_L2(ciclo)/normas_L2(1))**(1.0d0/ciclo)

         IF ( normas_L2(ciclo, t)/normas_L2(1, t) < tol ) THEN

            EXIT

         END IF

         DO level = 1, Levels - 1

            ! So atualiza bp = residuo, ou seja, apenas para level > 1 (o primeiro e bp = fonte)
            IF ( level > 1 ) THEN

               bp(lv_if(level,1):lv_if(level,2), t) = f(lv_if(level,1):lv_if(level,2), t)

            END IF

            CALL gs_p ( A(level), u(lv_if(level,1):lv_if(level,2), t), bp(lv_if(level,1):lv_if(level,2), t), ite_down )

            CALL calcula_residuo_p ( A(level), &
                                     u(lv_if(level,1):lv_if(level,2), t), &
                                     bp(lv_if(level,1):lv_if(level,2), t), &
                                     f(lv_if(level,1):lv_if(level,2), t) )

            CALL Restricao_P ( f(lv_if(level,1):lv_if(level,2), t),               &
                               f(lv_if(level+1, 1):lv_if(level+1, 2), t),         &
                               lv_nx(level),                                   &
                               lv_nx(level+1), lv_ny(level+1) )

         END DO

         level = Levels
         bp(lv_if(level,1):lv_if(level,2), t) = f(lv_if(level,1):lv_if(level,2), t)
         CALL gs_p ( A(level), u(lv_if(level,1):lv_if(level,2), t), bp(lv_if(level,1):lv_if(level,2), t), ite_down )

         DO level = Levels, 2, -1

             CALL Prolongacao_P ( u(lv_if(level-1,1):lv_if(level-1,2), t), &
                                  u(lv_if(level, 1):lv_if(level, 2), t),   &
                                  lv_nx(level-1),                       &
                                  lv_nx(level), lv_ny(level) )

             ! Limpando o vetor para evitar erros no proximo ciclo
             u(lv_if(level, 1):lv_if(level, 2), t) = 0.0d0
             CALL gs_p ( A(level-1), u(lv_if(level-1,1):lv_if(level-1,2), t), &
                                    bp(lv_if(level-1,1):lv_if(level-1,2), t), ite_up )

         END DO
      END DO

      u_o(:) = u(lv_if(1,1):lv_if(1,2), t)

   END SUBROUTINE MG_GS_P

   SUBROUTINE Atualiza_Variaveis_MG_GS_U( Lx_o, Ly_o, &
                                          Nx_o, Ny_o, &
                                          tol_o, &
                                          ite_down_o, ite_up_o, &
                                          max_ciclos_V_o, ht, Re, Tn_o )

      USE Variaveis_Solvers_U

      IMPLICIT NONE

      INTEGER, INTENT(IN) :: Nx_o, Ny_o, ite_down_o, ite_up_o, max_ciclos_V_o, Tn_o
      DOUBLE PRECISION, INTENT(IN) :: Lx_o, Ly_o, tol_o, ht, Re

      INTEGER :: level
      DOUBLE PRECISION :: hx, hy

      Lx = Lx_o
      Ly = Ly_o
      Nx = Nx_o
      Ny = Ny_o
      tol = tol_o
      ite_down = ite_down_o
      ite_up   = ite_up_o
      max_ciclos_V = max_ciclos_V_o
      Tn = Tn_o

      ! Calculando o numero de niveis
      Levels = LOG( DBLE(Nx+1))/LOG( DBLE(2) ) - 1

      ! lv_if => duas dimensoes 1: inicio da malha, 2: fim da malha
      ALLOCATE( lv_if(Levels, 2), lv_nx(Levels), lv_ny(Levels), normas_L2(max_ciclos_V, Tn) )

      ! Inicio da primeira malha comeca em 1
      lv_if(1,1) = 1

      ! Fim da primeira malha termina em Nx*Ny
      lv_if(1,2) = Nx*Ny

      ! Para cada nivel de malha
      DO level = 1, Levels

         ! Calcula o Nx e Ny de cada nivel de malha
         lv_nx(level) = (Nx+1)/(2**(level-1)) - 1
         lv_ny(level) = Ny/(2**(level-1))

         ! O inicio e fim da primeira malha ja foram calculados
         IF ( level > 1 ) THEN

            ! Calculando o indice que define o fim do vetor
            lv_if(level,2) = lv_if(level-1,2) + lv_nx(level)*lv_ny(level)

            ! Calculando o indice que define o inicio do vetor
            lv_if(level,1) = lv_if(level-1,2) + 1

         END IF

         !write(*,*) "Para P", level, lv_if(level, 1), lv_if(level,2)

      END DO

      ! Alocando as variaveis
      ! lv_if( Levels, 2 ) => comprimento total do array com todas as malhas
      ALLOCATE( u( lv_if( Levels, 2 ), Tn ) , &
                f( lv_if( Levels, 2 ), Tn ) , &
                bp( lv_if( Levels, 2 ), Tn ) &
              )

     ! Para evitar lixo numerico na memoria
     u(:, :) = 0.0d0
     f(:, :) = 0.0d0
     bp(:, :) = 0.0d0

     !-------------------------- matriz A de P --------------------------------
     ALLOCATE( A(Levels) )

     ! Inicializando a matriz A de U
     DO level = 1, Levels

         hx  = Lx/DBLE( lv_nx(level) + 1 )
         hy  = Ly/DBLE( lv_ny(level) )

         CALL A(level) % init( lv_nx(level), lv_ny(level), &
                               hx, hy, ht, &
                               Re)

         ! Atribuindo um stencil a cada volume de A
         CALL A(level) % atribui_stencils()

         ! Calculandos os coeficientes e posicoes dos stencils
         CALL A(level) % stencils_u(1.0d0)
         !-------------------------- matriz A de P --------------------------------
     END DO

   END SUBROUTINE Atualiza_Variaveis_MG_GS_U

   SUBROUTINE Atualiza_Variaveis_MG_GS_V( Lx_o, Ly_o, &
                                          Nx_o, Ny_o, &
                                          tol_o, &
                                          ite_down_o, ite_up_o, &
                                          max_ciclos_V_o, ht, Re, Tn_o )

      USE Variaveis_Solvers_V

      IMPLICIT NONE

      INTEGER, INTENT(IN) :: Nx_o, Ny_o, ite_down_o, ite_up_o, max_ciclos_V_o, Tn_o
      DOUBLE PRECISION, INTENT(IN) :: Lx_o, Ly_o, tol_o, ht, Re

      INTEGER :: level
      DOUBLE PRECISION :: hx, hy

      Lx = Lx_o
      Ly = Ly_o
      Nx = Nx_o
      Ny = Ny_o
      tol = tol_o
      ite_down = ite_down_o
      ite_up   = ite_up_o
      max_ciclos_V = max_ciclos_V_o
      Tn = Tn_o

      ! Calculando o numero de niveis
      Levels = LOG( DBLE(Nx))/LOG( DBLE(2) ) - 1

      ! lv_if => duas dimensoes 1: inicio da malha, 2: fim da malha
      ALLOCATE( lv_if(Levels, 2), lv_nx(Levels), lv_ny(Levels), normas_L2(max_ciclos_V, Tn) )

      ! Inicio da primeira malha comeca em 1
      lv_if(1,1) = 1

      ! Fim da primeira malha termina em Nx*Ny
      lv_if(1,2) = Nx*Ny

      ! Para cada nivel de malha
      DO level = 1, Levels

         ! Calcula o Nx e Ny de cada nivel de malha
         lv_nx(level) = Nx/(2**(level-1))
         lv_ny(level) = (Ny+1)/(2**(level-1)) - 1

         ! O inicio e fim da primeira malha ja foram calculados
         IF ( level > 1 ) THEN

            ! Calculando o indice que define o fim do vetor
            lv_if(level,2) = lv_if(level-1,2) + lv_nx(level)*lv_ny(level)

            ! Calculando o indice que define o inicio do vetor
            lv_if(level,1) = lv_if(level-1,2) + 1

         END IF

         !write(*,*) "Para P", level, lv_if(level, 1), lv_if(level,2)

      END DO

      ! Alocando as variaveis
      ! lv_if( Levels, 2 ) => comprimento total do array com todas as malhas
      ALLOCATE( u( lv_if( Levels, 2 ), Tn ) , &
                f( lv_if( Levels, 2 ), Tn ) , &
                bp( lv_if( Levels, 2 ), Tn ) &
              )

     ! Para evitar lixo numerico na memoria
     u(:, :) = 0.0d0
     f(:, :) = 0.0d0
     bp(:, :) = 0.0d0

     !-------------------------- matriz A de P --------------------------------
     ALLOCATE( A(Levels) )

     ! Inicializando a matriz A de U
     DO level = 1, Levels

         hx  = Lx/DBLE( lv_nx(level) )
         hy  = Ly/DBLE( lv_ny(level) + 1 )

         CALL A(level) % init( lv_nx(level), lv_ny(level), &
                               hx, hy, ht, &
                               Re)

         ! Atribuindo um stencil a cada volume de A
         CALL A(level) % atribui_stencils()

         ! Calculandos os coeficientes e posicoes dos stencils
         CALL A(level) % stencils_v(1.0d0)
         !-------------------------- matriz A de P --------------------------------
     END DO

   END SUBROUTINE Atualiza_Variaveis_MG_GS_V

END MODULE Subrotinas_MG_GS


! { dg-do run }
! { dg-options "-Wall" }
! Program to check corner cases for DO statements.
program do_1
  implicit none
  integer i, j

  ! limit=HUGE(i), step > 1
  j = 0
  do i = HUGE(i) - 10, HUGE(i), 2
    j = j + 1
  end do
  if (j .ne. 6) call abort
  j = 0
  do i = HUGE(i) - 9, HUGE(i), 2
    j = j + 1
  end do
  if (j .ne. 5) call abort

  ! Same again, but unknown loop step
  if (test1(10, 1) .ne. 11) call abort
  if (test1(10, 2) .ne. 6) call abort
  if (test1(9, 2) .ne. 5) call abort

  ! Zero iterations
  j = 0
  do i = 1, 0, 1 ! { dg-warning "executed zero times" }
    j = j + 1
  end do
  if (j .ne. 0) call abort
  j = 0
  do i = 1, 0, 2 ! { dg-warning "executed zero times" }
    j = j + 1
  end do
  if (j .ne. 0) call abort
  j = 0
  do i = 1, 2, -1 ! { dg-warning "executed zero times" }
    j = j + 1
  end do
  if (j .ne. 0) call abort
  call test2 (0, 1)
  call test2 (0, 2)
  call test2 (2, -1)
  call test2 (2, -2)

  ! Bound near smallest value
  j = 0;
  do i = -HUGE(i), -HUGE(i), 10
    j = j + 1
  end do
  if (j .ne. 1) call abort
contains
! Returns the number of iterations performed.
function test1(r, step)
  implicit none
  integer test1, r, step
  integer k, n
  k = 0
  do n = HUGE(n) - r, HUGE(n), step
    k = k + 1
  end do
  test1 = k
end function

subroutine test2 (lim, step)
  implicit none
  integer lim, step
  integer k, n
  k = 0
  do n = 1, lim, step
    k = k + 1
  end do
  if (k .ne. 0) call abort
end subroutine
end program


module CountingSort
  implicit none

  interface counting_sort
     module procedure counting_sort_mm, counting_sort_a
  end interface

contains

  subroutine counting_sort_a(array)
    integer, dimension(:), intent(inout) :: array

    call counting_sort_mm(array, minval(array), maxval(array))

  end subroutine counting_sort_a

  subroutine counting_sort_mm(array, tmin, tmax)
    integer, dimension(:), intent(inout) :: array
    integer, intent(in) :: tmin, tmax

    integer, dimension(tmin:tmax) :: cnt
    integer :: i, z

    cnt = 0                   ! Initialize to zero to prevent false counts
    FORALL (I=1:size(array))  ! Not sure that this gives any benefit over a DO loop.
        cnt(array(i)) = cnt(array(i))+1
    END FORALL
!
!   ok - cnt contains the frequency of every value
!   let's unwind them into the original array
!
    z = 1
    do i = tmin, tmax
       do while ( cnt(i) > 0 )
          array(z) = i
          z = z + 1
          cnt(i) = cnt(i) - 1
       end do
    end do

  end subroutine counting_sort_mm

end module CountingSort


      module MOD_CWGAUSS9
      contains
      SUBROUTINE CWGAUSS9(CWK,XNU,ND,NVOPA,T,xjc,dstep)
C***************************************************************
C***  Compute the Integration Weights for the Gauss Profile
c***  then compare with the theoretical weight and assume the
c***  rest has a intensity equal to the reference continuum
c***  The numbers CWK are used to correct the integration in
c***  routine COMPGAU
C***************************************************************
      implicit real*8(a-h,o-z)
      parameter (PI=3.141592654)
C***  Constant for thermal Gauss-Profile (= m(e)/(4k)) (cgs?)
      PARAMETER (GAUKONST=1.649538E-12)

      DIMENSION CWK(:,:),XNU(:),T(ND),xjc(nd)
      real*4 pot

      DO L=1,ND
       weight = dstep*sqrt(gaukonst/t(L)/pi)
       DO K=1,NVOPA
         CWK(L,K)=0.0
         DO KK=1,NVOPA
           XNU2=(XNU(K)-XNU(KK))*(XNU(K)-XNU(KK))
           pot=GAUKONST*XNU2/T(L)
           CWK(L,K)=CWK(L,K)+exp(-pot)
         ENDDO
         frac = weight*CWK(L,K)
         if (frac.gt.1.0000001) then
            print *,' sum .gt. 1:',L,K,frac
         endif
         if (frac.gt.1.) frac=1.

c         CWK(L,K)=(1.-frac)*xjc(L)
c version with fraction of integral
         CWK(L,K)=frac
       ENDDO
      ENDDO
c$$$c-pr
c$$$      L=40
c$$$      print *,' L, T(L) = ',L,T(L)
c$$$      do k=1,nvopa,20
c$$$       diff=xnu(k)*xnu(k)*GAUKONST/T(L)
c$$$       print *,k,xnu(k)/1.e5,diff,cwk(l,k)
c$$$      enddo
      RETURN
      END subroutine
      end module


!======================================================================================================================
!> @file        matrix.f90
!> @brief       This file contains a module that defines a matrix type.
!> @details     Heptadiagonal matrix supported for finite difference method using 7-stencil points
!> @author
!>              - Ji-Hoon Kang (jhkang@kisti.re.kr), Korea Institute of Science and Technology Information
!>
!> @date        May 2021
!> @version     1.0
!> @par         Copyright
!>              Copyright (c) 2021 Ji-Hoon Kang, Korea Institute of Science and Technology Information,
!>              All rights reserved.
!> @par         License
!>              This project is release under the terms of the MIT License (see LICENSE in )
!======================================================================================================================

!>
!> @brief       Module for matrix type for finite difference method with 7-stencil points.
!> @details     The module containes the matrix type, its creator and destroyer.
!>
module matrix

    implicit none

    !> @brief   Heptadiagonam matrix for finite difference method with 7-stencil points.
    !> @details It contains the degree of freedom (row size) and its seven coefficients for each coorinate.
    type, public        :: matrix_heptadiagonal
        integer(kind=4)                 :: dof              !< Degree of freedom, nx*ny*nz
        real(kind=8), allocatable       :: coeff(:,:,:,:)   !< Coefficient matrix. Seven elements for each coordinate
    end type matrix_heptadiagonal

    contains

    !>
    !> @brief       Create the heptadiagonal matrix for finite difference method with 7-stencil points
    !> @param       a_poisson   Matrix of matrix_heptadiagonal type
    !> @param       sdm         Subdomain
    !>
    subroutine matrix_heptadiagonal_create(a_poisson, sdm)

        use geometry, only : subdomain
        implicit none

        type(matrix_heptadiagonal), intent(inout)   :: a_poisson
        type(subdomain), intent(in)                 :: sdm

        integer(kind=4) :: i, j, k
        real(kind=8)    :: dxm2i, dym2i, dzm2i
        real(kind=8)    :: dxmp2i, dxmn2i, dymp2i, dymn2i, dzmp2i, dzmn2i

        ! Degree of freedom (row size) is equal to the number of grids in subdomain
        a_poisson%dof = sdm%nx * sdm%ny * sdm%nz

        ! Heptadiagonal matrix allocation
        ! First index 0 : (i, j, k)
        ! First index 1 : (i-1, j, k)
        ! First index 2 : (i+1, j, k)
        ! First index 3 : (i, j-1, k)
        ! First index 4 : (i, j+1, k)
        ! First index 5 : (i, j, k-1)
        ! First index 6 : (i, j, k+1)
        allocate( a_poisson%coeff(0:6, sdm%nx, sdm%ny, sdm%nz) )

        a_poisson%coeff = 0.0d0

        ! Build coefficient matrix
        do k=1, sdm%nz
            dzm2i = 1.0d0 / (sdm%dzm(k) * sdm%dzm(k))
            dzmp2i = 1.0d0 / (sdm%dzm(k) * sdm%dzg(k))
            dzmn2i = 1.0d0 / (sdm%dzm(k) * sdm%dzg(k+1))

            do j=1, sdm%ny
                dym2i = 1.0d0 / (sdm%dym(j) * sdm%dym(j))
                dymp2i = 1.0d0 / (sdm%dym(j) * sdm%dyg(j))
                dymn2i = 1.0d0 / (sdm%dym(j) * sdm%dyg(j+1))

                do i=1, sdm%nx
                    dxm2i = 1.0d0 / (sdm%dxm(i) * sdm%dxm(i))
                    dxmp2i = 1.0d0 / (sdm%dxm(i) * sdm%dxg(i))
                    dxmn2i = 1.0d0 / (sdm%dxm(i) * sdm%dxg(i+1))

                    a_poisson%coeff(0,i,j,k) = -(dxmp2i + dxmn2i + dymp2i + dymn2i + dzmp2i + dzmn2i)
                    a_poisson%coeff(1,i,j,k) = 1.0d0 * dxmp2i
                    a_poisson%coeff(2,i,j,k) = 1.0d0 * dxmn2i
                    a_poisson%coeff(3,i,j,k) = 1.0d0 * dymp2i
                    a_poisson%coeff(4,i,j,k) = 1.0d0 * dymn2i
                    a_poisson%coeff(5,i,j,k) = 1.0d0 * dzmp2i
                    a_poisson%coeff(6,i,j,k) = 1.0d0 * dzmn2i

                enddo
            enddo
        enddo

    end subroutine matrix_heptadiagonal_create

    !>
    !> @brief       Destroy the heptadiagonal matrix for finite difference method with 7-stencil points
    !> @param       a_poisson   Matrix of matrix_heptadiagonal type
    !>
    subroutine matrix_heptadiagonal_destroy(a_poisson)

        implicit none

        type(matrix_heptadiagonal), intent(inout)     :: a_poisson

        a_poisson%dof = 0
        deallocate( a_poisson%coeff )

    end subroutine matrix_heptadiagonal_destroy

end module matrix


! Response Spectra
!
! Original code by Doug Dreger
! Wrapper by Geoffrey Ely
!
! Create Python module with:
!     f2py -c -m rspectra rspectra.f90
!
! real component of displacement spectrum:    rd = z(1)
! real component of velocity spectrum:        rv = z(2)
! real component of acceleration spectrum:    aa = z(3)
! imaginary component of velocity spectrum:   prv = w * z(1)
! imaginary component of velocity spectrum:   pra = w * prv
! imaginary vel = i*w* real displacement
! imaginary acc = i*w* real velocity

! Wrapper
! u : acceleration time history
! dt : time step length
! w : angular frequency = 2 pi / T
! d : damping ratio
! n : number of samples (automatically determined)
subroutine rspectra(z, u, dt, w, d, n)
implicit none
real, intent(out) :: z(3)
real, intent(in) :: u(n), dt, w, d
integer, intent(in) :: n
!f2py intent(hide) :: n
if (w > 0.4 * acos(0.0) / dt) then
    call ucmpmx(z, u, dt, w, d, n-1)
else
    call cmpmax(z, u, dt, w, d, n-1)
end if
end subroutine

subroutine cmpmax(z, ug, dt, w, d, kug)
real ug(*), x1(3), x2(3), z(3), c(3)
wd = sqrt(1.0 - d * d) * w
w2 = w * w
w3 = w2 * w
do i = 1, 3
    x1(i) = 0.0
    z(i) = 0.0
end do
f1 = 2.0 * d / (w3 * dt)
f2 = 1.0 / w2
f3 = d * w
f4 = 1.0 / wd
f5 = f3 * f4
f6 = 2.0 * f3
e = exp(-f3 * dt)
g1 = e * sin(wd * dt)
g2 = e * cos(wd * dt)
h1 = wd * g2 - f3 * g1
h2 = wd * g1 + f3 * g2
do k = 1, kug
    dug = ug(k+1) - ug(k)
    z1 = f2 * dug
    z2 = f2 * ug(k)
    z3 = f1 * dug
    z4 = z1 / dt
    b = x1(1) + z2 - z3
    a = f4 * x1(2) + f5 * b + f4 * z4
    x2(1) = a * g1 + b * g2 + z3 - z2 - z1
    x2(2) = a * h1 - b * h2 - z4
    x2(3) = -f6 * x2(2) - w2 * x2(1)
    do l = 1, 3
        c(l) = abs(x2(l))
        if (c(l) .gt. z(l)) z(l) = c(l)
        x1(l) = x2(l)
    end do
end do
end subroutine

subroutine ucmpmx(z, ug, dt0, w, d, kug)
real ug(*), z(3), c(3), x1(3), x2(3)
pr = 4.0 * acos(0.0) / w
wd = sqrt(1.0 - d * d) * w
w2 = w * w
w3 = w2 * w
do i = 1, 3
    x1(i) = 0.0
    z(i) = 0.0
end do
f2 = 1.0 / w2
f3 = d * w
f4 = 1.0 / wd
f5 = f3 * f4
f6 = 2.0 * f3
dt = dt0
ns = nint(10.0 * dt / pr)+1
dt = dt / real(ns)
f1 = 2.0 * d / w3 / dt
e = exp(-f3 * dt)
g1 = e * sin(wd * dt)
g2 = e * cos(wd * dt)
h1 = wd * g2 - f3 * g1
h2 = wd * g1 + f3 * g2
do k = 1, kug
    dug = (ug(k+1) - ug(k)) / real(ns)
    g = ug(k)
    z1 = f2 * dug
    z3 = f1 * dug
    z4 = z1 / dt
    do is = 1, ns
        z2 = f2 * g
        b = x1(1) + z2 - z3
        a = f4 * x1(2) + f5 * b + f4 * z4
        x2(1) = a * g1 + b * g2 + z3 - z2 - z1
        x2(2) = a * h1 - b * h2 - z4
        x2(3) = -f6 * x2(2) - w2 * x2(,1)
        do l = 1, 3
            c(l) = abs(x2(l))
            if (c(l) .gt. z(l)) z(l) = c(l)
            x1(l) = x2(l)
        end do
        g = g + dug
    end do
end do
end subroutine


      subroutine smooth1(ya, n1, n2, wk, frac)
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
      use parambs
      use vmec0
      implicit none
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      integer n1, n2
      real(rprec) frac
      real(rprec), dimension(*) :: ya, wk
C-----------------------------------------------
C   L o c a l   P a r a m e t e r s
C-----------------------------------------------
       real(rprec), parameter :: zero = 0, one = 1
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      integer :: n11, n21, n, i
      real(rprec) :: as, a, a1, a2, a3
C-----------------------------------------------
c--
c       smoothing real array ya(*) for i: n1.le.i.le.n2
c     frac - defines how strong is smoothing;
c     if frac=0 then only smoothes the peaks
c--
      n11 = n1 + 1
      n21 = n2 - 1
      n = n21 - n11
      if (n .le. 0) return                    !too little number of points
c
c- check the edges
c
      as = sum(abs(ya(n11:n21-1)-ya(n11+1:n21)))
      as = as/n
c
      if (as .le. zero) then
         ya(n1) = ya(n11)
         ya(n2) = ya(n21)
         return
      else
         a = 3*(as + abs(ya(n11)-ya(n11+1)))
         a1 = abs(ya(n1)-ya(n11))
         if (a1 > a) ya(n1) = 2*ya(n11) - ya(n11+1)
         a = 3*(as + abs(ya(n21)-ya(n21-1)))
         a1 = abs(ya(n2)-ya(n21))
         if (a1 > a) ya(n2) = 2*ya(n21) - ya(n21-1)
      endif
c
c- work array
c
      wk(n1:n2) = ya(n1:n2)
c
c- check for strong peaks and remove
c
      do i = n11, n21
         a1 = .5_dp*(ya(i+1)+ya(i-1))
         a2 = 3*abs(ya(i+1)-ya(i-1))
         a3 = abs(ya(i)-a1)
         if (a3 > a2) ya(i) = a1
      end do
c
c- smoothing with a factor frac
c
      if (frac .le. zero) return
      ya(n11:n21) =(ya(n11:n21)+.5_dp*(wk(n11+1:n21+1)+wk(n11-1:n21-1))*
     1   frac)/(one + frac)

      end subroutine smooth1


!
!     CalculiX - A 3-dimensional finite element program
!              Copyright (C) 1998-2015 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
      subroutine orthotropic(orthol,anisox)
!
!     expands the 9 orthotropic elastic constants into a
!     3x3x3x3 matrix
!
      implicit none
!
      real*8 orthol(9),anisox(3,3,3,3)
!
      anisox(1,1,1,1)=orthol(1)
      anisox(1,1,1,2)=0.d0
      anisox(1,1,1,3)=0.d0
      anisox(1,1,2,1)=0.d0
      anisox(1,1,2,2)=orthol(2)
      anisox(1,1,2,3)=0.d0
      anisox(1,1,3,1)=0.d0
      anisox(1,1,3,2)=0.d0
      anisox(1,1,3,3)=orthol(4)
      anisox(1,2,1,1)=0.d0
      anisox(1,2,1,2)=orthol(7)
      anisox(1,2,1,3)=0.d0
      anisox(1,2,2,1)=orthol(7)
      anisox(1,2,2,2)=0.d0
      anisox(1,2,2,3)=0.d0
      anisox(1,2,3,1)=0.d0
      anisox(1,2,3,2)=0.d0
      anisox(1,2,3,3)=0.d0
      anisox(1,3,1,1)=0.d0
      anisox(1,3,1,2)=0.d0
      anisox(1,3,1,3)=orthol(8)
      anisox(1,3,2,1)=0.d0
      anisox(1,3,2,2)=0.d0
      anisox(1,3,2,3)=0.d0
      anisox(1,3,3,1)=orthol(8)
      anisox(1,3,3,2)=0.d0
      anisox(1,3,3,3)=0.d0
      anisox(2,1,1,1)=0.d0
      anisox(2,1,1,2)=orthol(7)
      anisox(2,1,1,3)=0.d0
      anisox(2,1,2,1)=orthol(7)
      anisox(2,1,2,2)=0.d0
      anisox(2,1,2,3)=0.d0
      anisox(2,1,3,1)=0.d0
      anisox(2,1,3,2)=0.d0
      anisox(2,1,3,3)=0.d0
      anisox(2,2,1,1)=orthol(2)
      anisox(2,2,1,2)=0.d0
      anisox(2,2,1,3)=0.d0
      anisox(2,2,2,1)=0.d0
      anisox(2,2,2,2)=orthol(3)
      anisox(2,2,2,3)=0.d0
      anisox(2,2,3,1)=0.d0
      anisox(2,2,3,2)=0.d0
      anisox(2,2,3,3)=orthol(5)
      anisox(2,3,1,1)=0.d0
      anisox(2,3,1,2)=0.d0
      anisox(2,3,1,3)=0.d0
      anisox(2,3,2,1)=0.d0
      anisox(2,3,2,2)=0.d0
      anisox(2,3,2,3)=orthol(9)
      anisox(2,3,3,1)=0.d0
      anisox(2,3,3,2)=orthol(9)
      anisox(2,3,3,3)=0.d0
      anisox(3,1,1,1)=0.d0
      anisox(3,1,1,2)=0.d0
      anisox(3,1,1,3)=orthol(8)
      anisox(3,1,2,1)=0.d0
      anisox(3,1,2,2)=0.d0
      anisox(3,1,2,3)=0.d0
      anisox(3,1,3,1)=orthol(8)
      anisox(3,1,3,2)=0.d0
      anisox(3,1,3,3)=0.d0
      anisox(3,2,1,1)=0.d0
      anisox(3,2,1,2)=0.d0
      anisox(3,2,1,3)=0.d0
      anisox(3,2,2,1)=0.d0
      anisox(3,2,2,2)=0.d0
      anisox(3,2,2,3)=orthol(9)
      anisox(3,2,3,1)=0.d0
      anisox(3,2,3,2)=orthol(9)
      anisox(3,2,3,3)=0.d0
      anisox(3,3,1,1)=orthol(4)
      anisox(3,3,1,2)=0.d0
      anisox(3,3,1,3)=0.d0
      anisox(3,3,2,1)=0.d0
      anisox(3,3,2,2)=orthol(5)
      anisox(3,3,2,3)=0.d0
      anisox(3,3,3,1)=0.d0
      anisox(3,3,3,2)=0.d0
      anisox(3,3,3,3)=orthol(6)
!
      return
      end