      SUBROUTINE AB08ND( EQUIL, N, M, P, A, LDA, B, LDB, C, LDC, D, LDD,
     $                   NU, RANK, DINFZ, NKROR, NKROL, INFZ, KRONR,
     $                   KRONL, AF, LDAF, BF, LDBF, TOL, IWORK, DWORK,
     $                   LDWORK, INFO )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To construct for a linear multivariable system described by a
C     state-space model (A,B,C,D) a regular pencil (A - lambda*B ) which
C                                                    f          f
C     has the invariant zeros of the system as generalized eigenvalues.
C     The routine also computes the orders of the infinite zeros and the
C     right and left Kronecker indices of the system (A,B,C,D).
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     EQUIL   CHARACTER*1
C             Specifies whether the user wishes to balance the compound
C             matrix (see METHOD) as follows:
C             = 'S':  Perform balancing (scaling);
C             = 'N':  Do not perform balancing.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The number of state variables, i.e., the order of the
C             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 dynamics matrix A of the 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 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 system.
C
C     LDC     INTEGER
C             The leading dimension of array C.  LDC >= MAX(1,P).
C
C     D       (input) DOUBLE PRECISION array, dimension (LDD,M)
C             The leading P-by-M part of this array must contain the
C             direct transmission matrix D of the system.
C
C     LDD     INTEGER
C             The leading dimension of array D.  LDD >= MAX(1,P).
C
C     NU      (output) INTEGER
C             The number of (finite) invariant zeros.
C
C     RANK    (output) INTEGER
C             The normal rank of the transfer function matrix.
C
C     DINFZ   (output) INTEGER
C             The maximum degree of infinite elementary divisors.
C
C     NKROR   (output) INTEGER
C             The number of right Kronecker indices.
C
C     NKROL   (output) INTEGER
C             The number of left Kronecker indices.
C
C     INFZ    (output) INTEGER array, dimension (N)
C             The leading DINFZ elements of INFZ contain information
C             on the infinite elementary divisors as follows:
C             the system has INFZ(i) infinite elementary divisors
C             of degree i, where i = 1,2,...,DINFZ.
C
C     KRONR   (output) INTEGER array, dimension (MAX(N,M)+1)
C             The leading NKROR elements of this array contain the
C             right Kronecker (column) indices.
C
C     KRONL   (output) INTEGER array, dimension (MAX(N,P)+1)
C             The leading NKROL elements of this array contain the
C             left Kronecker (row) indices.
C
C     AF      (output) DOUBLE PRECISION array, dimension
C             (LDAF,N+MIN(P,M))
C             The leading NU-by-NU part of this array contains the
C             coefficient matrix A  of the reduced pencil. The remainder
C                                 f
C             of the leading (N+M)-by-(N+MIN(P,M)) part is used as
C             internal workspace.
C
C     LDAF    INTEGER
C             The leading dimension of array AF.  LDAF >= MAX(1,N+M).
C
C     BF      (output) DOUBLE PRECISION array, dimension (LDBF,N+M)
C             The leading NU-by-NU part of this array contains the
C             coefficient matrix B  of the reduced pencil. The
C                                 f
C             remainder of the leading (N+P)-by-(N+M) part is used as
C             internal workspace.
C
C     LDBF    INTEGER
C             The leading dimension of array BF.  LDBF >= MAX(1,N+P).
C
C     Tolerances
C
C     TOL     DOUBLE PRECISION
C             A tolerance used in rank decisions to determine the
C             effective rank, which is defined as the order of the
C             largest leading (or trailing) triangular submatrix in the
C             QR (or RQ) factorization with column (or row) pivoting
C             whose estimated condition number is less than 1/TOL.
C             If the user sets TOL to be less than SQRT((N+P)*(N+M))*EPS
C             then the tolerance is taken as SQRT((N+P)*(N+M))*EPS,
C             where EPS is the machine precision (see LAPACK Library
C             Routine DLAMCH).
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (MAX(M,P))
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, MIN(P,M) + MAX(3*M-1,N),
C                               MIN(P,N) + MAX(3*P-1,N+P,N+M),
C                               MIN(M,N) + MAX(3*M-1,N+M) ).
C             An upper bound is MAX(s,N) + MAX(3*s-1,N+s), with
C             s = MAX(M,P).
C             For optimum performance LDWORK should be larger.
C
C             If LDWORK = -1, then a workspace query is assumed;
C             the routine only calculates the optimal size of the
C             DWORK array, returns this value as the first entry of
C             the DWORK array, and no error message related to LDWORK
C             is issued by XERBLA.
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 routine extracts from the system matrix of a state-space
C     system (A,B,C,D) a regular pencil A - lambda*B  which has the
C                                        f          f
C     invariant zeros of the system as generalized eigenvalues as
C     follows:
C
C        (a) construct the (N+P)-by-(N+M) compound matrix (B  A);
C                                                         (D  C)
C
C        (b) reduce the above system to one with the same invariant
C            zeros and with D of full row rank;
C
C        (c) pertranspose the system;
C
C        (d) reduce the system to one with the same invariant zeros and
C            with D square invertible;
C
C        (e) perform a unitary transformation on the columns of
C            (A - lambda*I  B) in order to reduce it to
C            (      C       D)
C
C            (A  - lambda*B   X)
C            ( f           f   ), with Y and B  square invertible;
C            (      0         Y)              f
C
C        (f) compute the right and left Kronecker indices of the system
C            (A,B,C,D), which together with the orders of the infinite
C            zeros (determined by steps (a) - (e)) constitute the
C            complete set of structural invariants under strict
C            equivalence transformations of a linear system.
C
C     REFERENCES
C
C     [1] Svaricek, F.
C         Computation of the Structural Invariants of Linear
C         Multivariable Systems with an Extended Version of
C         the Program ZEROS.
C         System & Control Letters, 6, pp. 261-266, 1985.
C
C     [2] Emami-Naeini, A. and Van Dooren, P.
C         Computation of Zeros of Linear Multivariable Systems.
C         Automatica, 18, pp. 415-430, 1982.
C
C     NUMERICAL ASPECTS
C
C     The algorithm is backward stable (see [2] and [1]).
C
C     FURTHER COMMENTS
C
C     In order to compute the invariant zeros of the system explicitly,
C     a call to this routine may be followed by a call to the LAPACK
C     Library routine DGGEV with A = A , B = B  and N = NU.
C                                     f       f
C     If RANK = 0, the routine DGEEV can be used (since B = I).
C                                                        f
C     CONTRIBUTOR
C
C     Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Nov. 1996.
C     Supersedes Release 2.0 routine AB08BD by F. Svaricek.
C
C     REVISIONS
C
C     Oct. 1997, Feb. 1998, Dec. 2003, March 2004, Jan. 2009, Mar. 2009,
C     Apr. 2009, Apr. 2011.
C
C     KEYWORDS
C
C     Generalized eigenvalue problem, Kronecker indices, multivariable
C     system, orthogonal transformation, structural invariant.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         EQUIL
      INTEGER           DINFZ, INFO, LDA, LDAF, LDB, LDBF, LDC, LDD,
     $                  LDWORK, M, N, NKROL, NKROR, NU, P, RANK
      DOUBLE PRECISION  TOL
C     .. Array Arguments ..
      INTEGER           INFZ(*), IWORK(*), KRONL(*), KRONR(*)
      DOUBLE PRECISION  A(LDA,*), AF(LDAF,*), B(LDB,*), BF(LDBF,*),
     $                  C(LDC,*), D(LDD,*), DWORK(*)
C     .. Local Scalars ..
      LOGICAL           LEQUIL, LQUERY
      INTEGER           I, I1, II, J, MM, MNU, MU, NINFZ, NN, NU1, NUMU,
     $                  NUMU1, PP, RO, SIGMA, WRKOPT
      DOUBLE PRECISION  MAXRED, SVLMAX, THRESH, TOLER
C     .. External Functions ..
      LOGICAL           LSAME
      DOUBLE PRECISION  DLAMCH, DLANGE
      EXTERNAL          DLAMCH, DLANGE, LSAME
C     .. External Subroutines ..
      EXTERNAL          AB08NX, DCOPY, DLACPY, DLASET, DORMRZ, DTZRZF,
     $                  TB01ID, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         DBLE, INT, MAX, MIN, SQRT
C     .. Executable Statements ..
C
      INFO = 0
      LEQUIL = LSAME( EQUIL, 'S' )
      LQUERY = ( LDWORK.EQ.-1 )
C
C     Test the input scalar arguments.
C
      IF( .NOT.LEQUIL .AND. .NOT.LSAME( EQUIL, 'N' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( M.LT.0 ) THEN
         INFO = -3
      ELSE IF( P.LT.0 ) THEN
         INFO = -4
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -6
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -8
      ELSE IF( LDC.LT.MAX( 1, P ) ) THEN
         INFO = -10
      ELSE IF( LDD.LT.MAX( 1, P ) ) THEN
         INFO = -12
      ELSE IF( LDAF.LT.MAX( 1, N + M ) ) THEN
         INFO = -22
      ELSE IF( LDBF.LT.MAX( 1, N + P ) ) THEN
         INFO = -24
      ELSE
         II = MIN( P, M )
         I  = MAX(          II + MAX( 3*M - 1, N ),
     $             MIN( P, N ) + MAX( 3*P - 1, N+P, N+M ),
     $             MIN( M, N ) + MAX( 3*M - 1, N+M ), 1 )
         IF( LQUERY ) THEN
            SVLMAX = ZERO
            NINFZ  = 0
            CALL AB08NX( N, M, P, P, 0, SVLMAX, BF, LDBF, NINFZ, INFZ,
     $                   KRONL, MU, NU, NKROL, TOL, IWORK, DWORK, -1,
     $                   INFO )
            WRKOPT = MAX( I, INT( DWORK(1) ) )
            CALL AB08NX( N, II, M, M-II, II, SVLMAX, AF, LDAF, NINFZ,
     $                   INFZ, KRONL, MU, NU, NKROL, TOL, IWORK, DWORK,
     $                   -1, INFO )
            WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) )
            CALL DTZRZF( II, N+II, AF, LDAF, DWORK, DWORK, -1, INFO )
            WRKOPT = MAX( WRKOPT, II + INT( DWORK(1) ) )
            CALL DORMRZ( 'Right', 'Transpose', N, N+II, II, N, AF, LDAF,
     $                   DWORK, AF, LDAF, DWORK, -1, INFO )
            WRKOPT = MAX( WRKOPT, II + INT( DWORK(1) ) )
         ELSE IF( LDWORK.LT.I ) THEN
            INFO = -28
         END IF
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'AB08ND', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         DWORK(1) = WRKOPT
         RETURN
      END IF
C
      DINFZ = 0
      NKROL = 0
      NKROR = 0
C
C     Quick return if possible.
C
      IF ( N.EQ.0 ) THEN
         IF ( MIN( M, P ).EQ.0 ) THEN
            NU   = 0
            RANK = 0
            DWORK(1) = ONE
            RETURN
         END IF
      END IF
C
      MM = M
      NN = N
      PP = P
C
      DO 20 I = 1, N
         INFZ(I) = 0
   20 CONTINUE
C
      IF ( M.GT.0 ) THEN
         DO 40 I = 1, N + 1
            KRONR(I) = 0
   40    CONTINUE
      END IF
C
      IF ( P.GT.0 ) THEN
         DO 60 I = 1, N + 1
            KRONL(I) = 0
   60    CONTINUE
      END IF
C
C     (Note: Comments in the code beginning "Workspace:" describe the
C     minimal amount of real workspace needed at that point in the
C     code, as well as the preferred amount for good performance.)
C
      WRKOPT = 1
