*> \brief \b ZGTRFS
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZGTRFS + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
*  Definition:
*  ===========
*
*       SUBROUTINE ZGTRFS( TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, DU2,
*                          IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK,
*                          INFO )
*
*       .. Scalar Arguments ..
*       CHARACTER          TRANS
*       INTEGER            INFO, LDB, LDX, N, NRHS
*       ..
*       .. Array Arguments ..
*       INTEGER            IPIV( * )
*       DOUBLE PRECISION   BERR( * ), FERR( * ), RWORK( * )
*       COMPLEX*16         B( LDB, * ), D( * ), DF( * ), DL( * ),
*      $                   DLF( * ), DU( * ), DU2( * ), DUF( * ),
*      $                   WORK( * ), X( LDX, * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> ZGTRFS improves the computed solution to a system of linear
*> equations when the coefficient matrix is tridiagonal, and provides
*> error bounds and backward error estimates for the solution.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] TRANS
*> \verbatim
*>          TRANS is CHARACTER*1
*>          Specifies the form of the system of equations:
*>          = 'N':  A * X = B     (No transpose)
*>          = 'T':  A**T * X = B  (Transpose)
*>          = 'C':  A**H * X = B  (Conjugate transpose)
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The order of the matrix A.  N >= 0.
*> \endverbatim
*>
*> \param[in] NRHS
*> \verbatim
*>          NRHS is INTEGER
*>          The number of right hand sides, i.e., the number of columns
*>          of the matrix B.  NRHS >= 0.
*> \endverbatim
*>
*> \param[in] DL
*> \verbatim
*>          DL is COMPLEX*16 array, dimension (N-1)
*>          The (n-1) subdiagonal elements of A.
*> \endverbatim
*>
*> \param[in] D
*> \verbatim
*>          D is COMPLEX*16 array, dimension (N)
*>          The diagonal elements of A.
*> \endverbatim
*>
*> \param[in] DU
*> \verbatim
*>          DU is COMPLEX*16 array, dimension (N-1)
*>          The (n-1) superdiagonal elements of A.
*> \endverbatim
*>
*> \param[in] DLF
*> \verbatim
*>          DLF is COMPLEX*16 array, dimension (N-1)
*>          The (n-1) multipliers that define the matrix L from the
*>          LU factorization of A as computed by ZGTTRF.
*> \endverbatim
*>
*> \param[in] DF
*> \verbatim
*>          DF is COMPLEX*16 array, dimension (N)
*>          The n diagonal elements of the upper triangular matrix U from
*>          the LU factorization of A.
*> \endverbatim
*>
*> \param[in] DUF
*> \verbatim
*>          DUF is COMPLEX*16 array, dimension (N-1)
*>          The (n-1) elements of the first superdiagonal of U.
*> \endverbatim
*>
*> \param[in] DU2
*> \verbatim
*>          DU2 is COMPLEX*16 array, dimension (N-2)
*>          The (n-2) elements of the second superdiagonal of U.
*> \endverbatim
*>
*> \param[in] IPIV
*> \verbatim
*>          IPIV is INTEGER array, dimension (N)
*>          The pivot indices; for 1 <= i <= n, row i of the matrix was
*>          interchanged with row IPIV(i).  IPIV(i) will always be either
*>          i or i+1; IPIV(i) = i indicates a row interchange was not
*>          required.
*> \endverbatim
*>
*> \param[in] B
*> \verbatim
*>          B is COMPLEX*16 array, dimension (LDB,NRHS)
*>          The right hand side matrix B.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*>          LDB is INTEGER
*>          The leading dimension of the array B.  LDB >= max(1,N).
*> \endverbatim
*>
*> \param[in,out] X
*> \verbatim
*>          X is COMPLEX*16 array, dimension (LDX,NRHS)
*>          On entry, the solution matrix X, as computed by ZGTTRS.
*>          On exit, the improved solution matrix X.
*> \endverbatim
*>
*> \param[in] LDX
*> \verbatim
*>          LDX is INTEGER
*>          The leading dimension of the array X.  LDX >= max(1,N).
*> \endverbatim
*>
*> \param[out] FERR
*> \verbatim
*>          FERR is DOUBLE PRECISION array, dimension (NRHS)
*>          The estimated forward error bound for each solution vector
*>          X(j) (the j-th column of the solution matrix X).
*>          If XTRUE is the true solution corresponding to X(j), FERR(j)
*>          is an estimated upper bound for the magnitude of the largest
*>          element in (X(j) - XTRUE) divided by the magnitude of the
*>          largest element in X(j).  The estimate is as reliable as
*>          the estimate for RCOND, and is almost always a slight
*>          overestimate of the true error.
*> \endverbatim
*>
*> \param[out] BERR
*> \verbatim
*>          BERR is DOUBLE PRECISION array, dimension (NRHS)
*>          The componentwise relative backward error of each solution
*>          vector X(j) (i.e., the smallest relative change in
*>          any element of A or B that makes X(j) an exact solution).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*>          WORK is COMPLEX*16 array, dimension (2*N)
*> \endverbatim
*>
*> \param[out] RWORK
*> \verbatim
*>          RWORK is DOUBLE PRECISION array, dimension (N)
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*>          INFO is INTEGER
*>          = 0:  successful exit
*>          < 0:  if INFO = -i, the i-th argument had an illegal value
*> \endverbatim
*
*> \par Internal Parameters:
*  =========================
*>
*> \verbatim
*>  ITMAX is the maximum number of steps of iterative refinement.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup complex16GTcomputational
*
*  =====================================================================
      SUBROUTINE ZGTRFS( TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, DU2,
     $                   IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK,
     $                   INFO )
