      SUBROUTINE AB09HY( N, M, P, A, LDA, B, LDB, C, LDC, D, LDD,
     $                   SCALEC, SCALEO, S, LDS, R, LDR, IWORK,
     $                   DWORK, LDWORK, BWORK, INFO )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To compute the Cholesky factors Su and Ru of the controllability
C     Grammian P = Su*Su' and observability Grammian Q = Ru'*Ru,
C     respectively, satisfying
C
C            A*P  + P*A' +  scalec^2*B*B'   = 0,       (1)
C
C            A'*Q + Q*A  +  scaleo^2*Cw'*Cw = 0,       (2)
C
C     where
C            Cw = Hw - Bw'*X,
C            Hw = inv(Dw)*C,
C            Bw = (B*D' + P*C')*inv(Dw'),
C            D*D' = Dw*Dw' (Dw upper triangular),
C
C     and, with Aw = A - Bw*Hw, X is the stabilizing solution of the
C     Riccati equation
C
C            Aw'*X + X*Aw + Hw'*Hw + X*Bw*Bw'*X = 0.   (3)
C
C     The P-by-M matrix D must have full row rank. Matrix A must be
C     stable and in a real Schur form.
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of state-space representation, i.e.,
C             the order of the matrix A.  N >= 0.
C
C     M       (input) INTEGER
C             The number of system inputs.  M >= 0.
C
C     P       (input) INTEGER
C             The number of system outputs.  M >= 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             stable state dynamics matrix A in a real Schur canonical
C             form.
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, corresponding to the Schur matrix A.
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, corresponding to the Schur
C             matrix A.
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
C             contain the full row rank input/output matrix D.
C
C     LDD     INTEGER
C             The leading dimension of array D.  LDD >= MAX(1,P).
C
C     SCALEC  (output) DOUBLE PRECISION
C             Scaling factor for the controllability Grammian in (1).
C
C     SCALEO  (output) DOUBLE PRECISION
C             Scaling factor for the observability Grammian in (2).
C
C     S       (output) DOUBLE PRECISION array, dimension (LDS,N)
C             The leading N-by-N upper triangular part of this array
C             contains the Cholesky factor Su of the cotrollability
C             Grammian P = Su*Su' satisfying (1).
C
C     LDS     INTEGER
C             The leading dimension of array S.  LDS >= MAX(1,N).
C
C     R       (output) DOUBLE PRECISION array, dimension (LDR,N)
C             The leading N-by-N upper triangular part of this array
C             contains the Cholesky factor Ru of the observability
C             Grammian Q = Ru'*Ru satisfying (2).
C
C     LDR     INTEGER
C             The leading dimension of array R.  LDR >= MAX(1,N).
C
C     Workspace
C
C     IWORK   INTEGER array, dimension 2*N
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, DWORK(1) returns the optimal value
C             of LDWORK and DWORK(2) contains RCOND, the reciprocal
C             condition number of the U11 matrix from the expression
C             used to compute X = U21*inv(U11). A small value RCOND
C             indicates possible ill-conditioning of the Riccati
C             equation (3).
C
C     LDWORK  INTEGER
C             The length of the array DWORK.
C             LDWORK >= MAX( 2, N*(MAX(N,M,P)+5),
C                            2*N*P+MAX(P*(M+2),10*N*(N+1) ) ).
C             For optimum performance LDWORK should be larger.
C
C     BWORK   LOGICAL array, dimension 2*N
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value;
C             = 1:  the state matrix A is not stable or is not in a
C                   real Schur form;
C             = 2:  the reduction of Hamiltonian matrix to real Schur
C                   form failed;
C             = 3:  the reordering of the real Schur form of the
C                   Hamiltonian matrix failed;
C             = 4:  the Hamiltonian matrix has less than N stable
C                   eigenvalues;
C             = 5:  the coefficient matrix U11 in the linear system
C                   X*U11 = U21, used to determine X, is singular to
C                   working precision;
C             = 6:  the feedthrough matrix D has not a full row rank P.
C
C     CONTRIBUTORS
C
C     A. Varga, German Aerospace Center, Oberpfaffenhofen, May 2000.
C     D. Sima, University of Bucharest, May 2000.
C     V. Sima, Research Institute for Informatics, Bucharest, May 2000.
C     Based on the RASP routines SRGRO and SRGRO1, by A. Varga, 1992.
C
C     REVISIONS
C
C     V. Sima, Research Institute for Informatics, Bucharest, Oct. 2001.
C
C     KEYWORDS
C
C     Minimal realization, model reduction, multivariable system,
C     state-space model, state-space representation,
C     stochastic balancing.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION ZERO, ONE, TWO
      PARAMETER        ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 )
C     .. Scalar Arguments ..
      INTEGER          INFO, LDA, LDB, LDC, LDD, LDR, LDS, LDWORK, M, N,
     $                 P
      DOUBLE PRECISION SCALEC, SCALEO
C     .. Array Arguments ..
      INTEGER          IWORK(*)
      DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*),
     $                 DWORK(*), R(LDR,*), S(LDS,*)
      LOGICAL          BWORK(*)
C     .. Local Scalars ..
      INTEGER          I, IERR, KBW, KCW, KD, KDW, KG, KQ, KS, KTAU, KU,
     $                 KW, KWI, KWR, LW, N2, WRKOPT
      DOUBLE PRECISION RCOND, RTOL
C     .. External Functions ..
      DOUBLE PRECISION DLANGE, DLAMCH
      EXTERNAL         DLANGE, DLAMCH
C     .. External Subroutines ..
      EXTERNAL         DGEMM, DGERQF, DLACPY, DORGRQ, DSYRK, DTRMM,
     $                 DTRSM, SB02MD, SB03OU, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC        ABS, DBLE, INT, MAX, MIN
C     .. Executable Statements ..
C
      INFO = 0
      LW   = MAX( 2, N*( MAX( N, M, P ) + 5 ),
     $            2*N*P + MAX( P*(M + 2), 10*N*(N + 1) ) )
C
      IF( N.LT.0 ) THEN
         INFO = -1
      ELSE IF( M.LT.0 ) THEN
         INFO = -2
      ELSE IF( P.LT.0 .OR. P.GT.M ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -5
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -7
      ELSE IF( LDC.LT.MAX( 1, P ) ) THEN
         INFO = -9
      ELSE IF( LDD.LT.MAX( 1, P ) ) THEN
         INFO = -11
      ELSE IF( LDS.LT.MAX( 1, N ) ) THEN
         INFO = -15
      ELSE IF( LDR.LT.MAX( 1, N ) ) THEN
         INFO = -17
      ELSE IF( LDWORK.LT.LW ) THEN
         INFO = -20
      END IF
C
      IF( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'AB09HY', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      SCALEC = ONE
      SCALEO = ONE
      IF( MIN( N, M, P ).EQ.0 ) THEN
         DWORK(1) = TWO
         DWORK(2) = ONE
         RETURN
      END IF
C
C     Solve for Su the Lyapunov equation
C                                      2
C     A*(Su*Su') + (Su*Su')*A' + scalec *B*B' = 0 .
C
C     Workspace:  need   N*(MAX(N,M) + 5);
C                 prefer larger.
C
      KU   = 1
      KTAU = KU + N*MAX( N, M )
      KW   = KTAU + N
C
      CALL DLACPY( 'Full', N, M, B, LDB, DWORK(KU), N )
      CALL SB03OU( .FALSE., .TRUE., N, M, A, LDA, DWORK(KU), N,
     $             DWORK(KTAU), S, LDS, SCALEC, DWORK(KW),
     $             LDWORK - KW + 1, IERR )
      IF( IERR.NE.0 ) THEN
         INFO = 1
         RETURN
      ENDIF
      WRKOPT = INT( DWORK(KW) ) + KW - 1
C
C     Allocate workspace for Bw' (P*N), Cw (P*N), Q2 (P*M),
C     where Q2 = inv(Dw)*D.
C     Workspace:  need   2*N*P + P*M.
C
      KBW  = 1
      KCW  = KBW  + P*N
      KD   = KCW  + P*N
      KDW  = KD   + P*(M - P)
      KTAU = KD   + P*M
      KW   = KTAU + P
C
C     Compute an upper-triangular Dw such that D*D' = Dw*Dw', using
C     the RQ-decomposition of D: D = [0 Dw]*( Q1 ).
C                                           ( Q2 )
C     Additional workspace:  need 2*P; prefer P + P*NB.
C
      CALL DLACPY( 'F', P, M, D, LDD, DWORK(KD), P )
      CALL DGERQF( P, M, DWORK(KD), P, DWORK(KTAU), DWORK(KW),
     $             LDWORK-KW+1, IERR )
      WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 )
C
C     Check the full row rank of D.
C
      RTOL = DBLE( M ) * DLAMCH( 'E' ) *
     $       DLANGE( '1', P, M, D, LDD, DWORK )
      DO 10 I = KDW, KDW+P*P-1, P+1
         IF( ABS( DWORK(I) ).LE.RTOL ) THEN
            INFO = 6
            RETURN
         END IF
   10 CONTINUE
C                    -1
C     Compute Hw = Dw  *C.
C
      CALL DLACPY( 'F', P, N, C, LDC, DWORK(KCW), P )
      CALL DTRSM( 'Left', 'Upper', 'No-transpose', 'Non-unit', P, N,
     $            ONE, DWORK(KDW), P, DWORK(KCW), P )
C
C     Compute Bw' = inv(Dw)*(D*B' + C*Su*Su').
C
C     Compute first Hw*Su*Su' in Bw'.
C
      CALL DLACPY( 'F', P, N, DWORK(KCW), P, DWORK(KBW), P )
      CALL DTRMM( 'Right', 'Upper', 'No-transpose', 'Non-unit', P, N,
     $            ONE, S, LDS, DWORK(KBW), P )
      CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-unit', P, N,
     $            ONE, S, LDS, DWORK(KBW), P )
C
C     Compute Q2 = inv(Dw)*D, as the last P lines of the orthogonal
C     matrix ( Q1 ) from the RQ decomposition of D.
C            ( Q2 )
C     Additional workspace:  need P; prefer P*NB.
C
      CALL DORGRQ( P, M, P, DWORK(KD), P, DWORK(KTAU), DWORK(KW),
     $             LDWORK-KW+1, IERR )
      WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 )
C
C     Compute Bw' <- Bw' + Q2*B'.
C
      CALL DGEMM( 'No-transpose', 'Transpose', P, N, M, ONE,
     $            DWORK(KD), P, B, LDB, ONE, DWORK(KBW), P )
C
C     Compute Aw = A - Bw*Hw in R.
C
      CALL DLACPY( 'F', N, N, A, LDA, R, LDR )
      CALL DGEMM( 'Transpose', 'No-transpose', N, N, P, -ONE,
     $            DWORK(KBW), P, DWORK(KCW), P, ONE, R, LDR )
C
C     Allocate storage to solve the Riccati equation (3) for
C     G(N*N), Q(N*N), WR(2N), WI(2N), S(2N*2N), U(2N*2N).
C
      N2  = N + N
      KG  = KD
      KQ  = KG  + N*N
      KWR = KQ  + N*N
      KWI = KWR + N2
      KS  = KWI + N2
      KU  = KS  + N2*N2
      KW  = KU  + N2*N2
C
C     Compute G = -Bw*Bw'.
C
      CALL DSYRK( 'Upper', 'Transpose', N, P, -ONE, DWORK(KBW), P, ZERO,
     $            DWORK(KG), N )
C
C     Compute Q = Hw'*Hw.
C
      CALL DSYRK( 'Upper', 'Transpose', N, P, ONE, DWORK(KCW), P, ZERO,
     $            DWORK(KQ), N )
C
C     Solve
C
C        Aw'*X + X*Aw + Q - X*G*X = 0,
C
C     with Q =  Hw'*Hw  and  G = -Bw*Bw'.
C     Additional workspace: need   6*N;
C                           prefer larger.
C
      CALL SB02MD( 'Continuous', 'None', 'Upper', 'General', 'Stable',
     $             N, R, LDR, DWORK(KG), N, DWORK(KQ), N, RCOND,
     $             DWORK(KWR), DWORK(KWI), DWORK(KS), N2,
     $             DWORK(KU), N2, IWORK, DWORK(KW), LDWORK-KW+1,
     $             BWORK, INFO )
      IF( INFO.NE.0 )
     $   RETURN
      WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 )
C
C     Compute Cw = Hw - Bw'*X.
C
      CALL DGEMM ( 'No-transpose', 'No-transpose', P, N, N, -ONE,
     $              DWORK(KBW), P, DWORK(KQ), N, ONE, DWORK(KCW), P )
