      SUBROUTINE PCGNS(NN,AA,LENAA,MAXA,PP,RHO,START,WORK,IFLAG)
C
C     This subroutine solves a system of equations using the method
C        of Conjugate Gradients.
C
C     The system to be solved is in the form Bx=b, where
C
C      +--          --+        +-    -+
C      |        |     |        |      |   T = START(k), where
C      |   AA   | -PP |        | -RHO |
C  B = |        |     | ,  b = |      |    |START(k)|=    max    |START(i)|
C      +--------+-----+        +------+                1<=i<=NN+1
C      |    E(k)**t   |        |  T   |
C      +--          --+        +-    -+
C
C   AA is an (NN x NN) symmetric matrix, PP, RHO are (NN x 1) vectors,
C   b is of length NN+1 and E(k)**t is the ( 1 x (NN+1) ) vector
C   consisting of all zeros, except for a '1' in its k-th position.
C   It is assumed that rank [AA,-PP]=NN and B is invertible.
C
C   The system is solved by splitting B into two matrices M and L, where
C
C       +-        -+                                +-     -+
C       |      |   |                                |       |
C       |  AA  | c |                                | -PP-c |
C   M = |      |   |  ,  L = u * [E(NN+1)**t],  u = |       | ,
C       +------+---+                                +-------+
C       |  c   | d |                                |   0   |
C       +-        -+                                +-     -+
C
C   E(NN+1) is the (NN+1) x 1 vector consisting of all zeros except for
C   a '1' in its last position, and x**t is the transpose of x.
C
C    The final solution vector, x, is given by
C
C            +-                                    -+
C            |           [sol(u)]*[E(NN+1)**t]      |
C       x =  | I  -  -----------------------------  | * sol(b)
C            |        {[(sol(u))**t]*E(NN+1)}+1.0   |
C            +-                                    -+
C
C     where sol(a)=[M**(-1)]*a.  The two systems (Mz=u, Mz=b) are solved
C     by a preconditioned conjugate gradient algorithm.
C
C
C
C     Input variables:
C
C        NN -- dimension of the matrix packed in AA.
C
C        AA -- one dimensional real array containing the leading NN x NN
C              submatrix of B in packed skyline storage form.
C
C        LENAA -- number of elements in the packed array AA.
C
C        MAXA -- integer array used for specifying information about AA.
C                Using packed skyline storage, it has length NN+2, and
C                stores the indices of the diagonal elements within AA.
C                MAXA(NN+1) = LENAA + 1 and MAXA(NN+2) = LENAA + NN + 3 - k
C                (k as defined above) by convention.
C                (NOTE:  The value of MAXA(NN+2) is set by this
C                subroutine when the preconditioning matrix Q is
C                initialized.)
C
C                For example, using the packed storage scheme,
C                a symmetric 5 x 5 matrix of the form
C
C                +--             --+
C                |  1  3  0  0  0  |
C                |  3  2  0  7  0  |
C                |  0  0  4  6  0  |
C                |  0  7  6  5  9  |
C                |  0  0  0  9  8  |
C                +--             --+
C
C                would result in NN=5, LENAA=9, MAXA=(1,2,4,5,8,10,*),
C                and AA=(1,2,3,4,5,6,7,8,9).
C
C        PP -- vector of length NN, used for (NN+1)st column of
C              augmented matrix B .
C
C        RHO -- vector of length NN, negative of top part of right hand
C               side b .
C
C        START -- vector of length NN+1, normally the solution to the
C                 previous linear system; used to determine the index k .
C
C     Output variables:
C
C        START -- solution vector x of  B x = b  (defined above).
C
C        IFLAG -- normally unchanged on output.  If the conjugate gradient
C                 iteration fails to converge in 10*(NN+1) iterations (most
C                 likely due to a singular Jacobian matrix), PCGNS returns
C                 with  IFLAG = 4 , and does not compute x.
C
C     Working storage:
C
C        WORK -- array of length 6*(NN+1) + LENAA :
C
C             WORK(1..NN+1) = temporary working storage;
C
C             WORK(NN+2..2NN+2) = intermediate solution vector z for Mz=u,
C                input value is used as initial estimate for z;
C
C             WORK(2NN+3..3NN+3) = intermediate solution vector z for Mz=b,
C                input value is used as initial estimate for z;
C
C             WORK(3NN+4..4NN+4) = storage for residual vectors;
C
C             WORK(4NN+5..5NN+5) = storage for direction vectors;
C
C             WORK(5NN+6..  *  ) = storage for the preconditioning matrix
C                Q, normally of length LENAA+NN+1. A storage scheme for Q
C                (and AA) other than the default packed skyline storage
C                scheme can be accomodated by simply extending the length
C                of WORK (and MAXA), and prodiving different versions of
C                the subroutines MULTDS, MFACDS, and QIMUDS.
C
C
C     Three user-defined subroutines are required:
C
C       MULTDS(y,AA,x,MAXA,NN,LENAA) -- computes y = AA x  .
C
C       MFACDS(NN,Q,LENAA,MAXA) -- computes the preconditioning matrix
C          Q based on M.  A copy of AA is placed in Q before the call;
C          after the call, it is assumed that Q contains some factorization
C          for the preconditioning matrix Q.  If no preconditioning is
C          required, MFACDS may be a dummy subroutine.
C
C       QIMUDS(Q,f,MAXA,NN,LENAA) -- computes f := [Q**(-1)]*f for any
C          vector f, given the factorization of Q produced by subroutine
C          MFACDS.  Again, if no preconditioning is required, QIMUDS
C          may be a dummy subroutine.
C
C
C     Subroutines and functions called:
C
C        BLAS -- DAXPY, DCOPY, DDOT, DNRM2, DSCAL, IDAMAX
C        D1MACH,MULTDS,MFACDS,QIMUDS
C
C
      INTEGER IFLAG,IMAX,IND,J,K,LENAA,NN,MAXA(NN+2),NP1,NP2,N2P3,
     &   N3P4,N4P5,N5P6
      DOUBLE PRECISION AA(LENAA),AB,AU,BB,BU,DZNRM,PBNPRD,PP(NN),
     &   PUNPRD,RBNPRD,RBTOL,RHO(NN),RNPRD,RUNPRD,RUTOL,
     &   START(NN+1),STARTK,TEMP,UNRM,WORK(5*(NN+1)+LENAA+NN+1),
     &   ZLEN,ZTOL
      LOGICAL STILLU,STILLB
C
      DOUBLE PRECISION D1MACH,DDOT,DNRM2
      INTEGER IDAMAX
C
C
C     SET UP BASES FOR VECTORS STORED IN WORK ARRAY.
C
      NP1=NN+1
      NP2=NN+2
      N2P3=(2*NN)+3
      N3P4=(3*NN)+4
      N4P5=(4*NN)+5
      N5P6=(5*NN)+6
C
C     FIND THE ELEMENT OF LARGEST MAGNITUDE IN THE INITIAL VECTOR, AND
C     RECORD ITS POSITION IN K.
C
      K=IDAMAX(NP1,START,1)
      STARTK=START(K)
C
C     INITIALIZE Q, SET VALUES OF MAXA(NN+1) AND MAXA(NN+2),
C     COMPUTE PRECONDITIONER.
C
      CALL DCOPY(LENAA,AA,1,WORK(N5P6),1)
      MAXA(NN+1)=LENAA+1
      MAXA(NN+2)=LENAA+NN+3-K
      CALL MFACDS(NN,WORK(N5P6),LENAA,MAXA)
C
C     COMPUTE ALL TOLERANCES NEEDED FOR EXIT CRITERIA.
C
      CALL DCOPY(NN,PP,1,WORK,1)
      IF (K .LT. NP1) WORK(K)=WORK(K)+1.0D0
      UNRM=DNRM2(NN,WORK,1)
C
      IMAX=10*NP1
      STILLU=.TRUE.
      STILLB=.TRUE.
      ZTOL=100.0*D1MACH(4)
      RBTOL=ZTOL*SQRT(STARTK**2 + DNRM2(NN,RHO,1)**2)
      RUTOL=ZTOL*UNRM
C
C     COMPUTE INITIAL RESIDUAL VECTOR FOR THE SYSTEM M z = u .
C
      CALL MULTDS(WORK(N3P4),AA,WORK(NP2),MAXA,NN,LENAA)
      WORK(N3P4+NN)=WORK(NP2+K-1)
      IND=N3P4+K-1
      IF (K .LT. NP1) WORK(IND)=WORK(IND)+WORK(NP2+NN)
      CALL DSCAL(NP1,-1.0D0,WORK(N3P4),1)
      CALL DAXPY(NN,-1.0D0,PP,1,WORK(N3P4),1)
      IF (K .LT. NP1) WORK(IND)=WORK(IND)-1.0D0
      CALL QIMUDS(WORK(N5P6),WORK(N3P4),MAXA,NN,LENAA)
C
C     COMPUTE INITIAL DIRECTION VECTOR, ALL INNER PRODUCTS FOR M z = u .
C
      CALL DCOPY(NP1,WORK(N3P4),1,WORK,1)
      CALL QIMUDS(WORK(N5P6),WORK,MAXA,NN,LENAA)
      CALL MULTDS(WORK(N4P5),AA,WORK,MAXA,NN,LENAA)
      WORK(N4P5+NN)=WORK(K)
      IF (K .LT. NP1) WORK(N4P5+K-1)=WORK(N4P5+K-1)+WORK(NP1)
C
      RUNPRD=DDOT(NP1,WORK(N3P4),1,WORK(N3P4),1)
      PUNPRD=DDOT(NP1,WORK(N4P5),1,WORK(N4P5),1)
C
      J=1
C
C     DO WHILE ((STILLU) .AND. (J .LE. IMAX))
100   IF (.NOT. ((STILLU) .AND. (J .LE. IMAX)) ) GO TO 200
C
C        IF ||RESIDUAL|| IS STILL NOT SMALL ENOUGH, CONTINUE.
         IF (SQRT(RUNPRD) .GT. RUTOL) THEN
            IF (PUNPRD .EQ. 0.0) THEN
               CALL MULTDS(WORK(N3P4),AA,WORK(NP2),MAXA,NN,LENAA)
               WORK(N3P4+NN)=WORK(NP2+K-1)
               IND=N3P4+K-1
               IF (K .LT. NP1) WORK(IND)=WORK(IND)+WORK(NP2+NN)
               CALL DSCAL(NP1,-1.0D0,WORK(N3P4),1)
               CALL DAXPY(NN,-1.0D0,PP,1,WORK(N3P4),1)
               IF (K .LT. NP1) WORK(N3P4+K-1)=WORK(N3P4+K-1)-1.0D0
               CALL QIMUDS(WORK(N5P6),WORK(N3P4),MAXA,NN,LENAA)
               CALL DCOPY(NP1,WORK(N3P4),1,WORK,1)
               CALL QIMUDS(WORK(N5P6),WORK,MAXA,NN,LENAA)
               CALL MULTDS(WORK(N4P5),AA,WORK,MAXA,NN,LENAA)
               WORK(N4P5+NN)=WORK(K)
               IND=N4P5+K-1
               IF (K .LT. NP1) WORK(IND)=WORK(IND)+WORK(NP1)
               RUNPRD=DDOT(NP1,WORK(N3P4),1,WORK(N3P4),1)
               PUNPRD=DDOT(NP1,WORK(N4P5),1,WORK(N4P5),1)
               IF (SQRT(RUNPRD) .LE. RUTOL) THEN
                  STILLU=.FALSE.
               ENDIF
            ENDIF
            IF (STILLU) THEN
C              UPDATE SOLUTION VECTOR; COMPUTE ||DELTA SOL||/||UPDATED||.
               AU=RUNPRD/PUNPRD
               CALL DCOPY(NP1,WORK(NP2),1,WORK,1)
               CALL DAXPY(NP1,AU,WORK(N4P5),1,WORK(NP2),1)
               CALL DAXPY(NP1,-1.0D0,WORK(NP2),1,WORK,1)
               ZLEN=DNRM2(NP1,WORK(NP2),1)
               DZNRM=DNRM2(NP1,WORK,1)
C              IF RELATIVE CHANGE IN SOLUTIONS IS SMALL ENOUGH, EXIT.
               IF ( (DZNRM/ZLEN) .LT. ZTOL) STILLU=.FALSE.
            ENDIF
         ELSE
            STILLU=.FALSE.
         ENDIF
C
C        IF NO EXIT CRITERIA FOR Mz=u HAVE BEEN MET, CONTINUE.
         IF (STILLU) THEN
C           UPDATE RESIDUAL VECTOR; COMPUTE (RNEW,RNEW), ||RNEW|| .
            CALL MULTDS(WORK,AA,WORK(N4P5),MAXA,NN,LENAA)
            WORK(NP1)=WORK(N4P5+K-1)
            IF (K .LT. NP1) WORK(K)=WORK(K)+WORK(N4P5+NN)
            CALL QIMUDS(WORK(N5P6),WORK,MAXA,NN,LENAA)
            CALL DAXPY(NP1,-AU,WORK,1,WORK(N3P4),1)
            RNPRD=DDOT(NP1,WORK(N3P4),1,WORK(N3P4),1)
C           UPDATE DIRECTION VECTOR; COMPUTE (PNEW,PNEW).
            BU=RNPRD/RUNPRD
            RUNPRD=RNPRD
            CALL DCOPY(NP1,WORK(N3P4),1,WORK,1)
            CALL QIMUDS(WORK(N5P6),WORK,MAXA,NN,LENAA)
            CALL MULTDS(START,AA,WORK,MAXA,NN,LENAA)
            START(NP1)=WORK(K)
            IF (K .LT. NP1) START(K)=START(K)+WORK(NP1)
            CALL DAXPY(NP1,BU,WORK(N4P5),1,START,1)
            CALL DCOPY(NP1,START,1,WORK(N4P5),1)
            PUNPRD=DDOT(NP1,WORK(N4P5),1,WORK(N4P5),1)
         ENDIF
C
         J=J+1
      GO TO 100
200   CONTINUE
C     END DO
C
C     SET ERROR FLAG IF THE CONJUGATE GRADIENT ITERATION DID NOT CONVERGE.
C
      IF (J .GT. IMAX) THEN
         IFLAG=4
         RETURN
      ENDIF
C
C     COMPUTE INITIAL RESIDUAL VECTOR FOR THE SYSTEM M z = b .
C
      CALL MULTDS(WORK(N3P4),AA,WORK(N2P3),MAXA,NN,LENAA)
      WORK(N3P4+NN)=WORK(N2P3+K-1)
      IND=N3P4+K-1
      IF (K .LT. NP1) WORK(IND)=WORK(IND)+WORK(N2P3+NN)
      CALL DSCAL(NP1,-1.0D0,WORK(N3P4),1)
      CALL DAXPY(NN,-1.0D0,RHO,1,WORK(N3P4),1)
      WORK(N3P4+NN)=STARTK+WORK(N3P4+NN)
      CALL QIMUDS(WORK(N5P6),WORK(N3P4),MAXA,NN,LENAA)