C
C     Construct the compound matrix  ( B  A ), dimension (N+P)-by-(M+N).
C                                    ( D  C )
C
      CALL DLACPY( 'Full', NN, MM, B, LDB, BF, LDBF )
      IF ( PP.GT.0 )
     $   CALL DLACPY( 'Full', PP, MM, D, LDD, BF(1+NN,1), LDBF )
      IF ( NN.GT.0 ) THEN
         CALL DLACPY( 'Full', NN, NN, A, LDA, BF(1,1+MM), LDBF )
         IF ( PP.GT.0 )
     $      CALL DLACPY( 'Full', PP, NN, C, LDC, BF(1+NN,1+MM), LDBF )
      END IF
C
C     If required, balance the compound matrix (default MAXRED).
C     Workspace: need   N.
C
      IF ( LEQUIL .AND. NN.GT.0 .AND. PP.GT.0 ) THEN
         MAXRED = ZERO
         CALL TB01ID( 'A', NN, MM, PP, MAXRED, BF(1,1+MM), LDBF, BF,
     $                LDBF, BF(1+NN,1+MM), LDBF, DWORK, INFO )
         WRKOPT = N
      END IF
C
C     If required, set tolerance.
C
      THRESH = SQRT( DBLE( (N + P)*(N + M) ) )*DLAMCH( 'Precision' )
      TOLER = TOL
      IF ( TOLER.LT.THRESH ) TOLER = THRESH
      SVLMAX = DLANGE( 'Frobenius', NN+PP, NN+MM, BF, LDBF, DWORK )
C
C     Reduce this system to one with the same invariant zeros and with
C     D upper triangular of full row rank MU (the normal rank of the
C     original system).
C     Workspace: need   MAX( 1, MIN(P,M) + MAX(3*M-1,N),
C                               MIN(P,N) + MAX(3*P-1,N+P,N+M) );
C                prefer larger.
C
      RO = PP
      SIGMA = 0
      NINFZ = 0
      CALL AB08NX( NN, MM, PP, RO, SIGMA, SVLMAX, BF, LDBF, NINFZ, INFZ,
     $             KRONL, MU, NU, NKROL, TOLER, IWORK, DWORK, LDWORK,
     $             INFO )
      WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) )
      RANK = MU
C
C     Pertranspose the system.
C
      NUMU = NU + MU
      IF ( NUMU.NE.0 ) THEN
         MNU = MM + NU
         NUMU1 = NUMU + 1
C
         DO 80 I = 1, NUMU
            CALL DCOPY( MNU, BF(I,1), LDBF, AF(1,NUMU1-I), -1 )
   80    CONTINUE
C
         IF ( MU.NE.MM ) THEN
C
C           Here MU < MM and MM > 0 (since MM = 0 implies MU = 0 = MM).
C
            PP = MM
            NN = NU
            MM = MU
C
C           Reduce the system to one with the same invariant zeros and
C           with D square invertible.
C           Workspace: need  MAX( 1, MU + MAX(3*MU-1,N),
C                                 MIN(M,N) + MAX(3*M-1,N+M) );
C                prefer larger. Note that MU <= MIN(P,M).
C
            RO = PP - MM
            SIGMA = MM
            CALL AB08NX( NN, MM, PP, RO, SIGMA, SVLMAX, AF, LDAF, NINFZ,
     $                   INFZ, KRONR, MU, NU, NKROR, TOLER, IWORK,
     $                   DWORK, LDWORK, INFO )
            WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) )
         END IF
C
         IF ( NU.NE.0 ) THEN
C
C           Perform a unitary transformation on the columns of
C                     ( B  A-lambda*I )
C                     ( D       C     )
C           in order to reduce it to
C                     ( X  AF-lambda*BF )
C                     ( Y       0       )
C           with Y and BF square invertible.
C
            CALL DLASET( 'Full', NU, MU, ZERO, ZERO, BF, LDBF )
            CALL DLASET( 'Full', NU, NU, ZERO, ONE,  BF(1,MU+1), LDBF )
C
            IF ( RANK.NE.0 ) THEN
               NU1 = NU + 1
               I1  = NU + MU
C
C              Workspace: need   2*MIN(M,P);
C                         prefer MIN(M,P) + MIN(M,P)*NB.
C
               CALL DTZRZF( MU, I1, AF(NU1,1), LDAF, DWORK, DWORK(MU+1),
     $                      LDWORK-MU, INFO )
               WRKOPT = MAX( WRKOPT, INT( DWORK(MU+1) ) + MU )
C
C              Workspace: need   MIN(M,P) + N;
C                         prefer MIN(M,P) + N*NB.
C
               CALL DORMRZ( 'Right', 'Transpose', NU, I1, MU, NU,
     $                      AF(NU1,1), LDAF, DWORK, AF, LDAF,
     $                      DWORK(MU+1), LDWORK-MU, INFO )
               WRKOPT = MAX( WRKOPT, INT( DWORK(MU+1) ) + MU )
C
               CALL DORMRZ( 'Right', 'Transpose', NU, I1, MU, NU,
     $                      AF(NU1,1), LDAF, DWORK, BF, LDBF,
     $                      DWORK(MU+1), LDWORK-MU, INFO )
C
            END IF
C
C           Move AF and BF in the first columns. This assumes that
C           DLACPY moves column by column.
C
            CALL DLACPY( 'Full', NU, NU, AF(1,MU+1), LDAF, AF, LDAF )
            IF ( RANK.NE.0 )
     $         CALL DLACPY( 'Full', NU, NU, BF(1,MU+1), LDBF, BF, LDBF )
C
         END IF
      END IF
C
C     Set right Kronecker indices (column indices).
C
      IF ( NKROR.GT.0 ) THEN
         J = 1
C
         DO 120 I = 1, N + 1
C
            DO 100 II = J, J + KRONR(I) - 1
               IWORK(II) = I - 1
  100       CONTINUE
C
            J = J + KRONR(I)
            KRONR(I) = 0
  120    CONTINUE
C
         NKROR = J - 1
C
         DO 140 I = 1, NKROR
            KRONR(I) = IWORK(I)
  140    CONTINUE
C
      END IF
C
C     Set left Kronecker indices (row indices).
C
      IF ( NKROL.GT.0 ) THEN
         J = 1
C
         DO 180 I = 1, N + 1
C
            DO 160 II = J, J + KRONL(I) - 1
               IWORK(II) = I - 1
  160       CONTINUE
C
            J = J + KRONL(I)
            KRONL(I) = 0
  180    CONTINUE
C
         NKROL = J - 1
C
         DO 200 I = 1, NKROL
            KRONL(I) = IWORK(I)
  200    CONTINUE
C
      END IF
C
      IF ( N.GT.0 ) THEN
         DINFZ = N
C
  220    CONTINUE
         IF ( INFZ(DINFZ).EQ.0 ) THEN
            DINFZ = DINFZ - 1
            IF ( DINFZ.GT.0 )
     $         GO TO 220
         END IF
      END IF
C
      DWORK(1) = WRKOPT
      RETURN
C *** Last line of AB08ND ***
      END


!    Copyright (C) 2012 The SPEED FOUNDATION
!    Author: Ilario Mazzieri
!
!    This file is part of SPEED.
!
!    SPEED is free software; you can redistribute it and/or modify it
!    under the terms of the GNU Affero General Public License as
!    published by the Free Software Foundation, either version 3 of the
!    License, or (at your option) any later version.
!
!    SPEED is distributed in the hope that it will be useful, but
!    WITHOUT ANY WARRANTY; without even the implied warranty of
!    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
!    Affero General Public License for more details.
!
!    You should have received a copy of the GNU Affero General Public License
!    along with SPEED.  If not, see <http://www.gnu.org/licenses/>.

!> @brief Make damping matrices for non-linear elastic materials.
!! @author Ilario Mazzieri
!> @date November, 2014
!> @version 1.2
!> @param[in] nn nuber of 1D GLL nodes
!> @param[in] ct 1D GLL nodes
!> @param[in] ww 1D GLL weights
!> @param[in] dd spectral derivative matrix
!> @param[in] rho material density
!> @param[in] gamma0 damping coefficient
!> @param[in] alfa11 costant values for the bilinear map
!> @param[in] alfa12 costant values for the bilinear map
!> @param[in] alfa13 costant values for the bilinear map
!> @param[in] alfa21 costant values for the bilinear map
!> @param[in] alfa22 costant values for the bilinear map
!> @param[in] alfa23 costant values for the bilinear map
!> @param[in] alfa31 costant values for the bilinear map
!> @param[in] alfa32 costant values for the bilinear map
!> @param[in] alfa33 costant values for the bilinear map
!> @param[in] beta11 costant values for the bilinear map
!> @param[in] beta12 costant values for the bilinear map
!> @param[in] beta13 costant values for the bilinear map
!> @param[in] beta21 costant values for the bilinear map
!> @param[in] beta22 costant values for the bilinear map
!> @param[in] beta23 costant values for the bilinear map
!> @param[in] beta31 costant values for the bilinear map
!> @param[in] beta32 costant values for the bilinear map
!> @param[in] beta33 costant values for the bilinear map
!> @param[in] gamma1 costant values for the bilinear map
!> @param[in] gamma2 costant values for the bilinear map
!> @param[in] gamma3 costant values for the bilinear map
!> @param[in] delta1 costant values for the bilinear map
!> @param[in] delta2 costant values for the bilinear map
!> @param[in] delta3 costant values for the bilinear map
!> @param[in] cs_nnz length of cs
!> @param[in] cs connectivity vector
!> @param[in] vcase  depth for non linear block
!> @param[in] R_el  reduction factor associated to strain invariant
!> @param[in] fpeak  peak frequency
!> @param[in] nf number of functions
!> @param[in] func_type function type
!> @param[in] func_indx  indices for the data
!> @param[in] nfdata number of data for each function
!> @param[in] func_data data for the calculation (depending on type)
!> @param[in] t_stress  time
!> @param[in] tag_func  function label
!> @param[in] yon  1 if the node is non-linear elastic, 0 otherwise
!> @param[in] tcase  not-honoring test case
!> @param[in] nnod_loc  number of local nodes
!> @param[in] vs_tria  vs values for each node
!> @param[out] mc_el non-linear damping matrix
!> @param[out] mck_el non-linear damping matrix
!> @param[out] gamma_new gamma value for debug mode

      subroutine MAKE_DAMPING_MATRIX_NLE(nn,ct,ww,dd,rho,gamma0,&
                           alfa11,alfa12,alfa13,alfa21,alfa22,alfa23,&
                           alfa31,alfa32,alfa33,beta11,beta12,beta13,&
                           beta21,beta22,beta23,beta31,beta32,beta33,&
                           gamma1,gamma2,gamma3,delta1,delta2,delta3,&
                           mc_el,mck_el,&
                           cs_nnz,cs,ielem,&
                           vcase,R_el,fpeak, &
                           func_type,func_indx,func_data,nfdata,nf,t_stress,tag_func,yon,gamma_new,&
                           tcase, nnod_loc, vs_tria)

      implicit none

      integer*4 :: nn
      integer*4 :: i,j,k
      integer*4 :: nnt,tagmat
      integer*4 :: cs_nnz
      integer*4 :: vcase,nfdata
      integer*4 :: nf,fn,ielem,tcase,nnod_loc,in,is

      integer*4, dimension(nf) :: func_type
      integer*4, dimension(nf +1) :: func_indx
      integer*4, dimension(0:cs_nnz) :: cs
      integer*4, dimension(nf) :: tag_func

      integer*4, dimension(nn,nn,nn) :: yon

      real*8 :: alfa11,alfa12,alfa13,alfa21,alfa22,alfa23,alfa31,alfa32,alfa33
      real*8 :: beta11,beta12,beta13,beta21,beta22,beta23,beta31,beta32,beta33
      real*8 :: gamma1,gamma2,gamma3,delta1,delta2,delta3
      real*8 :: dxdx,dxdy,dxdz,dydx,dydy,dydz,dzdx,dzdy,dzdz,det_j
      real*8 :: DEPTH
      real*8 :: lambda, mu
      real*8 :: t_stress
      real*8 :: get_func_value
      real*8 :: csi,fpeak,Q,PI,gamma

      real*8, dimension(nfdata) :: func_data
      real*8, dimension(nn) :: ct,ww
      real*8, dimension(nnod_loc) :: vs_tria

      real*8, dimension(nn,nn) :: dd

      real*8, dimension(nn,nn,nn) :: rho,gamma0,gamma_new
      real*8, dimension(nn,nn,nn) :: mc_el,mck_el
      real*8, dimension(nn,nn,nn) :: R_el

      gamma_new = gamma0;

