SUBROUTINE ZGBSVX_F95(A, B, X, KL, AFB, IPIV, FACT, TRANS, &
                      EQUED, R, C, FERR, BERR, RCOND, RPVGRW, INFO)
!
!  -- LAPACK95 interface driver routine (version 3.0) --
!     UNI-C, Denmark; Univ. of Tennessee, USA; NAG Ltd., UK
!     September, 2000
!
!  .. USE STATEMENTS ..
   USE LA_PRECISION, ONLY: WP => DP
   USE LA_AUXMOD, ONLY: LSAME, ERINFO
   USE F77_LAPACK, ONLY: GBSVX_F77 => LA_GBSVX
!  .. IMPLICIT STATEMENT ..
   IMPLICIT NONE
!  .. SCALAR ARGUMENTS ..
   CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS, FACT
   CHARACTER(LEN=1), INTENT(INOUT), OPTIONAL :: EQUED
   INTEGER, INTENT(IN), OPTIONAL :: KL
   INTEGER, INTENT(OUT), OPTIONAL :: INFO
   REAL(WP), INTENT(OUT), OPTIONAL :: RCOND, RPVGRW
!  .. ARRAY ARGUMENTS ..
   COMPLEX(WP), INTENT(INOUT) :: A(:,:), B(:,:)
   COMPLEX(WP), INTENT(OUT) :: X(:,:)
   INTEGER, INTENT(INOUT), OPTIONAL, TARGET :: IPIV(:)
   COMPLEX(WP), INTENT(INOUT), OPTIONAL, TARGET :: AFB(:,:)
   REAL(WP), INTENT(INOUT), OPTIONAL, TARGET :: C(:), R(:)
   REAL(WP), INTENT(OUT), OPTIONAL, TARGET :: FERR(:), BERR(:)
!----------------------------------------------------------------------
!
! Purpose
! =======
!
!    LA_GBSVX computes the solution to a real or complex linear system of
! equations of the form A*X = B, A^T*X = B or A^H*X = B, where A is a
! square band matrix and X and B are rectangular matrices or vectors.
!    LA_GBSVX can also optionally equilibrate the system if A is poorly
! scaled, estimate the condition number of (the equilibrated) A, return
! the pivot growth factor, and compute error bounds.
!
! =========
!
!       SUBROUTINE LA_GBSVX( AB, B, X, KL=kl, AFB=afb, IPIV=ipiv, &
!                  FACT=fact, TRANS=trans, EQUED=equed, R=r, C=c, &
!                  FERR=ferr, BERR=berr, RCOND=rcond, &
!                  RPVGRW=rpvgrw, INFO=info )
!          <type>(<wp>), INTENT(INOUT) :: AB(:,:), <rhs>
!          <type>(<wp>), INTENT(OUT) :: <sol>
!          INTEGER, INTENT(IN), OPTIONAL :: KL
!          <type>(<wp>), INTENT(INOUT), OPTIONAL :: AFB(:,:)
!          INTEGER, INTENT(INOUT), OPTIONAL :: IPIV(:)
!          CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: TRANS, FACT
!          CHARACTER(LEN=1), INTENT(INOUT), OPTIONAL :: EQUED
!          REAL(<wp>), INTENT(INOUT), OPTIONAL :: C(:), R(:)
!          REAL(<wp>), INTENT(OUT), OPTIONAL :: <err>, RCOND, RPVGRW
!          INTEGER, INTENT(OUT), OPTIONAL :: INFO
!       where
!          <type> ::= REAL | COMPLEX
!          <wp>   ::= KIND(1.0) | KIND(1.0D0)
!          <rhs>  ::= B(:,:) | B(:)
!          <sol>  ::= X(:,:) | X(:)
!          <err>  ::= FERR(:), BERR(:) | FERR, BERR
!
! Arguments
! =========
!
! AB        (input/output) REAL or COMPLEX rectangular array, shape (:,:)
!           with size(AB,1) = kl + ku + 1 and size(AB,2) = n, where kl
!           and ku are, respectively, the numbers of subdiagonals and
!           superdiagonals in the band of A, and n is the order of A.
!           On entry, the matrix A or its equilibration in band storage.
!           The (kl + ku + 1) diagonals of A are stored in rows 1 to
!           (kl + ku + 1) of AB, so that the j-th column of A is
!           stored in the j-th column of AB as follows:
!           AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl)
! 	                              1<=j<=n.
!           The remaining elements in AB need not be set.
!           If FACT = 'F' and EQUED /= 'N' then A has been equilibrated
!           by the scaling factors in R and/or C during the previous call
!           to LA GBSVX.
!           On exit, if FACT = 'E', the equilibrated version of A is
!           stored in AB; otherwise, AB is unchanged.
! B         (input/output) REAL or COMPLEX array, shape (:,:) with
!           size(B,1) = n or shape (:) with size(B) = n.
!           On entry, the matrix B.
!           On exit, the scaled version of B if the system has been
!           equilibrated; otherwise, B is unchanged.
! X         (output) REAL or COMPLEX array, shape (:,:) with size(X,1)=n
!           and size(X,2) = size(B,2), or shape (:) with size(X) = n.
!           The solution matrix X .
! KL        Optional (input) INTEGER.
!           The number of subdiagonals in the band of A (KL = kl).
!           The number of superdiagonals in the band is given by
! 	    ku =  size(AB,1) - kl - 1.
!           Default value: (size(AB,1) - 1) / 2.
! AFB       Optional (input or output) REAL or COMPLEX rectangular array,
!           shape (:,:) with size(AFB,1) = 2*kl+ku+1 and size(AFB,2)=n
!           If FACT = 'F' then AFB is an input argument that contains the
!           details of the factorization of (the equilibrated) A returned
!           by a previous call to LA_GBSVX.
!           If FACT /= 'F' then AFB is an output argument that contains
!           the details of the factorization of (the equilibrated) A. U is
! 	    an upper triangular band matrix with (kl + ku + 1) diagonals.
!           These are stored in the first (kl + ku + 1) rows of AFB. The
!           multipliers that arise during the factorization are stored in
!           the remaining rows.
! IPIV      Optional (input or output) INTEGER array, shape (:) with
!           size(IPIV) = n.
!           If FACT = 'F' then IPIV is an input argument that contains
!           the pivot indices from the factorization of (the equilibrated)
!           A, returned by a previous call to LA_GBSVX.
!           If FACT /= 'F' then IPIV is an output argument that contains
!           the pivot indices from the factorization of (the equilibrated)
! 	    A.
! FACT      Optional (input) CHARACTER(LEN=1).
!           Specifies whether the factored form of the matrix A is
!           supplied on entry, and, if not, whether the matrix A should
!           be equilibrated before it is factored.
!             = 'N': The matrix A will be copied to AFB and factored (no
! 	           equilibration).
!             = 'E': The matrix A will be equilibrated, then copied to
! 	           AFB and factored.
!             = 'F': AFB and IPIV contain the factored form of (the
! 	           equilibrated) A.
!           Default value: 'N'.
! TRANS     Optional (input) CHARACTER(LEN=1).
!           Specifies the form of the system of equations:
!             = 'N': A*X = B (No transpose)
!             = 'T': A^T*X = B (Transpose)
!             = 'C': A^H*X = B (Conjugate transpose)
!           Default value: 'N'.
! EQUED     Optional (input or output) CHARACTER(LEN=1).
!           Specifies the form of equilibration that was done.
!           EQUED is an input argument if FACT = 'F', otherwise it is an
!           output argument:
!             = 'N': No equilibration (always true if FACT = 'N').
!             = 'R': Row equilibration, i.e., A has been premultiplied
! 	           by diag(R).
!             = 'C': Column equilibration, i.e., A has been postmultiplied
! 	           by diag(C).
!             = 'B': Both row and column equilibration.
!           Default value: 'N'.
! R         Optional (input or output) REAL array, shape (:) with
!           size(R) = size(A,1).
!           The row scale factors for A.
!           R is an input argument if FACT = 'F' and EQUED = 'R' or 'B'.
!           R is an output argument if FACT = 'E' and EQUED = 'R' or 'B'.
! C         Optional (input or output) REAL array, shape (:) with
!           size(C) = size(A,1).
!           The column scale factors for A.
!           C is an input argument if FACT = 'F' and EQUED = 'C' or 'B'.
!           C is an output argument if FACT = 'E' and EQUED = 'C' or 'B'.
! FERR      Optional (output) REAL array of shape (:), with size(FERR) =
!           size(X,2), or REAL scalar.
!           The estimated forward error bound for each solution vector
!           X(j) (the j-th column of the solution matrix X). If XTRUE is
!           the true solution corresponding to X(j), FERR(j) is an
!           estimated upper bound for the magnitude of the largest element
!           in (X(j)-XTRUE) divided by the magnitude of the largest
! 	    element in X(j). The estimate is as reliable as the estimate
!           for RCOND and is almost always a slight overestimate of the
!           true error.
! BERR      Optional (output) REAL array of shape (:), with size(BERR) =
!           size(X,2), or REAL scalar.
!           The componentwise relative backward error of each solution
!   	    vector X(j) (i.e., the smallest relative change in any element
!           of A or B that makes X(j) an exact solution).
! RCOND     Optional (output) REAL.
!           The estimate of the reciprocal condition number of (the
!           equilibrated) A. If RCOND is less than the machine precision,
! 	    the matrix is singular to working precision. This condition is
!           indicated by a return code of INFO > 0.
! RPVGRW    Optional (output) REAL.
!           The reciprocal pivot growth factor ||A||inf = ||U||inf. If
! 	    RPVGRW is much less than 1, then the stability of the LU
! 	    factorization of the (equilibrated) matrix A could be poor.
!           This also means that the solution X , condition estimator
!           RCOND, and forward error bound FERR could be unreliable. If
! 	    the factorization fails with 0 < INFO <= size(A,1), then
!           RPVGRW contains the reciprocal pivot growth factor for the
!           leading INFO columns of A.
! INFO      Optional (output) INTEGER
!           = 0: successful exit.
!           < 0: if INFO = -i, the i-th argument had an illegal value.
!           > 0: if INFO = i, and i is
!             <= n: U(i,i) = 0. The factorization has been completed,
! 	          but the factor U is singular, so the solution could
! 		  not be computed.
!             = n+1: U is nonsingular, but RCOND is less than machine
! 	          precision, so the matrix is singular to working
! 		  precision. Nevertheless, the solution and error
! 		  bounds are computed because the computed solution can
! 		  be more accurate than the value of RCOND would suggest.
!           If INFO is not present and an error occurs, then the program
! 	    is terminated with an error message.
!----------------------------------------------------------------------
!  .. PARAMETERS ..
   CHARACTER(LEN=8), PARAMETER :: SRNAME = 'LA_GBSVX'
!  .. LOCAL SCALARS ..
   CHARACTER(LEN=1) :: LFACT, LTRANS, LEQUED
   INTEGER :: LINFO, NRHS, N, ISTAT, ISTAT1, SIPIV, S1AFB, S2AFB, &
              SC, SR, SFERR, SBERR, LD, LKL, LKU, LDA
   REAL(WP) :: LRCOND, MVR, MVC
!  .. LOCAL POINTERS ..
   INTEGER, POINTER :: LPIV(:)
   REAL(WP),  POINTER :: RWORK(:), LC(:), LR(:), LFERR(:), LBERR(:)
   COMPLEX(WP),  POINTER :: WORK(:), LAFB(:, :)
!  .. INTRINSIC FUNCTIONS ..
   INTRINSIC MAX, PRESENT, SIZE, MINVAL, TINY
!  .. EXECUTABLE STATEMENTS ..
   LINFO = 0; ISTAT = 0
   LDA = SIZE(A,1); N = SIZE(A, 2); NRHS = SIZE(B, 2); LD = MAX(1,N)
   IF( PRESENT(KL) ) THEN; LKL = KL; ELSE; LKL = (LDA-1)/2; ENDIF
   LKU = LDA -LKL -1
   IF( PRESENT(RCOND) ) RCOND = 1.0_WP
   IF( PRESENT(RPVGRW) ) RPVGRW = 1.0_WP
   IF( PRESENT(FACT) )THEN; LFACT = FACT; ELSE; LFACT='N'; END IF
   IF( PRESENT(EQUED) .AND. LSAME(LFACT,'F') )THEN; LEQUED = EQUED
   ELSE; LEQUED='N'; END IF
   IF( PRESENT(IPIV) )THEN; SIPIV = SIZE(IPIV); ELSE; SIPIV = N; END IF
   IF( PRESENT(AFB) )THEN; S1AFB = SIZE(AFB,1); S2AFB = SIZE(AFB,2)
   ELSE; S1AFB = 2*LKL+LKU+1; S2AFB = N; END IF
   IF( ( PRESENT(C) ) )THEN; SC = SIZE(C); ELSE; SC = N; END IF
   IF( ( PRESENT(C) .AND. LSAME(LFACT,'F') ) .AND. &
       ( LSAME(LEQUED,'C') .OR. LSAME(LEQUED,'B') ) )THEN; MVC = MINVAL(C)
   ELSE; MVC = TINY(1.0_WP); END IF
   IF( PRESENT(R) )THEN; SR = SIZE(R); ELSE; SR = N; END IF
   IF( ( PRESENT(R) .AND. LSAME(LFACT,'F') ) .AND. &
       ( LSAME(LEQUED,'R') .OR. LSAME(LEQUED,'B') ) )THEN; MVR = MINVAL(R)
   ELSE; MVR = TINY(1.0_WP); END IF
   IF( PRESENT(FERR) )THEN; SFERR = SIZE(FERR); ELSE; SFERR = NRHS; END IF
   IF( PRESENT(BERR) )THEN; SBERR = SIZE(BERR); ELSE; SBERR = NRHS; END IF
   IF(PRESENT(TRANS))THEN; LTRANS = TRANS; ELSE; LTRANS='N'; END IF
