C     LAST UPDATE 16/03/98
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
      SUBROUTINE BGCSYM2(AD,B,SMOO,TENS,PC1,PC2,NPIX,NRAST,DMIN,DMAX,
     &                  XC,YC,DINC,
     &                  CSYB,CSYD,YS,YSP,WRK,PIXBIN,INDEX,
     &                  MAXBIN,MAXNUM,IPRINT,ILOG)
      IMPLICIT NONE
C
C Purpose: Fits the background by the following method. The pixels are
C          assigned to a radial bin. The values held in this bin are
C          sorted and pixel values in the range PC1 to PC2 are averaged
C          to form a background value for this bin. When the binning is
C          complete, the radial bin values are used to calculate spline
C          coefficients. Background values for the 2D image are then
C          interpolated using these coefficients.
C
C Calls   2: SORT , CURVS
C Called by: BCKCSYM
C
C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
C
C Scalar arguments:
C
      INTEGER MAXBIN,MAXNUM
      REAL SMOO,TENS,PC1,PC2
      REAL DMIN,DMAX,XC,YC,DINC
      INTEGER IPRINT,ILOG
      INTEGER NPIX,NRAST
C
C Array arguments:
C
      REAL B(NPIX*NRAST),AD(NPIX*NRAST)
      REAL CSYB(MAXBIN),CSYD(MAXBIN),YS(MAXBIN),YSP(MAXBIN),
     &     WRK(9*MAXBIN),PIXBIN(MAXNUM)
      INTEGER INDEX(MAXNUM)
C
C Local Scalars:
C
      INTEGER IFPIX,ILPIX,IFRAST,ILRAST,NBIN
      INTEGER I,J,M,NB,IER,IBAD,NP,IP,IW,IBCK,IW1,IW2
      REAL DS,S,EPS,D1,D2,BCK
C
C External function:
C
      REAL CURV2
      EXTERNAL CURV2
C
C-----------------------------------------------------------------------
C
      IFPIX=1
      ILPIX=NPIX
      IFRAST=1
      ILRAST=NRAST

      WRITE(IPRINT,1000)
      CALL FLUSH(IPRINT)
      WRITE(ILOG,1000)
C
C========Set B to 0.
C
      DO 20 J=1,NRAST
         DO 10 I=1,NPIX
            M = (J-1)*NPIX + I
            B(M) = 0.
 10      CONTINUE
 20   CONTINUE
C
C========Initialize limits and increment for binning
C
      IF(DINC.EQ.0.)DINC=1.0
      NBIN=INT( (DMAX-DMIN)/DINC )+1
C
C========Loop over pixels and bin into d*
C

      IBAD = 0
      IBCK = 0
      DO 70 NB=1,NBIN
         D1 = DMIN+(FLOAT(NB-1)*DINC)
         D2 = D1 + DINC
         NP = 0
         DO 50 J=1,NRAST
            DO 40 I=1,NPIX
               DS = SQRT( (FLOAT(I)-0.5-XC)**2 + (FLOAT(J)-0.5-YC)**2 )
               IF(DS.GT.D1.AND.DS.LE.D2)THEN
                  M = (J-1)*NPIX + I
                  IF(AD(M).GT.-0.99E+30)THEN
                     IF(NP.LT.MAXNUM)THEN
                        NP = NP + 1
                        PIXBIN(NP) = AD(M)
                     ENDIF
                  ENDIF
               ENDIF
 40         CONTINUE
 50      CONTINUE
C
C========Sort pixel values and sum over desired interval
C
         IF(NP.GT.0)THEN
            CALL SORT(PIXBIN,NP,INDEX)
            IP = 0
            BCK = 0.0
            IW1 = MIN(INT(PC1*FLOAT(NP))+1,NP)
            IW2 = MIN(INT(PC2*FLOAT(NP))+1,NP)
            DO 60 IW=IW1,IW2
               IP = IP + 1
               BCK = BCK + PIXBIN(INDEX(IW))
 60         CONTINUE
C
C========Form average
C
            IBCK = IBCK + 1
            CSYB(IBCK) = BCK/FLOAT(IP)
            CSYD(IBCK) = DMIN+((FLOAT(NB)-0.5)*DINC)
         ELSE
            IBAD = IBAD + 1
         ENDIF
 70   CONTINUE
      WRITE(IPRINT,1005)IBCK,DINC
      CALL FLUSH(IPRINT)
      WRITE(ILOG,1005)IBCK,DINC
C
C========Calculate spline coefficients for interpolating radial bins
C
      IF(IBCK.GT.1)THEN
         EPS = SQRT(2.0/FLOAT(IBCK))
         S = SMOO*FLOAT(IBCK)
         CALL CURVS(IBCK,CSYD,CSYB,1.0,1,S,EPS,YS,YSP,TENS,WRK,IER)
         IF(IER.NE.0)THEN
            WRITE(IPRINT,2000)IER
            CALL FLUSH(IPRINT)
            WRITE(ILOG,2000)IER
            STOP 'Fatal error'
         ENDIF
C
C========Loop over image pixels to interpolate background values
C
         DO 90 J=IFRAST,ILRAST
            DO 80 I=IFPIX,ILPIX
               M = (J-1)*NPIX + I
               DS = SQRT(  (FLOAT(I)-0.5-XC)**2 + (FLOAT(J)-0.5-YC)**2 )
               IF(AD(M).GT.-0.99E+30)THEN
                  B(M) = CURV2(DS,IBCK,CSYD,YS,YSP,TENS)
               ENDIF
 80         CONTINUE
 90      CONTINUE
      ENDIF

      WRITE(IPRINT,1010)
      CALL FLUSH(IPRINT)
      WRITE(ILOG,1010)

      RETURN
C
 1000 FORMAT(/1X,'BGCSYM Circularly-symmetric background fitting...')
 1005 FORMAT(1X,'Number of radial bins ',I4,1X,'increment ',F10.4)
 1010 FORMAT(1X,'Circularly-symmetric background fitting done')
 2000 FORMAT(1X,'***Error in spline fitting: FITPACK error ',I3)
      END


      SUBROUTINE DGEFA(A,LDA,N,IPVT,INFO)
      INTEGER LDA,N,IPVT(*),INFO
      DOUBLE PRECISION A(LDA,*)
C
C     DGEFA FACTORS A DOUBLE PRECISION MATRIX BY GAUSSIAN ELIMINATION.
C
C     DGEFA IS USUALLY CALLED BY DGECO, BUT IT CAN BE CALLED
C     DIRECTLY WITH A SAVING IN TIME IF  RCOND  IS NOT NEEDED.
C     (TIME FOR DGECO) = (1 + 9/N)*(TIME FOR DGEFA) .
C
C     ON ENTRY
C
C        A       DOUBLE PRECISION(LDA, N)
C                THE MATRIX TO BE FACTORED.
C
C        LDA     INTEGER
C                THE LEADING DIMENSION OF THE ARRAY  A .
C
C        N       INTEGER
C                THE ORDER OF THE MATRIX  A .
C
C     ON RETURN
C
C        A       AN UPPER TRIANGULAR MATRIX AND THE MULTIPLIERS
C                WHICH WERE USED TO OBTAIN IT.
C                THE FACTORIZATION CAN BE WRITTEN  A = L*U  WHERE
C                L  IS A PRODUCT OF PERMUTATION AND UNIT LOWER
C                TRIANGULAR MATRICES AND  U  IS UPPER TRIANGULAR.
C
C        IPVT    INTEGER(N)
C                AN INTEGER VECTOR OF PIVOT INDICES.
C
C        INFO    INTEGER
C                = 0  NORMAL VALUE.
C                = K  IF  U(K,K) .EQ. 0.0 .  THIS IS NOT AN ERROR
C                     CONDITION FOR THIS SUBROUTINE, BUT IT DOES
C                     INDICATE THAT DGESL OR DGEDI WILL DIVIDE BY ZERO
C                     IF CALLED.  USE  RCOND  IN DGECO FOR A RELIABLE
C                     INDICATION OF SINGULARITY.
C
C     LINPACK. THIS VERSION DATED 08/14/78 .
C     CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB.
C
C     SUBROUTINES AND FUNCTIONS
C
C     BLAS DAXPY,DSCAL,IDAMAX
C
C     INTERNAL VARIABLES
C
      DOUBLE PRECISION T
      INTEGER IDAMAX,J,K,KP1,L,NM1
C
C
C     GAUSSIAN ELIMINATION WITH PARTIAL PIVOTING
C
      INFO = 0
      NM1 = N - 1
      IF (NM1 .LT. 1) GO TO 70
      DO 60 K = 1, NM1
         KP1 = K + 1
C
C        FIND L = PIVOT INDEX
C
         L = IDAMAX(N-K+1,A(K,K),1) + K - 1
         IPVT(K) = L
C
C        ZERO PIVOT IMPLIES THIS COLUMN ALREADY TRIANGULARIZED
C
         IF (A(L,K) .EQ. 0.0D0) GO TO 40
C
C           INTERCHANGE IF NECESSARY
C
            IF (L .EQ. K) GO TO 10
               T = A(L,K)
               A(L,K) = A(K,K)
               A(K,K) = T
   10       CONTINUE
C
C           COMPUTE MULTIPLIERS
C
            T = -1.0D0/A(K,K)
            CALL DSCAL(N-K,T,A(K+1,K),1)
C
C           ROW ELIMINATION WITH COLUMN INDEXING
C
            DO 30 J = KP1, N
               T = A(L,J)
               IF (L .EQ. K) GO TO 20
                  A(L,J) = A(K,J)
                  A(K,J) = T
   20          CONTINUE
               CALL DAXPY(N-K,T,A(K+1,K),1,A(K+1,J),1)
   30       CONTINUE
         GO TO 50
   40    CONTINUE
            INFO = K
   50    CONTINUE
   60 CONTINUE
   70 CONTINUE
      IPVT(N) = N
      IF (A(N,N) .EQ. 0.0D0) INFO = N
      RETURN
      END
      SUBROUTINE DPOFA(A,LDA,N,INFO)
      INTEGER LDA,N,INFO
      DOUBLE PRECISION A(LDA,*)
C
C     DPOFA FACTORS A DOUBLE PRECISION SYMMETRIC POSITIVE DEFINITE
C     MATRIX.
C
C     DPOFA IS USUALLY CALLED BY DPOCO, BUT IT CAN BE CALLED
C     DIRECTLY WITH A SAVING IN TIME IF  RCOND  IS NOT NEEDED.
C     (TIME FOR DPOCO) = (1 + 18/N)*(TIME FOR DPOFA) .
C
C     ON ENTRY
C
C        A       DOUBLE PRECISION(LDA, N)
C                THE SYMMETRIC MATRIX TO BE FACTORED.  ONLY THE
C                DIAGONAL AND UPPER TRIANGLE ARE USED.
C
C        LDA     INTEGER
C                THE LEADING DIMENSION OF THE ARRAY  A .
C
C        N       INTEGER
C                THE ORDER OF THE MATRIX  A .
C
C     ON RETURN
C
C        A       AN UPPER TRIANGULAR MATRIX  R  SO THAT  A = TRANS(R)*R
C                WHERE  TRANS(R)  IS THE TRANSPOSE.
C                THE STRICT LOWER TRIANGLE IS UNALTERED.
C                IF  INFO .NE. 0 , THE FACTORIZATION IS NOT COMPLETE.
C
C        INFO    INTEGER
C                = 0  FOR NORMAL RETURN.
C                = K  SIGNALS AN ERROR CONDITION.  THE LEADING MINOR
C                     OF ORDER  K  IS NOT POSITIVE DEFINITE.
C
C     LINPACK.  THIS VERSION DATED 08/14/78 .
C     CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB.
C
C     SUBROUTINES AND FUNCTIONS
C
C     BLAS DDOT
C     FORTRAN DSQRT
C
C     INTERNAL VARIABLES
C
      DOUBLE PRECISION DDOT,T
      DOUBLE PRECISION S
      INTEGER J,JM1,K
C     BEGIN BLOCK WITH ...EXITS TO 40
C
C
         DO 30 J = 1, N
            INFO = J
            S = 0.0D0
            JM1 = J - 1
            IF (JM1 .LT. 1) GO TO 20
            DO 10 K = 1, JM1
               T = A(K,J) - DDOT(K-1,A(1,K),1,A(1,J),1)
               T = T/A(K,K)
               A(K,J) = T
               S = S + T*T
   10       CONTINUE
   20       CONTINUE
            S = A(J,J) - S
C     ......EXIT
            IF (S .LE. 0.0D0) GO TO 40
            A(J,J) = DSQRT(S)
   30    CONTINUE
         INFO = 0
   40 CONTINUE
      RETURN
      END
      SUBROUTINE DQRDC(X,LDX,N,P,QRAUX,JPVT,WORK,JOB)
      INTEGER LDX,N,P,JOB
      INTEGER JPVT(*)
      DOUBLE PRECISION X(LDX,*),QRAUX(*),WORK(*)
C
C     DQRDC USES HOUSEHOLDER TRANSFORMATIONS TO COMPUTE THE QR
C     FACTORIZATION OF AN N BY P MATRIX X.  COLUMN PIVOTING
C     BASED ON THE 2-NORMS OF THE REDUCED COLUMNS MAY BE
C     PERFORMED AT THE USERS OPTION.
C
C     ON ENTRY
C
C        X       DOUBLE PRECISION(LDX,P), WHERE LDX .GE. N.
C                X CONTAINS THE MATRIX WHOSE DECOMPOSITION IS TO BE
C                COMPUTED.
C
C        LDX     INTEGER.
C                LDX IS THE LEADING DIMENSION OF THE ARRAY X.
C
C        N       INTEGER.
C                N IS THE NUMBER OF ROWS OF THE MATRIX X.
C
C        P       INTEGER.
C                P IS THE NUMBER OF COLUMNS OF THE MATRIX X.
C
C        JPVT    INTEGER(P).
C                JPVT CONTAINS INTEGERS THAT CONTROL THE SELECTION
C                OF THE PIVOT COLUMNS.  THE K-TH COLUMN X(K) OF X
C                IS PLACED IN ONE OF THREE CLASSES ACCORDING TO THE
C                VALUE OF JPVT(K).
C
C                   IF JPVT(K) .GT. 0, THEN X(K) IS AN INITIAL
C                                      COLUMN.
C
C                   IF JPVT(K) .EQ. 0, THEN X(K) IS A FREE COLUMN.
C
C                   IF JPVT(K) .LT. 0, THEN X(K) IS A FINAL COLUMN.
C
C                BEFORE THE DECOMPOSITION IS COMPUTED, INITIAL COLUMNS
C                ARE MOVED TO THE BEGINNING OF THE ARRAY X AND FINAL
C                COLUMNS TO THE END.  BOTH INITIAL AND FINAL COLUMNS
C                ARE FROZEN IN PLACE DURING THE COMPUTATION AND ONLY
C                FREE COLUMNS ARE MOVED.  AT THE K-TH STAGE OF THE
C                REDUCTION, IF X(K) IS OCCUPIED BY A FREE COLUMN
C                IT IS INTERCHANGED WITH THE FREE COLUMN OF LARGEST
C                REDUCED NORM.  JPVT IS NOT REFERENCED IF
C                JOB .EQ. 0.
C
C        WORK    DOUBLE PRECISION(P).
C                WORK IS A WORK ARRAY.  WORK IS NOT REFERENCED IF
C                JOB .EQ. 0.
C
C        JOB     INTEGER.
C                JOB IS AN INTEGER THAT INITIATES COLUMN PIVOTING.
C                IF JOB .EQ. 0, NO PIVOTING IS DONE.
C                IF JOB .NE. 0, PIVOTING IS DONE.
C
C     ON RETURN
C
C        X       X CONTAINS IN ITS UPPER TRIANGLE THE UPPER
C                TRIANGULAR MATRIX R OF THE QR FACTORIZATION.
C                BELOW ITS DIAGONAL X CONTAINS INFORMATION FROM
C                WHICH THE ORTHOGONAL PART OF THE DECOMPOSITION
C                CAN BE RECOVERED.  NOTE THAT IF PIVOTING HAS
C                BEEN REQUESTED, THE DECOMPOSITION IS NOT THAT
C                OF THE ORIGINAL MATRIX X BUT THAT OF X
C                WITH ITS COLUMNS PERMUTED AS DESCRIBED BY JPVT.
C
C        QRAUX   DOUBLE PRECISION(P).
C                QRAUX CONTAINS FURTHER INFORMATION REQUIRED TO RECOVER
C                THE ORTHOGONAL PART OF THE DECOMPOSITION.
C
C        JPVT    JPVT(K) CONTAINS THE INDEX OF THE COLUMN OF THE
C                ORIGINAL MATRIX THAT HAS BEEN INTERCHANGED INTO
C                THE K-TH COLUMN, IF PIVOTING WAS REQUESTED.
C
C     LINPACK. THIS VERSION DATED 08/14/78 .
C     G.W. STEWART, UNIVERSITY OF MARYLAND, ARGONNE NATIONAL LAB.
C
C     DQRDC USES THE FOLLOWING FUNCTIONS AND SUBPROGRAMS.
C
C     BLAS DAXPY,DDOT,DSCAL,DSWAP,DNRM2
C     FORTRAN DABS,DMAX1,MIN0,DSQRT
C
C     INTERNAL VARIABLES
C
      INTEGER J,JJ,JP,L,LP1,LUP,MAXJ,PL,PU
      DOUBLE PRECISION MAXNRM,DNRM2,TT
      DOUBLE PRECISION DDOT,NRMXL,T
      LOGICAL NEGJ,SWAPJ
