module mod_rgrd3
    use mod_rgrd2
    implicit none

contains
    !

    ! Code converted using TO_F90 by Alan Miller
    ! Date: 2013-09-18  Time: 12:23:20

    ! ... file rgrd3.f

    !     this file contains documentation for subroutine rgrd3 followed by
    !     fortran code for rgrd3 and additional subroutines.

    ! ... author

    !     John C. Adams (NCAR 1999)

    ! ... subroutine rgrd3(nx,ny,nz,x,y,z,p,mx,my,mz,xx,yy,zz,q,intpol,
    !    +                 w,lw,iw,liw,ier)

    ! ... purpose

    !     subroutine rgrd3 interpolates the values p(i,j,k) on the orthogonal
    !     grid (x(i),y(j),z(k)) for i=1,...,nx; j=1,...,ny; k=1,...,nz
    !     onto q(ii,jj,kk) on the orthogonal grid (xx(ii),yy(jj),zz(kk)) for
    !     ii=1,...,mx; jj=1,...,my; kk=1,...,mz.

    ! ... language

    !     coded in portable FORTRAN77 and FORTRAN90

    ! ... test program

    !     file trgrd3.f on regridpack includes a test program for subroutine rgrd3

    ! ... method

    !     linear or cubic interpolation is used (independently) in
    !     each direction (see argument intpol).

    ! ... required files

    !     files rgrd2.f and rgrd1.f must be loaded with rgrd3.f.  they
    !     include subroutines called by the routines in rgrd3.f

    ! ... requirements

    !     each of the x,y,z grids must be strictly montonically increasing
    !     and each of the xx,yy,zz grids must be montonically increasing
    !     (see ier = 4).  in addition the (X,Y,Z) region

    !          [xx(1),xx(mx)] X [yy(1),yy(my)] X [zz(1),zz(mz)]

    !     must lie within the (X,Y,Z) region

    !          [x(1),x(nx)] X [y(1),y(ny)] X [z(1),z(nz)].

    !     extrapolation is not allowed (see ier=3).  if these (X,Y,Z)
    !     regions are identical and the orthogonal grids are UNIFORM
    !     in each direction then subroutine rgrd3u (see file rgrd3u.f)
    !     should be used instead of rgrd3.

    ! ... efficiency

    !     inner most loops in regridpack software vectorize.  if
    !     the integer arguments mx,my,mz (see below) have different values,
    !     optimal vectorization will be achieved if mx > my > mz.

    ! *** input arguments

    ! ... nx

    !     the integer dimension of the grid vector x and the first dimension of p.
    !     nx > 1 if intpol(1) = 1 or nx > 3 if intpol(1) = 3 is required.

    ! ... ny

    !     the integer dimension of the grid vector y and the second dimension of p.
    !     ny > 1 if intpol(2) = 1 or ny > 3 if intpol(2) = 3 is required.

    ! ... nz

    !     the integer dimension of the grid vector z and the third dimension of p.
    !     nz > 1 if intpol(3) = 1 or nz > 3 if intpol(3) = 3 is required.

    ! ... x

    !     a real (kind=8) nx vector of strictly increasing values which defines the x
    !     portion of the orthogonal grid on which p is given

    ! ... y

    !     a real (kind=8) ny vector of strictly increasing values which defines the y
    !     portion of the orthogonal grid on which p is given

    ! ... z

    !     a real (kind=8) nz vector of strictly increasing values which defines the z
    !     portion of the orthogonal grid on which p is given

    ! ... p

    !     a real (kind=8) nx by ny by nz array of values given on the (x,y,z) grid

    ! ... mx

    !     the integer dimension of the grid vector xx and the first dimension of q.
    !     mx > 0 is required.

    ! ... my

    !     the integer dimension of the grid vector yy and the second dimension of q.
    !     my > 0 is required.

    ! ... mz

    !     the integer dimension of the grid vector zz and the third dimension of q.
    !     mz > 0 is required.

    ! ... xx

    !     a real (kind=8) mx vector of increasing values which defines the x portion of the
    !     orthogonal grid on which q is defined.  xx(1) < x(1) or xx(mx) > x(nx)
    !     is not allowed (see ier = 3)

    ! ... yy

    !     a real (kind=8) my vector of increasing values which defines the y portion of the
    !     orthogonal grid on which q is defined.  yy(1) < y(1) or yy(my) > y(ny)
    !     is not allowed (see ier = 3)

    ! ... zz

    !     a real (kind=8) mz vector of increasing values which defines the z portion of the
    !     orthogonal grid on which q is defined.  zz(1) < z(1) or zz(mz) > z(nz)
    !     is not allowed (see ier = 3)

    ! ... intpol

    !     an integer vector of dimension 3 which sets linear or cubic
    !     interpolation in each of the x,y,z directions as follows:

    !        intpol(1) = 1 sets linear interpolation in the x direction
    !        intpol(1) = 3 sets cubic interpolation in the x direction.

    !        intpol(2) = 1 sets linear interpolation in the y direction
    !        intpol(2) = 3 sets cubic interpolation in the y direction.

    !        intpol(3) = 1 sets linear interpolation in the z direction
    !        intpol(3) = 3 sets cubic interpolation in the z direction.

    !     values other than 1 or 3 in intpol are not allowed (ier = 5).

    ! ... w

    !     a real (kind=8) work space of length at least lw which must be provided in the
    !     routine calling rgrd3

    ! ... lw

    !     the integer length of the real (kind=8) work space w.  let

    !          lwx =   mx            if intpol(1) = 1
    !          lwx = 4*mx            if intpol(1) = 3

    !          lwy = my+2*mx         if intpol(2) = 1
    !          lwy = 4*(mx+my)       if intpol(2) = 3

    !          lwz = 2*mx*my+mz      if intpol(3) = 1
    !          lwz = 4*(mx*my+mz)    if intpol(3) = 3

    !     then lw must be greater than or equal to lwx+lwy+lwz

    ! ... iw

    !     an integer work space of length at least liw which must be provided in the
    !     routine calling rgrd3

    ! ... liw

    !     the integer length of the integer work space iw.  liw must be at least mx+my+mz

    ! *** output arguments

    ! ... q

    !     a real (kind=8) mx by my by mz array of values on the (xx,yy,zz) grid which are
    !     interpolated from p on the (x,y,z) grid

    ! ... ier

    !     an integer error flag set as follows:

    !     ier = 0 if no errors in input arguments are detected

    !     ier = 1 if  min0(mx,my,mz) < 1

    !     ier = 2 if nx < 2 when intpol(1)=1 or nx < 4 when intpol(1)=3 (or)
    !                ny < 2 when intpol(2)=1 or ny < 4 when intpol(2)=3 (or)
    !                nz < 2 when intpol(3)=1 or nz < 4 when intpol(3)=3.

    !     ier = 3 if xx(1) < x(1) or x(nx) < xx(mx) (or)
    !                yy(1) < y(1) or y(ny) < yy(my) (or)
    !                zz(1) < z(1) or z(nz) < zz(mz)

    ! *** to avoid this flag when end points are intended to be the
    !     same but may differ slightly due to roundoff error, they
    !     should be set exactly in the calling routine (e.g., if both
    !     grids have the same y boundaries then yy(1)=y(1) and yy(my)=y(ny)
    !     should be set before calling rgrd3)

    !     ier = 4 if one of the grids x,y,z is not strictly monotonically
    !             increasing or if one of the grids xx,yy,zz is not
    !             montonically increasing.  more precisely if:

    !             x(i+1) <= x(i) for some i such that 1 <= i < nx (or)

    !             y(j+1) <= y(j) for some j such that 1 <= j < ny (or)

    !             z(k+1) <= z(k) for some k such that 1 <= k < nz (or)

    !             xx(ii+1) < xx(ii) for some ii such that 1 <= ii < mx (or)

    !             yy(jj+1) < yy(jj) for some jj such that 1 <= jj < my (or)

    !             zz(kk+1) < zz(k)  for some kk such that 1 <= kk < mz

    !     ier = 5 if lw or liw is too small (insufficient work space)

    !     ier = 6 if any of intpol(1),intpol(2),intpol(3) is not equal to 1 or 3

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

    !     end of rgrd3 documentation, fortran code follows:

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

    SUBROUTINE rgrd3(nx,ny,nz,x,y,z,p,mx,my,mz,xx,yy,zz,q,intpol, w,lw,iw,liw,ier)

    IMPLICIT NONE
    INTEGER, INTENT(IN)                      :: nx
    INTEGER, INTENT(IN)                      :: ny
    INTEGER, INTENT(IN)                      :: nz
    real (kind=8), INTENT(IN)                :: x(nx)
    real (kind=8), INTENT(IN)                :: y(ny)
    real (kind=8), INTENT(IN)                :: z(nz)
    real (kind=8), INTENT(IN)                :: p(nx,ny,nz)
    INTEGER, INTENT(IN)                      :: mx
    INTEGER, INTENT(IN)                      :: my
    INTEGER, INTENT(IN)                      :: mz
    real (kind=8), INTENT(IN)                :: xx(mx)
    real (kind=8), INTENT(IN)                :: yy(my)
    real (kind=8), INTENT(IN)                :: zz(mz)
    real (kind=8), INTENT(OUT)               :: q(mx,my,mz)
    INTEGER, INTENT(IN)                      :: intpol(3)
    real (kind=8), INTENT(INOUT)             :: w(lw)
    INTEGER, INTENT(IN)                      :: lw
    INTEGER, INTENT(INOUT)                   :: iw(liw)
    INTEGER, INTENT(IN)                      :: liw
    INTEGER, INTENT(OUT)                     :: ier

    INTEGER :: lwx,lwy,lwz,jy,kz,mxmy

    INTEGER :: i,ii,j,jj,k,kk
    INTEGER :: i2,i3,i4,i5
    INTEGER :: j2,j3,j4,j5,j6,j7,j8,j9
    INTEGER :: k2,k3,k4,k5,k6,k7,k8,k9

    !     check input arguments

    ier = 1

    !     check (xx,yy,zz) grid resolution

    IF (MIN0(mx,my,mz) < 1) RETURN

    !     check intpol

    ier = 6
    IF (intpol(1) /= 1 .AND. intpol(1) /= 3) RETURN
    IF (intpol(2) /= 1 .AND. intpol(2) /= 3) RETURN
    IF (intpol(3) /= 1 .AND. intpol(3) /= 3) RETURN

    !     check (x,y,z) grid resolution

    ier = 2
    IF (intpol(1) == 1 .AND. nx < 2) RETURN
    IF (intpol(1) == 3 .AND. nx < 4) RETURN
    IF (intpol(2) == 1 .AND. ny < 2) RETURN
    IF (intpol(2) == 3 .AND. ny < 4) RETURN
    IF (intpol(3) == 1 .AND. nz < 2) RETURN
    IF (intpol(3) == 3 .AND. nz < 4) RETURN

    !     check work space length input and set minimum

    ier = 5
    mxmy = mx*my
    IF (intpol(1) == 1) THEN
      lwx = mx
    ELSE
      lwx = 4*mx
    END IF
    IF (intpol(2) == 1) THEN
      lwy = (my+2*mx)
    ELSE
      lwy = 4*(my+mx)
    END IF
    IF (intpol(3) == 1) THEN
      lwz = (2*mxmy+mz)
    ELSE
      lwz = 4*(mxmy+mz)
    END IF
    IF (lw < lwx+lwy+lwz) RETURN
    IF (liw < mx+my+mz) RETURN

    !     check (xx,yy,zz) grid contained in (x,y,z) grid

    ier = 3
    IF (xx(1) < x(1) .OR. xx(mx) > x(nx)) RETURN
    IF (yy(1) < y(1) .OR. yy(my) > y(ny)) RETURN
    IF (zz(1) < z(1) .OR. zz(mz) > z(nz)) RETURN

    !     check montonicity of grids

    ier = 4
    DO i=2,nx
      IF (x(i-1) >= x(i)) RETURN
    END DO
    DO j=2,ny
      IF (y(j-1) >= y(j)) RETURN
    END DO
    DO k=2,nz
      IF (z(k-1) >= z(k)) RETURN
    END DO
    DO ii=2,mx
      IF (xx(ii-1) > xx(ii)) RETURN
    END DO
    DO jj=2,my
      IF (yy(jj-1) > yy(jj)) RETURN
    END DO
    DO kk=2,mz
      IF (zz(kk-1) > zz(kk)) RETURN
    END DO

    !     arguments o.k.

    ier = 0
    jy = mx+1
    kz = mx+my+1
    IF (intpol(3) == 1) THEN

    !     linearly interpolate in nz, set work space pointers and scales

      k2 = 1
      k3 = k2
      k4 = k3+mz
      k5 = k4
      k6 = k5
      k7 = k6
      k8 = k7+mxmy
      k9 = k8+mxmy
      CALL linmx(nz,z,mz,zz,iw(kz),w(k3))
      j2 = k9

    !     set indices and scales which depend on y interpolation

      IF (intpol(2) == 1) THEN
    !     linear in y
        j3 = j2
        j4 = j3+my
        j5 = j4
        j6 = j5
        j7 = j6
        j8 = j7+mx
        j9 = j8+mx
        CALL linmx(ny,y,my,yy,iw(jy),w(j3))
        i2 = j9
      ELSE
    !     cubic in y
        j3 = j2+my
        j4 = j3+my
        j5 = j4+my
        j6 = j5+my
        j7 = j6+mx
        j8 = j7+mx
        j9 = j8+mx
        CALL cubnmx(ny,y,my,yy,iw(jy),w(j2),w(j3),w(j4),w(j5))
        i2 = j9+mx
      END IF

    !     set indices and scales which depend on x interpolation

      IF (intpol(1) == 1) THEN
    !     linear in x
        i3 = i2
        i4 = i3
        i5 = i4
        CALL linmx(nx,x,mx,xx,iw,w(i3))
      ELSE
    !     cubic in x
        i3 = i2+mx
        i4 = i3+mx
        i5 = i4+mx
        CALL cubnmx(nx,x,mx,xx,iw,w(i2),w(i3),w(i4),w(i5))
      END IF
      CALL lint3(nx,ny,nz,p,mx,my,mxmy,mz,q,intpol,iw(kz),  &
          w(k3),w(k7),w(k8),iw(jy),w(j2),w(j3),w(j4),w(j5),w(j6),  &
          w(j7),w(j8),w(j9),iw,w(i2),w(i3),w(i4),w(i5))
      RETURN
    ELSE

    !     cubically interpolate in z

      k2 = 1
      k3 = k2+mz
      k4 = k3+mz
      k5 = k4+mz
      k6 = k5+mz
      k7 = k6+mxmy
      k8 = k7+mxmy
      k9 = k8+mxmy
      CALL cubnmx(nz,z,mz,zz,iw(kz),w(k2),w(k3),w(k4),w(k5))
      j2 = k9+mxmy

    !     set indices which depend on y interpolation

      IF (intpol(2) == 1) THEN
        j3 = j2
        j4 = j3+my
        j5 = j4
        j6 = j5
        j7 = j6
        j8 = j7+mx
        j9 = j8+mx
        CALL linmx(ny,y,my,yy,iw(jy),w(j3))
        i2 = j9
      ELSE
        j3 = j2+my
        j4 = j3+my
        j5 = j4+my
        j6 = j5+my
        j7 = j6+mx
        j8 = j7+mx
        j9 = j8+mx
        CALL cubnmx(ny,y,my,yy,iw(jy),w(j2),w(j3),w(j4),w(j5))
        i2 = j9+mx
      END IF

    !     set work space portion and indices which depend on x interpolation

      IF (intpol(1) == 1) THEN
        i3 = i2
        i4 = i3
        i5 = i4
        CALL linmx(nx,x,mx,xx,iw,w(i3))
      ELSE
        i3 = i2+mx
        i4 = i3+mx
        i5 = i4+mx
        CALL cubnmx(nx,x,mx,xx,iw,w(i2),w(i3),w(i4),w(i5))
      END IF
      CALL cubt3(nx,ny,nz,p,mx,my,mxmy,mz,q,intpol,  &
          iw(kz),w(k2),w(k3),w(k4),w(k5),w(k6),w(k7),w(k8),w(k9),  &
          iw(jy),w(j2),w(j3),w(j4),w(j5),w(j6),w(j7),w(j8),w(j9),  &
          iw,w(i2),w(i3),w(i4),w(i5))
      RETURN

    END IF

    END SUBROUTINE rgrd3

    SUBROUTINE lint3(nx,ny,nz,p,mx,my,mxmy,mz,q,intpol,kz,  &
        dz,pk,pkp,jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp,ix,dxm,dx,dxp,dxpp)

    !     linearly interpolate in z direction

    IMPLICIT NONE
    INTEGER, INTENT(IN)                      :: nx
    INTEGER, INTENT(IN)                      :: ny
    INTEGER, INTENT(IN)                      :: nz
    real (kind=8), INTENT(IN)                :: p(nx,ny,nz)
    INTEGER, INTENT(IN)                      :: mx
    INTEGER, INTENT(IN)                      :: my
    INTEGER, INTENT(IN)                      :: mxmy
    INTEGER, INTENT(IN)                      :: mz
    real (kind=8), INTENT(OUT)               :: q(mxmy,mz)
    INTEGER, INTENT(IN)                      :: intpol(3)
    INTEGER, INTENT(IN)                      :: kz(mz)
    real (kind=8), INTENT(IN)                :: dz(mz)
    real (kind=8), INTENT(OUT)               :: pk(mxmy)
    real (kind=8), INTENT(IN OUT)            :: pkp(mxmy)
    INTEGER, INTENT(IN OUT)                  :: jy(my)
    real (kind=8), INTENT(IN OUT)            :: dym(my)
    real (kind=8), INTENT(IN OUT)            :: dy(my)
    real (kind=8), INTENT(IN OUT)            :: dyp(my)
    real (kind=8), INTENT(IN OUT)            :: dypp(my)
    real (kind=8), INTENT(IN OUT)            :: pjm(mx)
    real (kind=8), INTENT(IN OUT)            :: pj(mx)
    real (kind=8), INTENT(IN OUT)            :: pjp(mx)
    real (kind=8), INTENT(IN OUT)            :: pjpp(mx)
    INTEGER, INTENT(IN OUT)                  :: ix(mx)
    real (kind=8), INTENT(IN OUT)            :: dxm(mx)
    real (kind=8), INTENT(IN OUT)            :: dx(mx)
    real (kind=8), INTENT(IN OUT)            :: dxp(mx)
    real (kind=8), INTENT(IN OUT)            :: dxpp(mx)

    INTEGER :: k,kk,iijj,ksave

    IF (intpol(2) == 1) THEN

    !     linear in y

      ksave = -1
      DO kk=1,mz
        k = kz(kk)
        IF (k == ksave) THEN

    !     k pointer has not moved since last pass (no updates or interpolation)

        ELSE IF (k == ksave+1) THEN

    !     update k and interpolate k+1

          DO iijj=1,mxmy
            pk(iijj) = pkp(iijj)
          END DO
          CALL lint2(nx,ny,p(1,1,k+1),mx,my,pkp,intpol,jy,dy,  &
              pj,pjp,ix,dxm,dx,dxp,dxpp)
        ELSE

    !     interpolate k,k+1 in pk,pkp on xx,yy mesh

          CALL lint2(nx,ny,p(1,1,k),mx,my,pk,intpol,jy,dy,  &
              pj,pjp,ix,dxm,dx,dxp,dxpp)
          CALL lint2(nx,ny,p(1,1,k+1),mx,my,pkp,intpol,jy,dy,  &
              pj,pjp,ix,dxm,dx,dxp,dxpp)
        END IF

    !     save k pointer for next pass

        ksave = k

    !     linearly interpolate q(ii,jj,k) from pk,pkp in z direction

        DO iijj=1,mxmy
          q(iijj,kk) = pk(iijj)+dz(kk)*(pkp(iijj)-pk(iijj))
        END DO
      END DO
      RETURN

    ELSE

    !     cubic in y

      ksave = -1
      DO kk=1,mz
        k = kz(kk)
        IF (k == ksave) THEN

    !     k pointer has not moved since last pass (no updates or interpolation)

        ELSE IF (k == ksave+1) THEN

    !     update k and interpolate k+1

          DO iijj=1,mxmy
            pk(iijj) = pkp(iijj)
          END DO
          CALL cubt2(nx,ny,p(1,1,k+1),mx,my,pkp,intpol,  &
              jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp,ix,dxm,dx,dxp,dxpp)
        ELSE

    !     interpolate k,k+1 in pk,pkp on xx,yy mesh

          CALL cubt2(nx,ny,p(1,1,k),mx,my,pk,intpol,  &
              jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp,ix,dxm,dx,dxp,dxpp)
          CALL cubt2(nx,ny,p(1,1,k+1),mx,my,pkp,intpol,  &
              jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp,ix,dxm,dx,dxp,dxpp)
        END IF

    !     save k pointer for next pass

        ksave = k

    !     linearly interpolate q(ii,jj,k) from pk,pkp in z direction

        DO iijj=1,mxmy
          q(iijj,kk) = pk(iijj)+dz(kk)*(pkp(iijj)-pk(iijj))
        END DO
      END DO
      RETURN

    END IF
    END SUBROUTINE lint3

    SUBROUTINE cubt3(nx,ny,nz,p,mx,my,mxmy,mz,q,intpol,  &
        kz,dzm,dz,dzp,dzpp,pkm,pk,pkp,pkpp,jy,dym,dy,dyp,dypp,pjm,pj,  &
        pjp,pjpp,ix,dxm,dx,dxp,dxpp)

    !     cubically interpolate in z

    IMPLICIT NONE
    INTEGER, INTENT(IN)                      :: nx
    INTEGER, INTENT(IN)                      :: ny
    INTEGER, INTENT(IN)                      :: nz
    real (kind=8), INTENT(IN)                :: p(nx,ny,nz)
    INTEGER, INTENT(IN)                      :: mx
    INTEGER, INTENT(IN)                      :: my
    INTEGER, INTENT(IN)                      :: mxmy
    INTEGER, INTENT(IN)                      :: mz
    real (kind=8), INTENT(OUT)               :: q(mxmy,mz)
    INTEGER, INTENT(IN)                      :: intpol(3)
    INTEGER, INTENT(IN)                      :: kz(mz)
    real (kind=8), INTENT(IN)                :: dzm(mz)
    real (kind=8), INTENT(IN)                :: dz(mz)
    real (kind=8), INTENT(IN OUT)            :: dzp(mz)
    real (kind=8), INTENT(IN OUT)            :: dzpp(mz)
    real (kind=8), INTENT(OUT)               :: pkm(mxmy)
    real (kind=8), INTENT(IN OUT)            :: pk(mxmy)
    real (kind=8), INTENT(IN OUT)            :: pkp(mxmy)
    real (kind=8), INTENT(IN OUT)            :: pkpp(mxmy)
    INTEGER, INTENT(IN OUT)                  :: jy(my)
    real (kind=8), INTENT(IN OUT)            :: dym(my)
    real (kind=8), INTENT(IN OUT)            :: dy(my)
    real (kind=8), INTENT(IN OUT)            :: dyp(my)
    real (kind=8), INTENT(IN OUT)            :: dypp(my)
    real (kind=8), INTENT(IN OUT)            :: pjm(mx)
    real (kind=8), INTENT(IN OUT)            :: pj(mx)
    real (kind=8), INTENT(IN OUT)            :: pjp(mx)
    real (kind=8), INTENT(IN OUT)            :: pjpp(mx)
    INTEGER, INTENT(IN OUT)                  :: ix(mx)
    real (kind=8), INTENT(IN OUT)            :: dxm(mx)
    real (kind=8), INTENT(IN OUT)            :: dx(mx)
    real (kind=8), INTENT(IN OUT)            :: dxp(mx)
    real (kind=8), INTENT(IN OUT)            :: dxpp(mx)
    INTEGER :: k,kk,ksave,iijj

    IF (intpol(2) == 1) THEN

    !       linear in y

      ksave = -3
      DO kk=1,mz
        k = kz(kk)
        IF (k == ksave) THEN

    !       k pointer has not moved since last pass (no updates or interpolation)

        ELSE IF (k == ksave+1) THEN

    !       update k-1,k,k+1 and interpolate k+2

          DO iijj=1,mxmy
            pkm(iijj) = pk(iijj)
            pk(iijj) = pkp(iijj)
            pkp(iijj) = pkpp(iijj)
          END DO
          CALL lint2(nx,ny,p(1,1,k+2),mx,my,pkpp,  &
              intpol,jy,dy,pj,pjp,ix,dxm,dx,dxp,dxpp)
        ELSE IF (k == ksave+2) THEN

    !       update k-1,k and interpolate k+1,k+2

          DO iijj=1,mxmy
            pkm(iijj) = pkp(iijj)
            pk(iijj) = pkpp(iijj)
          END DO
          CALL lint2(nx,ny,p(1,1,k+1),mx,my,pkp,  &
              intpol,jy,dy,pj,pjp,ix,dxm,dx,dxp,dxpp)
          CALL lint2(nx,ny,p(1,1,k+2),mx,my,pkpp,  &
              intpol,jy,dy,pj,pjp,ix,dxm,dx,dxp,dxpp)
        ELSE IF (k == ksave+3) THEN

    !       update k-1 and interpolate k,k+1,k+2

          DO iijj=1,mxmy
            pkm(iijj) = pkpp(iijj)
          END DO
          CALL lint2(nx,ny,p(1,1,k),mx,my,pk,  &
              intpol,jy,dy,pj,pjp,ix,dxm,dx,dxp,dxpp)
          CALL lint2(nx,ny,p(1,1,k+1),mx,my,pkp,  &
              intpol,jy,dy,pj,pjp,ix,dxm,dx,dxp,dxpp)
          CALL lint2(nx,ny,p(1,1,k+2),mx,my,pkpp,  &
              intpol,jy,dy,pj,pjp,ix,dxm,dx,dxp,dxpp)
        ELSE

    !       interpolate all four k-1,k,k+1,k+2

          CALL lint2(nx,ny,p(1,1,k-1),mx,my,pkm,  &
              intpol,jy,dy,pj,pjp,ix,dxm,dx,dxp,dxpp)
          CALL lint2(nx,ny,p(1,1,k),mx,my,pk,  &
              intpol,jy,dy,pj,pjp,ix,dxm,dx,dxp,dxpp)
          CALL lint2(nx,ny,p(1,1,k+1),mx,my,pkp,  &
              intpol,jy,dy,pj,pjp,ix,dxm,dx,dxp,dxpp)
          CALL lint2(nx,ny,p(1,1,k+2),mx,my,pkpp,  &
              intpol,jy,dy,pj,pjp,ix,dxm,dx,dxp,dxpp)
        END IF

    !       save k pointer for next pass

        ksave = k

    !       cubically interpolate q(ii,jj,kk) from pkm,pk,pkp,pkpp in z direction

        DO iijj=1,mxmy
          q(iijj,kk) = dzm(kk)*pkm(iijj) + dz(kk)*pk(iijj) +  &
              dzp(kk)*pkp(iijj) + dzpp(kk)*pkpp(iijj)
        END DO
      END DO
      RETURN

    ELSE

    !       cubic in y

      ksave = -3
      DO kk=1,mz
        k = kz(kk)
        IF (k == ksave) THEN

    !       k pointer has not moved since last pass (no updates or interpolation)

        ELSE IF (k == ksave+1) THEN

    !       update k-1,k,k+1 and interpolate k+2

          DO iijj=1,mxmy
            pkm(iijj) = pk(iijj)
            pk(iijj) = pkp(iijj)
            pkp(iijj) = pkpp(iijj)
          END DO
          CALL cubt2(nx,ny,p(1,1,k+2),mx,my,pkpp,intpol,jy,dym,dy,  &
              dyp,dypp,pjm,pj,pjp,pjpp,ix,dxm,dx,dxp,dxpp)
        ELSE IF (k == ksave+2) THEN

    !       update k-1,k and interpolate k+1,k+2

          DO iijj=1,mxmy
            pkm(iijj) = pkp(iijj)
            pk(iijj) = pkpp(iijj)
          END DO
          CALL cubt2(nx,ny,p(1,1,k+1),mx,my,pkp,intpol,jy,dym,dy,  &
              dyp,dypp,pjm,pj,pjp,pjpp,ix,dxm,dx,dxp,dxpp)
          CALL cubt2(nx,ny,p(1,1,k+2),mx,my,pkpp,intpol,jy,dym,dy,  &
              dyp,dypp,pjm,pj,pjp,pjpp,ix,dxm,dx,dxp,dxpp)
        ELSE IF (k == ksave+3) THEN

    !       update k-1 and interpolate k,k+1,k+2

          DO iijj=1,mxmy
            pkm(iijj) = pkpp(iijj)
          END DO
          CALL cubt2(nx,ny,p(1,1,k),mx,my,pk,intpol,  &
              jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp,ix,dxm,dx,dxp,dxpp)
          CALL cubt2(nx,ny,p(1,1,k+1),mx,my,pkp,intpol,  &
              jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp,ix,dxm,dx,dxp,dxpp)
          CALL cubt2(nx,ny,p(1,1,k+2),mx,my,pkpp,intpol,  &
              jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp,ix,dxm,dx,dxp,dxpp)
        ELSE

    !     interpolate all four k-1,k,k+1,k+2

          CALL cubt2(nx,ny,p(1,1,k-1),mx,my,pkm,intpol,  &
              jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp,ix,dxm,dx,dxp,dxpp)
          CALL cubt2(nx,ny,p(1,1,k),mx,my,pk,intpol,  &
              jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp,ix,dxm,dx,dxp,dxpp)
          CALL cubt2(nx,ny,p(1,1,k+1),mx,my,pkp,intpol,  &
              jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp,ix,dxm,dx,dxp,dxpp)
          CALL cubt2(nx,ny,p(1,1,k+2),mx,my,pkpp,intpol,  &
              jy,dym,dy,dyp,dypp,pjm,pj,pjp,pjpp,ix,dxm,dx,dxp,dxpp)

        END IF

    !       save k pointer for next pass

        ksave = k

    !       cubically interpolate q(ii,jj,kk) from pkm,pk,pkp,pkpp in z direction

        DO iijj=1,mxmy
          q(iijj,kk) = dzm(kk)*pkm(iijj) + dz(kk)*pk(iijj) +  &
              dzp(kk)*pkp(iijj) + dzpp(kk)*pkpp(iijj)
        END DO
      END DO
      RETURN
    END IF

    END SUBROUTINE cubt3
