      subroutine gcbd(indgc,simul,nomf,n,x,f,g,imp,io,zero,
     &napmax,itmax,epsf,epsg,epsx,df0,binf,bsup,nfac,
     &vect,nvect,ivect,nivect,izs,rzs,dzs)
c!but
c     algorithme de minimisation d une fonction reguliere sous
c     contraintes de borne
c!methode
c     methode de bfgs a memoire limitee + projection
c!origine
c
c!sous programmes (modulopt)
c     proj rlbd majysa majz calbx gcp relvar bfgsd shanph
c!liste d' appel
c     indgc   indicateur de gcbd                                  es
c       en entree =1 standard
c                 =2 dh et indic initialises au debut de trav et itrav
c                    ifac,f,g initialises
c       en sortie
c        si < 0 incapacite de calculer un point meilleur que le point initial
c        si = 0 arret demande par l utilisateur
c        si > 0 on fournit un point meilleur que le point de depart
c        = -14 insuffisance memoire
c        = -13 indgc non egal a zero ou 1 en entree
c        = -12 zero,epsg ou df0 non strict. positifs
c        = -11 n,napmax,itmax ou io non strict. positifs
c        < -10 parametres d entree non convenables
c        = -6  arret lors du calcul de la direction de descente et iter=1
c        = -5  arret lors du calcul de l approximation du hessien  iter=1
c        = -3  anomalie de simul : indic negatif en un point ou
c              f et g ont ete precedemment calcules
c        = -2  echec de la recherche lineaire a la premiere iteration
c        = -1  f non definie au point initial
c        =  1  arret sur epsg
c        =  2            epsf
c        =  3            epsx
c        =  4            napmax
c        =  5            itmax
c        =  6  pente dans la direction opposee au gradient trop petite
c        =  7  arret lors du calcul de la direction de descente
c        =  8  arret lors du calcul de l approximation du hessien
c        = 10  arret par echec de la recherche lineaire , cause non precisee
c        = 11  idem avec indsim < 0
c        = 12            un pas trop petit proche d un pas trop grand
c                        ceci peut resulter d une erreur dans le gradient
c        = 13            trop grand nombre d appels dans une recherche lineaire
c
c     simul  subroutine permettant de calculer f et g (norme modulopt)
c     n dim de x                                                 e
c     x variables a optimiser (controle)                          es
c     f valeur du critere                                         s
c     g gradient de f                                             s
c     imp si =0 pas d impression
c             1  impressions en debut etfin dexecution
c             2  3 lignes a chaque iteration
c             >=3 nombreuses impressions    e
c     io numero fichier sortie            e
c     zero  proche zero machine                                             e
c     napmax nombre maximum d appels de simul                               e
c     itmax nombre maximum d iterations de gcbd                             e
c     epsf critere arret sur f            e
c     epsg arret si sup a norm2(g+)/n     e
c     epsx vect dim n precision sur x     e
c     df0>0 decroissance f prevue         e
c     binf,bsup bornes inf,sup,de dim n                          e
c     nfac nombre de variables non bloquees a l optimum          s
c     vect,ivect vecteurs de travail de dim nvect,nivect
c     izs,rzs,dzs : cf normes modulopt         es
c
c!
c         signification de quelques variables internes
c
c     {y}={g1}-{g0}                                        l (locale)
c     {s}={x1}-{x0}                                        l
c     {z}=[b]*{s}. [b] est une estimation de hessien       l
c     ys=<y>*{s}                                           l
c     zs=<z>*{s}                                           l
c     diag approximation diagonale du hessien  es
c     si indgc=0 diag initialise a *******************
c     puis remis a jour par bfgs diagonal
c     nt: le nombre de deplacements pris en compte          l
c     index(nt) repere les vect y,s,z                       l
c     wk1,wk2: vecteurs de travail de dim n                 l
c     ibloc vect dim n  ; si x(i) est bloque, ibloc(i)=iteration de blocage ;
c     si x(i) est libre, ibloc(i)=-1*(iteration de deblocage)
c     irit: irit=1, si relachement de vars a l'iter courante, 0 sinon
c     ired: ired=1 decision de redemarrage, 0 sinon
c     alg(1)=param
c     alg(2)=condmax
c     alg(6)=eps
c     alg(9)=tetaq ( critere de redemarrage)
c     ialg(1)       correction de powell sur y si (y,s)trop petit
c          0:       sans correction de powell
c          1:       avec correction
c     ialg(2)       mise a jour de diag par bfgsd
c          0:       pas de remise a jour
c          1:       remise a jour de diag par bfgsd
c     ialg(3)       mise a l'echelle par methode de shanno-phua
c          0:       pas de mise a l'echelle
c          1:       mise a l'echelle a toutes les iterations
c          2:       mise a l'echelle a la 2ieme iteration seulement
c     ialg(4):      memorisation pour choix iterations
c          0:                sans memorisation
c          1:      avec memorisation
c     ialg(5):      memorisation par variable
c          0:      sans memorisation
c          1:       avec memorisation
c     ialg(6):      choix des iterations de relachement
c          1:      relachement a toutes les iterations
c          2:      relachement si decroissance g norme gradient
c          10:     relachement si decroissance critere % iter.initcycle
c          11:      relachement si decroissance critere % decroissance cycle
c     ialg(7):      choix des variables a relacher
c          1:       methode de bertsekas modifiee
c     ialg(8):      choix de la direction de descente
c          3:      qn sans memoire: nt derniers deplacements
c          4:      redemarrage sans accumulation
c          5:      redemarrage avec accumulation
c     ialg(9):     critere de redemarrage
c          2:       redemarrage si fact. ou defact.
c          10:     decroissance critere % decroissance iter_init du cycle
c          11:     decroissance critere % decroissance totale du cycle
c          12:      diminution de znglib d un facteur alg(9)=tetaq
c     eps0 sert a partitionner les variables
c     ceps0 utilise dans le calcul de eps0
c     izag nombre d iterations min pendant lesquelles une var reste bloquee
c     nap nombre d appels de simul
c     iter iteration courante
c     ind indicateur de simul
c     icv memoire entree indgc
c     np  param utilise pour la gestion de vect. nb de vect courant.
c     lb  param utilise pour la gestion de vect. 1er place libre.
c     nb  param utilise pour la gestion de vect.
c        nb=2 si l'algorithme utilise est qn sans memoire +redem +pas acc
c        nb=1 sinon
c
      implicit double precision (a-h,o-z)
      real rzs(*)
      double precision dzs(*)
      dimension x(n),g(n),binf(n),bsup(n),epsx(n)
      dimension izs(*),vect(nvect),ivect(nivect),ialg(15),alg(15)
      character*6 nomf
      external simul
c
c     initialisation des parametres
      nt=2
      alg(1)= 1.0d-5
      alg(2)= 1.0d+6
      alg(6)=.50d+0
      alg(9)=.50d+0
c
      ialg(1)=1
      ialg(2)=0
      ialg(3)=2
      ialg(4)=0
      ialg(5)=0
      ialg(6)=2
      ialg(7)=1
      ialg(8)=4
      ialg(9)=12
c
c     verification des entrees
      ii=min(n,napmax,itmax)
      if(ii.gt.0)go to 10
      indgc=-11
      if(imp.gt.0) write(io,123)indgc
123   format(' gcbd : retour avec indgc=',i8)
      return
10    aa=min(zero,epsg,df0)
      do 11 i=1,n
11    aa=min(aa,epsx(i))
      if(aa.gt.0.0d+0) goto 12
      indgc=-12
      if(imp.gt.0) write(io,123) indgc
      return
12    continue
c
c     decoupage de la memoire
      ny=1
      ns=nt*n+ny
      nz=nt*n+ns
      nys=nt*n+nz
      nzs=nt+nys
      nd=nt+nzs
      ng=n+nd
      nx2=n+ng
      ndir=n+nx2
      ndiag=n+ndir
      nfin=n+ndiag
c
      if(nfin.gt.nvect) then
         write(io,1000)nfin,nvect
1000  format (' gcbd:insuffisance memoire; nvect=',i5,'devrait etre:',
     &  i5)
      indgc=-14
      return
      endif
c
      nindic=1
      nindex=n+nindic
      nfin=nt+nindex
      if(nfin.gt.nivect) then
         write(io,2000)nfin,nivect
2000  format (' gcbd:insuffisance memoire; nivect=',i5,'devrait etre:',
     &  i5)
      indgc=-14
      return
      endif
c
      call zgcbd(simul,n,binf,bsup,x,f,g,zero,napmax,itmax,indgc,ivect
     &(nindic),nfac,imp,io,epsx,epsf,epsg,vect(ndir),df0,vect(ndiag),
     &vect(nx2),izs,rzs,dzs,vect(ny),vect(ns),vect(nz),vect(nys),
     &vect(nzs),nt,ivect(nindex),vect(nd),vect(ng),alg,ialg,nomf)
      return
      end


!*==zdrot.f90  processed by SPAG 7.51RB at 20:37 on  3 Mar 2022
!> \brief \b ZDROT
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!  Definition:
!  ===========
!
!       SUBROUTINE ZDROT( N, ZX, INCX, ZY, INCY, C, S )
!
!       .. Scalar Arguments ..
!       INTEGER            INCX, INCY, N
!       DOUBLE PRECISION   C, S
!       ..
!       .. Array Arguments ..
!       COMPLEX*16         ZX( * ), ZY( * )
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> Applies a plane rotation, where the cos and sin (c and s) are real
!> and the vectors cx and cy are complex.
!> jack dongarra, linpack, 3/11/78.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>           On entry, N specifies the order of the vectors cx and cy.
!>           N must be at least zero.
!> \endverbatim
!>
!> \param[in,out] ZX
!> \verbatim
!>          ZX is COMPLEX*16 array, dimension at least
!>           ( 1 + ( N - 1 )*abs( INCX ) ).
!>           Before entry, the incremented array ZX must contain the n
!>           element vector cx. On exit, ZX is overwritten by the updated
!>           vector cx.
!> \endverbatim
!>
!> \param[in] INCX
!> \verbatim
!>          INCX is INTEGER
!>           On entry, INCX specifies the increment for the elements of
!>           ZX. INCX must not be zero.
!> \endverbatim
!>
!> \param[in,out] ZY
!> \verbatim
!>          ZY is COMPLEX*16 array, dimension at least
!>           ( 1 + ( N - 1 )*abs( INCY ) ).
!>           Before entry, the incremented array ZY must contain the n
!>           element vector cy. On exit, ZY is overwritten by the updated
!>           vector cy.
!> \endverbatim
!>
!> \param[in] INCY
!> \verbatim
!>          INCY is INTEGER
!>           On entry, INCY specifies the increment for the elements of
!>           ZY. INCY must not be zero.
!> \endverbatim
!>
!> \param[in] C
!> \verbatim
!>          C is DOUBLE PRECISION
!>           On entry, C specifies the cosine, cos.
!> \endverbatim
!>
!> \param[in] S
!> \verbatim
!>          S is DOUBLE PRECISION
!>           On entry, S specifies the sine, sin.
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date December 2016
!
!> \ingroup complex16_blas_level1
!
!  =====================================================================
      SUBROUTINE ZDROT(N,Zx,Incx,Zy,Incy,C,S)
      IMPLICIT NONE
!*--ZDROT102
!
!  -- Reference BLAS level1 routine (version 3.7.0) --
!  -- Reference BLAS is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     December 2016
!
!     .. Scalar Arguments ..
      INTEGER Incx , Incy , N
      DOUBLE PRECISION C , S
!     ..
!     .. Array Arguments ..
      COMPLEX*16 Zx(*) , Zy(*)
