! RUN: %python %S/test_folding.py %s %flang_fc1
! Tests folding of UNPACK (valid cases)
module m
  integer, parameter :: vector(*) = [1, 2, 3, 4]
  integer, parameter :: field(2,3) = reshape([(-j,j=1,6)], shape(field))
  logical, parameter :: mask(*,*) = reshape([.false., .true., .true., .false., .false., .true.], shape(field))
  logical, parameter :: test_unpack_1 = all(unpack(vector, mask, 0) == reshape([0,1,2,0,0,3], shape(mask)))
  logical, parameter :: test_unpack_2 = all(unpack(vector, mask, field) == reshape([-1,1,2,-4,-5,3], shape(mask)))
end module


*DECK DCHDC
      SUBROUTINE DCHDC (A, LDA, P, WORK, JPVT, JOB, INFO)
C***BEGIN PROLOGUE  DCHDC
C***PURPOSE  Compute the Cholesky decomposition of a positive definite
C            matrix.  A pivoting option allows the user to estimate the
C            condition number of a positive definite matrix or determine
C            the rank of a positive semidefinite matrix.
C***LIBRARY   SLATEC (LINPACK)
C***CATEGORY  D2B1B
C***TYPE      DOUBLE PRECISION (SCHDC-S, DCHDC-D, CCHDC-C)
C***KEYWORDS  CHOLESKY DECOMPOSITION, LINEAR ALGEBRA, LINPACK, MATRIX,
C             POSITIVE DEFINITE
C***AUTHOR  Dongarra, J., (ANL)
C           Stewart, G. W., (U. of Maryland)
C***DESCRIPTION
C
C     DCHDC computes the Cholesky decomposition of a positive definite
C     matrix.  A pivoting option allows the user to estimate the
C     condition of a positive definite matrix or determine the rank
C     of a positive semidefinite matrix.
C
C     On Entry
C
C         A      DOUBLE PRECISION(LDA,P).
C                A contains the matrix whose decomposition is to
C                be computed.  Only the upper half of A need be stored.
C                The lower part of the array A is not referenced.
C
C         LDA    INTEGER.
C                LDA is the leading dimension of the array A.
C
C         P      INTEGER.
C                P is the order of the matrix.
C
C         WORK   DOUBLE PRECISION.
C                WORK is a work array.
C
C         JPVT   INTEGER(P).
C                JPVT contains integers that control the selection
C                of the pivot elements, if pivoting has been requested.
C                Each diagonal element A(K,K)
C                is placed in one of three classes according to the
C                value of JPVT(K).
C
C                   If JPVT(K) .GT. 0, then X(K) is an initial
C                                      element.
C
C                   If JPVT(K) .EQ. 0, then X(K) is a free element.
C
C                   If JPVT(K) .LT. 0, then X(K) is a final element.
C
C                Before the decomposition is computed, initial elements
C                are moved by symmetric row and column interchanges to
C                the beginning of the array A and final
C                elements to the end.  Both initial and final elements
C                are frozen in place during the computation and only
C                free elements are moved.  At the K-th stage of the
C                reduction, if A(K,K) is occupied by a free element
C                it is interchanged with the largest free element
C                A(L,L) with L .GE. K.  JPVT is not referenced if
C                JOB .EQ. 0.
C
C        JOB     INTEGER.
C                JOB is an integer that initiates column pivoting.
C                If JOB .EQ. 0, no pivoting is done.
C                If JOB .NE. 0, pivoting is done.
C
C     On Return
C
C         A      A contains in its upper half the Cholesky factor
C                of the matrix A as it has been permuted by pivoting.
C
C         JPVT   JPVT(J) contains the index of the diagonal element
C                of a that was moved into the J-th position,
C                provided pivoting was requested.
C
C         INFO   contains the index of the last positive diagonal
C                element of the Cholesky factor.
C
C     For positive definite matrices INFO = P is the normal return.
C     For pivoting with positive semidefinite matrices INFO will
C     in general be less than P.  However, INFO may be greater than
C     the rank of A, since rounding error can cause an otherwise zero
C     element to be positive.  Indefinite systems will always cause
C     INFO to be less than P.
C
C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
C***ROUTINES CALLED  DAXPY, DSWAP
C***REVISION HISTORY  (YYMMDD)
C   790319  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  DCHDC
      INTEGER LDA,P,JPVT(*),JOB,INFO
      DOUBLE PRECISION A(LDA,*),WORK(*)
C
      INTEGER PU,PL,PLP1,J,JP,JT,K,KB,KM1,KP1,L,MAXL
      DOUBLE PRECISION TEMP
      DOUBLE PRECISION MAXDIA
      LOGICAL SWAPK,NEGK
C***FIRST EXECUTABLE STATEMENT  DCHDC
      PL = 1
      PU = 0
      INFO = P
      IF (JOB .EQ. 0) GO TO 160
C
C        PIVOTING HAS BEEN REQUESTED. REARRANGE THE
C        THE ELEMENTS ACCORDING TO JPVT.
C
         DO 70 K = 1, P
            SWAPK = JPVT(K) .GT. 0
            NEGK = JPVT(K) .LT. 0
            JPVT(K) = K
            IF (NEGK) JPVT(K) = -JPVT(K)
            IF (.NOT.SWAPK) GO TO 60
               IF (K .EQ. PL) GO TO 50
                  CALL DSWAP(PL-1,A(1,K),1,A(1,PL),1)
                  TEMP = A(K,K)
                  A(K,K) = A(PL,PL)
                  A(PL,PL) = TEMP
                  PLP1 = PL + 1
                  IF (P .LT. PLP1) GO TO 40
                  DO 30 J = PLP1, P
                     IF (J .GE. K) GO TO 10
                        TEMP = A(PL,J)
                        A(PL,J) = A(J,K)
                        A(J,K) = TEMP
                     GO TO 20
   10                CONTINUE
                     IF (J .EQ. K) GO TO 20
                        TEMP = A(K,J)
                        A(K,J) = A(PL,J)
                        A(PL,J) = TEMP
   20                CONTINUE
   30             CONTINUE
   40             CONTINUE
                  JPVT(K) = JPVT(PL)
                  JPVT(PL) = K
   50          CONTINUE
               PL = PL + 1
   60       CONTINUE
   70    CONTINUE
         PU = P
         IF (P .LT. PL) GO TO 150
         DO 140 KB = PL, P
            K = P - KB + PL
            IF (JPVT(K) .GE. 0) GO TO 130
               JPVT(K) = -JPVT(K)
               IF (PU .EQ. K) GO TO 120
                  CALL DSWAP(K-1,A(1,K),1,A(1,PU),1)
                  TEMP = A(K,K)
                  A(K,K) = A(PU,PU)
                  A(PU,PU) = TEMP
                  KP1 = K + 1
                  IF (P .LT. KP1) GO TO 110
                  DO 100 J = KP1, P
                     IF (J .GE. PU) GO TO 80
                        TEMP = A(K,J)
                        A(K,J) = A(J,PU)
                        A(J,PU) = TEMP
                     GO TO 90
   80                CONTINUE
                     IF (J .EQ. PU) GO TO 90
                        TEMP = A(K,J)
                        A(K,J) = A(PU,J)
                        A(PU,J) = TEMP
   90                CONTINUE
  100             CONTINUE
  110             CONTINUE
                  JT = JPVT(K)
                  JPVT(K) = JPVT(PU)
                  JPVT(PU) = JT
  120          CONTINUE
               PU = PU - 1
  130       CONTINUE
  140    CONTINUE
  150    CONTINUE
  160 CONTINUE
      DO 270 K = 1, P
C
C        REDUCTION LOOP.
C
         MAXDIA = A(K,K)
         KP1 = K + 1
         MAXL = K
C
C        DETERMINE THE PIVOT ELEMENT.
C
         IF (K .LT. PL .OR. K .GE. PU) GO TO 190
            DO 180 L = KP1, PU
               IF (A(L,L) .LE. MAXDIA) GO TO 170
                  MAXDIA = A(L,L)
                  MAXL = L
  170          CONTINUE
  180       CONTINUE
  190    CONTINUE
C
C        QUIT IF THE PIVOT ELEMENT IS NOT POSITIVE.
C
         IF (MAXDIA .GT. 0.0D0) GO TO 200
            INFO = K - 1
            GO TO 280
  200    CONTINUE
         IF (K .EQ. MAXL) GO TO 210
C
C           START THE PIVOTING AND UPDATE JPVT.
C
            KM1 = K - 1
            CALL DSWAP(KM1,A(1,K),1,A(1,MAXL),1)
            A(MAXL,MAXL) = A(K,K)
            A(K,K) = MAXDIA
            JP = JPVT(MAXL)
            JPVT(MAXL) = JPVT(K)
            JPVT(K) = JP
  210    CONTINUE
C
C        REDUCTION STEP. PIVOTING IS CONTAINED ACROSS THE ROWS.
C
         WORK(K) = SQRT(A(K,K))
         A(K,K) = WORK(K)
         IF (P .LT. KP1) GO TO 260
         DO 250 J = KP1, P
            IF (K .EQ. MAXL) GO TO 240
               IF (J .GE. MAXL) GO TO 220
                  TEMP = A(K,J)
                  A(K,J) = A(J,MAXL)
                  A(J,MAXL) = TEMP
               GO TO 230
  220          CONTINUE
               IF (J .EQ. MAXL) GO TO 230
                  TEMP = A(K,J)
                  A(K,J) = A(MAXL,J)
                  A(MAXL,J) = TEMP
  230          CONTINUE
  240       CONTINUE
            A(K,J) = A(K,J)/WORK(K)
            WORK(J) = A(K,J)
            TEMP = -A(K,J)
            CALL DAXPY(J-K,TEMP,WORK(KP1),1,A(KP1,J),1)
  250    CONTINUE
  260    CONTINUE
  270 CONTINUE
  280 CONTINUE
      RETURN
      END


! examples/Fortran/random_matrix.f90 - Example code for SPRAL_RANDOM_MATRIX pkg
program random_matrix_example
   use spral_matrix_util, only : print_matrix
   use spral_random, only : random_state
   use spral_random_matrix
   implicit none

   integer, parameter :: wp = kind(0d0)

   integer, parameter :: m=4, n=5, nnz=8
   integer :: ptr(n+1), row(nnz)
   real(wp) :: val(nnz)
   integer :: flag
   type(random_state) :: state

   ! Generate matrix
   write(*, "(a,i3,a,i3,a,i3,a)") &
      "Generating a ", m, " x", n, " non-singular matrix with ", nnz, &
      " non-zeroes"
   call random_matrix_generate(state, 0, m, n, nnz, ptr, row, flag, val=val, &
      nonsingular=.true.)

   ! Print matrix using utility routine from SPRAL_MATRIX_UTILS package
   write(*, "(a)") "Generated matrix:"
   call print_matrix(6, -1, 0, m, n, ptr, row, val=val)

