      SUBROUTINE SG02CV( DICO, JOB, JOBE, UPLO, TRANS, N, A, LDA, E,
     $                   LDE, X, LDX, R, LDR, NORMS, DWORK, LDWORK,
     $                   INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute the residual matrix R for a continuous-time or
C     discrete-time "reduced" Lyapunov equation, using the formulas
C
C        R = op(A)'*X + X*op(A) + Q,
C     or
C        R = op(A)'*X*op(E) + op(E)'*X*op(A) + Q,
C
C     in the continuous-time case, or the formulas
C
C        R = op(A)'*X*op(A) - X + Q,
C     or
C        R = op(A)'*X*op(A) - op(E)'*X*op(E) + Q,
C
C     in the discrete-time case, where X and Q are symmetric matrices,
C     A is in upper real Schur form, E is upper triangular, and op(W) is
C
C        op(W) = W   or   op(W) = W'.
C
C     Optionally, the Frobenius norms of the product terms defining the
C     denominator of the relative residual are also computed. The norms
C     of Q and X are not computed.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     DICO    CHARACTER*1
C             Specifies the type of the Lyapunov equation, as follows:
C             = 'C':  continuous-time Lyapunov equation;
C             = 'D':  discrete-time Lyapunov equation.
C
C     JOB     CHARACTER*1
C             Specifies which results must be computed, as follows:
C             = 'R':  The matrix R only must be computed;
C             = 'N':  The matrix R and the norms must be computed;
C             = 'B':  The matrix R and the norms must be computed.
C
C     JOBE    CHARACTER*1
C             Specifies whether E is a general or an identity matrix,
C             as follows:
C             = 'G':  The matrix E is general and is given;
C             = 'I':  The matrix E is assumed identity and is not given.
C
C     UPLO    CHARACTER*1
C             Specifies which triangles of the symmetric matrices X and
C             Q are given, as follows:
C             = 'U':  The upper triangular part is given;
C             = 'L':  The lower triangular part is given.
C
C     TRANS   CHARACTER*1
C             Specifies the form of op(W) to be used in the formulas
C             above, as follows:
C             = 'N':  op(W) = W;
C             = 'T':  op(W) = W';
C             = 'C':  op(W) = W'.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrices A, E, Q, X, and R.  N >= 0.
C
C     A       (input) DOUBLE PRECISION array, dimension (LDA,N)
C             The leading N-by-N upper part of this array must contain
C             the upper real Schur matrix A.
C             If TRANS = 'N' and (DICO = 'D' or (JOB = 'R' and
C             JOBE = 'G')), the entries 3, 4,..., N of the first column
C             are modified internally, but are restored on exit.
C             Otherwise, the part of this array below the first
C             subdiagonal is not referenced.
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= MAX(1,N).
C
C     E       (input) DOUBLE PRECISION array, dimension (LDE,*)
C             If JOBE = 'G', the leading N-by-N upper triangular part of
C             this array must contain the upper triangular matrix E.
C             The strictly lower triangular part of this array is not
C             referenced.
C             If JOBE = 'I', this array is not referenced.
C
C     LDE     INTEGER
C             The leading dimension of array E.
C             LDE >= MAX(1,N), if JOBE = 'G';
C             LDE >= 1,        if JOBE = 'I'.
C
C     X       (input/works.) DOUBLE PRECISION array, dimension (LDX,N)
C             On entry, if UPLO = 'U', the leading N-by-N upper
C             triangular part of this array must contain the upper
C             triangular part of the symmetric matrix X and the strictly
C             lower triangular part of the array is not referenced.
C             On entry, if UPLO = 'L', the leading N-by-N lower
C             triangular part of this array must contain the lower
C             triangular part of the symmetric matrix X and the strictly
C             upper triangular part of the array is not referenced.
C             If DICO = 'D' or (JOB = 'R' and JOBE = 'G'), the diagonal
C             elements of this array are modified internally, but they
C             are restored on exit.
C
C     LDX     INTEGER
C             The leading dimension of array X.  LDX >= MAX(1,N).
C
C     R       (input/output) DOUBLE PRECISION array, dimension (LDR,*)
C             On entry, the leading N-by-N upper or lower triangular
C             part (depending on UPLO) of this array must contain the
C             upper or lower triangular part, respectively, of the
C             matrix Q. The other strictly triangular part is not
C             referenced.
C             On exit, the leading N-by-N upper or lower triangular
C             part (depending on UPLO) of this array contains the upper
C             or lower triangular part, respectively, of the matrix R.
C
C     LDR     INTEGER
C             The leading dimension of array R.  LDR >= MAX(1,N).
C
C     NORMS   (output) DOUBLE PRECISION array, dimension (LN)
C             If JOB = 'N' or JOB = 'B', LN = 1 or 2, if (DICO = 'C' or
C             JOBE = 'I'), or (DICO = 'D' and JOBE = 'G'), respectively.
C             If DICO = 'C',
C             NORMS(1) contains the Frobenius norm of the matrix
C             op(A)'*X (or of X*op(A)), if JOBE = 'I', or of the matrix
C             op(A)'*X*op(E) (or of op(E)'*X*op(A)), if JOBE = 'G'.
C             If DICO = 'D',
C             NORMS(1) contains the Frobenius norm of the matrix
C             op(A)'*X*op(A);
C             if JOBE = 'G', NORMS(2) contains the Frobenius norm of the
C             matrix op(E)'*X*op(E).
C             If JOB <> 'N', this array is not referenced.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = -17 or if LDWORK = -2 on input, then
C             DWORK(1) returns the minimum value of LDWORK.
C             On exit, if INFO = 0, or if LDWORK = -1 on input, then
C             DWORK(1) returns the optimal value of LDWORK.
C
C     LDWORK  The length of the array DWORK. LDWORK >= MAX(v,1), with v
C             specified in the following table, where
C                a = 1, if JOBE = 'G';
C                a = 0, if JOBE = 'I'.
C
C             DICO   JOB             v
C             ----------------------------
C             'C'    'R'           a*N*N
C             'C'    'N','B'         N*N
C             ----------------------------
C             'D'    'R'             N*N
C             'D'    'N','B'       2*N*N
C             ----------------------------
C
C             If LDWORK = -1, an optimal workspace query is assumed; the
C             routine only calculates the optimal size of the DWORK
C             array, returns this value as the first entry of the DWORK
C             array, and no error message is issued by XERBLA.
C
C             If LDWORK = -2, a minimal workspace query is assumed; the
C             routine only calculates the minimal size of the DWORK
C             array, returns this value as the first entry of the DWORK
C             array, and no error message is issued by XERBLA.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value.
C
C     METHOD
C
C     The matrix expressions are efficiently evaluated, using symmetry.
C     If JOB = 'N' or JOB = 'B', then:
C     If DICO = 'C', the matrices op(op(A)'*X*op(E)) or op(X*op(A)), are
C     efficiently computed.
C     If DICO = 'D', the matrices op(A)'*X*op(A) and op(E)'*X*op(E), if
C     JOBE = 'G', are efficiently computed. The results are used to
C     evaluate R and the norms.
C     If JOB = 'R', then the needed parts of the intermediate results
C     are obtained and used to evaluate R.
C
C     NUMERICAL ASPECTS
C
C     The calculations are backward stable.
C
C     The algorithm requires approximately a*N^3 operations, where ^
C     denotes the power operator, and
C
C        a = 1,      if DICO = 'C' and JOB <> 'R' and JOBE = 'G';
C        a = 1/2,    otherwise.
C
C     An "operation" includes a multiplication, an addition, and some
C     address calculations.
C
C     CONTRIBUTORS
C
C     V. Sima, Research Institute for Informatics, Bucharest, Feb. 2019.
C
C     REVISIONS
C
C     V. Sima, Apr. 2019.
C
C     KEYWORDS
C
C     Algebraic Lyapunov equation, elementary matrix operations, matrix
C     algebra, matrix operations.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         DICO, JOB, JOBE, TRANS, UPLO
      INTEGER           INFO, LDA, LDE, LDR, LDWORK, LDX, N
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LDA,*), DWORK(*), E(LDE,*), NORMS(*),
     $                  R(LDR,*), X(LDX,*)
C     .. Local Scalars ..
      CHARACTER         NTRANS
      LOGICAL           DISCR, LJOBE, LJOBN, LJOBR, LTRANS, LUPLO,
     $                  UNITE
      INTEGER           J, MINWRK, NN, OPTWRK
C     .. External Functions ..
      LOGICAL           LSAME
      DOUBLE PRECISION  DLANGE, DLANSY
      EXTERNAL          DLANGE, DLANSY, LSAME
C     .. External Subroutines ..
      EXTERNAL          DAXPY, MB01OC, MB01OD, MB01OO, MB01OS, MB01RH,
     $                  MB01RT, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         MAX
C     .. Executable Statements ..
C
C     Test the input scalar arguments.
C
      INFO = 0
C
      DISCR  = LSAME( DICO,  'D' )
      LJOBN  = LSAME( JOB,   'N' ) .OR. LSAME( JOB, 'B' )
      LJOBR  = LSAME( JOB,   'R' )
      LJOBE  = LSAME( JOBE,  'G' )
      LUPLO  = LSAME( UPLO,  'U' )
      LTRANS = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' )
      UNITE  = .NOT.LJOBE