C
C     Solve for Ru the Lyapunov equation
C                                      2
C     A'*(Ru'*Ru) + (Ru'*Ru)*A + scaleo  * Cw'*Cw = 0 .
C
C     Workspace:  need   N*(MAX(N,P) + 5);
C                 prefer larger.
C
      KTAU = KCW  + N*MAX( N, P )
      KW   = KTAU + N
C
      CALL SB03OU( .FALSE., .FALSE., N, P, A, LDA, DWORK(KCW), P,
     $             DWORK(KTAU), R, LDR, SCALEO, DWORK(KW),
     $             LDWORK - KW + 1, IERR )
      WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 )
C
C     Save optimal workspace and RCOND.
C
      DWORK(1) = WRKOPT
      DWORK(2) = RCOND
C
      RETURN
C *** Last line of AB09HY ***
      END


subroutine bc_second_stage(k,k_t)

use definiciones
implicit none

integer(4)::iter,i,j,k,k_t
real(8)::a_top,b_top,c_top,a_bot,b_bot,c_bot
real(8)::a_left,b_left,c_left,a_right,b_right,c_right

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!Calculo de velocidades y aplicacion de condiciones de
!contorno
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

!----------------------------------------
!Condiciones de contorno para la vorticidad
!---------------------------------------

do j=1,nz_i+1
i=1
!omega_aprox_1(i,j)=(psi_new(i+2,j)*(x(i+1)-x(i))**3-psi_new(i+1,j)*(x(i+2)-x(i))**3)/&
!(0.5d0*((x(i+2)-x(i))**3*(x(i+1)-x(i))**2-(x(i+1)-x(i))**3*(x(i+2)-x(i))**2))
!omega_aprox_1(i,j)=-2.0d0*psi_new(i+1,j)*(h_x**2)/delta_x**2
omega_aprox_1(i,j)=(psi_new(i+2,j)-8.0d0*psi_new(i+1,j))/(2.0d0*delta_x**2)
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
i=nx_i+1
!omega_aprox_1(i,j)=(psi_new(i-2,j)*(x(i)-x(i-1))**3-psi_new(i-1,j)*(x(i)-x(i-2))**3)/&
!(0.5d0*((x(i)-x(i-2))**3*(x(i)-x(i-1))**2-(x(i)-x(i-1))**3*(x(i)-x(i-2))**2))
!omega_aprox_1(i,j)=-2.0d0*psi_new(i-1,j)*(h_x**2)/delta_x**2
omega_aprox_1(i,j)=(psi_new(i-2,j)-8.0d0*psi_new(i-1,j))/(2.0d0*delta_x**2)
end do

do i=1,nx_i+1
j=1
!omega_aprox_1(i,j)=(psi_new(i,j+2)*(z(j+1)-z(j))**3-psi_new(i,j+1)*(z(j+2)-z(j))**3)/&
!(0.5d0*((z(j+2)-z(j))**3*(z(j+1)-z(j))**2-(z(j+1)-z(j))**3*(z(j+2)-z(j))**2))
!omega_aprox_1(i,j)=-2.0d0*psi_new(i,j+1)*(h_z**2)/delta_z**2
omega_aprox_1(i,j)=(psi_new(i,j+2)-8.0d0*psi_new(i,j+1))/(2.0d0*delta_z**2)
j=nz_i+1
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!omega_aprox_1(i,j)=(psi_new(i,j-2)*(z(j)-z(j-1))**3-psi_new(i,j-1)*(z(j)-z(j-2))**3)/&
!(0.5d0*((z(j)-z(j-2))**3*(z(j)-z(j-1))**2-(z(j)-z(j-1))**3*(z(j)-z(j-2))**2))
!omega_aprox_1(i,j)=-2.0d0*psi_new(i,j-1)*(h_z**2)/delta_z**2
omega_aprox_1(i,j)=(psi_new(i,j-2)-8.0d0*psi_new(i,j-1)-6.0d0*delta_z)/(2.0d0*delta_z**2)
end do

do j=1,nz_i
i=1
u_aprox_1(i,j)=0.0d0
w_aprox_1(i,j)=0.0d0
i=nx_i+1
u_aprox_1(i,j)=0.0d0
w_aprox_1(i,j)=0.0d0
end do
do i=1,nx_i+1
j=1
u_aprox_1(i,j)=0.0d0
w_aprox_1(i,j)=0.0d0
j=nz_i+1
u_aprox_1(i,j)=1.0d0
w_aprox_1(i,j)=0.0d0
end do

!--------------------------------------
!Velocidad en el interior del dominio
!--------------------------------------

do i=2,nx_i
do j=2,nz_i
u_aprox_1(i,j)=(psi_new(i,j+1)-psi_new(i,j-1))/(2.0d0*delta_z)
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
w_aprox_1(i,j)=-(psi_new(i+1,j)-psi_new(i-1,j))/(2.0d0*delta_x)
end do
end do

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!Fin condiciones de contorno
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

end subroutine bc_second_stage


	SUBROUTINE POWFCN(SZALPH,N,SR,SP0,M,XPSI,SPOWER,ERR)
	IMPLICIT NONE
C
C-Description-----------------------------------------------------------
C
C  Function:
C	Calculate the true power associated with PSI,P0,R,N.
C  Arguments:
C   i	SZALPH	(REAL)
C	Z value associated with the (1-ALPHA/2)*100 percentile of the
C	standardized normal distribution, where ALPHA is the type I
C	error.
C   i	N	(Integer)
C	Number of case patients
C   i	SR	(REAL)
C	Correlation coefficient
C   i	SP0	(REAL)
C	Probability of exposure in control group
C   i	M	(Integer)
C	Number of matched controls per case patient
C   i	XPSI	(REAL)
C	Odds ratio
C   o	SPOWER	(REAL)
C   o	ERR	(Integer)
C	Error flag  0=No problems
C		    1=No matched table exists with P0, PSI, and R
C		    2=Expected number of M-tuples with an exposed case
C			and at least 1 unexposed control is <=5
C  Notes:
C   .	This routine was written by Dale Plummer.
C   .	Designed by Dr. William Dupont.
C   .   The LaTeX notation given in the comments is from:
C       Dupont, Biometrics 1988;44:1157-68.
C
C-Declarations----------------------------------------------------------
C
C
C  Arguments
C
	REAL SZALPH,SR,SP0,XPSI,SPOWER
	INTEGER N,M,ERR
C
C  Functions
C
	DOUBLE PRECISION PHI
C
C  Locals
C
	DOUBLE PRECISION ZALPH,R,P0,PSI,POWER
	DOUBLE PRECISION E1Y,S1
	DOUBLE PRECISION SPSI,ZL,ZU
	DOUBLE PRECISION RM,RN,EPSIY
	DOUBLE PRECISION MEAN,VAR,PSI_VALUE
	DOUBLE PRECISION V1,VPSI
C
C-Code------------------------------------------------------------------
C
C    Assume a successful run.
C
	ERR=0
C
C    Copy arguments M and N to floating point local storage.
C
	RM=DBLE(M)
	RN=DBLE(N)
C
C    Copy single precision arguments to double precision internal
C    representation.
C
C    ALPHA = \alpha
C    BETA = \beta
C    P0 = p_0
C    PSI = \psi
C    ZALPHA = z_{\alpha/2}
C    ZBETA = z_{\beta}
C
	ZALPH=DBLE(SZALPH)
	R=DBLE(SR)
	P0=DBLE(SP0)
	PSI=DBLE(XPSI)
C (C) -----------------------------------------------------
	PSI_VALUE=1
	CALL MEANANDVAR(P0,R,M,RM,PSI_VALUE,MEAN,VAR)
C
C    E1Y = e_1 in equation (6)
C    V1 = v_1 in equation (7)
C    S1 = s_1 in equation (6)
C
	V1 = VAR
	E1Y = MEAN * RN
	S1 = SQRT(RN*VAR)

	PSI_VALUE=PSI
	CALL MEANANDVAR(P0,R,M,RM,PSI_VALUE,MEAN,VAR)
C
C    EPSIY = E_{\psi} in equation (6)
C    VPSI = v_{\psi} in equation (7)
C    SPSI = s_{\psi} in qeuation (6)
C
	EPSIY = MEAN * RN
	VPSI = VAR
	SPSI=SQRT(RN*VAR)
C (C) -----------------------------------------------------
C
C    If E1Y <= 5 then normal approximation is suspect.  Abort power
C    calculations.
C
C   N.B. this check is removed 6/11/2014 (wdp)
C
C	IF (E1Y.LE.5.) THEN
C	    ERR=2
C	    SPOWER=0.
C	    RETURN
C	END IF

	ZL=(E1Y-EPSIY-ZALPH*S1)/SPSI
	ZU=(E1Y-EPSIY+ZALPH*S1)/SPSI
C
C    The following is equation (6) in Dupont (Biometrics, 1988; 44:1157-1168)
C
	POWER=PHI(REAL(ZL))+1.-PHI(REAL(ZU))
	SPOWER=REAL(POWER)
C
C    Finished.
C
	RETURN
	END


      subroutine elastic_stiffness(i, d_i)
!***********************************************************************
! Copyright 2011 Los Alamos National Security, LLC  All rights reserved
! Unless otherwise indicated,  this information has been authored by an
! employee or employees of the Los Alamos National Security, LLC (LANS),
! operator of the  Los  Alamos National  Laboratory  under Contract  No.
! DE-AC52-06NA25396  with  the U. S. Department  of  Energy.  The  U. S.
! Government   has   rights  to  use,  reproduce,  and  distribute  this
! information.  The  public may copy  and  use this  information without
! charge, provided that this  Notice and any statement of authorship are
! reproduced on all copies.  Neither  the  Government nor LANS makes any
! warranty,   express   or   implied,   or   assumes  any  liability  or
! responsibility for the use of this information.
!***********************************************************************
!
! Returns the 6x6 material stiffness tensor (D matrix) for a linear,
! isotropic, elastic material when the 'plastic' submacro is used
! in the stress computations.
!
! Author : Sai Rapaka
!

      use comflow
      use davidi
      use comji
      use comfi
      use comgi
      use comei
      use comdi
      use comci
      use combi
      use comdti
      use comai
      use comsi

      real*8, dimension(1:6, 1:6)  :: d_i
      integer i, itmp, iModel
      real*8 E0, nu0, lambda0, G0

      if(iPlastic.eq.0) then
        write(iout,*) '***ERROR : elastic stiffness routine called
     &   without plastic flag being set '
      endif

      itmp = modelNumber(i)
      iModel = plasticModel(itmp)

      d_i = 0.0d0
      if(iModel.eq.1) then
        E0 = elastic_mod(i)
        nu0 = poisson(i)
        lambda0 = E0*nu0/((1 + nu0)*(1 - 2.0d0*nu0))
        G0 = E0/(2.0d0*(1 + nu0))

        d_i(1:3, 1:3) = lambda0
        d_i(1,1) = d_i(1,1) + 2.0d0*G0
        d_i(2,2) = d_i(2,2) + 2.0d0*G0
        d_i(3,3) = d_i(3,3) + 2.0d0*G0
        d_i(4,4) = G0
        d_i(5,5) = G0
        d_i(6,6) = G0
      else
        write(iout,*) '***ERROR: elastic stiffness routine called for
     &   a node not set to be elastic'
      endif

      end subroutine elastic_stiffness


      SUBROUTINE CURVIT (INDEP,NI,DEP,ND,IFILE,Z,IZ,LZ,MCLOSE,TOLER,
     1                   MCSID,XSCALE,YSCALE)
C
C     PERFORMS LOCAL INTERPOLATION
C
C     INDEP  = X,Y COORDINATES OF INDEPENDENT ELEMENT CENTERS (2 X NI)
C     DEP    = X,Y COORDINATES OF DEPENDENT GRID POINTS  (2 X ND)
C     IFILE  = FILE TO WRITE SPECIAL FORM ROWS OF G-MATRIX
C     Z      = REAL AREA OF CORE, LENGTH = LZ.
C     IZ     = EQUIVALENT INTEGER AREA OF CORE, LENGTH = LZ.
C     MCLOSE = NUMBER OF CLOSEST INDEPENDENT POINTS TO USE
C     TOLER  = PERCENT OF DISTANCE FROM A DEPENDENT POINT TO
C              INDEPENDENT POINT NUMBER -NCLOSE- POINTS FURTHER OUT ARE
C              ALLOWED TO BE SUCH AS TO BE INCLUDED IN A LOCAL
C              INTERPOLATION.
C
      INTEGER         SYSBUF, IZ(1), SUBR(2), ITEMP(2), RD, RDREW, WRT,
     1                WRTREW, CLSREW, CLS, EOR
      REAL            Z(1), DEP(2,1), INDEP(2,1)
      CHARACTER       UFM*23, UWM*25
      COMMON /XMSSG / UFM, UWM
      COMMON /SYSTEM/ SYSBUF, IOUTPT
      COMMON /NAMES / RD, RDREW, WRT, WRTREW, CLSREW, CLS
      DATA    SUBR  / 4HCURV ,4HIT  /, EOR, NOEOR / 1, 0 /