C
C     COMPUTE INITIAL DIRECTION VECTOR, ALL INNER PRODUCTS FOR M z = b .
C
      CALL DCOPY(NP1,WORK(N3P4),1,WORK,1)
      CALL QIMUDS(WORK(N5P6),WORK,MAXA,NN,LENAA)
      CALL MULTDS(WORK(N4P5),AA,WORK,MAXA,NN,LENAA)
      WORK(N4P5+NN)=WORK(K)
      IF (K .LT. NP1) WORK(N4P5+K-1)=WORK(N4P5+K-1)+WORK(NP1)
C
      RBNPRD=DDOT(NP1,WORK(N3P4),1,WORK(N3P4),1)
      PBNPRD=DDOT(NP1,WORK(N4P5),1,WORK(N4P5),1)
C
      J=1
C
C     DO WHILE ( STILLB  .AND. (J .LE. IMAX) )
300   IF (.NOT. ( STILLB  .AND. (J .LE. IMAX) ) ) GO TO 400
C
C        IF ||RESIDUAL|| IS STILL NOT SMALL ENOUGH, CONTINUE.
         IF (SQRT(RBNPRD) .GT. RBTOL) THEN
            IF (PBNPRD .EQ. 0.0) THEN
               CALL MULTDS(WORK(N3P4),AA,WORK(N2P3),MAXA,NN,LENAA)
               WORK(N3P4+NN)=WORK(N2P3+K-1)
               IND=N3P4+K-1
               IF (K .LT. NP1) WORK(IND)=WORK(IND)+WORK(N2P3+NN)
               CALL DSCAL(NP1,-1.0D0,WORK(N3P4),1)
               CALL DAXPY(NN,-1.0D0,RHO,1,WORK(N3P4),1)
               WORK(N3P4+NN)=STARTK+WORK(N3P4+NN)
               CALL QIMUDS(WORK(N5P6),WORK(N3P4),MAXA,NN,LENAA)
               CALL DCOPY(NP1,WORK(N3P4),1,WORK,1)
               CALL QIMUDS(WORK(N5P6),WORK,MAXA,NN,LENAA)
               CALL MULTDS(WORK(N4P5),AA,WORK,MAXA,NN,LENAA)
               WORK(N4P5+NN)=WORK(K)
               IND=N4P5+K-1
               IF (K .LT. NP1) WORK(IND)=WORK(IND)+WORK(NP1)
               RBNPRD=DDOT(NP1,WORK(N3P4),1,WORK(N3P4),1)
               PBNPRD=DDOT(NP1,WORK(N4P5),1,WORK(N4P5),1)
               IF (SQRT(RBNPRD) .LE. RBTOL) THEN
                  STILLB=.FALSE.
               ENDIF
            ENDIF
            IF (STILLB) THEN
C              UPDATE SOLUTION VECTOR; COMPUTE ||DELTA SOL||/||UPDATED|| .
               AB=RBNPRD/PBNPRD
               CALL DCOPY(NP1,WORK(N2P3),1,WORK,1)
               CALL DAXPY(NP1,AB,WORK(N4P5),1,WORK(N2P3),1)
               CALL DAXPY(NP1,-1.0D0,WORK(N2P3),1,WORK,1)
               ZLEN=DNRM2(NP1,WORK(N2P3),1)
               DZNRM=DNRM2(NP1,WORK,1)
C              IF RELATIVE CHANGE IN SOLUTIONS IS SMALL ENOUGH, EXIT.
               IF ( (DZNRM/ZLEN) .LT. ZTOL) STILLB=.FALSE.
            ENDIF
         ELSE
            STILLB=.FALSE.
         ENDIF
C
C        IF NO EXIT CRITERIA FOR Mz=b HAVE BEEN MET, CONTINUE.
         IF (STILLB) THEN
C           UPDATE RESIDUAL VECTOR; COMPUTE (RNEW,RNEW), ||RNEW|| .
            CALL MULTDS(WORK,AA,WORK(N4P5),MAXA,NN,LENAA)
            WORK(NP1)=WORK(N4P5+K-1)
            IF (K .LT. NP1) WORK(K)=WORK(K)+WORK(N4P5+NN)
            CALL QIMUDS(WORK(N5P6),WORK,MAXA,NN,LENAA)
            CALL DAXPY(NP1,-AB,WORK,1,WORK(N3P4),1)
            RNPRD=DDOT(NP1,WORK(N3P4),1,WORK(N3P4),1)
C        UPDATE DIRECTION VECTOR; COMPUTE (PNEW,PNEW).
            BB=RNPRD/RBNPRD
            RBNPRD=RNPRD
            CALL DCOPY(NP1,WORK(N3P4),1,WORK,1)
            CALL QIMUDS(WORK(N5P6),WORK,MAXA,NN,LENAA)
            CALL MULTDS(START,AA,WORK,MAXA,NN,LENAA)
            START(NP1)=WORK(K)
            IF (K .LT. NP1) START(K)=START(K)+WORK(NP1)
            CALL DAXPY(NP1,BB,WORK(N4P5),1,START,1)
            CALL DCOPY(NP1,START,1,WORK(N4P5),1)
            PBNPRD=DDOT(NP1,WORK(N4P5),1,WORK(N4P5),1)
         ENDIF
C
         J=J+1
      GO TO 300
400   CONTINUE
C     END DO
C
C     SET ERROR FLAG IF THE CONJUGATE GRADIENT ITERATION DID NOT CONVERGE.
C
      IF (J .GT. IMAX) THEN
         IFLAG=4
         RETURN
      ENDIF
C
C     COMPUTE FINAL SOLUTION VECTOR X, RETURN IT IN START.
C
      TEMP=-WORK(N2P3+NN)/(1.0D0+WORK(NP2+NN))
      CALL DCOPY(NP1,WORK(N2P3),1,START,1)
      CALL DAXPY(NP1,TEMP,WORK(NP2),1,START,1)
C
      RETURN
      END


      FUNCTION bessy1(x)
      REAL bessy1,x
CU    USES bessj1
      REAL xx,z,bessj1
      DOUBLE PRECISION p1,p2,p3,p4,p5,q1,q2,q3,q4,q5,r1,r2,r3,r4,r5,r6,
     *s1,s2,s3,s4,s5,s6,s7,y
      SAVE p1,p2,p3,p4,p5,q1,q2,q3,q4,q5,r1,r2,r3,r4,r5,r6,s1,s2,s3,s4,
     *s5,s6,s7
      DATA p1,p2,p3,p4,p5/1.d0,.183105d-2,-.3516396496d-4,
     *.2457520174d-5,-.240337019d-6/, q1,q2,q3,q4,q5/.04687499995d0,
     *-.2002690873d-3,.8449199096d-5,-.88228987d-6,.105787412d-6/
      DATA r1,r2,r3,r4,r5,r6/-.4900604943d13,.1275274390d13,
     *-.5153438139d11,.7349264551d9,-.4237922726d7,.8511937935d4/,s1,s2,
     *s3,s4,s5,s6,s7/.2499580570d14,.4244419664d12,.3733650367d10,
     *.2245904002d8,.1020426050d6,.3549632885d3,1.d0/
      if(x.lt.8.)then
        y=x**2
        bessy1=x*(r1+y*(r2+y*(r3+y*(r4+y*(r5+y*r6)))))/(s1+y*(s2+y*(s3+
     *y*(s4+y*(s5+y*(s6+y*s7))))))+.636619772*(bessj1(x)*log(x)-1./x)
      else
        z=8./x
        y=z**2
        xx=x-2.356194491
        bessy1=sqrt(.636619772/x)*(sin(xx)*(p1+y*(p2+y*(p3+y*(p4+y*
     *p5))))+z*cos(xx)*(q1+y*(q2+y*(q3+y*(q4+y*q5)))))
      endif
      return
      END

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


!	afStresses:	Current afStresses (IN), New afStresses (OUT)
!	fEpsilonP:	Current State variables (IN), New State variables (OUT)
!	afE:	Constitutive Matrix (OUT)
!	afdStrains:	INCREMENTAL Strains (IN)
!	afProps:	Properties (IN)
! afStressesElastic(6) = Elastic afStresses predictor
! afDElastic(6,6) = Elastic constitutive matrix
! afStressesDeviatoric(6)= (New) Deviatoric Stresses tensor --> Used to form afE

Subroutine MaterialVonMises(afdStrains, fEpsilonP, afStresses, afProps, afStressesNew, fEpsilonPNew, afE)
  !DEC$ ATTRIBUTES DLLEXPORT::MaterialVonMises
	Implicit None
    Real, Intent(IN) :: fEpsilonP, afdStrains(6), afStresses(6), afProps(5)
	Real, Intent(OUT) :: afStressesNew(6), fEpsilonPNew, afE(6, 6)

	Real :: afStressesElastic(6), afDElastic(6, 6), afStressesDeviatoric(6)
	Integer :: K1, K2
	Real :: fTemp1, fTemp2, fTemp3, fG, fdEpsilonP, P_EL, P_NEW, CJ2_EL, CJ2_NEW

! afProps(1)=E (Young's modulus), afProps(2)=nu (Poisson's ratio)
! Do not use nu=0.5 (incrompressible solid)
! Evaluate elastic constitutive matrix
    afDElastic = 0.
	fTemp1 = afProps(1) * (1. - afProps(2)) / (1. + afProps(2)) / (1. - 2. * afProps(2))
	fTemp2 = afProps(1) * afProps(2) / (1. + afProps(2)) / (1. - 2. * afProps(2))
	fTemp3 = afProps(1) / (1. + afProps(2)) / 2.
	afDElastic(1, 1) = fTemp1
	afDElastic(2, 2) = fTemp1
	afDElastic(3, 3) = fTemp1
	afDElastic(1, 2) = fTemp2
	afDElastic(1, 3) = fTemp2
	afDElastic(2, 1) = fTemp2
	afDElastic(2, 3) = fTemp2
	afDElastic(3, 1) = fTemp2
	afDElastic(3, 2) = fTemp2
	afDElastic(4, 4) = fTemp3
	afDElastic(5, 5) = fTemp3
	afDElastic(6, 6) = fTemp3

! EVALUATE NEW afStresses TENSOR and STATE VARIABLE
! Calculate trial (elastic) afStresses state
	afStressesElastic = afStresses + MatMul(afDElastic, afdStrains)
! Yield function <>0 ?
! afProps(3)=sigma(y) (initial yield afStresses),
! afProps(4)=h (hardening modulus for linear hardening)
! fEpsilonP(1)=epsilon(p)_BAR (accumulated plastic strain)
	CJ2_EL = ((afStressesElastic(1) - afStressesElastic(2)) ** 2 + (afStressesElastic(2) - afStressesElastic(3)) ** 2 + &
		(afStressesElastic(3) - afStressesElastic(1)) ** 2) / 6. + afStressesElastic(4) ** 2 + afStressesElastic(5) ** 2 + &
		afStressesElastic(6) ** 2
	fTemp1 = SQRT(3. * CJ2_EL) - (afProps(3) + afProps(4) * fEpsilonP)
	If (fTemp1 <= 0.) Then
		afStressesNew = afStressesElastic     ! No plastic correction needed
		afE = afDElastic       ! Const. matrix = Elastic const. matrix, no change to the accumulated plastic strain
	Else
! Return mapping
		fG = afProps(1) / 2. / (1. + afProps(2))    ! fG = Shear modulus
		fdEpsilonP = fTemp1 / (3. * fG + afProps(4))
		fEpsilonPNew = fEpsilonP + fdEpsilonP  ! Update accumulated plastic strain
		fTemp1 = fG * fdEpsilonP * SQRT(3. / CJ2_EL)   ! 2. and 1/2. cancel out
		P_EL = (afStressesElastic(1) + afStressesElastic(2) + afStressesElastic(3)) / 3.  ! P_EL=mean afStresses (elastic)
		afStressesNew(1) = afStressesElastic(1) - fTemp1 * (afStressesElastic(1) - P_EL)
		afStressesNew(2) = afStressesElastic(2) - fTemp1 * (afStressesElastic(2) - P_EL)
		afStressesNew(3) = afStressesElastic(3) - fTemp1 * (afStressesElastic(3) - P_EL)
		afStressesNew(4) = afStressesElastic(4) - fTemp1 * afStressesElastic(4)
		afStressesNew(5) = afStressesElastic(5) - fTemp1 * afStressesElastic(5)
		afStressesNew(6) = afStressesElastic(6) - fTemp1 * afStressesElastic(6)

! CREATE NEW JACOBIAN
		P_NEW = (afStressesNew(1) + afStressesNew(2) + afStressesNew(3)) / 3.
		afStressesDeviatoric(1) = afStressesNew(1) - P_NEW
		afStressesDeviatoric(2) = afStressesNew(2) - P_NEW
		afStressesDeviatoric(3) = afStressesNew(3) - P_NEW
		afStressesDeviatoric(4) = afStressesNew(4)
		afStressesDeviatoric(5) = afStressesNew(5)
		afStressesDeviatoric(6) = afStressesNew(6)

		CJ2_NEW = ((afStressesNew(1) - afStressesNew(2)) ** 2 + (afStressesNew(2) - afStressesNew(3)) ** 2 + &
			(afStressesNew(3) - afStressesNew(1)) ** 2 ) / 6. + afStressesNew(4) ** 2 + afStressesNew(5) ** 2 + &
			afStressesNew(6) ** 2
		fTemp1 = 3. * fG * fG / (afProps(4) + 3. * fG) / CJ2_NEW
		Do K1 = 1, 6
			Do K2 = 1, 6
				afE(K2, K1) = afDElastic(K2, K1) - fTemp1 * afStressesDeviatoric(K2) * afStressesDeviatoric(K1)
			End Do
		End Do
!		afE = afDElastic       ! Const. matrix = Elastic const. matrix, no change to the accumulated plastic strain
	End If
End Subroutine


!! This module define physical and numerical constant used by ROHSA
module mod_constants
  !! This module define physical and numerical constant used by ROHSA
  use, intrinsic :: iso_fortran_env
  implicit none

  integer,  parameter, public :: xp = REAL64

  !physical constants FIXME CHECK VALUES
  real(xp), parameter, public :: G       = 6.67408e-8_xp !nravitationnal cst in cgs
  real(xp), parameter, public :: c       = 2.99792458e10_xp !speed of light in cgs
  real(xp), parameter, public :: pi      = 4.0_xp*atan(1.0_xp)
  real(xp), parameter, public :: M_sun   = 1.98855e33_xp !mass of the sun in cgs
  real(xp), parameter, public :: cst_rad = 7.5657308531642009e-15_xp !radiation cst in cgs
  real(xp), parameter, public :: stefan  = (c * cst_rad) / 4.0_xp !stefan cst in cgs
  real(xp), parameter, public :: kb      = 1.3806488e-16_xp !boltzmann cst in cgs
  real(xp), parameter, public :: R       = 8.3144598e7_xp !gas cst in csg = Boltzmann cst over proton mass
  real(xp), parameter, public :: gammag  = 5._xp / 3._xp !adiabatic coefficient
  real(xp), parameter, public :: thomson = 6.6524587158e-25_xp !thomson cross-section in cgs