C
C
      PL = 1
      PU = 0
      IF (JOB .EQ. 0) GO TO 60
C
C        PIVOTING HAS BEEN REQUESTED.  REARRANGE THE COLUMNS
C        ACCORDING TO JPVT.
C
         DO 20 J = 1, P
            SWAPJ = JPVT(J) .GT. 0
            NEGJ = JPVT(J) .LT. 0
            JPVT(J) = J
            IF (NEGJ) JPVT(J) = -J
            IF (.NOT.SWAPJ) GO TO 10
               IF (J .NE. PL) CALL DSWAP(N,X(1,PL),1,X(1,J),1)
               JPVT(J) = JPVT(PL)
               JPVT(PL) = J
               PL = PL + 1
   10       CONTINUE
   20    CONTINUE
         PU = P
         DO 50 JJ = 1, P
            J = P - JJ + 1
            IF (JPVT(J) .GE. 0) GO TO 40
               JPVT(J) = -JPVT(J)
               IF (J .EQ. PU) GO TO 30
                  CALL DSWAP(N,X(1,PU),1,X(1,J),1)
                  JP = JPVT(PU)
                  JPVT(PU) = JPVT(J)
                  JPVT(J) = JP
   30          CONTINUE
               PU = PU - 1
   40       CONTINUE
   50    CONTINUE
   60 CONTINUE
C
C     COMPUTE THE NORMS OF THE FREE COLUMNS.
C
      IF (PU .LT. PL) GO TO 80
      DO 70 J = PL, PU
         QRAUX(J) = DNRM2(N,X(1,J),1)
         WORK(J) = QRAUX(J)
   70 CONTINUE
   80 CONTINUE
C
C     PERFORM THE HOUSEHOLDER REDUCTION OF X.
C
      LUP = MIN0(N,P)
      DO 200 L = 1, LUP
         IF (L .LT. PL .OR. L .GE. PU) GO TO 120
C
C           LOCATE THE COLUMN OF LARGEST NORM AND BRING IT
C           INTO THE PIVOT POSITION.
C
            MAXNRM = 0.0D0
            MAXJ = L
            DO 100 J = L, PU
               IF (QRAUX(J) .LE. MAXNRM) GO TO 90
                  MAXNRM = QRAUX(J)
                  MAXJ = J
   90          CONTINUE
  100       CONTINUE
            IF (MAXJ .EQ. L) GO TO 110
               CALL DSWAP(N,X(1,L),1,X(1,MAXJ),1)
               QRAUX(MAXJ) = QRAUX(L)
               WORK(MAXJ) = WORK(L)
               JP = JPVT(MAXJ)
               JPVT(MAXJ) = JPVT(L)
               JPVT(L) = JP
  110       CONTINUE
  120    CONTINUE
         QRAUX(L) = 0.0D0
         IF (L .EQ. N) GO TO 190
C
C           COMPUTE THE HOUSEHOLDER TRANSFORMATION FOR COLUMN L.
C
            NRMXL = DNRM2(N-L+1,X(L,L),1)
            IF (NRMXL .EQ. 0.0D0) GO TO 180
               IF (X(L,L) .NE. 0.0D0) NRMXL = DSIGN(NRMXL,X(L,L))
               CALL DSCAL(N-L+1,1.0D0/NRMXL,X(L,L),1)
               X(L,L) = 1.0D0 + X(L,L)
C
C              APPLY THE TRANSFORMATION TO THE REMAINING COLUMNS,
C              UPDATING THE NORMS.
C
               LP1 = L + 1
               IF (P .LT. LP1) GO TO 170
               DO 160 J = LP1, P
                  T = -DDOT(N-L+1,X(L,L),1,X(L,J),1)/X(L,L)
                  CALL DAXPY(N-L+1,T,X(L,L),1,X(L,J),1)
                  IF (J .LT. PL .OR. J .GT. PU) GO TO 150
                  IF (QRAUX(J) .EQ. 0.0D0) GO TO 150
                     TT = 1.0D0 - (DABS(X(L,J))/QRAUX(J))**2
                     TT = DMAX1(TT,0.0D0)
                     T = TT
                     TT = 1.0D0 + 0.05D0*TT*(QRAUX(J)/WORK(J))**2
                     IF (TT .EQ. 1.0D0) GO TO 130
                        QRAUX(J) = QRAUX(J)*DSQRT(T)
                     GO TO 140
  130                CONTINUE
                        QRAUX(J) = DNRM2(N-L,X(L+1,J),1)
                        WORK(J) = QRAUX(J)
  140                CONTINUE
  150             CONTINUE
  160          CONTINUE
  170          CONTINUE
C
C              SAVE THE TRANSFORMATION.
C
               QRAUX(L) = X(L,L)
               X(L,L) = -NRMXL
  180       CONTINUE
  190    CONTINUE
  200 CONTINUE
      RETURN
      END
      SUBROUTINE DGTSL(N,C,D,E,B,INFO)
      INTEGER N,INFO
      DOUBLE PRECISION C(*),D(*),E(*),B(*)
C
C     DGTSL GIVEN A GENERAL TRIDIAGONAL MATRIX AND A RIGHT HAND
C     SIDE WILL FIND THE SOLUTION.
C
C     ON ENTRY
C
C        N       INTEGER
C                IS THE ORDER OF THE TRIDIAGONAL MATRIX.
C
C        C       DOUBLE PRECISION(N)
C                IS THE SUBDIAGONAL OF THE TRIDIAGONAL MATRIX.
C                C(2) THROUGH C(N) SHOULD CONTAIN THE SUBDIAGONAL.
C                ON OUTPUT C IS DESTROYED.
C
C        D       DOUBLE PRECISION(N)
C                IS THE DIAGONAL OF THE TRIDIAGONAL MATRIX.
C                ON OUTPUT D IS DESTROYED.
C
C        E       DOUBLE PRECISION(N)
C                IS THE SUPERDIAGONAL OF THE TRIDIAGONAL MATRIX.
C                E(1) THROUGH E(N-1) SHOULD CONTAIN THE SUPERDIAGONAL.
C                ON OUTPUT E IS DESTROYED.
C
C        B       DOUBLE PRECISION(N)
C                IS THE RIGHT HAND SIDE VECTOR.
C
C     ON RETURN
C
C        B       IS THE SOLUTION VECTOR.
C
C        INFO    INTEGER
C                = 0 NORMAL VALUE.
C                = K IF THE K-TH ELEMENT OF THE DIAGONAL BECOMES
C                    EXACTLY ZERO.  THE SUBROUTINE RETURNS WHEN
C                    THIS IS DETECTED.
C
C     LINPACK. THIS VERSION DATED 08/14/78 .
C     JACK DONGARRA, ARGONNE NATIONAL LABORATORY.
C
C     NO EXTERNALS
C     FORTRAN DABS
C
C     INTERNAL VARIABLES
C
      INTEGER K,KB,KP1,NM1,NM2
      DOUBLE PRECISION T
C     BEGIN BLOCK PERMITTING ...EXITS TO 100
C
         INFO = 0
         C(1) = D(1)
         NM1 = N - 1
         IF (NM1 .LT. 1) GO TO 40
            D(1) = E(1)
            E(1) = 0.0D0
            E(N) = 0.0D0
C
            DO 30 K = 1, NM1
               KP1 = K + 1
C
C              FIND THE LARGEST OF THE TWO ROWS
C
               IF (DABS(C(KP1)) .LT. DABS(C(K))) GO TO 10
C
C                 INTERCHANGE ROW
C
                  T = C(KP1)
                  C(KP1) = C(K)
                  C(K) = T
                  T = D(KP1)
                  D(KP1) = D(K)
                  D(K) = T
                  T = E(KP1)
                  E(KP1) = E(K)
                  E(K) = T
                  T = B(KP1)
                  B(KP1) = B(K)
                  B(K) = T
   10          CONTINUE
C
C              ZERO ELEMENTS
C
               IF (C(K) .NE. 0.0D0) GO TO 20
                  INFO = K
C     ............EXIT
                  GO TO 100
   20          CONTINUE
               T = -C(KP1)/C(K)
               C(KP1) = D(KP1) + T*D(K)
               D(KP1) = E(KP1) + T*E(K)
               E(KP1) = 0.0D0
               B(KP1) = B(KP1) + T*B(K)
   30       CONTINUE
   40    CONTINUE
         IF (C(N) .NE. 0.0D0) GO TO 50
            INFO = N
         GO TO 90
   50    CONTINUE
C
C           BACK SOLVE
C
            NM2 = N - 2
            B(N) = B(N)/C(N)
            IF (N .EQ. 1) GO TO 80
               B(NM1) = (B(NM1) - D(NM1)*B(N))/C(NM1)
               IF (NM2 .LT. 1) GO TO 70
               DO 60 KB = 1, NM2
                  K = NM2 - KB + 1
                  B(K) = (B(K) - D(K)*B(K+1) - E(K)*B(K+2))/C(K)
   60          CONTINUE
   70          CONTINUE
   80       CONTINUE
   90    CONTINUE
  100 CONTINUE
C
      RETURN
      END
      SUBROUTINE DPTSL(N,D,E,B)
      INTEGER N
      DOUBLE PRECISION D(*),E(*),B(*)
C
C     DPTSL GIVEN A POSITIVE DEFINITE TRIDIAGONAL MATRIX AND A RIGHT
C     HAND SIDE WILL FIND THE SOLUTION.
C
C     ON ENTRY
C
C        N        INTEGER
C                 IS THE ORDER OF THE TRIDIAGONAL MATRIX.
C
C        D        DOUBLE PRECISION(N)
C                 IS THE DIAGONAL OF THE TRIDIAGONAL MATRIX.
C                 ON OUTPUT D IS DESTROYED.
C
C        E        DOUBLE PRECISION(N)
C                 IS THE OFFDIAGONAL OF THE TRIDIAGONAL MATRIX.
C                 E(1) THROUGH E(N-1) SHOULD CONTAIN THE
C                 OFFDIAGONAL.
C
C        B        DOUBLE PRECISION(N)
C                 IS THE RIGHT HAND SIDE VECTOR.
C
C     ON RETURN
C
C        B        CONTAINS THE SOULTION.
C
C     LINPACK. THIS VERSION DATED 08/14/78 .
C     JACK DONGARRA, ARGONNE NATIONAL LABORATORY.
C
C     NO EXTERNALS
C     FORTRAN MOD
C
C     INTERNAL VARIABLES
C
      INTEGER K,KBM1,KE,KF,KP1,NM1,NM1D2
      DOUBLE PRECISION T1,T2
C
C     CHECK FOR 1 X 1 CASE
C
      IF (N .NE. 1) GO TO 10
         B(1) = B(1)/D(1)
      GO TO 70
   10 CONTINUE
         NM1 = N - 1
         NM1D2 = NM1/2
         IF (N .EQ. 2) GO TO 30
            KBM1 = N - 1
C
C           ZERO TOP HALF OF SUBDIAGONAL AND BOTTOM HALF OF
C           SUPERDIAGONAL
C
            DO 20 K = 1, NM1D2
               T1 = E(K)/D(K)
               D(K+1) = D(K+1) - T1*E(K)
               B(K+1) = B(K+1) - T1*B(K)
               T2 = E(KBM1)/D(KBM1+1)
               D(KBM1) = D(KBM1) - T2*E(KBM1)
               B(KBM1) = B(KBM1) - T2*B(KBM1+1)
               KBM1 = KBM1 - 1
   20       CONTINUE
   30    CONTINUE
         KP1 = NM1D2 + 1
C
C        CLEAN UP FOR POSSIBLE 2 X 2 BLOCK AT CENTER
C
         IF (MOD(N,2) .NE. 0) GO TO 40
            T1 = E(KP1)/D(KP1)
            D(KP1+1) = D(KP1+1) - T1*E(KP1)
            B(KP1+1) = B(KP1+1) - T1*B(KP1)
            KP1 = KP1 + 1
   40    CONTINUE
C
C        BACK SOLVE STARTING AT THE CENTER, GOING TOWARDS THE TOP
C        AND BOTTOM
C
         B(KP1) = B(KP1)/D(KP1)
         IF (N .EQ. 2) GO TO 60
            K = KP1 - 1
            KE = KP1 + NM1D2 - 1
            DO 50 KF = KP1, KE
               B(K) = (B(K) - E(K)*B(K+1))/D(K)
               B(KF+1) = (B(KF+1) - E(KF)*B(KF))/D(KF+1)
               K = K - 1
   50       CONTINUE
   60    CONTINUE
         IF (MOD(N,2) .EQ. 0) B(1) = (B(1) - E(1)*B(2))/D(1)
   70 CONTINUE
      RETURN
      END


*
************************************************************************
*
      SUBROUTINE ESSPMV( UPLO, N, ALPHA, AP, X, INCX, BETA, Y, INCY )
*     .. Scalar Arguments ..
      REAL               ALPHA, BETA
      INTEGER            INCX, INCY, N
      CHARACTER*1        UPLO
*     .. Array Arguments ..
      DOUBLE PRECISION   Y( * )
      REAL               AP( * ), X( * )
*     ..
*
*  Purpose
*  =======
*
*  ESSPMV performs the matrix-vector operation
*
*     y := alpha*A*x + beta*y,
*
*  where alpha and beta are scalars, x and y are n element vectors and
*  A is an n by n symmetric matrix. Additional precision arithmetic is
*  used in the computation.
*
*  Parameters
*  ==========
*
*  UPLO   - CHARACTER*1.
*           On entry, UPLO specifies whether the upper or lower
*           triangular part of the matrix A is supplied in the packed
*           array AP as follows:
*
*              UPLO = 'U' or 'u'   The upper triangular part of A is
*                                  supplied in AP.
*
*              UPLO = 'L' or 'l'   The lower triangular part of A is
*                                  supplied in AP.
*
*           Unchanged on exit.
*
*  N      - INTEGER.
*           On entry, N specifies the order of the matrix A.
*           N must be at least zero.
*           Unchanged on exit.
*
*  ALPHA  - REAL            .
*           On entry, ALPHA specifies the scalar alpha.
*           Unchanged on exit.
*
*  AP     - REAL             array of DIMENSION at least
*           ( ( n*( n + 1 ) )/2 ).
*           Before entry with UPLO = 'U' or 'u', the array AP must
*           contain the upper triangular part of the symmetric matrix
*           packed sequentially, column by column, so that AP( 1 )
*           contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )
*           and a( 2, 2 ) respectively, and so on.
*           Before entry with UPLO = 'L' or 'l', the array AP must
*           contain the lower triangular part of the symmetric matrix
*           packed sequentially, column by column, so that AP( 1 )
*           contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )
*           and a( 3, 1 ) respectively, and so on.
*           Unchanged on exit.
*
*  X      - REAL             array of dimension at least
*           ( 1 + ( n - 1 )*abs( INCX ) ).
*           Before entry, the incremented array X must contain the n
*           element vector x.
*           Unchanged on exit.
*
*  INCX   - INTEGER.
*           On entry, INCX specifies the increment for the elements of
*           X. INCX must not be zero.
*           Unchanged on exit.
*
*  BETA   - REAL            .
*           On entry, BETA specifies the scalar beta. When BETA is
*           supplied as zero then Y need not be set on input.
*           Unchanged on exit.
*
*  Y      - DOUBLE PRECISION array of dimension at least
*           ( 1 + ( n - 1 )*abs( INCY ) ).
*           Before entry, the incremented array Y must contain the n
*           element vector y. On exit, Y is overwritten by the updated
*           vector y. At least REAL             arithmetic is used in
*           the computation of y.
*
*  INCY   - INTEGER.
*           On entry, INCY specifies the increment for the elements of
*           Y. INCY must not be zero.
*           Unchanged on exit.
*
*
*  Level 2 Blas routine.
*
*  -- Written on 20-July-1986.
*     Sven Hammarling, Nag Central Office.
*     Richard Hanson, Sandia National Labs.
*
*
*     .. Parameters ..
      REAL               ONE         , ZERO
      PARAMETER        ( ONE = 1.0E+0, ZERO = 0.0E+0 )