end module


program number_precision
implicit none
integer*2:: int_result_2
integer*4:: int_result_4
real*4:: single_result
real*8:: pi = acos(-1.d0), double_result

int_result_2 = 2000000+1
int_result_4 = 2000000+1

write(*,*) int_result_2, int_result_4

single_result = real(pi)*10.0**32+sqrt(2.0)*10.0**21
double_result = pi*10.d0**32+sqrt(2.d0)*10.d0**21

write(*,*) single_result, double_result

end program number_precision


!! Pros:
!!
!!- A user only needs to use the extends(abstract_operator) and define
!!  the apply subroutine to use any Krylov solver.
!!
!!- Defining block matrices, combination of matrices and product
!!  matrices is trivial
!!
!!- Preconditoners are just some particular abstract operators.
!!
!! Cons.
!! - In same cases, we could save memory and computational power
!! defing other application like y=Ax+y instead of y=Ax. But these
!! savings are small and compromise readibility and flexibility of the
!! approach.
module AbstractOperators
  !! Module containg the abstract class parent of
  !! all operator classes defined on standard Fortran Vector
  use DVectors
  implicit none
  public :: abstract_operator, application
  type, abstract :: abstract_operator
     !! Abstract type defining base general operator

     !! Members shared by any operator:
     !! Number of columns (the domain of the application)
     integer :: ncol=0

     !! Number of rows (the co-domain of the application)
     integer :: nrow=0

     !! Logical flag for symmetry
     logical :: is_symmetric=.false.

     !! Real estimating the non linearity of the application, defined
     !! as: nonlinearity = |OP(x)+OP(y)-OP(x+y)|/(max(|x|,|y|,|x+y|)
     !! It is zero (the defualt value) for linear operators (up to
     !! machine precision). It may be greater that zero for quasi
     !! linear operator like inverse operator.
     double precision :: nonlinearity = 0.0d0
   contains
     !! Procedure for the application of the operator on a vector.
     procedure(application), deferred :: apply
  end type abstract_operator

  abstract interface
     !! Abstract procedure defining the interface for a general
     !! application actions
     !!
     !! y = M(x) = ( M*x if M is linear)
     subroutine application(this,vec_in,vec_out,ierr)
       import abstract_operator
       import dvector
       implicit none
       !! The class with all quantities describing the operator
       class(abstract_operator), intent(inout) :: this
       !! The input" vector
       class(dvector),        intent(in   ) :: vec_in
       !! The output vector y= "operator apllied on" x
       class(dvector),        intent(inout) :: vec_out
       !! An integer flag to inform about error
       !! It is zero if no error occured
       integer,                          intent(inout) :: ierr
     end subroutine application
  end interface
end module AbstractOperators


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

C=======================================================================
*DECK,VOL
      SUBROUTINE VOL (ITYPE,XX,YY,ZZ,VOLUME)
C
C     ******************************************************************
C
C     SUBROUTINE TO FIND THE VOLUME OF AN ELEMENT
C
C     Called by ELTON3, ELTOND
C
C     ******************************************************************
C
      DIMENSION XX(*), YY(*), ZZ(*)
C
C     ******************************************************************
C
      IF (ITYPE .EQ. 3) THEN
C
C 4-node quad
C
        A1 = XX(1) - XX(3)
        B1 = YY(1) - YY(3)
        A2 = XX(2) - XX(4)
        B2 = YY(2) - YY(4)
        CCR = (A1 * B2) - (A2 * B1)
        VOLUME = 0.5 * ABS(CCR)
C
        RETURN
C
      ELSE IF (ITYPE .EQ. 10) THEN
C
C 8-node hex
C
        GR1 = ( YY(2)*(ZZ(6)-ZZ(3)-ZZ(4)+ZZ(5)) + YY(3)*(ZZ(2)-ZZ(4))
     &        + YY(4)*(ZZ(3)-ZZ(8)-ZZ(5)+ZZ(2))
     &        + YY(5)*(ZZ(8)-ZZ(6)-ZZ(2)+ZZ(4))
     &        + YY(6)*(ZZ(5)-ZZ(2)) + YY(8)*(ZZ(4)-ZZ(5)) ) / 12.
c
        GR2 = ( YY(3)*(ZZ(7)-ZZ(4)-ZZ(1)+ZZ(6)) + YY(4)*(ZZ(3)-ZZ(1))
     &        + YY(1)*(ZZ(4)-ZZ(5)-ZZ(6)+ZZ(3))
     &        + YY(6)*(ZZ(5)-ZZ(7)-ZZ(3)+ZZ(1))
     &        + YY(7)*(ZZ(6)-ZZ(3)) + YY(5)*(ZZ(1)-ZZ(6)) ) / 12.
c
        GR3 = ( YY(4)*(ZZ(8)-ZZ(1)-ZZ(2)+ZZ(7)) + YY(1)*(ZZ(4)-ZZ(2))
     &        + YY(2)*(ZZ(1)-ZZ(6)-ZZ(7)+ZZ(4))
     &        + YY(7)*(ZZ(6)-ZZ(8)-ZZ(4)+ZZ(2))
     &        + YY(8)*(ZZ(7)-ZZ(4)) + YY(6)*(ZZ(2)-ZZ(7)) ) / 12.
c
        GR4 = ( YY(1)*(ZZ(5)-ZZ(2)-ZZ(3)+ZZ(8)) + YY(2)*(ZZ(1)-ZZ(3))
     &        + YY(3)*(ZZ(2)-ZZ(7)-ZZ(8)+ZZ(1))
     &        + YY(8)*(ZZ(7)-ZZ(5)-ZZ(1)+ZZ(3))
     &        + YY(5)*(ZZ(8)-ZZ(1)) + YY(7)*(ZZ(3)-ZZ(8)) ) / 12.
c
        GR5 = ( YY(8)*(ZZ(4)-ZZ(7)-ZZ(6)+ZZ(1)) + YY(7)*(ZZ(8)-ZZ(6))
     &        + YY(6)*(ZZ(7)-ZZ(2)-ZZ(1)+ZZ(8))
     &        + YY(1)*(ZZ(2)-ZZ(4)-ZZ(8)+ZZ(6))
     &        + YY(4)*(ZZ(1)-ZZ(8)) + YY(2)*(ZZ(6)-ZZ(1)) ) / 12.
c
        GR6 = ( YY(5)*(ZZ(1)-ZZ(8)-ZZ(7)+ZZ(2)) + YY(8)*(ZZ(5)-ZZ(7))
     &        + YY(7)*(ZZ(8)-ZZ(3)-ZZ(2)+ZZ(5))
     &        + YY(2)*(ZZ(3)-ZZ(1)-ZZ(5)+ZZ(7))
     &        + YY(1)*(ZZ(2)-ZZ(5)) + YY(3)*(ZZ(7)-ZZ(2)) ) / 12.
c
        GR7 = ( YY(6)*(ZZ(2)-ZZ(5)-ZZ(8)+ZZ(3)) + YY(5)*(ZZ(6)-ZZ(8))
     &        + YY(8)*(ZZ(5)-ZZ(4)-ZZ(3)+ZZ(6))
     &        + YY(3)*(ZZ(4)-ZZ(2)-ZZ(6)+ZZ(8))
     &        + YY(2)*(ZZ(3)-ZZ(6)) + YY(4)*(ZZ(8)-ZZ(3)) ) / 12.
c
        GR8 = ( YY(7)*(ZZ(3)-ZZ(6)-ZZ(5)+ZZ(4)) + YY(6)*(ZZ(7)-ZZ(5))
     &        + YY(5)*(ZZ(6)-ZZ(1)-ZZ(4)+ZZ(7))
     &        + YY(4)*(ZZ(1)-ZZ(3)-ZZ(7)+ZZ(5))
     &        + YY(3)*(ZZ(4)-ZZ(7)) + YY(1)*(ZZ(5)-ZZ(4)) ) / 12.
c
        VOLUME = XX(1) * GR1 + XX(2) * GR2 + XX(3) * GR3 + XX(4) * GR4
     &         + XX(5) * GR5 + XX(6) * GR6 + XX(7) * GR7 + XX(8) * GR8
C
        RETURN
C
      ELSE IF (ITYPE .EQ. 13) THEN
C
C 4-node shell, ignore curvature
C
        A1 = XX(1) - XX(3)
        B1 = YY(1) - YY(3)
        C1 = ZZ(1) - ZZ(3)
        A2 = XX(2) - XX(4)
        B2 = YY(2) - YY(4)
        C2 = ZZ(2) - ZZ(4)
C
        ACR = (B1 * C2) - (B2 * C1)
        BCR = (A1 * C2) - (A2 * C1)
        CCR = (A1 * B2) - (A2 * B1)
C
        VOLUME = 0.5 * SQRT(ACR*ACR + BCR*BCR + CCR*CCR)
C
        RETURN
      ELSE IF (ITYPE .EQ. 6) THEN
C
C 4-node tet
C (process Key's 8-node tet the same way using first 4 nodes)
C
        Y12 = YY(1) - YY(2)
        Y13 = YY(1) - YY(3)
        Y14 = YY(1) - YY(4)
        Y24 = YY(2) - YY(4)
        Y34 = YY(3) - YY(4)
        Z12 = ZZ(1) - ZZ(2)
        Z13 = ZZ(1) - ZZ(3)
        Z14 = ZZ(1) - ZZ(4)
        Z24 = ZZ(2) - ZZ(4)
        Z34 = ZZ(3) - ZZ(4)
C
        BX1 = (Y34*Z24 - Y24*Z34) / 6.0
        BX2 = (Y13*Z14 - Y14*Z13) / 6.0
        BX3 = (Y14*Z12 - Y12*Z14) / 6.0
        BX4 = (Y12*Z13 - Y13*Z12) / 6.0
C
        VOLUME = BX1*XX(1) + BX2*XX(2) + BX3*XX(3) + BX4*XX(4)
      ELSE
        CALL ERROR('VOL','ELEMENT TYPE',' ',ITYPE,
     &             'NOT YET IMPLEMENTED',0,' ',' ',1)
      END IF
      RETURN
      END


program main

  use boxlib
  use parallel
  use multifab_module
  use advance_module
  use fabio_module

  implicit none
  integer, parameter :: DM = 3
  integer, parameter :: NG  = 4
  integer, parameter :: NC  = 5

!--------------------------------------------------------------
    integer                   :: ngrids,ib,j,k
    double precision, pointer :: dp(:,:,:,:)
    double precision :: xloc,yloc,zloc,rholoc,eloc,uvel,vvel,wvel,scale
!--------------------------------------------------------------
  integer            :: nsteps, n_cell, max_grid_size
  integer            :: un, farg, narg
  logical            :: need_inputs_file, found_inputs_file
  character(len=128) :: inputs_file_name
  integer            :: i, lo(DM), hi(DM), istep
  double precision   :: prob_lo(DM), prob_hi(DM), cfl, eta, alam
  double precision   :: dx(DM), dt, time, start_time, end_time
  logical            :: is_periodic(DM)
  type(box)          :: bx
  type(boxarray)     :: ba
  type(layout)       :: la
  type(multifab)     :: U
  double precision   :: sleep_start_time, sleep_end_time

  real(kind=dp_t) :: starts, ends

  call boxlib_initialize()

  sleep_start_time = parallel_wtime()
  call Sleep(1)
  sleep_end_time = parallel_wtime()
  if ( parallel_IOProcessor() ) then
     write(6,42),"Sleep time (s) =",sleep_end_time-sleep_start_time
  end if

  nsteps        = 1
  n_cell        = 64
  max_grid_size = 64
  cfl           = 0.5d0
  eta           = 1.8d-4
  alam          = 1.5d2

  prob_lo     = -2.3d0
  prob_hi     =  2.3d0
  is_periodic = .true.
  !
  lo = 0
  hi = n_cell-1
  bx = make_box(lo,hi)

  do i = 1,DM
     dx(i) = (prob_hi(i)-prob_lo(i)) / n_cell
     write(6,42),"dx = ", dx(i)
  end do

  call boxarray_build_bx(ba,bx)

  call boxarray_maxsize(ba,max_grid_size)

  call layout_build_ba(la,ba,boxarray_bbox(ba),pmask=is_periodic)

  call destroy(ba)

  call multifab_build(U,la,NC,NG)

!------------------------------------------------- initialize U
    ngrids = U%ng

    do ib=1,nfabs(U)
      dp => dataptr(U,ib)
      lo = lwb(get_box(U,ib))
      hi = upb(get_box(U,ib))
      scale = 1.0d0

      do k=lo(3)-ng,hi(3)+ng
         zloc = dfloat(k)*dx(3)/scale
         do j=lo(2)-ng,hi(2)+ng
            yloc = dfloat(j)*dx(2)/scale
            do i=lo(1)-ng,hi(1)+ng
               xloc = dfloat(i)*dx(1)/scale

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

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

            enddo
         enddo
      enddo
    end do

  call fabio_multifab_write_d(U, ".", "mfUInit", nOutfiles = 1)
!--------------------------------------------------------------

  istep = 0
  time  = 0.d0

  start_time = parallel_wtime()

  do istep=1,nsteps

     call advance(U,dt,dx,cfl,eta,alam)

     time = time + dt

  end do

  end_time = parallel_wtime()

  call destroy(U)
  call destroy(la)

  if ( parallel_IOProcessor() ) then
     write(6,42),"Run time (s) =",end_time-start_time
     write(6,42),"Run time per iteration (s) =",(end_time-start_time) / nsteps
     print *,"-----------------"
  end if

42  format(a,f12.8)

  call boxlib_finalize()

end program main


FUNCTION IGM_ABSORB(lam,spec,zz,factor)

  !routine to include IGM absorption via Madau (1995)
  !this routine includes a fudge factor (accessed by pset%igm_factor)
  !that allows the user to scale the IGM optical depth

  USE sps_vars; USE sps_utils, ONLY : locate
  IMPLICIT NONE

  REAL(SP), DIMENSION(nspec), INTENT(in) :: lam,spec
  REAL(SP), DIMENSION(nspec) :: igm_absorb,lobs,xc,tau
  REAL(SP), INTENT(in) :: zz,factor
  REAL(SP) :: z1,lylim,a_metal
  INTEGER, PARAMETER  :: nly=17
  INTEGER :: vv,i
  REAL(SP), DIMENSION(nly) :: lyw,lycoeff

  !--------------------------------------------------------------!

  lyw = (/1215.67, 1025.72, 972.537, 949.743, 937.803,&
          930.748, 926.226, 923.150, 920.963, 919.352,&
          918.129, 917.181, 916.429, 915.824, 915.329,&
          914.919, 914.576/)

  lycoeff = (/0.0036,0.0017,0.0011846,0.0009410,0.0007960,&
       0.0006967,0.0006236,0.0005665,0.0005200,0.0004817,&
       0.0004487,0.0004200,0.0003947,0.000372,0.000352,&
       0.0003334,0.00031644/)

  lylim   = 911.75
  a_metal = 0.0017

  z1   = 1+zz
  lobs = lam*z1
  xc   = lobs/lylim

  tau = 0.0

  !Ly series line blanketing
  DO i=1,nly
     IF (lam(1).GT.lyw(i)) CONTINUE
     vv = MIN(MAX(locate(lam,lyw(i)),1),nspec)
     tau(1:vv) = tau(1:vv) + lycoeff(i) * &
          (lobs(1:vv)/lyw(i))**3.46
     !add metal blanketing (this has ~no effect)
     IF (i.EQ.1) THEN
        tau(1:vv) = tau(1:vv)+a_metal*(lobs(1:vv)/lyw(i))**1.68
     ENDIF
  ENDDO

  !LyC absorption
  IF (lam(1).LT.lylim) THEN
     vv = MIN(MAX(locate(lam,lylim),1),nspec)
     !approximation to Eqn 16 in Madau (1995); see his footnote 3
     tau(1:vv) = tau(1:vv) + &
          (0.25*xc(1:vv)**3*(z1**0.46-xc(1:vv)**0.46)) + &
          (9.4*xc(1:vv)**1.5*(z1**0.18-xc(1:vv)**0.18)) - &
          (0.7*xc(1:vv)**3*(xc(1:vv)**(-1.32)-z1**(-1.32))) - &
          (0.023*(z1**1.68-xc(1:vv)**1.68))
  ENDIF

  !the LyC fitting function seems to fall apart at really short
  !wavelengths, so when tau starts to decrease, cap it at the max.
  vv = MAXLOC(tau,1)
  tau(1:vv) = tau(vv)

  !attenuate the input spectrum by the IGM
  !include a fudge factor to dial up/down the strength
  igm_absorb = spec * EXP(-tau*factor)

END FUNCTION IGM_ABSORB


program ch0904
    ! Imperial Pints and Litres
    implicit none

    integer :: fluid
    real :: litres
    real :: pints

    print *, ' Imperial      Litre(s)'
    print *, ' pint(s)               '
    do fluid = 1, 10
        litres = fluid/1.75
        pints = fluid*1.75
        print 100, pints, fluid, litres
    end do

100 format (' ', f6.2, '  ', i3, '   ', f5.2)
end program


      subroutine forit (fnt,n,m,a,b,ier)
C...subroutine     forit     01/ 9/73
C...subroutine     forit     01/09/78
      dimension fnt(1),a(1),b(1)
C        check for parametr errors
      ier=0
      if(m.ge.0) goto 40
      ier=2
      return
  40  if (m.le.n) goto 60
      ier=1
      return
C        compute and preset constants
  60  an=n
      coef=2.0/(2.0*an+1.0)
      const=3.141593*coef
      s1=sin(const)
      c1=cos(const)
      c=1.0
      s=0.0
      j=1
      fntz=fnt(1)
  70  u2=0.0
      u1=0.0
      i=2*n+1
C        form fourier coefficients recursively
  75  u0=fnt(i)+2.0*c*u1-u2
      u2=u1
      u1=u0
      i=i-1
      if (i.gt.1) goto 75
      a(j)=coef*(fntz+c*u1-u2)
      b(j)=coef*s*u1
      if (j.ge.(m+1)) goto 100
      q=c1*c-s1*s
      s=c1*s+s1*c
      c=q
      j=j+1
      goto 70
  100 a(1)=a(1)*0.5
      return
      end


c>> 2006-03-11 DRDSPGE  Krogh  Initial code.
c--D replaces "?": DR?SPGE, ?SPGE
c Demo driver for DRSPGE
      integer N, LA, LIA
      parameter (N=6, LA=300, LIA=LA+5*N)
      integer IA(LA+5*N), ISPEC(7), I, J, K
      double precision A(LA),OPT(3),SIZE,B(N),BB(N),X(N),ERRX,ERRRES
      data IA(1),A(1), IA(2),A(2), IA(3),A(3) /2,0.D0, 1,-2.D0, 4,1.D0/
      data IA(4),A(4), IA(5),A(5) /1,0.D0, 3,-2.E0/
      data IA(6),A(6), IA(7),A(7), IA(8),A(8) /2,0.D0, 2,-2.D0, 5,-2.D0/
      data IA( 9),A( 9), IA(10),A(10), IA(11),A(11), IA(12),A(12)  /
     1  3,0.D0, 1,-1.D0, 5,-1.D0, 6,2.D0 /
      data IA(13),A(13), IA(14),A(14), IA(15),A(15), IA(16),A(16),
     1  IA(17),A(17), IA(18),A(18) / 5,0.D0, 1,-1.D0, 2,-2.D0, 3,2.D0,
     2  4,-1.D0, 6,-2.D0 /
      data IA(19),A(19), IA(20),A(20), IA(21),A(21), IA(22),A(22) /
     1  3,0.D0,  1,-2.D0, 3,2.D0, 6,1.D0 /
      data X / -2.0D0, -1.0D0, -2.0D0, -1.0D0, -1.0D0, -1.0D0 /
      data B /  8.0D0,  6.0D0, -2.0D0, -1.0D0,  5.0D0, -1.0D0 /
      data ISPEC / 0, LIA, LA, 0, 3, 4, 0 /

      do 100 I = 1, N
         BB(I) = B(I)
 100  continue
c              Call DSPGE to get the solution
      call DSPGE(N, ISPEC, IA, A, B, OPT)
c            Get maximal errors in the residual and the solution.
      ERRRES = 0.D0
      SIZE = 0.D0
      K = 1
      do 280 J = 1, N
        do 270 I = K+1, K + IA(K)
          SIZE = max(SIZE, abs(A(I) * X(J)))
          BB(IA(I)) = BB(IA(I)) - A(I) * B(J)
 270    continue
        K = I
 280  continue
      do 300 J = 1, N
        ERRRES = max(ERRRES, abs(BB(J)))
 300  continue
      ERRRES = ERRRES / SIZE
      ERRX = 0.D0
      do 320 I = 1, N
        ERRX = max(ERRX, abs(X(I) - B(I)))
 320  continue

      I = int(log10(abs(OPT(2))))
      if (I .gt. 0) I = I + 1
      OPT(2) = OPT(2)*10.D0**(-I)
      I = I + nint(OPT(3))
      print '('' Problem     N   RESERR     XERR    Unused    Used'',
     1  ''    RCOND      DET   x10^?'')'
      print '(''DEMOTEST     6'',1P,2E10.2,2I8,E10.2,0PF9.5,I6)',
     1  ERRRES,ERRX,ISPEC(4),ISPEC(3)-ISPEC(4),OPT(1),OPT(2),I
      stop
      end


c>> 2006-03-11 DRSSPGE  Krogh  Initial code.
c--S replaces "?": DR?SPGE, ?SPGE
c Demo driver for DRSPGE
      integer N, LA, LIA
      parameter (N=6, LA=300, LIA=LA+5*N)
      integer IA(LA+5*N), ISPEC(7), I, J, K
      real             A(LA),OPT(3),SIZE,B(N),BB(N),X(N),ERRX,ERRRES
      data IA(1),A(1), IA(2),A(2), IA(3),A(3) /2,0.E0, 1,-2.E0, 4,1.E0/
      data IA(4),A(4), IA(5),A(5) /1,0.E0, 3,-2.E0/
      data IA(6),A(6), IA(7),A(7), IA(8),A(8) /2,0.E0, 2,-2.E0, 5,-2.E0/
      data IA( 9),A( 9), IA(10),A(10), IA(11),A(11), IA(12),A(12)  /
     1  3,0.E0, 1,-1.E0, 5,-1.E0, 6,2.E0 /
      data IA(13),A(13), IA(14),A(14), IA(15),A(15), IA(16),A(16),
     1  IA(17),A(17), IA(18),A(18) / 5,0.E0, 1,-1.E0, 2,-2.E0, 3,2.E0,
     2  4,-1.E0, 6,-2.E0 /
      data IA(19),A(19), IA(20),A(20), IA(21),A(21), IA(22),A(22) /
     1  3,0.E0,  1,-2.E0, 3,2.E0, 6,1.E0 /
      data X / -2.0E0, -1.0E0, -2.0E0, -1.0E0, -1.0E0, -1.0E0 /
      data B /  8.0E0,  6.0E0, -2.0E0, -1.0E0,  5.0E0, -1.0E0 /
      data ISPEC / 0, LIA, LA, 0, 3, 4, 0 /

      do 100 I = 1, N
         BB(I) = B(I)
 100  continue
c              Call SSPGE to get the solution
      call SSPGE(N, ISPEC, IA, A, B, OPT)
c            Get maximal errors in the residual and the solution.
      ERRRES = 0.E0
      SIZE = 0.E0
      K = 1
      do 280 J = 1, N
        do 270 I = K+1, K + IA(K)
          SIZE = max(SIZE, abs(A(I) * X(J)))
          BB(IA(I)) = BB(IA(I)) - A(I) * B(J)
 270    continue
        K = I
 280  continue
      do 300 J = 1, N
        ERRRES = max(ERRRES, abs(BB(J)))
 300  continue
      ERRRES = ERRRES / SIZE
      ERRX = 0.E0
      do 320 I = 1, N
        ERRX = max(ERRX, abs(X(I) - B(I)))
 320  continue

      I = int(log10(abs(OPT(2))))
      if (I .gt. 0) I = I + 1
      OPT(2) = OPT(2)*10.E0**(-I)
      I = I + nint(OPT(3))
      print '('' Problem     N   RESERR     XERR    Unused    Used'',
     1  ''    RCOND      DET   x10^?'')'
      print '(''DEMOTEST     6'',1P,2E10.2,2I8,E10.2,0PF9.5,I6)',
     1  ERRRES,ERRX,ISPEC(4),ISPEC(3)-ISPEC(4),OPT(1),OPT(2),I
      stop
      end