*
*  -- LAPACK computational routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      CHARACTER          TRANS
      INTEGER            INFO, LDB, LDX, N, NRHS
*     ..
*     .. Array Arguments ..
      INTEGER            IPIV( * )
      DOUBLE PRECISION   BERR( * ), FERR( * ), RWORK( * )
      COMPLEX*16         B( LDB, * ), D( * ), DF( * ), DL( * ),
     $                   DLF( * ), DU( * ), DU2( * ), DUF( * ),
     $                   WORK( * ), X( LDX, * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      INTEGER            ITMAX
      PARAMETER          ( ITMAX = 5 )
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
      DOUBLE PRECISION   TWO
      PARAMETER          ( TWO = 2.0D+0 )
      DOUBLE PRECISION   THREE
      PARAMETER          ( THREE = 3.0D+0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            NOTRAN
      CHARACTER          TRANSN, TRANST
      INTEGER            COUNT, I, J, KASE, NZ
      DOUBLE PRECISION   EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN
      COMPLEX*16         ZDUM
*     ..
*     .. Local Arrays ..
      INTEGER            ISAVE( 3 )
*     ..
*     .. External Subroutines ..
      EXTERNAL           XERBLA, ZAXPY, ZCOPY, ZGTTRS, ZLACN2, ZLAGTM
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, DBLE, DCMPLX, DIMAG, MAX
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           LSAME, DLAMCH
*     ..
*     .. Statement Functions ..
      DOUBLE PRECISION   CABS1
*     ..
*     .. Statement Function definitions ..
      CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) )
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      INFO = 0
      NOTRAN = LSAME( TRANS, 'N' )
      IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
     $    LSAME( TRANS, 'C' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( NRHS.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -13
      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
         INFO = -15
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'ZGTRFS', -INFO )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
         DO 10 J = 1, NRHS
            FERR( J ) = ZERO
            BERR( J ) = ZERO
   10    CONTINUE
         RETURN
      END IF
*
      IF( NOTRAN ) THEN
         TRANSN = 'N'
         TRANST = 'C'
      ELSE
         TRANSN = 'C'
         TRANST = 'N'
      END IF
*
*     NZ = maximum number of nonzero elements in each row of A, plus 1
*
      NZ = 4
      EPS = DLAMCH( 'Epsilon' )
      SAFMIN = DLAMCH( 'Safe minimum' )
      SAFE1 = NZ*SAFMIN
      SAFE2 = SAFE1 / EPS
*
*     Do for each right hand side
*
      DO 110 J = 1, NRHS
*
         COUNT = 1
         LSTRES = THREE
   20    CONTINUE
*
*        Loop until stopping criterion is satisfied.
*
*        Compute residual R = B - op(A) * X,
*        where op(A) = A, A**T, or A**H, depending on TRANS.
*
         CALL ZCOPY( N, B( 1, J ), 1, WORK, 1 )
         CALL ZLAGTM( TRANS, N, 1, -ONE, DL, D, DU, X( 1, J ), LDX, ONE,
     $                WORK, N )
*
*        Compute abs(op(A))*abs(x) + abs(b) for use in the backward
*        error bound.
*
         IF( NOTRAN ) THEN
            IF( N.EQ.1 ) THEN
               RWORK( 1 ) = CABS1( B( 1, J ) ) +
     $                      CABS1( D( 1 ) )*CABS1( X( 1, J ) )
            ELSE
               RWORK( 1 ) = CABS1( B( 1, J ) ) +
     $                      CABS1( D( 1 ) )*CABS1( X( 1, J ) ) +
     $                      CABS1( DU( 1 ) )*CABS1( X( 2, J ) )
               DO 30 I = 2, N - 1
                  RWORK( I ) = CABS1( B( I, J ) ) +
     $                         CABS1( DL( I-1 ) )*CABS1( X( I-1, J ) ) +
     $                         CABS1( D( I ) )*CABS1( X( I, J ) ) +
     $                         CABS1( DU( I ) )*CABS1( X( I+1, J ) )
   30          CONTINUE
               RWORK( N ) = CABS1( B( N, J ) ) +
     $                      CABS1( DL( N-1 ) )*CABS1( X( N-1, J ) ) +
     $                      CABS1( D( N ) )*CABS1( X( N, J ) )
            END IF
         ELSE
            IF( N.EQ.1 ) THEN
               RWORK( 1 ) = CABS1( B( 1, J ) ) +
     $                      CABS1( D( 1 ) )*CABS1( X( 1, J ) )
            ELSE
               RWORK( 1 ) = CABS1( B( 1, J ) ) +
     $                      CABS1( D( 1 ) )*CABS1( X( 1, J ) ) +
     $                      CABS1( DL( 1 ) )*CABS1( X( 2, J ) )
               DO 40 I = 2, N - 1
                  RWORK( I ) = CABS1( B( I, J ) ) +
     $                         CABS1( DU( I-1 ) )*CABS1( X( I-1, J ) ) +
     $                         CABS1( D( I ) )*CABS1( X( I, J ) ) +
     $                         CABS1( DL( I ) )*CABS1( X( I+1, J ) )
   40          CONTINUE
               RWORK( N ) = CABS1( B( N, J ) ) +
     $                      CABS1( DU( N-1 ) )*CABS1( X( N-1, J ) ) +
     $                      CABS1( D( N ) )*CABS1( X( N, J ) )
            END IF
         END IF
*
*        Compute componentwise relative backward error from formula
*
*        max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) )
*
*        where abs(Z) is the componentwise absolute value of the matrix
*        or vector Z.  If the i-th component of the denominator is less
*        than SAFE2, then SAFE1 is added to the i-th components of the
*        numerator and denominator before dividing.
*
         S = ZERO
         DO 50 I = 1, N
            IF( RWORK( I ).GT.SAFE2 ) THEN
               S = MAX( S, CABS1( WORK( I ) ) / RWORK( I ) )
            ELSE
               S = MAX( S, ( CABS1( WORK( I ) )+SAFE1 ) /
     $             ( RWORK( I )+SAFE1 ) )
            END IF
   50    CONTINUE
         BERR( J ) = S