end module mod_constants


subroutine compute_localization_weights( istat, dist, nlb, nub, mlb, mub, nmax, mmax, nostat, mnstat, kcs, xz, yz, locval )

    use globaldata

    implicit none

    integer, intent(in) :: istat   ! current station number
    integer, intent(in) :: nostat  ! number of stations
    integer, intent(in) :: nlb, nub, nmax
    integer, intent(in) :: mlb, mub, mmax
    integer, dimension(nmax,mmax), intent(in) :: kcs
    integer, dimension(2,nostat) , intent(in) :: mnstat

    double precision, intent(in) :: dist
    real(fp) , dimension(nlb:nub, mlb:mub) , intent(in) :: xz     !  Description and declaration in esm_alloc_real.f90
    real(fp) , dimension(nlb:nub, mlb:mub) , intent(in) :: yz     !  Description and declaration in esm_alloc_real.f90

    double precision, dimension(nlb:nub, mlb:mub), intent(out) :: locval ! computed weights

    ! local variables
    integer :: m, n
    ! mn values of station
    integer :: ms, ns
    ! xy coordinates of station
    double precision :: sx, sy
    real :: weight
    real, external :: cohn

    ! intialize weight values
    locval = 0.0

    weight = 0.
    ms = mnstat(1,istat)
    ns = mnstat(2,istat)
    sx = xz(ns,ms)
    sy = yz(ns,ms)
    do n = 1, nmax
       do m = 1, mmax
          if (kcs(n,m) .gt. 0) then
             weight = cohn(sx,sy,xz(n,m),yz(n,m),dist)
          endif
          locval(n,m) = weight
       enddo
    enddo

end subroutine compute_localization_weights
!
!-------------------------------------------------------------------------------
!
function cohn(sm,sn,rm,rn,dist) result(weight)

    implicit none

    real :: weight ! localization weight according to Cohn's formula

    ! coordinates to compute localization weight for
    double precision :: sm, sn

    ! treshold distance for Cohn's formula. all points at a distance
    ! more than 2*dist have weight 0
    double precision :: dist
    double precision :: rm, rn

    ! local parameters
    real :: zc1 ! value of (z/c)
    real :: zc2 ! value of (z/c)^2
    real :: zc3 ! value of (z/c)^3
    real :: zc4 ! value of (z/c)^4
    real :: zc5 ! value of (z/c)^5
    real :: z   ! Eucledean distance between (m,n) and (rm, rn)
    real :: dm  ! distance between rm and sm
    real :: dn  ! distance between rn and sn

    real p1_4, p1_2, p2_3, p5_8, p5_3, p1_12
    parameter( p1_4  = 1.0/4.0  ) ! value of 1/4
    parameter( p1_2  = 1.0/2.0  ) ! value of 1/2
    parameter( p2_3  = 2.0/3.0  ) ! value of 2/3
    parameter( p5_8  = 5.0/8.0  ) ! value of 5/8
    parameter( p5_3  = 5.0/3.0  ) ! value of 5/3
    parameter( p1_12 = 1.0/12.0 ) ! value of 1/12

!     Compute distance per direction
!
      dn=abs(rn-sn)
      dm=abs(rm-sm)
!
!     Initialize weight
      weight=0.0
!
!     If point is likely to be within localization region
!
      if (dn<2.0*dist .and. dm<2.0*dist) then
!
!        compute euclidian distance
!
         z=sqrt(dn*dn+dm*dm)
!
!        compute weight according to Cohn's formula
!
         if (z .le. 2.0*dist) then
            zc1=z/dist
            zc2=zc1*zc1
            zc3=zc2*zc1
            zc4=zc3*zc1
            zc5=zc4*zc1
            if (z .le. dist) then
               weight=-p1_4 *zc5+p1_2*zc4+p5_8*zc3-p5_3*zc2+1.0
            else
               weight=p1_12*zc5-p1_2*zc4+p5_8*zc3+p5_3*zc2-5.0*zc1+4-p2_3*(dist/z)
            endif
         endif
      endif

      end function cohn


module vorticity
  use boundaries
  use exchange

  implicit none

  contains

  ! ---------------------------------------------------------------------------
  !> Evaluate relative vorticity at lower left grid boundary (du/dy
  !! and dv/dx are at lower left corner as well)
  subroutine evaluate_zeta(zeta, u, v, dx, dy, nx, ny, layers, &
                        xlow, xhigh, ylow, yhigh, OL, &
                        ilower, iupper, num_procs, myid)
    implicit none

    double precision, intent(out) :: zeta(xlow-OL:xhigh+OL, ylow-OL:yhigh+OL, layers)
    double precision, intent(in)  :: u(xlow-OL:xhigh+OL, ylow-OL:yhigh+OL, layers)
    double precision, intent(in)  :: v(xlow-OL:xhigh+OL, ylow-OL:yhigh+OL, layers)
    double precision, intent(in)  :: dx, dy
    integer,          intent(in)  :: nx, ny, layers
    integer,          intent(in)  :: xlow, xhigh, ylow, yhigh, OL
    integer,          intent(in)  :: ilower(0:num_procs-1,2)
    integer,          intent(in)  :: iupper(0:num_procs-1,2)
    integer,          intent(in)  :: num_procs, myid
    integer i, j, k

    zeta = 0d0

    do k = 1, layers
      do j = ylow-OL+1, yhigh+OL
        do i = xlow-OL+1, xhigh+OL
          zeta(i,j,k) = (v(i,j,k)-v(i-1,j,k))/dx-(u(i,j,k)-u(i,j-1,k))/dy
        end do
      end do
    end do

    return
  end subroutine evaluate_zeta

end module vorticity


! point_smoothers.f08
!
! Point smoothers for geometric multigrid.

module point_smoothers
    use, intrinsic iso_fortran_env
    use structured_grids
    implicit none

    ! Interface for the weighted jacobi method.
    interface wjacobi
        module procedure wjacobi_2d
        module procedure wjacobi_3d
    end interface wjacobi

    ! Interface for the guass seidel method.
    interface gauss_seidel
        module procedure gauss_seidel_2d
        module procedure gauss_seidel_3d
    end interface gauss_seidel

    ! Interface for the (weighted) SOR method.
    interface wsor
        module procedure wsor_2d
        module procedure wsor_3d
    end interface wsor

    contains

    !
    ! Subroutine definitions for weighted jacobi in 2D and 3D
    !

    subroutine wjacobi_2d(grid, U, F, w)
        type(Grid2D), intent(in) :: grid                                ! The grid that contains step size information, etc.
        real(REAL64), dimension(1:grid%nx, 1:grid%ny), intent(inout) :: U  ! The (discrete) function we are relaxing.
        real(REAL64), dimension(1:grid%nx, 1:grid%ny), intent(in) :: F     ! The right-hand-side of the PDE, in discrete form.
        real(REAL64), intent(in) :: w                                      ! The weight for the method.

        ! A temporary array that holds the next guess.
        real(REAL64), dimension(1:grid%nx, 1:grid%ny) :: temp

        ! Counters for the loops.
        integer :: i, j, k

        ! Temporary x- and y-coordinates.
        real(REAL64) :: x, y

        ! A temporary variable that stores the ratio of the square of the step sizes.
        real(REAL64) :: alpha

        ! Store the ratio of the step sizes.
        alpha = (grid%hx / grid%hy)**2

        ! First compute the interior points.
        !$omp parallel do private(i, j) collapse(2)
        do j = 2, grid%ny - 1
            do i = 2, grid%nx - 1
                temp(i, j) =    w * &
                                ( &
                                    F(i, j) + &
                                    U(i + 1, j) + U(i - 1, j) + &
                                    alpha * ( U(i, j + 1) + U(i, j - 1) )
                                ) / (2 * (1 + alpha))
                                + &
                                (1 - w) * U(i, j)
            end do
        end do
        !$omp end parallel do

        ! Set the new version of U to the current value of the temporary array.
        U = temp
    end subroutine wjacobi_2d

    subroutine wjacobi_3d(grid, U, F, w)
        type(Grid3D), intent(in) :: grid
        real(REAL64), dimension(1:grid%nx, 1:grid%ny, 1:grid%nz), intent(inout) :: U
        real(REAL64), dimension(1:grid%nx, 1:grid%ny, 1:grid%nz), intent(in) :: F
        real(REAL64), intent(in) :: w

        ! A temporary array that holds the next guess.
        real(REAL64), dimension(1:grid%nx, 1:grid%ny, 1:grid%nz) :: temp

        ! Counters for the loops.
        integer :: i, j, k, m

        ! Temporary x- and y-coordinates.
        real(REAL64) :: x, y, z

        ! A temporary variable that stores the ratio of the square of the step sizes.
        real(REAL64) :: alpha, beta

        ! Store the ratio of the step sizes.
        alpha = (grid%hx / grid%hy)**2
        beta = (grid%hx / grid%hz)**2

        ! First compute the interior points.
        !$omp parallel do private(i, j, k) collapse(3)
        do k = 2, grid%nz - 1
            do j = 2, grid%ny - 1
                do i = 2, grid%nx - 1
                    temp(i, j, k) = w * &
                                    ( &
                                        F(i, j, k) + &
                                        U(i + 1, j, k) + U(i - 1, j, k) + &
                                        alpha * ( U(i, j + 1, k) + U(i, j - 1, k) ) + &
                                        beta * (U(i, j, k + 1) + U(i, j, k - 1) ) &
                                    ) / (2 * (1 + alpha)) &
                                    + &
                                    (1 - w) * U(i, j, k)
                end do
            end do
        end do
        !$omp end parallel do

        ! Set the new version of U to the current value of the temporary array.
        U = temp
    end subroutine wjacobi_3d

    !
    ! Subroutine definitions for gauss seidel in 2D and 3D
    !

    subroutine gauss_seidel_2d(grid, U, F)
        type(Grid2D), intent(in) :: grid
        real(REAL64), dimension(1:grid%nx, 1:grid%ny), intent(inout) :: U
        real(REAL64), dimension(1:grid%nx, 1:grid%ny), intent(in) :: F

        ! A parameter to hold the ratio of our step sizes.
        real(REAL64), parameter :: alpha = (grid%hx / grid%hy)**2

        ! Counter variables for looping over the interior points and the boundaries.
        integer :: i, j, k

        ! Temporary x- and y-coordinates.
        real(REAL64) :: x, y

        ! Compute the new interior points.
        !$omp parallel do private(i, j) collapse(2)
        do j = 2, grid%ny - 1
            do i = 2, grid%nx - 1
                U(i, j) =   ( &
                                F(i, j) + &
                                U(i - 1, j) + U(i + 1, j) + &
                                alpha * ( &
                                    U(i, j - 1) + U(i, j + 1) &
                                ) &
                            ) / (2.0 * (1 + alpha))
            end do
        end do
        !$omp end parallel do
    end subroutine gauss_seidel_2d

    subroutine gauss_seidel_3d(grid, U)
        type(Grid3D), intent(in) :: grid
        real(REAL64), dimension(1:grid%nx, 1:grid%ny, 1:grid%nz), intent(inout) :: U

        real, parameter :: alpha = (grid%hx / grid%hy)**2
        real, parameter :: beta = (grid%hx / grid%hz)**2

        integer :: i, j, k

        ! First relax the interior points.
        !$omp parallel do private(i, j, k) collapse(3)
        do k = 2, grid%nz - 1
            do j = 2, grid%ny - 1
                do i = 2, grid%nx - 1
                    U(i, j, k) =    ( &
                                        F(i, j, k) + &

                                        U(i - 1, j, k) + U(i + 1, j, k) + &

                                        alpha * ( &
                                            U(i, j - 1, k) + U(i, j + 1, k)
                                        ) + &

                                        beta * ( &
                                            U(i, j, k - 1) + U(i, j, k + 1)
                                        )
                                    ) / (2.0 * (1 + alpha + beta))
                end do
            end do
        end do
        !$omp end parallel do
    end subroutine gauss_seidel_3d

    !
    ! Subroutine definitions for (weighted) successive overrelaxation in 2D and 3D.
    !

    subroutine wsor_2d(grid, U, F)
        type(Grid2D), intent(in) :: grid
        real(REAL64), dimension(1:grid%nx, 1:grid%ny), intent(inout) :: U
        real(REAL64), dimension(1:grid%nx, 1:grid%ny), intent(in) :: F

        real(REAL64), parameter :: alpha = (grid%hx / grid%hy)**2

        integer :: i, j, k

        ! First relax the interior points.
        !$omp parallel do private(i, j) collapse(2)
        do j = 2, grid%ny - 1
            do i = 2, grid%nx - 1
                U(i, j) =   w * ( &
                                    F(i, j) + &

                                    U(i - 1, j) + U(i + 1, j) + &

                                    alpha * ( &
                                        U(i, j - 1) + U(i, j + 1) &
                                    ) &
                                ) / (2.0 * (1 + alpha)) + &

                            (1 - w) * U(i, j)
            end do
        end do
        !$omp end parallel do
    end subroutine wsor_2d

    subroutine wsor_3d(grid, U, F)
        type(Grid3D), intent(in) :: grid
        real(REAL64), dimension(1:grid%nx, 1:grid%ny, 1:grid%nz), intent(inout) :: U
        real(REAL64), dimension(1:grid%nx, 1:grid%ny, 1:grid%nz), intent(in) :: F

        real(REAL64), parameter :: alpha = (grid%hx / grid%hy)**2
        real(REAL64), parameter :: beta = (grid%hx / grid%hz)**2

        integer :: i, j, k, m

        ! First relax the interior points.
        !$omp parallel do private(i, j, k) collapse(3)
        do k = 2, grid%nz - 1
            do j = 2, grid%ny - 1
                do i = 2, grid%nx - 1
                    U(i, j, k) =    w * ( &
                                        F(i, j, k) + &

                                        U(i - 1, j, k) + U(i + 1, j, k) + &

                                        alpha * ( &
                                            U(i, j - 1, k) + U(i, j + 1, k) &
                                        ) + &

                                        beta * ( &
                                            U(i, j, k - 1) + U(i, j, k + 1) &
                                        )
                                    ) / (2.0 * (1 + alpha + beta)) + &

                                    (1 - w) * U(i, j, k)
                end do
            end do
        end do
        !$omp end parallel do
    end subroutine wsor_3d