end program random_matrix_example


program problem32
  implicit none
  double precision         :: magic=987654321.0
  integer                  :: i,j,answer
  logical, dimension(9999) :: numbers

  do i=1,9999
     numbers(i)=.false.
  end do

  do i=1,ceiling(sqrt(magic))
     do j=i+1,ceiling(magic/i)
        if (ineligible(i,j)) exit
        if (pandigital(i,j)) then
           numbers(i*j)=.true.
        end if
     end do
  end do

  answer=0
  do i=1,9999
     if (numbers(i)) then
        answer=answer+i
     end if
  end do

  print *, answer

contains
  pure function digits(a)
    implicit none
    integer, intent(in) :: a
    integer             :: digits

    digits=ceiling(log10(dble(a)))
  end function digits

  pure function ineligible(a,b)
    implicit none
    integer, intent(in) :: a,b
    logical             :: ineligible

    ineligible=(digits(a)+digits(b)+digits(a*b) > 9)
  end function ineligible

  pure function pandigital(a,b)
    implicit none
    integer, intent(in)   :: a,b
    integer               :: i,j,k,temp
    integer, dimension(9) :: d
    logical               :: pandigital

    if (digits(a)+digits(b)+digits(a*b) /= 9) then
       pandigital=.false.
       go to 1
    end if

    do i=1,9
       d(i)=0
    end do

    i=a
    j=b
    k=a*b

    do while (i > 0)
       temp=mod(i,10)
       d(temp)=d(temp)+1
       i=i/10
    end do

    do while (j > 0)
       temp=mod(j,10)
       d(temp)=d(temp)+1
       j=j/10
    end do

    do while (k > 0)
       temp=mod(k,10)
       d(temp)=d(temp)+1
       k=k/10
    end do

    do i=1,9
       if (d(i) /= 1) then
          pandigital=.false.
          go to 1
       end if
    end do

    pandigital=.true.

1 end function pandigital

end program problem32


      PROGRAM FNDLAT
      IMPLICIT NONE
C
C**********
C*
C 1)  MAPS HYCOM GRID TO/FROM LATITUDE
C
C 2)  USES SUN FORTRAN SPECIFIC CARRIAGE CONTROL EDIT DESCIPTOR ('$').
C
C 3)  ALAN J. WALLCRAFT,  NRL,  MAY 2000.
C*
C**********
C
      INTEGER JDM,LOOP,MAPTYPE
      REAL    GRIDSZ,PI,PLAT,PY,QLAT,RADIAN,Y
C
      REAL ALAT,ALAT1,ALATU,DIST,DIST1,DISTU,GRID
      ALAT( DIST1,GRID)=(2.*ATAN(EXP(DIST1*GRID/RADIAN))-PI/2.)
      DIST( ALAT1,GRID)=ALOG(TAN((2.*ALAT1+PI)/4.))*RADIAN/GRID
      ALATU(DIST1,GRID)=DIST1*(GRID/RADIAN)
      DISTU(ALAT1,GRID)=ALAT1*(RADIAN/GRID)
C
      RADIAN=57.2957795
      PI    = 3.1415926536
C
C     SELECT GRID SIZE AND MAPPING DIRECTION.
C
      WRITE(6,'(a)',ADVANCE='NO')
     &   ' Grid size (deg) : '
      READ( 5,*)  GRIDSZ
      WRITE(6,'(a)',ADVANCE='NO')
     &   ' Eq. is at P(?)  : '
      READ(5,*) PY
      WRITE(6,'(a)',ADVANCE='NO')
     &   ' Input latitude (0) or grid (1) : '
      READ( 5,*)  MAPTYPE
C
      DO 11 LOOP=1,99999
C
        IF     (MAPTYPE.EQ.0 .OR. MAPTYPE.EQ.2) THEN
C
C         INPUT LATITUDE.
C
          WRITE(6,'(a)',ADVANCE='NO')
     &       ' Latitude (degN, -99.0 to exit) : '
          READ(5,*) PLAT
          IF     (ABS(PLAT).GT.90.0) THEN
            GOTO 111
          ENDIF
C
          IF     (MAPTYPE.EQ.0) THEN
            Y = PY + DIST( PLAT/RADIAN,GRIDSZ)
          ELSE
            Y = PY + DISTU(PLAT/RADIAN,GRIDSZ)
          ENDIF
          WRITE(6,7100) PLAT,Y
 7100     FORMAT(' Lat =',F8.3,
     +           '  is at P(',F9.3,')' /)
        ELSEIF (MAPTYPE.EQ.1 .OR. MAPTYPE.EQ.3) THEN
C
C         INPUT GRID DISTANCE.
C
          WRITE(6,'(a)',ADVANCE='NO')
     &       ' Index, -1.0 to exit : '
          READ(5,*) Y
          IF     (Y.LE.-1.0) THEN
            GOTO 111
          ENDIF
C
          IF     (MAPTYPE.EQ.1) THEN
            PLAT = ALAT( Y-PY,GRIDSZ)*RADIAN
          ELSE
            PLAT = ALATU(Y-PY,GRIDSZ)*RADIAN
          ENDIF
          WRITE(6,8100) Y,PLAT
 8100     FORMAT(' P(',F9.3,
     +           '), is at Lat =',F8.3 /)
        ENDIF
C
   11 CONTINUE
  111 CONTINUE
      STOP
C     END OF PROGRAM FNDLAT.
      END
      SUBROUTINE IEEE_RETROSPECTIVE()
C
C     DUMMY ROUTINE TO TURN OFF IEEE WARNING MESSAGES ON A SUN.
C
      END


      subroutine lmpar(n,r,ldr,ipvt,diag,qtb,delta,par,x,sdiag,wa1,
     *                 wa2)
      integer n,ldr
      integer ipvt(n)
      double precision delta,par
      double precision r(ldr,n),diag(n),qtb(n),x(n),sdiag(n),wa1(n),
     *                 wa2(n)