!  .. TEST THE ARGUMENTS
   IF( LDA < 0 .OR. N < 0 ) THEN; LINFO = -1
   ELSE IF( SIZE(B, 1) /= N .OR. NRHS < 0 )THEN; LINFO = -2
   ELSE IF( SIZE(X, 1) /= N .OR. SIZE(X, 2) /= NRHS )THEN; LINFO = -3
   ELSE IF( LKL < 0 .OR. LKU < 0 ) THEN; LINFO = -4
   ELSE IF( S1AFB /= 2*LKL+LKU+1 .OR. S2AFB /= N ) THEN; LINFO = -5
   ELSE IF( SIPIV /= N )THEN; LINFO = -6
   ELSE IF( SR /= N .OR. MVR <= 0.0_WP )THEN; LINFO = -10
   ELSE IF( SC /= N .OR. MVC <= 0.0_WP )THEN; LINFO = -11
   ELSE IF( SFERR /= NRHS )THEN; LINFO = -12
   ELSE IF( SBERR /= NRHS )THEN; LINFO = -13
   ELSE IF( ( .NOT. ( LSAME(LFACT,'F') .OR. LSAME(LFACT,'N') .OR. &
                    LSAME(LFACT,'E') ) ) .OR. &
       ( LSAME(LFACT,'F') .AND. .NOT.( PRESENT(AFB) .AND. PRESENT(IPIV) ) ) )THEN
      LINFO = -7
   ELSE IF( .NOT.( LSAME(LTRANS,'N') .OR.  LSAME(LTRANS,'T') .OR. &
                  LSAME(LTRANS,'C') ) )THEN; LINFO = -8
   ELSE IF( ( .NOT.( LSAME(LEQUED,'N') .OR. LSAME(LEQUED,'R') .OR. &
          LSAME(LEQUED,'C') .OR. LSAME(LEQUED,'B') ) &
              .AND. LSAME(LFACT,'F') ) .OR. &
         ( ( LSAME(LEQUED,'R') .OR. LSAME(LEQUED,'B') ) .AND. &
              .NOT.PRESENT(R) ) .OR. &
         ( ( LSAME(LEQUED,'C') .OR. LSAME(LEQUED,'B') ) .AND. &
              .NOT.PRESENT(C) ) )THEN; LINFO = -9
   ELSE IF ( N > 0 )THEN
      IF( .NOT.PRESENT(AFB) ) THEN; ALLOCATE( LAFB(S1AFB,N), STAT=ISTAT )
      ELSE; LAFB => AFB; END IF
      IF( ISTAT == 0 )THEN
         IF( .NOT.PRESENT(IPIV) )THEN; ALLOCATE( LPIV(N), STAT=ISTAT )
         ELSE; LPIV => IPIV; END IF
      END IF
      IF( ISTAT == 0 )THEN
         IF( .NOT.PRESENT(R) )THEN; ALLOCATE( LR(N), STAT=ISTAT )
         ELSE; LR => R; END IF
      END IF
      IF( ISTAT == 0 )THEN
         IF( .NOT.PRESENT(C) )THEN; ALLOCATE( LC(N), STAT=ISTAT )
         ELSE; LC => C; END IF
      END IF
      IF( ISTAT == 0 )THEN
         IF( .NOT.PRESENT(FERR) )THEN; ALLOCATE( LFERR(NRHS), STAT=ISTAT )
         ELSE; LFERR => FERR; END IF
      END IF
      IF( ISTAT == 0 )THEN
         IF( .NOT.PRESENT(BERR) )THEN; ALLOCATE( LBERR(NRHS), STAT=ISTAT )
         ELSE; LBERR => BERR; END IF
      END IF
      IF( ISTAT == 0 ) ALLOCATE(WORK(2*N), RWORK(N), STAT=ISTAT )
      IF( ISTAT == 0 )THEN
         CALL GBSVX_F77( LFACT, LTRANS, N, LKL, LKU, NRHS, A, LDA, LAFB, S1AFB, &
                         LPIV, LEQUED, LR, LC, B, LD, X, LD, LRCOND, &
                         LFERR, LBERR, WORK, RWORK, LINFO )
      ELSE; LINFO = -100; END IF
      IF( .NOT.PRESENT(R) ) DEALLOCATE( LR, STAT=ISTAT1 )
      IF( .NOT.PRESENT(C) ) DEALLOCATE( LC, STAT=ISTAT1 )
      IF( .NOT.PRESENT(AFB) ) DEALLOCATE( LAFB, STAT=ISTAT1 )
      IF( .NOT.PRESENT(IPIV) ) DEALLOCATE( LPIV, STAT=ISTAT1 )
      IF( .NOT.PRESENT(FERR) ) DEALLOCATE( LFERR, STAT=ISTAT1 )
      IF( .NOT.PRESENT(BERR) ) DEALLOCATE( LBERR, STAT=ISTAT1 )
      IF( PRESENT(RCOND) ) RCOND=LRCOND
      IF( PRESENT(EQUED) .AND. .NOT.LSAME(LFACT,'F') ) EQUED=LEQUED
      IF( PRESENT(RPVGRW) ) RPVGRW=RWORK(1)
      DEALLOCATE( WORK, RWORK, STAT=ISTAT1 )
   END IF
   CALL ERINFO( LINFO, SRNAME, INFO, ISTAT )
END SUBROUTINE ZGBSVX_F95


! ising.f90
! Author: Adam Iaizzi
! Updated 2020-03-24
! Based on a code by Anders Sandvik (see README for link)

!----------------------------------------------------------------------!
! Metropolis-algorithm simulation of the two-dimensional Ising model   !
! antiferromagnet with a uniform external field
! Reads the following from a file 'read.in':                           !
!    ll,tt, hh                                                         !
!    steps1,steps2,bins                                                !
! where: ll     = linear system size (integer)                         !
!        tt     = temperature (T/J)                                    !
!        hh     = field (h/J)                                          !
!        steps1 = # of sweeps for equilibration                        !
!        steps2 = # of sweeps per bin data collection                  !
!        bins   = # of data bins                                       !
! Random numbers seed (and integer) is read from 'seed.in'.            !
! Output files are save separated .txt files                           !
! amag.txt --> T  <m> <m^2> <m^4> (uniform magnetization, real, extensive)!
! enrg.txt --> T  <en> <en^2> (real, extensive)                       !
! smag.txt --> T  <m> <m^2> <m^4> (stagger magnetization, real, extensive)!
! spins.txt --> sigma_0 sigma_1 sigma_2 .... (spin config, integer)    !
! census.txt --> T  # of spins in each local config (see README)       !
!                                                                      !
!   See README.md for more info                                        !
!----------------------------------------------------------------------!

!----------------------!
 module systemvariables
 implicit none

 integer :: ll                       ! system length
 integer :: nn                       ! number of spins (nn=ll*ll)
 real(8) :: pflip(-4:4,-1:1)        ! flip probabilities
 integer, allocatable :: spin(:)     ! spin array

 end module systemvariables
!--------------------------!

!----------------------!
 module runSums
 implicit none
 ! array for census of local configurations
 integer :: census(-4:5) = 0
 ! x= center spin
 ! y= sum of neighboring spins
 !if x=-1, type=y. If x=+1, type=y+1
 end module runSums
!--------------------------!

!---------------!
 program ising2d
!---------------!
 use systemvariables
 use runSums
 implicit none

 integer :: i,j,m,bins,steps1,steps2,x,y
 real(8) :: crand,tt,mav,mav2,mav4,smav,smav2,smav4,en,en2,runsum
 real(8) :: hh
 integer, allocatable :: alt(:)
 ! function for calculating total flip probability
 real(8) :: sumFlips

 open(1,file='read.in',status='old')
 read(1,*)ll,tt,hh
 read(1,*)steps1,steps2,bins
 close(1)
 nn=ll*ll

 call initran(1)

 print*, "h=", hh, " t = ", tt
 ! set up flip probabilities
 do i=-4,4
    pflip(i,-1)=exp((2.d0*dble(i)+2*hh)/tt)
    pflip(i,0)=0.0d0
    pflip(i,+1)=exp((2.d0*dble(i)-2*hh)/tt)
 end do

 ! allocate arrays
 allocate (spin(0:nn-1))
 allocate (alt(0:nn-1))
 ! initialize random spin configuration and build checkerboard alternating sign array
 do i=0,nn-1
    spin(i)=2*int(2.d0*crand())-1
    x = mod(i,ll)
    y = i/ll
    alt(i) = (2*mod(x,2)-1)*(2*mod(y,2)-1)
 enddo

 ! equilibrate
 do i=1,steps1
    call mcstep()
 enddo

 ! do simulation, loop over bins
 do j=1,bins
    print*, "Bin ", j, " of ", bins
    ! reset magnetization sums
    mav=0.d0
    mav2=0.d0
    mav4=0.d0
    smav=0.d0
    smav2=0.d0
    smav4=0.d0
    census=0
    ! reset energy sums
    en=0.d0
    en2=0.d0
    ! do monte carlo sweeps
    do i=1,steps2
        !perfom mc sweep
       call mcstep()
       !sum magnetization
       m=sum(spin)
       mav= mav+(1.d0*m)/steps2;
       mav2=mav2+(1.d0*m)**2/steps2;
       mav4=mav4+(1.d0*m)**4/steps2;

       !calculate energy, use runsum (real) for running sum
       runsum=0-1.0d0*m*hh
       !interactions
       do y=0,ll-1
            do x=0,ll-1
                runsum=runsum+spin(ll*y+x)*(spin(ll*mod(y+1,ll)+x)+spin(ll*y+mod(x+1,ll)))
            enddo
       enddo
       ! add energy to running sums (with field contribution)
       en=en+(1.d0*runsum)/steps2;
       en2=en2+(1.d0*runsum)**2/steps2;

       !sum staggered magnetization
       m=dot_product(spin,alt)
       smav= smav+(1.d0*m)/steps2;
       smav2=smav2+(1.d0*m)**2/steps2;
       smav4=smav4+(1.d0*m)**4/steps2;
    enddo

    !do census (only once per bin)
    call doCensus()

    !write data to file at the end of each bin

    ! uniform magnetization: T, <m>, <m^2>, <m^4>
    open(10,file='amag.txt',position='append')
    write(10,'(f8.3,3en16.6)') tt,mav,mav2,mav4
    close(10)
    ! staggered magnetization: T, <sm>, <sm^2>, <sm^4>
    open(10,file='smag.txt',position='append')
    write(10,'(f8.3,3en16.6)') tt,smav,smav2,smav4
    close(10)
    ! energy: T, <E>, <E^2>
    open(10,file='enrg.txt',position='append')
    write(10,'(f8.3,2en16.6)') tt,en,en2
    close(10)
    ! census: T, census(-4).... census(5), sum of all flip probabilities
    open(10,file='census.txt',position='append')
    write(10,'(f8.3,10i10,e10.3)') tt, census(:), sumFlips()
    close(10)

    !write spin configuration out to file at end of bin
    open(10,file='spins.txt',position='append')
    write(10,*) spin(:)
    close(10)

 enddo

 deallocate(spin)
 deallocate(alt)

!-------------------!
 end program ising2d
!-------------------!

!========================================================
!========================================================
!            EXTERNAL SUBROUTINES AND FUNCTIONS
!========================================================
!========================================================

!----------------------------------------------!
! Does census of configurations !
!----------------------------------------------!
subroutine doCensus()
!-------------------!
 use systemvariables
 use runSums
 implicit none

 integer :: x,y,xp1,yp1,xm1,ym1,ii,neighbors

 !loop over all spins
 do y=0,ll-1
    do x=0,ll-1
        !determine index of spins array
        ii = ll*y+x
        xp1 = mod(x+1,ll)
        yp1 = mod(y+1,ll)
        xm1 = mod(x+ll-1,ll)
        ym1 = mod(y+ll-1,ll)
        neighbors = spin(ll*y+xp1) + spin(ll*y+xm1) + spin(ll*yp1+x) + spin(ll*ym1+x)
        census(neighbors+(spin(ii)+2)/2) = census(neighbors+(spin(ii)+2)/2) + 1
    enddo
enddo
end subroutine doCensus
!---------------------!

!----------------------------------------------!
! Prints the configuration to stdout !
!----------------------------------------------!
 subroutine printConfig()
!-------------------!
 use systemvariables
 implicit none

 integer :: y,x

 do y=-1,ll-1
    do x=0,ll-1
        !write out line separating
        if (y==-1) then
            write(*,'(a)',advance='no') '-'
        else
            if (spin(ll*y+x) == 1) then
                write(*,'(a)',advance='no') "0"
            else
                write(*,'(a)',advance='no') "."
            end if
        end if
    end do
    write(*,*) ""
 end do

 end subroutine printConfig
!---------------------!

!----------------------------------------------!
! Carries out one Monte Carlo step, defined as !
! nn flip attempts of randomly selected spins. !
!----------------------------------------------!
 subroutine mcstep()
!-------------------!
 use systemvariables
 implicit none

 integer :: i,s,x,y,s1,s2,s3,s4
 real(8) :: temp
 real(8) :: crand

 do i=1,nn
    s=int(crand()*nn)               ! generate random site
    x=mod(s,ll); y=s/ll           ! coordinates of site s
    s1=spin(mod(x+1,ll)+y*ll)     ! spin at right neighbor of site s
    s2=spin(x+mod(y+1,ll)*ll)     ! spin at up    neighbor of site s
    s3=spin(mod(x-1+ll,ll)+y*ll)  ! spin at left  neighbor of site s
    s4=spin(x+mod(y-1+ll,ll)*ll)  ! spin at down  neighbor of site s
    temp = crand()
    if (temp<pflip(spin(s)*(s1+s2+s3+s4),spin(s))) then
        spin(s)=-spin(s)  ! flip spin with Metroplois prob
    end if
 enddo

 end subroutine mcstep
!---------------------!

!----------------------------------------------!
! calculates total probability of all possible spin flips
!----------------------------------------------!
real(8) function sumFlips()
!-------------------!
    use systemvariables
    implicit none
    integer :: s,x,y,s1,s2,s3,s4

    !calc total probability of flipping any spin
    sumFlips = 0.d0
    do s=1,nn
        x=mod(s,ll); y=s/ll           ! coordinates of site s
        s1=spin(mod(x+1,ll)+y*ll)     ! spin at right neighbor of site s
        s2=spin(x+mod(y+1,ll)*ll)     ! spin at up    neighbor of site s
        s3=spin(mod(x-1+ll,ll)+y*ll)  ! spin at left  neighbor of site s
        s4=spin(x+mod(y-1+ll,ll)*ll)  ! spin at down  neighbor of site s
        sumFlips = sumFlips + min(1.d0,pflip(spin(s)*(s1+s2+s3+s4),spin(s)))
    enddo

 end function sumFlips
!---------------------!

!----------------------!
 real(8) function crand()