*     .. Local Scalars ..
      DOUBLE PRECISION   TEMP1, TEMP2
      INTEGER            I, INFO, IX, IY, J, JX, JY, K, KK, KX, KY
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     .. External Subroutines ..
      EXTERNAL           XERBLA
*     .. Intrinsic Functions ..
      INTRINSIC          DBLE
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      INFO = 0
      IF      ( .NOT.LSAME( UPLO, 'U' ).AND.
     $          .NOT.LSAME( UPLO, 'L' )      ) THEN
         INFO = 1
      ELSE IF ( N.LT.0 ) THEN
         INFO = 2
      ELSE IF ( INCX.EQ.0 ) THEN
         INFO = 6
      ELSE IF ( INCY.EQ.0 ) THEN
         INFO = 9
      END IF
      IF( INFO.NE.0 )THEN
         CALL XERBLA( 'ESSPMV', INFO )
         RETURN
      END IF
*
*     Quick return if possible.
*
      IF( ( N.EQ.0 ).OR.( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) )
     $   RETURN
*
*     Start the operations. In this version the elements of the array AP
*     are accessed sequentially with one pass through AP.
*
*     First form  y := beta*y  and set up the start points in X and Y if
*     the increments are not both unity.
*
      IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN
         IF( BETA.NE.ONE )THEN
            IF( BETA.EQ.ZERO )THEN
               DO 10, I = 1, N
                  Y( I ) = ZERO
   10          CONTINUE
            ELSE
               DO 20, I = 1, N
                  Y( I ) = BETA*Y( I )
   20          CONTINUE
            END IF
         END IF
      ELSE
         IF( INCX.GT.0 )THEN
            KX = 1
         ELSE
            KX = 1 - ( N - 1 )*INCX
         END IF
         IF( INCY.GT.0 )THEN
            KY = 1
         ELSE
            KY = 1 - ( N - 1 )*INCY
         END IF
         IF( BETA.NE.ONE )THEN
            IY = KY
            IF( BETA.EQ.ZERO )THEN
               DO 30, I = 1, N
                  Y( IY ) = ZERO
                  IY      = IY   + INCY
   30          CONTINUE
            ELSE
               DO 40, I = 1, N
                  Y( IY ) = BETA*Y( IY )
                  IY      = IY           + INCY
   40          CONTINUE
            END IF
         END IF
      END IF
      IF( ALPHA.EQ.ZERO )
     $   RETURN
      K = 1
      IF( LSAME( UPLO, 'U' ) )THEN
*
*        Form  y  when AP contains the upper triangle.
*
         IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN
            DO 60, J = 1, N
               TEMP1 = DBLE( ALPHA )*X( J )
               TEMP2 = ZERO
               DO 50, I = 1, J - 1
                  Y( I ) = Y( I ) + TEMP1*AP( K )
                  TEMP2  = TEMP2  + AP( K )*DBLE( X( I ) )
                  K      = K      + 1
   50          CONTINUE
               Y( J ) = Y( J ) + TEMP1*AP( K ) + ALPHA*TEMP2
               K      = K      + 1
   60       CONTINUE
         ELSE
            IX = KX - INCX
            DO 80, J = 1, N
               TEMP1 = DBLE( ALPHA )*X( IX + INCX )
               TEMP2 = ZERO
               IX    = KX
               IY    = KY
               KK    = K
               DO 70, K = KK, KK + J - 2
                  Y( IY ) = Y( IY ) + TEMP1*AP( K )
                  TEMP2   = TEMP2   + AP( K )*DBLE( X( IX ) )
                  IX      = IX      + INCX
                  IY      = IY      + INCY
   70          CONTINUE
               Y( IY ) = Y( IY ) + TEMP1*AP( K ) + ALPHA*TEMP2
               K       = K       + 1
   80       CONTINUE
         END IF
      ELSE
*
*        Form  y  when AP contains the lower triangle.
*
         IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN
            DO 100, J = 1, N
               TEMP1  = DBLE( ALPHA )*X( J )
               TEMP2  = ZERO
               Y( J ) = Y( J ) + TEMP1*AP( K )
               K      = K      + 1
               DO 90, I = J + 1, N
                  Y( I ) = Y( I ) + TEMP1*AP( K )
                  TEMP2  = TEMP2  + AP( K )*DBLE( X( I ) )
                  K      = K      + 1
   90          CONTINUE
               Y( J ) = Y( J ) + ALPHA*TEMP2
  100       CONTINUE
         ELSE
            JX = KX
            JY = KY
            DO 120, J = 1, N
               TEMP1   = DBLE( ALPHA )*X( JX )
               TEMP2   = ZERO
               Y( JY ) = Y( JY ) + TEMP1*AP( K )
               IX      = JX
               IY      = JY
               KK      = K       + 1
               DO 110, K = KK, KK + N - ( J + 1 )
                  IX      = IX      + INCX
                  IY      = IY      + INCY
                  Y( IY ) = Y( IY ) + TEMP1*AP( K )
                  TEMP2   = TEMP2   + AP( K )*DBLE( X( IX ) )
  110          CONTINUE
               Y( JY ) = Y( JY ) + ALPHA*TEMP2
               JX      = JX      + INCX
               JY      = JY      + INCY
  120       CONTINUE
         END IF
      END IF
*
      RETURN
*
*     End of ESSPMV.
*
      END


C FILE: FIB1.F
        SUBROUTINE FIB(A,N)
C
C CALCULATE FIRST N FIBONACCI NUMBERS
C
        INTEGER N
        REAL*8 A(N)
        DO I=1,N
            IF (I.EQ.1) THEN
                A(I) = 0.0D0
            ELSEIF (I.EQ.2) THEN
                A(I) = 1.0D0
            ELSE
                A(I) = A(I-1) + A(I-2)
            ENDIF
        ENDDO
        END
C END FILE FIB1.


program test5
#if (_DP==0)
 use iso_fortran_env,only:int32,int64,wp=>real32
#else
 use iso_fortran_env,only:int32,int64,wp=>real64
#endif
 use modmetis,only:METIS_CTYPE_SHEM
 use modsparse
 implicit none
 integer(kind=int32)::nrow
 integer(kind=int32)::row
 integer(kind=int32)::col
 integer(kind=int32)::iunit, istat
 integer(kind=int32)::i,j
 integer(kind=int32),allocatable::iarray(:,:)
 integer(kind=int32),allocatable::perm(:)
 real(kind=wp)::val
 real(kind=wp),allocatable::x(:),y(:)
 logical::lup=.false.
 type(coosparse)::coo
 type(crssparse)::crs

 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 !COO UPPER
 open(newunit=iunit,file='crsinput.ascii',status='old',action='read')
 read(iunit,*) nrow

 coo=coosparse(5,nel=4_int64,lupper=.true.)

 do
  read(iunit,*,iostat=istat) row,col,val
  if(istat.ne.0)exit
  call coo%add(row,col,val)
 end do
 close(iunit)

 call coo%add(5,5,10._wp)
 call coo%add(2,5,11._wp)
 call coo%add(5,2,11._wp)

 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 !CSR UPPER
 crs=coo
 call crs%print(lint=.true.)

 !perm=crs%getordering()
 perm=crs%getordering(compress=1,ctype=METIS_CTYPE_SHEM)
 print*,'perm',perm

 call crs%printstats()

 write(*,*)'aaaaaaaaaaaa'

 call crs%setpermutation(crs%getordering())
 call crs%printstats()

 allocate(x(crs%getdim(1)),y(crs%getdim(1)))
 x=1.;y=1.

 call crs%solve(x,y)

 write(*,*)'aaaaaaaaaaaa'
 allocate(iarray(crs%getdim(1),crs%getdim(2)))
 iarray=0
 do i=1,crs%getdim(1)
  do j=1,crs%getdim(2)
   val=crs%get(perm(i),perm(j))
   if(val.ne.0.)iarray(i,j)=1
  enddo
 enddo

 do i=1,crs%getdim(1)
  write(*,'(10000(i2))')iarray(i,:)
 enddo

end program


program getSin
implicit none

   real :: x
   print *,' Enter x(radian)'

   read *,x
   print *,SIN(x)
   open (unit = 42, file = "output.txt")
   write (42,*) SIN(x)
   close(42)

end program getSin


      function diskdenspsi(r,z,psi)
      parameter (pi=3.1415926535)
      common /gparameters/  a, b, c, v0, q, psi00,
     +                      psiout, rho1, sigbulge2,
     +                      rmdisk, rdisk, zdisk, outdisk, drtrunc,
     +                      potcor1
      common /moreconstants/ v02, v03, rdisk2, diskconst, bulgea

c the truncation factor is derived assuming that the azimuthal velocity dist
c is gaussian with dispersion sigma_R * 2 omega/kappa, as per epicycle theory.
      if( abs(z/zdisk) .gt. 10.) goto 99
      erfarg=(r-outdisk)/1.4142136/drtrunc
      if (erfarg.gt.4.) goto 99
      if (erfarg.lt.-4) then
         trunfac=1
      else
         trunfac=0.5*erfc(erfarg)
      endif
      if (z.eq.0.) then
         con=1
      else
        psizh= pot(r,zdisk)
        psi0 = pot(r,0.)
        con = 0.419974**((psi-psi0)/(psizh-psi0))
      endif
      diskdenspsi = diskconst*exp(-r/rdisk)*con*trunfac
      return
 99   diskdenspsi = 0.0
      return
      end


module sutherland_mod

USE Variablen

contains

subroutine sutherland
real:: n
integer:: i,j,h
! in dieser Subroutine wird die viskosität µ berechnet mit
! Hilfe des Sutherland Gesetzes
! und die Wärmeleitungskoefiziernt k

!Konstanten festlegen in INI_MOD
!cp=1004.5
!mu0=1.725
!Suth=110.3
!T_inf=275 !K
! Pr=0.72
! mu0=C1

mu0=1.458*10.**(-6)
Suth=110.4
 mu(1:m_local,1:n_local,1:o_local)=mu0*&
(T(1:m_local,1:n_local,1:o_local))**(3./2.)&
/(T(1:m_local,1:n_local,1:o_local)+Suth)

do I=1,m_local
	do j=1,n_local
		do h=1,o_local

			if((T(i,j,h)<110.3).AND.(T(i,j,h)>40))then
                      mu(i,j,h)=6.8070e-8 *T(i,j,h)
			endif
			if((T(i,j,h)<40))then
                      mu(i,j,h)=6.8070e-8 *T(i,j,h)
			endif

		enddo
	enddo
enddo
!print *, mu(1:10,1:10,1:10)
!read *, mu0
mu(1:m_local,1:n_local,1:o_local)=mu0
!cp=1004.5 cpo =: n
n=1004.5
Pr=0.72
k(1:m_local,1:n_local,1:o_local)=&
mu(1:m_local,1:n_local,1:o_local)*n/Pr

end subroutine

end module


subroutine rutclo(ndime,ngaus,posgp,weigp)

!-----------------------------------------------------------------------
!
!     This routine sets up the integration constants of closed rules for
!     triangles and tetrahedra
!
!             NDIME = 2             NDIME = 3
!
!          NGAUS  EXACT POL.     NGAUS  EXACT POL.
!          -----  ----------     -----  ----------
!            3       p1            4       p1
!            4       p2            5       p2
!            6       p1           10       p2
!            7       p3           11       p3
!           10       p3           15       p3
!           15       p5           20       p2 & x^4,...
!
!-----------------------------------------------------------------------

  use      typre
  implicit none

  integer(ip), intent(in)  :: ndime,ngaus
  real(rp),    intent(out) :: posgp(ndime,ngaus),weigp(ngaus)
  real(rp)                 :: w1,w2,w3
  integer(ip)              :: istop

!
! Line integral
!
  istop=0
  if(ndime==1) then
     if(ngaus==2) then
        posgp(1,1)=-1.0_rp
        posgp(1,2)= 1.0_rp
        weigp(1)= 1.0_rp
        weigp(2)= 1.0_rp
     else if(ngaus==3) then
        posgp(1,1)=-1.0_rp
        posgp(1,2)= 0.0_rp
        posgp(1,3)= 1.0_rp
        weigp(1)= 1.0_rp/3.0_rp
        weigp(2)= 4.0_rp/3.0_rp
        weigp(3)= 1.0_rp/3.0_rp
     else if(ngaus==4) then
        posgp(1,1)=-1.0_rp
        posgp(1,2)=-1.0_rp/3.0_rp
        posgp(1,3)= 1.0_rp/3.0_rp
        posgp(1,4)= 1.0_rp
        weigp(1)= 1.0_rp/4.0_rp
        weigp(2)= 3.0_rp/4.0_rp
        weigp(3)= 3.0_rp/4.0_rp
        weigp(4)= 1.0_rp/4.0_rp
!* * * * * * * * * * * * * * * * * *
!*
!* Valores calculados para ngaus==5
!*
!* * * * * * * * * * * * * * * * * *
     else if(ngaus==5) then
     posgp(1,1)=-1.0_rp
     posgp(1,2)=-1.0_rp/2.0_rp
     posgp(1,3)= 0.0_rp
     posgp(1,4)= 1.0_rp/2.0_rp
     posgp(1,5)= 1.0_rp
     weigp(1)=  7.0_rp/45.0_rp
     weigp(2)= 32.0_rp/45.0_rp
     weigp(3)=  4.0_rp/15.0_rp
     weigp(4)= 32.0_rp/45.0_rp
     weigp(5)=  7.0_rp/45.0_rp
     else
        istop=1
     end if
!
! Area integral (triangles)
!
  else if(ndime==2) then
     if(ngaus==3) then
        posgp(1,1)= 0.0_rp
        posgp(2,1)= 0.0_rp
        posgp(1,2)= 1.0_rp
        posgp(2,2)= 0.0_rp
        posgp(1,3)= 0.0_rp
        posgp(2,3)= 1.0_rp
        weigp(  1)= 1.0_rp/6.0_rp
        weigp(  2)= 1.0_rp/6.0_rp
        weigp(  3)= 1.0_rp/6.0_rp
     else if(ngaus==4) then
        posgp(1,1)= 0.0_rp
        posgp(2,1)= 0.0_rp
        posgp(1,2)= 1.0_rp
        posgp(2,2)= 0.0_rp
        posgp(1,3)= 0.0_rp
        posgp(2,3)= 1.0_rp
        posgp(1,4)= 1.0_rp/3.0_rp
        posgp(2,4)= 1.0_rp/3.0_rp
        weigp(  1)= 1.0_rp/24.0_rp
        weigp(  2)= 1.0_rp/24.0_rp
        weigp(  3)= 1.0_rp/24.0_rp
        weigp(  4)= 3.0_rp/8.0_rp
     else if(ngaus==6) then
        posgp(1,1)= 0.0_rp
        posgp(2,1)= 0.0_rp
        posgp(1,2)= 1.0_rp
        posgp(2,2)= 0.0_rp
        posgp(1,3)= 0.0_rp
        posgp(2,3)= 1.0_rp
        posgp(1,4)= 0.5_rp
        posgp(2,4)= 0.0_rp
        posgp(1,5)= 0.5_rp
        posgp(2,5)= 0.5_rp
        posgp(1,6)= 0.0_rp
        posgp(2,6)= 0.5_rp
        weigp(  1)= 1.0_rp/24.0_rp
        weigp(  2)= 1.0_rp/24.0_rp
        weigp(  3)= 1.0_rp/24.0_rp
        weigp(  4)= 1.0_rp/8.0_rp
        weigp(  5)= 1.0_rp/8.0_rp
        weigp(  6)= 1.0_rp/8.0_rp
     else if(ngaus==7) then
        posgp(1,1)= 0.0_rp
        posgp(2,1)= 0.0_rp
        posgp(1,2)= 1.0_rp
        posgp(2,2)= 0.0_rp
        posgp(1,3)= 0.0_rp
        posgp(2,3)= 1.0_rp
        posgp(1,4)= 0.5_rp
        posgp(2,4)= 0.0_rp
        posgp(1,5)= 0.5_rp
        posgp(2,5)= 0.5_rp
        posgp(1,6)= 0.0_rp
        posgp(2,6)= 0.5_rp
        posgp(1,7)= 1.0_rp/3.0_rp
        posgp(2,7)= 1.0_rp/3.0_rp
        weigp(  1)= 1.0_rp/40.0_rp
        weigp(  2)= 1.0_rp/40.0_rp
        weigp(  3)= 1.0_rp/40.0_rp
        weigp(  4)= 1.0_rp/15.0_rp
        weigp(  5)= 1.0_rp/15.0_rp
        weigp(  6)= 1.0_rp/15.0_rp
        weigp(  7)= 9.0_rp/40.0_rp