FUNCTION Source( Model, n, f ) RESULT(h)
   USE Lists
   TYPE(Model_t) :: Model
   INTEGER :: n
   REAL(KIND=dp) :: f, h, x, s

   INTEGER :: i, Step, OldStep = -1
   TYPE(Variable_t), POINTER :: T, P

    T => VariableGet( Model % Variables, 'Time' )
    Step = NINT( T % Values(1) )

    P => VariableGet( Model % Variables, 'Potential' )

!   First check the previous result
!   -------------------------------
    IF ( Step>1 .AND. Step /= OldStep ) THEN
       DO i=1,Model % NumberOfNodes
          x = Model % Nodes % x(i)
          s = P % Values( P % Perm(i) )
          SELECT CASE(Step)
             CASE(2) ! can we solve a zero field ?
                IF ( s /= 0 ) &
                   CALL Fatal( 'Source', 'Not able to integrate a zero field ?')
             CASE(3) ! how about a  parabola ?
                IF ( ABS(s+(x**2-PI*x)/2) > 1.0d-10 ) &
                   CALL Fatal( 'Source', 'Not able to integrate parabola ?' )
             CASE(4) ! how about a third degree polynomial
                IF ( ABS(s+(x**3-PI**2*x)/6) > 1.0d-10 ) &
                   CALL Fatal( 'Source', 'Not able to integrate 3d deg polynomial?' )
             CASE(5) ! how about a sine
                IF ( ABS(s-2*sin(x)) > 1.0d-4 ) &
                   CALL Fatal( 'Source', 'Not able to integrate sine?' )
          END SELECT
       END DO
       OldStep = Step
    END IF