!-----------------------------------------------------!
! 64-bit linear congruental random number generator   !
! iran64=oran64*2862933555777941757+1013904243        !
!-----------------------------------------------------!
 implicit none

 real(8)    :: dmu64
 integer(8) :: ran64,mul64,add64
 common/bran64/dmu64,ran64,mul64,add64

 ran64=ran64*mul64+add64
 crand=0.5d0+dmu64*dble(ran64)

 end function crand
!----------------!

!---------------------!
 subroutine initran(w)
!---------------------!
 implicit none

 integer(8) :: irmax
 integer(4) :: w,nb,b

 real(8)    :: dmu64
 integer(8) :: ran64,mul64,add64
 common/bran64/dmu64,ran64,mul64,add64

 irmax=2_8**31
 irmax=2*(irmax**2-1)+1
 mul64=2862933555777941757_8
 add64=1013904243
 dmu64=0.5d0/dble(irmax)

 open(10,file='seed.in',status='old')
 read(10,*)ran64
 close(10)
 if (w.ne.0) then
    open(10,file='seed.in',status='unknown')
    write(10,*)abs((ran64*mul64)/5+5265361)
    close(10)
 endif

 end subroutine initran
!----------------------!


!==============================================================================!
  subroutine User_Mod_Source(grid, phi, a_matrix, b_vector)
!------------------------------------------------------------------------------!
!   This is a prototype of a function for customized source for scalar.        !
!   It is called from "Compute_Scalar" function, just before calling the       !
!   linear solver.  Both system matrix ("a_matrix") and right hand side        !
!   vector ("b_vector") are sent should the user want to stabilize the         !
!   system for always positive variables, for example.                         !
!------------------------------------------------------------------------------!
!----------------------------------[Modules]-----------------------------------!
  use Const_Mod, only: PI
  use Grid_Mod
  use Var_Mod
  use Matrix_Mod
  use Flow_Mod
!------------------------------------------------------------------------------!
  implicit none
!----------------------------------[Locals]------------------------------------!
  integer :: c
!---------------------------------[Arguments]----------------------------------!
  type(Grid_Type)    :: grid
  type(Var_Type)     :: phi
  type(Matrix_Type)  :: a_matrix
  real, dimension(:) :: b_vector
!==============================================================================!

  !-----------------------------------------------------!
  !                                                     !
  !   Set source for temperature of the form:           !
  !                                                     !
  !    /                                                !
  !   |                                                 !
  !   | dT/dx * Ux * dV                                 !
  !   |                                                 !
  !  /                                                  !
  !                                                     !
  ! dT/dx is derived from condition that there is no    !
  ! change of energy in the system. It means            !
  !   mass_flux * cp * dT - Q * Area = 0,               !
  !   Area = B*dx*Nwall,                                !
  !   dT/dx = Q*B*Nwall/(mass_flux*cp),                 !
  ! where Q is heat flux through the wall, B is         !
  ! channel width and Nwall is number of heated walls.  !
  !                                                     !
  !-----------------------------------------------------!
  if( phi % name .eq. 'T' ) then
    do c = 1, grid % n_cells

      b_vector(c) = b_vector(c)                    &
                  - PI * 2* heat_flux * u % n(c)   &
                  / (bulk % flux_x * capacity) * grid % vol(c)
    end do
  end if

  end subroutine


module elemFunc
contains
    elemental function multiply(x, y) result(z)
        real, intent(in) :: x, y
        real :: z
        z = x * y
    end function multiply
end module elemFunc


C FUNCTION ONEJ                   (NEXT)
      FUNCTION ONEJ (X)
C
C     ONEJ - EVALUATES THE BESSEL FUNCTION OF FIRST KIND, J1(X).
C     SEE MATH TABLES AND OTHER AIDS TO COMPUTATION, VOL. 11, NO. 58,
C     PAGE 86.
C
      COMMON /CON /D2R, DCL, GAMA, PI, PI2, PIO2, R2D, RO, VOFL
C
C.....COMPUTE J1(X).....................................................
      R135 = PI * 3.0 / 4.0
      IF (X .GT. 4.0) GO TO 100
      T = X / 4.0
      Y = T * * 2
      ONEJ = ((((((( - 1.289769E-4 * Y + 2.2069155E-3) * Y - 2.36616773E
     1-2) * Y + 0.1777582922) * Y - 0.8888839649) * Y + 2.666666054) * Y
     2 - 3.999999971) * Y + 2.0) * T
      GO TO 105
 100  T = 4.0 / X
      Y = T * * 2
      PSUM = (((((4.2414E-6 * Y - 2.0092E-5) * Y + 5.80759E-5) * Y - 2.2
     13203E-4) * Y + 2.9218256E-3) * Y + 0.3989422819) * 2.50662827
      QSUM = ((((( - 3.6594E-6 * Y + 1.622E-5) * Y - 3.98708E-5) * Y + 1
     1.064741E-4) * Y - 6.3904E-4) * Y + 3.74008364E-2) * 2.50662827 * T
      TX = COS (X - R135)
      TY = SIN (X - R135)
      TS = SQRT (2.0 / (PI * X))
      ONEJ = TS * (PSUM * TX - QSUM * TY)
 105  RETURN
      END


! solve quadratic for iron speciation
! mick follows, March 2015
       subroutine fe_equil(nbox_dum, fet_dum, lt_dum, beta_dum,
     &                     feprime_dum)
       implicit none
       INTEGER :: nbox_dum
       REAL*8, DIMENSION(nbox_dum):: fet_dum
       REAL*8, DIMENSION(nbox_dum):: lt_dum
!!       REAL*8, DIMENSION(nbox_dum):: beta_dum
       REAL*8 :: beta_dum
       REAL*8, DIMENSION(nbox_dum):: feprime_dum
       REAL*8, DIMENSION(nbox_dum):: betam
       REAL*8, DIMENSION(nbox_dum):: a,b,c,dummy,dummy1,x1,x2
!
       betam = 1.0/beta_dum
       a  = 1.0
       b  = (lt_dum + betam - fet_dum)
       c = -1.0 * fet_dum * betam
! standard quadratic solution for roots
       dummy = b*b - 4.0*a*c
       dummy1 = dummy**0.5
       x1 = (-b + dummy1) / (2.0*a)
       x2 = (-b - dummy1) / (2.0*a)
! which root?
       feprime_dum = x1
!
       return
       end


! Program to test assumed size arrays
subroutine test2(p)
   integer, dimension(2, *) :: p

   if (any (p(:, 1:3) .ne. reshape((/1, 2, 4, 5, 7, 8/), (/2, 3/)))) &
     call abort ()
end subroutine

program assumed_size
   integer, dimension (3, 3) :: a
   external test2

   a = reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9/), (/3, 3/))

   call test1(a, (/1, 2, 3, 4, 5, 6/))
   if (a(1,1) .ne. 0) call abort
   a(1, 1) = 1
   call test1(a(1:2, :), (/1, 2, 4, 5, 7, 8/))
   if (a(1,1) .ne. 0) call abort
   a(1, 1) = 1
   call test1(a(3:1:-1, :), (/3, 2, 1, 6, 5, 4/))
   if (a(3,1) .ne. 0) call abort
   a(3, 1) = 3
   call test1(a(:, 2:3), (/4, 5, 6, 7, 8, 9/))
   if (a(1, 2) .ne. 0) call abort
   a(1, 2) = 4

   call test2(a(1:2, :))
   call test2((/1, 2, 4, 5, 7, 8/))
contains
subroutine test1(p, q)
   integer, dimension(*) :: p
   integer, dimension(1:) :: q

   if (any (p(1:size(q)) .ne. q)) call abort ()
   p(1) = 0
end subroutine

end program


*DECK DXPSI
      DOUBLE PRECISION FUNCTION DXPSI (A, IPSIK, IPSIX)
C***BEGIN PROLOGUE  DXPSI
C***SUBSIDIARY
C***PURPOSE  To compute values of the Psi function for DXLEGF.
C***LIBRARY   SLATEC
C***CATEGORY  C7C
C***TYPE      DOUBLE PRECISION (XPSI-S, DXPSI-D)
C***KEYWORDS  PSI FUNCTION
C***AUTHOR  Smith, John M., (NBS and George Mason University)
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   820728  DATE WRITTEN
C   890126  Revised to meet SLATEC CML recommendations.  (DWL and JMS)
C   901019  Revisions to prologue.  (DWL and WRB)
C   901106  Changed all specific intrinsics to generic.  (WRB)
C           Corrected order of sections in prologue and added TYPE
C           section.  (WRB)
C   920127  Revised PURPOSE section of prologue.  (DWL)
C***END PROLOGUE  DXPSI
      DOUBLE PRECISION A,B,C,CNUM,CDENOM
      DIMENSION CNUM(12),CDENOM(12)
      SAVE CNUM, CDENOM
C
C        CNUM(I) AND CDENOM(I) ARE THE ( REDUCED ) NUMERATOR
C        AND 2*I*DENOMINATOR RESPECTIVELY OF THE 2*I TH BERNOULLI
C        NUMBER.
C
      DATA CNUM(1),CNUM(2),CNUM(3),CNUM(4),CNUM(5),CNUM(6),CNUM(7),
     1CNUM(8),CNUM(9),CNUM(10),CNUM(11),CNUM(12)
     2    / 1.D0,     -1.D0,    1.D0,     -1.D0, 1.D0,
     3   -691.D0,  1.D0,     -3617.D0, 43867.D0, -174611.D0, 77683.D0,
     4   -236364091.D0/
      DATA CDENOM(1),CDENOM(2),CDENOM(3),CDENOM(4),CDENOM(5),CDENOM(6),
     1 CDENOM(7),CDENOM(8),CDENOM(9),CDENOM(10),CDENOM(11),CDENOM(12)
     2/12.D0,120.D0,   252.D0,   240.D0,132.D0,
     3  32760.D0, 12.D0,  8160.D0, 14364.D0, 6600.D0, 276.D0, 65520.D0/
C***FIRST EXECUTABLE STATEMENT  DXPSI
      N=MAX(0,IPSIX-INT(A))
      B=N+A
      K1=IPSIK-1
C
C        SERIES EXPANSION FOR A .GT. IPSIX USING IPSIK-1 TERMS.
C
      C=0.D0
      DO 12 I=1,K1
      K=IPSIK-I
   12 C=(C+CNUM(K)/CDENOM(K))/B**2
      DXPSI=LOG(B)-(C+.5D0/B)
      IF(N.EQ.0) GO TO 20
      B=0.D0
C
C        RECURRENCE FOR A .LE. IPSIX.
C
      DO 15 M=1,N
   15 B=B+1.D0/(N-M+A)
      DXPSI=DXPSI-B
   20 RETURN
      END


c-----------------------------------------------------------------------
      subroutine polyeval(x,n,p,uq)
      real*8 x,y
      integer n,i
      real*8 p(1)
      real*8 uq

      y=p(n)

      do i=n-1,1,-1
        y=y*x+p(i)
      enddo

      uq=y

      end
