      SUBROUTINE TB04BW( ORDER, P, M, MD, IGN, LDIGN, IGD, LDIGD, GN,
     $                   GD, D, LDD, INFO )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To compute the sum of an P-by-M rational matrix G and a real
C     P-by-M matrix D.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     ORDER   CHARACTER*1
C             Specifies the order in which the polynomial coefficients
C             of the rational matrix are stored, as follows:
C             = 'I':  Increasing order of powers of the indeterminate;
C             = 'D':  Decreasing order of powers of the indeterminate.
C
C     Input/Output Parameters
C
C     P       (input) INTEGER
C             The number of the system outputs.  P >= 0.
C
C     M       (input) INTEGER
C             The number of the system inputs.  M >= 0.
C
C     MD      (input) INTEGER
C             The maximum degree of the polynomials in G, plus 1, i.e.,
C             MD = MAX(IGN(I,J),IGD(I,J)) + 1.
C                  I,J
C
C     IGN     (input/output) INTEGER array, dimension (LDIGN,M)
C             On entry, the leading P-by-M part of this array must
C             contain the degrees of the numerator polynomials in G:
C             the (i,j) element of IGN must contain the degree of the
C             numerator polynomial of the polynomial ratio G(i,j).
C             On exit, the leading P-by-M part of this array contains
C             the degrees of the numerator polynomials in G + D.
C
C     LDIGN   INTEGER
C             The leading dimension of array IGN.  LDIGN >= max(1,P).
C
C     IGD     (input) INTEGER array, dimension (LDIGD,M)
C             The leading P-by-M part of this array must contain the
C             degrees of the denominator polynomials in G (and G + D):
C             the (i,j) element of IGD contains the degree of the
C             denominator polynomial of the polynomial ratio G(i,j).
C
C     LDIGD   INTEGER
C             The leading dimension of array IGD.  LDIGD >= max(1,P).
C
C     GN      (input/output) DOUBLE PRECISION array, dimension (P*M*MD)
C             On entry, this array must contain the coefficients of the
C             numerator polynomials, Num(i,j), of the rational matrix G.
C             The polynomials are stored in a column-wise order, i.e.,
C             Num(1,1), Num(2,1), ..., Num(P,1), Num(1,2), Num(2,2),
C             ..., Num(P,2), ..., Num(1,M), Num(2,M), ..., Num(P,M);
C             MD memory locations are reserved for each polynomial,
C             hence, the (i,j) polynomial is stored starting from the
C             location ((j-1)*P+i-1)*MD+1. The coefficients appear in
C             increasing or decreasing order of the powers of the
C             indeterminate, according to ORDER.
C             On exit, this array contains the coefficients of the
C             numerator polynomials of the rational matrix G + D,
C             stored similarly.
C
C     GD      (input) DOUBLE PRECISION array, dimension (P*M*MD)
C             This array must contain the coefficients of the
C             denominator polynomials, Den(i,j), of the rational
C             matrix G. The polynomials are stored as for the
C             numerator polynomials.
C
C     D       (input) DOUBLE PRECISION array, dimension (LDD,M)
C             The leading P-by-M part of this array must contain the
C             matrix D.
C
C     LDD     INTEGER
C             The leading dimension of array D.  LDD >= max(1,P).
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value.
C
C     METHOD
C
C     The (i,j) entry of the real matrix D is added to the (i,j) entry
C     of the matrix G, g(i,j), which is a ratio of two polynomials,
C     for i = 1 : P, and for j = 1 : M. If g(i,j) = 0, it is assumed
C     that its denominator is 1.
C
C     NUMERICAL ASPECTS
C
C     The algorithm is numerically stable.
C
C     FURTHER COMMENTS
C
C     Often, the rational matrix G is found from a state-space
C     representation (A,B,C), and D corresponds to the direct
C     feedthrough matrix of the system. The sum G + D gives the
C     transfer function matrix of the system (A,B,C,D).
C     For maximum efficiency of index calculations, GN and GD are
C     implemented as one-dimensional arrays.
C
C     CONTRIBUTORS
C
C     V. Sima, Research Institute for Informatics, Bucharest, May 2002.
C     Based on the BIMASC Library routine TMCADD by A. Varga.
C
C     REVISIONS
C
C     V. Sima, Research Institute for Informatics, Bucharest, Feb. 2004.
C
C     KEYWORDS
C
C     State-space representation, transfer function.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION   ZERO
      PARAMETER          ( ZERO = 0.0D0 )
C     .. Scalar Arguments ..
      CHARACTER          ORDER
      INTEGER            INFO, LDD, LDIGD, LDIGN, M, MD, P
C     .. Array Arguments ..
      DOUBLE PRECISION   D(LDD,*), GD(*), GN(*)
      INTEGER            IGD(LDIGD,*), IGN(LDIGN,*)
C     .. Local Scalars ..
      LOGICAL            ASCEND
      INTEGER            I, II, J, K, KK, KM, ND, NN
      DOUBLE PRECISION   DIJ
C     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
C     .. External Subroutines ..
      EXTERNAL           DAXPY, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
C     ..
C     .. Executable Statements ..
C
C     Test the input scalar parameters.
C
      INFO   = 0
      ASCEND = LSAME( ORDER, 'I' )
      IF( .NOT.ASCEND .AND. .NOT.LSAME( ORDER, 'D' ) ) THEN
         INFO = -1
      ELSE IF( P.LT.0 ) THEN
         INFO = -2
      ELSE IF( M.LT.0 ) THEN
         INFO = -3
      ELSE IF( MD.LT.1 ) THEN
         INFO = -4
      ELSE IF( LDIGN.LT.MAX( 1, P ) ) THEN
         INFO = -6
      ELSE IF( LDIGD.LT.MAX( 1, P ) ) THEN
         INFO = -8
      ELSE IF( LDD.LT.MAX( 1, P ) ) THEN
         INFO = -12
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'TB04BW', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( MIN( P, M ).EQ.0 )
     $   RETURN
C
      K = 1
C
      IF ( ASCEND ) THEN
C
C        Polynomial coefficients are stored in increasing order.
C
         DO 30 J = 1, M
C
            DO 20 I = 1, P
               DIJ = D(I,J)
               IF ( DIJ.NE.ZERO ) THEN
                  NN = IGN(I,J)
                  ND = IGD(I,J)
                  IF ( NN.EQ.0 .AND. ND.EQ.0 ) THEN
                     IF ( GN(K).EQ.ZERO ) THEN
                        GN(K) = DIJ
                     ELSE
                        GN(K) = GN(K) + DIJ*GD(K)
                     ENDIF
                  ELSE
                     KM = MIN( NN, ND ) + 1
                     CALL DAXPY( KM, DIJ, GD(K), 1, GN(K), 1 )
                     IF ( NN.LT.ND ) THEN
C
                        DO 10 II = K + KM, K + ND
                           GN(II) = DIJ*GD(II)
   10                   CONTINUE
C
                        IGN(I,J) = ND
                      ENDIF
                  ENDIF
               ENDIF
               K = K + MD
   20       CONTINUE
C
   30    CONTINUE
C
      ELSE
C
C        Polynomial coefficients are stored in decreasing order.
C
         DO 60 J = 1, M
C
            DO 50 I = 1, P
               DIJ = D(I,J)
               IF ( DIJ.NE.ZERO ) THEN
                  NN = IGN(I,J)
                  ND = IGD(I,J)
                  IF ( NN.EQ.0 .AND. ND.EQ.0 ) THEN
                     IF ( GN(K).EQ.ZERO ) THEN
                        GN(K) = DIJ
                     ELSE
                        GN(K) = GN(K) + DIJ*GD(K)
                     ENDIF
                  ELSE
                     KM = MIN( NN, ND ) + 1
                     IF ( NN.LT.ND ) THEN
                        KK = K + ND - NN
C
                        DO 35 II = K + NN, K, -1
                           GN(II+ND-NN) = GN(II)
   35                   CONTINUE
C
                        DO 40 II = K, KK - 1
                           GN(II) = DIJ*GD(II)
   40                   CONTINUE
C
                        IGN(I,J) = ND
                        CALL DAXPY( KM, DIJ, GD(KK), 1, GN(KK), 1 )
                     ELSE
                        KK = K + NN - ND
                        CALL DAXPY( KM, DIJ, GD(K), 1, GN(KK), 1 )
                     ENDIF
                  ENDIF
               ENDIF
               K = K + MD
   50       CONTINUE
C
   60    CONTINUE
C
      ENDIF
C
      RETURN
C *** Last line of TB04BW ***
      END


*> \brief \b CUNGTSQR_ROW
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download CUNGTSQR_ROW + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*>
*  Definition:
*  ===========
*
*       SUBROUTINE CUNGTSQR_ROW( M, N, MB, NB, A, LDA, T, LDT, WORK,
*      $                         LWORK, INFO )
*       IMPLICIT NONE
*
*       .. Scalar Arguments ..
*       INTEGER           INFO, LDA, LDT, LWORK, M, N, MB, NB
*       ..
*       .. Array Arguments ..
*       COMPLEX           A( LDA, * ), T( LDT, * ), WORK( * )
*       ..
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> CUNGTSQR_ROW generates an M-by-N complex matrix Q_out with
*> orthonormal columns from the output of CLATSQR. These N orthonormal
*> columns are the first N columns of a product of complex unitary
*> matrices Q(k)_in of order M, which are returned by CLATSQR in
*> a special format.
*>
*>      Q_out = first_N_columns_of( Q(1)_in * Q(2)_in * ... * Q(k)_in ).
*>
*> The input matrices Q(k)_in are stored in row and column blocks in A.
*> See the documentation of CLATSQR for more details on the format of
*> Q(k)_in, where each Q(k)_in is represented by block Householder
*> transformations. This routine calls an auxiliary routine CLARFB_GETT,
*> where the computation is performed on each individual block. The
*> algorithm first sweeps NB-sized column blocks from the right to left
*> starting in the bottom row block and continues to the top row block
*> (hence _ROW in the routine name). This sweep is in reverse order of
*> the order in which CLATSQR generates the output blocks.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] M
*> \verbatim
*>          M is INTEGER
*>          The number of rows of the matrix A.  M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The number of columns of the matrix A. M >= N >= 0.
*> \endverbatim
*>
*> \param[in] MB
*> \verbatim
*>          MB is INTEGER
*>          The row block size used by CLATSQR to return
*>          arrays A and T. MB > N.
*>          (Note that if MB > M, then M is used instead of MB
*>          as the row block size).
*> \endverbatim
*>
*> \param[in] NB
*> \verbatim
*>          NB is INTEGER
*>          The column block size used by CLATSQR to return
*>          arrays A and T. NB >= 1.
*>          (Note that if NB > N, then N is used instead of NB
*>          as the column block size).
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*>          A is COMPLEX array, dimension (LDA,N)
*>
*>          On entry:
*>
*>             The elements on and above the diagonal are not used as
*>             input. The elements below the diagonal represent the unit
*>             lower-trapezoidal blocked matrix V computed by CLATSQR
*>             that defines the input matrices Q_in(k) (ones on the
*>             diagonal are not stored). See CLATSQR for more details.
*>
*>          On exit:
*>
*>             The array A contains an M-by-N orthonormal matrix Q_out,
*>             i.e the columns of A are orthogonal unit vectors.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*>          LDA is INTEGER
*>          The leading dimension of the array A.  LDA >= max(1,M).
*> \endverbatim
*>
*> \param[in] T
*> \verbatim
*>          T is COMPLEX array,
*>          dimension (LDT, N * NIRB)
*>          where NIRB = Number_of_input_row_blocks
*>                     = MAX( 1, CEIL((M-N)/(MB-N)) )
*>          Let NICB = Number_of_input_col_blocks
*>                   = CEIL(N/NB)
*>
*>          The upper-triangular block reflectors used to define the
*>          input matrices Q_in(k), k=(1:NIRB*NICB). The block
*>          reflectors are stored in compact form in NIRB block
*>          reflector sequences. Each of the NIRB block reflector
*>          sequences is stored in a larger NB-by-N column block of T
*>          and consists of NICB smaller NB-by-NB upper-triangular
*>          column blocks. See CLATSQR for more details on the format
*>          of T.
*> \endverbatim
*>
*> \param[in] LDT
*> \verbatim
*>          LDT is INTEGER
*>          The leading dimension of the array T.
*>          LDT >= max(1,min(NB,N)).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*>          (workspace) COMPLEX array, dimension (MAX(1,LWORK))
*>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*>          The dimension of the array WORK.
*>          LWORK >= NBLOCAL * MAX(NBLOCAL,(N-NBLOCAL)),
*>          where NBLOCAL=MIN(NB,N).
*>          If LWORK = -1, then a workspace query is assumed.
*>          The routine only calculates the optimal size of the WORK
*>          array, returns this value as the first entry of the WORK
*>          array, and no error message related to LWORK is issued
*>          by XERBLA.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*>          INFO is INTEGER
*>          = 0:  successful exit
*>          < 0:  if INFO = -i, the i-th argument had an illegal value
*> \endverbatim
*>
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2020
*
*> \ingroup complexOTHERcomputational
*
*> \par Contributors:
*  ==================
*>
*> \verbatim
*>
*> November 2020, Igor Kozachenko,
*>                Computer Science Division,
*>                University of California, Berkeley
*>
*> \endverbatim
*>
*  =====================================================================
      SUBROUTINE CUNGTSQR_ROW( M, N, MB, NB, A, LDA, T, LDT, WORK,
     $                         LWORK, INFO )
      IMPLICIT NONE
