SUBROUTINE CALAVB ()

  ! ****************************************************************************
  ! *** SUBROUTINE CALAV CALCULATES VERTICAL VISCOSITY AND DIFFUSIVITY
  ! *** USING GLAPERIN ET AL'S MODIFICATION OF THE MELLOR-YAMADA MODEL
  ! *** (NOTE AV, AB, AND AQ ARE ACTUALLY DIVIDED BY H)
  ! *** IF ISGA=1 VALUES ARE GEOMETRI!AVERAGES WITH THE PREVIOUS VALUES
  !
  ! CHANGE RECORD
  ! DATE MODIFIED     BY               DESCRIPTION
  !----------------------------------------------------------------------!
  !    2018-10       PAUL M. CRAIG     IMPLEMENTED SPATIALLY VARYING AVO AND ABO
  !    2015-06       PAUL M. CRAIG     IMPLEMENTED SIGMA-Z (SGZ) IN EE8.0
  !    2014-09       PAUL M. CRAIG     ADDED THE LWET BYPASS APPROACH
  !    2011-03-11    PAUL M. CRAIG     MERGED LATEST CODES AND RESTRUCTURED, ADDED OMP
  !                  JOHN HAMRICK      ADDED DRYCELL BYPASS AND CONSISTENT INITIALIZATION OF DRY VALUES

  USE GLOBAL
  IMPLICIT NONE

  INTEGER :: L,K,ND,LF,LL,LP
  REAL    :: QQIMAX,RIQMIN,RIQ,SFAV,SFAB,ABTMP,AVTMP
  REAL    :: SFAV0,SFAV1,SFAV2,SFAV3,SFAB0,SFAB1,RIQMAXX

  ! ***  GALPERIN (DEFAULT)
  SFAV0= 0.392010
  SFAV1= 7.760050
  SFAV2=34.676440
  SFAV3= 6.127200
  SFAB0= 0.493928
  SFAB1=34.676440
  RIQMIN=-0.999/SFAB1

  ! *** KANTHA AND CLAYSON (1994)
  IF( ISTOPT(0) == 2 )THEN
    SFAV0= 0.392010
    SFAV1= 8.679790
    SFAV2=30.192000
    SFAV3= 6.127200
    SFAB0= 0.493928
    SFAB1=30.192000
    RIQMIN=-0.999/SFAB1
  ENDIF

  ! ***  KANTHA (2003)
  IF( ISTOPT(0) == 3 )THEN
    SFAV0= 0.392010
    SFAV1=14.509100
    SFAV2=24.388300
    SFAV3= 3.236400
    SFAB0= 0.490025
    SFAB1=24.388300
    RIQMIN=-0.999/SFAB1
  ENDIF

  RIQMAXX = 1.E32
  IF( ISLLIM >= 1 ) RIQMAXX = RIQMAX

  QQIMAX = 1./QQMIN

  ! ****************************************************************************
  !$OMP PARALLEL DEFAULT(SHARED)

  IF( BSC <= 1.E-6 )THEN
    ! *** VERTICAL DIFFUSVITY TIME FILTERING - NONE
    !$OMP DO PRIVATE(ND,K,LP,L,ABTMP,AVTMP)
    DO ND=1,NDM
      IF( ISFAVB == 0 .OR. N == 1 )THEN
        ! *** VERTICAL DIFFUSVITY TIME FILTERING - NONE
        DO K=1,KS
          DO LP=1,LLWET(K,ND)
            L = LKWET(LP,K,ND)
            AB(L,K) = AVCON*SFAB0*DML(L,K)*HP(L)*QQSQR(L,K) + AVBXY(L)
            AV(L,K) = AVCON*SFAV0*DML(L,K)*HP(L)*QQSQR(L,K) + AVOXY(L)
            AV(L,K) = AV(L,K)*HPI(L)
            AB(L,K) = AB(L,K)*HPI(L)
          ENDDO
        ENDDO

      ELSEIF( ISFAVB == 1 .AND. N > 1 )THEN
        ! *** VERTICAL DIFFUSVITY TIME FILTERING - AVERAGE
        DO K=1,KS
          DO LP=1,LLWET(K,ND)
            L = LKWET(LP,K,ND)
            ABTMP = AVCON*SFAB0*DML(L,K)*HP(L)*QQSQR(L,K) + AVBXY(L)
            AVTMP = AVCON*SFAV0*DML(L,K)*HP(L)*QQSQR(L,K) + AVOXY(L)
            AV(L,K) = 0.5*(AV(L,K) + AVTMP*HPI(L))
            AB(L,K) = 0.5*(AB(L,K)+ABTMP*HPI(L))
          ENDDO
        ENDDO

      ELSEIF( ISFAVB == 2 .AND. N > 1 )THEN
        ! *** VERTICAL DIFFUSVITY TIME FILTERING - SQRT
        DO K=1,KS
          DO LP=1,LLWET(K,ND)
            L = LKWET(LP,K,ND)
            ABTMP = AVCON*SFAB0*DML(L,K)*HP(L)*QQSQR(L,K) + AVBXY(L)
            AVTMP = AVCON*SFAV0*DML(L,K)*HP(L)*QQSQR(L,K) + AVOXY(L)
            AV(L,K) = SQRT(AV(L,K)*AVTMP*HPI(L))
            AB(L,K) = SQRT(AB(L,K)*ABTMP*HPI(L))
          ENDDO
        ENDDO
      ENDIF
    ENDDO
    !$OMP END DO

  ELSE

    !----------------------------------------------------------------------C
    IF( ISFAVB == 0 .OR. N == 1 )THEN
      ! *** VERTICAL DIFFUSVITY TIME FILTERING - NONE
      !$OMP DO PRIVATE(ND,K,LP,L,RIQ,SFAV,SFAB)
      DO ND=1,NDM

        DO K=1,KS
          DO LP=1,LLWET(K,ND)
            L = LKWET(LP,K,ND)
            RIQ = -GP*HP(L)*DML(L,K)*DML(L,K)*DZIG(L,K)*(B(L,K+1)-B(L,K))/QQ(L,K)
            RIQ = MAX(RIQ,RIQMIN)
            RIQ = MIN(RIQ,RIQMAXX)
            SFAV = SFAV0*(1.+SFAV1*RIQ)/((1.+SFAV2*RIQ)*(1.+SFAV3*RIQ))
            SFAB = SFAB0/(1.+SFAB1*RIQ)
            AB(L,K) = AVCON*SFAB*DML(L,K)*HP(L)*QQSQR(L,K) + AVBXY(L)
            AV(L,K) = AVCON*SFAV*DML(L,K)*HP(L)*QQSQR(L,K) + AVOXY(L)
            AV(L,K) = AV(L,K)*HPI(L)
            AB(L,K) = AB(L,K)*HPI(L)
          ENDDO
        ENDDO
      ENDDO
      !$OMP END DO

    !----------------------------------------------------------------------C
    ELSEIF( ISFAVB == 1 .AND. N > 1 )THEN
      ! *** VERTICAL DIFFUSVITY TIME FILTERING - AVERAGE
      !$OMP DO PRIVATE(ND,K,LP,L,RIQ,SFAV,SFAB,AVTMP,ABTMP)
      DO ND=1,NDM

        DO K=1,KS
          DO LP=1,LLWET(K,ND)
            L=LKWET(LP,K,ND)
            RIQ = -GP*HP(L)*DML(L,K)*DML(L,K)*DZIG(L,K)*(B(L,K+1)-B(L,K))/QQ(L,K)
            RIQ = MAX(RIQ,RIQMIN)
            RIQ = MIN(RIQ,RIQMAXX)
            SFAV = SFAV0*(1.+SFAV1*RIQ)/((1.+SFAV2*RIQ)*(1.+SFAV3*RIQ))
            SFAB = SFAB0/(1.+SFAB1*RIQ)
            ABTMP = AVCON*SFAB*DML(L,K)*HP(L)*QQSQR(L,K) + AVBXY(L)
            AVTMP = AVCON*SFAV*DML(L,K)*HP(L)*QQSQR(L,K) + AVOXY(L)
            AV(L,K) = 0.5*(AV(L,K) + AVTMP*HPI(L))
            AB(L,K) = 0.5*(AB(L,K)+ABTMP*HPI(L))
          ENDDO
        ENDDO
      ENDDO
      !$OMP END DO

    !----------------------------------------------------------------------C
    ELSEIF( ISFAVB == 2 .AND. N > 1 )THEN
      ! *** VERTICAL DIFFUSVITY TIME FILTERING - SQRT
      !$OMP DO PRIVATE(ND,K,LP,L,RIQ,SFAV,SFAB,AVTMP,ABTMP)
      DO ND=1,NDM

        DO K=1,KS
          DO LP=1,LLWET(K,ND)
            L = LKWET(LP,K,ND)
            RIQ = -GP*HP(L)*DML(L,K)*DML(L,K)*DZIG(L,K)*(B(L,K+1)-B(L,K))/QQ(L,K)
            RIQ = MAX(RIQ,RIQMIN)
            RIQ = MIN(RIQ,RIQMAXX)
            SFAV = SFAV0*(1.+SFAV1*RIQ)/((1.+SFAV2*RIQ)*(1.+SFAV3*RIQ))
            SFAB = SFAB0/(1.+SFAB1*RIQ)
            ABTMP = AVCON*SFAB*DML(L,K)*HP(L)*QQSQR(L,K) + AVBXY(L)
            AVTMP = AVCON*SFAV*DML(L,K)*HP(L)*QQSQR(L,K) + AVOXY(L)
            AV(L,K) = SQRT(AV(L,K)*AVTMP*HPI(L))
            AB(L,K) = SQRT(AB(L,K)*ABTMP*HPI(L))
          ENDDO
        ENDDO
      ENDDO
      !$OMP END DO
    ENDIF

  ENDIF

  ! *** APPLY OPEN BOUNDARYS
  !$OMP SINGLE
  DO LL=1,NBCSOP
    L=LOBCS(LL)
    DO K=1,KS
      AB(L,K)=0.0
    ENDDO
  ENDDO
  !$OMP END SINGLE

  ! ****************************************************************************
  IF( ISLOG >= 1 )THEN
    !$OMP SINGLE
    AVMAX=AVO
    ABMAX=ABO
    AVMIN=10.
    ABMIN=10.
    DO K=1,KS
      DO L=2,LA
        IF( LKSZ(L,K) )CYCLE
        AVMAX=MAX(AVMAX,AV(L,K))
        ABMAX=MAX(ABMAX,AB(L,K))
        AVMIN=MIN(AVMIN,AV(L,K))
        ABMIN=MIN(ABMIN,AB(L,K))
      ENDDO
    ENDDO
    !$OMP END SINGLE
  ENDIF

  ! ****************************************************************************
  ! *** CHECK FOR DEPTHS LESS THAN ZBR
  IF( ISDRY > 0 )THEN
    !$OMP DO PRIVATE(ND,LF,LL,LP,L,K)
    DO ND=1,NDM
      LF=(ND-1)*LDMWET+1
      LL=MIN(LF+LDMWET-1,LAWET)

      DO LP=LF,LL
        L=LWET(LP)
        IF( HPK(L,KSZ(L)) < ZBR(L) )THEN
          DO K=KS-1,KSZ(L),-1
            IF( HP(L)*Z(L,K-1) > ZBR(L) )CYCLE
            AV(L,K) = AV(L,K+1)
            AB(L,K) = AB(L,K+1)
          ENDDO
        ENDIF
      ENDDO
    ENDDO
    !$OMP END DO
  ENDIF

  ! ****************************************************************************
  ! *** NOW APPLY MAXIMUM, IF REQURIED
  IF( ISAVBMX >= 1 )THEN
    !$OMP DO PRIVATE(ND,K,LP,L,AVTMP,ABTMP)
    DO ND=1,NDM

      DO K=1,KS
        DO LP=1,LLWET(K,ND)
          L=LKWET(LP,K,ND)
          AVTMP = AVMX*HPI(L)
          ABTMP = ABMX*HPI(L)
          AV(L,K) = MIN(AV(L,K),AVTMP)
          AB(L,K) = MIN(AB(L,K),ABTMP)
        ENDDO
      ENDDO
    ENDDO
    !$OMP END DO
  ENDIF

  ! ****************************************************************************
  ! *** COMPUTE THE INVERSE OF THE AVERAGE AV AT THE U AND V INTERFACES
  IF( IGRIDV == 0 )THEN
    !$OMP DO PRIVATE(ND,K,LP,L)
    DO ND=1,NDM
      DO K=1,KS
        DO LP=1,LLWET(K,ND)
          L=LKWET(LP,K,ND)
          AVUI(L,K) = 2.0/( AV(L,K) + AV(LWC(L),K) )
          AVVI(L,K) = 2.0/( AV(L,K) + AV(LSC(L),K) )
        ENDDO
      ENDDO
    ENDDO
    !$OMP END DO
  ELSE
    !$OMP DO PRIVATE(ND,K,LP,L)
    DO ND=1,NDM
      DO K=1,KS
        DO LP=1,LLWET(K,ND)
          L=LKWET(LP,K,ND)
          AVUI(L,K) = SUB(L)*(1. + SUB3D(L,K))/( AV(L,K)*HP(L) + SUB3D(L,K)*AV(LWC(L),K)*HP(LWC(L) ) )*HU(L)
          AVVI(L,K) = SVB(L)*(1. + SVB3D(L,K))/( AV(L,K)*HP(L) + SVB3D(L,K)*AV(LSC(L),K)*HP(LSC(L) ) )*HV(L)
        ENDDO
      ENDDO
    ENDDO
    !$OMP END DO
  ENDIF

  ! ****************************************************************************
  ! *** ISSQL:   0 SETS QQ AND QQL STABILITY FUNCTIONS PROPORTIONAL TO
  ! ***            MOMENTUM STABILITY FUNCTIONS
  IF( ISTOPT(0) <= 2 .OR. ISSQL == 0 )THEN
    !$OMP DO PRIVATE(ND,K,LP,L)
    DO ND=1,NDM
      DO K=2,KS
        DO LP=1,LLWET(K-1,ND)
          L = LKWET(LP,K-1,ND)
          AQ(L,K) = 0.205*(AV(L,K-1) + AV(L,K))
        ENDDO
      ENDDO
      DO LP=1,LLWET(KS,ND)
        L = LKWET(LP,KS,ND)
        AQ(L,KSZ(L)) = 0.205*AV(L,KSZ(L))
        AQ(L,KC)     = 0.205*AV(L,KS)
      ENDDO
    ENDDO
    !$OMP END DO

  ENDIF

  ! ****************************************************************************
  ! *** ISSQL:     1  SETS QQ AND QQL STABILITY FUNCTIONS TO CONSTANTS
  ! *** ISTOPT(0)  3  KANTHA (2003)
  IF( ISTOPT(0) == 3 .OR. ISSQL == 1 )THEN
    IF( ISFAVB == 1 .AND. N > 1 )THEN
      ! *** AVERAGE FILTER
      !$OMP DO PRIVATE(ND,LF,LL,K,LP,L)
      DO ND=1,NDM
        LF=(ND-1)*LDMWET+1
        LL=MIN(LF+LDMWET-1,LAWET)

        DO K=2,KS
          DO LP=1,LLWET(K-1,ND)
            L=LKWET(LP,K-1,ND)
            AQ(L,K)=0.314*( DML(L,K-1)*QQSQR(L,K-1)+DML(L,K)*QQSQR(L,K) ) + AVOXY(L)*HPI(L)
          ENDDO
        ENDDO

        DO LP=LF,LL
          L=LWET(LP)
          AQ(L,KSZ(L))=0.314*DML(L,KSZ(L))**QQSQR(L,KSZ(L)) + AVOXY(L)*HPI(L)
          AQ(L,KC)    =0.314*DML(L,KC    )* QQSQR(L,KC    ) + AVOXY(L)*HPI(L)
        ENDDO
      ENDDO
      !$OMP END DO

    ELSE
      ! *** SQRT FILTER & NO FILTER
      !$OMP DO PRIVATE(ND,LF,LL,K,LP,L)
      DO ND=1,NDM
        LF=(ND-1)*LDMWET+1
        LL=MIN(LF+LDMWET-1,LAWET)

        DO K=2,KS
          DO LP=1,LLWET(K-1,ND)
            L=LKWET(LP,K-1,ND)
            AQ(L,K)=0.5*( 0.314*( DML(L,K-1)*QQSQR(L,K-1)+DML(L,K  )*QQSQR(L,K) ) + AVOXY(L)*HPI(L) ) + 0.5*AQ(L,K)
          ENDDO
        ENDDO

        DO LP=LF,LL
          L=LWET(LP)
          AQ(L,KSZ(L))=0.5*( 0.314*DML(L,KSZ(L))**QQSQR(L,KSZ(L)) + AVOXY(L)*HPI(L) ) + 0.5*AQ(L,KSZ(L))
          AQ(L,KC)    =0.5*( 0.314*DML(L,KC    )* QQSQR(L,KC    ) + AVOXY(L)*HPI(L) ) + 0.5*AQ(L,KC)
        ENDDO
      ENDDO
      !$OMP END DO

    ENDIF
  ENDIF

  !$OMP END PARALLEL

  ! ****************************************************************************
  RETURN

