*DECK DMPAR
      SUBROUTINE DMPAR (N, R, LDR, IPVT, DIAG, QTB, DELTA, PAR, X,
     +   SIGMA, WA1, WA2)
C***BEGIN PROLOGUE  DMPAR
C***SUBSIDIARY
C***PURPOSE  Subsidiary to DNLS1 and DNLS1E
C***LIBRARY   SLATEC
C***TYPE      DOUBLE PRECISION (LMPAR-S, DMPAR-D)
C***AUTHOR  (UNKNOWN)
C***DESCRIPTION
C
C   **** Double Precision version of LMPAR ****
C
C     Given an M by N matrix A, an N by N nonsingular DIAGONAL
C     matrix D, an M-vector B, and a positive number DELTA,
C     the problem is to determine a value for the parameter
C     PAR such that if X solves the system
C
C           A*X = B ,     SQRT(PAR)*D*X = 0 ,
C
C     in the least squares sense, and DXNORM is the Euclidean
C     norm of D*X, then either PAR is zero and
C
C           (DXNORM-DELTA) .LE. 0.1*DELTA ,
C
C     or PAR is positive and
C
C           ABS(DXNORM-DELTA) .LE. 0.1*DELTA .
C
C     This subroutine completes the solution of the problem
C     if it is provided with the necessary information from the
C     QR factorization, with column pivoting, of A. That is, if
C     A*P = Q*R, where P is a permutation matrix, Q has orthogonal
C     columns, and R is an upper triangular matrix with diagonal
C     elements of nonincreasing magnitude, then DMPAR expects
C     the full upper triangle of R, the permutation matrix P,
C     and the first N components of (Q TRANSPOSE)*B. On output
C     DMPAR also provides an upper triangular matrix S such that
C
C            T   T                   T
C           P *(A *A + PAR*D*D)*P = S *S .
C
C     S is employed within DMPAR and may be of separate interest.
C
C     Only a few iterations are generally needed for convergence
C     of the algorithm. If, however, the limit of 10 iterations
C     is reached, then the output PAR will contain the best
C     value obtained so far.
C
C     The subroutine statement is
C
C       SUBROUTINE DMPAR(N,R,LDR,IPVT,DIAG,QTB,DELTA,PAR,X,SIGMA,
C                        WA1,WA2)
C
C     where
C
C       N is a positive integer input variable set to the order of R.
C
C       R is an N by N array. On input the full upper triangle
C         must contain the full upper triangle of the matrix R.
C         On output the full upper triangle is unaltered, and the
C         strict lower triangle contains the strict upper triangle
C         (transposed) of the upper triangular matrix S.
C
C       LDR is a positive integer input variable not less than N
C         which specifies the leading dimension of the array R.
C
C       IPVT is an integer input array of length N which defines the
C         permutation matrix P such that A*P = Q*R. Column J of P
C         is column IPVT(J) of the identity matrix.
C
C       DIAG is an input array of length N which must contain the
C         diagonal elements of the matrix D.
C
C       QTB is an input array of length N which must contain the first
C         N elements of the vector (Q TRANSPOSE)*B.
C
C       DELTA is a positive input variable which specifies an upper
C         bound on the Euclidean norm of D*X.
C
C       PAR is a nonnegative variable. On input PAR contains an
C         initial estimate of the Levenberg-Marquardt parameter.
C         On output PAR contains the final estimate.
C
C       X is an output array of length N which contains the least
C         squares solution of the system A*X = B, SQRT(PAR)*D*X = 0,
C         for the output PAR.
C
C       SIGMA is an output array of length N which contains the
C         diagonal elements of the upper triangular matrix S.
C
C       WA1 and WA2 are work arrays of length N.
C
C***SEE ALSO  DNLS1, DNLS1E
C***ROUTINES CALLED  D1MACH, DENORM, DQRSLV
C***REVISION HISTORY  (YYMMDD)
C   800301  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   900328  Added TYPE section.  (WRB)
C***END PROLOGUE  DMPAR
      INTEGER N,LDR
      INTEGER IPVT(*)
      DOUBLE PRECISION DELTA,PAR
      DOUBLE PRECISION R(LDR,*),DIAG(*),QTB(*),X(*),SIGMA(*),WA1(*),
     1 WA2(*)
      INTEGER I,ITER,J,JM1,JP1,K,L,NSING
      DOUBLE PRECISION DXNORM,DWARF,FP,GNORM,PARC,PARL,PARU,P1,P001,
     1 SUM,TEMP,ZERO
      DOUBLE PRECISION D1MACH,DENORM
      SAVE P1, P001, ZERO
      DATA P1,P001,ZERO /1.0D-1,1.0D-3,0.0D0/
C***FIRST EXECUTABLE STATEMENT  DMPAR
      DWARF = D1MACH(1)
C
C     COMPUTE AND STORE IN X THE GAUSS-NEWTON DIRECTION. IF THE
C     JACOBIAN IS RANK-DEFICIENT, OBTAIN A LEAST SQUARES SOLUTION.
C
      NSING = N
      DO 10 J = 1, N
         WA1(J) = QTB(J)
         IF (R(J,J) .EQ. ZERO .AND. NSING .EQ. N) NSING = J - 1
         IF (NSING .LT. N) WA1(J) = ZERO
   10    CONTINUE
      IF (NSING .LT. 1) GO TO 50
      DO 40 K = 1, NSING
         J = NSING - K + 1
         WA1(J) = WA1(J)/R(J,J)
         TEMP = WA1(J)
         JM1 = J - 1
         IF (JM1 .LT. 1) GO TO 30
         DO 20 I = 1, JM1
            WA1(I) = WA1(I) - R(I,J)*TEMP
   20       CONTINUE
   30    CONTINUE
   40    CONTINUE
   50 CONTINUE
      DO 60 J = 1, N
         L = IPVT(J)
         X(L) = WA1(J)
   60    CONTINUE
C
C     INITIALIZE THE ITERATION COUNTER.
C     EVALUATE THE FUNCTION AT THE ORIGIN, AND TEST
C     FOR ACCEPTANCE OF THE GAUSS-NEWTON DIRECTION.
C
      ITER = 0
      DO 70 J = 1, N
         WA2(J) = DIAG(J)*X(J)
   70    CONTINUE
      DXNORM = DENORM(N,WA2)
      FP = DXNORM - DELTA
      IF (FP .LE. P1*DELTA) GO TO 220
C
C     IF THE JACOBIAN IS NOT RANK DEFICIENT, THE NEWTON
C     STEP PROVIDES A LOWER BOUND, PARL, FOR THE ZERO OF
C     THE FUNCTION. OTHERWISE SET THIS BOUND TO ZERO.
C
      PARL = ZERO
      IF (NSING .LT. N) GO TO 120
      DO 80 J = 1, N
         L = IPVT(J)
         WA1(J) = DIAG(L)*(WA2(L)/DXNORM)
   80    CONTINUE
      DO 110 J = 1, N
         SUM = ZERO
         JM1 = J - 1
         IF (JM1 .LT. 1) GO TO 100
         DO 90 I = 1, JM1
            SUM = SUM + R(I,J)*WA1(I)
   90       CONTINUE
  100    CONTINUE
         WA1(J) = (WA1(J) - SUM)/R(J,J)
  110    CONTINUE
      TEMP = DENORM(N,WA1)
      PARL = ((FP/DELTA)/TEMP)/TEMP
  120 CONTINUE
C
C     CALCULATE AN UPPER BOUND, PARU, FOR THE ZERO OF THE FUNCTION.
C
      DO 140 J = 1, N
         SUM = ZERO
         DO 130 I = 1, J
            SUM = SUM + R(I,J)*QTB(I)
  130       CONTINUE
         L = IPVT(J)
         WA1(J) = SUM/DIAG(L)
  140    CONTINUE
      GNORM = DENORM(N,WA1)
      PARU = GNORM/DELTA
      IF (PARU .EQ. ZERO) PARU = DWARF/MIN(DELTA,P1)
C
C     IF THE INPUT PAR LIES OUTSIDE OF THE INTERVAL (PARL,PARU),
C     SET PAR TO THE CLOSER ENDPOINT.
C
      PAR = MAX(PAR,PARL)
      PAR = MIN(PAR,PARU)
      IF (PAR .EQ. ZERO) PAR = GNORM/DXNORM
C
C     BEGINNING OF AN ITERATION.
C
  150 CONTINUE
         ITER = ITER + 1
C
C        EVALUATE THE FUNCTION AT THE CURRENT VALUE OF PAR.
C
         IF (PAR .EQ. ZERO) PAR = MAX(DWARF,P001*PARU)
         TEMP = SQRT(PAR)
         DO 160 J = 1, N
            WA1(J) = TEMP*DIAG(J)
  160       CONTINUE
         CALL DQRSLV(N,R,LDR,IPVT,WA1,QTB,X,SIGMA,WA2)
         DO 170 J = 1, N
            WA2(J) = DIAG(J)*X(J)
  170       CONTINUE
         DXNORM = DENORM(N,WA2)
         TEMP = FP
         FP = DXNORM - DELTA
C
C        IF THE FUNCTION IS SMALL ENOUGH, ACCEPT THE CURRENT VALUE
C        OF PAR. ALSO TEST FOR THE EXCEPTIONAL CASES WHERE PARL
C        IS ZERO OR THE NUMBER OF ITERATIONS HAS REACHED 10.
C
         IF (ABS(FP) .LE. P1*DELTA
     1       .OR. PARL .EQ. ZERO .AND. FP .LE. TEMP
     2            .AND. TEMP .LT. ZERO .OR. ITER .EQ. 10) GO TO 220
C
C        COMPUTE THE NEWTON CORRECTION.
C
         DO 180 J = 1, N
            L = IPVT(J)
            WA1(J) = DIAG(L)*(WA2(L)/DXNORM)
  180       CONTINUE
         DO 210 J = 1, N
            WA1(J) = WA1(J)/SIGMA(J)
            TEMP = WA1(J)
            JP1 = J + 1
            IF (N .LT. JP1) GO TO 200
            DO 190 I = JP1, N
               WA1(I) = WA1(I) - R(I,J)*TEMP
  190          CONTINUE
  200       CONTINUE
  210       CONTINUE
         TEMP = DENORM(N,WA1)
         PARC = ((FP/DELTA)/TEMP)/TEMP
C
C        DEPENDING ON THE SIGN OF THE FUNCTION, UPDATE PARL OR PARU.
C
         IF (FP .GT. ZERO) PARL = MAX(PARL,PAR)
         IF (FP .LT. ZERO) PARU = MIN(PARU,PAR)
C
C        COMPUTE AN IMPROVED ESTIMATE FOR PAR.
C
         PAR = MAX(PARL,PAR+PARC)
C
C        END OF AN ITERATION.
C
         GO TO 150
  220 CONTINUE
C
C     TERMINATION.
C
      IF (ITER .EQ. 0) PAR = ZERO
      RETURN
C
C     LAST CARD OF SUBROUTINE DMPAR.
C
      END


C
C $Id: curvidp.f,v 1.3 2008-07-27 03:10:10 haley Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
C NOTE: If you make any changes to this software, please remember to
C make the same changes to the corresponding single precision routine.
C
      FUNCTION CURVIDP(XL,XU,N,X,Y,YP,SIGMA)
      DOUBLE PRECISION CURVIDP
      DOUBLE PRECISION SIGMAP
      DOUBLE PRECISION XXL
      DOUBLE PRECISION XXU
      DOUBLE PRECISION SSIGN
      DOUBLE PRECISION SUM
      DOUBLE PRECISION DEL1
      DOUBLE PRECISION DEL2
      DOUBLE PRECISION DELS
      DOUBLE PRECISION T1
      DOUBLE PRECISION T2
      DOUBLE PRECISION DUMMY
      DOUBLE PRECISION C1
      DOUBLE PRECISION C2
      DOUBLE PRECISION SS
      DOUBLE PRECISION CS
      DOUBLE PRECISION DELU1
      DOUBLE PRECISION DELU2
      DOUBLE PRECISION DELL1
      DOUBLE PRECISION DELL2
      DOUBLE PRECISION DELI
      DOUBLE PRECISION CU1
      DOUBLE PRECISION CU2
      DOUBLE PRECISION CL1
      DOUBLE PRECISION CL2
c
      INTEGER N
      DOUBLE PRECISION XL,XU,X(N),Y(N),YP(N),SIGMA
c
c                                 coded by alan kaylor cline
c                           from fitpack -- january 26, 1987
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this function integrates a curve specified by a spline
c under tension between two given limits. the subroutine
c curv1 should be called earlier to determine necessary
c parameters.
c
c on input--
c
c   xl and xu contain the upper and lower limits of inte-
c   gration, respectively. (sl need not be less than or
c   equal to xu, curvidp (xl,xu,...) .eq. -curvidp (xu,xl,...) ).
c
c   n contains the number of points which were specified to
c   determine the curve.
c
c   x and y are arrays containing the abscissae and
c   ordinates, respectively, of the specified points.
c
c   yp is an array from subroutine curv1 containing
c   the values of the second derivatives at the nodes.
c
c and
c
c   sigma contains the tension factor (its sign is ignored).
c
c the parameters n, x, y, yp, and sigma should be input
c unaltered from the output of curv1.
c
c on output--
c
c   curvidp contains the integral value.
c
c none of the input parameters are altered.
c
c this function references package modules intrvldp and
c snhcshdp.
c
c-----------------------------------------------------------
c
c denormalize tension factor
c
      SIGMAP = ABS(SIGMA)*DBLE(N-1)/ (X(N)-X(1))
c
c determine actual upper and lower bounds
c
      XXL = XL
      XXU = XU
      SSIGN = 1.D0
      IF (XL.LT.XU) GO TO 1
      XXL = XU
      XXU = XL
      SSIGN = -1.D0
      IF (XL.GT.XU) GO TO 1
c
c return zero if xl .eq. xu
c
      CURVIDP = 0.D0
      RETURN
c
c search for proper intervals
c
    1 ILM1 = INTRVLDP(XXL,X,N)
      IL = ILM1 + 1
      IUM1 = INTRVLDP(XXU,X,N)
      IU = IUM1 + 1
      IF (IL.EQ.IU) GO TO 8
c
c integrate from xxl to x(il)
c
      SUM = 0.D0
      IF (XXL.EQ.X(IL)) GO TO 3
      DEL1 = XXL - X(ILM1)
      DEL2 = X(IL) - XXL
      DELS = X(IL) - X(ILM1)
      T1 = (DEL1+DELS)*DEL2/ (2.D0*DELS)
      T2 = DEL2*DEL2/ (2.D0*DELS)
      SUM = T1*Y(IL) + T2*Y(ILM1)
      IF (SIGMA.EQ.0.D0) GO TO 2
      CALL SNHCSHDP(DUMMY,C1,SIGMAP*DEL1,2)
      CALL SNHCSHDP(DUMMY,C2,SIGMAP*DEL2,2)
      CALL SNHCSHDP(SS,CS,SIGMAP*DELS,3)
      SUM = SUM + ((DELS*DELS* (CS-SS/2.D0)-DEL1*DEL1* (C1-SS/2.D0))*
     +      YP(IL)+DEL2*DEL2* (C2-SS/2.D0)*YP(ILM1))/
     +      (SIGMAP*SIGMAP*DELS* (1.D0+SS))
      GO TO 3
    2 SUM = SUM - T1*T1*DELS*YP(IL)/6.D0 -
     +      T2* (DEL1* (DEL2+DELS)+DELS*DELS)*YP(ILM1)/12.D0
c
c integrate over interior intervals
c
    3 IF (IU-IL.EQ.1) GO TO 6
      ILP1 = IL + 1
      DO 5 I = ILP1,IUM1
          DELS = X(I) - X(I-1)
          SUM = SUM + (Y(I)+Y(I-1))*DELS/2.D0
          IF (SIGMA.EQ.0.D0) GO TO 4
          CALL SNHCSHDP(SS,CS,SIGMAP*DELS,3)
          SUM = SUM + (YP(I)+YP(I-1))*DELS* (CS-SS/2.D0)/
     +          (SIGMAP*SIGMAP* (1.D0+SS))
          GO TO 5
    4     SUM = SUM - (YP(I)+YP(I-1))*DELS*DELS*DELS/24.D0
    5 CONTINUE