end module point_smoothers


      subroutine INTERPCENTRALSLOPE(
     & slope
     & ,islopelo0,islopelo1
     & ,islopehi0,islopehi1
     & ,nslopecomp
     & ,state
     & ,istatelo0,istatelo1
     & ,istatehi0,istatehi1
     & ,nstatecomp
     & ,iblo0,iblo1
     & ,ibhi0,ibhi1
     & ,dir
     & )
      implicit none
      integer*8 chiterations
      integer*8 chflops,chloads,chstores
      common /chiterations/ chiterations
      common /chflops/ chflops,chloads,chstores
      EXTERNAL CHCOMMON
      integer CHF_ID(0:5,0:5)
      data CHF_ID/ 1,0,0,0,0,0 ,0,1,0,0,0,0 ,0,0,1,0,0,0 ,0,0,0,1,0,0 ,0
     &,0,0,0,1,0 ,0,0,0,0,0,1 /
      integer nslopecomp
      integer islopelo0,islopelo1
      integer islopehi0,islopehi1
      REAL*8 slope(
     & islopelo0:islopehi0,
     & islopelo1:islopehi1,
     & 0:nslopecomp-1)
      integer nstatecomp
      integer istatelo0,istatelo1
      integer istatehi0,istatehi1
      REAL*8 state(
     & istatelo0:istatehi0,
     & istatelo1:istatehi1,
     & 0:nstatecomp-1)
      integer iblo0,iblo1
      integer ibhi0,ibhi1
      integer dir
      integer i0,i1
      integer ii0,ii1
      integer var
      ii0=CHF_ID(0, dir)
      ii1=CHF_ID(1, dir)
      do var = 0, nstatecomp - 1
      chiterations=(1+ibhi1-iblo1)*(1+ibhi0-iblo0)*1
      do i1 = iblo1,ibhi1
      do i0 = iblo0,ibhi0
          slope (i0,i1,var) = (0.500d0) * (
     & state (i0+ii0,i1+ii1,var) -
     & state (i0-ii0,i1-ii1,var) )
      enddo
      enddo
       end do
       chflops=chflops+2*chiterations
       chloads=chloads+chiterations
       chstores=chstores+chiterations
      return
      end


C
C	$Id$
C
      SUBROUTINE CSGRADL (N,K,X,Y,Z,W,LIST,LPTR,LEND, G,IER)
      INTEGER N, K, LIST(*), LPTR(*), LEND(N), IER
      DOUBLE PRECISION X(N), Y(N), Z(N), W(N), G(3)
C
C***********************************************************
C
C                                              From SSRFPACK
C                                            Robert J. Renka
C                                  Dept. of Computer Science
C                                       Univ. of North Texas
C                                           renka@cs.unt.edu
C                                                   07/24/96
C
C   Given a triangulation of a set of nodes on the unit
C sphere with their associated data values W, this routine
C estimates a gradient vector at node K as follows:  the
C coordinate system is rotated so that K becomes the north
C pole, node K and a set of nearby nodes are projected
C orthogonally onto the X-Y plane (in the new coordinate
C system), a quadratic is fitted in a weighted least squares
C sense to the data values at the projected nodes such that
C the value (associated with K) at (0,0) is interpolated, X
C and Y-partial derivative estimates DX and DY are computed
C by differentiating the quadratic at (0,0), and the esti-
C mated gradient G is obtained by rotating (DX,DY,0) back to
C the original coordinate system.  Note that G lies in the
C plane tangent to the sphere at node K, i.e., G is orthogo-
C nal to the unit vector represented by node K.  A Marquardt
C stabilization factor is used if necessary to ensure a
C well-conditioned least squares system, and a unique solu-
C tion exists unless the nodes are collinear.
C
C On input:
C
C       N = Number of nodes in the triangulation.  N .GE. 7.
C
C       K = Node at which the gradient is sought.  1 .LE. K
C           .LE. N.
C
C       X,Y,Z = Arrays containing the Cartesian coordinates
C               of the nodes.
C
C       W = Array containing the data values at the nodes.
C           W(I) is associated with (X(I),Y(I),Z(I)) for
C           I = 1,...,N.
C
C       LIST,LPTR,LEND = Data structure defining the trian-
C                        gulation.  Refer to STRIPACK
C                        Subroutine CSTRMESH.
C
C Input parameters are not altered by this routine.
C
C On output:
C
C       G = X, Y, and Z components (in that order) of the
C           estimated gradient at node K unless IER < 0.
C
C       IER = Error indicator:
C             IER .GE. 6 if no errors were encountered.
C                        IER contains the number of nodes
C                        (including K) used in the least
C                        squares fit.
C             IER = -1 if N or K is outside its valid range.
C             IER = -2 if the least squares system has no
C                      unique solution due to duplicate or
C                      collinear nodes.
C
C STRIPACK module required by CSGRADL:  CSGETNP
C
C SSRFPACK modules required by CSGRADL:  CSAPLYR, CSAPLYRT,
C                                        CSCONSTR, CSGIVENS,
C                                        CSROTATE, CSSETUP
C
C Intrinsic functions called by CSGRADL:  ABS, MIN, DBLE, SQRT
C
C***********************************************************
C
      INTEGER   LMN, LMX
      PARAMETER (LMN=10,  LMX=30)
      INTEGER I, IERR, IM1, IP1, J, JP1, KK, L, LM1, LMAX,
     .        LMIN, LNP, NN, NP, NPTS(LMX)
      DOUBLE PRECISION A(6,6), AV, AVSQ, C, CX, CY, DF,
     .                 DMIN, DTOL, DX, DY, RF, RIN, RTOL, S,
     .                 SF, SUM, SX, SY, WK, WT, XP, YP, ZP
C
      DATA    RTOL/1.D-6/, DTOL/.01D0/, SF/1.D0/
C
C Local parameters:
C
C A =         Transpose of the (upper triangle of the) aug-
C               mented regression matrix
C AV =        Root-mean-square distance (in the rotated
C               coordinate system) between the origin and
C               the nodes (other than K) in the least
C               squares fit.  The first 3 columns of A**T
C               are scaled by 1/AVSQ, the next 2 by 1/AV.
C AVSQ =      AV*AV:  accumulated in SUM
C C,S =       Components of the plane rotation used to
C               triangularize the regression matrix
C CX,SX =     Components of a plane rotation about the X-
C               axis which, together with CY and SY, define
C               a mapping from node K to the north pole
C               (0,0,1)
C CY,SY =     Components of a plane rotation about the Y-
C               axis
C DF =        Negative Z component (in the rotated coordi-
C               nate system) of an element NP of NPTS --
C               increasing function of the angular distance
C               between K and NP.  DF lies in the interval
C               (-1,1).
C DMIN =      Minimum of the magnitudes of the diagonal
C               elements of the triangularized regression
C               matrix
C DTOL =      Tolerance for detecting an ill-conditioned
C               system (DMIN is required to be at least
C               DTOL)
C DX,DY =     X and Y components of the estimated gradient
C               in the rotated coordinate system
C I,J =       Loop indexes
C IERR =      Error flag for calls to CSGETNP (not checked)
C IM1,IP1 =   I-1, I+1
C JP1 =       J+1
C KK =        Local copy of K
C L =         Number of columns of A**T to which a rotation
C               is applied
C LM1 =       LMIN-1
C LMIN,LMAX = Min(LMN,N), Min(LMX,N)
C LMN,LMX =   Minimum and maximum values of LNP for N
C               sufficiently large.  In most cases LMN-1
C               nodes are used in the fit.  7 .LE. LMN .LE.
C               LMX.
C LNP =       Length of NPTS or LMAX+1
C NN =        Local copy of N
C NP =        Element of NPTS to be added to the system
C NPTS =      Array containing the indexes of a sequence of
C               nodes ordered by angular distance from K.
C               NPTS(1)=K and the first LNP-1 elements of
C               NPTS are used in the least squares fit.
C               unless LNP = LMAX+1, NPTS(LNP) determines R
C               (see RIN).
C RF =        Value of DF associated with NPTS(LNP) unless
C               LNP = LMAX+1 (see RIN)
C RIN =       Inverse of a radius of influence R which
C               enters into WT:  R = 1+RF unless all ele-
C               ments of NPTS are used in the fit (LNP =
C               LMAX+1), in which case R is the distance
C               function associated with some point more
C               distant from K than NPTS(LMAX)
C RTOL =      Tolerance for determining LNP (and hence R):
C               if the increase in DF between two successive
C               elements of NPTS is less than RTOL, they are
C               treated as being the same distance from node
C               K and an additional node is added
C SF =        Marquardt stabilization factor used to damp
C               out the first 3 solution components (second
C               partials of the quadratic) when the system
C               is ill-conditioned.  Increasing SF results
C               in more damping (a more nearly linear fit).
C SUM =       Sum of squared Euclidean distances (in the
C               rotated coordinate system) between the
C               origin and the nodes used in the least
C               squares fit
C WK =        W(K) -- data value at node K
C WT =        Weight for the equation coreesponding to NP:
C               WT = (R-D)/(R*D) = 1/D - RIN, where D = 1-ZP
C               is associated with NP
C XP,YP,ZP =  Coordinates of NP in the rotated coordinate
C               system unless ZP < 0, in which case
C               (XP,YP,0) lies on the equator
C
      NN = N
      KK = K
      WK = W(KK)
C
C Check for errors and initialize LMIN, LMAX.
C
      IF (NN .LT. 7  .OR.  KK .LT. 1  .OR.  KK .GT. NN)
     .   GO TO 13
      LMIN = MIN(LMN,NN)
      LMAX = MIN(LMX,NN)
C
C Compute NPTS, LNP, AVSQ, AV, and R.
C   Set NPTS to the closest LMIN-1 nodes to K.  DF contains
C   the negative Z component (in the rotated coordinate
C   system) of the new node on return from CSGETNP.
C
      SUM = 0.
      NPTS(1) = KK
      LM1 = LMIN - 1
      DO 1 LNP = 2,LM1
        CALL CSGETNP (X,Y,Z,LIST,LPTR,LEND,LNP, NPTS, DF,IERR)
        SUM = SUM + 1. - DF*DF
    1   CONTINUE
C
C   Add additional nodes to NPTS until the increase in
C     R = 1+RF is at least RTOL.
C
      DO 2 LNP = LMIN,LMAX
        CALL CSGETNP (X,Y,Z,LIST,LPTR,LEND,LNP, NPTS, RF,IERR)
        IF (RF-DF .GE. RTOL) GO TO 3
        SUM = SUM + 1. - RF*RF
    2   CONTINUE
C
C   Use all LMAX nodes in the least squares fit.  R is
C     arbitrarily increased by 5 percent.
C
      RF = 1.05*RF + .05
      LNP = LMAX + 1
C
C   There are LNP-2 equations corresponding to nodes
C     NPTS(2),...,NPTS(LNP-1).
C
    3 AVSQ = SUM/DBLE(LNP-2)
      AV = SQRT(AVSQ)
      RIN = 1./(1.+RF)
C
C Construct the rotation.
C
      CALL CSCONSTR (X(KK),Y(KK),Z(KK), CX,SX,CY,SY)
C
C Set up the first 5 equations of the augmented regression
C   matrix (transposed) as the columns of A, and zero out
C   the lower triangle (upper triangle of A) with Givens
C   rotations.
C
      DO 5 I = 1,5
        NP = NPTS(I+1)
        CALL CSAPLYR (X(NP),Y(NP),Z(NP),CX,SX,CY,SY, XP,YP,ZP)
        WT = 1./(1.-ZP) - RIN
        CALL CSSETUP (XP,YP,W(NP),WK,AV,AVSQ,WT, A(1,I))
        IF (I .EQ. 1) GO TO 5
        IM1 = I - 1
        DO 4 J = 1,IM1
          JP1 = J + 1
          L = 6 - J
          CALL CSGIVENS ( A(J,J),A(J,I), C,S)
          CALL CSROTATE (L,C,S, A(JP1,J),A(JP1,I) )
    4     CONTINUE
    5   CONTINUE
C
C Add the additional equations to the system using
C   the last column of A.  I .LE. LNP.
C
      I = 7
    6   IF (I .EQ. LNP) GO TO 8
        NP = NPTS(I)
        CALL CSAPLYR (X(NP),Y(NP),Z(NP),CX,SX,CY,SY, XP,YP,ZP)
        WT = 1./(1.-ZP) - RIN
        CALL CSSETUP (XP,YP,W(NP),WK,AV,AVSQ,WT, A(1,6))
        DO 7 J = 1,5
          JP1 = J + 1
          L = 6 - J
          CALL CSGIVENS ( A(J,J),A(J,6), C,S)
          CALL CSROTATE (L,C,S, A(JP1,J),A(JP1,6) )
    7     CONTINUE
        I = I + 1
        GO TO 6
C
C Test the system for ill-conditioning.
C
    8 DMIN = MIN( ABS(A(1,1)),ABS(A(2,2)),ABS(A(3,3)),
     .            ABS(A(4,4)),ABS(A(5,5)) )
      IF (DMIN .GE. DTOL) GO TO 12
      IF (LNP .LE. LMAX) THEN
C
C Add another node to the system and increase R.
C   I = LNP.
C
        LNP = LNP + 1
        IF (LNP .LE. LMAX) CALL CSGETNP (X,Y,Z,LIST,LPTR,LEND,
     .                                 LNP,NPTS, RF,IERR)
        RIN = 1./(1.05*(1.+RF))
        GO TO 6
      ENDIF
C
C Stabilize the system by damping second partials.  Add
C   multiples of the first three unit vectors to the first
C   three equations.
C
      DO 11 I = 1,3
        A(I,6) = SF
        IP1 = I + 1
        DO 9 J = IP1,6
          A(J,6) = 0.
    9     CONTINUE
        DO 10 J = I,5
          JP1 = J + 1
          L = 6 - J
          CALL CSGIVENS ( A(J,J),A(J,6), C,S)
          CALL CSROTATE (L,C,S, A(JP1,J),A(JP1,6) )
   10     CONTINUE
   11   CONTINUE
C
C Test the linear portion of the stabilized system for
C   ill-conditioning.
C
      DMIN = MIN( ABS(A(4,4)),ABS(A(5,5)) )
      IF (DMIN .LT. DTOL) GO TO 14
C
C Solve the 2 by 2 triangular system for the estimated
C   partial derivatives.
C
   12 DY = A(6,5)/A(5,5)
      DX = (A(6,4) - A(5,4)*DY)/A(4,4)/AV
      DY = DY/AV
C
C Rotate the gradient (DX,DY,0) back into the original
C   coordinate system.
C
      CALL CSAPLYRT (DX,DY,CX,SX,CY,SY, G)
      IER = LNP - 1
      RETURN
C
C N or K is outside its valid range.
C
   13 IER = -1
      RETURN
C
C No unique solution due to collinear nodes.
C
   14 IER = -2
      RETURN
      END


C NCLFORTSTART
      SUBROUTINE DTAPER(X,N,P,XT,IOPT)
      IMPLICIT NONE