END


*> \brief \b CCHKTB
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*       SUBROUTINE CCHKTB( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR,
*                          NMAX, AB, AINV, B, X, XACT, WORK, RWORK, NOUT )
*
*       .. Scalar Arguments ..
*       LOGICAL            TSTERR
*       INTEGER            NMAX, NN, NNS, NOUT
*       REAL               THRESH
*       ..
*       .. Array Arguments ..
*       LOGICAL            DOTYPE( * )
*       INTEGER            NSVAL( * ), NVAL( * )
*       REAL               RWORK( * )
*       COMPLEX            AB( * ), AINV( * ), B( * ), WORK( * ), X( * ),
*      $                   XACT( * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> CCHKTB tests CTBTRS, -RFS, and -CON, and CLATBS.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] DOTYPE
*> \verbatim
*>          DOTYPE is LOGICAL array, dimension (NTYPES)
*>          The matrix types to be used for testing.  Matrices of type j
*>          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
*>          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
*> \endverbatim
*>
*> \param[in] NN
*> \verbatim
*>          NN is INTEGER
*>          The number of values of N contained in the vector NVAL.
*> \endverbatim
*>
*> \param[in] NVAL
*> \verbatim
*>          NVAL is INTEGER array, dimension (NN)
*>          The values of the matrix column dimension N.
*> \endverbatim
*>
*> \param[in] NNS
*> \verbatim
*>          NNS is INTEGER
*>          The number of values of NRHS contained in the vector NSVAL.
*> \endverbatim
*>
*> \param[in] NSVAL
*> \verbatim
*>          NSVAL is INTEGER array, dimension (NNS)
*>          The values of the number of right hand sides NRHS.
*> \endverbatim
*>
*> \param[in] THRESH
*> \verbatim
*>          THRESH is REAL
*>          The threshold value for the test ratios.  A result is
*>          included in the output file if RESULT >= THRESH.  To have
*>          every test ratio printed, use THRESH = 0.
*> \endverbatim
*>
*> \param[in] TSTERR
*> \verbatim
*>          TSTERR is LOGICAL
*>          Flag that indicates whether error exits are to be tested.
*> \endverbatim
*>
*> \param[in] NMAX
*> \verbatim
*>          NMAX is INTEGER
*>          The leading dimension of the work arrays.
*>          NMAX >= the maximum value of N in NVAL.
*> \endverbatim
*>
*> \param[out] AB
*> \verbatim
*>          AB is COMPLEX array, dimension (NMAX*NMAX)
*> \endverbatim
*>
*> \param[out] AINV
*> \verbatim
*>          AINV is COMPLEX array, dimension (NMAX*NMAX)
*> \endverbatim
*>
*> \param[out] B
*> \verbatim
*>          B is COMPLEX array, dimension (NMAX*NSMAX)
*>          where NSMAX is the largest entry in NSVAL.
*> \endverbatim
*>
*> \param[out] X
*> \verbatim
*>          X is COMPLEX array, dimension (NMAX*NSMAX)
*> \endverbatim
*>
*> \param[out] XACT
*> \verbatim
*>          XACT is COMPLEX array, dimension (NMAX*NSMAX)
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*>          WORK is COMPLEX array, dimension
*>                      (NMAX*max(3,NSMAX))
*> \endverbatim
*>
*> \param[out] RWORK
*> \verbatim
*>          RWORK is REAL array, dimension
*>                      (max(NMAX,2*NSMAX))
*> \endverbatim
*>
*> \param[in] NOUT
*> \verbatim
*>          NOUT is INTEGER
*>          The unit number for output.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup complex_lin
*
*  =====================================================================
      SUBROUTINE CCHKTB( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR,
     $                   NMAX, AB, AINV, B, X, XACT, WORK, RWORK, NOUT )
*
*  -- LAPACK test routine (version 3.7.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     December 2016
*
*     .. Scalar Arguments ..
      LOGICAL            TSTERR
      INTEGER            NMAX, NN, NNS, NOUT
      REAL               THRESH
*     ..
*     .. Array Arguments ..
      LOGICAL            DOTYPE( * )
      INTEGER            NSVAL( * ), NVAL( * )
      REAL               RWORK( * )
      COMPLEX            AB( * ), AINV( * ), B( * ), WORK( * ), X( * ),
     $                   XACT( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      INTEGER            NTYPE1, NTYPES
      PARAMETER          ( NTYPE1 = 9, NTYPES = 17 )
      INTEGER            NTESTS
      PARAMETER          ( NTESTS = 8 )
      INTEGER            NTRAN
      PARAMETER          ( NTRAN = 3 )
      REAL               ONE, ZERO
      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
*     ..
*     .. Local Scalars ..
      CHARACTER          DIAG, NORM, TRANS, UPLO, XTYPE
      CHARACTER*3        PATH
      INTEGER            I, IDIAG, IK, IMAT, IN, INFO, IRHS, ITRAN,
     $                   IUPLO, J, K, KD, LDA, LDAB, N, NERRS, NFAIL,
     $                   NIMAT, NIMAT2, NK, NRHS, NRUN
      REAL               AINVNM, ANORM, RCOND, RCONDC, RCONDI, RCONDO,
     $                   SCALE
*     ..
*     .. Local Arrays ..
      CHARACTER          TRANSS( NTRAN ), UPLOS( 2 )
      INTEGER            ISEED( 4 ), ISEEDY( 4 )
      REAL               RESULT( NTESTS )
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      REAL               CLANTB, CLANTR
      EXTERNAL           LSAME, CLANTB, CLANTR
*     ..
*     .. External Subroutines ..
      EXTERNAL           ALAERH, ALAHD, ALASUM, CCOPY, CERRTR, CGET04,
     $                   CLACPY, CLARHS, CLASET, CLATBS, CLATTB, CTBCON,
     $                   CTBRFS, CTBSV, CTBT02, CTBT03, CTBT05, CTBT06,
     $                   CTBTRS
*     ..
*     .. Scalars in Common ..
      LOGICAL            LERR, OK
      CHARACTER*32       SRNAMT
      INTEGER            INFOT, IOUNIT
*     ..
*     .. Common blocks ..
      COMMON             / INFOC / INFOT, IOUNIT, OK, LERR
      COMMON             / SRNAMC / SRNAMT
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          CMPLX, MAX, MIN
*     ..
*     .. Data statements ..
      DATA               ISEEDY / 1988, 1989, 1990, 1991 /
      DATA               UPLOS / 'U', 'L' / , TRANSS / 'N', 'T', 'C' /
*     ..
*     .. Executable Statements ..
*
*     Initialize constants and the random number seed.
*
      PATH( 1: 1 ) = 'Complex precision'
      PATH( 2: 3 ) = 'TB'
      NRUN = 0
      NFAIL = 0
      NERRS = 0
      DO 10 I = 1, 4
         ISEED( I ) = ISEEDY( I )
   10 CONTINUE
*
*     Test the error exits
*
      IF( TSTERR )
     $   CALL CERRTR( PATH, NOUT )
      INFOT = 0
*
      DO 140 IN = 1, NN
*
*        Do for each value of N in NVAL
*
         N = NVAL( IN )
         LDA = MAX( 1, N )
         XTYPE = 'N'
         NIMAT = NTYPE1
         NIMAT2 = NTYPES
         IF( N.LE.0 ) THEN
            NIMAT = 1
            NIMAT2 = NTYPE1 + 1
         END IF
*
         NK = MIN( N+1, 4 )
         DO 130 IK = 1, NK
*
*           Do for KD = 0, N, (3N-1)/4, and (N+1)/4. This order makes
*           it easier to skip redundant values for small values of N.
*
            IF( IK.EQ.1 ) THEN
               KD = 0
            ELSE IF( IK.EQ.2 ) THEN
               KD = MAX( N, 0 )
            ELSE IF( IK.EQ.3 ) THEN
               KD = ( 3*N-1 ) / 4
            ELSE IF( IK.EQ.4 ) THEN
               KD = ( N+1 ) / 4
            END IF
            LDAB = KD + 1
*
            DO 90 IMAT = 1, NIMAT
*
*              Do the tests only if DOTYPE( IMAT ) is true.
*
               IF( .NOT.DOTYPE( IMAT ) )
     $            GO TO 90
*
               DO 80 IUPLO = 1, 2
*
*                 Do first for UPLO = 'U', then for UPLO = 'L'
*
                  UPLO = UPLOS( IUPLO )
*
*                 Call CLATTB to generate a triangular test matrix.
*
                  SRNAMT = 'CLATTB'
                  CALL CLATTB( IMAT, UPLO, 'No transpose', DIAG, ISEED,
     $                         N, KD, AB, LDAB, X, WORK, RWORK, INFO )
*
*                 Set IDIAG = 1 for non-unit matrices, 2 for unit.
*
                  IF( LSAME( DIAG, 'N' ) ) THEN
                     IDIAG = 1
                  ELSE
                     IDIAG = 2
                  END IF
*
*                 Form the inverse of A so we can get a good estimate
*                 of RCONDC = 1/(norm(A) * norm(inv(A))).
*
                  CALL CLASET( 'Full', N, N, CMPLX( ZERO ),
     $                         CMPLX( ONE ), AINV, LDA )
                  IF( LSAME( UPLO, 'U' ) ) THEN
                     DO 20 J = 1, N
                        CALL CTBSV( UPLO, 'No transpose', DIAG, J, KD,
     $                              AB, LDAB, AINV( ( J-1 )*LDA+1 ), 1 )
   20                CONTINUE
                  ELSE
                     DO 30 J = 1, N
                        CALL CTBSV( UPLO, 'No transpose', DIAG, N-J+1,
     $                              KD, AB( ( J-1 )*LDAB+1 ), LDAB,
     $                              AINV( ( J-1 )*LDA+J ), 1 )
   30                CONTINUE
                  END IF
*
*                 Compute the 1-norm condition number of A.
*
                  ANORM = CLANTB( '1', UPLO, DIAG, N, KD, AB, LDAB,
     $                    RWORK )
                  AINVNM = CLANTR( '1', UPLO, DIAG, N, N, AINV, LDA,
     $                     RWORK )
                  IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN
                     RCONDO = ONE
                  ELSE
                     RCONDO = ( ONE / ANORM ) / AINVNM
                  END IF
*
*                 Compute the infinity-norm condition number of A.
*
                  ANORM = CLANTB( 'I', UPLO, DIAG, N, KD, AB, LDAB,
     $                    RWORK )
                  AINVNM = CLANTR( 'I', UPLO, DIAG, N, N, AINV, LDA,
     $                     RWORK )
                  IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN
                     RCONDI = ONE
                  ELSE
                     RCONDI = ( ONE / ANORM ) / AINVNM
                  END IF
*
                  DO 60 IRHS = 1, NNS
                     NRHS = NSVAL( IRHS )
                     XTYPE = 'N'
*
                     DO 50 ITRAN = 1, NTRAN
*
*                    Do for op(A) = A, A**T, or A**H.
*
                        TRANS = TRANSS( ITRAN )
                        IF( ITRAN.EQ.1 ) THEN
                           NORM = 'O'
                           RCONDC = RCONDO
                        ELSE
                           NORM = 'I'
                           RCONDC = RCONDI
                        END IF
*
*+    TEST 1
*                    Solve and compute residual for op(A)*x = b.
*
                        SRNAMT = 'CLARHS'
                        CALL CLARHS( PATH, XTYPE, UPLO, TRANS, N, N, KD,
     $                               IDIAG, NRHS, AB, LDAB, XACT, LDA,
     $                               B, LDA, ISEED, INFO )
                        XTYPE = 'C'
                        CALL CLACPY( 'Full', N, NRHS, B, LDA, X, LDA )
*
                        SRNAMT = 'CTBTRS'
                        CALL CTBTRS( UPLO, TRANS, DIAG, N, KD, NRHS, AB,
     $                               LDAB, X, LDA, INFO )
*
*                    Check error code from CTBTRS.
*
                        IF( INFO.NE.0 )
     $                     CALL ALAERH( PATH, 'CTBTRS', INFO, 0,
     $                                  UPLO // TRANS // DIAG, N, N, KD,
     $                                  KD, NRHS, IMAT, NFAIL, NERRS,
     $                                  NOUT )
*
                        CALL CTBT02( UPLO, TRANS, DIAG, N, KD, NRHS, AB,
     $                               LDAB, X, LDA, B, LDA, WORK, RWORK,
     $                               RESULT( 1 ) )
*
*+    TEST 2
*                    Check solution from generated exact solution.
*
                        CALL CGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
     $                               RESULT( 2 ) )
*
*+    TESTS 3, 4, and 5
*                    Use iterative refinement to improve the solution
*                    and compute error bounds.
*
                        SRNAMT = 'CTBRFS'
                        CALL CTBRFS( UPLO, TRANS, DIAG, N, KD, NRHS, AB,
     $                               LDAB, B, LDA, X, LDA, RWORK,
     $                               RWORK( NRHS+1 ), WORK,
     $                               RWORK( 2*NRHS+1 ), INFO )
*
*                    Check error code from CTBRFS.
*
                        IF( INFO.NE.0 )
     $                     CALL ALAERH( PATH, 'CTBRFS', INFO, 0,
     $                                  UPLO // TRANS // DIAG, N, N, KD,
     $                                  KD, NRHS, IMAT, NFAIL, NERRS,
     $                                  NOUT )
*
                        CALL CGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
     $                               RESULT( 3 ) )
                        CALL CTBT05( UPLO, TRANS, DIAG, N, KD, NRHS, AB,
     $                               LDAB, B, LDA, X, LDA, XACT, LDA,
     $                               RWORK, RWORK( NRHS+1 ),
     $                               RESULT( 4 ) )