c
c integrate from x(iu-1) to xxu
c
    6 IF (XXU.EQ.X(IUM1)) GO TO 10
      DEL1 = XXU - X(IUM1)
      DEL2 = X(IU) - XXU
      DELS = X(IU) - X(IUM1)
      T1 = DEL1*DEL1/ (2.D0*DELS)
      T2 = (DEL2+DELS)*DEL1/ (2.D0*DELS)
      SUM = SUM + T1*Y(IU) + T2*Y(IUM1)
      IF (SIGMA.EQ.0.D0) GO TO 7
      CALL SNHCSHDP(DUMMY,C1,SIGMAP*DEL1,2)
      CALL SNHCSHDP(DUMMY,C2,SIGMAP*DEL2,2)
      CALL SNHCSHDP(SS,CS,SIGMAP*DELS,3)
      SUM = SUM + (YP(IU)*DEL1*DEL1* (C1-SS/2.D0)+
     +      YP(IUM1)* (DELS*DELS* (CS-SS/2.D0)-DEL2*DEL2* (C2-SS/2.D0)))
     +      / (SIGMAP*SIGMAP*DELS* (1.D0+SS))
      GO TO 10
    7 SUM = SUM - T1* (DEL2* (DEL1+DELS)+DELS*DELS)*YP(IU)/12.D0 -
     +      T2*T2*DELS*YP(IUM1)/6.D0
      GO TO 10
c
c integrate from xxl to xxu
c
    8 DELU1 = XXU - X(IUM1)
      DELU2 = X(IU) - XXU
      DELL1 = XXL - X(IUM1)
      DELL2 = X(IU) - XXL
      DELS = X(IU) - X(IUM1)
      DELI = XXU - XXL
      T1 = (DELU1+DELL1)*DELI/ (2.D0*DELS)
      T2 = (DELU2+DELL2)*DELI/ (2.D0*DELS)
      SUM = T1*Y(IU) + T2*Y(IUM1)
      IF (SIGMA.EQ.0.D0) GO TO 9
      CALL SNHCSHDP(DUMMY,CU1,SIGMAP*DELU1,2)
      CALL SNHCSHDP(DUMMY,CU2,SIGMAP*DELU2,2)
      CALL SNHCSHDP(DUMMY,CL1,SIGMAP*DELL1,2)
      CALL SNHCSHDP(DUMMY,CL2,SIGMAP*DELL2,2)
      CALL SNHCSHDP(SS,DUMMY,SIGMAP*DELS,-1)
      SUM = SUM + (YP(IU)* (DELU1*DELU1* (CU1-SS/2.D0)-
     +      DELL1*DELL1* (CL1-SS/2.D0))+YP(IUM1)*
     +      (DELL2*DELL2* (CL2-SS/2.D0)-DELU2*DELU2* (CU2-SS/2.D0)))/
     +      (SIGMAP*SIGMAP*DELS* (1.D0+SS))
      GO TO 10
    9 SUM = SUM - T1* (DELU2* (DELS+DELU1)+DELL2* (DELS+DELL1))*YP(IU)/
     +      12.D0 - T2* (DELL1* (DELS+DELL2)+DELU1* (DELS+DELU2))*
     +      YP(IUM1)/12.D0
c
c correct sign and return
c
   10 CURVIDP = SSIGN*SUM
      RETURN
      END


      subroutine timeca(deltim,delxi,drir0,iodb,nodbmx,nord,noutpt,
     $ nrd1mx,nttyo,prcinf,qriinf,rirec0,time0,time1)
c
c     This subroutine calculates the interval (deltim) of model time
c     that corresponds to the reaction progress interval (delxi).
c
c     This subroutine is called by:
c
c       EQ6/chksti.f
c       EQ6/eqshel.f
c       EQ6/path.f
c
c-----------------------------------------------------------------------
c
c     Principal input:
c
c
c     Principal output:
c
c
c-----------------------------------------------------------------------
c
      implicit none
c
c-----------------------------------------------------------------------
c
c     Calling sequence variable declarations.
c
      integer nodbmx,nrd1mx
c
      integer noutpt,nttyo
c
      integer iodb(nodbmx)
      integer nord
c
      logical qriinf
c
      real*8 drir0(nrd1mx)
      real*8 deltim,delxi,prcinf,rirec0,time0,time1
c
c-----------------------------------------------------------------------
c
c     Local variable declarations.
c
      integer i,n
c
      real*8 dxp
c
      real*8 fctrl
c
c-----------------------------------------------------------------------
c
      if (qriinf) then
        write (noutpt,1000)
        write (nttyo,1000)
 1000   format(/' * Note - (EQ6/timeca) Have encountered an infinite',
     $  /7x,'time interval.')
        time1 = prcinf
        deltim = prcinf
        go to 999
      endif
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
      deltim = rirec0*delxi
      if (nord .gt. 0) then
        dxp = delxi
        do n = 1,nord
          i = n + 1
          dxp = dxp*delxi
          deltim = deltim + ( drir0(n)*dxp )/fctrl(i)
        enddo
      endif
      time1 = time0 + deltim
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
      if (deltim.le.0. .and. delxi.gt.0.) then
        if (iodb(2) .gt. 0) then
          write (noutpt,1010) deltim,nord
          write (nttyo,1010) deltim,nord
 1010     format(/' * Note - (EQ6/timeca) Have encountered a',
     $    /7x,'time increment of ',1pe12.5,' seconds calculated for',
     $    /7x,'order ',i2,'.')
          write (noutpt,1020) delxi,rirec0
 1020     format(7x,'delxi= ',1pe12.5,/7x,'rirec0= ',e12.5)
          if (nord .gt. 0) write (noutpt,1030) (drir0(n), n = 1,nord)
 1030     format(7x,'drir0: ',/12x,1pe12.5,3x,e12.5,3x,e12.5,
     $    /12x,e12.5,3x,e12.5,3x,e12.5)
        endif
      endif
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
  999 continue
      end


program example_mnist

  ! A training example with the MNIST dataset.
  ! Uses stochastic gradient descent and mini-batch size of 100.
  ! Can be run in serial or parallel mode without modifications.

  use mod_kinds, only: ik, rk
  use mod_mnist, only: label_digits, load_mnist
  use mod_network, only: network_type

  implicit none

  real(rk), allocatable :: tr_images(:,:), tr_labels(:)
  real(rk), allocatable :: te_images(:,:), te_labels(:)
  real(rk), allocatable :: input(:,:), output(:,:)

  type(network_type) :: net

  integer(ik) :: i, n, num_epochs
  integer(ik) :: batch_size, batch_start, batch_end
  real(rk) :: pos

  call load_mnist(tr_images, tr_labels, te_images, te_labels)

  net = network_type([784, 30, 10])

  batch_size = 100
  num_epochs = 10

  if (this_image() == 1) print '(a,f5.2,a)', 'Initial accuracy: ', &
    net % accuracy(te_images, label_digits(te_labels)) * 100, ' %'

  epochs: do n = 1, num_epochs
    batches: do i = 1, size(tr_labels) / batch_size

      ! pull a random mini-batch from the dataset
      call random_number(pos)
      batch_start = int(pos * (size(tr_labels) - batch_size + 1))
      batch_end = batch_start + batch_size - 1

      ! prepare mini-batch
      input = tr_images(:,batch_start:batch_end)
      output = label_digits(tr_labels(batch_start:batch_end))

      ! train the network on the mini-batch
      call net % train(input, output, eta=3._rk)

    end do batches

    if (this_image() == 1) print '(a,i2,a,f5.2,a)', 'Epoch ', n, ' done, Accuracy: ', &
      net % accuracy(te_images, label_digits(te_labels)) * 100, ' %'

  end do epochs

end program example_mnist


module m_calc_mpsmat
contains
   subroutine calc_mpsmat(fi, mpdata, smat)
      use m_types
      use m_judft
      use m_constants
      implicit none
      type(t_mat), intent(inout) :: smat
      type(t_fleurinput), intent(in)    :: fi
      TYPE(t_mpdata), intent(in)        :: mpdata

      integer :: igpt2, igpt1, ic, itype, ineq, g(3)
      real    :: gnorm, rdum

      call timestart("calc smat")
      call smat%alloc(.False., mpdata%num_gpts(),mpdata%num_gpts())
      !$OMP PARALLEL DO default(none) schedule(guided)&
      !$OMP private(ic,igpt2,igpt1, g, gnorm, itype, rdum)&
      !$OMP shared(mpdata, fi, smat)
      DO igpt2 = 1, mpdata%num_gpts()
         DO igpt1 = 1, igpt2
            g = mpdata%g(:, igpt2) - mpdata%g(:, igpt1)
            gnorm = gptnorm(g, fi%cell%bmat)
            IF (abs(gnorm) < 1e-12) THEN
               DO itype = 1, fi%atoms%ntype
                  smat%data_c(igpt1, igpt2) = smat%data_c(igpt1, igpt2) + fi%atoms%neq(itype)*fpi_const*fi%atoms%rmt(itype)**3/3
               END DO
            ELSE
               ic = 0
               do ic =1,fi%atoms%nat
                  itype = fi%atoms%itype(ic)
                  rdum = fi%atoms%rmt(itype)*gnorm
                  rdum = fpi_const*(SIN(rdum) - rdum*COS(rdum))/gnorm**3
                  smat%data_c(igpt1, igpt2) = smat%data_c(igpt1, igpt2) &
                                       + rdum*EXP(ImagUnit*tpi_const*dot_PRODUCT(fi%atoms%taual(:, ic), g))
               END DO
            END IF
         END DO
      END DO
      !$OMP END PARALLEL DO

      call smat%u2l()
      call timestop("calc smat")
   end subroutine calc_mpsmat
end module m_calc_mpsmat


! MIT License
!
! Copyright (c) 2020 SHEMAT-Suite
!
! Permission is hereby granted, free of charge, to any person obtaining a copy
! of this software and associated documentation files (the "Software"), to deal
! in the Software without restriction, including without limitation the rights
! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is
! furnished to do so, subject to the following conditions:
!
! The above copyright notice and this permission notice shall be included in all
! copies or substantial portions of the Software.
!
! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
! SOFTWARE.

!>    @brief solve of : [M] x [x] = [b], CG algorithm based with ILU preconditioning
!>    @param[in] N_I lengths of I dimension of local matrix [M]
!>    @param[in] N_J lengths of J dimension of local matrix [M]
!>    @param[in] N_K lengths of K dimension of local matrix [M]
!>    @param[in,out] x solution vector [x], on start = start vector
!>    @param[in] b right side, vector [b]
!>    @param[in] depsilon precision criteria to break iterations
!>    @param[in] mbc_mask boundary condition pattern (mask)
!>    @param[in] max_It max iteration number
!>    @param[in] criteria precision criteria mode to break iterations\n
!>    - 0 : relative stopping crit.: ||[res]||       < depsilon*||[res0]||\n
!>    - 1 : absolute stopping crit.: ||[res]||       < depsilon\n
!>    - 2 : maximum  stopping crit.: max(abs([res])) < depsilon\n
!>    first [res]^=[r], later (if precise enough): [res]^=([M]x[x]-[b])
!>    @param[in] MA 1. diagonal of the system matrix [M]
!>    @param[in] MB 2. diagonal of the system matrix [M]
!>    @param[in] MC 3. diagonal of the system matrix [M]
!>    @param[in] MD 4. diagonal of the system matrix [M]
!>    @param[in] ME 5. diagonal of the system matrix [M]
!>    @param[in] MF 6. diagonal of the system matrix [M]
!>    @param[in] MG 7. diagonal of the system matrix [M]
!>    @param[in] UD helper diagonal elements for preconditioning
!>    @param[out] bound_block boundary exchange buffer for each block, between the threads
!>    @param[out] dnrm normalisation vector, temporary use
!>    @param[out] lMA temporary thread local elements of the 1. diagonal of [M]
!>    @param[out] lMB temporary thread local elements of the 2. diagonal of [M]
!>    @param[out] lMC temporary thread local elements of the 3. diagonal of [M]
!>    @param[out] lMD temporary thread local elements of the 4. diagonal of [M]
!>    @param[out] lME temporary thread local elements of the 5. diagonal of [M]
!>    @param[out] lMF temporary thread local elements of the 6. diagonal of [M]
!>    @param[out] lMG temporary thread local elements of the 7. diagonal of [M]
!>    @param[out] lUD temporary thread local elements of the helper diagonal [UD]
!>    @param[out] lx temporary thread local elements of the solution vector [x]
!>    @param[out] lb temporary thread local elements of the right side [b]
!>    @param[out] ldnrm temporary thread local elements of the normalisation vector
!>    @param[out] llocTMP temporary thread local elements of the local temporary vectors
!>    @param[out] ud_block block buffer for helper diagonal [UD]
!>    @param[in] ismpl local sample index
!>    @details
!>    solve of : [M] x [x] = [b]\n
!>    [M] is s.p.d. Matrix, only used in 'omp_MVP'\n
!>    Technics :\n
!>               - use reverse communication technics.\n
!>                 each vector should be dense full without any hole,\n
!>                 ( you can copy your elements from your structure to a \n
!>                 temporary dense full vector, befor you use this algorithm \n
!>                 and give the correct number of elements in 'N' ).\n
!>                 if you have setup all vectors by a specific composition,\n
!>                 each vector (x,b,r,...) on the same thread should use\n
!>                 the same composition (same structure for all vectors on\n
!>                 one thread).\n
      SUBROUTINE omp_sym_solve_ilu(n_i,n_j,n_k,x,b,depsilon,mbc_mask, &
          max_it,criteria,ma,mb,mc,md,me,mf,mg,ud,bound_block,dnrm, &
          lma,lmb,lmc,lmd,lme,lmf,lmg,lud,lx,lb,ldnrm,lloctmp, &
          ud_block,ismpl)
        use mod_OMP_TOOLS
        use mod_blocking_size
        IMPLICIT NONE
        INCLUDE 'OMP_TOOLS.inc'

!     N_I*N_J*N_K : length of all vector r,z,s,t,v,p,y,t_pc,s_pc
        INTEGER n_i, n_j, n_k, max_it, ismpl

!     vector x and b for [M]x[x]=[b]
!     res0 ^= ||res0||, start residuel, given for 'criteria=0'
        DOUBLE PRECISION x(n_i*n_j*n_k), b(n_i*n_j*n_k)
        DOUBLE PRECISION res0, ud(n_i*n_j*n_k)
        DOUBLE PRECISION ma(n_i*n_j*n_k), mb(n_i*n_j*n_k)
        DOUBLE PRECISION mc(n_i*n_j*n_k), md(n_i*n_j*n_k)
        DOUBLE PRECISION me(n_i*n_j*n_k), mf(n_i*n_j*n_k)
        DOUBLE PRECISION mg(n_i*n_j*n_k)
        CHARACTER mbc_mask(n_i*n_j*n_k)

!     definitions of 'work' and 'locTMP'
        INCLUDE 'pre_cg.inc'
!      use mod_blocking_size
!       locTMP   : space for local vectors, using to exchange data with
!                  'matrix-vector-product'(MVP) and 'pre-conditioners'(L/R),
!                  for definitions see more in 'pre_bicgstab.inc'

!     global buffer for boundary exchange
        DOUBLE PRECISION bound_block(block_i*block_j+block_i*block_k+ &
          block_j*block_k,bdim_i,bdim_j,bdim_k,2)
        DOUBLE PRECISION dnrm(n_i*n_j*n_k)