!     ELEMENT NODAL MASS CALCULATION

      do k = 1,nn
         do j = 1,nn
            do i = 1,nn

                if (yon(i,j,k).eq.1) then

                   dxdx = alfa11 +beta12*ct(k) +beta13*ct(j) &
                                        + gamma1*ct(j)*ct(k)
                   dydx = alfa21 +beta22*ct(k) +beta23*ct(j) &
                                        + gamma2*ct(j)*ct(k)
                   dzdx = alfa31 +beta32*ct(k) +beta33*ct(j) &
                                        + gamma3*ct(j)*ct(k)
                   dxdy = alfa12 +beta11*ct(k) +beta13*ct(i) &
                                       + gamma1*ct(k)*ct(i)
                   dydy = alfa22 +beta21*ct(k) +beta23*ct(i) &
                                        + gamma2*ct(k)*ct(i)
                   dzdy = alfa32 +beta31*ct(k) +beta33*ct(i) &
                                        + gamma3*ct(k)*ct(i)
                   dxdz = alfa13 +beta11*ct(j) +beta12*ct(i) &
                                        + gamma1*ct(i)*ct(j)
                   dydz = alfa23 +beta21*ct(j) +beta22*ct(i) &
                                        + gamma2*ct(i)*ct(j)
                   dzdz = alfa33 +beta31*ct(j) +beta32*ct(i) &
                                        + gamma3*ct(i)*ct(j)
                   det_j = dxdz * (dydx*dzdy - dzdx*dydy) &
                                        - dydz * (dxdx*dzdy - dzdx*dxdy) &
                                        + dzdz * (dxdx*dydy - dydx*dxdy)

                  is = nn*nn*(k -1) +nn*(j -1) +i
                  in = cs(cs(ielem -1) +is)
                  !-------------------------------------------------------------------
                  !
                  if(tcase .ne. 16) then
                    do fn = 1,nf
                       if (vcase.eq.tag_func(fn)) then
                          if (func_type(fn) .eq. 61) then
                             csi = get_func_value(nf,func_type,func_indx,func_data, nfdata,&
                                                 fn,R_el(i,j,k))

                              Q = 1.d0/(2.d0*csi)
                              PI = 4.0d0 * datan(1.0d0)
                              gamma = PI * fpeak / Q

                              if (gamma0(i,j,k) .ge. gamma) gamma = gamma0(i,j,k)
                              gamma_new(i,j,k) = gamma

                              mc_el(i,j,k) = 2.d0 * gamma * rho(i,j,k) &
                                                                * det_j * ww(i) * ww(j) * ww(k)
                              mck_el(i,j,k) = (gamma**2) * rho(i,j,k) &
                                                                * det_j * ww(i) * ww(j) * ww(k)

                           endif
                       endif
                     enddo
                   elseif (tcase .eq. 16) then

                     do fn = 1,nf
                         if (vcase .eq. tag_func(fn)) then
                             if (func_type(fn) .eq. 61 .and. vs_tria(in) .lt. 325.d0) then

                               csi = get_func_value(nf,func_type,func_indx,func_data, nfdata,&
                                                 fn,R_el(i,j,k))

                                Q = 1.d0/(2.d0*csi)
                                PI = 4.0d0 * datan(1.0d0)
                                gamma = PI * fpeak / Q

                                if (gamma0(i,j,k) .ge. gamma) gamma = gamma0(i,j,k)
                                gamma_new(i,j,k) = gamma

                                mc_el(i,j,k) = 2.d0 * gamma * rho(i,j,k) &
                                                                  * det_j * ww(i) * ww(j) * ww(k)
                                mck_el(i,j,k) = (gamma**2) * rho(i,j,k) &
                                                                  * det_j * ww(i) * ww(j) * ww(k)

                             elseif (func_type(fn) .eq. 63 .and. vs_tria(in) .lt. 450.d0) then
                               csi = get_func_value(nf,func_type,func_indx,func_data, nfdata,&
                                                 fn,R_el(i,j,k))

                                Q = 1.d0/(2.d0*csi)
                                PI = 4.0d0 * datan(1.0d0)
                                gamma = PI * fpeak / Q

                                if (gamma0(i,j,k) .ge. gamma) gamma = gamma0(i,j,k)
                                gamma_new(i,j,k) = gamma

                                mc_el(i,j,k) = 2.d0 * gamma * rho(i,j,k) &
                                                                * det_j * ww(i) * ww(j) * ww(k)
                                mck_el(i,j,k) = (gamma**2) * rho(i,j,k) &
                                                                * det_j * ww(i) * ww(j) * ww(k)

                              endif
                          endif
                        enddo

                   endif!tcase = 16

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

                endif !if (yon(i,j,k).eq.1) then

            enddo
         enddo
      enddo

      return

      end subroutine MAKE_DAMPING_MATRIX_NLE


	real function cin(n,pres,temp,qv)
C
c   based on the program calcsound from Kerry Emanuel web site.
C   ***   This program accepts input from the sounding contained   ***
C   ***      in the file <<sounding>> and calculates various       ***
C   ***       properties of samples of air raised or lowered       ***
C   ***                   to different levels.                     ***
C   ***      Output is tabulated in the file <<calcsound.out>>     ***
C   ***                 and in NCAR graphics files                 ***
C
	real pres(1), temp(1), qv(1)
c       units mb, K, g/kg
	integer n

	PARAMETER (NA=2000)
	REAL T(NA), P(NA), R(NA), TLR(NA,NA), TLP(NA,NA)
	REAL EV(NA), ES(NA), TVRDIF(NA,NA), TVPDIF(NA,NA)
	REAL TLVR(NA,NA), TLVP(NA,NA), LW(NA,NA), TVD(NA)
	REAL CAPER(NA), CAPEP(NA), DCAPE(NA), PAR(NA)
	REAL PAP(NA), NAR(NA), NAP(NA)
C

	do i=1,n
	  p(i) = pres(i)
	  t(i) = temp(i) - 273.15
	  r(i) = qv(i)
	end do

C   ***   ASSIGN VALUES OF THERMODYNAMIC CONSTANTS     ***
C
        CPD=1005.7
	CPV=1870.0
        CL=4190.0
        CPVMCL=2320.0
        RV=461.5
        RD=287.04
        EPS=RD/RV
        ALV0=2.501E6
C
C   ***   Read in the sounding from the file <<sounding>>          ***
c
	DO 20 I=1,N
	 R(I)=R(I)*0.001
	 EV(I)=R(I)*P(I)/(EPS+R(I))
	 ES(I)=6.112*EXP(17.67*T(I)/(243.5+T(I)))
	 T(I)=T(I)+273.15
   20	CONTINUE
C
C   ***  Begin outer loop, which cycles through parcel origin levels I ***
C
	DO 500 I=1,N
C
C   ***  Define various conserved parcel quantities: reversible   ***
C   ***        entropy, S, pseudo-adiabatic entropy, SP,          ***
C   ***                   and enthalpy, AH                        ***
C
	RS=EPS*ES(I)/(P(I)-ES(I))
	ALV=ALV0-CPVMCL*(T(I)-273.15)
	EM=MAX(EV(I),1.0E-6)
	S=(CPD+R(I)*CL)*LOG(T(I))-RD*LOG(P(I)-EV(I))+
     1    ALV*R(I)/T(I)-R(I)*RV*LOG(EM/ES(I))
	SP=CPD*LOG(T(I))-RD*LOG(P(I)-EV(I))+
     1    ALV*R(I)/T(I)-R(I)*RV*LOG(EM/ES(I))
	AH=(CPD+R(I)*CL)*T(I)+ALV*R(I)
C
C   ***  Find the temperature and mixing ratio of the parcel at   ***
C   ***    level I saturated by a wet bulb process                ***
C
	SLOPE=CPD+ALV*ALV*RS/(RV*T(I)*T(I))
	TG=T(I)
	RG=RS
	DO 100 J=1,20
	 ALV1=ALV0-CPVMCL*(TG-273.15)
	 AHG=(CPD+CL*RG)*TG+ALV1*RG
	 TG=TG+(AH-AHG)/SLOPE
	 TC=TG-273.15
	 ENEW=6.112*EXP(17.67*TC/(243.5+TC))
	 RG=EPS*ENEW/(P(I)-ENEW)
  100	CONTINUE
C
C   ***  Calculate conserved variable at top of downdraft   ***
C
	EG=RG*P(I)/(EPS+RG)
	SPD=CPD*LOG(TG)-RD*LOG(P(I)-EG)+
     1    ALV1*RG/TG
	TVD(I)=TG*(1.+RG/EPS)/(1.+RG)-T(I)*(1.+R(I)/EPS)/
     1    (1.+R(I))
	IF(P(I).LT.100.0)TVD(I)=0.0
	RGD0=RG
	TGD0=TG
C
C   ***   Find lifted condensation pressure     ***
C
	RH=R(I)/RS
	RH=MIN(RH,1.0)
	CHI=T(I)/(1669.0-122.0*RH-T(I))
	PLCL=1.0
	IF(RH.GT.0.0)THEN
	 PLCL=P(I)*(RH**CHI)
	END IF
C
C   ***  Begin updraft loop   ***
C
	SUM=0.0
	RG0=R(I)
	TG0=T(I)
	DO 200 J=I,N
C
C   ***  Calculate estimates of the rates of change of the entropies  ***
C   ***           with temperature at constant pressure               ***
C
	 RS=EPS*ES(J)/(P(J)-ES(J))
	 ALV=ALV0-CPVMCL*(T(J)-273.15)
	 SL=(CPD+R(I)*CL+ALV*ALV*RS/(RV*T(J)*T(J)))/T(J)
	 SLP=(CPD+RS*CL+ALV*ALV*RS/(RV*T(J)*T(J)))/T(J)
C
C   ***  Calculate lifted parcel temperature below its LCL   ***
C
	 IF(P(J).GE.PLCL)THEN
	  TLR(I,J)=T(I)*(P(J)/P(I))**(RD/CPD)
	  TLP(I,J)=TLR(I,J)
	  LW(I,J)=0.0
	  TLVR(I,J)=TLR(I,J)*(1.+R(I)/EPS)/(1.+R(I))
	  TLVP(I,J)=TLVR(I,J)
	  TVRDIF(I,J)=TLVR(I,J)-T(J)*(1.+R(J)/EPS)/(1.+R(J))
	  TVPDIF(I,J)=TVRDIF(I,J)
	 ELSE