*
*        Test stopping criterion. Continue iterating if
*           1) The residual BERR(J) is larger than machine epsilon, and
*           2) BERR(J) decreased by at least a factor of 2 during the
*              last iteration, and
*           3) At most ITMAX iterations tried.
*
         IF( BERR( J ).GT.EPS .AND. TWO*BERR( J ).LE.LSTRES .AND.
     $       COUNT.LE.ITMAX ) THEN
*
*           Update solution and try again.
*
            CALL ZGTTRS( TRANS, N, 1, DLF, DF, DUF, DU2, IPIV, WORK, N,
     $                   INFO )
            CALL ZAXPY( N, DCMPLX( ONE ), WORK, 1, X( 1, J ), 1 )
            LSTRES = BERR( J )
            COUNT = COUNT + 1
            GO TO 20
         END IF
*
*        Bound error from formula
*
*        norm(X - XTRUE) / norm(X) .le. FERR =
*        norm( abs(inv(op(A)))*
*           ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X)
*
*        where
*          norm(Z) is the magnitude of the largest component of Z
*          inv(op(A)) is the inverse of op(A)
*          abs(Z) is the componentwise absolute value of the matrix or
*             vector Z
*          NZ is the maximum number of nonzeros in any row of A, plus 1
*          EPS is machine epsilon
*
*        The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B))
*        is incremented by SAFE1 if the i-th component of
*        abs(op(A))*abs(X) + abs(B) is less than SAFE2.
*
*        Use ZLACN2 to estimate the infinity-norm of the matrix
*           inv(op(A)) * diag(W),
*        where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) )))
*
         DO 60 I = 1, N
            IF( RWORK( I ).GT.SAFE2 ) THEN
               RWORK( I ) = CABS1( WORK( I ) ) + NZ*EPS*RWORK( I )
            ELSE
               RWORK( I ) = CABS1( WORK( I ) ) + NZ*EPS*RWORK( I ) +
     $                      SAFE1
            END IF
   60    CONTINUE