C
      IF (     .NOT.DISCR  .AND. .NOT.LSAME( DICO,  'C' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.LJOBN  .AND. .NOT.LJOBR ) THEN
         INFO = -2
      ELSE IF(      UNITE  .AND. .NOT.LSAME( JOBE,  'I' ) ) THEN
         INFO = -3
      ELSE IF( .NOT.LUPLO  .AND. .NOT.LSAME( UPLO,  'L' ) ) THEN
         INFO = -4
      ELSE IF( .NOT.LTRANS .AND. .NOT.LSAME( TRANS, 'N' ) ) THEN
         INFO = -5
      ELSE IF( N.LT.0 ) THEN
         INFO = -6
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -8
      ELSE IF( LDE.LT.1  .OR. ( LJOBE .AND. LDE.LT.N ) ) THEN
         INFO = -10
      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
         INFO = -12
      ELSE IF( LDR.LT.MAX( 1, N ) ) THEN
         INFO = -14
      ELSE
         NN = N*N
C
         IF ( LJOBN ) THEN
            IF ( DISCR ) THEN
               MINWRK = 2*NN
            ELSE
               MINWRK = NN
            END IF
         ELSE IF ( .NOT.DISCR .AND. UNITE ) THEN
            MINWRK = 0
         ELSE
            MINWRK = NN
         END IF
C
         OPTWRK = MINWRK
C
         IF ( LDWORK.EQ.-2 ) THEN
            DWORK(1) = MAX( 1, MINWRK )
            RETURN
         ELSE IF ( LDWORK.EQ.-1 ) THEN
            DWORK(1) = MAX( 1, OPTWRK )
            RETURN
         END IF
C
         IF ( LDWORK.LT.MINWRK ) THEN
            INFO = -17
            DWORK(1) = MAX( 1, MINWRK )
         END IF
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'SG02CV', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF ( N.EQ.0 ) THEN
         IF ( .NOT.LJOBR ) THEN
            NORMS(1) = ZERO
            IF ( DISCR .AND. LJOBE )
     $         NORMS(2) = ZERO
         END IF
         RETURN
      END IF
C
      IF ( LTRANS ) THEN
         NTRANS = 'NoTran'
      ELSE
         NTRANS = 'Tran'
      END IF
C
      IF ( LJOBR ) THEN
C
C        JOB = 'R'.
C
         IF ( DISCR ) THEN
C
C           Discrete-time case.
C
C           Compute in R a triangle of the symmetric matrix
C              R = Q + A'*X*A,  if TRANS = 'N';
C              R = Q + A*X*A',  if TRANS = 'T'.
C
C           Workspace: N*N.
C
            CALL MB01RH( UPLO, NTRANS, N, ONE, ONE, R, LDR, A, LDA, X,
     $                   LDX, DWORK, LDWORK, INFO )
C
            IF ( UNITE ) THEN
C
C              Subtract the triangle of X from R.
C
               IF ( LUPLO ) THEN
C
                  DO 10 J = 1, N
                     CALL DAXPY( J, -ONE, X(1,J), 1, R(1,J), 1 )
   10             CONTINUE
C
               ELSE
C
                  DO 20 J = 1, N
                     CALL DAXPY( N-J+1, -ONE, X(J,J), 1, R(J,J), 1 )
   20             CONTINUE
C
               END IF
C
            ELSE
C
C              Subtract the triangle of op(E)'*X*op(E) from R.
C
C              Workspace: N*N.
C
               CALL MB01RT( UPLO, NTRANS, N, ONE, -ONE, R, LDR, E, LDE,
     $                      X, LDX, DWORK, LDWORK, INFO )
            END IF
C
         ELSE
C
C           Continuous-time case.
C
            IF ( LJOBE ) THEN
C
C              Compute in R a triangle of
C                 R = op(A)'*X*op(E) + op(E)'*X*op(A) + Q.
C
C              Workspace N*N.
C
               CALL MB01OD( UPLO, NTRANS, N, ONE, ONE, R, LDR, A, LDA,
     $                      X, LDX, E, LDE, DWORK, NN, INFO )
C
            ELSE
C
C              Compute in R a triangle of
C                 R = op(A)'*X + X*op(A) + Q.
C
               CALL MB01OC( UPLO, NTRANS, N, ONE, ONE, R, LDR, A, LDA,
     $                      X, LDX, INFO )
            END IF
C
         END IF
C
      ELSE
C
C        JOB = 'B' or 'N'.
C
         IF ( DISCR ) THEN
C
C           Discrete-time case.
C
            IF ( LJOBE ) THEN
C
C              Compute in DWORK a triangle of op(E)'*X*op(E) and its
C              norm.
C
C              Workspace: 2*N*N.
C
               CALL MB01RT( UPLO, NTRANS, N, ZERO, ONE, DWORK, N, E,
     $                      LDE, X, LDX, DWORK(NN+1), LDWORK, INFO )
C
               NORMS(2) = DLANSY( 'F-norm', UPLO, N, DWORK, N, DWORK )
C
C              Compute in R the triangle of Q - op(E)'*X*op(E).
C
               IF ( LUPLO ) THEN
C
                  DO 30 J = 1, N
                     CALL DAXPY( J, -ONE, DWORK(1+(J-1)*N), 1, R(1,J),
     $                           1 )
   30             CONTINUE
C
               ELSE
C
                  DO 40 J = 1, N
                     CALL DAXPY( N-J+1, -ONE, DWORK(J+(J-1)*N), 1,
     $                           R(J,J), 1 )
   40             CONTINUE
C
               END IF
C
            ELSE
C
C              Compute in R the triangle of Q - X.
C
               IF ( LUPLO ) THEN
C
                  DO 50 J = 1, N
                     CALL DAXPY( J, -ONE, X(1,J), 1, R(1,J), 1 )
   50             CONTINUE
C
               ELSE
C
                  DO 60 J = 1, N
                     CALL DAXPY( N-J+1, -ONE, X(J,J), 1, R(J,J), 1 )
   60             CONTINUE
C
               END IF
C
            END IF
C
C           Compute in DWORK a triangle of op(A)'*X*op(A) and its norm.
C
C           Workspace: 2*N*N.
C
            CALL MB01RH( UPLO, NTRANS, N, ZERO, ONE, DWORK, N, A, LDA,
     $                   X, LDX, DWORK(NN+1), NN, INFO )
C
            NORMS(1) = DLANSY( 'F-norm', UPLO, N, DWORK, N, DWORK )
C
C           Update the triangle of R := R + op(A)'*X*op(A).
C
            IF ( LUPLO ) THEN
C
               DO 70 J = 1, N
                  CALL DAXPY( J, ONE, DWORK(1+(J-1)*N), 1, R(1,J), 1 )
   70          CONTINUE
C
            ELSE
C
               DO 80 J = 1, N
                  CALL DAXPY( N-J+1, ONE, DWORK(J+(J-1)*N), 1, R(J,J),
     $                        1 )
   80          CONTINUE
C
            END IF
C
         ELSE
C
C           Continuous-time case.
C
            IF ( LJOBE ) THEN
C
C              Compute in DWORK
C                 E'*X*A,  if TRANS = 'N';
C                 A*X*E',  if TRANS = 'T'.
C
C              Workspace: N*N.
C
               CALL MB01OO( UPLO, NTRANS, N, A, LDA, X, LDX, E, LDE,
     $                      DWORK, N, INFO )
C
            ELSE
C
C              Compute in DWORK
C                 A*X,  if TRANS = 'N';
C                 X*A,  if TRANS = 'T'.
C
C              Workspace: N*N.
C
               CALL MB01OS( UPLO, NTRANS, N, A, LDA, X, LDX, DWORK, N,
     $                      INFO )
C
            END IF
C
C           Compute the norm of the product P.
C
            NORMS(1) = DLANGE( 'F-norm', N, N, DWORK, N, DWORK )
C
C           Compute in R a triangle of Q + P + P'.
C
            IF ( LUPLO ) THEN
C
               DO 90 J = 1, N
                  CALL DAXPY( J, ONE, DWORK(1+(J-1)*N), 1, R(1,J), 1 )
                  CALL DAXPY( J, ONE, DWORK(J), N, R(1,J), 1 )
   90          CONTINUE
C
            ELSE
C
               DO 100 J = 1, N
                  CALL DAXPY( N-J+1, ONE, DWORK(J+(J-1)*N), 1, R(J,J),
     $                        1 )
                  CALL DAXPY( N-J+1, ONE, DWORK(J+(J-1)*N), N, R(J,J),
     $                        1 )
  100          CONTINUE
C
            END IF
C
         END IF
C
      END IF
C
      DWORK(1) = MAX( 1, OPTWRK )
C
      RETURN
C *** Last line of SG02CV ***
      END


SUBROUTINE p66(input_file,output_file)
!-------------------------------------------------------------------------
! Program 6.6 Plane strain bearing capacity analysis of an elastic-plastic
!             (von Mises) material using 8-node rectangular quadrilaterals.
!             Flexible smooth footing. Load control.
!             Consistent tangent stiffness.
!             Closest Point Projection Method (CPPM).
!-------------------------------------------------------------------------
 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,incs,iters,iy,k,limit,loaded_nodes,ndim=2,ndof=16,nels,   &
   neq,nip=4,nlen,nn,nod=8,nodof=2,nprops=3,np_types,nst=4,nxe,nye
 REAL(iwp)::bot,det,dlam,dsbar,dslam,d3=3.0_iwp,end_time,fnew,lode_theta, &
   ltol,one=1.0_iwp,ptot,sigm,start_time,tol,zero=0.0_iwp
 CHARACTER(LEN=15)::argv,element='quadrilateral'
 LOGICAL::converged
!-----------------------dynamic arrays------------------------------------
 INTEGER,ALLOCATABLE::etype(:),g(:),g_g(:,:),g_num(:,:),kdiag(:),nf(:,:), &
   node(:),num(:)
 REAL(iwp),ALLOCATABLE::acat(:,:),bee(:,:),bdylds(:),caflow(:),&
   coord(:,:),daatd(:,:),ddylds(:),dee(:,:),der(:,:),deriv(:,:),dload(:), &
   dsigma(:),eld(:),eload(:),eps(:),g_coord(:,:),jac(:,:),km(:,:),kv(:),  &
   loads(:),loadsr(:),points(:,:),prop(:,:),qinc(:),qinva(:),qinvr(:),    &
   qmat(:,:),ress(:),rmat(:,:),sigma(:),stress(:),tensor(:,:,:),          &
   tensorl(:,:,:),totd(:),totdl(:),trial(:),val(:,:),vmfl(:),vmfla(:),    &
   vmflq(:),weights(:),x_coords(:),y_coords(:)
!-----------------------input and initialisation--------------------------

 OPEN(10,FILE=input_file)
 OPEN(11,FILE=output_file)
 CALL CPU_TIME(start_time)
 READ(10,*)nxe,nye,np_types
 CALL mesh_size(element,nod,nels,nn,nxe,nye)
 ALLOCATE(nf(nodof,nn),points(nip,ndim),weights(nip),g_coord(ndim,nn),    &
   x_coords(nxe+1),y_coords(nye+1),num(nod),dee(nst,nst),                 &
   tensor(nst,nip,nels),g_g(ndof,nels),coord(nod,ndim),jac(ndim,ndim),    &
   der(ndim,nod),deriv(ndim,nod),g_num(nod,nels),bee(nst,ndof),           &
   km(ndof,ndof),eld(ndof),eps(nst),sigma(nst),eload(ndof),g(ndof),       &
   vmfl(nst),qinvr(nst),stress(nst),dload(ndof),caflow(nst),dsigma(nst),  &
   ress(nst),rmat(nst,nst),acat(nst,nst),qmat(nst,nst),qinva(nst),        &
   daatd(nst,nst),vmflq(nst),vmfla(nst),prop(nprops,np_types),etype(nels),&
   tensorl(nst,nip,nels),trial(nst))
 READ(10,*)prop
 etype=1
 IF(np_types>1)READ(10,*)etype
 READ(10,*)x_coords,y_coords
 CALL bc_rect(nxe,nye,nf,'y')
 neq=MAXVAL(nf)
 ALLOCATE(kdiag(neq),loads(0:neq),bdylds(0:neq),totd(0:neq),ddylds(0:neq),&
   loadsr(0:neq),totdl(0:neq))
   kdiag=0
!-----------------------loop the elements to find global arrays sizes-----
 elements_1: DO iel=1,nels
   CALL geom_rect(element,iel,x_coords,y_coords,coord,num,'y')
   CALL num_to_g(num,nf,g)
   CALL fkdiag(kdiag,g)
   g_num(:,iel)=num
   g_coord(:,num)=TRANSPOSE(coord)
   g_g(:,iel)=g
 END DO elements_1
 CALL mesh(g_coord,g_num,argv,nlen,12)
 DO i=2,neq
   kdiag(i)=kdiag(i)+kdiag(i-1)
 END DO
 ALLOCATE(kv(kdiag(neq)))
 WRITE(11,'(2(A,I7))')                                                    &
   " There are",neq," equations and the skyline storage is",kdiag(neq)
 kv=zero
 totd=zero
 tensor=zero
 tensorl=zero
 CALL sample(element,points,weights)
!--------------starting element stiffness integration and assembly--------
 elements_2: DO iel=1,nels
   CALL deemat(dee,prop(2,etype(iel)),prop(3,etype(iel)))
   num=g_num(:,iel)
   coord=TRANSPOSE(g_coord(:,num))
   g=g_g(:,iel)
   km=zero
   gauss_pts_1: DO i=1,nip
     CALL shape_der(der,points,i)
     jac=MATMUL(der,coord)
     det=determinant(jac)
     CALL invert(jac)
     deriv=MATMUL(jac,der)
     CALL beemat(bee,deriv)
     km=km+MATMUL(MATMUL(TRANSPOSE(bee),dee),bee)*det*weights(i)
   END DO gauss_pts_1
   CALL fsparv(kv,km,g,kdiag)
 END DO elements_2
!-----------------------read load weightings and factorise equations------
 READ(10,*)loaded_nodes
 ALLOCATE(node(loaded_nodes),val(loaded_nodes,ndim))
 READ(10,*)(node(i),val(i,:),i=1,loaded_nodes)
 CALL sparin(kv,kdiag)
!-------------------------------------------------------------------------
 READ(10,*)ltol,tol,limit,incs
 ALLOCATE(qinc(incs))
 READ(10,*)qinc
 ptot=zero
 WRITE(11,'(/A)')"  step   load        disp      iters"
 load_increments: DO iy=1,incs
   ptot=ptot+qinc(iy)
   totdl=zero
   loads=zero
   loadsr=zero
   bdylds=zero
   iters=0
!-----------------------load increment loop-------------------------------
   DO i=1,loaded_nodes
     loads(nf(:,node(i)))=val(i,:)*qinc(iy)   ! load increment
     loadsr(nf(:,node(i)))=val(i,:)*ptot      ! total load
   END DO
!-----------------------plastic iteration loop----------------------------
   iterations: DO
     iters=iters+1
     WRITE(*,'(A,F8.2,A,I4)')"  load",ptot,"  iteration",iters
     IF(iters/=1)loads=zero
     loads=loads+bdylds
     CALL spabac(kv,loads,kdiag)
     loads(0)=zero
     totdl=totdl+loads
     ddylds=zero
     kv=zero
!-----------------------go round the Gauss Points ------------------------
     elements_3: DO iel=1,nels
       dload=zero
       num=g_num(:,iel)
       coord=TRANSPOSE(g_coord(:,num))
       g=g_g(:,iel)
       km=zero
       eld=totdl(g)
       gauss_pts_2: DO i=1,nip
         CALL shape_der(der,points,i)
         jac=MATMUL(der,coord)
         det=determinant(jac)
         CALL invert(jac)
         deriv=MATMUL(jac,der)
         CALL beemat(bee,deriv)
         eps=MATMUL(bee,eld)
         CALL deemat(dee,prop(2,etype(iel)),prop(3,etype(iel)))
         sigma=MATMUL(dee,eps)
         stress=sigma+tensorl(:,i,iel)
         trial=stress
         CALL invar(stress,sigm,dsbar,lode_theta)
!-----------------------check whether yield is violated-------------------
         fnew=dsbar-SQRT(d3)*prop(1,etype(iel))
         IF(fnew>=zero)THEN
           dlam=zero
           iterate_on_fnew: DO
             CALL vmflow(stress,dsbar,vmfl)
             caflow=MATMUL(dee,vmfl)
             ress=stress-trial+caflow*dlam
             CALL fmacat(vmfl,acat)
             acat=acat/dsbar
             qmat=dlam*MATMUL(dee,acat)
             DO k=1,4
               qmat(k,k)=qmat(k,k)+one
             END DO
             CALL invert(qmat)
             vmflq=MATMUL(vmfl,qmat)
             vmfla=MATMUL(vmflq,dee)
             dslam=(fnew-DOT_PRODUCT(vmflq,ress))/DOT_PRODUCT(vmfla,vmfl)
             dsigma=-MATMUL(qmat,ress)-MATMUL(MATMUL(qmat,dee),vmfl)*dslam
             stress=stress+dsigma
             CALL invar(stress,sigm,dsbar,lode_theta)
             fnew=dsbar-SQRT(d3)*prop(1,etype(iel))
             dlam=dlam+dslam
             IF(fnew<ltol)EXIT
           END DO iterate_on_fnew
           CALL vmflow(stress,dsbar,vmfl)
           CALL fmrmat(vmfl,dsbar,dlam,dee,rmat)
           caflow=MATMUL(rmat,vmfl)
           bot=DOT_PRODUCT(vmfl,caflow)
           CALL formaa(vmfl,rmat,daatd)
           dee=rmat-daatd/bot
         END IF
         km=km+MATMUL(MATMUL(TRANSPOSE(bee),dee),bee)*det*weights(i)
!-----------------------update the Gauss Point stresses-------------------
         tensor(:,i,iel)=stress
         eload=MATMUL(stress,bee)
         dload=dload+eload*det*weights(i)
       END DO gauss_pts_2
!-----------------------compute the total bodyloads vector----------------
       ddylds(g)=ddylds(g)+dload
       ddylds(0)=zero
       CALL fsparv(kv,km,g,kdiag)
     END DO elements_3
     CALL sparin(kv,kdiag)
     bdylds=loadsr-ddylds
     bdylds(0)=zero
     IF(norm(bdylds(1:))/norm(loadsr(1:))<tol)converged=.TRUE.
     IF(iters==1)converged=.FALSE.
     IF(converged.OR.iters==limit)EXIT
   END DO iterations
   tensorl=tensor
   totd=totd+totdl
   WRITE(11,'(I5,2E12.4,I5)')iy,ptot,totd(nf(2,node(1))),iters
   IF(iters==limit)EXIT
 END DO load_increments
 CALL dismsh(totd,nf,0.05_iwp,g_coord,g_num,argv,nlen,13)
 CALL vecmsh(totd,nf,0.05_iwp,0.1_iwp,g_coord,g_num,argv,nlen,14)
 CALL CPU_TIME(end_time)
 WRITE(11,'(A,F12.4)')" Time taken = ",end_time-start_time

END SUBROUTINE p66


module struct_fact
!! Computes the struture factor from the radial distribution functions.
use iso_fortran_env
use iso_c_binding
use sinft
implicit none

real(8), parameter, private :: PI=3.141592653589793

private :: eleFFS, do_dst

contains

function EleFFS(q, r)
  !! Proportional to the form factor of a sphere.
  real(8) :: EleFFS
  real(8), intent(in) :: q,r
  real(8) :: x
  x=q*r
  eleFFs = sin(x)-x*cos(x)
end function

subroutine do_dst(n, y, out)
  !! Do a sinus tranform of y-1.
  integer :: n !! dat length
  real(8), intent(in) :: y(n) !! input data
  real(8) :: out(n) !! result
  real(8) :: in(n)
  integer :: i
  do i=1,n
    in(i) = (y(i)-1.D0)*(real(i,8)-0.5D0)
  end do
  call sinft_calc(n, in, out)
end subroutine

subroutine calc_sdeq( dx, n,  q,  sf,  pf, nqext,qext,  sfext, ng,  gder, nf,  pop&
	      &,  rad,  phi)
  !! Calculates S(q) from RDFs.
  use spline
  integer, intent(in) :: n !! length of q array
  integer, intent(in) :: nqext !! length of qext
  integer, intent(in) :: ng  !! lenght of RDFs
  integer, intent(in) :: nf  !! number of families
  real(8), intent(in) :: dx  !! space bin of RDFs
  real(8), intent(in) :: phi !! volume fraction
  real(8) :: q(n) !! wave numbers
  real(8) :: sf(n) !! struture factor
  real(8) :: pf(n) !! form factor
  real(8) :: qext(nqext) !! new q values
  real(8) :: sfext(nqext) !! interpolated struture factor
  real(8) :: gder(n,ng)  !! RDFs
  real(8) :: pop(nf)     !! family populations
  real(8) :: rad(nf)     !! family radii

  integer :: i, j,k,ind
  real(8) :: vp, gsk, dump,dsq
  real(8), allocatable :: s(:),g(:),rho(:),sf2ip(:)
  allocate(s(n),g(n),rho(nf))

  if(ng /= (nf*(nf+1))/2) stop "calc_sqdeq: ng != (nf*(nf+1))/2"

  vp=0.0
  do i=1,nf
    vp = vp + pop(i)*4.D0/3.D0*PI*(rad(i)**3)
  end do
  do i=1,nf
    rho(i) = pop(i)*phi/vp
  end do

  do k=1,n
    q(k) = (PI*(k))/(dx*n);
  end do

  sf = 0.D0
  pf = 0.D0

  ind = 0
  do i=1,nf
    ind = ind + 1
    do k=1,n
      g(k) = gder(k,ind)
    end do
    call do_dst(n, g, s)
    do k=1,n
      gsk = 1.d0 + (2.d0*PI*(rho(i)*dx*dx)/q(k))*s(k)
      dump = EleFFS(q(k), rad(i))*EleFFS(q(k), rad(i))*rho(i)
      sf(k) = sf(k) + gsk*dump
      pf(k) = pf(k) + dump
    end do
  end do
  do i=1,nf
    do j=i+1,nf
      ind = ind + 1
      do k=1,n
        g(k) = gder(k,ind)
      end do
      call do_dst(n, g, s)
      do k=1,n
        dsq = sqrt(rho(i)*rho(j))
        gsk = 2.D0*PI*(dsq*dx*dx)/q(k)*s(k)
        dump = EleFFS(q(k), rad(i))*EleFFS(q(k), rad(j))*dsq;
        sf(k) = sf(k) + 2.D0*gsk*dump
      end do
    end do
  end do
  call sinft_cleanup()
  sf = sf / pf

  allocate(sf2ip(n))
  call cubspline_init(n, q, sf,sf2ip)
  call cubspline_equalsep_eval(n,q,sf,sf2ip,nqext,qext, sfext)

end subroutine

end module struct_fact


	PROGRAM FERROR
C
C	THIS PROGRAM CALCULATES THE ERROR AND THE CHANGEOVER POINT BETWEEN
C	THE POWER SERIES AND THE ASYMPTOTIC SERIES FOR SUBROUTINE F
C	EVALUATE ERROR IN POWER SERIES
	EPS = 1.E-7                 !  SINGLE PRECISION ROUNDOFF ERROR
C
	DO N = 1,20
	  ALPHA = 2.1 + .1*(N-1)
	  A2 = ALPHA**2
C	  ERR = .5*EPS*SQRT(1./(2.*A2))*(A2-.5)**A2*EXP(A2+.5)
	  ERR = .5*EPS*SQRT(1./(2.*A2-1.))*((A2-.5)**(A2-1.))*EXP(A2)
	  TERMN = A2-1.
	  ERRLOG = ALOG10(ERR)
C	  PRINT*,ALPHA,TERMN,ERR,ERRLOG
C	  WRITE(7,*) ALPHA,TERMN,ERR,ERRLOG
	ENDDO
C	IT IS ALL WRONG FROM HERE
C
C	EVALUATE ERROR IN ASYMPTOTIC SERIES
C
	DO N = 1,20
	  ALPHA = 1.7 + .05*(N-1)
	  A2 = ALPHA**2
	  TERMN = A2+.5
	  ERR = 2.*SQRT(2.*A2-1.)/(TERMN-1.)**(TERMN-.5)/EXP(TERMN)
	  ERRLOG = ALOG10(ERR)
C	  PRINT*,ALPHA,TERMN,ERR,ERRLOG
C	  WRITE(7,*) ALPHA,TERMN,ERR,ERRLOG
	ENDDO
C
C	CALCULATE LIMITS
C
	DO N = 1,60
	  ALPHA = 1.7 + .05*(N-1)
	  A2 = ALPHA**2
	  EPSN = 2.*EXP(-2.*A2)
	  FRERR = 1.414*EXP(-A2)
	  PRINT*,ALPHA,EPSN,FRERR
	  WRITE(7,*) ALPHA,EPSN,FRERR
	ENDDO
	STOP
	END


       SUBROUTINE W3FB12(XI,XJ,ALAT1,ELON1,DX,ELONV,ALATAN,ALAT,ELON,
     &                               IERR)
C$$$   SUBPROGRAM  DOCUMENTATION  BLOCK
C
C SUBPROGRAM:  W3FB12        LAMBERT(I,J) TO LAT/LON FOR GRIB
C   PRGMMR: STACKPOLE        ORG: NMC42       DATE:88-11-28
C
C ABSTRACT: CONVERTS THE COORDINATES OF A LOCATION ON EARTH GIVEN IN A
C   GRID COORDINATE SYSTEM OVERLAID ON A LAMBERT CONFORMAL TANGENT
C   CONE PROJECTION TRUE AT A GIVEN N OR S LATITUDE TO THE
C   NATURAL COORDINATE SYSTEM OF LATITUDE/LONGITUDE
C   W3FB12 IS THE REVERSE OF W3FB11.
C   USES GRIB SPECIFICATION OF THE LOCATION OF THE GRID
C
C PROGRAM HISTORY LOG:
C   88-11-25  ORIGINAL AUTHOR:  STACKPOLE, W/NMC42
C   90-04-12  R.E.JONES   CONVERT TO CFT77 FORTRAN
C   94-04-28  R.E.JONES   ADD SAVE STATEMENT
C
C USAGE:  CALL W3FB12(XI,XJ,ALAT1,ELON1,DX,ELONV,ALATAN,ALAT,ELON,IERR,
C                                   IERR)
C   INPUT ARGUMENT LIST:
C     XI       - I COORDINATE OF THE POINT  REAL*4
C     XJ       - J COORDINATE OF THE POINT  REAL*4
C     ALAT1    - LATITUDE  OF LOWER LEFT POINT OF GRID (POINT 1,1)
C                LATITUDE <0 FOR SOUTHERN HEMISPHERE; REAL*4
C     ELON1    - LONGITUDE OF LOWER LEFT POINT OF GRID (POINT 1,1)
C                  EAST LONGITUDE USED THROUGHOUT; REAL*4
C     DX       - MESH LENGTH OF GRID IN METERS AT TANGENT LATITUDE
C     ELONV    - THE ORIENTATION OF THE GRID.  I.E.,
C                THE EAST LONGITUDE VALUE OF THE VERTICAL MERIDIAN
C                WHICH IS PARALLEL TO THE Y-AXIS (OR COLUMNS OF
C                THE GRID) ALONG WHICH LATITUDE INCREASES AS
C                THE Y-COORDINATE INCREASES.  REAL*4
C                THIS IS ALSO THE MERIDIAN (ON THE OTHER SIDE OF THE
C                TANGENT CONE) ALONG WHICH THE CUT IS MADE TO LAY
C                THE CONE FLAT.
C     ALATAN   - THE LATITUDE AT WHICH THE LAMBERT CONE IS TANGENT TO
C                (TOUCHES OR OSCULATES) THE SPHERICAL EARTH.
C                 SET NEGATIVE TO INDICATE A
C                 SOUTHERN HEMISPHERE PROJECTION; REAL*4
C
C   OUTPUT ARGUMENT LIST:
C     ALAT     - LATITUDE IN DEGREES (NEGATIVE IN SOUTHERN HEMI.)
C     ELON     - EAST LONGITUDE IN DEGREES, REAL*4
C     IERR     - .EQ. 0   IF NO PROBLEM
C                .GE. 1   IF THE REQUESTED XI,XJ POINT IS IN THE
C                         FORBIDDEN ZONE, I.E. OFF THE LAMBERT MAP
C                         IN THE OPEN SPACE WHERE THE CONE IS CUT.
C                  IF IERR.GE.1 THEN ALAT=999. AND ELON=999.
C
C   REMARKS: FORMULAE AND NOTATION LOOSELY BASED ON HOKE, HAYES,
C     AND RENNINGER'S "MAP PROJECTIONS AND GRID SYSTEMS...", MARCH 1981
C     AFGWC/TN-79/003
C
C ATTRIBUTES:
C   LANGUAGE: CRAY CFT77 FORTRAN
C   MACHINE:  CRAY C916-128, CRAY Y-MP8/864, CRAY Y-MP EL2/256
C
C$$$
C
         LOGICAL NEWMAP
C
         SAVE
C
         DATA  RERTH /6.3712E+6/, PI/3.14159/, OLDRML/99999./
C
C        PRELIMINARY VARIABLES AND REDIFINITIONS
C
C        H = 1 FOR NORTHERN HEMISPHERE; = -1 FOR SOUTHERN
C
         IF (ALATAN.GT.0) THEN
           H = 1.
         ELSE
           H = -1.
         ENDIF
C
         PIBY2  = PI     / 2.0
         RADPD  = PI     / 180.0
         DEGPRD = 1.0    / RADPD
         REBYDX = RERTH  / DX
         ALATN1 = ALATAN * RADPD
         AN     = H * SIN(ALATN1)
         COSLTN = COS(ALATN1)
C
C        MAKE SURE THAT INPUT LONGITUDE DOES NOT PASS THROUGH
C        THE CUT ZONE (FORBIDDEN TERRITORY) OF THE FLAT MAP
C        AS MEASURED FROM THE VERTICAL (REFERENCE) LONGITUDE
C
         ELON1L = ELON1
         IF ((ELON1-ELONV).GT.180.)
     &     ELON1L = ELON1 - 360.
         IF ((ELON1-ELONV).LT.(-180.))
     &     ELON1L = ELON1 + 360.
C
         ELONVR = ELONV * RADPD
C
C        RADIUS TO LOWER LEFT HAND (LL) CORNER
C
         ALA1 =  ALAT1 * RADPD
         RMLL = REBYDX * ((COSLTN**(1.-AN))*(1.+AN)**AN) *
     &           (((COS(ALA1))/(1.+H*SIN(ALA1)))**AN)/AN
C
C        USE RMLL TO TEST IF MAP AND GRID UNCHANGED FROM PREVIOUS
C        CALL TO THIS CODE.  THUS AVOID UNNEEDED RECOMPUTATIONS.
C
         IF (RMLL.EQ.OLDRML) THEN
           NEWMAP = .FALSE.
         ELSE
           NEWMAP = .TRUE.
           OLDRML = RMLL
C
C          USE LL POINT INFO TO LOCATE POLE POINT
C
           ELO1 = ELON1L * RADPD
           ARG = AN * (ELO1-ELONVR)
           POLEI = 1. - H * RMLL * SIN(ARG)
           POLEJ = 1. + RMLL * COS(ARG)
         ENDIF
C
C        RADIUS TO THE I,J POINT (IN GRID UNITS)
C              YY REVERSED SO POSITIVE IS DOWN
C
         XX = XI - POLEI
         YY = POLEJ - XJ
         R2 = XX**2 + YY**2
C
C        CHECK THAT THE REQUESTED I,J IS NOT IN THE FORBIDDEN ZONE
C           YY MUST BE POSITIVE UP FOR THIS TEST
C
         THETA = PI*(1.-AN)
         BETA = ABS(ATAN2(XX,-YY))
         IERR = 0
         IF (BETA.LE.THETA) THEN
           IERR = 1
           ALAT = 999.
           ELON = 999.
           IF (.NOT.NEWMAP)  RETURN
         ENDIF
C
C        NOW THE MAGIC FORMULAE
C
         IF (R2.EQ.0) THEN
           ALAT = H * 90.0
           ELON = ELONV
         ELSE
C
C          FIRST THE LONGITUDE
C
           ELON = ELONV + DEGPRD * ATAN2(H*XX,YY)/AN
           ELON = AMOD(ELON+360., 360.)
C
C          NOW THE LATITUDE
C          RECALCULATE THE THING ONLY IF MAP IS NEW SINCE LAST TIME
C
           IF (NEWMAP) THEN
             ANINV = 1./AN
             ANINV2 = ANINV/2.
             THING = ((AN/REBYDX) ** ANINV)/
     &         ((COSLTN**((1.-AN)*ANINV))*(1.+ AN))
           ENDIF
           ALAT = H*(PIBY2 - 2.*ATAN(THING*(R2**ANINV2)))*DEGPRD
         ENDIF
C
C        FOLLOWING TO ASSURE ERROR VALUES IF FIRST TIME THRU
C         IS OFF THE MAP
C
         IF (IERR.NE.0) THEN
           ALAT = 999.
           ELON = 999.
           IERR = 2
         ENDIF
         RETURN
         END


!====================================================================
!
! MODULE: PlanckFunc
!
!   SUBROUTINE: Calc_PlanckTempToRad()
!   SUBROUTINE: Calc_PlanckRadToTemp()
!
!
! Created by Y.Tahara in Aug,02
! Modified by Y.Tahara in Oct,02 to make consistent with OPTRAN
!
! Modified by Yong Han in Oct, 03
!
! Modified by Yong Chen in Jan, 08
!====================================================================

module PlanckFunc

  !--- modules

  USE Type_Kinds, only : fp_kind
  USE SpcCoeff_Define

  !--- implicit

  implicit none

  !--- public & private

  Private

  Public  Calc_PlanckTempToRad
  Public  Calc_PlanckRadToTemp
  Public  Pred_BrightTemp
  Public  Pred_BrightTemp2

  real(fp_kind), parameter :: ZERO = 0.0_fp_kind
  real(fp_kind),parameter :: ONE     =  1._fp_kind
  real(fp_kind),parameter :: TOLERANCE        = EPSILON( ONE )

 contains

  !====================================================================
  !
  ! SUBROUTINE: Calc_PlanckTempToRad()
  !
  !   Calc_PlanckTempToRad() calculates an radiance of a specified
  !   channel from black body using the Planck Law.
  !
  !====================================================================

  function Calc_PlanckTempToRad( channel, temperature, SpcCoeff ) result( radiance )

    !--- interface

    integer      ,intent(in)            :: channel         ! ch seq #
    real(fp_kind),intent(in)            :: temperature     ! temperature (K)
    type(SpcCoeff_type),intent(in)      :: SpcCoeff        ! spectrum coef (freq, Plunck const)

    real(fp_kind)            :: radiance        ! radiance

    !--- local variables
    real(fp_kind) :: effective_temperature

    !--- apply the polychromaticity correction
    !--- to obtain an effective temperature

    effective_temperature = SpcCoeff%band_c1( channel ) &
                                + ( SpcCoeff%band_c2( channel ) * temperature )

    !--- calculate the Planck radiance

    radiance =                  SpcCoeff%planck_c1( channel )  / &
    !          ----------------------------------------------------------------------
               ( EXP( SpcCoeff%planck_c2( channel ) / effective_temperature ) - ONE )

  end function Calc_PlanckTempToRad

  !====================================================================
  !
  ! SUBROUTINE: Calc_PlanckRadToTemp()
  !
  !   Calc_PlanckRadToTemp() calculates a black body surface
  !   temperature from its emissivity of a specified channel
  !   using the Planck Law.
  !
  !====================================================================

  function Calc_PlanckRadToTemp( channel, radiance, SpcCoeff ) result( temperature )

    !--- interface

    integer      ,intent(in)            :: channel         ! ch seq #
    real(fp_kind),intent(in)            :: radiance        ! radiance
    type(SpcCoeff_type),intent(in)      :: SpcCoeff        ! spectrum coef (freq, Plunck const)

    real(fp_kind)            :: temperature     ! temperature (K)

    !--- local variables

    real(fp_kind) :: effective_temperature

    !--- calculate the effective temperature

    effective_temperature =              SpcCoeff%planck_c2( channel )  / &
    !                       ---------------------------------------------------------
                            LOG( ( SpcCoeff%planck_c1( channel ) / radiance ) + ONE )

    !--- apply the polychromatic correction to
    !--- obtain the true temperature

    temperature = ( effective_temperature - SpcCoeff%band_c1( channel ) ) / &
    !             ---------------------------------------------------------
                                SpcCoeff%band_c2( channel )

  end function Calc_PlanckRadToTemp

  !====================================================================
  !
  ! FUNCTION: Pred_BrightTemp()
  !
  !   Pred_BrightTemp() calculates a brightness temperature
  !   from transmittance and temperature profiles.
  !   Only up-welling radiance is considered as
  !
  !     Iup =   sum    B(l) * ( TransAll(l-1) - TransAll(l) )
  !           l=layers
  !
  !====================================================================

  function Pred_BrightTemp( Ichan, alltrans_lev, t_lay, Tskin, &
                            SurfaceEmiss, SpcCoeff ) result( Tb )

    !--- interface

    integer      ,intent(in) :: Ichan                   ! channel seq #
    real(fp_kind),intent(in) :: alltrans_lev(0:)        ! total transmittances
    real(fp_kind),intent(in) :: t_lay(:)                ! temperatures (K)
    real(fp_kind),intent(in) :: Tskin                   ! skin temperature (K)
    real(fp_kind),intent(in) :: SurfaceEmiss            ! surface emissivity (K)
    type(SpcCoeff_type),intent(in)   :: SpcCoeff        ! spectrum coef (freq, Plunck const)

    real(fp_kind)            :: Tb                      ! brightness temperature (K)

    !--- local variables

    real(fp_kind) :: rad
    real(fp_kind) :: tau, tau1
    integer       :: Ilev, Nlay

    Nlay = size(alltrans_lev) - 1

    !--- surface

    if( alltrans_lev(Nlay) > TOLERANCE )then
      rad = SurfaceEmiss * Calc_PlanckTempToRad(Ichan,Tskin,SpcCoeff) * alltrans_lev(Nlay)
    else
      rad = ZERO
    endif

    !--- upwelling radiance

    do Ilev = 1, Nlay

      tau1 = alltrans_lev(Ilev-1)
      tau  = alltrans_lev(Ilev  )

!!      if( tau1 >= ZERO .and. tau >= ZERO )then

      !--- check if trans decrease as descending from TOA

!!        if( tau1 < tau )then
!!          print *, "### ERROR ###"
!!          print *, " Total trans be decrease as descending from TOA in Tb calculation"
!!          print *, " Levs :", Ilev-1, Ilev
!!          print *, " Trans:", alltrans_lev(1:Ilev)
!!          stop 99
!!        endif

      !--- accumulate radiance

      rad = rad + Calc_PlanckTempToRad(Ichan,t_lay(Ilev), SpcCoeff) * ( tau1 - tau )

!!      endif

    enddo

    !--- Tb

    Tb = Calc_PlanckRadToTemp(Ichan,rad, SpcCoeff)

  end function Pred_BrightTemp

 function Pred_BrightTemp2( Ichan, alltrans_lev, bt_lay, bTskin, &
                            SurfaceEmiss, SpcCoeff ) result( Tb )

    !--- interface

    integer      ,intent(in) :: Ichan                   ! channel seq #
    real(fp_kind),intent(in) :: alltrans_lev(0:)        ! total transmittances
    real(fp_kind),intent(in) :: bt_lay(:)                ! brightness temperatures (K)
    real(fp_kind),intent(in) :: bTskin                   ! brightness skin temperature (K)
    real(fp_kind),intent(in) :: SurfaceEmiss            ! surface emissivity (K)
    type(SpcCoeff_type),intent(in)   :: SpcCoeff        ! spectrum coef (freq, Plunck const)

    real(fp_kind)            :: Tb                      ! brightness temperature (K)

    !--- local variables

    real(fp_kind) :: rad
    real(fp_kind) :: tau, tau1
    integer       :: Ilev, Nlay

    Nlay = size(alltrans_lev) - 1

    !--- surface

    if( alltrans_lev(Nlay) > TOLERANCE )then
      rad = SurfaceEmiss * bTskin * alltrans_lev(Nlay)
    else
      rad = ZERO
    endif

    !--- upwelling radiance

    do Ilev = 1, Nlay

      tau1 = alltrans_lev(Ilev-1)
      tau  = alltrans_lev(Ilev  )

      if( tau1 >= ZERO .and. tau >= ZERO )then

        !--- check if trans decrease as descending from TOA

        if( tau1 < tau )then
          print *, "### ERROR ###"
          print *, " Total trans be decrease as descending from TOA in Tb calculation"
          print *, " Levs :", Ilev-1, Ilev
          print *, " Trans:", alltrans_lev
          stop 99
        endif

        !--- accumulate radiance

        rad = rad + Bt_lay(Ilev) * ( tau1 - tau )

      endif

    enddo

    !--- Tb

    Tb = Calc_PlanckRadToTemp(Ichan,rad, SpcCoeff)

  end function Pred_BrightTemp2

end module PlanckFunc


      REAL             FUNCTION SSINPX (X)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
c>> 1996-03-30 SSINPX Krogh   Added external statement.
C>> 1996-01-29 SCOSPX WVS JPL Add better acknowledgement for origins.
C>> 1994-10-20 SSINPX Krogh  Changes to use M77CON
C>> 1994-04-22 SSINPX CLL Made SP and DP codes similar.
C>> 1993-05-06 SSINPX WVS JPL Convert from NSWC to Math 77
c--S replaces "?": ?SINPX, ?ERM1
C ----------------------------------------------------------------------
c This procedure was originally procedure SIN1 from the Naval Surface
c Warfare Center library.
C ----------------------------------------------------------------------
C
C                        EVALUATION OF SIN(PI*X)
C
C                             --------------
C
C     THE EXPANSION FOR SIN(PI*A) (ABS(A) .LE. 1/4) USING A1,...,A13
C     IS ACCURATE TO WITHIN 2 UNITS OF THE 40-TH SIGNIFICANT DIGIT, AND
C     THE EXPANSION FOR COS(PI*A) (ABS(A) .LE. 1/4) USING B1,...,B13
C     IS ACCURATE TO WITHIN 4 UNITS OF THE 40-TH SIGNIFICANT DIGIT.
c
c     The polynomials using coefficients SA0, ... SA6 and SB1, ..., SB6
c     give approximations whose largest observed relative error in the
c     relevant intervals is 0.129e-14.
c     We will use this latter approximation when the machine epsilon
c     is larger than 0.2e-14.
c ----------------------------------------------------------------------
      external R1MACH
      integer N
      real             R1MACH
      REAL             A, BIG, CUTOFF, EPS, PI, T, W, X
      REAL             A1, A2, A3, A4, A5, A6, A7, A8, A9, A10,
     *                 A11, A12, A13
      REAL             B1, B2, B3, B4, B5, B6, B7, B8, B9, B10,
     *                 B11, B12, B13
      REAL             SA0, SA1, SA2, SA3, SA4, SA5, SA6
      REAL                  SB1, SB2, SB3, SB4, SB5, SB6
      SAVE BIG, EPS
c -----------------------
      PARAMETER ( PI = 3.141592653589793238462643383279502884197E+00 )
      parameter ( CUTOFF = 0.2e-14 )
c -----------------------
      data EPS / -1.0e0 /
      DATA SA0 /.314159265358979E+01/, SA1 /-.516771278004995E+01/,
     *     SA2 /.255016403987327E+01/, SA3 /-.599264528932149E+00/,
     *     SA4 /.821458689493251E-01/, SA5 /-.737001831310553E-02/,
     *     SA6 /.461514425296398E-03/
      DATA SB1 /-.493480220054460E+01/, SB2 /.405871212639605E+01/,
     *     SB3 /-.133526276691575E+01/, SB4 /.235330543508553E+00/,
     *     SB5 /-.258048861575714E-01/, SB6 /.190653140279462E-02/
      DATA A1  /-.1028083791780141522795259479153765743002E+00/,
     *     A2  / .3170868848763100170457042079710451905600E-02/,
     *     A3  /-.4657026956105571623449026167864697920000E-04/,
     *     A4  / .3989844942879455643410226655783424000000E-06/,
     *     A5  /-.2237397227721999776371894030796800000000E-08/,
     *     A6  / .8847045483056962709715066675200000000000E-11/,
     *     A7  /-.2598715447506450292885585920000000000000E-13/,
     *     A8  / .5893449774331011070033920000000000000000E-16/,
     *     A9  /-.1062975472045522550784000000000000000000E-18/,
     *     A10 / .1561182648301780992000000000000000000000E-21/,
     *     A11 /-.1903193516670976000000000000000000000000E-24/,
     *     A12 / .1956617650176000000000000000000000000000E-27/,
     *     A13 /-.1711276032000000000000000000000000000000E-30/
c -----------------------
      DATA B1  /-.3084251375340424568385778437461297229882E+00/,
     *     B2  / .1585434424381550085228521039855226435920E-01/,
     *     B3  /-.3259918869273900136414318317506279360000E-03/,
     *     B4  / .3590860448591510079069203991239232000000E-05/,
     *     B5  /-.2461136950494199754009084061808640000000E-07/,
     *     B6  / .1150115912797405152263195572224000000000E-09/,
     *     B7  /-.3898073171259675439899172864000000000000E-12/,
     *     B8  / .1001886461636271969091584000000000000000E-14/,
     *     B9  /-.2019653396886572027084800000000000000000E-17/,
     *     B10 / .3278483561466560512000000000000000000000E-20/,
     *     B11 /-.4377345082051788800000000000000000000000E-23/,
     *     B12 / .4891532381388800000000000000000000000000E-26/,
     *     B13 /-.4617089843200000000000000000000000000000E-29/
c -----------------------
      IF (eps .LT. 0.0e0) then
         eps = R1MACH(3)
         BIG = 1.0e0/eps
      endif
c -----------------------
      A = ABS(X)
      IF (A .GE. BIG) THEN
         CALL SERM1 ('SSINPX',1,2,
     1   'No precision because ABS(X) is too large','X',X,'.')
         SSINPX = 0.E0
         RETURN
      END IF
      N = A
      T = N
      A = A - T
      IF (A .GT. 0.75E0) GO TO 20
      IF (A .LT. 0.25E0) GO TO 21
C
C                    0.25 .LE. A .LE. 0.75
C
      A = 0.25E0 + (0.25E0 - A)
      if(eps .lt. cutoff) then
         T = 16.E0*A*A
         SSINPX = (((((((((((((B13*T + B12)*T + B11)*T + B10)*T + B9)*T+
     *                B8)*T + B7)*T + B6)*T + B5)*T + B4)*T + B3)*T +
     *                B2)*T + B1)*T + 0.5E0) + 0.5E0
      else
         T = A*A
         SSINPX = ((((((SB6*T + SB5)*T + SB4)*T + SB3)*T + SB2)*T
     *                  + SB1)*T + 0.5E0) + 0.5E0
      endif
      GO TO 30
C
C                 A .LT. 0.25  OR  A .GT. 0.75
C
   20 A = 0.25E0 + (0.75E0 - A)
   21 continue
      if(eps .lt. cutoff) then
         T = 16.E0*A*A
         W = (((((((((((((A13*T + A12)*T + A11)*T + A10)*T + A9)*T +
     *            A8)*T + A7)*T + A6)*T + A5)*T + A4)*T + A3)*T +
     *            A2)*T + A1)*T + 0.5E0) + 0.5E0
         SSINPX = PI*A*W
      else
         T = A*A
         SSINPX = ((((((SA6*T + SA5)*T + SA4)*T + SA3)*T + SA2)*T
     *                  + SA1)*T + SA0)*A
      endif
C
C                        TERMINATION
C
   30 IF (X .LT. 0.0E0) SSINPX = - SSINPX
      IF (MOD(N,2) .NE. 0) SSINPX = - SSINPX
      RETURN
      END


c______________________________________________________________________
c
      subroutine geogcor(u,nt,nvec,nsta,ih,orient,decl,theta,irot)

c           Given : NVEC complex input vectors in U (total # of components
c                is NT, # of stations is NSTA, NCHMX is second dimension of
c                   array orient, IH is array giving index for first H component
c                    for each station (so ih(ista+1)-ih(ista) =nch(ista)))
c                and some directions giving the coordinate system of the components
c                  of the vector:
c                   ORIENT = orientations of field component coordinte system
c                      relative to geomagnetic north
c                   DECL = degrees E of geographic N of the H-axis at each site
c         THis routine rotates U so that on output the components are
c          all expressed in a fixed coordinate system, with x-axis pointing
c                   THETA degrees E of Geographic N
c       (this is the way it works when irot=+1 ; when irot = -1, the coordinate
c            transformation is reversed  )

      real decl(nsta),orient(2,nt),theta
      integer ih(*)
      include 'nstamx.inc'
      complex u(nt,nvec),temp(nchmx,nchmx)

      write(*,*) 'nt,nvec,nsta',nt,nvec,nsta
      write(*,*) 'ih',(ih(k),k=1,nsta+1)

      do ista = 1,nsta
         nch = ih(ista+1)-ih(ista)
         call mkccmt(theta,temp,orient(1,ih(ista)),nch)

         do j=1,nvec
            call rotmult(temp,u(ih(ista),j),nch)
         enddo
      enddo
      return
      end
c_____________________________________________________________________
c
      subroutine mkccmt(theta,u,orient,nch)
c       makes rotation matrix (u) for rotating up to 5 channel data an angle
c       theta (in degrees); the assumed order of the 5 channels is
c       Hx, Hy, Hz, Ex, Ey the rotation direction is clockwise for positive

      include 'nstamx.inc'
      parameter (pc=.0174533)
      real u(nchmx,nchmx),orient(2,*),theta
      do i=1,nch
         do j=1,nch
            u(i,j)=0.0
         enddo
      enddo
      if(nch.eq.5) then
         u(1,1)=cos((orient(1,1)-theta)*pc)
         u(1,2)=cos((orient(1,2)-theta)*pc)
         u(2,1)=sin((orient(1,1)-theta)*pc)
         u(2,2)=sin((orient(1,2)-theta)*pc)
         u(4,4)=cos((orient(1,4)-theta)*pc)
         u(4,5)=cos((orient(1,5)-theta)*pc)
         u(5,4)=sin((orient(1,4)-theta)*pc)
         u(5,5)=sin((orient(1,5)-theta)*pc)
         u(3,3)=1.0
         return
      else if(nch.eq.4) then
         u(1,1)=cos((orient(1,1)-theta)*pc)
         u(1,2)=cos((orient(1,2)-theta)*pc)
         u(2,1)=sin((orient(1,1)-theta)*pc)
         u(2,2)=sin((orient(1,2)-theta)*pc)
         u(3,3)=cos((orient(1,3)-theta)*pc)
         u(3,4)=cos((orient(1,4)-theta)*pc)
         u(4,3)=sin((orient(1,3)-theta)*pc)
         u(4,4)=sin((orient(1,4)-theta)*pc)
         return
      else if(nch.eq.3) then
         u(1,1)=cos((orient(1,1)-theta)*pc)
         u(1,2)=cos((orient(1,2)-theta)*pc)
         u(2,1)=sin((orient(1,1)-theta)*pc)
         u(2,2)=sin((orient(1,2)-theta)*pc)
         u(3,3) = 1.0
         return
      else
         if(nch .ne. 2) then
           write(*,*) 'In mkccmt : Only changing coordinates for ',
     &        ' for first two channels'
         endif
         do i=1,nch
            u(i,i) = 1.0
         enddo
         u(1,1)=cos((orient(1,1)-theta)*pc)
         u(1,2)=cos((orient(1,2)-theta)*pc)
         u(2,1)=sin((orient(1,1)-theta)*pc)
         u(2,2)=sin((orient(1,2)-theta)*pc)
      end if
      end
c________________________________________________________________
c
      subroutine rotmult(u,x,nch)
      include 'nstamx.inc'
      real u(nchmx,nchmx)
      complex work(nchmx),x(nch)

      do i=1,nch
      work(i) = (0.,0.)
         do j=1,nch
            work(i) = work(i) + u(i,j)*x(j)
         enddo
      enddo
      do i = 1,nch
         x(i) = work(i)
      enddo
      return
      end


!==============================================================================!
  subroutine Compute_Shear_And_Vorticity(grid)
!------------------------------------------------------------------------------!
!   Computes the magnitude of the shear stress.                                !
!------------------------------------------------------------------------------!
!   She = sqrt( 2 * Sij * Sij )                                                !
!   Sij = 1/2 ( dUi/dXj + dUj/dXi )                                            !
!------------------------------------------------------------------------------!
!----------------------------------[Modules]-----------------------------------!
  use all_mod
  use pro_mod
  use les_mod
  use rans_mod
  use Grid_Mod
!------------------------------------------------------------------------------!
  implicit none
!---------------------------------[Arguments]----------------------------------!
  type(Grid_Type) :: grid
!-----------------------------------[Locals]-----------------------------------!
  integer :: c
!==============================================================================!

  call Exchange(grid, u % n)
  call Exchange(grid, v % n)
  call Exchange(grid, w % n)

  call GraPhi(grid, u % n, 1, u % x, .TRUE.)  ! dU/dx
  call GraPhi(grid, u % n, 2, u % y, .TRUE.)  ! dU/dy
  call GraPhi(grid, u % n, 3, u % z, .TRUE.)  ! dU/dz
  call GraPhi(grid, v % n, 1, v % x, .TRUE.)  ! dV/dx
  call GraPhi(grid, v % n, 2, v % y, .TRUE.)  ! dV/dy
  call GraPhi(grid, v % n, 3, v % z, .TRUE.)  ! dV/dz
  call GraPhi(grid, w % n, 1, w % x, .TRUE.)  ! dW/dx
  call GraPhi(grid, w % n, 2, w % y, .TRUE.)  ! dW/dy
  call GraPhi(grid, w % n, 3, w % z, .TRUE.)  ! dW/dz

  do c = 1, grid % n_cells
    Shear(c) = u % x(c)**2                     &
             + v % y(c)**2                     &
             + w % z(c)**2                     &
             + 0.5 * (v % z(c) + w % y(c))**2  &
             + 0.5 * (u % z(c) + w % x(c))**2  &
             + 0.5 * (v % x(c) + u % y(c))**2

    Vort(c) = - (  0.5*(v % z(c) - w % y(c))**2   &
                 + 0.5*(u % z(c) - w % x(c))**2   &
                 + 0.5*(v % x(c) - u % y(c))**2)

  end do

  Shear = sqrt(2.0 * Shear)
  Vort  = sqrt(2.0 * abs(Vort))

  end subroutine


      SUBROUTINE AVENOR(BUF,OBUF,INDXS,OLEVS,NSAMPS, lprint, last )
C     AVENOR PERFORMS AVERAGE AMPLITUDE NORMALIZATION IN MEMORY.  THE AP VERSION
C  IS AVEVFC.  AVERAGE AMPLITUDE NORMALIZE ADJUSTS THE AVERAGE ABSOLUTE AMPLITUDE
C  WITHIN EACH WINDOW TO A SPECIFIED LEVEL.  IT DOES THIS BY DIVIDING THE
C  LEVEL BY THE AVERAGE ABSOLUTE VALUE OF THE WINDOW IN ORDER TO FORM A
C  MULTIPLIER THAT WILL BE APPLIED TO THE CENTER POINT OF THE WINDOW.
C  DATA UP TO THE FIRST WINDOW MIDPOINT RECEIVE THE FIRST MULTIPLIER.
C  MULTIPLIERS BETWEEN WINDOW MIDPOINTS ARE LINEARLY INTERPOLATED.
C  DATA AFTER THE MIDPOINT OF THE LAST WINDOW RECEIVE THE MULTIPLIER OF THE
C  LAST WINDOW.  (A ONE WINDOW AVENOR RESULTS IS ALL DATA GETTING THE SAME
C  MULTIPLIER).
C      ANY NUMBER OF WINDOWS MAY BE GIVEN, BUT THE LAST WINDOW MUST BE ZERO TIME.
C
C  COPYRIGHTED BY:
C  PAUL HENKART, SEISMIC REFLECTION PROCESSORS, SAN DIEGO, CA.
C  16 JANUARY 1983.  ALL RIGHTS RESERVED.
c
c  mod 11 Oct 02 - Add argument last, which when set non-zero means
c                  to use the multipliers from the last trace rather
c                  than calculate new ones.  The windows/indices may
c                  be different.
c  mod 19 Oct 02 - Print the values on the trace being held (last).
C
C  ARGUMENTS:
C  BUF    - THE INPUT ARRAY
C  OBUF   - THE OUTPUT ARRAY.  THE OUTPUT MAY NOT BE THE SAME AS THE INPUT,
C           EXCEPT WHEN ONLY ONE WINDOW IS GIVEN.
C  INDXS  - AN ARRAY OF INDEXES DEFINING THE WINDOWS.  THE INDEXES MUST BE
C           GIVEN IN PAIRS, START INDEX FOLLOWED BY THE END INDEX.  AS NOTED
C           ABOVE, THE LAST INDEXES MUST BE 0.  THEREFORE, THERE MUST BE
C           2*(THE NUMBER OF WINDOWS)+2 INDEXES.
C  OLEVS  - AN ARRAY OF OUTPUT WINDOW LEVELS.  THERE MUST BE A LEVEL FOR EACH
C           WINDOW.
C  NSAMPS - THE TOTAL NUMBER OF SAMPLES IN THE TRACE
C
C
      DIMENSION INDXS(1),OLEVS(1),BUF(1),OBUF(1)
      DIMENSION rmult_last(4)
      SAVE rmult_last, iprint
      DATA iprint/1/
C
      ICOUNT=-1
      IC=1
   10 ICOUNT=ICOUNT+2                                                    /* SET UP FOR THE NEXT WINDOW
      ISTART=INDXS(ICOUNT)                                              /* THE START INDEX OF THE WINDOW
      IEND=INDXS(ICOUNT+1)                                              /* THE END INDEX OF THE WINDOW
      IF(IEND.LE.ISTART) GO TO 300
      MIDPT=ISTART+(IEND-ISTART)/2                                      /* FIND THE MID POINT OF THE WINDOW
      OLEV=OLEVS(IC)                                                    /* GET THE OUTPUT LEVEL FOR THIS WINDOW
      IC=IC+1
      IF( last .NE. 0 ) THEN
          rmult = rmult_last(ic-1)
          GOTO 110
      ENDIF
      REALN=FLOAT(IEND-ISTART)                                          /* THE WINDOW LENGTH
      AVE=0.
      DO 100 I=ISTART,IEND                                              /* FIND THE AVERAGE ABSOLUTE VALUE
  100 AVE=AVE+ABS(BUF(I))                                               /*  WATCH OUT FOR OVERFLOW !!!!!!!!!
      AVE=AVE/REALN                                                      /* THESE 2 LINES COULD BE REPLACE BY THE SINGLE LINE
C  100 AVE=AVE+ABS(BUF(I))/REALN                                        /* BUT I DISLIKE DIVIDES ($$$$)
      RMULT=1.
      IF(AVE.NE.0.) RMULT=OLEV/AVE                                      /* WATCH OUT FOR DIVIDE BY ZERO!
      rmult_last(ic-1) = rmult
  110 CONTINUE
      IF( IAND(lprint,4) .NE. 0 ) PRINT *,' Average absolute ave  = ',
     &     ave,' multiplier=',rmult
      IF( iprint .NE. 0 .AND. last .NE. 0 )
     &    PRINT *,ic-1,' multiplier =',rmult
      IF(ICOUNT.NE.1) GO TO 200
      DO 120 I=1,MIDPT                                                  /* DO THE FIRST WINDOW
  120 OBUF(I)=BUF(I)*RMULT                                              /* MULTIPLY EVERYTHING UP TO AND INCLUDING THE MIDPT
      RMULT1=RMULT                                                      /* SAVE THE MULTIPLIER
      MIDPT1=MIDPT                                                      /* SAVE THE MIDPOINT
      GO TO 10                                                          /* GO GET THE NEXT WINDOW
C****
C****   DO THE WINDOW IF IT'S NOT THE FIRST OR LAST WINDOW
C****
  200 TEMP=(RMULT-RMULT1)/(MIDPT-MIDPT1+1)                               /* GET THE INTERPOLATOR
      X=0.
      DO 220 I=MIDPT1,MIDPT                                             /* REMEMBER THAT MIDPT1 WAS THE MIDPOINT OF THE LAST WINDOW
      X=X+1.
  220 OBUF(I)=BUF(I)*(RMULT1+X*TEMP)
      RMULT1=RMULT                                                       /* SAVE THE MULTIPLIER AND MIDPOINT FOR THE NEXT WINDOW
      MIDPT1=MIDPT
      GO TO 10                                                          /* GET ANOTHER WINDOW
C****
C****    THIS IS THE LAST WINDOW
C****
  300 DO 320 I=MIDPT1,NSAMPS                                            /* DO IT TO THE END OF THE TRACE
  320 OBUF(I)=BUF(I)*RMULT                                              /* USE THE MULTIPLIER OF THE LAST WINDOW TO THE END
      IF( iprint .NE. 0 .AND. last .NE. 0 ) iprint = 0
      RETURN
      END


      subroutine gauher2(x,w,n)
      implicit none
      integer n,maxit
      real*8 w(n),x(n)
      real*8 eps,pim4
      parameter(eps=3.d-14,pim4=.7511255444649425d0,maxit=10)
      integer i,its,j,m
      real*8 p1,p2,p3,pp,z,z1

      m=(n+1)/2
      z=0.d0
      do i=1,n
         w(i)=0.0
         x(i)=0.0
      end do

      do 13 i=1,m
        if(i.eq.1)then
          z=sqrt(float(2*n+1))-1.85575*(2*n+1)**(-.16667)
        else if(i.eq.2)then
          z=z-1.14*n**.426/z
        else if (i.eq.3)then
          z=1.86*z-.86*x(1)
        else if (i.eq.4)then
          z=1.91*z-.91*x(2)
        else
          z=2.*z-x(i-2)
        endif
        do 12 its=1,MAXIT
          p1=PIM4
          p2=0.d0
          do 11 j=1,n
            p3=p2
            p2=p1
            p1=z*sqrt(2.d0/j)*p2-sqrt(dble(j-1)/dble(j))*p3
11        continue
          pp=sqrt(2.d0*n)*p2
          z1=z
          z=z1-p1/pp
          if(abs(z-z1).le.EPS)goto 1
12      continue
        call rexit("too many iterations in gauher")
1       x(i)=z
        x(n+1-i)=-z
        w(i)=2.d0/(pp*pp)
        w(n+1-i)=w(i)
13    continue
      return
      END


	subroutine gamma_qdr(pl,gl,a,pu,gu,p,gamma)
ccc
ccc
ccc
ccc	DESCRIPTION :	Evaluate the quadratic gamma profile at a pressure
ccc			between two bottles
ccc
ccc	PRECISION :	Double
ccc
ccc	INPUT :		pl, pu		bottle pressures
ccc			gl, gu		bottle gamma values
ccc			a		quadratic coefficient
ccc			p		pressure for gamma value
ccc
ccc	OUTPUT :	gamma		gamma value at p
ccc
ccc	UNITS :		pressure	db
ccc			gamma		kg m-3
ccc			a		kg m-3
ccc
ccc
ccc	AUTHOR :	David Jackett
ccc
ccc	CREATED :	June 1993
ccc
ccc	REVISION :	1.1		30/6/93
ccc
ccc
ccc
	implicit double precision (a-h,o-z)

	p1 = (p-pu)/(pu-pl)
	p2 = (p-pl)/(pu-pl)

	gamma = (a*p1+(gu-gl))*p2+gl

	return
	end


program ch0916
    ! Repetition and Whole Array Output
    implicit none

    real, dimension(10,10) :: y
    integer :: nrows = 6
    integer :: ncols = 7
    integer :: i, j
    integer :: k = 0

    do i = 1, nrows
        do j = 1, ncols
            k = k+1
            y(i,j) = k
        end do
    end do
    write(*, 100) y

100 format (1x, 10f10.4)
end program


program queens
    implicit none
    integer :: n
    integer, allocatable :: pos(:)

    print "(a)", "The board size is "
    read *, n
    allocate(pos(n), source=0)
    call add_queen(pos, 1)
    deallocate(pos)
contains
    recursive subroutine add_queen(a, row)
        integer, intent(inout) :: a(:)
        integer, intent(in) :: row
        integer :: n, c, r, l

        n = size(a)
        if (n < row) then ! print the board
            block
                character(len=n) :: chess_row
                chess_row = repeat('.', n)
                do r = 1, n
                    chess_row(a(r):a(r)) = "Q"
                    write(*, '(a)') chess_row
                    chess_row(a(r):a(r)) = '.'
                end do
                print * ! new line
                !read *  ! wait for key pressed
            end block
        else
            columns: do c = 1, n
                ! Safe column?
                do l = 1, n
                    if (a(l) == c) cycle columns
                end do
                ! Safe diagonals?
                do l = 1, n
                    if (a(l) /= 0) then
                        if (abs(l - row) == abs(a(l) - c)) cycle columns
                    end if
                end do
                a(row) = c ! Add a new queen.
                call add_queen(a, row + 1)
                a(row) = 0 ! Remove the added queen.
            end do columns
        end if
    end subroutine add_queen
end program queens


! -*- mode: f90 -*-
!
! $Id: binarytrees.1.ifc.code,v 1.5 2010-02-20 19:34:17 igouy-guest Exp $ ; $Name:  $
!
! The Computer Language Shootout Benchmarks
! http://shootout.alioth.debian.org/

! contributed by Steve Decker
! based on the C version by Kevin Carson
! compilation:
!    gfortran -O3 -fomit-frame-pointer -funroll-loops binarytrees.f90
!
! This implementation does not need TR15581
!
module b_tree
  implicit none
  save

  integer, parameter :: short = selected_int_kind(1)

  type treeNode
     integer :: item
     type(treeNode), pointer :: left
     type(treeNode), pointer :: right
  end type treeNode

contains

  subroutine NewTreeNode(left, right, item, node)
    type(treeNode), target, intent(in) :: left, right
    integer, intent(in) :: item
    type(treeNode), pointer :: node

    allocate(node)
    node = treeNode(item, left, right)
  end subroutine NewTreeNode

  recursive function ItemCheck(tree) result (check)
    type(treeNode), pointer :: tree
    integer :: check

    if (.not. associated(tree%left)) then
       check = tree%item
    else
       check = tree%item + ItemCheck(tree%left) - ItemCheck(tree%right)
    end if
    deallocate(tree)
  end function ItemCheck

  recursive subroutine BottomUpTree(item, depth, node)
    integer, intent(in) :: item
    integer(kind=short), intent(in) :: depth
    type(treeNode), pointer :: node

    type(treeNode), pointer :: left, right

    nullify(left, right)

    if (depth > 0) then
       call BottomUpTree(2 * item - 1, depth - 1_short, left)
       call BottomUpTree(2 * item, depth - 1_short, right)
    end if
    call NewTreeNode(left, right, item, node)
  end subroutine BottomUpTree
end module b_tree

program binarytrees
  use b_tree
  implicit none

  integer(kind=short), parameter :: minDepth = 4_short
  character,           parameter :: tab = achar(9)

  integer :: i, iterations, check
  integer(kind=short) :: N, depth, maxDepth, stretchDepth
  character(len=2) :: argv
  type(treeNode), pointer :: stretchTree => null(), longLivedTree => null(),  &
                             tempTree => null()

  call get_command_argument(1, argv)
  read (argv, "(i2)") N

  maxDepth = max(minDepth + 2_short, N)

  stretchDepth = maxDepth + 1_short
  call BottomUpTree(0, stretchDepth, stretchTree)
  write(*,"(2(a,i0))") "stretch tree of depth ", stretchDepth,  &
       tab//" check: ", ItemCheck(stretchTree)

  call BottomUpTree(0, maxDepth, longLivedTree)

  do depth = minDepth, maxDepth, 2
     iterations = 2**(maxDepth - depth + minDepth)
     check = 0
     do i = 1, iterations
        call BottomUpTree(i, depth, tempTree)
        check = check + ItemCheck(tempTree)

        call BottomUpTree(-i, depth, tempTree)
        check = check + ItemCheck(tempTree)
     end do
     write(*,"(2(i0,a),i0)") iterations*2, tab//" trees of depth ", depth,  &
          tab//" check: ", check
  end do

  write(*,"(2(a,i0))") "long lived tree of depth ", maxDepth,  &
       tab//" check: ", ItemCheck(longLivedTree)
end program binarytrees


SUBROUTINE DiffZArbitrary_CD(var,varZ,IndexesZ,StencilsZ,Nx,Ny,Nz,gamma)
!
! Explicit order differentiation in Z-direction.
!
! Full rank stencils always applied.
!
! By Allan P. Engsig-Karup.
USE Precision
USE DataTypes
IMPLICIT NONE
INTEGER :: Nx, Ny, Nz, rank, order, gamma,i, j, k
REAL(KIND=long), DIMENSION(Nz,Nx,Ny) :: var, varZ
!GD: addition for correct cross derivatives near corners...
INTEGER, DIMENSION(Nz,Nx,Ny,2*gamma+1) :: IndexesZ
REAL(KIND=long), DIMENSION(Nz,Nx,Ny,2*gamma+1) :: StencilsZ

rank = 2*gamma+1

DO j = 1, Ny
	DO i = 1, Nx
		DO k = 1, Nz
			varZ(k,i,j) = DOT_PRODUCT(StencilsZ(k,i,j,1:rank),var(IndexesZ(k,i,j,1:rank),i,j))
		END DO
	END DO
END DO

END SUBROUTINE DiffZArbitrary_CD


module mod_AA_tree_map
  implicit none
  type t_key
    integer :: k
  end type t_key
  type t_val
    integer :: v
  end type t_val
  type t_node
    type(t_node), pointer :: left, right
    type(t_key) :: key
    type(t_val) :: val
    integer :: level
  end type t_node
  type(t_node), pointer :: nil
  type t_map
    type(t_node), pointer :: root
  end type t_map
  private
  public :: t_map, init_map, release_map, put, belong, get, remove
  public :: size_of, first_key, last_key, poll_first_entry, poll_last_entry
contains
  function new_key(k) result(key)
    implicit none
    integer, intent(in) :: k
    type(t_key) :: key
    key%k = k
    return
  end function new_key
  function new_val(v) result(val)
    implicit none
    integer, intent(in) :: v
    type(t_val) :: val
    val%v = v
    return
  end function new_val
  function compare(k1,k2) result(c)
    implicit none
    type(t_key) :: k1, k2
    integer :: c
    c = k1%k-k2%k
    return
  end function compare
  function new_node(key,val) result(node)
    implicit none
    type(t_key) :: key
    type(t_val) :: val
    type(t_node), pointer :: node
    allocate(node)
    node%left => nil
    node%right => nil
    node%key = key
    node%val = val
    node%level = 1
    return
  end function new_node
  recursive subroutine release_node(node)
    type(t_node), pointer :: node
    if (associated(node,nil)) return
    call release_node(node%left)
    call release_node(node%right)
    deallocate(node)
    return
  end subroutine release_node
  logical function is_leaf(x)
    implicit none
    type(t_node), pointer :: x
    is_leaf = (.not.associated(x,nil)).and. &
    &          associated(x%left,nil).and.associated(x%right,nil)
    return
  end function is_leaf
  recursive function size_of_tree(root) result(s)
    implicit none
    type(t_node), pointer :: root
    integer :: s
    s = 0
    if (associated(root,nil)) return
    s = size_of_tree(root%left)+size_of_tree(root%right)+1
    return
  end function size_of_tree
  subroutine skew(root)
    implicit none
    type(t_node), pointer :: root, temp
    if (associated(root,nil).or.associated(root%left,nil).or. &
    &   root%left%level.ne.root%level) return
    temp => root
    root => root%left
    temp%left => root%right
    root%right => temp
    return
  end subroutine skew
  subroutine split(root)
    implicit none
    type(t_node), pointer :: root, temp
    if (associated(root,nil).or.associated(root%right,nil).or. &
    &   associated(root%right%right,nil).or. &
    &   root%right%right%level.ne.root%level) return
    temp => root
    root => root%right
    temp%right => root%left
    root%left => temp
    root%level = root%level+1
    return
  end subroutine split
  recursive subroutine insert(root,key,val)
    implicit none
    type(t_node), pointer :: root
    type(t_key) :: key
    type(t_val) :: val
    if (associated(root,nil)) then
      root => new_node(key,val)
      return
    else if (compare(key,root%key).lt.0) then
      call insert(root%left,key,val)
    else if (compare(key,root%key).gt.0) then
      call insert(root%right,key,val)
    else
      root%val = val
    end if
    call skew(root)
    call split(root)
    return
  end subroutine insert
  recursive subroutine delete(root,key)
    type(t_node), pointer :: root, leaf
    type(t_key) :: key
    if (associated(root,nil)) then
      return
    else if (compare(key,root%key).lt.0) then
      call delete(root%left,key)
    else if (compare(key,root%key).gt.0) then
      call delete(root%right,key)
    else
      if (is_leaf(root)) then
        root => nil
      else if (associated(root%left,nil)) then
        leaf => root%right
        do while (.not.associated(leaf%left,nil))
          leaf => leaf%left
        end do
        call delete(root%right,leaf%key)
        root%key = leaf%key
        root%val = leaf%val
      else
        leaf => root%left
        do while (.not.associated(leaf%right,nil))
          leaf => leaf%right
        end do
        call delete(root%left,leaf%key)
        root%key = leaf%key
        root%val = leaf%val
      end if
    end if
    call decrease_level(root)
    call skew(root)
    call skew(root%right)
    if (.not.associated(root%right,nil)) call skew(root%right%right)
    call split(root)
    call split(root%right)
    return
  end subroutine delete
  subroutine decrease_level(root)
    implicit none
    type(t_node), pointer :: root
    integer :: should_be
    should_be = min(root%left%level,root%right%level)+1
    if (should_be.lt.root%level) then
      root%level = should_be
      if (should_be.lt.root%right%level) root%right%level = should_be
    end if
    return
  end subroutine decrease_level
  subroutine init_map(map)
    implicit none
    type(t_map) :: map
    allocate(nil)
    nil%left => nil
    nil%right => nil
    nil%level = 0
    map%root => nil
    map%root%left => nil
    map%root%right => nil
    return
  end subroutine init_map
  subroutine release_map(map)
    implicit none
    type(t_map) :: map
    call release_node(map%root)
    deallocate(nil)
    return
  end subroutine release_map
  subroutine put(map,k,v)
    implicit none
    type(t_map) :: map
    integer, intent(in) :: k, v
    call insert(map%root,new_key(k),new_val(v))
    return
  end subroutine put
  function belong(map,k) result(b)
    implicit none
    type(t_map) :: map
    integer, intent(in) :: k
    logical :: b
    type(t_key) :: key
    type(t_node), pointer :: node
    key = new_key(k)
    b = .false.
    node => map%root
    do while (.not.associated(node,nil))
      if (compare(key,node%key).lt.0) then
        node => node%left
      else if (compare(key,node%key).gt.0) then
        node => node%right
      else
        b = .true.
        return
      end if
    end do
    return
  end function belong
  function get(map,k) result(v)
    implicit none
    type(t_map) :: map
    integer, intent(in) :: k
    integer :: v
    type(t_key) :: key
    type(t_node), pointer :: node
    key = new_key(k)
    v = -1
    node => map%root
    do while (.not.associated(node,nil))
      if (compare(key,node%key).lt.0) then
        node => node%left
      else if (compare(key,node%key).gt.0) then
        node => node%right
      else
        v = node%val%v
        return
      end if
    end do
    return
  end function get
  subroutine remove(map,k)
    implicit none
    type(t_map) :: map
    integer, intent(in) :: k
    call delete(map%root,new_key(k))
    return
  end subroutine remove
  function size_of(map) result(s)
    implicit none
    type(t_map) :: map
    integer :: s
    s = size_of_tree(map%root)
    return
  end function size_of
  function first_key(map) result(k)
    implicit none
    type(t_map) :: map
    integer :: k
    type(t_node), pointer :: node
    k = -1
    node => map%root
    if (associated(node,nil)) return
    do while (.not.associated(node%left,nil))
      node => node%left
    end do
    k = node%key%k
    return
  end function first_key
  function last_key(map) result(k)
    implicit none
    type(t_map) :: map
    integer :: k
    type(t_node), pointer :: node
    k = -1
    node => map%root
    if (associated(node,nil)) return
    do while (.not.associated(node%right,nil))
      node => node%right
    end do
    k = node%key%k
    return
  end function last_key
  function poll_first_entry(map) result(k)
    implicit none
    type(t_map) :: map
    integer :: k
    type(t_node), pointer :: node
    k = -1
    node => map%root
    if (associated(node,nil)) return
    do while (.not.associated(node%left,nil))
      node => node%left
    end do
    k = node%key%k
    call remove(map,k)
    return
  end function poll_first_entry
  function poll_last_entry(map) result(k)
    implicit none
    type(t_map) :: map
    integer :: k
    type(t_node), pointer :: node
    k = -1
    node => map%root
    if (associated(node,nil)) return
    do while (.not.associated(node%right,nil))
      node => node%right
    end do
    k = node%key%k
    call remove(map,k)
    return
  end function poll_last_entry
end module mod_AA_tree_map


module env_precision
    implicit none
    integer, parameter :: r4k  = selected_real_kind(6, 37)
    integer, parameter :: r8k  = selected_real_kind(15, 307)
    integer, parameter :: r16k = selected_real_kind(33, 4931)
    integer, parameter :: i2k  = selected_int_kind(4)
    integer, parameter :: i4k  = selected_int_kind(9)
    integer, parameter :: i8k  = selected_int_kind(15)
end module env_precision


!
!  -- LAPACK95 interface driver routine (version 3.0) --
!     UNI-C, Denmark; Univ. of Tennessee, USA; NAG Ltd., UK
!     September, 2000
!
!  .. USE STATEMENTS ..
      USE LA_PRECISION, ONLY: WP => SP
      USE LA_AUXMOD, ONLY: ERINFO, LSAME
!  .. IMPLICIT STATEMENT ..
      IMPLICIT NONE
!  .. SCALAR ARGUMENTS ..
      CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: JOBZ, UPLO
      INTEGER, INTENT(IN), OPTIONAL :: ITYPE
      INTEGER, INTENT(OUT), OPTIONAL :: INFO
!  .. ARRAY ARGUMENTS ..
      COMPLEX(WP), INTENT(INOUT) :: A(:,:), B(:,:)
      REAL(WP), INTENT(OUT) :: W(:)
!----------------------------------------------------------------------
!
! Purpose
! =======
!
!        LA_SYGV, LA_SYGVD, LA_HEGV and LA_HEGVD compute all eigenvalues
! and, optionally, all eigenvectors of generalized eigenvalue problems of
! the form A*z = lambda*B*z, A*B*z = lambda*z, and B*A*z = lambda*z,
! where A and B are real symmetric in the cases of LA_SYGV and LA_SYGVD
! and complex Hermitian in the cases of LA_HEGV and LA_HEGVD. In all four
! cases B is positive deffinite.
!        LA_SYGVD and LA_HEGVD use a divide and conquer algorithm. If
! eigenvectors are desired, they can be much faster than LA_SYGV and
! LA_HEGV for large matrices but use more workspace.
!
! =========
!
!       SUBROUTINE LA_SYGV / LA_SYGVD / LA_HEGV / LA_HEGVD( A, B, &
!                  W, ITYPE=itype, JOBZ=jobz, UPLO=uplo, INFO=info )
!            <type>(<wp>), INTENT(INOUT) :: A(:,:), B(:,:)
!            REAL(<wp>), INTENT(OUT) :: W(:)
!            INTEGER, INTENT(IN), OPTIONAL :: ITYPE
!            CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: JOBZ, UPLO
!            INTEGER, INTENT(OUT), OPTIONAL :: INFO
!       where
!            <type> ::= REAL | COMPLEX
!            <wp>   ::= KIND(1.0) | KIND(1.0D0)
!
! Arguments
! =========
!
! A       (input/output) REAL or COMPLEX square array, shape (:,:).
!         On entry, the matrix A.
!         If UPLO = 'U', the upper triangular part of A contains the
!         upper triangular part of matrix A. If UPLO = 'L', the lower
!         triangular part of A contains the lower triangular part of
!         matrix A.
!         On exit, if JOBZ = 'V', then the columns of A contain the
!         eigenvectors, normalized as follows:
!            if ITYPE = 1 or 2: Z^H*B*Z = I ,
!            if ITYPE = 3: Z^H*B^-1*Z = I .
!         If JOBZ = 'N', then the upper triangle (if UPLO = 'U') or the
!         lower triangle (if UPLO = 'L') of A, including the diagonal,
!         is destroyed.
! B       (input/output) REAL or COMPLEX square array, shape (:,:) with
!         size(B,1) = size(A,1).
!         On entry, the matrix B. If UPLO = 'U', the upper triangular
!         part of B contains the upper triangular part of matrix B. If
! 	  UPLO = 'L', the lower triangular part of B contains the lower
!         triangular part of matrix B.
!         On exit, if the part of B containing the matrix is overwritten
!         by the triangular factor U or L of the Cholesky factorization
!         B = U^H*U or B = L*L^H , respectively.
! W       (output) REAL array, shape (:) with size(W) = size(A,1).
!         The eigenvalues in ascending order.
! ITYPE   Optional (input) INTEGER.
!         Specifies the problem type to be solved:
!           = 1: A*z = lambda*B*z
!           = 2: A*B*z = lambda*z
!           = 3: B*A*z = lambda*z
!         Default value: 1.
! JOBZ    Optional (input) CHARACTER(LEN=1).
!           = 'N': Compute eigenvalues only;
!           = 'V': Compute eigenvalues and eigenvectors.
!         Default value: 'N'.
! UPLO    Optional (input) CHARACTER(LEN=1).
!           = 'U': Upper triangles of A and B are stored;
!           = 'L': Lower triangles of A and B are stored.
!         Default value: 'U'.
! INFO    Optional (output) INTEGER.
!         = 0: successful exit.
!         < 0: if INFO = -i, the i-th argument had an illegal value.
!         > 0: the algorithm failed to converge or matrix B is not
! 	  positive deffinite:
!             <= n: if INFO = i, i off-diagonal elements of an
!                   intermediate tridiagonal form did not converge to
!                   zero.
!             > n: if INFO = n+i, for 1 <= i <= n, then the leading minor
!                   of order i of B is not positive deffinite. The
!                   factorization of B could not be completed and no
!                   eigenvalues or eigenvectors were computed.
!             n is the order of A.
!         If INFO is not present and an error occurs, then the program is
!         terminated with an error message.
!------------------------------------------------------------------------
!  .. LOCAL PARAMETERS ..
!  .. LOCAL SCALARS ..
      CHARACTER(LEN=1) :: LJOBZ, LUPLO
!  .. LOCAL ARRAYS ..
      COMPLEX(WP), POINTER :: WORK(:)
      INTEGER, POINTER :: IWORK(:)
      COMPLEX(WP) :: WORKMIN(1)
      INTEGER :: IWORKMIN(1)
!  .. INTRINSIC FUNCTIONS ..
      INTRINSIC SIZE, MAX, PRESENT
!  .. EXECUTABLE STATEMENTS ..
      LINFO = 0; N = SIZE(A,1); LD = MAX(1,N); ISTAT = 0
      IF( PRESENT(ITYPE) )THEN
        LITYPE = ITYPE
      ELSE
        LITYPE = 1
      END IF
      IF( PRESENT(JOBZ) ) THEN
        LJOBZ = JOBZ
      ELSE
        LJOBZ = 'N'
      END IF
      IF( PRESENT(UPLO) ) THEN
        LUPLO = UPLO
      ELSE
        LUPLO = 'U'
      END IF
!  .. TEST THE ARGUMENTS ..
      IF( SIZE( A, 2 ) /= N .OR. N < 0 )THEN
        LINFO = -1
      ELSE IF( SIZE( B, 1 ) /= N .OR. SIZE( B, 2 ) /= N  )THEN
        LINFO = -2
      ELSE IF( SIZE( W ) /= N )THEN
        LINFO = -3
      ELSE IF( LITYPE < 1 .OR. LITYPE > 3 )THEN
        LINFO = -4
      ELSE IF( .NOT.LSAME(LJOBZ,'N') .AND. .NOT.LSAME(LJOBZ,'V') )THEN
        LINFO = -5
      ELSE IF( .NOT.LSAME(LUPLO,'U') .AND. .NOT.LSAME(LUPLO,'L') )THEN
        LINFO = -6
      ELSE IF( N > 0 )THEN
!  .. DETERMINE THE WORKSPACE ..
!  .. QUERING THE SIZE OF WORKSPACE ..
      ENDIF
      CALL ERINFO(LINFO, SRNAME, INFO, ISTAT)


C--------------------------------------------------------------------
C  SPLBRK -- make a spline with a break (C0 only) at specified locn
C
      SUBROUTINE r8splbrk (IOPT, N, NBRK, X, Y, B, C, D)
C
C  Spline the whole interval, and then respline a subinterval, saving
C  the endpt coeffs from the original spline.
C
C  Result is a spline that is C2 everywhere except C0 only at one
C  interior break point.
C
C  IOPT=0  use SPLAAN for dy/dx=0 at LHS bc
C  IOPT=1  use SPLINE for standard bc
C
C  N -- no. of data pts
C  NBRK -- break point
C
!============
! idecl:  explicitize implicit INTEGER declarations:
      IMPLICIT NONE
      INTEGER, PARAMETER :: R8=SELECTED_REAL_KIND(12,100)
      INTEGER n,nbrk,iopt
!============
! idecl:  explicitize implicit REAL declarations:
      REAL*8 bsave,csave,dsave
!============
      REAL*8 X(N),Y(N),B(N),C(N),D(N)
C
      if(iopt.eq.0) then
         call r8splaan(n, x, y, b, c, d)
      else
         call r8spline(n, x, y, b, c, d)
      endif
C
      bsave=b(nbrk)
      csave=c(nbrk)
      dsave=d(nbrk)
C
      call r8nspline(nbrk, x, y, b, c, d)
C
      b(nbrk)=bsave
      c(nbrk)=csave
      d(nbrk)=dsave
C
      return
      end


Subroutine Turvis
use Aero2DCOM
implicit none
integer i,j
real(8) Xi,fnu1,Dwplus,phi1,F1,betai,St,phi2,F2,Ret,alphastar
logical(1) sstlowre
 sstlowre=.true.
 DO j=1,Jc
  DO i=1,Ic
   if(Turmod=='sa') then
    if(Walltreat=='lr') then
     Xi=rho(i,j)*Tn(i,j)/mu(i,j)+Cks*ksi/d(i,j)
    else
     Xi=rho(i,j)*Tn(i,j)/mu(i,j)
    end if
    fnu1=Xi**3/(Xi**3+Cnu1**3)
    mut(i,j)=rho(i,j)*Tn(i,j)*fnu1
   else if(Turmod=='ke') then
    mut(i,j)=(rho(i,j)*Cu*Tk(i,j)**2)/Te(i,j)
   else if(Turmod=='sst') then
    Dwplus=max(2*rho(i,j)*(Tkx(i,j)*Twx(i,j)+Tky(i,j)*Twy(i,j))/(sigmaw2*Tw(i,j)),1e-10)
    phi1=min(max(sqrt(Tk(i,j))/(betastarf*Tw(i,j)*d(i,j)),500*mu(i,j)/(rho(i,j)*d(i,j)**2*Tw(i,j))),&
    4*rho(i,j)*Tk(i,j)/(sigmaw2*Dwplus*d(i,j)**2))
    F1=tanh(phi1**4)
    betai=F1*betai1+(1-F1)*betai2
    St=sqrt(2*(Ux(i,j)**2+Vy(i,j)**2)+(Uy(i,j)+Vx(i,j))**2)
    phi2=max(2*sqrt(Tk(i,j))/(betastarf*Tw(i,j)*d(i,j)),500*mu(i,j)/(rho(i,j)*d(i,j)**2*Tw(i,j)))
    F2=tanh(phi2**2)
    if(sstlowre) then
      Ret=rho(i,j)*Tk(i,j)/(mu(i,j)*Tw(i,j))
      alphastar=alphastarf*(0.024+Ret/Rk)/(1+Ret/Rk)
    else
      alphastar=alphastarf
    end if
    mut(i,j)=(rho(i,j)*Tk(i,j))/(Tw(i,j)*max(1./alphastar,St*F2/(alpha1*Tw(i,j))))
   else if(Turmod=='lam'.or.Turmod=='inv') then
    mut(i,j)=0
   end if
  end DO
 end DO
end Subroutine Turvis


module integration

  use pde
  use global_module

  implicit none

  real(kind=8), dimension(Neq,Nx,Ny) :: U_new ! Working variable

  contains

  ! ========================================================================

  subroutine forward_Euler_step(U, dt)

    ! This function performs one step of the Forward Euler explicit time integrator

    implicit none

    real(kind=8), dimension(Neq,Nx,Ny), intent(inout)  :: U

    real(kind=8), intent(in) :: dt
    integer :: i, j, eqID

    real(kind=8), dimension(Neq) :: F_N, F_S, F_W, F_E

    ! First, assign BCs. Wall BCs need to be updated in time, taking the value
    ! from neighboring cells.
    call assign_BCs(U) ! See the pde.f03 module

    ! Update solution using the forward Euler integrator - INTERNAL CELLS only
    do j = 3, Ny-2
      do i = 3, Nx-2

        call compute_fluxes_Mieussens(U, i, j, F_N, F_S, F_W, F_E)

        U_new(:,i,j) = U(:,i,j) - dt/dx*(F_E - F_W) - dt/dy*(F_N - F_S)

        ! Check that the solution did not diverge
        do eqID = 1, Neq
          if (isnan(U_new(eqID,i,j))) then
            print*, 'Solution diverged, try with a smaller time step! Aborting.'
            stop
          end if
        end do

      end do
    end do

    ! Save solution (internal cells ONLY! Do not overwrite ghost cells!)
    U(:,3:Nx-2,3:Ny-2) = U_new(:,3:Nx-2,3:Ny-2)

  end subroutine

  ! ========================================================================

  subroutine midpoint_Euler_step(U, dt)

    ! This function performs one step of the Forward Euler explicit time integrator

    implicit none

    real(kind=8), dimension(Neq,Nx,Ny), intent(inout)  :: U

    real(kind=8), intent(in) :: dt
    integer :: i, j, eqID

    real(kind=8), dimension(Neq) :: F_N, F_S, F_W, F_E

    ! First, assign BCs. Wall BCs need to be updated in time, taking the value
    ! from neighboring cells.
    call assign_BCs(U) ! See the pde.f03 module

    ! Compute first half step - Create U_new that is actually U_half
    do j = 3, Ny-2
      do i = 3, Nx-2
        call compute_fluxes_Mieussens(U, i, j, F_N, F_S, F_W, F_E)
        U_new(:,i,j) = U(:,i,j) - dt/2.0/dx*(F_E - F_W) - dt/2.0/dy*(F_N - F_S)
      end do
    end do

    call assign_BCs(U_new) ! See the pde.f03 module

    ! Compute second half step - Use U_new (not U!!!! Be careful!) to compute the fluxes,
    ! and update U
    do j = 3, Ny-2
      do i = 3, Nx-2

        ! Compute fluxes from U_new (= U_half).
        ! If you compute fluxes directly from U, you make a mistake, because you are
        ! updating U dynamically! You would compute weird fluxes!
        call compute_fluxes_Mieussens(U_new, i, j, F_N, F_S, F_W, F_E)
        U(:,i,j) = U(:,i,j) - dt/dx*(F_E - F_W) - dt/dy*(F_N - F_S)

        ! Check that the solution did not diverge
        do eqID = 1, Neq
          if (isnan(U(eqID,i,j))) then
            print*, 'Solution diverged, try with a smaller time step! Aborting.'
            stop
          end if
        end do

      end do
    end do

  end subroutine

  ! ========================================================================

  subroutine compute_fluxes_Mieussens(U, i, j, F_N, F_S, F_W, F_E)

    ! Computes Rusanov numerical fluxes for the cell (i,j)

    implicit none

    real(kind=8), dimension(Neq,Nx,Ny), intent(in)  :: U
    real(kind=8), dimension(Neq),       intent(out) :: F_N, F_S, F_W, F_E
    integer, intent(in) :: i, j

    integer :: eqID
    real(kind=8), dimension(Neq) :: U_L, U_R, F_L, F_R
    real(kind=8) :: x_now, p_now, gam, v_now, F_now, Psi

    x_now = compute_x_from_i(i)
    p_now = compute_p_from_j(j)
    gam   = sqrt(1.0 + p_now*p_now/M/M/c/c)
    gam   = 1.0 ! DBDBDBDBDBDBDBDBDBDBDBDBDBDBDB
    v_now = p_now/gam/M
    F_now = F_field(compute_x_from_i(i))

    ! North flux
    call slope_fun(U(1,i,j-1),U(1,i,j),U(1,i,j+1),U(1,i,j+2), Psi)
    F_N = 0.5*(F_now*U(1,i,j) + F_now*U(1,i,j+1) - abs(F_now)*(U(1,i,j+1) - U(1,i,j) - Psi))

    ! South flux
    call slope_fun(U(1,i,j-2),U(1,i,j-1),U(1,i,j),U(1,i,j+1), Psi)
    F_S = 0.5*(F_now*U(1,i,j-1) + F_now*U(1,i,j) - abs(F_now)*(U(1,i,j) - U(1,i,j-1) - Psi))

    ! East flux
    call slope_fun(U(1,i-1,j),U(1,i,j),U(1,i+1,j),U(1,i+2,j), Psi)
    F_E = 0.5*(v_now*U(1,i,j) + v_now*U(1,i+1,j) - abs(v_now)*(U(1,i+1,j) - U(1,i,j) - Psi))

    ! West flux
    call slope_fun(U(1,i-2,j),U(1,i-1,j),U(1,i,j),U(1,i+1,j), Psi)
    F_W = 0.5*(v_now*U(1,i-1,j) + v_now*U(1,i,j) - abs(v_now)*(U(1,i,j) - U(1,i-1,j) - Psi))

  end subroutine

  ! =======================================================================

  subroutine slope_fun(U_m2, U_m1, U_p1, U_p2, Psi)

    implicit none

    real(kind=8), intent(in)  :: U_m2, U_m1, U_p1, U_p2
    real(kind=8), intent(out) :: Psi

    Psi = 0.0 ! Initialize as first order

    if (second_order_bool) then
      Psi = minmod((U_m1-U_m2), (U_p1-U_m1), (U_p2-U_p1))
    end if

  end subroutine

  ! =======================================================================

  function minmod(a,b,c)

    implicit none

    real(kind=8), intent(in) :: a, b, c

    real(kind=8) :: minmod

    if ( (a .ge. 0.0) .and. (b .ge. 0.0) .and. (c .ge. 0.0) ) then
      minmod = min(a,b,c)
    else if ( (a .le. 0.0) .and. (b .le. 0.0) .and. (c .le. 0.0) ) then
      minmod = -min(abs(a), abs(b), abs(c))
    else
      minmod = 0.0
    end if

  end function

end module


MODULE SunPD

	DOUBLE PRECISION, PARAMETER :: TeffSun=5778. !K
	DOUBLE PRECISION, PARAMETER :: loggSun=4.43191399643523D0 !cgs
	DOUBLE PRECISION, PARAMETER :: RSun=6.9598D10 !cm
	DOUBLE PRECISION, PARAMETER :: RSunm=6.9598D8 !m
	DOUBLE PRECISION, PARAMETER :: RSunKm=6.9598D5 !km
	DOUBLE PRECISION, PARAMETER :: Grav=6.67384D-8 !cgs
	DOUBLE PRECISION, PARAMETER :: MSun=10.D0**loggSun*RSun**2/Grav !g !!! MSun=1.96214783383218D+33
	DOUBLE PRECISION, PARAMETER :: MSunkg=MSun/1000.D0 !1.96214783383218D+30 !kg
	DOUBLE PRECISION, PARAMETER, PRIVATE :: pi=3.14159265358979 !Greek pi
	DOUBLE PRECISION, PARAMETER :: rhoSun=MSun/(4./3.*pi*RSun**3) !g/cm3   1.38948171766240D0 !g/cm3   !!
	!!Absolute magnitude
	!(1) Johnson V-band interpolated in the grid as from Bonfanti+ (2015)
	!(2) Gaia G-band as taken from Casagrande&VandenBerg (2018)
	DOUBLE PRECISION, DIMENSION(2), PARAMETER :: MabsSun=(/4.833,4.67/)

	DOUBLE PRECISION, PARAMETER :: ZSun=0.01524D0 !present day solar metallicity
                           			!(Caffau+, 2011). The initial one is 0.01774
    DOUBLE PRECISION, PARAMETER  :: costZ=-log10(ZSun) !1.81701503299642D0 !!!Z=10.**(FeH-1.817)!!!
    !!
    DOUBLE PRECISION, PARAMETER  :: dYdZ=1.78,He0=0.2485
    DOUBLE PRECISION, PARAMETER  :: numaxSun=3090 !microHz Chaplin 14. In Kjeldsen&Bedding 3050
	DOUBLE PRECISION, PARAMETER  :: DnuSun=135.1 !microHz Chaplin 14. In Kjeldsen&Bedding 134.9

END MODULE SunPD