c-----------------------------------------------------------------------
      program test

      include 'ceedf.h'

      integer ceed,err
      integer x,xq,u,uq,w
      integer bxl,bxg,bug
      integer i
      integer q
      parameter(q=6)

      integer plen
      parameter(plen=6)
      real*8 p(plen)
      real*8 pint(plen+1)
      real*8 xx(2)
      real*8 xxq(q)
      real*8 uuq(q)
      real*8 uu(q)
      real*8 ww(q)
      real*8 summ,error,p1,pm1
      integer*8 offset1,offset2

      character arg*32

      data p/1,2,3,4,5,6/
      data xx/-1,1/

      call getarg(1,arg)
      call ceedinit(trim(arg)//char(0),ceed,err)

      call ceedvectorcreate(ceed,2,x,err)
      call ceedvectorsetarray(x,ceed_mem_host,ceed_use_pointer,xx,err)
      call ceedvectorcreate(ceed,q,xq,err)
      call ceedvectorsetvalue(xq,0.d0,err)
      call ceedvectorcreate(ceed,q,u,err)
      call ceedvectorcreate(ceed,q,uq,err)
      call ceedvectorsetvalue(uq,0.d0,err)
      call ceedvectorcreate(ceed,q,w,err)
      call ceedvectorsetvalue(w,0.d0,err)

      call ceedbasiscreatetensorh1lagrange(ceed,1,1,2,q,
     $  ceed_gauss_lobatto,bxl,err)

      call ceedbasisapply(bxl,1,ceed_notranspose,ceed_eval_interp,
     $  x,xq,err)

      call ceedvectorgetarrayread(xq,ceed_mem_host,xxq,offset1,err)
      do i=1,q
        call polyeval(xxq(i+offset1),plen,p,uu(i))
      enddo
      call ceedvectorrestorearrayread(xq,xxq,offset1,err)
      call ceedvectorsetarray(u,ceed_mem_host,ceed_use_pointer,uu,err)

      call ceedbasiscreatetensorh1lagrange(ceed,1,1,2,q,ceed_gauss,
     $  bxg,err)
      call ceedbasiscreatetensorh1lagrange(ceed,1,1,q,q,ceed_gauss,
     $  bug,err)

      call ceedbasisapply(bxg,1,ceed_notranspose,ceed_eval_interp,
     $  x,xq,err)
      call ceedbasisapply(bug,1,ceed_notranspose,ceed_eval_interp,
     $  u,uq,err)
      call ceedbasisapply(bug,1,ceed_notranspose,ceed_eval_weight,
     $  ceed_null,w,err)

      call ceedvectorgetarrayread(w,ceed_mem_host,ww,offset1,err)
      call ceedvectorgetarrayread(uq,ceed_mem_host,uuq,offset2,err)
      summ=0.0
      do i=1,q
        summ=summ+ww(i+offset1)*uuq(i+offset2)
      enddo
      call ceedvectorrestorearrayread(w,ww,offset1,err)
      call ceedvectorrestorearrayread(uq,uuq,offset2,err)

      pint(1)=0.0
      do i=1,plen
        pint(i+1)=p(i)/i
      enddo

      call polyeval(1.0D0,plen,pint,p1)
      call polyeval(-1.0D0,plen,pint,pm1)
      error=summ-p1+pm1
      if (abs(error) > 1e-10) then
        write(*,*) 'Error ',error,' sum ',summ,' exact ',p1-pm1
      endif

      call ceedvectordestroy(x,err)
      call ceedvectordestroy(xq,err)
      call ceedvectordestroy(u,err)
      call ceedvectordestroy(uq,err)
      call ceedvectordestroy(w,err)
      call ceedbasisdestroy(bxl,err)
      call ceedbasisdestroy(bxg,err)
      call ceedbasisdestroy(bug,err)
      call ceeddestroy(ceed,err)
      end
c-----------------------------------------------------------------------


! THIS VERSION: GALAHAD 2.1 - 22/03/2007 AT 09:00 GMT.
   PROGRAM GALAHAD_ULS_example
   USE GALAHAD_ULS_DOUBLE
   IMPLICIT NONE
   INTEGER, PARAMETER :: wp = KIND( 1.0D+0 )
   INTEGER :: i, info, m, n, ne, rank
   TYPE ( SMT_TYPE ) :: MATRIX
   TYPE ( ULS_CONTROL ) :: CONTROL
   TYPE ( ULS_AINFO ) :: AINFO
   TYPE ( ULS_FINFO ) :: FINFO
   TYPE ( ULS_SINFO ) :: SINFO
   TYPE ( ULS_FACTORS ) :: FACTORS
   INTEGER, ALLOCATABLE, DIMENSION( : ) :: ROWS, COLS
   REAL ( KIND = wp ), ALLOCATABLE, DIMENSION( : ) :: B, X

!  Read matrix order and number of entries

   READ( 5, * ) m, n, ne
   MATRIX%m = m ; MATRIX%n = n ; MATRIX%ne = ne

!  Allocate arrays of appropriate sizes

   ALLOCATE( MATRIX%VAL( ne ),  MATRIX%ROW( ne ),  MATRIX%COL( ne ) )
   ALLOCATE( B( m ), X( n ), ROWS( m ), COLS( n ) )

!  Read matrix

   READ( 5, * ) ( MATRIX%ROW( i ), MATRIX%COL( i ), MATRIX%VAL( i ), i = 1, ne )

!  Initialize the structures

   CALL ULS_initialize( FACTORS, CONTROL )

!  Analyse and factorize

   CALL ULS_analyse( MATRIX, FACTORS, CONTROL, AINFO, FINFO )
   IF ( AINFO%flag < 0 ) THEN
     WRITE( 6, '( A, I0 )' )                                                   &
       ' Failure of ULS_ANALYSE with AINFO%flag = ',  AINFO%flag
     STOP
   END IF

!  Write row and column reorderings

   CALL ULS_special_rows_and_cols( FACTORS, rank, ROWS, COLS, info )
   WRITE( 6, "( A, /, ( 10I5 ) )" ) ' row orderings:', ROWS( : rank )
   WRITE( 6, "( A, /, ( 10I5 ) )" ) ' column orderings:', COLS( : rank )

!  Read right-hand side and solve system

   READ( 5, * ) B
   CALL ULS_solve( MATRIX, FACTORS, B, X, CONTROL, SINFO )
   IF ( SINFO%flag == 0 ) WRITE( 6, '( A, /,( 6ES11.3 ) )' )                    &
     ' Solution of set of equations without refinement is', X

!  Clean up

   DEALLOCATE( MATRIX%VAL, MATRIX%ROW, MATRIX%COL )
   CALL ULS_FINALIZE( FACTORS, CONTROL, INFO )

   END PROGRAM GALAHAD_ULS_example


!---------------------------------------------------------------------!
!                                PHAML                                !
!                                                                     !
! The Parallel Hierarchical Adaptive MultiLevel code for solving      !
! linear elliptic partial differential equations of the form          !
! (PUx)x + (QUy)y + RU = F on 2D polygonal domains with mixed         !
! boundary conditions, and eigenvalue problems where F is lambda*U.   !
!                                                                     !
! PHAML is public domain software.  It was produced as part of work   !
! done by the U.S. Government, and is not subject to copyright in     !
! the United States.                                                  !
!                                                                     !
!     William F. Mitchell                                             !
!     Applied and Computational Mathematics Division                  !
!     National Institute of Standards and Technology                  !
!     william.mitchell@nist.gov                                       !
!     http://math.nist.gov/phaml                                      !
!                                                                     !
!---------------------------------------------------------------------!

!----------------------------------------------------
! This file contains the user supplied module phaml_user_mod
!----------------------------------------------------

module phaml_user_mod

!----------------------------------------------------
! This module contains user global data.
!
! In this version, that consists of a selection parameter to determine
! which problem to solve, and a couple parameters for those problems.
! This version just solves some simple scalar linear elliptic PDEs.
!----------------------------------------------------

!----------------------------------------------------
! Other modules used are:

use phaml
!----------------------------------------------------

implicit none

!----------------------------------------------------
! The following parameters are defined:

! Set choice to determine which problem to solve

integer, parameter :: choice = 6

! The choices are:
!  1) Laplace, solution x+y
!  2) more complicated Laplace solution
!  3) Laplace, singularity at the origin, from the popular L domain problem
!  4) Laplace with 0 boundary conditions on 3 sides and a
!     quartic on the top -- solution unknown
!  5) Laplace with 0.0 on 3 sides, piecewise linear on the top with the point
!     at which it is 1.0 specified by prob_param -- soln unknown
!  6) Poisson, solution x**ipower + y**ipower
!  7) Poisson, solution is a sharp peak
!  8) Poisson, x**ipower + y**ipower with Neuman and mixed boundary conditions
!  9) nonconstant coefficients
! 10) Poisson, solution x(1-x)y(1-y)
! 11) Helmholtz with parameter -a**2 and b.c. sin(a*x) + sin(a*y), a=prob_param.
!     Multigrid will fail if prob_param is sufficiently large.
! 12) Poisson, solution sin(a*x) + sin(a*y), a=prob_param
! 13) Poisson, solution sin(a*r), a=prob_param, r=sqrt(x**2+y**2)
! 14) Helmholtz with parameter a=prob_param, solution x**ipower + y**ipower
! 15) Poisson, solution tanh(prob_param*(x**2+y**2-.5)) circular wave front
! 16) Helmholtz with same coefficient and solution as the eigenvalue example
! 17) First order terms, solution x**ipower + y**ipower
! 18) Cross derivative term, solution x**ipower * y**ipower

integer, save :: ipower = 10 ! degree of polynomial for problem 6,8,14
real(my_real), save :: prob_param = 0.7_my_real
!----------------------------------------------------

end module phaml_user_mod


C Contains a jump out of a do loop to end
      FUNCTION RTFLSP(FUNC,X1,X2,XACC)
      PARAMETER (MAXIT=30)
      FL=FUNC(X1)
      FH=FUNC(X2)
      IF(FL*FH > 0.) PAUSE 'Root must be bracketed for false position.'
      IF(FL < 0.)THEN
        XL=X1
        XH=X2
      ELSE
        XL=X2
        XH=X1
        SWAP=FL
        FL=FH
        FH=SWAP
      ENDIF
      DX=XH-XL
      DO 11 J=1,MAXIT
        RTFLSP=XL+DX*FL/(FL-FH)
        F=FUNC(RTFLSP)
        IF(F < 0.) THEN
          DEL=XL-RTFLSP
          XL=RTFLSP
          FL=F
        ELSE
          DEL=XH-RTFLSP
          XH=RTFLSP
          FH=F
        ENDIF
        DX=XH-XL
        IF(ABS(DEL) < XACC or F .EQ. 0.)RETURN
11    CONTINUE
      PAUSE 'RTFLSP exceed maximum iterations'
      END


std_atm_table_len = 45
allocate(std_atm_hgt_col(std_atm_table_len), std_atm_pres_col(std_atm_table_len))

std_atm_hgt_col(1)  = 86.0_r8 ; std_atm_pres_col(1)  = 3.732E-01_r8
std_atm_hgt_col(2)  = 84.0_r8 ; std_atm_pres_col(2)  = 5.308E-01_r8
std_atm_hgt_col(3)  = 82.0_r8 ; std_atm_pres_col(3)  = 7.498E-01_r8
std_atm_hgt_col(4)  = 80.0_r8 ; std_atm_pres_col(4)  = 1.052E+00_r8
std_atm_hgt_col(5)  = 78.0_r8 ; std_atm_pres_col(5)  = 1.467E+00_r8
std_atm_hgt_col(6)  = 76.0_r8 ; std_atm_pres_col(6)  = 2.033E+00_r8
std_atm_hgt_col(7)  = 74.0_r8 ; std_atm_pres_col(7)  = 2.800E+00_r8
std_atm_hgt_col(8)  = 72.0_r8 ; std_atm_pres_col(8)  = 3.835E+00_r8
std_atm_hgt_col(9)  = 70.0_r8 ; std_atm_pres_col(9)  = 5.220E+00_r8
std_atm_hgt_col(10) = 68.0_r8 ; std_atm_pres_col(10) = 7.051E+00_r8
std_atm_hgt_col(11) = 66.0_r8 ; std_atm_pres_col(11) = 9.459E+00_r8
std_atm_hgt_col(12) = 64.0_r8 ; std_atm_pres_col(12) = 1.260E+01_r8
std_atm_hgt_col(13) = 62.0_r8 ; std_atm_pres_col(13) = 1.669E+01_r8
std_atm_hgt_col(14) = 60.0_r8 ; std_atm_pres_col(14) = 2.196E+01_r8
std_atm_hgt_col(15) = 58.0_r8 ; std_atm_pres_col(15) = 2.872E+01_r8
std_atm_hgt_col(16) = 56.0_r8 ; std_atm_pres_col(16) = 3.736E+01_r8
std_atm_hgt_col(17) = 54.0_r8 ; std_atm_pres_col(17) = 4.833E+01_r8
std_atm_hgt_col(18) = 52.0_r8 ; std_atm_pres_col(18) = 6.221E+01_r8
std_atm_hgt_col(19) = 50.0_r8 ; std_atm_pres_col(19) = 7.977E+01_r8
std_atm_hgt_col(20) = 48.0_r8 ; std_atm_pres_col(20) = 1.023E+02_r8
std_atm_hgt_col(21) = 46.0_r8 ; std_atm_pres_col(21) = 1.313E+02_r8
std_atm_hgt_col(22) = 44.0_r8 ; std_atm_pres_col(22) = 1.695E+02_r8
std_atm_hgt_col(23) = 42.0_r8 ; std_atm_pres_col(23) = 2.200E+02_r8
std_atm_hgt_col(24) = 40.0_r8 ; std_atm_pres_col(24) = 2.871E+02_r8
std_atm_hgt_col(25) = 38.0_r8 ; std_atm_pres_col(25) = 3.771E+02_r8
std_atm_hgt_col(26) = 36.0_r8 ; std_atm_pres_col(26) = 4.985E+02_r8
std_atm_hgt_col(27) = 34.0_r8 ; std_atm_pres_col(27) = 6.634E+02_r8
std_atm_hgt_col(28) = 32.0_r8 ; std_atm_pres_col(28) = 8.890E+02_r8
std_atm_hgt_col(29) = 30.0_r8 ; std_atm_pres_col(29) = 1.197E+03_r8
std_atm_hgt_col(30) = 28.0_r8 ; std_atm_pres_col(30) = 1.616E+03_r8
std_atm_hgt_col(31) = 26.0_r8 ; std_atm_pres_col(31) = 2.188E+03_r8
std_atm_hgt_col(32) = 24.0_r8 ; std_atm_pres_col(32) = 2.972E+03_r8
std_atm_hgt_col(33) = 22.0_r8 ; std_atm_pres_col(33) = 4.047E+03_r8
std_atm_hgt_col(34) = 20.0_r8 ; std_atm_pres_col(34) = 5.529E+03_r8
std_atm_hgt_col(35) = 18.0_r8 ; std_atm_pres_col(35) = 7.565E+03_r8
std_atm_hgt_col(36) = 16.0_r8 ; std_atm_pres_col(36) = 1.035E+04_r8
std_atm_hgt_col(37) = 14.0_r8 ; std_atm_pres_col(37) = 1.417E+04_r8
std_atm_hgt_col(38) = 12.0_r8 ; std_atm_pres_col(38) = 1.940E+04_r8
std_atm_hgt_col(39) = 10.0_r8 ; std_atm_pres_col(39) = 2.650E+04_r8
std_atm_hgt_col(40) =  8.0_r8 ; std_atm_pres_col(40) = 3.565E+04_r8
std_atm_hgt_col(41) =  6.0_r8 ; std_atm_pres_col(41) = 4.722E+04_r8
std_atm_hgt_col(42) =  4.0_r8 ; std_atm_pres_col(42) = 6.166E+04_r8
std_atm_hgt_col(43) =  2.0_r8 ; std_atm_pres_col(43) = 7.950E+04_r8
std_atm_hgt_col(44) =  0.0_r8 ; std_atm_pres_col(44) = 1.013E+05_r8
std_atm_hgt_col(45) = -2.0_r8 ; std_atm_pres_col(45) = 1.278E+05_r8

std_atm_hgt_col(:) = std_atm_hgt_col(:) * 1000.0_r8