*
*  -- LAPACK computational routine (version 3.10.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2020
*
*     .. Scalar Arguments ..
      INTEGER           INFO, LDA, LDT, LWORK, M, N, MB, NB
*     ..
*     .. Array Arguments ..
      COMPLEX           A( LDA, * ), T( LDT, * ), WORK( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      COMPLEX            CONE, CZERO
      PARAMETER          ( CONE = ( 1.0E+0, 0.0E+0 ),
     $                     CZERO = ( 0.0E+0, 0.0E+0 ) )
*     ..
*     .. Local Scalars ..
      LOGICAL            LQUERY
      INTEGER            NBLOCAL, MB2, M_PLUS_ONE, ITMP, IB_BOTTOM,
     $                   LWORKOPT, NUM_ALL_ROW_BLOCKS, JB_T, IB, IMB,
     $                   KB, KB_LAST, KNB, MB1
*     ..
*     .. External Subroutines ..
      EXTERNAL           CLARFB_GETT, CLASET, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          CMPLX, MAX, MIN
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters
*
      INFO = 0
      LQUERY  = LWORK.EQ.-1
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 .OR. M.LT.N ) THEN
         INFO = -2
      ELSE IF( MB.LE.N ) THEN
         INFO = -3
      ELSE IF( NB.LT.1 ) THEN
         INFO = -4
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -6
      ELSE IF( LDT.LT.MAX( 1, MIN( NB, N ) ) ) THEN
         INFO = -8
      ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN
         INFO = -10
      END IF
*
      NBLOCAL = MIN( NB, N )
*
*     Determine the workspace size.
*
      IF( INFO.EQ.0 ) THEN
         LWORKOPT = NBLOCAL * MAX( NBLOCAL, ( N - NBLOCAL ) )
      END IF
*
*     Handle error in the input parameters and handle the workspace query.
*
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'CUNGTSQR_ROW', -INFO )
         RETURN
      ELSE IF ( LQUERY ) THEN
         WORK( 1 ) = CMPLX( LWORKOPT )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( MIN( M, N ).EQ.0 ) THEN
         WORK( 1 ) = CMPLX( LWORKOPT )
         RETURN
      END IF
*
*     (0) Set the upper-triangular part of the matrix A to zero and
*     its diagonal elements to one.
*
      CALL CLASET('U', M, N, CZERO, CONE, A, LDA )
*
*     KB_LAST is the column index of the last column block reflector
*     in the matrices T and V.
*
      KB_LAST = ( ( N-1 ) / NBLOCAL ) * NBLOCAL + 1
*
*
*     (1) Bottom-up loop over row blocks of A, except the top row block.
*     NOTE: If MB>=M, then the loop is never executed.
*
      IF ( MB.LT.M ) THEN
*
*        MB2 is the row blocking size for the row blocks before the
*        first top row block in the matrix A. IB is the row index for
*        the row blocks in the matrix A before the first top row block.
*        IB_BOTTOM is the row index for the last bottom row block
*        in the matrix A. JB_T is the column index of the corresponding
*        column block in the matrix T.
*
*        Initialize variables.
*
*        NUM_ALL_ROW_BLOCKS is the number of row blocks in the matrix A
*        including the first row block.
*
         MB2 = MB - N
         M_PLUS_ONE = M + 1
         ITMP = ( M - MB - 1 ) / MB2
         IB_BOTTOM = ITMP * MB2 + MB + 1
         NUM_ALL_ROW_BLOCKS = ITMP + 2
         JB_T = NUM_ALL_ROW_BLOCKS * N + 1
*
         DO IB = IB_BOTTOM, MB+1, -MB2
*
*           Determine the block size IMB for the current row block
*           in the matrix A.
*
            IMB = MIN( M_PLUS_ONE - IB, MB2 )
*
*           Determine the column index JB_T for the current column block
*           in the matrix T.
*
            JB_T = JB_T - N
*
*           Apply column blocks of H in the row block from right to left.
*
*           KB is the column index of the current column block reflector
*           in the matrices T and V.
*
            DO KB = KB_LAST, 1, -NBLOCAL
*
*              Determine the size of the current column block KNB in
*              the matrices T and V.
*
               KNB = MIN( NBLOCAL, N - KB + 1 )
*
               CALL CLARFB_GETT( 'I', IMB, N-KB+1, KNB,
     $                     T( 1, JB_T+KB-1 ), LDT, A( KB, KB ), LDA,
     $                     A( IB, KB ), LDA, WORK, KNB )
*
            END DO
*
         END DO
*
      END IF
*
*     (2) Top row block of A.
*     NOTE: If MB>=M, then we have only one row block of A of size M
*     and we work on the entire matrix A.
*
      MB1 = MIN( MB, M )
*
*     Apply column blocks of H in the top row block from right to left.
*
*     KB is the column index of the current block reflector in
*     the matrices T and V.
*
      DO KB = KB_LAST, 1, -NBLOCAL
*
*        Determine the size of the current column block KNB in
*        the matrices T and V.
*
         KNB = MIN( NBLOCAL, N - KB + 1 )
*
         CALL CLARFB_GETT( 'N', MB1-KB-KNB+1, N-KB+1, KNB,
     $               T( 1, KB ), LDT, A( KB, KB ), LDA,
     $               A( KB+KNB, KB), LDA, WORK, KNB )
*
      END DO
*
      WORK( 1 ) = CMPLX( LWORKOPT )
      RETURN
*
*     End of CUNGTSQR_ROW
*
      END


SUBROUTINE dispcrv(npoin,nelem,lnods,lside,ldv2sd,nodcre,nwlnd,lindi,cd,cvdisp)
!-----------------------------------------------------------------------
! compute displacements of the new nodes by the curvature of the sheet
!-----------------------------------------------------------------------
IMPLICIT NONE

  !--- Dummy variables
  INTEGER(kind=4),INTENT(IN):: npoin,          & !Number of nodes
                               nelem             !Number of elements in the set
  INTEGER(kind=4),POINTER:: lnods(:,:),     & !Conectivities of the set
                            ldv2sd(:,:),    & !Element side subdivision
                            lside(:,:),     & !Neighbor elements of the set
                            nodcre(:,:),    & !Nodes between is generated a new node
                            nwlnd(:,:),     & !new conectivities of refined mesh
                            lindi(:)          !label of new element by old elements
  REAL(kind=8),INTENT(IN):: cd(:,:)     !Nodal coordinates
  REAL(kind=8),POINTER:: cvdisp(:,:)    !Displacements of culvature correction

  !--- Local variables
  INTEGER(kind=4),PARAMETER:: nxn(3) = (/ 2,3,1 /) !next node in connectv.
  INTEGER(kind=4):: i, j, k, nn(3), ielem, jelem, kelem, ipoin, elcre(0:6), newnds, newel

  REAL(kind=8):: ls(3,2), t(3), n(3), long, curv, area, zdisp
  LOGICAL:: found
  INTEGER(kind=4),ALLOCATABLE:: bnod1(:), bnod2(:)
  REAL(kind=8),ALLOCATABLE:: tn(:,:), tw(:,:)
  LOGICAL,ALLOCATABLE:: actnd(:)

  ! ****  Compute nodal normals and elements Z-increments of a surface  ***
  newnds = nodcre(1,0)   !Number of new nodes in the refinement process
  newel = nodcre(2,0)    !Number of elements in the new refined mesh

  ALLOCATE(tn(3,npoin),tw(3,newnds),actnd(npoin))
  actnd(1:npoin) = .TRUE.
  tn(1:3,1:npoin) = 0d0         !nodal average normals initialization
  tw(1:3,1:newnds) = 0d0        !new nodal normals initialization

  ALLOCATE(bnod1(npoin),bnod2(npoin))   !Identify boundary nodes
  bnod1(1:npoin) = 0            !boundary  first node initialization (0 for inner node)
  bnod2(1:npoin) = 0            !boundary second node initialization (0 for inner node)

  ! Compute average normals at the nodes and the new nodal points
  kelem = 1
  found = .FALSE.
  DO ielem=1,nelem                         !for each element

    actnd(lnods(1:3,ielem)) = .FALSE.
    nn(1:3) = lnods(1:3,ielem)                   !connectivities of the element
    DO i=1,2                                     !first two side elements
      k = nxn(i)                                 !next node
      ls(1:3,i) = cd(1:3,nn(k)) - cd(1:3,nn(i))  !tang. vector
    END DO
    CALL vecpro(ls(1:3,1),ls(1:3,2),t)              !normal*area*2
    area = 0.5d0*DSQRT(DOT_PRODUCT(t(1:3),t(1:3)))  !Element area
    t(1:3) = t(1:3)/(2d0*area*area)       !Unitary normal divided by the area
    DO i=1,3
      k = nn(i)              !node number
      tn(1:3,k) = tn(1:3,k) + t  !sums on average unitary normal weighted by the inverse of the area
      IF (lside(i,ielem) /= 0) CYCLE   !Identify nodes of the boundary
      j = nn(nxn(i))    !Next node
      bnod1(k) = j      !Identify first node of the boundary
      bnod2(j) = k      !Identify second node of the boundary
    END DO

    !Found elements that created new nodal points
    IF (.NOT.found) THEN
      jelem = kelem - 1
      elcre = 0
      DO
        jelem = jelem + 1
        IF (lindi(jelem) /= ielem) CYCLE
        elcre(1) = jelem
        k = 1
        DO
          jelem = jelem + 1
          IF (jelem > newel) EXIT
          IF (lindi(jelem) == ielem) THEN
            k = k + 1                      !Se trata de un elemento divido en k veces
            elcre(k) = jelem               !Numero del k-esimo elemento de la division
          ELSE
            EXIT
          END IF
        END DO
        elcre(0) = k                   !Elemento dividido en k-veces
        IF (k > 1) found=.TRUE.
        EXIT
      END DO
      kelem = kelem + elcre(0)
    END IF

    !Compute average normals at the new nodal points
    IF (found) THEN
      found = .FALSE.
      SELECT CASE (elcre(0))
      CASE (2)
        k = nwlnd(1,elcre(2)) - npoin   !Number of node created
        tw(1:3,k) = tw(1:3,k) + t(1:3)        !sums on average unitary normal weighted by the inverse of the area
      CASE (4)
        IF (ldv2sd(3,ielem) == 0) THEN  !is a element divided by 2
          IF (lnods(2,ielem) == nwlnd(2,elcre(3))) THEN
            found = .TRUE.   !First of the two primitive elements
            k = nwlnd(1,elcre(3)) - npoin
            tw(1:3,k) = tw(1:3,k) + t(1:3)
          ELSE   ! IF ( lnods(2,ielem) == nwlnd(3,elcre(4)) ) THEN
            k = nwlnd(1,elcre(4)) - npoin
            tw(1:3,k) = tw(1:3,k) + t(1:3)
          END IF
        ELSE                         !is a single primitive element
          DO i=2,4
            k = nwlnd(1,elcre(i)) - npoin
            tw(1:3,k) = tw(1:3,k) + t(1:3)
          END DO
        END IF
      CASE (5)
        IF ( lnods(2,ielem) == nwlnd(2,elcre(3)) ) THEN  !This is the first element if second is refined twice
          found = .TRUE.   !First of the two primitive elements
          k = nwlnd(1,elcre(3)) - npoin
          tw(1:3,k) = tw(1:3,k) + t(1:3)
        ELSE IF ( lnods(2,ielem) == nwlnd(2,elcre(5)) ) THEN  !This is the second element if first is refined twice
          DO i=4,5
            k = nwlnd(1,elcre(i)) - npoin
            tw(1:3,k) = tw(1:3,k) + t(1:3)
          END DO
        ELSE IF ( lnods(2,ielem) == nwlnd(2,elcre(4)) ) THEN  !This is the first element if it is refined twice
          found = .TRUE.   !First of the two primitive elements
          DO i=4,5
            k = nwlnd(1,elcre(i)) - npoin
            tw(1:3,k) = tw(1:3,k) + t(1:3)
          END DO
        ELSE ! IF ( lnods(2,ielem) == nwlnd(3,elcre(3)) ) THEN  !This is the second element if first is refined twice
          k = nwlnd(1,elcre(3)) - npoin
          tw(1:3,k) = tw(1:3,k) + t(1:3)
        END IF
      CASE (6)
        IF ( lnods(2,ielem) == nwlnd(2,elcre(3)) ) THEN  !This is the first element (refined twice)
          found = .TRUE.   !First of the two primitive elements
          DO i=3,4
            k = nwlnd(1,elcre(i)) - npoin
            tw(1:3,k) = tw(1:3,k) + t(1:3)
          END DO
        ELSE ! IF ( lnods(2,ielem) == nwlnd(2,elcre(6)) ) THEN  !This is the second element (refined twice too)
          DO i=5,6
            k = nwlnd(1,elcre(i)) - npoin
            tw(1:3,k) = tw(1:3,k) + t(1:3)
          END DO
        END IF
      END SELECT
    END IF

  END DO

  ! Compute unitary normals at the nodes
  DO ipoin=1,npoin
    IF (actnd(ipoin)) CYCLE
    t(1:3) = tn(1:3,ipoin)                    !weighted normal
    long = DSQRT(DOT_PRODUCT(t(1:3),t(1:3)))  !length
    IF (long > 0d0) tn(1:3,ipoin) = t(1:3)/long  !unit vector for nodes
  END DO

  ! Compute curvatures at the new nodes
  DO i=1,newnds
    t(1:3) = tw(1:3,i)                        !weighted normal
    long = DSQRT(DOT_PRODUCT(t(1:3),t(1:3)))  !length
    IF (long > 0d0) tw(1:3,i) = t(1:3)/long   !unit vector (for new nodes)

    nn(1:2) = nodcre(1:2,i)
    found = bnod1(nn(1))==nn(2) .OR. bnod2(nn(1))==nn(2)  !TRUE for a boundary new node
    IF ( found ) THEN  !new node is a boundary node
      cvdisp(1:3,i) = 0d0
    ELSE                                         !new node is a inner node
      n(1:3) = tn(1:3,nn(2)) - tn(1:3,nn(1))  !Normal increment
      t(1:3) = cd(1:3,nn(2)) - cd(1:3,nn(1))  !Tangent vector
      long = DSQRT(DOT_PRODUCT(t(1:3),t(1:3)))    !Nodal distant
      t = t/long                                  !Unitary tangent vector
      curv = DOT_PRODUCT(n(1:3),t(1:3))           !Curvature at the new node * long

      zdisp = -0.25d0*curv*curv + 1d0
      IF (zdisp <= 0d0) zdisp=0d0
      zdisp = DSQRT(zdisp)
      zdisp = DSQRT((1d0-zdisp)/(1d0+zdisp))*long*0.5d0  !Nodal value of the displacement by curvature
      IF (curv < 0d0) zdisp=-zdisp

      cvdisp(1:3,i) = zdisp*tw(1:3,i)   !Nodal displacement by curvature
    END IF
  END DO

  DEALLOCATE(tn,tw,bnod1,bnod2,actnd)  !release memory