C
      NCLOSE = MIN0(MCLOSE,NI)
      IF (NCLOSE .LE. 2) NCLOSE = NI
C
C     COMPUTE TOLERANCE MULTIPLIER WITH RESPECT TO SQUARES.
C     TOLERANCE IS IN PERCENT OF DISTANCE TO POINT NUMBER -NCLOSE- IN
C     FINAL LIST
C
      TOL = (1.0 + TOLER/100.0)**2
C
C     THUS IF DISTANCE FROM THE DEPENDENT POINT TO INDEPENDENT POINT
C     NUMBER -NCLOSE- = LSQ, ADDITIONAL INDEPENDENT POINTS WILL BE
C     INCLUDED IF THE SQUARE OF THEIR DISTANCE TO THE DEPENDENT POINT
C     IS .LE. TOL TIMES LSQ.
C
C
C     ALLOCATE BUFFER FOR -IFILE- AND OPEN -IFILE-.
C
      IBUF = LZ - SYSBUF
      JZ   = IBUF - 1
      ICRQ = -JZ
      IF (JZ .LE. 0) GO TO 900
      CALL GOPEN (IFILE,IZ(IBUF),1)
C
C     EACH ROW OF G-MATRIX WILL BE WRITTEN AS A LOGICAL RECORD
C     WITH PAIRS OF
C                 1- INDEPENDENT POINT INDEX
C                 2- G VALUE
C
C
C     SHORT CUT WILL BE TAKEN IF ALL INDEPENDENT POINTS ARE TO BE USED
C     FOR INTERPOLATION AT EACH DEPENDENT POINT.
C
      IF (NCLOSE .EQ. NI) GO TO 550
C
C     MASTER LOOP ON DEPENDENT POINTS. EACH DEPENDENT POINT RESULTS IN
C     A VARIABLE LENGTH ROW OF G-MATRIX DEPENDING ON HOW MANY
C     INDEPENDENT POINTS ARE SELECTED FOR USE. (AT LEAST 3 MUST BE USED)
C
   80 DO 500 I = 1,ND
C
C     LIST OF DISTANCE SQUARES OF ALL INDEPENDENT POINTS TO
C     CURRENT DEPENDENT POINT IS FORMED.
C
C     SELECTION OF THE -NCLOSE- SMALLEST VALUES IS THEN MADE.
C
C     THEN ANY OTHER INDEPENDENT POINTS WITHIN TOLERANCE RANGE OF
C     POINT NUMBER -NCLOSE- IN LIST ARE ADDED.
C
      FMAX = 0.0
      X    = DEP(1,I)
      Y    = DEP(2,I)
      ICRQ = NI - JZ
      IF (NI .GT. JZ) GO TO 900
      DO 100 J = 1,NI
      Z(J) = (XSCALE*(INDEP(1,J)-X))**2 + (YSCALE*(INDEP(2,J)-Y))**2
      IF (Z(J) .LE. FMAX) GO TO 100
      FMAX = Z(J)
  100 CONTINUE
      FMAX = 2.0*FMAX + 1.0
C
C     ALLOCATE FOR LIST OF INDEXES TO THE MINIMUMS.
C
      ILIST = NI + 1
      NLIST = NI
C
C     FIND -NCLOSE- SMALLEST VALUES.
C
      DO 170 J = 1,NCLOSE
      FMIN = FMAX
C
      DO 160 K = 1,NI
      IF (FMIN-Z(K)) 160,160,150
  150 FMIN = Z(K)
      IDX  = K
  160 CONTINUE
C
C     ADD INDEX TO THIS MINIMUM TO THE LIST
C
      ICRQ = NLIST + 1 - JZ
      IF (ICRQ .GT. 0) GO TO 900
      IZ(NLIST+1) = IDX
      NLIST = NLIST + 1
C
C     RESET THIS VALUE SO IT CAN NOT BE USED AGAIN
C
      Z(IDX) = FMAX
  170 CONTINUE
C
C     ADD ANY ADDITIONAL INDEPENDENT POINTS WITHIN TOLERANCE RANGE OF
C     LAST ONE SELECTED ABOVE.
C
      FMAX = TOL*FMIN
      DO 190 J = 1,NI
      IF (Z(J) .GT. FMAX) GO TO 190
      ICRQ = NLIST + 1 - JZ
      IF (ICRQ .GT. 0) GO TO 900
      IZ(NLIST+1) = J
      NLIST = NLIST + 1
  190 CONTINUE
C
C     LIST IS COMPLETE THUS MOVE IT TO THE BEGINNING OF THE CORE BLOCK.
C
      J = 0
      DO 210 K = ILIST,NLIST
      J = J + 1
      IZ(J) = IZ(K)
  210 CONTINUE
      ILIST = 1
      NLIST = J
      IPTS  = J
C
C     HERE AND IZ(ILIST) TO IZ(NLIST) CONTAINS LIST OF
C     POSITION INDEXES OF INDEPENDENT POINT COORDINATES TO BE USED.
C
C     NOW SET UP LIST OF XY-CCORDINATES OF THESE INDEPENDENT POINTS
C     FOR THE SSPLIN CALL.
C
      IXY  = NLIST + 1
      NXY  = NLIST + 2*IPTS
      ICRQ = NXY - JZ
      IF (NXY .GT. JZ) GO TO 900
      JXY  = NLIST
      DO 270 J = ILIST,NLIST
      K    = IZ(J)
      Z(JXY+1) = INDEP(1,K)
      Z(JXY+2) = INDEP(2,K)
      JXY  = JXY + 2
  270 CONTINUE
C
C     NOW READY FOR SSPLIN ROUTINE CALL.
C
      CALL SSPLIN (IPTS,Z(IXY),1,DEP(1,I),0,0,0,1,0,Z(JXY+1),JZ-JXY,
     1             ISING)
      IF (ISING .NE. 2) GO TO 300
C
C     ILL-CONDITION FOR THIS DEPENDENT POINT - NO SOLUTION POSSIBLE.
C
      CALL PAGE2 (4)
      WRITE  (IOUTPT,250) UWM,I,MCSID
  250 FORMAT (A25,' 2252. (CURVIT-1) LOCAL INTERPOLATION USING INDE',
     1       'PENDENT VALUES WITHIN RANGE OF THE', /5X,I7,'-TH SORTED ',
     2       'ORDER GRID ID INVOLVED WITH RESPECT TO MATERIAL COORDIN',
     3       'ATE SYSTEM ID',I9, /5X,'CAN NOT BE COMPLETED.  ILL-CONDI',
     4       'TION MAY HAVE RESULTED FROM ALIGNMENT OF INDEPENDENT ',
     5       'VALUE COORDINATES.', /5X,
     6       'OUTPUT FOR THE GRID ID IN QUESTION WILL NOT APPEAR.')
      IPTS = 0
      GO TO 340
C
C     REPLACE INDEPENDENT POINT XY PAIRS WITH SPECIAL FORM DEPENDENT
C     POINT G-MATRIX OUTPUT ROW.
C
  300 K1 = ILIST
      K2 = JXY + 1
      DO 320 J = IXY,NXY,2
      IZ(J ) = IZ(K1)
      Z(J+1) = Z(K2)
      K1 = K1 + 1
      K2 = K2 + 1
  320 CONTINUE
C
  340 CALL WRITE (IFILE,IZ(IXY),2*IPTS,EOR)
C
C  GO PROCESS NEXT DEPENDENT POINT.
C
  500 CONTINUE
      GO TO 800
C
C     CHECK FOR SUFFICIENT CORE FOR SHORT CUT.
C
  550 N = NI + 3
      N = N**2 + 3*N + NI*ND + N*ND
      IF (N .GT. JZ) GO TO 80
C
C     CALL SSPLIN AND GET G-MATRIX STORED BY ROWS.
C
      CALL SSPLIN (NI,INDEP(1,1),ND,DEP(1,1),0,0,0,1,0,Z(1),JZ,ISING)
      IF (ISING .NE. 2) GO TO 650
      N = 0
      WRITE (IOUTPT,250) UWM,N,MCSID
C
C     OUTPUT NULL ROW FOR EACH DEPENDENT POINT.
C
      DO 600 I = 1,ND
      CALL WRITE (IFILE,0,0,EOR)
  600 CONTINUE
      GO TO 800
C
C     OUTPUT ROWS OF G-MATRIX WITH INDEXES.
C
  650 K = 0
      DO 680 I = 1,ND
      DO 670 J = 1,NI
      K = K + 1
      ITEMP(1) = J
      ITEMP(2) = IZ(K)
      CALL WRITE (IFILE,ITEMP(1),2,NOEOR)
  670 CONTINUE
      CALL WRITE (IFILE,0,0,EOR)
  680 CONTINUE
C
C     ALL G-MATRIX ROWS COMPLETE. (ROWS SINGULAR ARE EMPTY LOGICAL
C     RECORDS IN -IFILE- )
C
  800 CALL CLOSE (IFILE,CLSREW)
      RETURN
C
  900 CALL MESAGE (-8,ICRQ,SUBR)
      RETURN
      END


      subroutine snlm (ltot, mtot, xnlm)
      implicit none
c     Set nlm, legendre normalization factors, xnlm in common /nlm/
c     Calculates legendre norm factors
c     xnlm= sqrt ((2l+1)(l-m)!/(l+m)!)

cc      include 'dim.h'
      integer ltot, mtot, il, im, mmaxp1, l, m, i
      double precision xnlm(ltot+1, mtot+1)

c     flg(i) = i! * afac**i, set in factst
      double precision flg(0:210), afac, cnlm

      call factst (afac, flg)

c     initialize xnlm explicitly
      do 20  il = 1, ltot+1
         mmaxp1 = min(mtot+1, il)
         do 5  im = mmaxp1, mtot+1
            xnlm(il, im) = 0.d0
 5       continue
         do 10  im = 1, mmaxp1
            l = il-1
            m = im-1
            cnlm = (2*l+1) * flg(l-m) / flg(l+m)
            xnlm(il,im) = sqrt(cnlm) * afac**m
 10      continue
 20   continue
      return
      end
      subroutine factst (afac, flg)
      implicit none

c     FACTorial SeT, flg(i) = i! * afac**i
      double precision afac, flg(0:210)
      integer i
c     afac = 1/64 works with double precision on a VAX
      afac = 1/64.d0

      flg(0) = 1
      flg(1) = afac
      do 10  i = 2, 210
         flg(i) = flg(i-1) * i * afac
 10   continue
      return
      end