C NCL: xTaper = taper(x,p,iopt)

c this subroutine applies split-cosine-bell tapering to the series x.
c .   the series will be tapered to the mean of x.
c .   See Bloomfield's "Intro to Fourier .."
c .   This is used prior performing an fft on non-cyclic data

c arguments:
c .   x   series to be tapered (tapering done in place)
c .       **missing data not allowed**
c .   n   series length
c .   p   the proportion of the time series to be tapered
c .       [p=0.10 means 10 %]
c .   xt  tapered series
c .   iopt  iopt=0 taper to series mean
c .   iopt  iopt=1 means *force* taper to 0.0
C                                            INPUT
      INTEGER N,IOPT
      DOUBLE PRECISION X(N),P
C                                            OUTPUT
      DOUBLE PRECISION XT(N)
C NCLEND
      INTEGER I,M,kopt
      DOUBLE PRECISION WEIGHT,PI,PIM,XAV
      DATA PI/3.141592653589D0/

      kopt = iopt

c pathological case: all values constant
c force taper to xav=0.0

      do i=2,n
         if (x(i).ne.x(1)) then
             go to 10
         end if
      end do
      kopt = 1
   10 continue

      XAV = 0.0D0
      if (kopt.ne.1) then
          DO I = 1,N
             XT(I) = X(I)
             XAV = XAV + X(I)
         END DO
         XAV = XAV/N
      end if

      M = MAX0(1,INT(P*DBLE(N)+0.5D0)/2)
      PIM = PI/DBLE(M)

      DO I = 1,M
          WEIGHT = 0.5D0 - 0.5D0*COS(PIM* (DBLE(I)-0.5D0))
          XT(I) = (X(I)-XAV)*WEIGHT + XAV
          XT(N+1-I) = (X(N+1-I)-XAV)*WEIGHT + XAV
      END DO

c .   cft correction factor for taper (not used , for info only)
c c c cft = 0.5*(128.-93.*p)/(8.-5.*p)**2

      RETURN
      END


** Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
** See https://llvm.org/LICENSE.txt for license information.
** SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception

*   Real arithmetic operations (+, -, *, /) including constant
*   folding and implied type conversions of integer operands.

	programp

	parameter(N = 33)
	real rslts(N), expect(N)

c   tests 1 - 3:
	data expect /-2.0, 2.0, 3.0,
c   tests 4 - 11:
     +               3.5, 5e-5, 5e-5, -1.0, 3.5, 0.0, 4.0, 4.0,
c   tests 12 - 18:
     +               -0.5, -0.5, 5.0, -8.0, 0.5, 1.0, 2.0,
c   tests 19 - 25:
     +               1.5, -6.0, 1.0, 1.0, -9.0, 4.0, 4.0,
c   tests 26 - 33:
     +               10.0, -1.5, 4.0, 1.0, -2.5, 4.0, 3.0, 1.0 /

	data i2 / 2/, x2, xn3, x2en5 / 2.0, - 3.0, 2.0e-5 /

c   tests 1 - 3, unary minus:

	rslts(1) = -2.0
	rslts(2) = - ( -x2)
	rslts(3) = -xn3

c   tests 4 - 11, addition:

	rslts(4) = 1.5 + 2.0
	rslts(5) = x2en5 + 3e-5
	rslts(6) = 3e-5 + x2en5
	rslts(7) = x2 + xn3

	rslts(8) = 2 + 1.5
	rslts(9) = xn3 + (+3)
	rslts(10) = +x2 + i2
	rslts(11) = i2 + x2

c   tests 12 - 18, subtraction:

	rslts(12) = 1.5 - 2.0
	rslts(13) = 1.5 - x2
	rslts(14) = x2 - xn3

	rslts(15) = (-5) - (- xn3)
	rslts(16) = i2 - 1.5
	rslts(17) = 3.0 - i2
	rslts(18) = 3.0 - 1

c   tests 19 - 25, multiplication:

	rslts(19) = 0.5 * 3.0
	rslts(20) = x2 * xn3
	rslts(21) = x2 * .5

	rslts(22) = 2 * .5
	rslts(23) = xn3 * 3
	rslts(24) = x2 * i2
	rslts(25) = i2 * x2

c   tests 26 - 33, division:

	rslts(26) = 5.0 / .5
	rslts(27) = xn3 / x2
	rslts(28) = x2 / .5
	rslts(29) = 2.0 / x2

	rslts(30) = 5 / (-x2)
	rslts(31) = i2 / .5
	rslts(32) = 3.0 / (i2 - 1)
	rslts(33) = 5.0 / 5

c   check results:

	call check(rslts, expect, N)
	end


! Define BLAS API in Fortran module
module spral_blas_iface
  implicit none

  private
  public :: daxpy, dcopy, ddot, dnrm2, dscal
  public :: zaxpy, zcopy, zdotc, dznrm2, zscal
  public :: dgemm, dtrsm
  public :: zgemm, ztrsm

  ! Level 1 BLAS
  interface
    subroutine daxpy( n, a, x, incx, y, incy )
      implicit none
      integer, intent(in) :: n, incx, incy
      double precision, intent(in) :: a
      double precision, intent(in   ), dimension(*) :: x
      double precision, intent(inout), dimension(*) :: y
    end subroutine daxpy
    subroutine dcopy( n, x, incx, y, incy )
      implicit none
      integer, intent(in) :: n, incx, incy
      double precision, intent(in ), dimension(*) :: x
      double precision, intent(out), dimension(*) :: y
    end subroutine dcopy
    double precision function ddot( n, x, incx, y, incy )
      implicit none
      integer, intent(in) :: n, incx, incy
      double precision, intent(in), dimension(*) :: x
      double precision, intent(in), dimension(*) :: y
    end function ddot
    double precision function dnrm2( n, x, incx )
      implicit none
      integer, intent(in) :: n, incx
      double precision, intent(in), dimension(*) :: x
    end function dnrm2
    subroutine dscal( n, a, x, incx )
      implicit none
      integer, intent(in) :: n, incx
      double precision, intent(in) :: a
      double precision, intent(in), dimension(*) :: x
    end subroutine dscal
    subroutine zcopy( n, x, incx, y, incy )
      implicit none
      integer, parameter :: PRECISION = kind(1.0D0)
      integer, intent(in) :: n, incx, incy
      complex(PRECISION), intent(in ), dimension(*) :: x
      complex(PRECISION), intent(out), dimension(*) :: y
    end subroutine zcopy
    double precision function dznrm2( n, x, incx )
      implicit none
      integer, parameter :: PRECISION = kind(1.0D0)
      integer, intent(in) :: n, incx
      complex(PRECISION), intent(in), dimension(*) :: x
    end function dznrm2
    function zdotc( n, x, incx, y, incy )
      implicit none
      integer, parameter :: PRECISION = kind(1.0D0)
      integer, intent(in) :: n, incx, incy
      complex(PRECISION), intent(in), dimension(*) :: x
      complex(PRECISION), intent(in), dimension(*) :: y
      complex(PRECISION) :: zdotc
    end function zdotc
    subroutine zscal( n, a, x, incx )
      implicit none
      integer, parameter :: PRECISION = kind(1.0D0)
      integer, intent(in) :: n, incx
      complex(PRECISION), intent(in) :: a
      complex(PRECISION), intent(in), dimension(*) :: x
    end subroutine zscal
    subroutine zaxpy( n, a, x, incx, y, incy )
      implicit none
      integer, parameter :: PRECISION = kind(1.0D0)
      integer, intent(in) :: n, incx, incy
      complex(PRECISION), intent(in) :: a
      complex(PRECISION), intent(in   ), dimension(*) :: x
      complex(PRECISION), intent(inout), dimension(*) :: y
    end subroutine zaxpy
  end interface

  ! Level 3 BLAS
  interface
    subroutine dgemm( ta, tb, m, n, k, alpha, a, lda, b, ldb, beta, c, ldc )
      implicit none
      character, intent(in) :: ta, tb
      integer, intent(in) :: m, n, k
      integer, intent(in) :: lda, ldb, ldc
      double precision, intent(in) :: alpha, beta
      double precision, intent(in   ), dimension(lda, *) :: a
      double precision, intent(in   ), dimension(ldb, *) :: b
      double precision, intent(inout), dimension(ldc, *) :: c
    end subroutine dgemm
    subroutine dtrsm( side, uplo, trans, diag, m, n, alpha, a, lda, b, ldb )
      implicit none
      character, intent(in) :: side, uplo, trans, diag
      integer, intent(in) :: m, n, lda, ldb
      double precision, intent(in   ) :: alpha
      double precision, intent(in   ) :: a(lda, *)
      double precision, intent(inout) :: b(ldb, n)
    end subroutine dtrsm
    subroutine zgemm( ta, tb, m, n, k, alpha, a, lda, b, ldb, beta, c, ldc )
      implicit none
      integer, parameter :: PRECISION = kind(1.0D0)
      character, intent(in) :: ta, tb
      integer, intent(in) :: m, n, k
      integer, intent(in) :: lda, ldb, ldc
      complex(PRECISION), intent(in) :: alpha, beta
      complex(PRECISION), intent(in   ), dimension(lda, *) :: a
      complex(PRECISION), intent(in   ), dimension(ldb, *) :: b
      complex(PRECISION), intent(inout), dimension(ldc, *) :: c
    end subroutine zgemm
    subroutine ztrsm( side, uplo, trans, diag, m, n, alpha, a, lda, b, ldb )
      implicit none
      integer, parameter :: PRECISION = kind(1.0D0)
      character, intent(in) :: side, uplo, trans, diag
      integer, intent(in) :: m, n, lda, ldb
      complex(PRECISION), intent(in   ) :: alpha
      complex(PRECISION), intent(in   ) :: a(lda, *)
      complex(PRECISION), intent(inout) :: b(ldb, n)
    end subroutine ztrsm
  end interface

end module spral_blas_iface


module particles_objs

  use iso_fortran_env

  implicit none

! Define parameter
  real(real64), parameter :: pi = 3.14159
  real(real64), parameter :: e0 = 8.854188e-12

! Define types
  type, public :: Particle
    ! define the attributes
     character(9) :: name
     real(real64) :: radius
     real(real64) :: mass
   contains
     procedure :: cross_area => ca  ! Multiple Dispatch & Overloading Functions
     procedure :: show => show_p    ! Multiple Dispatch & Overloading Functions
  end type Particle

  ! hereditary
  type, extends(Particle) :: Electron
     real(real64) :: charge
   contains
     procedure :: electric_potential => ep
     procedure :: show => show_e ! Multiple Dispatch
  end type Electron

! Define Procedure
contains

  subroutine ca(this)
    ! arguments
    class(Particle), intent(in) :: this
    print *, pi * (this%radius + this%radius)**2
  end subroutine ca

  subroutine show_p(this)
    class(Particle), intent(in) :: this
    print *, 'name :', this%name, 'radius :', this%radius, 'mass :', this%mass
  end subroutine show_p

  real(real64) function ep(this, radius) &
       result(V)
    ! arguments
    class(Electron), intent(in) :: this
    real(real64), intent(in) :: radius

    V = 1./(4.*pi*e0) * this%charge / radius

  end function ep

  subroutine show_e(this)
    class(Electron), intent(in) :: this
    print *, 'name .', this%name, 'radius :', this%radius, 'mass :', this%mass, 'charge :', this%charge
  end subroutine show_e

end module particles_objs


	FUNCTION PR_AMSL  ( pmsl )
C************************************************************************
C* PR_AMSL								*
C*									*
C* This function computes a standard abbreviated 3-digit display of	*
C* pressure containing the tens and units digits and the first digit	*
C* after the decimal point.  The input is multiplied by 10, truncated,	*
C* and the original thousand and hundred digits are dropped.  The	*
C* following equation is used:						*
C*									*
C*              AMSL = NINT ( AMOD ( PMSL, 100 ) * 10 )			*
C*									*
C* This function can be used to compute SALT from ALTM, and SMSL from 	*
C* PMSL.								*
C*									*
C* REAL PR_AMSL  ( PMSL )						*
C*									*
C* Input parameters:							*
C*	PMSL		REAL		Pressure in mb			*
C*									*
C* Output parameters:							*
C*	PR_AMSL		REAL		Standard abbreviated pressure	*
C**									*
C* Log:									*
C* M. Goodman/RDS	 2/85	Original source				*
C* M. desJardins/GSFC	 9/85	Corrected				*
C* I. Graffman/RDS	12/87	GEMPAK4					*
C* G. Huffman/GSC	 7/88	Documentation				*
C* K. F. Brill/GSC       6/89   Generalized for pmsl and altm		*
C************************************************************************
        INCLUDE   'GEMPRM.PRM'
        INCLUDE   'ERMISS.FNC'
C------------------------------------------------------------------------
C*	Check for missing data.
C
	IF  ( ERMISS ( pmsl ) )  THEN
	    pr_amsl = RMISSD
	  ELSE
C
C*	    Drop the leading thousand and/or hundreds digits.
C
	    aalt = AMOD ( pmsl, 100. )
C
C*	    Include the tenths digit.
C
	    aalt = aalt * 10.
	    PR_AMSL = ANINT ( aalt )
	END IF
C*
	RETURN
	END


C     SOLVE QUADRATIC EQUATION IN FORTRAN I
      READ 100,A,B,C
100   FORMAT(3F12.4)
      DISCR = B**2-4*A*C
      IF (DISCR) 10,20,30
10    X1=(-B)/(2.*A)
      X2=SQRTF(ABSF(DISCR))/(2.*A)
      PRINT 110,X1,X2
110   FORMAT(5H X = ,F12.3,4H +i ,F12.3)
      PRINT 120,X1,X2
120   FORMAT(5H X = ,F12.3,4H -i ,F12.3)
      GOTO 40
20    X1=(-B)/(2.*A)
      PRINT 130,X1
130   FORMAT(11H X1 = X2 = ,F12.3)
      GOTO 40
30    X1=((-B)+SQRTF(ABSF(DISCR)))/(2.*A)
      X2=((-B)-SQRTF(ABSF(DISCR)))/(2.*A)
      PRINT 140,X1
140   FORMAT(6H X1 = ,F12.3)
      PRINT 150,X2
150   FORMAT(6H X2 = ,F12.3)
40    CONTINUE
      STOP 25252