*
*                       Print information about the tests that did not
*                       pass the threshold.
*
                        DO 40 K = 1, 5
                           IF( RESULT( K ).GE.THRESH ) THEN
                              IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
     $                           CALL ALAHD( NOUT, PATH )
                              WRITE( NOUT, FMT = 9999 )UPLO, TRANS,
     $                           DIAG, N, KD, NRHS, IMAT, K, RESULT( K )
                              NFAIL = NFAIL + 1
                           END IF
   40                   CONTINUE
                        NRUN = NRUN + 5
   50                CONTINUE
   60             CONTINUE
*
*+    TEST 6
*                    Get an estimate of RCOND = 1/CNDNUM.
*
                  DO 70 ITRAN = 1, 2
                     IF( ITRAN.EQ.1 ) THEN
                        NORM = 'O'
                        RCONDC = RCONDO
                     ELSE
                        NORM = 'I'
                        RCONDC = RCONDI
                     END IF
                     SRNAMT = 'CTBCON'
                     CALL CTBCON( NORM, UPLO, DIAG, N, KD, AB, LDAB,
     $                            RCOND, WORK, RWORK, INFO )
*
*                    Check error code from CTBCON.
*
                     IF( INFO.NE.0 )
     $                  CALL ALAERH( PATH, 'CTBCON', INFO, 0,
     $                               NORM // UPLO // DIAG, N, N, KD, KD,
     $                               -1, IMAT, NFAIL, NERRS, NOUT )
*
                     CALL CTBT06( RCOND, RCONDC, UPLO, DIAG, N, KD, AB,
     $                            LDAB, RWORK, RESULT( 6 ) )
*
*                    Print the test ratio if it is .GE. THRESH.
*
                     IF( RESULT( 6 ).GE.THRESH ) THEN
                        IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
     $                     CALL ALAHD( NOUT, PATH )
                        WRITE( NOUT, FMT = 9998 ) 'CTBCON', NORM, UPLO,
     $                     DIAG, N, KD, IMAT, 6, RESULT( 6 )
                        NFAIL = NFAIL + 1
                     END IF
                     NRUN = NRUN + 1
   70             CONTINUE
   80          CONTINUE
   90       CONTINUE
*
*           Use pathological test matrices to test CLATBS.
*
            DO 120 IMAT = NTYPE1 + 1, NIMAT2
*
*              Do the tests only if DOTYPE( IMAT ) is true.
*
               IF( .NOT.DOTYPE( IMAT ) )
     $            GO TO 120
*
               DO 110 IUPLO = 1, 2
*
*                 Do first for UPLO = 'U', then for UPLO = 'L'
*
                  UPLO = UPLOS( IUPLO )
                  DO 100 ITRAN = 1, NTRAN
*
*                    Do for op(A) = A, A**T, and A**H.
*
                     TRANS = TRANSS( ITRAN )
*
*                    Call CLATTB to generate a triangular test matrix.
*
                     SRNAMT = 'CLATTB'
                     CALL CLATTB( IMAT, UPLO, TRANS, DIAG, ISEED, N, KD,
     $                            AB, LDAB, X, WORK, RWORK, INFO )
*
*+    TEST 7
*                    Solve the system op(A)*x = b
*
                     SRNAMT = 'CLATBS'
                     CALL CCOPY( N, X, 1, B, 1 )
                     CALL CLATBS( UPLO, TRANS, DIAG, 'N', N, KD, AB,
     $                            LDAB, B, SCALE, RWORK, INFO )
*
*                    Check error code from CLATBS.
*
                     IF( INFO.NE.0 )
     $                  CALL ALAERH( PATH, 'CLATBS', INFO, 0,
     $                               UPLO // TRANS // DIAG // 'N', N, N,
     $                               KD, KD, -1, IMAT, NFAIL, NERRS,
     $                               NOUT )
*
                     CALL CTBT03( UPLO, TRANS, DIAG, N, KD, 1, AB, LDAB,
     $                            SCALE, RWORK, ONE, B, LDA, X, LDA,
     $                            WORK, RESULT( 7 ) )
*
*+    TEST 8
*                    Solve op(A)*x = b again with NORMIN = 'Y'.
*
                     CALL CCOPY( N, X, 1, B, 1 )
                     CALL CLATBS( UPLO, TRANS, DIAG, 'Y', N, KD, AB,
     $                            LDAB, B, SCALE, RWORK, INFO )
*
*                    Check error code from CLATBS.
*
                     IF( INFO.NE.0 )
     $                  CALL ALAERH( PATH, 'CLATBS', INFO, 0,
     $                               UPLO // TRANS // DIAG // 'Y', N, N,
     $                               KD, KD, -1, IMAT, NFAIL, NERRS,
     $                               NOUT )
*
                     CALL CTBT03( UPLO, TRANS, DIAG, N, KD, 1, AB, LDAB,
     $                            SCALE, RWORK, ONE, B, LDA, X, LDA,
     $                            WORK, RESULT( 8 ) )
*
*                    Print information about the tests that did not pass
*                    the threshold.
*
                     IF( RESULT( 7 ).GE.THRESH ) THEN
                        IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
     $                     CALL ALAHD( NOUT, PATH )
                        WRITE( NOUT, FMT = 9997 )'CLATBS', UPLO, TRANS,
     $                     DIAG, 'N', N, KD, IMAT, 7, RESULT( 7 )
                        NFAIL = NFAIL + 1
                     END IF
                     IF( RESULT( 8 ).GE.THRESH ) THEN
                        IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
     $                     CALL ALAHD( NOUT, PATH )
                        WRITE( NOUT, FMT = 9997 )'CLATBS', UPLO, TRANS,
     $                     DIAG, 'Y', N, KD, IMAT, 8, RESULT( 8 )
                        NFAIL = NFAIL + 1
                     END IF
                     NRUN = NRUN + 2
  100             CONTINUE
  110          CONTINUE
  120       CONTINUE
  130    CONTINUE
  140 CONTINUE
*
*     Print a summary of the results.
*
      CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