!     private copy for preconditioning
        DOUBLE PRECISION lma(max_blocks*block_i*block_j*block_k, &
          tlevel_1)
        DOUBLE PRECISION lmb(max_blocks*block_i*block_j*block_k, &
          tlevel_1)
        DOUBLE PRECISION lmc(max_blocks*block_i*block_j*block_k, &
          tlevel_1)
        DOUBLE PRECISION lmd(max_blocks*block_i*block_j*block_k, &
          tlevel_1)
        DOUBLE PRECISION lme(max_blocks*block_i*block_j*block_k, &
          tlevel_1)
        DOUBLE PRECISION lmf(max_blocks*block_i*block_j*block_k, &
          tlevel_1)
        DOUBLE PRECISION lmg(max_blocks*block_i*block_j*block_k, &
          tlevel_1)
        DOUBLE PRECISION lud(max_blocks*block_i*block_j*block_k, &
          tlevel_1)
        DOUBLE PRECISION lx(max_blocks*block_i*block_j*block_k, &
          tlevel_1)
        DOUBLE PRECISION lb(max_blocks*block_i*block_j*block_k, &
          tlevel_1)
        DOUBLE PRECISION ldnrm(max_blocks*block_i*block_j*block_k, &
          tlevel_1)
        DOUBLE PRECISION lloctmp(max_blocks*block_i*block_j*block_k, &
          max_loctmp,tlevel_1)
        DOUBLE PRECISION ud_block(block_i*block_j+block_i*block_k+ &
          block_j*block_k,max_blocks,tlevel_1)

!     x,y,z-grid index for each block position
        INTEGER, ALLOCATABLE :: xyz_block(:,:)
        INTEGER lxyz_block, tid

!     Pre_CG stuff
!     work     : control variable : what is to do out of this subroutine,
!                see more discription in 'pre_cg.inc',
!                on startup should set to 'work=START'
        INTEGER work

!     break with enough precision
        DOUBLE PRECISION depsilon

        INTEGER xi, yi, zi, loc_mem, loc_memm1
        INTEGER criteria, i, j, k, fkt_proza
        EXTERNAL fkt_proza
!     openmp-private variables
        INTEGER tpos, tanz
!     openmp-shared variables
        INTEGER ipar(5), iii
        DOUBLE PRECISION, ALLOCATABLE :: rpar(:)
        INTEGER, ALLOCATABLE :: proza_lock(:,:,:)
        LOGICAL lpar(1)

!     start values
        work = start
        res0 = 1.D+99

        ALLOCATE(proza_lock(bdim_i,bdim_j,bdim_k))

!$OMP  parallel &
!$OMP num_threads(Tlevel_1)&
!$OMP default(none) shared(Tlevel_1, ismpl)&
!$OMP shared(block_i,block_j,block_k, bdim_i,bdim_j,bdim_k,ipar,rpar)&
!$OMP shared(N_I,N_J,N_K, depsilon, max_It, criteria, res0, work,lpar)&
!$OMP shared(bound_block, MA,MB,MC,MD,ME,MF,MG,UD, x,b,ProzA_lock)&
!$OMP shared(mbc_mask, dnrm, ud_block, ldnrm, max_blocks)&
!$OMP shared(lMA,lMB,lMC,lMD,lUD,lME,lMF,lMG,lx,lb,llocTMP)&
!$OMP private(i,j,k, tid, loc_mem,loc_memm1, lxyz_block, xyz_block)&
!$OMP private(xi,yi,zi, iii, tpos, tanz)
!$      call omp_binding(ismpl)

        CALL omp_part(n_i*n_j*n_k,tpos,tanz)
        tid = omp_get_his_thread_num() + 1

!$OMP master
        iii = 6 + 4*omp_get_num_of_threads()
        ALLOCATE(rpar(iii))
        CALL set_dval(iii,0.D0,rpar)
!      allocate(rpar(6 +4 *OMP_GET_NUM_of_THREADS()))
        CALL par_reset(proza_lock)
!$OMP end master
!     normalise the linear system, use [dnrm] to normalise the system
        CALL norm_linsys(tanz,mbc_mask(tpos),b(tpos),x(tpos),ma(tpos), &
          mb(tpos),mc(tpos),md(tpos),me(tpos),mf(tpos),mg(tpos), &
          dnrm(tpos))
!$OMP barrier
!     init ILU(0)-preconditioner, other start values
        CALL prepare_ilu(n_i,n_j,n_k,ma,mb,mc,md,me,mf,mg,ud)

!     max number of private blocks = bdim_i*bdim_j*bdim_k
        ALLOCATE(xyz_block(3,bdim_i*bdim_j*bdim_k))

        lxyz_block = 0
        DO k = 1, bdim_k
          DO j = 1, bdim_j
            DO i = 1, bdim_i
              IF (fkt_proza(i,j,k)==tid-1) THEN
!           compute number of private blocks
                lxyz_block = lxyz_block + 1
!           setup index information for each private block
                xyz_block(1,lxyz_block) = i
                xyz_block(2,lxyz_block) = j
                xyz_block(3,lxyz_block) = k
              END IF
            END DO
          END DO
        END DO
!     memory requirements
        loc_mem = lxyz_block*block_i*block_j*block_k
        loc_memm1 = max_blocks*block_i*block_j*block_k

!     make private copies from the global arrays
!$OMP barrier
        CALL lcopy_ilu(n_i,n_j,n_k,ma,lma(1,tid),lxyz_block,xyz_block)
        CALL lcopy_ilu(n_i,n_j,n_k,mb,lmb(1,tid),lxyz_block,xyz_block)
        CALL lcopy_ilu(n_i,n_j,n_k,mc,lmc(1,tid),lxyz_block,xyz_block)
        CALL lcopy_ilu(n_i,n_j,n_k,md,lmd(1,tid),lxyz_block,xyz_block)
        CALL lcopy_ilu(n_i,n_j,n_k,ud,lud(1,tid),lxyz_block,xyz_block)
        CALL lcopy_ilu(n_i,n_j,n_k,me,lme(1,tid),lxyz_block,xyz_block)
        CALL lcopy_ilu(n_i,n_j,n_k,mf,lmf(1,tid),lxyz_block,xyz_block)
        CALL lcopy_ilu(n_i,n_j,n_k,mg,lmg(1,tid),lxyz_block,xyz_block)
        CALL lcopy_ilu(n_i,n_j,n_k,x,lx(1,tid),lxyz_block,xyz_block)
        CALL lcopy_ilu(n_i,n_j,n_k,b,lb(1,tid),lxyz_block,xyz_block)
        CALL lcopy_ilu(n_i,n_j,n_k,dnrm,ldnrm(1,tid),lxyz_block,xyz_block)
!     lcopy_ilu of [locTMP] not needed, but of the cleanup
!aw-test      Call set_dval(loC_memm1*max_loCTMP,0.d0,lloCTMP(1,1,tid))

!     copy private [UD] surface (position-1)
        DO i = 1, lxyz_block
          CALL lsurf_ilu(n_i,n_j,n_k,i,ud,ud_block(1,i,tid),lxyz_block,xyz_block)
        END DO

!     INIT
!     preload ([M]x[x]) in [z]
        CALL omp_mvp2(n_i,n_j,n_k,lxyz_block,lx(1,tid), &
          lloctmp(1,s,tid),lma(1,tid),lmb(1,tid),lmc(1,tid), &
          lmd(1,tid),lme(1,tid),lmf(1,tid),lmg(1,tid),bound_block, &
          xyz_block)

!**************************************************************

10      CONTINUE

!     cg-routines without Pre-Cond.
!     step : is the return-lable for pre_cg()
        CALL pre_cg(loc_mem,lx(1,tid),lb(1,tid),loc_memm1, &
          lloctmp(1,1,tid),depsilon,ldnrm(1,tid),max_it,criteria,res0, &
          work,ipar,rpar,lpar)
!     implicit barrier here

        IF ((work==mvp) .OR. (work==mvpx)) THEN
!       solve: [M]x[z]=[r] -> [z]:=[A^-1]x[r]
!       here [M] can be a substituted Matrix [T] -> solve: [T]x[z]=[r]
          CALL omp_lu_solve2(n_i,n_j,n_k,lxyz_block,lloctmp(1,r,tid), &
            lloctmp(1,z,tid),lma(1,tid),lmb(1,tid),lmc(1,tid), &
            lud(1,tid),lme(1,tid),lmf(1,tid),lmg(1,tid), &
            ud_block(1,1,tid),bound_block,xyz_block,proza_lock)
!       need barrier here, [LU] and [MVP] modify "bound_block"
!$OMP   barrier
!       [s]:=[M]x[z]
          CALL omp_mvp2(n_i,n_j,n_k,lxyz_block,lloctmp(1,z,tid), &
            lloctmp(1,s,tid),lma(1,tid),lmb(1,tid),lmc(1,tid), &
            lmd(1,tid),lme(1,tid),lmf(1,tid),lmg(1,tid),bound_block, &
            xyz_block)
        END IF

!     [v]:=[M]x[x], for advanced precision
        IF (work==mvpx) THEN
!       need barrier here, both [MVP] modify "bound_block"
!$OMP   barrier
          CALL omp_mvp2(n_i,n_j,n_k,lxyz_block,lx(1,tid), &
            lloctmp(1,v,tid),lma(1,tid),lmb(1,tid),lmc(1,tid), &
            lmd(1,tid),lme(1,tid),lmf(1,tid),lmg(1,tid),bound_block, &
            xyz_block)
        END IF

!     precision not enough ?
        IF ((work/=fine) .AND. (work/=abort)) GO TO 10
!     at "work=ABORT", we can startup with a new [r^]

!**************************************************************

!     get the global [x] from private
        CALL lcopy_bak_ilu(n_i,n_j,n_k,x,lx(1,tid),lxyz_block,xyz_block)

        DEALLOCATE(xyz_block)

!$OMP end parallel
        DEALLOCATE(rpar)
        DEALLOCATE(proza_lock)

        RETURN
      END


module parameters
    integer, parameter :: N_total = 32
    integer, parameter :: N_start = 2
    integer, parameter :: N_on_blade = N_total - N_start + 1
    integer, parameter :: N = N_on_blade - 2
    integer, parameter :: T = 5e6
    integer, parameter :: t_count = 5e3
    integer, parameter :: simulation_type = 1
    integer, parameter :: blade_num = 2
    real, parameter :: radius = 5
    real, parameter :: omega = 72.0/60*2*3.1415926
    real, parameter :: pitch = 3.0/180*3.1415926
    real, parameter :: total_time = 10
    real, parameter :: r_start = 0.508
    real :: delta_t = total_time/T
    real :: delta_r = radius/(N_on_blade-1)
end module parameters


c-----------------------------------------------------------------------
      subroutine setquad
C
C     Set up the quadrant points and associated element-element links
C     for plotting r-s-t surfaces in 3D and for establishing general
C     zipper planes.        pff 11-20-90  21:30 and  1-8-91
C
C     (Note: this algorithm is inherently CONFORMING, as constant r-s-t
C            planes have little significance in a non-conforming
C            discretization where the continuum assumption is not honored.)
C
#     include "basics.inc"
      include 'basicsp.inc'
C
C     Algorithm:  Set up indices, e.g:
C                                                     ^ s
C         These points define planes                  |
C         which propagate from one         +----------|---------+
C         element to the next, as          |          |         |
C         shown near pt. 3:                |         4+         |
C                                          |          |         |
C                                          |          |         |
C                                          +--1+------------+2--+--> r
C                                          |          |         |
C                                          |          |         |
C                                          | - - - - 3+ - - - - |
C                                          |          |         |
C                                          +--------------------+
C
C     Set up the connectivity list by performing the K^2 loop which
C     searches for coincident nodes, thus identifying an element-element
C     interaction.
C
CXXX
CXXX   recall, that normals will always be defined positive if they point
CXXX   away from the element center...,,, thus, once the topology of the
CXXX   normal (in or out) is established for one element, it will carry through
CXXX   to the rest of the elements.
CXXX
CXXX   2)  we can have a pseudo XYZ plane for now which takes as the default
CXXX   normal to be x y or z at the given point.
CXXX
CXXX   3)  when determining which  element contains the originating point, just
CXXX       use the first found point, and choose the closest quadpoint with an
CXXX       appropriately oriented normal vector (in some distance/normal norm).
CXXX
C
      DIMENSION XYZ(3,8)
      DIMENSION INEIGH(6,6)
      DATA      INEIGH/  1, -1, -1,  1,  1, -1
     $                , -1,  1,  1, -1, -1,  1
     $                , -1,  1,  1, -1, -1,  1
     $                ,  1, -1, -1,  1,  1, -1
     $                ,  1, -1, -1,  1,  1, -1
     $                , -1,  1,  1, -1, -1,  1 /
C
      IF (.NOT.IF3D) return
      CALL GENCEN
      NFACES=6
      EPSM = 1.0E-10
      NEL5=120*NELM
      CALL RZERO(XYZQ,NEL5)

c     if (nel.gt.20000) then
c        call prsi('Will not set quad for nel > 20K. NEL=$',nel)
c        return
c     endif

C     Define quadpoints:
      DO 100 IE=1,NEL
         CALL MAPXC(XYZ,IE)
C
C     Plane 1
         XYZQ(1,1,1,IE)=.125*(3.0*(XYZ(1,1)+XYZ(1,5))+XYZ(1,2)+XYZ(1,6))
         XYZQ(2,1,1,IE)=.125*(3.0*(XYZ(2,1)+XYZ(2,5))+XYZ(2,2)+XYZ(2,6))
         XYZQ(3,1,1,IE)=.125*(3.0*(XYZ(3,1)+XYZ(3,5))+XYZ(3,2)+XYZ(3,6))
C
         XYZQ(1,2,1,IE)=.125*(3.0*(XYZ(1,3)+XYZ(1,7))+XYZ(1,4)+XYZ(1,8))
         XYZQ(2,2,1,IE)=.125*(3.0*(XYZ(2,3)+XYZ(2,7))+XYZ(2,4)+XYZ(2,8))
         XYZQ(3,2,1,IE)=.125*(3.0*(XYZ(3,3)+XYZ(3,7))+XYZ(3,4)+XYZ(3,8))
C
         XYZQ(1,3,1,IE)=.125*(3.0*(XYZ(1,1)+XYZ(1,3))+XYZ(1,2)+XYZ(1,4))
         XYZQ(2,3,1,IE)=.125*(3.0*(XYZ(2,1)+XYZ(2,3))+XYZ(2,2)+XYZ(2,4))
         XYZQ(3,3,1,IE)=.125*(3.0*(XYZ(3,1)+XYZ(3,3))+XYZ(3,2)+XYZ(3,4))
C
         XYZQ(1,4,1,IE)=.125*(3.0*(XYZ(1,5)+XYZ(1,7))+XYZ(1,6)+XYZ(1,8))
         XYZQ(2,4,1,IE)=.125*(3.0*(XYZ(2,5)+XYZ(2,7))+XYZ(2,6)+XYZ(2,8))
         XYZQ(3,4,1,IE)=.125*(3.0*(XYZ(3,5)+XYZ(3,7))+XYZ(3,6)+XYZ(3,8))
C
C     Plane 2
         XYZQ(1,1,2,IE)=.125*(3.0*(XYZ(1,2)+XYZ(1,6))+XYZ(1,1)+XYZ(1,5))
         XYZQ(2,1,2,IE)=.125*(3.0*(XYZ(2,2)+XYZ(2,6))+XYZ(2,1)+XYZ(2,5))
         XYZQ(3,1,2,IE)=.125*(3.0*(XYZ(3,2)+XYZ(3,6))+XYZ(3,1)+XYZ(3,5))
C
         XYZQ(1,2,2,IE)=.125*(3.0*(XYZ(1,4)+XYZ(1,8))+XYZ(1,3)+XYZ(1,7))
         XYZQ(2,2,2,IE)=.125*(3.0*(XYZ(2,4)+XYZ(2,8))+XYZ(2,3)+XYZ(2,7))
         XYZQ(3,2,2,IE)=.125*(3.0*(XYZ(3,4)+XYZ(3,8))+XYZ(3,3)+XYZ(3,7))