!==============================================================================
program Au
!==============================================================================
!  Computes the Universal Elastic Anisotropy Index (A^U) given a set of elastic
!  constants.
!
!  A^U = Cv:Sr - 6, where Cv is Voigt-averaged stiffness, Sr is Reuss-averaged
!                   compliance, and : signifies inner product, such that
!                   Cij:Sij = C11*S11 + C12*S21 + C13*S31 ... C66*S66
!
!      = 5(Gv/Gr) + (Kv/Kr) - 6
!
!       where 9Kv = c11 + c22 + c33 + 2(c12 + c23 + c31)
!            15Gv = c11 + c22 + c33 - (c12 + c23 + c31) + 3(c44 + c55 + c66)
!            1/Kr = s11 + s22 + s33 + 2(s12 + s23 + s31)
!           15/Gr = 4(s11 + s22 + s33) - 4(s12 + s23 + s31) + 3(s44 + s55 + s66)
!
!  According to:
!      Hill, R. The elastic behaviour of a crystalline aggregate.
!               P Phys Soc Lond A (1952) vol. 65 (389) pp. 349-355
!
!  Read ECs from stdin, assuming only 21 are supplied.
!  If first command line argument is set, use that number of elastic constants

   use anisotropy_ajn

   implicit none

   double precision  :: C(6,6),S(6,6),Kv,Kr,Gv,Gr,A
   integer           :: nec=21,i,j,iostatus=0
   character(len=20) :: arg

!  Check for command line options
   if (command_argument_count() > 0) then
      call get_command_argument(1,arg)
      read(arg,*,iostat=iostatus) nec
      if (iostatus /= 0 .or. (nec /= 21 .and. nec /= 36)) then
         write(0,'(3a)') 'Argument "',trim(arg),'" not understood.'
         write(0,'(a)') 'Please specify whether 21 or 36 elastic constants input.'
      stop
      endif
   endif

!  Loop over all lines of input
   iostatus=0
   do while (iostatus==0)

!  Read in constants
   if (nec == 21) then
      read (*,*,iostat=iostatus) ((C(i,j),j=i,6),i=1,6)
   else
      read (*,*,iostat=iostatus) ((C(i,j),j=1,6),i=1,6)
   endif

   if (iostatus < 0) stop
   if (iostatus > 0) then
      write(0,'(a)') 'Problem reading elastic constants: stopping.'
      stop
   endif

!  Fill in lower diagonal
   do i=1,6; do j=1,6; C(j,i) = C(i,j); enddo; enddo

!!  Find stiffness from inverse
!   call inverse(6,6,C,S)
!
!!  Calculate Voigt moduli
!   Kv = (1./9.) * (C(1,1) + C(2,2) + C(3,3) + 2.*(C(1,2) + C(2,3) + C(3,1)))
!
!   Gv = (1./15.) * (C(1,1) + C(2,2) + C(3,3) - (C(1,2) + C(2,3) + C(3,1)) + &
!                    3.*(C(4,4) + C(5,5) + C(6,6)))
!
!!  Calculate Reuss moduli
!   Kr = 1./(S(1,1) + S(2,2) + S(3,3) + 2.*(S(1,2) + S(2,3) + S(3,1)))
!
!   Gr = 15./(4.*(S(1,1) + S(2,2) + S(3,3)) - 4.*(S(1,2) + S(2,3) + S(3,1)) + &
!             3.*(S(4,4) + S(5,5) + S(6,6)))
!
!!  Calculate Au
!   A = 5.*(Gv/Gr) + (Kv/Kr) - 6.

   A = CIJ_Au(C)

!  Output value to stdout
   write(*,*) A

   enddo

end program Au
!------------------------------------------------------------------------------


      SUBROUTINE TD05AD( UNITF, OUTPUT, NP1, MP1, W, A, B, VALR, VALI,
     $                   INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     Given a complex valued rational function of frequency (transfer
C     function) G(jW) this routine will calculate its complex value or
C     its magnitude and phase for a specified frequency value.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     UNITF   CHARACTER*1
C             Indicates the choice of frequency unit as follows:
C             = 'R':  Input frequency W in radians/second;
C             = 'H':  Input frequency W in hertz.
C
C     OUTPUT  CHARACTER*1
C             Indicates the choice of co-ordinates for output as folows:
C             = 'C':  Cartesian co-ordinates (output real and imaginary
C                     parts of G(jW));
C             = 'P':  Polar co-ordinates (output magnitude and phase
C                     of G(jW)).
C
C     Input/Output Parameters
C
C     NP1     (input) INTEGER
C             The order of the denominator + 1, i.e. N + 1.  NP1 >= 1.
C
C     MP1     (input) INTEGER
C             The order of the numerator + 1, i.e. M + 1.  MP1 >= 1.
C
C     W       (input) DOUBLE PRECISION
C             The frequency value W for which the transfer function is
C             to be evaluated.
C
C     A       (input) DOUBLE PRECISION array, dimension (NP1)
C             This array must contain the vector of denominator
C             coefficients in ascending order of powers. That is, A(i)
C             must contain the coefficient of (jW)**(i-1) for i = 1,
C             2,...,NP1.
C
C     B       (input) DOUBLE PRECISION array, dimension (MP1)
C             This array must contain the vector of numerator
C             coefficients in ascending order of powers. That is, B(i)
C             must contain the coefficient of (jW)**(i-1) for i = 1,
C             2,...,MP1.
C
C     VALR    (output) DOUBLE PRECISION
C             If OUTPUT = 'C', VALR contains the real part of G(jW).
C             If OUTPUT = 'P', VALR contains the magnitude of G(jW)
C                              in dBs.
C
C     VALI    (output) DOUBLE PRECISION
C             If OUTPUT = 'C', VALI contains the imaginary part of
C                              G(jW).
C             If OUTPUT = 'P', VALI contains the phase of G(jW) in
C                              degrees.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value;
C             = 1:  if the frequency value W is a pole of G(jW), or all
C                   the coefficients of the A polynomial are zero.
C
C     METHOD
C
C     By substituting the values of A, B and W in the following
C     formula:
C
C            B(1)+B(2)*(jW)+B(3)*(jW)**2+...+B(MP1)*(jW)**(MP1-1)
C     G(jW) = ---------------------------------------------------.
C            A(1)+A(2)*(jW)+A(3)*(jW)**2+...+A(NP1)*(jW)**(NP1-1)
C
C     REFERENCES
C
C     None.
C
C     NUMERICAL ASPECTS
C
C     The algorithm requires 0(N+M) operations.
C
C     CONTRIBUTORS
C
C     Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996.
C     Supersedes Release 2.0 routine TD01AD by Control Systems Research
C     Group, Kingston Polytechnic, United Kingdom, March 1981.
C
C     REVISIONS
C
C     February 1997.
C     February 22, 1998 (changed the name of TD01MD).
C
C     KEYWORDS
C
C     Elementary polynomial operations, frequency response, matrix
C     fraction, polynomial matrix, state-space representation, transfer
C     matrix.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE, EIGHT, TWENTY, NINETY, ONE80, THRE60
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0, EIGHT=8.0D0,
     $                    TWENTY=20.0D0, NINETY=90.0D0, ONE80 = 180.0D0,
     $                    THRE60=360.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         OUTPUT, UNITF
      INTEGER           INFO, MP1, NP1
      DOUBLE PRECISION  VALI, VALR, W
C     .. Array Arguments ..
      DOUBLE PRECISION  A(*), B(*)
C     .. Local Scalars ..
      LOGICAL           LOUTPU, LUNITF
      INTEGER           I, IPHASE, M, M2, N, N2, NPZERO, NZZERO
      DOUBLE PRECISION  BIMAG, BREAL, G, TIMAG, TREAL, TWOPI, W2, WC
      COMPLEX*16        ZTEMP
C     .. External Functions ..
      LOGICAL           LSAME
      DOUBLE PRECISION  DLAPY2
      COMPLEX*16        ZLADIV
      EXTERNAL          DLAPY2, LSAME, ZLADIV
C     .. External Subroutines ..
      EXTERNAL          XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         ABS, ATAN, DBLE, DCMPLX, DIMAG, LOG10, MAX, MOD,
     $                  SIGN
C     .. Executable Statements ..
C
      INFO = 0
      LUNITF = LSAME( UNITF,  'H' )
      LOUTPU = LSAME( OUTPUT, 'P' )
C
C     Test the input scalar arguments.
C
      IF( .NOT.LUNITF .AND. .NOT.LSAME( UNITF,  'R' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.LOUTPU .AND. .NOT.LSAME( OUTPUT, 'C' ) ) THEN
         INFO = -2
      ELSE IF( NP1.LT.1 ) THEN
         INFO = -3
      ELSE IF( MP1.LT.1 ) THEN
         INFO = -4
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'TD05AD', -INFO )
         RETURN
      END IF
C
      M = MP1 - 1
      N = NP1 - 1
      WC = W
      TWOPI = EIGHT*ATAN( ONE )
      IF ( LUNITF ) WC = WC*TWOPI
      W2 = WC**2
C
C     Determine the orders z (NZZERO) and p (NPZERO) of the factors
C     (jW)**k in the numerator and denominator polynomials, by counting
C     the zero trailing coefficients.  The value of G(jW) will then be
C     computed as (jW)**(z-p)*m(jW)/n(jW), for appropriate m and n.
C
      I = 0
C
   10 CONTINUE
      I = I + 1
      IF ( I.LE.M ) THEN
         IF ( B(I).EQ.ZERO ) GO TO 10
      END IF
C
      NZZERO = I - 1
      I = 0
C
   20 CONTINUE
      I = I + 1
      IF ( I.LE.N ) THEN
         IF ( A(I).EQ.ZERO ) GO TO 20
      END IF
C
      NPZERO = I - 1
      IPHASE = NZZERO - NPZERO
C
      M2 = MOD( M - NZZERO, 2 )
C
C     Add real parts of the numerator m(jW).
C
      TREAL = B(MP1-M2)
C
      DO 30 I = M - 1 - M2, NZZERO + 1, -2
         TREAL = B(I) - W2*TREAL
   30 CONTINUE
C
C     Add imaginary parts of the numerator m(jW).
C
      IF ( M.EQ.0 ) THEN
         TIMAG = ZERO
      ELSE
         TIMAG = B(M+M2)
C
         DO 40 I = M + M2 - 2, NZZERO + 2, -2
            TIMAG = B(I) - W2*TIMAG
   40    CONTINUE
C
         TIMAG = TIMAG*WC
      END IF
C
      N2 = MOD( N - NPZERO, 2 )
C
C     Add real parts of the denominator n(jW).
C
      BREAL = A(NP1-N2)
C
      DO 50 I = N - 1 - N2, NPZERO + 1, -2
         BREAL = A(I) - W2*BREAL
   50 CONTINUE
C
C     Add imaginary parts of the denominator n(jW).
C
      IF ( N.EQ.0 ) THEN
         BIMAG = ZERO
      ELSE
         BIMAG = A(N+N2)
C
         DO 60 I = N + N2 - 2, NPZERO + 2, -2
            BIMAG = A(I) - W2*BIMAG
   60    CONTINUE
C
         BIMAG = BIMAG*WC
      END IF
C
      IF ( ( MAX( ABS( BREAL ), ABS( BIMAG ) ).EQ.ZERO ) .OR.
     $     ( W.EQ.ZERO .AND. IPHASE.LT.0 ) ) THEN
C
C        Error return:  The specified frequency W is a pole of G(jW),
C              or all the coefficients of the A polynomial are zero.
C
         INFO = 1
      ELSE
C
C        Evaluate the complex number W**(z-p)*m(jW)/n(jW).
C
         ZTEMP =
     $      ZLADIV( DCMPLX( TREAL, TIMAG ), DCMPLX( BREAL, BIMAG ) )
         VALR = DBLE(  ZTEMP )*WC**IPHASE
         VALI = DIMAG( ZTEMP )*WC**IPHASE
C
         IF ( .NOT.LOUTPU ) THEN
C
C           Cartesian co-ordinates: Update the result for j**(z-p).
C
            I = MOD( ABS( IPHASE ), 4 )
            IF ( ( IPHASE.GT.0 .AND. I.GT.1 ) .OR.
     $           ( IPHASE.LT.0 .AND. ( I.EQ.1 .OR. I.EQ.2) ) ) THEN
               VALR = -VALR
               VALI = -VALI
            END IF
C
            IF ( MOD( I, 2 ).NE.0 ) THEN
               G    =  VALR
               VALR = -VALI
               VALI =  G
            END IF
C
         ELSE
C
C           Polar co-ordinates: Compute the magnitude and phase.
C
            G = DLAPY2( VALR, VALI )
C
            IF ( VALR.EQ.ZERO ) THEN
               VALI = SIGN( NINETY, VALI )
            ELSE
               VALI = ( ATAN( VALI/VALR )/TWOPI )*THRE60
               IF ( VALI.EQ.ZERO .AND. NZZERO.EQ.M .AND. NPZERO.EQ.N
     $                           .AND. B(NZZERO+1)*A(NPZERO+1).LT.ZERO )
     $            VALI = ONE80
            END IF
C
            VALR = TWENTY*LOG10( G )
C
            IF ( IPHASE.NE.0 )
     $         VALI = VALI + DBLE( NZZERO - NPZERO )*NINETY
         END IF
C
      END IF
C
      RETURN
C *** Last line of TD05AD ***
      END


      SUBROUTINE MB03YT( A, LDA, B, LDB, ALPHAR, ALPHAI, BETA, CSL, SNL,
     $                   CSR, SNR )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute the periodic Schur factorization of a real 2-by-2
C     matrix pair (A,B) where B is upper triangular. This routine
C     computes orthogonal (rotation) matrices given by CSL, SNL and CSR,
C     SNR such that
C
C     1) if the pair (A,B) has two real eigenvalues, then
C
C        [ a11 a12 ] := [  CSL  SNL ] [ a11 a12 ] [  CSR -SNR ]
C        [  0  a22 ]    [ -SNL  CSL ] [ a21 a22 ] [  SNR  CSR ]
C
C        [ b11 b12 ] := [  CSR  SNR ] [ b11 b12 ] [  CSL -SNL ]
C        [  0  b22 ]    [ -SNR  CSR ] [  0  b22 ] [  SNL  CSL ],
C
C     2) if the pair (A,B) has a pair of complex conjugate eigenvalues,
C        then
C
C        [ a11 a12 ] := [  CSL  SNL ] [ a11 a12 ] [  CSR -SNR ]
C        [ a21 a22 ]    [ -SNL  CSL ] [ a21 a22 ] [  SNR  CSR ]
C
C        [ b11  0  ] := [  CSR  SNR ] [ b11 b12 ] [  CSL -SNL ]
C        [  0  b22 ]    [ -SNR  CSR ] [  0  b22 ] [  SNL  CSL ].
C
C     This is a modified version of the LAPACK routine DLAGV2 for
C     computing the real, generalized Schur decomposition of a
C     two-by-two matrix pencil.
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,2)
C             On entry, the leading 2-by-2 part of this array must
C             contain the matrix A.
C             On exit, the leading 2-by-2 part of this array contains
C             the matrix A of the pair in periodic Schur form.
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= 2.
C
C     B       (input/output) DOUBLE PRECISION array, dimension (LDB,2)
C             On entry, the leading 2-by-2 part of this array must
C             contain the upper triangular matrix B.
C             On exit, the leading 2-by-2 part of this array contains
C             the matrix B of the pair in periodic Schur form.
C
C     LDB     INTEGER
C             The leading dimension of the array B.  LDB >= 2.
C
C     ALPHAR  (output) DOUBLE PRECISION array, dimension (2)
C     ALPHAI  (output) DOUBLE PRECISION array, dimension (2)
C     BETA    (output) DOUBLE PRECISION array, dimension (2)
C             (ALPHAR(k)+i*ALPHAI(k))*BETA(k) are the eigenvalues of the
C             pair (A,B), k=1,2, i = sqrt(-1). ALPHAI(1) >= 0.
C
C     CSL     (output) DOUBLE PRECISION
C             The cosine of the first rotation matrix.
C
C     SNL     (output) DOUBLE PRECISION
C             The sine of the first rotation matrix.
C
C     CSR     (output) DOUBLE PRECISION
C             The cosine of the second rotation matrix.
C
C     SNR     (output) DOUBLE PRECISION
C             The sine of the second rotation matrix.
C
C     REFERENCES
C
C     [1] Van Loan, C.
C         Generalized Singular Values with Algorithms and Applications.
C         Ph. D. Thesis, University of Michigan, 1973.
C
C     CONTRIBUTORS
C
C     D. Kressner, Technical Univ. Berlin, Germany, and
C     P. Benner, Technical Univ. Chemnitz, Germany, December 2003.
C
C     REVISIONS
C
C     V. Sima, June 2008 (SLICOT version of the HAPACK routine DLAPV2).
C     V. Sima, July 2008, May 2009.
C
C     KEYWORDS
C
C     Eigenvalue, periodic Schur form
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      INTEGER           LDA, LDB
      DOUBLE PRECISION  CSL, CSR, SNL, SNR
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LDA,*), ALPHAI(2), ALPHAR(2), B(LDB,*),
     $                  BETA(2)