C
C   ***  Iteratively calculate lifted parcel temperature and mixing   ***
C   ***    ratios for both reversible and pseudo-adiabatic ascent     ***
C
	 TG=T(J)
	 RG=RS
	 DO 150 K=1,20
	  EM=RG*P(J)/(EPS+RG)
	  ALV=ALV0-CPVMCL*(TG-273.15)
	  SG=(CPD+R(I)*CL)*LOG(TG)-RD*LOG(P(J)-EM)+
     1      ALV*RG/TG
	  TG=TG+(S-SG)/SL
	  TC=TG-273.15
	  ENEW=6.112*EXP(17.67*TC/(243.5+TC))
	  RG=EPS*ENEW/(P(J)-ENEW)
  150	 CONTINUE
	 TLR(I,J)=TG
	 TLVR(I,J)=TG*(1.+RG/EPS)/(1.+R(I))
	 LW(I,J)=R(I)-RG
	 LW(I,J)=MAX(0.0,LW(I,J))
	 TVRDIF(I,J)=TLVR(I,J)-T(J)*(1.+R(J)/EPS)/(1.+R(J))
C
C   ***   Now do pseudo-adiabatic ascent   ***
C
	 TG=T(J)
	 RG=RS
	 DO 180 K=1,20
	  CPW=0.0
	  IF(J.GT.1)THEN
	   CPW=SUM+CL*0.5*(RG0+RG)*(LOG(TG)-LOG(TG0))
	  END IF
	  EM=RG*P(J)/(EPS+RG)
	  ALV=ALV0-CPVMCL*(TG-273.15)
	  SPG=CPD*LOG(TG)-RD*LOG(P(J)-EM)+CPW+
     1      ALV*RG/TG
	  TG=TG+(SP-SPG)/SLP
	  TC=TG-273.15
	  ENEW=6.112*EXP(17.67*TC/(243.5+TC))
	  RG=EPS*ENEW/(P(J)-ENEW)
  180	 CONTINUE
	 TLP(I,J)=TG
	 TLVP(I,J)=TG*(1.+RG/EPS)/(1.+RG)
	 TVPDIF(I,J)=TLVP(I,J)-T(J)*(1.+R(J)/EPS)/(1.+R(J))
	 RG0=RG
	 TG0=TG
	 SUM=CPW
 	END IF
  200	CONTINUE
	IF(I.EQ.1)GOTO 500
C
C   ***  Begin downdraft loop   ***
C
	SUM2=0.0
	DO 300 J=I-1,1,-1
C
C   ***  Calculate estimate of the rate of change of entropy          ***
C   ***           with temperature at constant pressure               ***
C
	 RS=EPS*ES(J)/(P(J)-ES(J))
	 ALV=ALV0-CPVMCL*(T(J)-273.15)
	 SLP=(CPD+RS*CL+ALV*ALV*RS/(RV*T(J)*T(J)))/T(J)
	 TG=T(J)
	 RG=RS
C
C   ***  Do iteration to find downdraft temperature   ***
C
	 DO 250 K=1,20
	  CPW=SUM2+CL*0.5*(RGD0+RG)*(LOG(TG)-LOG(TGD0))
	  EM=RG*P(J)/(EPS+RG)
	  ALV=ALV0-CPVMCL*(TG-273.15)
	  SPG=CPD*LOG(TG)-RD*LOG(P(J)-EM)+CPW+
     1      ALV*RG/TG
	  TG=TG+(SPD-SPG)/SLP
	  TC=TG-273.15
	  ENEW=6.112*EXP(17.67*TC/(243.5+TC))
	  RG=EPS*ENEW/(P(J)-ENEW)
  250	 CONTINUE
	 SUM2=CPW
	 TGD0=TG
	 RGD0=RG
	 TLP(I,J)=TG
	 TLVP(I,J)=TG*(1.+RG/EPS)/(1.+RG)
	 TVPDIF(I,J)=TLVP(I,J)-T(J)*(1.+R(J)/EPS)/(1.+R(J))
	 IF(P(I).LT.100.0)TVPDIF(I,J)=0.0
	 TVPDIF(I,J)=MIN(TVPDIF(I,J),0.0)
	 TLR(I,J)=T(J)
	 TLVR(I,J)=T(J)
	 TVRDIF(I,J)=0.0
	 LW(I,J)=0.0
  300	CONTINUE
  500   CONTINUE
C
C  ***  Begin loop to find CAPE, PA, and NA from reversible and ***
C  ***            pseudo-adiabatic ascent, and DCAPE            ***
C
	DO 800 I=1,N
	 CAPER(I)=0.0
	 CAPEP(I)=0.0
	 DCAPE(I)=0.0
	 PAP(I)=0.0
	 PAR(I)=0.0
	 NAP(I)=0.0
	 NAR(I)=0.0
C
C   ***   Find lifted condensation pressure     ***
C
	RS=EPS*ES(I)/(P(I)-ES(I))
	RH=R(I)/RS
	RH=MIN(RH,1.0)
	CHI=T(I)/(1669.0-122.0*RH-T(I))
	PLCL=1.0
	IF(RH.GT.0.0)THEN
	 PLCL=P(I)*(RH**CHI)
	END IF
C
C   ***  Find lifted condensation level and maximum level   ***
C   ***               of positive buoyancy                  ***
C
	 ICB=N
	 INBR=1
	 INBP=1
	 DO 550 J=N,I,-1
	  IF(P(J).LT.PLCL)ICB=MIN(ICB,J)
	  IF(TVRDIF(I,J).GT.0.0)INBR=MAX(INBR,J)
	  IF(TVPDIF(I,J).GT.0.0)INBP=MAX(INBP,J)
  550	 CONTINUE
	  IMAX=MAX(INBR,I)
	   DO 555 J=IMAX,N
	    TVRDIF(I,J)=0.0
  555	   CONTINUE
	  IMAX=MAX(INBP,I)
	   DO 565 J=IMAX,N
	    TVPDIF(I,J)=0.0
  565	   CONTINUE
C
C   ***  Do updraft loops        ***
C
	 IF(INBR.GT.I)THEN
	  DO 600 J=I+1,INBR
	   TVM=0.5*(TVRDIF(I,J)+TVRDIF(I,J-1))
	   PM=0.5*(P(J)+P(J-1))
	   IF(TVM.LE.0.0)THEN
	    NAR(I)=NAR(I)-RD*TVM*(P(J-1)-P(J))/PM
	   ELSE
	    PAR(I)=PAR(I)+RD*TVM*(P(J-1)-P(J))/PM
	   END IF
  600	  CONTINUE
	  CAPER(I)=PAR(I)-NAR(I)
	 END IF
	 IF(INBP.GT.I)THEN
	  DO 650 J=I+1,INBP
	   TVM=0.5*(TVPDIF(I,J)+TVPDIF(I,J-1))
	   PM=0.5*(P(J)+P(J-1))
	   IF(TVM.LE.0.0)THEN
	    NAP(I)=NAP(I)-RD*TVM*(P(J-1)-P(J))/PM
	   ELSE
	    PAP(I)=PAP(I)+RD*TVM*(P(J-1)-P(J))/PM
	   END IF
  650	  CONTINUE
	  CAPEP(I)=PAP(I)-NAP(I)
	 END IF
C
C  ***       Find DCAPE     ***
C
	 IF(I.EQ.1)GOTO 800
	 DO 700 J=I-1,1,-1
	  TVDIFM=TVPDIF(I,J+1)
	  IF(I.EQ.(J+1))TVDIFM=TVD(I)
	  TVM=0.5*(TVPDIF(I,J)+TVDIFM)
	  PM=0.5*(P(J)+P(J+1))
	  IF(TVM.LT.0.0)THEN
	   DCAPE(I)=DCAPE(I)-RD*TVM*(P(J)-P(J+1))/PM
	  END IF
  700	 CONTINUE
  800	CONTINUE

	 cin = nap(1)

	return
	END


C++**************************************************************************
C Program DECODE_PAPA
C To decode speckle files generated by PAPA type camera
C (X,Y,X,Y,etc) in 8 bits for X and 8 bits for Y.
C Output: bispectrum phase factor, modulus (squared) of the spectrum,
C         and long integration.
C
C Output file for the details of the input parameters: DECODE_PAPA.DAT
C
C Tests: fft_nag.for or fft_jlp.for give exactly the same FFT,
C        and JLP version goes as fast as the nag version (maybe a bit
C        faster even)
C
C JLP
C Version: 14-06-92
C--**************************************************************************
C Nota: C@ points to debugging instructions
C
	PROGRAM DECODE_PAPA

C  POUR IR=25
	PARAMETER (NGMAX=187566,IDIM=256)

C  POUR IR=30
C	PARAMETER (NGMAX=388400,IDIM=256)

C MAX number of photons/frame:
        PARAMETER (MAXPH=2000,MAXPH2=4000)

	REAL IMAGE(IDIM,IDIM),LONG_INTEG(IDIM,IDIM)
C Squared modulus, and bispectral phase factor:
	REAL MODSQ(IDIM,IDIM),IMAGINARY(IDIM,IDIM),FFIELD(IDIM,IDIM)
	REAL YCE1(NGMAX,4),SNRM(IDIM,IDIM)
C !! integer*2 !!!!
	INTEGER*2 IBUF(MAXPH),IX,IY
	INTEGER*4 NX1,NY1,ISKIP
	INTEGER*4 NCARA,IFRAME,NFRAME,NPHOTONS
	LOGICAL*1 IBUFT(MAXPH2),IX1(2),IY1(2)
	CHARACTER LONGNAME*40
	CHARACTER FILE1*40,FFNAME*40,COMMENTS*80,NAME*40
	EQUIVALENCE (IBUF(1),IBUFT(1))
	EQUIVALENCE (IX1(1),IX)
	EQUIVALENCE (IY1(1),IY)
	COMMON/MFRAMES/LONG_INTEG
	COMMON/BISP1/MODSQ,SNRM,IMAGINARY,YCE1,IR,NBETA,NGAMMA

10	FORMAT(A)

	CALL JLP_BEGIN
	CALL JLP_INQUIFMT

	OPEN(2,STATUS='UNKNOWN',FILE='decode_papa.log',ERR=999)
	WRITE(2,58)
	WRITE(6,58)
58	FORMAT(' Program DECODE_PAPA Version 14-06-92',/,
     1	' Compression of images to 128x128',/)
        IFACT=2
	NX1=256/IFACT
	NY1=256/IFACT

C UV Coverage:
	WRITE(6,*) ' Radius (IR) of uv-coverage ?'
	READ(5,*) IR
	CALL COVERA(IR,NBETA,NGAMMA)

C Speckle data:
95	WRITE(6,*) ' INPUT FILE (SPECKLE DATA) :'
	READ(5,10) FILE1
C	OPEN(10,FILE=FILE1,
C     1	FORM='UNFORMATTED',STATUS='OLD',ERR=95)
C Imode=0 (read only)
	IMODE=0
	CALL JLP_OSDOPEN(FILE1,40,IMODE,IFID,ISTAT)
	 IF(ISTAT.NE.0)THEN
	    WRITE(6,*) ' Fatal error opening the data input file'
	    GOTO 998
	 ENDIF

	WRITE(6,98)
98	FORMAT(' Number or photons per frame (max=2000)',
     1	' number of frames, and number of bytes to skip at the beginning')
	READ(5,*) NPHOTONS,NFRAME,ISKIP
        NPHOTONS=MIN(2000,NPHOTONS)
	IF(ISKIP.GE.1)THEN
         NCARA=1
	 DO I=1,ISKIP
	   CALL JLP_OSDREAD(IFID,IBUFT,NCARA,ISTAT)
	 END DO
	 PRINT 86,ISKIP,ISTAT
86	 FORMAT(' Skipping ',I6,' bytes at the beginning, ISTAT=',I5)
	ENDIF