C
         XYZQ(1,3,2,IE)=.125*(3.0*(XYZ(1,2)+XYZ(1,4))+XYZ(1,1)+XYZ(1,3))
         XYZQ(2,3,2,IE)=.125*(3.0*(XYZ(2,2)+XYZ(2,4))+XYZ(2,1)+XYZ(2,3))
         XYZQ(3,3,2,IE)=.125*(3.0*(XYZ(3,2)+XYZ(3,4))+XYZ(3,1)+XYZ(3,3))
C
         XYZQ(1,4,2,IE)=.125*(3.0*(XYZ(1,6)+XYZ(1,8))+XYZ(1,5)+XYZ(1,7))
         XYZQ(2,4,2,IE)=.125*(3.0*(XYZ(2,6)+XYZ(2,8))+XYZ(2,5)+XYZ(2,7))
         XYZQ(3,4,2,IE)=.125*(3.0*(XYZ(3,6)+XYZ(3,8))+XYZ(3,5)+XYZ(3,7))
C
C     Plane 5
         XYZQ(1,1,5,IE)=.125*(3.0*(XYZ(1,1)+XYZ(1,3))+XYZ(1,5)+XYZ(1,7))
         XYZQ(2,1,5,IE)=.125*(3.0*(XYZ(2,1)+XYZ(2,3))+XYZ(2,5)+XYZ(2,7))
         XYZQ(3,1,5,IE)=.125*(3.0*(XYZ(3,1)+XYZ(3,3))+XYZ(3,5)+XYZ(3,7))
C
         XYZQ(1,2,5,IE)=.125*(3.0*(XYZ(1,2)+XYZ(1,4))+XYZ(1,6)+XYZ(1,8))
         XYZQ(2,2,5,IE)=.125*(3.0*(XYZ(2,2)+XYZ(2,4))+XYZ(2,6)+XYZ(2,8))
         XYZQ(3,2,5,IE)=.125*(3.0*(XYZ(3,2)+XYZ(3,4))+XYZ(3,6)+XYZ(3,8))
C
         XYZQ(1,3,5,IE)=.125*(3.0*(XYZ(1,1)+XYZ(1,2))+XYZ(1,5)+XYZ(1,6))
         XYZQ(2,3,5,IE)=.125*(3.0*(XYZ(2,1)+XYZ(2,2))+XYZ(2,5)+XYZ(2,6))
         XYZQ(3,3,5,IE)=.125*(3.0*(XYZ(3,1)+XYZ(3,2))+XYZ(3,5)+XYZ(3,6))
C
         XYZQ(1,4,5,IE)=.125*(3.0*(XYZ(1,3)+XYZ(1,4))+XYZ(1,7)+XYZ(1,8))
         XYZQ(2,4,5,IE)=.125*(3.0*(XYZ(2,3)+XYZ(2,4))+XYZ(2,7)+XYZ(2,8))
         XYZQ(3,4,5,IE)=.125*(3.0*(XYZ(3,3)+XYZ(3,4))+XYZ(3,7)+XYZ(3,8))
C
C     Plane 6
         XYZQ(1,1,6,IE)=.125*(3.0*(XYZ(1,5)+XYZ(1,7))+XYZ(1,1)+XYZ(1,3))
         XYZQ(2,1,6,IE)=.125*(3.0*(XYZ(2,5)+XYZ(2,7))+XYZ(2,1)+XYZ(2,3))
         XYZQ(3,1,6,IE)=.125*(3.0*(XYZ(3,5)+XYZ(3,7))+XYZ(3,1)+XYZ(3,3))
C
         XYZQ(1,2,6,IE)=.125*(3.0*(XYZ(1,6)+XYZ(1,8))+XYZ(1,2)+XYZ(1,4))
         XYZQ(2,2,6,IE)=.125*(3.0*(XYZ(2,6)+XYZ(2,8))+XYZ(2,2)+XYZ(2,4))
         XYZQ(3,2,6,IE)=.125*(3.0*(XYZ(3,6)+XYZ(3,8))+XYZ(3,2)+XYZ(3,4))
C
         XYZQ(1,3,6,IE)=.125*(3.0*(XYZ(1,5)+XYZ(1,6))+XYZ(1,1)+XYZ(1,2))
         XYZQ(2,3,6,IE)=.125*(3.0*(XYZ(2,5)+XYZ(2,6))+XYZ(2,1)+XYZ(2,2))
         XYZQ(3,3,6,IE)=.125*(3.0*(XYZ(3,5)+XYZ(3,6))+XYZ(3,1)+XYZ(3,2))
C
         XYZQ(1,4,6,IE)=.125*(3.0*(XYZ(1,7)+XYZ(1,8))+XYZ(1,3)+XYZ(1,4))
         XYZQ(2,4,6,IE)=.125*(3.0*(XYZ(2,7)+XYZ(2,8))+XYZ(2,3)+XYZ(2,4))
         XYZQ(3,4,6,IE)=.125*(3.0*(XYZ(3,7)+XYZ(3,8))+XYZ(3,3)+XYZ(3,4))
C
C     Plane 3
         XYZQ(1,1,3,IE)=.125*(3.0*(XYZ(1,1)+XYZ(1,5))+XYZ(1,3)+XYZ(1,7))
         XYZQ(2,1,3,IE)=.125*(3.0*(XYZ(2,1)+XYZ(2,5))+XYZ(2,3)+XYZ(2,7))
         XYZQ(3,1,3,IE)=.125*(3.0*(XYZ(3,1)+XYZ(3,5))+XYZ(3,3)+XYZ(3,7))
C
         XYZQ(1,2,3,IE)=.125*(3.0*(XYZ(1,2)+XYZ(1,6))+XYZ(1,4)+XYZ(1,8))
         XYZQ(2,2,3,IE)=.125*(3.0*(XYZ(2,2)+XYZ(2,6))+XYZ(2,4)+XYZ(2,8))
         XYZQ(3,2,3,IE)=.125*(3.0*(XYZ(3,2)+XYZ(3,6))+XYZ(3,4)+XYZ(3,8))
C
         XYZQ(1,3,3,IE)=.125*(3.0*(XYZ(1,1)+XYZ(1,2))+XYZ(1,3)+XYZ(1,4))
         XYZQ(2,3,3,IE)=.125*(3.0*(XYZ(2,1)+XYZ(2,2))+XYZ(2,3)+XYZ(2,4))
         XYZQ(3,3,3,IE)=.125*(3.0*(XYZ(3,1)+XYZ(3,2))+XYZ(3,3)+XYZ(3,4))
C
         XYZQ(1,4,3,IE)=.125*(3.0*(XYZ(1,5)+XYZ(1,6))+XYZ(1,7)+XYZ(1,8))
         XYZQ(2,4,3,IE)=.125*(3.0*(XYZ(2,5)+XYZ(2,6))+XYZ(2,7)+XYZ(2,8))
         XYZQ(3,4,3,IE)=.125*(3.0*(XYZ(3,5)+XYZ(3,6))+XYZ(3,7)+XYZ(3,8))
C
C     Plane 4
         XYZQ(1,1,4,IE)=.125*(3.0*(XYZ(1,3)+XYZ(1,7))+XYZ(1,1)+XYZ(1,5))
         XYZQ(2,1,4,IE)=.125*(3.0*(XYZ(2,3)+XYZ(2,7))+XYZ(2,1)+XYZ(2,5))
         XYZQ(3,1,4,IE)=.125*(3.0*(XYZ(3,3)+XYZ(3,7))+XYZ(3,1)+XYZ(3,5))
C
         XYZQ(1,2,4,IE)=.125*(3.0*(XYZ(1,4)+XYZ(1,8))+XYZ(1,2)+XYZ(1,6))
         XYZQ(2,2,4,IE)=.125*(3.0*(XYZ(2,4)+XYZ(2,8))+XYZ(2,2)+XYZ(2,6))
         XYZQ(3,2,4,IE)=.125*(3.0*(XYZ(3,4)+XYZ(3,8))+XYZ(3,2)+XYZ(3,6))
C
         XYZQ(1,3,4,IE)=.125*(3.0*(XYZ(1,3)+XYZ(1,4))+XYZ(1,1)+XYZ(1,2))
         XYZQ(2,3,4,IE)=.125*(3.0*(XYZ(2,3)+XYZ(2,4))+XYZ(2,1)+XYZ(2,2))
         XYZQ(3,3,4,IE)=.125*(3.0*(XYZ(3,3)+XYZ(3,4))+XYZ(3,1)+XYZ(3,2))
C
         XYZQ(1,4,4,IE)=.125*(3.0*(XYZ(1,7)+XYZ(1,8))+XYZ(1,5)+XYZ(1,6))
         XYZQ(2,4,4,IE)=.125*(3.0*(XYZ(2,7)+XYZ(2,8))+XYZ(2,5)+XYZ(2,6))
         XYZQ(3,4,4,IE)=.125*(3.0*(XYZ(3,7)+XYZ(3,8))+XYZ(3,5)+XYZ(3,6))
C
  100 CONTINUE
C
C     Find Neighbor-Neighbor connections:
C
      DO 500 IE=1,NEL
      DO 500 IFACE=1,NFACES
      DO 500 IQPT=1,4
C
         NEIGHI=INT(XYZQ(4,IQPT,IFACE,IE))
         IF (NEIGHI.EQ.0) THEN
            IQP1=IQPT+1
            IQP1=MOD1(IQP1,4)
            EPSI=(XYZQ(1,IQPT,IFACE,IE)-XYZQ(1,IQP1,IFACE,IE))**2
     $          +(XYZQ(2,IQPT,IFACE,IE)-XYZQ(2,IQP1,IFACE,IE))**2
     $          +(XYZQ(3,IQPT,IFACE,IE)-XYZQ(3,IQP1,IFACE,IE))**2
C
c           DO 204 JE=1,NEL
c   pff: 4/13/93
            DO 204 JE=ie,Nel
            IF (JE.EQ.IE) GOTO 202
            DIST=(XCEN(IE)-XCEN(JE))**2+(YCEN(IE)-YCEN(JE))**2
     $          +(ZCEN(IE)-ZCEN(JE))**2
            DST2=(RCEN(IE)+RCEN(JE))**2
c           write(6,101) ie,je,dst2,dist,rcen(ie),rcen(je)
  101       format(2x,'dist:',2i3,4f12.7)
            IF (DST2.LT.DIST) GOTO 202
            DO 200 JFACE=1,NFACES
            DO 200 JQPT=1,4
c   pff: 4/13/93
            NEIGHJ=INT(XYZQ(4,IQPT,IFACE,IE))
            IF (NEIGHJ.ne.0) GOTO 200
c   pff: 4/13/93
               JQP1=JQPT+1
               JQP1=MOD1(JQP1,4)
               EPSJ=(XYZQ(1,JQPT,JFACE,JE)-XYZQ(1,JQP1,JFACE,JE))**2
     $             +(XYZQ(2,JQPT,JFACE,JE)-XYZQ(2,JQP1,JFACE,JE))**2
     $             +(XYZQ(3,JQPT,JFACE,JE)-XYZQ(3,JQP1,JFACE,JE))**2
               EPS=EPSM*(EPSJ+EPSI)
               EPS=MAX(EPS,EPSM)
               DIST=(XYZQ(1,IQPT,IFACE,IE)-XYZQ(1,JQPT,JFACE,JE))**2
     $             +(XYZQ(2,IQPT,IFACE,IE)-XYZQ(2,JQPT,JFACE,JE))**2
     $             +(XYZQ(3,IQPT,IFACE,IE)-XYZQ(3,JQPT,JFACE,JE))**2
               IF (DIST.LE.EPS) THEN
C                 We found our match, make a note of it
C                 and move to the next point.
                  NEIGHI=24*(JE-1)+4*(JFACE-1)+JQPT
                  NEIGHJ=24*(IE-1)+4*(IFACE-1)+IQPT
                  INRM=INEIGH(IFACE,JFACE)
                  XYZQ(4,NEIGHJ,1,1)=FLOAT(INRM*NEIGHI)
                  XYZQ(4,NEIGHI,1,1)=FLOAT(INRM*NEIGHJ)
                  GOTO 300
               endif
  200       CONTINUE
  202       CONTINUE
  204       CONTINUE
  300       CONTINUE
         endif
  500 CONTINUE
c
c     Initialize interp routine ---
c
      CALL INTERP(VAL1,xp(1),yp(1),zp(1),idum,wkv1,ierr)
C
C     Diagnostic (1-8-91)
C
c     CALL DRQUAD
C
      return
      end
c-----------------------------------------------------------------------
      subroutine drquad
#     include "basics.inc"
C
      NFACES=6
      DO 600 IE=1,NEL
      DO 600 IFACE=1,NFACES
      DO 600 IQPT=1,4
         ICLR=2*IFACE
c        ICLR=MOD1(ICLR,14)
c        ICLR=5
         CALL COLOR(ICLR)
         CALL XDIAM3(XYZQ(1,IQPT,IFACE,IE))
  600 CONTINUE
C
      return
      end
c-----------------------------------------------------------------------
      subroutine xdiam3(xyz)
c     draws a diamond around XX,YY
#     include "basics.inc"
C
      DIMENSION XYZ(3)
      XX=XISO(XYZ(1),XYZ(2),XYZ(3))
      YY=YISO(XYZ(1),XYZ(2),XYZ(3))
      CALL MOVEC(XX+.0025*XFAC ,YY+.0025*YFAC)
      CALL DRAWC(XX-.0025*XFAC ,YY+.0025*YFAC)
      CALL DRAWC(XX-.0025*XFAC ,YY-.0025*YFAC)
      CALL DRAWC(XX+.0025*XFAC ,YY-.0025*YFAC)
      CALL DRAWC(XX+.0025*XFAC ,YY+.0025*YFAC)
      return
      end
c-----------------------------------------------------------------------
      subroutine mapxc(xyz,ie)
C     Map the element corner points (x,y,z) to standard vector.
#     include "basics.inc"
      DIMENSION INDX(8)
      DIMENSION XYZ(3,8)
      INDX(1)=1
      INDX(2)=2
      INDX(3)=4
      INDX(4)=3
      INDX(5)=5
      INDX(6)=6
      INDX(7)=8
      INDX(8)=7
      NDIM2 = 2**NDIM
C
      DO 50 IX=1,NDIM2
         I=INDX(IX)
         XYZ(1,IX)=X(IE,I)
         XYZ(2,IX)=Y(IE,I)
         XYZ(3,IX)=Z(IE,I)
   50 CONTINUE
      return
      end
c-----------------------------------------------------------------------
      subroutine decod(ix,iy,iz,ie,Jxyz,nx,ny,nz)
C
      ixyz = abs(jxyz)
      NXY  = NX*NY
      NXYZ = NXY*NZ
C
      IE  = (IXYZ + NXYZ - 1)/NXYZ
      IXY = IXYZ-(IE-1)*NXYZ
      IZ  = (IXY + NXY - 1)/NXY
      IXX = IXY-(IZ-1)*NXY
      IY  = (IXX + NX - 1)/NX
      IX  = IXX-(IY-1)*NX
C
C     Check
C
      ICHECK = (IE-1)*NXYZ + (IZ-1)*NXY + (IY-1)*NX + IX
      IF (ICHECK.NE.IXYZ) THEN
         WRITE(6,*) 'hey, what gives here?  icheck,ixyz:',icheck,ixyz
      endif
      return
      end
c-----------------------------------------------------------------------
      subroutine setsrfp(srfqal,nqual,ifld)
      CHARACTER*1 SRFQAL(1)
      CHARACTER*1 CB1,CB
C
#     include "basics.inc"
C
C     Select a list of planes according to the specified boundary
C     qualifications given in SRFQAL.  If the number of qualifications,
C     NQUAL, is negative, select all boundaries NOT meeting the
C     qualifications.
C
C     Note:  Modification 10/2/92 -
C            Set INRM such that the "+" direction associated with the
C            plane has the same direction as the closest fundamental
C            unit vector (e_1,e_2, or e_3).    pff.
C
C
c     NLSTP=0                      pff 12/21/96
      NFACES=2*NDIM
C
      if (nqual.gt.0) then