!* * * * * * * * * * * * * * * * * * * * * *
!*
!* Regla calculada para ngaus=10, p3 exacto
!*
!* * * * * * * * * * * * * * * * * * * * * *
     else if(ngaus==10) then
        posgp(1, 1)= 0.0_rp
        posgp(2, 1)= 0.0_rp
        posgp(1, 2)= 1.0_rp
        posgp(2, 2)= 0.0_rp
        posgp(1, 3)= 0.0_rp
        posgp(2, 3)= 1.0_rp
        posgp(1, 4)= 1.0_rp/3.0_rp
        posgp(2, 4)= 0.0_rp
        posgp(1, 5)= 2.0_rp/3.0_rp
        posgp(2, 5)= 0.0_rp
        posgp(1, 6)= 2.0_rp/3.0_rp
        posgp(2, 6)= 1.0_rp/3.0_rp
        posgp(1, 7)= 1.0_rp/3.0_rp
        posgp(2, 7)= 2.0_rp/3.0_rp
        posgp(1, 8)= 0.0_rp
        posgp(2, 8)= 2.0_rp/3.0_rp
        posgp(1, 9)= 0.0_rp
        posgp(2, 9)= 1.0_rp/3.0_rp
        posgp(1,10)= 1.0_rp/3.0_rp
        posgp(2,10)= 1.0_rp/3.0_rp
        weigp(   1)= 1.0_rp/60.0_rp
        weigp(   2)= 1.0_rp/60.0_rp
        weigp(   3)= 1.0_rp/60.0_rp
        weigp(   4)= 3.0_rp/80.0_rp
        weigp(   5)= 3.0_rp/80.0_rp
        weigp(   6)= 3.0_rp/80.0_rp
        weigp(   7)= 3.0_rp/80.0_rp
        weigp(   8)= 3.0_rp/80.0_rp
        weigp(   9)= 3.0_rp/80.0_rp
        weigp(  10)= 9.0_rp/40.0_rp

! * * * * * * * * * * * * * * * * * * * * * * *
! *
! *  Regla calculada para ngaus==15, p4 exacto
! *
! * * * * * * * * * * * * * * * * * * * * * * *
!    else if(ngaus==15) then
!        posgp(1, 1)= 0.0_rp
!        posgp(2, 1)= 0.0_rp
!        posgp(1, 2)= 1.0_rp
!        posgp(2, 2)= 0.0_rp
!        posgp(1, 3)= 0.0_rp
!        posgp(2, 3)= 1.0_rp
!        posgp(1, 4)= 1.0_rp/4.0_rp
!        posgp(2, 4)= 0.0_rp
!        posgp(1, 5)= 1.0_rp/2.0_rp
!        posgp(2, 5)= 0.0_rp
!        posgp(1, 6)= 3.0_rp/4.0_rp
!        posgp(2, 6)= 0.0_rp
!        posgp(1, 7)= 3.0_rp/4.0_rp
!        posgp(2, 7)= 1.0_rp/4.0_rp
!        posgp(1, 8)= 1.0_rp/2.0_rp
!        posgp(2, 8)= 1.0_rp/2.0_rp
!        posgp(1, 9)= 1.0_rp/4.0_rp
!        posgp(2, 9)= 3.0_rp/4.0_rp
!        posgp(1,10)= 0.0_rp
!        posgp(2,10)= 3.0_rp/4.0_rp
!        posgp(1,11)= 0.0_rp
!        posgp(2,11)= 1.0_rp/2.0_rp
!        posgp(1,12)= 0.0_rp
!        posgp(2,12)= 1.0_rp/4.0_rp
!        posgp(1,13)= 1.0_rp/4.0_rp
!        posgp(2,13)= 1.0_rp/4.0_rp
!        posgp(1,14)= 1.0_rp/2.0_rp
!        posgp(2,14)= 1.0_rp/4.0_rp
!        posgp(1,15)= 1.0_rp/4.0_rp
!        posgp(2,15)= 1.0_rp/2.0_rp
!        weigp(1) =  0.0_rp
!        weigp(2) =  0.0_rp
!        weigp(3) =  0.0_rp
!        weigp(4) =  2.0_rp/45.0_rp
!        weigp(5) = -1.0_rp/90.0_rp
!        weigp(6) =  2.0_rp/45.0_rp
!        weigp(7) =  2.0_rp/45.0_rp
!        weigp(8) = -1.0_rp/90.0_rp
!        weigp(9) =  2.0_rp/45.0_rp
!        weigp(10) = 2.0_rp/45.0_rp
!        weigp(11) =-1.0_rp/90.0_rp
!        weigp(12) = 2.0_rp/45.0_rp
!        weigp(13) = 4.0_rp/45.0_rp
!        weigp(14) = 4.0_rp/45.0_rp
!        weigp(15) = 4.0_rp/45.0_rp

! * * * * * * * * * * * * * * * * * * * * * * * * * * *
! *
! *  Regla opcional calculada para ngaus==15, p4 exacto
! *  elemento p4 modificado
! *
! * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     else if(ngaus==15) then
!        posgp(1, 1)= 0.0_rp
!        posgp(2, 1)= 0.0_rp
!        posgp(1, 2)= 1.0_rp
!        posgp(2, 2)= 0.0_rp
!        posgp(1, 3)= 0.0_rp
!        posgp(2, 3)= 1.0_rp
!        posgp(1, 4)= 1.0_rp/4.0_rp
!        posgp(2, 4)= 0.0_rp
!        posgp(1, 5)= 1.0_rp/2.0_rp
!        posgp(2, 5)= 0.0_rp
!        posgp(1, 6)= 3.0_rp/4.0_rp
!        posgp(2, 6)= 0.0_rp
!        posgp(1, 7)= 3.0_rp/4.0_rp
!        posgp(2, 7)= 1.0_rp/4.0_rp
!        posgp(1, 8)= 1.0_rp/2.0_rp
!        posgp(2, 8)= 1.0_rp/2.0_rp
!        posgp(1, 9)= 1.0_rp/4.0_rp
!        posgp(2, 9)= 3.0_rp/4.0_rp
!        posgp(1,10)= 0.0_rp
!        posgp(2,10)= 3.0_rp/4.0_rp
!        posgp(1,11)= 0.0_rp
!        posgp(2,11)= 1.0_rp/2.0_rp
!        posgp(1,12)= 0.0_rp
!        posgp(2,12)= 1.0_rp/4.0_rp
!        posgp(1,13)= 1.0_rp/6.0_rp
!        posgp(2,13)= 1.0_rp/6.0_rp
!        posgp(1,14)= 2.0_rp/3.0_rp
!        posgp(2,14)= 1.0_rp/6.0_rp
!        posgp(1,15)= 1.0_rp/6.0_rp
!        posgp(2,15)= 2.0_rp/3.0_rp
!        weigp(   1)= 2.0_rp/135.0_rp
!        weigp(   2)= 2.0_rp/135.0_rp
!        weigp(   3)= 2.0_rp/135.0_rp
!        weigp(   4)=-4.0_rp/135.0_rp
!        weigp(   5)= 11.0_rp/180.0_rp
!        weigp(   6)=-4.0_rp/135.0_rp
!        weigp(   7)=-4.0_rp/135.0_rp
!        weigp(   8)= 11.0_rp/180.0_rp
!        weigp(   9)=-4.0_rp/135.0_rp
!        weigp(  10)=-4.0_rp/135.0_rp
!        weigp(  11)= 11.0_rp/180.0_rp
!        weigp(  12)=-4.0_rp/135.0_rp
!        weigp(  13)= 3.0_rp/20.0_rp
!        weigp(  14)= 3.0_rp/20.0_rp
!        weigp(  15)= 3.0_rp/20.0_rp
! * * * * * * * * * * * * * * * * * * * * * * * * * * *
! *
! *  Regla opcional calculada para ngaus==15, p5 exacto
! *  elemento p4 modificado
! *
! * * * * * * * * * * * * * * * * * * * * * * * * * * *
     else if(ngaus==15) then
        posgp(1, 1)= 0.0_rp
        posgp(2, 1)= 0.0_rp
        posgp(1, 2)= 1.0_rp
        posgp(2, 2)= 0.0_rp
        posgp(1, 3)= 0.0_rp
        posgp(2, 3)= 1.0_rp
        posgp(1, 4)= 1.0_rp/4.0_rp
        posgp(2, 4)= 0.0_rp
        posgp(1, 5)= 1.0_rp/2.0_rp
        posgp(2, 5)= 0.0_rp
        posgp(1, 6)= 3.0_rp/4.0_rp
        posgp(2, 6)= 0.0_rp
        posgp(1, 7)= 3.0_rp/4.0_rp
        posgp(2, 7)= 1.0_rp/4.0_rp
        posgp(1, 8)= 1.0_rp/2.0_rp
        posgp(2, 8)= 1.0_rp/2.0_rp
        posgp(1, 9)= 1.0_rp/4.0_rp
        posgp(2, 9)= 3.0_rp/4.0_rp
        posgp(1,10)= 0.0_rp
        posgp(2,10)= 3.0_rp/4.0_rp
        posgp(1,11)= 0.0_rp
        posgp(2,11)= 1.0_rp/2.0_rp
        posgp(1,12)= 0.0_rp
        posgp(2,12)= 1.0_rp/4.0_rp
        posgp(1,13)= (7.0_rp-sqrt(7.0_rp))/21.0_rp
        posgp(2,13)= (7.0_rp-sqrt(7.0_rp))/21.0_rp
        posgp(1,14)= (7.0_rp+2.0_rp*sqrt(7.0_rp))/21.0_rp
        posgp(2,14)= (7.0_rp-sqrt(7.0_rp))/21.0_rp
        posgp(1,15)= (7.0_rp-sqrt(7.0_rp))/21.0_rp
        posgp(2,15)= (7.0_rp+2.0_rp*sqrt(7.0_rp))/21.0_rp
        weigp(   1)= 11.0_rp*sqrt(7.0_rp)/15120.0_rp+1.0_rp/216.0_rp
        weigp(   2)= 11.0_rp*sqrt(7.0_rp)/15120.0_rp+1.0_rp/216.0_rp
        weigp(   3)= 11.0_rp*sqrt(7.0_rp)/15120.0_rp+1.0_rp/216.0_rp
        weigp(   4)= 4.0_rp/135.0_rp-4.0_rp*sqrt(7.0_rp)/945.0_rp
        weigp(   5)= 11.0_rp*sqrt(7.0_rp)/630.0_rp-1.0_rp/30.0_rp
        weigp(   6)= 4.0_rp/135.0_rp-4.0_rp*sqrt(7.0_rp)/945.0_rp
        weigp(   7)= 4.0_rp/135.0_rp-4.0_rp*sqrt(7.0_rp)/945.0_rp
        weigp(   8)= 11.0_rp*sqrt(7.0_rp)/630.0_rp-1.0_rp/30.0_rp
        weigp(   9)= 4.0_rp/135.0_rp-4.0_rp*sqrt(7.0_rp)/945.0_rp
        weigp(  10)= 4.0_rp/135.0_rp-4.0_rp*sqrt(7.0_rp)/945.0_rp
        weigp(  11)= 11.0_rp*sqrt(7.0_rp)/630.0_rp-1.0_rp/30.0_rp
        weigp(  12)= 4.0_rp/135.0_rp-4.0_rp*sqrt(7.0_rp)/945.0_rp
        weigp(  13)= 49.0_rp/360.0_rp-7.0_rp*sqrt(7.0_rp)/720.0_rp
        weigp(  14)= 49.0_rp/360.0_rp-7.0_rp*sqrt(7.0_rp)/720.0_rp
        weigp(  15)= 49.0_rp/360.0_rp-7.0_rp*sqrt(7.0_rp)/720.0_rp
        else
        istop=1
     end if