C Enter the flat field:
        WRITE(6,73)
73      FORMAT(/,' ********ENTER THE FLAT FIELD:*******')
        FFNAME=' '
        CALL JLP_READIMAG(FFIELD,NXFF,NYFF,IDIM,FFNAME,COMMENTS)
          IF(NXFF.NE.256.OR.NYFF.NE.256)THEN
            WRITE(2,76)
76          FORMAT(' Fatal error: Inconsistent size of the flat field')
            GOTO 998
          ENDIF
C Normalization of the flat field:
        CALL NORMALIZE(FFIELD,256,256,IDIM)

C Header for the logfile:
	WRITE(2,92) FILE1,NPHOTONS,NFRAME
92	FORMAT(' Input file:',A,/,
     1	' Number of photons per frame :',I8,/,
     1	' Number of frames (wanted):',I8,/)

	 XPHOT=0.
	 CALL ERASE_IMAGE(IMAGINARY,NX1,NY1,IDIM)
	 CALL ERASE_IMAGE(MODSQ,NX1,NY1,IDIM)
	 CALL ERASE_IMAGE(SNRM,NX1,NY1,IDIM)

C Read data as a continuous flow, with sets of 1024 points
	 NCARA=2*NPHOTONS
	 DO IFRAME=1,NFRAME
	   CALL JLP_OSDREAD(IFID,IBUFT,NCARA,ISTAT)
	   NBUF=NCARA/2
	   IF(ISTAT.NE.0.OR.NBUF.NE.NPHOTONS)THEN
	      IF(K.EQ.1)THEN
	      WRITE(6,*) ' Fatal error reading the data in the input file'
	      CALL JLP_OSDCLOSE(IFID,ISTAT)
	      GOTO 998
	      ELSE
C Normal exit from the loop:
	      GOTO 9999
	      ENDIF
	   ENDIF
C To know how it goes:
           IF(MOD(IFRAME,10).EQ.1) THEN
	     WRITE(2,111)IFRAME
	     WRITE(6,111)IFRAME
111	     FORMAT(' FRAME #',I8)
           ENDIF
C Swaping (since data coming from the Vax):
C	   CALL SWAP(IBUF,NBUF)
C Decoding now, integrating the individual frames,
C mean spectrum, bispectrum :
	    DO I=1,NCARA,2
C For Sun: IX1(1) MSB, IX1(2) LSB.
	      IX=0
	      IY=0
	      IX1(2)=IBUFT(I)
	      IY1(2)=IBUFT(I+1)
	      IX=IX+1
	      IY=IY+1
C Add the new photon now:
C Flat field correction, and integration of the photons on IMAGE:
             IXX=IX/IFACT
             IYY=IY/IFACT
	     IMAGE(IXX,IYY)=IMAGE(IXX,IYY)+FFIELD(IX,IY)
	    END DO

	  CALL PAPA_SPIMAGE(IMAGE,NX1,NY1)
	 END DO

C End:
C9999	CLOSE(10)
9999	CALL JLP_OSDCLOSE(IFID,ISTAT)
	IF(ISTAT.NE.0)THEN
	  WRITE(6,*) ' Fatal error closing the data input file'
	ENDIF

C Recentre Fourier transforms:
        CALL RECENTRE(MODSQ,MODSQ,NX1,NY1,IDIM)
        CALL RECENTRE(SNRM,SNRM,NX1,NY1,IDIM)

C Diagnostic:
	NFRAME=IFRAME-1
	IXC=NX1/2+1
	IYC=NY1/2+1
	W1=MODSQ(IXC,IYC)/FLOAT(NFRAME)
	XPHOT=NPHOTONS
	WRITE(6,88) XPHOT,NFRAME,W1
	WRITE(2,88) XPHOT,NFRAME,W1
88	FORMAT(' Mean Nphotons/frame:',F14.2,'  Nframes :',I8,/,
     1	' Maximum of MODSQ : ',G12.4,2X)
	W1=MODSQ(IXC,IYC)
	CALL MEAN_FRAMES(MODSQ,NX1,NY1,IDIM,W1)
	CALL MEAN_FRAMES(SNRM,NX1,NY1,IDIM,W1)

C Simply divide the integrated frames by the number of frames:
	W1=REAL(NFRAME)
	CALL MEAN_FRAMES(YCE1,NGAMMA,4,NGMAX,W1)
	CALL MEAN_FRAMES(LONG_INTEG,NX1,NY1,IDIM,W1)

C Squared modulus:
	WRITE(6,39)
39	FORMAT(/,' ********OUTPUT OF THE MEAN SQUARED MODULUS:*******')
	   WRITE(COMMENTS,38) FILE1(1:12),NFRAME,XPHOT
38	   FORMAT('MODSQ ',A12,' Nf,Np:',X,I10,X,F9.1)
	   WRITE(6,10) COMMENTS
	   WRITE(2,10) COMMENTS
	   NAME='modsq'
	   CALL JLP_WRITEIMAG(MODSQ,NX1,NY1,IDIM,NAME,COMMENTS)
	   WRITE(2,36)
	   WRITE(6,36)
36	   FORMAT(' Mean spectrum (modulus squared) in: modsq')

C Bipsectrum:
	   NAME='bisp1'
	   CALL JLP_WRITEIMAG(YCE1,NGAMMA,4,NGMAX,NAME,COMMENTS)
	   WRITE(2,37)
37	   FORMAT(' Mean bispectrum in: bisp1 (list')

	WRITE(6,49)
49	FORMAT(/,' ****OUTPUT OF THE LONG INTEGRATION FRAME:*****')
	   WRITE(COMMENTS,48) FILE1(1:14),NFRAME,XPHOT
48	   FORMAT(' ',A14,' Nf,Np:',X,I10,X,F9.1)
	   WRITE(6,10) COMMENTS
	   WRITE(2,10) COMMENTS
	   LONGNAME='long'
	   CALL JLP_WRITEIMAG(LONG_INTEG,NX1,NY1,IDIM,LONGNAME,
     1	COMMENTS)
	   WRITE(2,47)
	   WRITE(6,47)
47	   FORMAT(' Long integ. (mean) of the frames in: long')

C End:
998	CLOSE(2)
	PRINT *,' Logfile in: decode_papa.log'
	CALL JLP_END
	STOP
999	PRINT *,' Fatal error opening: decode_papa.log'
	CALL JLP_END
	STOP
	END
C********************************************************************
C Subroutine PAPA_SPIMAGE
C Integrates the counts on speckle images
C********************************************************************
	SUBROUTINE PAPA_SPIMAGE(IMAGE,NX1,NY1)
C  POUR IR=25
	PARAMETER (NGMAX=187566,IDIM=256)

C  POUR IR=30
C	PARAMETER (NGMAX=388400,IDIM=256)

	REAL*4 MODSQ(IDIM,IDIM),YCE1(NGMAX,4)
	INTEGER*4 IR,NBETA,NGAMMA
	REAL*4 IMAGE(IDIM,IDIM)
	REAL*4 IMAGINARY(IDIM,IDIM)
	INTEGER*4 NX1,NY1

	COMMON/BISP1/MODSQ,SNRM,IMAGINARY,YCE1,IR,NBETA,NGAMMA

C Long integration:
	CALL SUM_FRAMES(IMAGE,NX1,NY1)

C Fourier Transform:
C        WRITE(6,*) ' Start FFT'
        CALL MYFOURN2(IMAGE,IMAGINARY,NX1,NY1,IDIM)

C Computes the mean spectrum and bispectrum (correction from photon noise)
C        PRINT *,' Calling BISPEC1'
C Nota: 02-12-91: BISPEC1 seems better than BISPEC2
	CALL BISPEC1(IMAGE,IMAGINARY,MODSQ,SNRM,NX1,NY1,IDIM,
     1	YCE1,IR,NBETA,NGAMMA)
C	CALL BISPEC2(IMAGE,IMAGINARY,MODSQ,SNRM,NX1,NY1,IDIM,
C     1	YCE1,IR,NBETA,NGAMMA)

C Prepares the next step:
C Cleans the previous image:
	CALL ERASE_IMAGE(IMAGE,NX1,NY1,IDIM)

	RETURN
	END
C********************************************************************
C Subroutine ERASE
C Erases the image
C********************************************************************
	SUBROUTINE ERASE_IMAGE(IMAGE,NX,NY,IDIM)
	REAL*4 IMAGE(IDIM,*)
	INTEGER*4 NX,NY
	DO J=1,NY
	  DO I=1,NX
	     IMAGE(I,J)=0.
	  END DO
	END DO
	RETURN
	END
C********************************************************************
C Subroutine SUM_FRAMES
C To add up all the frames
C********************************************************************
	SUBROUTINE SUM_FRAMES(IMAGE,NX,NY)
	PARAMETER (IDIM=256)
	REAL*4 LONG_INTEG(IDIM,IDIM)
	REAL*4 IMAGE(IDIM,*)
	COMMON/MFRAMES/LONG_INTEG

C Add up all the frames:
	DO J=1,NY
	  DO I=1,NX
	    LONG_INTEG(I,J)=LONG_INTEG(I,J)+IMAGE(I,J)
	  END DO
	END DO

	RETURN
	END
C********************************************************************
C Subroutine MEAN_FRAMES
C Computes the mean frame
C********************************************************************
	SUBROUTINE MEAN_FRAMES(A,NX,NY,IDIM,XQUO)
	REAL*4 A(IDIM,*),XNUMB,XQUO
	INTEGER*4 NX,NY

	DO J=1,NY
	   DO I=1,NX
	      A(I,J)=A(I,J)/XQUO
	   END DO
	END DO

	RETURN
	END

C********************************************************************
C Swap the two bytes of integer*2 values.
C
C IN   : Input/Output array
C NCAR : Number of INTEGER*2 to swap
c************************************************************
        SUBROUTINE SWAP (IN, NCAR)
	INTEGER*2 IN(*), AUXI2
	INTEGER*4 NCAR
	LOGICAL*1 LOW, AUXL1(2)
	EQUIVALENCE (AUXI2, AUXL1(1))

        DO I=1, NCAR
	 AUXI2=IN(I)
	 LOW  =AUXL1(1)
C Swap
	 AUXL1(1)=AUXL1(2)
	 AUXL1(2)=LOW
	 IN(I)  =AUXI2
	 END DO
	 RETURN

	 END
C********************************************************************
C Subroutine NORMALIZE
C To normalize the flat field on the working area
C
C JLP91: Please note that we take 1/FFIELD in order to multiply with
C the flat field... (easier to handle with padding filter and zeroes...)
C********************************************************************
        SUBROUTINE NORMALIZE(FFIELD,NX,NY,IDIM)
        REAL*4 FFIELD(IDIM,*)
        REAL*8 XMEAN
        REAL*4 MIN_VALUE,MAX_VALUE
        CHARACTER NAME*40,COMMENTS*80

C Computing the mean on the good area:
        XMEAN=0.
        DO J=1,NY
          DO I=1,NX
             FFIELD(I,J)=MAX(0.,FFIELD(I,J))
             XMEAN=XMEAN+FFIELD(I,J)
          END DO
        END DO
        XMEAN=XMEAN/FLOAT(NX*NY)
        WRITE(6,58) XMEAN
        WRITE(2,58) XMEAN
58      FORMAT(' First mean value of the Flat Field: ',G12.5)