c
         do iq=1,nqual
            cb1=srfqal(iq)
            if (cb1.eq.'1'.or.cb1.eq.'2'.or.cb1.eq.'3'
     $      .or.cb1.eq.'4'.or.cb1.eq.'5'.or.cb1.eq.'6') then
               read(cb1,1) iface
    1          format(i1)
               do ie=1,nel
                  nlstp=nlstp+1
                  ijkpln=eface1(iface)
                  ix=1
                  if (mod(ijkpln,2).eq.0) ix=nx
                  list(nlstp)=6*nx*(ie-1)+nx*(ijkpln-1)+ix
                  call signpl(list(nlstp))
               enddo
            else
               do ie=1,nel
               do iface=1,nfaces
                  cb=cbc(iface,ie,ifld)
                  if (cb.eq.cb1) then
                     nlstp=nlstp+1
                     ijkpln=eface1(iface)
                     ix=1
                     if (mod(ijkpln,2).eq.0) ix=nx
                     list(nlstp)=6*nx*(ie-1)+nx*(ijkpln-1)+ix
                     call signpl(list(nlstp))
                  endif
               enddo
               enddo
            endif
         enddo
C
      ELSE
C
c        open(unit=55,file='bdry')
         NQ=-NQUAL
         DO 300 IE=1,NEL
         DO 300 IFACE=1,NFACES
            CB=CBC(IFACE,IE,IFLD)
            DO 200 IQ=1,NQ
               CB1=SRFQAL(IQ)
C              if it's one of these, don't plot.
               IF (CB1.EQ.CB) GOTO 300
  200       CONTINUE
C
C           Since the b.c. isn't one of the one's specified, we plot
C           this surface....
            NLSTP=NLSTP+1
            IJKPLN=EFACE1(IFACE)
c           call outvtx(ie,iface,55)
            IX=1
            IF (MOD(IJKPLN,2).EQ.0) IX=NX
            LIST(NLSTP)=6*NX*(IE-1)+NX*(IJKPLN-1)+IX
            CALL SIGNPL(LIST(NLSTP))
  300    CONTINUE
c        close(unit=55)
C
      endif
      return
      end
c-----------------------------------------------------------------------
      subroutine sortl
#     include "basics.inc"
      include 'basicsp.inc'
      COMMON /CTMPS1/ IND(NELM,6),WK(NELM,6)
C
      NXY =NX*NY
      NXYZ=NZ*NXY
c
c     March over all mirror configurations, all planes
c
      i = 0
      do im  =1,nmirror
         do ipl =1,nlstp
            i = i+1
            LISTA=ABS(LIST(ipl))
            CALL DECOD(IPLANE,IPLN,IE,IDUM,LISTA,NX,6,NELM)
c
c           Z-sort based on centerpoint of selected plane
c
            IX=(NX+1)/2
            IY=(NY+1)/2
            IZ=(NZ+1)/2
            IF (IPLN.LE.2) THEN
               IX=IPLANE
            ELSEIF (IPLN.LE.4) THEN
               IY=IPLANE
            ELSE
               IZ=IPLANE
            endif
c
            IEOFF=NXYZ*(IE-1)+NXY*(IZ-1)+NX*(IY-1)+IX
            if (im.eq.1) then
               ZDEPTH(I,1)=ZISO(XP(IEOFF),YP(IEOFF),ZP(IEOFF))
            else
               call mirror(xmi,ymi,zmi,xp(ieoff),yp(ieoff),zp(ieoff),im)
               ZDEPTH(I,1)=ZISO(xmi,ymi,zmi)
            endif
            lmir(i) = im
         enddo
         call icopy(lisw(1+(im-1)*nlstp),list,nlstp)
      enddo
      CALL SORT(ZDEPTH,   IND,NLSTP*nmirror)
      CALL ISWAP(LISW ,WK,IND,NLSTP*nmirror)
      CALL ISWAP(lmir ,WK,IND,NLSTP*nmirror)
C
      return
      end
c-----------------------------------------------------------------------
      subroutine signpl(lplane)
C
C     Find the closest component of (1,1,1) to the normal associated
C     with this plane, and assign the sign of the dot product of that
C     component with the normal to Lplane.
C     11/92 pff.
C
#     include "basics.inc"
      include 'basicsp.inc'
      DIMENSION VEC0(3),VEC1(3),VEC2(3),VEC3(3)
C
      CALL DECOD(IPLANE,IPLN,IE,IDUM,Lplane,NX,6,NELM)
C
      I=(1+NX)/2
      J=(1+NY)/2
      K=(1+NZ)/2
C
      Nxyz=Nx*Ny*Nz
      Nxy =Nx*Ny
C
      IF (IPLN.LE.2) THEN
         I =IPLANE
         ieoff1 = nxyz*(ie-1)+nxy*(k-1)+nx*(j  )+i
         ieoff2 = nxyz*(ie-1)+nxy*(k  )+nx*(j-1)+i
      ELSEIF (IPLN.LE.4) THEN
         J =IPLANE
         ieoff1 = nxyz*(ie-1)+nxy*(k-1)+nx*(j-1)+i+1
         ieoff2 = nxyz*(ie-1)+nxy*(k  )+nx*(j-1)+i
      ELSE
         K =IPLANE
         ieoff1 = nxyz*(ie-1)+nxy*(k-1)+nx*(j-1)+i+1
         ieoff2 = nxyz*(ie-1)+nxy*(k-1)+nx*(j  )+i
      endif
      ieoff  = nxyz*(ie-1)+nxy*(k-1)+nx*(j-1)+i
C
      VEC0(1)=Xp(ieoff)
      VEC0(2)=Yp(ieoff)
      VEC0(3)=Zp(ieoff)
C
      VEC1(1)=Xp(ieoff1)
      VEC1(2)=Yp(ieoff1)
      VEC1(3)=Zp(ieoff1)
C
      VEC2(1)=Xp(ieoff2)
      VEC2(2)=Yp(ieoff2)
      VEC2(3)=Zp(ieoff2)
C
      CALL SUB3  (VEC1,VEC1,VEC0,3)
      CALL SUB3  (VEC2,VEC2,VEC0,3)
      CALL CROSS (VEC0,VEC1,VEC2)
      CALL NORM3D(VEC0)
C
      Vmax=0.0
      DO 10 I=1,3
         IF (ABS(VEC0(i)).GT.Vmax) THEN
             Vmax=ABS(VEC0(i))
             Imax=i
         endif
   10 CONTINUE
      IF (VEC0(Imax).LT.0.0) Lplane=-abs(Lplane)
c     write(6,*) ie,vec0(imax),lplane,' signpl'
      return
      end
c-----------------------------------------------------------------------
      subroutine gencen
#     include "basics.inc"
C
C     Generate the element centers
C
      IF (IF3D) THEN
         DO 100 IEL=1,NEL
            XCEN(IEL)=( X(IEL,1)+X(IEL,2)+X(IEL,3)+X(IEL,4)
     $               +  X(IEL,5)+X(IEL,6)+X(IEL,7)+X(IEL,8))/8.
            YCEN(IEL)=( Y(IEL,1)+Y(IEL,2)+Y(IEL,3)+Y(IEL,4)
     $               +  Y(IEL,5)+Y(IEL,6)+Y(IEL,7)+Y(IEL,8))/8.
            ZCEN(IEL)=( Z(IEL,1)+Z(IEL,2)+Z(IEL,3)+Z(IEL,4)
     $               +  Z(IEL,5)+Z(IEL,6)+Z(IEL,7)+Z(IEL,8))/8.
  100    CONTINUE
      ELSE
         DO 200 IEL=1,NEL
            XCEN(IEL)=(X(IEL,1)+X(IEL,2)+X(IEL,3)+X(IEL,4))/4.
            YCEN(IEL)=(Y(IEL,1)+Y(IEL,2)+Y(IEL,3)+Y(IEL,4))/4.
            ZCEN(IEL)=0.0
  200    CONTINUE
      endif
C
C     Compute the maximum radius from the center
C
      CALL RZERO(RCEN,NEL)
      IF (IF3D) THEN
         DO 300 IEL=1,NEL
         DO 300 J=1,8
            RAD=(X(IEL,J)-XCEN(IEL))**2 + (Y(IEL,J)-YCEN(IEL))**2
     $         +(Z(IEL,J)-ZCEN(IEL))**2
            RCEN(IEL)=MAX(RCEN(IEL),RAD)
  300    CONTINUE
      ELSE
         DO 400 IEL=1,NEL
         DO 400 J=1,4
            RAD=(X(IEL,J)-XCEN(IEL))**2 + (Y(IEL,J)-YCEN(IEL))**2
            RCEN(IEL)=MAX(RCEN(IEL),RAD)
  400    CONTINUE
      endif
      CALL VSQRT(RCEN,NEL)
C
      return
      end
c-----------------------------------------------------------------------
      subroutine clip_plane
C     Set up list of candidate RST planes
#     include "basics.inc"
      include 'basicsp.inc'
      COMMON /PFFLG/  ILGRNG,ISCND,IENTRP,INEWTX
      DIMENSION VEC(3),VEC1(3),VEC2(3),VEC3(3)
      CHARACTER*1 cplane,dplane
      LOGICAL IFANY,IFTMP
c
      IND(I,J,K,IEL)=I+NX*(J-1)+NX*NY*(K-1)+NX*NY*NZ*(IEL-1)
C
      CALL PRS('Clip in X, Y, or Z ?$')
      CALL RES(cplane,1)
      call capit(cplane,1)
      write(6,*)'cplane : ',cplane
c
      CALL PRS('Enter location of clipping plane:$')
      CALL RER(clipping_plane)
c
      CALL PRS
     $('Enter "<" or ">" if you wish to remove below or above plane.$')
      CALL RES(dplane,1)
c
C     3-D
C
      inew = 0
      DO 6000 I=1,NLSTP
C
C           New plotting algorithms for color fill and fishnet - pff 7-1-90
C           (3D will come later - 10-10-90)
C
         LISTA=ABS(LIST(I))
         CALL DECOD(IPLANE,IPLN,IE,IDUM,LISTA,NX,6,NELM)
         I1=1
         I2=NX
         J1=1
         J2=NY
         K1=1
         K2=NZ
         IF (IPLN.LE.2) THEN
            I1=IPLANE
            I2=IPLANE
         ELSEIF (IPLN.LE.4) THEN
            J1=IPLANE
            J2=IPLANE
         ELSE
            K1=IPLANE
            K2=IPLANE
         endif
c
         DO 5001 IZ=K1,K2
         DO 5001 IY=J1,J2
         DO 5001 IX=I1,I2
            IPOINT=IND(IX,IY,IZ,IE)
c
            if (cplane.eq.'X') qq = xp(ipoint)
            if (cplane.eq.'Y') qq = yp(ipoint)
            if (cplane.eq.'Z') qq = zp(ipoint)
c
c           See if we delete this plane from the list
            if (dplane.eq.'<'.and.qq.lt.clipping_plane) goto 5002
            if (dplane.eq.'>'.and.qq.gt.clipping_plane) goto 5002
c
 5001    CONTINUE
c        If we get here, then all points are included
         inew = inew+1
         list(inew) = list(i)
c
 5002    CONTINUE
 6000 CONTINUE
      nlstp = inew
      return
      end
c-----------------------------------------------------------------------
      subroutine mirror(xm,ym,zm,xi,yi,zi,m)
c
c     Based on mirror specification number, m,  compute the reflected
c     image of xi,yi,zi
c
c     For now, we support only one mirror -- that is the y=0 plane
c
      xm =  xi
      ym = -yi
      zm =  zi
c
      return
      end
c-----------------------------------------------------------------------
      subroutine vmirror(tm,xm,ym,zm,n,m)
      real tm(n,n),xm(n,n),ym(n,n),zm(n,n)
c
c     Based on mirror specification number, m,  compute the reflected
c     image of xi,yi,zi
c
c     For now, we support only one mirror -- that is the y=0 plane
c
      if (m.eq.2) then
         do i=1,n*n
            ym(i,1) = -ym(i,1)
         enddo
      endif
c
      return
      end
c-----------------------------------------------------------------------
      subroutine outvtx(ie,ifce,io)
c
#     include "basics.inc"
c
      integer fv3(4,6)
      save    fv3
      data    fv3 /  1,2,5,6
     $            ,  2,3,6,7
     $            ,  3,4,7,8
     $            ,  1,4,5,8
     $            ,  1,2,3,4
     $            ,  5,6,7,8  /
c
c     Output coordinates of this face
c
      xa = 0
      ya = 0
      za = 0
c
      do iv=1,4
         xa = xa+0.25*x(ie,fv3(iv,ifce))
         ya = ya+0.25*y(ie,fv3(iv,ifce))
         za = za+0.25*z(ie,fv3(iv,ifce))
      enddo
      write(io,1) xa,ya,za
    1 format(3f14.4)
c
      return
      end
c-----------------------------------------------------------------------
      subroutine assign_bc
c
c     prompt user for new bc to be applied to currently selected planes
c
#     include "basics.inc"
      include 'basicsp.inc'
c
      return
      end
c-----------------------------------------------------------------------
      subroutine gaujordf(a,m,n,indr,indc,ipiv,ierr)
C
C     Gauss-Jordan matrix inversion with full pivoting
c
c     Num. Rec. p. 30, 2nd Ed., Fortran
c
C
C     A is an nxn matrix, assumed contiguous in memory
C     W is a  work array of dimension n
C
      real    a(m,n)
      integer indr(m),indc(n),ipiv(n)
c
      real rmult
      integer wdsize
c
      ierr = 0
c
      eps = 1.e-12
      one = 1.
      wdsize = 8
      if (one+eps.eq.1.) wdsize = 4
c
      call izero(ipiv,n)
c
c
      do j=1,n
         amx=0.
c
c        Pivot search
         do i=1,m
            if (ipiv(i).ne.1) then
               do k=1,n
                  if (ipiv(k).eq.0) then
                    if (abs(a(i,k)).ge.amx) then
                       amx = abs(a(i,k))
                       ir  = i
                       jc  = k
                    endif
                 elseif (ipiv(k).gt.1) then
                    ierr = -ipiv(k)
                    return
                 endif
              enddo
           endif
        enddo
        ipiv(jc) = ipiv(jc) + 1
c
c       Swap rows
        if (ir.ne.jc) then
           do k=1,n
              tmp     = a(ir,k)
              a(ir,k) = a(jc,k)
              a(jc,k) = tmp
           enddo
        endif
        indr(j)=ir
        indc(j)=jc
        if (abs(a(jc,jc)).lt.eps) then
           write(6,*) 'small Gauss Jordan Piv:',jc,a(jc,jc)
           ierr = jc
           return
        endif
        piv = 1./a(jc,jc)
        a(jc,jc)=1.
        do k=1,n
           a(jc,k) = a(jc,k)*piv
        enddo
c
        do i=1,m
           if (i.ne.jc) then
              rmult   = a(i,jc)
              a(i,jc) = 0.
              do k=1,n
                 a(i,k) = a(i,k) - rmult*a(jc,k)
              enddo
           endif
        enddo
      enddo
c
c     Unscramble matrix
      do k=n,1,-1
         if (indr(k).ne.indc(k)) then
            do i=1,m
               tmp=a(i,indr(k))
               a(i,indr(k))=a(i,indc(k))
               a(i,indc(k))=tmp
            enddo
         endif
      enddo
c
      return
      end
c-----------------------------------------------------------------------
      subroutine shiftcg
c
c     prompt user for new cg and translate geometry to this location
c
#     include "basics.inc"
      include 'basicsp.inc'
c
      real cgx,cgy,cgz
      real ngx,ngy,ngz
      character*80 fnm
c
      ntot= nx*ny*nz*nel
      mtot= nelm*8
      if (if3d) then
         call vol_int(cgx,vol,xp)
         call vol_int(cgy,vol,yp)
         call vol_int(cgz,vol,zp)
         cgx = cgx/vol
         cgy = cgy/vol
         cgz = cgz/vol
         call prsrrr('Old CG: $',cgx,cgy,cgz)