!   Then define new one
!   -------------------
    x = Model % Nodes % x(n)

    SELECT CASE(Step)
       CASE(1) ! can we solve a zero field ?
          h = 0
       CASE(2) ! how about a  parabola ?
          h = 1
       CASE(3) ! how about a third degree polynomial
          h = x
       CASE(4) ! how about a sine
          h = f
       CASE(5) ! how about a sine
          h = f
    END SELECT
END FUNCTION Source


( -*- text -*- )

: TEST
	1 0 < . CR
	0 1 < . CR
	1 -1 < . CR
	-1 1 < . CR
	-1 0 < . CR
	0 -1 < . CR CR

	1 0 > . CR
	0 1 > . CR
	1 -1 > . CR
	-1 1 > . CR
	-1 0 > . CR
	0 -1 > . CR CR

	1 1 <= . CR
	0 0 <= . CR
	-1 -1 <= . CR
	1 0 <= . CR
	0 1 <= . CR
	1 -1 <= . CR
	-1 1 <= . CR
	-1 0 <= . CR
	0 -1 <= . CR CR

	1 1 >= . CR
	0 0 >= . CR
	-1 -1 >= . CR
	1 0 >= . CR
	0 1 >= . CR
	1 -1 >= . CR
	-1 1 >= . CR
	-1 0 >= . CR
	0 -1 >= . CR CR

	1 1 = . CR
	1 0 = . CR
	0 0 = . CR
	1 -1 = . CR
	-1 -1 = . CR CR

	1 1 <> . CR
	1 0 <> . CR
	0 0 <> . CR
	1 -1 <> . CR
	-1 -1 <> . CR CR

	1 0= . CR
	0 0= . CR
	-1 0= . CR CR

	1 0<> . CR
	0 0<> . CR
	-1 0<> . CR CR

	1 0< . CR
	0 0< . CR
	-1 0< . CR CR

	1 0> . CR
	0 0> . CR
	-1 0> . CR CR

	1 0<= . CR
	0 0<= . CR
	-1 0<= . CR CR

	1 0>= . CR
	0 0>= . CR
	-1 0>= . CR CR