!
! Volume integral ( tetrahedra )
!
  else if(ndime==3) then
     if(ngaus==4) then
        posgp(1,1)= 0.0_rp
        posgp(2,1)= 0.0_rp
        posgp(3,1)= 0.0_rp
        posgp(1,2)= 1.0_rp
        posgp(2,2)= 0.0_rp
        posgp(3,2)= 0.0_rp
        posgp(1,3)= 0.0_rp
        posgp(2,3)= 1.0_rp
        posgp(3,3)= 0.0_rp
        posgp(1,4)= 0.0_rp
        posgp(2,4)= 0.0_rp
        posgp(3,4)= 1.0_rp
        weigp(  1)= 1.0_rp/24.0_rp
        weigp(  2)= 1.0_rp/24.0_rp
        weigp(  3)= 1.0_rp/24.0_rp
        weigp(  4)= 1.0_rp/24.0_rp
     else if(ngaus==5) then
        posgp(1,1)= 0.0_rp
        posgp(2,1)= 0.0_rp
        posgp(3,1)= 0.0_rp
        posgp(1,2)= 1.0_rp
        posgp(2,2)= 0.0_rp
        posgp(3,2)= 0.0_rp
        posgp(1,3)= 0.0_rp
        posgp(2,3)= 1.0_rp
        posgp(3,3)= 0.0_rp
        posgp(1,4)= 0.0_rp
        posgp(2,4)= 0.0_rp
        posgp(3,4)= 1.0_rp
        posgp(1,5)= 1.0_rp/4.0_rp
        posgp(2,5)= 1.0_rp/4.0_rp
        posgp(3,5)= 1.0_rp/4.0_rp
        weigp(  1)= 1.0_rp/120.0_rp
        weigp(  2)= 1.0_rp/120.0_rp
        weigp(  3)= 1.0_rp/120.0_rp
        weigp(  4)= 1.0_rp/120.0_rp
        weigp(  5)= 2.0_rp/15.0_rp
     else if(ngaus==10) then
        posgp(1, 1)= 0.0_rp
        posgp(2, 1)= 0.0_rp
        posgp(3, 1)= 0.0_rp
        posgp(1, 2)= 1.0_rp
        posgp(2, 2)= 0.0_rp
        posgp(3, 2)= 0.0_rp
        posgp(1, 3)= 0.0_rp
        posgp(2, 3)= 1.0_rp
        posgp(3, 3)= 0.0_rp
        posgp(1, 4)= 0.0_rp
        posgp(2, 4)= 0.0_rp
        posgp(3, 4)= 1.0_rp
        posgp(1, 5)= 0.5_rp
        posgp(2, 5)= 0.0_rp
        posgp(3, 5)= 0.0_rp
        posgp(1, 6)= 0.5_rp
        posgp(2, 6)= 0.5_rp
        posgp(3, 6)= 0.0_rp
        posgp(1, 7)= 0.0_rp
        posgp(2, 7)= 0.5_rp
        posgp(3, 7)= 0.0_rp
        posgp(1, 8)= 0.5_rp
        posgp(2, 8)= 0.0_rp
        posgp(3, 8)= 0.5_rp
        posgp(1, 9)= 0.0_rp
        posgp(2, 9)= 0.5_rp
        posgp(3, 9)= 0.5_rp
        posgp(1,10)= 0.0_rp
        posgp(2,10)= 0.0_rp
        posgp(3,10)= 0.5_rp
        weigp(   1)=-1.0_rp/120.0_rp
        weigp(   2)=-1.0_rp/120.0_rp
        weigp(   3)=-1.0_rp/120.0_rp
        weigp(   4)=-1.0_rp/120.0_rp
        weigp(   5)= 1.0_rp/30.0_rp
        weigp(   6)= 1.0_rp/30.0_rp
        weigp(   7)= 1.0_rp/30.0_rp
        weigp(   8)= 1.0_rp/30.0_rp
        weigp(   9)= 1.0_rp/30.0_rp
        weigp(  10)= 1.0_rp/30.0_rp
     else if(ngaus==11) then
        posgp(1, 1)= 0.0_rp
        posgp(2, 1)= 0.0_rp
        posgp(3, 1)= 0.0_rp
        posgp(1, 2)= 1.0_rp
        posgp(2, 2)= 0.0_rp
        posgp(3, 2)= 0.0_rp
        posgp(1, 3)= 0.0_rp
        posgp(2, 3)= 1.0_rp
        posgp(3, 3)= 0.0_rp
        posgp(1, 4)= 0.0_rp
        posgp(2, 4)= 0.0_rp
        posgp(3, 4)= 1.0_rp
        posgp(1, 5)= 0.5_rp
        posgp(2, 5)= 0.0_rp
        posgp(3, 5)= 0.0_rp
        posgp(1, 6)= 0.5_rp
        posgp(2, 6)= 0.5_rp
        posgp(3, 6)= 0.0_rp
        posgp(1, 7)= 0.0_rp
        posgp(2, 7)= 0.5_rp
        posgp(3, 7)= 0.0_rp
        posgp(1, 8)= 0.5_rp
        posgp(2, 8)= 0.0_rp
        posgp(3, 8)= 0.5_rp
        posgp(1, 9)= 0.0_rp
        posgp(2, 9)= 0.5_rp
        posgp(3, 9)= 0.5_rp
        posgp(1,10)= 0.0_rp
        posgp(2,10)= 0.0_rp
        posgp(3,10)= 0.5_rp
        posgp(1,11)= 1.0_rp/4.0_rp
        posgp(2,11)= 1.0_rp/4.0_rp
        posgp(3,11)= 1.0_rp/4.0_rp
        weigp(   1)= 1.0_rp/360.0_rp
        weigp(   2)= 1.0_rp/360.0_rp
        weigp(   3)= 1.0_rp/360.0_rp
        weigp(   4)= 1.0_rp/360.0_rp
        weigp(   5)= 1.0_rp/90.0_rp
        weigp(   6)= 1.0_rp/90.0_rp
        weigp(   7)= 1.0_rp/90.0_rp
        weigp(   8)= 1.0_rp/90.0_rp
        weigp(   9)= 1.0_rp/90.0_rp
        weigp(  10)= 1.0_rp/90.0_rp
        weigp(  11)= 4.0_rp/45.0_rp
     else if(ngaus==15) then
        posgp(1, 1)= 0.0_rp
        posgp(2, 1)= 0.0_rp
        posgp(3, 1)= 0.0_rp
        posgp(1, 2)= 1.0_rp
        posgp(2, 2)= 0.0_rp
        posgp(3, 2)= 0.0_rp
        posgp(1, 3)= 0.0_rp
        posgp(2, 3)= 1.0_rp
        posgp(3, 3)= 0.0_rp
        posgp(1, 4)= 0.0_rp
        posgp(2, 4)= 0.0_rp
        posgp(3, 4)= 1.0_rp
        posgp(1, 5)= 0.5_rp
        posgp(2, 5)= 0.0_rp
        posgp(3, 5)= 0.0_rp
        posgp(1, 6)= 0.5_rp
        posgp(2, 6)= 0.5_rp
        posgp(3, 6)= 0.0_rp
        posgp(1, 7)= 0.0_rp
        posgp(2, 7)= 0.5_rp
        posgp(3, 7)= 0.0_rp
        posgp(1, 8)= 0.0_rp
        posgp(2, 8)= 0.0_rp
        posgp(3, 8)= 0.5_rp
        posgp(1, 9)= 0.5_rp
        posgp(2, 9)= 0.0_rp
        posgp(3, 9)= 0.5_rp
        posgp(1,10)= 0.0_rp
        posgp(2,10)= 0.5_rp
        posgp(3,10)= 0.5_rp
        posgp(1,11)= 1.0_rp/3.0_rp
        posgp(2,11)= 1.0_rp/3.0_rp
        posgp(3,11)= 0.0_rp
        posgp(1,12)= 1.0_rp/3.0_rp
        posgp(2,12)= 0.0_rp
        posgp(3,12)= 1.0_rp/3.0_rp
        posgp(1,13)= 1.0_rp/3.0_rp
        posgp(2,13)= 1.0_rp/3.0_rp
        posgp(3,13)= 1.0_rp/3.0_rp
        posgp(1,14)= 0.0_rp
        posgp(2,14)= 1.0_rp/3.0_rp
        posgp(3,14)= 1.0_rp/3.0_rp
        posgp(1,15)= 1.0_rp/4.0_rp
        posgp(2,15)= 1.0_rp/4.0_rp
        posgp(3,15)= 1.0_rp/4.0_rp
        weigp(   1)= 17.0_rp/5040.0_rp
        weigp(   2)= 17.0_rp/5040.0_rp
        weigp(   3)= 17.0_rp/5040.0_rp
        weigp(   4)= 17.0_rp/5040.0_rp
        weigp(   5)=  2.0_rp/315.0_rp
        weigp(   6)=  2.0_rp/315.0_rp
        weigp(   7)=  2.0_rp/315.0_rp
        weigp(   8)=  2.0_rp/315.0_rp
        weigp(   9)=  2.0_rp/315.0_rp
        weigp(  10)=  2.0_rp/315.0_rp
        weigp(  11)=  9.0_rp/840.0_rp
        weigp(  12)=  9.0_rp/840.0_rp
        weigp(  13)=  9.0_rp/840.0_rp
        weigp(  14)=  9.0_rp/840.0_rp
        weigp(  15)= 16.0_rp/315.0_rp
     else if(ngaus==20) then                           ! Integrates P2
        posgp(1, 1)= 0.0_rp                                ! and quartic mono-
        posgp(2, 1)= 0.0_rp                                ! mials to avoid zero
        posgp(3, 1)= 0.0_rp                                ! weights at the
        posgp(1, 2)= 1.0_rp                                ! edges
        posgp(2, 2)= 0.0_rp
        posgp(3, 2)= 0.0_rp
        posgp(1, 3)= 0.0_rp
        posgp(2, 3)= 1.0_rp
        posgp(3, 3)= 0.0_rp
        posgp(1, 4)= 0.0_rp
        posgp(2, 4)= 0.0_rp
        posgp(3, 4)= 1.0_rp
        posgp(1, 5)= 1.0_rp/3.0_rp
        posgp(2, 5)= 0.0_rp
        posgp(3, 5)= 0.0_rp
        posgp(1, 6)= 2.0_rp/3.0_rp
        posgp(2, 6)= 0.0_rp
        posgp(3, 6)= 0.0_rp
        posgp(1, 7)= 2.0_rp/3.0_rp
        posgp(2, 7)= 1.0_rp/3.0_rp
        posgp(3, 7)= 0.0_rp
        posgp(1, 8)= 1.0_rp/3.0_rp
        posgp(2, 8)= 2.0_rp/3.0_rp
        posgp(3, 8)= 0.0_rp
        posgp(1, 9)= 0.0_rp
        posgp(2, 9)= 2.0_rp/3.0_rp
        posgp(3, 9)= 0.0_rp
        posgp(1,10)= 0.0_rp
        posgp(2,10)= 1.0_rp/3.0_rp
        posgp(3,10)= 0.0_rp
        posgp(1,11)= 0.0_rp
        posgp(2,11)= 0.0_rp
        posgp(3,11)= 1.0_rp/3.0_rp
        posgp(1,12)= 2.0_rp/3.0_rp
        posgp(2,12)= 0.0_rp
        posgp(3,12)= 1.0_rp/3.0_rp
        posgp(1,13)= 0.0_rp
        posgp(2,13)= 2.0_rp/3.0_rp
        posgp(3,13)= 1.0_rp/3.0_rp
        posgp(1,14)= 0.0_rp
        posgp(2,14)= 0.0_rp
        posgp(3,14)= 2.0_rp/3.0_rp
        posgp(1,15)= 1.0_rp/3.0_rp
        posgp(2,15)= 0.0_rp
        posgp(3,15)= 2.0_rp/3.0_rp
        posgp(1,16)= 0.0_rp
        posgp(2,16)= 1.0_rp/3.0_rp
        posgp(3,16)= 2.0_rp/3.0_rp
        posgp(1,17)= 1.0_rp/3.0_rp
        posgp(2,17)= 1.0_rp/3.0_rp
        posgp(3,17)= 0.0_rp
        posgp(1,18)= 1.0_rp/3.0_rp
        posgp(2,18)= 0.0_rp
        posgp(3,18)= 1.0_rp/3.0_rp
        posgp(1,19)= 1.0_rp/3.0_rp
        posgp(2,19)= 1.0_rp/3.0_rp
        posgp(3,19)= 1.0_rp/3.0_rp
        posgp(1,20)= 0.0_rp
        posgp(2,20)= 1.0_rp/3.0_rp
        posgp(3,20)= 1.0_rp/3.0_rp
        w1 = 383.0_rp/2400.0_rp
        w2 = 1.0_rp/240.0_rp - w1
        w3 = 3.0_rp/80.0_rp  - w2
        weigp(   1)= w1
        weigp(   2)= w1
        weigp(   3)= w1
        weigp(   4)= w1
        weigp(   5)= w2
        weigp(   6)= w2
        weigp(   7)= w2
        weigp(   8)= w2
        weigp(   9)= w2
        weigp(  10)= w2
        weigp(  11)= w2
        weigp(  12)= w2
        weigp(  13)= w2
        weigp(  14)= w2
        weigp(  15)= w2
        weigp(  16)= w2
        weigp(  17)= w3
        weigp(  18)= w3
        weigp(  19)= w3
        weigp(  20)= w3
     else
        istop=1
     end if
  end if
!
! Errors
!
  if(istop==1) call runend('RUTCLO: NOT AVAILABLE INTEGRATION RULE')

end subroutine rutclo


subroutine  VEGRAD (TIME,RNETV,SWAVEV,TZERO)
  use simsphere_mod
  implicit none

  real :: TIME, RNETV, SWAVEV, TZERO
  real :: t1, TZERO5, TZERO4

!      INCLUDE 'modvars.h'

  if (eq(time,0.0)) then ! Initialize
    TAF = otemp
    TF =  otemp
    TG =  otemp
    t1 = atemp
    TA = ATEMP
!	QA = QD(1)
    QAF = QD(1)
  end if

! **  Calculate incident solar flux at top of the canopy (SOL)

  SOL = SWAVE / ( 1 - ALBDOE )

! **

  RSG = SOL * ( 1 - SIGF ) * ( 1 - ALBG ) / ( 1 - SIGF * ALBG * ALBF )

  RSF = SOL * ( 1 - ALBF ) * SIGF * ( 1 + ALBG * ( 1 - SIGF ) / ( 1 - SIGF * ALBF * ALBG ) )

! **

  RLG = ( 1 - SIGF ) * EPSI * ( LWDN - SIGMA * TG**4 ) /         &
           ( 1 - SIGF * ( 1 - EPSF ) * ( 1 - EPSI ) ) -          &
           EPSI * EPSF * SIGF * SIGMA * ( TG**4 - TF**4 ) /      &
           ( 1 - SIGF * ( 1 - EPSF ) * ( 1 - EPSI ) )

  RLF = SIGF * ( EPSF * ( LWDN - SIGMA * TF**4 ) +               &
           EPSF * EPSI * SIGMA * ( TG**4 - TF**4) /              &
           ( 1 - SIGF * ( 1 - EPSF ) * ( 1 - EPSI ) ) ) +        &
           SIGF * ( 1 - SIGF ) * ( 1- EPSI ) * ( EPSF ) *        &
           ( LWDN - SIGMA * TF**4 ) / ( 1 - SIGF *               &
           ( 1 - EPSI ) * ( 1 - EPSF ) )

! **  Note that the radiometric temperature at the surfce is denoted
! **  by TZERO and is the equivalent to OTEMP in the bare soil mode.

  TZERO5 = (1 - SIGF ) * EPSI * TG**4 + EPSF * SIGF * TF**4
  TZERO5 = TZERO5**0.25

  TZERO4 = LWDN - RLG - RLF
  TZERO4 = TZERO4 / ( 1 * SIGMA )
  TZERO = TZERO4**0.25

  RNETG = RLG + RSG
  RNETF = RLF + RSF
  RNETV = RNETG + RNETF

! **  Set temperature and humidity variables.

  if (rnetf <= 0.0) then ! Set value since TA set to T1 (Vel)
    TAF = ta ! Set in Vel
    TF =  otemp
    TG =  otemp
!	TA = ATEMP
!	QA = QD(1)
    QAF = QD(1)
  end if

!
  SWAVEV = (RSG + RSF)

 return
end


MODULE GravitySolutionModule_Newtonian_PointMass

  USE KindModule, ONLY: &
    DP, Zero, One
  USE UnitsModule, ONLY: &
    GravitationalConstant
  USE ProgramHeaderModule, ONLY: &
    nDOFX
  USE ReferenceElementModuleX, ONLY: &
    NodesLX_q
  USE ReferenceElementModuleX_Lagrange, ONLY: &
    LX_L2G
  USE MeshModule, ONLY: &
    MeshX
  USE GeometryFieldsModule, ONLY: &
    CoordinateSystem, &
    iGF_Phi_N, &
    nGF

  IMPLICIT NONE
  PRIVATE

  PUBLIC :: ComputeGravitationalPotential

CONTAINS

  SUBROUTINE ComputeGravitationalPotential &
    ( iX_B0, iX_E0, iX_B1, iX_E1, G, Mass )

    INTEGER, INTENT(in)     :: &
      iX_B0(3), iX_E0(3), iX_B1(3), iX_E1(3)
    REAL(DP), INTENT(inout) :: &
      G(1:,iX_B1(1):,iX_B1(2):,iX_B1(3):,1:)
    REAL(DP), INTENT(in)    :: &
      Mass

    SELECT CASE ( TRIM( CoordinateSystem ) )

      CASE ( 'CARTESIAN' )

        CALL ComputeGravitationalPotential_CARTESIAN &
               ( iX_B0, iX_E0, iX_B1, iX_E1, G, Mass )

      CASE ( 'SPHERICAL' )

        CALL ComputeGravitationalPotential_SPHERICAL &
               ( iX_B0, iX_E0, iX_B1, iX_E1, G, Mass )

      CASE ( 'CYLINDRICAL' )

        CALL ComputeGravitationalPotential_CYLINDRICAL &
               ( iX_B0, iX_E0, iX_B1, iX_E1, G, Mass )

      CASE DEFAULT

        WRITE(*,*)
        WRITE(*,'(A5,A27,A)') &
          '', 'Invalid Coordinate System: ', TRIM( CoordinateSystem )
        STOP

    END SELECT

  END SUBROUTINE ComputeGravitationalPotential

  SUBROUTINE ComputeGravitationalPotential_CARTESIAN &
    ( iX_B0, iX_E0, iX_B1, iX_E1, G, Mass )

    INTEGER, INTENT(in)     :: &
      iX_B0(3), iX_E0(3), iX_B1(3), iX_E1(3)
    REAL(DP), INTENT(inout) :: &
      G(1:,iX_B1(1):,iX_B1(2):,iX_B1(3):,1:)
    REAL(DP), INTENT(in)    :: &
      Mass

  END SUBROUTINE ComputeGravitationalPotential_CARTESIAN

  SUBROUTINE ComputeGravitationalPotential_SPHERICAL &
    ( iX_B0, iX_E0, iX_B1, iX_E1, G, Mass )

    INTEGER, INTENT(in)     :: &
      iX_B0(3), iX_E0(3), iX_B1(3), iX_E1(3)
    REAL(DP), INTENT(inout) :: &
      G(1:,iX_B1(1):,iX_B1(2):,iX_B1(3):,1:)
    REAL(DP), INTENT(in)    :: &
      Mass

    INTEGER  :: iX1, iX2, iX3, iNodeX
    REAL(DP) :: XC, dX, xL_q, xG_q
    REAL(DP) :: G_L(nDOFX,nGF)

    DO iX3 = iX_B1(3), iX_E1(3)
      DO iX2 = iX_B1(2), iX_E1(2)
        DO iX1 = iX_B1(1), iX_E1(1)

          XC = MeshX(1) % Center(iX1)
          dX = MeshX(1) % Width (iX1)

          DO iNodeX = 1, nDOFX

            xL_q = NodesLX_q(1,iNodeX)

            xG_q = XC + dX * xL_q

            ! --- Compute Newtonian Potential

            G_L(iNodeX,iGF_Phi_N) = - GravitationalConstant * Mass / xG_q

          END DO

          CALL DGEMV &
                 ( 'N', nDOFX, nDOFX, One, LX_L2G, nDOFX, &
                   G_L(:,iGF_Phi_N), 1, Zero, G(:,iX1,iX2,iX3,iGF_Phi_N), 1 )

          END DO
        END DO
      END DO

  END SUBROUTINE ComputeGravitationalPotential_SPHERICAL

  SUBROUTINE ComputeGravitationalPotential_CYLINDRICAL &
    ( iX_B0, iX_E0, iX_B1, iX_E1, G, Mass )

    INTEGER, INTENT(in)     :: &
      iX_B0(3), iX_E0(3), iX_B1(3), iX_E1(3)
    REAL(DP), INTENT(inout) :: &
      G(1:,iX_B1(1):,iX_B1(2):,iX_B1(3):,1:)
    REAL(DP), INTENT(in)    :: &
      Mass

  END SUBROUTINE ComputeGravitationalPotential_CYLINDRICAL