*
         KASE = 0
   70    CONTINUE
         CALL ZLACN2( N, WORK( N+1 ), WORK, FERR( J ), KASE, ISAVE )
         IF( KASE.NE.0 ) THEN
            IF( KASE.EQ.1 ) THEN
*
*              Multiply by diag(W)*inv(op(A)**H).
*
               CALL ZGTTRS( TRANST, N, 1, DLF, DF, DUF, DU2, IPIV, WORK,
     $                      N, INFO )
               DO 80 I = 1, N
                  WORK( I ) = RWORK( I )*WORK( I )
   80          CONTINUE
            ELSE
*
*              Multiply by inv(op(A))*diag(W).
*
               DO 90 I = 1, N
                  WORK( I ) = RWORK( I )*WORK( I )
   90          CONTINUE
               CALL ZGTTRS( TRANSN, N, 1, DLF, DF, DUF, DU2, IPIV, WORK,
     $                      N, INFO )
            END IF
            GO TO 70
         END IF
*
*        Normalize error.
*
         LSTRES = ZERO
         DO 100 I = 1, N
            LSTRES = MAX( LSTRES, CABS1( X( I, J ) ) )
  100    CONTINUE
         IF( LSTRES.NE.ZERO )
     $      FERR( J ) = FERR( J ) / LSTRES
*
  110 CONTINUE
*
      RETURN
*
*     End of ZGTRFS
*
      END


!*==dlar2v.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief \b DLAR2V applies a vector of plane rotations with real cosines and real sines from both sides to a sequence of 2-by-2 symmetric/Hermitian matrices.
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download DLAR2V + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE DLAR2V( N, X, Y, Z, INCX, C, S, INCC )
!
!       .. Scalar Arguments ..
!       INTEGER            INCC, INCX, N
!       ..
!       .. Array Arguments ..
!       DOUBLE PRECISION   C( * ), S( * ), X( * ), Y( * ), Z( * )
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> DLAR2V applies a vector of real plane rotations from both sides to
!> a sequence of 2-by-2 real symmetric matrices, defined by the elements
!> of the vectors x, y and z. For i = 1,2,...,n
!>
!>    ( x(i)  z(i) ) := (  c(i)  s(i) ) ( x(i)  z(i) ) ( c(i) -s(i) )
!>    ( z(i)  y(i) )    ( -s(i)  c(i) ) ( z(i)  y(i) ) ( s(i)  c(i) )
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>          The number of plane rotations to be applied.
!> \endverbatim
!>
!> \param[in,out] X
!> \verbatim
!>          X is DOUBLE PRECISION array,
!>                         dimension (1+(N-1)*INCX)
!>          The vector x.
!> \endverbatim
!>
!> \param[in,out] Y
!> \verbatim
!>          Y is DOUBLE PRECISION array,
!>                         dimension (1+(N-1)*INCX)
!>          The vector y.
!> \endverbatim
!>
!> \param[in,out] Z
!> \verbatim
!>          Z is DOUBLE PRECISION array,
!>                         dimension (1+(N-1)*INCX)
!>          The vector z.
!> \endverbatim
!>
!> \param[in] INCX
!> \verbatim
!>          INCX is INTEGER
!>          The increment between elements of X, Y and Z. INCX > 0.
!> \endverbatim
!>
!> \param[in] C
!> \verbatim
!>          C is DOUBLE PRECISION array, dimension (1+(N-1)*INCC)
!>          The cosines of the plane rotations.
!> \endverbatim
!>
!> \param[in] S
!> \verbatim
!>          S is DOUBLE PRECISION array, dimension (1+(N-1)*INCC)
!>          The sines of the plane rotations.
!> \endverbatim
!>
!> \param[in] INCC
!> \verbatim
!>          INCC is INTEGER
!>          The increment between elements of C and S. INCC > 0.
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date December 2016
!
!> \ingroup doubleOTHERauxiliary
!
!  =====================================================================
      SUBROUTINE DLAR2V(N,X,Y,Z,Incx,C,S,Incc)
      IMPLICIT NONE