;


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

*   Intrinsic (double complex) names passed as arguments.
*   (all intrinsics which are allowed to be passed are tested once).

	parameter(n = 7)
	implicit real*8 (d)
	integer rslts(n), expect(n)

	integer ztoi
	intrinsic dconjg, cdsqrt, cdexp, cdlog, cdsin, cdcos
	intrinsic cdabs

	rslts(1) = ztoi((1.0d0, 2.0d0),  dconjg)
	rslts(2) = ztoi((2.0d0, -3.0d0), cdsqrt)
	rslts(3) = ztoi((-1.0d0, 1.0d0), cdexp)
	rslts(4) = ztoi((3.0d0, 4.0d0),  cdlog)
	rslts(5) = ztoi((3.0d0, 4.0d0),  cdsin)
	rslts(6) = ztoi((3.0d0, 4.0d0),  cdcos)

c  --- tests 7:  cdabs

	call sub4(rslts(7), cdabs)

c  --- check results:

	call check(rslts, expect, n)

	data expect /
     +       980, 1665, 201, 1618, 3583, -27073,
     +       5
     +              /
	end

c ccccccccccccccccccccccccccccccccccccccccccccccccccccccc

	integer function ztoi(c, f)
	double complex c, f, t
	external f

	t = f(c)
	ztoi = real(t) * 1000 + dimag(t) * 10
	end

	subroutine sub4(a, cdabs)
	external cdabs
	double precision cdabs
	integer a(*)

	a(1) = cdabs((3.1d0, 4.0d0))
	end


      program prog
      real data(2, 3)
      do i=1,2
        do j=1,3
          data(i,j) = i+10*j
        enddo
      enddo
      do j=1,3
        do i=1,2
          write(6, *) data(i,j)
        enddo
      enddo
      end