#include "eiscor.h"
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! ZTTEEV (Zomplex Two by Two Eigenvalues and EigenVectors)
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! This routine computes the Schur decomposition of a general
! 2x2 COMPLEX(kind=8) matrix.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! INPUT VARIABLES:
!
!  H              COMPLEX(8) array of dimension (2,2)
!                   Contains the 2x2 matrix.
!
! OUTPUT VARIABLES:
!
!  E              COMPLEX(8) array of dimension (2)
!                   On exit contains the eigenvalues of H.
!
!  Z              COMPLEX(8) array of dimension (2,2)
!                   On exit the columns of Z contain the Schur vectors
!                   of H sorted to match the array E.
!
! INFO            INTEGER
!                   INFO = 0 implies successful computation
!                   INFO = -1 implies H is invalid
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine ZTTEEV(H,E,Z,INFO)

  implicit none

  ! input variables
  integer, intent(inout) :: INFO
  complex(8), intent(in) :: H(2,2)
  complex(8), intent(inout) :: E(2), Z(2,2)

  ! compute variables
  integer :: ii, id
  real(8) :: temp, nrm1, nrm2
  complex(8) :: WORK(4)
  complex(8) :: trace, detm, disc

  ! initialize info
  INFO = 0

  ! check input in debug mode
  if (DEBUG) then

    ! check H
    call ZARACH2(2,2,H,INFO)
    if (INFO.NE.0) then
      call UARERR(__FILE__,__LINE__,"H is invalid",INFO,-1)
      return
    end if

  end if

  ! compute intermediate values
  trace = H(1,1) + H(2,2)
  detm = H(1,1)*H(2,2) - H(2,1)*H(1,2)
  disc = sqrt((H(1,1)-H(2,2))**2 + cmplx(4d0,0d0,kind=8)*H(1,2)*H(2,1))

  ! compute E
  if(abs(trace+disc) > abs(trace-disc))then
     if(abs(trace+disc) == 0)then
        E(1) = cmplx(0d0,0d0,kind=8)
        E(2) = cmplx(0d0,0d0,kind=8)
     else
        E(1) = (trace+disc)/cmplx(2d0,0d0,kind=8)
        E(2) = detm/E(1)
     end if
  else
     if(abs(trace-disc) == 0)then
        E(1) = cmplx(0d0,0d0,kind=8)
        E(2) = cmplx(0d0,0d0,kind=8)
     else
        E(1) = (trace-disc)/cmplx(2d0,0d0,kind=8)
        E(2) = detm/E(1)
     end if
  end if

  ! compute diagonal with least cancellation
  WORK(1) = H(1,1) - E(1)
  WORK(2) = H(2,2) - E(1)
  WORK(3) = H(1,1) - E(2)
  WORK(4) = H(2,2) - E(2)

  id = 1
  temp = abs(WORK(1))
  do ii=1,3
    if(abs(WORK(ii+1)) > temp) then
        id = ii+1
        temp = abs(WORK(id))
    end if
  end do

  ! initialize first column of Z
  ! swap eigenvalues if necessary
  if (temp .EQ. 0d0) then
    Z(1,1) = cmplx(1d0,0d0,kind=8)
    Z(2,1) = cmplx(0d0,0d0,kind=8)
  else if (id .EQ. 1) then
    Z(1,1) = H(1,2)
    Z(2,1) = -WORK(1)
  else if (id .EQ. 2) then
    Z(1,1) = -WORK(2)
    Z(2,1) = H(2,1)
  else if (id .EQ. 3) then
    Z(1,1) = H(1,2)
    Z(2,1) = -WORK(3)
    trace = E(1)
    E(1) = E(2)
    E(2) = trace
  else
    Z(1,1) = -WORK(4)
    Z(2,1) = H(2,1)
    trace = E(1)
    E(1) = E(2)
    E(2) = trace
  end if

  ! normalize first column of Z
  nrm1 = abs(Z(1,1))
  nrm2 = abs(Z(2,1))
  if (nrm1 > nrm2) then
    nrm2 = nrm2/nrm1
    temp = nrm1*sqrt(1d0 + nrm2*nrm2)
  else
    nrm1 = nrm1/nrm2
    temp = nrm2*sqrt(1d0 + nrm1*nrm1)
  end if
  Z(1,1) = Z(1,1)/temp
  Z(2,1) = Z(2,1)/temp

  ! store second column of Z
  Z(1,2) = -conjg(Z(2,1))
  Z(2,2) = conjg(Z(1,1))

end subroutine ZTTEEV


C
C**************************  VOLBAS ************************************
C
C  calculate the volume of each element, the volume assigned to each
C  node, and the basis function coefficients.
C  Basis function coefficients are divided by 6.
C
C***********************************************************************
C
      SUBROUTINE VOLBAS(N,NT,TETRA,IP4,AI,BI,CI,DI,
     1                  VOLNOD,VOLU,VOLUR,IVOL,X,Y,Z)
C
      IMPLICIT  NONE
      INTEGER   J,IEL,IV1,IV2,IV3,IV4
      INTEGER   N,NT
      INTEGER   TETRA(5,*),IP4(4,4),IVOL(*)
      REAL*8    VOL,VOL4,R4
      REAL*8    AI(4,*),BI(4,*),CI(4,*),DI(4,*)
      REAL*8    VOLNOD(*),VOLU(*),VOLUR(*),X(*),Y(*),Z(*)
      INCLUDE  'IOUNITS.H'
C
      R4=0.25D0
      CALL INIT0R(N,VOLNOD)
      DO IEL=1,NT
         CALL VOLUMS(IP4,TETRA(1,IEL),X,Y,Z,VOL)
         CALL BASIS6(IP4,TETRA(1,IEL),X,Y,Z,AI(1,IEL),
     1               BI(1,IEL),CI(1,IEL),DI(1,IEL))
         IF (VOL .EQ. 0.0D0) THEN
            WRITE(IOUT2,1000) IEL,(TETRA(J,IEL),J=1,4)
            CALL CLOSIO
            STOP
         END IF
         VOL4=DABS(VOL)*R4
         IV1=TETRA(1,IEL)
         IV2=TETRA(2,IEL)
         IV3=TETRA(3,IEL)
         IV4=TETRA(4,IEL)
         VOLNOD(IV1)=VOLNOD(IV1) + VOL4
         VOLNOD(IV2)=VOLNOD(IV2) + VOL4
         VOLNOD(IV3)=VOLNOD(IV3) + VOL4
         VOLNOD(IV4)=VOLNOD(IV4) + VOL4
         IVOL(IEL)=1
         IF (VOL .LT. 0.0D0) THEN
            IVOL(IEL)=-1
            VOL=-VOL
         END IF
         VOLU(IEL)=VOL
         VOLUR(IEL)=1.0D0/VOL
      END DO
C
      RETURN
 1000 FORMAT(/,' ERROR IN SUBROUTINE VOLBAS: ZERO AREA CALCULATED',/,
     1         '    AT ELEMENT ',I6,'  NODE NUMBERS:',4I6)
      END


	DOUBLE PRECISION FUNCTION ERFC(X)
	IMPLICIT NONE
	DOUBLE PRECISION X,R2,R3,ERF,PI
	DATA PI/3.1415 9265 3589 7932D0/
	IF (X.GE.0.AND.X.LT.0.46875) THEN
	    ERFC=1.-ERF(X)
	ELSE IF (X.GE.0.46875.AND.X.LT.4.0) THEN
	    ERFC=EXP(-X**2)*R2(X)
	ELSE IF (X.GE.4.0) THEN
C
C    Check for argument to EXP that causes underflow.
C
	    IF (X.GT.9.3) THEN
		    ERFC=0.0
	    ELSE
		    ERFC=(EXP(-X**2)/X)*(1.D0/DSQRT(PI)+X**(-2)*R3(X**(-2)))
	    END IF
	ELSE
	    STOP
	END IF
	RETURN
	END


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
program genfield

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  implicit none
  character(len=5) :: output,lineshape
  integer :: Nsteps
  real(kind=8) :: dt,time,field
  real(kind=8) :: t1on,t1off,tfin,tpulse1,mu1,freq1,E01

! parameter of the Lorentzian
  real(kind=8) :: nu0,nu,numin,numax,weight,dnu,area,E
  real(kind=8) :: fwhm,const,const2,norm

! constants
  real(kind=8),parameter :: pi = 3.141592653589793d0
  real(kind=8),parameter :: fs2au = 41.341373337d0
  real(kind=8),parameter :: light = 2.99792458d10
  real(kind=8),parameter :: zero = 0d0
  real(kind=8),parameter :: conv= 2.756923555732303547d-4

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! read input

  open(11,file='pulse.param',status='old')
  read(11,*) output
  read(11,*) lineshape
  read(11,*) t1on,t1off,tfin
  read(11,*) Nsteps
  read(11,*) mu1
  read(11,*) freq1
  read(11,*) E01
  read(11,*) dnu
  close(11)

! set pulse parameters
  tpulse1 = t1off-t1on           ! pulse duration
  if(E01 < 0.) then
     E01 = 2d0*pi/(tpulse1*fs2au*abs(mu1))
     write(*,*) 'Field fluence ::',real(E01/conv)**2
  else
     write(*,*) 'Field fluence ::',real(E01)
     E01 = conv*sqrt(E01)
  endif
  write(*,*) 'Field amplitude ::',real(E01)
  dt = tfin/Nsteps
  nu0 = 2d0*pi*freq1*light*1d-15 ! conversion WN to frequency

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! field envelope for a sin2 pulse

  if(lineshape == "shape") then
     open(11,file='shape.dat',status='replace')
     if(output == "mctdh") then
        write(11,22)
     else
        write(11,*) Nsteps+1,dt*fs2au
     endif
     time = zero
     field = zero
! compute the intensity of a PI pulse
     do
        if(time >= t1on .and. time <= t1off) then
           field = E01*sin(pi*(time-t1on)/tpulse1)**2
        endif
        if(output == "mctdh") then
           write(11,'(f20.10,f20.12)') time*fs2au,field
        else
           write(11,'(e20.7)') field
        endif
        time = time + dt
        if(time > tfin) exit
     enddo
     close(11)

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! field for a delta pulse

  elseif(lineshape == "delta") then
     open(11,file='delta.dat',status='replace')
     if(output == "mctdh") then
        write(11,22)
     else
        write(11,*) Nsteps+1,dt*fs2au
     endif
     time = zero
     field = zero
! compute the intensity of a PI pulse
     do
        if(time >= t1on .and. time <= t1off) then
           field = E01*sin(pi*(time-t1on)/tpulse1)**2*cos(nu0*time)
        endif
        if(output == "mctdh") then
           write(11,'(f20.10,f20.12)') time*fs2au,field
        else
           write(11,'(e20.7)') field
        endif
        time = time + dt
        if(time > tfin) exit
     enddo
     close(11)

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! field for a chirped pulse

  elseif(lineshape == "chirp") then
     dnu = 2d0*pi*dnu*light*1d-15 ! conversion WN to frequency
     const = 9d0*pi/(mu1*E01*tpulse1)
     const2 = dnu/(1d0 + const)

     open(11,file='chirp.dat',status='replace')
     if(output == "mctdh") then
        write(11,22)
     else
        write(11,*) Nsteps+1,dt*fs2au
     endif
     time = zero
     field = zero
! compute the field
     do
        if(time <= t1on) then
           field = E01*sin(0.5d0*pi*time/t1on)**2*cos(nu0*time)
        elseif(time > t1on .and. time <= t1off) then
           nu = nu0 + const2*(((time-t1on)/tpulse1)**2+const*(time-t1on)/tpulse1)
           field = E01*cos(nu*time)
        else
           field = E01*cos(0.5d0*pi*(time-t1off)/(tfin-t1off))**2*cos(nu*time)
        endif
        if(output == "mctdh") then
           write(11,'(f20.10,f20.12)') time*fs2au,field
        else
           write(11,'(e20.7)') field
        endif
        time = time + dt
        if(time > tfin) exit
     enddo
     close(11)

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! field for a lorentzian-shaped line

  elseif(lineshape == "lortz") then

     open(11,file='lorentz.dat',status='replace')
     fwhm = 2d0*pi*(50d0)*light*1d-15 ! conversion WN to frequency
     numin = nu0 - 5d0*fwhm
     numax = nu0 + 5d0*fwhm
     dnu = (numax-numin)/1d3
     const = (fwhm*0.5d0)/pi
     const2 = (fwhm*0.5d0)**2

! compute the normalizing constant
     nu = numin
     norm = zero
     norme: do
        if(nu > numax) exit norme
        weight = const/((nu-nu0)**2+const2)
        norm = norm + weight*dnu
        nu = nu + dnu
     enddo norme

! set pulse area equal to the area of an equivalent delta pulse
     area = zero
     do
        if(time >= t1on .and. time <= t1off) then
           const = E01*sin(pi*(time-t1on)/tpulse1)**2*cos(nu0*time)
           area = area + abs(const)**2
        endif
        time = time + dt
        if(time > tfin) exit
     enddo
     area = area*dt

! compute the intensity of the desired pulse
     E = zero
     time = zero
     field = zero
     do
        if(time >= t1on .and. time <= t1off) then
           nu = numin
           field = zero
           aire: do
              if(nu > numax) exit aire
              weight = const/((nu-nu0)**2+const2)
              field = field + (sin(pi*(time-t1on)/tpulse1)**2*cos(nu*time)*weight/norm)*dnu
              nu = nu + dnu
           enddo aire
           E = E + abs(field)**2
        endif
        time = time + dt
        if(time > tfin) exit
     enddo
     E = sqrt(area/(E*dt))

! compute the field
     if(output == "mctdh") then
        write(11,22)
     else
        write(11,*) Nsteps+1,dt*fs2au
     endif
     time = zero
     do
        field = zero
        if(time >= t1on .and. time <= t1off) then
           nu = numin
           pulse: do
              if(nu > numax) exit pulse
              weight = const/((nu-nu0)**2+const2)
              field = field + E*sin(pi*(time-t1on)/tpulse1)**2*cos(nu*time)*weight*dnu/norm
              nu = nu + dnu
           enddo pulse
        endif
        if(output == "mctdh") then
           write(11,'(f20.10,f20.12)') time*fs2au,field
        else
           write(11,'(e20.7)') field
        endif
        time = time + dt
        if(time > tfin) exit
     enddo
     close(11)
  endif
 22 format('# Time [atomic units]   E(t) [e a_0]')