RETURN
END SUBROUTINE dispcrv


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

      subroutine y_solve(rho_i, qs, square, u, rhs, nx, nxmax, ny, nz)

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

c---------------------------------------------------------------------
c     Performs line solves in Y direction by first factoring
c     the block-tridiagonal matrix into an upper triangular matrix,
c     and then performing back substitution to solve for the unknow
c     vectors of each line.
c
c     Make sure we treat elements zero to cell_size in the direction
c     of the sweep.
c---------------------------------------------------------------------

      include 'header.h'
      include 'work_lhs_vec.h'

      integer nx, nxmax, ny, nz
      double precision rho_i(  0:nxmax-1,0:ny-1,0:nz-1),
     $                 qs    ( 0:nxmax-1,0:ny-1,0:nz-1),
     $                 square( 0:nxmax-1,0:ny-1,0:nz-1),
     $                 u    (5,0:nxmax-1,0:ny-1,0:nz-1),
     $                 rhs  (5,0:nxmax-1,0:ny-1,0:nz-1)

      integer i, j, k, m, n, jsize

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

      if (timeron) call timer_start(t_ysolve)

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

c---------------------------------------------------------------------
c     This function computes the left hand side for the three y-factors
c---------------------------------------------------------------------

!$OMP PARALLEL DEFAULT(SHARED) PRIVATE(n,m,j,i,k,jsize)
!$OMP&  SHARED(dy5,dy4,dy3,dy2,dy1,ty2,ty1,dt,c1345,con43,c3c4,c1,c2,
!$OMP&         nx,ny,nz)
      jsize = ny-1

c---------------------------------------------------------------------
c     Compute the indices for storing the tri-diagonal matrix;
c     determine a (labeled f) and n jacobians for cell c
c---------------------------------------------------------------------
!$OMP DO
      do k = 1, nz-2
         do j = 0, jsize
            do i = 1, nx-2

               tmp1 = rho_i(i,j,k)
               tmp2 = tmp1 * tmp1
               tmp3 = tmp1 * tmp2

               fjac(1,1,i,j) = 0.d0
               fjac(1,2,i,j) = 0.d0
               fjac(1,3,i,j) = 1.d0
               fjac(1,4,i,j) = 0.d0
               fjac(1,5,i,j) = 0.d0

               fjac(2,1,i,j) = - ( u(2,i,j,k)*u(3,i,j,k) )
     >              * tmp2
               fjac(2,2,i,j) = u(3,i,j,k) * tmp1
               fjac(2,3,i,j) = u(2,i,j,k) * tmp1
               fjac(2,4,i,j) = 0.d0
               fjac(2,5,i,j) = 0.d0

               fjac(3,1,i,j) = - ( u(3,i,j,k)*u(3,i,j,k)*tmp2)
     >              + c2 * qs(i,j,k)
               fjac(3,2,i,j) = - c2 *  u(2,i,j,k) * tmp1
               fjac(3,3,i,j) = ( 2.d0 - c2 )
     >              *  u(3,i,j,k) * tmp1
               fjac(3,4,i,j) = - c2 * u(4,i,j,k) * tmp1
               fjac(3,5,i,j) = c2

               fjac(4,1,i,j) = - ( u(3,i,j,k)*u(4,i,j,k) )
     >              * tmp2
               fjac(4,2,i,j) = 0.d0
               fjac(4,3,i,j) = u(4,i,j,k) * tmp1
               fjac(4,4,i,j) = u(3,i,j,k) * tmp1
               fjac(4,5,i,j) = 0.d0

               fjac(5,1,i,j) = ( c2 * 2.0d0 * square(i,j,k)
     >              - c1 * u(5,i,j,k) )
     >              * u(3,i,j,k) * tmp2
               fjac(5,2,i,j) = - c2 * u(2,i,j,k)*u(3,i,j,k)
     >              * tmp2
               fjac(5,3,i,j) = c1 * u(5,i,j,k) * tmp1
     >              - c2
     >              * ( qs(i,j,k)
     >              + u(3,i,j,k)*u(3,i,j,k) * tmp2 )
               fjac(5,4,i,j) = - c2 * ( u(3,i,j,k)*u(4,i,j,k) )
     >              * tmp2
               fjac(5,5,i,j) = c1 * u(3,i,j,k) * tmp1

               njac(1,1,i,j) = 0.d0
               njac(1,2,i,j) = 0.d0
               njac(1,3,i,j) = 0.d0
               njac(1,4,i,j) = 0.d0
               njac(1,5,i,j) = 0.d0

               njac(2,1,i,j) = - c3c4 * tmp2 * u(2,i,j,k)
               njac(2,2,i,j) =   c3c4 * tmp1
               njac(2,3,i,j) =   0.d0
               njac(2,4,i,j) =   0.d0
               njac(2,5,i,j) =   0.d0

               njac(3,1,i,j) = - con43 * c3c4 * tmp2 * u(3,i,j,k)
               njac(3,2,i,j) =   0.d0
               njac(3,3,i,j) =   con43 * c3c4 * tmp1
               njac(3,4,i,j) =   0.d0
               njac(3,5,i,j) =   0.d0

               njac(4,1,i,j) = - c3c4 * tmp2 * u(4,i,j,k)
               njac(4,2,i,j) =   0.d0
               njac(4,3,i,j) =   0.d0
               njac(4,4,i,j) =   c3c4 * tmp1
               njac(4,5,i,j) =   0.d0

               njac(5,1,i,j) = - (  c3c4
     >              - c1345 ) * tmp3 * (u(2,i,j,k)**2)
     >              - ( con43 * c3c4
     >              - c1345 ) * tmp3 * (u(3,i,j,k)**2)
     >              - ( c3c4 - c1345 ) * tmp3 * (u(4,i,j,k)**2)
     >              - c1345 * tmp2 * u(5,i,j,k)

               njac(5,2,i,j) = (  c3c4 - c1345 ) * tmp2 * u(2,i,j,k)
               njac(5,3,i,j) = ( con43 * c3c4
     >              - c1345 ) * tmp2 * u(3,i,j,k)
               njac(5,4,i,j) = ( c3c4 - c1345 ) * tmp2 * u(4,i,j,k)
               njac(5,5,i,j) = ( c1345 ) * tmp1

            enddo
         enddo

c---------------------------------------------------------------------
c     zero the whole left hand side for starters
c---------------------------------------------------------------------
         do i = 1, nx-2
            do m = 1, 5
               do n = 1, 5
                  lhs(m,n,aa,i,0) = 0.0d0
                  lhs(m,n,bb,i,0) = 0.0d0
                  lhs(m,n,cc,i,0) = 0.0d0
                  lhs(m,n,aa,i,jsize) = 0.0d0
                  lhs(m,n,bb,i,jsize) = 0.0d0
                  lhs(m,n,cc,i,jsize) = 0.0d0
               enddo
            enddo

c---------------------------------------------------------------------
c     next, set all diagonal values to 1. This is overkill, but convenient
c---------------------------------------------------------------------
            do m = 1, 5
               lhs(m,m,bb,i,0) = 1.0d0
               lhs(m,m,bb,i,jsize) = 1.0d0
            enddo
         enddo