program hello
    ! Importing a module
    use vector_math

    implicit none

    ! Variable Declaration
    double precision, dimension(6) :: vec
    double precision, allocatable, dimension(:) :: new_vec
    integer(1) :: i, n

    ! Hello, World!
    print *, "Hello, World!"

    n = size(vec)
    ! Using a function from the module
    new_vec = vector_sin(vec)
    do i = 1, (n -1)
        print *, "Sin(", i, "*pi/", n, ") =", new_vec(i)
    end do

end program hello


module precision

  integer, parameter :: fqp = selected_real_kind(20, 200)
  integer, parameter :: fdp = selected_real_kind(10, 200)
  integer, parameter :: fsp = selected_real_kind(5, 50)
  integer, parameter :: idp = selected_int_kind(9)
  integer, parameter :: isp = selected_int_kind(6)
  integer, parameter :: cdp = fdp
  integer, parameter :: csp = fsp

end module precision


! { dg-do compile }
! { dg-options "-std=f2003 -fdump-tree-original" }

! PR fortran/38936
! Check that array expression association (with correct bounds) works for
! complicated expressions.

! Contributed by Daniel Kraft, d@domob.eu.

MODULE m
  IMPLICIT NONE

CONTAINS

  PURE FUNCTION func (n)
    INTEGER, INTENT(IN) :: n
    INTEGER :: func(2 : n+1)

    INTEGER :: i

    func = (/ (i, i = 1, n) /)
  END FUNCTION func

END MODULE m

PROGRAM main
  USE :: m
  IMPLICIT NONE

  ASSOCIATE (arr => func (4))
    ! func should only be called once here, not again for the bounds!

    IF (LBOUND (arr, 1) /= 1 .OR. UBOUND (arr, 1) /= 4) CALL abort ()
    IF (arr(1) /= 1 .OR. arr(4) /= 4) CALL abort ()
  END ASSOCIATE
END PROGRAM main
! { dg-final { cleanup-modules "m" } }
! { dg-final { scan-tree-dump-times "func" 2 "original" } }
! { dg-final { cleanup-tree-dump "original" } }


!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++!
!                          Futility Development Group                          !
!                             All rights reserved.                             !
!                                                                              !
! Futility is a jointly-maintained, open-source project between the University !
! of Michigan and Oak Ridge National Laboratory.  The copyright and license    !
! can be found in LICENSE.txt in the head directory of this repository.        !
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++!
!> @brief A Fortran 2003 module defining "lines" for use in geometry.
!>
!> This module provides a derived data types for a "line" it is implicitly
!> for 1-D, 2-D, or 3-D space and this is determined by its members.
!> The line is defined by two points. The module also provides methods for
!> constructing the line, clearing its members, and getting the length of the
!> line, its midpoint, or an intersection with another line.
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++!
MODULE Geom_Line
USE IntrType
USE Geom_Points

IMPLICIT NONE
PRIVATE !Default contents of module to private
!
! List of Public items
PUBLIC :: LineType
PUBLIC :: OPERATOR(==)

!> @brief Type for a Line
!>
!> It is defined by 2 points and is implicitly 1-D, 2-D, or 3-D.
TYPE :: LineType
  !> The points definint the line segment p(1) is the starting point
  !> p(2) is the ending point
  TYPE(PointType) :: p1
  TYPE(PointType) :: p2
!
!List of type bound procedures
  CONTAINS
    !> @copybrief GeomLine::init_LineType
    !> @copydetails GeomLine::init_LineType
    PROCEDURE,PASS :: set => init_LineType
    !> @copybrief GeomLine::clear_LineType
    !> @copydetails GeomLine::clear_LineType
    PROCEDURE,PASS :: clear => clear_LineType
    !> @copybrief GeomLine::dim_LineType
    !> @copydetails GeomLine::dim_LineType
    PROCEDURE,PASS :: getDim => dim_LineType
    !> @copybrief GeomLine::length_lineType
    !> @copydetails GeomLine::length_lineType
    PROCEDURE,PASS :: length => length_lineType
    !> @copybrief GeomLine::midPointLine
    !> @copydetails GeomLine::midPointLine
    PROCEDURE,PASS :: midPoint => midPoint_LineType
    !> @copybrief GeomLine::intersect_LineType_and_LineType
    !> @copydetails GeomLine::intersect_LineType_and_LineType
    PROCEDURE,PASS :: intersect => intersect_LineType_and_LineType
    PROCEDURE,PASS :: intersectLine => intersect_LineType_and_LineType
    !> @copybrief GeomLine::distance_LineType_to_PointType
    !> @copydetails GeomLine::distance_LineType_to_PointType
    PROCEDURE,PASS :: distance2Point => distance_LineType_to_PointType
    !> @copybrief GeomLine::distance_LineType_to_LineType
    !> @copydetails GeomLine::distance_LineType_to_LineType
    PROCEDURE,PASS :: distance2Line => distance_LineType_to_LineType
    !> @copybrief GeomLine::pointIsLeft_LineType
    !> @copydetails GeomLine::pointIsLeft_LineType
    PROCEDURE,PASS :: pointIsLeft => pointIsLeft_LineType
    !> @copybrief GeomLine::pointIsRight_LineType
    !> @copydetails GeomLine::pointIsRight_LineType
    PROCEDURE,PASS :: pointIsRight => pointIsRight_LineType
ENDTYPE LineType

!> @brief Generic interface for 'is equal to' operator (==)
!>
!> Adds 'is equal to' capability for Line types
INTERFACE OPERATOR(==)
  !> @copybrief Geom_Line::isequal_LineType
  !> @copydetails Geom_Line::isequal_LineType
  MODULE PROCEDURE isequal_LineType
ENDINTERFACE
!
!===============================================================================
CONTAINS
!
!-------------------------------------------------------------------------------
!> @brief Constructor for LineType
!> @param sp the starting point of the line
!> @param ep the end point of the line
!> @returns line the LineType object
!>
!> If sp and ep are not of the same type line is returned as NULL.
ELEMENTAL SUBROUTINE init_LineType(line,sp,ep)
  CLASS(LineType),INTENT(INOUT) :: line
  TYPE(PointType),INTENT(IN) :: sp,ep
  CALL line%clear()
  IF(sp%dim == ep%dim .AND. sp%dim > 0) THEN
    line%p1=sp
    line%p2=ep
  ENDIF