!*--DLAR2V114
!
!  -- LAPACK auxiliary routine (version 3.7.0) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     December 2016
!
!     .. Scalar Arguments ..
      INTEGER Incc , Incx , N
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION C(*) , S(*) , X(*) , Y(*) , Z(*)
!     ..
!
!  =====================================================================
!
!     .. Local Scalars ..
      INTEGER i , ic , ix
      DOUBLE PRECISION ci , si , t1 , t2 , t3 , t4 , t5 , t6 , xi , yi ,&
     &                 zi
!     ..
!     .. Executable Statements ..
!
      ix = 1
      ic = 1
      DO i = 1 , N
         xi = X(ix)
         yi = Y(ix)
         zi = Z(ix)
         ci = C(ic)
         si = S(ic)
         t1 = si*zi
         t2 = ci*zi
         t3 = t2 - si*xi
         t4 = t2 + si*yi
         t5 = ci*xi + t1
         t6 = ci*yi - t1
         X(ix) = ci*t5 + si*t4
         Y(ix) = ci*t6 - si*t3
         Z(ix) = ci*t4 - si*t5
         ix = ix + Incx
         ic = ic + Incc
      ENDDO
!
!     End of DLAR2V
!
      END SUBROUTINE DLAR2V


subroutine sld_rotmat(imodi,nnode,mnode,ndime,ndof,amatr,bvect,&
  &               rotma)

!------------------------------------------------------------------------
!
! This routine modifies a matrix the components of which are
! submatrices by rotating them using a matrix R ( = ROTMA) as follows:
!
!                |       A_11  ....      A_1i  R   ....      A_1n   |
!                |   ............................................   |
!     AMATR <--  |   R^t A_i1  ....  R^t A_ii  R   ....  R^t A_in   |
!                |   ............................................   |
!                |       A_n1  ....      A_ni  R   ....      A_nn   |
!
! where i ( = IMODI) is a given position. Also, the i-subvector of the
! given vector BVECT is multiplied by R^t.
!
! When A is the lumped mass matrix Aij=0 when i/=j and then
!
!                |       A_11  ....       0        ....        0    |
!                |   ............................................   |
!     AMATR <--  |         0   ....  R^t A_ii  R   ....        0    |
!                |   ............................................   |
!                |         0   ....       0        ....      A_nn   |
!
! and A_11 = int N1 * id(ndime,ndime)
!
! When A is the consistent mass matrix
!
!                |       A_11  ....      A_1i  R   ....      A_1n   |
!                |   ............................................   |
!     AMATR <--  |   R^t A_i1  ....  R^t A_ii  R   ....  R^t A_in   |
!                |   ............................................   |
!                |       A_n1  ....      A_ni  R   ....      A_nn   |
!
! and A_ij = int Ni Nj * id(ndime,ndime)
!------------------------------------------------------------------------
  use def_parame
  implicit none
  integer(ip), intent(in)    :: nnode,mnode,ndime,ndof
  real(rp),    intent(in)    :: rotma(ndime,ndime)
!  real(rp),    intent(inout) :: amatr(mtott,mtott)
  real(rp),    intent(inout) :: amatr(ndof,mnode,ndof,mnode)
  real(rp),    intent(inout) :: bvect(ndof,mnode)
  integer(ip)                :: imodi,inode,jnode
  integer(ip)                :: idime,jdime,kdime,idof,jdof
!
! Modifies column number IMODI of AMATR ( A_j,imodi <-- A_j,imodi R )
!
forall(idof=1:ndof,inode=1:nnode)
        amatr(idof,inode,1:ndime,imodi) = matmul(amatr(idof,inode,1:ndime,imodi),rotma)
end forall