C Then normalization to 1:
C This value should not be too small, otherwise it distorts the spectrum!!!
C (0.01 is too small, 0.333 not too bad,...)
        MIN_VALUE=0.1
        MAX_VALUE=10.
        SUM=0.
        DO J=1,NY
          DO I=1,NX
             FFIELD(I,J)=FFIELD(I,J)/XMEAN
             FFIELD(I,J)=MAX(FFIELD(I,J),MIN_VALUE)
             FFIELD(I,J)=MIN(FFIELD(I,J),MAX_VALUE)
             SUM=SUM+FFIELD(I,J)
          END DO
        END DO
        XMEAN=SUM/FLOAT(NX*NY)
        WRITE(6,59) XMEAN
        WRITE(2,59) XMEAN
59      FORMAT(' Second mean of the Flat Field (limits 0.1, 10.): ',G12.5)

C Normalization to 1 and inversion of the flat field:
        DO J=1,NY
          DO I=1,NX
            FFIELD(I,J)=XMEAN/FFIELD(I,J)
          END DO
        END DO

C Test:
        COMMENTS='Inverse flat field'
        NAME='ffield_test'
        PRINT *,' Output of the synthetic Flat Field: ',NAME
        CALL JLP_WRITEIMAG(FFIELD,NX,NY,IDIM,NAME,
     1       COMMENTS)

        RETURN
        END
C*************************************************************
	INCLUDE 'jlp_bispec1.for'
	include 'jlp_cover.for'
	include 'fft_jlp.for'
C	include 'fft_nag.for'
C********************************************************************
        SUBROUTINE MYFOURN2(TR,TI,NX,NY,IDIM)
	REAL TR(IDIM,*),TI(IDIM,*)
        REAL DATA(600*600*2)
        INTEGER NN(2)

C Rearranging the data for MYFOURN1
C (real and complex value ordered in a standard fortran array...)
        K=1
        DO J=1,NY
          DO I=1,NX
          DATA(K)=TR(I,J)
          DATA(K+1)=0.
          K = K+2
          END DO
        END DO

C Actual FFT:
        NN(1)=NX
        NN(2)=NY
        CALL MYFOURN1(DATA,NN)

C Rearranging the data
        K=1
        DO J=1,NY
          DO I=1,NX
          TR(I,J)=DATA(K)
          TI(I,J)=DATA(K+1)
          K = K+2
          END DO
        END DO

        RETURN
        END
C++*******************************************************************
C FOURN1
C From "Numerical Recipees" p 451
C
C Replaces DATA by its NDIM-dimensional disccrete Fourier transform.
C NN is an integer array of length NDIM, containing the lengths of each
C dimension (number of complex values), which MUST all be powers of 2.
C DATA is a real array of length twice the product of these lengths, in
C which the data are stored as in a multidimensional complex Fortran array.
C
C Restriction of fourn1 to ndim=2, and only direct FFT
C
C JLP
C Version 03-11-91
C--*********************************************************************
	SUBROUTINE MYFOURN1(DATA,NN)

C Double precision for trigonometric recurrences:
	real*8 wr,wi,wpr,wpi,wtemp,theta

	integer*4 ntot,nprev,n,i1,i2,i3,i2rev,i3rev
	integer*4 ibit,ifp1,ifp2,ip1,ip2,k1,k2,idim,nrem
	integer*4 nn(*)
	real*4 data(*),tempr,tempi

C Compute total number of complex values:
	ntot=1
	do 11 idim=1,2
	  ntot=ntot*nn(idim)
11	continue

	nprev=1

C Main loop over the dimensions:
	do 18 idim=1,2
	  n=nn(idim)
	  nrem=ntot/(n*nprev)
	  ip1=2*nprev
	  ip2=ip1*n
	  ip3=ip2*nrem
	  i2rev=1

C This is the bit reversal routine
C (to set up the book keeping for the next step):
	  do 14 i2=1,ip2,ip1
	      if(i2.lt.i2rev)then
	         do 13 i1=i2,i2+ip1-2,2
	            do 12 i3=i1,ip3,ip2
	               i3rev=i2rev+i3-i2
C Swap real array  (i3 <-> i3rev) and imaginary array (i3+1 <-> i3rev+1)
	               tempr=data(i3)
	               tempi=data(i3+1)
	               data(i3)=data(i3rev)
	               data(i3+1)=data(i3rev+1)
	               data(i3rev)=tempr
	               data(i3rev+1)=tempi
12	            continue
13	         continue
              endif
              ibit=ip2/2
1	      if((ibit.ge.ip1).and.(i2rev.gt.ibit))then
	          i2rev=i2rev-ibit
	          ibit=ibit/2
	      go to 1
	      endif
	      i2rev=i2rev+ibit
14	   continue

C Here begins the Danielson-Lanczos section of the routine:
C (i.e. iterative processing of the data)
	ifp1=ip1
2	if(ifp1.lt.ip2)then
	  ifp2=2*ifp1
C Initialize for the trig. recurrence:
	  theta=-6.28318530717959/(ifp2/ip1)
	  wpr=-2.d0*dsin(0.5d0*theta)**2
	  wpi=dsin(theta)
	  wr=1.d0
	  wi=0.d0
	  do 17 i3=1,ifp1,ip1
	    do 16 i1=i3,i3+ip1-2,2
	      do 15 i2=i1,ip3,ifp2
	        k1=i2
	        k2=k1+ifp1
C Danielson-Lanczos formula:
	        tempr=sngl(wr)*data(k2)-sngl(wi)*data(k2+1)
	        tempi=sngl(wr)*data(k2+1)+sngl(wi)*data(k2)
	        data(k2)=data(k1)-tempr
	        data(k2+1)=data(k1+1)-tempi
	        data(k1)=data(k1)+tempr
	        data(k1+1)=data(k1+1)+tempi
15	      continue
16	    continue

C Trigonometric recurrence:
	    wtemp=wr
	    wr=wr*wpr-wi*wpi+wr
	    wi=wi*wpr+wtemp*wpi+wi
17	    continue
	  ifp1=ifp2
	  go to 2
	  endif
	  nprev=n*nprev