!*==dla_gercond.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief \b DLA_GERCOND estimates the Skeel condition number for a general matrix.
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download DLA_GERCOND + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       DOUBLE PRECISION FUNCTION DLA_GERCOND ( TRANS, N, A, LDA, AF,
!                                               LDAF, IPIV, CMODE, C,
!                                               INFO, WORK, IWORK )
!
!       .. Scalar Arguments ..
!       CHARACTER          TRANS
!       INTEGER            N, LDA, LDAF, INFO, CMODE
!       ..
!       .. Array Arguments ..
!       INTEGER            IPIV( * ), IWORK( * )
!       DOUBLE PRECISION   A( LDA, * ), AF( LDAF, * ), WORK( * ),
!      $                   C( * )
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!>    DLA_GERCOND estimates the Skeel condition number of op(A) * op2(C)
!>    where op2 is determined by CMODE as follows
!>    CMODE =  1    op2(C) = C
!>    CMODE =  0    op2(C) = I
!>    CMODE = -1    op2(C) = inv(C)
!>    The Skeel condition number cond(A) = norminf( |inv(A)||A| )
!>    is computed by computing scaling factors R such that
!>    diag(R)*A*op2(C) is row equilibrated and computing the standard
!>    infinity-norm condition number.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] TRANS
!> \verbatim
!>          TRANS is CHARACTER*1
!>     Specifies the form of the system of equations:
!>       = 'N':  A * X = B     (No transpose)
!>       = 'T':  A**T * X = B  (Transpose)
!>       = 'C':  A**H * X = B  (Conjugate Transpose = Transpose)
!> \endverbatim
!>
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>     The number of linear equations, i.e., the order of the
!>     matrix A.  N >= 0.
!> \endverbatim
!>
!> \param[in] A
!> \verbatim
!>          A is DOUBLE PRECISION array, dimension (LDA,N)
!>     On entry, the N-by-N matrix A.
!> \endverbatim
!>
!> \param[in] LDA
!> \verbatim
!>          LDA is INTEGER
!>     The leading dimension of the array A.  LDA >= max(1,N).
!> \endverbatim
!>
!> \param[in] AF
!> \verbatim
!>          AF is DOUBLE PRECISION array, dimension (LDAF,N)
!>     The factors L and U from the factorization
!>     A = P*L*U as computed by DGETRF.
!> \endverbatim
!>
!> \param[in] LDAF
!> \verbatim
!>          LDAF is INTEGER
!>     The leading dimension of the array AF.  LDAF >= max(1,N).
!> \endverbatim
!>
!> \param[in] IPIV
!> \verbatim
!>          IPIV is INTEGER array, dimension (N)
!>     The pivot indices from the factorization A = P*L*U
!>     as computed by DGETRF; row i of the matrix was interchanged
!>     with row IPIV(i).
!> \endverbatim
!>
!> \param[in] CMODE
!> \verbatim
!>          CMODE is INTEGER
!>     Determines op2(C) in the formula op(A) * op2(C) as follows:
!>     CMODE =  1    op2(C) = C
!>     CMODE =  0    op2(C) = I
!>     CMODE = -1    op2(C) = inv(C)
!> \endverbatim
!>
!> \param[in] C
!> \verbatim
!>          C is DOUBLE PRECISION array, dimension (N)
!>     The vector C in the formula op(A) * op2(C).
!> \endverbatim
!>
!> \param[out] INFO
!> \verbatim
!>          INFO is INTEGER
!>       = 0:  Successful exit.
!>     i > 0:  The ith argument is invalid.
!> \endverbatim
!>
!> \param[out] WORK
!> \verbatim
!>          WORK is DOUBLE PRECISION array, dimension (3*N).
!>     Workspace.
!> \endverbatim
!>
!> \param[out] IWORK
!> \verbatim
!>          IWORK is INTEGER array, dimension (N).
!>     Workspace.
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date December 2016
!
!> \ingroup doubleGEcomputational
!
!  =====================================================================
      DOUBLE PRECISION FUNCTION DLA_GERCOND(Trans,N,A,Lda,Af,Ldaf,Ipiv, &
     &   Cmode,C,Info,Work,Iwork)
      IMPLICIT NONE
!*--DLA_GERCOND155
!
!  -- LAPACK computational routine (version 3.7.0) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     December 2016
!
!     .. Scalar Arguments ..
      CHARACTER Trans
      INTEGER N , Lda , Ldaf , Info , Cmode
!     ..
!     .. Array Arguments ..
      INTEGER Ipiv(*) , Iwork(*)
      DOUBLE PRECISION A(Lda,*) , Af(Ldaf,*) , Work(*) , C(*)
!     ..
!
!  =====================================================================
!
!     .. Local Scalars ..
      LOGICAL notrans
      INTEGER kase , i , j
      DOUBLE PRECISION ainvnm , tmp
!     ..
!     .. Local Arrays ..
      INTEGER isave(3)
!     ..
!     .. External Functions ..
      LOGICAL LSAME
      EXTERNAL LSAME
!     ..
!     .. External Subroutines ..
      EXTERNAL DLACN2 , DGETRS , XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC ABS , MAX
!     ..
!     .. Executable Statements ..
!
      DLA_GERCOND = 0.0D+0
!
      Info = 0
      notrans = LSAME(Trans,'N')
      IF ( .NOT.notrans .AND. .NOT.LSAME(Trans,'T') .AND.               &
     &     .NOT.LSAME(Trans,'C') ) THEN
         Info = -1
      ELSEIF ( N<0 ) THEN
         Info = -2
      ELSEIF ( Lda<MAX(1,N) ) THEN
         Info = -4
      ELSEIF ( Ldaf<MAX(1,N) ) THEN
         Info = -6
      ENDIF
      IF ( Info/=0 ) THEN
         CALL XERBLA('DLA_GERCOND',-Info)
         RETURN
      ENDIF
      IF ( N==0 ) THEN
         DLA_GERCOND = 1.0D+0
         RETURN
      ENDIF
!
!     Compute the equilibration matrix R such that
!     inv(R)*A*C has unit 1-norm.
!
      IF ( notrans ) THEN
         DO i = 1 , N
            tmp = 0.0D+0
            IF ( Cmode==1 ) THEN
               DO j = 1 , N
                  tmp = tmp + ABS(A(i,j)*C(j))
               ENDDO
            ELSEIF ( Cmode==0 ) THEN
               DO j = 1 , N
                  tmp = tmp + ABS(A(i,j))
               ENDDO
            ELSE
               DO j = 1 , N
                  tmp = tmp + ABS(A(i,j)/C(j))
               ENDDO
            ENDIF
            Work(2*N+i) = tmp
         ENDDO
      ELSE
         DO i = 1 , N
            tmp = 0.0D+0
            IF ( Cmode==1 ) THEN
               DO j = 1 , N
                  tmp = tmp + ABS(A(j,i)*C(j))
               ENDDO
            ELSEIF ( Cmode==0 ) THEN
               DO j = 1 , N
                  tmp = tmp + ABS(A(j,i))
               ENDDO
            ELSE
               DO j = 1 , N
                  tmp = tmp + ABS(A(j,i)/C(j))
               ENDDO
            ENDIF
            Work(2*N+i) = tmp
         ENDDO
      ENDIF
!
!     Estimate the norm of inv(op(A)).
!
      ainvnm = 0.0D+0

      kase = 0
      DO
         CALL DLACN2(N,Work(N+1),Work,Iwork,ainvnm,kase,isave)
         IF ( kase/=0 ) THEN
            IF ( kase==2 ) THEN
!
!           Multiply by R.
!
               DO i = 1 , N
                  Work(i) = Work(i)*Work(2*N+i)
               ENDDO

               IF ( notrans ) THEN
                  CALL DGETRS('No transpose',N,1,Af,Ldaf,Ipiv,Work,N,   &
     &                        Info)
               ELSE
                  CALL DGETRS('Transpose',N,1,Af,Ldaf,Ipiv,Work,N,Info)
               ENDIF
!
!           Multiply by inv(C).
!
               IF ( Cmode==1 ) THEN
                  DO i = 1 , N
                     Work(i) = Work(i)/C(i)
                  ENDDO
               ELSEIF ( Cmode==-1 ) THEN
                  DO i = 1 , N
                     Work(i) = Work(i)*C(i)
                  ENDDO
               ENDIF
            ELSE
!
!           Multiply by inv(C**T).
!
               IF ( Cmode==1 ) THEN
                  DO i = 1 , N
                     Work(i) = Work(i)/C(i)
                  ENDDO
               ELSEIF ( Cmode==-1 ) THEN
                  DO i = 1 , N
                     Work(i) = Work(i)*C(i)
                  ENDDO
               ENDIF

               IF ( notrans ) THEN
                  CALL DGETRS('Transpose',N,1,Af,Ldaf,Ipiv,Work,N,Info)
               ELSE
                  CALL DGETRS('No transpose',N,1,Af,Ldaf,Ipiv,Work,N,   &
     &                        Info)
               ENDIF
!
!           Multiply by R.
!
               DO i = 1 , N
                  Work(i) = Work(i)*Work(2*N+i)
               ENDDO
            ENDIF
            CYCLE
         ENDIF
!
!     Compute the estimate of the reciprocal condition number.
!
         IF ( ainvnm/=0.0D+0 ) DLA_GERCOND = (1.0D+0/ainvnm)
         EXIT
      ENDDO
!
!
      END FUNCTION DLA_GERCOND


!
!     CalculiX - A 3-dimensional finite element program
!              Copyright (C) 1998-2015 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.
!
      subroutine shape3l(xi,xl,xsj,xs,shp,iflag)
!
!     shape functions and derivatives for a 3-node quadratic
!     isoparametric 1-D element. -1<=xi<=1
!
!     iflag=2: calculate the value of the shape functions,
!              their derivatives w.r.t. the local coordinates
!              and the Jacobian (size of tangent vector to the
!              curved line)
!
      implicit none
!
      integer i,k,iflag
!
      real*8 shp(7,3),xs(3,7),xsi(2,3),xl(3,3),sh(3),xsj(3),xi
!
      intent(in) xi,xl,iflag
!
      intent(out) xsj,xs,shp
!
!     shape functions and their glocal derivatives for an element
!     described with two local parameters and three global ones.
!
!     local derivatives of the shape functions: xi-derivative
!
      shp(1,1)=xi-0.5d0
      shp(1,2)=-2.d0*xi
      shp(1,3)=xi+0.5d0
!
!     shape functions
!
      shp(4,1)=xi*(xi-1.d0)/2.d0
      shp(4,2)=(1.d0-xi)*(1.d0+xi)
      shp(4,3)=xi*(xi+1.d0)/2.d0
!
!     computation of the local derivative of the global coordinates
!     (xs)
!
      do i=1,3
         xs(i,1)=0.d0
         do k=1,3
            xs(i,1)=xs(i,1)+xl(i,k)*shp(1,k)
         enddo
      enddo
!
!     computation of the jacobian vector
!
      xsj(1)=dsqrt(xs(1,1)**2+xs(2,1)**2+xs(3,1)**2)
!
      return
      end


      subroutine box_mueller(gran1,gran2)

c*********************************************************************
c
c     box mueller method for generating gaussian random numbers
c      with a zero mean and standard deviation of 1
c
c     duni() is a double precision random number on interval [0,1)
c     gran1 and gran2 are both gaussian random numbers
c
c     copyright daresbury laboratory
c     author w.smith may 2008
c
c*********************************************************************

      implicit none

      logical newjob
      real(8) ran0,ran1,ran2,gran1,gran2
      save newjob
      data newjob/.true./

c     make sure duni is initialised

      if(newjob)then

        newjob=.false.
        ran0=duni()

      endif

      ran0=1.d0

c     generate uniform random numbers on [-1, 1)

      do while(ran0.ge.1.d0)

        ran1=2.d0*duni()-1.d0
        ran2=2.d0*duni()-1.d0
        ran0=ran1**2+ran2**2

      enddo

c     calculate gaussian random numbers

      ran0=sqrt((-2.d0*log(ran0))/ran0)
      gran1=ran0*ran1
      gran2=ran0*ran2

      return
      end


      subroutine assign_quadrant_id(id,vector,epsilon,ierror)
C
C #####################################################################
C
C     PURPOSE -
C
C          Determing the which of 6 quadrents VECTOR points into
C
C     INPUT ARGUMENTS -
C
C        vector - 3 component vector
C
C     OUTPUT ARGUMENTS -
C
C        id       - integer flag indicating which direction vector points
C
C       26 possible exterior node types
c
c   1   bottom             1, 4, 3, 2
c   2   top                5, 6, 7, 8
c   3   front (south)      1, 2, 6, 5
c   4   right (east)       2, 3, 7, 6
c   5   back  (north)      3, 4, 8, 7
c   6   left  (west)       1, 5, 8, 4
c   7   bottom front       1,2
c   8   bottom left        1,4
c   9   front  left        1,5
c  10   bottom right       2,3
c  11   front right        2,6
c  12   bottom back        3,4
c  13   right back         3,7
c  14   back left          4,8
c  15   top front          5,6
c  16   top left           5,8
c  17   top right          6,7
c  18   top back           7,8
c  19   bottom front left  1
c  20   bottom front right 2
c  21   bottom back  right 3
c  22   bottom back  left  4
c  23   top    front left  5
c  24   top    front right 6
c  25   top    back  right 7
c  26   top    back  left  8
C
C        IERROR   - error flag (returns zero if no errors)
C
C     AUTHOR
C
C         Carl W. Gable  gable@lanl.gov (Los Alamos National Laboratory)
C
C     CHANGE HISTORY -
C
C        $Log: assign_quadrant_id.f,v $
C        Revision 2.00  2007/11/05 19:45:46  spchu
C        Import to CVS
C
CPVCS
CPVCS       Rev 1.2   Mon Mar 02 08:27:24 1998   tam
CPVCS    added epsilon to call identify_dot()
CPVCS
CPVCS       Rev 1.1   Mon Apr 14 16:39:02 1997   pvcs
CPVCS    No change.
CPVCS
CPVCS       Rev 1.0   Wed May 08 12:35:26 1996   gable
CPVCS    Initial revision.
C
C ######################################################################
C
      implicit none
      real*8 dot(6)
      real*8 epsilon
      real*8 vector(3)
      integer id
      integer ierror
c
      call dot_product_6_planes(vector,dot)
      call identify_dot(dot,epsilon,id,ierror)
c
      return
      end