forall(jdof=1:ndof,jnode=1:nnode)
        amatr(1:ndime,imodi,jdof,jnode) = matmul(transpose(rotma),amatr(1:ndime,imodi,jdof,jnode))
end forall

bvect(1:ndime,imodi) = matmul(transpose(rotma),bvect(1:ndime,imodi))

end subroutine sld_rotmat


chapter x. example 3. construction and evaluation of the pp-representat-
c                     ion of a b-spline.
c  from  * a practical guide to splines *  by c. de boor
calls bsplpp(bsplvb),ppvalu(interv)
c
      integer ia,l
      real bcoef(7),break(5),coef(4,4),scrtch(4,4),t(11),value,x
c                set knot sequence  t  and b-coeffs for  b(4,4,t)  ....
      data t / 4*0.,1.,3.,4.,4*6. /, bcoef / 3*0.,1.,3*0. /
c                          construct pp-representation  ....
      call bsplpp ( t, bcoef, 7, 4, scrtch, break, coef, l )
c
c     as a check, evaluate  b(4,4,t)  from its pp-repr. on a fine mesh.
c             the values should agree with (some of) those generated in
c                        example 2 .
      do 20 ia=1,40
         x = float(ia)/5. - 1.
         value = ppvalu ( break, coef, l, 4, x, 0 )
   20    print 620, x, value
  620 format(f10.1,f20.8)
                                        stop
      end


c
c     gaussInterp routine -- Gaussian weighted smoothing in lat, lon, and time
c
c Based on Ed Armstrong's routines. Designed to be called from python using f2py.
c
c
c Gaussian weighting = exp( vfactor * (((x - x0)/sx)^2 + ((y - y0)/sy)^2 + ((t - t0)/st)^2 ))
c
c where deltas are distances in lat, lon and time and sx, sy, st are one e-folding sigmas.
c
c Cutoffs for neighbors allowed in the interpolation are set by distance in lat/lon (see wlat/wlon);
c for time all epochs are included.

      subroutine gaussInterp_f(var, mask,
     &                         time, lat, lon,
     &                         outlat, outlon,
     &                         wlat, wlon,
     &                         slat, slon, stime,
     &                         vfactor,
     &                         missingValue,
     &                         verbose,
     &                         vinterp, vweight, status,
     &                         ntime, nlat, nlon, noutlat, noutlon)

      implicit none
      integer*4 ntime, nlat, nlon
c                 ! prepared 3D array of variable data over time, lon, & lat
      real*4    var(ntime, nlat, nlon)
c                 ! variable to be interpolated, over ntime epochs
      integer*1 mask(ntime, nlat, nlon)
c                 ! pixel quality mask
      integer*4 time(ntime)
c                 ! time epochs to gaussian-interpolate over
      real*4 lat(nlat)
                  ! latitude corrdinate vector
      real*4 lon(nlon)
                  ! longitude corrdinate vector
cf2py intent(in) var, mask, time, lat, lon        !! annotations for f2py processor
      integer*4 noutlat, noutlon
      real*4 outlat(noutlat), outlon(noutlon)
c                 ! lat/lon grid to interpolate to
cf2py intent(in) outlat, outlon
      real*4 wlat, wlon
c                 ! window of lat/lon neighbors to gaussian weight, expressed in delta lat (degrees)
c                 ! if an integer, then it is the number of neighbors on EACH side
cf2py intent(in) wlat, wlon
      real*4 slat, slon, stime
c                 ! sigma for gaussian downweighting with distance in lat, lon, & time
cf2py intent(in) slat, slon, stime
      real*4 vfactor
c                 ! factor in front of gaussian expression
      real*4 missingValue
c                 ! value to mark missing values in interp result
      integer*4 verbose
c                 ! integer to set verbosity level
cf2py intent(in) vfactor, missingValue
      real*4 vinterp(noutlat, noutlon)
c                 ! interpolated variable using gaussians, missing values not counted
      real*4 vweight(noutlat, noutlon)
c                 ! weight of values interpolated (can be zero), if so should become missing value
      integer*4 status