18	continue

	return
	end


      subroutine compute_rrx(ctfm,ctfmp,n_A,n_B,n_Lamx,n_phi,octfmp,x,Nx
     &,hx,myzero,phys_bdy,res)
      implicit none
      integer i
      integer Nx
      real*8 hx
      real*8 myzero
      real*8 ctfm(Nx)
      real*8 ctfmp(Nx)
      real*8 n_A(Nx)
      real*8 n_B(Nx)
      real*8 n_Lamx(Nx)
      real*8 n_phi(Nx)
      real*8 octfmp(Nx)
      real*8 x(Nx)
      integer phys_bdy(2)
      real*8 res(Nx)
      real*8 qb
      if (phys_bdy(1) .eq. 1) then
      do i=1, 1, 1
      qb = myzero * x(i)
      res(i)=qb
      end do
      endif
      do i=2, Nx-1, 1
      qb = (-0.2D1 + 0.2D1 / n_B(i) * n_A(i)) / ctfm(i) ** 2 + ((0.25000
     #00000000000D0 * (-0.1D1 * n_A(i - 1) + n_A(i + 1)) * n_Lamx(i) + 0
     #.2500000000000000D0 * (-0.1D1 * n_A(i - 1) + n_A(i + 1)) / n_A(i)
     #* octfmp(i) + 0.5000000000000000D0 * n_A(i) * (-0.1D1 * n_Lamx(i -
     # 1) + n_Lamx(i + 1)) - 0.2D1 * (n_phi(i - 1) - 0.1D1 * n_phi(i + 1
     #)) * octfmp(i)) / ctfmp(i) + (0.2D1 * n_phi(i - 1) - 0.2D1 * n_phi
     #(i + 1) - 0.1D1 / n_B(i) * (-0.1D1 * n_B(i - 1) + n_B(i + 1)) - 0.
     #5000000000000000D0 / n_B(i) * (-0.1D1 * n_A(i - 1) + n_A(i + 1)) +
     # 0.1D1 / n_B(i) ** 2 * n_A(i) * (-0.1D1 * n_B(i - 1) + n_B(i + 1))
     #) / ctfmp(i) / ctfm(i)) / hx + (0.1875000000000000D0 / n_A(i) ** 2
     # * (-0.1D1 * n_A(i - 1) + n_A(i + 1)) ** 2 - 0.5000000000000000D0
     #/ n_A(i) * (-0.1D1 * n_A(i - 1) + n_A(i + 1)) * (n_phi(i - 1) - 0.
     #1D1 * n_phi(i + 1)) - 0.1250000000000000D0 / n_B(i) ** 2 * (-0.1D1
     # * n_B(i - 1) + n_B(i + 1)) ** 2 + 0.5000000000000000D0 / n_B(i) *
     # (-0.1D1 * n_B(i - 1) + n_B(i + 1)) * (n_phi(i - 1) - 0.1D1 * n_ph
     #i(i + 1)) - 0.4D1 * n_phi(i - 1) + 0.8D1 * n_phi(i) - 0.4D1 * n_ph
     #i(i + 1) - 0.5000000000000000D0 / n_A(i) * (n_A(i - 1) - 0.2D1 * n
     #_A(i) + n_A(i + 1))) / ctfmp(i) ** 2 / hx ** 2
      res(i)=qb
      end do
      if (phys_bdy(2) .eq. 1) then
      do i=Nx, Nx, 1
      qb = myzero * x(i)
      res(i)=qb
      end do
      endif
      END


c  bpsplinb -- dmc 30 May 1996
c
c  set up coefficients for bicubic spline with following BC's:
c  * LHS and RHS BC under user control (see comments)
c  * derivatives periodic in second coordinate (use pspline.for)
c
      subroutine r8bpsplinb(x,inx,th,inth,fspl,inf3,
     >                    ibcxmin,bcxmin,ibcxmax,bcxmax,
     >                    wk,nwk,ilinx,ilinth,ier)
c
      IMPLICIT NONE
      INTEGER, PARAMETER :: R8=SELECTED_REAL_KIND(12,100)
      integer inx,inth,inf3,nwk
      REAL*8 x(inx),th(inth),fspl(4,4,inf3,inth),wk(nwk)
      integer ibcxmin,ibcxmax
      REAL*8 bcxmin(inth),bcxmax(inth)
c
c  input:
c    x(1...inx) -- abscissae, first dimension of data
c   th(1...inth) -- abscissae, second (periodic) dimension of data
c   fspl(1,1,1..inx,1..inth) -- function values
c   inf3 -- fspl dimensioning, inf3.ge.inx required.
c
c  boundary conditions input:
c   ibcxmin -- indicator for boundary condition at x(1):
c    bcxmin(...) -- boundary condition data
c     =0 -- use "not a knot", bcxmin(...) ignored
c     =1 -- match slope, specified at x(1),th(ith) by bcxmin(ith)
c     =2 -- match 2nd derivative, specified at x(1),th(ith) by bcxmin(ith)
c     =3 -- boundary condition is slope=0 (df/dx=0) at x(1), all th(j)
c     =4 -- boundary condition is d2f/dx2=0 at x(1), all th(j)
c     =5 -- match 1st derivative to 1st divided difference
c     =6 -- match 2nd derivative to 2nd divided difference
c     =7 -- match 3rd derivative to 3rd divided difference
c           (for more detailed definition of BCs 5-7, see the
c           comments of subroutine mkspline)
c   NOTE bcxmin(...) referenced ONLY if ibcxmin=1 or ibcxmin=2
c
c   ibcxmax -- indicator for boundary condition at x(nx):
c    bcxmax(...) -- boundary condition data
c     (interpolation as with ibcxmin, bcxmin)
c
c  output:
c   fspl(*,*,1..inx,1..inth) -- bicubic spline coeffs (4x4)
c   ...fspl(1,1,*,*) is not replaced.
c
      integer ilinx,ilinth,ier
c
c   ilinx -- =1 on output if x(inx) pts are nearly evenly spaced (tol=1e-3)
c   ilinth-- =1 on output if th(inth) evenly spaced (tol=1e-3)
c
c   ier -- completion code, 0 for normal
c
c  workspace:
c   wk -- must be at least 5*max(inx,inth) large
c  nwk -- size of workspace
c
c---------------------------------
c  compute bicubic spline of 2d function, given values at the grid
c  grid crossing points, f(1,1,i,j)=f(x(i),th(j)).
c
c  on evaluation:  for point x btw x(i) and x(i+1), dx=x-x(i)
c                       and th btw th(j) and th(j+1), dt=th-th(j),
c
c      spline =
c        f(1,1,i,j) + dx*f(2,1,i,j) + dx**2*f(3,1,i,j) + dx**3*f(4,1,i,j)
c   +dt*(f(1,2,i,j) + dx*f(2,2,i,j) + dx**2*f(3,2,i,j) + dx**3*f(4,2,i,j))
c   +d2*(f(1,3,i,j) + dx*f(2,3,i,j) + dx**2*f(3,3,i,j) + dx**3*f(4,3,i,j))
c   +d3*(f(1,4,i,j) + dx*f(2,4,i,j) + dx**2*f(3,4,i,j) + dx**3*f(4,4,i,j))
c
c      where d2=dt**2 and d3=dt**3.
c
c---------------------------------
c
      integer ierx,ierth
      REAL*8 zdum(1)
c
c---------------------------------
c
      ier=0
      if(nwk.lt.5*max(inx,inth)) then
         write(6,'('' ?bpsplinb:  workspace too small.'')')
         ier=1
      endif
      if(inx.lt.2) then
         write(6,'('' ?bpsplinb:  at least 2 x points required.'')')
         ier=1
      endif
      if(inth.lt.2) then
         write(6,'('' ?bpsplinb:  need at least 2 theta points.'')')
         ier=1
      endif
c
      call ibc_ck(ibcxmin,'bcspline','xmin',0,7,ier)
      call ibc_ck(ibcxmax,'bcspline','xmax',0,7,ier)
c
c  check ilinx & x vector
c
      call r8splinck(x,inx,ilinx,1.0E-3_r8,ierx)
      if(ierx.ne.0) ier=2
c
      if(ier.eq.2) then
         write(6,'('' ?bpsplinb:  x axis not strict ascending'')')
      endif
c
c  check ilinth & th vector
c
      call r8splinck(th,inth,ilinth,1.0E-3_r8,ierth)
      if(ierth.ne.0) ier=3
c
      if(ier.eq.3) then
         write(6,'('' ?bpsplinb:  th axis not strict ascending'')')
      endif
c
      if(ier.ne.0) return
c
c------------------------------------
      zdum=0.0_r8
c
      call r8bcspline(x,inx,th,inth,fspl,inf3,
     >   ibcxmin,bcxmin,ibcxmax,bcxmax,
     >   -1,zdum,-1,zdum,
     >   wk,nwk,ilinx,ilinth,ier)
c
      end


      SUBROUTINE STEP
C
C THIS ROUTINE CONTROLS THE TIMESTEPPING PROCESS, AND CALLS ROUTINE
C COMP1 TO COMPUTE A SINGLE TIMESTEP. IT CHANGES THE INDEXES LNM1,
C LN AND LNP1 AS POINTERS INTO A CIRCULAR BUFFER OF TIMELEVELS OF
C THE PROGNOSTIC VARIABLES DIVERGENCE, VORTICITY AND GEOPOTENTIAL.
C INITIALIZATION IS BY TWO SEMI-IMPLICIT TIMESTEPS, NORMAL TIME-
C STEPPING BY A CENTERED LEAPFROG-SCHEME. AN ASSELIN FILTER CAN BE
C USED TO PREVENT MODAL SPLITTING.
C
C CALLED BY: STSWM
C CALLS: COMP1
C
C REVISIONS:
C 7-10-92 CHANGE TO CCM CODING CONVENTIONS (R. JAKOB)
C
C---- Model Parameters -------------------------------------------------
C
      INCLUDE 'params.i'
C
C---- Common Blocks ----------------------------------------------------
C
C Constants
      INCLUDE 'consts.i'
C Prognostic variables
      INCLUDE 'tdvars.i'
C
C------ Local Variables ------------------------------------------------
C
C    LATITUDE/LONGITUDE INDEX
C
      INTEGER I,J
C
C----- Executable Statements -------------------------------------------
C
C     MAIN LOOP OF TIME INTEGRATION
C     CENTERED (LEAPFROG) PROCEDURE
C
      IF (NSTEP .EQ. 1) THEN
C
C        PERFORM INITIAL TIME STEPS BY COPYING PROGNOSTIC
C        VARIABLES INTO PREVIOUS TIMELEVEL FOR SMOOTH START
C
C        FIRST FORWARD TIMESTEP (DT/2.0)
C
         DO 70 J=1,NLAT
            DO 60 I=1,NLON
               ZETA(I,J,LVLS) = ZETA(I,J,1)
               DIV (I,J,LVLS) = DIV (I,J,1)
               PHI (I,J,LVLS) = PHI (I,J,1)
   60       CONTINUE
   70    CONTINUE
C
         LNM1   = LVLS
         LN     = 1
         LNP1   = 2
         CALL COMP1(DT/2.0)
C
C        SECOND CENTERED TIMESTEP (DT)
C
C        DO 90 J=1,NLAT
C           DO 80 I=1,NLON
C              ZETA(I,J,LVLS) = ZETA(I,J,1)
C              DIV (I,J,LVLS) = DIV (I,J,1)
C              PHI (I,J,LVLS) = PHI (I,J,1)
C  80       CONTINUE
C  90    CONTINUE

         LNM1 = LVLS
         LN = 2
         LNP1 = 1
         CALL COMP1(DT)
C
C        SET BUFFER POINTERS FOR FIRST LEAPFROG TIMESTEP (2.0*DT)
C
         LNM1 = LVLS
         LN   = 1
         LNP1 = 2
C
         RETURN
C
      ELSE
C
C     ALL OTHER INSTANCES OF CENTERED DIFFERENCING
C
         CALL COMP1(2.0*DT)
C
C        ASSELIN FILTER (FILTERS COMPUTATIONAL MODE BY
C        DAMPING HIGH-FREQUENCY MODES)
C
         IF (AFC .NE. 0.0) THEN
            DO 100 J=1,NLAT
               DO 95 I=1,NLON
                  ZETA(I,J,LN) = ZETA(I,J,LN) + AFC*(ZETA(I,J,LNM1)
     $                          - 2.0*ZETA(I,J,LN) + ZETA(I,J,LNP1))
                  DIV(I,J,LN)  = DIV(I,J,LN) + AFC*(DIV(I,J,LNM1)
     $                          - 2.0*DIV(I,J,LN) + DIV(I,J,LNP1))
                  PHI(I,J,LN)  = PHI(I,J,LN) + AFC*(PHI(I,J,LNM1)
     $                          - 2.0*PHI(I,J,LN) + PHI(I,J,LNP1))
   95          CONTINUE
  100       CONTINUE
         ENDIF
C
C        ADVANCE CIRCULAR BUFFER POINTERS
C
         LNM1 = LN
         LN   = LNP1
         LNP1 = MOD(LN+1,LVLS)
         IF (LNP1 .EQ. 0) LNP1 = LVLS
C
         RETURN
C
      ENDIF
C
      END


SUBROUTINE fill(nx,ny,i1,i2,j1,j2,za,tx,critx,cor,mxs,rmask,error,nvalue)

! ** This routine originates from the USA.
! ** It was delivered (by 3.5" diskette)
! ** to DNMI in nov. 1990.

! ***** Re-edited at DNMI in January '91 by H.Engedahl.
! ***** Again re-edited at DNMI in March '92 by H.Engedahl to fit the
! ***** ECOM3D output configuration.
! ***** DNMI/FoU 25.08.1993 A.Foss : Recoded for speedup.

!// Solves Laplace's equation with Neumann boundary conditions
!// (dA/dn = 0) in RECTANGULAR coordinates by an iterative method to
!// fill in reasonable values at gridpoints containing values like
!// "undef".

!// NOTE: It is impossibel to make a really parallel (MPP) version of this
!//       routine. One MPP node should work on a complete field.
!//       Parallelization is done on a 'higher' level.  (A.Foss '98)

!-----------------------------------------------------------------------
!//     nx   = Array x dimension
!//     ny   = Array y dimension
!//   i1,i2  = Subarea in x direction to be filled
!//   j1,j2  = Subarea in y direction to be filled
!//     za   = Array to be filled (REAL)
!//     tx   = All values in array A GREATER than Tx are filled (REAL)
!//    critx = Criteria for relaxation, DEL**2 = CRIT
!//            (Usually 4 orders of magnitude DOWN from data in A)
!//     cor  = Coef. of overrelaxation, between +1.2 and +2.0
!//     mxs  = Max. allowed no. of scans in relaxation procedure.
!//   rmask  = Work array
!//   error  = Array containing the errors in the relaxation procedure.
!//   nvalue = No. of gridpoints with value (possibly 0) ... output
!-----------------------------------------------------------------------

IMPLICIT NONE

INTEGER, INTENT(IN)  :: nx, ny, i1, i2, j1, j2, mxs
REAL,    INTENT(IN)  :: tx,critx,cor
INTEGER, INTENT(OUT) :: nvalue

REAL                 :: za(nx,ny)
REAL                 :: rmask(nx,ny)
REAL                 :: error(nx,ny)
INTEGER              :: n, j, i, i1p1, i2m1, j1p1, j2m1, nnn, nbad
REAL                 :: suma, asuma, crit, crtest

n = 0
suma = 0.

DO j=j1,j2
DO i=i1,i2
  IF (za(i,j) < tx) THEN
    suma = suma + za(i,j)
    n = n+1
  END IF
END DO
END DO

nvalue = n

IF (n < 1) THEN
  PRINT *
  PRINT *,"******************  WARNING  *******************"
  PRINT *,"SUBROUTINE FILL : NO USEFUL DATA IN THE FIELD"
  PRINT *,"ALL DATA IN THE INTERIOR (SUBAREA) WERE > ",tx
  PRINT *,"******************  WARNING  *******************"
  PRINT *
  RETURN
END IF

suma = suma/n
asuma = 0.

DO j=j1,j2
DO i=i1,i2
  IF (za(i,j) < tx) THEN
    asuma = asuma + ABS(za(i,j)-suma)
    rmask(i,j) = 0.
  ELSE
    za(i,j) = suma
    rmask(i,j) = 1.
  END IF
END DO
END DO

asuma = asuma/n

crit = critx*asuma  ! af:  Using asuma not suma

!// The value of suma ( i.e. the MEAN value of the array A ) is filled in
!// the array A at all points with an initial value >= t.
!// za(i,j) = suma may be regarded as the "first guess" in the iterative
!// method.

i1p1 = i1 + 1
i2m1 = i2 - 1
j1p1 = j1 + 1
j2m1 = j2 - 1

DO j=j1p1,j2m1
DO i=i1p1,i2m1
  rmask(i,j) = cor*rmask(i,j)
END DO
END DO

DO nnn=1,mxs

  DO j=j1p1,j2m1
    DO i=i1p1,i2m1
      error(i,j) = (za(i+1,j)+za(i,j+1)+za(i,j-1))*0.25-za(i,j)
    END DO
    DO i=i1p1,i2m1
      error(i,j) = error(i,j) + za(i-1,j)*0.25
      za(i,j) = za(i,j) + error(i,j)*rmask(i,j)
    END DO
  END DO

  !// Test convergence now and then (slow test loop)
  IF (nnn < mxs-5 .AND. MOD(nnn,10) == 0) THEN
    crtest = crit*cor
    nbad = 0
    j = j1
    DO WHILE (nbad == 0 .AND. j < j2m1)
      j=j+1
      DO i=i1p1,i2m1
        IF (ABS(error(i,j))*rmask(i,j) > crtest) nbad = 1
      END DO
    END DO
    IF (nbad == 0) GOTO 300
  END IF

  DO j=j1p1,j2m1
    za(i1,j) = za(i1,j) + (za(i1p1,j)-za(i1,j))*rmask(i1,j)
    za(i2,j) = za(i2,j) + (za(i2m1,j)-za(i2,j))*rmask(i2,j)
  END DO
  DO i=i1,i2
     za(i,j1) = za(i,j1) + (za(i,j1p1)-za(i,j1))*rmask(i,j1)
     za(i,j2) = za(i,j2) + (za(i,j2m1)-za(i,j2))*rmask(i,j2)
  END DO

ENDDO

300 CONTINUE

RETURN

END


program main
    use FEMDomainClass
    implicit none

    type(FEMDomain_) :: domain1, domain2
    integer(int32)::field_id

    call domain1%create(meshtype="Cube")
    call domain2%create(meshtype="Cube")
    call domain1%rotate(x=1.00d0)
    call domain1%move(y=0.50d0)
    call domain1%move(z=0.50d0)
    call domain1%move(x=0.5d0)

    call domain1%addlayer(name="waterhead",attribute="node",datastyle="scalar")
    call domain2%addlayer(name="waterhead",attribute="node",datastyle="scalar")

    field_id=domain1%getLayerID(name="waterhead")
    domain1%physicalfield(field_id)%scalar(:)=2.0d0

    field_id=domain2%getLayerID(name="waterhead")
    domain2%physicalfield(field_id)%scalar(:)=1.0d0

    call domain1%projection("=>",domain=domain2,PhysicalField="waterhead",debug=.true.)
    call domain1%msh(name="domain1")
    call domain1%gmsh(name="domain1")
    call domain1%PhysicalField(1)%msh(name="domain1_waterhead")
    call domain2%msh(name="domain2")
    call domain2%PhysicalField(1)%msh(name="domain2_waterhead")
    print *, maxval(domain2%physicalfield(field_id)%scalar(:)),minval(domain2%physicalfield(field_id)%scalar(:))

end program main


Program DeriD
  implicit none
  REAL::S, P
  REAL, allocatable, dimension(:, :)::A
  REAL, allocatable, dimension(:)::B
  INTEGER::i, j, x, N
  open(unit=14, file="Datos.dat", status="old")
  N=0
  do i=1, 10000
     read(14, *, end=15) S
     N=N+1
  end do
15 close(14)
  write(*, *) "El archivo contiene", N, " pares de datos."
  write(*, *)
  allocate(A(1:N, 1:2), B(1:N))
  open(42, file="Datos.dat", status="old")
  do i=1, N
     read(42, *) A(i, :)
     write(*, *) A(i, :)
  end do

  do i=1, N
     B(i)=(A(i, 2)-A(i+1, 2))/(A(i, 1)-A(i+1, 1))
  end do
  write(*, *)
  do i=1, N
     write(*, *) A(i, :), B(i)
  end do
  deallocate(A, B)
end Program DeriD


! { dg-do run }
!
! Test for the fix for PR34640. In this case, final testing of the
! patch revealed that in some cases the actual descriptor was not
! being passed to procedure dummy pointers.
!
! Contributed by Thomas Koenig  <tkoenig@netcologne.de>
!
module x
  use iso_c_binding
  implicit none
  type foo
     complex :: c
     integer :: i
  end type foo
contains
  subroutine printit(c, a)
    complex, pointer, dimension(:) :: c
    integer :: i
    integer(kind=c_intptr_t) :: a
    a = transfer(c_loc(c(2)),a)
  end subroutine printit
end module x

program main
  use x
  use iso_c_binding
  implicit none
  type(foo), dimension(5), target :: a
  integer :: i
  complex, dimension(:), pointer :: pc
  integer(kind=c_intptr_t) :: s1, s2, s3
  a%i = 0
  do i=1,5
     a(i)%c = cmplx(i**2,i)
  end do
  pc => a%c
  call printit(pc, s3)

  s1 = transfer(c_loc(a(2)%c),s1)
  if (s1 /= s3) STOP 1

  s2 = transfer(c_loc(pc(2)),s2)
  if (s2 /= s3) STOP 2

end program main


module pmmf_isotropic_dilation
#include <messenger.h>
    use mod_kinds,      only: rk,ik
    use mod_constants,  only: ZERO, HALF, ONE, TWO, THREE, FIVE, EIGHT, PI
    use type_prescribed_mesh_motion_function,  only: prescribed_mesh_motion_function_t
    implicit none
    private

    !>  isotropic_dilation mesh motion.
    !!
    !!  @author Eric Wolf
    !!  @date   3/15/2017
    !!
    !!
    !-------------------------------------------------------------------------------
    type, extends(prescribed_mesh_motion_function_t), public :: isotropic_dilation_pmmf
        private

    contains

        procedure   :: init
        procedure   :: compute_pos
        procedure   :: compute_vel

    end type isotropic_dilation_pmmf
    !********************************************************************************

contains

    !>  X = (isotropic_dilation_factor*t+1)*x
    !!  v = isotropic_dilation_factor*x
    !!
    !!  @author Eric Wolf
    !!  @date   3/15/2017
    !!
    !-------------------------------------------------------------------------
    subroutine init(self)
        class(isotropic_dilation_pmmf),  intent(inout)  :: self

        !
        ! Set function name
        !
        call self%set_name("isotropic_dilation")

        !
        ! Set function options to default settings
        !
        call self%add_option('isotropic_dilation_factor',ZERO)

    end subroutine init
    !*************************************************************************

    !>
    !!
    !!  @author Eric Wolf
    !!  @date   3/15/2017
    !!
    !!
    !-----------------------------------------------------------------------------------------
    function compute_pos(self,time,node) result(val)
        class(isotropic_dilation_pmmf),     intent(inout)   :: self
        real(rk),                   intent(in)      :: time
        real(rk),                   intent(in)      :: node(3)

        integer(ik)                                 :: ivar
        real(rk)                                    :: val(3)

        real(rk)                                    :: factor

        factor = self%get_option_value('isotropic_dilation_factor')

        val = (factor*time+ONE)*node

    end function compute_pos
    !**********************************************************************************

    !>
    !!
    !!  @author Eric Wolf
    !!  @date   3/15/2017
    !!
    !!
    !-----------------------------------------------------------------------------------------
    function compute_vel(self,time,node) result(val)
        class(isotropic_dilation_pmmf),     intent(inout)   :: self
        real(rk),                   intent(in)      :: time
        real(rk),                   intent(in)      :: node(3)

        integer(ik)                                 :: ivar
        real(rk)                                    :: val(3)
        real(rk)                                    :: factor

        factor = self%get_option_value('isotropic_dilation_factor')

        val = factor*node

    end function compute_vel
    !**********************************************************************************

end module pmmf_isotropic_dilation


! { dg-do compile }
! { dg-options "-std=f95" }
!
! PR fortran/33178
!
! Initialization expressions:
! Fortran 95: Elemental functions w/ integer/character arguments
! Fortran 2003: restriction lifted
!
integer :: a = sign(1,1)   ! Ok F95
real    :: b = sign(1.,1.) ! { dg-error "Fortran 2003: Elemental function as initialization expression" }
end


! enum_set.f90 --
!     Yet another experiment with sets of integers:
!     use F2003 features to combine functions to
!     filter out unwanted integers and keep those
!     that have particular properties.
!
!     Note:
!     It is assumed in the combine function that
!     the properties lead to an ascending function
!
module enumeration_procedure

    type enum_func
        type(enum_func), pointer                 :: f    => null()
        type(enum_func), pointer                 :: g    => null()
        procedure(enumeration), pointer, pass(t) :: enum => null()
    end type enum_func

    abstract interface
        integer function enumeration( t, idx )
            import :: enum_func
            type(enum_func), intent(in) :: t
            integer, intent(in)         :: idx
        end function enumeration
    end interface

end module enumeration_procedure

module enumerate_sets
    use enumeration_procedure

    implicit none

!    procedure(enumeration) :: combine

contains

! func, combination --
!     Convenience functions to initialise the derived types
!
! Note:
!     Also used to get (hopefully) around a compiler limitation
!
function func( f )
    procedure(enumeration)         :: f
    type(enum_func)                :: func

    func%enum => f

end function func

function combination( f, g, c )
    type(enum_func), target        :: f
    type(enum_func), target        :: g
    procedure(enumeration)         :: c
    type(enum_func)                :: combination

    combination%f    => f
    combination%g    => g
    combination%enum => c

end function combination

! combine --
!     Combine the two integer sets in such a way that
!     only the integers that belong to both are returned

integer function combine( t, idx )
    type(enum_func), intent(in) :: t
    integer, intent(in)         :: idx

    integer                     :: count
    integer                     :: i
    integer                     :: j
    integer                     :: fi
    integer                     :: gj

    count = 0
    i     = 0
    j     = 0

    fi = t%f%enum(i)
    gj = t%g%enum(j)

    do while ( count < idx )

        if ( fi == gj ) then
            count = count + 1
            i     = i     + 1
        else if ( fi < gj ) then
            i  = i + 1
        else
            j  = j + 1
        endif
        fi = t%f%enum(i)
        gj = t%g%enum(j)

     enddo

     combine = i - 1

end function combine

end module

! pell_equation
!     Module to implement the Pell equation "y**2 = 2 * x**2 + 1"
!
module pell_equation
    use enumerate_sets

!    procedure(enumeration) :: y_square
!    procedure(enumeration) :: x_pell

contains

integer function y_square( t, idx )
    type(enum_func), intent(in) :: t    ! Not used
    integer, intent(in)         :: idx

    y_square = idx ** 2

end function y_square

integer function x_pell( t, idx )
    type(enum_func), intent(in) :: t    ! Not used
    integer, intent(in)         :: idx

    x_pell = 2 * idx ** 2 + 1

end function x_pell

end module pell_equation

program enum_set
    use pell_equation

    implicit none

    type(enum_func), target :: xright
    type(enum_func), target :: yleft
    type(enum_func) :: xpell
    type(enum_func) :: ypell

!   procedure(enumeration) :: combine
!   procedure(enumeration) :: y_square
!   procedure(enumeration) :: x_pell

    integer :: i
    integer :: x
    integer :: y

    !
    ! We want both x and y, so we have to compute them twice
    ! (We could of course adapt the interface to return
    ! the two integers ...)
    !
!    xright%enum => x_pell
!    yleft%enum  => y_square
!
!    xpell%f    => xright
!    xpell%g    => yleft
!    xpell%enum => combine
!
!    ypell%f    => yleft
!    ypell%g    => xright
!    ypell%enum => combine

     xright = func( x_pell )
     yleft  = func( y_square )

     xpell  = combination( xright, yleft, combine )
     ypell  = combination( yleft, xright, combine )

    do i = 1,5
        x = xpell%enum(i)
        y = ypell%enum(i)
       write(*,*) '>>', i, x, y
    enddo

    do i = 1,100000
        x = 2 * i ** 2 + 1
        y = int( sqrt(float(x)) ) ** 2
        if ( x == y ) then
            write(*,*) 'Direct:', i, int(sqrt(float(y)))
        endif
    enddo
end program enum_set