! BUCKLING_CPANEL_BARDELL subroutine
!
! Buckling of cylindrical panels.
!
! The required inputs that should be given are described below.
! All inputs will be entered by a DRESP3 NASTRAN Structure.
!
! Run control
! -----------
! NUM : integer
!   Number of returned eigenvalues
!
! M : integer
!   Number of terms along x
!
! N : integer
!   Number of terms along x
!
! Geometry
! --------
! a : float
!   The panel length (dimension along x)
! b : float
!   The panel circumferential width (dimension along y)
! r : float
!   The panel radius. (Set a high value to simulate a plate)
! t : float, optional (used with ISOTROPIC flag)
!   Panel thickness
!
! Isotropic Material Properties
! -----------------------------
! ISOTROPIC : flag
!   If present in the input, matrix ABD will be calculated based on
!   E, nu and t.
! E : float
!   Elastic modulus
! nu : float
!   Poisson's ratio
!
! Orthotropic Material Properties
! -------------------------------
! ISOTROPIC : FALSE
!   Matrix ABD will be calculated based on E1, E2, G12, nu12, nu21 and t.
! E1 : float
!   Elastic modulus at longitudinal direction
! E2 : float
!   Elastic modulus at transversal direction
! G12 : float
!   Shear modulus between longitudinal and transversal directions
! nu12 : float
!   Poisson's ratio between longitudinal and transversal directions
! nu21 : float
!   Poisson's ratio between transversal nad longitudinal directions
! t : float
!   Laminate thickness
!
! Applied Loads
! -------------
! Nxx : float
!   Nxx longitudinal membrane stress
! Nyy : float
!   Nyy transversal membrane stress
! Nxy : float
!   Nxy shear membrane stress
!
! Laminate Constitutive Variables (matrix ABD)
! -------------------------------------------
! ONLY used if ISOTROPIC = FALSE
!
! A11 : float
!   Membrane stiffness along x
! A12 : float
!   Membrane stiffness
! A16 : float
!   Shear-extension coupling
! A22 : float
!   Membrane stiffness along y
! A26 : float
!   Shear-extension coupling
! A66 : float
!   Membrane Shear stiffness
! ----------------------------------------------------------------------------------
! IN THIS CASE, CONSIDERED LAMINATE IS SMEAR NASTRAN TYPE => ALL Bij TERMS ARE NULL.
! ----------------------------------------------------------------------------------
! B11 : float
!   Bending-extension coupling
! B12 : float
!   Bending-extension coupling
! B16 : float
!   Bending-extension coupling
! B22 : float
!   Bending-extension coupling
! B26 : float
!   Bending-extension coupling
! B66 : float
!   Bending-extension coupling
! -----------------------------------------------------------------------------------------------------
! IN THIS CASE, CONSIDERED LAMINATE IS SMEAR NASTRAN TYPE => ALL D12-21, D16-61, D26-62 TERMS ARE NULL.
! -----------------------------------------------------------------------------------------------------
! D11 : float
!   Bending stiffness
! D12 : float
!   Bending stiffness
! D16 : float
!   Bending-twist stiffness
! D22 : float
!   Bending stiffness
! D26 : float
!   Bending-twist stiffness
! D66 : float
!   Twist (torsion) stiffness
!
! Boundary conditions - Always Simply Supported - All these terms below remain as is in this code.
! ------------------------------------------------------------------------------------------------
! u1tx : float
!   If 1. the edge at x=0 can translate along u
!   If 0. the edge at x=0 cannot translate along u
! u1rx : float
!   If 1. the end at x=0 can rotate
!   If 0. the end at x=0 cannot translate along u
! u2tx : float
!   If 1. the edge at x=a can translate along u
!   If 0. the edge at x=a cannot translate along u
! u2rx : float
!   If 1. the end at x=a can rotate
!   If 0. the end at x=a cannot translate along u
! u1ty : float
!   If 1. the edge at y=0 can translate along u
!   If 0. the edge at y=0 cannot translate along u
! u1ry : float
!   If 1. the end at y=0 can rotate
!   If 0. the end at y=0 cannot translate along u
! u2ty : float
!   If 1. the edge at y=b can translate along u
!   If 0. the edge at y=b cannot translate along u
! u2ry : float
!   If 1. the end at y=b can rotate
!   If 0. the end at y=b cannot translate along u
! v1tx : float
!   If 1. the edge at x=0 can translate along v
!   If 0. the edge at x=0 cannot translate along v
! v1rx : float
!   If 1. the end at x=0 can rotate
!   If 0. the end at x=0 cannot translate along v
! v2tx : float
!   If 1. the edge at x=a can translate along v
!   If 0. the edge at x=a cannot translate along v
! v2rx : float
!   If 1. the end at x=a can rotate
!   If 0. the end at x=a cannot translate along v
! v1ty : float
!   If 1. the edge at y=0 can translate along v
!   If 0. the edge at y=0 cannot translate along v
! v1ry : float
!   If 1. the end at y=0 can rotate
!   If 0. the end at y=0 cannot translate along v
! v2ty : float
!   If 1. the edge at y=b can translate along v
!   If 0. the edge at y=b cannot translate along v
! v2ry : float
!   If 1. the end at y=b can rotate
!   If 0. the end at y=b cannot translate along v
! w1tx : float
!   If 1. the edge at x=0 can translate along w
!   If 0. the edge at x=0 cannot translate along w
! w1rx : float
!   If 1. the end at x=0 can rotate
!   If 0. the end at x=0 cannot translate along w
! w2tx : float
!   If 1. the edge at x=a can translate along w
!   If 0. the edge at x=a cannot translate along w
! w2rx : float
!   If 1. the end at x=a can rotate
!   If 0. the end at x=a cannot translate along w
! w1ty : float
!   If 1. the edge at y=0 can translate along w
!   If 0. the edge at y=0 cannot translate along w
! w1ry : float
!   If 1. the end at y=0 can rotate
!   If 0. the end at y=0 cannot translate along w
! w2ty : float
!   If 1. the edge at y=b can translate along w
!   If 0. the edge at y=b cannot translate along w
! w2ry : float
!   If 1. the end at y=b can rotate
!   If 0. the end at y=b cannot translate along w

! Written by Saullo Castro, November 2015
! Modified by Guilherme Abreu, February 2016

SUBROUTINE R3SVALD(GRPID, TYPNAM, NITEMS, ARGLIS, NSIZE, ARGVAL, &
                   NWRDA8, ARGCHR, forg, nresp, narg, DR3VAL, senval, ERROR)
    ! ----------------------------------------------------------------------
    !
    !     PURPOSE: COMPUTE THE EXTERNAL RESPONSE
    !
    !     GRPID   INPUT INTEGER        - GROUP ID
    !     TYPNAM  INPUT CHARACTER*8    - NAME OF EXTERNAL RESPONSE TYPE
    !     NITEMS  INPUT INTEGER        - DIMENSION OF ARRAY ARGLIS
    !     NSIZE   INPUT INTEGER        - DIMENSION OF ARRAY ARGVAL
    !     NWRDA8  INPUT INTEGER        - DIMENSION OF CHARACTER ARRAY ARGCHR
    !     ARGLIS  INPUT INTEGER        - ARRAY OF NO. OF ITEMS FOR EACH
    !                                     ARGUMENT type
    !     ARGVAL  INPUT DOUBLE         - ARRAY OF ARGUMENT VALUES (except
    !                                            characters)
    !     ARGCHR  INPUT CHARACTER*8    - ARRAY OF CHARACTER VALUES
    !     nresp   input INTEGER        - number of responses
    !     forg    input INTEGER        - type of call
    !                                     = 0 function evaluation
    !                                     = 1 sensitivity evaluation
    !     narg    input INTEGER        - number of arguments needing gradients
    !     DR3VAL  OUTPUT DOUBLE        - VALUE OF THE EXTERNAL RESPONSEs
    !     senval  output double        - matrix of the sensitivity of the IRth
    !                                    response to the IARGth argument
    !     ERROR   INPUT/OUTPUT INTEGER -ERROR CODE FOR THE CALL.
    !                                   0 = PRINT ERROR MESSAGES
    !                                   1 = DO NOT PRINT ERROR MESSAGES.
    !
    !   METHOD
    !       A)SET UP VARIOUS PARAMETERS FROM THE ARGUMENT LIST
    !       B)if forg = 0 EVALUATE THE EXTERNAL RESPONSE BASED ON THE
    !                     GIVEN TYPNAM
    !       C)else if forg = 1 EVALUATE THE sensitivities of the external
    !                          responses to the arguments that can vary for
    !                          the given typnam
    !       D)RETURN BADTYP ERROR IF TYPNAM IS NOT MATCHED HERE.
    !
    !     nsize - the number of arguments or values in a dresp3 entry
    !
    !     nsize=nv+nc+nr+nnc+ndvp1+ndvp2+ndvc1+ndvc2+ndvm1+ndvm2+nrr2
    !        where:
    !        nv     = number of desvars    nc    = number of dtables
    !        nr     = number of dresp1s    nnc   = number of dnode pairs
    !        ndvp1  = number of dvprel1s   ndvp2 = number dvprel2s
    !        ndvc1  = number of dvcrel1s   ndvc2 = number dvcrel2s
    !        ndvm1  = number of dvmrel1s   ndvm2 = number dvmrel2s
    !        nrr2   = number of dresp2s
    !     narg = nsize - nc
    !
    !   CALLED BY
    !       SENDR3SVALD
    ! ----------------------------------------------------------------------
    !
    ! VARIABLES PASSED IN
    !
    USE CPANELBARDELL, ONLY: CALC_K0, CALC_KG0
    IMPLICIT NONE

    CHARACTER*8, INTENT(IN) :: TYPNAM, ARGCHR(NWRDA8)
    INTEGER, INTENT(IN) :: forg, nresp, narg
    INTEGER, INTENT(IN) :: GRPID, NITEMS, NSIZE, ARGLIS(NITEMS), NWRDA8
    REAL*8, INTENT(IN) :: ARGVAL(NSIZE)
    INTEGER, INTENT(INOUT) :: ERROR
    REAL*8, INTENT(OUT) :: DR3VAL(*), senval(nresp, narg)
    INTEGER BADTYP
    DATA BADTYP /7554/

    ! Bardell's inputs
    REAL*8 A11, A12, A16, A22, A26, A66
    REAL*8 B11, B12, B16, B22, B26, B66
    REAL*8 D11, D12, D16, D22, D26, D66
    REAL*8 u1tx, u1rx, u2tx, u2rx, u1ty, u1ry, u2ty, u2ry
    REAL*8 v1tx, v1rx, v2tx, v2rx, v1ty, v1ry, v2ty, v2ry
    REAL*8 w1tx, w1rx, w2tx, w2rx, w1ty, w1ry, w2ty, w2ry
    REAL*8 a, b, r, Nxx, Nyy, Nxy
    REAL*8 E1, E2, G12, nu12, nu21, t

    ! MKL inputs
    CHARACTER*1 BALANC, JOBVL, JOBVR, SENSE
    INTEGER NT, nulls, NUM, M, N
    REAL*8, ALLOCATABLE :: K0(:, :), KG0(:, :), K02(:, :), KG02(:, :)
    INTEGER LDA, LDB, LDZ

    ! workspace
    INTEGER i, j, id, jd
    INTEGER LWORK
    INTEGER, ALLOCATABLE :: IWORK(:)
    REAL*8, ALLOCATABLE :: WORK(:)
    REAL*8 E11, nu, NULLTOL
    CHARACTER (LEN=5) :: ISOTROPIC
    INTEGER, ALLOCATABLE :: TMP(:)

    LOGICAL debug, exist

    ! MKL outputs
    INTEGER Mout, INFO
    INTEGER, ALLOCATABLE :: IFAIL(:)
    REAL*8, ALLOCATABLE :: EIGVALS(:), EIGVECS(:, :)

    ERROR = 0

    debug = .false.
    IF (debug) THEN
        inquire(file='pcbuck.log', exist=exist)

        IF (exist) THEN
            OPEN(unit=10, file='pcbuck.log', status='old', position='append', action='write')
        ELSE
            OPEN(unit=10, file='pcbuck.log', status='new', action='write')
        END IF
    END IF

    ISOTROPIC = "FALSE"

    IF (TYPNAM .eq. 'BUCK_PC') THEN
        IF (debug) THEN
            WRITE(10, *) '! DOUBLE PRECISION ROUTINE'
            WRITE(10, *) ''
            WRITE(10, *) 'GRPID', GRPID
            WRITE(10, *) 'NITEMS', NITEMS
            WRITE(10, *) 'NSIZE', NSIZE
            WRITE(10, *) 'ARGLIS', ARGLIS
            WRITE(10, *) 'NWRDA8', NWRDA8
            WRITE(10, *) 'ERROR', ERROR
            WRITE(10, *) 'nresp', nresp
            WRITE(10, *) 'ARGVAL(1)', ARGVAL(1)
            WRITE(10, *) 'ARGVAL(2)', ARGVAL(2)
        END IF

        BALANC = 'N'
        JOBVL = 'N'
        JOBVR = 'N'
        SENSE = 'N'

        NUM = 10
        M = 15
        N = 15

        ! Tolerance to consider a zero in K0 and KG0
        NULLTOL = 1.e-15

        ! Default boundary conditions (simply supported)
        u1tx = 0.
        u1rx = 1.
        u2tx = 0.
        u2rx = 1.
        u1ty = 0.
        u1ry = 1.
        u2ty = 0.
        u2ry = 1.
        v1tx = 0.
        v1rx = 1.
        v2tx = 0.
        v2rx = 1.
        v1ty = 0.
        v1ry = 1.
        v2ty = 0.
        v2ry = 1.
        w1tx = 0.
        w1rx = 1.
        w2tx = 0.
        w2rx = 1.
        w1ty = 0.
        w1ry = 1.
        w2ty = 0.
        w2ry = 1.

        t = ARGVAL(1)     ! Getting t from DRESP3
        a = ARGVAL(2)     ! Getting a from DRESP3
        b = ARGVAL(3)     ! Getting b from DRESP3
        r = ARGVAL(4)     ! Getting r from DRESP3
        E1 = ARGVAL(5)    ! Getting E1 from DRESP3
        E2 = ARGVAL(6)    ! Getting E2 from DRESP3
        G12 = ARGVAL(7)   ! Getting G12 from DRESP3
        nu12 = ARGVAL(8)  ! Getting nu12 from DRESP3
        nu21 = ARGVAL(9)  ! Getting nu21 from DRESP3
        Nxx = ARGVAL(10)  ! Getting Nxx from DRESP3
        Nyy = ARGVAL(11)  ! Getting Nyy from DRESP3
        Nxy = ARGVAL(12)  ! Getting Nxy from DRESP3

        IF (debug) THEN
            WRITE(10, *) '! Input'
            WRITE(10, *) '! DRESP3 arguments'
            WRITE(10, *) 't', ARGVAL(1)
            WRITE(10, *) 'a', ARGVAL(2)
            WRITE(10, *) 'b', ARGVAL(3)
            WRITE(10, *) 'r', ARGVAL(4)
            WRITE(10, *) 'E1', ARGVAL(5)
            WRITE(10, *) 'E2', ARGVAL(6)
            WRITE(10, *) 'G12', ARGVAL(7)
            WRITE(10, *) 'nu12', ARGVAL(8)
            WRITE(10, *) 'nu21', ARGVAL(9)
            WRITE(10, *) 'Nxx', ARGVAL(10)
            WRITE(10, *) 'Nyy', ARGVAL(11)
            WRITE(10, *) 'Nxy', ARGVAL(12)
        END IF

        NT = 3*M*N

        ! Calculating ABD
        IF (ISOTROPIC == "TRUE") THEN
            G12 = E11/(2*(1 + nu))

            A11 = E11*t/(1 - nu**2)
            A12 = nu*E11*t/(1 - nu**2)
            A16 = 0
            A22 = E11*t/(1 - nu**2)
            A26 = 0
            A66 = G12*t

            B11 = 0
            B12 = 0
            B16 = 0
            B22 = 0
            B26 = 0
            B66 = 0

            D11 = E11*t**3/(12*(1 - nu**2))
            D12 = nu*E11*t**3/(12*(1 - nu**2))
            D16 = 0
            D22 = E11*t**3/(12*(1 - nu**2))
            D26 = 0
            D66 = G12*t**3/12
        END IF

        !nu21 = nu12*(E2/E1)

        ! ABD Matrix to Orthotropic Material
        A11 = t*(E1/(1.-nu12*nu21))
        A12 = t*(nu12*E2/(1.-nu12*nu21))
        A16 = 0
        A22 = t*(E2/(1.-nu12*nu21))
        A26 = 0
        A66 = t*G12

        B11 = 0
        B12 = 0
        B16 = 0
        B22 = 0
        B26 = 0
        B66 = 0

        D11 = ((t**3.)/12.)*(E1/(1.-nu12*nu21))
        D12 = ((t**3.)/12.)*(nu12*E2/(1.-nu12*nu21))
        D16 = 0
        D22 = ((t**3.)/12.)*(E2/(1.-nu12*nu21))
        D26 = 0
        D66 = ((t**3.)/12.)*G12

        ! allocating arrays
        ALLOCATE(K0(NT, NT))
        ALLOCATE(KG0(NT, NT))

        IF (debug) THEN
            WRITE(10, *) '! Intermediate'
            WRITE(10, *) 'D11', D11
            WRITE(10, *) 'D12', D12
            WRITE(10, *) 'D22', D22
            WRITE(10, *) 'D66', D66
        END IF

        ! constitutive stiffness matrix
        CALL CALC_K0(M, N, K0, a, b, r, &
                     A11, A12, A16, A22, A26, A66, &
                     B11, B12, B16, B22, B26, B66, &
                     D11, D12, D16, D22, D26, D66, &
                     u1tx, u1rx, u2tx, u2rx, u1ty, u1ry, u2ty, u2ry, &
                     v1tx, v1rx, v2tx, v2rx, v1ty, v1ry, v2ty, v2ry, &
                     w1tx, w1rx, w2tx, w2rx, w1ty, w1ry, w2ty, w2ry)

        ! geometric stiffness matrix
        CALL CALC_KG0(M, N, KG0, a, b, Nxx, Nyy, Nxy, &
                      w1tx, w1rx, w2tx, w2rx, w1ty, w1ry, w2ty, w2ry)

        ! removing null rows and columns
        ALLOCATE(TMP(NT))
        TMP = 0
        WHERE (ABS(SUM(K0, DIM=1)) <= NULLTOL) TMP = 1
        nulls = SUM(TMP)

        ALLOCATE(K02(NT-nulls, NT-nulls))
        ALLOCATE(KG02(NT-nulls, NT-nulls))

        jd = 0
        DO j=1, NT
            IF (TMP(j) == 1) THEN
                jd = jd+1
                CYCLE
            END IF
            id = 0
            DO i=1, NT
                IF (TMP(i) == 1) THEN
                    id = id+1
                    CYCLE
                END IF
                K02(i-id, j-jd) = K0(i, j)
                KG02(i-id, j-jd) = KG0(i, j)
            END DO
        END DO
        DEALLOCATE(TMP)

        ! allocating arrays
        ALLOCATE(IWORK((NT-nulls)*25))

        ! allocating output arrays
        ALLOCATE(EIGVALS(NT-nulls))
        ALLOCATE(EIGVECS(NT-nulls, NT-nulls))
        ALLOCATE(IFAIL(NT-nulls))

        LDA = NT-nulls
        LDB = NT-nulls
        LDZ = NT-nulls

        EIGVALS = EIGVALS*0

        ! Workspace query
        LWORK = -1
        ALLOCATE(WORK(10))
        IF (debug) THEN
            WRITE(10, *) '! flag 1'
        END IF
        CALL DSYGVX(1, "N", "I", "U", (NT-nulls), KG02, LDB, K02, LDA, &
                    -1.D10, 0, 1, NUM, 0., Mout, EIGVALS, EIGVECS, LDZ, &
                    WORK, LWORK, IWORK, IFAIL, INFO)
        LWORK = WORK(1)
        DEALLOCATE(WORK)
        IF (debug) THEN
            WRITE(10, *) '! flag 2'
        END IF
        ! Eigensolver query
        ALLOCATE(WORK(LWORK))
        CALL DSYGVX(1, "N", "I", "U", (NT-nulls), KG02, LDB, K02, LDA, &
                    -1.D10, 0, 1, NUM, 0., Mout, EIGVALS, EIGVECS, LDZ, &
                    WORK, LWORK, IWORK, IFAIL, INFO)
        DEALLOCATE(WORK)

        WHERE(EIGVALS /= 0) EIGVALS = -1/EIGVALS

        IF (ABS(EIGVALS(1)) < 1.e-6) THEN
            EIGVALS(1) = 666
        END IF

        ! Storing eigenvalues
        DR3VAL(1) = EIGVALS(1)

        DEALLOCATE(K0)
        DEALLOCATE(KG0)
        DEALLOCATE(K02)
        DEALLOCATE(KG02)
        DEALLOCATE(IWORK)
        DEALLOCATE(IFAIL)
        DEALLOCATE(EIGVALS)
        DEALLOCATE(EIGVECS)

    ELSE
        ERROR = BADTYP
    END IF

    IF (debug) THEN
        WRITE(10, *) '! Result'
        WRITE(10, *) 'EIGVALS(1)', EIGVALS(1)
    END IF
    IF (debug) THEN
        CLOSE(10)
    END IF