*
 9999 FORMAT( ' UPLO=''', A1, ''', TRANS=''', A1, ''',
     $      DIAG=''', A1, ''', N=', I5, ', KD=', I5, ', NRHS=', I5,
     $      ', type ', I2, ', test(', I2, ')=', G12.5 )
 9998 FORMAT( 1X, A, '( ''', A1, ''', ''', A1, ''', ''', A1, ''',',
     $      I5, ',', I5, ',  ... ), type ', I2, ', test(', I2, ')=',
     $      G12.5 )
 9997 FORMAT( 1X, A, '( ''', A1, ''', ''', A1, ''', ''', A1, ''', ''',
     $      A1, ''',', I5, ',', I5, ', ...  ),  type ', I2, ', test(',
     $      I1, ')=', G12.5 )
      RETURN
*
*     End of CCHKTB
*
      END


program tover
    use ccm_numz
    real(b8),allocatable :: m1(:,:),m2(:,:),m3(:,:),m4(:,:)
    integer n
    real(b8) t0_start;
    real(b8) t1_start,t1_end,e1;
    real(b8) t2_start,t2_end,e2;
    real(b8) t3_start,t3_end,e3;
    real(b8) t4_start,t4_end,e4;

    n=400
    allocate(m1(n,n),m2(n,n),m3(n,n),m4(n,n))
    call mset(m1,n,10)
    call mset(m2,n,20)
    call mset(m3,n,30)
    call mset(m4,n,40)
    t0_start=ccm_time()
!$omp parallel sections

!$omp section
    t1_start=ccm_time()
    call invert(m1,n)
    call invert(m1,n)
    t1_end=ccm_time()
    e1=mcheck(m1,n,10)
    t1_start=t1_start-t0_start
    t1_end=t1_end-t0_start

!$omp section
    t2_start=ccm_time()
    call invert(m2,n)
    call invert(m2,n)
    t2_end=ccm_time()
    e2=mcheck(m2,n,20)
    t2_start=t2_start-t0_start
    t2_end=t2_end-t0_start

!$omp section
    t3_start=ccm_time()
    call invert(m3,n)
    call invert(m3,n)
    t3_end=ccm_time()
    e3=mcheck(m3,n,30)
    t3_start=t3_start-t0_start
    t3_end=t3_end-t0_start

!$omp section
    t4_start=ccm_time()
    call invert(m4,n)
    call invert(m4,n)
    t4_end=ccm_time()
    e4=mcheck(m4,n,40)
    t4_start=t4_start-t0_start
    t4_end=t4_end-t0_start

!$omp end parallel sections

 write(*,1)1,t1_start,t1_end,e1
 write(*,1)2,t2_start,t2_end,e2
 write(*,1)3,t3_start,t3_end,e3
 write(*,1)4,t4_start,t4_end,e4
 1 format("section ",i4," start time= ",g12.5," end time= ",g12.5," error=",g12.5)
 end program


! #############################
program main
    use ReactorClass
    use IOClass
    implicit none

    real(real64)   :: CO2, O2, C
    integer(int32) :: i
    type(Reactor_) :: reactor
    type(IO_)      :: f(3)

    CO2 = 0.0d0 ! mol
    C   = 1.0d0 ! mol
    O2  = 1.0d0 ! mol

    call reactor%init()
    call reactor%put("CO2", CO2)
    call reactor%put("C"  ,   C)
    call reactor%put("O2" ,  O2)

    ! define reactor with reaction coefficient (in here, = 1.0)
    call reactor%define([str("C"),str("O2")],[str("CO2")],1.0d0)
    ! If
    !  a*[A] + b*[B] -> c*[C]
    ! - d A/dt = k[A]^nA*[B]^nB
    ! then please add args
    !  mol_rate=[a,b,c],reaction_order=[nA,nB])

    ! create file
    call f(1)%open("A_mol.txt")
    call f(2)%open("B_mol.txt")
    call f(3)%open("C_mol.txt")
    ! export initial condition
    call f(1)%write(reactor%substances(1)%ptr)
    call f(2)%write(reactor%substances(2)%ptr)
    call f(3)%write(reactor%substances(3)%ptr)

    ! run t=0.0 to 10.0s
    do i=1,1000
      call reactor%run(dt=0.010d0)
      call f(1)%write(reactor%substances(1)%ptr)
      call f(2)%write(reactor%substances(2)%ptr)
      call f(3)%write(reactor%substances(3)%ptr)
    enddo

    ! close files
    call f(1)%close()
    call f(2)%close()
    call f(3)%close()

  end program main
  ! #############################


      SUBROUTINE MB3PYZ( M, N, A, LDA, RCOND, SVLMAX, RANK, SVAL, JPVT,
     $                   TAU, DWORK, ZWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute a rank-revealing RQ factorization of a complex general
C     M-by-N matrix  A,  which may be rank-deficient, and estimate its
C     effective rank using incremental condition estimation.
C
C     The routine uses a truncated RQ factorization with row pivoting:
C                                   [ R11 R12 ]
C        P * A = R * Q,  where  R = [         ],
C                                   [  0  R22 ]
C     with R22 defined as the largest trailing upper triangular
C     submatrix whose estimated condition number is less than 1/RCOND.
C     The order of R22, RANK, is the effective rank of A.  Condition
C     estimation is performed during the RQ factorization process.
C     Matrix R11 is full (but of small norm), or empty.
C
C     MB3PYZ  does not perform any scaling of the matrix A.
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     M       (input) INTEGER
C             The number of rows of the matrix A.  M >= 0.
C
C     N       (input) INTEGER
C             The number of columns of the matrix A.  N >= 0.
C
C     A       (input/output) COMPLEX*16 array, dimension ( LDA, N )
C             On entry, the leading M-by-N part of this array must
C             contain the given matrix A.
C             On exit, the upper triangle of the subarray
C             A(M-RANK+1:M,N-RANK+1:N) contains the RANK-by-RANK upper
C             triangular matrix R22;  the remaining elements in the last
C             RANK  rows, with the array TAU, represent the unitary
C             matrix Q as a product of  RANK  elementary reflectors
C             (see METHOD).  The first  M-RANK  rows contain the result
C             of the RQ factorization process used.
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= max(1,M).
C
C     RCOND   (input) DOUBLE PRECISION
C             RCOND is used to determine the effective rank of A, which
C             is defined as the order of the largest trailing triangular
C             submatrix R22 in the RQ factorization with pivoting of A,
C             whose estimated condition number is less than 1/RCOND.
C             0 <= RCOND <= 1.
C             NOTE that when SVLMAX > 0, the estimated rank could be
C             less than that defined above (see SVLMAX).
C
C     SVLMAX  (input) DOUBLE PRECISION
C             If A is a submatrix of another matrix B, and the rank
C             decision should be related to that matrix, then SVLMAX
C             should be an estimate of the largest singular value of B
C             (for instance, the Frobenius norm of B).  If this is not
C             the case, the input value SVLMAX = 0 should work.
C             SVLMAX >= 0.
C
C     RANK    (output) INTEGER
C             The effective (estimated) rank of A, i.e., the order of
C             the submatrix R22.
C
C     SVAL    (output) DOUBLE PRECISION array, dimension ( 3 )
C             The estimates of some of the singular values of the
C             triangular factor R:
C             SVAL(1): largest singular value of
C                      R(M-RANK+1:M,N-RANK+1:N);
C             SVAL(2): smallest singular value of
C                      R(M-RANK+1:M,N-RANK+1:N);
C             SVAL(3): smallest singular value of R(M-RANK:M,N-RANK:N),
C                      if RANK < MIN( M, N ), or of
C                      R(M-RANK+1:M,N-RANK+1:N), otherwise.
C             If the triangular factorization is a rank-revealing one
C             (which will be the case if the trailing rows were well-
C             conditioned), then SVAL(1) will also be an estimate for
C             the largest singular value of A, and SVAL(2) and SVAL(3)
C             will be estimates for the RANK-th and (RANK+1)-st singular
C             values of A, respectively.
C             By examining these values, one can confirm that the rank
C             is well defined with respect to the chosen value of RCOND.
C             The ratio SVAL(1)/SVAL(2) is an estimate of the condition
C             number of R(M-RANK+1:M,N-RANK+1:N).
C
C     JPVT    (output) INTEGER array, dimension ( M )
C             If JPVT(i) = k, then the i-th row of P*A was the k-th row
C             of A.
C
C     TAU     (output) COMPLEX*16 array, dimension ( MIN( M, N ) )
C             The trailing  RANK  elements of TAU contain the scalar
C             factors of the elementary reflectors.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension ( 2*M )
C
C     ZWORK   COMPLEX*16 array, dimension ( 3*M-1 )
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 computes a truncated RQ factorization with row
C     pivoting of A,  P * A = R * Q,  with  R  defined above, and,
C     during this process, finds the largest trailing submatrix whose
C     estimated condition number is less than 1/RCOND, taking the
C     possible positive value of SVLMAX into account.  This is performed
C     using an adaptation of the LAPACK incremental condition estimation
C     scheme and a slightly modified rank decision test.  The
C     factorization process stops when  RANK  has been determined.
C
C     The matrix Q is represented as a product of elementary reflectors
C
C        Q = H(k-rank+1)' H(k-rank+2)' . . . H(k)', where k = min(m,n).
C
C     Each H(i) has the form
C
C        H = I - tau * v * v'
C
C     where tau is a complex scalar, and v is a complex vector with
C     v(n-k+i+1:n) = 0 and v(n-k+i) = 1; conjg(v(1:n-k+i-1)) is stored
C     on exit in A(m-k+i,1:n-k+i-1), and tau in TAU(i).
C
C     The matrix P is represented in jpvt as follows: If
C        jpvt(j) = i
C     then the jth row of P is the ith canonical unit vector.
C
C     REFERENCES
C
C     [1] Bischof, C.H. and P. Tang.
C         Generalizing Incremental Condition Estimation.
C         LAPACK Working Notes 32, Mathematics and Computer Science
C         Division, Argonne National Laboratory, UT, CS-91-132,
C         May 1991.
C
C     [2] Bischof, C.H. and P. Tang.
C         Robust Incremental Condition Estimation.
C         LAPACK Working Notes 33, Mathematics and Computer Science
C         Division, Argonne National Laboratory, UT, CS-91-133,
C         May 1991.
C
C     NUMERICAL ASPECTS
C
C     The algorithm is backward stable.
C
C     CONTRIBUTOR
C
C     V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1998.
C     Complex version: V. Sima, Research Institute for Informatics,
C     Bucharest, Nov. 2008.
C
C     REVISIONS
C
C     V. Sima, Jan. 2010, following Bujanovic and Drmac's suggestion.
C
C     KEYWORDS
C
C     Eigenvalue problem, matrix operations, unitary transformation,
C     singular values.
C
C    ******************************************************************
C
C     .. Parameters ..
      INTEGER            IMAX, IMIN
      PARAMETER          ( IMAX = 1, IMIN = 2 )
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
      COMPLEX*16         CONE
      PARAMETER          ( CONE = ( 1.0D+0, 0.0D+0 ) )
C     .. Scalar Arguments ..
      INTEGER            INFO, LDA, M, N, RANK
      DOUBLE PRECISION   RCOND, SVLMAX
C     .. Array Arguments ..
      INTEGER            JPVT( * )
      COMPLEX*16         A( LDA, * ), TAU( * ), ZWORK( * )
      DOUBLE PRECISION   DWORK( * ), SVAL( 3 )
C     .. Local Scalars ..
      INTEGER            I, ISMAX, ISMIN, ITEMP, J, JWORK, K, MKI, NKI,
     $                   PVT
      COMPLEX*16         AII, C1, C2, S1, S2
      DOUBLE PRECISION   SMAX, SMAXPR, SMIN, SMINPR, TEMP, TEMP2, TOLZ
C     ..
C     .. External Functions ..
      INTEGER            IDAMAX
      DOUBLE PRECISION   DLAMCH, DZNRM2
      EXTERNAL           DLAMCH, DZNRM2, IDAMAX
C     ..
C     .. External Subroutines ..
      EXTERNAL           XERBLA, ZCOPY, ZLACGV, ZLAIC1, ZLARF, ZLARFG,
     $                   ZSCAL, ZSWAP
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, MIN, SQRT
C     ..
C     .. Executable Statements ..
C
C     Test the input scalar arguments.
C
      INFO = 0
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -4
      ELSE IF( RCOND.LT.ZERO .OR. RCOND.GT.ONE ) THEN
         INFO = -5
      ELSE IF( SVLMAX.LT.ZERO ) THEN
         INFO = -6
      END IF
C
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'MB3PYZ', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      K = MIN( M, N )
      IF( K.EQ.0 ) THEN
         RANK = 0
         SVAL( 1 ) = ZERO
         SVAL( 2 ) = ZERO
         SVAL( 3 ) = ZERO
         RETURN
      END IF
C
      TOLZ  = SQRT( DLAMCH( 'Epsilon' ) )
      ISMIN = 1
      ISMAX = ISMIN + M
      JWORK = ISMAX + M
C
C     Initialize partial row norms and pivoting vector. The first m
C     elements of DWORK store the exact row norms.
C
      DO 10 I = 1, M
         DWORK( I ) = DZNRM2( N, A( I, 1 ), LDA )
         DWORK( M+I ) = DWORK( I )
         JPVT( I ) = I
   10 CONTINUE
C
C     Compute factorization and determine RANK using incremental
C     condition estimation.
C
      RANK = 0
C
   20 CONTINUE
      IF( RANK.LT.K ) THEN
         I = K - RANK
C
C        Determine ith pivot row and swap if necessary.
C
         MKI = M - RANK
         NKI = N - RANK
         PVT = IDAMAX( MKI, DWORK, 1 )
C
         IF( PVT.NE.MKI ) THEN
            CALL ZSWAP( N, A( PVT, 1 ), LDA, A( MKI, 1 ), LDA )
            ITEMP = JPVT( PVT )
            JPVT( PVT ) = JPVT( MKI )
            JPVT( MKI ) = ITEMP
            DWORK( PVT )   = DWORK( MKI )
            DWORK( M+PVT ) = DWORK( M+MKI )
         END IF
C
         IF( NKI.GT.1 ) THEN
C
C           Save A(m-k+i,n-k+i) and generate elementary reflector H(i)
C           to annihilate A(m-k+i,1:n-k+i-1), k = min(m,n).
C               A(m-k+i,1:n-k+i) * H(tau,v)        = [0 , *]         <=>
C               H(conj(tau),v) A(m-k+i,1:n-k+i)^H  = [0 ; *],
C           using H(tau,v)^H = H(conj(tau),v).
C
            CALL ZLACGV( NKI, A( MKI, 1 ), LDA )
            AII = A( MKI, NKI )
            CALL ZLARFG( NKI, A( MKI, NKI ), A( MKI, 1 ), LDA, TAU( I )
     $                 )
         END IF
C
         IF( RANK.EQ.0 ) THEN
C
C           Initialize; exit if matrix is zero (RANK = 0).
C
            SMAX = ABS( A( M, N ) )
            IF ( SMAX.EQ.ZERO ) THEN
               SVAL( 1 ) = ZERO
               SVAL( 2 ) = ZERO
               SVAL( 3 ) = ZERO
               RETURN
            END IF
            SMIN = SMAX
            SMAXPR = SMAX
            SMINPR = SMIN
            C1 = CONE
            C2 = CONE
         ELSE
C
C           One step of incremental condition estimation.
C
            CALL ZCOPY ( RANK, A( MKI, NKI+1 ), LDA, ZWORK( JWORK ), 1 )
            CALL ZLAIC1( IMIN, RANK, ZWORK( ISMIN ), SMIN,
     $                   ZWORK( JWORK ), A( MKI, NKI ), SMINPR, S1, C1 )
            CALL ZLAIC1( IMAX, RANK, ZWORK( ISMAX ), SMAX,
     $                   ZWORK( JWORK ), A( MKI, NKI ), SMAXPR, S2, C2 )
         END IF
C
         IF( SVLMAX*RCOND.LE.SMAXPR ) THEN
            IF( SVLMAX*RCOND.LE.SMINPR ) THEN
               IF( SMAXPR*RCOND.LE.SMINPR ) THEN
C
                  IF( MKI.GT.1 ) THEN
C
C                    Continue factorization, as rank is at least RANK.
C                    Apply H(i) to A(1:m-k+i-1,1:n-k+i) from the right.
C
                     AII = A( MKI, NKI )
                     A( MKI, NKI ) = CONE
                     CALL ZLARF( 'Right', MKI-1, NKI, A( MKI, 1 ), LDA,
     $                           TAU( I ), A, LDA, ZWORK( JWORK ) )
                     A( MKI, NKI ) = AII
C
C                    Update partial row norms.
C
                     DO 30 J = 1, MKI - 1
                        IF( DWORK( J ).NE.ZERO ) THEN
                           TEMP = ABS( A( J, NKI ) ) / DWORK( J )
                           TEMP = MAX( ( ONE + TEMP )*( ONE - TEMP ),
     $                                 ZERO )
                           TEMP2 = TEMP*( DWORK( J ) / DWORK( M+J ) )**2
                           IF( TEMP2.LE.TOLZ ) THEN
                              DWORK( J )   = DZNRM2( NKI-1, A( J, 1 ),
     $                                               LDA )
                              DWORK( M+J ) = DWORK( J )
                           ELSE
                              DWORK( J ) = DWORK( J )*SQRT( TEMP )
                           END IF
                        END IF
   30                CONTINUE
C
                  END IF
C
                  DO 40 I = 1, RANK
                     ZWORK( ISMIN+I-1 ) = S1*ZWORK( ISMIN+I-1 )
                     ZWORK( ISMAX+I-1 ) = S2*ZWORK( ISMAX+I-1 )
   40             CONTINUE
C
                  ZWORK( ISMIN+RANK ) = C1
                  ZWORK( ISMAX+RANK ) = C2
                  SMIN = SMINPR
                  SMAX = SMAXPR
                  RANK = RANK + 1
                  CALL ZLACGV( NKI-1, A( MKI, 1 ), LDA )
                  GO TO 20
               END IF
            END IF
         END IF
      END IF
C
C     Restore the changed part of the (M-RANK)-th row and set SVAL.
C
      IF ( RANK.LT.K .AND. NKI.GT.1 ) THEN
         CALL ZLACGV( NKI-1, A( MKI, 1 ), LDA )
         CALL ZSCAL( NKI-1, -A( MKI, NKI )*TAU( I ), A( MKI, 1 ), LDA )
         A( MKI, NKI ) = AII
      END IF
      SVAL( 1 ) = SMAX
      SVAL( 2 ) = SMIN
      SVAL( 3 ) = SMINPR
C
      RETURN
C *** Last line of MB3PYZ ***
      END


      double complex function fzip(s12,s34,s56)
      implicit none
      double complex I3m,lnrat
      double precision s12,s34,s56,Del12,Del34,Del56,Del3

C     Implementation of BDKW Nucl Phys. 513, 3 (1998)
C     Eqn. (B15).
      Del12=s12-s34-s56
      Del34=s34-s12-s56
      Del56=s56-s12-s34
      Del3=s12*Del12+s34*Del34+s56*Del56

      fzip=Dcmplx((3d0*s34*Del34/Del3**2-1d0/Del3)*s12*s56)
     . *I3m(s12,s34,s56)
     . +Dcmplx((3d0*s56*Del56/Del3**2-0.5d0/Del3)*s12)
     . *lnrat(-s12,-s34)
     . +Dcmplx((3d0*s12*Del12/Del3**2-0.5d0/Del3)*s56)
     . *lnrat(-s56,-s34)
     . -Dcmplx(0.5d0*Del34/Del3)
      end


PROGRAM accuracy
    IMPLICIT NONE

    INTEGER, PARAMETER  ::  double = SELECTED_REAL_KIND (13)
    REAL (KIND = double) :: A, B, C

    A = 2.0_double
    B = 0.1 * A
    C = 0.1_double * A

    PRINT *, A
    PRINT *, B
    PRINT *, C

END PROGRAM accuracy


!----------------------------------------------------------------------
!----------------------------------------------------------------------
!   cir :    Homoclinic Bifurcation in an Electronic Circuit
!                (the same equations as in demo tor)
!----------------------------------------------------------------------
!----------------------------------------------------------------------

      SUBROUTINE FUNC(NDIM,U,ICP,PAR,IJAC,F,DFDU,DFDP)
!     ---------- ----

      IMPLICIT NONE
      INTEGER, INTENT(IN) :: NDIM, ICP(*), IJAC
      DOUBLE PRECISION, INTENT(IN) :: U(NDIM), PAR(*)
      DOUBLE PRECISION, INTENT(OUT) :: F(NDIM)
      DOUBLE PRECISION, INTENT(INOUT) :: DFDU(NDIM,NDIM), DFDP(NDIM,*)

      DOUBLE PRECISION rn,be,ga,r,a3,b3,x,y,z

       rn=PAR(1)
       be=PAR(2)
       ga=PAR(3)
       r =PAR(4)
       a3=PAR(5)
       b3=PAR(6)

       x=U(1)
       y=U(2)
       z=U(3)

       F(1)= ( -(be+rn)*x + be*y - a3*x**3 + b3*(y-x)**3 )/r
       F(2)=  be*x - (be+ga)*y - z - b3*(y-x)**3
       F(3)= y

       IF(IJAC.EQ.0)RETURN

       DFDU(1,1)=( -(be+rn) -3*a3*x**2 - 3*b3*(y-x)**2  )/r
       DFDU(1,2)=( be + 3*b3*(y-x)**2 )/r
       DFDU(1,3)=0

       DFDU(2,1)=be + 3*b3*(y-x)**2
       DFDU(2,2)=-(be+ga) - 3*b3*(y-x)**2
       DFDU(2,3)=-1

       DFDU(3,1)=0
       DFDU(3,2)=1
       DFDU(3,3)=0

      IF(IJAC.EQ.1)RETURN

!      *Parameter derivatives
       DFDP(1,1)=-x/r
       DFDP(2,1)=0
       DFDP(3,1)=0

       DFDP(1,2)=( -x + y )/r
       DFDP(2,2)=x-y
       DFDP(3,2)=0

       DFDP(1,3)=0
       DFDP(2,3)=-y
       DFDP(3,3)=0

       DFDP(1,4)=-F(1)/r
       DFDP(2,4)=0
       DFDP(3,4)=0

       DFDP(1,5)=x**3/r
       DFDP(2,5)=0
       DFDP(3,5)=0

       DFDP(1,6)=(y-x)**3 / r
       DFDP(2,6)=-(y-x)**3
       DFDP(3,6)=0

      END SUBROUTINE FUNC

      SUBROUTINE STPNT(NDIM,U,PAR,T)
!     ---------- -----

      IMPLICIT NONE
      INTEGER, INTENT(IN) :: NDIM
      DOUBLE PRECISION, INTENT(INOUT) :: U(NDIM),PAR(*)
      DOUBLE PRECISION, INTENT(IN) :: T

!----------------------------------------------------------------------
! Problem parameters (only PAR(1-9) are available to the user) :

       PAR(1)=-0.721309D0         ! nu
       PAR(2)=0.6                 ! beta
       PAR(3)=0.0                 ! gamma
       PAR(4)=0.6                 ! r
       PAR(5)=0.328578            ! a_3
       PAR(6)=0.933578            ! b_3

       PAR(11)=36.13              ! Truncated time interval

!----------------------------------------------------------------------
! If IEQUIB >0 put initial equilibrium in PAR(11+i), i=1,...,NDIM :

      PAR(12) = 0.0
      PAR(13) = 0.0
      PAR(14) = 0.0

      END SUBROUTINE STPNT

      SUBROUTINE PVLS(NDIM,U,PAR)
!     ---------- ----

      IMPLICIT NONE
      INTEGER, INTENT(IN) :: NDIM
      DOUBLE PRECISION, INTENT(IN) :: U(NDIM)
      DOUBLE PRECISION, INTENT(INOUT) :: PAR(*)
! Homoclinic bifurcations COMMON block needed here :
      INTEGER ITWIST,ISTART,IEQUIB,NFIXED,NPSI,NUNSTAB,NSTAB,NREV
      COMMON /BLHOM/ ITWIST,ISTART,IEQUIB,NFIXED,NPSI,NUNSTAB,NSTAB,NREV

      INTEGER I

! If IEQUIB =0 put analytic equilibrium in PAR(11+i), i=1..NDIM

      IF(IEQUIB.EQ.0)THEN
        DO I=1,NDIM
          PAR(11+I)= 0.0
        ENDDO
      ENDIF

      END SUBROUTINE PVLS

      SUBROUTINE BCND
      END SUBROUTINE BCND

      SUBROUTINE ICND
      END SUBROUTINE ICND

      SUBROUTINE FOPT
      END SUBROUTINE FOPT


*DECK TRBAK3
      SUBROUTINE TRBAK3 (NM, N, NV, A, M, Z)
C***BEGIN PROLOGUE  TRBAK3
C***PURPOSE  Form the eigenvectors of a real symmetric matrix from the
C            eigenvectors of a symmetric tridiagonal matrix formed
C            by TRED3.
C***LIBRARY   SLATEC (EISPACK)
C***CATEGORY  D4C4
C***TYPE      SINGLE PRECISION (TRBAK3-S)
C***KEYWORDS  EIGENVECTORS OF A REAL SYMMETRIC MATRIX, EISPACK
C***AUTHOR  Smith, B. T., et al.
C***DESCRIPTION
C
C     This subroutine is a translation of the ALGOL procedure TRBAK3,
C     NUM. MATH. 11, 181-195(1968) by Martin, Reinsch, and Wilkinson.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971).
C
C     This subroutine forms the eigenvectors of a REAL SYMMETRIC
C     matrix by back transforming those of the corresponding
C     symmetric tridiagonal matrix determined by  TRED3.
C
C     On Input
C
C        NM must be set to the row dimension of the two-dimensional
C          array parameter, Z, as declared in the calling program
C          dimension statement.  NM is an INTEGER variable.
C
C        N is the order of the matrix.  N is an INTEGER variable.
C          N must be less than or equal to NM.
C
C        NV is an INTEGER variable set equal to the dimension of the
C          array A as specified in the calling program.  NV must not
C          be less than  N*(N+1)/2.
C
C        A contains information about the orthogonal transformations
C          used in the reduction by  TRED3  in its first N*(N+1)/2
C          positions.  A is a one-dimensional REAL array, dimensioned
C          A(NV).
C
C        M is the number of columns of Z to be back transformed.
C          M is an INTEGER variable.
C
C        Z contains the eigenvectors to be back transformed in its
C          first M columns.  Z is a two-dimensional REAL array,
C          dimensioned Z(NM,M).
C
C     On Output
C
C        Z contains the transformed eigenvectors in its first M columns.
C
C     Note that TRBAK3 preserves vector Euclidean norms.
C
C     Questions and comments should be directed to b. s. Garbow,
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C     ------------------------------------------------------------------
C
C***REFERENCES  B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow,
C                 Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen-
C                 system Routines - EISPACK Guide, Springer-Verlag,
C                 1976.
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   760101  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  TRBAK3
C
      INTEGER I,J,K,L,M,N,IK,IZ,NM,NV
      REAL A(*),Z(NM,*)
      REAL H,S
C
C***FIRST EXECUTABLE STATEMENT  TRBAK3
      IF (M .EQ. 0) GO TO 200
      IF (N .EQ. 1) GO TO 200
C
      DO 140 I = 2, N
         L = I - 1
         IZ = (I * L) / 2
         IK = IZ + I
         H = A(IK)
         IF (H .EQ. 0.0E0) GO TO 140
C
         DO 130 J = 1, M
            S = 0.0E0
            IK = IZ
C
            DO 110 K = 1, L
               IK = IK + 1
               S = S + A(IK) * Z(K,J)
  110       CONTINUE
C     .......... DOUBLE DIVISION AVOIDS POSSIBLE UNDERFLOW ..........
            S = (S / H) / H
            IK = IZ
C
            DO 120 K = 1, L
               IK = IK + 1
               Z(K,J) = Z(K,J) - S * A(IK)
  120       CONTINUE
C
  130    CONTINUE
C
  140 CONTINUE
C
  200 RETURN
      END


      SUBROUTINE SB08ED( DICO, N, M, P, ALPHA, A, LDA, B, LDB, C, LDC,
     $                   D, LDD, NQ, NR, BR, LDBR, DR, LDDR, TOL, DWORK,
     $                   LDWORK, IWARN, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To construct, for a given system G = (A,B,C,D), an output
C     injection matrix H and an orthogonal transformation matrix Z, such
C     that the systems
C
C          Q = (Z'*(A+H*C)*Z, Z'*(B+H*D), C*Z, D)
C     and
C          R = (Z'*(A+H*C)*Z, Z'*H, C*Z, I)
C
C     provide a stable left coprime factorization of G in the form
C                   -1
C              G = R  * Q,
C
C     where G, Q and R are the corresponding transfer-function matrices.
C     The resulting state dynamics matrix of the systems Q and R has
C     eigenvalues lying inside a given stability domain.
C     The Z matrix is not explicitly computed.
C
C     Note: If the given state-space representation is not detectable,
C     the undetectable part of the original system is automatically
C     deflated and the order of the systems Q and R is accordingly
C     reduced.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     DICO    CHARACTER*1
C             Specifies the type of the original system as follows:
C             = 'C':  continuous-time system;
C             = 'D':  discrete-time system.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The dimension of the state vector, i.e. the order of the
C             matrix A, and also the number of rows of the matrices B
C             and BR, and the number of columns of the matrix C.
C             N >= 0.
C
C     M       (input) INTEGER
C             The dimension of input vector, i.e. the number of columns
C             of the matrices B and D.  M >= 0.
C
C     P       (input) INTEGER
C             The dimension of output vector, i.e. the number of rows
C             of the matrices C, D and DR, and the number of columns of
C             the matrices BR and DR.  P >= 0.
C
C     ALPHA   (input) DOUBLE PRECISION array, dimension (2)
C             ALPHA(1) contains the desired stability degree to be
C             assigned for the eigenvalues of A+H*C, and ALPHA(2)
C             the stability margin. The eigenvalues outside the
C             ALPHA(2)-stability region will be assigned to have the
C             real parts equal to ALPHA(1) < 0 and unmodified
C             imaginary parts for a continuous-time system
C             (DICO = 'C'), or moduli equal to 0 <= ALPHA(2) < 1
C             for a discrete-time system (DICO = 'D').
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the leading N-by-N part of this array must
C             contain the state dynamics matrix A.
C             On exit, the leading NQ-by-NQ part of this array contains
C             the leading NQ-by-NQ part of the matrix Z'*(A+H*C)*Z, the
C             state dynamics matrix of the numerator factor Q, in a
C             real Schur form. The leading NR-by-NR part of this matrix
C             represents the state dynamics matrix of a minimal
C             realization of the denominator factor R.
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= MAX(1,N).
C
C     B       (input/output) DOUBLE PRECISION array, dimension
C             (LDB,MAX(M,P))
C             On entry, the leading N-by-M part of this array must
C             contain the input/state matrix of the system.
C             On exit, the leading NQ-by-M part of this array contains
C             the leading NQ-by-M part of the matrix Z'*(B+H*D), the
C             input/state matrix of the numerator factor Q.
C             The remaining part of this array is needed as workspace.
C
C     LDB     INTEGER
C             The leading dimension of array B.  LDB >= MAX(1,N).
C
C     C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
C             On entry, the leading P-by-N part of this array must
C             contain the state/output matrix of the system.
C             On exit, the leading P-by-NQ part of this array contains
C             the leading P-by-NQ part of the matrix C*Z, the
C             state/output matrix of the numerator factor Q.
C             The first NR columns of this array represent the
C             state/output matrix of a minimal realization of the
C             denominator factor R.
C             The remaining part of this array is needed as workspace.
C
C     LDC     INTEGER
C             The leading dimension of array C.
C             LDC >= MAX(1,M,P), if N > 0.
C             LDC >= 1,          if N = 0.
C
C     D       (input) DOUBLE PRECISION array, dimension (LDD,MAX(M,P))
C             The leading P-by-M part of this array must contain the
C             input/output matrix. D represents also the input/output
C             matrix of the numerator factor Q.
C             This array is modified internally, but restored on exit.
C             The remaining part of this array is needed as workspace.
C
C     LDD     INTEGER
C             The leading dimension of array D.  LDD >= MAX(1,M,P).
C
C     NQ      (output) INTEGER
C             The order of the resulting factors Q and R.
C             Generally, NQ = N - NS, where NS is the number of
C             unobservable eigenvalues outside the stability region.
C
C     NR      (output) INTEGER
C             The order of the minimal realization of the factor R.
C             Generally, NR is the number of observable eigenvalues
C             of A outside the stability region (the number of modified
C             eigenvalues).
C
C     BR      (output) DOUBLE PRECISION array, dimension (LDBR,P)
C             The leading NQ-by-P part of this array contains the
C             leading NQ-by-P part of the output injection matrix
C             Z'*H, which moves the eigenvalues of A lying outside
C             the ALPHA-stable region to values on the ALPHA-stability
C             boundary. The first NR rows of this matrix form the
C             input/state matrix of a minimal realization of the
C             denominator factor R.
C
C     LDBR    INTEGER
C             The leading dimension of array BR.  LDBR >= MAX(1,N).
C
C     DR      (output) DOUBLE PRECISION array, dimension (LDDR,P)
C             The leading P-by-P part of this array contains an
C             identity matrix representing the input/output matrix
C             of the denominator factor R.
C
C     LDDR    INTEGER
C             The leading dimension of array DR.  LDDR >= MAX(1,P).
C
C     Tolerances
C
C     TOL     DOUBLE PRECISION
C             The absolute tolerance level below which the elements of
C             C are considered zero (used for observability tests).
C             If the user sets TOL <= 0, then an implicitly computed,
C             default tolerance, defined by  TOLDEF = N*EPS*NORM(C),
C             is used instead, where EPS is the machine precision
C             (see LAPACK Library routine DLAMCH) and NORM(C) denotes
C             the infinity-norm of C.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, DWORK(1) returns the optimal value
C             of LDWORK.
C
C     LDWORK  INTEGER
C             The dimension of working array DWORK.
C             LDWORK >= MAX( 1, N*P + MAX( N*(N+5), 5*P, 4*M ) ).
C             For optimum performance LDWORK should be larger.
C
C     Warning Indicator
C
C     IWARN   INTEGER
C             = 0:  no warning;
C             = K:  K violations of the numerical stability condition
C                   NORM(H) <= 10*NORM(A)/NORM(C) occured during the
C                   assignment of eigenvalues.
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 reduction of A to a real Schur form failed;
C             = 2:  a failure was detected during the ordering of the
C                   real Schur form of A, or in the iterative process
C                   for reordering the eigenvalues of Z'*(A + H*C)*Z
C                   along the diagonal.
C
C     METHOD
C
C     The subroutine uses the right coprime factorization algorithm
C     of [1] applied to G'.
C
C     REFERENCES
C
C     [1] Varga A.
C         Coprime factors model reduction method based on
C         square-root balancing-free techniques.
C         System Analysis, Modelling and Simulation,
C         vol. 11, pp. 303-311, 1993.
C
C     NUMERICAL ASPECTS
C                                            3
C     The algorithm requires no more than 14N  floating point
C     operations.
C
C     CONTRIBUTOR
C
C     A. Varga, German Aerospace Center,
C     DLR Oberpfaffenhofen, July 1998.
C     Based on the RASP routine LCFS.
C
C     REVISIONS
C
C     Nov. 1998, V. Sima, Research Institute for Informatics, Bucharest.
C     Dec. 1998, V. Sima, Katholieke Univ. Leuven, Leuven.
C     May  2003, A. Varga, DLR Oberpfaffenhofen.
C     Nov  2003, A. Varga, DLR Oberpfaffenhofen.
C     Sep. 2005, A. Varga, German Aerospace Center.
C
C     KEYWORDS
C
C     Coprime factorization, eigenvalue, eigenvalue assignment,
C     feedback control, pole placement, state-space model.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ONE, ZERO
      PARAMETER         ( ONE = 1.0D0, ZERO = 0.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         DICO
      INTEGER           INFO, IWARN, LDA, LDB, LDBR, LDC, LDD, LDDR,
     $                  LDWORK, M, N, NQ, NR, P
      DOUBLE PRECISION  TOL
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LDA,*), ALPHA(*), B(LDB,*), BR(LDBR,*),
     $                  C(LDC,*), D(LDD,*), DR(LDDR,*), DWORK(*)
C     .. Local Scalars ..
      LOGICAL           DISCR
      INTEGER           KBR, KW
C     .. External Functions ..
      LOGICAL           LSAME
      EXTERNAL          LSAME
C     .. External subroutines ..
      EXTERNAL          AB07MD, DLASET, MA02AD, MA02BD, SB08FD, TB01XD,
     $                  XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         DBLE, MAX, MIN
C     .. Executable Statements ..
C
      DISCR = LSAME( DICO, 'D' )
      IWARN = 0
      INFO  = 0
C
C     Check the scalar input parameters.
C
      IF( .NOT.( LSAME( DICO, 'C' ) .OR. DISCR ) ) 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( ( DISCR .AND. ( ALPHA(1).LT.ZERO .OR. ALPHA(1).GE.ONE
     $                  .OR.   ALPHA(2).LT.ZERO .OR. ALPHA(2).GE.ONE ) )
     $    .OR.
     $    ( .NOT.DISCR .AND. ( ALPHA(1).GE.ZERO .OR. ALPHA(2).GE.ZERO )
     $    ) ) THEN
         INFO = -5
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -7
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -9
      ELSE IF( LDC.LT.1 .OR. ( N.GT.0 .AND. LDC.LT.MAX( M, P ) ) )
     $      THEN
         INFO = -11
      ELSE IF( LDD.LT.MAX( 1, M, P ) ) THEN
         INFO = -13
      ELSE IF( LDBR.LT.MAX( 1, N ) ) THEN
         INFO = -17
      ELSE IF( LDDR.LT.MAX( 1, P ) ) THEN
         INFO = -19
      ELSE IF( LDWORK.LT.MAX( 1, N*P + MAX( N*(N+5), 5*P, 4*M ) ) ) THEN
         INFO = -22
      END IF
      IF( INFO.NE.0 )THEN
C
C        Error return.
C
         CALL XERBLA( 'SB08ED', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( MIN( N, P ).EQ.0 ) THEN
         NQ = 0
         NR = 0
         DWORK(1) = ONE
         CALL DLASET( 'Full', P, P, ZERO, ONE, DR, LDDR )
         RETURN
      END IF
C
C     Compute the dual system G' = (A',C',B',D').
C
      CALL AB07MD( 'D', N, M, P, A, LDA, B, LDB, C, LDC, D, LDD,
     $             INFO )
C
C     Compute the right coprime factorization of G' with
C     prescribed stability degree.
C
C     Workspace needed:      P*N;
C     Additional workspace:  need  MAX( N*(N+5), 5*P, 4*M );
C                            prefer larger.
C
      KBR = 1
      KW  = KBR + P*N
      CALL SB08FD( DICO, N, P, M, ALPHA, A, LDA, B, LDB, C, LDC, D, LDD,
     $             NQ, NR, DWORK(KBR), P, DR, LDDR, TOL, DWORK(KW),
     $             LDWORK-KW+1, IWARN, INFO )
      IF( INFO.EQ.0 ) THEN
C
C        Determine the elements of the left coprime factorization from
C        those of the computed right coprime factorization and make the
C        state-matrix upper real Schur.
C
         CALL TB01XD( 'D', NQ, P, M, MAX( 0, NQ-1 ), MAX( 0, NQ-1 ),
     $                A, LDA, B, LDB, C, LDC, D, LDD, INFO )
C
         CALL MA02AD( 'Full', P, NQ, DWORK(KBR), P, BR, LDBR )
         CALL MA02BD( 'Left', NQ, P, BR, LDBR )
C
      END IF
C
      DWORK(1) = DWORK(KW) + DBLE( KW-1 )
C
      RETURN
C *** Last line of SB08ED ***
      END


       module calc_maxjutt

        use polsynchemis, only: polsynchth

       contains

!         subroutine calc_maxjutt_subroutine(nu,ncgs,bcgs,tcgs,usim,incang,maxjutt_args,ktotal)
         subroutine calc_maxjutt_subroutine(nu,ncgs,bcgs,tcgs,incang,maxjutt_args,ktotal)
           double precision, dimension(:), intent(in) :: nu
           double precision, dimension(:), intent(in) :: ncgs,bcgs,tcgs,incang
           double precision, dimension(:), intent(in) :: maxjutt_args
!6 weights, 1 delta
!           double precision, dimension(:), intent(in) :: usim

           double precision, dimension(size(maxjutt_args) - 1) :: weights_arr, i_arr, delta_arr
           double precision, dimension(size(ncgs)) :: tcgs_min
!           double precision, dimension(size(ncgs)) :: theta_min
           double precision :: delta, a, dwsum

           double precision, dimension(size(ncgs),11) :: ktemp
           double precision, dimension(size(ncgs),11),intent(out) :: ktotal
!           ones = 1d0
!           write(6,*) 'maxjutt: ',size(maxjutt_args),size(weights_arr)
           a = 3d0
!Note derivation assumes relativistic a = 3.0
           delta = maxjutt_args(1) !first argument is delta
           weights_arr = maxjutt_args(2:)/SUM(maxjutt_args(2:)) !normalize
!           write(6,*) 'maxjutt weights: ',weights_arr,delta
           i_arr = (/ (I, I=0,size(weights_arr)-1) /) !indices
           delta_arr = delta**i_arr !all deltas to be multiplied by thetamin
           dwsum = SUM(weights_arr * delta_arr)

!           theta_min = (usim/ncgs)/a/dwsum !USIM

!            u_e = 3 ncgs k tcgs
!            theta_min = 3 k tcgs / a / dwsum / m / c / c
!            k tcgs_min = theta_min * m * c * c =
!            = 3 k tcgs / a / dwsum
!            = k tcgs / dwsum
           tcgs_min = tcgs/dwsum
!check if that second a is necessary

!           write(6,*) weights_arr
!           write(6,*) delta_arr
!N array of theta_mins calculated to satisfy sum energy = usim
!3/5/2015 Checking thetamin calculation. Weight calculation is straightforward. Comparing to edf.py
!Comparison revealed a = 3 discrepancy, now in agreement
!weights_arr and delta_arr working as intended

!pseudocode
!ktotal = whatever
!convert units to cgs?
!for i in (1,size(weights_arr)):
!    ktemp  = polsynchth(nu,weights_arr(i)*ncgs,bcgs,thetamin*delta_arr(i),e%incang,Kth)
!    ktotal = ktotal + ktemp
!return K to emis.f90
           ktotal = 0d0
           do i=1,size(weights_arr)
              ktemp = 0d0
!              write(6,*) 'calc_maxjutt call polsynchth: ',weights_arr(i),ncgs(1),bcgs(1),tcgs_min(1)*delta_arr(1),incang(1)
              call polsynchth(nu,weights_arr(i)*ncgs,bcgs,tcgs_min*delta_arr(i),incang,ktemp)
              ktotal = ktotal + ktemp
           enddo
!           write(6,*) 'maxjutt loop: ',tcgs_min,delta_arr,i,size(weights_arr)
         end subroutine calc_maxjutt_subroutine

         end module calc_maxjutt


C Copyright 2009-2010 by PyMMLib Development Group (see AUTHORS file)
C This code is part of the PyMMLib distribution and governed by
C its license.  Please see the LICENSE file that should have been
C included as part of this package.
C
C DESCRIPTION: tls_residuals - Fortran77 subroutines and functions
C used for validation PDB structures.
C AUTHORS:
C  - P. Christoph Champ (PCC),
C  - Frank Zucker,
C  - Ethan A. Merritt (EAM)
C REQUIREMENTS: f2py (part of the Numpy package)
C
************************************************************************
* UPDATES
* PCC Sep 2009  - added sum_square_diff() + diff_trace_uv()
* PCC Aug 2009  - initial version
*
************************************************************************

C     ******************************************************************
      SUBROUTINE calc_ccuij(corwij,U,V)
C     ******************************************************************
C --- Calculates the correlation coefficient of Uij and Vij
c      implicit none
      integer MAXATOM
      parameter (MAXATOM=10000)
      real inv3x3
      real U(3,3),  UINV(3,3)
      real V(3,3),  VINV(3,3)
      real W(3,3),  WINV(3,3)
      real          ZINV(3,3)
      real VV(3,3), VVINV(3,3)
      real det, det_U, det_V, det_W, det_VV
      real corwij
      real uijcor(MAXATOM)
Cf2py intent(in) u, v
Cf2py intent(out) corwij
Cf2py depend(u, v) corwij

c Take inverses of the two matrices
      det_U = inv3x3(Uinv, U)
      det_V = inv3x3(Vinv, V)

      if (det_U .le. 0 .or. det_V .le. 0 .or.
     *     U(1,1) .le. 0 .or. V(1,1) .le. 0 .or.
     *     U(1,1)*U(2,2) .le. U(1,2)*U(2,1) .or.
     *     V(1,1)*V(2,2) .le. V(1,2)*V(2,1)) then
          corwij = 0
          return
      endif

c And their sum (for the covariance)
      call add3x3( Winv, Uinv, Vinv )
      det_W = 1. / inv3x3( W, Winv )

      if (det_W .le. 0) then
          corwij = 0
          return
      endif

c Now the correlation coefficient
      corwij = (8.0 * det_W) / sqrt( det_U * det_V )
      corwij = sqrt(corwij)
c     if (corwij .gt. 1.00001) write (0,*) ' BOGUS CCuij = ',corwij

      return
      end

C     ******************************************************************
      SUBROUTINE sum_square_diff(sqd,U,V)
C     ******************************************************************
C --- Calculates the sum of the differences of anisotropic ADP tensors
C --- U and V squared.
C --- sqd = abs(numpy.sum(numpy.subtract(U,V)**2))
      real U(3,3)
      real V(3,3)
      real W(3,3)
      real sqd, WSUM
Cf2py intent(in) u, v
Cf2py intent(out) sqd
Cf2py depend(u, v) sqd

      call subtract3x3(W, U, V)
      call sum3x3(WSUM, W**2)

      sqd = abs(WSUM)
      return
      end

C     ******************************************************************
      SUBROUTINE diff_trace_uv(dtuv,U,V)
C     ******************************************************************
C --- Calculates the trace difference of anisotropic ADP tensors U and V.
C --- dtuv = abs((numpy.trace(U) - numpy.trace(V))/ 3.0)
      real U(3,3)
      real V(3,3)
      real W(3,3)
      real dtuv, Utrace, Vtrace
Cf2py intent(in) u, v
Cf2py intent(out) dtuv
Cf2py depend(u, v) dtuv

      call trace3x3(Utrace, U)
      call trace3x3(Vtrace, V)

C      write(*,*) 'U-V = ', (Utrace - Vtrace)

      dtuv = abs((Utrace - Vtrace) / 3.0)
      return
      end

C     ******************************************************************
      SUBROUTINE rosenfeld(r,Upos,Vpos,U,V)
C     ******************************************************************
C --- Calculates the "Rosenfeld" of anisotropic ADP tensors U and V.
C --- r = abs(Un - Vn)
C
C     a/b = x,y,z of U/b
C     d   = distance between a, b
C
C     n = numpy.array([(a[0] - b[0])/d, (a[1] - b[1])/d, (a[2] - b[2])/d])
C     Un = numpy.dot(numpy.dot(n, U), numpy.transpose(n))
C     Vn = numpy.dot(numpy.dot(n, V), numpy.transpose(n))
C     return abs(Un - Vn)
C----------------------
      real U(3,3), Upos(3), Un, U13(1,3)
      real V(3,3), Vpos(3), Vn, V13(1,3)
      real d, n(1,3), nT(3,1), r
Cf2py intent(in) upos, vpos, u, v
Cf2py intent(out) r
Cf2py depend(u, v) r

      d = sqrt( (Upos(1)-Vpos(1))**2 +
     &          (Upos(2)-Vpos(2))**2 +
     &          (Upos(3)-Vpos(3))**2 )

      do j=1,3
          n(1,j) = (Upos(j)-Vpos(j))/d
          nT(j,1) = n(1,j)
      enddo

      call matmlt1x3(U13, n, U)
      call matmlt1x3(V13, n, V)
      Un = dot(U13, nT)
      Vn = dot(V13, nT)

      r = abs(Un - Vn)

      return
      end

C     ******************************************************************
      SUBROUTINE project_U(UMAT,VEC,UPROJ)
C     ******************************************************************
C --- Calculate projection of UMAT parallel to vector VEC
C --- Assume orthogonal coordinates

      REAL UMAT(6),VEC(3),UPROJ
      REAL V1(3)

      VEC2 = VEC(1)**2 + VEC(2)**2 + VEC(3)**2

      V1(1) = UMAT(1)*VEC(1) + UMAT(4)*VEC(2) + UMAT(5)*VEC(3)
      V1(2) = UMAT(4)*VEC(1) + UMAT(2)*VEC(2) + UMAT(6)*VEC(3)
      V1(3) = UMAT(5)*VEC(1) + UMAT(6)*VEC(2) + UMAT(3)*VEC(3)

      UPROJ = (VEC(1)*V1(1) + VEC(2)*V1(2) + VEC(3)*V1(3))/VEC2

      END

********************************************************************************
*                 MATRIX MANIPULATION SUBROUTINES AND FUNCTIONS                *
********************************************************************************

C     ******************************************************************
      SUBROUTINE array(A,N,M)
C     ******************************************************************
C     INCREMENT THE FIRST ROW AND DECREMENT THE FIRST COLUMN OF A
      INTEGER N,M,I,J
      REAL*8 A(N,M)
Cf2py intent(in,out,copy) a
Cf2py integer intent(hide),depend(a) :: n=shape(a,0), m=shape(a,1)
      DO J=1,M
         A(1,J) = A(1,J)
      ENDDO
      DO I=1,N
         A(I,1) = A(I,1)
      ENDDO
      END

C     ******************************************************************
      SUBROUTINE array3x1(A,N,M)
C     ******************************************************************
C     INCREMENT THE FIRST ROW AND DECREMENT THE FIRST COLUMN OF A
      INTEGER N,M,I,J
      REAL*8 A(N,M)
C***Cf2py intent(in,out,copy) a
C***Cf2py integer intent(hide),depend(a) :: n=shape(a,0), m=shape(a,1)
      DO J=1,M
         A(1,J) = A(1,J)
      ENDDO
      DO I=1,N
         A(I,1) = A(I,1)
      ENDDO
      END

C     ******************************************************************
      SUBROUTINE mul3x3(C,A,B)
C     multiply a 3x3 matrix/array
C     ******************************************************************
C --- A SUBROUTINE FOR MULTIPLYING TWO 3*3 MATRICES TOGETHER.
      real A(3,3), B(3,3), C(3,3)
      integer i,j
C***Cf2py intent(in) a, b
C***Cf2py intent(out) c
C***Cf2py depend(a) c
      do i = 1,3
      do j = 1,3
          C(i,j) = A(i,1)*B(1,j) + A(i,2)*B(2,j) + A(i,3)*B(3,j)
      enddo
      enddo
      return
      end

C     ******************************************************************
      SUBROUTINE matmlt3x3(C,A,B)
C     multiply a 3x3 matrix/array
C     ******************************************************************
C --- A SUBROUTINE FOR MULTIPLYING TWO 3*3 MATRICES TOGETHER.
      real A(3,3), B(3,3), C(3,3)
      integer i,j
C***Cf2py intent(in) a, b
C***Cf2py intent(out) c
C***Cf2py depend(a) c
      do i = 1,3
      do j = 1,3
          C(i,j) = A(i,1)*B(j,1) + A(i,2)*B(j,2) + A(i,3)*B(j,3)
      enddo
      enddo
      return
      end

C     ******************************************************************
      SUBROUTINE matmlt1x3(C,A,B)
C     ******************************************************************
C --- A SUBROUTINE FOR MULTIPLYING (1x3)*(3x3) MATRICES TOGETHER.
      real A(1,3), B(3,3), C(1,3)
      integer i,j

      i = 1
      do j = 1,3
          C(i,j) = A(i,1)*B(j,1) + A(i,2)*B(j,2) + A(i,3)*B(j,3)
      enddo
      return
      end

C     ******************************************************************
      SUBROUTINE trn3x3(B,A)
C     ******************************************************************
C --- transpose a 3x3 matrix/array
      real    A(3,3), B(3,3)
      integer i, j
C***Cf2py intent(in) a
C***Cf2py intent(out) b
C***Cf2py depend(a) b
      do i = 1, 3
      do j = 1, 3
          B(i,j) = A(j,i)
      enddo
      enddo
      return
      end

C     ******************************************************************
      subroutine add3x3(C,A,B)
C     ******************************************************************
C --- add a 3x3 matrix/array
      real A(3,3), B(3,3), C(3,3)
      integer i,j
C***Cf2py intent(in) a, b
C***Cf2py intent(out) c
C***Cf2py depend(a) c
      do i = 1,3
      do j = 1,3
          C(i,j) = A(i,j) + B(i,j)
      enddo
      enddo
      return
      end

C     ******************************************************************
      subroutine sum3x3(B,A)
C     ******************************************************************
C --- sum a 3x3 matrix/array
      real A(3,3), B
      integer i,j
C***Cf2py intent(in) a
C***Cf2py intent(out) b
C***Cf2py depend(a) b
      B = 0.0
      do i = 1,3
      do j = 1,3
          B = B + A(i,j)
      enddo
      enddo
      return
      end

C     ******************************************************************
      subroutine subtract3x3(C,A,B)
C     ******************************************************************
C --- subtract a 3x3 matrix/array
      real A(3,3), B(3,3), C(3,3)
      integer i,j
C***Cf2py intent(in) a, b
C***Cf2py intent(out) c
C***Cf2py depend(a) c
      do i = 1,3
      do j = 1,3
          C(i,j) = A(i,j) - B(i,j)
      enddo
      enddo
      return
      end

C     ******************************************************************
      subroutine trace3x3(T,A)
C     ******************************************************************
C --- trace of a 3x3 matrix/array
      real A(3,3), T
      integer i
C***Cf2py intent(in) a
C***Cf2py intent(out) t
C***Cf2py depend(a) t
      T = 0.0
      do i = 1,3
          T = T + A(i,i)
      enddo
      return
      end

C     ******************************************************************
      SUBROUTINE CROSS(B,C,A)
C     ******************************************************************
C --- cross product of two 3x3 matrices/arrays
      REAL A(3),B(3),C(3)
      A(1)=B(2)*C(3)-C(2)*B(3)
      A(2)=B(3)*C(1)-C(3)*B(1)
      A(3)=B(1)*C(2)-C(1)*B(2)
      RETURN
      END

C     ******************************************************************
      FUNCTION DOT(A,B)
C     ******************************************************************
C --- dot product of two 3x3 matrices/arrays
      REAL A(3),B(3)
      DOT = A(1)*B(1) + A(2)*B(2) + A(3)*B(3)
      RETURN
      END

C     ******************************************************************
      FUNCTION inv3x3( A, B )
C     ******************************************************************
C --- inverse of a 3x3 matrix/array
      REAL A(3,3),B(3,3),C(3,3),D
      CALL CROSS(B(1,2),B(1,3),C(1,1))
      CALL CROSS(B(1,3),B(1,1),C(1,2))
      CALL CROSS(B(1,1),B(1,2),C(1,3))
      D=DOT(B(1,1), C(1,1))
      IF (ABS(D) .LE. 1.E-30) THEN
          inv3x3 = 0.0
          RETURN
      ENDIF
      DO I=1,3
      DO J=1,3
          A(I,J) = C(J,I)/D
      ENDDO
      ENDDO
      inv3x3 = D
      RETURN
      END

C     ******************************************************************
      subroutine assert (logic, message)
C     ******************************************************************
      logical logic
      character*(*) message
      if (logic) return
      write(0,*) '>>> ',message,' <<<'
      stop
      end

************************************************************************
*              Matrix inversion via LU decomposition                   *
*       adapted from Numerical Recipes in Fortran (1986)               *
************************************************************************
*
CCC     input  NxN matrix A is replaced by its LU decomposition
CC      output index(N) records row permutation due to pivoting
C       output D is parity of row permutations
c
C     ******************************************************************
        subroutine ludcmp( A, n, index, D )
C     ******************************************************************
        implicit  NONE
        integer   n,index(n)
        real      A(n,n)
        real      D

        integer   i,imax,j,k
        real      aamax,dum,sum
        integer    NMAX
        parameter (NMAX=10)
        real      vv(NMAX)

        d = 1.
        do i=1,n
            aamax = 0.
            do j=1,n
                if (abs(A(i,j)).gt.aamax) aamax = abs(A(i,j))
            enddo
            call assert(aamax.ne.0.,'Singular matrix')
            vv(i) = 1. / aamax
        enddo
        do j=1,n
            if (j.gt.1) then
                do i=1,j-1
                    sum = A(i,j)
                    if (i.gt.1) then
                        do k=1,i-1
                            sum = sum - A(i,k)*A(k,j)
                        enddo
                        A(i,j) = sum
                    endif
                enddo
            endif
            aamax = 0.
            do i=j,n
                sum = A(i,j)
                if (j.gt.1) then
                    do k=1,j-1
                        sum = sum - A(i,k)*A(k,j)
                    enddo
                    A(i,j) = sum
                endif
                dum = vv(i) * abs(sum)
                if (dum.ge.aamax) then
                    imax = i
                    aamax = dum
                endif
            enddo
            if (j.ne.imax) then
                do k=1,n
                    dum = A(imax,k)
                    A(imax,k) = A(j,k)
                    A(j,k) = dum
                enddo
                d = -d
                vv(imax) = vv(j)
            endif
            index(j) = imax
            call assert(A(j,j).ne.0.,'Singular matrix')
            if (j.ne.n) then
                dum = 1. / A(j,j)
                do i=j+1,n
                    A(i,j) = A(i,j) * dum
                enddo
            endif
        enddo
        return
        end

C     ******************************************************************
        subroutine lubksb( A, N, index, B )
C     ******************************************************************
CCC     corresponding back-substitution routine
CC
C
        implicit NONE
        integer  n, index(n)
        real     A(n,n), B(n)

        integer  i,ii,j,ll
        real     sum

        ii = 0
        do i=1,n
            ll = index(i)
            sum = B(ll)
            B(ll) = B(i)
            if (ii.ne.0) then
                do j=ii,i-1
                    sum = sum - A(i,j)*B(j)
                enddo
            else if (sum.ne.0.) then
                ii = i
            endif
            B(i) = sum
        enddo

        do i=n,1,-1
            sum = B(i)
            if (i.lt.n) then
                do j=i+1,n
                    sum = sum - A(i,j)*B(j)
                enddo
            endif
            B(i) = sum / A(i,i)
        enddo
        return
        end

************************************************************************
* Find eigenvalues and eigenvectors of nxn symmetric matrix using      *
* cyclic Jacobi method. NP is (Fortran) physical storage dimension.    *
* On return A is destroyed, D contains eigenvalues,and each column of  *
* V is a normalized eigenvector                                        *
* Adapted from Numerical Recipes in Fortran (1986)                     *
* We only need it for 3x3 symmetric matrices, so it's overkill.        *
************************************************************************
CCC
CC
      subroutine eigenvalues(eigens,U)
C --- sqd = abs(numpy.sum(numpy.subtract(U,V)**2))
      real U(3,3)
      real EIGENS(3), EVECS(4,4)
Cf2py intent(in) u
Cf2py intent(out) eigens
Cf2py depend(u) eigens

      call jacobi(U,3,4,EIGENS,EVECS)

c     Units of this matrix are A**2; we want values in A
      do i = 1,3
          if (EIGENS(i).gt.0.) then
              EIGENS(i) = sqrt(EIGENS(i))
          else
C             write (noise,*) 'Non-positive definite ellipsoid!'
              EIGENS(i) = 0.
          endif
      enddo

      return
      end
C
        subroutine jacobi( A, n, np, D, V )
C                  jacobi(UU, 3, 4, EIGENS, EVECS )
        PARAMETER (NMAX=4)
c       Machine dependent! (converge when off-diagonal sum is less than this)
        PARAMETER (TINY = 1.e-37)
        real A(np,np), D(n), V(np,np)
        real B(NMAX), Z(NMAX)
C *** Cf2py intent(in) a, n, np
C *** Cf2py intent(out) eigens, evecs
C *** Cf2py depend(a) eigens, evecs
c
        call assert(n.le.NMAX,'Matrix too big for eigenvector routine')

c
c       Initialize V to identity matrix, B and D to diagonal of A
        do ip = 1,n
        do iq = 1,n
            V(ip,iq) = 0.0
        enddo
        V(ip,ip) = 1.0
        B(ip) = A(ip,ip)
        D(ip) = B(ip)
        Z(ip) = 0.0
        enddo
        nrot = 0

c
c       50 sweeps is never expected to happen; Press et al (1986) claim
c       6 to 10 are typical for moderate matrix sizes
c       Empirical trials of rastep show 6 sweeps, 8-10 rotations
        do i = 1,50
            sm = 0.0
            do ip = 1,n-1
            do iq = ip+1,n
                sm = sm+abs(A(ip,iq))
            enddo
            enddo
            if (sm .lt. TINY) return
c           After 4 sweeps skip rotation if the off-diagonal is small
            if (i .lt. 4) then
                thresh = 0.2*sm/(n*n)
            else
                thresh = 0.0
            endif
            do ip = 1,n-1
            do iq = ip+1,n
                g = 100. * abs(A(ip,iq))
                if ((i.gt.4) .and.
     &              (abs(D(ip)) + g .eq. abs(D(ip))) .and.
     &              (abs(D(iq)) + g .eq. abs(D(iq)))) then
                    A(ip,iq) = 0.0
                else if (abs(A(ip,iq)).gt.thresh) then
                    h = D(iq) - D(ip)
                    if (abs(h) + g .eq. abs(h)) then
                        t = A(ip,iq) / h
                    else
                        theta = 0.5 * h / A(ip,iq)
                        t = 1. / (abs(theta) + sqrt(1.+theta*theta))
                        if (theta.lt.0.) t = -t
                    endif
                    c = 1./sqrt(1.+t*t)
                    s = t * c
                    tau = s/(1.+c)
                    h = t * A(ip,iq)
                    Z(ip) = Z(ip) - h
                    Z(iq) = Z(iq) + h
                    D(ip) = D(ip) - h
                    D(iq) = D(iq) + h
                    A(ip,iq) = 0.0
                    do j = 1,ip-1
                        g = A(j,ip)
                        h = A(j,iq)
                        A(j,ip) = g - s*(h+g*tau)
                        A(j,iq) = h + s*(g-h*tau)
                    enddo
                    do j = ip+1,iq-1
                        g = A(ip,j)
                        h = A(j, iq)
                        A(ip,j) = g - s*(h+g*tau)
                        A(j,iq) = h + s*(g-h*tau)
                    enddo
                    do j = iq+1,n
                        g = A(ip,j)
                        h = A(iq,j)
                        A(ip,j) = g - s*(h+g*tau)
                        A(iq,j) = h + s*(g-h*tau)
                    enddo
                    do j = 1,n
                        g = V(j,ip)
                        h = V(j,iq)
                        V(j,ip) = g - s*(h+g*tau)
                        V(j,iq) = h + s*(g-h*tau)
                    enddo
                    nrot = nrot + 1
                endif
            enddo
            enddo
c
c           Update D with sum and reinitialize Z
            do ip = 1,n
                B(ip) = B(ip) + Z(ip)
                D(ip) = B(ip)
                Z(ip) = 0.0
            enddo
        enddo
        call assert(.false.,'Failed to find eigenvectors')
        return
        end
c


module game2048
    implicit none
    integer(kind=4),parameter :: size=4, full_size=16
    integer(kind=4) :: status(size, size) = 0

contains
    subroutine game_start()
        implicit none
        real :: r
        integer :: x, y, choose
        call random_seed()
        call random_number(r)
        x = ceiling(r*4)
        call random_number(r)
        y = ceiling(r*4)
        status = 0
        status(x, y) = 2
        write(*,"(A20)") "This is a 2048 game;"
        write(*,"(A54)") "use 'w'(up), 's'(down), 'a'(left), 'd'(right) to play."
        write(*,"(A11)", advance="NO") "Ready?[Y/n]"
        call getchar(choose)
        if (choose /= ichar('Y') .and. choose /= ichar('y')) stop
        call clean_console()
        call print_frame()
        do while (step())
            continue
        end do
    end subroutine game_start

    subroutine print_frame()
        implicit none
        character(len=30) :: line
        integer :: i, j
        line = repeat('-', 30)
        call set_cursor_potition(0, 0)
        write(*,"(A30)") line
        do i=1,size
            do j=1,size
                if (status(i,j)/=0) then
                    write(*,"('| ',I4,1X)", advance="NO") status(i,j)
                else
                    write(*,"(A1,6X)", advance="NO") "|"
                end if
            end do
            write(*,"(' |',/,A30)") line
        end do
    end subroutine print_frame

    function shift2048(change)
        implicit none
        integer(kind=4),intent(in) :: change(size)
        integer(kind=4) :: shift2048(size)
        integer(kind=4) :: temp(size)
        integer :: read_idx, write_idx, i
        temp = 0
        temp = pack(change, change/=0, temp)
        read_idx = count(temp /= 0)
        shift2048 = 0
        write_idx = 1
        i = 1
        do while(i <= read_idx)
            if(i < size .and. temp(i)==temp(i+1)) then
                shift2048(write_idx) = temp(i) * 2
                write_idx = write_idx + 1
                i  = i + 2
            else
                shift2048(write_idx) = temp(i)
                write_idx = write_idx + 1
                i = i + 1
            end if
        end do
        return
    end function shift2048

    subroutine change_status(direction)
        implicit none
        character(len=*),intent(in) :: direction
        integer :: i
        integer(kind=4) :: temp(size)
        select case(direction)
        case("UP")
            do i=1,size
                temp = shift2048(status(:,i))
                status(:,i) = temp
            end do
        case("DOWN")
            do i=1,size
                temp = shift2048(status(size:1:-1, i))
                status(size:1:-1, i) = temp
            end do
        case("LEFT")
            do i=1,size
                temp = shift2048(status(i,:))
                status(i,:) = temp
            end do
        case("RIGHT")
            do i=1,size
                temp = shift2048(status(i,size:1:-1))
                status(i, size:1:-1) = temp
            end do
        case default
            continue
        end select
        return
    end subroutine change_status

    subroutine add_new()
        implicit none
        integer(kind=4) :: temp(full_size)
        integer :: zero_counts, i, rand_num, p
        real :: rnum
        zero_counts = count(status==0)
        if (zero_counts == 0) return
        call random_seed()
        call random_number(rnum)
        rand_num = floor(rnum*zero_counts)
        temp = reshape(status, shape(temp))
        do i=1, full_size
            zero_counts = zero_counts - count((/temp(i)==0/))
            if(zero_counts == rand_num) then
                call random_number(rnum)
                select case(maxval(temp))
                case(64)
                    p = floor(rnum*8.0)
                case(128)
                    p = floor(rnum*5.0)
                case(256)
                    p = floor(rnum*3.0)
                case(512)
                    p = floor(rnum*2.0)
                case(1024)
                    p = floor(rnum*1.5)
                case default
                    p = 1
                end select
                if (p==0) then
                    temp(i) = 4
                else
                    temp(i) = 2
                endif
                exit
            end if
        end do
        status = reshape(temp, shape(status))
    end subroutine add_new

    logical function step()
        implicit none
        integer(kind=4) :: ch
        call getch(ch)
        select case(ch)
        case(ichar('w'),72,65)
            call change_status("UP")
        case(ichar('s'),80,66)
            call change_status("DOWN")
        case(ichar('a'),75,68)
            call change_status("LEFT")
        case(ichar('d'),77,67)
            call change_status("RIGHT")
        case(ichar('q'),ichar('Q'))
            write(*,"(A9)") "You quit!"
            step = .false.
            return
        case default
            step = .true.
            return
        end select
        select case(check_status())
        case(0)
            continue
        case(1)
            call print_frame()
            write(*,"(A10)") "You win!!!"
            step = .false.
            return
        case(-1)
            call print_frame()
            write(*,"(A9)") "You fail!"
            step = .false.
            return
        case default
            call print_frame()
            write(*,"(A5)") "error"
            step = .false.
            return
        end select
        call add_new()
        call print_frame()
        step = .true.
        return
    end function step

    integer function check_status()
        implicit none
        integer :: i, j
        if (any(status == 2048)) then
            check_status = 1
            return
        end if
        if (any(status == 0)) then
            check_status = 0
            return
        end if
        do i=1,size
            do j=1,size-1
                if(status(i,j) == status(i,j+1)) then
                    check_status = 0
                    return
                end if
            end do
        end do
        do j=1,size
            do i=1,size-1
                if(status(i,j) == status(i+1,j)) then
                    check_status = 0
                    return
                end if
            end do
        end do
        check_status = -1
        return
    end function check_status
end module game2048

program game
    use game2048
    implicit none
    call game_start()
end program game


program test_iany
implicit none
integer, parameter :: vm_read = int(Z'0010')
integer, parameter :: vm_write = int(Z'0020')
integer, parameter :: dup_handle = int(Z'0040')
integer, parameter :: create_process = int(Z'0080')
print "(z8.8)",ior(vm_read,ior(vm_write,ior(dup_handle,create_process)))
print "(z8.8)",iany([vm_read,vm_write,dup_handle,create_process])
end program test_iany
! output:
! 000000F0
! 000000F0


 SUBROUTINE stre02_6 (mat,l,stres,j)

 ! computes the internal nodal forces  1D (truss elements)
 ! for rubbers
 USE mat_dba, ONLY : mater
 IMPLICIT NONE
 REAL (kind=8), INTENT(IN) :: l  !lambda
 REAL (kind=8), INTENT(IN OUT) :: stres(:)
 REAL (kind=8), INTENT(OUT) :: j
 TYPE (mater), POINTER :: mat
 !  local variables
 REAL (kind=8) le,dl,yistr,signo,efpst,beta,db
 INTEGER (kind=4) :: model
 REAL (kind=8) :: pp(2),p(12) ,k
 LOGICAL :: plast

 !INTERFACE
 !  INCLUDE 'rubber1d.h'
 !END INTERFACE

 !     evaluates incremental and total stress

 p = mat%prope(7:18)
 k = mat%prope(4)
 model = mat%matdef(8)         !strain energy model
 plast =  mat%matdef(3) > 1
 IF( plast ) pp = mat%propp(1:2)

 IF( plast )THEN
   ! ! implicit analysis (last converged values)
   ! stres(4:6) = stres(8:10)     !plastic strain, back stress, eq.pl.st
   ! stres(7) = 0d0               !dl
   le = l/EXP(stres(4))           !elastic strain
   efpst = stres(6)               !plastic strain
   yistr = pp(1) + pp(2)*efpst    !linear hardening

   CALL rubber1d(p,le,plast,model,beta,db)

   dl = ABS(beta) - yistr       !yield function

   IF( dl > 0d0 )THEN
     signo = 1d0                                  !strain sign
     IF(beta < 0d0) signo = -1d0
     DO
       dl = dl / (db+pp(2))       !consistency param.
       le = le/EXP(dl*signo)      !elastic lambda
       CALL rubber1d(p,le,plast,model,beta,db)
       efpst = efpst + dl
       yistr = pp(1) + pp(2)*efpst    !linear hardening
       dl = ABS(beta) - yistr        !yield function
       IF( ABS(dl) < 1d-4 )EXIT
     END DO
     stres(4) = LOG(l/le)                         !plastic strain
     !stres(5) = stres(5) + kinet*stres(4)        !back stress
     !stres(6) = ABS(stres(4))                    !effective plastic strain
     stres(6) = efpst                             !effective plastic strain
     !stres(7) = dl                               !implicit analysis
   END IF
   stres(2) = beta        !converged Kirchhoff stress
 ELSE
   CALL rubber1d(p,l,plast,model,beta,db)
   stres(2) = beta*l**2        !converged Kirchhoff stress
 END IF

 IF( k > 0d0 )THEN
   j = EXP(beta/2d0/k)    !volumetric
 ELSE
   j = 1d0
 END IF

 RETURN
 END SUBROUTINE stre02_6