c
c        call prs   ('Input new CG: $')
c        call rerrr (ngx,ngy,ngz)
c
         call prs ('Input file containing new matrix:$')
         call blank(fnm,80)
         call res (fnm,80)
         open (unit=88,file=fnm,status='old',err=999)
         read (88,*,err=9999,end=9999) ngx,ngy,ngz
         close (unit=88)
c
         dx = ngx-cgx
         dy = ngy-cgy
         dz = ngz-cgz
         call cadd(xp,dx,ntot)
         call cadd(yp,dy,ntot)
         call cadd(zp,dz,ntot)
         call cadd(x ,dx,mtot)
         call cadd(y ,dy,mtot)
         call cadd(z ,dz,mtot)
      else
         call vol_int(cgx,vol,xp)
         call vol_int(cgy,vol,yp)
         cgx = cgx/vol
         cgy = cgy/vol
         call prsrr ('Old CG: $',cgx,cgy)
         call prs   ('Input new CG: $')
         call rerr  (ngx,ngy)
         dx = ngx-cgx
         dy = ngy-cgy
         call cadd(xp,dx,ntot)
         call cadd(yp,dy,ntot)
         call cadd(x ,dx,mtot)
         call cadd(y ,dy,mtot)
      endif
c
      call gencen
      call coef
      return
c
  999 continue
      call prs('Problem opening file.$')
      return
c
 9999 continue
      call prs('Problem reading file.$')
      close (unit=88)
      return
c
      end
c-----------------------------------------------------------------------
      subroutine shiftmom
c
c     prompt user for new cg and translate geometry to this location
c
#     include "basics.inc"
      include 'basicsp.inc'
c
      real ixx,iyy,izz,ixy,ixz,iyz
      real m(3,3),lam(3),wrk(9)
      real n(3,3),r(3,3)
      integer indr(3),indc(3),ipiv(3)
      character*80 fnm
c
      ntot= nx*ny*nz*nel
      if (if3d) then
         call vol_int(cgx,vol,xp)
         call vol_int(cgy,vol,yp)
         call vol_int(cgz,vol,zp)
         cgx = cgx/vol
         cgy = cgy/vol
         cgz = cgz/vol
         cgxm=-cgx
         cgym=-cgy
         cgzm=-cgz
c
         call cadd2(wkv1,xp,cgxm,ntot)
         call cadd2(wkv2,yp,cgym,ntot)
         call cadd2(wkv3,zp,cgzm,ntot)
         call vol_int2(ixx,vol,wkv1,wkv1)
         call vol_int2(iyy,vol,wkv2,wkv2)
         call vol_int2(izz,vol,wkv3,wkv3)
         call vol_int2(ixy,vol,wkv1,wkv2)
         call vol_int2(ixz,vol,wkv1,wkv3)
         call vol_int2(iyz,vol,wkv2,wkv3)
c
         ixx = ixx/vol
         iyy = iyy/vol
         izz = izz/vol
         ixy = ixy/vol
         ixz = ixz/vol
         iyz = iyz/vol
c
         a = iyy+izz
         b = izz+ixx
         c = ixx+iyy
c
         f = iyz
         g = ixz
         h = ixy
c
         m(1,1) =  a
         m(1,2) = -h
         m(1,3) = -g
c
         m(2,1) = -h
         m(2,2) =  b
         m(2,3) = -f
c
         m(3,1) = -g
         m(3,2) = -f
         m(3,3) =  c
c

         call ssyev('V','U',3,M,3,lam,wrk,9,info)
c
         if (info.ne.0) then
            call prsi('Returning. ssyev info not 0:$',info)
            return
         endif
c
         call prsrrr('Vec 1:$',m(1,1),m(2,1),m(3,1))
         call prsrrr('Vec 2:$',m(1,2),m(2,2),m(3,2))
         call prsrrr('Vec 3:$',m(1,3),m(2,3),m(3,3))
c
         call outmat(m,3,3,'Mom')
c
c        call prs   ('Input new matrix $')
c        call prs   ('Vec 1:$')
c        call rerrr (n(1,1),n(2,1),n(3,1))
c        call prs   ('Vec 2:$')
c        call rerrr (n(1,2),n(2,2),n(3,2))
c        call prs   ('Vec 3:$')
c        call rerrr (n(1,3),n(2,3),n(3,3))
c
         call prs ('Input file containing new matrix:$')
         call blank(fnm,80)
         call res (fnm,80)
         open (unit=88,file=fnm,status='old',err=999)
         read (88,*,err=9999,end=9999) ((n(i,j),j=1,3),i=1,3)
         close (unit=88)