END SUBROUTINE


subroutine ruqope(ndime,ngaus,posgp,weigp)

!-----------------------------------------------------------------------
!
!     This routine sets up the integration constants of open
!     integration rules for brick elements:
!
!          NDIME = 1             NDIME = 2             NDIME = 3
!
!      NGAUS  EXACT POL.     NGAUS  EXACT POL.     NGAUS  EXACT POL.
!      -----  ----------     -----  ----------     -----  ----------
!        1      q1           1 x 1     q1          1x1x1     q1
!        2      q3           2 x 2     q3          2x2x2     q3
!        3      q5           3 x 3     q5          3x3x3     q5
!        4      q7           4 x 4     q7          4x4x4     q7
!        5      q9           5 x 5     q9          5x5x5     q9
!        6      q11          6 x 6     q11         6x6x6     q11
!        7      q13          7 x 7     q13         7x7x7     q13
!        8      q15          8 x 8     q15         8x8x8     q15
!       16      q31         16 x 16    q31        16x16x16   q31
!
!-----------------------------------------------------------------------

  use     typre
  implicit none

  integer(ip), intent(in)  :: ndime,ngaus
  real(rp),    intent(out) :: posgp(ndime,ngaus),weigp(ngaus)
  real(rp)                 :: posgl(16),weigl(16)
  integer(ip)              :: nlocs,igaus,ilocs,jlocs,klocs

  if(ndime==1) then
     nlocs=ngaus
  else if(ndime==2) then
     nlocs=nint(sqrt(real(ngaus,rp)))
  else
     nlocs=nint(real(ngaus,rp)**(1.0_rp/3.0_rp))
  end if

  if(nlocs==1) then
     posgl(1)=0.0_rp
     weigl(1)=2.0_rp
  else if(nlocs==2) then
     posgl(1)=-0.577350269189626_rp
     posgl(2)= 0.577350269189626_rp
     weigl(1)= 1.0_rp
     weigl(2)= 1.0_rp
  else if(nlocs==3) then
     posgl(1)=-0.774596669241483_rp
     posgl(2)= 0.0_rp
     posgl(3)= 0.774596669241483_rp
     weigl(1)= 0.555555555555556_rp
     weigl(2)= 0.888888888888889_rp
     weigl(3)= 0.555555555555556_rp
  else if(nlocs==4)  then
     posgl(1)=-0.861136311594053_rp
     posgl(2)=-0.339981043584856_rp
     posgl(3)= 0.339981043584856_rp
     posgl(4)= 0.861136311594053_rp
     weigl(1)= 0.347854845137454_rp
     weigl(2)= 0.652145154862546_rp
     weigl(3)= 0.652145154862546_rp
     weigl(4)= 0.347854845137454_rp
  else if(nlocs==5)  then
            posgl(1) = -0.906179845938664_rp
            posgl(2) = -0.538469310105683_rp
            posgl(3) =  0.0_rp
            posgl(4) =  0.538469310105683_rp
            posgl(5) =  0.906179845938664_rp
            weigl(1) =  0.236926885056189_rp
            weigl(2) =  0.478628670499366_rp
            weigl(3) =  0.568888888888889_rp
            weigl(4) =  0.478628670499366_rp
            weigl(5) =  0.236926885056189_rp
  else if(nlocs==6)  then
            posgl(1) = -0.932469514203152_rp
            posgl(2) = -0.661209386466265_rp
            posgl(3) = -0.238619186083197_rp
            posgl(4) =  0.238619186083197_rp
            posgl(5) =  0.661209386466265_rp
            posgl(6) =  0.932469514203152_rp
            weigl(1) =  0.171324492379170_rp
            weigl(2) =  0.360761573048139_rp
            weigl(3) =  0.467913934572691_rp
            weigl(4) =  0.467913934572691_rp
            weigl(5) =  0.360761573048139_rp
            weigl(6) =  0.171324492379170_rp
  else if(nlocs==7)  then
            posgl(1) = -0.949107912342759_rp
            posgl(2) = -0.741531185599394_rp
            posgl(3) = -0.405845151377397_rp
            posgl(4) =  0.0_rp
            posgl(5) =  0.405845151377397_rp
            posgl(6) =  0.741531185599394_rp
            posgl(7) =  0.949107912342759_rp
            weigl(1) =  0.129484966168870_rp
            weigl(2) =  0.279705391489277_rp
            weigl(3) =  0.381830050505119_rp
            weigl(4) =  0.417959183673469_rp
            weigl(5) =  0.381830050505119_rp
            weigl(6) =  0.279705391489277_rp
            weigl(7) =  0.129484966168870_rp
  else if(nlocs==8)  then
            posgl(1) = -0.960289856497536_rp
            posgl(2) = -0.796666477413627_rp
            posgl(3) = -0.525532409916329_rp
            posgl(4) = -0.183434642495650_rp
            posgl(5) =  0.183434642495650_rp
            posgl(6) =  0.525532409916329_rp
            posgl(7) =  0.796666477413627_rp
            posgl(8) =  0.960289856497536_rp

            weigl(1) =  0.101228536290376_rp
            weigl(2) =  0.222381034453374_rp
            weigl(3) =  0.313706645877887_rp
            weigl(4) =  0.362683783378362_rp
            weigl(5) =  0.362683783378362_rp
            weigl(6) =  0.313706645877887_rp
            weigl(7) =  0.222381034453374_rp
            weigl(8) =  0.101228536290376_rp
  else if(nlocs==16)  then
            posgl( 1) =-0.98940093499165_rp
            posgl( 2) =-0.94457502307323_rp
            posgl( 3) =-0.86563120238783_rp
            posgl( 4) =-0.75540440835500_rp
            posgl( 5) =-0.61787624440264_rp
            posgl( 6) =-0.45801677765723_rp
            posgl( 7) =-0.28160355077926_rp
            posgl( 8) =-0.09501250983764_rp
            posgl( 9) = 0.09501250983764_rp
            posgl(10) = 0.28160355077926_rp
            posgl(11) = 0.45801677765723_rp
            posgl(12) = 0.61787624440264_rp
            posgl(13) = 0.75540440835500_rp
            posgl(14) = 0.86563120238783_rp
            posgl(15) = 0.94457502307323_rp
            posgl(16) = 0.98940093499165_rp

            weigl( 1) =  0.02715245941175_rp
            weigl( 2) =  0.06225352393865_rp
            weigl( 3) =  0.09515851168249_rp
            weigl( 4) =  0.12462897125553_rp
            weigl( 5) =  0.14959598881658_rp
            weigl( 6) =  0.16915651939500_rp
            weigl( 7) =  0.18260341504492_rp
            weigl( 8) =  0.18945061045507_rp
            weigl( 9) =  0.18945061045507_rp
            weigl(10) =  0.18260341504492_rp
            weigl(11) =  0.16915651939500_rp
            weigl(12) =  0.14959598881658_rp
            weigl(13) =  0.12462897125553_rp
            weigl(14) =  0.09515851168249_rp
            weigl(15) =  0.06225352393865_rp
            weigl(16) =  0.02715245941175_rp
  end if

  if(ndime==1) then
     igaus=0
     do ilocs=1,nlocs
        igaus=igaus+1
        weigp(  igaus)=weigl(ilocs)
        posgp(1,igaus)=posgl(ilocs)
     end do
  else if(ndime==2) then
     igaus=0
     do ilocs=1,nlocs
        do jlocs=1,nlocs
           igaus=igaus+1
           weigp(  igaus)=weigl(ilocs)*weigl(jlocs)
           posgp(1,igaus)=posgl(ilocs)
           posgp(2,igaus)=posgl(jlocs)
        end do
     end do
  else if(ndime==3) then
     igaus=0
     do ilocs=1,nlocs
        do jlocs=1,nlocs
           do klocs=1,nlocs
              igaus=igaus+1
              weigp(  igaus)=weigl(ilocs)*weigl(jlocs)*weigl(klocs)
              posgp(1,igaus)=posgl(ilocs)
              posgp(2,igaus)=posgl(jlocs)
              posgp(3,igaus)=posgl(klocs)
           end do
        end do
     end do
  end if

end subroutine ruqope