END MODULE GravitySolutionModule_Newtonian_PointMass


!!# SUBROUTINE MODULE: <SUB_levQuadrature_LMLQ>
MODULE SUB_levQuadrature_LMLQ

!!## PURPOSE
!! Generate the Level Symmetric (LQ) quadrature sets in
!! Lewis and Miller's "Computational Methods of Neutron
!! Transport", 1993, American Nuclear Society.

!!## EXTERNAL KINDS
USE KND_IntrinsicTypes,ONLY: &                !!((01-A-KND_IntrinsicTypes.f90))
  KIND_Rsp,KIND_Rdp                           !!((01-A-KND_IntrinsicTypes.f90))

!!## EXTERNAL PARAMETERS
USE PAR_Constants_Rdp,ONLY: c_2               !!((02-A-PAR_Constants_Rdp.f90))

!!## EXTERNAL PROCEDURES
USE SUB_levQuadratureReflect                  !!((07-B-SUB_levQuadratureReflect.f90))
USE SUB_levQuadratureNormalize                !!((07-B-SUB_levQuadratureNormalize.f90))
USE FUN_NEARLOC                               !!((06-A-FUN_NEARLOC.f90))
USE FUN_Error                                 !!((04-A-FUN_Error.f90))
USE FUN_IsError                               !!((05-A-FUN_IsError.f90))

!!## DEFAULT IMPLICIT
IMPLICIT NONE

!!## DEFAULT ACCESS
PRIVATE

!!## PROCEDURE LISTING
INTERFACE levQuadrature_LMLQ
 MODULE PROCEDURE levQuadrature_LMLQ_Rsp
 MODULE PROCEDURE levQuadrature_LMLQ_Rdp
END INTERFACE

!!## PUBLIC ACCESS LIST
PUBLIC :: levQuadrature_LMLQ

!!## MODULE PROCEDURES
CONTAINS

!!### PURE SUBROUTINE: <levQuadrature_LMLQ_Rsp>
PURE SUBROUTINE levQuadrature_LMLQ_Rsp( N,xa,xp,wa,wp,Nm )
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "08-B-SUB_levQuadrature_LMLQ.f90.hdr"
!!--begin--
INCLUDE "08-B-SUB_levQuadrature_LMLQ.f90.bdy"
!!--end--
END SUBROUTINE

!!### PURE SUBROUTINE: <levQuadrature_LMLQ_Rdp>
PURE SUBROUTINE levQuadrature_LMLQ_Rdp( N,xa,xp,wa,wp,Nm )
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "08-B-SUB_levQuadrature_LMLQ.f90.hdr"
!!--begin--
INCLUDE "08-B-SUB_levQuadrature_LMLQ.f90.bdy"
!!--end--
END SUBROUTINE

END MODULE


! multigrid for constant ceoefficient u - l^2 u'' = v with Neumann BCs
! on uniform, square nodal grids
module mgrelax
  implicit none
contains

  subroutine warning()
    integer code
    code = 0
    return
  end subroutine warning

 subroutine restrictnc(fine,coarse,nfx,nfy,ncx,ncy)
    ! restriction : full weighting
    integer nfx,nfy,ncx,ncy
    real(kind=8) :: fine(0:nfx+1,0:nfy+1)
    real(kind=8) :: coarse(0:ncx+1,0:ncy+1), t

    integer i,j, ii, jj
    !ensure that nf = 2*(nc)
    if (nfx .ne. 2*(ncx)) then
       write(*,*) ' nfx =  != 2*(ncx)'
       stop
    end if
    if (nfy .ne. 2*(ncy)) then
       write(*,*) ' nfx =  != 2*(ncx) '
       stop
    end if

!    write(*,*) 'in restrict'

    coarse(0,:) = 0.0
    coarse(ncx+1,:) = 0.0
    coarse(:,0) = 0.0
    coarse(:,ncy+1) = 0.0
     do j = 1, ncy
        do i = 1, ncx
          ii = 2*i
          jj = 2*j
          t = fine(ii,jj) + fine(ii,jj+1) + fine(ii+1,jj) + fine(ii+1,jj+1)
          coarse(i,j) = t / 4.0

       end do
    end do
    return
  end subroutine restrictnc

  subroutine prolongnc(fine,coarse,nfx,nfy,ncx,ncy)
    !prolongation : linear interpolation from coarse to fine, nodal
    integer nfx,nfy,ncx,ncy
    real(kind=8) :: fine(0:nfx+1,0:nfy+1)
    real(kind=8) :: coarse(0:ncx+1,0:ncy+1)

    integer i,j, ii, jj
    !ensure that nf = 2*(nc)
    if (nfx .ne. 2*(ncx)) then
       write(*,*) ' nfx =  != 2*(ncx) +1 '
       stop
    end if

!    write(*,*) 'in prolong'
    if (nfy .ne. 2*(ncy)) then
       write(*,*) ' nfx =  != 2*(ncx) +1 '
       stop
    end if

    fine(nfx,nfy) = coarse(ncx,ncy)
    do j = 1, ncy
       do i = 1, ncx
          ii = 2*i
          jj = 2*j
          fine(ii,jj) = coarse(i,j)
          fine(ii+1,jj) = coarse(i,j)
          fine(ii,jj+1) = coarse(i,j)
          fine(ii+1,jj+1) = coarse(i,j)
       end do
    end do
    return
  end subroutine prolongnc

  subroutine apply(u,lu,a,ni,nj)
    integer :: ni,nj,i,j
    real(kind=8) :: a
    real(kind=8) :: u(0:ni+1,0:nj+1)
    real(kind=8) :: lu(0:ni+1,0:nj+1)
    real(kind=8) :: b

!    write(*,*) 'in apply'
    !Neumann BC
    u(0,:) =  u(2,:)
    u(ni+1,:) =  u(ni-1,:)
    u(:,0) =  u(:,2)
    u(:,nj+1) =  u(:,nj-1)
    lu(0,:) = 0.0
    lu(ni+1,:) = 0.0
    lu(:,nj+1) = 0.0
    lu(:,0) = 0.0

     do j = 1, nj
        do i = 1, ni
           lu(i,j) = u(i,j)*(1+4.0*a) &
                - a * (u(i+1,j) +  u(i-1,j) + u(i,j-1) +  u(i,j+1))

        end do
     end do
     i = 0
     return
  end subroutine apply

  subroutine resid(u,v,r,a,ni,nj)
    integer :: ni,nj,i,j
    real(kind=8) :: a
    real(kind=8) :: u(0:ni+1,0:nj+1)
    real(kind=8) :: v(0:ni+1,0:nj+1)
    real(kind=8) :: r(0:ni+1,0:nj+1)
    real(kind=8) :: b

!    write(*,*) 'in resid'

    !Neumann BC
    u(0,:) =  u(2,:)
    u(ni+1,:) =  u(ni-1,:)
    u(:,0) =  u(:,2)
    u(:,nj+1) =  u(:,nj-1)
    r(0,:) = 0.0
    r(ni+1,:) = 0.0
    r(:,nj+1) = 0.0
    r(:,0) = 0.0

     do j = 1, nj
        do i = 1, ni
           r(i,j) = v(i,j) - (u(i,j)*(1+4.0*a) &
                - a * (u(i+1,j) +  u(i-1,j) + u(i,j-1) +  u(i,j+1)))

        end do
     end do
     return
  end subroutine resid

  subroutine gsrb(u,v,a,ni,nj,n)

    ! n gsrb passes. u is assumed to have one layer of ghost cells,
    ! a = lambda**2 / dx **2
    integer :: n,  ni, nj
    real(kind=8) :: u(0:ni+1,0:nj+1)
    real(kind=8) :: v(0:ni+1,0:nj+1)
    real(kind=8) :: a

    integer :: iter, i, j , color

!    write (*,*) 'in gsrb, n =', n

    do iter = 1,n

       !Neumann BC
       u(0,:) =  u(2,:)
       u(ni+1,:) =  u(ni-1,:)
       u(:,0) =  u(:,2)
       u(:,nj+1) =  u(:,nj-1)

       ! red
       do j = 1, nj
          i = 1 +  mod(j,2)
          do while (i .le. ni)
             u(i,j) = (v(i,j) + a * (u(i+1,j) +  u(i-1,j) &
                  +  u(i,j + 1) + u(i,j -1)))/ (1.0 + 4.0*a)

             i = i + 2
          end do
       end do

       ! black
       do j = 1, nj
          i = 1 +  mod(j + 1,2)

          do while (i .le. ni)
             u(i,j) = (v(i,j) + a * (u(i+1,j) +  u(i-1,j) &
                  +  u(i,j + 1) + u(i,j -1)))/ (1.0 + 4.0*a)

             i = i + 2

          end do
       end do

    end do
    return
  end subroutine gsrb

  recursive subroutine vcycle(u,v,a,nx,ny,depth,nsmooth)

    integer :: nx, ny, nsmooth, depth
    real(kind=8) :: u(0:nx+1,0:ny+1)
    real(kind=8) :: v(0:nx+1,0:ny+1)
    real(kind=8) :: a, resnorm

    integer ncx,ncy,i,j
    real(kind=8) :: ac ! a on the coarse mesh
    real(kind=8), allocatable :: du(:,:)
    real(kind=8), allocatable :: res(:,:)
    real(kind=8), allocatable :: lu(:,:)
    real(kind=8), allocatable :: duc(:,:)
    real(kind=8), allocatable :: resc(:,:)

!    write (*,*) 'vcycle -- depth = ', depth
!    write(*,*) '    nsmooth = ', nsmooth

    if (( mod(nx,2) .ne. 0) .or. ( mod(ny,2) .ne. 0 )) then
       ! no more coarsenings possible
!       write(*,*) 'at bottom: nx,ny = ', nx, ny
!       write(*,*) 'mod(nx,2) = ', mod(nx,2)
!       write(*,*) 'mod(ny,2) = ', mod(ny,2)
       call gsrb(u,v,a,nx,ny,nsmooth*nx*ny)
       return
    end if

    ncx = (nx + 1)/2
    ncy = (ny + 1)/2

    if (depth > 1) then

       allocate(lu(0:nx+1,0:ny+1))
       allocate(du(0:nx+1,0:ny+1))
       allocate(res(0:nx+1,0:ny+1))
       allocate(duc(0:ncx+1,0:ncy+1))
       allocate(resc(0:ncx+1,0:ncy+1))

       call gsrb(u,v,a,nx,ny,nsmooth)
       call resid(u,v,res,a,nx,ny)
       call restrictnc(res,resc,nx,ny,ncx,ncy)
       ac = a / 4.0
       duc = 0.0
       call vcycle(duc , resc, ac, ncx, ncy,  depth -1, nsmooth)
       call prolongnc(du, duc , nx, ny,  ncx, ncy )
       u = u + du
       call gsrb(u,v,a,nx,ny,nsmooth)
    else
       ! at the bottom of the cycle
       call gsrb(u,v,a,nx,ny,nsmooth*nx*ny)
    end if
    return
  end subroutine vcycle

end module mgrelax


C
C      **********************************************************************
C      ********************* SUBROUTINE CHOL  *******************************
C      **********************************************************************
C
       SUBROUTINE CHOL(A,N,U,NULLTY,NA,NU,IFAULT)
C
C      *      ALGORITHM AS 6 J.R.STATIST.SOC.C.(1968) VOL.17, NO.2          *
C      *                                                                    *
C      *      GIVEN A SYMMETRIC MATRIX OF ORDER N AS A LOWER TRIANGLE       *
C      *      IN A( ),  CALCULATE AN UPPER TRIANGLE, U( ), SUCH THAT        *
C      *      UPRIME*U=A. U( ) MAY COINCIDE WITH A( ). A( ) MUST BE         *
C      *      POSITIVE SEMIDEFINITE.                                        *
C      *      ETA IS SET TO MULTIPLYING FACTOR DETERMINING THE              *
C      *      EFFECTIVE  ZERO FOR PIVOT.                                    *
C      *      NULLTY IS RETURNED AS NO. OF EFFECTIVE ZERO PIVOTS.           *
C      *      IFAULT IS RETURNED AS 1,IF N.LE.0, 2,IF A( ) IS NOT           *
C      *      POSITIVE SEMI-DEFINITE WITHIN THE TOLERANCE BY ETA.           *
C      *      OTHERWISE ZERO.                                               *
C
C      *        NOTE : VARIABLES NA,NU, HAVE BEEN ADDED TO THE              *
C      *               ARGUMENT LIST AND USED TO DIMENSION TO ARRAYS        *
C      *               A AND U, RESPECTIVELY. (BY WOLYNETZ (1979))          *
C
       IMPLICIT REAL*8 (A-H,O-Z), INTEGER (I-N)

       DIMENSION A(NA),U(NU)
C
       DATA ETA /1.0E-9/
C
C      *       THE VALUE OF ETA WILL DEPEND ON THE WORD LENGTH OF           *
C      *       THE COMPUTER BEING USED.                                     *
C
       IFAULT=1
       IF(N.GT.0) THEN
          IFAULT=2
          NULLTY=0
          J=1
          K=0

          DO 10 ICOL=1,N
             L=0

             DO 11 IROW=1,ICOL
                K=K+1
                W=A(K)
                M=J

                DO 12 I=1,IROW
                   L=L+1
                   IF(I.EQ.IROW) GOTO 13
                   W=W-U(L)*U(M)
                   M=M+1
   12           CONTINUE

   13           IF(IROW.EQ.ICOL) GOTO 14
                IF(U(L).EQ.0.0) THEN
                   U(K) = 0.0
                ELSE
                   U(K)=W/U(L)
                ENDIF
   11        CONTINUE

   14        IF(DABS(W).GE.DABS(ETA*A(K))) THEN
                IF(W.LT.0.0) GOTO 100
                U(K)=DSQRT(W)
             ELSE
                U(K)=0.0
                NULLTY=NULLTY+1
             ENDIF
             J=J+ICOL
   10     CONTINUE

          IFAULT=0

       ENDIF
  100  RETURN
       END