C     .. Local Scalars ..
      DOUBLE PRECISION  ANORM, BNORM, H1, H2, H3, QQ, R, RR, SAFMIN,
     $                  SCALE1, SCALE2, T, ULP, WI, WR1, WR2
C     .. External Functions ..
      DOUBLE PRECISION  DLAMCH, DLAPY2
      EXTERNAL          DLAMCH, DLAPY2
C     .. External Subroutines ..
      EXTERNAL          DLAG2, DLARTG, DLASV2, DROT
C     .. Intrinsic Functions ..
      INTRINSIC         ABS, MAX
C
C     .. Executable Statements ..
C
      SAFMIN = DLAMCH( 'S' )
      ULP    = DLAMCH( 'P' )
C
C     Scale A.
C
      ANORM = MAX( ABS( A(1,1) ) + ABS( A(2,1) ),
     $             ABS( A(1,2) ) + ABS( A(2,2) ), SAFMIN )
      A(1,1) = A(1,1) / ANORM
      A(1,2) = A(1,2) / ANORM
      A(2,1) = A(2,1) / ANORM
      A(2,2) = A(2,2) / ANORM
C
C     Scale B.
C
      BNORM = MAX( ABS( B(1,1) ), ABS( B(1,2) ) + ABS( B(2,2) ), SAFMIN)
      B(1,1) = B(1,1) / BNORM
      B(1,2) = B(1,2) / BNORM
      B(2,2) = B(2,2) / BNORM
C
C     Check if A can be deflated.
C
      IF ( ABS( A(2,1) ).LE.ULP ) THEN
         CSL = ONE
         SNL = ZERO
         CSR = ONE
         SNR = ZERO
         WI  = ZERO
         A(2,1) = ZERO
         B(2,1) = ZERO
C
C     Check if B is singular.
C
      ELSE IF ( ABS( B(1,1) ).LE.ULP ) THEN
         CALL DLARTG( A(2,2), A(2,1), CSR, SNR, T )
         SNR = -SNR
         CALL DROT( 2, A(1,1), 1, A(1,2), 1, CSR, SNR )
         CALL DROT( 2, B(1,1), LDB, B(2,1), LDB, CSR, SNR )
         CSL = ONE
         SNL = ZERO
         WI  = ZERO
         A(2,1) = ZERO
         B(1,1) = ZERO
         B(2,1) = ZERO
      ELSE IF( ABS( B(2,2) ).LE.ULP ) THEN
         CALL DLARTG( A(1,1), A(2,1), CSL, SNL, R )
         CSR = ONE
         SNR = ZERO
         WI  = ZERO
         CALL DROT( 2, A(1,1), LDA, A(2,1), LDA, CSL, SNL )
         CALL DROT( 2, B(1,1), 1, B(1,2), 1, CSL, SNL )
         A(2,1) = ZERO
         B(2,1) = ZERO
         B(2,2) = ZERO
      ELSE
C
C        B is nonsingular, first compute the eigenvalues of A / adj(B).
C
         R = B(1,1)
         B(1,1) = B(2,2)
         B(2,2) = R
         B(1,2) = -B(1,2)
         CALL DLAG2( A, LDA, B, LDB, SAFMIN, SCALE1, SCALE2, WR1, WR2,
     $               WI )
C
         IF( WI.EQ.ZERO ) THEN
C
C           Two real eigenvalues, compute s*A-w*B.
C
            H1 = SCALE1*A(1,1) - WR1*B(1,1)
            H2 = SCALE1*A(1,2) - WR1*B(1,2)
            H3 = SCALE1*A(2,2) - WR1*B(2,2)
C
            RR = DLAPY2( H1, H2 )
            QQ = DLAPY2( SCALE1*A(2,1), H3 )
C
            IF ( RR.GT.QQ ) THEN
C
C              Find right rotation matrix to zero 1,1 element of
C              (sA - wB).
C
               CALL DLARTG( H2, H1, CSR, SNR, T )
C
            ELSE
C
C              Find right rotation matrix to zero 2,1 element of
C              (sA - wB).
C
               CALL DLARTG( H3, SCALE1*A(2,1), CSR, SNR, T )
C
            END IF
C
            SNR = -SNR
            CALL DROT( 2, A(1,1), 1, A(1,2), 1, CSR, SNR )
            CALL DROT( 2, B(1,1), 1, B(1,2), 1, CSR, SNR )
C
C           Compute inf norms of A and B.
C
            H1 = MAX( ABS( A(1,1) ) + ABS( A(1,2) ),
     $                ABS( A(2,1) ) + ABS( A(2,2) ) )
            H2 = MAX( ABS( B(1,1) ) + ABS( B(1,2) ),
     $                ABS( B(2,1) ) + ABS( B(2,2) ) )
C
            IF( ( SCALE1*H1 ).GE.ABS( WR1 )*H2 ) THEN
C
C              Find left rotation matrix Q to zero out B(2,1).
C
               CALL DLARTG( B(1,1), B(2,1), CSL, SNL, R )
C
            ELSE
C
C              Find left rotation matrix Q to zero out A(2,1).
C
               CALL DLARTG( A(1,1), A(2,1), CSL, SNL, R )
C
            END IF
C
            CALL DROT( 2, A(1,1), LDA, A(2,1), LDA, CSL, SNL )
            CALL DROT( 2, B(1,1), LDB, B(2,1), LDB, CSL, SNL )
C
            A(2,1) = ZERO
            B(2,1) = ZERO
C
C           Re-adjoint B.
C
            R = B(1,1)
            B(1,1) = B(2,2)
            B(2,2) = R
            B(1,2) = -B(1,2)
C
         ELSE
C
C           A pair of complex conjugate eigenvalues:
C           first compute the SVD of the matrix adj(B).
C
            R = B(1,1)
            B(1,1) = B(2,2)
            B(2,2) = R
            B(1,2) = -B(1,2)
            CALL DLASV2( B(1,1), B(1,2), B(2,2), R, T, SNL, CSL,
     $                   SNR, CSR )
C
C           Form (A,B) := Q(A,adj(B))Z' where Q is left rotation matrix
C           and Z is right rotation matrix computed from DLASV2.
C
            CALL DROT( 2, A(1,1), LDA, A(2,1), LDA, CSL, SNL )
            CALL DROT( 2, B(1,1), LDB, B(2,1), LDB, CSR, SNR )
            CALL DROT( 2, A(1,1), 1, A(1,2), 1, CSR, SNR )
            CALL DROT( 2, B(1,1), 1, B(1,2), 1, CSL, SNL )
C
            B(2,1) = ZERO
            B(1,2) = ZERO
         END IF
C
      END IF
C
C     Unscaling
C
      R = B(1,1)
      T = B(2,2)
      A(1,1) = ANORM*A(1,1)
      A(2,1) = ANORM*A(2,1)
      A(1,2) = ANORM*A(1,2)
      A(2,2) = ANORM*A(2,2)
      B(1,1) = BNORM*B(1,1)
      B(2,1) = BNORM*B(2,1)
      B(1,2) = BNORM*B(1,2)
      B(2,2) = BNORM*B(2,2)
C
      IF( WI.EQ.ZERO ) THEN
         ALPHAR(1) = A(1,1)
         ALPHAR(2) = A(2,2)
         ALPHAI(1) = ZERO
         ALPHAI(2) = ZERO
         BETA(1) = B(1,1)
         BETA(2) = B(2,2)
      ELSE
         WR1 = ANORM*WR1
         WI  = ANORM*WI
         IF ( ABS( WR1 ).GT.ONE .OR. WI.GT.ONE ) THEN
            WR1 = WR1*R
            WI = WI*R
            R = ONE
         END IF
         IF ( ABS( WR1 ).GT.ONE .OR. ABS( WI ).GT.ONE ) THEN
            WR1 = WR1*T
            WI = WI*T
            T = ONE
         END IF
         ALPHAR(1) = ( WR1 / SCALE1 )*R*T
         ALPHAI(1) = ABS( ( WI  / SCALE1 )*R*T )
         ALPHAR(2) =  ALPHAR(1)
         ALPHAI(2) = -ALPHAI(1)
         BETA(1) = BNORM
         BETA(2) = BNORM
      END IF
      RETURN
C *** Last line of MB03YT ***
      END


c****************************************************************
c
c       Various curvature functions
c
c
c****************************************************************
c**
c**	FILE NAME: curvature.f
c**
c**     DATE WRITTEN: 12/02/93
c**
c**     PROGRAMMER:Scott Hensley
c**
c** 	FUNCTIONAL DESCRIPTION: This routine computes the curvature for
c**     of various types required for ellipsoidal or spherical earth
c**     calculations.
c**
c**     ROUTINES CALLED:none
c**
c**     NOTES: none
c**
c**     UPDATE LOG:
c**
c*****************************************************************

        real*8 function  reast(r_a,r_e2,r_lat)

       	implicit none
        real*8 r_a,r_e2,r_lat

        reast = r_a/sqrt(1.d0 - r_e2*sin(r_lat)**2)

        end

        real*8 function  rnorth(r_a,r_e2,r_lat)

       	implicit none
        real*8 r_a,r_e2,r_lat

        rnorth = (r_a*(1.d0 - r_e2))/(1.d0 - r_e2*sin(r_lat)**2)**(1.5d0)

        end

        real*8 function  rdir(r_a,r_e2,r_hdg,r_lat)

       	implicit none
        real*8 r_a,r_e2,r_lat,r_hdg,r_re,r_rn,reast,rnorth

        r_re = reast(r_a,r_e2,r_lat)
        r_rn = rnorth(r_a,r_e2,r_lat)

        rdir = (r_re*r_rn)/(r_re*cos(r_hdg)**2 + r_rn*sin(r_hdg)**2)

        end


	subroutine tuispl (xa, ya, y2, x, y)
C
C  Interpolate at point X using cubic splines.  The array Y2 must have
C  previously been computed by calling TUCSPL.  Note that XA, YA, Y2
C  are two-element subarrays of the arrays with the same names elsewhere.
C  Input and output are all double precision.
C  This routine was copied with slight modifications from the SPLINT
C  subroutine in Numerical Recipes by Press, Flannery, Teukolsky and
C  Vetterling.
C
C  XA		i: pair of independent-variable values
C  YA		i: pair of dependent-variable values
C  Y2		i: second derivatives of YA at each point
C  X		i: value at which spline is to be computed
C  Y		o: interpolated value at X
C
CH  Phil Hodge, 14-Apr-1988  Subroutine copied from Numerical Recipes SPLINT.
C
	double precision xa(2), ya(2), y2(2), x, y
C--
	double precision h, a, b

	h = xa(2) - xa(1)

	a = (xa(2) - x) / h
	b = (x - xa(1)) / h
	y = a * ya(1) + b * ya(2) +
     +		((a**3 - a) * y2(1) + (b**3 - b) * y2(2))
     +		* h * h / 6.

	return
	end