!     ..
!
! =====================================================================
!
!     .. Local Scalars ..
      INTEGER i , ix , iy
      COMPLEX*16 ctemp
!     ..
!     .. Executable Statements ..
!
      IF ( N<=0 ) RETURN
      IF ( Incx==1 .AND. Incy==1 ) THEN
!
!        code for both increments equal to 1
!
         DO i = 1 , N
            ctemp = C*Zx(i) + S*Zy(i)
            Zy(i) = C*Zy(i) - S*Zx(i)
            Zx(i) = ctemp
         ENDDO
      ELSE
!
!        code for unequal increments or equal increments not equal
!          to 1
!
         ix = 1
         iy = 1
         IF ( Incx<0 ) ix = (-N+1)*Incx + 1
         IF ( Incy<0 ) iy = (-N+1)*Incy + 1
         DO i = 1 , N
            ctemp = C*Zx(ix) + S*Zy(iy)
            Zy(iy) = C*Zy(iy) - S*Zx(ix)
            Zx(ix) = ctemp
            ix = ix + Incx
            iy = iy + Incy
         ENDDO
      ENDIF
      END SUBROUTINE ZDROT


	SUBROUTINE GR_AXLV  ( dmin, dmax, start, stop, rint, stradj,
     +                        stpadj, v, nv, iret )
C************************************************************************
C* GR_AXLV								*
C*									*
C* This subroutine defines axis label values given the data range,	*
C* the axis range and labeLling interval, if it is defined.  A suitable	*
C* label interval is determined automatically if it is missing.		*
C*									*
C* GR_AXLV  ( DMIN, DMAX, START, STOP, RINT, STRADJ, STPADJ, V, NV,	*
C*            IRET )							*
C*									*
C* Input parameters:							*
C*	DMIN		REAL		Minimum data value		*
C*	DMAX		REAL		Maximum data value		*
C*	START		REAL		Starting value on axis		*
C*	STOP		REAL		Stopping value on axis		*
C*	RINT		REAL		Labelling interval		*
C*	STRADJ		LOGICAL		Flag to permit adjusting START	*
C*	STPADJ		LOGICAL		Flag to permit adjusting STOP	*
C*									*
C* Output parameters:							*
C*	V  ( NV )	REAL		Array of label values		*
C*	NV		INTEGER		Number of label values		*
C*	IRET		INTEGER		Return code			*
C*					  0 = normal return 		*
C*					-15 = START or STOP missing	*
C*					-17 = Scaling cannot be done	*
C**									*
C* Log:									*
C* K. Brill/GSC		 5/90        					*
C* K. Brill/NMC      	07/90		Checks for error conditions	*
C* J. Wu/GSC            07/00           Moved INCLUDE 'ERMISS.FNC'      *
C*                                      before the DATA statement       *
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
C*
	REAL		v (*)
	LOGICAL  	stradj, stpadj
C*
	REAL    	qinc (5)
	LOGICAL 	notdon
	INCLUDE		'ERMISS.FNC'
	DATA  		qinc /1.,2.,3.,5.,10./
C*
C------------------------------------------------------------------------
	iret = 0
	nv = 0
C
C*	Check for errors in input.
C
	IF  ( ERMISS ( start ) .or. ERMISS ( stop ) .or.
     +        start .eq. stop ) THEN
	    iret = -15
	    RETURN
	END IF
	rmin = AMIN1 ( start, stop )
	rmax = AMAX1 ( start, stop )
C*
	IF ( .not. ERMISS ( rint ) ) THEN
C
C*	  If the interval is defined, use it to generate labels.
C
	  CALL GR_CMPV ( rmin, rmax, rint, LLAXIS, nv, v, ire )
C*
	ELSE
C
C*        Generate the label interval automatically.
C
	  delta = ABS ( start - stop )
	  ipwr = INT ( ALOG10 ( delta ) ) - 2
	  IF ( ipwr .lt. 0 ) ipwr = ipwr - 1
          notdon = .true.
	  DO WHILE ( notdon )
	    ipwr = ipwr + 1
	    IF ( ipwr .gt. 29 ) THEN
	       iret = -17
	       CALL ER_WMSG ( 'GR', iret, ' ', ier )
	       RETURN
	    END IF
            fctr = 10. ** ipwr
	    IF ( ipwr .lt. 0 ) THEN
	      ipos = -ipwr
	      fctr = 1.0000001 / 10. ** ipos
	    END IF
	    i = 0
            DO WHILE ( i .lt. 5 .and. notdon )
	      i = i + 1
	      aninc = qinc ( i ) * fctr
	      itest = INT ( delta/aninc )
	      IF ( itest .lt. 7 ) notdon = .false.
	    END DO
	  END DO
	  CALL GR_CMPV ( rmin, rmax, aninc, LLAXIS, nv, v, ire )
	END IF
C
C*	If DMIN or DMAX is missing, START and STOP cannot be adjusted.
C*      If there is no adjusting to be done, RETURN.
C
	IF ( ERMISS ( dmin ) .or. ERMISS ( dmax ) .or.
     +     ( .not. stradj .and. .not. stpadj ) )       RETURN
C*
	  test = (start - stop ) * ( dmin - dmax )
	IF ( stradj ) THEN
	  IF ( test .lt. 0.0 .and.
     +       ( v (nv) .lt. start .and. v (nv) .gt. dmax ) )
     +           start = v (nv)
	  IF ( test .gt. 0.0 .and.
     +       ( v (1) .gt. start .and. v (1) .lt. dmin ) )
     +           start = v (1)
	END IF
C*
	IF ( stpadj ) THEN
	  IF ( test .lt. 0.0 .and.
     +       ( v (1) .lt. dmin .and. v (1) .gt. stop ) )
     +         stop = v (1)
	  IF ( test .gt. 0.0 .and.
     +       ( v (nv) .gt. dmax .and. v (nv) .lt. stop ) )
     +         stop = v (nv)
	END IF
C*
	RETURN
	END


*DECK CNBIR
      SUBROUTINE CNBIR (ABE, LDA, N, ML, MU, V, ITASK, IND, WORK, IWORK)
C***BEGIN PROLOGUE  CNBIR
C***PURPOSE  Solve a general nonsymmetric banded system of linear
C            equations.  Iterative refinement is used to obtain an error
C            estimate.
C***LIBRARY   SLATEC
C***CATEGORY  D2C2
C***TYPE      COMPLEX (SNBIR-S, CNBIR-C)
C***KEYWORDS  BANDED, LINEAR EQUATIONS, NONSYMMETRIC
C***AUTHOR  Voorhees, E. A., (LANL)
C***DESCRIPTION
C
C    Subroutine CNBIR solves a general nonsymmetric banded NxN
C    system of single precision complex linear equations using
C    SLATEC subroutines CNBFA and CNBSL.  These are adaptations
C    of the LINPACK subroutines CGBFA and CGBSL which require
C    a different format for storing the matrix elements.
C    One pass of iterative refinement is used only to obtain an
C    estimate of the accuracy.  If  A  is an NxN complex banded
C    matrix and if  X  and  B  are complex N-vectors, then CNBIR
C    solves the equation
C
C                          A*X=B.
C
C    A band matrix is a matrix whose nonzero elements are all
C    fairly near the main diagonal, specifically  A(I,J) = 0
C    if  I-J is greater than  ML  or  J-I  is greater than
C    MU .  The integers ML and MU are called the lower and upper
C    band widths and  M = ML+MU+1  is the total band width.
C    CNBIR uses less time and storage than the corresponding
C    program for general matrices (CGEIR) if 2*ML+MU .LT. N .
C
C    The matrix A is first factored into upper and lower tri-
C    angular matrices U and L using partial pivoting.  These
C    factors and the pivoting information are used to find the
C    solution vector X .  Then the residual vector is found and used
C    to calculate an estimate of the relative error, IND .  IND esti-
C    mates the accuracy of the solution only when the input matrix
C    and the right hand side are represented exactly in the computer
C    and does not take into account any errors in the input data.
C
C    If the equation A*X=B is to be solved for more than one vector
C    B, the factoring of A does not need to be performed again and
C    the option to only solve (ITASK .GT. 1) will be faster for
C    the succeeding solutions.  In this case, the contents of A, LDA,
C    N, WORK and IWORK must not have been altered by the user follow-
C    ing factorization (ITASK=1).  IND will not be changed by CNBIR
C    in this case.
C
C
C    Band Storage
C
C          If  A  is a band matrix, the following program segment
C          will set up the input.
C
C                  ML = (band width below the diagonal)
C                  MU = (band width above the diagonal)
C                  DO 20 I = 1, N
C                     J1 = MAX(1, I-ML)
C                     J2 = MIN(N, I+MU)
C                     DO 10 J = J1, J2
C                        K = J - I + ML + 1
C                        ABE(I,K) = A(I,J)
C               10    CONTINUE
C               20 CONTINUE
C
C          This uses columns  1  through  ML+MU+1  of ABE .
C
C    Example:  If the original matrix is
C
C          11 12 13  0  0  0
C          21 22 23 24  0  0
C           0 32 33 34 35  0
C           0  0 43 44 45 46
C           0  0  0 54 55 56
C           0  0  0  0 65 66
C
C     then  N = 6, ML = 1, MU = 2, LDA .GE. 5  and ABE should contain
C
C           * 11 12 13        , * = not used
C          21 22 23 24
C          32 33 34 35
C          43 44 45 46
C          54 55 56  *
C          65 66  *  *
C
C
C  Argument Description ***
C
C    ABE    COMPLEX(LDA,MM)
C             on entry, contains the matrix in band storage as
C               described above.  MM  must not be less than  M =
C               ML+MU+1 .  The user is cautioned to dimension  ABE
C               with care since MM is not an argument and cannot
C               be checked by CNBIR.  The rows of the original
C               matrix are stored in the rows of  ABE  and the
C               diagonals of the original matrix are stored in
C               columns  1  through  ML+MU+1  of  ABE .  ABE  is
C               not altered by the program.
C    LDA    INTEGER
C             the leading dimension of array ABE.  LDA must be great-
C             er than or equal to N.  (terminal error message IND=-1)
C    N      INTEGER
C             the order of the matrix A.  N must be greater
C             than or equal to 1 .  (terminal error message IND=-2)
C    ML     INTEGER
C             the number of diagonals below the main diagonal.
C             ML  must not be less than zero nor greater than or
C             equal to  N .  (terminal error message IND=-5)
C    MU     INTEGER
C             the number of diagonals above the main diagonal.
C             MU  must not be less than zero nor greater than or
C             equal to  N .  (terminal error message IND=-6)
C    V      COMPLEX(N)
C             on entry, the singly subscripted array(vector) of di-
C               mension N which contains the right hand side B of a
C               system of simultaneous linear equations A*X=B.
C             on return, V contains the solution vector, X .
C    ITASK  INTEGER
C             if ITASK=1, the matrix A is factored and then the
C               linear equation is solved.
C             if ITASK .GT. 1, the equation is solved using the existing
C               factored matrix A and IWORK.
C             if ITASK .LT. 1, then terminal error message IND=-3 is
C               printed.
C    IND    INTEGER
C             GT. 0  IND is a rough estimate of the number of digits
C                     of accuracy in the solution, X .  IND=75 means
C                     that the solution vector  X  is zero.
C             LT. 0  see error message corresponding to IND below.
C    WORK   COMPLEX(N*(NC+1))
C             a singly subscripted array of dimension at least
C             N*(NC+1)  where  NC = 2*ML+MU+1 .
C    IWORK  INTEGER(N)
C             a singly subscripted array of dimension at least N.
C
C  Error Messages Printed ***
C
C    IND=-1  terminal   N is greater than LDA.
C    IND=-2  terminal   N is less than 1.
C    IND=-3  terminal   ITASK is less than 1.
C    IND=-4  terminal   The matrix A is computationally singular.
C                         A solution has not been computed.
C    IND=-5  terminal   ML is less than zero or is greater than
C                         or equal to N .
C    IND=-6  terminal   MU is less than zero or is greater than
C                         or equal to N .
C    IND=-10 warning    The solution has no apparent significance.
C                         The solution may be inaccurate or the matrix
C                         A may be poorly scaled.
C
C               NOTE-  The above terminal(*fatal*) error messages are
C                      designed to be handled by XERMSG in which
C                      LEVEL=1 (recoverable) and IFLAG=2 .  LEVEL=0
C                      for warning error messages from XERMSG.  Unless
C                      the user provides otherwise, an error message
C                      will be printed followed by an abort.
C
C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
C***ROUTINES CALLED  CCOPY, CDCDOT, CNBFA, CNBSL, R1MACH, SCASUM, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   800819  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
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   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900510  Convert XERRWV calls to XERMSG calls, cvt GOTO's to
C           IF-THEN-ELSE.  (RWC)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  CNBIR
C
      INTEGER LDA,N,ITASK,IND,IWORK(*),INFO,J,K,KK,L,M,ML,MU,NC
      COMPLEX ABE(LDA,*),V(*),WORK(N,*),CDCDOT
      REAL XNORM,DNORM,SCASUM,R1MACH
      CHARACTER*8 XERN1, XERN2