ENDSUBROUTINE init_LineType
!
!-------------------------------------------------------------------------------
!> @brief Deallocates the @c sp and @c ep components of line
!> @param line line segment of type @c LineType
ELEMENTAL SUBROUTINE clear_LineType(line)
  CLASS(LineType),INTENT(INOUT) :: line
  CALL line%p1%clear()
  CALL line%p2%clear()
ENDSUBROUTINE clear_LineType
!
!-------------------------------------------------------------------------------
!> @brief Returns the dimension of the LineType @e line
!> @param line line segment of type @c LineType
!> @returns @c n the dimension of LineType @c line
ELEMENTAL FUNCTION dim_LineType(line) RESULT(n)
  CLASS(LineType),INTENT(IN) :: line
  INTEGER(SIK) :: n
  n=0
  IF(line%p1%dim == line%p2%dim .AND. line%p1%dim > 0) n=line%p1%dim
ENDFUNCTION dim_LineType
!
!-------------------------------------------------------------------------------
!> @brief Computes the length of a line segment defined by 2 points
!> @param line line segment of type @c LineType
!> @returns @c length the length of @c line
ELEMENTAL FUNCTION length_LineType(line) RESULT(length)
  CLASS(LineType),INTENT(IN) :: line
  REAL(SRK) :: length
  length=Distance(line%p1,line%p2)
ENDFUNCTION length_LineType
!
!-------------------------------------------------------------------------------
!> @brief Computes the midpoint of line defined by two points
!> @param line line segment of type @c LineType
!> @returns @c p the midpoint of @c line
ELEMENTAL FUNCTION midPoint_LineType(line) RESULT(p)
  CLASS(LineType),INTENT(IN) :: line
  TYPE(PointType) :: p
  p=midPoint(line%p1,line%p2)
ENDFUNCTION midPoint_LineType
!
!-------------------------------------------------------------------------------
!> @brief Finds the intersection between 2 line segments (if it exists)
!> @param l1 the line to test for intersection
!> @param l2 the other line to test for intersection
!> @returns @c p the point of intersection
!> @note a return code is assigned to p%dim indicating the type of
!> intersection.
!>   -3: there is no intersection (disjoint)
!>   -2: the line segments overlap
!>   -1: problem with dummy arguments passed to routine
!>  > 0: success; an intersection point was found
ELEMENTAL FUNCTION intersect_LineType_and_LineType(l1,l2) RESULT(p)
  CLASS(LineType),INTENT(IN) :: l1
  TYPE(LineType),INTENT(IN) :: l2
  TYPE(PointType) :: p
  p%dim=-1
  IF(l1%p1%dim == l1%p2%dim .AND. l2%p1%dim == l2%p2%dim .AND. &
      l1%p1%dim == l2%p1%dim .AND. l1%p1%dim > 0) THEN
    SELECTCASE(l1%p1%dim)
    CASE(1)
      p%dim=-2 !Always collinear/overlap
    CASE(2)
      p=intersect_lines2D(l1%p1,l1%p2,l2%p1,l2%p2)
    CASE(3)
      p=intersect_lines3D(l1%p1,l1%p2,l2%p1,l2%p2)
    ENDSELECT
  ENDIF
ENDFUNCTION intersect_LineType_and_LineType
!
!-------------------------------------------------------------------------------
!> @brief Finds the intersection between two 2-D line segments (if it exists)
!> @param s1p0 the line to test for intersection
!> @param s1p1 the line to test for intersection
!> @param s2p0 the line to test for intersection
!> @param s2p1 the line to test for intersection
!> @returns @c p the point of intersection (if it exists)
!> @note a return code is assigned to p%dim indicating the type of
!> intersection.
!>   -3: there is no intersection (disjoint)
!>   -2: the line segments overlap
!>  > 0: success; an intersection point was found
ELEMENTAL FUNCTION intersect_lines2D(s1p0,s1p1,s2p0,s2p1) RESULT(p)
  TYPE(PointType),INTENT(IN) :: s1p0,s1p1,s2p0,s2p1
  TYPE(PointType) :: p
  REAL(SRK) :: u(2),v(2),w(2),d,s,t
  u(1)=s1p1%coord(1)-s1p0%coord(1)
  u(2)=s1p1%coord(2)-s1p0%coord(2)
  v(1)=s2p1%coord(1)-s2p0%coord(1)
  v(2)=s2p1%coord(2)-s2p0%coord(2)
  w(1)=s1p0%coord(1)-s2p0%coord(1)
  w(2)=s1p0%coord(2)-s2p0%coord(2)
  d=u(1)*v(2)-u(2)*v(1)
  s=v(1)*w(2)-v(2)*w(1)
  t=u(1)*w(2)-u(2)*w(1)
  IF(ABS(d) < EPSREAL) THEN
    !Segments are collinear
    IF(s /= 0._SRK .OR. t /= 0._SRK) THEN
      p%dim=-3 !parallel lines
    ELSE
      p%dim=-2 !overlap
    ENDIF
  ELSE
    s=s/d
    t=t/d
    IF(((0._SRK .APPROXLE. s) .AND. (s .APPROXLE. 1.0_SRK)) .AND. &
        ((0._SRK .APPROXLE. t) .AND. (t .APPROXLE. 1.0_SRK))) THEN
      !Success, intersection point was found.
      p=s1p0
      p%coord(1)=p%coord(1)+s*u(1)
      p%coord(2)=p%coord(2)+s*u(2)
    ELSE
      !would intersect if segments were infinite. Still store how close it
      !was though. this is useful for calling routines that might need to
      !know that the point was close (i.e. Coarse ray trace)
      p=s1p0
      p%dim=-3
      p%coord(1)=p%coord(1)+s*u(1)
      p%coord(2)=p%coord(2)+s*u(2)
    ENDIF
  ENDIF
ENDFUNCTION intersect_lines2D
!
!-------------------------------------------------------------------------------
!> @brief Finds the intersection between two 3-D line segments (if it exists)
!> @param s1p0 the line to test for intersection
!> @param s1p1 the line to test for intersection
!> @param s2p0 the line to test for intersection
!> @param s2p1 the line to test for intersection
!> @returns @c p the point of intersection (if it exists)
!> @note a return code is assigned to p%dim indicating the type of
!> intersection.
!>   -3: there is no intersection (disjoint)
!>   -2: the line segments overlap
!>  > 0: success; an intersection point was found
!>
ELEMENTAL FUNCTION intersect_lines3D(s1p0,s1p1,s2p0,s2p1) RESULT(p)
TYPE(PointType),INTENT(IN) :: s1p0,s1p1,s2p0,s2p1
  TYPE(PointType) :: p

  TYPE(LineType) :: s1,s2,dis
  REAL(SRK) :: mu1,mu2
  INTEGER(SIK) :: thisDim
  REAL(SRK) :: EPSREAL_LOCAL

  EPSREAL_LOCAL=EPSREAL*100._SRK
  p%dim=-3
  s1%p1=s1p0
  s1%p2=s1p1
  s2%p1=s2p0
  s2%p2=s2p1
  CALL distance_LineType_to_LineType(s1,s2,dis,mu1,mu2)
  thisDim=dis%p1%dim
  IF(thisDim > 0) THEN
    IF(0._SRK-EPSREAL_LOCAL <= mu1 .AND. mu1 <= 1._SRK+EPSREAL_LOCAL &
        .AND. 0._SRK-EPSREAL_LOCAL <= mu2 .AND. mu2 <= 1._SRK+EPSREAL_LOCAL &
        .AND. dis%length() < EPSREAL_LOCAL) THEN
      p=dis%p1
    ENDIF
  ELSEIF(thisDim == -2) THEN
    p%dim=-2
  ENDIF
  CALL s1%clear()
  CALL s2%clear()
  CALL dis%clear()
ENDFUNCTION intersect_lines3D
!
!-------------------------------------------------------------------------------
!> @brief Calculates the shortest line segment between two line segments
!>   s1 and s2 (if it exists).
!> @param s1 the first line segment to test
!> @param s2 the second line segment to test
!> @param mu1 the position of the start point of dis on the s1
!> @param mu2 the position of the end point of dis on the s2
!> @returns @c dis the shortest segment between s1 and s2 (if it exists)
!> @note a return code is assigned to dis%p1%dim and dis%p2%dim indicating
!>   the type of result.
!>   -3: the line segments are parallel
!>   -2: the line segments overlap
!>   -1: problem with dummy arguments passed to routine
!>  > 0: success; an shortest distance was found
!>
!> @note this routine only works in 3-D space.
!>
!> Calculates the line segment 'dis' that is the shortest route between
!> two line segments s1 and s2. Calculate also the values of mu1 and mu1 where
!>    dis%p1 = s1%p1 + mu1 (s1%p2 - s1%p1)
!>    dis%p2 = s2%p1 + mu2 (s2%p1 - s2%p1)
!>
ELEMENTAL SUBROUTINE distance_LineType_to_LineType(s1,s2,dis,mu1,mu2)
  CLASS(LineType),INTENT(IN) :: s1
  TYPE(LineType),INTENT(IN) :: s2
  TYPE(LineType),INTENT(OUT) :: dis
  REAL(SRK),OPTIONAL,INTENT(INOUT) :: mu1
  REAL(SRK),OPTIONAL,INTENT(INOUT) :: mu2
  TYPE(LineType) :: line
  REAL(SRK),DIMENSION(3) :: p13,p43,p21
  REAL(SRK) :: d1343,d4321,d1321,d4343,d2121
  REAL(SRK) :: denom,numer,d

  dis%p1%dim=-1
  dis%p2%dim=-1
  IF(s1%getdim() == 3 .AND. s2%getdim() == 3) THEN
    p21(1)=s1%p2%coord(1)-s1%p1%coord(1)
    p21(2)=s1%p2%coord(2)-s1%p1%coord(2)
    p21(3)=s1%p2%coord(3)-s1%p1%coord(3)
    p43(1)=s2%p2%coord(1)-s2%p1%coord(1)
    p43(2)=s2%p2%coord(2)-s2%p1%coord(2)
    p43(3)=s2%p2%coord(3)-s2%p1%coord(3)
    !Check the line segment
    IF((ABS(p21(1)) > EPSREAL .OR. ABS(p21(2)) > EPSREAL &
        .OR. ABS(p21(3)) > EPSREAL) .AND. (ABS(p43(1)) > EPSREAL &
        .OR. ABS(p43(2)) > EPSREAL .OR. ABS(p43(3)) > EPSREAL)) THEN
      p13(1)=s1%p1%coord(1)-s2%p1%coord(1)
      p13(2)=s1%p1%coord(2)-s2%p1%coord(2)
      p13(3)=s1%p1%coord(3)-s2%p1%coord(3)

      d1343=p13(1)*p43(1)+p13(2)*p43(2)+p13(3)*p43(3)
      d4321=p43(1)*p21(1)+p43(2)*p21(2)+p43(3)*p21(3)
      d1321=p13(1)*p21(1)+p13(2)*p21(2)+p13(3)*p21(3)
      d4343=p43(1)*p43(1)+p43(2)*p43(2)+p43(3)*p43(3)
      d2121=p21(1)*p21(1)+p21(2)*p21(2)+p21(3)*p21(3)
      denom=d2121*d4343-d4321*d4321
      IF(denom < EPSREAL) THEN
        dis%p1%dim=-3
        dis%p2%dim=-3
        d=ABS(p13(1)*p21(1)+p13(2)*p21(2)+p13(3)*p21(3))
        CALL line%set(s1%p1,s2%p1)
        IF(ABS(d-line%length()*s1%length()) < EPSREAL) THEN
          dis%p1%dim=-2
          dis%p2%dim=-2
        ENDIF
        CALL line%clear()
      ELSE
        numer=d1343*d4321-d1321*d4343
        mu1=numer/denom
        mu2=(d1343+d4321*mu1)/d4343
        dis%p1=s1%p1
        dis%p1%coord(1)=s1%p1%coord(1)+mu1*p21(1)
        dis%p1%coord(2)=s1%p1%coord(2)+mu1*p21(2)
        dis%p1%coord(3)=s1%p1%coord(3)+mu1*p21(3)
        dis%p2=s2%p1
        dis%p2%coord(1)=s2%p1%coord(1)+mu2*p43(1)
        dis%p2%coord(2)=s2%p1%coord(2)+mu2*p43(2)
        dis%p2%coord(3)=s2%p1%coord(3)+mu2*p43(3)
      ENDIF
    ENDIF
  ENDIF