c
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c  .                                                             .
c  .                  copyright (c) 1998 by UCAR                 .
c  .                                                             .
c  .       University Corporation for Atmospheric Research       .
c  .                                                             .
c  .                      all rights reserved                    .
c  .                                                             .
c  .                                                             .
c  .                         SPHEREPACK3.0                       .
c  .                                                             .
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c
c
c
c ... file igradgc.f
c
c     this file includes documentation and code for
c     subroutine igradgc         i
c
c ... files which must be loaded with igradgc.f
c
c     sphcom.f, hrfft.f, shsgc.f,vhagc.f
c
c     subroutine igradgc(nlat,nlon,isym,nt,sf,isf,jsf,br,bi,mdb,ndb,
c    +                   wshsgc,lshsgc,work,lwork,ierror)
c
c     let br,bi,cr,ci be the vector spherical harmonic coefficients
c     precomputed by vhagc for a vector field (v,w).  let (v',w') be
c     the irrotational component of (v,w) (i.e., (v',w') is generated
c     by assuming cr,ci are zero and synthesizing br,bi with vhsgs).
c     then subroutine igradgc computes a scalar field sf such that
c
c            gradient(sf) = (v',w').
c
c     i.e.,
c
c            v'(i,j) = d(sf(i,j))/dtheta          (colatitudinal component of
c                                                 the gradient)
c     and
c
c            w'(i,j) = 1/sint*d(sf(i,j))/dlambda  (east longitudinal component
c                                                 of the gradient)
c
c     at the gaussian colatitude theta(i) (see nlat as input parameter)
c     and longitude lambda(j) = (j-1)*2*pi/nlon where sint = sin(theta(i)).
c
c     note:  for an irrotational vector field (v,w), subroutine igradgc
c     computes a scalar field whose gradient is (v,w).  in ay case,
c     subroutine igradgc "inverts" the gradient subroutine gradgc.
c
c     input parameters
c
c     nlat   the number of points in the gaussian colatitude grid on the
c            full sphere. these lie in the interval (0,pi) and are computed
c            in radians in theta(1) <...< theta(nlat) by subroutine gaqd.
c            if nlat is odd the equator will be included as the grid point
c            theta((nlat+1)/2).  if nlat is even the equator will be
c            excluded as a grid point and will lie half way between
c            theta(nlat/2) and theta(nlat/2+1). nlat must be at least 3.
c            note: on the half sphere, the number of grid points in the
c            colatitudinal direction is nlat/2 if nlat is even or
c            (nlat+1)/2 if nlat is odd.
c
c     nlon   the number of distinct londitude points.  nlon determines
c            the grid increment in longitude as 2*pi/nlon. for example
c            nlon = 72 for a five degree grid. nlon must be greater than
c            3.  the efficiency of the computation is improved when nlon
c            is a product of small prime numbers.
c
c
c     isym   a parameter which determines whether the scalar field sf is
c            computed on the full or half sphere as follows:
c
c      = 0
c
c            the symmetries/antsymmetries described in isym=1,2 below
c            do not exist in (v,w) about the equator.  in this case sf
c            is neither symmetric nor antisymmetric about the equator.
c            sf is computed on the entire sphere.  i.e., in the array
c            sf(i,j) for i=1,...,nlat and  j=1,...,nlon
c
c      = 1
c
c            w is antisymmetric and v is symmetric about the equator.
c            in this case sf is antisymmetyric about the equator and
c            is computed for the northern hemisphere only.  i.e.,
c            if nlat is odd sf is computed in the array sf(i,j) for
c            i=1,...,(nlat+1)/2 and for j=1,...,nlon.  if nlat is even
c            sf is computed in the array sf(i,j) for i=1,...,nlat/2
c            and j=1,...,nlon.
c
c      = 2
c
c            w is symmetric and v is antisymmetric about the equator.
c            in this case sf is symmetyric about the equator and
c            is computed for the northern hemisphere only.  i.e.,
c            if nlat is odd sf is computed in the array sf(i,j) for
c            i=1,...,(nlat+1)/2 and for j=1,...,nlon.  if nlat is even
c            sf is computed in the array sf(i,j) for i=1,...,nlat/2
c            and j=1,...,nlon.
c
c
c     nt     nt is the number of scalar and vector fields.  some
c            computational efficiency is obtained for multiple fields.
c            the arrays br,bi, and sf can be three dimensional corresponding
c            to an indexed multiple vector field (v,w).  in this case,
c            multiple scalar synthesis will be performed to compute each
c            scalar field.  the third index for br,bi, and sf is the synthesis
c            index which assumes the values k = 1,...,nt.  for a single
c            synthesis set nt = 1.  the description of the remaining
c            parameters is simplified by assuming that nt=1 or that br,bi,
c            and sf are two dimensional arrays.
c
c     isf    the first dimension of the array sf as it appears in
c            the program that calls igradgc. if isym = 0 then isf
c            must be at least nlat.  if isym = 1 or 2 and nlat is
c            even then isf must be at least nlat/2. if isym = 1 or 2
c            and nlat is odd then isf must be at least (nlat+1)/2.
c
c     jsf    the second dimension of the array sf as it appears in
c            the program that calls igradgc. jsf must be at least nlon.
c
c     br,bi  two or three dimensional arrays (see input parameter nt)
c            that contain vector spherical harmonic coefficients
c            of the vector field (v,w) as computed by subroutine vhagc.
c     ***    br,bi must be computed by vhagc prior to calling igradgc.
c
c     mdb    the first dimension of the arrays br and bi as it appears in
c            the program that calls igradgc (and vhagc). mdb must be at
c            least min0(nlat,nlon/2) if nlon is even or at least
c            min0(nlat,(nlon+1)/2) if nlon is odd.
c
c     ndb    the second dimension of the arrays br and bi as it appears in
c            the program that calls igradgc (and vhagc). ndb must be at
c            least nlat.
c
c
c  wshsgc    an array which must be initialized by subroutine shsgci.
c            once initialized,
c            wshsgc can be used repeatedly by igradgc as long as nlon
c            and nlat remain unchanged.  wshsgc must not be altered
c            between calls of igradgc.
c
c
c  lshsgc    the dimension of the array wshsgc as it appears in the
c            program that calls igradgc. define
c
c               l1 = min0(nlat,(nlon+2)/2) if nlon is even or
c               l1 = min0(nlat,(nlon+1)/2) if nlon is odd
c
c            and
c
c               l2 = nlat/2        if nlat is even or
c               l2 = (nlat+1)/2    if nlat is odd.
c
c
c            then lshsgc must be at least
c
c               nlat*(2*l2+3*l1-2)+3*l1*(1-l1)/2+nlon+15
c
c
c     work   a work array that does not have to be saved.
c
c     lwork  the dimension of the array work as it appears in the
c            program that calls igradgc  define
c
c               l2 = nlat/2                    if nlat is even or
c               l2 = (nlat+1)/2                if nlat is odd
c               l1 = min0(nlat,(nlon+2)/2) if nlon is even or
c               l1 = min0(nlat,(nlon+1)/2) if nlon is odd

c            if isym is zero then lwork must be at least
c
c               nlat*(nlon*nt+max0(3*l2,nlon)+2*nt*l1+1)
c
c            if isym is not zero then lwork must be at least
c
c               l2*(nlon*nt+max0(3*nlat,nlon)) + nlat*(2*nt*l1+1)
c
c
c
c     **************************************************************
c
c     output parameters
c
c
c     sf    a two or three dimensional array (see input parameter nt) that
c           contain a scalar field whose gradient is the irrotational
c           component of the vector field (v,w).  the vector spherical
c           harmonic coefficients br,bi were precomputed by subroutine
c           vhagc.  sf(i,j) is given at the gaussian colatitude theta(i)
c           and longitude lambda(j) = (j-1)*2*pi/nlon.  the index ranges
c           are defined at input parameter isym.
c
c
c  ierror   = 0  no errors
c           = 1  error in the specification of nlat
c           = 2  error in the specification of nlon
c           = 3  error in the specification of isym
c           = 4  error in the specification of nt
c           = 5  error in the specification of isf
c           = 6  error in the specification of jsf
c           = 7  error in the specification of mdb
c           = 8  error in the specification of ndb
c           = 9  error in the specification of lshsgc
c           = 10 error in the specification of lwork
c
c **********************************************************************
c
      subroutine igradgc(nlat,nlon,isym,nt,sf,isf,jsf,br,bi,mdb,ndb,
     +wshsgc,lshsgc,work,lwork,ierror)
      dimension sf(isf,jsf,nt)
      dimension br(mdb,ndb,nt),bi(mdb,ndb,nt)
      dimension wshsgc(lshsgc),work(lwork)
c
c     check input parameters
c
      ierror = 1
      if(nlat .lt. 3) return
      ierror = 2
      if(nlon .lt. 4) return
      ierror = 3
      if(isym.lt.0 .or. isym.gt.2) return
      ierror = 4
      if(nt .lt. 0) return
      ierror = 5
      imid = (nlat+1)/2
      if((isym.eq.0 .and. isf.lt.nlat) .or.
     +   (isym.ne.0 .and. isf.lt.imid)) return
      ierror = 6
      if(jsf .lt. nlon) return
      ierror = 7
      mmax = min0(nlat,(nlon+2)/2)
      if(mdb .lt. min0(nlat,(nlon+1)/2)) return
      ierror = 8
      if(ndb .lt. nlat) return
      ierror = 9
c
c     verify saved work space length
c
      l2 = (nlat+mod(nlat,2))/2
      l1 = min0((nlon+2)/2,nlat)
      if (lshsgc .lt. nlat*(2*l2+3*l1-2)+3*l1*(1-l1)/2+nlon+15)return
      ierror = 10
c
c     set minimum and verify unsaved work space
c
      ls = nlat
      if(isym .gt. 0) ls = imid
      nln = nt*ls*nlon
c
c     set first dimension for a,b (as requried by shsgc)
c
      mab = min0(nlat,nlon/2+1)
      mn = mab*nlat*nt
c     lwkmin = nln+ls*nlon+2*mn+nlat
      if (isym .eq. 0) then
	lwkmin = nlat*(nt*nlon+max0(3*l2,nlon)+2*nt*l1+1)
      else
	lwkmin = l2*(nt*nlon+max0(3*nlat,nlon))+nlat*(2*nt*l1+1)
      end if
      if (lwork .lt. lwkmin) return
      ierror = 0
c
c     set work space pointers
c
      ia = 1
      ib = ia + mn
      is = ib + mn
      iwk = is + nlat
      liwk = lwork-2*mn-nlat
      call igrdgc1(nlat,nlon,isym,nt,sf,isf,jsf,work(ia),work(ib),mab,
     +work(is),mdb,ndb,br,bi,wshsgc,lshsgc,work(iwk),liwk,ierror)
      return
      end

      subroutine igrdgc1(nlat,nlon,isym,nt,sf,isf,jsf,a,b,mab,
     +sqnn,mdb,ndb,br,bi,wsav,lsav,wk,lwk,ierror)
      dimension sf(isf,jsf,nt)
      dimension br(mdb,ndb,nt),bi(mdb,ndb,nt),sqnn(nlat)
      dimension a(mab,nlat,nt),b(mab,nlat,nt)
      dimension wsav(lsav),wk(lwk)
c
c     preset coefficient multiplyers in vector
c
      do 1 n=2,nlat
      fn = float(n-1)
      sqnn(n) = 1.0/sqrt(fn*(fn+1.))
    1 continue
c
c     set upper limit for vector m subscript
c
      mmax = min0(nlat,(nlon+1)/2)
c
c     compute multiple scalar field coefficients
c
      do 2 k=1,nt
c
c     preset to 0.0
c
      do 3 n=1,nlat
      do 4 m=1,mab
      a(m,n,k) = 0.0
      b(m,n,k) = 0.0
    4 continue
    3 continue
c
c     compute m=0 coefficients
c
      do 5 n=2,nlat
      a(1,n,k) = br(1,n,k)*sqnn(n)
      b(1,n,k)= bi(1,n,k)*sqnn(n)
    5 continue
c
c     compute m>0 coefficients
c
      do 6 m=2,mmax
      do 7 n=m,nlat
      a(m,n,k) = sqnn(n)*br(m,n,k)
      b(m,n,k) = sqnn(n)*bi(m,n,k)
    7 continue
    6 continue
    2 continue
c
c     scalar sythesize a,b into sf
c
      call shsgc(nlat,nlon,isym,nt,sf,isf,jsf,a,b,mab,nlat,wsav,
     +           lsav,wk,lwk,ierror)
      return
      end


program test_argsort
use types, only: dp
use utils, only: assert
use sorting, only: argsort
implicit none

call assert(all(argsort([4, 3, 2, 1, 5]) == [4, 3, 2, 1, 5]))
call assert(all(argsort([10, 9, 8, 7, 6]) == [5, 4, 3, 2, 1]))
call assert(all(argsort([1, -1]) == [2, 1]))
call assert(all(argsort([1, 2, 2, 2, 3]) == [1, 2, 3, 4, 5]))
call assert(all(argsort([2, 2, 2, 3, 1]) == [5, 2, 3, 1, 4]))

call assert(all(argsort([4.0_dp, 3.0_dp, 2.0_dp, 1.0_dp, 5.0_dp]) == &
        [4, 3, 2, 1, 5]))
call assert(all(argsort([10.0_dp, 9.0_dp, 8.0_dp, 7.0_dp, 6.0_dp]) == &
        [5, 4, 3, 2, 1]))
call assert(all(argsort([1.0_dp, -1.0_dp]) == [2, 1]))
call assert(all(argsort([1.0_dp, 2.0_dp, 2.0_dp, 2.0_dp, 3.0_dp]) == &
        [1, 2, 3, 4, 5]))
call assert(all(argsort([2.0_dp, 2.0_dp, 2.0_dp, 3.0_dp, 1.0_dp]) == &
        [5, 2, 3, 1, 4]))

call assert(all(argsort([4.1_dp, 2.1_dp, 2.05_dp, -1.5_dp, 4.2_dp]) == &
        [4, 3, 2, 1, 5]))

end program


! { dg-do run }
! Vector subscripts, ranks and shapes of initialization expressions (PRs 29393,
! 29630 and 29679)
program test

    implicit none
    integer :: i, j
    integer, parameter :: a(4,4,4) = reshape([ (i,i=1,64) ], [4,4,4])
    integer, parameter :: v(4) = [4, 1, 3, 2]

    integer :: b1(3,3) = a(1:3, 2, 2:4)
    integer :: b2(1,3) = a(2:2, 4, [1,4,3])
    integer :: b2b(3) = a([1,4,3], 2, 4)
    integer :: b3(4) = a(1, v, 3)
    integer :: b4(3,3) = a(v([2,4,3]), 2, [2,3,4])

    if (any(b1 /= reshape([21,22,23, 37,38,39, 53,54,55], [3,3]))) STOP 1
    if (any(b2 /= reshape([14, 62, 46], [1,3]))) STOP 2
    if (any(b2b /= [53, 56, 55])) STOP 3
    if (any(b3 /= [45, 33, 41, 37])) STOP 4
    if (any(b4 /= reshape([21,22,23, 37,38,39, 53,54,55], [3,3]))) STOP 5
end program test


! { dg-do compile }
! { dg-options "-fdump-tree-original" }
!
! PR fortran/57785
!
! Contributed by Kontantinos Anagnostopoulos
!
! The implicit complex conjugate was missing for DOT_PRODUCT

! For the following, the compile-time simplification fails for SUM;
! see PR fortran/56342. Hence, a manually expanded SUM is used.

!if (DOT_PRODUCT ((/ (1.0, 2.0), (2.0, 3.0) /), (/ (1.0, 1.0), (1.0, 4.0) /))   &
!   /= SUM (CONJG ((/ (1.0, 2.0), (2.0, 3.0) /))*(/ (1.0, 1.0), (1.0, 4.0) /))) &
!   call abort ()
!
!if (ANY (MATMUL ((/ (1.0, 2.0), (2.0, 3.0) /),                                 &
!                 RESHAPE ((/ (1.0, 1.0), (1.0, 4.0) /),(/2, 1/))) /=           &
!         SUM ((/ (1.0, 2.0), (2.0, 3.0) /)*(/ (1.0, 1.0), (1.0, 4.0) /))))     &
!    call abort ()

if (DOT_PRODUCT ((/ (1.0, 2.0), (2.0, 3.0) /), (/ (1.0, 1.0), (1.0, 4.0) /))  &
    /= CONJG (cmplx(1.0, 2.0)) * cmplx(1.0, 1.0)                              &
     + CONJG (cmplx(2.0, 3.0)) * cmplx(1.0, 4.0)) &
  call abort ()

if (ANY (MATMUL ((/ (1.0, 2.0), (2.0, 3.0) /),                                &
                 RESHAPE ((/ (1.0, 1.0), (1.0, 4.0) /),(/2, 1/)))             &
         /= cmplx(1.0, 2.0) * cmplx(1.0, 1.0)                                 &
          + cmplx(2.0, 3.0) * cmplx(1.0, 4.0)))                               &
  call abort ()
end

! { dg-final { scan-tree-dump-not "abort" "original" } }