end program genfield
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!


      SUBROUTINE SB02MX( JOBG, JOBL, FACT, UPLO, TRANS, FLAG, DEF, N, M,
     $                   A, LDA, B, LDB, Q, LDQ, R, LDR, L, LDL, IPIV,
     $                   OUFACT, G, LDG, IWORK, DWORK, LDWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute the following matrices
C
C                -1
C         G = B*R  *B',
C
C         -               -1
C         A = A +/- op(B*R  *L'),
C
C         -            -1
C         Q = Q +/- L*R  *L',
C
C     where A, B, Q, R, L, and G are N-by-N, N-by-M, N-by-N, M-by-M,
C     N-by-M, and N-by-N matrices, respectively, with Q, R and G
C     symmetric matrices, and op(W) is one of
C
C         op(W) = W  or  op(W) = W'.
C
C     When R is well-conditioned with respect to inversion, standard
C     algorithms for solving linear-quadratic optimization problems will
C     then also solve optimization problems with coupling weighting
C     matrix L. Moreover, a gain in efficiency is possible using matrix
C     G in the deflating subspace algorithms (see SLICOT Library routine
C     SB02OD) or in the Newton's algorithms (see SLICOT Library routine
C     SG02CD).
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     JOBG    CHARACTER*1
C             Specifies whether or not the matrix G is to be computed,
C             as follows:
C             = 'G':  Compute G;
C             = 'N':  Do not compute G.
C
C     JOBL    CHARACTER*1
C             Specifies whether or not the matrix L is zero, as follows:
C             = 'Z':  L is zero;
C             = 'N':  L is nonzero.
C
C     FACT    CHARACTER*1
C             Specifies how the matrix R is given (factored or not), as
C             follows:
C             = 'N':  Array R contains the matrix R;
C             = 'C':  Array R contains the Cholesky factor of R;
C             = 'U':  Array R contains the factors of the symmetric
C                     indefinite UdU' or LdL' factorization of R.
C
C     UPLO    CHARACTER*1
C             Specifies which triangle of the matrices R, Q (if
C             JOBL = 'N'), and G (if JOBG = 'G') is stored, as follows:
C             = 'U':  Upper triangle is stored;
C             = 'L':  Lower triangle is stored.
C
C     TRANS   CHARACTER*1
C             Specifies the form of op(W) to be used in the matrix
C             multiplication, as follows:
C             = 'N':  op(W) = W;
C             = 'T':  op(W) = W';
C             = 'C':  op(W) = W'.
C
C     FLAG    CHARACTER*1
C             Specifies which sign is used, as follows:
C             = 'P':  The plus  sign is used;
C             = 'M':  The minus sign is used.
C
C     DEF     CHARACTER*1
C             If FACT = 'N', specifies whether or not it is assumed that
C             matrix R is positive definite, as follows:
C             = 'D':  Matrix R is assumed positive definite;
C             = 'I':  Matrix R is assumed indefinite.
C             Both values can be used to perform the computations,
C             irrespective to the R definiteness, but using the adequate
C             value will save some computational effort (see FURTHER
C             COMMENTS).
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrices A, Q, and G, and the number of
C             rows of the matrices B and L.  N >= 0.
C
C     M       (input) INTEGER
C             The order of the matrix R, and the number of columns of
C             the matrices B and L.  M >= 0.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, if JOBL = 'N', the leading N-by-N part of this
C             array must contain the matrix A.
C             On exit, if JOBL = 'N', and INFO = 0, the leading N-by-N
C                                                    -
C             part of this array contains the matrix A.
C             If JOBL = 'Z', this array is not referenced.
C
C     LDA     INTEGER
C             The leading dimension of array A.
C             LDA >= MAX(1,N) if JOBL = 'N';
C             LDA >= 1        if JOBL = 'Z'.
C
C     B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
C             On entry, the leading N-by-M part of this array must
C             contain the matrix B.
C             On exit, if OUFACT = 1, and INFO = 0, the leading N-by-M
C                                                             -1
C             part of this array contains the matrix B*chol(R)  .
C             On exit, B is unchanged if OUFACT <> 1 (hence also when
C             FACT = 'U').
C
C     LDB     INTEGER
C             The leading dimension of array B.  LDB >= MAX(1,N).
C
C     Q       (input/output) DOUBLE PRECISION array, dimension (LDQ,N)
C             On entry, if JOBL = 'N', the leading N-by-N upper
C             triangular part (if UPLO = 'U') or lower triangular part
C             (if UPLO = 'L') of this array must contain the upper
C             triangular part or lower triangular part, respectively, of
C             the symmetric matrix Q. The strictly lower triangular part
C             (if UPLO = 'U') or strictly upper triangular part (if
C             UPLO = 'L') is not referenced.
C             On exit, if JOBL = 'N' and INFO = 0, the leading N-by-N
C             upper triangular part (if UPLO = 'U') or lower triangular
C             part (if UPLO = 'L') of this array contains the upper
C             triangular part or lower triangular part, respectively, of
C                                  -            -1
C             the symmetric matrix Q = Q +/- L*R  *L'.
C             If JOBL = 'Z', this array is not referenced.
C
C     LDQ     INTEGER
C             The leading dimension of array Q.
C             LDQ >= MAX(1,N) if JOBL = 'N';
C             LDQ >= 1        if JOBL = 'Z'.
C
C     R       (input/output) DOUBLE PRECISION array, dimension (LDR,M)
C             On entry, if FACT = 'N', the leading M-by-M upper
C             triangular part (if UPLO = 'U') or lower triangular part
C             (if UPLO = 'L') of this array must contain the upper
C             triangular part or lower triangular part, respectively,
C             of the symmetric input weighting matrix R.
C             On entry, if FACT = 'C', the leading M-by-M upper
C             triangular part (if UPLO = 'U') or lower triangular part
C             (if UPLO = 'L') of this array must contain the Cholesky
C             factor of the positive definite input weighting matrix R
C             (as produced by LAPACK routine DPOTRF).
C             On entry, if FACT = 'U', the leading M-by-M upper
C             triangular part (if UPLO = 'U') or lower triangular part
C             (if UPLO = 'L') of this array must contain the factors of
C             the UdU' or LdL' factorization, respectively, of the
C             symmetric indefinite input weighting matrix R (as produced
C             by LAPACK routine DSYTRF).
C             If FACT = 'N' and DEF = 'D', the strictly lower triangular
C             part (if UPLO = 'U') or strictly upper triangular part
C             (if UPLO = 'L') of this array is used as workspace (filled
C             in by symmetry). If FACT = 'N' and DEF = 'I', the strictly
C             lower triangular part (if UPLO = 'U') or strictly upper
C             triangular part (if UPLO = 'L') is unchanged.
C             On exit, if OUFACT = 1, and INFO = 0 (or INFO = M+1),
C             the leading M-by-M upper triangular part (if UPLO = 'U')
C             or lower triangular part (if UPLO = 'L') of this array
C             contains the Cholesky factor of the given input weighting
C             matrix.
C             On exit, if OUFACT = 2, and INFO = 0 (or INFO = M+1),
C             the leading M-by-M upper triangular part (if UPLO = 'U')
C             or lower triangular part (if UPLO = 'L') of this array
C             contains the factors of the UdU' or LdL' factorization,
C             respectively, of the given input weighting matrix.
C             On exit R is unchanged if FACT = 'C' or 'U'.
C
C     LDR     INTEGER
C             The leading dimension of array R.  LDR >= MAX(1,M).
C
C     L       (input/output) DOUBLE PRECISION array, dimension (LDL,M)
C             On entry, if JOBL = 'N', the leading N-by-M part of this
C             array must contain the matrix L.
C             On exit, if JOBL = 'N', OUFACT = 1, and INFO = 0, the
C             leading N-by-M part of this array contains the matrix
C                      -1
C             L*chol(R)  .
C             On exit, L is unchanged if OUFACT <> 1 (hence also when
C             FACT = 'U').
C             L is not referenced if JOBL = 'Z'.
C
C     LDL     INTEGER
C             The leading dimension of array L.
C             LDL >= MAX(1,N) if JOBL = 'N';
C             LDL >= 1        if JOBL = 'Z'.
C
C     IPIV    (input/output) INTEGER array, dimension (M)
C             On entry, if FACT = 'U', this array must contain details
C             of the interchanges performed and the block structure of
C             the d factor in the UdU' or LdL' factorization of matrix R
C             (as produced by LAPACK routine DSYTRF).
C             On exit, if OUFACT = 2, this array contains details of
C             the interchanges performed and the block structure of the
C             d factor in the UdU' or LdL' factorization of matrix R,
C             as produced by LAPACK routine DSYTRF.
C             This array is not referenced if FACT = 'C'.
C
C     OUFACT  (output) INTEGER
C             Information about the factorization finally used.
C             OUFACT = 0:  no factorization of R has been used (M = 0);
C             OUFACT = 1:  Cholesky factorization of R has been used;
C             OUFACT = 2:  UdU' (if UPLO = 'U') or LdL' (if UPLO = 'L')
C                          factorization of R has been used.
C
C     G       (output) DOUBLE PRECISION array, dimension (LDG,N)
C             If JOBG = 'G', and INFO = 0, the leading N-by-N upper
C             triangular part (if UPLO = 'U') or lower triangular part
C             (if UPLO = 'L') of this array contains the upper
C             triangular part (if UPLO = 'U') or lower triangular part
C                                                                 -1
C             (if UPLO = 'L'), respectively, of the matrix G = B*R  B'.
C             If JOBG = 'N', this array is not referenced.
C
C     LDG     INTEGER
C             The leading dimension of array G.
C             LDG >= MAX(1,N) if JOBG = 'G';
C             LDG >= 1        if JOBG = 'N'.
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (M)
C             If FACT = 'C' or FACT = 'U', this array is not referenced.
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0 or LDWORK = -1, DWORK(1) returns the
C             optimal value of LDWORK; if FACT = 'N' and LDWORK is set
C             as specified below, DWORK(2) contains the reciprocal
C             condition number of the given matrix R. DWORK(2) is set to
C             zero if M = 0.
C             On exit, if LDWORK = -2 on input or INFO = -26, then
C             DWORK(1) returns the minimal value of LDWORK.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.
C             LDWORK >= 1              if FACT = 'C' or  (FACT = 'U' and
C                                         JOBG = 'N' and  JOBL = 'Z');
C             LDWORK >= MAX(2,3*M)     if FACT = 'N' and  JOBG = 'N' and
C                                                         JOBL = 'Z';
C             LDWORK >= MAX(2,3*M,N*M) if FACT = 'N' and (JOBG = 'G' or
C                                                         JOBL = 'N');
C             LDWORK >= MAX(1,N*M)     if FACT = 'U' and (JOBG = 'G' or
C                                                         JOBL = 'N').
C             For optimum performance LDWORK should be larger than 3*M,
C             if FACT = 'N'.
C
C             If LDWORK = -1, an optimal workspace query is assumed; the
C             routine only calculates the optimal size of the DWORK
C             array, returns this value as the first entry of the DWORK
C             array, and no error message is issued by XERBLA.
C
C             If LDWORK = -2, a minimal workspace query is assumed; the
C             routine only calculates the minimal size of the DWORK
C             array, returns this value as the first entry of the DWORK
C             array, and no error message 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             = i:  if the i-th element (1 <= i <= M) of the d factor is
C                   exactly zero; the UdU' (or LdL') factorization has
C                   been completed, but the block diagonal matrix d is
C                   exactly singular;
C             = M+1:  if the matrix R is numerically singular.
C
C     METHOD
C                            -     -
C     The matrices G, and/or A and Q are evaluated using the given or
C     computed symmetric factorization of R.
C
C     NUMERICAL ASPECTS
C
C     The routine should not be used when R is ill-conditioned.
C
C     FURTHER COMMENTS
C
C     Using argument TRANS allows to avoid the transposition of matrix A
C     needed to solve optimal filtering/estimation problems by the same
C     routines solving optimal control problems.
C     If DEF is set to 'D', but R is indefinite, the computational
C     effort for factorization will be approximately double, since
C     Cholesky factorization, tried first, will fail, and symmetric
C     indefinite factorization will then be used.
C     If DEF is set to 'I', but R is positive definite, the
C     computational effort will be slightly higher than that when using
C     Cholesky factorization. It is recommended to use DEF = 'D' also if
C     the definiteness is not known, but M is (much) smaller than N.
C
C     CONTRIBUTOR
C
C     V. Sima, Research Institute for Informatics, Bucharest, Apr. 2014.
C     This is an extended version of the SLICOT Library routine SB02MT.
C
C     REVISIONS
C
C     V. Sima, May 2014, Aug. 2017, Oct. 2017.
C
C     KEYWORDS
C
C     Algebraic Riccati equation, closed loop system, continuous-time
C     system, discrete-time system, optimal regulator, Schur form.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         DEF, FACT, FLAG, JOBG, JOBL, TRANS, UPLO
      INTEGER           INFO, LDA, LDB, LDG, LDL, LDQ, LDR, LDWORK, M,
     $                  N, OUFACT