#include "eiscor.h"
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! ZUFTDB (Zomplex Unitary hessenberg Factored Two by two Diagonal Block)
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! This routine computes a two by two diagonal block of a unitary upper
! hessenberg matrix that is stored as a product of givens rotations
! and a complex diagonal matrix.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! INPUT VARIABLES:
!
!  N               INTEGER
!                    dimension of matrix
!
!  K               INTEGER
!                    index of the diagonal block
!
!  Q               REAL(8) array of dimension (3*(N-1))
!                    array of generators for givens rotations
!                    generators must be orthogonal to working precision
!
!  D               REAL(8) array of dimension (2*N)
!                    array of generators for complex diagonal matrix
!                    on output contains the eigenvalues
!
! OUTPUT VARIABLES:
!
!  H              COMPLEX(8) array of dimension (2,2)
!                   on exit contains the desired 2x2 block
!
!  INFO           INTEGER
!                   INFO = 0 implies successful computation
!                   INFO = -1 implies N is invalid
!                   INFO = -2 implies K is invalid
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine ZUFTDB(N,K,Q,D,H,INFO)

  implicit none

  ! input variables
  integer, intent(in) :: N, K
  integer, intent(inout) :: INFO
  real(8), intent(in) :: Q(3*(N-1)), D(2*N)
  complex(8), intent(inout) :: H(2,2)

  ! compute variables
  integer :: strt

  ! initialize INFO
  INFO = 0

  ! check input in debug mode
  if (DEBUG) then

    ! check N
    call IARNAN(N,INFO)
    if (INFO.NE.0) then
      call UARERR(__FILE__,__LINE__,"N is invalid",INFO,-1)
      return
    end if
    call IARINF(N,INFO)
    if (INFO.NE.0) then
      call UARERR(__FILE__,__LINE__,"N is invalid",INFO,-1)
      return
    end if
    if (N < 2) then
      INFO = -1
      call UARERR(__FILE__,__LINE__,"N must be at least 2",INFO,INFO)
      return
    end if

    ! check K
    if ((K < 1).OR.(K > N-1)) then
      INFO = -2
      call UARERR(__FILE__,__LINE__,"K must 1 <= K <= N-1",INFO,INFO)
      return
    end if

  end if

  ! set index
  strt = 3*(K-1)

  ! initialize H
  H(1,1) = cmplx(Q(strt+1),Q(strt+2),kind=8)
  H(2,1) = cmplx(Q(strt+3),0d0,kind=8)
  H(1,2) = -H(2,1)
  H(2,2) = conjg(H(1,1))

  ! apply upper rotation
  if (K > 1) then
    H(1,:) = H(1,:)*cmplx(Q(strt-2),-Q(strt-1),kind=8)
    end if

  ! apply lower rotation
  if (K < (N-1)) then
    H(:,2) = H(:,2)*cmplx(Q(strt+4),Q(strt+5),kind=8)
  end if

  ! apply diagonal
  strt = 2*(k-1)
  H(:,1) = H(:,1)*cmplx(D(strt+1),D(strt+2),kind=8)
  H(:,2) = H(:,2)*cmplx(D(strt+3),D(strt+4),kind=8)

end subroutine ZUFTDB


module StructuralMaterialM
  use UtilitiesM
  use PropertyM

  implicit none

  private
  public :: StructuralMaterialDT, structuralMaterial

  type :: StructuralMaterialDT
     real(rkind)                 :: young
     real(rkind)                 :: poissonCoef
     real(rkind)                 :: thermalCoef
     real(rkind), dimension(6,6) :: d
   contains
     procedure :: init
  end type StructuralMaterialDT

  interface structuralMaterial
     procedure :: constructor
  end interface structuralMaterial

contains

  type(StructuralMaterialDT) function constructor(young, poissonCoef, thermalCoef)
    implicit none
    real(rkind), intent(in) :: young
    real(rkind), intent(in) :: poissonCoef
    real(rkind), intent(in) :: thermalCoef
    call constructor%init(young, poissonCoef, thermalCoef)
  end function constructor

  subroutine init(this, young, poissonCoef, thermalCoef)
    implicit none
    class(StructuralMaterialDT), intent(inout) :: this
    real(rkind)                , intent(in)    :: young
    real(rkind)                , intent(in)    :: poissonCoef
    real(rkind)                , intent(in)    :: thermalCoef
    real(rkind)                                :: factor
    this%young       = young
    this%poissonCoef = poissonCoef
    this%thermalCoef = thermalCoef
    !Deformación plana:
    factor = young/((1+poissonCoef)*(1-2*poissonCoef))
    this%d(1,1) = factor*(1-poissonCoef)
    this%d(2,2) = factor*(1-poissonCoef)
    this%d(3,3) = factor*(1-poissonCoef)
    this%d(1,2) = factor*poissonCoef
    this%d(1,3) = factor*poissonCoef
    this%d(1,2) = factor*poissonCoef
    this%d(2,3) = factor*poissonCoef
    this%d(3,1) = factor*poissonCoef
    this%d(3,2) = factor*poissonCoef
    this%d(4,4) = factor*(1-2*poissonCoef)/2._rkind
    this%d(5,5) = factor*(1-2*poissonCoef)/2._rkind
    this%d(6,6) = factor*(1-2*poissonCoef)/2._rkind
  end subroutine init

end module StructuralMaterialM


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C       Written by: Anshuk Attri
C
C       Contact: contact@anshukattri.in
C       Website: www.anshukattri.in/research
C       GITHUB: github.com/aa-tree/
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

        SUBROUTINE DELTA_XPP_ENCKE(VTIME, VRHO, VSTATE,
     &VDIM, OSTATE)

        IMPLICIT NONE

        INCLUDE 'common.dat'

        INTEGER VDIM
        REAL*8 VTIME
        REAL*8 VSTATE(VDIM), OSTATE(VDIM), VRHO(VDIM)

!
!       SUMMARY:
!       This routine implements a part of Encke's formulation of the
!       n-body problem. The routine only returns delta_r at a particular
!       time.
!
!       See Reference: Fundamentals of Astrodynamics, Bate, Mueller, and
!       White, Dover Publications, pp-390-396
!

!       VARIABLES:
!
!       NAME             TYPE               DESCRIPTION
!
!       VTIME            INPUT(REAL*8)      The time at which Delta_r
!                                           is to be calculated.
!
!       VRHO(6)          INPUT(REAL*8)      The state vector rho.
!
!       VSTATE(6)        INPUT(REAL*8)      The state vector r.
!
!       VDIM             INPUT(INTEGER)     The dimension of the system.
!                                           Cannot be any value other
!                                           than 6.
!
!       OSTATE(6)        OUTPUT(REAL*8)     State vector containing the
!                                           value of delta_r.
!
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

        INTEGER  I, J

        REAL*8 R_STATE(VDIM), TEMP_PERT(3)
        REAL*8 MOD_R, MOD_RHO, Q_VAR
        REAL*8 TEMP1, SUM_B, TEMP_MOD
        REAL*8 MU_P, MU_J

        REAL*8 PERT_GRAV(3,MMAX)

        REAL*8 RJ(VDIM), RJI(VDIM)

!
!       Overriding the value of VDIM
!
        VDIM=6
!
!       Assign zereos to the output vector.
!

        DO I=1,VDIM
          OSTATE(I)=0.00D0
          R_STATE(I)=VSTATE(I)+VRHO(I)
         ! WRITE(*,*) R_STATE(I),VRHO(I),VSTATE(I)
        END DO

        DO I=1,3
          OSTATE(I)=VSTATE(I+3)
        END DO

C
C       Calculate mods of vectors r and rho. And then calculate q.
C

        CALL GET_VEC_MOD(R_STATE, MOD_R)
        CALL GET_VEC_MOD(VRHO, MOD_RHO)
C        WRITE(*,*) 'MOD_R', MOD_R
C        WRITE(*,*) 'MOD_RHO', MOD_RHO
C        PAUSE

        IF(MOD_RHO .NE. 0) THEN

            TEMP1=(MOD_R/MOD_RHO)**2.0D0

            Q_VAR=(1.0D0-TEMP1) ! (Holds the value of 2q)

!            WRITE(*,*) 'QVAR', Q_VAR
!            PAUSE

            TEMP1=-1.50D0

            CALL GETBINOMIAL_SUM(TEMP1, Q_VAR, SUM_B)

            CALL GET_MU(IPB, MU_P)

C
C       The primary body term of the Encke's formulation.
C

            DO I=1,3
              TEMP1=((1.0D0-SUM_B)*R_STATE(I))
              TEMP1=TEMP1-VSTATE(I)
              OSTATE(I+3)=(MU_P*TEMP1)/(MOD_RHO**3.0D0)
              !PERT_GRAV(I,PRB_ID)=OSTATE(I) !Assign for analysis.
            END DO

!
!       To get the term a_p
!

!
!       Gravitational Perturbations from the model.
!

            DO I=1,3
                TEMP_PERT(I)=0.0D0
            END DO
            DO J=1,MMAX

            IF(LIST_I(J,1) .NE. IPB) THEN

              CALL GET_POS_WRT_IBC(VTIME, LIST_I(J,1), RJ)

              DO I=1,VDIM
                  RJI(I)= R_STATE(I)-RJ(I)
              END DO

              CALL GET_VEC_MOD(RJI, TEMP_MOD)

              IF(TEMP_MOD .NE. 0 ) THEN

                      MU_J=0.D0
                      CALL GET_MU(LIST_I(J,1), MU_J)

                  DO I=1,3
                      TEMP1=(-1.0D0*MU_J)*RJI(I)
                      TEMP1=TEMP1/(TEMP_MOD**3.0D0)
                      TEMP_PERT(I)=TEMP_PERT(I)+TEMP1
                    !  PERT_GRAV(I,J)=TEMP1 ! Saving Perturbations for analysis.
                  END DO

              END IF

          END IF
          END DO

            DO I=1,3
                OSTATE(I+3)=TEMP_PERT(I)+OSTATE(I+3)
            END DO

        ELSE
            WRITE(*,*) 'Error in DELTA_XPP_ENCKE. Mod of the vector rho'
            WRITE(*,*) ' is zero.'

        END IF

        RETURN
        END


module init_data_module

  use bl_error_module
  use multifab_module
  use layout_module

  implicit none

  private

  public :: init_data

contains

  subroutine init_data(data,dx,plo,phi)

    type(multifab),   intent(inout) :: data
    double precision, intent(in   ) :: dx(data%dim)
    double precision, intent(in   ) :: plo(data%dim), phi(data%dim)

    integer                   :: lo(data%dim), hi(data%dim), ng, i
    double precision, pointer :: dp(:,:,:,:)

    ng = data%ng

    do i=1,nfabs(data)

       dp => dataptr(data,i)
       lo = lwb(get_box(data,i))
       hi = upb(get_box(data,i))

       select case(data%dim)
       case (2)
          call bl_error('We only support 3-D')
       case (3)
          call init_data_3d(lo,hi,ng,dx,dp,plo,phi)
       end select
    end do

  end subroutine init_data

  subroutine init_data_3d(lo,hi,ng,dx,cons,plo,phi)

    use advance_module ! For: irho imx imy imz iene.

    integer,          intent(in   ) :: lo(3),hi(3),ng
    double precision, intent(in   ) :: dx(3),plo(3),phi(3)
    double precision, intent(inout) :: cons(-ng+lo(1):hi(1)+ng,-ng+lo(2):hi(2)+ng,-ng+lo(3):hi(3)+ng,5)

    integer          :: i,j,k
    double precision :: xloc,yloc,zloc,rholoc,eloc,uvel,vvel,wvel,scale(3)

    double precision, parameter :: twopi = 2.0d0 * 3.141592653589793238462643383279502884197d0

    do i=1,3
       scale(i) = (phi(i)-plo(i))/twopi
    end do

    !$OMP PARALLEL DO PRIVATE(i,j,k,zloc,yloc,xloc,uvel,vvel,wvel,rholoc,eloc)
    do k=lo(3),hi(3)
       zloc = dfloat(k)*dx(3)/scale(3)
       do j=lo(2),hi(2)
          yloc = dfloat(j)*dx(2)/scale(2)
          do i=lo(1),hi(1)
             xloc = dfloat(i)*dx(1)/scale(1)

             uvel   = 1.1d4*sin(1*xloc)*sin(2*yloc)*sin(3*zloc)
             vvel   = 1.0d4*sin(2*xloc)*sin(4*yloc)*sin(1*zloc)
             wvel   = 1.2d4*sin(3*xloc)*cos(2*yloc)*sin(2*zloc)
             rholoc = 1.0d-3 + 1.0d-5*sin(1*xloc)*cos(2*yloc)*cos(3*zloc)
             eloc   = 2.5d9  + 1.0d-3*sin(2*xloc)*cos(2*yloc)*sin(2*zloc)

             cons(i,j,k,irho) = rholoc
             cons(i,j,k,imx)  = rholoc*uvel
             cons(i,j,k,imy)  = rholoc*vvel
             cons(i,j,k,imz)  = rholoc*wvel
             cons(i,j,k,iene) = rholoc*(eloc + (uvel**2+vvel**2+wvel**2)/2)

          enddo
       enddo
    enddo
    !$OMP END PARALLEL DO

  end subroutine init_data_3d

end module init_data_module


module extended
   use constants
   implicit none
   private

   public :: decode, encode

contains

   function decode(code) result(value)
      real(dp) :: value

      character(*), intent(in) :: code

      integer :: byte, bytes(10), bit, digit, sign, exponent
      real(dp) :: mantissa

      do byte = 1, 10
         bytes(byte) = ichar(code(byte:byte))
      end do

      sign = merge(-1, 1, btest(bytes(1), 7))
      mantissa = 0.0_dp
      exponent = -16383

      digit = 0
      do byte = 2, 1, -1
         do bit = 0, 5 + byte
            if (btest(bytes(byte), bit)) then
               exponent = exponent + 2 ** digit
            end if
            digit = digit + 1
         end do
      end do

      digit = 0
      do byte = 3, 10
         do bit = 7, 0, -1
            if (btest(bytes(byte), bit)) then
               mantissa = mantissa + 2.0_dp ** digit
            end if
            digit = digit - 1
         end do
      end do

      value = sign * mantissa * 2.0_dp ** exponent
   end function decode

   function encode(value) result(code)
      character(10) :: code

      real(dp), intent(in) :: value

      integer :: byte, bytes(10), bit, exponent
      real(dp) :: mantissa

      exponent = int(log(abs(value)) / log(2.0_dp))
      mantissa = abs(value) / 2.0_dp ** exponent
      exponent = exponent + 16383

      bytes = 0

      if (value .lt. 0) bytes(1) = ibset(bytes(1), 7)

      do byte = 2, 1, -1
         do bit = 0, 5 + byte
            if (modulo(exponent, 2) .eq. 1) then
               bytes(byte) = ibset(bytes(byte), bit)
            end if
            exponent = exponent / 2
         end do
      end do

      do byte = 3, 10
         do bit = 7, 0, -1
            if (mantissa .ge. 1.0_dp) then
               mantissa = mantissa - 1.0_dp
               bytes(byte) = ibset(bytes(byte), bit)
            end if
            mantissa = 2.0_dp * mantissa
         end do
      end do

      do byte = 1, 10
         code(byte:byte) = char(bytes(byte))
      end do
   end function encode
end module extended


program main
    implicit none
    character(3) c
    integer i, j, s
    do i = 1, 100
      s = 0
      j = i
      do while (j > 0)
        s = s + mod(j, 10)
        j = j / 10
      end do
      if (mod(i, s) == 0) then
        write(c, '(i3)') i
        print '(a)', adjustl(c)
      end if
    end do