c                 ! negative status indicates error
cf2py intent(out) vinterp, vweight, status

      integer*4 clamp
      integer*4 imin, imax, jmin, jmax, itmp
      integer*4 iin, jin, kin
      integer*4 iMidTime
      integer*4 i, j, iwlat, iwlon

      real*4 wlat2, wlon2, lat1, lon1, dlat, dlon, fac
      real*4 varmin, varmax, val
      real*8 midTime
      logical*1 nLatNeighbors, nLonNeighbors

      write(6, *) 'Echoing inputs ...'
      write(6, *) 'ntime, nlat, nlon:', ntime, nlat, nlon
      write(6, *) 'noutlat, noutlon:', noutlat, noutlon
      write(6, *) 'wlat, wlon:', wlat, wlon
      write(6, *) 'slat, slon, stime:', slat, slon, stime
      write(6, *) 'vfactor:', vfactor
      write(6, *) 'missingValue:', missingValue

      status = 0
      if (int(wlat) .eq. wlat) then
         iwlat = int(wlat)
         nLatNeighbors = .TRUE.
         write(6, *) 'Using', iwlat,
     &      'neighbors on each side in the lat direction.'
      else
         nLatNeighbors = .FALSE.
      end if
      if (int(wlon) .eq. wlon) then
         iwlon = int(wlon)
         nLonNeighbors = .TRUE.
         write(6, *) 'Using', iwlon,
     &      'neighbors on each side in the lon direction.'
      else
         nLonNeighbors = .FALSE.
      end if

      wlat2 = wlat / 2.
      wlon2 = wlon / 2.
      lat1 = lat(1)
      lon1 = lon(1)
      dlat = lat(2) - lat(1)
      dlon = lon(2) - lon(1)
      iMidTime = int(ntime/2 + 0.5)
      midTime = time(iMidTime)

      if (verbose .gt. 3) then
          write(6, *) 'time:', time
          write(6, *) 'lat:', lat
          write(6, *) 'lon:', lon
          write(6, *) 'outlat:', outlat
          write(6, *) 'outlon:', outlon
c          write(6, *) 'mask(iMidTime):', mask(iMidTime,:,:)
          write(6, *) 'var(iMidTime):', var(iMidTime,:,:)
      end if

      do i = 1, noutlat
         if (verbose .gt. 1) write(6, *) outlat(i)
         do j = 1, noutlon
            vinterp(i,j) = 0.0
            vweight(i,j) = 0.0
            if (verbose .gt. 3) then
               write(6, *) '(i,j) = ', i, j
               write(6, *) '(outlat,outlon) = ', outlat(i), outlon(j)
            end if

            if (nLatNeighbors) then
               imin = clamp(i - iwlat, 1, nlat)
               imax = clamp(i + iwlat, 1, nlat)
            else
               imin = clamp(int((outlat(i) - wlat2 - lat1)/dlat + 0.5),
     &                      1, nlat)
               imax = clamp(int((outlat(i) + wlat2 - lat1)/dlat + 0.5),
     &                      1, nlat)
            end if
            if (imin .gt. imax) then
c              ! input latitudes descending, so swap
               itmp = imin
               imin = imax
               imax = itmp
            end if

            if (nLonNeighbors) then
               jmin = clamp(j - iwlon, 1, nlon)
               jmax = clamp(j + iwlon, 1, nlon)
            else
               jmin = clamp(int((outlon(j) - wlon2 - lon1)/dlon + 0.5),
     &                      1, nlon)
               jmax = clamp(int((outlon(j) + wlon2 - lon1)/dlon + 0.5),
     &                      1, nlon)
            end if

            if (verbose .gt. 2) then
               write(6, *) '(imin,imax,minlat,maxlat) = ',
     &               imin, imax, lat(imin), lat(imax)
               write(6, *) '(jmin,jmax,minlon,maxlon) = ',
     &               jmin, jmax, lon(jmin), lon(jmax)
            end if

            if (verbose .gt. 4 .and. i .eq. noutlat/2
     &             .and. j .eq. noutlon/2) then
               write(6, *) 'Echoing factors ...'
            end if

            do kin = 1, ntime
               varmin = 0.
               varmax = 0.
               do iin = imin, imax
                  do jin = jmin, jmax
                     if (mask(kin,iin,jin) .eq. 0) then
                        fac = exp( vfactor *
     &                         (((outlat(i) - lat(iin))/slat)**2
     &                        + ((outlon(j) - lon(jin))/slon)**2
     &                        + ((midTime   - time(kin))/stime)**2))

                        val = var(kin,iin,jin)
                        if (verbose .gt. 4 .and. i .eq. noutlat/2
     &                         .and. j .eq. noutlon/2) then
                           write(6, *) kin, iin, jin, time(kin),
     &                           lat(iin), lon(jin), val, fac, val*fac
                        end if

                        vinterp(i,j) = vinterp(i,j) + val * fac
                        vweight(i,j) = vweight(i,j) + fac
                        if (verbose .gt. 3) then
                           varmin = min(varmin, val)
                           varmax = max(varmax, val)
                        end if
                     end if
                  end do
               end do
               if (verbose .gt. 3) then
                  write(6, *) '(itime, varmin, varmax) = ',
     &                           kin, varmin, varmax
               end if
            end do
            if (vweight(i,j).ne. 0.0) then
               vinterp(i,j) = vinterp(i,j) / vweight(i,j)
            else
               vinterp(i,j) = missingValue
            end if
         end do
      end do
      return
      end

      integer*4 function clamp(i, n, m)
      integer*4 i, n, m
      clamp = i
      if (i .lt. n) clamp = n
      if (i .gt. m) clamp = m
      end


      REAL this,that
      DIST(X,Y,Z) = SQRT(X**2 + Y**2 + Z**2) + this/that !One arithmetic statement, possibly lengthy.
      ...
      D = 3 + DIST(X1 - X2,YDIFF,SQRT(ZD2))              !Invoke local function DIST.