C     .. Array Arguments ..
      INTEGER           IPIV(*), IWORK(*)
      DOUBLE PRECISION  A(LDA,*), B(LDB,*), DWORK(*), G(LDG,*),
     $                  L(LDL,*), Q(LDQ,*), R(LDR,*)
C     .. Local Scalars ..
      LOGICAL           BNZER, LDEF, LFACTC, LFACTU, LFLAG, LJOBG,
     $                  LJOBL, LNFACT, LTRANS, LUPLOU
      CHARACTER         NT, TR, TRANSU
      INTEGER           J, WRKMIN, WRKOPT
      DOUBLE PRECISION  EPS, RCOND, RNORM, TEMP
C     .. External Functions ..
      LOGICAL           LSAME
      DOUBLE PRECISION  DLAMCH, DLANGE, DLANSY
      EXTERNAL          DLAMCH, DLANGE, DLANSY, LSAME
C     .. External Subroutines ..
      EXTERNAL          DCOPY, DGEMM, DLASET, DPOCON, DPOTRF, DSYCON,
     $                  DSYRK, DSYTRF, DSYTRS, DTRSM, MA02ED, MB01RB,
     $                  XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         INT, MAX
C     .. Executable Statements ..
C
      INFO   = 0
      LJOBG  = LSAME( JOBG,  'G' )
      LJOBL  = LSAME( JOBL,  'N' )
      LFACTC = LSAME( FACT,  'C' )
      LFACTU = LSAME( FACT,  'U' )
      LTRANS = LSAME( TRANS, 'N' )
      LUPLOU = LSAME( UPLO,  'U' )
      LFLAG  = LSAME( FLAG,  'M' )
      LDEF   = LSAME( DEF,   'D' )
      LNFACT = .NOT.( LFACTC .OR. LFACTU )