end program


 SUBROUTINE stre02_1 (mat,e,stres,hyper,j)

 USE mat_dba, ONLY : mater,inte_cr

 ! computes the internal nodal forces  1D (truss elements)

 IMPLICIT NONE
 REAL (kind=8), INTENT(IN) :: e
 REAL (kind=8), INTENT(IN OUT) :: stres(:) !(1)S0 (2)S (3)? (4)Ep (5)BS (6)eps
 REAL (kind=8), INTENT(OUT) :: j
 TYPE (mater), POINTER :: mat
 LOGICAL, INTENT(IN) :: hyper
 !  local variables
 REAL (kind=8) stran,dsttr,dlamb,yistr,signo,efpst
 INTEGER (kind=4)  :: is,ik,i
 REAL (kind=8)  :: young,c0,c1,c2,c3,kinmod,kinsat,&
                        aprim,kinet,poiss
 LOGICAL :: plast

 !     evaluates incremental and total stress

 young = mat%prope(1)
 poiss = mat%prope(2)
 poiss = 1d0-2d0*poiss
 plast =  mat%matdef(3) > 1
 IF( plast )THEN
   is    =  mat%matdef(4)
   c0   = mat%propp(1)        !C0 constant or Initial Yield
   c1   = mat%propp(2)        !Efref or Hardening constant
   c2   = mat%propp(3)        !exponent
   c3   = mat%propp(4)        !residual flow stress
   ik   =  mat%matdef(5)      !kinematic hardening model
   SELECT CASE (ik)
   CASE (1)                     !KHNONE
     kinet = 0d0
   CASE (2)                     !KHLINE
     kinmod = mat%propp(6)*2.75d0  !????
     kinet = kinmod
   CASE (3)                     !KHSATU
     kinmod = mat%propp(6)*2.75d0  !????
     kinsat = mat%propp(7)*2.5d0   !????
   END SELECT
 END IF

 IF( hyper )THEN  !for hyper-elastic models
   IF( plast )THEN
     stran = e - stres(4)                   !trial elastic strain
     stres(2) = young*stran + stres(1)      !trial stress
   ELSE
     stres(2) = young*e + stres(1)          !elastic model
   END IF
 ELSE             !for hipo-elastic models
   stres(2) = young*e + stres(2)            !
 END IF

 IF ( plast ) THEN        ! plastic

   ! implicit analysis (last converged values)
   !stres(4:6) = stres(8:10)      !plastic strain, back stress, eq.pl.st
   !stres(7) = 0d0               !dlamb

   !  compute present yield stress
   efpst = stres(6)                         !initial equivalent plastic strain

   IF( is == 5 )THEN                          !iso-hard by points
     i = 1   !begin at first interval
     c0 = inte_cr (mat%chead%val,mat%chead%np,efpst,i)
     c1 = mat%chead%val(3,i)
     c0 = c0 - c1 * efpst
     CALL isoha14(2,yistr,aprim,efpst,c0,c1,c2,c3)
   ELSE                                       !iso-hard is analytical
     CALL isoha14(is,yistr,aprim,efpst,c0,c1,c2,c3)
   END IF

   signo = 1d0                                  !strain sign
   SELECT CASE ( ik ) !kinematic hardening model
   CASE (1) ! no hardening
     dsttr = ABS(stres(2)) - yistr       !yield function
     IF(stres(2) < 0d0) signo = -1d0
   CASE (2) ! linear kinematic hardening
     dsttr = ABS(stres(2)-stres(5)) - yistr       !yield function
     IF(stres(2)-stres(5) < 0d0) signo = -1d0
   CASE (3) ! saturation law for kinematic hardening
     dsttr = ABS(stres(2)-stres(5)) - yistr       !yield function
     IF(stres(2)-stres(5) < 0d0) signo = -1d0
     kinet = kinmod - kinsat *stres(5)*signo      !modify kin-hard modulus
   END SELECT
   !
   IF(dsttr > 0) THEN                          !if greater than zero
     !IF( stres(2) < 0d0 )THEN
     !  print *,'first'
     !END IF
     DO
       dlamb = dsttr / (young+aprim+kinet)     !consistency param.
       stres(4) = stres(4) + dlamb*signo              !plastic strain
       stres(5) = stres(5) + dlamb*kinet*signo        !back stress
       stres(6) = stres(6) + dlamb                    !effective plastic strain
       stres(2) = stres(2) - young*dlamb*signo        !stress
       yistr = yistr+aprim*dlamb
       dsttr = ABS(stres(2)-stres(5))-yistr
       IF(ABS(dsttr/yistr) < 0.001 ) EXIT
     END DO
     !stres(7) = dlamb                               !implicit analysis
   END IF
   stran = stres(2)/young  !elastic strain ?
 END IF
 j = 1d0 + stran*poiss     !jacobian
 RETURN
 END SUBROUTINE stre02_1


subroutine core_exc_cor(xc, ispin, cval, nx, ny, nz, dv, rho, rho_s, tau, rj, grho, rlrho, rho_nlcc, vxc, vxc_s, exc, tot_exc)
  implicit none
  character(20), intent(in) :: xc
  integer, intent(in) :: ispin ! ispin=0(nonmag) =1(mag)
  real(8), intent(in) :: cval
  integer, intent(in) :: nx, ny, nz
  real(8), intent(in) :: dv
  real(8), intent(in) :: rho(nx, ny, nz)
  real(8), intent(in) :: rho_s(nx, ny, nz, 2)
  real(8), intent(in) :: tau(nx, ny, nz)
  real(8), intent(in) :: rj(nx, ny, nz, 3)
  real(8), intent(in) :: grho(nx, ny, nz, 3)
  real(8), intent(in) :: rlrho(nx, ny, nz)
  real(8), intent(in) :: rho_nlcc(nx, ny, nz)
  real(8), intent(out) :: vxc(nx, ny, nz) ! lda
  real(8), intent(out) :: vxc_s(nx, ny, nz, 2) !lsda
  real(8), intent(out) :: exc(nx, ny, nz)
  real(8), intent(out) :: tot_exc ! sum(exc)

  select case(xc)
  case("pz")
    if (ispin == 0) then
      call core_exc_cor_pz() !lda
    else
      call core_exc_cor_pz_spin() !lsda
    endif
  case("pbe")
    call core_exc_cor_pbe()
  case("lda")
    call core_exc_cor_lda()
  case("tbmbj")
    call core_exc_cor_tbmbj()
  case("tpss")
    call core_exc_cor_tpss()
  end select

#define UNUSED_VARIABLE(VAR) if(.false.) call salmon_unusedvar(VAR)
  UNUSED_VARIABLE(cval)
  UNUSED_VARIABLE(rho_s)
  UNUSED_VARIABLE(tau)
  UNUSED_VARIABLE(rj)
  UNUSED_VARIABLE(grho)
  UNUSED_VARIABLE(rlrho)
  UNUSED_VARIABLE(rho_nlcc)
  UNUSED_VARIABLE(vxc_s)

  return

contains

  Subroutine core_exc_cor_pz()
    implicit none
    real(8),parameter :: Pi=3.141592653589793d0
    real(8),parameter :: gammaU=-0.1423d0,beta1U=1.0529d0
    real(8),parameter :: beta2U=0.3334d0,AU=0.0311d0,BU=-0.048d0
    real(8),parameter :: CU=0.002d0,DU=-0.0116d0
    real(8),parameter :: const = 0.75d0*(3d0/(2d0*pi))**(2d0/3d0)
    real(8) :: trho,rs,rssq,rsln
    real(8) :: de_xc_drho, e_xc
    integer :: ix, iy, iz

    tot_exc = 0.0
    do iz = 1, nz
      do iy = 1, ny
        do ix = 1, nx
          trho = rho(ix, iy, iz) + 1d-10
          rs=(3d0/(4*Pi*trho))**(1d0/3d0)
          e_xc=-const/rs
          de_xc_drho=e_xc/(3*trho)
          if (rs>1d0) then
            rssq=sqrt(rs)
            e_xc=e_xc+gammaU/(1d0+beta1U*rssq+beta2U*rs)
            de_xc_drho=de_xc_drho+gammaU*(0.5d0*beta1U*rssq+beta2U*rs)/(3*trho)/(1+beta1U*rssq+beta2U*rs)**2
          else
            rsln=log(rs)
            e_xc=e_xc+AU*rsln+BU+CU*rs*rsln+DU*rs
            de_xc_drho=de_xc_drho-rs/(3*trho)*(AU/rs+CU*(rsln+1)+DU)
          endif

          exc(ix,iy,iz)=e_xc*trho
          vxc(ix,iy,iz)=e_xc+trho*de_xc_drho

          tot_exc = tot_exc + exc(ix, iy, iz) * dv
        end do
      end do
    end do

    return
  End Subroutine core_exc_cor_pz

  subroutine core_exc_cor_pz_spin()
    implicit none
    return
  end subroutine core_exc_cor_pz_spin

  subroutine core_exc_cor_pbe()
    implicit none
    return
  end subroutine core_exc_cor_pbe

  subroutine core_exc_cor_lda()
    implicit none
    return
  end subroutine core_exc_cor_lda

  subroutine core_exc_cor_tbmbj()
    implicit none
    return
  end subroutine core_exc_cor_tbmbj

  subroutine core_exc_cor_tpss()
    implicit none
    return
  end subroutine core_exc_cor_tpss

end subroutine


      real function depend(xu,xl,a,b,cdep,phi,theta,ktrato,qostar)
c
c     + + + PURPOSE + + +
c     Calculates for a segment of an Overland Flow Element that
c     has deposition at the beginning of the segment - where that
c     deposition ends - using the analytic solution to the
c     deposition equation.
c
c     Called (once) from subroutine ROUTE
c     Author(s): G. Foster, M. Nearing, J. Ascough, D. Flanagan
c     Reference in User Guide:
c
c     Changes: 1) TMPVR1 added to eliminate redundant calculations.
c              2) ITMPV1 added and moved outside the do-loop to reduce
c                 the number of calls to ABS, and to substitute an
c                 integer comparison (.NE.) for a floating-point one.
c              3) KTRATO & QOSTAR added to argument list so that
c                 common blocks ENDS1 & INFCO1 do not need to be ref-
c                 erenced.
c              4) MXPLAN is never used.  Reference to PROUTE1.INC is
c                 deleted.
c
c     Version: This module recoded from WEPP version 90.92.
c     Date recoded: 01/08/91.
c     Recoded by: Charles R. Meyer.
c
c     + + + KEYWORDS + + +
c
c     + + + ARGUMENT DECLARATIONS + + +
      real xu, xl, a, b, cdep, phi, theta, ktrato, qostar
c
c     + + + ARGUMENT DEFINITIONS + + +
c     xu     - n.d. distance at top of slope segment
c     xl     - n.d. distance at end of slope segment
c     a      - shear stress equation coefficient
c     b      - shear stress equation coefficient
c     cdep   - portion of the solution to deposition equation
c     phi    - n.d. deposition parameter
c     theta  - n.d. interrill detachment parameter
c     ktrato -
c     qostar -
c
c     + + + LOCAL VARIABLES + + +
      real xdend, r1, r2, ratio, expon, f, df, xmin, tmpvr1
      integer j, kkkk, itmpv1, loopfg
c
c     xdend  - current trial value for n.d. distance where
c              deposition ends
c     r1     - portion of solution to deposition equation solved
c              for conditions of rate equal to 0 and beginning
c              point equal to x=xu
c     r2     -   "       "          "          "        "
c     ratio  -   "       "          "          "        "
c     expon  -   "       "          "          "        "
c     f      - current solution for deposition rate at x=xdend
c     df     - current solution for derivative of deposition rate
c     j      - counter variable - in loop to only allow a finite
c              number of iterations to determine where dep. ends
c     loopfg - flag. 1 = exit L1 Loop
c
c     + + + SUBROUTINES CALLED + + +
c     undflo
c
c     + + + END SPECIFICATIONS + + +
c
c       Solve for first term of deposition equation
      tmpvr1 = 2.0 * a * ktrato
c
      r1 = (phi/(1.0+phi)) * (b*ktrato-theta-(tmpvr1*qostar))
c
c     Solve for second term of deposition equation
c
      r2 = tmpvr1 * phi / (2.0+phi)
c
c     If flow is increasing down the OFE, check whether deposition
c     at the end of the current segment (uniform or convex shape)
c
      if (qostar.ge.0.0) then
        xdend = xl
        ratio = (xu+qostar) / (xdend+qostar)
        expon = 1.0 + phi
        call undflo(ratio,expon)
c
c       Determine deposition rate at x = xl (end of segment) -
c       if a negative value deposition occurs from xu to xl - RETURN
c
        f = r1 + r2 * (xdend+qostar) + cdep * ratio ** expon
        if (f.lt.0.0) then
          depend = xdend
          return
        end if
c
c       If deposition not occurring at x=xl, set beginning point for
c       iterative solution for xdent close to x=xu
c
        xdend = xu + 0.01
        if (xdend.gt.xl) xdend = (xu+xl) / 2.0
c
c     else - flow is decreasing down the OFE segment, first check
c     to determine that deposition does not immediately end
c     past the initial point ( x = xu ) - then set the
c     beginning point for the iterative solution for xdend
c     close to x = xu
c
      else

c new dcf
        if(abs(xu+qostar).le.0.0001)then
          depend=-qostar
          return
        endif
c new dcf end

        xdend = xu + 0.0001
        if (xdend.gt.xl) xdend = (xu+xl) / 2.0
        ratio = (xu+qostar) / (xdend+qostar)
        expon = 1.0 + phi
        call undflo(ratio,expon)
c
c       determine deposition at x = xdend, and if the value
c       is positive or zero - RETURN
c
        f = r1 + r2 * (xdend+qostar) + cdep * ratio ** expon
        if (f.ge.0.0) then
          depend = xdend
          return
        end if
c
      end if
c
c     *** Begin L1 Loop ***
c
      loopfg = 0
      j = 0
      xmin = xl
      kkkk = 0
   10 continue
      j = j + 1
c
c     ITMPV1 is a flag set if ABS(XDEND + QOSTAR) > 0.0 .  This
c     replacement code is put inside the loop, since XDEND, which
c     it depends on, is supposed to change value each time through
c     the loop. We still save time, since the line of original
c     code above is repeated below.
c
c
c
c     Iterative solution for XDEND
c
c
c     Solve for portions of the deposition equation
c     at the trial value of xdend
c
c     Original Code:
c     if(abs(xdend+qostar).gt.0.0)then
c
c     ITMPV1 is a flag set if ABS(XDEND + QOSTAR) > 0.0 this
c     replacement code is put inside the loop, since XDEND,
c     which it depends on, is supposed to change value each
c     time through the loop. We still save time, since the
c     line of orignial code above is repeated below
c
      tmpvr1 = xdend + qostar
      if (abs(tmpvr1).gt.0.0) then
        itmpv1 = 1
      else
        itmpv1 = 0
      end if
c
      if (itmpv1.ne.0) then
        ratio = (xu+qostar) / tmpvr1
      else
        ratio = 1.0
      end if
      if (ratio.lt.0.0) ratio = 1.0
      expon = 1.0 + phi
      call undflo(ratio,expon)
c
c     Solve the deposition equation at trial value of xdend.
c
      f = r1 + r2 * (xdend+qostar) + cdep * ratio ** expon
c
c     Check added 2/7/91 to flag if any positive values
c     of f have been calculated between xu and xl, and
c     then to record the point on slope where this was found.
c
      if (f.gt.0.0.and.qostar.lt.0.0) then
        kkkk = kkkk + 1
        if (xdend.lt.xmin) xmin = xdend
      end if
c
c     TEST - If the value of nondimensional deposition
c     rate is less than 0.0001, jump out of DO LOOP and
c     use the current value of XDEND as point where
c     deposition predicted to end.
c
      if (abs(f).gt.0.0001) then
c       Original Code:
c       if(abs(xdend+qostar).gt.0.0)then
        if (itmpv1.ne.0) then
c
c         Solve for the derivative of the deposition function
c
          df = r2 - (1.0+phi) * cdep * (ratio**expon) / tmpvr1
          if (abs(df).gt.0.0) then
c
c           Use the derivative to obtain a new trial value for XDEND
c
            xdend = xdend - f / df
c
            if (qostar.lt.0.0) then
              if (xdend.lt.xu) xdend = xu + 0.0001
              if (xdend.gt.-qostar) xdend = -qostar - 0.0001
              if (xdend.gt.xl) xdend = xl
            end if
          else
c
c           If the derivative is zero at the point,
c           restart the iterations with xdend close to xu
c
            xdend = xu + 0.0001
          end if
        end if
        if (xdend.lt.xu) xdend = xu + 0.0001
      else
        loopfg = 1
      end if
      if (j.lt.10.and.loopfg.eq.0) go to 10
c
c     Check if solution has not converged for a plane on which
c     flow is decreasing - if it has not and none of the trial
c     values of xdend between xu and xl (or -qostar) have produced
c     non-negative results - then set xdend equal to xl.
c
      if (loopfg.eq.0.and.qostar.lt.0.0) then
        if (kkkk.eq.0) then
          xdend = xl
        else
          xdend = xmin
        end if
      end if
c
      depend = xdend
c
      return
      end


!===============================================================================
subroutine mer_advection(DXT,DZT,VVEL,Eres,Eres_adv)
!  meridional advection of a energy reservoir term
implicit none

integer, parameter                          :: imt=3600,jmt=2400,km=42
integer                                     :: i,j,k
real,    dimension(imt,jmt,km), intent(in)  :: DZT, VVEL,Eres
real,    dimension(imt,jmt),    intent(in)  :: DXT
real,    dimension(imt,jmt),    intent(out) :: Eres_adv

!Eres_adv(:,:) = sum(Eres(:,:,:)*TTT_VVEL(:,:,:)*DZT(:,:,:),3)/1.e2
do i=2,imt
  do j=2,jmt-1
    Eres_adv(i,j)=0.
    do k=1,km
    Eres_adv(i,j) = Eres_adv(i,j) +&
0.25*(Eres(i,j,k)+Eres(i,j+1,k))*(VVEL(i,j,k)*DZT(i,j,k)+VVEL(i-1,j,k)*DZT(i-1,j,k))/1.e2
    enddo
  enddo
enddo
i=1
  do j=2,jmt-1
    Eres_adv(1,j)=0.
    do k=1,km
    Eres_adv(i,j) = Eres_adv(i,j) +&
0.25*(Eres(i,j,k)+Eres(i,j+1,k))*(VVEL(i,j,k)*DZT(i,j,k)+VVEL(imt,j,k)*DZT(imt,j,k))/1.e2
    enddo
  enddo
end subroutine mer_advection
!===============================================================================