c---------------------------------------------------------------------
c     now joacobians set, so form left hand side in y direction
c---------------------------------------------------------------------
         do j = 1, jsize-1
            do i = 1, nx-2

               tmp1 = dt * ty1
               tmp2 = dt * ty2

               lhs(1,1,aa,i,j) = - tmp2 * fjac(1,1,i,j-1)
     >              - tmp1 * njac(1,1,i,j-1)
     >              - tmp1 * dy1
               lhs(1,2,aa,i,j) = - tmp2 * fjac(1,2,i,j-1)
     >              - tmp1 * njac(1,2,i,j-1)
               lhs(1,3,aa,i,j) = - tmp2 * fjac(1,3,i,j-1)
     >              - tmp1 * njac(1,3,i,j-1)
               lhs(1,4,aa,i,j) = - tmp2 * fjac(1,4,i,j-1)
     >              - tmp1 * njac(1,4,i,j-1)
               lhs(1,5,aa,i,j) = - tmp2 * fjac(1,5,i,j-1)
     >              - tmp1 * njac(1,5,i,j-1)

               lhs(2,1,aa,i,j) = - tmp2 * fjac(2,1,i,j-1)
     >              - tmp1 * njac(2,1,i,j-1)
               lhs(2,2,aa,i,j) = - tmp2 * fjac(2,2,i,j-1)
     >              - tmp1 * njac(2,2,i,j-1)
     >              - tmp1 * dy2
               lhs(2,3,aa,i,j) = - tmp2 * fjac(2,3,i,j-1)
     >              - tmp1 * njac(2,3,i,j-1)
               lhs(2,4,aa,i,j) = - tmp2 * fjac(2,4,i,j-1)
     >              - tmp1 * njac(2,4,i,j-1)
               lhs(2,5,aa,i,j) = - tmp2 * fjac(2,5,i,j-1)
     >              - tmp1 * njac(2,5,i,j-1)

               lhs(3,1,aa,i,j) = - tmp2 * fjac(3,1,i,j-1)
     >              - tmp1 * njac(3,1,i,j-1)
               lhs(3,2,aa,i,j) = - tmp2 * fjac(3,2,i,j-1)
     >              - tmp1 * njac(3,2,i,j-1)
               lhs(3,3,aa,i,j) = - tmp2 * fjac(3,3,i,j-1)
     >              - tmp1 * njac(3,3,i,j-1)
     >              - tmp1 * dy3
               lhs(3,4,aa,i,j) = - tmp2 * fjac(3,4,i,j-1)
     >              - tmp1 * njac(3,4,i,j-1)
               lhs(3,5,aa,i,j) = - tmp2 * fjac(3,5,i,j-1)
     >              - tmp1 * njac(3,5,i,j-1)

               lhs(4,1,aa,i,j) = - tmp2 * fjac(4,1,i,j-1)
     >              - tmp1 * njac(4,1,i,j-1)
               lhs(4,2,aa,i,j) = - tmp2 * fjac(4,2,i,j-1)
     >              - tmp1 * njac(4,2,i,j-1)
               lhs(4,3,aa,i,j) = - tmp2 * fjac(4,3,i,j-1)
     >              - tmp1 * njac(4,3,i,j-1)
               lhs(4,4,aa,i,j) = - tmp2 * fjac(4,4,i,j-1)
     >              - tmp1 * njac(4,4,i,j-1)
     >              - tmp1 * dy4
               lhs(4,5,aa,i,j) = - tmp2 * fjac(4,5,i,j-1)
     >              - tmp1 * njac(4,5,i,j-1)

               lhs(5,1,aa,i,j) = - tmp2 * fjac(5,1,i,j-1)
     >              - tmp1 * njac(5,1,i,j-1)
               lhs(5,2,aa,i,j) = - tmp2 * fjac(5,2,i,j-1)
     >              - tmp1 * njac(5,2,i,j-1)
               lhs(5,3,aa,i,j) = - tmp2 * fjac(5,3,i,j-1)
     >              - tmp1 * njac(5,3,i,j-1)
               lhs(5,4,aa,i,j) = - tmp2 * fjac(5,4,i,j-1)
     >              - tmp1 * njac(5,4,i,j-1)
               lhs(5,5,aa,i,j) = - tmp2 * fjac(5,5,i,j-1)
     >              - tmp1 * njac(5,5,i,j-1)
     >              - tmp1 * dy5

               lhs(1,1,bb,i,j) = 1.d0
     >              + tmp1 * 2.d0 * njac(1,1,i,j)
     >              + tmp1 * 2.d0 * dy1
               lhs(1,2,bb,i,j) = tmp1 * 2.d0 * njac(1,2,i,j)
               lhs(1,3,bb,i,j) = tmp1 * 2.d0 * njac(1,3,i,j)
               lhs(1,4,bb,i,j) = tmp1 * 2.d0 * njac(1,4,i,j)
               lhs(1,5,bb,i,j) = tmp1 * 2.d0 * njac(1,5,i,j)

               lhs(2,1,bb,i,j) = tmp1 * 2.d0 * njac(2,1,i,j)
               lhs(2,2,bb,i,j) = 1.d0
     >              + tmp1 * 2.d0 * njac(2,2,i,j)
     >              + tmp1 * 2.d0 * dy2
               lhs(2,3,bb,i,j) = tmp1 * 2.d0 * njac(2,3,i,j)
               lhs(2,4,bb,i,j) = tmp1 * 2.d0 * njac(2,4,i,j)
               lhs(2,5,bb,i,j) = tmp1 * 2.d0 * njac(2,5,i,j)

               lhs(3,1,bb,i,j) = tmp1 * 2.d0 * njac(3,1,i,j)
               lhs(3,2,bb,i,j) = tmp1 * 2.d0 * njac(3,2,i,j)
               lhs(3,3,bb,i,j) = 1.d0
     >              + tmp1 * 2.d0 * njac(3,3,i,j)
     >              + tmp1 * 2.d0 * dy3
               lhs(3,4,bb,i,j) = tmp1 * 2.d0 * njac(3,4,i,j)
               lhs(3,5,bb,i,j) = tmp1 * 2.d0 * njac(3,5,i,j)

               lhs(4,1,bb,i,j) = tmp1 * 2.d0 * njac(4,1,i,j)
               lhs(4,2,bb,i,j) = tmp1 * 2.d0 * njac(4,2,i,j)
               lhs(4,3,bb,i,j) = tmp1 * 2.d0 * njac(4,3,i,j)
               lhs(4,4,bb,i,j) = 1.d0
     >              + tmp1 * 2.d0 * njac(4,4,i,j)
     >              + tmp1 * 2.d0 * dy4
               lhs(4,5,bb,i,j) = tmp1 * 2.d0 * njac(4,5,i,j)

               lhs(5,1,bb,i,j) = tmp1 * 2.d0 * njac(5,1,i,j)
               lhs(5,2,bb,i,j) = tmp1 * 2.d0 * njac(5,2,i,j)
               lhs(5,3,bb,i,j) = tmp1 * 2.d0 * njac(5,3,i,j)
               lhs(5,4,bb,i,j) = tmp1 * 2.d0 * njac(5,4,i,j)
               lhs(5,5,bb,i,j) = 1.d0
     >              + tmp1 * 2.d0 * njac(5,5,i,j)
     >              + tmp1 * 2.d0 * dy5

               lhs(1,1,cc,i,j) =  tmp2 * fjac(1,1,i,j+1)
     >              - tmp1 * njac(1,1,i,j+1)
     >              - tmp1 * dy1
               lhs(1,2,cc,i,j) =  tmp2 * fjac(1,2,i,j+1)
     >              - tmp1 * njac(1,2,i,j+1)
               lhs(1,3,cc,i,j) =  tmp2 * fjac(1,3,i,j+1)
     >              - tmp1 * njac(1,3,i,j+1)
               lhs(1,4,cc,i,j) =  tmp2 * fjac(1,4,i,j+1)
     >              - tmp1 * njac(1,4,i,j+1)
               lhs(1,5,cc,i,j) =  tmp2 * fjac(1,5,i,j+1)
     >              - tmp1 * njac(1,5,i,j+1)

               lhs(2,1,cc,i,j) =  tmp2 * fjac(2,1,i,j+1)
     >              - tmp1 * njac(2,1,i,j+1)
               lhs(2,2,cc,i,j) =  tmp2 * fjac(2,2,i,j+1)
     >              - tmp1 * njac(2,2,i,j+1)
     >              - tmp1 * dy2
               lhs(2,3,cc,i,j) =  tmp2 * fjac(2,3,i,j+1)
     >              - tmp1 * njac(2,3,i,j+1)
               lhs(2,4,cc,i,j) =  tmp2 * fjac(2,4,i,j+1)
     >              - tmp1 * njac(2,4,i,j+1)
               lhs(2,5,cc,i,j) =  tmp2 * fjac(2,5,i,j+1)
     >              - tmp1 * njac(2,5,i,j+1)

               lhs(3,1,cc,i,j) =  tmp2 * fjac(3,1,i,j+1)
     >              - tmp1 * njac(3,1,i,j+1)
               lhs(3,2,cc,i,j) =  tmp2 * fjac(3,2,i,j+1)
     >              - tmp1 * njac(3,2,i,j+1)
               lhs(3,3,cc,i,j) =  tmp2 * fjac(3,3,i,j+1)
     >              - tmp1 * njac(3,3,i,j+1)
     >              - tmp1 * dy3
               lhs(3,4,cc,i,j) =  tmp2 * fjac(3,4,i,j+1)
     >              - tmp1 * njac(3,4,i,j+1)
               lhs(3,5,cc,i,j) =  tmp2 * fjac(3,5,i,j+1)
     >              - tmp1 * njac(3,5,i,j+1)

               lhs(4,1,cc,i,j) =  tmp2 * fjac(4,1,i,j+1)
     >              - tmp1 * njac(4,1,i,j+1)
               lhs(4,2,cc,i,j) =  tmp2 * fjac(4,2,i,j+1)
     >              - tmp1 * njac(4,2,i,j+1)
               lhs(4,3,cc,i,j) =  tmp2 * fjac(4,3,i,j+1)
     >              - tmp1 * njac(4,3,i,j+1)
               lhs(4,4,cc,i,j) =  tmp2 * fjac(4,4,i,j+1)
     >              - tmp1 * njac(4,4,i,j+1)
     >              - tmp1 * dy4
               lhs(4,5,cc,i,j) =  tmp2 * fjac(4,5,i,j+1)
     >              - tmp1 * njac(4,5,i,j+1)

               lhs(5,1,cc,i,j) =  tmp2 * fjac(5,1,i,j+1)
     >              - tmp1 * njac(5,1,i,j+1)
               lhs(5,2,cc,i,j) =  tmp2 * fjac(5,2,i,j+1)
     >              - tmp1 * njac(5,2,i,j+1)
               lhs(5,3,cc,i,j) =  tmp2 * fjac(5,3,i,j+1)
     >              - tmp1 * njac(5,3,i,j+1)
               lhs(5,4,cc,i,j) =  tmp2 * fjac(5,4,i,j+1)
     >              - tmp1 * njac(5,4,i,j+1)
               lhs(5,5,cc,i,j) =  tmp2 * fjac(5,5,i,j+1)
     >              - tmp1 * njac(5,5,i,j+1)
     >              - tmp1 * dy5

            enddo
         enddo

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

c---------------------------------------------------------------------
c     performs gaussian elimination on this cell.
c
c     assumes that unpacking routines for non-first cells
c     preload C' and rhs' from previous cell.
c
c     assumed send happens outside this routine, but that
c     c'(JMAX) and rhs'(JMAX) will be sent to next cell
c---------------------------------------------------------------------

c---------------------------------------------------------------------
c     multiply c(i,0,k) by b_inverse and copy back to c
c     multiply rhs(0) by b_inverse(0) and copy to rhs
c---------------------------------------------------------------------
!dir$ ivdep
         do i = 1, nx-2
            call binvcrhs( lhs(1,1,bb,i,0),
     >                        lhs(1,1,cc,i,0),
     >                        rhs(1,i,0,k) )
         enddo

c---------------------------------------------------------------------
c     begin inner most do loop
c     do all the elements of the cell unless last
c---------------------------------------------------------------------
         do j=1,jsize-1
!dir$ ivdep
            do i = 1, nx-2

c---------------------------------------------------------------------
c     subtract A*lhs_vector(j-1) from lhs_vector(j)
c
c     rhs(j) = rhs(j) - A*rhs(j-1)
c---------------------------------------------------------------------
               call matvec_sub(lhs(1,1,aa,i,j),
     >                         rhs(1,i,j-1,k),rhs(1,i,j,k))

c---------------------------------------------------------------------
c     B(j) = B(j) - C(j-1)*A(j)
c---------------------------------------------------------------------
               call matmul_sub(lhs(1,1,aa,i,j),
     >                         lhs(1,1,cc,i,j-1),
     >                         lhs(1,1,bb,i,j))

c---------------------------------------------------------------------
c     multiply c(i,j,k) by b_inverse and copy back to c
c     multiply rhs(i,1,k) by b_inverse(i,1,k) and copy to rhs
c---------------------------------------------------------------------
               call binvcrhs( lhs(1,1,bb,i,j),
     >                        lhs(1,1,cc,i,j),
     >                        rhs(1,i,j,k) )

            enddo
         enddo

c---------------------------------------------------------------------
c     rhs(jsize) = rhs(jsize) - A*rhs(jsize-1)
c---------------------------------------------------------------------
!dir$ ivdep
         do i = 1, nx-2
            call matvec_sub(lhs(1,1,aa,i,jsize),
     >                         rhs(1,i,jsize-1,k),rhs(1,i,jsize,k))

c---------------------------------------------------------------------
c     B(jsize) = B(jsize) - C(jsize-1)*A(jsize)
c     call matmul_sub(aa,i,jsize,k,c,
c     $              cc,i,jsize-1,k,c,bb,i,jsize,k)
c---------------------------------------------------------------------
            call matmul_sub(lhs(1,1,aa,i,jsize),
     >                         lhs(1,1,cc,i,jsize-1),
     >                         lhs(1,1,bb,i,jsize))

c---------------------------------------------------------------------
c     multiply rhs(jsize) by b_inverse(jsize) and copy to rhs
c---------------------------------------------------------------------
            call binvrhs( lhs(1,1,bb,i,jsize),
     >                       rhs(1,i,jsize,k) )
         enddo

c---------------------------------------------------------------------
c     back solve: if last cell, then generate U(jsize)=rhs(jsize)
c     else assume U(jsize) is loaded in un pack backsub_info
c     so just use it
c     after call u(jstart) will be sent to next cell
c---------------------------------------------------------------------

         do j=jsize-1,0,-1
            do i = 1, nx-2
               do m=1,BLOCK_SIZE
                  do n=1,BLOCK_SIZE
                     rhs(m,i,j,k) = rhs(m,i,j,k)
     >                    - lhs(m,n,cc,i,j)*rhs(n,i,j+1,k)
                  enddo
               enddo
            enddo
         enddo

      enddo
!$OMP END DO nowait
!$OMP END PARALLEL
      if (timeron) call timer_stop(t_ysolve)

      return
      end


C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C     *                                                               *
C     *                  copyright (c) 2011 by UCAR                   *
C     *                                                               *
C     *       University Corporation for Atmospheric Research         *
C     *                                                               *
C     *                      all rights reserved                      *
C     *                                                               *
C     *                     FFTPACK  version 5.1                      *
C     *                                                               *
C     *                 A Fortran Package of Fast Fourier             *
C     *                                                               *
C     *                Subroutines and Example Programs               *
C     *                                                               *
C     *                             by                                *
C     *                                                               *
C     *               Paul Swarztrauber and Dick Valent               *
C     *                                                               *
C     *                             of                                *
C     *                                                               *
C     *         the National Center for Atmospheric Research          *
C     *                                                               *
C     *                Boulder, Colorado  (80307)  U.S.A.             *
C     *                                                               *
C     *                   which is sponsored by                       *
C     *                                                               *
C     *              the National Science Foundation                  *
C     *                                                               *
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
      SUBROUTINE COSTF1(N,INC,X,WSAVE,WORK,IER)
      REAL       X(INC,*)       ,WSAVE(*)
      DOUBLE PRECISION           DSUM
      IER = 0
      NM1 = N-1
      NP1 = N+1
      NS2 = N/2
      IF (N-2) 200,101,102
  101 X1H = X(1,1)+X(1,2)
      X(1,2) = .5*(X(1,1)-X(1,2))
      X(1,1) = .5*X1H
      GO TO 200
  102 IF (N .GT. 3) GO TO 103
      X1P3 = X(1,1)+X(1,3)
      TX2 = X(1,2)+X(1,2)
      X(1,2) = .5*(X(1,1)-X(1,3))
      X(1,1) = .25*(X1P3+TX2)
      X(1,3) = .25*(X1P3-TX2)
      GO TO 200
  103 DSUM = X(1,1)-X(1,N)
      X(1,1) = X(1,1)+X(1,N)
      DO 104 K=2,NS2
         KC = NP1-K
         T1 = X(1,K)+X(1,KC)
         T2 = X(1,K)-X(1,KC)
         DSUM = DSUM+WSAVE(KC)*T2
         T2 = WSAVE(K)*T2
         X(1,K) = T1-T2
         X(1,KC) = T1+T2
  104 CONTINUE
      MODN = MOD(N,2)
      IF (MODN .EQ. 0) GO TO 124
      X(1,NS2+1) = X(1,NS2+1)+X(1,NS2+1)
  124 LENX = INC*(NM1-1)  + 1
      LNSV = NM1 + INT(LOG(REAL(NM1))/LOG(2.)) + 4
      LNWK = NM1