Program TimingAccuracyDH
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!	This program will test the accuracy of the spherical harmonic Driscoll and
!	Healy tranformation routines by expanding a field in the space domain, transforming this
!	to spherical harmonics, and comparing the relative error of the coefficients
!
!
!	Written by Mark Wieczorek (July 2006)
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	use SHTOOLS

	implicit none

	integer, parameter ::	maxdeg = 2800
	character*200 ::	outfile1, outfile2, outfile3, outfile4, outfile
	real*8, allocatable ::	cilm(:,:,:), cilm2(:,:,:), griddh(:,:)
	real*8 ::		huge8, maxerror, err1, err2, beta, rms, timein(3), timeout(3)
	integer ::		lmax, l, m, seed, n, sampling, lmaxout, astat(3)

	allocate(cilm(2,maxdeg+1,maxdeg+1), stat=astat(1))
	allocate(cilm2(2,maxdeg+1,maxdeg+1), stat=astat(2))
	allocate(griddh(2*maxdeg+2,4*maxdeg+4), stat=astat(3))

	if (sum(astat(1:3)) /= 0) then
		print*, "Error --- TimingAccuracyDH"
		print*, "Problem allocating arrays CILM, CILM2, GRIDDH"
		stop
	endif

	sampling = 1
	print*, "Value of beta for power law Sff = l^(-beta) > "
	read(*,*) beta

	print*, "output file name > "
	read(*,*) outfile

	outfile1 = trim(outfile) // ".timef"
	outfile2 = trim(outfile) // ".timei"
	outfile3 = trim(outfile) // ".maxerror"
	outfile4 = trim(outfile) // ".rmserror"

	huge8 = huge(maxerror)

	seed = -1053253

	cilm = 0.0d0

	do l=1, maxdeg

		do m=0, l
			if (m==0) then
				cilm(1,l+1,m+1) = RandomGaussian(seed)
			else
				cilm(1,l+1,m+1) = RandomGaussian(seed)
				cilm(2,l+1,m+1) = RandomGaussian(seed)
			endif
		enddo
		cilm(1:2, l+1, 1:l+1) = cilm(1:2, l+1, 1:l+1)*sqrt(dble(l)**beta)/sqrt(2.0d0*l+1)
	enddo

	print*, "Lmax, Maximum rel. error of Cilm, RMS relative error, Time inverse (sec), Time forward (sec)"

	lmax = 1

	do

		lmax = lmax*2
		if (lmax > maxdeg) lmax = maxdeg

		n = 2*lmax + 2

		if (lmax==2) then
			open(12,file=outfile1, status="replace")
			open(13,file=outfile2, status="replace")
			open(14,file=outfile3, status="replace")
			open(15,file=outfile4, status="replace")
		else
			open(12,file=outfile1, position="append")
			open(13,file=outfile2, position="append")
			open(14,file=outfile3, position="append")
			open(15,file=outfile4, position="append")
		endif

		call cpu_time(timein(2))
		if (sampling == 1) then
			call MakeGridDH(griddh(1:n, 1:n), n, cilm(1:2,1:lmax+1, 1:lmax+1), lmax, sampling=sampling)
		else
			call MakeGridDH(griddh(1:n, 1:2*n), n, cilm(1:2,1:lmax+1, 1:lmax+1), lmax, sampling=sampling)
		endif
		call cpu_time(timeout(2))

		call cpu_time(timein(3))
		if (sampling == 1) then
			call SHExpandDH(griddh(1:n, 1:n), n, cilm2(1:2, 1:lmax+1, 1:lmax+1), lmaxout, sampling=sampling)
		else
			call SHExpandDH(griddh(1:n, 1:2*n), n, cilm2(1:2, 1:lmax+1, 1:lmax+1), lmaxout, sampling=sampling)
		endif
		call cpu_time(timeout(3))

		maxerror = 0.0d0
		rms = 0.0d0

		do l=1, lmax

			do m=0, l
				if (m==0) then
					err1 = abs( (cilm(1,l+1,m+1)-cilm2(1,l+1,m+1)) / cilm(1,l+1,m+1) )
					if (err1 >= maxerror) maxerror = err1
					rms = rms + err1**2
				else
					err1 = abs( (cilm(1,l+1,m+1)-cilm2(1,l+1,m+1)) / cilm(1,l+1,m+1) )
					err2 = abs( (cilm(2,l+1,m+1)-cilm2(2,l+1,m+1)) / cilm(2,l+1,m+1) )
					if (err1 >= maxerror) maxerror = err1
					if (err2 >= maxerror) maxerror = err2
					rms = rms + err1**2 + err2**2
				endif
			enddo
		enddo
		rms = sqrt(rms/dble(l+1)**2)

		! elasped time in seconds!
		print*, lmax, maxerror, rms, timeout(2)-timein(2), timeout(3)-timein(3)
		write(12,*) lmax, timeout(2)-timein(2)
		write(13,*) lmax, timeout(3)-timein(3)
		write(14,*) lmax, maxerror
		write(15,*) lmax, rms

		if (maxerror > huge8) then
			print*, "Overflow problems"
			print*, "Overflow problems"
			close(12)
			close(13)
			close(14)
			close(15)
			stop
		endif

		if (maxerror > 10.0d0) then
			close(12)
			close(13)
			close(14)
			close(15)
			stop
		endif

		close(12)
		close(13)
		close(14)
		close(15)

		if (lmax == maxdeg) exit

	enddo

end program TimingAccuracyDH


!
! Nyx code units are defined as:
!      Length [Mpc]
!      Velocity [km/s]
!      Mass [M_sun]
!      (+ Kelvin for temperature)
!
! Fundamental constants are taken from Chin. Phys. C, 40, 100001 (2016), see
!          http://pdg.lbl.gov/2016/reviews/rpp2016-rev-phys-constants.pdf
!          http://pdg.lbl.gov/2016/reviews/rpp2016-rev-astrophysical-constants.pdf
!

module fundamental_constants_module

  use amrex_fort_module, only : rt => amrex_real
  implicit none

  real(rt), parameter :: pi = 3.141592653589793238d0

  ! Relation of our code units & CGS:
  real(rt), parameter :: M_unit = 1.98848d33    ! M_sun
  real(rt), parameter :: L_unit = 3.0856776d24  ! Mpc
  real(rt), parameter :: V_unit = 1.d5          ! km/s
  real(rt), parameter :: T_unit = L_unit/V_unit ! time unit

  !
  ! Fundamental constants
  !
  real(rt), parameter :: Gconst = 6.67408e-8_rt       &       ! Newton [g^-1*s^-2*cm^3]
                                  * M_unit*T_unit**2/L_unit**3

  real(rt), parameter :: k_B    = 1.38064852e-16_rt   &       ! Boltzmann [g*cm^2/s^2*K]
                                  * T_unit**2/(M_unit*L_unit**2)

  real(rt), parameter :: hbar   = 1.0545718e-27_rt    &       ! Planck/2pi [g*cm^2/s]
                                  * T_unit/(M_unit*L_unit**2)

  real(rt), parameter :: n_A    = 6.022140857e23_rt   &       ! Avogadro's number [mol^-1]
                                  * M_unit

  real(rt), parameter :: m_proton = 1.672621e-24_rt   &       ! Proton mass [g]
                                    / M_unit

  real(rt), parameter :: sigma_T =  6.6524587158e-25_rt  &    ! Thomson cross section [cm^2]
                                    / L_unit**2

  real(rt), parameter :: c_light = 2.99792458e10_rt   &       ! Speed of light [cm/s]
                                   / V_unit

  real(rt), parameter :: Hubble_const = 100._rt               ! Hubble constant / h

  !
  ! Useful quantities and conversions
  !
  real(rt), parameter :: mp_over_kb = m_proton/k_B

  real(rt), parameter :: density_to_cgs = M_unit / L_unit**3

  ! For internal energy
  real(rt), parameter :: e_to_cgs = V_unit**2

  ! For source terms we convert [erg/(s*cm^3) = g/(s^3*cm)] into code units
  real(rt), parameter :: heat_from_cgs = L_unit*(T_unit**3 / M_unit)

  ! For AGN accretion rate
  real(rt), parameter :: eddington_const = 4.0d0*pi * Gconst * m_proton / (sigma_T * c_light)

end module fundamental_constants_module


SUBROUTINE zcoord (z2, z1, y2, y1, x2, x1, zint, yint, xint)
!-----------------------------------------------
!   m o d u l e s
!-----------------------------------------------
  USE kind_param, ONLY: double
  IMPLICIT NONE
!-----------------------------------------------
!   d u m m y   a r g u m e n t s
!-----------------------------------------------
  REAL (double), INTENT (IN) :: z2
  REAL (double), INTENT (IN) :: z1
  REAL (double), INTENT (IN) :: y2
  REAL (double), INTENT (IN) :: y1
  REAL (double), INTENT (IN) :: x2
  REAL (double), INTENT (IN) :: x1
  REAL (double), INTENT (OUT) :: zint
  REAL (double), INTENT (IN) :: yint
  REAL (double), INTENT (IN) :: xint
!-------------------------------------------

  IF (x2 /= x1) THEN
     zint = (z2-z1) * (xint-x1) / (x2-x1) + z1
  ELSE
     zint = (z2-z1) * (yint-y1) / (y2-y1) + z1
  END IF
  RETURN
END SUBROUTINE zcoord


!***********************************************************************
! Computes the potential evapotranspiration using the Hargreaves and
! Samani formulation
! Hargreaves, G.H. and Z.A. Samani, 1985. Reference crop
! evapotranspiration from temperature. Transaction of ASAE 1(2):96-99.
!***********************************************************************
      MODULE PRMS_POTET_HS
        IMPLICIT NONE
        ! Local Variables
        CHARACTER(LEN=8), SAVE :: MODNAME
        ! Declared Parameters
        REAL, SAVE, ALLOCATABLE :: Hs_krs(:, :)
      END MODULE PRMS_POTET_HS

      INTEGER FUNCTION potet_hs()
      USE PRMS_POTET_HS
      USE PRMS_MODULE, ONLY: Process, Nhru
      USE PRMS_BASIN, ONLY: Active_hrus, Hru_route_order, Hru_area, Basin_area_inv
      USE PRMS_CLIMATEVARS, ONLY: Basin_potet, Potet, Tavgc, Tminc, Tmaxc, Swrad
      USE PRMS_SET_TIME, ONLY: Nowmonth
      IMPLICIT NONE
! Functions
      INTRINSIC SQRT, DBLE, ABS
      INTEGER, EXTERNAL :: declparam, getparam
      EXTERNAL read_error, print_module
! Local Variables
      INTEGER :: i, j
      REAL :: temp_diff, swrad_inch_day !, coef_kt
      CHARACTER(LEN=80), SAVE :: Version_potet
!***********************************************************************
      potet_hs = 0

      IF ( Process(:3)=='run' ) THEN
        Basin_potet = 0.0D0
        DO j = 1, Active_hrus
          i = Hru_route_order(j)
          temp_diff = Tmaxc(i) - Tminc(i) ! should be mean monthlys???
!          swrad_mm_day = Swrad(i)/23.89/2.45
!          swrad_mm_day = Swrad(i)*0.04184/2.45
          swrad_inch_day = Swrad(i)*0.000673 ! Langleys->in/day
! http://www.zohrabsamani.com/research_material/files/Hargreaves-samani.pdf
!          coef_kt = 0.00185*(temp_diff**2) - 0.0433*temp_diff + 0.4023
!          Potet(i) = Hs_krs(i, Nowmonth)*coef_kt*swrad_inch_day*SQRT(temp_diff)*(Tavgc(i)+17.8)

! Danger markstro
!          Potet(i) = Hs_krs(i, Nowmonth)*swrad_inch_day*SQRT(temp_diff)*(Tavgc(i)+17.8)
          Potet(i) = Hs_krs(i, Nowmonth)*swrad_inch_day*SQRT(ABS(temp_diff))*(Tavgc(i)+17.8)
! End Danger
          IF ( Potet(i)<0.0 ) Potet(i) = 0.0
          Basin_potet = Basin_potet + DBLE( Potet(i)*Hru_area(i) )
        ENDDO
        Basin_potet = Basin_potet*Basin_area_inv

      ELSEIF ( Process(:4)=='decl' ) THEN
        Version_potet = 'potet_hs.f90 2016-07-20 15:30:00Z'
        CALL print_module(Version_potet, 'Potential Evapotranspiration', 90)
        MODNAME = 'potet_hs'

        ALLOCATE ( Hs_krs(Nhru,12) )
        IF ( declparam(MODNAME, 'hs_krs', 'nhru,nmonths', 'real', &
     &       '0.0135', '0.01', '0.24', &
     &       'Potential ET adjustment factor - Hargreaves-Samani', &
     &       'Monthly (January to December) adjustment factor used in Hargreaves-Samani potential ET computations for each HRU', &
     &       'decimal fraction')/=0 ) CALL read_error(1, 'hs_krs')

!******Get parameters
      ELSEIF ( Process(:4)=='init' ) THEN
        IF ( getparam(MODNAME, 'hs_krs', Nhru*12, 'real', Hs_krs)/=0 ) CALL read_error(2, 'hs_krs')
      ENDIF

      END FUNCTION potet_hs


 SUBROUTINE projq4(y,x,xi,eta,shape,flag)
 !
 ! proyects a point over a quadrilateral
 ! first order approach
 ! initial guess is assumed good enough
 !
 IMPLICIT NONE
 ! dummy arguments
 REAL(kind=8), INTENT(IN) :: y(3), & !point coordinates
                             x(3,4)  !quad nodal coordinates
 REAL(kind=8), INTENT(IN OUT) :: xi,eta, & !guess
                                 shape(4)  !shape functions at the guess
 LOGICAL, INTENT(IN) :: flag         !to recompute shape functions
 ! local variables
 REAL(kind=8) :: deriv(4,2), &
                 xx(3,2),xy(3,2),t(3),mx,xc(3)

 ! compute shape functions and derivatives at the point
 CALL shape1 (4 ,deriv ,shape ,xi,eta )
 ! distance from point to initial guress
 xc = y - MATMUL(x,shape)
 ! jacobian matrix at the guess
 xx = MATMUL(x,deriv)
 ! compute inverse jacobian matrix (dual base)
 CALL vecpro(xx(1,1),xx(1,2),t(1))   !normal vector
 CALL vecuni(3,t,mx)                 !unit normal vector and Jacobian
 CALL vecpro(xx(1,2),t(1),xy(1,1))   !first vector of the dual base
 CALL vecpro(t(1),xx(1,1),xy(1,2))   !second vector of the dual base
 xi = xi + DOT_PRODUCT(xc,xy(:,1))/mx   !compute improved position
 eta= eta+ DOT_PRODUCT(xc,xy(:,2))/mx
 IF( flag )THEN
   mx = xi*eta
   shape(1) = (1d0-xi-eta+mx)/4d0
   shape(2) = (1d0+xi-eta-mx)/4d0
   shape(3) = (1d0+xi+eta+mx)/4d0
   shape(4) = (1d0-xi+eta-mx)/4d0
 END IF

 RETURN
 END SUBROUTINE projq4