C***FIRST EXECUTABLE STATEMENT  CNBIR
      IF (LDA.LT.N) THEN
         IND = -1
         WRITE (XERN1, '(I8)') LDA
         WRITE (XERN2, '(I8)') N
         CALL XERMSG ('SLATEC', 'CNBIR', 'LDA = ' // XERN1 //
     *      ' IS LESS THAN N = ' // XERN2, -1, 1)
         RETURN
      ENDIF
C
      IF (N.LE.0) THEN
         IND = -2
         WRITE (XERN1, '(I8)') N
         CALL XERMSG ('SLATEC', 'CNBIR', 'N = ' // XERN1 //
     *      ' IS LESS THAN 1', -2, 1)
         RETURN
      ENDIF
C
      IF (ITASK.LT.1) THEN
         IND = -3
         WRITE (XERN1, '(I8)') ITASK
         CALL XERMSG ('SLATEC', 'CNBIR', 'ITASK = ' // XERN1 //
     *      ' IS LESS THAN 1', -3, 1)
         RETURN
      ENDIF
C
      IF (ML.LT.0 .OR. ML.GE.N) THEN
         IND = -5
         WRITE (XERN1, '(I8)') ML
         CALL XERMSG ('SLATEC', 'CNBIR',
     *      'ML = ' // XERN1 // ' IS OUT OF RANGE', -5, 1)
         RETURN
      ENDIF
C
      IF (MU.LT.0 .OR. MU.GE.N) THEN
         IND = -6
         WRITE (XERN1, '(I8)') MU
         CALL XERMSG ('SLATEC', 'CNBIR',
     *      'MU = ' // XERN1 // ' IS OUT OF RANGE', -6, 1)
         RETURN
      ENDIF
C
      NC = 2*ML+MU+1
      IF (ITASK.EQ.1) THEN
C
C        MOVE MATRIX ABE TO WORK
C
         M=ML+MU+1
         DO 10 J=1,M
            CALL CCOPY(N,ABE(1,J),1,WORK(1,J),1)
   10    CONTINUE
C
C        FACTOR MATRIX A INTO LU
         CALL CNBFA(WORK,N,N,ML,MU,IWORK,INFO)
C
C        CHECK FOR COMPUTATIONALLY SINGULAR MATRIX
         IF (INFO.NE.0) THEN
            IND=-4
            CALL XERMSG ('SLATEC', 'CNBIR',
     *         'SINGULAR MATRIX A - NO SOLUTION', -4, 1)
            RETURN
         ENDIF
      ENDIF
C
C     SOLVE WHEN FACTORING COMPLETE
C     MOVE VECTOR B TO WORK
C
      CALL CCOPY(N,V(1),1,WORK(1,NC+1),1)
      CALL CNBSL(WORK,N,N,ML,MU,IWORK,V,0)
C
C     FORM NORM OF X0
C
      XNORM = SCASUM(N,V(1),1)
      IF (XNORM.EQ.0.0) THEN
         IND = 75
         RETURN
      ENDIF
C
C     COMPUTE  RESIDUAL
C
      DO 40 J=1,N
         K  = MAX(1,ML+2-J)
         KK = MAX(1,J-ML)
         L  = MIN(J-1,ML)+MIN(N-J,MU)+1
         WORK(J,NC+1) = CDCDOT(L,-WORK(J,NC+1),ABE(J,K),LDA,V(KK),1)
   40 CONTINUE
C
C     SOLVE A*DELTA=R
C
      CALL CNBSL(WORK,N,N,ML,MU,IWORK,WORK(1,NC+1),0)
C
C     FORM NORM OF DELTA
C
      DNORM = SCASUM(N,WORK(1,NC+1),1)
C
C     COMPUTE IND (ESTIMATE OF NO. OF SIGNIFICANT DIGITS)
C     AND CHECK FOR IND GREATER THAN ZERO
C
      IND = -LOG10(MAX(R1MACH(4),DNORM/XNORM))
      IF (IND.LE.0) THEN
         IND = -10
         CALL XERMSG ('SLATEC', 'CNBIR',
     *      'SOLUTION MAY HAVE NO SIGNIFICANCE', -10, 0)
      ENDIF
      RETURN
      END


program problem43
  implicit none
  integer, parameter     :: n=10
  integer                :: i,temp
  integer*8              :: answer=0
  integer, dimension(10) :: c,A

  ! Start of Heap's Algorithm
  ! Source: https://en.wikipedia.org/wiki/Heap%27s_algorithm
  do i=0,n-1
     c(i+1)=0
     A(i+1)=i
  end do

  if (predicate(A)) answer=answer+number(A,n)

  i=0
  do while (i<n)
     if (c(i+1)<i) then
        if (mod(i,2)==0) then
           temp=A(0+1)
           A(0+1)=A(i+1)
           A(i+1)=temp
        else
           temp=A(c(i+1)+1)
           A(c(i+1)+1)=A(i+1)
           A(i+1)=temp
        end if
        if (predicate(A)) answer=answer+number(A,n)
        c(i+1)=c(i+1)+1
        i=0
     else
        c(i+1)=0
        i=i+1
     end if

  end do
  ! End of Heap's Algorithm

  print *, answer

contains

  pure function number(A,n)
    implicit none
    integer, dimension(*), intent(in) :: A
    integer, intent(in)               :: n
    integer                           :: i
    integer*8                         :: number

    number=0

    do i=1,n
       number=number*10
       number=number+A(i)
    end do

  end function number

  pure function predicate(A)
    integer, dimension(n), intent(in) :: A
    logical                           :: predicate

    predicate=.true.

    if (mod(number(A(2:4),3),2) /= 0) then
       predicate=.false.
       goto 1
    end if
    if (mod(number(A(3:5),3),3) /= 0) then
       predicate=.false.
       goto 1
    end if
    if (mod(number(A(4:6),3),5) /= 0) then
       predicate=.false.
       goto 1
    end if
    if (mod(number(A(5:7),3),7) /= 0) then
       predicate=.false.
       goto 1
    end if
    if (mod(number(A(6:8),3),11) /= 0) then
       predicate=.false.
       goto 1
    end if
    if (mod(number(A(7:9),3),13) /= 0) then
       predicate=.false.
       goto 1
    end if
    if (mod(number(A(8:10),3),17) /= 0) then
       predicate=.false.
       goto 1
    end if

1 end function predicate

end program problem43


      subroutine cfactor

!!    ~ ~ ~ PURPOSE ~ ~ ~
!!    this subroutine predicts daily soil loss caused by water erosion
!!    using the modified universal soil loss equation

!!    ~ ~ ~ INCOMING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    cvm(:)      |none          |natural log of USLE_C (the minimum value
!!                               |of the USLE C factor for the land cover)
!!    hru_km(:)   |km**2         |area of HRU in square kilometers
!!    icr(:)      |none          |sequence number of crop grown within a year
!!    idplt(:,:,:)|none          |land cover code from crop.dat
!!    ihru        |none          |HRU number
!!    iwave       |none          |flag to differentiate calculation of HRU and
!!                               |subbasin sediment calculation
!!                               |iwave = 0 for HRU
!!                               |iwave = subbasin # for subbasin
!!    nro(:)      |none          |sequence number of year in rotation
!!    peakr       |m^3/s         |peak runoff rate
!!    rsd_covco   |              |residue cover factor for computing fraction of
!!                                  cover
!!    sno_hru(:)  |mm H2O        |amount of water in snow in HRU on current day
!!    sol_cov(:)  |kg/ha         |amount of residue on soil surface
!!    sub_km(:)   |km^2          |area of subbasin in square kilometers
!!    sub_qd(:)   |mm H2O        |surface runoff loading from subbasin for day
!!    surfq(:)    |mm H2O        |surface runoff for the day in HRU
!!    usle_ei     |100(ft-tn in)/(acre-hr)|USLE rainfall erosion index
!!    usle_mult(:)|none          |product of USLE K,P,LS,exp(rock)
!!    wcklsp(:)   |
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ OUTGOING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    cklsp(:)    |
!!    sedyld(:)   |metric tons   |daily soil loss caused by water erosion
!!    usle        |metric tons/ha|daily soil loss predicted with USLE equation
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ LOCAL DEFINITIONS ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    c           |
!!    j           |none          |HRU number
!!    bio_frcov   |              |fraction of cover by biomass - adjusted for
!!                                  canopy height
!!    grcov_fr    |              |fraction of cover by biomass as function of lai
!!    rsd_frcov   |              |fraction of cover by residue
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ SUBROUTINES/FUNCTIONS CALLED ~ ~ ~
!!    Intrinsic: Exp

!!    ~ ~ ~ ~ ~ ~ END SPECIFICATIONS ~ ~ ~ ~ ~ ~

      use parm

      integer :: j
      real :: c

      j = 0
      j = ihru

      !! initialize variables
      c = 0.

      !! HRU sediment calculations
      if (icfac == 0) then
        if (idplt(j) > 0) then
          c = Exp((-.2231 - cvm(idplt(j))) *
     &	      Exp(-.00115 * sol_cov(j)) + cvm(idplt(j)))
        else
          if (sol_cov(j) > 1.e-4) then
            c = Exp(-.2231 * Exp(-.00115 * sol_cov(j)))
          else
            c = .8
          end if
	  end if
      else
        rsd_frcov = Exp(-rsd_covco * sol_cov(j))
        grcov_fr = laiday(j) / (laiday(j) +
     *          Exp(1.748 - 1.748*laiday(j)))
        bio_frcov = 1. - grcov_fr * Exp(-.01*cht(j))
        c = amax1(1.e-10,rsd_frcov*bio_frcov)
      end if

      usle_cfac(ihru) = c

      return
      end


! { dg-do run }
!
! Check PDT type extension and simple OOP.
!
module vars
  integer :: d_dim = 4
  integer :: mat_dim = 256
  integer, parameter :: ftype = kind(0.0d0)
end module

  use vars
  implicit none
  integer :: i
  type :: mytype (a,b)
    integer, kind :: a = kind(0.0e0)
    integer, LEN :: b = 4
    integer :: i
    real(kind = a) :: d(b, b)
  end type

  type, extends(mytype) :: thytype(h)
    integer, kind :: h
    integer(kind = h) :: j
  end type

  type x (q, r, s)
    integer, kind :: q
    integer, kind :: r
    integer, LEN :: s
    integer(kind = q) :: idx_mat(2,2)  ! check these do not get treated as pdt_arrays.
    type (mytype (b=s)) :: mat1
    type (mytype (b=s*2)) :: mat2
  end type x

  real, allocatable :: matrix (:,:)
  type(thytype(ftype, 4, 4)) :: w
  type(x(8,4,256)) :: q
  class(mytype(ftype, :)), allocatable :: cz

  w%d = reshape ([(real(i), i = 1, d_dim*d_dim)],[d_dim,d_dim])

! Make sure that the type extension is ordering the parameters correctly.
  if (w%a .ne. ftype) STOP 1
  if (w%b .ne. 4) STOP 2
  if (w%h .ne. 4) STOP 3
  if (size (w%d) .ne. 16) STOP 4
  if (int (w%d(2,4)) .ne. 14) STOP 5
  if (kind (w%j) .ne. w%h) STOP 6

! As a side issue, ensure PDT components are OK
  if (q%mat1%b .ne. q%s) STOP 7
  if (q%mat2%b .ne. q%s*2) STOP 8
  if (size (q%mat1%d) .ne. mat_dim**2) STOP 9
  if (size (q%mat2%d) .ne. 4*mat_dim**2) STOP 10

! Now check some basic OOP with PDTs
  matrix = w%d

! TODO - for some reason, using w%d directly in the source causes a seg fault.
  allocate (cz, source = mytype(ftype, d_dim, 0, matrix))
  select type (cz)
    type is (mytype(ftype, *))
      if (int (sum (cz%d)) .ne. 136) STOP 11
    type is (thytype(ftype, *, 8))
      STOP 12
  end select
  deallocate (cz)

  allocate (thytype(ftype, d_dim*2, 8) :: cz)
  cz%d = reshape ([(i*10, i = 1, cz%b**2)], [cz%b,cz%b])
  select type (cz)
    type is (mytype(ftype, *))
      STOP 13
    type is (thytype(ftype, *, 8))
      if (int (sum (cz%d)) .ne. 20800) STOP 14
  end select

  deallocate (cz)
end


! contains a simple example of a gp to use in tests

module m_gp_example
  use m_gp
  use m_gp_sparse
  use m_gp_dense
  use m_util
  use m_cov_sqexp
  use m_noise_value_only
  implicit none

  type(SparseGP) :: gp
  type(DenseGP) :: gpdense
  integer, parameter :: N = 50
  real(dp) :: x(2*N,1), t(2*N)
  integer :: obs_type(2*N)

  public :: gp, gpDense, N, x, t, obs_type

contains

  subroutine gp_example_initialise
    integer :: i, j, u
    real(dp) :: a
    type(cov_sqexp) :: cf
    type(noise_value_only) :: nm

    ! shuffled input vector
    do i=1,N
       call random_number(a)
       j = int(a*i)+1 ! random integer in [1,i]
       if (j.ne.i) x(i,:) = x(j,:)
       x(j,1) = 5.0*(i-1.0)/(N-1)
    end do

    do i=1,N
       ! value
       call random_number(a)
       t(i) = x(i,1)**2 ! + 0.0001 * a
       obs_type(i) = 0
       ! deriv
       x(i+N,1) = x(i,1)
       t(i+N) = 2*x(i,1)
       obs_type(i+N) = 1
    end do

    open(newunit=u,file="gp_example_training_data")
    write (u,'(2F20.10)') (x(i,1), t(i), i=1,N)
    close(u)

    gp = SparseGP(N-2, (/ 1.d-4 /), (/ 1.0_dp, 1.4_dp /), x(1:N,:), obs_type(1:N), t(1:N), cf, nm)

    gpDense = DenseGP( (/ 1.d-9 /), (/ 1.0_dp, 1.4_dp /), x(1:N,:), obs_type(1:N), t(1:N), cf, nm)

  end subroutine gp_example_initialise
end module m_gp_example


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!> Study the exponential of a nonsymmetric graph using the technique of
!! Guo, Krystal, and Bojan Mohar. "Hermitian adjacency matrix of digraphs and
!! mixed graphs." Journal of Graph Theory 85, no. 1 (2017): 217-248.
PROGRAM ComplexMatrix
  USE DataTypesModule, ONLY : NTREAL, NTCOMPLEX
  USE ExponentialSolversModule, ONLY : ComputeExponential
  USE LoggingModule, ONLY : EnterSubLog, ExitSubLog, WriteElement, WriteHeader
  USE PSMatrixAlgebraModule, ONLY : IncrementMatrix, ScaleMatrix
  USE PSMatrixModule, ONLY : Matrix_ps, ConstructMatrixFromMatrixMarket, &
       & DestructMatrix, TransposeMatrix, GetMatrixTripletList, &
       & FillMatrixFromTripletList, ConstructEmptyMatrix, ConjugateMatrix, &
       & PrintMatrix, CopyMatrix, WriteMatrixToMatrixMarket
  USE ProcessGridModule, ONLY : ConstructProcessGrid, DestructProcessGrid
  USE SolverParametersModule, ONLY : SolverParameters_t
  USE TripletListModule, ONLY : TripletList_r, DestructTripletList, &
       & GetTripletAt, TripletList_c, ConstructTripletList, &
       & AppendToTripletList, SymmetrizeTripletList, MM_SYMMETRIC
  USE TripletModule, ONLY : Triplet_r, Triplet_c
  USE MPI
  IMPLICIT NONE
  !! Variables for handling input parameters.
  INTEGER :: process_rows, process_columns, process_slices
  CHARACTER(len=80) :: input_file
  CHARACTER(len=80) :: exponential_file
  REAL(NTREAL) :: threshold
  TYPE(SolverParameters_t) :: solver_parameters
  !! Matrices
  TYPE(Matrix_ps) :: InMat
  TYPE(Matrix_ps) :: GMat
  TYPE(Matrix_ps) :: ExMat
  !! Temporary Variables
  CHARACTER(len=80) :: argument
  CHARACTER(len=80) :: argument_value
  INTEGER :: counter
  INTEGER :: provided, ierr

  !! Setup MPI
  CALL MPI_Init_thread(MPI_THREAD_SERIALIZED, provided, ierr)

  !! Process The Input
  !! Process the input parameters.
  DO counter=1,command_argument_count(),2
     CALL get_command_argument(counter,argument)
     CALL get_command_argument(counter+1,argument_value)
     SELECT CASE(argument)
     CASE('--input_file')
        input_file = argument_value
     CASE('--exponential_file')
        exponential_file = argument_value
     CASE('--process_rows')
        READ(argument_value,*) process_rows
     CASE('--process_columns')
        READ(argument_value,*) process_columns
     CASE('--process_slices')
        READ(argument_value,*) process_slices
     CASE('--threshold')
        READ(argument_value,*) threshold
     END SELECT
  END DO

  !! Setup the process grid.
  CALL ConstructProcessGrid(MPI_COMM_WORLD, process_rows, process_columns, &
       & process_slices)

  CALL WriteHeader("Command Line Parameters")
  CALL EnterSubLog
  CALL WriteElement(key="input_file", value=input_file)
  CALL WriteElement(key="exponential_file", value=exponential_file)
  CALL WriteElement(key="process_rows", value=process_rows)
  CALL WriteElement(key="process_columns", value=process_columns)
  CALL WriteElement(key="process_slices", value=process_slices)
  CALL WriteElement(key="threshold", value=threshold)
  CALL ExitSubLog

  !! Construct The Hermitian Matrix
  CALL ConstructMatrixFromMatrixMarket(InMat, input_file)
  CALL ConstructGuoMatrix(InMat, GMat)
  CALL ScaleMatrix(GMat, 0.5_NTREAL)

  !! Compute The Exponential
  solver_parameters = SolverParameters_t(threshold_in=threshold)
  CALL ComputeExponential(GMat, ExMat, solver_parameters)

  !! Write To File
  CALL WriteMatrixToMatrixMarket(ExMat, exponential_file)

  !! Cleanup
  CALL DestructMatrix(InMat)
  CALL DestructMatrix(GMat)
  CALL DestructProcessGrid
  CALL MPI_Finalize(ierr)

CONTAINS!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  !> Construct the Hermitian matrix from the nonsymmetric matrix
  SUBROUTINE ConstructGuoMatrix(Input, Output)
    !> Input matrix
    TYPE(Matrix_ps), INTENT(IN) :: Input
    !> The hermitian output matrix
    TYPE(Matrix_ps), INTENT(INOUT) :: Output
    !! Local Variables
    TYPE(Matrix_ps) :: Guide
    TYPE(Matrix_ps) :: SMatrix
    TYPE(Matrix_ps) :: CMatrix
    TYPE(TripletList_r) :: tlist
    TYPE(TripletList_c) :: clist
    !! Temporary Variables
    TYPE(Triplet_r) :: temp
    TYPE(Triplet_c) :: temp_c
    INTEGER :: II

    !! Symmetric The Input Matrix
    CALL GetMatrixTripletList(Input, tlist)
    CALL SymmetrizeTripletList(tlist, MM_SYMMETRIC)
    CALL ConstructEmptyMatrix(SMatrix, Input)
    CALL FillMatrixFromTripletList(SMatrix, tlist)

    !! Construct The Guide Matrix
    CALL CopyMatrix(SMatrix, Guide)
    CALL IncrementMatrix(Input, Guide, alpha_in=-1.0_NTREAL)

    !! Now iterate over the entries in the guide matrix.
    CALL GetMatrixTripletList(Guide, tlist)
    CALL ConstructTripletList(clist)
    DO II = 1, tlist%CurrentSize
       CALL GetTripletAt(tlist, II, temp)
       temp_c%index_row = temp%index_row
       temp_c%index_column = temp%index_column
       temp_c%point_value = (0.0,1.0)
       CALL AppendToTripletList(clist, temp_c)
    END DO
    CALL ConstructEmptyMatrix(CMatrix, Input)
    CALL FillMatrixFromTripletList(CMatrix, clist, preduplicated_in=.TRUE.)

    !! Now add it all together
    CALL TransposeMatrix(CMatrix, Output)
    CALL ConjugateMatrix(Output)
    CALL IncrementMatrix(CMatrix, Output)
    CALL IncrementMatrix(SMatrix, Output)

    !! Cleanup
    CALL DestructMatrix(SMatrix)
    CALL DestructMatrix(CMatrix)
    CALL DestructMatrix(Guide)
    CALL DestructTripletList(clist)
    CALL DestructTripletList(tlist)
  END SUBROUTINE ConstructGuoMatrix
END PROGRAM ComplexMatrix


SUBROUTINE p46(input_file,output_file)
!-------------------------------------------------------------------------
! Program 4.6 Stability (buckling) analysis of elastic beams using 2-node
!             beam elements (elastic foundation optional).
!-------------------------------------------------------------------------
 USE main
 USE geom
 IMPLICIT NONE
 CHARACTER(len=60),INTENT(IN) :: input_file
 CHARACTER(len=60),INTENT(OUT) :: output_file
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 INTEGER::i,iel,iters,k,limit,ndof=4,nels,neq,nod=2,nodof=2,nn,nprops,    &
   np_types,nr,nlen
 REAL(iwp)::eval,tol,zero=0.0_iwp
!-----------------------dynamic arrays------------------------------------
 INTEGER,ALLOCATABLE::etype(:),g(:),g_g(:,:),kdiag(:),nf(:,:),num(:)
 REAL(iwp),ALLOCATABLE::ell(:),evec(:),kg(:,:),gv(:),km(:,:),kv(:),       &
   mm(:,:),prop(:,:)
 CHARACTER(LEN=15)::argv
!-----------------------input and initialisation--------------------------
 OPEN(10,FILE=input_file)
 OPEN(11,FILE=output_file)
 READ(10,*)nels,nprops,np_types
 nn=nels+1
 ALLOCATE(nf(nodof,nn),ell(nels),num(nod),g(ndof),g_g(ndof,nels),         &
   etype(nels),prop(nprops,np_types),km(ndof,ndof),kg(ndof,ndof),         &
   mm(ndof,ndof))
 READ(10,*)prop
 etype=1
 IF(np_types>1)READ(10,*)etype
 READ(10,*)ell
 nf=1
 READ(10,*)nr,(k,nf(:,k),i=1,nr),limit,tol
 CALL formnf(nf)
 neq=MAXVAL(nf)
 ALLOCATE(kdiag(neq),evec(0:neq))
!-----------------------loop the elements to find global array sizes------
 kdiag=0
 elements_1: DO iel=1,nels
   num=(/iel,iel+1/)
   CALL num_to_g(num,nf,g)
   g_g(:,iel)=g
   CALL fkdiag(kdiag,g)
 END DO elements_1
 DO i=2,neq
   kdiag(i)=kdiag(i)+kdiag(i-1)
 END DO
 ALLOCATE(kv(kdiag(neq)),gv(kdiag(neq)))
 WRITE(11,'(2(A,I5))')                                                    &
   " There are",neq," equations and the skyline storage is",kdiag(neq)
!-----------------------global stiffness and geometric matrix assembly----
 kv=zero
 gv=zero
 elements_2: DO iel=1, nels
   mm=zero
   CALL beam_km(km,prop(1,etype(iel)),ell(iel))
   IF(nprops>1)CALL beam_mm(mm,prop(2,etype(iel)),ell(iel))
   CALL beam_gm(kg,ell(iel))
   g=g_g(:,iel)
   CALL fsparv(kv,km+mm,g,kdiag)
   CALL fsparv(gv,kg,g,kdiag)
 END DO elements_2
!-----------------------solve eigenvalue problems-------------------------
 CALL stability(kv,gv,kdiag,tol,limit,iters,evec,eval)
 WRITE(11,'(/A,E12.4,/)')" The buckling load =",eval
 evec(0)=zero
 WRITE(11,'(A)')" The buckling mode"
 WRITE(11,'(/A)')"  Node Translation Rotation"
 DO k=1,nn
   WRITE(11,'(I5,2E12.4)')k,evec(nf(:,k))
 END DO
 WRITE(11,'(/A,I5,A)')" Converged in",iters," iterations"
 CALL beamdis(evec,nf,0.40_iwp,10,nels,ell,argv,nlen,12)
END SUBROUTINE p46


!======================================================================!
  SUBROUTINE CalcVort()
!----------------------------------------------------------------------!
!  Computes the magnitude of the vorticity                             !
!----------------------------------------------------------------------!
!  Vort = sqrt( 2 * Sij * Sij )                                       !
!  Sij = 1/2 ( dUi/dXj - dUj/dXi )                                     !
!----------------------------------------------------------------------!
!------------------------------[Modules]-------------------------------!
  USE all_mod
  USE pro_mod
  USE les_mod
  USE rans_mod
!----------------------------------------------------------------------!
  IMPLICIT NONE
!-------------------------------[Locals]-------------------------------!
  INTEGER :: c, i
  REAL    :: Sjk
!--------------------------------[CVS]---------------------------------!
!  $Id: CalcVort.f90,v 1.4 2009/06/30 12:00:18 IUS\mhadziabdic Exp $
!  $Source: /home/IUS/mhadziabdic/.CVSROOT/T-Rex/Process/CalcVort.f90,v $
!======================================================================!

  call Exchng(U % n)
  call Exchng(V % n)
  call Exchng(W % n)

!===================!
!                   !
!     SGS terms     !
!                   !
!===================!
  do i=1,3

    if(i == 1) then
      call GraPhi(W % n,2,PHIy, .TRUE.)  ! dW/dy
      call GraPhi(V % n,3,PHIz, .TRUE.)  ! dV/dz
    end if
    if(i == 2) then
      call GraPhi(W % n,1,PHIx, .TRUE.)  ! dW/dx
      call GraPhi(U % n,3,PHIz, .TRUE.)  ! dU/dz
    end if
    if(i == 3) then
      call GraPhi(V % n,1,PHIx, .TRUE.)  ! dV/dx
      call GraPhi(U % n,2,PHIy, .TRUE.)  ! dU/dy
    end if

    do c=1,NC
      if(i == 1) then
        Sjk = 0.5*(PHIy(c)-PHIz(c)) ! Syz=Szy:  .5(dV/dz+dW/dy)
        Vort(c) = 2.0*Sjk*Sjk
      end if
      if(i == 2) then
        Sjk = 0.5*(PHIx(c)-PHIz(c)) ! Sxz=Szx:  .5(dU/dz+dW/dx)
        Vort(c) = Vort(c) + 2.0*Sjk*Sjk
      end if
      if(i == 3) then
        Sjk = 0.5*(PHIx(c)-PHIy(c)) ! Sxy=Syx:  .5(dV/dx+dU/dy)
        Vort(c) = Vort(c) + 2.0*Sjk*Sjk
      end if
    end do

  end do  ! i

  do c = 1, NC
    Vort(c) = sqrt(abs(2.0 * Vort(c)))
  end do
  END SUBROUTINE CalcVort


real*16 function AsymptoticPart(TValues, LambdaLower, N1, LambdaUpper)
	use LU
	implicit none
	integer N, N1
	real*16 TValues(N1)
	real*16 LambdaLower, Temp
	integer LambdaUpper, ZetaUpperBound, num

	external DGESV, ModifiedRiemannZeta
	real*16 ModifiedRiemannZeta

	real*16 AsymptoticSum, AsymptoticSum16
	integer q, i, j, Info
	real*8 A(LambdaUpper+1, LambdaUpper+1)
	real*8 BX(LambdaUpper+1)
	real*16 A16(LambdaUpper+1, LambdaUpper+1)
	real*16 BX16(LambdaUpper+1)
	real*16 AB16(LambdaUpper+1,LambdaUpper+2)
	integer IPIV(N1)
	integer ( kind = 4 ) nnew, rhs_num, infonew
	integer, allocatable, dimension(:) :: INDX
	integer rc, D

	N = N1

    ZetaUpperBound = 10000

	! Initialize the summation
	AsymptoticSum = 0.0q0
	AsymptoticSum16 = 0.0q0
	A = 0.0d0
	A16 = 0.0q0

	!// Fill in x vector  with the values of T(q) for q = N-LambdaUpper to N.
	do i = 1, LambdaUpper+1, 1
		BX(i) = TValues(i + (N - (LambdaUpper+1)))
		BX16(i) = TValues(i + (N - (LambdaUpper+1)))
	enddo

	!// This is our lower value for q, q = N-LambdaUpper.
	q = N - (LambdaUpper)

	! Fill in our matrix, A, with the coefficients.  These coefficients are the q^(i+LambdaLower) in equation (19).
	!  Also notice that i and j are swapped from how they normally are in nested for loops.
	do j = 1, LambdaUpper+1, 1
		do i = 1, LambdaUpper+1, 1
			A(j,i) = 1.0q0 / real(q,16) ** ((i-1)+real(LambdaLower,16))
			A16(j,i) = 1.0q0 / real(q,16) ** ((i-1)+real(LambdaLower,16))
		enddo

		q = q + 1  ! We want all integral values for q up to N
	enddo

	! LU decomposition
	num = LambdaUpper + 1
	A = A16
	allocate(INDX(num))
	!call LU decomposition routine
	call LUDCMP(A16,num,INDX,D,rc)
	!call appropriate solver if previous return code is ok
	if (rc.eq.0) then
		call LUBKSB(A16,num,INDX,BX16)
	endif
	deallocate(INDX)

	do i = 1, LambdaUpper+1, 1
		!AsymptoticSum = AsymptoticSum + BX(i) * ModifiedRiemannZeta(N-1, real((i-1)+LambdaLower,16), ZetaUpperBound)
		!Temp = ModifiedRiemannZeta(N, real((i-1)+LambdaLower,16), ZetaUpperBound)
		AsymptoticSum = AsymptoticSum + BX16(i) * ModifiedRiemannZeta(N, real((i-1)+LambdaLower,16), ZetaUpperBound)
		!AsymptoticSum16 = AsymptoticSum16 + AB16(i,LambdaUpper+2) * ModifiedRiemannZeta(N, real((i-1)+LambdaLower,16), ZetaUpperBound)
	enddo

	!write (*,*) 'Asymptotic part:', AsymptoticSum

	AsymptoticPart = AsymptoticSum
	!AsymptoticPart = AsymptoticSum16
	return
end

! This is the Riemann zeta function shown in (18) with its first N terms removed.
real*16 function ModifiedRiemannZeta(N, i, ZetaUpperBound)
	implicit none
	include 'ModifiedZeta.h'
	integer N
	real*16 i
	integer ZetaUpperBound
	real*16 Sum, Term, Zeta2
	integer j
	logical, save :: FirstCall = .true.

	select case (N)
		case (5)
			ModifiedRiemannZeta = Zeta5(int(2*i) - 2)
			return
		case (10)
			ModifiedRiemannZeta = Zeta10(int(2*i) - 2)
			return
		case (15)
			ModifiedRiemannZeta = Zeta15(int(2*i) - 2)
			return
		case (20)
			ModifiedRiemannZeta = Zeta20(int(2*i) - 2)
			return
		case (21)
			ModifiedRiemannZeta = Zeta21(int(2*i) - 2)
			return
		case (25)
			ModifiedRiemannZeta = Zeta25(int(2*i) - 2)
			return
		case (26)
			ModifiedRiemannZeta = Zeta26(int(2*i) - 2)
			return
		case (30)
			ModifiedRiemannZeta = Zeta30(int(2*i) - 2)
			return
		case (31)
			ModifiedRiemannZeta = Zeta31(int(2*i) - 2)
			return
		case (35)
			ModifiedRiemannZeta = Zeta35(int(2*i) - 2)
			return
		case (36)
			ModifiedRiemannZeta = Zeta36(int(2*i) - 2)
			return
		case (40)
			ModifiedRiemannZeta = Zeta40(int(2*i) - 2)
			return
		case (41)
			ModifiedRiemannZeta = Zeta41(int(2*i) - 2)
			return
		case (45)
			ModifiedRiemannZeta = Zeta45(int(2*i) - 2)
			return
		case (46)
			ModifiedRiemannZeta = Zeta46(int(2*i) - 2)
			return
		case (50)
			ModifiedRiemannZeta = Zeta50(int(2*i) - 2)
			return
		case (51)
			ModifiedRiemannZeta = Zeta51(int(2*i) - 2)
			return
		case (55)
			ModifiedRiemannZeta = Zeta55(int(2*i) - 2)
			return
		case (60)
			ModifiedRiemannZeta = Zeta60(int(2*i) - 2)
			return
		case (65)
			ModifiedRiemannZeta = Zeta65(int(2*i) - 2)
			return
		case (70)
			ModifiedRiemannZeta = Zeta70(int(2*i) - 2)
			return
		case (75)
			ModifiedRiemannZeta = Zeta75(int(2*i) - 2)
			return
	end select

	! This is to make it explicitly clear that the hardcoded values are more accurate.
	if (FirstCall .eqv. .true.)	then
		write (*,*) 'NOTE! Hardcoded values for the modified Riemann Zeta function are not being used.'
		write (*,*) ' The accuracy of the results will be less than if hardcoded values are used.'
		FirstCall = .false.
	end if

	Sum = 0.0q0

	! For the special case of i == 2, we have a p-series with a definite sum (Zeta2 below).
	!  This series converges *VERY* slowly, so we take it as a special case.
	if (int(i) == 2) then
		Zeta2 = 1.644934066848226436472415166646025189219q0
		do j = 1, N, 1
			Zeta2 = Zeta2 - 1.0q0 / real(j**i,16)
		enddo
		ModifiedRiemannZeta = Zeta2
		return
	endif

	j = N+1
	!do j = N+1, ZetaUpperBound, 1
	do
		Term = 1.0q0 / (real(j,16) ** real(i,16))
		Sum = Sum + Term
		!@TODO: How small do we really need to get this?
		if (Term < 1q-21) exit
		j = j + 1
	enddo

	ModifiedRiemannZeta = Sum
	return
end


\ 2D vectors!  fixed point or integer either works
\ in experimental stage
\ future ideas:
\  - "V" registers with push and pop words.  all "vector" params implicit?

: vector:  ( x y - <name> )  create swap , , ;
2 cells constant /vector
: 2.  swap . . ;
: 3.  rot . 2. ;
: 2?  swap ? ? ;
: vadd  swap 2@ rot 2+! ;
: x@  @ ;
: y@  cell+ @ ;
: x!  ! ;
: y!  cell+ ! ;
: x+!  +! ;
: y+!  cell+ +! ;
: vcopy  swap 2@ rot 2! ;
: vclamp  ( lowx lowy highx highy vec - )  >r  2@ 2min 2max r> 2! ;
: 2rnd  ( x y - x y )  rnd swap rnd swap ;
: vrnd  >r  2rnd  r> 2! ;
: uvec  ( deg - x y )   >r  r@ cos  r> sin ;  \ get unit vector from angle
: vec  ( deg len - x y )  >r  uvec  r> dup 2* ;
: angle  ( x y - deg ) 1pf 1pf fatan2 r>d f>p  360 + 360 mod ;
: magnitude  ( x y - n )  2pf fdup f* fswap fdup f* f+ fsqrt f>p ;
: normalize  ( vec - )  dup 2@ 2dup 0 0 d= ?exit  2dup magnitude dup 2/  ( 1 1 2+ ) rot 2! ;
: vdif  ( vec1 vec2 - x y )  2@ rot 2@ 2- ;
: proximity  ( vec1 vec2 - n ) vdif magnitude ;   \ distance between two vectors
: hypot  ( vec - n )  2@ 1pf fdup f* 1pf fdup f* f+ fsqrt f>p ;
: dotp  ( vec1 vec2 - n ) swap 2@ rot 2@  -rot ( b.x a.y ) * >r  ( a.x b.y ) *  r> - ;
: rotate  ( deg vec - )
    swap  dup cos  swap sin  locals| sin(ang) cos(ang) v |
    v x@ cos(ang) * v y@ sin(ang) * -
    v x@ sin(ang) * v y@ cos(ang) * +  v 2! ;
: scale  ( x y vec - )
    >r  2@ 2*  r> 2! ;
: vlerp  ( vec1 vec2 n - )
    locals| n v2 v1 |
    v1 x@ v2 x@ n lerp  v1 y@ v2 y@ n lerp  v2 2! ;


c
c     =================================================
      double precision function psi(x,y)
c     =================================================
c
c     # stream function

      implicit double precision (a-h,o-z)

      psi = x**2 + y**2
c
      return
      end


*dk rand_lg
C***********************************************************************
C
C  PURPOSE -
C
C   Machine independent general-purpose real*8
C   random number generator for unix workstations.
C
C ............................................................
C
C   TO USE the random number generator:
C
C   *  x=rand_lg()
C       - puts the next random real*8 number on (0,1) in
C         variable x.
C
C   *  i=irand_lg(j)
C       - puts the next random integer on [0,j] in
C         variable i.
C
C   * * * NOTE INITIALIZATION IS *NOT* REQUIRED BEFORE USE * * *
C    (as the defaults are in a block data statement)
C
C ............................................................
C
C   TO MODIFY the random number generator parameters:
C
C   *  call seed_rand_lg(seed1,seed2)
C       - reset the random number seeds using the integers seed1 and
C         seed2, which should be "large, but not too large" positive
C         integers, and seed2 should be odd and smaller than seed1.
C
C   *  call adv_rand_lg()
C       - advances the random number parameters
C
C   *  call reset_rand_lg(rnmultin,nstridin,rijkin,nadvin)
C       - If the integer arguments are all zero or smaller reset
C         the random number generator to the initial defaults
C         (initialized at compile time with a block data statement).
C       - Otherwise re-initialize the random number generator parameters
C         using the integers rnmultin,nstridin,rijkin,nadvin
C         which should be "large, but not too large" positive integers
C         (see code for meaning).
C
C ............................................................
C
C       $Log: rand_lg.f,v $
C       Revision 2.00  2007/11/09 20:03:59  spchu
C       Import to CVS
C
CPVCS
CPVCS       Rev 1.3   Wed Jul 21 15:25:44 1999   jtg
CPVCS    gave block data statement a name
CPVCS
CPVCS       Rev 1.2   Fri Jul 09 22:38:06 1999   jtg
CPVCS    fixed typo
CPVCS
CPVCS       Rev 1.1   Fri Jul 09 21:21:32 1999   jtg
CPVCS    fixed typo
CPVCS
CPVCS       Rev 1.0   Fri Jul 09 20:59:30 1999   jtg
CPVCS    Initial revision.
C
C PRIOR HISTORY:
C
C replaces t3d/potts_random_numbers.f and grain3d/potts_random_numbers.f
C (jtg@lanl.gov got this from Charlie Snell at LANL who got it from
C Hendricks at LANL, and I don't know where they have it from.
C It is "well tested"....)
C
C "_lg" hass been added to all subroutine and function names
C to avoid package conflicts
C
*********************************************************************
c returns the next random integer in [0,j]

      integer function irand_lg(j)
c ........................................................................
      implicit none
      real*8 rand_lg
      integer j,absj
c     --------------------------------------------------------------

      absj = abs(j)

c     ! find random integer in [0,|j|]
      irand_lg = rand_lg() * dble(absj+1)

c     ! check for error due to numerical roundoff
      if (irand_lg.gt.absj)  irand_lg=absj

      if (j.lt.0)   irand_lg = -irand_lg

      return
      end
c ########################################################################
c returns the next pseudo-random real number in (0,1)

      real*8 function rand_lg()
c ........................................................................
      implicit none
      real*8  rnfb,rnfs,rngb,rngs,rijk,ranj,rani,rans,ranb
      common /com_rand_lg/ rnfb,rnfs,rngb,rngs,rijk,ranj,rani,rans,ranb
      real*8 p, q, a, b, r
      parameter (p=2d0**24,q=2d0**(-24),r=2d0**(-48))
c     --------------------------------------------------------------

c        rand_lg()=mod(2**48*rand_lg()*rnmult,2**48)
c        split rand_lg() and rnmult into upper and lower 24-bit halves,
c        ranb,rans,rngb,rngs, respectively, to achieve 96-bit precision.
c        this expression for b is invalid unless rngb+rngs < 2**24
c        or unless the more elaborate expression of adv_rand_lg is used.

      a = rngs * rans
      b = rngb*rans + rngs*ranb + int(a*q)
      rans = a - int(a*q)*p
      ranb = b - int(b*q)*p
      rand_lg = ( ranb*p + rans ) * r

      return
      end
c ########################################################################
c resets the random number seed

      subroutine seed_rand_lg(seed1,seed2)
c ........................................................................
      implicit none
      real*8  rnfb,rnfs,rngb,rngs,rijk,ranj,rani,rans,ranb
      common /com_rand_lg/ rnfb,rnfs,rngb,rngs,rijk,ranj,rani,rans,ranb
      integer seed1, seed2
      real*8 large
      parameter (large=1.d16)
c     --------------------------------------------------------------

      ranb = abs(seed1)
      rans = abs(seed2)

c check for legal values of the two components of the random seed
      if (rans.gt.ranb) then
         ranb = rans
         rans = abs(seed1)
      endif
      if (mod(int(rans),2).eq.0) rans = rans+1.
      if (ranb.gt.large) ranb = large
      if (rans.gt.large) rans = large - 101234567.

      return
      end
c ########################################################################
c pre-initialize the pseudo-random number sequence at compile time

      block data rand_data_lg
c ........................................................................
      implicit none
      real*8  rnfb,rnfs,rngb,rngs,rijk,ranj,rani,rans,ranb
      common /com_rand_lg/ rnfb,rnfs,rngb,rngs,rijk,ranj,rani,rans,ranb

      data rnfb /13008944.d0/, rnfs /170125.d0/, rngb /1136868.d0/
     &   , rngs /6328637.d0/, rijk /19073486328125.d0/
     &   , rani /1136868.d0/, ranj /6328637.d0/
     &   , ranb /1136868.d0/, rans /6328637.d0/

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

      end
c ########################################################################
c re-initialize the pseudo-random number sequence
c to defaults if (rnmultin,nstridin,rijkin,nadvin) = (0,0,0,0),
c otherwise use those inputs>0 to startup the random number generator.

      subroutine reset_rand_lg(rnmultin,nstridin,rijkin,nadvin)
c ........................................................................
      implicit none
      integer rijkin,nstridin,rnmultin,nadvin
      real*8  rnfb,rnfs,rngb,rngs,rijk,ranj,rani,rans,ranb
      common /com_rand_lg/ rnfb,rnfs,rngb,rngs,rijk,ranj,rani,rans,ranb
      real*8 p,q
      parameter (p=2d0**24,q=2d0**(-24))
      real*8 a,b,rnmult
      integer istrid,iadv,nstrid
c     --------------------------------------------------------------

      if ( (nstridin.gt.0) .or. (rnmultin.gt.0) ) then

c        ! Set the random number multiplier rnmult and the random number
c        ! stride nstrid. The random number multiplier must be odd.
c        ! The random number modulus sum must be .lt. p
c        ! rnmultin should be greater than p

10       if (rnmultin.gt.0) then
            if (mod(rnmultin,2).eq.0) then
               rnmult = rnmultin+1
            else
               rnmult = rnmultin
            endif
         else
            rnmult=19073486328125.d0
         endif

c        ! rngb and rngs are the upper and lower 24 bits of rnmult.
         rngb = int(rnmult*q)
         rngs = rnmult-rngb*p
         if (rngb.eq.0) rngb = 1
         if (rngs.eq.0) rngs = 1
         if (rngb+rngs.ge.p)  then
            rnmultin = rnmultin/7
            goto 10
         endif

c        ! get rnfb (upper 24 bits) and rnfs (lower 24 bits) of
c        ! rnmult**nstrid which is used in adv_rand_lg to advance the random
c        ! number by nstrid random numbers for each history.

         if (nstridin.gt.0) then
            nstrid = nstridin
         else
            nstrid = 152917
         endif

         rnfb = rngb
         rnfs = rngs
         nstrid = nstrid - 1
         do istrid=1,nstrid
            a = rngs*rnfs
            b = rngb*rnfs - int(rngb*rnfs*q)*p
     &        + rngs*rnfb - int(rngs*rnfb*q)*p
     &        + int(a*q)
            rnfs = a - int(a*q)*p
            rnfb = b - int(b*q)*p
         enddo

      else

         ! rnmult = 5**19
         rnmult = 19073486328125.d0
         rngb = 1136868.d0
         rngs = 6328637.d0
         rnfb = 13008944.d0
         rnfs = 170125.d0

      endif

c     ! if desired, insert a starting value of the random number rijk
c     ! otherwise use the default rijk=rnmult
      if (rijkin.gt.0) then
         rijk = rijkin
      else
         rijk = rnmult
      endif

c     ! rijk is composed of ranj (top 24 bits) and rani (bottom 24 bits).
      rani = int(rijk*q)
      ranj = rijk-rani*p

c     ! if desired, advance the initial random number
      do iadv=1,nadvin-1
         call adv_rand_lg()
      enddo

      ranb = rani
      rans = ranj

      return
      end
c ########################################################################
c advance source random number, rijk, for the next history.
c ranj is the lower 24 bits of rijk, rani is the upper 24 bits.
c (currently not used: see comments above)

      subroutine adv_rand_lg()
c ........................................................................
      implicit none
      real*8  rnfb,rnfs,rngb,rngs,rijk,ranj,rani,rans,ranb
      common /com_rand_lg/ rnfb,rnfs,rngb,rngs,rijk,ranj,rani,rans,ranb
      real*8 p, q, a, b
      parameter (p=2d0**24,q=2d0**(-24))
c     --------------------------------------------------------------

      a = rnfs * ranj
      b = rnfb*ranj - int(rnfb*ranj*q)*p
     &  + rnfs*rani - int(rnfs*rani*q)*p
     &  + int(a*q)
      ranj = a - int(a*q)*p
      rani = b - int(b*q)*p
      rijk = rani*p + ranj

      return
      end
c ########################################################################


! calc_time_step.f90
! author: sunder

!-----------------------------------------------------------------------
! Calculates time step for a general non-linear PDE for an explicit DG
! method
!-----------------------------------------------------------------------

subroutine calc_time_step
    use ader_dg
    implicit none

    ! Local variables

    integer  :: iDim, i, j, k, l
    real :: Lambda(nVar)
    real :: nv(nDim,nDim), denom

    ! Normal vectors pointing into the two space dimensions

    nv = 0.0

    do i = 1, nDim
        nv(i,i) = 1.0
    end do

    ! First calculate the minimum time step on the current processor

    dt = 1.0e20

    do j = 1, JMAX
        do i = 1, IMAX

            do k = 1, nDOF(1)
                do l = 1, nDOF(2)
                    denom = 0.0
                    do iDim = 1, nDim
                        call PDEEigenvalues(uh(:,k,l,i,j),nv(:,iDim),Lambda)
                        denom = denom + maxval(abs(Lambda))/dx(iDim)
                    end do
                    dt = min(dt, CFL*PNPMTable(N)/denom )
                end do
            end do

        end do
    end do

    if (time+dt .gt. tend) then
        dt = tend - time
    end if

end subroutine calc_time_step


c     DRDERFCE
c>> 1996-05-28 DRDERFCE Krogh Moved formats up.
c>> 1994-10-19 DRDERFCE Krogh  Changes to use M77CON
c>> 1992-04-29 DRDERFCE CAO Replaced '1' in format.
c>> 1992-01-29 DRDERFCE cao/cll eliminate underflow error message.
c>> 1992-01-29 DRDERFCE cao/cll better output labels.
c>> 1991-11-20 DRDERFCE CLL Edited for Fortran 90
c>> 1987-12-09 DRDERFCE Lawson  Initial Code.
c     DEMONSTRATION DRIVER FOR  DERFCE
c     ------------------------------------------------------------------
c--D replaces "?": DR?ERFCE, ?ERFC, ?ERFCE
c     ------------------------------------------------------------------
      external DERFC,DERFCE
      double precision DERFC, DERFCE
      double precision W, X, Y, Z
      integer J
c
  100 format(' ',3X,'X',8X,'DERFCE',7X,'DERFC*(X*X)',6X,'DIFF'/' ')
  200 format(1X,F5.1,3X,2(G15.8),1X,E9.2)
c     ------------------------------------------------------------------
c
      X = 0.0d0
      write(*,100)
      do 10 J=1,18
        W = DERFC(X) * EXP(X * X)
        Y = DERFCE(X)
        Z = Y - W
        write(*,200) X,Y,W,Z
        X = X + 0.5d0
   10 continue
      do 20 J=1,18
        Y = DERFCE(X)
        write(*,200) X,Y
        X = X + 1.0d0
   20 continue
      stop
      end


      SUBROUTINE ranpt(pt,region,n)
      INTEGER n,idum
      REAL pt(n),region(2*n)
      COMMON /ranno/ idum
      SAVE /ranno/
CU    USES ran1
      INTEGER j
      REAL ran1
      do 11 j=1,n
        pt(j)=region(j)+(region(j+n)-region(j))*ran1(idum)
11    continue
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/ranpt.for


program Reversal_game
  implicit none

  integer :: list(9) = (/ 1, 2, 3, 4, 5, 6, 7, 8, 9 /)
  integer :: pos, attempts = 0

  call random_seed
  do while (sorted(list))
    call Shuffle(list)
  end do
  write(*, "(9i5)") list
  write(*,*)
  do while (.not. Sorted(list))
    write(*, "(a)", advance="no") "How many numbers from the left do you want to reverse? : "
    read*, pos
    attempts = attempts + 1
    list(1:pos) = list(pos:1:-1)
    write(*, "(9i5)") list
    write(*,*)
  end do
  write(*,*)
  write(*, "(a,i0,a)") "Congratulations! Solved in ", attempts, " attempts"

contains

subroutine Shuffle(a)
  integer, intent(inout) :: a(:)
  integer :: i, randpos, temp
  real :: r

  do i = size(a), 2, -1
    call random_number(r)
    randpos = int(r * i) + 1
    temp = a(randpos)
    a(randpos) = a(i)
    a(i) = temp
  end do
end subroutine

function Sorted(a)
  logical :: Sorted
  integer, intent(in) :: a(:)
  integer :: i

  do i = 1, size(a)-1
    if(list(i+1) /= list(i)+1) then
      Sorted = .false.
      return
    end if
  end do
  Sorted = .true.
end function

end program


      module lhsGkeep

      real*8, allocatable :: lhsG(:)

      end module

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

      subroutine keeplhsG

      use lhsGkeep

      include "common.h"

      allocate ( lhsG(nnz*nshg) )

      return

      end
      subroutine cmass (shp, shgl, xl, em)
c
c----------------------------------------------------------------------
c
c     This subroutine computes the consistent mass matrices
c
c     Ken Jansen, Spring 2000
c----------------------------------------------------------------------
c
c
      include "common.h"
c
      integer ne, na, nb, nodlcla, nodlclb, iel
      dimension
     &     shp(nshl,MAXQPT),   shgl(nsd,nshl,MAXQPT),
     &     em(npro,nshl,nshl),
     &     xl(npro,nenl,nsd)
c
      dimension shape(npro,nshl),   shdrv(npro,nsd,nshl),
     &          sgn(npro,nshl),     dxidx(npro,nsd,nsd),
     &          shg(npro,nshl,nsd),
     &          WdetJ(npro)
c
      em = zero
c
c.... loop through the integration points
c
      do intp = 1, ngauss      ! (these are in common.h)
c
c.... get the hierarchic shape functions at this int point
c
         call getshp(shp,         shgl,         sgn,
     &               shape,       shdrv,        intp)
c
c.... calculate the determinant of the jacobian and weight it
c
         call e3metric( xl, shdrv,dxidx,shg,WdetJ)
c
         do iel = 1, npro
            do  na  = 1, nshl
               do  nb = 1, nshl
                  shp2 = shape(iel,na) * shape(iel,nb)
                  em(iel,na,nb) = em(iel,na,nb) + shp2*WdetJ(iel)
               enddo
            enddo
         enddo
      enddo
c
c.... return
c
      return
      end

      subroutine cmassl (shp, shgl, shpf, shglf, xl, em, Qwtf)
c
c----------------------------------------------------------------------
c
c     This subroutine computes the consistent mass matrices
c
c     Ken Jansen, Spring 2000
c----------------------------------------------------------------------
c
c
      include "common.h"
c
      integer ne, na, nb, nodlcla, nodlclb, iel
      dimension
     &     shp(nshl,MAXQPT),   shgl(nsd,nshl,MAXQPT),
     &     shpf(nshl,MAXQPT),  shglf(nsd,nshl,MAXQPT),
     &     em(npro,nshl,nshl), eml(npro,nshl),
     &     xl(npro,nenl,nsd)
c
      dimension shape(npro,nshl),   shdrv(npro,nsd,nshl),
     &          sgn(npro,nshl),     dxidx(npro,nsd,nsd),
     &          shg(npro,nshl,nsd), Qwtf(ngaussf),
     &          WdetJ(npro)
c
      em = zero
      eml= zero

      if (ifproj.eq.1)then
         nods = nshl
      else
         nods = nenl
      endif

c----------------> Get the lumped mass matrix <-----------------------

c
c.... loop through the integration points
c
      do intp = 1, ngaussf      ! (these are in common.h)
c
c.... get the hierarchic shape functions at this int point
c
         call getshp(shpf,         shglf,         sgn,
     &               shape,       shdrv,        intp)
c
c.... calculate the determinant of the jacobian and weight it
c
         call e3metricf( xl, shdrv,dxidx,shg,WdetJ,Qwtf)
c
         do i=1,nods !nenl !nshl
            eml(:,i) = eml(:,i) + shape(:,i)*WdetJ(:)
         enddo

      enddo ! End loop over quad points.

c--------------> Get the consistent mass matrix <------------------------

      shape = zero
      shdrv = zero
      dxidx = zero
      WdetJ = zero
      shg   = zero

c
c.... loop through the integration points
c
      do intp = 1, ngauss       ! (these are in common.h)

c.... get the hierarchic shape functions at this int point
c
c
c.... for the mass matrix to be consistent shp and shgl must be
c.... evaluated with at least higher quadrature than one-pt. quad.

         call getshp(shp,         shgl,         sgn,
     &               shape,       shdrv,        intp)

c
c.... calculate the determinant of the jacobian and weight it
c
         call e3metric( xl, shdrv,dxidx,shg,WdetJ)
c

         do iel = 1, npro
            do  na  = 1, nods !nenl !nshl
               do  nb = 1, nods !nenl !nshl
                  shp2 = shape(iel,na) * shape(iel,nb)
                  em(iel,na,nb) = em(iel,na,nb) + shp2*WdetJ(iel)
               enddo
            enddo
         enddo

      enddo    ! End loop over quadrature points

c----------> Obtain a mixed (lumped/consistent) mass matrix <------------

c... Different combinations of the lump and mass matrices yield
c... filters of varying widths. In the limiting case were
c... the entire matrix is lumped, we obtain the same filter as
c... in getdmc.f. Note that in these equivalent ways of
c... filtering one-point quadrature is used for shpf and shgl..

      em = (one-flump)*em

      do iel = 1, npro
         do  na  = 1, nods !nenl !nshl
            em(iel,na,na) = em(iel,na,na)+flump*eml(iel,na)
         enddo
      enddo

c
c.... return
c
      return
      end

      subroutine cmasstl (shp, shgl, shpf, shglf, xl, em, Qwtf)
c
c----------------------------------------------------------------------
c
c     This subroutine computes the consistent mass matrices
c
c     Ken Jansen, Spring 2000
c----------------------------------------------------------------------
c
c
      include "common.h"
c
      integer ne, na, nb, nodlcla, nodlclb, iel
      dimension
     &     shp(nshl,MAXQPT),   shgl(nsd,nshl,MAXQPT),
     &     shpf(nshl,MAXQPT),  shglf(nsd,nshl,MAXQPT),
     &     em(npro,nshl,nshl), eml(npro,nshl),
     &     xl(npro,nenl,nsd)
c
      dimension shape(npro,nshl),   shdrv(npro,nsd,nshl),
     &          sgn(npro,nshl),     dxidx(npro,nsd,nsd),
     &          shg(npro,nshl,nsd), Qwtf(ngaussf),
     &          WdetJ(npro)
c
      em = zero
      eml= zero

c----------------> Get the lumped mass matrix <-----------------------

c
c.... loop through the integration points
c
      do intp = 1, ngaussf      ! (these are in common.h)
c
c.... get the hierarchic shape functions at this int point
c
         call getshp(shpf,         shglf,         sgn,
     &               shape,       shdrv,        intp)
c
c.... calculate the determinant of the jacobian and weight it
c
         call e3metricf( xl, shdrv,dxidx,shg,WdetJ,Qwtf)
c
         do i=1,nshl
            eml(:,i) = eml(:,i) + shape(:,i)*WdetJ(:)
         enddo

      enddo ! End loop over quad points.

c--------------> Get the consistent mass matrix <------------------------

      shape = zero
      shdrv = zero
      dxidx = zero
      WdetJ = zero
      shg   = zero

c
c.... loop through the integration points
c
      do intp = 1, ngauss       ! (these are in common.h)

c.... get the hierarchic shape functions at this int point
c
c
c.... for the mass matrix to be consistent shp and shgl must be
c.... evaluated with at least higher quadrature than one-pt. quad.

         call getshp(shp,         shgl,         sgn,
     &               shape,       shdrv,        intp)

c
c.... calculate the determinant of the jacobian and weight it
c
         call e3metric( xl, shdrv,dxidx,shg,WdetJ)
c

         do iel = 1, npro
            do  na  = 1, nshl
               do  nb = 1, nshl
                  shp2 = shape(iel,na) * shape(iel,nb)
                  em(iel,na,nb) = em(iel,na,nb) + shp2*WdetJ(iel)
               enddo
            enddo
         enddo

      enddo    ! End loop over quadrature points

c----------> Obtain a mixed (lumped/consistent) mass matrix <------------

c... Different combinations of the lump and mass matrices yield
c... filters of varying widths. In the limiting case were
c... the entire matrix is lumped, we obtain the same filter as
c... in getdmc.f. Note that in these equivalent ways of
c... filtering one-point quadrature is used for shpf and shgl..

      do iel = 1, npro
         do  na  = 1, nshl
            em(iel,na,na) = eml(iel,na)
         enddo
      enddo

c
c.... return
c
      return
      end

c-----------------------------------------------------------------------
c
c  compute the metrics of the mapping from global to local
c  coordinates and the jacobian of the mapping (weighted by
c  the quadrature weight
c
c-----------------------------------------------------------------------
      subroutine e3metricf(  xl,      shgl,     dxidx,
     &                      shg,     WdetJ, Qwtf)

      include "common.h"

      real*8     xl(npro,nenl,nsd),    shgl(npro,nsd,nshl),
     &           dxidx(npro,nsd,nsd),  shg(npro,nshl,nsd),
     &           WdetJ(npro),          Qwtf(ngaussf)

      real*8     dxdxi(npro,nsd,nsd),  tmp(npro)

c
c.... compute the deformation gradient
c
      dxdxi = zero
c
       do n = 1, nenl
          dxdxi(:,1,1) = dxdxi(:,1,1) + xl(:,n,1) * shgl(:,1,n)
          dxdxi(:,1,2) = dxdxi(:,1,2) + xl(:,n,1) * shgl(:,2,n)
          dxdxi(:,1,3) = dxdxi(:,1,3) + xl(:,n,1) * shgl(:,3,n)
          dxdxi(:,2,1) = dxdxi(:,2,1) + xl(:,n,2) * shgl(:,1,n)
          dxdxi(:,2,2) = dxdxi(:,2,2) + xl(:,n,2) * shgl(:,2,n)
          dxdxi(:,2,3) = dxdxi(:,2,3) + xl(:,n,2) * shgl(:,3,n)
          dxdxi(:,3,1) = dxdxi(:,3,1) + xl(:,n,3) * shgl(:,1,n)
          dxdxi(:,3,2) = dxdxi(:,3,2) + xl(:,n,3) * shgl(:,2,n)
          dxdxi(:,3,3) = dxdxi(:,3,3) + xl(:,n,3) * shgl(:,3,n)
       enddo
c
c.... compute the inverse of deformation gradient
c
       dxidx(:,1,1) =   dxdxi(:,2,2) * dxdxi(:,3,3)
     &                - dxdxi(:,3,2) * dxdxi(:,2,3)
       dxidx(:,1,2) =   dxdxi(:,3,2) * dxdxi(:,1,3)
     &                - dxdxi(:,1,2) * dxdxi(:,3,3)
       dxidx(:,1,3) =  dxdxi(:,1,2) * dxdxi(:,2,3)
     &                - dxdxi(:,1,3) * dxdxi(:,2,2)
       tmp          = one / ( dxidx(:,1,1) * dxdxi(:,1,1)
     &                       + dxidx(:,1,2) * dxdxi(:,2,1)
     &                       + dxidx(:,1,3) * dxdxi(:,3,1) )
       dxidx(:,1,1) = dxidx(:,1,1) * tmp
       dxidx(:,1,2) = dxidx(:,1,2) * tmp
       dxidx(:,1,3) = dxidx(:,1,3) * tmp
       dxidx(:,2,1) = (dxdxi(:,2,3) * dxdxi(:,3,1)
     &                - dxdxi(:,2,1) * dxdxi(:,3,3)) * tmp
       dxidx(:,2,2) = (dxdxi(:,1,1) * dxdxi(:,3,3)
     &                - dxdxi(:,3,1) * dxdxi(:,1,3)) * tmp
       dxidx(:,2,3) = (dxdxi(:,2,1) * dxdxi(:,1,3)
     &                - dxdxi(:,1,1) * dxdxi(:,2,3)) * tmp
       dxidx(:,3,1) = (dxdxi(:,2,1) * dxdxi(:,3,2)
     &                - dxdxi(:,2,2) * dxdxi(:,3,1)) * tmp
       dxidx(:,3,2) = (dxdxi(:,3,1) * dxdxi(:,1,2)
     &                - dxdxi(:,1,1) * dxdxi(:,3,2)) * tmp
       dxidx(:,3,3) = (dxdxi(:,1,1) * dxdxi(:,2,2)
     &                - dxdxi(:,1,2) * dxdxi(:,2,1)) * tmp
c
c       WdetJ = Qwt(lcsyst,intp) / tmp

       WdetJ = Qwtf(intp) / tmp
c
c.... compute the global gradient of shape-functions
c
       do n = 1, nshl
          shg(:,n,1) = shgl(:,1,n) * dxidx(:,1,1) +
     &                 shgl(:,2,n) * dxidx(:,2,1) +
     &                 shgl(:,3,n) * dxidx(:,3,1)
          shg(:,n,2) = shgl(:,1,n) * dxidx(:,1,2) +
     &                 shgl(:,2,n) * dxidx(:,2,2) +
     &                 shgl(:,3,n) * dxidx(:,3,2)
          shg(:,n,3) = shgl(:,1,n) * dxidx(:,1,3) +
     &                 shgl(:,2,n) * dxidx(:,2,3) +
     &                 shgl(:,3,n) * dxidx(:,3,3)
       enddo

       return
       end


*DECK ACOSH
      FUNCTION ACOSH (X)
C***BEGIN PROLOGUE  ACOSH
C***PURPOSE  Compute the arc hyperbolic cosine.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C4C
C***TYPE      SINGLE PRECISION (ACOSH-S, DACOSH-D, CACOSH-C)
C***KEYWORDS  ACOSH, ARC HYPERBOLIC COSINE, ELEMENTARY FUNCTIONS, FNLIB,
C             INVERSE HYPERBOLIC COSINE
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C ACOSH(X) computes the arc hyperbolic cosine of X.
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  R1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770401  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C***END PROLOGUE  ACOSH
      SAVE ALN2,XMAX
      DATA ALN2 / 0.6931471805 5994530942E0/
      DATA XMAX /0./
C***FIRST EXECUTABLE STATEMENT  ACOSH
      IF (XMAX.EQ.0.) XMAX = 1.0/SQRT(R1MACH(3))
C
      IF (X .LT. 1.0) CALL XERMSG ('SLATEC', 'ACOSH', 'X LESS THAN 1',
     +   1, 2)
C
      IF (X.LT.XMAX) ACOSH = LOG (X + SQRT(X*X-1.0))
      IF (X.GE.XMAX) ACOSH = ALN2 + LOG(X)
C
      RETURN
      END


PROGRAM cu_logical

  USE constants
  USE lib_functions
  USE upd_nodes
  USE upd_edges

  IMPLICIT NONE

  INTEGER::it_max, it, var_index, node_index
  REAL::int_convert, it_convert
  REAL,DIMENSION(:),ALLOCATABLE::nodes, edges, p, q, new_nodes, new_edges, pert_pw, pert_init, pert_end

  CHARACTER(:),ALLOCATABLE::output

!!! Initializing constants
  it_max = <%= iterations %> ! number of iterations performed during the simulation (30 iterations = 6 months)
  int_convert = 5.0
  it_convert= (it_max/100.0)

!!! Arrays initialization
  ALLOCATE(p(nb_edges))
  ALLOCATE(q(nb_edges))
  ALLOCATE(new_nodes(nb_nodes))
  ALLOCATE(new_edges(nb_edges))
  ALLOCATE(nodes(nb_nodes))
  ALLOCATE(edges(nb_edges))
! ============================================================
! Perturbations arrays initialization
! ============================================================
  ALLOCATE(pert_pw(nb_nodes))
  ALLOCATE(pert_init(nb_nodes))
  ALLOCATE(pert_end(nb_nodes))

!!! Initial state
  nodes = 0.0     ! all initial conditions are set to 0, except those set manually (see below)

<%= initialValues %>

! ============================================================
!!! initializing perturbations pw
! ============================================================
<%= pert_pws %>

! ============================================================
!!! initializing perturbations init
! ============================================================
<%= pert_inits %>

!!! initializing perturbations end
! ============================================================
<%= pert_ends %>

! ============================================================
!!! initializing edges' strengths & latencies
! ============================================================
! Random version

CALL init_random_seed()
CALL RANDOM_NUMBER(p)
CALL RANDOM_NUMBER(q)

! initializing edges p values
<%= ps %>

! initializing edges q values
<%= qs %>

!!! initializing nodes & computing first edges
  !nodes = nodes_0
  edges = update_edges(nodes)

!!! computing states for all but the one last iteration: this is where the perturbations act on the nodes
  DO it = 1, it_max
    !! computing next node values
    new_nodes = update_nodes(edges, nodes)
    !! applying perturbations
    DO node_index = 1, nb_nodes
        if (pert_pw(node_index) >= 0.0 .AND. it <= pert_end(node_index) .AND.  it >= pert_init(node_index)) then
          nodes(node_index) =  pert_pw(node_index)
        end if
    END DO
    !! computing the next edges values
    new_edges = (1.0 - p) * edges + q * p * update_edges(nodes)
    !!! this outputs the nodes before their update

    output = real2char(nodes(1))
    DO var_index = 2, nb_nodes
        output=output // "," // real2char(nodes(var_index))
    END DO

     WRITE (unit=*,fmt="(a)") output

!!! updating the edges / nodes
     edges = new_edges
     nodes = new_nodes

  END DO

!!! freeing resources
  DEALLOCATE(p, q, new_nodes, new_edges, nodes, edges, pert_pw, pert_init, pert_end)

END PROGRAM cu_logical