C
      CALL RFFT1F(NM1,INC,X,LENX,WSAVE(N+1),LNSV,WORK,
     1            LNWK,IER1)
      IF (IER1 .NE. 0) THEN
        IER = 20
        CALL XERFFT ('COSTF1',-5)
        GO TO 200
      ENDIF
C
      SNM1 = 1./FLOAT(NM1)
      DSUM = SNM1*DSUM
      IF(MOD(NM1,2) .NE. 0) GO TO 30
      X(1,NM1) = X(1,NM1)+X(1,NM1)
   30 DO 105 I=3,N,2
         XI = .5*X(1,I)
         X(1,I) = .5*X(1,I-1)
         X(1,I-1) = DSUM
         DSUM = DSUM+XI
  105 CONTINUE
      IF (MODN .NE. 0) GO TO 117
      X(1,N) = DSUM
  117 X(1,1) = .5*X(1,1)
      X(1,N) = .5*X(1,N)
  200 RETURN
      END


  MODULE poiss_module

  implicit none

  private
  public :: poiss

  CONTAINS

      subroutine poiss(uh,vh,mh,rmh,mf,rmf,pi0,thv0,rho0,rf0,   &
                       dum1,dum2,dum3,def,divx,ppi,uten,vten,wten,  &
                       cfb,cfa,cfc,d1,d2,pdt,lgbth,lgbph,rhs,trans,dttmp)

      use input
      use singleton , only : fft
      implicit none

      real, intent(in), dimension(ib:ie) :: uh
      real, intent(in), dimension(jb:je) :: vh
      real, intent(in), dimension(ib:ie,jb:je,kb:ke) :: mh,rmh
      real, intent(in), dimension(ib:ie,jb:je,kb:ke+1) :: mf,rmf
      real, intent(in), dimension(ib:ie,jb:je,kb:ke) :: pi0,thv0,rho0,rf0
      real, intent(inout), dimension(ib:ie,jb:je,kb:ke) :: dum1,dum2,dum3,def,ppi
      real, intent(in), dimension(ib:ie,jb:je,kb:ke) :: divx
      real, intent(in), dimension(ib:ie+1,jb:je,kb:ke) :: uten
      real, intent(in), dimension(ib:ie,jb:je+1,kb:ke) :: vten
      real, intent(in), dimension(ib:ie,jb:je,kb:ke+1) :: wten
      real, intent(in), dimension(ipb:ipe,jpb:jpe,kpb:kpe) :: cfb
      real, intent(in), dimension(kpb:kpe) :: cfa,cfc,d1,d2
      complex, intent(inout), dimension(ipb:ipe,jpb:jpe,kpb:kpe) :: pdt,lgbth,lgbph
      complex, intent(inout), dimension(ipb:ipe,jpb:jpe) :: rhs,trans
      real, intent(in) :: dttmp

      integer :: i,j,k
      real :: tem
      real, dimension(nk) :: r1,deft2
      complex :: temc

      IF(axisymm.eq.1)THEN
        if(myid.eq.0)then
          print *
          print *,'  The anelastic/incompressible solver cannot be '
          print *,'  used with the axisymmetric model(yet)'
          print *
          print *,'  Stopping model ...'
          print *
        endif
        call stopcm1
      ENDIF

!-----------------------------------------------------------------------
!!!
!!!  Get the forcing from the exact numerical representation
!!!  of the right-hand side of the momentum equation
!!!
!!!  The divx term reduces accumulation of numerical errors over time
!!!
!!!
!!! fourier transform the total forcing, then forward part of tridiagonal solver:
!!!

      DO k=1,nk

        tem = 1.0/dttmp

!$omp parallel do default(shared)  &
!$omp private(i,j)
        do j=1,nj
        do i=1,ni
          def(i,j,k)=rho0(1,1,k)*(                                  &
                     (uten(i+1,j,k)-uten(i,j,k))*rdx*uh(i)          &
                    +(vten(i,j+1,k)-vten(i,j,k))*rdy*vh(j) )        &
                    +( rf0(i,j,k+1)*wten(i,j,k+1)                   &
                      -rf0(i,j,k  )*wten(i,j,k  ) )*rdz*mh(i,j,k)   &
                    +divx(i,j,k)*tem
          rhs(i,j)=cmplx(def(i,j,k)*d1(k),0.0)
        enddo
        enddo

        if(imirror.eq.1)then

!$omp parallel do default(shared)  &
!$omp private(i,j)
          do j=1,nj
          do i=1,ni
            rhs(ipe+1-i,j)=rhs(i,j)
          enddo
          enddo

        endif

        if(jmirror.eq.1)then

!$omp parallel do default(shared)  &
!$omp private(i,j)
          do j=1,nj
          do i=1,ni
            rhs(i,jpe+1-j)=rhs(i,j)
          enddo
          enddo

        endif

        if(imirror.eq.1.and.jmirror.eq.1)then

!$omp parallel do default(shared)  &
!$omp private(i,j)
          do j=1,nj
          do i=1,ni
            rhs(ipe+1-i,jpe+1-j)=rhs(i,j)
          enddo
          enddo

        endif

        trans=fft(rhs)

        IF( k.eq.1 )THEN

          !$omp parallel do default(shared)  &
          !$omp private(i,j,tem)
          do j=jpb,jpe
          do i=ipb,ipe
            tem = 1.0/cfb(i,j,1)
            lgbth(i,j,1) = -cfc(1)*tem
            lgbph(i,j,1) = trans(i,j)*tem
          enddo
          enddo

        ELSEIF( k.lt.nk )THEN

          !$omp parallel do default(shared)  &
          !$omp private(i,j,temc)
          do j=jpb,jpe
          do i=ipb,ipe
            temc = 1.0/(cfa(k)*lgbth(i,j,k-1)+cfb(i,j,k))
            lgbth(i,j,k) = -cfc(k)*temc
            lgbph(i,j,k) = (trans(i,j)-cfa(k)*lgbph(i,j,k-1))*temc
          enddo
          enddo

        ELSE

          !$omp parallel do default(shared)  &
          !$omp private(i,j,temc)
          do j=jpb,jpe
          do i=ipb,ipe
            temc = 1.0/(cfa(k)*lgbth(i,j,k-1)+cfb(i,j,k))
            lgbth(i,j,k) = -cfc(k)*temc
            lgbph(i,j,k) = (trans(i,j)-cfa(k)*lgbph(i,j,k-1))*temc
            pdt(i,j,k) = lgbph(i,j,k)
          enddo
          enddo

        ENDIF

        deft2(k) = real(trans(1,1))

      ENDDO

!-----------------------------------------------------------------------
!!! backward part of tridiagonal solver:

      DO k=(nk-1),1,-1

        !$omp parallel do default(shared)  &
        !$omp private(i,j)
        do j=jpb,jpe
        do i=ipb,ipe
          pdt(i,j,k) = lgbth(i,j,k)*pdt(i,j,k+1)+lgbph(i,j,k)
        enddo
        enddo

      ENDDO

      r1(1) = 0.0
      pdt(1,1,1) = 0.0

      r1(2) = (deft2(1)-cfb(1,1,1)*r1(1))/cfc(1)
      pdt(1,1,2) = cmplx( r1(2) , 0.0 )

      do k=2,(nk-1)
        r1(k+1) = (deft2(k)-cfa(k)*r1(k-1)-cfb(1,1,k)*r1(k))/cfc(k)
        pdt(1,1,k+1) = cmplx( r1(k+1) , 0.0 )
      enddo

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

!!!
!!! reverse fourier transform:
!!!

      DO k=1,nk

        !$omp parallel do default(shared)  &
        !$omp private(i,j)
        do j=jpb,jpe
        do i=ipb,ipe
          rhs(i,j)=pdt(i,j,k)
        enddo
        enddo

        trans=fft(rhs,inv=.true.)

        !$omp parallel do default(shared)  &
        !$omp private(i,j)
        do j=1,nj
        do i=1,ni
          ppi(i,j,k)=real(trans(i,j))*d2(k)
        enddo
        enddo

      ENDDO

      if(timestats.ge.1) time_poiss=time_poiss+mytime()

!-----------------------------------------------------------------------
!  All done.

      end subroutine poiss

  END MODULE poiss_module


! { dg-do run }
!
! This program does a correctness check for
! ARRAY[idx] = SCALAR, ARRAY[idx] = ARRAY and SCALAR[idx] = SCALAR
!
program main
  implicit none
  integer, parameter :: n = 3
  integer, parameter :: m = 4

  ! Allocatable coarrays
  call one(-5, 1)
  call one(0, 0)
  call one(1, -5)
  call one(0, -11)

  ! Static coarrays
  call two()
  call three()