implicit none

integer, allocatable, dimension(:) :: x,y,z
allocate(x(3),y(3),z(3))
x = (/ 4, 1, 7 /)
y = (/ 1, 2, 3 /)
print*, x(2), y(1)
print*, 'x = ', x
print*, 'y = ', y
z = 4*x+2*y             ! vector times constant is built into fortran
print*, '4x + 2y= ', z

stop
end

4670 Numerical Analysis/Class Examples/array1.f90


      subroutine setprob
      implicit double precision (a-h,o-z)
      character*12 fname
      common /cqinit/ beta,ic
      common /comaux/ rhol,cl,rhor,cr
      common /comlim/ mylim,mrplim(2)
c
c     # Set the material parameters for the acoustic equations
c
c
      iunit = 7
      fname = 'setprob.data'
c     # open the unit with new routine from Clawpack 4.4 to skip over
c     # comment lines starting with #:
      call opendatafile(iunit, fname)

c     # choice of initial data:
      read(7,*) ic
c     # beta for initial conditions:
      read(7,*) beta
c
c     # Piecewise constant medium with single interface at x=0
c     # Density and sound speed to left and right:
      read(7,*) rhol
      read(7,*) cl
      read(7,*) rhor
      read(7,*) cr

      return
      end


program bitwise
implicit none
print*,iand(1,1),iand(1,0),iand(0,1),iand(0,0) ! 1 0 0 0
print*,iand(2,2),iand(2,1),iand(2,0)           ! 2 0 0
print*,ior(1,1),ior(1,0),ior(0,1),ior(0,0)     ! 1 1 1 0
print*,ieor(1,1),ieor(1,0),ieor(0,1),ieor(0,0) ! 0 1 1 0
print*,iany([1,1]),iany([1,0]),iany([0,0])     ! 1 1 0
end program bitwise


! { dg-do run }
!
! CO_SUM/CO_MIN/CO_MAX
!
program test
  implicit none
  intrinsic co_max
  intrinsic co_min
  intrinsic co_sum
  call test_min
  call test_max
  call test_sum
contains
  subroutine test_max
    integer :: val
    val = this_image ()
    call co_max (val, result_image=1)
    if (this_image() == 1) then
      !write(*,*) "Maximal value", val
      if (val /= num_images()) STOP 1
    end if
  end subroutine test_max

  subroutine test_min
    integer :: val
    val = this_image ()
    call co_min (val, result_image=1)
    if (this_image() == 1) then
      !write(*,*) "Minimal value", val
      if (val /= 1) STOP 2
    end if
  end subroutine test_min

  subroutine test_sum
    integer :: val, n
    val = this_image ()
    call co_sum (val, result_image=1)
    if (this_image() == 1) then
      !write(*,*) "The sum is ", val
      n = num_images()
      if (val /= (n**2 + n)/2) STOP 3
    end if
  end subroutine test_sum
end program test