c
c
c        X" = R X'  ==>    R  =  X" (X')^-1
c
         do k=1,3
            call norm3d(m(1,k))
            call norm3d(n(1,k))
         enddo
c
         call outmat   (m,3,3,'mb4')
c        call gaujord  (m,3,3,wrk,info)
         call gaujordf (m,3,3,indr,indc,ipiv,info)
         call outmat   (m,3,3,'maf')
         call outmat   (n,3,3,'nb4')
         call mxm      (n,3,m,3,r,3)
         call outmat   (r,3,3,'Rot')
c
         if (info.ne.0) then
            call prsi('Returning. gaujord info not 0:$',info)
            return
         endif
c
c        Rotation matrix set, apply to every point on the planet
c
         do i=1,ntot
            xn = r(1,1)*wkv1(i)+r(1,2)*wkv2(i)+r(1,3)*wkv3(i)+cgx
            yn = r(2,1)*wkv1(i)+r(2,2)*wkv2(i)+r(2,3)*wkv3(i)+cgy
            zn = r(3,1)*wkv1(i)+r(3,2)*wkv2(i)+r(3,3)*wkv3(i)+cgz
            xp(i) = xn
            yp(i) = yn
            zp(i) = zn
         enddo
c
         do ie=1,nel
         do ic=1,8
            xo = x(ie,ic)-cgx
            yo = y(ie,ic)-cgy
            zo = z(ie,ic)-cgz
            xn = r(1,1)*xo+r(1,2)*yo+r(1,3)*zo
            yn = r(2,1)*xo+r(2,2)*yo+r(2,3)*zo
            zn = r(3,1)*xo+r(3,2)*yo+r(3,3)*zo
            x(ie,ic) = xn + cgx
            y(ie,ic) = yn + cgy
            z(ie,ic) = zn + cgz
         enddo
         enddo
      endif
c
      call gencen
      call coef
      return
c
  999 continue
      call prs('Problem opening file.$')
      return
c
 9999 continue
      call prs('Problem reading file.$')
      close (unit=88)
      return
c
      end
c-----------------------------------------------------------------------
      subroutine mapz(f,regdir)
#     include "basics.inc"
c
      real f(1)
      real gll_pts(nxm),gll_wts(nxm),i(nxm*nxm),it(nxm*nxm)
      real w(nxm*nxm*nxm)
      character*1 regdir
c
      integer e
c
c     This routine maps data from GLL points to uniform points in
c     the z direction only.   This is really a special purpose routine...
c
      call legend(gll_pts,gll_wts,nx)
c
c     Use Fornberg's routine to compute interpolation coefficients
c
      nx1 = nx-1
      l   = 1
      mx  = nx
      do k=1,mx
         z0 = (2.*(k-1))/(mx-1) - 1.
         call fd_weights_full(z0,gll_pts,nx1,0,it(l))
         l  = l+nx
      enddo
      call transpose(i,mx,it,nx)
c
      if (regdir.eq.'z'.or.regdir.eq.'Z') then
         nxy  = nx*ny
         nxyz = nx*ny*nz
         l = 1
         do e=1,nel
            call mxm (f(l),nxy,it,nz,w,nz)
            call copy(f(l),w,nxyz)
            l = l+nxyz
         enddo
      elseif (regdir.eq.'x'.or.regdir.eq.'X') then
         nyz  = ny*nz
         nxyz = nx*ny*nz
         l = 1
         do e=1,nel
            call mxm (i,nx,f(l),nx,w,nyz)
            call copy(f(l),w,nxyz)
            l = l+nxyz
         enddo
      else
         call prs('Sorry, direction is not currently supported$')
         write(6,*) 'Direction: ',regdir
      endif
      return
      end
c-----------------------------------------------------------------------
      subroutine setsrfp_periodic(e,f,e1,f1,ifld)

#     include "basics.inc"

      integer e,f,e1,f1,e0,f0
c
c     Select a pair of planes w / periodic bcs
c
      nlstp=0
      nfaces=2*ndim
c
      nlstp=nlstp+1
      ijkpln=eface1(f)
      ix=1
      if (mod(ijkpln,2).eq.0) ix=nx
      list(nlstp)=6*nx*(e-1)+nx*(ijkpln-1)+ix
      call signpl(list(nlstp))
c
      e1 = bc(1,f,e,ifld)
      f1 = bc(2,f,e,ifld)
c
      e0 = bc(1,f1,e1,ifld)
      f0 = bc(2,f1,e1,ifld)
c
      if (e0.ne.e .or. f0.ne.f) then
         call prsiii('Element RECIPROCITY FAIL:$',e,e0,e1)
         call prsiii('Face    RECIPROCITY FAIL:$',f,f0,f1)
      else
         nlstp=nlstp+1
         ijkpln=eface1(f1)
         ix=1
         if (mod(ijkpln,2).eq.0) ix=nx
         list(nlstp)=6*nx*(e1-1)+nx*(ijkpln-1)+ix
         call signpl(list(nlstp))
         call prsiv('Reciprocity OK:$',e,f,e1,f1)
      endif
c
      return
      end
c-----------------------------------------------------------------------
      subroutine periodic_check

#     include "basics.inc"

      integer e,f,e1,f1,e0,f0
c
c     Select a pair of planes w / periodic bcs
c
      ifld = 2
      if (ifflow) ifld = 1
c
      nfaces = 2*ndim
      do e=1,nel
      do f=1,nfaces
         write(6,*) e,f,cbc(f,e,ifld),' CBC'
         if (cbc(f,e,ifld).eq.'P  ') then
            call setsrfp_periodic(e,f,e1,f1,ifld)
            call tem
            call prsiv('Plotted e,f:$',e,f,e1,f1)
            call prs  ('Continue (y/n) ?$')
            call res  (ans,1)
            if (ans.eq.'n'.or.ans.eq.'N') return
         endif
      enddo
      enddo
c
      return
      end
c-----------------------------------------------------------------------


*DECK DQDOTA
      DOUBLE PRECISION FUNCTION DQDOTA (N, DB, QC, DX, INCX, DY, INCY)
C***BEGIN PROLOGUE  DQDOTA
C***PURPOSE  Compute the inner product of two vectors with extended
C            precision accumulation and result.
C***LIBRARY   SLATEC
C***CATEGORY  D1A4
C***TYPE      DOUBLE PRECISION (DQDOTA-D)
C***KEYWORDS  DOT PRODUCT, INNER PRODUCT
C***AUTHOR  Lawson, C. L., (JPL)
C           Hanson, R. J., (SNLA)
C           Kincaid, D. R., (U. of Texas)
C           Krogh, F. T., (JPL)
C***DESCRIPTION
C
C               B L A S  Subprogram
C   Description of Parameters
C
C    --Input--
C       N  number of elements in input vector(S)
C      DB  double precision scalar to be added to inner product
C      QC  extended precision scalar to be added to inner product
C      DX  double precision vector with N elements
C    INCX  storage spacing between elements of DX
C      DY  double precision vector with N elements
C    INCY  storage spacing between elements of DY
C
C    --Output--
C  DQDOTA  double precision result
C      QC  extended precision result
C
C    D.P. dot product with extended precision accumulation (and result)
C    QC and DQDOTA are set = DB + QC + sum for I = 0 to N-1 of
C      DX(LX+I*INCX) * DY(LY+I*INCY),  where QC is an extended
C      precision result previously computed by DQDOTI or DQDOTA
C      and LX = 1 if INCX .GE. 0, else LX = (-INCX)*N, and LY is
C      defined in a similar way using INCY.  The MP package by
C      Richard P. Brent is used for the extended precision arithmetic.
C
C    Fred T. Krogh,  JPL,  1977,  June 1
C
C    The common block for the MP package is name MPCOM.  If local
C    variable I1 is zero, DQDOTA calls MPBLAS to initialize
C    the MP package and reset I1 to 1.
C
C    The argument QC(*) and the local variables QX and QY are INTEGER
C    arrays of size 30.  See the comments in the routine MPBLAS for the
C    reason for this choice.
C
C***REFERENCES  C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T.
C                 Krogh, Basic linear algebra subprograms for Fortran
C                 usage, Algorithm No. 539, Transactions on Mathematical
C                 Software 5, 3 (September 1979), pp. 308-323.
C***ROUTINES CALLED  MPADD, MPBLAS, MPCDM, MPCMD, MPMUL
C***COMMON BLOCKS    MPCOM
C***REVISION HISTORY  (YYMMDD)
C   791001  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C   930124  Increased Array sizes for SUN -r8.  (RWC)
C***END PROLOGUE  DQDOTA
      DOUBLE PRECISION DX(*), DY(*), DB
      INTEGER  QC(30), QX(30), QY(30)
      COMMON /MPCOM/  MPB, MPT, MPM, MPLUN, MPMXR, MPR(30)
      SAVE I1
      DATA  I1 / 0 /
C***FIRST EXECUTABLE STATEMENT  DQDOTA
      IF (I1 .EQ. 0) CALL MPBLAS(I1)
      IF (DB .EQ. 0.D0) GO TO 20
      CALL MPCDM(DB, QX)
      CALL MPADD(QC, QX, QC)
   20 IF (N .EQ. 0) GO TO 40
      IX = 1
      IY = 1
      IF (INCX .LT. 0) IX = (-N + 1) * INCX + 1
      IF (INCY .LT. 0) IY = (-N + 1) * INCY + 1
      DO  30  I = 1,N
         CALL MPCDM(DX(IX), QX)
         CALL MPCDM(DY(IY), QY)
         CALL MPMUL(QX, QY, QX)
         CALL MPADD(QC, QX, QC)
         IX = IX + INCX
         IY = IY + INCY
   30 CONTINUE
   40 CALL MPCMD(QC, DQDOTA)
      RETURN
      END


      subroutine runY_00llll(k,l,Xtwiddle,Gtwiddle,Shat6,N0)
      implicit none
C---  Expression for extension of Eq. 5.60a
C---  Calculates D00llll
C---  Small terms of order Xtwiddle(0,k)*Diiiii,Xtwiddle(0,0)*Diiiiii
C---  Denominator Gtwiddle(k,l)
      include 'pvDnames.f'
      include 'pvDv.f'
      include 'Darraydef.f'
      include 'Darrays.f'
      integer ep,N0,k,l,np
      parameter(np=3)
      double precision Xtwiddle(0:np,0:np),Gtwiddle(np,np)
      double complex Shat6(np,z5max,-2:0)

      do ep=-2,0
      Dv(dzziiii(z4(l,l,l,l))+N0,ep)=
     . (Gtwiddle(k,1)*Shat6(1,z5(l,l,l,l,l),ep)
     . +Gtwiddle(k,2)*Shat6(2,z5(l,l,l,l,l),ep)
     . +Gtwiddle(k,3)*Shat6(3,z5(l,l,l,l,l),ep)
     . +Xtwiddle(k,0)*Dv(diiiii(z5(l,l,l,l,l))+N0,ep)
     . -Xtwiddle(0,0)*Dv(diiiiii(z6(k,l,l,l,l,l))+N0,ep))
     . /(10d0*Gtwiddle(k,l))
      enddo

      return
      end


      SUBROUTINE SETK08(NA,NC,A,C,PTK,NPTK,IDEF,NTET,NKMAX,NTMAX)
C     SET THE K-POINTS IN THE 1/16TH OF THE BRILLOUIN ZONE FOR A
C     SIMPLE TETRAGONAL LATTICE WITH PARAMETERS A, C
C     SYMMETRY IS D4H
      IMPLICIT REAL*8(A-H,O-Z)
      REAL*4 AVOL
      DIMENSION PTK(4,NKMAX),IDEF(5,NTMAX)
      EQUIVALENCE (IVOL,AVOL)
      PI = 3.141592653589793238D0
      IF(NA.LE.0.OR.NC.LE.0) GOTO 97
      IF(A.LE.0.0D0 .OR. C.LE.0.0D0) GOTO 98
      NPTK = (NA+1)*(NA+2)*(NC+1)/2
      IF(NPTK.GT.NKMAX) STOP '*** <SETK08> NPTK EXCEEDS NKMAX ***'
      NTET = 3*NC*NA**2
      IF(NTET.GT.NTMAX) STOP '*** <SETK08> NTET EXCEEDS NTMAX ***'
C *** SET THE K-POINTS
      AK=PI/A/NA
      CK=PI/C/NC
      WRITE(6,100) NPTK,NTET,NA*AK,NA*AK,NC*CK
      W = 2.0D0/(NA*NA*NC)
      NPTK=0
      DO 1 I=0,NA,1
      DO 1 J=0,I,1
      DO 1 K=0,NC,1
C        NPTK = I*(I+1)/2*NZ1 + J*NZ1 + K+1
      WK = W
      IF(I.EQ.0) WK = WK/2.0D0
      IF(J.EQ.0) WK = WK/2.0D0
      IF(J.EQ.I) WK = WK/2.0D0
      IF(I.EQ.NA) WK = WK/2.0D0
      IF(J.EQ.NA) WK = WK/2.0D0
      IF(K.EQ.0 .OR. K.EQ.NC) WK = WK/2.0D0
      NPTK=NPTK+1
      PTK(1,NPTK)=I*AK
      PTK(2,NPTK)=J*AK
      PTK(3,NPTK)=K*CK
      PTK(4,NPTK)=WK
    1 CONTINUE
C *** DEFINE THE TETRAHEDRA
      NZ1=NC+1
      NTET=0
      I7=0
      I=0
    4 IX=(I+1)*NZ1
      J = 0
    5 K=0
      I7=I*IX/2+J*NZ1
    6 I7=I7+1
      I6=I7+IX
      I2=I6+NZ1
      I1=I2+1
      NTET=NTET+1
      IDEF(1,NTET)=I7
      IDEF(2,NTET)=I6
      IDEF(3,NTET)=I2
      IDEF(4,NTET)=I1
      I8=I7+1
      I5=I6+1
      NTET=NTET+1
      IDEF(1,NTET)=I7
      IDEF(2,NTET)=I6
      IDEF(3,NTET)=I5
      IDEF(4,NTET)=I1
      NTET=NTET+1
      IDEF(1,NTET)=I7
      IDEF(2,NTET)=I8
      IDEF(3,NTET)=I5
      IDEF(4,NTET)=I1
      IF(J.EQ.I) GOTO 7
      I3=I7+NZ1
      I4=I3+1
      NTET=NTET+1
      IDEF(1,NTET)=I7
      IDEF(2,NTET)=I3
      IDEF(3,NTET)=I2
      IDEF(4,NTET)=I1
      NTET=NTET+1
      IDEF(1,NTET)=I7
      IDEF(2,NTET)=I3
      IDEF(3,NTET)=I4
      IDEF(4,NTET)=I1
      NTET=NTET+1
      IDEF(1,NTET)=I7
      IDEF(2,NTET)=I8
      IDEF(3,NTET)=I4
      IDEF(4,NTET)=I1
    7 K=K+1
      IF(K.LT.NC) GOTO 6
      J=J+1
      IF(J.LE.I) GOTO 5
      I=I+1
      IF(I.LT.NA) GOTO 4
      AVOL=1.D0/DFLOAT(NTET)
      DO 15 IT=1,NTET
   15 IDEF(5,IT)=IVOL
      RETURN
   97 WRITE(6,101)
      GOTO 99
   98 WRITE(6,102)
   99 STOP
  100 FORMAT(' SAMPLING THE 16TH PART OF A SQUARE-BASED PRISM'/
     .1X,I5,' K-POINTS',I7,' TETRAHEDRA'/
     .' KXMAX =',D11.4,'  KYMAX =',D11.4,'  KZMAX =',D11.4)
  101 FORMAT(' *** <SETK08> NA OR NC IS NOT A POSITIVE INTEGER ***')
  102 FORMAT(' *** <SETK08> A AND C MUST BE POSITIVE ***')
      END


! Copyright (c) 2019 Etienne Descamps
! All rights reserved.
!
! Redistribution and use in source and binary forms, with or without modification,
! are permitted provided that the following conditions are met:
!
! 1. Redistributions of source code must retain the above copyright notice,
!    this list of conditions and the following disclaimer.
!
! 2. Redistributions in binary form must reproduce the above copyright notice,
!    this list of conditions and the following disclaimer in the documentation and/or
!    other materials provided with the distribution.
!
! 3. Neither the name of the copyright holder nor the names of its contributors may be
!    used to endorse or promote products derived from this software without specific prior
!    written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
! ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
! WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
! IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
! INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
! (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
! LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
! THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
! NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE,
! EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

Module mlf_distribution
  Use ieee_arithmetic
  Use iso_c_binding
  Use mlf_utils
  Use mlf_cfuns
  IMPLICIT NONE
  PRIVATE

  Integer, Public, Parameter :: mlf_dist_mode = 1, mlf_dist_median = 2, mlf_dist_mean = 3
  Integer, Public, Parameter :: mlf_dist_geom_mean = 4

  Type, Public, Abstract :: mlf_distribution_abstract
  Contains
    procedure(mlf_distribution_getParameters), deferred :: getParameters
    procedure(mlf_distribution_withParameters), deferred :: withParameters
  End Type mlf_distribution_abstract

  Type, Public, Abstract, Extends(mlf_distribution_abstract) :: mlf_distribution_multivariate
  Contains
    procedure(mlf_multivariate_fitWithData), deferred :: fitWithData
    procedure(mlf_multivariate_computePDF), deferred :: computePDF
    procedure :: computeLogPDF => mlf_multivariate_computeLogPDF
  End Type mlf_distribution_multivariate

  Type, Public, Abstract, Extends(mlf_distribution_abstract) :: mlf_distribution_univariate
  Contains
    procedure(mlf_univariate_fitWithData), deferred :: fitWithData
    procedure(mlf_univariate_computePDF), deferred :: computePDF
    procedure :: computeLogPDF => mlf_univariate_computeLogPDF
    procedure(mlf_univariate_getStats), deferred :: getStats
  End Type mlf_distribution_univariate

  Type, Public, Abstract, Extends(mlf_distribution_univariate) :: mlf_distributionWithCDF_type
  Contains
    procedure(mlf_univariate_computeCDF), deferred :: computeCDF
    procedure :: integrateIncomplete => mlf_univariate_integrateIncomplete
  End Type mlf_distributionWithCDF_type

  Type, Public, Abstract, Extends(mlf_distributionWithCDF_type) :: mlf_distributionWithQuantile_type
  Contains
    procedure(mlf_univariate_quantile), deferred :: quantile
    procedure :: quantileTable => mlf_univariate_quantileTable
  End Type mlf_distributionWithQuantile_type

  Abstract Interface
    Integer Function mlf_distribution_getParameters(this, X)
      Use iso_c_binding
      import :: mlf_distribution_abstract
      class(mlf_distribution_abstract), intent(in) :: this
      real(c_double), intent(out) :: X(:)
    End Function mlf_distribution_getParameters

   Integer Function mlf_distribution_withParameters(this, X)
      Use iso_c_binding
      import :: mlf_distribution_abstract
      class(mlf_distribution_abstract), intent(inout) :: this
      real(c_double), intent(in) :: X(:)
    End Function mlf_distribution_withParameters

    Integer Function mlf_multivariate_fitWithData(this, Points, W, prior)
      Use iso_c_binding
      import :: mlf_distribution_multivariate, mlf_distribution_abstract
      class(mlf_distribution_multivariate), intent(inout) :: this
      real(c_double), intent(in) :: Points(:,:)
      real(c_double), intent(in), optional :: W(:)
      class(mlf_distribution_abstract), optional, intent(in) :: prior
    End Function mlf_multivariate_fitWithData

    Integer Function mlf_univariate_fitWithData(this, Points, W, prior)
      Use iso_c_binding
      import :: mlf_distribution_univariate, mlf_distribution_abstract
      class(mlf_distribution_univariate), intent(inout) :: this
      real(c_double), intent(in) :: Points(:)
      real(c_double), intent(in), optional :: W(:)
      class(mlf_distribution_abstract), optional, intent(in) :: prior
    End Function mlf_univariate_fitWithData

    Function mlf_multivariate_computePDF(this, X) Result(y)
      Use iso_c_binding
      import :: mlf_distribution_multivariate
      class(mlf_distribution_multivariate), intent(in) :: this
      real(c_double), intent(in) :: X(:)
      real(c_double) :: y
    End Function mlf_multivariate_computePDF

    Elemental Function mlf_univariate_computePDF(this, x) Result(y)
      Use iso_c_binding
      import :: mlf_distribution_univariate
      class(mlf_distribution_univariate), intent(in) :: this
      real(c_double), intent(in) :: x
      real(c_double) :: y
    End Function mlf_univariate_computePDF

    Function mlf_univariate_getStats(this, statType) Result(y)
      Use iso_c_binding
      import :: mlf_distribution_univariate
      class(mlf_distribution_univariate), intent(in) :: this
      integer, intent(in) :: statType
      real(c_double) :: y
    End Function mlf_univariate_getStats

    Function mlf_univariate_quantile(this, y) Result(x)
      Use iso_c_binding
      import :: mlf_distributionWithQuantile_type
      class(mlf_distributionWithQuantile_type), intent(in) :: this
      real(c_double), intent(in) :: y
      real(c_double) :: x
    End Function mlf_univariate_quantile

    Function mlf_univariate_computeCDF(this, x) Result(y)
      Use iso_c_binding
      import :: mlf_distributionWithCDF_type
      class(mlf_distributionWithCDF_type), intent(in) :: this
      real(c_double), intent(in) :: x
      real(c_double) :: y
    End Function mlf_univariate_computeCDF
  End Interface
Contains
  Function mlf_multivariate_computeLogPDF(this, X) Result(y)
    class(mlf_distribution_multivariate), intent(in) :: this
    real(c_double), intent(in) :: X(:)
    real(c_double) :: y
    y = LOG(this%computePDF(X))
  End Function mlf_multivariate_computeLogPDF

  Elemental Function mlf_univariate_computeLogPDF(this, x) Result(y)
    class(mlf_distribution_univariate), intent(in) :: this
    real(c_double), intent(in) :: x
    real(c_double) :: y
    y = LOG(this%computePDF(X))
  End Function mlf_univariate_computeLogPDF

  Subroutine mlf_univariate_quantileTable(this, X)
    class(mlf_distributionWithQuantile_type), intent(in) :: this
    real(c_double), intent(out) :: X(:)
    integer :: i
    Do i= 1,SIZE(X)
      X(i) = this%quantile(REAL(i-1,8)/REAL(SIZE(X)-1,8))
    End Do
  End Subroutine mlf_univariate_quantileTable

  Real(c_double) Function mlf_univariate_integrateIncomplete(this, X, z, dydz) Result(y)
    class(mlf_distributionWithCDF_type), intent(in) :: this
    real(c_double), intent(in) :: X(:), z
    real(c_double), intent(out), optional :: dydz
    real(c_double), parameter :: icoeff(3) =  [3d0/8d0, 7d0/6d0, 23d0/24d0]
    integer :: i, N
    N = SIZE(X)
    y = DOT_PRODUCT(icoeff, [IC(X(1)), IC(X(2)), IC(X(3))])
    Do i = 4, N-3
      y = y + IC(X(i))
    End Do
    y = y + DOT_PRODUCT(icoeff, [IC(X(N)), IC(X(N-1)), IC(X(N-2))])
    If(PRESENT(dydz)) Then
      dydz = DOT_PRODUCT(icoeff, [ID(X(1)), ID(X(2)), ID(X(3))])
      Do i = 4, N-3
        dydz = dydz + ID(X(i))
      End Do
      dydz = dydz + DOT_PRODUCT(icoeff, [ID(X(N)), ID(X(N-1)), ID(X(N-2))])
    Endif
  Contains
    Real(c_double) Function IC(t) Result(r)
      real(c_double), intent(in) :: t
      real(c_double) :: delta
      delta = ABS(t-z)
      If(delta == 0d0) Then
        r = 0
      Else
        r = this%computeCDF(t+delta) - this%computeCDF(t-delta)
      Endif
    End Function IC
    Real(c_double) Function ID(t) Result(r)
      real(c_double), intent(in) :: t
      real(c_double) :: delta
      delta = ABS(t-z)
      If(delta == 0d0) Then
        r = 0
      Else
        r = SIGN(this%computePDF(t+delta) - this%computePDF(t-delta), t-z)
      Endif
    End Function ID
  End Function mlf_univariate_integrateIncomplete

End Module mlf_distribution


! Vector addition
program vadd

  use timer
  use omp_lib

  implicit none

  integer :: N=50000000
  real(kind=8), allocatable :: A(:), B(:), C(:)
  integer :: i
  integer :: tid, nthreads
  real(kind=8) :: start, end

  ! Allocate memory
  allocate(A(N))
  allocate(B(N))
  allocate(C(N))

  ! Initilise data
  do i = 1, N
    A(i) = 1.0_8
    B(i) = 2.0_8
    C(i) = 0.0_8
  end do

  ! Start timer
  call wtime(start)

  ! Open parallel region
  ! tid variable must be private to each thread
  !$omp parallel private(tid)

  ! Get thread number
  tid = omp_get_thread_num()

  ! Get total number of threads
  nthreads = omp_get_num_threads()

  ! Vector addition
  ! Share iteration space based on thread ID
  do i = 1+(tid*N/nthreads), (tid+1)*N/nthreads
    C(i) = A(i) + B(i)
  end do

  ! End parallel region
  !$omp end parallel

  ! Stop timer
  call wtime(end)

  ! Print result
  write(*,"(A)")         "------------------------------------"
  write(*,"(A,F10.3)")   "runtime:  ", end-start
  if (any(C .ne. 3.0_8)) then
    write(*,"(A)")       "WARNING: results incorrect"
  end if
  write(*,"(A)")         "------------------------------------"

  ! Free memory
  deallocate(A,B)

end program vadd


! { dg-do run }
! { dg-options "-finline-matmul-limit=0 -fdump-tree-original -fdump-tree-optimized -Warray-temporaries -fbounds-check" }

  implicit none

  integer :: i, j

  integer, parameter :: nx=3, ny=4
  integer, parameter, dimension(nx,ny) :: p = &
    & reshape ((/ (i**2, i=1,size(p)) /), shape(p))
  integer, parameter, dimension(ny,nx) :: q = &
    & reshape ((/ (((nx*(i-1)+j)**2, i=1,ny), j=1,nx) /), (/ ny, nx /))

  integer, parameter, dimension(nx,nx) :: r = &
    & reshape ((/ (i*i, i=1,size(r)) /), shape(r))
  integer, parameter, dimension(nx,nx) :: s = &
    & reshape ((/ (((nx*(i-1)+j)**2, i=1,nx), j=1,nx) /), (/ nx, nx /))

  integer, dimension(nx,ny) :: a, b
  integer, dimension(ny,nx) :: c
  integer, dimension(nx,nx) :: e, f, g

  character(144) :: u, v

  a = p

  c = transpose(a)
  if (any(c /= q)) STOP 1

  write(u,*) transpose(a)
  write(v,*) q
  if (u /= v) STOP 2

  e = r
  f = s

  g = transpose(e+f)
  if (any(g /= r + s)) STOP 3

  write(u,*) transpose(e+f)
  write(v,*) r + s
  if (u /= v) STOP 4

  e = transpose(e)      ! { dg-warning "Creating array temporary" }
  if (any(e /= s)) STOP 5

  write(u,*) transpose(transpose(e))
  write(v,*) s
  if (u /= v) STOP 6

  e = transpose(e+f)     ! { dg-warning "Creating array temporary" }
  if (any(e /= 2*r)) STOP 7

  write(u,*) transpose(transpose(e+f))-f
  write(v,*) 2*r
  if (u /= v) STOP 8

  a = foo(transpose(c))
  if (any(a /= p+1)) STOP 9

  write(u,*) foo(transpose(c))    ! { dg-warning "Creating array temporary" }
  write(v,*) p+1
  if (u /= v) STOP 10

  c = transpose(foo(a))      ! Unnecessary { dg-warning "Creating array temporary" }
  if (any(c /= q+2)) STOP 11

  write(u,*) transpose(foo(a))     ! { dg-warning "Creating array temporary" }
  write(v,*) q+2
  if (u /= v) STOP 12

  e = foo(transpose(e))     ! { dg-warning "Creating array temporary" }
  if (any(e /= 2*s+1)) STOP 13

  write(u,*) transpose(foo(transpose(e))-1)     ! { dg-warning "Creating array temporary" }
  write(v,*) 2*s+1
  if (u /= v) STOP 14

  e = transpose(foo(e))     ! { dg-warning "Creating array temporary" }
  if (any(e /= 2*r+2)) STOP 15

  write(u,*) transpose(foo(transpose(e)-1))     ! 2 temps { dg-warning "Creating array temporary" }
  write(v,*) 2*r+2
  if (u /= v) STOP 16

  a = bar(transpose(c))
  if (any(a /= p+4)) STOP 17

  write(u,*) bar(transpose(c))
  write(v,*) p+4
  if (u /= v) STOP 18

  c = transpose(bar(a))
  if (any(c /= q+6)) STOP 19

  write(u,*) transpose(bar(a))
  write(v,*) q+6
  if (u /= v) STOP 20

  e = bar(transpose(e))     ! { dg-warning "Creating array temporary" }
  if (any(e /= 2*s+4)) STOP 21

  write(u,*) transpose(bar(transpose(e)))-2
  write(v,*) 2*s+4
  if (u /= v) STOP 22

  e = transpose(bar(e))     ! { dg-warning "Creating array temporary" }
  if (any(e /= 2*r+6)) STOP 23

  write(u,*) transpose(transpose(bar(e))-2)
  write(v,*) 2*r+6
  if (u /= v) STOP 24

  if (any(a /= transpose(transpose(a)))) STOP 25! optimized away

  write(u,*) a
  write(v,*) transpose(transpose(a))
  if (u /= v) STOP 26

  b = a * a

  if (any(transpose(a+b) /= transpose(a)+transpose(b))) STOP 27! optimized away

  write(u,*) transpose(a+b)
  write(v,*) transpose(a) + transpose(b)
  if (u /= v) STOP 28

  if (any(transpose(matmul(a,c)) /= matmul(transpose(c), transpose(a)))) STOP 29! 2 temps { dg-warning "Creating array temporary" }

  write(u,*) transpose(matmul(a,c))     ! { dg-warning "Creating array temporary" }
  write(v,*) matmul(transpose(c), transpose(a))     ! { dg-warning "Creating array temporary" }
  if (u /= v) STOP 30

  if (any(transpose(matmul(e,a)) /= matmul(transpose(a), transpose(e)))) STOP 31! 2 temps { dg-warning "Creating array temporary" }

  write(u,*) transpose(matmul(e,a))     ! { dg-warning "Creating array temporary" }
  write(v,*) matmul(transpose(a), transpose(e))     ! { dg-warning "Creating array temporary" }
  if (u /= v) STOP 32

  call baz (transpose(a))

  call toto1 (a, transpose (c))
  if (any (a /= 2 * p + 12)) STOP 33

  call toto1 (e, transpose (e))          ! { dg-warning "Creating array temporary" }
  if (any (e /= 4 * s + 12)) STOP 34

  call toto2 (c, transpose (a))
  if (any (c /= 2 * q + 13)) STOP 35

  call toto2 (e, transpose(e))           ! { dg-warning "Creating array temporary" }
  if (any (e /= 4 * r + 13)) STOP 36

  call toto2 (e, transpose(transpose(e)))           ! { dg-warning "Creating array temporary" }
  if (any (e /= 4 * r + 14)) STOP 37

  call toto3 (e, transpose(e))
  if (any (e /= 4 * r + 14)) STOP 38

  call titi (nx, e, transpose(e))           ! { dg-warning "Creating array temporary" }
  if (any (e /= 4 * s + 17)) STOP 39

  contains

  function foo (x)
    integer, intent(in) :: x(:,:)
    integer :: foo(size(x,1), size(x,2))
    foo = x + 1
  end function foo

  elemental function bar (x)
    integer, intent(in) :: x
    integer :: bar
    bar = x + 2
  end function bar

  subroutine baz (x)
    integer, intent(in) :: x(:,:)
  end subroutine baz

  elemental subroutine toto1 (x, y)
    integer, intent(out) :: x
    integer, intent(in)  :: y
    x = y + y
  end subroutine toto1

  subroutine toto2 (x, y)
    integer, dimension(:,:), intent(out) :: x
    integer, dimension(:,:), intent(in)  :: y
    x = y + 1
  end subroutine toto2

  subroutine toto3 (x, y)
    integer, dimension(:,:), intent(in) :: x, y
  end subroutine toto3

end

subroutine titi (n, x, y)
  integer :: n, x(n,n), y(n,n)
  x = y + 3
end subroutine titi

! No call to transpose
! { dg-final { scan-tree-dump-times "_gfortran_transpose" 0 "original" } }
!
! 24 temporaries
! { dg-final { scan-tree-dump-times "struct\[^\\n\]*atmp" 24 "original" } }
!
! 2 tests optimized out
! { dg-final { scan-tree-dump-times "_gfortran_stop" 39 "original" } }
! { # Commented out as failing at -O0: dg-final { scan-tree-dump-times "_gfortran_stop" 37 "optimized" } }
!
! cleanup


! Type your code here, or load an example.
real function square(x)
    implicit none
    real, intent(in) :: x
    square = x * x
    return
end function square


module interfaceFortran

	implicit none

	public executerElementC, executerSymbolicC
	private fortranMatrix2Carray, fortranMatrix2CarrayI

	contains

	subroutine executerElementC(id_Elem_Family, AE, BE, MaxLRows, XLL, NDim, iDofT, NodElt, &
								Sol0, Sol1, CommonPar, Param, JParam, DelT, DTm, Time)

		integer , intent(in) :: id_Elem_Family,MaxLRows,Ndim,iDofT, NodElt! all integers
		Real*8 , intent(in) :: DelT, DTm,Time ! all reals
		Real*8 , intent(out) :: AE(MaxLRows*MaxLRows), BE(MaxLRows)
		Real*8 , intent(in) :: XLL(*), Sol0(*), Sol1(*), Param(*), JParam(*), CommonPar(*)

		real*8 :: AEaux(MaxLRows,MaxLRows)

		AEaux = 0.0d0
		BE = 0.0d0
		call executerElement(id_Elem_Family, AEaux, BE, MaxLRows, XLL, NDim, iDofT, NodElt, &
								Sol0, Sol1, CommonPar, Param, JParam, DelT, DTm, Time)

		call fortranMatrix2Carray(AE,AEaux,MaxLRows,MaxLRows)

	end subroutine

	subroutine executerSymbolicC(id_Elem_Family, Coupling,CommonPar,iDofT,Ndim,MaxLRows)

		Integer, intent(in) :: id_Elem_Family, MaxLRows,Ndim,iDofT
		Integer, intent(out) :: Coupling(MaxLRows,MaxLRows)
		Real*8 , intent(in) :: CommonPar(*)

		integer iAdd
		integer :: CouplingAux(MaxLRows,MaxLRows)

		iAdd = 0;
		CouplingAux = 0;

		call executerSymbolic(id_Elem_Family, CouplingAux,CommonPar,iDofT,Ndim,MaxLRows,iAdd)

		call fortranMatrix2CarrayI(Coupling,CouplingAux,MaxLRows,MaxLRows)

	end subroutine

	subroutine fortranMatrix2Carray(VinC,MinF,n,m)
		real*8 , intent(out) :: VinC(n*m)
		real*8 , intent(in) :: MinF(n,m)
		integer , intent(in) :: n,m
		integer i , j , ip

		do j  = 1,m
			do i  = 1,n
				ip = (i-1)*m + j
				VinC(ip) = MinF(i,j)
			end do
		end do

	end subroutine

	subroutine fortranMatrix2CarrayI(VinC,MinF,n,m)
		integer , intent(out) :: VinC(n*m)
		integer , intent(in) :: MinF(n,m)
		integer , intent(in) :: n,m
		integer i , j , ip

		do j  = 1,m
			do i  = 1,n
				ip = (i-1)*m + j
				VinC(ip) = MinF(i,j)
			end do
		end do

	end subroutine

end module


! quicksort.f -*-f90-*-
! Author: t-nissie
! License: GPLv3
! Gist: https://gist.github.com/t-nissie/479f0f16966925fa29ea
!!
recursive subroutine quicksort(a, first, last)
    implicit none
    integer a(*), x, t
    integer first, last
    integer i, j

    x = a((first + last)/2)
    i = first
    j = last
    do
    do while (a(i) < x)
        i = i + 1
    end do
    do while (x < a(j))
        j = j - 1
    end do
    if (i >= j) exit
    t = a(i); a(i) = a(j); a(j) = t
    i = i + 1
    j = j - 1
    end do
    if (first < i - 1) call quicksort(a, first, i - 1)
    if (j + 1 < last) call quicksort(a, j + 1, last)
end subroutine quicksort

program test_quicksort
    integer, target :: x(10)
    data x/1, 4, 3, 8, 2, 6, 9, 7, 0, 5/

    call quicksort(x, 1, 10)
    print *, x
end


!----------------------------------------------------------------------
!----------------------------------------------------------------------
!   int :    An ODE with boundary and integral constraints
!----------------------------------------------------------------------
!----------------------------------------------------------------------

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

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

      DOUBLE PRECISION E

       E=EXP(U(1))
       F(1)=U(2)
       F(2)=-PAR(1)*E

      IF(IJAC.EQ.0)RETURN

       DFDU(1,1)=0.0
       DFDU(1,2)=1
       DFDU(2,1)=-PAR(1)*E
       DFDU(2,2)=0.0

      IF(IJAC.EQ.1)RETURN

!      *Parameter derivatives
       DFDP(1,1)=0.0
       DFDP(2,1)=-E

      END SUBROUTINE FUNC

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

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

       PAR(1)=0
       PAR(2)=0
       PAR(3)=0

       U(1)=0.0
       U(2)=0.0

      END SUBROUTINE STPNT

      SUBROUTINE BCND(NDIM,PAR,ICP,NBC,U0,U1,FB,IJAC,DBC)
!     ---------- ----

      IMPLICIT NONE
      INTEGER, INTENT(IN) :: NDIM, ICP(*), NBC, IJAC
      DOUBLE PRECISION, INTENT(IN) :: PAR(*), U0(NDIM), U1(NDIM)
      DOUBLE PRECISION, INTENT(OUT) :: FB(NBC)
      DOUBLE PRECISION, INTENT(INOUT) :: DBC(NBC,*)

       FB(1)=U0(1)-U1(1)-PAR(2)

      IF(IJAC.EQ.0)RETURN

       DBC(1,1)=1.0
       DBC(1,2)=0.0

       DBC(1,3)=-1.0
       DBC(1,4)=0.0

      IF(IJAC.EQ.1)RETURN

!      *Parameter derivatives
       DBC(1,5)=0.0
       DBC(1,6)=-1.0
       DBC(1,7)=0.0

      END SUBROUTINE BCND

      SUBROUTINE ICND(NDIM,PAR,ICP,NINT,U,UOLD,UDOT,UPOLD,FI,IJAC,DINT)
!     ---------- ----

      IMPLICIT NONE
      INTEGER, INTENT(IN) :: NDIM, ICP(*), NINT, IJAC
      DOUBLE PRECISION, INTENT(IN) :: PAR(*)
      DOUBLE PRECISION, INTENT(IN) :: U(NDIM), UOLD(NDIM), UDOT(NDIM), UPOLD(NDIM)
      DOUBLE PRECISION, INTENT(OUT) :: FI(NINT)
      DOUBLE PRECISION, INTENT(INOUT) :: DINT(NINT,*)

       FI(1)=U(1)-PAR(3)

      IF(IJAC.EQ.0)RETURN

       DINT(1,1)=1.0
       DINT(1,2)=0.0

      IF(IJAC.EQ.1)RETURN

!      *Parameter derivatives
       DINT(1,3)=0.0
       DINT(1,4)=0.0
       DINT(1,5)=-1.0

      END SUBROUTINE ICND

      SUBROUTINE FOPT
      END SUBROUTINE FOPT

      SUBROUTINE PVLS
      END SUBROUTINE PVLS


! { dg-do run }
! tests FORALL statements with a mask
dimension i2(15,10), i1(15)
type a
   sequence
   integer k
end type a
type(a) :: a1(10), a2(5,5)

i1 = (/ 0, 1, 2, 3, 4, 0, 6, 7, 8, 9, 10, 0, 0, 13, 14 /)
forall (i=1:15, i1(i) /= 0)
   i1(i) = 0
end forall
if (any(i1 /= 0)) STOP 1

a1(:)%k = i1(1:10)
forall (i=1:10, a1(i)%k == 0)
   a1(i)%k = i
end forall
if (any (a1(:)%k /= (/ (i, i=1,10) /))) STOP 2

forall (i=1:15, j=1:10, a1(j)%k <= j)
   i2(i,j) = j + i*11
end forall
do i=1,15
   if (any (i2(i,:) /= (/ (i*11 + j, j=1,10) /))) STOP 3
end do
end


constant a = - { x = 1 }


  subroutine skosgp (e, sigkosgp)
!  subroutine skosgp (photonEG, e, sigkosgp)

! ======================================================================
!
!    gamma + H cross section. Only called with a0 = 1!
!
!    "Last" change: 13-AUG-2003 by NVMokhov
!    Edited by A. J. Sierk, LANL T-16, October, 2003.
!    Edited by AJS, LANL T-2, December, 2011.
!    Edited by LMK, XCP-3, July 2013 (included error protection).
!
! ======================================================================

    use, intrinsic:: iso_fortran_env, only: int32, real64

    implicit none
!    class(PhotonEventGenerator), intent(inout) :: photonEG   ! UNUSED!
    real(real64),   intent(in   ) :: e
    real(real64),   intent(  out) :: sigkosgp

    real(real64) :: ar, fp, fr, g4, g8, hpp, rdel, rh, s1, s2, s3, s4, &
         & temp, temp2, z, zud, zz1

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

    real(real64), parameter :: udelz = 5.813_real64
    real(real64), parameter :: wdelz = 0.056_real64
    real(real64), parameter :: whaz  = 0.045_real64

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

    z = log(e)
    zud = z - udelz
    temp2 = wdelz
    temp = one + zud*zud/temp2
    rdel = 0.55d0/(temp)
    zz1 = z - 6.57d0
    temp2 = whaz
    temp = one + zz1*zz1/temp2
    rh = 0.223d0/(temp)

    temp = one + exp(12.d0*(7.25d0 - z))
    g4 = exp(four*(6.27d0 - z))/(temp)

    temp = one + exp(24.d0*(6.9d0 - z))
    g8 = exp(eight*(6.66d0 - z))/(temp)

    temp = one + exp(four*(7.d0 - z))
    fp = one/(temp)
    hpp = 0.0375d0*(z - 16.5d0) + 1.07d0*exp(-0.11d0*z)

    ar = 25.d0*(5.24d0 - z)
    temp = one + exp(ar)
    fr = one/(temp)
    s1 = fr*(rdel + rh)
    s2 = g4
    s3 = g8
    s4 = fp*hpp

    sigkosgp = s1 + s2 + s3 + s4
    return
! ======================================================================
  end subroutine skosgp