contains
  subroutine one(lb1, lb2)
    integer, value :: lb1, lb2

    integer :: i_sgn1, i_sgn2, i, i_e, i_s, j, j_e, j_s
    integer, allocatable :: caf(:,:)[:]
    integer, allocatable :: a(:,:), b(:,:)

    allocate(caf(lb1:n+lb1-1, lb2:m+lb2-1)[*], &
         a(lb1:n+lb1-1, lb2:m+lb2-1), &
         b(lb1:n+lb1-1, lb2:m+lb2-1))

    b = reshape([(i*33, i = 1, size(b))], shape(b))

    ! Whole array: ARRAY = SCALAR
    caf = -42
    a = -42
    a(:,:) = b(lb1, lb2)
    sync all
    if (this_image() == 1) then
      caf(:,:)[num_images()] = b(lb1, lb2)
    end if
    sync all
    if (this_image() == num_images()) then
      if (any (a /= caf)) &
           STOP 1
    end if
    sync all

    ! Whole array: ARRAY = ARRAY
    caf = -42
    a = -42
    a(:,:) = b(:, :)
    sync all
    if (this_image() == 1) then
      caf(:,:)[num_images()] = b(:, :)
    end if
    sync all
    if (this_image() == num_images()) then
      if (any (a /= caf)) &
           STOP 2
    end if
    sync all

    ! Scalar assignment
    caf = -42
    a = -42
    do j = lb2, m+lb2-1
      do i = n+lb1-1, 1, -2
        a(i,j) = b(i,j)
      end do
    end do
    do j = lb2, m+lb2-1
      do i = 1, n+lb1-1, 2
        a(i,j) = b(i,j)
      end do
    end do
    sync all
    if (this_image() == 1) then
      do j = lb2, m+lb2-1
        do i = n+lb1-1, 1, -2
          caf(i,j)[num_images()] = b(i, j)
        end do
      end do
      do j = lb2, m+lb2-1
        do i = 1, n+lb1-1, 2
          caf(i,j)[num_images()] = b(i, j)
        end do
      end do
    end if
    sync all
    if (this_image() == num_images()) then
      if (any (a /= caf)) &
           STOP 3
    end if
    sync all

    ! Array sections with different ranges and pos/neg strides
    do i_sgn1 = -1, 1, 2
      do i_sgn2 = -1, 1, 2
        do i=lb1, n+lb1-1
          do i_e=lb1, n+lb1-1
            do i_s=1, n
              do j=lb2, m+lb2-1
                do j_e=lb2, m+lb2-1
                  do j_s=1, m
                    ! ARRAY = SCALAR
                    caf = -42
                    a = -42
                    a(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2) = b(lb1, lb2)
                    sync all
                    if (this_image() == 1) then
                      caf(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2)[num_images()] &
                           = b(lb1, lb2)
                    end if
                    sync all

                    ! ARRAY = ARRAY
                    caf = -42
                    a = -42
                    a(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2) &
                         = b(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2)
                    sync all
                    if (this_image() == 1) then
                      caf(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2)[num_images()] &
                           = b(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2)
                    end if
                    sync all

                    if (this_image() == num_images()) then
                      if (any (a /= caf)) then
                        print '(*(g0))', "bounds: ", lb1,":",n+lb1-1,", ", &
                             lb2,":",m+lb2-1
                        print '(*(g0))', "section: ", i,":",i_e,":",i_s*i_sgn1, &
                             ", ", j,":",j_e,":",j_s*i_sgn2
                        print *, i
                        print *, a
                        print *, caf
                        print *, a-caf
                        STOP 4
                      endif
                    end if
                    sync all
                  end do
                end do
              end do
            end do
          end do
        end do
      end do
    end do
  end subroutine one

  subroutine two()
    integer, parameter :: lb1 = -5, lb2 = 1

    integer :: i_sgn1, i_sgn2, i, i_e, i_s, j, j_e, j_s
    integer, save :: caf(lb1:n+lb1-1, lb2:m+lb2-1)[*]
    integer, save :: a(lb1:n+lb1-1, lb2:m+lb2-1)
    integer, save :: b(lb1:n+lb1-1, lb2:m+lb2-1)

    b = reshape([(i*33, i = 1, size(b))], shape(b))

    ! Whole array: ARRAY = SCALAR
    caf = -42
    a = -42
    a(:,:) = b(lb1, lb2)
    sync all
    if (this_image() == 1) then
      caf(:,:)[num_images()] = b(lb1, lb2)
    end if
    sync all
    if (this_image() == num_images()) then
      if (any (a /= caf)) &
           STOP 5
    end if

    ! Whole array: ARRAY = ARRAY
    caf = -42
    a = -42
    a(:,:) = b(:, :)
    sync all
    if (this_image() == 1) then
      caf(:,:)[num_images()] = b(:, :)
    end if
    sync all
    if (this_image() == num_images()) then
      if (any (a /= caf)) &
           STOP 6
    end if
    sync all

    ! Scalar assignment
    caf = -42
    a = -42
    do j = lb2, m+lb2-1
      do i = n+lb1-1, 1, -2
        a(i,j) = b(i,j)
      end do
    end do
    do j = lb2, m+lb2-1
      do i = 1, n+lb1-1, 2
        a(i,j) = b(i,j)
      end do
    end do
    sync all
    if (this_image() == 1) then
      do j = lb2, m+lb2-1
        do i = n+lb1-1, 1, -2
          caf(i,j)[num_images()] = b(i, j)
        end do
      end do
      do j = lb2, m+lb2-1
        do i = 1, n+lb1-1, 2
          caf(i,j)[num_images()] = b(i, j)
        end do
      end do
    end if
    sync all
    if (this_image() == num_images()) then
      if (any (a /= caf)) &
           STOP 7
    end if
    sync all

    ! Array sections with different ranges and pos/neg strides
    do i_sgn1 = -1, 1, 2
      do i_sgn2 = -1, 1, 2
        do i=lb1, n+lb1-1
          do i_e=lb1, n+lb1-1
            do i_s=1, n
              do j=lb2, m+lb2-1
                do j_e=lb2, m+lb2-1
                  do j_s=1, m
                    ! ARRAY = SCALAR
                    caf = -42
                    a = -42
                    a(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2) = b(lb1, lb2)
                    sync all
                    if (this_image() == 1) then
                      caf(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2)[num_images()] &
                           = b(lb1, lb2)
                    end if
                    sync all

                    ! ARRAY = ARRAY
                    caf = -42
                    a = -42
                    a(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2) &
                         = b(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2)
                    sync all
                    if (this_image() == 1) then
                      caf(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2)[num_images()] &
                           = b(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2)
                    end if
                    sync all

                    if (this_image() == num_images()) then
                      if (any (a /= caf)) then
                        print '(*(g0))', "bounds: ", lb1,":",n+lb1-1,", ", &
                             lb2,":",m+lb2-1
                        print '(*(g0))', "section: ", i,":",i_e,":",i_s*i_sgn1, &
                             ", ", j,":",j_e,":",j_s*i_sgn2
                        print *, i
                        print *, a
                        print *, caf
                        print *, a-caf
                        STOP 8
                      endif
                    end if
                    sync all
                  end do
                end do
              end do
            end do
          end do
        end do
      end do
    end do
  end subroutine two

  subroutine three()
    integer, parameter :: lb1 = 0, lb2 = 0

    integer :: i_sgn1, i_sgn2, i, i_e, i_s, j, j_e, j_s
    integer, save :: caf(lb1:n+lb1-1, lb2:m+lb2-1)[*]
    integer, save :: a(lb1:n+lb1-1, lb2:m+lb2-1)
    integer, save :: b(lb1:n+lb1-1, lb2:m+lb2-1)

    b = reshape([(i*33, i = 1, size(b))], shape(b))

    ! Whole array: ARRAY = SCALAR
    caf = -42
    a = -42
    a(:,:) = b(lb1, lb2)
    sync all
    if (this_image() == 1) then
      caf(:,:)[num_images()] = b(lb1, lb2)
    end if
    sync all
    if (this_image() == num_images()) then
      if (any (a /= caf)) &
           STOP 9
    end if

    ! Whole array: ARRAY = ARRAY
    caf = -42
    a = -42
    a(:,:) = b(:, :)
    sync all
    if (this_image() == 1) then
      caf(:,:)[num_images()] = b(:, :)
    end if
    sync all
    if (this_image() == num_images()) then
      if (any (a /= caf)) &
           STOP 10
    end if
    sync all

    ! Scalar assignment
    caf = -42
    a = -42
    do j = lb2, m+lb2-1
      do i = n+lb1-1, 1, -2
        a(i,j) = b(i,j)
      end do
    end do
    do j = lb2, m+lb2-1
      do i = 1, n+lb1-1, 2
        a(i,j) = b(i,j)
      end do
    end do
    sync all
    if (this_image() == 1) then
      do j = lb2, m+lb2-1
        do i = n+lb1-1, 1, -2
          caf(i,j)[num_images()] = b(i, j)
        end do
      end do
      do j = lb2, m+lb2-1
        do i = 1, n+lb1-1, 2
          caf(i,j)[num_images()] = b(i, j)
        end do
      end do
    end if
    sync all
    if (this_image() == num_images()) then
      if (any (a /= caf)) &
           STOP 11
    end if

    ! Array sections with different ranges and pos/neg strides
    do i_sgn1 = -1, 1, 2
      do i_sgn2 = -1, 1, 2
        do i=lb1, n+lb1-1
          do i_e=lb1, n+lb1-1
            do i_s=1, n
              do j=lb2, m+lb2-1
                do j_e=lb2, m+lb2-1
                  do j_s=1, m
                    ! ARRAY = SCALAR
                    caf = -42
                    a = -42
                    a(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2) = b(lb1, lb2)
                    sync all
                    if (this_image() == 1) then
                      caf(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2)[num_images()] &
                           = b(lb1, lb2)
                    end if
                    sync all

                    ! ARRAY = ARRAY
                    caf = -42
                    a = -42
                    a(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2) &
                         = b(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2)
                    sync all
                    if (this_image() == 1) then
                      caf(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2)[num_images()] &
                           = b(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2)
                    end if
                    sync all

                    if (this_image() == num_images()) then
                      if (any (a /= caf)) then
                        print '(*(g0))', "bounds: ", lb1,":",n+lb1-1,", ", &
                             lb2,":",m+lb2-1
                        print '(*(g0))', "section: ", i,":",i_e,":",i_s*i_sgn1, &
                             ", ", j,":",j_e,":",j_s*i_sgn2
                        print *, i
                        print *, a
                        print *, caf
                        print *, a-caf
                        STOP 12
                      endif
                    end if
                    sync all
                  end do
                end do
              end do
            end do
          end do
        end do
      end do
    end do
  end subroutine three
end program main


!> \file mo_integrate.f90

!> \brief Provides integration routines

!> \details This module provides routine for numerical integration such a Newton-Cotes formulas, etc.

!> \authors Matthias Cuntz
!> \date Mar 2013
MODULE mo_integrate

  ! Provide numerical integration.

  ! Written  Matthias Cuntz, Mar 2013

  ! License
  ! -------
  ! This file is part of the JAMS Fortran package, distributed under the MIT License.
  !
  ! Copyright (c) 2013 Matthias Cuntz - mc (at) macu (dot) de
  !
  ! Permission is hereby granted, free of charge, to any person obtaining a copy
  ! of this software and associated documentation files (the "Software"), to deal
  ! in the Software without restriction, including without limitation the rights
  ! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
  ! copies of the Software, and to permit persons to whom the Software is
  ! furnished to do so, subject to the following conditions:
  !
  ! The above copyright notice and this permission notice shall be included in all
  ! copies or substantial portions of the Software.
  !
  ! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
  ! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
  ! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
  ! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
  ! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
  ! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
  ! SOFTWARE.

  USE mo_kind, ONLY: i4, sp, dp

  IMPLICIT NONE

  PUBLIC :: int_regular ! Integrate regularily spaced data

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

  !     NAME
  !         int_regular

  !     PURPOSE
  !>        \brief Integrate regularily spaced data.

  !>        \details Integrates regularily spaced data with a 5-point Newton-Cotes formula:
  !>        \f[ \int y = \frac{2}{45} dx \sum_{i=5,n-4,4} 7 y_{i-4} + 32 y_{i-3} + 12 y_{i-2} + 32 y_{i-1} + 7 y_{i} \f]

  !>        dx=1 if not given.

  !     INTENT(IN)
  !>        \param[in] "real(sp/dp) :: dat(:)"        \f$ y_i \f$ 1D-array with y-values.

  !     INTENT(INOUT)
  !         None

  !     INTENT(OUT)
  !         None

  !     INTENT(IN), OPTIONAL
  !>       \param[in] "real(sp/dp) :: dx"             x-spacing (default=1.)

  !     INTENT(INOUT), OPTIONAL
  !         None

  !     INTENT(OUT), OPTIONAL
  !         None

  !     RETURN
  !>       \return     real(sp/dp) :: integral — \f$ \int y \f$ integral of y values

  !     RESTRICTIONS
  !         None

  !     EXAMPLE
  !         vec = (/ 1., 2, 3., 4., 5., 6., 7., 8., 9. /)
  !         m   = int_regular(vec)
  !         -> see also example in test directory

  !     LITERATURE
  !         None

  !     HISTORY
  !>        \author Matthias Cuntz
  !>        \date Mar 2013
  INTERFACE int_regular
     MODULE PROCEDURE int_regular_sp, int_regular_dp
  END INTERFACE int_regular

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

  PRIVATE

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

CONTAINS

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

  ! integrates tabulated function with equal distant points usign 5-point Newton-Cotes formula
  FUNCTION int_regular_dp(dat, dx)

    IMPLICIT NONE

    REAL(dp), DIMENSION(:),           INTENT(IN)  :: dat
    REAL(dp),               OPTIONAL, INTENT(IN)  :: dx
    REAL(dp)                                      :: int_regular_dp

    INTEGER(i4) :: n, n0
    REAL(dp)    :: ddx

    if (size(dat,1) < 5) stop 'Error int_regular_dp: size(dat) < 5'

    if (present(dx)) then
       ddx = dx*2.0_dp/45.0_dp
    else
       ddx = 2.0_dp/45.0_dp
    endif

    n0 = 5
    n  = size(dat,1)

    if (ddx .gt. 0.0_dp) then
       int_regular_dp = sum( &
            (7.0_dp*(dat(n0-4:n-4:4) + dat(n0:n:4)) + &
            32.0_dp*(dat(n0-3:n-3:4) + dat(n0-1:n-1:4)) + &
            12.0_dp*dat(n0-2:n-2:4)) )
       ! to avoid underflow issues
       if ( ddx .lt. 1.0_dp ) then
          if ( int_regular_dp .gt. tiny(1.0_dp)/ddx ) then
             int_regular_dp = ddx * int_regular_dp
          else
             int_regular_dp = tiny(1.0_dp)
          end if
       else
          int_regular_dp = ddx * int_regular_dp
       end if
    else
       int_regular_dp = 0.0_dp
    end if

  END FUNCTION int_regular_dp

  FUNCTION int_regular_sp(dat, dx)

    IMPLICIT NONE

    REAL(sp), DIMENSION(:),           INTENT(IN)  :: dat
    REAL(sp),               OPTIONAL, INTENT(IN)  :: dx
    REAL(sp)                                      :: int_regular_sp

    INTEGER(i4) :: n, n0
    REAL(sp)    :: ddx

    if (size(dat,1) < 5) stop 'Error int_regular_sp: size(dat) < 5'

    if (present(dx)) then
       ddx = dx*2.0_sp/45.0_sp
    else
       ddx = 2.0_sp/45.0_sp
    endif

    n0 = 5
    n  = size(dat,1)
    if (ddx .gt. 0.0_sp) then
       int_regular_sp = sum( &
            (7.0_sp*(dat(n0-4:n-4:4) + dat(n0:n:4)) + &
            32.0_sp*(dat(n0-3:n-3:4) + dat(n0-1:n-1:4)) + &
            12.0_sp*dat(n0-2:n-2:4)) )
       ! to avoid underflow issues
       if ( ddx .lt. 1.0_sp ) then
          if ( int_regular_sp .gt. tiny(1.0_sp)/ddx ) then
             int_regular_sp = ddx * int_regular_sp
          else
             int_regular_sp = tiny(1.0_sp)
          end if
       else
          int_regular_sp = ddx * int_regular_sp
       end if
    else
       int_regular_sp = 0.0_sp
    end if

  END FUNCTION int_regular_sp

END MODULE mo_integrate


DIMENSION :: X(3), Y(3,2)
X = [3.2,4.01,6.5]
Y = RESHAPE(SOURCE=[2.0,[4.5,4.5],X],SHAPE=[3,2])
END PROGRAM


C
      SUBROUTINE SNEWBILCAL (DGLNG,DGLAT,RADI,DYEAR,DALNG,
     $                       DALAT,DBABS,DBN,DBE,DBD,DXL,ISTAT)
c  ------------------------------------------------------------------------
c  Part of "poa_calfos" (STECF/IPMG)
c  Part of "NEWBILCAL" program to produce IGRF geomagnetic model (GSFC)
c
c  History:
c  --------
c  Version   Date        Author          Description
c      1.0       Jul 00  M. Rosa         POA calibration code
c      1.2       Jun 01  A. Alexov       Added IDS's common block for file
c                                        header access, ISTAT
c  ------------------------------------------------------------------------
C
C *************************************************************
C ** IGRF MAGNETIC FIELD MODEL +  SHELLG L-VALUE CALCULATION **
C *************************************************************
C adapted by Michael Rosa STECF 22 DEC 1996 from BILCAL, VERSION 3.0,
C AUGUST 1995, includes also AACGM code
C
C  UMR     =   ATAN(1.0)*4./180.   <DEGREE>*UMR=<RADIANT>
C  ERA         EARTH RADIUS FOR NORMALIZATION OF CARTESIAN COORDINATES
C  EREQU       MAJOR HALF AXIS FOR EARTH ELLIPSOID (6378.160 KM)
C  ERPOL       MINOR HALF AXIS FOR EARTH ELLIPSOID (6356.775 KM)
C  AQUAD       SQUARE OF MAJOR HALF AXIS FOR EARTH ELLIPSOID
C  BQUAD       SQUARE OF MINOR HALF AXIS FOR EARTH ELLIPSOID
C  ERA, EREQU and ERPOL as recommended by the IAU
C---------------------------------------------------------------------
      IMPLICIT NONE
      INTEGER*4   ICODE
      REAL*8 DGLNG,DGLAT,DALNG,DALAT,DBABS,DXL,RADI
      REAL*8 DBN,DBE,DBD,DIMO,DIP,DEC,DYEAR