C
C     Test the input scalar arguments.
C
      IF(      .NOT.LJOBG  .AND. .NOT.LSAME( JOBG,  'N' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.LJOBL  .AND. .NOT.LSAME( JOBL,  'Z' ) ) THEN
         INFO = -2
      ELSE IF(      LNFACT .AND. .NOT.LSAME( FACT,  'N' ) ) THEN
         INFO = -3
      ELSE IF( .NOT.LUPLOU .AND. .NOT.LSAME( UPLO,  'L' ) ) THEN
         INFO = -4
      ELSE IF( .NOT.LTRANS .AND. .NOT.LSAME( TRANS, 'T' )
     $                     .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN
         INFO = -5
      ELSE IF( .NOT.LFLAG  .AND. .NOT.LSAME( FLAG,  'P' ) ) THEN
         INFO = -6
      ELSE IF( .NOT.LDEF   .AND. .NOT.LSAME( DEF,   'I' )
     $                     .AND. LNFACT ) THEN
         INFO = -7
      ELSE IF( N.LT.0 ) THEN
         INFO = -8
      ELSE IF( M.LT.0 ) THEN
         INFO = -9
      ELSE IF( LDA.LT.1 .OR. ( LJOBL .AND. LDA.LT.N ) ) THEN
         INFO = -11
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -13
      ELSE IF( LDQ.LT.1 .OR. ( LJOBL .AND. LDQ.LT.N ) ) THEN
         INFO = -15
      ELSE IF( LDR.LT.MAX( 1, M ) ) THEN
         INFO = -17
      ELSE IF( LDL.LT.1 .OR. ( LJOBL .AND. LDL.LT.N ) ) THEN
         INFO = -19
      ELSE IF( LDG.LT.1 .OR. ( LJOBG .AND. LDG.LT.N ) ) THEN
         INFO = -23
      ELSE
         IF( LFACTC ) THEN
            WRKMIN = 1
         ELSE IF( LFACTU ) THEN
            IF( LJOBG .OR. LJOBL ) THEN
               WRKMIN = MAX( 1, N*M )
            ELSE
               WRKMIN = 1
            END IF
         ELSE
            IF( LJOBG .OR. LJOBL ) THEN
               WRKMIN = MAX( 2, 3*M, N*M )
            ELSE
               WRKMIN = MAX( 2, 3*M )
            END IF
         END IF
         IF( LDWORK.EQ.-1 ) THEN
            IF( LNFACT ) THEN
               CALL DSYTRF( UPLO, M, R, LDR, IPIV, DWORK, -1, INFO )
               WRKOPT = MAX( WRKMIN, INT( DWORK(1) ) )
            ELSE
               WRKOPT = WRKMIN
            END IF
            DWORK(1) = WRKOPT
            RETURN
         ELSE IF( LDWORK.EQ.-2 ) THEN
            DWORK(1) = WRKMIN
            RETURN
         ELSE IF( LDWORK.LT.WRKMIN ) THEN
            INFO = -26
            DWORK(1) = WRKMIN
         END IF
      END IF
C
      IF( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'SB02MX', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( M.EQ.0 ) THEN
         IF( LJOBG )
     $      CALL DLASET( UPLO, N, N, ZERO, ZERO, G, LDG )
         OUFACT   = 0
         DWORK(1) = WRKMIN
         IF( LNFACT )
     $      DWORK(2) = ZERO
         RETURN
      END IF
C
C     (Note: Comments in the code beginning "Workspace:" describe the
C     minimal amount of workspace needed at that point in the code,
C     as well as the preferred amount for good performance.
C     NB refers to the optimal block size for the immediately
C     following subroutine, as returned by ILAENV.)
C
      WRKOPT = 1
C
      IF( LNFACT ) THEN
C
C        Set relative machine precision.
C
         EPS = DLAMCH( 'Precision' )
C
C        Compute the norm of the matrix R, which is not factored.
C        Then, if DEF = 'D', save the given triangle of R in the other
C        strict triangle and the diagonal in the workspace, and try
C        Cholesky factorization.
C        Workspace: need M.
C
         RNORM = DLANSY( '1-norm', UPLO, M, R, LDR, DWORK )
C
         IF( LDEF ) THEN
            CALL DCOPY(  M, R, LDR+1, DWORK, 1 )
            CALL MA02ED( UPLO, M, R, LDR )
            CALL DPOTRF( UPLO, M, R, LDR, INFO )
            IF( INFO.EQ.0 ) THEN
C
C              Compute the reciprocal of the condition number of R.
C              Workspace: need 3*M.
C
               CALL DPOCON( UPLO, M, R, LDR, RNORM, RCOND, DWORK, IWORK,
     $                      INFO )
C
C              Return if the matrix is singular to working precision.
C
               OUFACT = 1
               IF( RCOND.LT.EPS ) THEN
                  INFO = M + 1
                  DWORK(2) = RCOND
                  RETURN
               END IF
               WRKOPT = MAX( WRKOPT, 3*M )
            ELSE
C
C              Restore the saved triangle, to use the UdU' or LdL'
C              factorization.
C
               CALL DCOPY( M, DWORK, 1, R, LDR+1 )
               IF( LUPLOU ) THEN
                  CALL MA02ED( 'Lower', M, R, LDR )
               ELSE
                  CALL MA02ED( 'Upper', M, R, LDR )
               END IF
            END IF
         END IF
C
         IF( .NOT.LDEF .OR. INFO.GT.0 ) THEN
C
C           Compute the UdU' or LdL' factorization.
C           Workspace: need   1,
C                      prefer M*NB.
C
            CALL DSYTRF( UPLO, M, R, LDR, IPIV, DWORK, LDWORK, INFO )
            OUFACT = 2
            IF( INFO.GT.0 ) THEN
               DWORK(2) = ZERO
               RETURN
            END IF
            WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) )
C
C           Compute the reciprocal of the condition number of R.
C           Workspace: need 2*M.
C
            CALL DSYCON( UPLO, M, R, LDR, IPIV, RNORM, RCOND, DWORK,
     $                   IWORK, INFO )
C
C           Return if the matrix is singular to working precision.
C
            IF( RCOND.LT.EPS ) THEN
               INFO = M + 1
               DWORK(2) = RCOND
               RETURN
            END IF
         END IF
      ELSE IF( LFACTC ) THEN
         OUFACT = 1
      ELSE
         OUFACT = 2
      END IF
C
      IF( N.GT.0 ) THEN
         NT = 'No transpose'
         TR = 'Transpose'
C
         IF( LJOBL ) THEN
            IF( LFLAG ) THEN
               TEMP = -ONE
            ELSE
               TEMP =  ONE
            END IF
         END IF
C
         BNZER = DLANGE( '1-norm', N, M, B, LDB, DWORK ).GT.ZERO
C
         IF( OUFACT.EQ.1 ) THEN
C
C           Solve positive definite linear system(s).
C
            IF( LUPLOU ) THEN
               TRANSU = NT
            ELSE
               TRANSU = TR
            END IF
C
            IF( BNZER ) THEN
C
C              Solve the system X*U = B, overwriting B with X.
C
               CALL DTRSM( 'Right', UPLO, TRANSU, 'Non-unit', N, M, ONE,
     $                     R, LDR, B, LDB )
C
               IF( LJOBG ) THEN
C                                            -1
C                 Compute the matrix  G = B*R  *B', multiplying X*X'.
C
                  CALL DSYRK( UPLO, NT, N, M, ONE, B, LDB, ZERO, G, LDG)
               END IF
            END IF
C
            IF( LJOBL ) THEN
C
C              Update matrices A (if B nonzero) and Q.
C
C              Solve the system Y*U = L, overwriting L with Y.
C
               CALL DTRSM( 'Right', UPLO, TRANSU, 'Non-unit', N, M, ONE,
     $                     R, LDR, L, LDL )
C
               IF( BNZER ) THEN
C
C                 Compute A <- A +/- op(X*Y').
C
                  IF( LTRANS ) THEN
                     CALL DGEMM( NT, TR, N, N, M, TEMP, B, LDB, L, LDL,
     $                           ONE, A, LDA )
                  ELSE
                     CALL DGEMM( NT, TR, N, N, M, TEMP, L, LDL, B, LDB,
     $                           ONE, A, LDA )
                  END IF
               END IF
C
C              Compute Q <- Q +/- Y*Y'.
C
               CALL DSYRK( UPLO, NT, N, M, TEMP, L, LDL, ONE, Q, LDQ )
            END IF
         ELSE
C
C           Solve indefinite linear system(s).
C
            IF( BNZER ) THEN
C
               IF( LJOBG .OR. .NOT.LTRANS ) THEN
C
C                 Solve the system UdU'*X = B' (or LdL'*X = B').
C                 Workspace: need N*M.
C
                  DO 10 J = 1, M
                     CALL DCOPY( N, B(1,J), 1, DWORK(J), M )
   10             CONTINUE
C
                  CALL DSYTRS( UPLO, M, N, R, LDR, IPIV, DWORK, M, INFO)
               END IF
C
               IF( LJOBG ) THEN
C                                                          -1
C                 Compute a triangle of the matrix  G = B*R  *B' = B*X.
C
                  CALL MB01RB( 'Left', UPLO, NT, N, M, ZERO, ONE, G,
     $                         LDG, B, LDB, DWORK, M, INFO )
               END IF
            END IF
C
            IF( LJOBL ) THEN
C
C              Update matrices A and Q.
C
               IF( .NOT.LTRANS .AND. BNZER ) THEN
C
C                 A <- A +/- L*X, if TRANS <> 'N'.
C
                  CALL DGEMM( NT, NT, N, N, M, TEMP, L, LDL, DWORK, M,
     $                        ONE, A, LDA )
               END IF
C
C              Solve the system UdU'*Y = L' (or LdL'*Y = L').
C
               DO 20 J = 1, M
                  CALL DCOPY( N, L(1,J), 1, DWORK(J), M )
   20          CONTINUE
C
               CALL DSYTRS( UPLO, M, N, R, LDR, IPIV, DWORK, M, INFO )
C
               IF( LTRANS .AND. BNZER ) THEN
C
C                 A <- A +/- B*Y, if TRANS =  'N'.
C
                  CALL DGEMM( NT, NT, N, N, M, TEMP, B, LDB, DWORK, M,
     $                        ONE, A, LDA )
               END IF
C                                               -            -1
C              Compute a triangle of the matrix Q = Q +/- L*R  *L'
C                                                 = Q +/- L*Y.
C
               CALL MB01RB( 'Left', UPLO, NT, N, M, ONE, TEMP, Q, LDQ,
     $                      L, LDL, DWORK, M, INFO )
            END IF
         END IF
      END IF
C
      DWORK(1) = WRKOPT
      IF( LNFACT )
     $   DWORK(2) = RCOND
C
C *** Last line of SB02MX ***
      RETURN
      END


subroutine derv(neqn,t,u,ut)
!
!  Subroutine derv computes the derivative vector
!  of the nonlinear PDE problem
!
!  Double precision coding is used
implicit double precision(a-h,o-z)
!
!  Global variables
common/p/ alpha, xk, sigma, xl, ui, ua, a, e, rhos, cps, xls, cs
!
!  Size the arrays
dimension u(neqn), ut(neqn)
!
!  Spatial grid
dx=1.0d0/dfloat(neqn-2)
dxs=dx*dx
!
!  Insulation
do i=1,neqn-2
if(i.eq.1)then
u0=u(2)+2.0d0*dx*xl*(sigma/xk)*(a*ua**4-e*u(1)**4)
ut(i)=(u(2)-2.0d0*u(1)+u0)/dxs
else
ut(i)=(u(i+1)-2.0d0*u(i)+u(i-1))/dxs
end if
end do
!
!  Steel
ut(neqn)=(xk*xl/alpha)*(1.0d0/cs)*(u(neqn-2)-u(neqn-1))/dx
ut(neqn-1)=ut(neqn)
!
!  End of derv
return
end


!-----------------------------------------------------------------------
      subroutine ppiclf_user_SetYdot
!
      implicit none
!
      include "PPICLF"
!
! Internal:
!
      real*8 rpi, rmu, rhof, rmass, vmag, dp, rep, rphip, rphif, asndf,
     >       rmacr, rmachp, dvxdt, dvydt, rpr, rkappa, rcp_fluid,
     >       rcp_part, rmass_therm, rmass_add, rmach_rat
      real*8 fqsx, fqsy, fbx, fby, fcx, fcy, famx, famy, fdpdx, fdpdy,
     >       qq
      real*8 rcd1, rcd_mcr, rcd_std, rcd_M1, rcd_M2, rcd_am,
     >       beta, factor, f1M, f2M, f3M, C1, C2, C3, lrep

      integer*4 i
!
      rpi        = 4.0*atan(1.0)
      rmu        = 1.8E-5
      rcp_part   = 840.0
      rpr        = 0.72
      rcp_fluid  = 1006.0
      rkappa     = rcp_fluid*rmu/rpr

! evaluate ydot
      do i=1,ppiclf_npart
         ! Useful values
         rmass = ppiclf_rprop(PPICLF_R_JVOLP,i)
     >          *ppiclf_rprop(PPICLF_R_JRHOP,i)
         vmag  = (ppiclf_rprop(PPICLF_R_JUX,i)
     >           -ppiclf_y(PPICLF_JVX,i))**2
     >          +(ppiclf_rprop(PPICLF_R_JUY,i)
     >           -ppiclf_y(PPICLF_JVY,i))**2
         vmag  = sqrt(vmag)
         rhof  = ppiclf_rprop(PPICLF_R_JRHOF,i)
         dp    = ppiclf_rprop(PPICLF_R_JDP,i)
         rep   = vmag*dp*rhof/rmu
         rphip = ppiclf_rprop(PPICLF_R_JPHIP,i)
         rphip = min(0.3,rphip)
         rphif = 1.0-ppiclf_rprop(PPICLF_R_JPHIP,i)
         asndf = ppiclf_rprop(PPICLF_R_JCS,i)
         rmachp= vmag/asndf

         ! Quasi-steady force (Re_p and Ma_p corrections):
         !   Improved Drag Correlation for Spheres and Application
         !   to Shock-Tube Experiments
         !   - Parmar et al. (2010)
         !   - AIAA Journal
         if(rep .lt. 1E-12) then
            rcd1 = 1.0
         else
            rmacr= 0.6 ! Critical rmachp no.
            rcd_mcr = (1.+0.15*rep**(0.684)) +
     >                (rep/24.0)*(0.513/(1.+483./rep**(0.669)))
          if (rmachp .le. rmacr) then
             rcd_std = (1.+0.15*rep**(0.687)) +
     >                (rep/24.0)*(0.42/(1.+42500./rep**(1.16)))
             rmach_rat = rmachp/rmacr
             rcd1 = rcd_std + (rcd_mcr - rcd_std)*rmach_rat
          else if (rmachp .le. 1.0) then
            rcd_M1 = (1.0+0.118*rep**0.813) +
     >                (rep/24.0)*0.69/(1.0+3550.0/rep**.793)
            C1 =  6.48
            C2 =  9.28
            C3 = 12.21
            f1M = -1.884 +8.422*rmachp -13.70*rmachp**2 +8.162*rmachp**3
            f2M = -2.228 +10.35*rmachp -16.96*rmachp**2 +9.840*rmachp**3
            f3M =  4.362 -16.91*rmachp +19.84*rmachp**2 -6.296*rmachp**3
            lrep = log(rep)
            factor = f1M*(lrep-C2)*(lrep-C3)/((C1-C2)*(C1-C3))
     >              +f2M*(lrep-C1)*(lrep-C3)/((C2-C1)*(C2-C3))
     >              +f3M*(lrep-C1)*(lrep-C2)/((C3-C1)*(C3-C2))
            rcd1 = rcd_mcr + (rcd_M1-rcd_mcr)*factor
          else if (rmachp .lt. 1.75) then
            rcd_M1 = (1.0+0.118*rep**0.813) +
     >              (rep/24.0)*0.69/(1.0+3550.0/rep**.793)
            rcd_M2 = (1.0+0.107*rep**0.867) +
     >              (rep/24.0)*0.646/(1.0+861.0/rep**.634)
            C1 =  6.48
            C2 =  8.93
            C3 = 12.21
            f1M = -2.963 +4.392*rmachp -1.169*rmachp**2 -0.027*rmachp**3
     >             -0.233*exp((1.0-rmachp)/0.011)
            f2M = -6.617 +12.11*rmachp -6.501*rmachp**2 +1.182*rmachp**3
     >             -0.174*exp((1.0-rmachp)/0.010)
            f3M = -5.866 +11.57*rmachp -6.665*rmachp**2 +1.312*rmachp**3
     >             -0.350*exp((1.0-rmachp)/0.012)
            lrep = log(rep)
            factor = f1M*(lrep-C2)*(lrep-C3)/((C1-C2)*(C1-C3))
     >              +f2M*(lrep-C1)*(lrep-C3)/((C2-C1)*(C2-C3))
     >              +f3M*(lrep-C1)*(lrep-C2)/((C3-C1)*(C3-C2))
            rcd1 = rcd_M1 + (rcd_M2-rcd_M1)*factor
          else
            rcd1 = (1.0+0.107*rep**0.867) +
     >                (rep/24.0)*0.646/(1.0+861.0/rep**.634)
          end if ! rmachp
         endif    ! rep
         beta = rcd1*3.0*rpi*rmu*dp
         ! Quasi-steady force (phi corrections):
         !   The Added Mass, Basset, and Viscous Drag Coefficients
         !   in Nondilute Bubbly Liquids Undergoing Small-Amplitude
         !   Oscillatory Motion
         !   - Sangani et al. (1991)
         !   - Phys. Fluids A
         beta = beta*(1.+2.*rphip)/(1-rphip)**3

         fqsx = beta
     >          *(ppiclf_rprop(PPICLF_R_JUX,i)-ppiclf_y(PPICLF_JVX,i))
         fqsy = beta
     >          *(ppiclf_rprop(PPICLF_R_JUY,i)-ppiclf_y(PPICLF_JVY,i))

         ! Added mass force (Ma_p corrections):
         !   On the unsteady inviscid force on cylinders and spheres
         !   in subcritical compressible flow
         !   - Parmar et al. (2008)
         !   - Philos. Trans. R. Soc. London, Ser. A
         rcd_am = 1.0 + 1.8*rmachp**2 + 7.6*rmachp**4
         ! Added mass force (phi corrections):
         !   On the dispersed two-phase flow in the laminar flow regime
         !   - Zuber (1964)
         !   - Chem. Engng Sci.
         rcd_am = rcd_am*(1.0+2.0*rphip)
         rmass_add = rhof*ppiclf_rprop(PPICLF_R_JVOLP,i)*rcd_am

         famx = -rcd_am*ppiclf_rprop(PPICLF_R_JVOLP,i)*
     >            ppiclf_rprop(PPICLF_R_JDPDX,i)
         famy = -rcd_am*ppiclf_rprop(PPICLF_R_JVOLP,i)*
     >            ppiclf_rprop(PPICLF_R_JDPDY,i)

         dvxdt = ppiclf_ydot(PPICLF_JVX,i)
         dvydt = ppiclf_ydot(PPICLF_JVY,i)

         ! Pressure gradient force
         fdpdx = -ppiclf_rprop(PPICLF_R_JVOLP,i)*
     >            ppiclf_rprop(PPICLF_R_JDPDX,i)
         fdpdy = -ppiclf_rprop(PPICLF_R_JVOLP,i)*
     >            ppiclf_rprop(PPICLF_R_JDPDY,i)

         ! Collision force:
         !  A discrete numerical model for granular assemblies
         !  - Cundall and Strack (1979)
         !  - Geotechnique
         call ppiclf_solve_NearestNeighbor(i)

         fcx  = ppiclf_ydotc(PPICLF_JVX,i)
         fcy  = ppiclf_ydotc(PPICLF_JVY,i)

         ! Quasi-steady heat transfer:
         !   Interaction of a planar shock wave with a dense particle
         !   curtain: Modeling and experiments
         !   - Ling et al. (2012)
         !   - Physics of Fluids
         rmass_therm = rmass*rcp_part
         qq = 2.0*rpi*rkappa*dp*(ppiclf_rprop(PPICLF_R_JT,i) -
     >                           ppiclf_y(PPICLF_JT,i) )
         qq = qq*(1.0+0.3*rep**(0.5)*rpr**(1.0/3.0))

         ! set ydot for all PPICLF_SLN number of equations
         ppiclf_ydot(PPICLF_JX ,i) = ppiclf_y(PPICLF_JVX,i)
         ppiclf_ydot(PPICLF_JY ,i) = ppiclf_y(PPICLF_JVY,i)
         ppiclf_ydot(PPICLF_JVX,i) = (fqsx+famx+fdpdx+fcx)/
     >                               (rmass+rmass_add)
         ppiclf_ydot(PPICLF_JVY,i) = (fqsy+famy+fdpdy+fcy)/
     >                               (rmass+rmass_add)
         ppiclf_ydot(PPICLF_JT,i)  = qq/rmass_therm

!        ! Account for dv/dt added mass force for projection
         famx = famx - rmass_add*dvxdt
         famy = famy - rmass_add*dvydt

         ! Project hydrodynamic forces
         ppiclf_ydotc(PPICLF_JVX,i)     = -(fqsx+famx)
         ppiclf_ydotc(PPICLF_JVY,i)     = -(fqsy+famy)
         ! Project work done by hydrodynamic forces:
         !   Inter-phase heat transfer and energy coupling in turbulent
         !   dispersed multiphase flows
         !   - Ling et al. (2016)
         !   - Physics of Fluids
         ppiclf_rprop(PPICLF_R_JE,i) =fqsx*ppiclf_y(PPICLF_JVX,i)+
     >                                fqsy*ppiclf_y(PPICLF_JVY,i)+
     >                                famx*ppiclf_rprop(PPICLF_R_JUX,i)+
     >                                famy*ppiclf_rprop(PPICLF_R_JUY,i)
         ! Project heat transfer
         ppiclf_rprop(PPICLF_R_JE,i) = qq  +ppiclf_rprop(PPICLF_R_JE,i)
         ppiclf_rprop(PPICLF_R_JE,i) = -1.0*ppiclf_rprop(PPICLF_R_JE,i)
      enddo
! evaluate ydot

      return
      end
!-----------------------------------------------------------------------
      subroutine ppiclf_user_MapProjPart(map,y,ydot,ydotc,rprop)
!
      implicit none
!
! Input:
!
      real*8 y    (PPICLF_LRS)
      real*8 ydot (PPICLF_LRS)
      real*8 ydotc(PPICLF_LRS)
      real*8 rprop(PPICLF_LRP)
!
! Output:
!
      real*8 map  (PPICLF_LRP_PRO)
!
! Internal:
!
      real*8 dp_norm
!
      ! particle volume divided by particle diameter for 2d
      dp_norm = 1.0/rprop(PPICLF_R_JDP)
      map(PPICLF_P_JPHIP)  = dp_norm*rprop(PPICLF_R_JVOLP)
      map(PPICLF_P_JFX)    = dp_norm*ydotc(PPICLF_JVX)
      map(PPICLF_P_JFY)    = dp_norm*ydotc(PPICLF_JVY)
      map(PPICLF_P_JE)     = dp_norm*rprop(PPICLF_R_JE)
      map(PPICLF_P_JPHIPU) = dp_norm*rprop(PPICLF_R_JVOLP)
     >                              *y(PPICLF_JVX)
      map(PPICLF_P_JPHIPV) = dp_norm*rprop(PPICLF_R_JVOLP)
     >                              *y(PPICLF_JVY)
      return
      end
!-----------------------------------------------------------------------
      subroutine ppiclf_user_EvalNearestNeighbor
     >                                        (i,j,yi,rpropi,yj,rpropj)
!
      implicit none
!
      include "PPICLF"
!
! Input:
!
      integer*4 i
      integer*4 j
      real*8 yi    (PPICLF_LRS)
      real*8 rpropi(PPICLF_LRP)
      real*8 yj    (PPICLF_LRS)
      real*8 rpropj(PPICLF_LRP)
!
! Internal:
!
      real*8 ksp,erest
      common /ucollision/ ksp,erest

      real*8 rpi2, rthresh, rxdiff, rydiff, rzdiff, rdiff, rm1, rm2,
     >       rmult, eta, rbot, rn_12x, rn_12y, rn_12z, rdelta12,
     >       rv12_mag, rv12_mage, rksp_max, rnmag, rksp_wall, rextra
!
      rpi2  =  9.869604401089358d0

      ! other particles
      if (j .ne. 0) then
         rthresh  = 0.5d0*(rpropi(PPICLF_R_JDP) + rpropj(PPICLF_R_JDP))

         rxdiff = yj(PPICLF_JX) - yi(PPICLF_JX)
         rydiff = yj(PPICLF_JY) - yi(PPICLF_JY)
!        rzdiff = yj(PPICLF_JZ) - yi(PPICLF_JZ)

         rdiff = rxdiff**2 + rydiff**2
!    >          +rzdiff**2
         rdiff = sqrt(rdiff)

         if (rdiff .gt. rthresh) return

         rm1 = rpropi(PPICLF_R_JRHOP)*rpropi(PPICLF_R_JVOLP)
         rm2 = rpropj(PPICLF_R_JRHOP)*rpropj(PPICLF_R_JVOLP)

         rmult = 1.0d0/sqrt(1.0d0/rm1+1.0d0/rm2)
         eta   = 2.0d0*sqrt(ksp)*log(erest)/sqrt(log(erest)**2+rpi2)
     >           *rmult

         rbot = 1.0d0/rdiff
         rn_12x = rxdiff*rbot
         rn_12y = rydiff*rbot
!        rn_12z = rzdiff*rbot

         rdelta12 = rthresh - rdiff

         rv12_mag = (yj(PPICLF_JVX)-yi(PPICLF_JVX))*rn_12x
     >            + (yj(PPICLF_JVY)-yi(PPICLF_JVY))*rn_12y
!    >            + (yj(PPICLF_JVZ)-yi(PPICLF_JVZ))*rn_12z

         rv12_mage = rv12_mag*eta
         rksp_max  = ksp*rdelta12
         rnmag     = -rksp_max - rv12_mage

         ppiclf_ydotc(PPICLF_JVX,i) = ppiclf_ydotc(PPICLF_JVX,i)
     >                              + rnmag*rn_12x
         ppiclf_ydotc(PPICLF_JVY,i) = ppiclf_ydotc(PPICLF_JVY,i)
     >                              + rnmag*rn_12y
!        ppiclf_ydotc(PPICLF_JVZ,i) = ppiclf_ydotc(PPICLF_JVZ,i)
!    >                              + rnmag*rn_12z

      ! boundaries
      elseif (j .eq. 0) then

         rksp_wall = ksp

         ! give a bit larger collision threshold for walls
         rextra   = 0.0d0
         rthresh  = (0.5d0+rextra)*rpropi(PPICLF_R_JDP)

         rxdiff = yj(PPICLF_JX) - yi(PPICLF_JX)
         rydiff = yj(PPICLF_JY) - yi(PPICLF_JY)
!        rzdiff = yj(PPICLF_JZ) - yi(PPICLF_JZ)

         rdiff = rxdiff**2 + rydiff**2
!    >          +rzdiff**2
         rdiff = sqrt(rdiff)

         if (rdiff .gt. rthresh) return

         rm1 = rpropi(PPICLF_R_JRHOP)*rpropi(PPICLF_R_JVOLP)

         rmult = sqrt(rm1)
         eta   = 2.0d0*sqrt(rksp_wall)*log(erest)
     >           /sqrt(log(erest)**2+rpi2)*rmult

         rbot = 1.0d0/rdiff
         rn_12x = rxdiff*rbot
         rn_12y = rydiff*rbot
         rn_12z = rzdiff*rbot

         rdelta12 = rthresh - rdiff

         rv12_mag = -yi(PPICLF_JVX)*rn_12x
     >              -yi(PPICLF_JVY)*rn_12y
!    >              -yi(PPICLF_JVZ)*rn_12z

         rv12_mage = rv12_mag*eta
         rksp_max  = rksp_wall*rdelta12
         rnmag     = -rksp_max - rv12_mage

         ppiclf_ydotc(PPICLF_JVX,i) = ppiclf_ydotc(PPICLF_JVX,i)
     >                              + rnmag*rn_12x
         ppiclf_ydotc(PPICLF_JVY,i) = ppiclf_ydotc(PPICLF_JVY,i)
     >                              + rnmag*rn_12y
!        ppiclf_ydotc(PPICLF_JVZ,i) = ppiclf_ydotc(PPICLF_JVZ,i)
!    >                              + rnmag*rn_12z

      endif

      return
      end
!-----------------------------------------------------------------------


module fib3
use assert, only: wp
implicit none

contains

pure function FIB(n)

!     CALCULATE FIRST N FIBONACCI NUMBERS
integer, intent(in) :: n
real(wp), dimension(n) :: fib

integer i

fib(:2) = [0, 1]

do I=3,N
  fib(I) = fib(I-1) + fib(I-2)
enddo

end function fib

end module


! { dg-do run }
! { dg-additional-options "-mfp-rounding-mode=d" { target alpha*-*-* } }

  use, intrinsic :: ieee_features, only : ieee_rounding
  use, intrinsic :: ieee_arithmetic
  implicit none

  interface check_equal
    procedure check_equal_float, check_equal_double
  end interface

  interface check_not_equal
    procedure check_not_equal_float, check_not_equal_double
  end interface

  interface divide
    procedure divide_float, divide_double
  end interface

  real :: sx1, sx2, sx3
  double precision :: dx1, dx2, dx3
  type(ieee_round_type) :: mode

  ! We should support at least C float and C double types
  if (ieee_support_rounding(ieee_nearest)) then
    if (.not. ieee_support_rounding(ieee_nearest, 0.)) STOP 1
    if (.not. ieee_support_rounding(ieee_nearest, 0.d0)) STOP 2
  end if

  ! The initial rounding mode should probably be NEAREST
  ! (at least on the platforms we currently support)
  if (ieee_support_rounding(ieee_nearest, 0.)) then
    call ieee_get_rounding_mode (mode)
    if (mode /= ieee_nearest) STOP 3
  end if

  if (ieee_support_rounding(ieee_up, sx1) .and. &
      ieee_support_rounding(ieee_down, sx1) .and. &
      ieee_support_rounding(ieee_nearest, sx1) .and. &
      ieee_support_rounding(ieee_to_zero, sx1)) then

    sx1 = 1
    sx2 = 3
    sx1 = divide(sx1, sx2, ieee_up)

    sx3 = 1
    sx2 = 3
    sx3 = divide(sx3, sx2, ieee_down)
    call check_not_equal(sx1, sx3)
    call check_equal(sx3, nearest(sx1, -1.))
    call check_equal(sx1, nearest(sx3,  1.))

    call check_equal(1./3., divide(1., 3., ieee_nearest))
    call check_equal(-1./3., divide(-1., 3., ieee_nearest))

    call check_equal(divide(3., 7., ieee_to_zero), &
                    divide(3., 7., ieee_down))
    call check_equal(divide(-3., 7., ieee_to_zero), &
                    divide(-3., 7., ieee_up))

  end if

  if (ieee_support_rounding(ieee_up, dx1) .and. &
      ieee_support_rounding(ieee_down, dx1) .and. &
      ieee_support_rounding(ieee_nearest, dx1) .and. &
      ieee_support_rounding(ieee_to_zero, dx1)) then

    dx1 = 1
    dx2 = 3
    dx1 = divide(dx1, dx2, ieee_up)

    dx3 = 1
    dx2 = 3
    dx3 = divide(dx3, dx2, ieee_down)
    call check_not_equal(dx1, dx3)
    call check_equal(dx3, nearest(dx1, -1.d0))
    call check_equal(dx1, nearest(dx3,  1.d0))

    call check_equal(1.d0/3.d0, divide(1.d0, 3.d0, ieee_nearest))
    call check_equal(-1.d0/3.d0, divide(-1.d0, 3.d0, ieee_nearest))

    call check_equal(divide(3.d0, 7.d0, ieee_to_zero), &
                    divide(3.d0, 7.d0, ieee_down))
    call check_equal(divide(-3.d0, 7.d0, ieee_to_zero), &
                    divide(-3.d0, 7.d0, ieee_up))

  end if

contains

  real function divide_float (x, y, rounding) result(res)
    use, intrinsic :: ieee_arithmetic
    real, intent(in) :: x, y
    type(ieee_round_type), intent(in) :: rounding
    type(ieee_round_type) :: old

    call ieee_get_rounding_mode (old)
    call ieee_set_rounding_mode (rounding)

    res = x / y

    call ieee_set_rounding_mode (old)
  end function

  double precision function divide_double (x, y, rounding) result(res)
    use, intrinsic :: ieee_arithmetic
    double precision, intent(in) :: x, y
    type(ieee_round_type), intent(in) :: rounding
    type(ieee_round_type) :: old

    call ieee_get_rounding_mode (old)
    call ieee_set_rounding_mode (rounding)

    res = x / y

    call ieee_set_rounding_mode (old)
  end function

  subroutine check_equal_float (x, y)
    real, intent(in) :: x, y
    if (x /= y) then
      print *, x, y
      STOP 4
    end if
  end subroutine

  subroutine check_equal_double (x, y)
    double precision, intent(in) :: x, y
    if (x /= y) then
      print *, x, y
      STOP 5
    end if
  end subroutine

  subroutine check_not_equal_float (x, y)
    real, intent(in) :: x, y
    if (x == y) then
      print *, x, y
      STOP 6
    end if
  end subroutine

  subroutine check_not_equal_double (x, y)
    double precision, intent(in) :: x, y
    if (x == y) then
      print *, x, y
      STOP 7
    end if
  end subroutine

end


program integration3

  use usermodule1

  implicit none

  integer :: i, j
  real(8) :: x, y, integ

  integ = 0.0d0

  j = 1

  do while (j <= 10)

     y = dble(j) * 1.0d0

     i = 1

     do while (i <= 10)

        x = dble(i) * 2.5d-1

        integ = integ + userfunc(x, y)

        i = i + 1

     end do

     j = j + 1

  end do

  write(*,'(a,e20.10e3)') 'Integration value = ', integ

end program integration3


module length_test
  use fruit
contains
  subroutine test_length_xy
    use length, only : length_xy
    real :: xy_1(2)
    real :: xy_2(2)

    xy_1(1:2) = (/ 0.5, 1.0 /)
    xy_2(1:2) = (/ 3.5, 5.0 /)

    call assert_equals(5.0, length_xy(xy_1, xy_2), 1.e-5, "length (0.5,1)to(3.5,5.0)")

    !! stop   !! code for debug. What if tester code stops?
  end subroutine test_length_xy

  subroutine test_length_xy_hundred
    use length, only : length_xy
    real :: xy_1(2)
    real :: xy_2(2)
    integer :: i
    character(20) :: message

    do i = 1, 100
      write(message, '("assertion", i3)') i
      xy_1(1:2) = (/ 0.0, 0.0 /)
      xy_2(1:2) = (/ 3.0, 4.0 /)
      call assert_equals(5.1, length_xy(xy_1, xy_2), 1.e-5, &
      &  trim(message) // " length sqrt(3^2+4^2)")
    enddo
  end subroutine test_length_xy_hundred
end module length_test


PROGRAM Example_1_1       ! At http://micro.ustc.edu.cn/Fortran/ZJDing/
    REAL :: a, b, av1, av2
    READ *, a, b
        av1 = (a + b)/2; av2 = (a*b)**0.5
    PRINT *, av1, av2
END


        !COMPILER-GENERATED INTERFACE MODULE: Fri May 22 16:59:06 2020
        ! This source file is for reference only and may not completely
        ! represent the generated interface used by the compiler.
        MODULE FOURIER_TRANSFORM__genmod
          INTERFACE
            SUBROUTINE FOURIER_TRANSFORM(LX,CX,SIGNI)
              INTEGER(KIND=4) :: LX
              COMPLEX(KIND=8) :: CX(LX)
              REAL(KIND=8) :: SIGNI
            END SUBROUTINE FOURIER_TRANSFORM
          END INTERFACE
        END MODULE FOURIER_TRANSFORM__genmod