c     **********
c
c     subroutine 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 lmpar 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     lmpar 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 lmpar 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 lmpar(n,r,ldr,ipvt,diag,qtb,delta,par,x,sdiag,
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       sdiag 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     subprograms called
c
c       minpack-supplied ... dpmpar,enorm,qrsolv
c
c       fortran-supplied ... dabs,dmax1,dmin1,dsqrt
c
c     argonne national laboratory. minpack project. march 1980.
c     burton s. garbow, kenneth e. hillstrom, jorge j. more
c
c     **********
      integer i,iter,j,jm1,jp1,k,l,nsing
      double precision dxnorm,dwarf,fp,gnorm,parc,parl,paru,p1,p001,
     *                 sum,temp,zero
      double precision dpmpar,enorm
      data p1,p001,zero /1.0d-1,1.0d-3,0.0d0/
c
c     dwarf is the smallest positive magnitude.
c
      dwarf = dpmpar(2)
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 = enorm(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 = enorm(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 = enorm(n,wa1)
      paru = gnorm/delta
      if (paru .eq. zero) paru = dwarf/dmin1(delta,p1)
c
c     if the input par lies outside of the interval (parl,paru),
c     set par to the closer endpoint.
c
      par = dmax1(par,parl)
      par = dmin1(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 = dmax1(dwarf,p001*paru)
         temp = dsqrt(par)
         do 160 j = 1, n
            wa1(j) = temp*diag(j)
  160       continue
         call qrsolv(n,r,ldr,ipvt,wa1,qtb,x,sdiag,wa2)
         do 170 j = 1, n
            wa2(j) = diag(j)*x(j)
  170       continue
         dxnorm = enorm(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 (dabs(fp) .le. p1*delta
     *       .or. parl .eq. zero .and. fp .le. temp
     *            .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)/sdiag(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 = enorm(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 = dmax1(parl,par)
         if (fp .lt. zero) paru = dmin1(paru,par)
c
c        compute an improved estimate for par.
c
         par = dmax1(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 lmpar.
c
      end


 MODULE GDSWZD03_MOD
!$$$  MODULE DOCUMENTATION BLOCK
!
! $Revision: 71314 $
!
! MODULE:  GDSWZD03_MOD  GDS WIZARD MODULE FOR LAMBERT CONFORMAL CONIC
!   PRGMMR: GAYNO     ORG: W/NMC23       DATE: 2015-01-21
!
! ABSTRACT: - CONVERT FROM EARTH TO GRID COORDINATES OR VICE VERSA.
!           - COMPUTE VECTOR ROTATION SINES AND COSINES.
!           - COMPUTE MAP JACOBIANS.
!           - COMPUTE GRID BOX AREA.
!
! PROGRAM HISTORY LOG:
!   2015-01-21  GAYNO   INITIAL VERSION FROM A MERGER OF
!                       ROUTINES GDSWIZ03 AND GDSWZD03.
!
! USAGE:  "USE GDSWZD03_MOD"  THEN CALL THE PUBLIC DRIVER
!         ROUTINE "GDSWZD03".
!
! ATTRIBUTES:
!   LANGUAGE: FORTRAN 90
!
!$$$
!
 IMPLICIT NONE

 PRIVATE

 PUBLIC                        :: GDSWZD03

 REAL,           PARAMETER     :: RERTH=6.3712E6
 REAL,           PARAMETER     :: PI=3.14159265358979
 REAL,           PARAMETER     :: DPR=180./PI

 INTEGER                       :: IROT

 REAL                          :: AN, DLON, DR, DXS, DYS, H

 CONTAINS

 SUBROUTINE GDSWZD03(KGDS,IOPT,NPTS,FILL,XPTS,YPTS,RLON,RLAT,NRET, &
                     CROT,SROT,XLON,XLAT,YLON,YLAT,AREA)
!$$$  SUBPROGRAM DOCUMENTATION BLOCK
!
! SUBPROGRAM:  GDSWZD03   GDS WIZARD FOR LAMBERT CONFORMAL CONICAL
!   PRGMMR: IREDELL       ORG: W/NMC23       DATE: 96-04-10
!
! ABSTRACT: THIS SUBPROGRAM DECODES THE GRIB GRID DESCRIPTION SECTION
!           (PASSED IN INTEGER FORM AS DECODED BY SUBPROGRAM W3FI63)
!           AND RETURNS ONE OF THE FOLLOWING:
!             (IOPT=+1) EARTH COORDINATES OF SELECTED GRID COORDINATES
!             (IOPT=-1) GRID COORDINATES OF SELECTED EARTH COORDINATES
!           FOR LAMBERT CONFORMAL CONICAL PROJECTIONS.
!           IF THE SELECTED COORDINATES ARE MORE THAN ONE GRIDPOINT
!           BEYOND THE THE EDGES OF THE GRID DOMAIN, THEN THE RELEVANT
!           OUTPUT ELEMENTS ARE SET TO FILL VALUES.
!           THE ACTUAL NUMBER OF VALID POINTS COMPUTED IS RETURNED TOO.
!           OPTIONALLY, THE VECTOR ROTATIONS, MAP JACOBIANS AND
!           GRID BOX AREAS FOR THIS GRID MAY BE RETURNED AS WELL.
!           TO COMPUTE THE VECTOR ROTATIONS, THE OPTIONAL ARGUMENTS
!           'SROT' AND 'CROT'  MUST BE PRESENT.  TO COMPUTE THE MAP
!           JACOBIANS, THE OPTIONAL ARGUMENTS 'XLON', 'XLAT',
!           'YLON', 'YLAT' MUST BE PRESENT. TO COMPUTE THE GRID BOX
!           AREAS THE OPTIONAL ARGUMENT 'AREA' MUST BE PRESENT.
!
! PROGRAM HISTORY LOG:
!   96-04-10  IREDELL
!   96-10-01  IREDELL  PROTECTED AGAINST UNRESOLVABLE POINTS
!   97-10-20  IREDELL  INCLUDE MAP OPTIONS
! 1999-04-27  GILBERT  CORRECTED MINOR ERROR CALCULATING VARIABLE AN
!                      FOR THE SECANT PROJECTION CASE (RLATI1.NE.RLATI2).
! 2012-08-14  GAYNO    FIX PROBLEM WITH SH GRIDS.  ENSURE GRID BOX
!                      AREA ALWAYS POSITIVE.
! 2015-01-21  GAYNO    MERGER OF GDSWIZ03 AND GDSWZD03.  MAKE
!                      CROT,SORT,XLON,XLAT,YLON,YLAT AND AREA
!                      OPTIONAL ARGUMENTS.  MAKE PART OF A MODULE.
!                      MOVE VECTOR ROTATION, MAP JACOBIAN AND GRID
!                      BOX AREA COMPUTATIONS TO SEPARATE SUBROUTINES.
!
! USAGE:    CALL GDSWZD03(KGDS,IOPT,NPTS,FILL,XPTS,YPTS,RLON,RLAT,NRET,
!    &                    CROT,SROT,XLON,XLAT,YLON,YLAT,AREA)
!
!   INPUT ARGUMENT LIST:
!     KGDS     - INTEGER (200) GDS PARAMETERS AS DECODED BY W3FI63
!     IOPT     - INTEGER OPTION FLAG
!                (+1 TO COMPUTE EARTH COORDS OF SELECTED GRID COORDS)
!                (-1 TO COMPUTE GRID COORDS OF SELECTED EARTH COORDS)
!     NPTS     - INTEGER MAXIMUM NUMBER OF COORDINATES
!     FILL     - REAL FILL VALUE TO SET INVALID OUTPUT DATA
!                (MUST BE IMPOSSIBLE VALUE; SUGGESTED VALUE: -9999.)
!     XPTS     - REAL (NPTS) GRID X POINT COORDINATES IF IOPT>0
!     YPTS     - REAL (NPTS) GRID Y POINT COORDINATES IF IOPT>0
!     RLON     - REAL (NPTS) EARTH LONGITUDES IN DEGREES E IF IOPT<0
!                (ACCEPTABLE RANGE: -360. TO 360.)
!     RLAT     - REAL (NPTS) EARTH LATITUDES IN DEGREES N IF IOPT<0
!                (ACCEPTABLE RANGE: -90. TO 90.)
!
!   OUTPUT ARGUMENT LIST:
!     XPTS     - REAL (NPTS) GRID X POINT COORDINATES IF IOPT<0
!     YPTS     - REAL (NPTS) GRID Y POINT COORDINATES IF IOPT<0
!     RLON     - REAL (NPTS) EARTH LONGITUDES IN DEGREES E IF IOPT>0
!     RLAT     - REAL (NPTS) EARTH LATITUDES IN DEGREES N IF IOPT>0
!     NRET     - INTEGER NUMBER OF VALID POINTS COMPUTED
!     CROT     - REAL, OPTIONAL (NPTS) CLOCKWISE VECTOR ROTATION COSINES
!     SROT     - REAL, OPTIONAL (NPTS) CLOCKWISE VECTOR ROTATION SINES
!                (UGRID=CROT*UEARTH-SROT*VEARTH;
!                 VGRID=SROT*UEARTH+CROT*VEARTH)
!     XLON     - REAL, OPTIONAL (NPTS) DX/DLON IN 1/DEGREES
!     XLAT     - REAL, OPTIONAL (NPTS) DX/DLAT IN 1/DEGREES
!     YLON     - REAL, OPTIONAL (NPTS) DY/DLON IN 1/DEGREES
!     YLAT     - REAL, OPTIONAL (NPTS) DY/DLAT IN 1/DEGREES
!     AREA     - REAL, OPTIONAL (NPTS) AREA WEIGHTS IN M**2
!                (PROPORTIONAL TO THE SQUARE OF THE MAP FACTOR)
!
! ATTRIBUTES:
!   LANGUAGE: FORTRAN 90
!
!$$$
 IMPLICIT NONE
!
 INTEGER,        INTENT(IN   ) :: IOPT, KGDS(200), NPTS
 INTEGER,        INTENT(  OUT) :: NRET
!
 REAL,           INTENT(IN   ) :: FILL
 REAL,           INTENT(INOUT) :: RLON(NPTS),RLAT(NPTS)
 REAL,           INTENT(INOUT) :: XPTS(NPTS),YPTS(NPTS)
 REAL, OPTIONAL, INTENT(  OUT) :: CROT(NPTS),SROT(NPTS)
 REAL, OPTIONAL, INTENT(  OUT) :: XLON(NPTS),XLAT(NPTS)
 REAL, OPTIONAL, INTENT(  OUT) :: YLON(NPTS),YLAT(NPTS),AREA(NPTS)
!
 INTEGER                       :: IM, JM, IPROJ, N
 INTEGER                       :: ISCAN, JSCAN
!
 LOGICAL                       :: LROT, LMAP, LAREA
!
 REAL                          :: ANTR, DI, DJ
 REAL                          :: DX, DY, DLON1
 REAL                          :: DE, DE2, DR2
 REAL                          :: HI, HJ
 REAL                          :: ORIENT, RLAT1, RLON1
 REAL                          :: RLATI1, RLATI2
 REAL                          :: XMAX, XMIN, YMAX, YMIN, XP, YP
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 IF(PRESENT(CROT)) CROT=FILL
 IF(PRESENT(SROT)) SROT=FILL
 IF(PRESENT(XLON)) XLON=FILL
 IF(PRESENT(XLAT)) XLAT=FILL
 IF(PRESENT(YLON)) YLON=FILL
 IF(PRESENT(YLAT)) YLAT=FILL
 IF(PRESENT(AREA)) AREA=FILL
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 IF(KGDS(1).EQ.003) THEN
   IM=KGDS(2)
   JM=KGDS(3)
   RLAT1=KGDS(4)*1.E-3
   RLON1=KGDS(5)*1.E-3
   IROT=MOD(KGDS(6)/8,2)
   ORIENT=KGDS(7)*1.E-3
   DX=KGDS(8)
   DY=KGDS(9)
   IPROJ=MOD(KGDS(10)/128,2)
   ISCAN=MOD(KGDS(11)/128,2)
   JSCAN=MOD(KGDS(11)/64,2)
   RLATI1=KGDS(12)*1.E-3
   RLATI2=KGDS(13)*1.E-3
   H=(-1.)**IPROJ
   HI=(-1.)**ISCAN
   HJ=(-1.)**(1-JSCAN)
   DXS=DX*HI
   DYS=DY*HJ
   IF(RLATI1.EQ.RLATI2) THEN
     AN=SIN(RLATI1/DPR)
   ELSE
     AN=LOG(COS(RLATI1/DPR)/COS(RLATI2/DPR))/ &
        LOG(TAN((90-RLATI1)/2/DPR)/TAN((90-RLATI2)/2/DPR))
   ENDIF
   DE=RERTH*COS(RLATI1/DPR)*TAN((RLATI1+90)/2/DPR)**AN/AN
   IF(H*RLAT1.EQ.90) THEN
     XP=1
     YP=1
   ELSE
     DR=DE/TAN((RLAT1+90)/2/DPR)**AN
     DLON1=MOD(RLON1-ORIENT+180+3600,360.)-180
     XP=1-SIN(AN*DLON1/DPR)*DR/DXS
     YP=1+COS(AN*DLON1/DPR)*DR/DYS
   ENDIF
   ANTR=1/(2*AN)
   DE2=DE**2
   XMIN=0
   XMAX=IM+1
   YMIN=0
   YMAX=JM+1
   NRET=0
   IF(PRESENT(CROT).AND.PRESENT(SROT))THEN
     LROT=.TRUE.
   ELSE
     LROT=.FALSE.
   ENDIF
   IF(PRESENT(XLON).AND.PRESENT(XLAT).AND.PRESENT(YLON).AND.PRESENT(YLAT))THEN
     LMAP=.TRUE.
   ELSE
     LMAP=.FALSE.
   ENDIF
   IF(PRESENT(AREA))THEN
     LAREA=.TRUE.
   ELSE
     LAREA=.FALSE.
   ENDIF
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  TRANSLATE GRID COORDINATES TO EARTH COORDINATES
   IF(IOPT.EQ.0.OR.IOPT.EQ.1) THEN
     DO N=1,NPTS
       IF(XPTS(N).GE.XMIN.AND.XPTS(N).LE.XMAX.AND. &
          YPTS(N).GE.YMIN.AND.YPTS(N).LE.YMAX) THEN
         DI=H*(XPTS(N)-XP)*DXS
         DJ=H*(YPTS(N)-YP)*DYS
         DR2=DI**2+DJ**2
         DR=SQRT(DR2)
         IF(DR2.LT.DE2*1.E-6) THEN
           RLON(N)=0.
           RLAT(N)=H*90.
         ELSE
           RLON(N)=MOD(ORIENT+1./AN*DPR*ATAN2(DI,-DJ)+3600,360.)
           RLAT(N)=(2*DPR*ATAN((DE2/DR2)**ANTR)-90)
         ENDIF
         NRET=NRET+1
         DLON=MOD(RLON(N)-ORIENT+180+3600,360.)-180
         IF(LROT)  CALL GDSWZD03_VECT_ROT(CROT(N),SROT(N))
         IF(LMAP)  CALL GDSWZD03_MAP_JACOB(RLAT(N),FILL, &
                                           XLON(N),XLAT(N),YLON(N),YLAT(N))
         IF(LAREA) CALL GDSWZD03_GRID_AREA(RLAT(N),FILL,AREA(N))
       ELSE
         RLON(N)=FILL
         RLAT(N)=FILL
       ENDIF
     ENDDO
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  TRANSLATE EARTH COORDINATES TO GRID COORDINATES
   ELSEIF(IOPT.EQ.-1) THEN
     DO N=1,NPTS
       IF(ABS(RLON(N)).LE.360.AND.ABS(RLAT(N)).LE.90.AND. &
                                      H*RLAT(N).NE.-90) THEN
         DR=H*DE*TAN((90-RLAT(N))/2/DPR)**AN
         DLON=MOD(RLON(N)-ORIENT+180+3600,360.)-180
         XPTS(N)=XP+H*SIN(AN*DLON/DPR)*DR/DXS
         YPTS(N)=YP-H*COS(AN*DLON/DPR)*DR/DYS
         IF(XPTS(N).GE.XMIN.AND.XPTS(N).LE.XMAX.AND. &
            YPTS(N).GE.YMIN.AND.YPTS(N).LE.YMAX) THEN
           NRET=NRET+1
           IF(LROT)  CALL GDSWZD03_VECT_ROT(CROT(N),SROT(N))
           IF(LMAP)  CALL GDSWZD03_MAP_JACOB(RLAT(N),FILL, &
                                             XLON(N),XLAT(N),YLON(N),YLAT(N))
           IF(LAREA) CALL GDSWZD03_GRID_AREA(RLAT(N),FILL,AREA(N))
         ELSE
           XPTS(N)=FILL
           YPTS(N)=FILL
         ENDIF
       ELSE
         XPTS(N)=FILL
         YPTS(N)=FILL
       ENDIF
     ENDDO
   ENDIF
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  PROJECTION UNRECOGNIZED
 ELSE
   IF(IOPT.GE.0) THEN
     DO N=1,NPTS
       RLON(N)=FILL
       RLAT(N)=FILL
     ENDDO
   ENDIF
   IF(IOPT.LE.0) THEN
     DO N=1,NPTS
       XPTS(N)=FILL
       YPTS(N)=FILL
     ENDDO
   ENDIF
 ENDIF
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 END SUBROUTINE GDSWZD03
!
 SUBROUTINE GDSWZD03_VECT_ROT(CROT,SROT)
!$$$  SUBPROGRAM DOCUMENTATION BLOCK
!
! SUBPROGRAM:  GDSWZD03_VECT_ROT   VECTOR ROTATION FIELDS FOR
!                                  LAMBERT CONFORMAL CONICAL
!
!   PRGMMR: GAYNO     ORG: W/NMC23       DATE: 2015-01-21
!
! ABSTRACT: THIS SUBPROGRAM COMPUTES THE VECTOR ROTATION SINES AND
!           COSINES FOR A LAMBERT CONFORMAL CONICAL GRID
!
! PROGRAM HISTORY LOG:
! 2015-01-21  GAYNO    INITIAL VERSION
!
! USAGE:    CALL GDSWZD03_VECT_ROT(CROT,SROT)
!
!   INPUT ARGUMENT LIST:
!     NONE
!
!   OUTPUT ARGUMENT LIST:
!     CROT     - CLOCKWISE VECTOR ROTATION COSINES (REAL)
!     SROT     - CLOCKWISE VECTOR ROTATION SINES (REAL)
!                (UGRID=CROT*UEARTH-SROT*VEARTH;
!                 VGRID=SROT*UEARTH+CROT*VEARTH)
!
! ATTRIBUTES:
!   LANGUAGE: FORTRAN 90
!
!$$$
 IMPLICIT NONE

 REAL,           INTENT(  OUT) :: CROT, SROT

 IF(IROT.EQ.1) THEN
   CROT=COS(AN*DLON/DPR)
   SROT=SIN(AN*DLON/DPR)
 ELSE
   CROT=1.
   SROT=0.
 ENDIF

 END SUBROUTINE GDSWZD03_VECT_ROT
!
 SUBROUTINE GDSWZD03_MAP_JACOB(RLAT,FILL,XLON,XLAT,YLON,YLAT)
!$$$  SUBPROGRAM DOCUMENTATION BLOCK
!
! SUBPROGRAM:  GDSWZD03_MAP_JACOB  MAP JACOBIANS FOR
!                                  LAMBERT CONFORMAL CONICAL
!
!   PRGMMR: GAYNO     ORG: W/NMC23       DATE: 2015-01-21
!
! ABSTRACT: THIS SUBPROGRAM COMPUTES THE MAP JACOBIANS FOR
!           A LAMBERT CONFORMAL CONICAL GRID.
!
! PROGRAM HISTORY LOG:
! 2015-01-21  GAYNO    INITIAL VERSION
!
! USAGE:  CALL GDSWZD03_MAP_JACOB(RLAT,FILL,XLON,XLAT,YLON,YLAT)
!
!   INPUT ARGUMENT LIST:
!     RLAT     - GRID POINT LATITUDE IN DEGREES (REAL)
!     FILL     - FILL VALUE FOR UNDEFINED POINTS (REAL)
!
!   OUTPUT ARGUMENT LIST:
!     XLON     - DX/DLON IN 1/DEGREES (REAL)
!     XLAT     - DX/DLAT IN 1/DEGREES (REAL)
!     YLON     - DY/DLON IN 1/DEGREES (REAL)
!     YLAT     - DY/DLAT IN 1/DEGREES (REAL)
!
! ATTRIBUTES:
!   LANGUAGE: FORTRAN 90
!
!$$$

 IMPLICIT NONE

 REAL,           INTENT(IN   ) :: RLAT, FILL
 REAL,           INTENT(  OUT) :: XLON, XLAT, YLON, YLAT

 REAL                          :: CLAT

 CLAT=COS(RLAT/DPR)
 IF(CLAT.LE.0.OR.DR.LE.0) THEN
   XLON=FILL
   XLAT=FILL
   YLON=FILL
   YLAT=FILL
 ELSE
   XLON=H*COS(AN*DLON/DPR)*AN/DPR*DR/DXS
   XLAT=-H*SIN(AN*DLON/DPR)*AN/DPR*DR/DXS/CLAT
   YLON=H*SIN(AN*DLON/DPR)*AN/DPR*DR/DYS
   YLAT=H*COS(AN*DLON/DPR)*AN/DPR*DR/DYS/CLAT
 ENDIF

 END SUBROUTINE GDSWZD03_MAP_JACOB
!
 SUBROUTINE GDSWZD03_GRID_AREA(RLAT,FILL,AREA)
!$$$  SUBPROGRAM DOCUMENTATION BLOCK
!
! SUBPROGRAM:  GDSWZD03_GRID_AREA  GRID BOX AREA FOR
!                                  LAMBERT CONFORMAL CONICAL
!
!   PRGMMR: GAYNO     ORG: W/NMC23       DATE: 2015-01-21
!
! ABSTRACT: THIS SUBPROGRAM COMPUTES THE GRID BOX AREA FOR
!           A LAMBERT CONFORMAL CONICAL GRID.
!
! PROGRAM HISTORY LOG:
! 2015-01-21  GAYNO    INITIAL VERSION
!
! USAGE:  CALL GDSWZD03_GRID_AREA(RLAT,FILL,AREA)
!
!   INPUT ARGUMENT LIST:
!     RLAT     - LATITUDE OF GRID POINT IN DEGREES (REAL)
!     FILL     - FILL VALUE FOR UNDEFINED POINTS (REAL)
!
!   OUTPUT ARGUMENT LIST:
!     AREA     - AREA WEIGHTS IN M**2 (REAL)
!
! ATTRIBUTES:
!   LANGUAGE: FORTRAN 90
!
!$$$

 IMPLICIT NONE

 REAL,           INTENT(IN   ) :: RLAT
 REAL,           INTENT(IN   ) :: FILL
 REAL,           INTENT(  OUT) :: AREA

 REAL                          :: CLAT

 CLAT=COS(RLAT/DPR)
 IF(CLAT.LE.0.OR.DR.LE.0) THEN
   AREA=FILL
 ELSE
   AREA=RERTH**2*CLAT**2*ABS(DXS)*ABS(DYS)/(AN*DR)**2
 ENDIF

 END SUBROUTINE GDSWZD03_GRID_AREA

 END MODULE GDSWZD03_MOD


!Calculate the writhe between segment that was moved and segment that was not moved using the method of Klenin (2000)

subroutine mc_writhe(R, RP, IB1, IB2, IT1, IT2, N, Wr)
   use params, only: dp, pi
   use precision, only: eps
   use vector_utils, only: cross
   implicit none

   integer, intent(in) :: N                 ! Number of beads per polymer
   real(dp), intent(in) :: R(3, N), RP(3, N)  ! Position
   integer, intent(in) :: IB1, IB2, IT1, IT2   ! Bead indices for terminal points of segment moved
   !integer, intent(in) :: IP                ! Test polymer index
   !Geometric variables
   real(dp) r1(3)                  ! Position bead 1
   real(dp) r2(3)                  ! Position bead 2
   real(dp) r12(3)                 ! Relative position vector
   real(dp) s1                     ! Length of segment 1
   real(dp) s2                     ! Length of segment 2
   real(dp) beta                   ! Angle between tangents
   real(dp) e1(3)                  ! Tangent of first segment
   real(dp) e2(3)                  ! Tangent of second segment
   real(dp) cosB
   real(dp) sin2B
   real(dp) e3(3)
   real(dp) a0
   real(dp) a1
   real(dp) a2
   real(dp) a3

   !Variables for writhe integral
   real(dp) t1
   real(dp) t2
   real(dp) F1
   real(dp) F2
   real(dp) F3
   real(dp) F4

   !Counter variables
   integer I
   integer J
   integer NBI, NBO, II, IO, IIP1, IOP1
   real(dp) dWr
   real(dp), intent(out) :: Wr      ! Writhe

   if (IB2 >= IB1) then
      NBI = IB2 - IB1
      NBO = N - NBI
   else
      NBO = IB1 - IB2
      NBI = N - NBO
   ENDif

   Wr = 0.
   II = IB1

   do I = 1, NBI - 1
      IO = IB1
      if (II .gt. N) then
         II = 1
         IIP1 = II + 1
      elseif (II == N) then
         IIP1 = 1
      else
         IIP1 = II + 1
      ENDif

      do J = 1, NBI - 1

         if (IO > N) then
            IO = 1
            IOP1 = IO + 1
         elseif (IO == N) then
            IOP1 = 1
         else
            IOP1 = IO + 1
         ENDif

         r1 = R(:, II)
         r2 = R(:, IO)
         r12 = r2 - r1

         if (RP(1, Io) /= R(1, Io) .OR. RP(2, Io) /= R(2, Io) .OR. RP(3, Io) /= R(3, Io)) then
            ! PRinT *, "POSITIONS NOT EQUAL", IO,"of", NBO
         ENDif

         if (RP(1, IOP1) /= R(1, IOP1) .OR. RP(2, IOP1) /= R(2, IOP1) .OR. RP(3, IOP1) /= RP(3, IOP1)) then
            !  PRinT *, "POSITIONS NOT EQUAL AT IOP1", IOP1
         endif

         s2 = SQRT(SUM((R(:, IOP1) - R(:, IO))**2))
         s1 = SQRT(SUM((R(:, IIP1) - R(:, II))**2))
         e2 = (R(:, IOP1) - R(:, IO))/s2
         e1 = (R(:, IIP1) - R(:, II))/s1
         cosB = doT_PRODUCT(e1, e2)

         sin2B = 1 - (cosB**2)

         e3 = cross(e1, e2)

         a1 = doT_PRODUCT(r12, e2*cosB - e1)/(sin2B)
         a2 = doT_PRODUCT(r12, e2 - e1*cosB)/sin2B
         a0 = doT_PRODUCT(r12, e3)/sin2B

         t1 = a1 + s1
         t2 = a2 + s2
         F1 = -ATAN((t1*t2 + (a0**2)*cosB)/(a0*SQRT((t1**2 + t2**2 - 2.*t1*t2*cosB + (a0**2)*sin2B))))/(4.*PI)
         t1 = a1 + s1
         t2 = a2
         F2 = -ATAN((t1*t2 + (a0**2)*cosB)/(a0*SQRT((t1**2 + t2**2 - 2*t1*t2*cosB + (a0**2)*sin2B))))/(4.*PI)
         t1 = a1
         t2 = a2 + s2
         F3 = -ATAN((t1*t2 + (a0**2)*cosB)/(a0*SQRT((t1**2 + t2**2 - 2*t1*t2*cosB + (a0**2)*sin2B))))/(4.*PI)
         t1 = a1
         t2 = a2
         F4 = -ATAN((t1*t2 + (a0**2)*cosB)/(a0*SQRT((t1**2 + t2**2 - 2*t1*t2*cosB + (a0**2)*sin2B))))/(4.*PI)
         dWr = F1 - F2 - F3 + F4

         if (dWr /= dWr) then
            dWr = 0.
         endif

         Wr = Wr + dWr

         IO = IO + 1
      ENDdo
      II = II + 1
   ENDdo

   Wr = 2.*Wr

   RETURN
END subroutine mc_writhe


!----------------------------------------------------------------------*
! SUBROUTINE SGPCDT                                                    *
! Authors: Daniel van Kraalingen                                       *
! Date   : 28-Apr-1995, Version: 1.2                                   *
! Purpose: This subroutine calculates daily total gross                *
!          assimilation (GPCDT) by performing a Gaussian integration   *
!          over time. At three different times of the day,             *
!          radiation is computed and used to determine assimilation    *
!          whereafter integration takes place. Accuracy of computation *
!          can be controlled the switch IACC (IACC=1 calls three point *
!          GAUSS procedure, IACC=2 calls combination routine with      *
!          error control                                               *
!                                                                      *
! FORMAL PARAMETERS:  (I=input,O=output,C=control,IN=init,T=time)      *
! name   type meaning                                     units  class *
! ----   ---- -------                                     -----  ----- *
! IACC    I4  Switch used to determine accuracy of            -     I  *
!             assimilation calculations                                *
! IDOY    I4  Day of year                                    d      I  *
! LAT     R4  Latitude of the site                        degrees   I  *
! RDD     R4  Daily total of shortwave radiation          J/m2/d    I  *
! FRPAR   R4  Fraction of total shortwave irradiation        -      I  *
!             that is photosynthetically active                        *
! CSLV    R4  Scattering coefficient of leaves for PAR        -     I  *
! AMAX    R4  Assimilation rate at light saturation       kg CO2/   I  *
!                                                        ha leaf/h     *
! EFF     R4  Initial light use efficiency               kg CO2/J/  I  *
!                                                       (ha/h/m2/s)    *
! ECPDF   R4  Extinction coefficient for          ha ground/ha leaf I  *
!             diffuse light                                            *
! GAI     R4  Green area index                    ha leaf/ha ground I  *
! DAYL    R4  Astronomic daylength (base = 0 degrees)        h      O  *
! DAYLP   R4  Photoperiodic daylength (base = -4 degrees)    h      O  *
! GPCDT   R4  Daily total gross assimilation            kg CO2/ha/d O  *
! RAPCDT  R4  Daily rate of absorbed PAR                  J/m/d     O  *
!                                                                      *
! Fatal error checks: none                                             *
! Warnings          : none                                             *
! Subprograms called: SASTRO, SGPC1, SGPC2, SSKYC                      *
! File usage        : none                                             *
!----------------------------------------------------------------------*

      SUBROUTINE SGPCDT (IACC, IDOY , LAT   , RDD  , FRPAR, &
                         CSLV, AMAX , EFF   , ECPDF, GAI  , &
                         DAYL, DAYLP, GPCDT, RAPCDT)
      IMPLICIT NONE

!     Formal parameters
      INTEGER IACC, IDOY
      REAL LAT, RDD, FRPAR, CSLV, AMAX, EFF, ECPDF, GAI
      REAL DAYL, DAYLP, GPCDT, RAPCDT

!     Local parameters

!     Gauss parameters
      INTEGER IGSN
      PARAMETER (IGSN=3)
      REAL GSX(IGSN), GSW(IGSN)

!     Miscellaneous
      REAL SOLCON,DSINB,DSINBE,SINLD,COSLD,HOUR,SINB,RDPDR,RDPDF
      REAL GPC,ANGOT,RAPC
      INTEGER I1

      SAVE         ! TAOLI

      DATA GSX /0.112702, 0.500000, 0.887298/
      DATA GSW /0.277778, 0.444444, 0.277778/

!     Compute daylength and related data
      CALL SASTRO (IDOY,LAT, &
                   SOLCON,ANGOT,DAYL,DAYLP,DSINB,DSINBE,SINLD,COSLD)

!     Assimilation set to zero and three different times of the day
      GPCDT  = 0.
      RAPCDT = 0.
      DO I1=1,IGSN

!        At the specified HOUR, external radiation
!        conditions are computed
         HOUR = 12.0+DAYL*0.5*GSX(I1)
         CALL SSKYC (HOUR, SOLCON, FRPAR, DSINBE, SINLD, COSLD, RDD, &
                     SINB, RDPDR, RDPDF)

!        Assimilation rate of canopy is computed
         IF (IACC.EQ.1) THEN
!           Choose three point Gauss method
            CALL SGPC1 (CSLV, AMAX, EFF,ECPDF, GAI, SINB, RDPDR, RDPDF, &
                        GPC, RAPC)
         ELSE IF (IACC.EQ.2) THEN
!           Choose routine with internal error control
            CALL SGPC2 (CSLV, AMAX, EFF,ECPDF, GAI, SINB, RDPDR, RDPDF, &
                        GPC, RAPC)
         ELSE
            CALL FATALERR ('SGPCDT','accuracy not specified')
         END IF

         GPCDT  = GPCDT +GPC *GSW(I1)
         RAPCDT = RAPCDT+RAPC*GSW(I1)
      END DO

!     Integration of assimilation rate to a daily total (GPCDT)
      GPCDT  = GPCDT *DAYL

!     Integration of absorption rate to a daily total (RAPCDT)
      RAPCDT = RAPCDT*DAYL*3600.

      RETURN
      END


!
!     CalculiX - A 3-dimensional finite element program
!              Copyright (C) 1998-2018 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
!     S.W. Sloan, Adv.Eng.Software,1987,9(1),34-55.
!     Permission for use with the GPL license granted by Prof. Scott
!     Sloan on 17. Nov. 2013
!
      subroutine deltri(numpts,n,x,y,list,bin,v,e,numtri)
!
      implicit none
!
      integer n,i,list(*),v(3,*),e(3,*),numtri,bin(*),p,numpts
!
      real*8 xmin,xmax,ymin,ymax,dmax,c00001,fact,x(*),y(*)
!
      parameter(c00001=1.d0)
!
      xmin=x(list(1))
      xmax=xmin
      ymin=y(list(1))
      ymax=ymin
      do 5 i=2,n
         p=list(i)
         xmin=min(xmin,x(p))
         xmax=max(xmax,x(p))
         ymin=min(ymin,y(p))
         ymax=max(ymax,y(p))
 5    continue
      dmax=max(xmax-xmin,ymax-ymin)
      fact=c00001/dmax
      do 10 i=1,n
         p=list(i)
         x(p)=(x(p)-xmin)*fact
         y(p)=(y(p)-ymin)*fact
 10   continue
      call bsort(n,x,y,xmin,xmax,ymin,ymax,dmax,bin,list)
      call delaun(numpts,n,x,y,list,bin,v,e,numtri)
      do 30 i=1,n
         p=list(i)
         x(p)=x(p)*dmax+xmin
         y(p)=y(p)*dmax+ymin
 30   continue
      end


program main
  ! Big int library
  use big_int_math

  ! Default
  implicit none

  ! Variables
  character(100) :: a,b,out

  ! Test big num lib
  a = '2147483647'
  b = '852516354'
  out = add_two_big_nums(a,b)

  write(*,*) 'a: ',a
  write(*,*) 'b: ',b
  write(*,*) 'a + b: ',out

end program main


module rpoisson_other

! Other Poisson integrators, not directly used by dftatom, but available
! for reuse. This module contains various Adams predictor-corrector integrators
! (both for outward and inward integration).

use types, only: dp
use constants, only: pi
use ode1d_other, only: adams_extrapolation_inward, adams_interp_inward
use ode1d, only: adams_extrapolation_outward, adams_interp_outward

implicit none

private
public rpoisson_inward, rpoisson_outward_pc_rV, rpoisson_inward_pc, &
    rpoisson_inward_pc_rV

contains

function rpoisson_inward(R, Rp, rho, Z) result(V)
! Solves the equation V''(r) + 2/r*V'(r) = -4*pi*rho
!
! Uses explicit Adams method.
!
!
! It rewrites it to (r*V)'' = -4*pi*rho*r, converts to uniform grid:
!   u1 = r*V
!   u2 = (r*V)'
!   u1p = u2 * Rp
!   u2p = -4*pi*rho*R * Rp
! and integrates inward using Adams method. This gives u1=r*V and
! at the end we divide by "r": V = u1/r
!
! The boundary condition is such, that V -> Z/r for large r. So the boundary
! condition for u1=r*V is Z. We just set the initial 4 points of u1 for
! the Adams method equal to Z (and zero derivative u2) at the right hand side
! of the domain.
real(dp), intent(in) :: R(:), Rp(:), rho(:)
integer, intent(in) :: Z
real(dp) :: V(size(R))

real(dp), dimension(size(R)) :: u1, u1p, u2p
real(dp) :: u2
integer :: N, i

N = size(R)
u1(N-3:N) = Z
u2 = 0
u1p(N-3:N) = 0
u2p = -4*pi*rho * R * Rp

do i = N-3, 2, -1
    u1p(i) = Rp(i) * u2
    u1(i-1)  = u1(i)  + adams_extrapolation_inward(u1p, i)
    u2  = u2  + adams_extrapolation_inward(u2p, i)
end do
V = u1/R
end function

function rpoisson_inward_pc_rV(R, Rp, rho, Z) result(V)
! Solves the equation V''(r) + 2/r*V'(r) = -4*pi*rho
!
! Uses predictor corrector Adams method.
!
! It rewrites it to (r*V)'' = -4*pi*rho*r, converts to uniform grid:
!   u1 = r*V
!   u2 = (r*V)'
!   u1p = u2 * Rp
!   u2p = -4*pi*rho*R * Rp
! and integrates inward using Adams method. This gives u1=r*V and
! at the end we divide by "r": V = u1/r
!
! The boundary condition is such, that V -> Z/r for large r. So the boundary
! condition for u1=r*V is Z. We just set the initial 4 points of u1 for
! the Adams method equal to Z (and zero derivative u2) at the right hand side
! of the domain.
real(dp), intent(in) :: R(:), Rp(:), rho(:)
integer, intent(in) :: Z
real(dp) :: V(size(R))

real(dp), dimension(size(R)) :: u1, u2, u1p, u2p
integer :: N, i, it
integer, parameter :: max_it = 4
!real(dp), parameter :: alpha = 32.388_dp
!real(dp), parameter :: alpha = 1.0_dp/25

N = size(R)
!u1(N-3:N) = Z * erf(alpha * R(N-3:N))
!u2(N-3:N) = Z * alpha * 2 / sqrt(pi) * exp(-alpha**2 * R(N-3:N)**2)
u1 = Z
u2 = 0
!u1 = Z * erf(alpha * R)
!u2 = Z * alpha * 2 / sqrt(pi) * exp(-alpha**2 * R**2)
!u1p(N-3:N) = u2(N-3:N) * Rp(N-3:N)
u1p = u2 * Rp
u2p = -4*pi*rho * R * Rp

do i = N-3, 2, -1
    !u1p(i) = Rp(i) * u2(i)
    u1(i-1)  = u1(i)  + adams_extrapolation_inward(u1p, i)
    u2(i-1)  = u2(i)  + adams_extrapolation_inward(u2p, i)
    do it = 1, max_it
        u1p(i-1) = Rp(i-1) * u2(i-1)
        u1(i-1)  = u1(i)  + adams_interp_inward(u1p, i)
        u2(i-1)  = u2(i)  + adams_interp_inward(u2p, i)
    end do
end do
V = u1/R
end function

function rpoisson_inward_pc(R, Rp, rho, Z) result(V)
! Solves the equation V''(r) + 2/r*V'(r) = -4*pi*rho
!
! Uses predictor corrector Adams method.
!
! It rewrites it to (r*V)'' = -4*pi*rho*r, converts to uniform grid:
!   u1 = r*V
!   u2 = (r*V)'
!   u1p = u2 * Rp
!   u2p = -4*pi*rho*R * Rp
! and integrates inward using Adams method. This gives u1=r*V and
! at the end we divide by "r": V = u1/r
!
! The boundary condition is such, that V -> Z/r for large r. So the boundary
! condition for u1=r*V is Z. We just set the initial 4 points of u1 for
! the Adams method equal to Z (and zero derivative u2) at the right hand side
! of the domain.
real(dp), intent(in) :: R(:), Rp(:), rho(:)
integer, intent(in) :: Z
real(dp) :: V(size(R))

real(dp), dimension(size(R)) :: u1, u2, u1p, u2p
integer :: N, i, it
integer, parameter :: max_it = 4
!real(dp), parameter :: alpha = 32.388_dp
!real(dp), parameter :: alpha = 1.0_dp/25

N = size(R)
u1 = Z
u2 = 0
!u1(N-3:N) = Z * erf(alpha * R(N-3:N))
!u2(N-3:N) = Z * alpha * 2 / sqrt(pi) * exp(-alpha**2 * R(N-3:N)**2)
!u1 = Z * erf(alpha * R) / R
!u2 = -Z * erf(alpha * R) / R**2 + &
!            Z * alpha * 2 / sqrt(pi) * exp(-alpha**2 * R**2) / R
u1p = u2 * Rp
u2p = -(4*pi*rho + 2*u2/R) * Rp

do i = N-3, 2, -1
    u1(i-1)  = u1(i)  + adams_extrapolation_inward(u1p, i)
    u2(i-1)  = u2(i)  + adams_extrapolation_inward(u2p, i)
    do it = 1, max_it
        u1p(i-1) = +Rp(i-1) * u2(i-1)
        u2p(i-1) = -Rp(i-1) * (4*pi*rho(i-1) + 2*u2(i-1)/R(i-1))
        u1(i-1)  = u1(i)  + adams_interp_inward(u1p, i)
        u2(i-1)  = u2(i)  + adams_interp_inward(u2p, i)
    end do
end do
V = u1
end function

function rpoisson_outward_pc_rV(R, Rp, rho, Z) result(V)
! Solves the equation V''(r) + 2/r*V'(r) = -4*pi*rho
!
! Uses predictor corrector Adams method.
!
! It rewrites it to (r*V)'' = -4*pi*rho*r, converts to uniform grid:
!   u1 = r*V
!   u2 = (r*V)'
!   u1p = u2 * Rp
!   u2p = -4*pi*rho*R * Rp
! and integrates outward using Adams method. This gives u1=r*V and
! at the end we divide by "r": V = u1/r
real(dp), intent(in) :: R(:), Rp(:), rho(:)
integer, intent(in) :: Z
real(dp) :: V(size(R))

real(dp), dimension(size(R)) :: u1, u2, u1p, u2p
integer :: N, i, it
integer, parameter :: max_it = 2
!real(dp), parameter :: alpha = 32.388_dp
!real(dp), parameter :: alpha = 1.0_dp / 25

N = size(R)
!u1(:4) = Z * erf(alpha * R(:4))
!u2(:4) = Z * alpha * 2 / sqrt(pi) * exp(-alpha**2 * R(:4)**2)
!u1(:4) = Z * 2 * alpha * R(:4) / sqrt(pi)
!u2(:4) = Z * 2 * alpha / sqrt(pi)
u1(:4) = Z
u2(:4) = 0
!print *, u1(:4)
!print *, u2(:4)
!stop "OK"
u1p(:4) = u2(:4) * Rp(:4)
u2p = -4*pi*rho * R * Rp

do i = 4, N-1
    u1p(i) = Rp(i) * u2(i)
    u1(i+1)  = u1(i)  + adams_extrapolation_outward(u1p, i)
    u2(i+1)  = u2(i)  + adams_extrapolation_outward(u2p, i)
    do it = 1, max_it
        u1p(i+1) = Rp(i+1) * u2(i+1)
        u1(i+1)  = u1(i)  + adams_interp_outward(u1p, i)
        u2(i+1)  = u2(i)  + adams_interp_outward(u2p, i)
    end do
end do
V = u1/R
!V = V - V(N) + Z/R(N)
end function

end module


!===================================================================
!
! Simple utilities for math/porting

! I decided to use overloading so that the polymorphic calls are
! automatically bound to the right wrapper.
!
! Initial version:  Ken McElvain   17Jan2015
!
module butil_mod
   implicit none

   interface BMIN
      MODULE PROCEDURE BMIN_I4I4, BMIN_I4I8, BMIN_I8I4, BMIN_I8I8, &
      BMIN_R4R4, BMIN_R4R8, BMIN_R8R4, BMIN_R8R8
   end interface BMIN

   interface BMAX
      MODULE PROCEDURE BMAX_I4I4, BMAX_I4I8, BMAX_I8I4, BMAX_I8I8, &
      BMAX_R4R4, BMAX_R4R8, BMAX_R8R4, BMAX_R8R8
   end interface BMAX

contains

! min for kind=4 integers
integer(kind=4) function BMIN_I4I4(a,b)
   implicit none
   integer(kind=4),intent(in) :: a, b
   if(a < b) then
      BMIN_I4I4 = a
   else
      BMIN_I4I4 = b
   end if
   RETURN
end function BMIN_I4I4

! min for mixed case
integer(kind=8) function BMIN_I4I8(a,b)
   implicit none
   integer(kind=4),intent(in) :: a
   integer(kind=8),intent(in) :: b
   integer(kind=8) :: a8
   a8 = a
   if(a8 < b) then
      BMIN_I4I8 = a8
   else
      BMIN_I4I8 = b
   end if
   RETURN
end function BMIN_I4I8

! min for other mixed case
integer(kind=8) function BMIN_I8I4(a,b)
   implicit none
   integer(kind=8),intent(in) :: a
   integer(kind=4),intent(in) :: b
   integer(kind=8) :: b8
   b8 = b
   if(a < b8) then
      BMIN_I8I4 = a
   else
      BMIN_I8I4 = b8
   end if
   RETURN
end function BMIN_I8I4

! min for kind=8 integers
integer(kind=8) function BMIN_I8I8(a,b)
   implicit none
   integer(kind=8),intent(in) :: a
   integer(kind=8),intent(in) :: b
   if(a < b) then
      BMIN_I8I8 = a
   else
      BMIN_I8I8 = b
   end if
   RETURN
end function BMIN_I8I8

! min for kind=4 reals
real(kind=4) function BMIN_R4R4(a,b)
   implicit none
   real(kind=4),intent(in) :: a, b
   if(a < b) then
      BMIN_R4R4 = a
   else
      BMIN_R4R4 = b
   end if
   RETURN
end function BMIN_R4R4

! min for mixed kind=4,8 reals
real(kind=8) function BMIN_R4R8(a,b)
   implicit none
   real(kind=4),intent(in) :: a
   real(kind=8),intent(in) :: b
   real(kind=8) :: a8
   a8 = a
   if(a8 < b) then
      BMIN_R4R8 = a8
   else
      BMIN_R4R8 = b
   end if
   RETURN
end function BMIN_R4R8

! min for mixed kind=8,4 reals
real(kind=8) function BMIN_R8R4(a,b)
   implicit none
   real(kind=8),intent(in) :: a
   real(kind=4),intent(in) :: b
   real(kind=8) :: b8
   b8 = b
   if(a < b8) then
      BMIN_R8R4 = a
   else
      BMIN_R8R4 = b8
   end if
   RETURN
end function BMIN_R8R4

! min for kind=8 reals
real(kind=8) function BMIN_R8R8(a,b)
   implicit none
   real(kind=8),intent(in) :: a
   real(kind=8),intent(in) :: b
   if(a < b) then
      BMIN_R8R8 = a
   else
      BMIN_R8R8 = b
   end if
   RETURN
end function BMIN_R8R8

! max for kind=4 integers
integer(kind=4) function BMAX_I4I4(a,b)
   implicit none
   integer(kind=4),intent(in) :: a, b
   if(a > b) then
      BMAX_I4I4 = a
   else
      BMAX_I4I4 = b
   end if
   RETURN
end function BMAX_I4I4

! max for mixed case
integer(kind=8) function BMAX_I4I8(a,b)
   implicit none
   integer(kind=4),intent(in) :: a
   integer(kind=8),intent(in) :: b
   integer(kind=8) :: a8
   a8 = a
   if(a8 > b) then
      BMAX_I4I8 = a8
   else
      BMAX_I4I8 = b
   end if
   RETURN
end function BMAX_I4I8

! max for other mixed case
integer(kind=8) function BMAX_I8I4(a,b)
   implicit none
   integer(kind=8),intent(in) :: a
   integer(kind=4),intent(in) :: b
   integer(kind=8) :: b8
   b8 = b
   if(a > b8) then
      BMAX_I8I4 = a
   else
      BMAX_I8I4 = b8
   end if
   RETURN
end function BMAX_I8I4

! max for kind=8 integers
integer(kind=8) function BMAX_I8I8(a,b)
   implicit none
   integer(kind=8),intent(in) :: a
   integer(kind=8),intent(in) :: b
   if(a > b) then
      BMAX_I8I8 = a
   else
      BMAX_I8I8 = b
   end if
   RETURN
end function BMAX_I8I8

! max for kind=4 reals
real(kind=4) function BMAX_R4R4(a,b)
   implicit none
   real(kind=4),intent(in) :: a, b
   if(a > b) then
      BMAX_R4R4 = a
   else
      BMAX_R4R4 = b
   end if
   RETURN
end function BMAX_R4R4

! max for mixed kind=4,8 reals
real(kind=8) function BMAX_R4R8(a,b)
   implicit none
   real(kind=4),intent(in) :: a
   real(kind=8),intent(in) :: b
   real(kind=8) :: a8
   a8 = a
   if(a8 > b) then
      BMAX_R4R8 = a8
   else
      BMAX_R4R8 = b
   end if
   RETURN
end function BMAX_R4R8

! max for mixed kind=8,4 reals
real(kind=8) function BMAX_R8R4(a,b)
   implicit none
   real(kind=8),intent(in) :: a
   real(kind=4),intent(in) :: b
   real(kind=8) :: b8
   b8 = b
   if(a > b8) then
      BMAX_R8R4 = a
   else
      BMAX_R8R4 = b8
   end if
   RETURN
end function BMAX_R8R4

! max for kind=8 reals
real(kind=8) function BMAX_R8R8(a,b)
   implicit none
   real(kind=8),intent(in) :: a
   real(kind=8),intent(in) :: b
   if(a > b) then
      BMAX_R8R8 = a
   else
      BMAX_R8R8 = b
   end if
   RETURN
end function BMAX_R8R8

subroutine overflowerr(msg)
   implicit none
   character(len=*), intent(in) :: msg
   print *, msg
   call printstacktrace  ! if enabled in build
   stop 1
end subroutine overflowerr

! utility to convert an 8 byte integer to a 4 byte integer
! with overflow detection
integer(kind=4) function bint8to4(i8, id)
   implicit none
   integer(kind=8), intent(in) :: i8
   integer :: id ! identification of caller
   integer(kind=4) :: i4
   i4 = int(i8, kind(i4))
   if(i4 /= i8) then
      print *, "Stuffing oversized number in integer(kind=4)", i8, ", at id=", id
      call printstacktrace  ! if enabled in build
      stop 1
   end if
   bint8to4 = i4
   return
end function bint8to4

! generic way to stop on error
! should we print iproc?
subroutine errstop(msg)
   implicit none
   character(len=*), intent(in) :: msg
   write(6,"(A)") msg
   flush(6)
   call printstacktrace  ! if enabled in build
   stop 1
end subroutine errstop

!==========================================================
      real function zeta(i,j)

      implicit none

      integer i,j

      zeta = 1.0
      if(i ==j)zeta = sqrt(2.)
      return
      end function zeta

end module butil_mod


module filters
use, intrinsic:: iso_fortran_env, only: stderr=>error_unit
use, intrinsic:: iso_c_binding, only: c_int, c_bool
use, intrinsic:: ieee_arithmetic, only: ieee_value, ieee_quiet_nan
use comm, only: sp

implicit none (type, external)
private
public:: fircircfilter

contains

subroutine fircircfilter(x,N,b,L, y,filtok) bind(c)
! http://www.mathworks.com/help/fixedpoint/ug/convert-fir-filter-to-fixed-point-with-types-separate-from-code.html
integer(c_int), intent(in) :: N,L
real(sp),intent(in) :: x(N), b(L)
real(sp),intent(out) :: y(N)
logical(c_bool),intent(out) :: filtok

integer :: k,p, i,j
real(sp) :: z(L), acc, nan
logical,parameter :: verbose=.false.

nan = ieee_value(1._sp, ieee_quiet_nan)

filtok=.false.

if (N < 1) then
  write(stderr,*) "E: expected input array length>0, you passed in len(x)=",N
  y(1) = nan
  return
elseif (verbose) then
  print *, "input signal len(x)=",size(x)," output signal len(y)=",size(y)
endif

if (L < 1) then
  write(stderr,*) "E: expected more than zero filter coefficients, len(B)=",L
  y(1) = nan
  return
elseif (verbose) then
  print *, "filter coefficients len(B)=",L
endif

!    if (any(ieee_is_nan(b))) then
!        write(stderr,*) 'E: NaN filter coefficients'
!        y(1) = nan
!        return
!    endif

p = 0
z(:) = 0

do i = 1,N
  p = p + 1
  if (p > L)  p = 1
  z(p) = x(i)
  acc = 0
  k = p
  do j = 1,L
    acc = acc + b(j)*z(k)
    k = k - 1
    if (k < 1)  k = L
  enddo !j
  y(i) = acc
enddo !i

filtok = .true.

end subroutine fircircfilter

end module filters


PROGRAM CEI_EXAMPLE
! Gael de Oliveira, Ricardo Pereira, Feb. 2015
! We follow implicit type rules REAL(A-H,O-Z), INTEGER(I-N)

! Start by including the data (file generated from matlab
! with custom script)
     INCLUDE 'CEI_DATA.f90'
! Typical variable declarations found in the include (together with data)
!    INTEGER N_HK, N_RT, N_TPPT
!    REAL, DIMENSION(1,11) :: HK_RANGE
!    REAL, DIMENSION(1,11) :: RT_RANGE
!    REAL, DIMENSION(1,11) :: TPPT_RANGE
!    REAL, DIMENSION(11,11,11) :: CEI_TABLE

! Define CEI evaluation point
      HK   = 2.0
      RT   = 1000.0
      TPPT = 0.5

! Look for upper nearest neighbour of desired CEI point in (HK,RT,TPPT) space
! This code is a bit a hard to understand (deep nesting) but fairly efficient for a
! simple algorithm (in terms of theorethical computational complexity, might still
! pose efficiency issues on architectures with inneficient execution control, but
! I seem to remember that x64 is fairly good at that!)
      DO 100 I_HK=2,N_HK
        ! Check if we are in proper HK interval
        IF (HK .LT. HK_RANGE(1,I_HK)) THEN
          ! Loop through RT only if that is the case (and not otherwise)
          DO 200 I_RT=2,N_RT
            ! Check if we are in proper RT interval
            IF (RT .LT. RT_RANGE(1,I_RT)) THEN
              ! Loop through TPPT only if that is the case (and not otherwise)
              DO 300 I_TPPT=2,N_TPPT
                ! Check if we are in proper TPPT interval
                IF (TPPT .LT.  TPPT_RANGE(1,I_TPPT)) THEN
                  ! Write some output
                  WRITE(*,1000) I_HK, I_RT, I_TPPT
                  WRITE(*,1100) HK_RANGE(1,I_HK) , RT_RANGE(1,I_RT), TPPT_RANGE(1,I_TPPT)
                  ! And leave loop
                  GOTO 500
                ENDIF
 300          CONTINUE
            ENDIF
 200      CONTINUE
        ENDIF
 100  CONTINUE

 500  WRITE(*,*) 'FOUND POINT!!!'

      WRITE(*,1000) I_HK, I_RT, I_TPPT
      WRITE(*,1100) HK_RANGE(1,I_HK) , RT_RANGE(1,I_RT), TPPT_RANGE(1,I_TPPT)

 1000 FORMAT('I_HK=', I12  , '   I_RT=', I12  , '   I_TPPT=', I12)
 1100 FORMAT('  HK=', F12.4, '     RT=', F12.1, '     TPPT=', F12.4)

END PROGRAM


c     program DRDFMIN
c>> 1996-05-28 DRDFMIN Krogh  Moved format up.
c>> 1994-10-19 DRDFMIN Krogh  Changes to use M77CON
c>> 1994-07-15 DRDFMIN CLL
c>> 1993-03-01 CLL Changed "zero" to "minimum".
c>> 1992-03-24 CLL Added missing comma in format statement.
c>> 1987-12-09 DRDFMIN  Lawson  Initial Code.
c     Demo driver for DFMIN.  Finds minimum of a univariate function.
c     C. L. Lawson & S. Y. Chiu, JPL, Aug 1987, Oct 1987
c     F. T. Krogh, Oct. 1987.
c     ------------------------------------------------------------------
c--D replaces "?": DR?FMIN, ?FMIN
c     ------------------------------------------------------------------
      double precision A, B, X, XORF, TOL, XTOL, TWO
      parameter(A = -1.0D0, B = 1.0D0, XTOL = 1.0D-7)
      parameter(TWO = 2.0D0)
      integer MODE
    1 format(' Results returned by DFMIN:'/'    MODE = ',i3/
     *'    Solution:     X = ',f16.08/
     *'               f(X) = ',f16.08)
c     ------------------------------------------------------------------
      write(*,'(1x,a)')
     * 'DRDFMIN.. Demo driver for DFMIN, univariate minimum finder.',
     * 'Problem:      Find minimum of 2**X + 2**(-2*X).',
     * 'Exact result: X = 1/3',
     * 'Min value: 1.5 * 2**(1/3) = 1.88988157...'
      X = A
      XORF = B
      TOL = XTOL
      MODE = 0
   10 call DFMIN(X, XORF, MODE, TOL)
      if (MODE .ne. 1) go to 20
         XORF = TWO**X + TWO**(-TWO*X)
      go to 10
   20 continue
      write(*,1) MODE, X, XORF
      stop
      end


MODULE gs

  implicit none

CONTAINS

  subroutine serialgs(n,M,b,x,r,iter,eps,maxit)

    ! SCALAR ARGUMENTS
    integer :: n,iter,maxit
    real(8) :: eps,r

    ! ARRAY ARGUMENTS
    real(8) :: M(n,n),b(n),x(n)

    intent(in   ) :: M,b,n,eps,maxit
    intent(out  ) :: r,iter
    intent(inout) :: x

    ! LOCAL SCALARS
    integer :: i
    real(8) :: prev(n)

    r = 1.0D+20

    iter = 0

    do while (r .gt. eps .and. iter .lt. maxit)

       ! UPDATING X

       do i = 1,n
          prev(i) = x(i)
       end do

       call updatex(1,n,n,M,b,x)

       ! STOPPING CRITERIUM

       r = 0.0D0
       do i = 1,n
          r = max(r,abs(prev(i) - x(i)))
          if (r .gt. eps) then
             exit
          end if
       end do

       iter = iter + 1

    end do

  end subroutine serialgs

  subroutine updatex(start,end,n,M,b,x)

    ! This subroutine applies the Gauss-Seidel step in a subset of the
    ! rows and variables of the system.

    ! ARGUMENTS
    integer :: start,end,n
    real(8) :: M(n,n),b(n),x(n)

    intent(in   ) :: start,end,n,M,b
    intent(inout) :: x

    ! LOCAL SCALARS
    integer :: i,j
    real(8) :: s

    do i = start,end
       s = b(i)
       do j = 1,n
          if (i .ne. j) then
             s = s - M(i,j) * x(j)
          end if
       end do
       x(i) = s / M(i,i)
    end do

  end subroutine updatex

  integer function ceil(x)

    ! SCALAR ARGUMENTS
    real(8), intent(in) :: x

    ceil = INT(x)

    if (ceil .ne. x) then
       return
    end if

    return

  end function ceil

  subroutine sharedgs(n,M,b,x,r,iter,eps,maxit)

    ! Shared memory Gauss-Seidel method, using OpenMP routines.

    ! SCALAR ARGUMENTS
    integer :: n,iter,maxit
    real(8) :: eps

    ! ARRAY ARGUMENTS
    real(8) :: M(n,n),b(n),x(n),r

    intent(in   ) :: M,b,n,eps,maxit
    intent(out  ) :: r,iter
    intent(inout) :: x

    ! LOCAL SCALARS
    integer :: i,np,tn,start,end,it

    ! LOCAL ARRAYS
    real(8) :: res(n)

    ! FUNCTIONS
    integer omp_get_num_threads,omp_get_thread_num

    do i = 1,n
       res(i) = 1.0D+20
    end do

    iter = 0

    !$OMP PARALLEL PRIVATE(np,tn,start,end,it)

    np = omp_get_num_threads()

    tn = omp_get_thread_num()

    start = 1 + ceil(tn * n / (1.0D0 * np))

    if (tn .eq. np - 1) then
       end = n
    else
       end = ceil((tn + 1) * n / (1.0D0 * np))
    end if

    call partialgs(n,M,b,x,res,start,end,it,eps,maxit)

    !$OMP ATOMIC
    iter = iter + it

    !$OMP END PARALLEL

    r = maxval(res)

  end subroutine sharedgs

  subroutine partialgs(n,M,b,x,r,start,end,iter,eps,maxit)

    ! SCALAR ARGUMENTS
    integer :: n,start,end,iter,maxit
    real(8) :: eps

    ! ARRAY ARGUMENTS
    real(8) :: M(n,n),b(n),x(n),r(n)

    intent(in   ) :: M,b,n,eps,start,end,maxit
    intent(out  ) :: r,iter
    intent(inout) :: x

    ! LOCAL SCALARS
    integer :: i
    real(8) :: res

    ! LOCAL ARRAYS
    real(8) :: prev(start:end)

    iter = 0

    res = maxval(r)

    do while (res .gt. eps .and. iter .lt. maxit)

       do i = start,end
          prev(i) = x(i)
       end do

       call updatex(start,end,n,M,b,x)

       ! STOPPING CRITERIUM

       res = 0.0D0
       do i = start,end
          r(i) = abs(prev(i) - x(i))
          res = max(res,r(i))
       end do

       if (res .lt. eps) then
          res = maxval(r)
       end if

       iter = iter + 1

    end do

  end subroutine partialgs

END MODULE


module m_TypeDef
  implicit none
  public

  integer,parameter::  RK = KIND(0.0D0)
  real(RK),parameter:: Pi   = 3.141592653589793238462643383279502884_RK    ! Pi constant
  real(RK),parameter:: twoPi= 6.283185307179586476925286766559005768_RK
  integer,save:: nrank  ! local MPI rank
  integer,save:: nproc  ! total number of processors

  real(RK),parameter:: zero     =  0.000_RK
  real(RK),parameter:: quarter  =  0.250_RK
  real(RK),parameter:: oneEighth=  0.125_RK
  real(RK),parameter:: half     =  0.500_RK
  real(RK),parameter:: one      =  1.000_RK
  real(RK),parameter:: two      =  2.000_RK
  real(RK),parameter:: three    =  3.000_RK
  real(RK),parameter:: four     =  4.000_RK
  real(RK),parameter:: five     =  5.000_RK
  real(RK),parameter:: eight    =  8.000_RK
  real(RK),parameter:: ten      = 10.000_RK
  real(RK),parameter:: twelve   = 12.000_RK
  real(RK),parameter:: fifteen  = 15.000_RK
  real(RK),parameter:: sixteen  = 16.000_RK
  real(RK),parameter:: seventeen= 17.000_RK
  real(RK),parameter:: sixty    = 60.000_RK

  interface num2str
    module procedure num2strI, num2strR4, num2strR8
  end interface

contains

  ! integer number to string
  character(64) function num2strI( i )
    implicit none
    integer, intent(in) :: i
    character(64):: ch

    write(ch,"(I20)") i
    num2strI = trim(adjustl(ch))
  end function

  ! float number to string
  character(64) function num2strR4( i )
    implicit none
    real(4), intent(in) :: i
    character(64):: ch

    write(ch,"(ES15.6)") i
    num2strR4 = trim(adjustl(ch))
  end function

  ! double number to string
  character(64) function num2strR8( i )
    implicit none
    real(8), intent(in) :: i
    character(64):: ch

    write(ch,"(ES20.10)") i
    num2strR8 = trim(adjustl(ch))
  end function

end module m_TypeDef


program test2d

  use decomp_2d
  use decomp_2d_io

  implicit none

  integer, parameter :: nx=50, ny=50, nz=50
  integer, parameter :: p_row=2, p_col=2

  real(mytype), dimension(nx,ny,nz) :: data1

  real(mytype), allocatable, dimension(:,:,:) :: u1, u2, u3

  integer :: i,j,k, m, ierror

  call MPI_INIT(ierror)
  call decomp_2d_init(nx,ny,nz,p_row,p_col)

  ! ***** global data *****
  m = 1
  do k=1,nz
     do j=1,ny
        do i=1,nx
           data1(i,j,k) = float(m)
           m = m+1
        end do
     end do
  end do

  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  ! Testing the swap routines
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

  !allocate(u1(xstart(1):xend(1), xstart(2):xend(2), xstart(3):xend(3)))
  !allocate(u2(ystart(1):yend(1), ystart(2):yend(2), ystart(3):yend(3)))
  !allocate(u3(zstart(1):zend(1), zstart(2):zend(2), zstart(3):zend(3)))
  call alloc_x(u1, opt_global=.true.)
  call alloc_y(u2, opt_global=.true.)
  call alloc_z(u3, opt_global=.true.)

  ! original x-pensil based data
  do k=xstart(3),xend(3)
    do j=xstart(2),xend(2)
      do i=xstart(1),xend(1)
        u1(i,j,k) = data1(i,j,k)
      end do
    end do
  end do

10 format(15I5)

  if (nrank==0) then
     write(*,*) 'Numbers held on Rank 0'
     write(*,*) ' '
     write(*,*) 'X-pencil'
     write(*,10) int(u1)
  end if

  call decomp_2d_write_one(1,u1,'u1.dat')

  !!!!!!!!!!!!!!!!!!!!!!!
  ! x-pensil ==> y-pensil
  call transpose_x_to_y(u1,u2)

  if (nrank==0) then
     write(*,*) ' '
     write(*,*) 'Y-pencil'
     write(*,10) int(u2)
  end if

  call decomp_2d_write_one(2,u2,'u2.dat')
  ! 'u1.dat' and 'u2.dat' should be identical byte-by-byte

  ! also check the transposition this way
  do k=ystart(3),yend(3)
    do j=ystart(2),yend(2)
      do i=ystart(1),yend(1)
        if (abs(u2(i,j,k)-data1(i,j,k)).gt.0) stop "error swaping x->y"
      end do
    end do
  end do

  !!!!!!!!!!!!!!!!!!!!!!!
  ! y-pensil ==> z-pensil
  call transpose_y_to_z(u2,u3)

  if (nrank==0) then
     write(*,*) ' '
     write(*,*) 'Z-pencil'
     write(*,10) int(u3)
  end if

  call decomp_2d_write_one(3,u3,'u3.dat')
  ! 'u1.dat','u2.dat' and 'u3.dat' should be identical

  do k=zstart(3),zend(3)
    do j=zstart(2),zend(2)
      do i=zstart(1),zend(1)
        if (abs(u3(i,j,k)-data1(i,j,k)).gt.0) stop "error swaping y->z"
      end do
    end do
  end do

  !!!!!!!!!!!!!!!!!!!!!!!
  ! z-pensil ==> y-pensil
  call transpose_z_to_y(u3,u2)
  call decomp_2d_write_one(2,u2,'u2b.dat')

  do k=ystart(3),yend(3)
    do j=ystart(2),yend(2)
      do i=ystart(1),yend(1)
        if (abs(u2(i,j,k)-data1(i,j,k)).gt.0) stop "error swaping z->y"
      end do
    end do
  end do

  !!!!!!!!!!!!!!!!!!!!!!!
  ! y-pensil ==> x-pensil
  call transpose_y_to_x(u2,u1)
  call decomp_2d_write_one(1,u1,'u1b.dat')

  do k=xstart(3),xend(3)
    do j=xstart(2),xend(2)
      do i=xstart(1),xend(1)
        if (abs(u1(i,j,k)-data1(i,j,k)).gt.0) stop "error swaping y->x"
      end do
    end do
  end do

  call decomp_2d_finalize
  call MPI_FINALIZE(ierror)
  deallocate(u1,u2,u3)

end program test2d