c      REAL*8 DGLNG,DGLAT,RADI,DIMO,DIP,DEC

      REAL*4      GLNG,GLAT,ALAT,ALNG,BABS,BAB1,XL
      REAL*4      UMR,ERAD,AQUAD,BQUAD
      REAL*4      HEIGHT,YEAR,BN,BE,BD

      COMMON/GENER/       UMR,ERAD,AQUAD,BQUAD
C
C local variables
C
      INTEGER ISTAT
      CHARACTER*80 CONTXT
      INTEGER STDOUT
      PARAMETER (STDOUT = 1)
      INTEGER STDERR
      PARAMETER (STDERR = 2)
C
C Common block containing input/output file descriptions
C
C       IDS - file id numbers
C       GCOUNT - group counts
C       NAXIS - naxis
C       NAXIS1 - first dimensions
C       NAXIS2 - second dimensions
C       FILL - Fill values
C
        INTEGER IDS(30),NAXIS(30),NAXIS1(30),NAXIS2(30),GCOUNT(30)
        REAL FILL(30)
        COMMON /IOCOM/IDS,GCOUNT,NAXIS,NAXIS1,NAXIS2,FILL

C     initialize common /GENER/
      if (ERAD.LT.6300.0) CALL INITIZE
C
      HEIGHT = SNGL(RADI/1000.D0)-ERAD
      GLNG = SNGL(DGLNG)
      GLAT = SNGL(DGLAT)
      YEAR = SNGL(DYEAR)

C Get field coefficients for actual decimal year
      CALL FELDCOF (YEAR,DIMO,ISTAT)
      IF (ISTAT .NE. 0) THEN
             GO TO 999
      END IF
C Calculate field
      CALL FELDG (GLAT,GLNG,HEIGHT,BN,BE,BD,BABS)
C Calculate shell parameters
      CALL SHELLG (GLAT,GLNG,HEIGHT,DIMO,XL,ICODE,BAB1)

      DIP = ASIN(BD/BABS)/UMR
      DEC = ASIN(BE/SQRT(BE*BE+BN*BN))/UMR

      DBABS = DBLE(BABS)
      DBN = BN
      DBE = BE
      DBD = BD
      DXL = DBLE(XL)

      CALL CONV_GEO_CRD (GLAT,GLNG,HEIGHT,ALAT,ALNG,1,ISTAT)
C check the output error
      IF (ISTAT .NE. 0) THEN
             GO TO 999
      END IF

      DALNG = DBLE(ALNG)
      DALAT = DBLE(ALAT)

      IF (ISTAT .NE. 0) THEN
             GO TO 999
      END IF

      ISTAT=0
      GO TO 1000
999   CALL YMSPUT(CONTXT,STDOUT+STDERR,0,ISTAT)
      ISTAT=1
1000  RETURN
      END


!-----------------------------------------------------------------------
! Solve surface energy balance
!-----------------------------------------------------------------------
subroutine SURF_EBAL(alb,CH,Dz1,gs,ksurf,Ts1,         &
                     Esnow,Gsurf,Hsurf,LEsrf,Melt,Rnet)

use CONSTANTS, only : &
  cp,                &! Specific heat capacity of dry air (J/K/kg)
  Lc,                &! Latent heat of condensation (J/kg)
  Lf,                &! Latent heat of fusion (J/kg)
  Ls,                &! Latent heat of sublimation (J/kg)
  Rgas,              &! Gas constant for dry air (J/K/kg)
  Rwat,              &! Gas constant for water vapour (J/K/kg)
  sb,                &! Stefan-Boltzmann constant (W/m^2/K^4)
  Tm                  ! Melting point (K)

use DRIVING, only: &
  dt,                &! Timestep (s)
  LW,                &! Incoming longwave radiation (W/m2)
  Ps,                &! Surface pressure (Pa)
  Qa,                &! Specific humidity (kg/kg)
  Rf,                &! Rainfall rate (kg/m2/s)
  Sf,                &! Snowfall rate (kg/m2/s)
  SW,                &! Incoming shortwave radiation (W/m2)
  Ta,                &! Air temperature (K)
  Ua                  ! Wind speed (m/s)

use STATE_VARIABLES, only : &
  Sice,              &! Ice content of snow layers (kg/m^2)
  Tsurf               ! Surface skin temperature (K)

implicit none

real*8, intent(in) :: &
  alb,               &! Albedo
  CH,                &! Transfer coefficient for heat and moisture
  Dz1,               &! Surface layer thickness (m)
  gs,                &! Surface moisture conductance (m/s)
  ksurf,             &! Surface layer thermal conductivity (W/m/K)
  Ts1                 ! Surface layer temperature (K)

real*8, intent(out) :: &
  Esnow,             &! Snow sublimation rate (kg/m^2/s)
  Gsurf,             &! Heat flux into surface (W/m^2)
  Hsurf,             &! Sensible heat flux (W/m^2)
  LEsrf,             &! Latent heat flux (W/m^2)
  Melt,              &! Surface melt rate (kg/m^2/s)
  Rnet                ! Net radiation (W/m^2)

real*8 :: &
  D,                 &! dQsat/dT (1/K)
  dE,                &! Change in surface moisture flux (kg/m^2/s)
  dG,                &! Change in surface heat flux (W/m^2)
  dH,                &! Change in sensible heat flux (W/m^2)
  dR,                &! Change in net radiation (W/m^2)
  dTs,               &! Change in surface skin temperatures (K)
  Esurf,             &! Surface moisture flux (kg/m^2/s)
  Esoil,             &! Soil evaporation rate (kg/m^2/s)
  Lh,                &! Latent heat (J/kg)
  psi,               &! Moisture availability factor
  Qs,                &! Saturation humidity at surface layer temperature
  rho,               &! Air density (kg/m^3)
  rKH                 ! rho*CH*Ua (kg/m^2/s)

call QSAT(.FALSE.,Ps,Tsurf,Qs)
psi = gs / (gs + CH*Ua)
if (Qs < Qa .or. Sice(1) > 0) psi = 1
Lh = Ls
if (Tsurf > Tm) Lh = Lc
rho = Ps / (Rgas*Ta)
rKH = rho*CH*Ua

! Surface energy balance without melt
D = Lh*Qs/(Rwat*Tsurf**2)
Esurf = psi*rKH*(Qs - Qa)
Gsurf = 2*ksurf*(Tsurf - Ts1)/Dz1
Hsurf = cp*rKH*(Tsurf - Ta)
LEsrf = Lh*Esurf
Melt = 0
Rnet = (1 - alb)*SW + LW - sb*Tsurf**4
dTs = (Rnet - Hsurf - LEsrf - Gsurf) / &
      ((cp + Lh*psi*D)*rKH + 2*ksurf/Dz1 + 4*sb*Tsurf**3)
dE = psi*rKH*D*dTs
dG = 2*ksurf*dTs/Dz1
dH = cp*rKH*dTs
dR = -sb*Tsurf**3*dTs

! Surface melting
if (Tsurf + dTs > Tm .and. Sice(1) > 0) then
  Melt = sum(Sice)/dt
  dTs = (Rnet - Hsurf - LEsrf - Gsurf - Lf*Melt) / &
        ((cp + Ls*psi*D)*rKH + 2*ksurf/Dz1 + 4*sb*Tsurf**3)
  dE = rKH*D*dTs
  dG = 2*ksurf*dTs/Dz1
  dH = cp*rKH*dTs
  if (Tsurf + dTs < Tm) then
      call QSAT(.FALSE.,Ps,Tm,Qs)
      Esurf = rKH*(Qs - Qa)
      Gsurf = 2*ksurf*(Tm - Ts1)/Dz1
      Hsurf = cp*rKH*(Tm - Ta)
      LEsrf = Ls*Esurf
      Rnet = (1 - alb)*SW + LW - sb*Tm**4
      Melt = (Rnet - Hsurf - LEsrf - Gsurf) / Lf
      Melt = max(Melt, 0.)
      dE = 0
      dG = 0
      dH = 0
      dR = 0
      dTs = Tm - Tsurf
  end if
end if

! Update surface temperature and fluxes
Tsurf = Tsurf + dTs
Esurf = Esurf + dE
Gsurf = Gsurf + dG
Hsurf = Hsurf + dH
Rnet  = Rnet + dR
Esnow = 0
Esoil = 0
if (Sice(1) > 0 .or. Tsurf < Tm) then
  Esnow = Esurf
  LEsrf = Ls*Esurf
else
  Esoil = Esurf
  LEsrf = Lc*Esurf
end if

end subroutine SURF_EBAL


!        Generated by TAPENADE     (INRIA, Ecuador team)
!  tapenade 3.x
!
!  Differentiation of gi in forward (tangent) mode:
!   variations   of useful results: gi
!   with respect to varying inputs: *propunit
!   Plus diff mem management of: propunit:in
!>    @brief average  conductivities on cell faces in x direction
!>    @param[in] i grid indices
!>    @param[in] j grid indices
!>    @param[in] k grid indices
!>    @param[in] ismpl local sample index
!>    @return x  conductivity (m/(Pa s))
DOUBLE PRECISION FUNCTION g_GI(i, j, k, ismpl, gi)
  USE ARRAYS

  USE g_ARRAYS

  USE MOD_GENRL
  USE MOD_FLOW
  IMPLICIT NONE
  INTEGER :: ismpl
  INTEGER :: i, j, k
  EXTERNAL KX, RHOF, VISF
  EXTERNAL g_KX
  DOUBLE PRECISION :: f1, f2, prod, summ, KX, RHOF, VISF
  DOUBLE PRECISION :: g_f1, g_f2, g_prod, g_summ, g_KX
  DOUBLE PRECISION :: result1
  DOUBLE PRECISION :: g_result1
  DOUBLE PRECISION :: result2
  DOUBLE PRECISION :: gi
  gi = 0.d0
  IF (i0 .GT. 1 .AND. i .LT. i0) THEN
    g_result1 = g_KX(i, j, k, ismpl, result1)
    result2 = VISF(i, j, k, ismpl)
    g_f1 = g_result1/result2
    f1 = result1/result2
    g_result1 = g_KX(i + 1, j, k, ismpl, result1)
    result2 = VISF(i + 1, j, k, ismpl)
    g_f2 = g_result1/result2
    f2 = result1/result2
    g_prod = f2*g_f1 + f1*g_f2
    prod = f1*f2
    g_summ = delx(i+1)*g_f1 + delx(i)*g_f2
    summ = f1*delx(i+1) + f2*delx(i)
    IF (summ .GT. 0.d0) THEN
      g_gi = 2.d0*(g_prod-prod*g_summ/summ)/summ
      gi = 2.d0*prod/summ
    ELSE
      g_gi = 0.D0
    END IF
  ELSE
    g_gi = 0.D0
  END IF
  RETURN