ENDSUBROUTINE distance_LineType_to_LineType
!
!-------------------------------------------------------------------------------
!> @brief Finds the shortest squared distance between a point and a segment
!> @param line the LineType
!> @param p the PointType
!> @returns @c d2 the minimum squared distance between the point and the line
!> @note if @c d2<0, then there was a problem with the input arguments. If
!> @c d2==0 than the point is on the segment.
!>
ELEMENTAL FUNCTION distance_LineType_to_PointType(line,p) RESULT(d2)
  CLASS(LineType),INTENT(IN) :: line
  TYPE(PointType),INTENT(IN) :: p
  REAL(SRK) :: d2
  d2=-1._SRK
  IF(line%p1%dim == line%p2%dim .AND. line%p1%dim == p%dim) THEN
    SELECTCASE(p%dim)
    CASE(1)
      d2=distance1D_to_point(line%p1,line%p2,p)
    CASE(2)
      d2=distance2D_to_point(line%p1,line%p2,p)
    CASE(3)
      d2=distance3D_to_point(line%p1,line%p2,p)
    ENDSELECT
  ENDIF
ENDFUNCTION distance_LineType_to_PointType
!
!-------------------------------------------------------------------------------
!> @brief Finds the shortest squared distance between a point and a segment in
!> 1-D.
!> @param a start point of line segment
!> @param b end point of line segment
!> @param c the point to find the distance from line segment ab
!> @returns @c d2 the minimum squared distance between the point and the line
!>
ELEMENTAL FUNCTION distance1D_to_point(a,b,c) RESULT(d2)
  TYPE(PointType),INTENT(IN) :: a,b,c
  REAL(SRK) :: d2
  IF(c%coord(1) < a%coord(1)) THEN
    d2=(a%coord(1)-c%coord(1))*(a%coord(1)-c%coord(1))
  ELSEIF(c%coord(1) > b%coord(1)) THEN
    d2=(c%coord(1)-b%coord(1))*(c%coord(1)-b%coord(1))
  ELSE
    d2=0.0_SRK
  ENDIF
ENDFUNCTION distance1D_to_point
!
!-------------------------------------------------------------------------------
!> @brief Finds the shortest squared distance between a point and a segment in
!> 2-D.
!> @param a start point of line segment
!> @param b end point of line segment
!> @param c the point to find the distance from line segment ab
!> @returns @c d2 the minimum squared distance between the point and the line
!>
ELEMENTAL FUNCTION distance2D_to_point(a,b,c) RESULT(d2)
  TYPE(PointType),INTENT(IN) :: a,b,c
  REAL(SRK) :: d2
  REAL(SRK) :: e,f
  REAL(SRK) :: ab(2),ac(2),bc(2)

  ab(1)=b%coord(1)-a%coord(1)
  ab(2)=b%coord(2)-a%coord(2)
  ac(1)=c%coord(1)-a%coord(1)
  ac(2)=c%coord(2)-a%coord(2)

  e=ac(1)*ab(1)+ac(2)*ab(2)
  IF(e <= 0.0_SRK) THEN
    !c projects onto ab outside a
    d2=ac(1)*ac(1)+ac(2)*ac(2)
  ELSE
    f=ab(1)*ab(1)+ab(2)*ab(2)
    IF(e >= f) THEN
      !c projects onto ab outside b
      bc(1)=c%coord(1)-b%coord(1)
      bc(2)=c%coord(2)-b%coord(2)
      d2=bc(1)*bc(1)+bc(2)*bc(2)
    ELSE
      !c projects onto ab
      d2=(ac(1)*ac(1)+ac(2)*ac(2))-e*e/f
    ENDIF
  ENDIF
ENDFUNCTION distance2D_to_point
!
!-------------------------------------------------------------------------------
!> @brief Finds the shortest squared distance between a point and a segment in
!> 3-D.
!> @param a start point of line segment
!> @param b end point of line segment
!> @param c the point to find the distance from line segment ab
!> @returns @c d2 the minimum squared distance between the point and the line
!>
ELEMENTAL FUNCTION distance3D_to_point(a,b,c) RESULT(d2)
  TYPE(PointType),INTENT(IN) :: a,b,c
  REAL(SRK) :: d2
  REAL(SRK) :: e,f
  REAL(SRK) :: ab(3),ac(3),bc(3)

  ab(1)=b%coord(1)-a%coord(1)
  ab(2)=b%coord(2)-a%coord(2)
  ab(3)=b%coord(3)-a%coord(3)
  ac(1)=c%coord(1)-a%coord(1)
  ac(2)=c%coord(2)-a%coord(2)
  ac(3)=c%coord(3)-a%coord(3)

  e=ac(1)*ab(1)+ac(2)*ab(2)+ac(3)*ab(3)
  IF(e <= 0.0_SRK) THEN
    !c projects onto ab outside a
    d2=ac(1)*ac(1)+ac(2)*ac(2)+ac(3)*ac(3)
  ELSE
    f=ab(1)*ab(1)+ab(2)*ab(2)+ab(3)*ab(3)
    IF(e >= f) THEN
      !c projects onto ab outside b
      bc(1)=c%coord(1)-b%coord(1)
      bc(2)=c%coord(2)-b%coord(2)
      bc(3)=c%coord(3)-b%coord(3)
      d2=bc(1)*bc(1)+bc(2)*bc(2)+bc(3)*bc(3)
    ELSE
      !c projects onto ab
      d2=(ac(1)*ac(1)+ac(2)*ac(2)+ac(3)*ac(3))-e*e/f
    ENDIF
  ENDIF
ENDFUNCTION distance3D_to_point
!
!-------------------------------------------------------------------------------
!> @brief Determines whether a point is to the left of the line.
!> @param line the line object
!> @param pt the point object
!> @returns @c bool the boolean result of the operation
!>
!> Function is elemental so it can be used on an array of lines.
ELEMENTAL FUNCTION pointIsLeft_LineType(line,pt) RESULT(bool)
  CLASS(LineType),INTENT(IN) :: line
  TYPE(PointType),INTENT(IN) :: pt
  LOGICAL(SBK) :: bool
  bool=.FALSE.
  IF((pt%dim > 1) .AND. (line%getDim() > 1)) &
      bool=(line%p2%coord(1)-line%p1%coord(1))*(pt%coord(2)-line%p1%coord(2))- &
      (line%p2%coord(2)-line%p1%coord(2))*(pt%coord(1)-line%p1%coord(1)) > 0.0_SRK
ENDFUNCTION pointIsLeft_LineType
!
!-------------------------------------------------------------------------------
!> @brief Determines whether a point is to the right of the line.
!> @param line the line object
!> @param pt the point object
!> @returns @c bool the boolean result of the operation
!>
!> Function is elemental so it can be used on an array of lines.
ELEMENTAL FUNCTION pointIsRight_LineType(line,pt) RESULT(bool)
  CLASS(LineType),INTENT(IN) :: line
  TYPE(PointType),INTENT(IN) :: pt
  LOGICAL(SBK) :: bool
  bool=.FALSE.
  IF((pt%dim > 1) .AND. (line%getDim() > 1)) &
      bool=(line%p2%coord(1)-line%p1%coord(1))*(pt%coord(2)-line%p1%coord(2))- &
      (line%p2%coord(2)-line%p1%coord(2))*(pt%coord(1)-line%p1%coord(1)) < 0.0_SRK
ENDFUNCTION pointIsRight_LineType
!
!-------------------------------------------------------------------------------
!> @brief Defines the 'is equal to' operation between two lines e.g. @c
!>        l0 == l1
!> @param p0 the first line
!> @param p1 the second line
!> @returns @c bool the boolean result of the operation
!>
!> Function is elemental so it can be used on an array of lines.
ELEMENTAL FUNCTION isequal_LineType(l0,l1) RESULT(bool)
  TYPE(LineType),INTENT(IN) :: l0,l1
  LOGICAL(SBK) :: bool
  bool=.FALSE.
  IF(l0%p1 == l1%p1) bool=l0%p2 == l1%p2
ENDFUNCTION isequal_LineType
!
ENDMODULE Geom_Line


      PROGRAM xgaulag
C     driver for routine gaulag
      INTEGER NP
      PARAMETER(NP=64)
      INTEGER i,n
      REAL func,alf,checkw,checkx,gammln,xx,x(NP),w(NP)
      alf=1.
1     write(*,*) 'Enter N'
      read(*,*,END=99) n
      call gaulag(x,w,n,alf)
      write(*,'(/1x,t3,a,t10,a,t22,a/)') '#','X(I)','W(I)'
      do 11 i=1,n
        write(*,'(1x,i2,2e14.6)') i,x(i),w(i)
11    continue
      checkx=0.
      checkw=0.
      do 12 i=1,n
        checkx=checkx+x(i)
        checkw=checkw+w(i)
12    continue
      write(*,'(/1x,a,e15.7,a,e15.7)') 'Check value:',checkx,
     *  '  should be:',n*(n+alf)
      write(*,'(/1x,a,e15.7,a,e15.7)') 'Check value:',checkw,
     *  '  should be:',exp(gammln(1.+alf))
C     demonstrate the use of GAULAG for an integral
      xx=0.0
      do 13 i=1,n
        xx=xx+w(i)*func(x(i))
13    continue
      write(*,'(/1x,a,f12.6)') 'Integral from GAULAG:',xx
      write(*,'(1x,a,f12.6)') 'Actual value:        ',1./(2.*sqrt(2.))
      go to 1
99    stop
      END
      REAL FUNCTION func(x)
      REAL x,bessj0
      func=bessj0(x)
      END

NR-Functions/Numerical Recipes- Example & Functions/Examples/xgaulag.for