END FUNCTION g_GI


      SUBROUTINE SB16CY( DICO, JOBCF, N, M, P, A, LDA, B, LDB, C, LDC,
     $                   F, LDF, G, LDG, SCALEC, SCALEO, S, LDS, R, LDR,
     $                   DWORK, LDWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute, for a given open-loop model (A,B,C,0), and for
C     given state feedback gain F and full observer gain G,
C     such that A+B*F and A+G*C are stable, the Cholesky factors
C     Su and Ru of a controllability Grammian P = Su*Su' and of
C     an observability Grammian Q = Ru'*Ru corresponding to a
C     frequency-weighted model reduction of the left or right coprime
C     factors of the state-feedback controller.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     DICO    CHARACTER*1
C             Specifies the type of the open-loop system as follows:
C             = 'C':  continuous-time system;
C             = 'D':  discrete-time system.
C
C     JOBCF   CHARACTER*1
C             Specifies whether a left or right coprime factorization
C             of the state-feedback controller is to be used as follows:
C             = 'L':  use a left coprime factorization;
C             = 'R':  use a right coprime factorization.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the open-loop state-space representation,
C             i.e., the order of the matrix A.  N >= 0.
C
C     M       (input) INTEGER
C             The number of system inputs.  M >= 0.
C
C     P       (input) INTEGER
C             The number of system outputs.  P >= 0.
C
C     A       (input) DOUBLE PRECISION array, dimension (LDA,N)
C             The leading N-by-N part of this array must contain the
C             state matrix A of the open-loop system.
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= MAX(1,N).
C
C     B       (input) DOUBLE PRECISION array, dimension (LDB,M)
C             The leading N-by-M part of this array must contain the
C             input/state matrix B of the open-loop system.
C
C     LDB     INTEGER
C             The leading dimension of array B.  LDB >= MAX(1,N).
C
C     C       (input) DOUBLE PRECISION array, dimension (LDC,N)
C             The leading P-by-N part of this array must contain the
C             state/output matrix C of the open-loop system.
C
C     LDC     INTEGER
C             The leading dimension of array C.  LDC >= MAX(1,P).
C
C     F       (input) DOUBLE PRECISION array, dimension (LDF,N)
C             The leading M-by-N part of this array must contain a
C             stabilizing state feedback matrix.
C
C     LDF     INTEGER
C             The leading dimension of array F.  LDF >= MAX(1,M).
C
C     G       (input) DOUBLE PRECISION array, dimension (LDG,P)
C             The leading N-by-P part of this array must contain a
C             stabilizing observer gain matrix.
C
C     LDG     INTEGER
C             The leading dimension of array G.  LDG >= MAX(1,N).
C
C     SCALEC  (output) DOUBLE PRECISION
C             Scaling factor for the controllability Grammian.
C             See METHOD.
C
C     SCALEO  (output) DOUBLE PRECISION
C             Scaling factor for the observability Grammian.
C             See METHOD.
C
C     S       (output) DOUBLE PRECISION array, dimension (LDS,N)
C             The leading N-by-N upper triangular part of this array
C             contains the Cholesky factor Su of frequency-weighted
C             cotrollability Grammian P = Su*Su'. See METHOD.
C
C     LDS     INTEGER
C             The leading dimension of the array S.  LDS >= MAX(1,N).
C
C     R       (output) DOUBLE PRECISION array, dimension (LDR,N)
C             The leading N-by-N upper triangular part of this array
C             contains the Cholesky factor Ru of the frequency-weighted
C             observability Grammian Q = Ru'*Ru. See METHOD.
C
C     LDR     INTEGER
C             The leading dimension of the array R.  LDR >= MAX(1,N).
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, DWORK(1) returns the optimal value
C             of LDWORK.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.
C             LDWORK >= MAX(1, N*(N + MAX(N,M) + MIN(N,M) + 6)),
C                                                       if JOBCF = 'L';
C             LDWORK >= MAX(1, N*(N + MAX(N,P) + MIN(N,P) + 6)),
C                                                       if JOBCF = 'R'.
C             For optimum performance LDWORK should be larger.
C             An upper bound for both cases is
C             LDWORK >= MAX(1, N*(N + MAX(N,M,P) + 7)).
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value;
C             = 1:  eigenvalue computation failure;
C             = 2:  the matrix A+G*C is not stable;
C             = 3:  the matrix A+B*F is not stable;
C             = 4:  the Lyapunov equation for computing the
C                   observability Grammian is (nearly) singular;
C             = 5:  the Lyapunov equation for computing the
C                   controllability Grammian is (nearly) singular.
C
C     METHOD
C
C     In accordance with the type of the coprime factorization
C     of the controller (left or right), the Cholesky factors Su and Ru
C     of the frequency-weighted controllability Grammian P = Su*Su' and
C     of the frequency-weighted observability Grammian Q = Ru'*Ru are
C     computed by solving appropriate Lyapunov or Stein equations [1].
C
C     If JOBCF = 'L' and DICO = 'C', P and Q are computed as the
C     solutions of the following Lyapunov equations:
C
C            (A+B*F)*P + P*(A+B*F)' +  scalec^2*B*B' = 0,  (1)
C
C            (A+G*C)'*Q + Q*(A+G*C) +  scaleo^2*F'*F = 0.  (2)
C
C     If JOBCF = 'L' and DICO = 'D', P and Q are computed as the
C     solutions of the following Stein equations:
C
C            (A+B*F)*P*(A+B*F)' - P +  scalec^2*B*B' = 0,  (3)
C
C            (A+G*C)'*Q*(A+G*C) - Q +  scaleo^2*F'*F = 0.  (4)
C
C     If JOBCF = 'R' and DICO = 'C', P and Q are computed as the
C     solutions of the following Lyapunov equations:
C
C            (A+B*F)*P + P*(A+B*F)' +  scalec^2*G*G' = 0,  (5)
C
C            (A+G*C)'*Q + Q*(A+G*C) +  scaleo^2*C'*C = 0.  (6)
C
C     If JOBCF = 'R' and DICO = 'D', P and Q are computed as the
C     solutions of the following Stein equations:
C
C            (A+B*F)*P*(A+B*F)' - P +  scalec^2*G*G' = 0,  (7)
C
C            (A+G*C)'*Q*(A+G*C) - Q +  scaleo^2*C'*C = 0.  (8)
C
C     REFERENCES
C
C     [1] Liu, Y., Anderson, B.D.O. and Ly, O.L.
C         Coprime factorization controller reduction with Bezout
C         identity induced frequency weighting.
C         Automatica, vol. 26, pp. 233-249, 1990.
C
C     CONTRIBUTORS
C
C     A. Varga, German Aerospace Center, Oberpfaffenhofen, October 2000.
C     D. Sima, University of Bucharest, October 2000.
C     V. Sima, Research Institute for Informatics, Bucharest, Oct. 2000.
C
C     REVISIONS
C
C     A. Varga, Australian National University, Canberra, November 2000.
C
C     KEYWORDS
C
C     Controller reduction, frequency weighting, multivariable system,
C     state-space model, state-space representation.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION ONE
      PARAMETER        ( ONE = 1.0D0 )
C     .. Scalar Arguments ..
      CHARACTER        DICO, JOBCF
      INTEGER          INFO, LDA, LDB, LDC, LDF, LDG, LDR, LDS, LDWORK,
     $                 M, N, P
      DOUBLE PRECISION SCALEC, SCALEO
C     .. Array Arguments ..
      DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*),
     $                 F(LDF,*), G(LDG,*), R(LDR,*), S(LDS,*)
C     .. Local Scalars ..
      LOGICAL          DISCR, LEFTW
      INTEGER          IERR, KAW, KU, KW, KWI, KWR, LDU, LW, ME, MP,
     $                 WRKOPT
C     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
C     .. External Subroutines ..
      EXTERNAL         DGEMM, DLACPY, SB03OD, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC        INT, MAX, MIN
C     .. Executable Statements ..
C
      DISCR = LSAME( DICO,  'D' )
      LEFTW = LSAME( JOBCF, 'L' )
C
      INFO = 0
      IF( LEFTW ) THEN
         MP = M
      ELSE
         MP = P
      END IF
      LW = N*( N + MAX( N, MP ) + MIN( N, MP ) + 6 )
C
      IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN
         INFO = -1
      ELSE IF( .NOT.( LEFTW .OR. LSAME( JOBCF, 'R' ) ) ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( M.LT.0 ) THEN
         INFO = -4
      ELSE IF( P.LT.0 ) THEN
         INFO = -5
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -7
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -9
      ELSE IF( LDC.LT.MAX( 1, P ) ) THEN
         INFO = -11
      ELSE IF( LDF.LT.MAX( 1, M ) ) THEN
         INFO = -13
      ELSE IF( LDG.LT.MAX( 1, N ) ) THEN
         INFO = -15
      ELSE IF( LDS.LT.MAX( 1, N ) ) THEN
         INFO = -19
      ELSE IF( LDR.LT.MAX( 1, N ) ) THEN
         INFO = -21
      ELSE IF( LDWORK.LT.MAX( 1, LW ) ) THEN
         INFO = -23
      END IF
C
      IF( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'SB16CY', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( MIN( N, M, P ).EQ.0 ) THEN
         SCALEC   = ONE
         SCALEO   = ONE
         DWORK(1) = ONE
         RETURN
      END IF
C
C     Allocate storage for work arrays.
C
      KAW = 1
      KU  = KAW + N*N
      KWR = KU  + N*MAX( N, MP )
      KWI = KWR + N
      KW  = KWI + N
C
C     Form A+G*C.
C
      CALL DLACPY( 'Full', N, N, A, LDA, DWORK(KAW), N )
      CALL DGEMM( 'No-transpose', 'No-transpose', N, N, P, ONE,
     $            G, LDG, C, LDC, ONE, DWORK(KAW), N )
C
C     Form the factor H of the free term.
C
      IF( LEFTW ) THEN
C
C        H = F.
C
         LDU = MAX( N, M )
         ME  = M
         CALL DLACPY( 'Full', M, N, F, LDF, DWORK(KU), LDU )
      ELSE
C
C        H = C.
C
         LDU = MAX( N, P )
         ME  = P
         CALL DLACPY( 'Full', P, N, C, LDC, DWORK(KU), LDU )
      END IF
C
C     Solve for the Cholesky factor Ru of Q, Q = Ru'*Ru,
C     the continuous-time Lyapunov equation (if DICO = 'C')
C
C        (A+G*C)'*Q + Q*(A+G*C) +  scaleo^2*H'*H = 0,
C
C     or the discrete-time Lyapunov equation (if DICO = 'D')
C
C        (A+G*C)'*Q*(A+G*C) - Q +  scaleo^2*H'*H = 0.
C
C     Workspace:  need   N*(N + MAX(N,M) + MIN(N,M) + 6) if JOBCF = 'L';
C                        N*(N + MAX(N,P) + MIN(N,P) + 6) if JOBCF = 'R'.
C                 prefer larger.
C
      CALL SB03OD( DICO, 'NoFact', 'NoTransp', N, ME, DWORK(KAW), N,
     $             R, LDR, DWORK(KU), LDU, SCALEO, DWORK(KWR),
     $             DWORK(KWI), DWORK(KW), LDWORK-KW+1, IERR )
      IF( IERR.NE.0 ) THEN
         IF( IERR.EQ.2 ) THEN
            INFO = 2
         ELSE IF( IERR.EQ.1 ) THEN
            INFO = 4
         ELSE IF( IERR.EQ.6 ) THEN
            INFO = 1
         END IF
         RETURN
      END IF
C
      WRKOPT = INT( DWORK(KW) ) + KW - 1
      CALL DLACPY( 'Upper', N, N, DWORK(KU), LDU, R, LDR )
C
C     Form A+B*F.
C
      CALL DLACPY( 'Full', N, N, A, LDA, DWORK(KAW), N )
      CALL DGEMM( 'No-transpose', 'No-transpose', N, N, M, ONE,
     $            B, LDB, F, LDF, ONE, DWORK(KAW), N )
C
C     Form the factor K of the free term.
C
      LDU = N
      IF( LEFTW ) THEN
C
C        K = B.
C
         ME = M
         CALL DLACPY( 'Full', N, M, B, LDB, DWORK(KU), LDU )
      ELSE
C
C        K = G.
C
         ME = P
         CALL DLACPY( 'Full', N, P, G, LDG, DWORK(KU), LDU )
      END IF
C
C     Solve for the Cholesky factor Su of P, P = Su*Su',
C     the continuous-time Lyapunov equation (if DICO = 'C')
C
C         (A+B*F)*P + P*(A+B*F)' +  scalec^2*K*K' = 0,
C
C     or the discrete-time Lyapunov equation (if DICO = 'D')
C
C         (A+B*F)*P*(A+B*F)' - P +  scalec^2*K*K' = 0.
C
C     Workspace:  need   N*(N + MAX(N,M) + MIN(N,M) + 6) if JOBCF = 'L';
C                        N*(N + MAX(N,P) + MIN(N,P) + 6) if JOBCF = 'R'.
C                        prefer larger.
C
      CALL SB03OD( DICO, 'NoFact', 'Transp', N, ME, DWORK(KAW), N,
     $             S, LDS, DWORK(KU), LDU, SCALEC, DWORK(KWR),
     $             DWORK(KWI), DWORK(KW), LDWORK-KW+1, IERR )
      IF( IERR.NE.0 ) THEN
         IF( IERR.EQ.2 ) THEN
            INFO = 3
         ELSE IF( IERR.EQ.1 ) THEN
            INFO = 5
         ELSE IF( IERR.EQ.6 ) THEN
            INFO = 1
         END IF
         RETURN
      END IF
      WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 )
      CALL DLACPY( 'Upper', N, N, DWORK(KU), LDU, S, LDS )
C
C     Save the optimal workspace.
C
      DWORK(1) = WRKOPT
C
      RETURN
C *** Last line of SB16CY ***
      END


! This code is part of the OpenCSR package developed at:
! https://github.com/ChristopherMayes/OpenCSR

module fft_mod

use, intrinsic :: iso_fortran_env

implicit none

integer, parameter, private :: dp = REAL64

contains

subroutine ccfft3d(a,b,idir,n1,n2,n3,iskiptrans)
use, intrinsic :: iso_c_binding
use omp_lib
implicit none
include 'fftw3.f03'

integer :: idir(3)
type(C_PTR) :: plan
complex(C_DOUBLE_COMPLEX), dimension(:,:,:) ::a, b
integer :: dir, fdir, n1, n2, n3, iskiptrans, n_threads

if (idir(1) == 1) then
  fdir = FFTW_BACKWARD
else
  fdir = FFTW_FORWARD
endif

!! print *, 'fftw_execute_dft...'
!$ n_threads = omp_get_max_threads()
!$ if (n_threads > 1) then
!! !$   print *, 'n_threads: ', n_threads
!$   call fftw_plan_with_nthreads(n_threads)
!$ endif

plan = fftw_plan_dft_3d(n3,n2,n1, a,b, fdir,FFTW_ESTIMATE)
call fftw_execute_dft(plan,a, b)
call fftw_destroy_plan(plan)

!$ if (n_threads > 1) call fftw_cleanup_threads()

!! print *, '...done'

end subroutine

end module fft_mod