!!# FUNCTION MODULE <<FUN_xySLICE>>
MODULE FUN_xySLICE

!!## PURPOSE
!! Return slices <Sli> of shapes made when ``cut'' by angle <theta>.
!! The actual angle theta is greatly preferred to the direction
!! U=(/cos(theta),sin(theta)/) as there can be a considerable loss
!! in precision when theta=pi/2.

!!## AUTHORS
!! [waw] W. A. Wieselquist

!!## CHANGES
!! 1 Sep. 2011 [waw] the slice area also needs to be scaled when the polygon is
!!                   but by a factor scale**2!
!! 28 August 2011 [waw]

!!## EXTERNAL MODULES
USE KND_IntrinsicTypes,ONLY: KIND_Rdp,KIND_Rsp !!((01-A-KND_IntrinsicTypes.f90))
USE SUB_Sort_quick,ONLY: Sort=>Sort_quick !!((03-A-SUB_Sort_quick.f90))
USE FUN_xyINTEGRALXX
USE FUN_xyINTEGRALXY
USE FUN_xyINTEGRALYY

!!## DEFAULT IMPLICIT
IMPLICIT NONE

!!## DEFAULT ACCESS
PRIVATE

!!## VARIABLES
REAL(KIND_Rdp),PARAMETER :: PI=3.1415926535897932384626433832795_KIND_Rdp !ACOS(-1._KIND_Rdp)
LOGICAL,SAVE :: Using_BB_Shift=.TRUE.
LOGICAL,SAVE :: Using_Scale_Factor=.TRUE.
LOGICAL,SAVE :: VERBOSE_SLICE=.FALSE.

!!## PROCEDURE OVERLOADING
INTERFACE xySLICE_Pgt
 MODULE PROCEDURE xySLICE_Pgt_Rdp
END INTERFACE

!!## PUBLIC ACCESS LIST
PUBLIC :: xySLICE_Pgt
PUBLIC :: xySLICE_Pgt_Rdp
PUBLIC :: VERBOSE_SLICE

!!## CONTAINED PROCEDURES
 CONTAINS

SUBROUTINE xySLICE_Pgt_Rdp( n, pg0, theta0, TOL, &
    ns, sli, a, c, vin, vout, ein, eout, nvl, vleft, eleft, nvr, vright, eright, &
    corig, crot )

!input
INTEGER,INTENT(IN)  :: n                   !number of sides
REAL(KIND_Rdp),INTENT(IN) :: pg0(2,n)             !counter-clockwise points (xi,yi)=pg(1:2,i) for i=1..n
REAL(KIND_Rdp),INTENT(IN)  :: theta0              !angle to slice with
REAL(KIND_Rdp),INTENT(IN)  :: TOL                 !relative tolerance for thin slice fix
!output
INTEGER,INTENT(OUT) :: ns                  !number of slices
REAL(KIND_Rdp),INTENT(OUT) :: sli(3,n)            !u,vmin,vmax coordinates of slice in rotated coordinate system
                               !(ui,vmini,vmaxi)=sli(1:3,i) for i=1..ns (maximum of n)
REAL(KIND_Rdp),INTENT(OUT) :: a                   !area of polygon
REAL(KIND_Rdp),INTENT(OUT) :: c(2)                !centroid of polygon
INTEGER,INTENT(OUT) :: vin(n),vout(n)      !vertex indices of the incoming and outgoing vertices in the
                               !original polygon with vout(1)=vout(n)=0 by definition
INTEGER,INTENT(OUT) :: ein(n-1),eout(n-1)  !edge indices of the incoming and outgoing edges

INTEGER,INTENT(OUT) :: nvl,nvr             !number of hanging verts on the left and right edges
INTEGER,INTENT(OUT) :: vleft(n),vright(n)
INTEGER,INTENT(OUT) :: eleft(n-1),eright(n-1)
REAL(KIND_Rdp),INTENT(OUT),OPTIONAL :: corig(3),crot(3)

!local
REAL(KIND_Rdp) :: cn(2),scale,xv(n),yin(n),yout(n),yv(n),theta,pg(2,n)
INTEGER :: i,j,order(n)
LOGICAL :: is_outgoing(n)
REAL(KIND_Rdp) :: barx2_b,barxy_b,bary2_b
REAL(KIND_Rdp) :: barx2_a,barxy_a,bary2_a

!transform theta
theta=PI/2._KIND_Rdp-theta0
pg=pg0

!shift
IF( Using_BB_Shift )THEN
  CALL SHIFT_BOUNDING_RECTANGLE(n,pg,c)
ELSE
  c(1:2)=0._KIND_Rdp
END IF

!get area
a = AREA(n,pg)
IF( VERBOSE_SLICE )THEN
    WRITE(*,*)'area=',a
END IF

!scale
IF( Using_Scale_Factor )THEN
  scale       = SQRT(a)
ELSE
  scale       = 1._KIND_Rdp
END IF
pg = pg/scale
a  = a/(scale**2)
IF( VERBOSE_SLICE )THEN
    WRITE(*,*)'scale factor=',scale
    WRITE(*,*)'after scaling'
    WRITE(*,'(999(1x,es24.16))')(pg(2,i),i=1,n)
    WRITE(*,'(999(1x,es24.16))')(pg(1,i),i=1,n)
END IF

!Calculate the centroid and shift the polygon.
cn(1:2) = CENTROID( n, pg, a )
IF( VERBOSE_SLICE )THEN
    WRITE(*,*)'centroid='
    WRITE(*,'(2(1x,es24.16))')cn(1:2)
END IF

pg(1,1:n) = pg(1,1:n) - cn(1)
pg(2,1:n) = pg(2,1:n) - cn(2)
c(1:2)    = c(1:2) + cn(1:2)
IF( VERBOSE_SLICE )THEN
    WRITE(*,*)'after shifting to the true centroid'
    WRITE(*,'(999(1x,es24.16))')(pg(2,i),i=1,n)
    WRITE(*,'(999(1x,es24.16))')(pg(1,i),i=1,n)
END IF

IF( PRESENT(corig) )THEN
 barx2_b = xyINTEGRALXX_Pg(n,pg)
 barxy_b = xyINTEGRALXY_Pg(n,pg)
 bary2_b = xyINTEGRALYY_Pg(n,pg)
 corig = (/barx2_b,bary2_b,barxy_b/)
END IF

!Rotate the n-sided polygon in place about the origin (its centroid).
CALL ROTATE( n, pg, theta )
IF( VERBOSE_SLICE )THEN
    WRITE(*,*)'after rotate'
    WRITE(*,'(999(1x,es24.16))')(pg(2,i),i=1,n)
    WRITE(*,'(999(1x,es24.16))')(pg(1,i),i=1,n)
END IF

IF( PRESENT(crot) )THEN
 barx2_a = xyINTEGRALXX_Pg(n,pg)
 barxy_a = xyINTEGRALXY_Pg(n,pg)
 bary2_a = xyINTEGRALYY_Pg(n,pg)
 crot = (/barx2_a,bary2_a,barxy_a/)
END IF

!Order the slices from left to right and determine the outgoing ones
!by that ordering.
CALL ORDER_SLICE(n,pg,xv,yv,order,is_outgoing)
IF( VERBOSE_SLICE )THEN
    WRITE(*,*)'is_outgoing in terms of original verts'
    WRITE(*,'(99(1x,g23.1))')is_outgoing
    WRITE(*,*)'final order (y,x)'
    WRITE(*,'(99(1x,es23.16))')yv
    WRITE(*,'(99(1x,es23.16))')xv
    WRITE(*,'(99(1x,i23))')order
END IF

!Set y-values available on top and bottom sides and interpolate
!to get the other y-values.
CALL INTERPOLATE_SLICE( n, order, pg, is_outgoing, &
          vin, vout, yin, yout )
IF( VERBOSE_SLICE )THEN
    WRITE(*,*)'after interpolate yout/yin'
    WRITE(*,'(99(1x,es24.16))')(yout(i),i=1,n)
    WRITE(*,'(99(1x,es24.16))')(yin(i),i=1,n)
    WRITE(*,*)'after interpolate vout/vin '
    WRITE(*,'(99(1x,i24))')(vout(i),i=1,n)
    WRITE(*,'(99(1x,i24))')(vin(i),i=1,n)
END IF

!Assemble canonical slices.
sli(1,1:n) = xv(1:n)
sli(2,1:n) = yin(1:n)
sli(3,1:n) = yout(1:n)
IF( VERBOSE_SLICE )THEN
    WRITE(*,*)'before collapse sli'
    WRITE(*,'(99(1x,es24.16))')(sli(3,j),j=1,n)
    WRITE(*,'(99(1x,es24.16))')(sli(2,j),j=1,n)
    WRITE(*,'(99(1x,es24.16))')(sli(1,j),j=1,n)
END IF

!Remove thin slices in place (on return only ns values are used).
ns=n
CALL COLLAPSE_THIN_SLICES( ns, vin, vout, sli, TOL )
IF( VERBOSE_SLICE )THEN
    WRITE(*,*)'after collapse vout/vin '
    WRITE(*,'(99(1x,i24))')(vout(i),i=1,ns)
    WRITE(*,'(99(1x,i24))')(vin(i),i=1,ns)
    WRITE(*,*)'after collapse sli'
    WRITE(*,'(99(1x,es24.16))')(sli(3,j),j=1,ns)
    WRITE(*,'(99(1x,es24.16))')(sli(2,j),j=1,ns)
    WRITE(*,'(99(1x,es24.16))')(sli(1,j),j=1,ns)
END IF

!Determine the incoming and outgoing edges.
CALL GET_EDGES(ns,vin,vout,ein,eout)
IF( VERBOSE_SLICE )THEN
    WRITE(*,*)'eout/ein'
    WRITE(*,'(99(1x,i24))')(eout(j),j=1,ns-1)
    WRITE(*,'(99(1x,i24))')(ein(j),j=1,ns-1)
END IF

!Find hanging verts.
CALL LOOP_ITERATOR(n,vout(1),vin(1),vleft,nvl)
CALL LOOP_ITERATOR(n,vin(ns),vout(ns),vright,nvr)

!Only now do we set the outgoing verts to 0 on the left and right.
!IF THEY ARE THE SAME---otherwise we have a special situation
IF( vout(1)==vin(1) )THEN
  vout(1)=0
END IF
IF( vout(ns)==vin(ns) )THEN
  vout(ns)=0
END IF

!Find hanging edges.
eleft=0
eright=0

!Re-scale the slices.
sli(1:3,1:ns) = sli(1:3,1:ns)*scale
pg=pg*scale

END SUBROUTINE xySLICE_Pgt_Rdp

SUBROUTINE SHIFT_BOUNDING_RECTANGLE(n,pg,c)
INTEGER :: n
REAL(KIND_Rdp) :: pg(2,n),c(2)
!LOCALS
INTEGER :: i

!For better numerics, shift the polygon near (0,0) using the bounding rectangle.
c(1)        = 0.5_KIND_Rdp*( MINVAL(pg(1,1:n)) + MAXVAL(pg(1,1:n)) )
c(2)        = 0.5_KIND_Rdp*( MINVAL(pg(2,1:n)) + MAXVAL(pg(2,1:n)) )
pg(1,1:n) = pg(1,1:n) - c(1)
pg(2,1:n) = pg(2,1:n) - c(2)
IF( VERBOSE_SLICE )THEN
    WRITE(*,*)'shift bounding rectangle'
    WRITE(*,'(999(1x,es24.16))')(pg(2,i),i=1,n)
    WRITE(*,'(999(1x,es24.16))')(pg(1,i),i=1,n)
END IF
END SUBROUTINE

FUNCTION SLICE_AREA(n,sli) RESULT(AREA)
INTEGER :: n
REAL(KIND_Rdp) :: sli(3,n)
REAL(KIND_Rdp) :: sminbar,smaxbar,dt
REAL(KIND_Rdp) :: AREA
INTEGER :: i

AREA = 0._KIND_Rdp

DO i=1,n-1
    sminbar=0.5_KIND_Rdp*(sli(2,i+1)+sli(2,i))
    smaxbar=0.5_KIND_Rdp*(sli(3,i+1)+sli(3,i))
    dt=sli(1,i+1)-sli(1,i)
    AREA = AREA + dt*(smaxbar-sminbar)
END DO

END FUNCTION SLICE_AREA

!returns 0 if start=finish
SUBROUTINE LOOP_ITERATOR(n,start,finish,list,i)
INTEGER :: n,start,finish,i
INTEGER :: list(n)
INTEGER :: j
list(1:n)=0
i=0
IF( start>n .OR. finish>n .OR. start<1 .OR. finish<1 )THEN
    RETURN
ELSE
    IF( START .NE. FINISH )THEN
        j=start
        DO WHILE(.TRUE.)
            j=NEXT_CCW(j,n)
            !WRITE(*,*)'test j=',j
            IF( j.NE.finish )THEN
                i=i+1
                list(i)=j
                !WRITE(*,*)'added that j to element i=',i
            ELSE
                EXIT
            END IF
        END DO
    END IF
END IF
END SUBROUTINE

SUBROUTINE ORDER_SLICE(n,pg,xv,yv,order,is_outgoing)
!input
INTEGER :: n                   !number of sides
REAL(KIND_Rdp) :: pg(2,n)             !counter-clockwise points (xi,yi)=pg(1:2,i) for i=1..n
REAL(KIND_Rdp) :: xv(n),yv(n)
!output
INTEGER :: order(n)
LOGICAL :: is_outgoing(n)
                               !original polygon with vout(1)=vout(n)=0 by definition
!local
INTEGER :: i,j,ixl,ixr
INTEGER :: ordery(n)
INTEGER :: order2(n)

i=1
DO j=1,n
  xv(j)    = pg(1,i)
  yv(j)    = pg(2,i)
  order(j) = j
  i = NEXT_CCW(i,n)
END DO
IF( VERBOSE_SLICE )THEN
    WRITE(*,*)'pre x-sort (y,x)'
    WRITE(*,'(99(1x,es23.16))')yv
    WRITE(*,'(99(1x,es23.16))')xv
    WRITE(*,'(99(1x,i23))')order
END IF

CALL SORT( xv(1:n), order(1:n) )
i=1
DO j=1,n
    yv(j) = pg(2,order(j))
    i = NEXT_CCW(i,n)
END DO
IF( VERBOSE_SLICE )THEN
    WRITE(*,*)'post x-sort (y,x)'
    WRITE(*,'(99(1x,es23.16))')yv
    WRITE(*,'(99(1x,es23.16))')xv
    WRITE(*,'(99(1x,i23))')order
END IF

DO j=2,n
    IF( ABS(xv(1)-xv(j))>EPSILON(1._KIND_Rdp) )EXIT
END DO
ixl=j-1
if( ixl-1>0 )then
    CALL SORT( yv(1:ixl), ordery(1:ixl) )
    order2=order
    DO i=1,ixl
        order(i)=order2(ordery(i))
    END DO
    IF( VERBOSE_SLICE )THEN
        WRITE(*,*)'post y-sort 1 (y,x)'
        WRITE(*,'(99(1x,es23.16))')yv
        WRITE(*,'(99(1x,es23.16))')xv
        WRITE(*,'(99(1x,i23))')order
    END IF
end if
DO j=n-1,ixl+1,-1
    IF( ABS(xv(n)-xv(j))>EPSILON(1._KIND_Rdp) )EXIT
END DO
ixr=j+1
if( n-ixr>0 )then
    CALL SORT( yv(ixr:n), ordery(ixr:n) )
    order2=order
    DO i=ixr,n
        order(i)=order2(ixr-1+ordery(i))
    END DO
    IF( VERBOSE_SLICE )THEN
        WRITE(*,*)'post y-sort 2 (y,x)'
        WRITE(*,'(99(1x,es23.16))')yv
        WRITE(*,'(99(1x,es23.16))')xv
        WRITE(*,'(99(1x,i23))')order
    END IF
end if

ixl=order(1)
ixr=order(n)
IF( VERBOSE_SLICE )THEN
    WRITE(*,*)'ixl,ixr'
    WRITE(*,*)ixl,ixr
END IF

j=ixl
is_outgoing=.TRUE.
DO i=1,n
    is_outgoing(j)=.FALSE.
    IF( j==ixr )EXIT
    j=NEXT_CCW(j,n)
END DO

END SUBROUTINE ORDER_SLICE

FUNCTION NEXT_CCW( i, n ) RESULT(next)
INTEGER :: i,n,next
next=MOD(i,n)+1
IF( next.LE.0 )THEN
  next=next+n
END IF
END FUNCTION NEXT_CCW

REAL(KIND_Rdp) FUNCTION AREA( n, pg )
INTEGER :: n
REAL(KIND_Rdp) :: pg(2,n)
INTEGER :: i,next
AREA = 0._KIND_Rdp
DO i=1,n
  next=NEXT_CCW(i,n)
  AREA = AREA + pg(1,i)*pg(2,next) - pg(1,next)*pg(2,i)
END DO
AREA = 0.5*AREA

IF( AREA.LE.0 )THEN
  WRITE(*,*)'area=',AREA
  STOP 'polygon is not counter-clockwise'
END IF
END FUNCTION AREA

FUNCTION CENTROID( n, pg, area ) RESULT(c)
INTEGER :: n
REAL(KIND_Rdp) :: pg(2,n),area,c(2)
REAL(KIND_Rdp) :: xc,yc,a,b
INTEGER :: i,next
xc=0
yc=0
DO i=1,n
  next=NEXT_CCW(i,n)
  a = ( pg(1,i)*pg(2,next) - pg(1,next)*pg(2,i) )
  xc = xc + ( pg(1,i) + pg(1,next) )*a
  yc = yc + ( pg(2,i) + pg(2,next) )*a
END DO
b  = 1.0/(6*area)
xc = xc*b
yc = yc*b
c=(/xc,yc/)
END FUNCTION CENTROID

SUBROUTINE ROTATE( n, pg, theta )
INTEGER :: n
REAL(KIND_Rdp) :: pg(2,n),theta
INTEGER :: i
REAL(KIND_Rdp) :: x,y,r,cos_t,sin_t,cos_dt,sin_dt,cos_tp,sin_tp
DO i=1,n
  x = pg(1,i)
  y = pg(2,i)
  r = SQRT( x**2 + y**2 )
  cos_t = x/r
  sin_t = y/r
  cos_dt = COS(theta)
  sin_dt = SIN(theta)
  cos_tp = cos_t*cos_dt - sin_t*sin_dt
  sin_tp = sin_t*cos_dt + cos_t*sin_dt
  pg(1,i)=r*cos_tp
  pg(2,i)=r*sin_tp
END DO
END SUBROUTINE ROTATE

SUBROUTINE INTERPOLATE_SLICE( n, order, pg, is_outgoing, &
   vin,vout, yin,yout )
!remember: is_outgoing is a function of original vert indices as in pg
INTEGER :: n,order(n),vin(n),vout(n)
REAL(KIND_Rdp) :: pg(2,n),yin(n),yout(n)
LOGICAL :: is_outgoing(n)
INTEGER :: i,o,ibl,ibr,itl,itr
REAL(KIND_Rdp) :: inf,xv(n)
inf=HUGE(1._KIND_Rdp)
yin  = -inf
yout = +inf
vin   =  0
vout  =  0
DO i=1,n
  o = order(i)
  xv(i)=pg(1,o)
  IF( is_outgoing(o) )THEN
    vout(i)  = o
    vin(i)   = 0
    yout(i)  = pg(2,o)
  ELSE
    vin(i)   = o
    vout(i)  = 0
    yin(i)   = pg(2,o)
  END IF
END DO
yout(1)=yin(1)
yout(n)=yin(n)
vout(1)=vin(1)
vout(n)=vin(n)
IF( VERBOSE_SLICE )THEN
    WRITE(*,*)'yout/yin A'
    WRITE(*,'(99(1x,es24.16))')(yout(i),i=1,n)
    WRITE(*,'(99(1x,es24.16))')(yin(i),i=1,n)
    WRITE(*,*)'vout/vin A'
    WRITE(*,'(99(1x,i24))')(vout(i),i=1,n)
    WRITE(*,'(99(1x,i24))')(vin(i),i=1,n)
END IF

DO i=2,n-1
  IF( vin(i).EQ.0 )THEN
    DO ibr=i+1,n
      IF( vin(ibr).NE.0 )EXIT
    END DO
    DO ibl=i-1,1,-1
      IF( vin(ibl).NE.0 )EXIT
    END DO
    yin(i) = yin(ibl) + &
              (     xv(i) -    xv(ibl) )* &
              (  yin(ibr) -   yin(ibl) )/ &
              (   xv(ibr) -    xv(ibl) )
  ELSE IF( vout(i).EQ.0 )THEN
    DO itr=i+1,n
      IF( vout(itr).NE.0 )EXIT
    END DO
    DO itl=i-1,1,-1
      IF( vout(itl).NE.0 )EXIT
    END DO
    yout(i) = yout(itl) + &
              (     xv(i) -    xv(itl) )* &
              ( yout(itr) -  yout(itl) )/ &
              (   xv(itr) -    xv(itl) )
  END IF
END DO

END SUBROUTINE INTERPOLATE_SLICE

SUBROUTINE GET_EDGES( n, vin, vout, ein, eout )
INTEGER :: n,vin(n),vout(n)
INTEGER :: ein(n-1),eout(n-1)  !edge indices of the incoming and outgoing edges in the
                               !original polygon
INTEGER :: i
ein(1)=vin(1)
DO i=2,n-1
    IF( vin(i) .NE. 0 )THEN
      ein(i)=vin(i)
    ELSE
      ein(i)=ein(i-1)
    END IF
END DO
eout(n-1)=vout(n)
DO i=n-2,1,-1
    IF( vout(i+1) .NE. 0 )THEN
      eout(i)=vout(i+1)
    ELSE
      eout(i)=eout(i+1)
    END IF
END DO
END SUBROUTINE GET_EDGES

SUBROUTINE COLLAPSE_THIN_SLICES( n, vin, vout, sli, TOL )
INTEGER :: n,vin(n),vout(n)
REAL(KIND_Rdp) :: sli(3,n),TOL
INTEGER :: ns,i,j,k,ihr,ihl
REAL(KIND_Rdp) :: thin_dw,dw
ihl=0
ihr=0
ns=n
thin_dw=TOL*(sli(1,n)-sli(1,1))

!collapse contiguous thin slices on the left
DO k=1,ns-1
    dw=sli(1,2)-sli(1,1)
    IF( dw .LE. thin_dw )THEN
        IF( vout(2).EQ.0 )THEN
            vout(2)=vout(1)
        ELSE IF( vin (2).EQ.0 )THEN
            vin(2)=vin(1)
        END IF
        CALL DELETE_PARTITION(1,ns,vin,vout,sli)
    ELSE
        EXIT
    END IF
    IF( VERBOSE_SLICE )THEN
        WRITE(*,*)'sli (left) on fix iteration k=',k
        WRITE(*,'(99(1x,es24.16))')(sli(3,j),j=1,ns)
        WRITE(*,'(99(1x,es24.16))')(sli(2,j),j=1,ns)
        WRITE(*,'(99(1x,es24.16))')(sli(1,j),j=1,ns)
        WRITE(*,*)'vout/vin'
        WRITE(*,'(99(1x,i24))')(vout(j),j=1,ns)
        WRITE(*,'(99(1x,i24))')(vin(j),j=1,ns)
    END IF
END DO

!collapse contiguous thin slices on the right
DO k=1,ns-1
    dw=sli(1,ns)-sli(1,ns-1)
    IF( dw .LE. thin_dw )THEN
        IF( vout(ns-1).EQ.0 )THEN
            vin(ns)=vin(ns-1)
        ELSE IF( vin (ns-1).EQ.0 )THEN
            vout(ns)=vout(ns-1)
        END IF
        CALL DELETE_PARTITION(ns-1,ns,vin,vout,sli)
    ELSE
        EXIT
    END IF
    IF( VERBOSE_SLICE )THEN
        WRITE(*,*)'sli (right) on fix iteration k=',k
        WRITE(*,'(99(1x,es24.16))')(sli(3,j),j=1,ns)
        WRITE(*,'(99(1x,es24.16))')(sli(2,j),j=1,ns)
        WRITE(*,'(99(1x,es24.16))')(sli(1,j),j=1,ns)
        WRITE(*,*)'vout/vin'
        WRITE(*,'(99(1x,i24))')(vout(j),j=1,ns)
        WRITE(*,'(99(1x,i24))')(vin(j),j=1,ns)
    END IF
END DO

!collapse contiguous thin slices in the middle
i=2
DO k=2,ns-2
    dw=sli(1,i+1)-sli(1,i)
    IF( dw .LE. thin_dw )THEN
        IF( vout(i+1).EQ.0 )THEN
            vout(i+1)=vout(i)
        ELSE IF( vin (i+1).EQ.0 )THEN
            vin(i+1)=vin(i)
        END IF
        CALL DELETE_PARTITION(i,ns,vin,vout,sli)
    END IF
    IF( VERBOSE_SLICE )THEN
        WRITE(*,*)'sli (center) on fix iteration i=',i
        WRITE(*,'(99(1x,es24.16))')(sli(3,j),j=1,ns)
        WRITE(*,'(99(1x,es24.16))')(sli(2,j),j=1,ns)
        WRITE(*,'(99(1x,es24.16))')(sli(1,j),j=1,ns)
        WRITE(*,*)'vout/vin'
        WRITE(*,'(99(1x,i24))')(vout(j),j=1,ns)
        WRITE(*,'(99(1x,i24))')(vin(j),j=1,ns)
    END IF
    i = i + 1
    IF( i>=ns )EXIT
END DO

n=ns
END SUBROUTINE COLLAPSE_THIN_SLICES

!erases partition i and moves all other partitions left 1
SUBROUTINE DELETE_PARTITION(i,ns,vin,vout,sli)
INTEGER :: i,ns
INTEGER :: vin(ns),vout(ns)
REAL(KIND_Rdp) :: sli(3,ns)

vin(i:ns-1) = vin(i+1:ns)
vout(i:ns-1) = vout(i+1:ns)

sli(1,i+1)         = SMALLEST(sli(1,i),sli(1,i+1))
sli(2,i+1)         = MIN(sli(2,i),sli(2,i+1))
sli(3,i+1)         = MAX(sli(3,i),sli(3,i+1))
sli(1:3,i:ns-1) = sli(1:3,i+1:ns)

ns=ns-1

END SUBROUTINE DELETE_PARTITION

REAL(KIND_Rdp) FUNCTION SMALLEST(a,b)
REAL(KIND_Rdp) :: a,b,c
IF( ABS(a)<ABS(b) )THEN
  c=a
ELSE
  c=b
END IF
SMALLEST=c
END FUNCTION SMALLEST

END MODULE


        subroutine azel(azimuth, elev, StaXYZ, East, North,
     .                  Staup, SatPos)
        implicit none
c      returns azimuth and elevation angle in degrees
c      station is cartesian coordinates of station (meters)
c      X, Y, Z is satellite coordinates (meters)
c ----------------------------------------------------
      double precision elev, azimuth
      double precision StaXYZ(3), X, Y, Z, East(3),
     . North(3), Staup(3), sta2sat(3), Mstation, Msat,
     . sta2sat_N, sta2sat_E, UdotS, zenith,SatPos(3)
      double precision pi, Lat,Long,Ht, range

c ----------------------------------------------------

c ... find azimuth/elevation of satellite relative
c ... to the reference station (station(3))
        pi = 4.0*datan(1.d0)
        sta2sat(1) = SatPos(1) - StaXYZ(1)
        sta2sat(2) = SatPos(2) - StaXYZ(2)
        sta2sat(3) = SatPos(3) - StaXYZ(3)
        range = sqrt(sta2sat(1)**2+ sta2sat(2)**2 +sta2sat(3)**2)

c    ... azimuth of satellite from station:
c  ... get components of 'sta2sat' in ENV frame:
         sta2sat_E = East(1)*sta2sat(1) + East(2)*sta2sat(2)
     .        + East(3)*sta2sat(3)
         sta2sat_N = North(1)*sta2sat(1) + North(2)*sta2sat(2)
     .        + North(3)*sta2sat(3)

c atan2(X,Y) == tan-1(X/Y)
         azimuth = datan2(sta2sat_E, sta2sat_N)*180/pi
         if (azimuth .lt. 0) then
            azimuth = 360 + azimuth
         endif

c    ... elevation angle calculation:
c         Mstation = dsqrt(Staup(1)**2 + Staup(2)**2 +
c    .          Staup(3)**2)
         Mstation = 1
         Msat = dsqrt(sta2sat(1)**2 + sta2sat(2)**2 +
     .          sta2sat(3)**2)
         UdotS = Staup(1)*sta2sat(1) + Staup(2)*sta2sat(2) +
     .           Staup(3)*sta2sat(3)
         zenith = dacos(UdotS/(Mstation*Msat))*180/pi
         elev = 90 - zenith

       return
       end

c---------------------------------------------------------------------
      subroutine geoxyz2(alat,along,hght,x,y,z,iflag)
c
c Purpose:
c     Convert geodetic curvilinear coordinates to geocentric Cartesian
c        coordinates and vice versa
c
c Input:
c     iflag = 1  convert geodetic coordinates to cartesian coordinates
c           = 2  convert cartesian coordinates to geodetic coordinates
c
c Input/Output:
c     alat,along : geodetic latitude and longitude (radians)
c     hght       : height above the reference ellipsiod (meters)
c     x,y,z      : geocentric Cartesian coordinates (meters)
c
c Notes:
c     Currently assumes the WGS84 reference ellipsoid;
c     Clarke 1866 ellipsoid with approximate translation parameters
c        for NAD27 are commented.
c     Cartesian to geodetic conversion uses an iterative scheme
c        valid to the millimeter level.
c
      integer iflag
      real*8 alat,along,hght,x,y,z, b
      real*8 semi,finv
      real*8 twopi,f,e2,curvn,sqr,alat0,cutoff
      real*8 sinlat,coslat,sinlon,coslon

      semi = 6378137.d0
      finv = 298.257223563d0
      twopi= 8.d0*datan(1.d0)
      f= 1.d0/finv
      b = semi*(1.d0 - f)
      e2= 2.d0*f - f*f
      if( iflag.eq.1) then
         sinlat= dsin(alat)
         coslat= dcos(alat)
         sinlon= dsin(along)
         coslon= dcos(along)
         curvn= semi/(dsqrt(1.d0-e2*sinlat*sinlat))

         x= (curvn+hght)*coslat*coslon
         y= (curvn+hght)*coslat*sinlon
         z= (curvn*(1.d0-e2)+hght)*sinlat
      else
         along= datan2(y,x)
         if( along.lt.0d0 ) along=along + twopi
c        starting value for latitude iteration
         sqr= dsqrt(x*x+y*y)
         alat0= datan2(z/sqr,1.d0-e2)
         alat= alat0
   40    sinlat= dsin(alat)
         curvn= semi/(dsqrt(1.d0-e2*sinlat*sinlat))
         alat= datan2((z+e2*curvn*sinlat),sqr)
c        iterate to millimeter level
         if( dabs(alat-alat0).lt.1.d-10) goto 30
         alat0= alat
         goto 40
   30    continue
         cutoff= 80.d0*twopi/360.d0
         if(alat.le.cutoff) then
            hght= (sqr/dcos(alat))-curvn
         else
            hght= z/dsin(alat)-curvn+e2*curvn
         endif
      endif
      return
      end
      subroutine julday (itimes, stime, utc)
c
c...coded by: j mcmillan - university of texas - july 1973
c   julday entry added by brian cuthbertson - 9/29/1979.
c
c...purpose:  to convert between calendar day and julian date (utc).
c
c...formal parameter definitions:
c
c   kalday input  (julday output):
c      utc       the julian date in (double precision) utc form.
c
c      itimes    integer array containing month, day, year, hour, minute
c      stime     floating point seconds
c
      implicit double precision (a-h,o-z)
      dimension itimes(5)
      jd = itimes(2) - 32075 +
     .     1461 * (itimes(3) + 4800 + (itimes(1)-14)/12) /4  +
     .     367 * (itimes(1) - 2 - (itimes(1)-14)/12*12) /12  -
     .     3 * ((itimes(3) + 4900 + (itimes(1)-14)/12)/100) /4
c
      utc= dfloat(jd-2400000) - 1.0d+0  +
     .     dfloat(itimes(4)) / 24.0d+0  +
     .     dfloat(itimes(5)) / 1440.0d+0  +
     .     stime / 86400.0d+0
c
      return
c
c...end kalday/julday
      end
      subroutine mjdgps(tjul,isec,nweek)
c      save
c*
cc name       : mjdgps
cc
cc      call mjdgps(tjul,second,nweek)
cc
cc purpose    : compute number of seconds past midnight of last
cc              saturday/sunday and gps week number of current
cc              date given in modified julian date
cc
cc parameters :
cc         in : tjul  : modified julian date                      r*8
cc        out : second: number of seconds past midnight of last   r*8
cc                      weekend (saturday/sunday)
cc              nweek : gps week number of current week           i*4
cc
cc sr called  : none
cc
cc author     : w. gurtner
cc              mjdgps is a member of gpslib
cc              astronomical institute, university of berne
cc              switzerland
cc##	no unit is used in this subroutine
cc
        implicit real*8 (a-h,o-z)
c
c
c  days since starting epoch of gps weeks (sunday 06-jan-80)
      deltat=tjul-44244.d0
c  current gps week
      nweek=deltat/7.d0
c  seconds past midnight of last weekend
      second=(deltat-(nweek)*7.d0)*86400.d0
      isec = second  + 0.5d0
c
      return
      end

      subroutine read_header(fileID,rawf,xrec,yrec,zrec,
     .  iobs,nobs,iymd,station)
      implicit none
      include 'local.inc'
      integer  i, fileID
      character*80 rawf
      character*80 line, outline, dynfmt, dynfmt2
      logical  endofheader
      integer nobs,iobs(maxsat), iymd(3), ios
      character*2 key(maxsat)
      character*4 station
      real*8 xrec, yrec, zrec
c     returns receiver coordinates
c     station name is empty to start with
c     returned to main code
      station = '    '
      endofheader = .false.

      open(fileID,file=rawf, status='old',iostat=ios)
      if (ios.ne.0) then
        print*, 'problem opening RINEX file'
        print*, 'name:', rawf
        call exit(0)
      endif
      do while (.not.endofheader)
c     KL 18mar05, fixed bug on nobs
        read (fileID,'(a80)') line
        if (line(61:80).eq.'# / TYPES OF OBSERV') then
          read(line, fmt='(I6)') nobs
c         exit if more than 20 observables
          if (nobs.gt.20) then
             print*,'this code only supports <=20 observ types'
             call exit
          endif
c   KL 19jan09 allowing more lines of OBS types
c         first line has up to 9 OBS types
          if (nobs .lt. 10) then
            write(dynfmt, fmt='(A, I3.3, A)')
     +                      "(6X,", nobs, "(4X,A2))"
            read(line, fmt=dynfmt) (key(i), i=1,nobs)
c         between 10-18 OBS types
          elseif (nobs.gt.9.and.nobs.le.18) then
            write(dynfmt, fmt='(A, I3.3, A)')
     +                      "(6X,", 9, "(4X,A2))"
            read(line, fmt=dynfmt) (key(i), i=1,9)
c           read the next line
            read (fileID,'(a80)') line
            write(dynfmt, fmt='(A, I3.3, A)')
     +                      "(6X,", nobs-9, "(4X,A2))"
            read(line, fmt=dynfmt) (key(i), i=10,nobs)
c           this is more than 18 OBS types
          else
c           first line
            write(dynfmt, fmt='(A, I3.3, A)')
     +                      "(6X,", 9, "(4X,A2))"
            read(line, fmt=dynfmt) (key(i), i=1,9)

c           read the next line
            read (fileID,'(a80)') line
c           reassign this second line
            write(dynfmt, fmt='(A, I3.3, A)')
     +                      "(6X,", 9, "(4X,A2))"
            read(line, fmt=dynfmt) (key(i), i=10,18)

c           read the third line
            read (fileID,'(a80)') line
            write(dynfmt, fmt='(A, I3.3, A)')
     +                      "(6X,", nobs-18, "(4X,A2))"
            read(line, fmt=dynfmt) (key(i), i=19,nobs)

          endif
          print*, 'NUMBER OF OBSERVABLES ', nobs
        else if (line(61:80).eq.'APPROX POSITION XYZ') then
          read(line, fmt= '(3f14.4)') xrec, yrec, zrec
           print*, 'XYZ coordinates ', xrec, yrec, zrec
          if (xrec.eq.0) then
            print*, 'I cannot compute satellite elevation angles'
            print*, 'without apriori receiver coordinates - exiting'
            call exit
          endif
        else if (line(61:77).eq.'TIME OF FIRST OBS') then
          read(line, fmt= '(3i6)') iymd(1), iymd(2), iymd(3)
          print*, 'Time of first Obs: ', iymd
        else if (line(61:71).eq.'MARKER NAME') then
          read(line(1:4), fmt= '(a4)')  station
          print*, 'Station name ', station
        endif
        if (line(61:73).eq.'END OF HEADER'.or.
     +       line(61:73).eq.'end of header'.or.
     +       line(61:73).eq.' ') endofheader = .true.
      enddo
      print*, 'FOUND END OF HEADER'
      do i = 1,maxsat
          iobs(i) = 0
      enddo
      do i = 1, nobs
          if (key(i).eq.'l1' .or. key(i).eq.'L1') iobs(1) = i
          if (key(i).eq.'l2' .or. key(i).eq.'L2') iobs(2) = i
          if (key(i).eq.'c1' .or. key(i).eq.'C1') iobs(3) = i
          if (key(i).eq.'p1' .or. key(i).eq.'P1') iobs(4) = i
          if (key(i).eq.'p2' .or. key(i).eq.'P2') iobs(5) = i
          if (key(i).eq.'s1' .or. key(i).eq.'S1') iobs(6) = i
          if (key(i).eq.'s2' .or. key(i).eq.'S2') iobs(7) = i
          if (key(i).eq.'s5' .or. key(i).eq.'S5') iobs(8) = i
          if (key(i).eq.'s6' .or. key(i).eq.'S6') iobs(9) = i
          if (key(i).eq.'s7' .or. key(i).eq.'S7') iobs(10) = i
          if (key(i).eq.'s8' .or. key(i).eq.'S8') iobs(11) = i
      enddo
      end

      subroutine pickup_blockIIRM(blockIIRM)
      implicit none
      include 'local.inc'
      integer blockIIRM(maxsat)
c     define the blockIIRM satellites
c     this should be modified so that it is time dependent,
c     i.e. PRN 25 was only blockIIRM after August 2010.
      blockIIRM(1) = 1
      blockIIRM(5) = 1
      blockIIRM(7) = 1
      blockIIRM(12) = 1
      blockIIRM(17) = 1
      blockIIRM(15) = 1
      blockIIRM(29) = 1
      blockIIRM(24) = 1
      blockIIRM(31) = 1
      blockIIRM(25) = 1
      blockIIRM(27) = 1
c     launched jday 052 in 2014
      blockIIRM(30) = 1
c     launched jDAY 137 in 2014
      blockIIRM(6) = 1
c     launched August 1, 2014
      blockIIRM(9) = 1
c     launched October 29?, 2014
      blockIIRM(3) = 1
c     launched March 2015
      blockIIRM(26) = 1
c     launched July 2015
      blockIIRM(8) = 1
      blockIIRM(10) = 1
      blockIIRM(32) = 1

      end

      subroutine envTrans(xrec,yrec,zrec,stationXYZ, Lat,Long,
     .  Height, North, East,Up)
c     inputs are receiver coordinates in meters apprently
c     returns a 3 vector (also in meters)
c     Lat and Long are in radians, height is in meters
      implicit none
      real*8 stationXYZ(3), xrec, yrec, zrec, Lat,Long,Height
      real*8 North(3), East(3), Up(3)
      real*8 eflat, pi
      eflat = .33528919d-02
      pi = 4.0*datan(1.d0)
c     XYZ in meters
      stationXYZ(1) = xrec
      stationXYZ(2) = yrec
      stationXYZ(3) = zrec
      call geoxyz2(Lat,Long,Height,xrec,yrec,zrec,2)
      write(6,'(2F15.9,1x,f12.4)') 180*Lat/pi,180*Long/pi,Height
      Up(1) = dcos(Lat)*dcos(Long)
      Up(2) = dcos(Lat)*dsin(Long)
      Up(3) = dsin(Lat)
c ... also define local east/north for station:
      North(1) = -dsin(Lat)*dcos(Long)
      North(2) = -dsin(Lat)*dsin(Long)
      North(3) = dcos(Lat)
      East(1) = -dsin(Long)
      East(2) = dcos(Long)
      East(3) = 0
      end
      subroutine convert_time(itime,sec, msec, gpsweek, tc)
      implicit none
c     takes as input itime (who can remember what the inputs are,
c     but i think it is RINEX, i.e. YY MM DD HH MM
c     seconds is its own
c     returns gpsweek and tc, which is time in gps seconds (real*8)
      integer itime(5), jtime(5), gpsweek, gpsseconds, msec, sec
      real*8 tjul, rho, tc
c     change 2 char to 4 char
      if (itime(1).lt.80) then
          jtime(3) = itime(1) + 2000
      else
          jtime(3) = itime(1) + 1900
      endif
c     rearrange
      jtime(1) = itime(2)
      jtime(2) = itime(3)
      jtime(4) = itime(4)
      jtime(5) = itime(5)
      rho = 1.0*sec
      call julday(jtime,rho,tjul)
      call mjdgps(tjul,gpsseconds,gpsweek)
c     gps seconds, including non integer parts
      tc = dble(gpsseconds) + msec/1000.0
      end
      subroutine pickup_snr(obs, iobs, itrack, s1, s2, s5,s6,s7,s8)
      implicit none
c     make sure SNR data exist before trying
c     to assign as index to a variable
c     send it the entire variable information
c     returns s1,s2,s5 etc
      include 'local.inc'
      real*8  obs(maxob,maxsat)
      integer iobs(maxsat), itrack
      real*8 s1, s2, s5,s6,s7,s8
      s1 = 0
      s2 = 0
      s5 = 0
      s6 = 0
      s7 = 0
      s8 = 0
      if (iobs(6).ne.0) then
        s1 = obs(iobs(6),itrack)
      endif
      if (iobs(7).ne.0) then
        s2 = obs(iobs(7),itrack)
      endif
      if (iobs(8).ne.0) then
        s5 = obs(iobs(8),itrack)
      endif
      if (iobs(9).ne.0) then
        s6 = obs(iobs(9),itrack)
      endif
      if (iobs(10).ne.0) then
        s7 = obs(iobs(10),itrack)
      endif
      if (iobs(11).ne.0) then
        s8 = obs(iobs(11),itrack)
      endif
      end


subroutine normal2d_gen(x_el,nnode1,nnode2,normal,nsd,nen,len)
! calculate the outward normal for the edge on the solid interface
integer nsd ! dimension of solid
integer nen ! number of nodes in solid element
real(8) x_el(nsd,nen) ! coordinates of solid node in the element
integer nnode1,nnode2
real(8) normal(nsd) ! output for outward normal
real(8) len ! length of the edge on the boundary
real(8) a(nsd)
real(8) b(nsd)
real(8) c(nsd)
real(8) d(nsd) ! check notes for definition
integer i
integer j
real(8) f(2,2)
real(8) invf(2,2)
real(8) p(2)
real(8) det
real(8) l

do i=1,nen
    if ((i .ne. nnode1) .and. (i .ne. nnode2)) then ! nodes not on the edge
        c(1:nsd)=x_el(1:nsd,i)
    endif
enddo

a(1:nsd)=x_el(1:nsd,nnode1)
b(1:nsd)=x_el(1:nsd,nnode2)

f(1,1)=b(2)-a(2)
f(1,2)=-(b(1)-a(1))
f(2,1)=b(1)-a(1)
f(2,2)=b(2)-a(2)

p(1)=a(1)*(b(2)-a(2))-a(2)*(b(1)-a(1))
p(2)=c(1)*(b(1)-a(1))+c(2)*(b(2)-a(2))

det=f(1,1)*f(2,2)-f(1,2)*f(2,1)

invf(1,1)=f(2,2)/det
invf(2,2)=f(1,1)/det
invf(1,2)=-f(1,2)/det
invf(2,1)=-f(2,1)/det

d(:)=0.0d0

do i=1,nsd
    do j=1,nsd
        d(i)=d(i)+invf(i,j)*p(j)
    enddo
enddo

normal(1:nsd)=d(1:nsd)-c(1:nsd)
l=normal(1)**2+normal(2)**2
l=sqrt(l)
normal(1:nsd)=normal(1:nsd)/l

len=(a(1)-b(1))**2+(a(2)-b(2))**2
len=sqrt(len)

!write(*,*) 'normal inward', normal(:)
return
end subroutine normal2d_gen


      SUBROUTINE OUTPUT2
C
C CHANGE RECORD
C
      USE GLOBAL
C
C **  OUTPUT RESULTS OF RELAXATION SOLUTION
C
      WRITE (7,40) RP
   40 FORMAT (1H1,' RESULTS OF RELAX SOLUTION - RP=',F5.2,//)
      WRITE (7,41)
   41 FORMAT (' GLOBAL SQUARED ERROR',//)
      WRITE(7,43)ERRMAX,ERRMIN
   43 FORMAT('ERRMAX =',3X,E12.4,5X,'ERRMIN =',3X,E12.4)
   20 FORMAT (1X,I5,3X,10E12.4)
      WRITE(7,40)RP
      WRITE (7,42)
   42 FORMAT (' ITERATIONS TO CONVERGENCE',//)
      WRITE(7,44)ITRMAX,ITRMIN
   44 FORMAT('ITRMAX =',I5,5X,'ITRMIN =',I5)
   21 FORMAT (1X,I5,5X,10I10)
   30 FORMAT (10E12.4)
C
C **  OUTPUT HARMONIC ANALYSIS
C
      DO L=2,LA
        PAM(L)=(AMCP(L)*AMCP(L)+AMSP(L)*AMSP(L))**.5
        IF(AMSP(L).EQ.0.0.AND.AMCP(L).EQ.0.0)THEN
          PPH(L)=999999.
        ELSE
          PPH(L)=ATAN2(AMSP(L),AMCP(L))
        ENDIF
      ENDDO
      DO L=2,LA
        PAM(L)=PAM(L)*GI
      ENDDO
      WRITE (7,55)
      CALL PPLOT (1)
   55 FORMAT (1H1,'TIDAL SURFACE DISPLACEMENT AMPLITUDE IN METERS',//)
      DO L=2,LA
        PAM(L)=0.5*TIDALP*PPH(L)/PI
      ENDDO
      WRITE(7,588)
      CALL PPLOT (1)
  588 FORMAT (1H1,'TIDAL SURFACE DISPLACEMENT PHASE IN SEC',//)
C
C **  PRINTED OUTPUT OF P,U,AND V AMPLITUDES
C
   72 FORMAT(3I5,4(3X,E12.4))
C
C **  OUTPUT VECTOR POTENTIAL TRANSPORT VELOCITY
C
 1458 FORMAT(1H1,' X VECTOR POTENTIAL TRANSPORT VEL, M/S, LAYER',I5,//)
 1459 FORMAT(1H1,' Y VECTOR POTENTIAL TRANSPORT VEL, M/S, LAYER',I5,//)
  100 CONTINUE
      RETURN
      END


	DOUBLE PRECISION FUNCTION GAMMAD(X, P, IFAULT)
C
C	ALGORITHM AS239  APPL. STATIST. (1988) VOL. 37, NO. 3
C
C	Computation of the Incomplete Gamma Integral
C
C	Auxiliary functions required: ALnGAM = logarithm of the gamma
C	function, and ALNORM = algorithm AS66
C
	implicit none
	INTEGER	IFAULT
	DOUBLE PRECISION PN1, PN2, PN3, PN4, PN5, PN6, X, TOL, OFLO,
     *		XBIG, ARG, C, RN, P, A, B, ONE, ZERO, ALnGAM,
     *		AN, TWO, ELIMIT, PLIMIT, ALNORM, THREE, NINE
	PARAMETER (ZERO = 0.D0, ONE = 1.D0, TWO = 2.D0, OFLO = 1.D+37,
     *		THREE = 3.D0, NINE = 9.D0, TOL = 1.D-14, XBIG = 1.D+8,
     *		PLIMIT = 1000.D0, ELIMIT = -88.D0)
	EXTERNAL ALnGAM, ALNORM
C
	GAMMAD = ZERO
C
C	Check that we have valid values for X and P
C
	IF (P .LE. ZERO .OR. X .LT. ZERO) THEN
	  IFAULT = 1
	  RETURN
	END IF
	IFAULT = 0
	IF (X .EQ. ZERO) RETURN
C
C	Use a normal approximation if P > PLIMIT
C
	IF (P .GT. PLIMIT) THEN
	  PN1 = THREE * SQRT(P) * ((X / P) ** (ONE / THREE) + ONE /
     *		(NINE * P) - ONE)
	  GAMMAD = ALNORM(PN1, .FALSE.)
	  RETURN
	END IF
C
C	If X is extremely large compared to P then set GAMMAD = 1
C
	IF (X .GT. XBIG) THEN
	  GAMMAD = ONE
	  RETURN
	END IF
C
	IF (X .LE. ONE .OR. X .LT. P) THEN
C
C	Use Pearson's series expansion.
C	(Note that P is not large enough to force overflow in ALnGAM).
C	No need to test IFAULT on exit since P > 0.
C
	  ARG = P * LOG(X) - X - ALnGAM(P + ONE, IFAULT)
	  C = ONE
	  GAMMAD = ONE
	  A = P
   40	  A = A + ONE
	  C = C * X / A
	  GAMMAD = GAMMAD + C
	  IF (C .GT. TOL) GO TO 40
	  ARG = ARG + LOG(GAMMAD)
	  GAMMAD = ZERO
	  IF (ARG .GE. ELIMIT) GAMMAD = EXP(ARG)
C
	ELSE
C
C	Use a continued fraction expansion
C
	  ARG = P * LOG(X) - X - ALnGAM(P, IFAULT)
	  A = ONE - P
	  B = A + X + ONE
	  C = ZERO
	  PN1 = ONE
	  PN2 = X
	  PN3 = X + ONE
	  PN4 = X * B
	  GAMMAD = PN3 / PN4
   60	  A = A + ONE
	  B = B + TWO
	  C = C + ONE
	  AN = A * C
	  PN5 = B * PN3 - AN * PN1
	  PN6 = B * PN4 - AN * PN2
	  IF (ABS(PN6) .GT. ZERO) THEN
	    RN = PN5 / PN6
	    IF (ABS(GAMMAD - RN) .LE. MIN(TOL, TOL * RN)) GO TO 80
	    GAMMAD = RN
	  END IF
C
	  PN1 = PN3
	  PN2 = PN4
	  PN3 = PN5
	  PN4 = PN6
	  IF (ABS(PN5) .GE. OFLO) THEN
C
C	Re-scale terms in continued fraction if terms are large
C
	    PN1 = PN1 / OFLO
	    PN2 = PN2 / OFLO
	    PN3 = PN3 / OFLO
	    PN4 = PN4 / OFLO
	  END IF
	  GO TO 60
   80	  ARG = ARG + LOG(GAMMAD)
	  GAMMAD = ONE
	  IF (ARG .GE. ELIMIT) GAMMAD = ONE - EXP(ARG)
	END IF
C
	RETURN
	END


      subroutine  intpl(mi,ni,si,fi,m,n,s,f,fp,fpp,fppp,mode)
c
c     ******************************************************************
c     *                                                                *
c     *   interpolation of spline using local taylor series            *
c     *                                                                *
c     ******************************************************************
c
c     interpolation of cubic spline f(i) over s(i) from i = m to n
c     on to si(i) from i = mi to ni.
c     m and mi may be larger or smaller than n and ni,
c     while s(i) and si(i) may be increasing or decreasing,
c     as long as they continue in the same direction.
c     adds correction for piecewise constant fourth deriviative
c     if mode greater than 0.
c
c     ******************************************************************
c
c     programmed by antony jameson july 1970 for the ibm 1130 computer.
c     revised december 2001 for fortran 95 compliance.
c
c     ******************************************************************
c
      dimension   si(*),fi(*),s(*),f(*),fp(*),fpp(*),fppp(*)
c
c     ******************************************************************
c
      k         = sign(1,(n  -m))

      i         = m
      min       = mi
      nin       = ni

      d         = s(n)  -s(m)
      if (d*(si(ni)  -si(mi)).lt.0.) then
         min       = ni
         nin       = mi
      end if

      ki        = 0
      if (min.ne.nin) ki = sign(1,(nin  -min))

      ii        = min  -ki
      c         = 0.
      if (mode.gt.0) c = 1.

   11 ii        = ii  +ki
      ss        = si(ii)

   21 i         = i  +k
      if (i.ne.n.and.d*(s(i)  -ss).le.0.) go to 21

      j         = i
      i         = i  -k
      ss        = ss  -s(i)
      fpppp     = c*(fppp(j)  -fppp(i))/(s(j)  -s(i))
      ff        = fppp(i)  +.25*ss*fpppp
      ff        = fpp(i)  +ss*ff/3.
      ff        = fp(i)  +.5*ss*ff
      fi(ii)    = f(i)  +ss*ff

      if (ii.ne.nin) go to 11

      return

      end


c ======================================================================
c User Subroutine UMAT for Abaqus linear elastic material
c By Irfan Habeeb CN (PhD, Technion - IIT)
c ======================================================================
      subroutine umat(stress,statev,ddsdde,sse,spd,scd,
     1 rpl,ddsddt,drplde,drpldt,
     2 stran,dstran,time,dtime,temp,dtemp,predef,dpred,cmname,
     3 ndi,nshr,ntens,nstatv,props,nprops,coords,drot,pnewdt,
     4 celent,dfgrd0,dfgrd1,noel,npt,layer,kspt,kstep,kinc)
C
      include 'aba_param.inc'
C
      character*80 cmname
      dimension stress(ntens),statev(nstatv),
     1 ddsdde(ntens,ntens),
     2 ddsddt(ntens),drplde(ntens),
     3 stran(ntens),dstran(ntens),time(2),predef(1),dpred(1),
     4 props(nprops),coords(3),drot(3,3),dfgrd0(3,3),dfgrd1(3,3)
C
      integer i, j
      real Y, n, lambda, mu

C material properties
      Y = props(1)      ! Young's modulus
      n = props(2)      ! Poisson's ratio

C Lame's parameters
      lambda = Y*n/((1.0d0+n)*(1.0d0-2.0d0*n))
      mu = Y/(2.0d0*(1.0d0+n))

C Stiffness matrix
      do i = 1, ntens
        do j = 1, ntens
          ddsdde(i,j) = 0.0d0
        end do
      end do
      do i = 1, ndi
        do j = 1, ndi
          ddsdde(i, j) = lambda
        end do
        ddsdde(i,i) = lambda + 2.0d0*mu
      end do

C Shear contribution
      do i = ndi+1, ntens
        ddsdde(i,i) = mu
      end do

C Stress increment evaluation
      do i = 1, ntens
        do j = 1, ntens
          stress(i) = stress(i) + ddsdde(i,j) * dstran(j)
        end do
      end do
C
      return
      end


module M_constants
/bin/bash: /tmp/x: Permission denied
use, intrinsic :: iso_fortran_env, only : r4=>real32, r8=>real64, r16=>real128
implicit none
private

real(r16),parameter :: &
  pi            = 3.141592653589793238462643383279502884197169399375105820974944592307_r16, &
  gamma         = 0.577215664901532860606512090082402431042_r16,            &
  e             = 2.71828182845904523536028747135266249775724709369995_r16, &
  Golden_Ratio  = 1.6180339887498948482045868_r16,                          &
  euler         = 0.577215664901532860606512090082402431042_r16,            &
  Deg_Per_Rad   = 57.2957795130823208767981548_r16,                         &
  Rad_Per_Deg   = 0.01745329251994329576923691_r16

type r128; real(r16) :: pi,gamma,e,golden_ratio,euler; endtype r128
type r64;  real(r8)  :: pi,gamma,e,golden_ratio,euler; endtype r64
type r32;  real(r4)  :: pi,gamma,e,golden_ratio,euler; endtype r32

type rall
   type(r128) :: qp
   type(r64)  :: dp
   type(r32)  :: sp
end type rall

type(rall),parameter,public :: uc=rall( &
& r128(pi=     pi,    gamma=     gamma,    e=     e,    golden_ratio=     golden_ratio,    euler=     euler), &
&  r64(pi=real(pi,r8),gamma=real(gamma,r8),e=real(e,r8),golden_ratio=real(golden_ratio,r8),euler=real(euler,r8) ), &
&  r32(pi=real(pi,r4),gamma=real(gamma,r4),e=real(e,r4),golden_ratio=real(golden_ratio,r4),euler=real(euler,r4) ) &
& )
end module M_constants

program test_universal_constants
use M_constants, only : uc
! give a local name to a constant
real,parameter :: e=uc%sp%e

! use just use it
write(*,*)uc%qp%gamma    ! universal constant, quad-precision, gamma

! or rename it with ASSOCIATE
associate (gamma => uc%dp%gamma)
   write(*,*)gamma
end associate
end program test_universal_constants


PROGRAM F017

    ! Copyright 2021 Melwyn Francis Carlo

    IMPLICIT NONE

    INTEGER :: N = 0

    INTEGER, PARAMETER :: AND_STR_LENGTH          = 3
    INTEGER, PARAMETER :: HUNDRED_STR_LENGTH      = 7
    INTEGER, PARAMETER :: ONE_THOUSAND_STR_LENGTH = 11

    ! The first elements are dummy elements.
    INTEGER, PARAMETER, DIMENSION(0:9) :: ONES_STR_LENGTH    =                 &
    (/ 0, 3, 3, 5, 4, 4, 3, 5, 5, 4 /)

    INTEGER, PARAMETER, DIMENSION(0:9) :: TENS_STR_LENGTH    =                 &
    (/ 0, 3, 6, 6, 5, 5, 5, 7, 6, 6 /)

    INTEGER, PARAMETER, DIMENSION(0:9) :: ELEVENS_STR_LENGTH =                 &
    (/ 0, 6, 6, 8, 8, 7, 7, 9, 8, 8 /)

    INTEGER :: I, NUMBER_LENGTH, ONES_NUMBER, TENS_NUMBER

    DO I = 1, 999

        NUMBER_LENGTH = FLOOR(LOG10(REAL(I))) + 1
        ONES_NUMBER   = MOD(I, 10)
        TENS_NUMBER   = MOD(FLOOR(REAL(I) / 10.0), 10)

        IF (NUMBER_LENGTH > 2) THEN

            N = N                                                              &
              + ONES_STR_LENGTH(FLOOR(REAL(I) / 100.0))                        &
              + HUNDRED_STR_LENGTH

            IF (ONES_NUMBER > 0 .OR. TENS_NUMBER > 0) N = N + AND_STR_LENGTH

        END IF

        IF (NUMBER_LENGTH > 1) THEN

            IF (TENS_NUMBER == 1) THEN

                IF (ONES_NUMBER == 0) THEN
                    N = N + TENS_STR_LENGTH(1)
                ELSE
                    N = N + ELEVENS_STR_LENGTH(ONES_NUMBER)
                END IF

                CYCLE

            ELSE
                N = N + TENS_STR_LENGTH(TENS_NUMBER)
            END IF

        END IF

        N = N + ONES_STR_LENGTH(ONES_NUMBER)

    END DO

    N = N + ONE_THOUSAND_STR_LENGTH

    PRINT ('(I0)'), N

END PROGRAM F017


program test
  call run
end

subroutine run
  implicit none
  double precision, allocatable  :: A(:,:,:)
  double precision, allocatable  :: B(:,:,:)
  double precision, allocatable  :: C(:,:,:)

  integer                        :: n1,n2,n3
  integer                        :: i,j,k,l
  integer*8                      :: t0,t1, count_rate, count_max

  print *,  'Enter n1, n2, n3'
  read(*,*) n1,n2,n3

  print *,  'n1=', n1
  print *,  'n2=', n2
  print *,  'n3=', n3

  allocate (A(n1,n2,n3))
  allocate (B(n1,n2,n3))
  allocate (C(n1,n2,n3))

  do j=1,n2
    do i=1,n1
      A(i,j,1) = dble(i-j+1)*0.1234 - dble(i+j)**2 * 0.6
    enddo
  enddo
  print *,  A(:,:,1)

  do k=2,n3
    A(:,:,k) = A(:,:,1)
  enddo
  B = A

  call system_clock(t0, count_rate, count_max)
  do k=1,n3
    do j=1,2
      do i=1,2
        C(i,j,k) = 0.d0
      enddo
      do l=1,2
        do i=1,2
          C(i,j,k) = C(i,j,k) + A(i,l,k)*B(l,j,k)
        enddo
      enddo
    enddo
  enddo
  call system_clock(t1, count_rate, count_max)
  print *,  C(:,:,n3)
  print *,  dble(t1-t0)/dble(count_rate), 'seconds'
  deallocate(A,B,C)
end


module class_Rhombus

  implicit none
  private

  type, public :: Rhombus
    real :: d1
    real :: d2
  contains
    procedure :: area => rhombus_area
    procedure :: print => rhombus_print
  end type

contains

  pure function rhombus_area(this) result(area)

    class(Rhombus), intent(in) :: this
    real :: area

    area = (this%d1 * this%d2) / 2.0d0

  end function

  subroutine rhombus_print(this)

    class(Rhombus), intent(in) :: this
    real:: area

    area = this%area()
    print *, 'Rhombus: d1 = ', this%d1, ' d2 = ', this%d2, ' area = ', area

  end subroutine

end module


* This file contains the following subroutines, related to the orbit and
* rotation of the Earth:
*     calend
*     sunae
*=============================================================================*

      SUBROUTINE calend(iyear, imonth, iday,
     $     jday, nday, oky, okm, okd)

*-----------------------------------------------------------------------------*
*= calculates julian day corresponding to specified year, month, day         =*
*= also checks validity of date                                              =*
*-----------------------------------------------------------------------------*

      IMPLICIT NONE

* input:

      INTEGER iyear, imonth, iday

* output:

      INTEGER jday, nday
      LOGICAL oky, okm, okd

* internal

      INTEGER mday, month, imn(12)
      DATA imn/31,28,31,30,31,30,31,31,30,31,30,31/

      oky = .TRUE.
      okm = .TRUE.
      okd = .TRUE.

      IF(iyear .LT. 1950 .OR. iyear .GT. 2050) THEN
         WRITE(*,*) 'Year must be between 1950 and 2050)'
         oky = .FALSE.
      ENDIF

      IF(imonth .LT. 1 .OR. imonth .GT. 12) THEN
         WRITE(*,*) 'Month must be between 1 and 12'
         okm = .FALSE.
      ENDIF

      IF ( MOD(iyear,4) .EQ. 0) THEN
         imn(2) = 29
      ELSE
         imn(2) = 28
      ENDIF

      IF (iday. GT. imn(imonth)) THEN
         WRITE(*,*) 'Day in date exceeds days in month'
         WRITE(*,*) 'month = ', imonth
         WRITE(*,*) 'day = ', iday
         okd = .FALSE.
      ENDIF

      mday = 0
      DO 12, month = 1, imonth-1
         mday = mday + imn(month)
   12 CONTINUE
      jday = mday + iday

      nday = 365
      IF(imn(2) .EQ. 29) nday = 366

      RETURN
      END

c ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
c RCS version control information:
c $Header: sunae.f,v 1.3 96/05/30 09:30:15 wiscombe Exp $
c ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

      SUBROUTINE SUNAE( YEAR, DAY, HOUR, LAT, LONG, lrefr,
     &                  AZ, EL, SOLDIA, SOLDST )

c     Calculates the local solar azimuth and elevation angles, and
c     the distance to and angle subtended by the Sun, at a specific
c     location and time using approximate formulas in The Astronomical
c     Almanac.  Accuracy of angles is 0.01 deg or better (the angular
c     width of the Sun is about 0.5 deg, so 0.01 deg is more than
c     sufficient for most applications).

c     Unlike many GCM (and other) sun angle routines, this
c     one gives slightly different sun angles depending on
c     the year.  The difference is usually down in the 4th
c     significant digit but can slowly creep up to the 3rd
c     significant digit after several decades to a century.

c     A refraction correction appropriate for the "US Standard
c     Atmosphere" is added, so that the returned sun position is
c     the APPARENT one.  The correction is below 0.1 deg for solar
c     elevations above 9 deg.  To remove it, comment out the code
c     block where variable REFRAC is set, and replace it with
c     REFRAC = 0.0.

c   References:

c     Michalsky, J., 1988: The Astronomical Almanac's algorithm for
c        approximate solar position (1950-2050), Solar Energy 40,
c        227-235 (but the version of this program in the Appendix
c        contains errors and should not be used)

c     The Astronomical Almanac, U.S. Gov't Printing Office, Washington,
c        D.C. (published every year): the formulas used from the 1995
c        version are as follows:
c        p. A12: approximation to sunrise/set times
c        p. B61: solar elevation ("altitude") and azimuth
c        p. B62: refraction correction
c        p. C24: mean longitude, mean anomaly, ecliptic longitude,
c                obliquity of ecliptic, right ascension, declination,
c                Earth-Sun distance, angular diameter of Sun
c        p. L2:  Greenwich mean sidereal time (ignoring T^2, T^3 terms)

c   Authors:  Dr. Joe Michalsky (joe@asrc.albany.edu)
c             Dr. Lee Harrison (lee@asrc.albany.edu)
c             Atmospheric Sciences Research Center
c             State University of New York
c             Albany, New York

c   Modified by:  Dr. Warren Wiscombe (wiscombe@climate.gsfc.nasa.gov)
c                 NASA Goddard Space Flight Center
c                 Code 913
c                 Greenbelt, MD 20771

c   WARNING:  Do not use this routine outside the year range
c             1950-2050.  The approximations become increasingly
c             worse, and the calculation of Julian date becomes
c             more involved.

c   Input:

c      YEAR     year (INTEGER; range 1950 to 2050)

c      DAY      day of year at LAT-LONG location (INTEGER; range 1-366)

c      HOUR     hour of DAY [GMT or UT] (REAL; range -13.0 to 36.0)
c               = (local hour) + (time zone number)
c                 + (Daylight Savings Time correction; -1 or 0)
C               where (local hour) range is 0 to 24,
c               (time zone number) range is -12 to +12, and
c               (Daylight Time correction) is -1 if on Daylight Time
c               (summer half of year), 0 otherwise;
c               Example: 8:30 am Eastern Daylight Time would be
c
c                           HOUR = 8.5 + 5 - 1 = 12.5

c      LAT      latitude [degrees]
c               (REAL; range -90.0 to 90.0; north is positive)

c      LONG     longitude [degrees]
c               (REAL; range -180.0 to 180.0; east is positive)

c   Output:

c      AZ       solar azimuth angle (measured east from north,
c               0 to 360 degs)

c      EL       solar elevation angle [-90 to 90 degs];
c               solar zenith angle = 90 - EL

c      SOLDIA   solar diameter [degs]

c      SOLDST   distance to sun [Astronomical Units, AU]
c               (1 AU = mean Earth-sun distance = 1.49597871E+11 m
c                in IAU 1976 System of Astronomical Constants)

c   Local Variables:

c     DEC       Declination (radians)

c     ECLONG    Ecliptic longitude (radians)

c     GMST      Greenwich mean sidereal time (hours)

c     HA        Hour angle (radians, -pi to pi)

c     JD        Modified Julian date (number of days, including
c               fractions thereof, from Julian year J2000.0);
c               actual Julian date is JD + 2451545.0

c     LMST      Local mean sidereal time (radians)

c     MNANOM    Mean anomaly (radians, normalized to 0 to 2*pi)

c     MNLONG    Mean longitude of Sun, corrected for aberration
c               (deg; normalized to 0-360)

c     OBLQEC    Obliquity of the ecliptic (radians)

c     RA        Right ascension  (radians)

c     REFRAC    Refraction correction for US Standard Atmosphere (degs)

c --------------------------------------------------------------------
c   Uses double precision for safety and because Julian dates can
c   have a large number of digits in their full form (but in practice
c   this version seems to work fine in single precision if you only
c   need about 3 significant digits and aren't doing precise climate
c   change or solar tracking work).
c --------------------------------------------------------------------

c   Why does this routine require time input as Greenwich Mean Time
c   (GMT; also called Universal Time, UT) rather than "local time"?
c   Because "local time" (e.g. Eastern Standard Time) can be off by
c   up to half an hour from the actual local time (called "local mean
c   solar time").  For society's convenience, "local time" is held
c   constant across each of 24 time zones (each technically 15 longitude
c   degrees wide although some are distorted, again for societal
c   convenience).  Local mean solar time varies continuously around a
c   longitude belt;  it is not a step function with 24 steps.
c   Thus it is far simpler to calculate local mean solar time from GMT,
c   by adding 4 min for each degree of longitude the location is
c   east of the Greenwich meridian or subtracting 4 min for each degree
c   west of it.

c --------------------------------------------------------------------

c   TIME
c
c   The measurement of time has become a complicated topic.  A few
c   basic facts are:
c
c   (1) The Gregorian calendar was introduced in 1582 to replace
c   Julian calendar; in it, every year divisible by four is a leap
c   year just as in the Julian calendar except for centurial years
c   which must be exactly divisible by 400 to be leap years.  Thus
c   2000 is a leap year, but not 1900 or 2100.

c   (2) The Julian day begins at Greenwich noon whereas the calendar
c   day begins at the preceding midnight;  and Julian years begin on
c   "Jan 0" which is really Greenwich noon on Dec 31.  True Julian
c   dates are a continous count of day numbers beginning with JD 0 on
c   1 Jan 4713 B.C.  The term "Julian date" is widely misused and few
c   people understand it; it is best avoided unless you want to study
c   the Astronomical Almanac and learn to use it correctly.

c   (3) Universal Time (UT), the basis of civil timekeeping, is
c   defined by a formula relating UT to GMST (Greenwich mean sidereal
c   time).  UTC (Coordinated Universal Time) is the time scale
c   distributed by most broadcast time services.  UT, UTC, and other
c   related time measures are within a few sec of each other and are
c   frequently used interchangeably.

c   (4) Beginning in 1984, the "standard epoch" of the astronomical
c   coordinate system is Jan 1, 2000, 12 hr TDB (Julian date
c   2,451,545.0, denoted J2000.0).  The fact that this routine uses
c   1949 as a point of reference is merely for numerical convenience.
c --------------------------------------------------------------------

c     .. Scalar Arguments ..

      LOGICAL lrefr

      INTEGER   YEAR, DAY
      REAL      AZ, EL, HOUR, LAT, LONG, SOLDIA, SOLDST
c     ..
c     .. Local Scalars ..

      LOGICAL   PASS1
      INTEGER   DELTA, LEAP
      DOUBLE PRECISION  DEC, DEN, ECLONG, GMST, HA, JD, LMST,
     &                  MNANOM, MNLONG, NUM, OBLQEC, PI, RA,
     &                  RPD, REFRAC, TIME, TWOPI
c     ..
c     .. Intrinsic Functions ..

      INTRINSIC AINT, ASIN, ATAN, COS, MOD, SIN, TAN
c     ..
c     .. Data statements ..

      SAVE     PASS1, PI, TWOPI, RPD
      DATA     PASS1 /.True./
c     ..

      IF( YEAR.LT.1950 .OR. YEAR.GT.2050 )
     &    STOP 'SUNAE--bad input variable YEAR'
      IF( DAY.LT.1 .OR. DAY.GT.366 )
     &    STOP 'SUNAE--bad input variable DAY'
      IF( HOUR.LT.-13.0 .OR. HOUR.GT.36.0 )
     &    STOP 'SUNAE--bad input variable HOUR'
      IF( LAT.LT.-90.0 .OR. LAT.GT.90.0 )
     &    STOP 'SUNAE--bad input variable LAT'
      IF( LONG.LT.-180.0 .OR. LONG.GT.180.0 )
     &    STOP 'SUNAE--bad input variable LONG'

      IF(PASS1) THEN
         PI     = 2.*ASIN( 1.0 )
         TWOPI  = 2.*PI
         RPD    = PI / 180.
         PASS1 = .False.
      ENDIF

c                    ** current Julian date (actually add 2,400,000
c                    ** for true JD);  LEAP = leap days since 1949;
c                    ** 32916.5 is midnite 0 jan 1949 minus 2.4e6

      DELTA  = YEAR - 1949
      LEAP   = DELTA / 4
      JD     = 32916.5 + (DELTA*365 + LEAP + DAY) + HOUR / 24.

c                    ** last yr of century not leap yr unless divisible
c                    ** by 400 (not executed for the allowed YEAR range,
c                    ** but left in so our successors can adapt this for
c                    ** the following 100 years)

      IF( MOD( YEAR, 100 ).EQ.0 .AND.
     &    MOD( YEAR, 400 ).NE.0 ) JD = JD - 1.

c                     ** ecliptic coordinates
c                     ** 51545.0 + 2.4e6 = noon 1 jan 2000

      TIME  = JD - 51545.0

c                    ** force mean longitude between 0 and 360 degs

      MNLONG = 280.460 + 0.9856474*TIME
      MNLONG = MOD( MNLONG, 360.D0 )
      IF( MNLONG.LT.0. ) MNLONG = MNLONG + 360.

c                    ** mean anomaly in radians between 0 and 2*pi

      MNANOM = 357.528 + 0.9856003*TIME
      MNANOM = MOD( MNANOM, 360.D0 )
      IF( MNANOM.LT.0.) MNANOM = MNANOM + 360.

      MNANOM = MNANOM*RPD

c                    ** ecliptic longitude and obliquity
c                    ** of ecliptic in radians

      ECLONG = MNLONG + 1.915*SIN( MNANOM ) + 0.020*SIN( 2.*MNANOM )
      ECLONG = MOD( ECLONG, 360.D0 )
      IF( ECLONG.LT.0. ) ECLONG = ECLONG + 360.

      OBLQEC = 23.439 - 0.0000004*TIME
      ECLONG = ECLONG*RPD
      OBLQEC = OBLQEC*RPD

c                    ** right ascension

      NUM  = COS( OBLQEC )*SIN( ECLONG )
      DEN  = COS( ECLONG )
      RA   = ATAN( NUM / DEN )

c                    ** Force right ascension between 0 and 2*pi

      IF( DEN.LT.0.0 ) THEN
         RA  = RA + PI
      ELSE IF( NUM.LT.0.0 ) THEN
         RA  = RA + TWOPI
      END IF

c                    ** declination

      DEC  = ASIN( SIN( OBLQEC )*SIN( ECLONG ) )

c                    ** Greenwich mean sidereal time in hours

      GMST = 6.697375 + 0.0657098242*TIME + HOUR

c                    ** Hour not changed to sidereal time since
c                    ** 'time' includes the fractional day

      GMST  = MOD( GMST, 24.D0)
      IF( GMST.LT.0. ) GMST   = GMST + 24.

c                    ** local mean sidereal time in radians

      LMST  = GMST + LONG / 15.
      LMST  = MOD( LMST, 24.D0 )
      IF( LMST.LT.0. ) LMST   = LMST + 24.

      LMST   = LMST*15.*RPD

c                    ** hour angle in radians between -pi and pi

      HA  = LMST - RA

      IF( HA.LT.- PI ) HA  = HA + TWOPI
      IF( HA.GT.PI )   HA  = HA - TWOPI

c                    ** solar azimuth and elevation

      EL  = ASIN( SIN( DEC )*SIN( LAT*RPD ) +
     &            COS( DEC )*COS( LAT*RPD )*COS( HA ) )

      AZ  = ASIN( - COS( DEC )*SIN( HA ) / COS( EL ) )

c                    ** Put azimuth between 0 and 2*pi radians

      IF( SIN( DEC ) - SIN( EL )*SIN( LAT*RPD ).GE.0. ) THEN

         IF( SIN(AZ).LT.0.) AZ  = AZ + TWOPI

      ELSE

         AZ  = PI - AZ

      END IF

c                     ** Convert elevation and azimuth to degrees
      EL  = EL / RPD
      AZ  = AZ / RPD

c  ======== Refraction correction for U.S. Standard Atmos. ==========
c      (assumes elevation in degs) (3.51823=1013.25 mb/288 K)

      IF( EL.GE.19.225 ) THEN

         REFRAC = 0.00452*3.51823 / TAN( EL*RPD )

      ELSE IF( EL.GT.-0.766 .AND. EL.LT.19.225 ) THEN

         REFRAC = 3.51823 * ( 0.1594 + EL*(0.0196 + 0.00002*EL) ) /
     &            ( 1. + EL*(0.505 + 0.0845*EL) )

      ELSE IF( EL.LE.-0.766 ) THEN

         REFRAC = 0.0

      END IF

* sm: switch off refraction:

      IF(lrefr) THEN
         EL  = EL + REFRAC
      ENDIF

c ===================================================================

c                   ** distance to sun in A.U. & diameter in degs

      SOLDST = 1.00014 - 0.01671*COS(MNANOM) - 0.00014*COS( 2.*MNANOM )
      SOLDIA = 0.5332 / SOLDST

      IF( EL.LT.-90.0 .OR. EL.GT.90.0 )
     &    STOP 'SUNAE--output argument EL out of range'
      IF( AZ.LT.0.0 .OR. AZ.GT.360.0 )
     &    STOP 'SUNAE--output argument AZ out of range'

      RETURN

      END


! { dg-do run }
!
! Testing IEEE modules on large real kinds

program test

  use ieee_arithmetic
  implicit none

  ! k1 and k2 will be large real kinds, if supported, and single/double
  ! otherwise
  integer, parameter :: k1 = &
    max(ieee_selected_real_kind(precision(0.d0) + 1), kind(0.))
  integer, parameter :: k2 = &
    max(ieee_selected_real_kind(precision(0._k1) + 1), kind(0.d0))

  real(kind=k1) :: x1, y1
  real(kind=k2) :: x2, y2
  logical :: l

  ! Checking ieee_is_finite

  if (.not. ieee_is_finite(huge(0._k1))) call abort
  if (ieee_is_finite(ieee_value(0._k1, ieee_negative_inf))) call abort
  x1 = -42
  if (.not. ieee_is_finite(x1)) call abort
  if (ieee_is_finite(sqrt(x1))) call abort

  if (.not. ieee_is_finite(huge(0._k2))) call abort
  if (ieee_is_finite(ieee_value(0._k2, ieee_negative_inf))) call abort
  x2 = -42
  if (.not. ieee_is_finite(x2)) call abort
  if (ieee_is_finite(sqrt(x2))) call abort

  ! Other ieee_is intrinsics

  if (ieee_is_nan(huge(0._k1))) call abort
  if (.not. ieee_is_negative(-huge(0._k1))) call abort
  if (.not. ieee_is_normal(-huge(0._k1))) call abort

  if (ieee_is_nan(huge(0._k2))) call abort
  if (.not. ieee_is_negative(-huge(0._k2))) call abort
  if (.not. ieee_is_normal(-huge(0._k2))) call abort

  ! ieee_support intrinsics

  if (.not. ieee_support_datatype(x1)) call abort
  if (.not. ieee_support_denormal(x1)) call abort
  if (.not. ieee_support_divide(x1)) call abort
  if (.not. ieee_support_inf(x1)) call abort
  if (.not. ieee_support_io(x1)) call abort
  if (.not. ieee_support_nan(x1)) call abort
  if (.not. ieee_support_rounding(ieee_nearest, x1)) call abort
  if (.not. ieee_support_sqrt(x1)) call abort
  if (.not. ieee_support_standard(x1)) call abort

  l = ieee_support_underflow_control(x1)

  if (.not. ieee_support_datatype(x2)) call abort
  if (.not. ieee_support_denormal(x2)) call abort
  if (.not. ieee_support_divide(x2)) call abort
  if (.not. ieee_support_inf(x2)) call abort
  if (.not. ieee_support_io(x2)) call abort
  if (.not. ieee_support_nan(x2)) call abort
  if (.not. ieee_support_rounding(ieee_nearest, x2)) call abort
  if (.not. ieee_support_sqrt(x2)) call abort
  if (.not. ieee_support_standard(x2)) call abort

  l = ieee_support_underflow_control(x2)

  ! ieee_value and ieee_class

  if (.not. ieee_is_nan(ieee_value(x1, ieee_quiet_nan))) call abort
  if (ieee_class(ieee_value(x1, ieee_positive_denormal)) &
    /= ieee_positive_denormal) call abort

  if (.not. ieee_is_nan(ieee_value(x2, ieee_quiet_nan))) call abort
  if (ieee_class(ieee_value(x2, ieee_positive_denormal)) &
    /= ieee_positive_denormal) call abort

  ! ieee_unordered

  if (.not. ieee_unordered(ieee_value(x1, ieee_quiet_nan), 0._k1)) call abort
  if (ieee_unordered(ieee_value(x1, ieee_negative_inf), 0._k1)) call abort

  if (.not. ieee_unordered(ieee_value(x2, ieee_quiet_nan), 0._k2)) call abort
  if (ieee_unordered(ieee_value(x2, ieee_negative_inf), 0._k2)) call abort

  ! ieee_copy_sign

  if (.not. ieee_class(ieee_copy_sign(ieee_value(x1, ieee_positive_inf), -1.)) &
            == ieee_negative_inf) call abort
  if (.not. ieee_class(ieee_copy_sign(0._k1, -42._k2)) &
            == ieee_negative_zero) call abort

  if (.not. ieee_class(ieee_copy_sign(ieee_value(x2, ieee_positive_inf), -1.)) &
            == ieee_negative_inf) call abort
  if (.not. ieee_class(ieee_copy_sign(0._k2, -42._k1)) &
            == ieee_negative_zero) call abort

  ! ieee_logb

  if (ieee_logb (42._k1) /= exponent(42._k1) - 1) call abort

  if (ieee_logb (42._k2) /= exponent(42._k2) - 1) call abort

  ! ieee_next_after

  if (ieee_next_after(42._k1, ieee_value(x1, ieee_positive_inf)) &
      /= 42._k1 + spacing(42._k1)) call abort

  if (ieee_next_after(42._k2, ieee_value(x2, ieee_positive_inf)) &
      /= 42._k2 + spacing(42._k2)) call abort

  ! ieee_rem

  if (ieee_class(ieee_rem(-42._k1, 2._k1)) /= ieee_negative_zero) &
    call abort

  if (ieee_class(ieee_rem(-42._k2, 2._k2)) /= ieee_negative_zero) &
    call abort

  ! ieee_rint

  if (ieee_rint(-1.1_k1) /= -1._k1) call abort
  if (ieee_rint(huge(x1)) /= huge(x1)) call abort

  if (ieee_rint(-1.1_k2) /= -1._k2) call abort
  if (ieee_rint(huge(x2)) /= huge(x2)) call abort

  ! ieee_scalb

  x1 = sqrt(42._k1)
  if (ieee_scalb(x1, 2) /= 4._k1 * x1) call abort
  if (ieee_scalb(x1, -2) /= x1 / 4._k1) call abort

  x2 = sqrt(42._k2)
  if (ieee_scalb(x2, 2) /= 4._k2 * x2) call abort
  if (ieee_scalb(x2, -2) /= x2 / 4._k2) call abort

end program test


program whereStatement
implicit none

   integer :: a(3,5), i , j

   do i = 1,3
      do j = 1, 5
         a(i,j) = j-i
      end do
   end do

   Print *, 'The A array:'

   do i = lbound(a,1), ubound(a,1)
      write(*,*) (a(i,j), j = lbound(a,2), ubound(a,2))
   end do

   where( a<0 )
      a = 1
   elsewhere
      a = 5
   end where

   Print *, 'The A array:'
   do i = lbound(a,1), ubound(a,1)
      write(*,*) (a(i,j), j = lbound(a,2), ubound(a,2))
   end do

end program whereStatement


! { dg-do compile }
! { dg-options "-Warray-temporaries -O -fdump-tree-original" }
!
! PR fortran/43829
! Scalarization of reductions.
! Test that product is properly inlined.

! For more extended tests, see inline_sum_1.f90

  implicit none

  integer :: i

  integer, parameter :: q = 2
  integer, parameter :: nx=3, ny=2*q, nz=5
  integer, parameter, dimension(nx,ny,nz) :: p  = &
        & reshape ((/ (i, i=1,size(p)) /), shape(p))

  integer, dimension(nx,ny,nz) :: a
  integer, dimension(nx,   nz) :: ay

  a  = p

  ay = product(a,2)

end
! { dg-final { scan-tree-dump-times "struct array._integer\\(kind=4\\) atmp" 0 "original" } }
! { dg-final { scan-tree-dump-times "struct array\[^\\n\]*atmp" 0 "original" } }
! { dg-final { scan-tree-dump-times "_gfortran_product_" 0 "original" } }


PROGRAM live_game

    INTEGER, PARAMETER :: N = 300, T = 500
    INTEGER, DIMENSION(N,N) :: x_i, x_f
    INTEGER point_value
    CHARACTER(20) :: filename

    open(1, File="CI.dat", status = "Old")

    DO j = 1, N
        READ(1,*) (x_i(i,j), i = 1, N)
    END DO

    DO k = 1, T
        DO i = 1, N
            x_f(1,i)=x_i(1,i)
            x_f(N,i)=x_i(N,i)
            x_f(i,1)=x_i(i,1)
            x_f(i,N)=x_i(i,N)
        END DO

        DO i = 2, N - 1
            DO j = 2, N - 1
                point_value = x_i(i+1,j)+x_i(i+1,j+1)+x_i(i+1,j-1)+x_i(i,j+1)+x_i(i,j-1)+x_i(i-1,j)+x_i(i-1,j-1)+x_i(i-1,j+1)
                IF (x_i(i,j) .EQ. 1) THEN
                    IF (point_value .LT. 2) THEN
                        x_f(i,j) = 0
                    ELSEIF ((point_value .GE. 2) .AND. (point_value .LE. 3)) THEN
                    x_f(i,j)=1
                ELSEIF (point_value .GT. 3) THEN
                    x_f(i,j)=0
                END IF
            ELSEIF (x_i(i,j).EQ.0) THEN
                IF (point_value .EQ. 3) THEN
                    x_f(i,j)=1
                ELSE
                    x_f(i,j)=0
                END IF
            END IF
        END DO
    END DO

    WRITE(filename,'(a,i0,a)') 'data',k,'.dat'
    open(2,file=filename)
        DO j = 1, N
            WRITE(2,*) ((x_f(i,j)), i=1,N)
        END DO

        DO i = 1, N
            DO j = 1, N
                x_i(i,j) = x_f(i,j)
            END DO
        END DO
    END DO

END PROGRAM


      SUBROUTINE AB13ED( N, A, LDA, LOW, HIGH, TOL, DWORK, LDWORK,
     $                   INFO )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To estimate beta(A), the 2-norm distance from a real matrix A to
C     the nearest complex matrix with an eigenvalue on the imaginary
C     axis. The estimate is given as
C
C            LOW <= beta(A) <= HIGH,
C
C     where either
C
C            (1 + TOL) * LOW >= HIGH,
C
C     or
C
C            LOW = 0   and   HIGH = delta,
C
C     and delta is a small number approximately equal to the square root
C     of machine precision times the Frobenius norm (Euclidean norm)
C     of A. If A is stable in the sense that all eigenvalues of A lie
C     in the open left half complex plane, then beta(A) is the distance
C     to the nearest unstable complex matrix, i.e., the complex
C     stability radius.
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrix A.  N >= 0.
C
C     A       (input) DOUBLE PRECISION array, dimension (LDA,N)
C             The leading N-by-N part of this array must contain the
C             matrix A.
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= MAX(1,N).
C
C     LOW     (output) DOUBLE PRECISION
C             A lower bound for beta(A).
C
C     HIGH    (output) DOUBLE PRECISION
C             An upper bound for beta(A).
C
C     Tolerances
C
C     TOL     DOUBLE PRECISION
C             Specifies the accuracy with which LOW and HIGH approximate
C             beta(A). If the user sets TOL to be less than SQRT(EPS),
C             where EPS is the machine precision (see LAPACK Library
C             Routine DLAMCH), then the tolerance is taken to be
C             SQRT(EPS).
C             The recommended value is TOL = 9, which gives an estimate
C             of beta(A) correct to within an order of magnitude.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, DWORK(1) returns the optimal value
C             of LDWORK.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.
C             LDWORK >= MAX( 1, 3*N*(N+1) ).
C             For optimum performance LDWORK should be larger.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value;
C             = 1:  the QR algorithm (LAPACK Library routine DHSEQR)
C                   fails to converge; this error is very rare.
C
C     METHOD
C
C     Let beta(A) be the 2-norm distance from a real matrix A to the
C     nearest complex matrix with an eigenvalue on the imaginary axis.
C     It is known that beta(A) = minimum of the smallest singular
C     value of (A - jwI), where I is the identity matrix and j**2 = -1,
C     and the minimum is taken over all real w.
C     The algorithm computes a lower bound LOW and an upper bound HIGH
C     for beta(A) by a bisection method in the following way. Given a
C     non-negative real number sigma, the Hamiltonian matrix H(sigma)
C     is constructed:
C
C                       |   A      -sigma*I |     | A   G  |
C           H(sigma) =  |                   | :=  |        | .
C                       | sigma*I    -A'    |     | F  -A' |
C
C     It can be shown [1] that H(sigma) has an eigenvalue whose real
C     part is zero if and only if sigma >= beta. Any lower and upper
C     bounds on beta(A) can be improved by choosing a number between
C     them and checking to see if H(sigma) has an eigenvalue with zero
C     real part.  This decision is made by computing the eigenvalues of
C     H(sigma) using the square reduced algorithm of Van Loan [2].
C
C     REFERENCES
C
C     [1] Byers, R.
C         A bisection method for measuring the distance of a stable
C         matrix to the unstable matrices.
C         SIAM J. Sci. Stat. Comput., Vol. 9, No. 5, pp. 875-880, 1988.
C
C     [2] Van Loan, C.F.
C         A symplectic method for approximating all the eigenvalues of a
C         Hamiltonian matrix.
C         Linear Algebra and its Applications, Vol 61, 233-251, 1984.
C
C     NUMERICAL ASPECTS
C
C     Due to rounding errors the computed values of LOW and HIGH can be
C     proven to satisfy
C
C            LOW - p(n) * sqrt(e) * norm(A) <= beta(A)
C     and
C            beta(A) <= HIGH + p(n) * sqrt(e) * norm(A),
C
C     where p(n) is a modest polynomial of degree 3, e is the machine
C     precision and norm(A) is the Frobenius norm of A, see [1].
C     The recommended value for TOL is 9 which gives an estimate of
C     beta(A) correct to within an order of magnitude.
C     AB13ED requires approximately 38*N**3 flops for TOL = 9.
C
C     CONTRIBUTOR
C
C     R. Byers, the routines BISEC and BISEC0 (January, 1995).
C
C     REVISIONS
C
C     Release 4.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1999.
C     V. Sima, Research Institute for Informatics, Bucharest, Jan. 2003.
C
C     KEYWORDS
C
C     Distances, eigenvalue, eigenvalue perturbation, norms, stability
C     radius.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      DOUBLE PRECISION  HIGH, LOW, TOL
      INTEGER           INFO, LDA, LDWORK, N
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LDA,*), DWORK(*)
C     .. Local Scalars ..
      INTEGER           I, IA2, IAA, IGF, IHI, ILO, IWI, IWK, IWR,
     $                  JWORK, MINWRK, N2
      DOUBLE PRECISION  ANRM, SEPS, SFMN, SIGMA, TAU, TEMP, TOL1, TOL2
      LOGICAL           RNEG, SUFWRK
C     .. Local Arrays ..
      DOUBLE PRECISION  DUMMY(1), DUMMY2(1,1)
C     .. External Functions ..
      DOUBLE PRECISION  DLAMCH, DLANGE
      EXTERNAL          DLAMCH, DLANGE
C     .. External Subroutines ..
      EXTERNAL          DCOPY, DGEBAL, DGEMM, DHSEQR, DLACPY, DSYMM,
     $                  DSYMV, MA02ED, MB04ZD, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         ABS, DBLE, MAX, SQRT
C     .. Executable Statements ..
C
C     Test the input scalar arguments.
C
      INFO   = 0
      MINWRK = 3*N*( N + 1 )
C
      IF( N.LT.0 ) THEN
         INFO = -1
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -3
      ELSE IF( LDWORK.LT.MAX( 1, MINWRK ) ) THEN
         INFO = -8
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'AB13ED', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      LOW = ZERO
      IF ( N.EQ.0 ) THEN
         HIGH = ZERO
         DWORK(1) = ONE
         RETURN
      END IF
C
C     Indices for splitting the work array.
C     (Note: Comments in the code beginning "Workspace:" describe the
C     minimal amount of real workspace needed at that point in the
C     code, as well as the preferred amount for good performance.)
C
      N2  = N*N
      IGF = 1
      IA2 = IGF + N2 + N
      IAA = IA2 + N2
      IWK = IAA + N2
      IWR = IAA
      IWI = IWR + N
C
      SUFWRK = LDWORK-IWK.GE.N2
C
C     Computation of the tolerances and the treshold for termination of
C     the bisection method. SEPS is the square root of the machine
C     precision.
C
      SFMN = DLAMCH( 'Safe minimum' )
      SEPS = SQRT( DLAMCH( 'Epsilon' ) )
      TAU  = ONE + MAX( TOL, SEPS )
      ANRM = DLANGE( 'Frobenius', N, N, A, LDA, DWORK )
      TOL1 = SEPS * ANRM
      TOL2 = TOL1 * DBLE( 2*N )
C
C     Initialization of the bisection method.
C
      HIGH = ANRM
C
C     WHILE ( HIGH > TAU*MAX( TOL1, LOW ) ) DO
   10 IF ( HIGH.GT.( TAU*MAX( TOL1, LOW ) ) ) THEN
         SIGMA = SQRT( HIGH ) * SQRT( MAX( TOL1, LOW ) )
C
C        Set up H(sigma).
C        Workspace: N*(N+1)+2*N*N.
C
         CALL DLACPY( 'Full', N, N, A, LDA, DWORK(IAA), N )
         DWORK(IGF)   =  SIGMA
         DWORK(IGF+N) = -SIGMA
         DUMMY(1) = ZERO
         CALL DCOPY( N-1, DUMMY, 0, DWORK(IGF+1), 1 )
C
         DO 20 I = IGF, IA2 - N - 2, N + 1
            CALL DCOPY( N+1, DWORK(I), 1, DWORK(I+N+1), 1 )
   20    CONTINUE
C
C        Computation of the eigenvalues by the square reduced algorithm.
C        Workspace: N*(N+1)+2*N*N+2*N.
C
         CALL MB04ZD( 'No vectors', N, DWORK(IAA), N, DWORK(IGF), N,
     $                DUMMY2, 1, DWORK(IWK), INFO )
C
C        Form the matrix A*A + F*G.
C        Workspace: need   N*(N+1)+2*N*N+N;
C                   prefer N*(N+1)+3*N*N.
C
         JWORK = IA2
         IF ( SUFWRK )
     $      JWORK = IWK
C
         CALL DLACPY( 'Lower', N, N, DWORK(IGF), N, DWORK(JWORK), N )
         CALL MA02ED( 'Lower', N, DWORK(JWORK), N )
C
         IF ( SUFWRK ) THEN
C
C           Use BLAS 3 calculation.
C
            CALL DSYMM( 'Left', 'Upper', N, N, ONE, DWORK(IGF+N), N,
     $                  DWORK(JWORK), N, ZERO, DWORK(IA2), N )
         ELSE
C
C           Use BLAS 2 calculation.
C
            DO 30 I = 1, N
               CALL DSYMV( 'Upper', N, ONE, DWORK(IGF+N), N,
     $                     DWORK(IA2+N*(I-1)), 1, ZERO, DWORK(IWK), 1 )
               CALL DCOPY( N, DWORK(IWK), 1, DWORK(IA2+N*(I-1)), 1 )
   30       CONTINUE
C
         END IF
C
         CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, N, ONE,
     $               DWORK(IAA), N, DWORK(IAA), N, ONE, DWORK(IA2), N )
C
C        Find the eigenvalues of A*A + F*G.
C        Workspace: N*(N+1)+N*N+3*N.
C
         JWORK = IWI + N
         CALL DGEBAL( 'Scale', N, DWORK(IA2), N, ILO, IHI, DWORK(JWORK),
     $                I )
         CALL DHSEQR( 'Eigenvalues', 'NoSchurVectors', N, ILO, IHI,
     $                DWORK(IA2), N, DWORK(IWR), DWORK(IWI), DUMMY2, 1,
     $                DWORK(JWORK), N, INFO )
C
         IF ( INFO.NE.0 ) THEN
            INFO = 1
            RETURN
         END IF
C
C        (DWORK(IWR+i), DWORK(IWI+i)), i = 0,...,N-1, contain the
C        squares of the eigenvalues of H(sigma).
C
         I = 0
         RNEG = .FALSE.
C        WHILE ( ( DWORK(IWR+i),DWORK(IWI+i) ) not real positive
C                .AND. I < N ) DO
   40    IF ( .NOT.RNEG .AND. I.LT.N ) THEN
            TEMP = ABS( DWORK(IWI+I) )
            IF ( TOL1.GT.SFMN ) TEMP = TEMP / TOL1
            RNEG = ( ( DWORK(IWR+I).LT.ZERO ) .AND. ( TEMP.LE.TOL2 ) )
            I = I + 1
            GO TO 40
C           END WHILE 40
         END IF

         IF ( RNEG ) THEN
            HIGH = SIGMA
         ELSE
            LOW = SIGMA
         END IF
         GO TO 10
C        END WHILE 10
      END IF
C
C     Set optimal workspace dimension.
C
      DWORK(1) = DBLE( MAX( 4*N2 + N, MINWRK ) )
C
C *** Last line of AB13ED ***
      END


module reflect_mod
  implicit none
  save
contains
  subroutine reflect(n1,n2,ct1,pi,r_flag)
    implicit none
    real*8,intent(in) :: n1,n2,pi !refractive index of  skin
    real*8,intent(in) :: ct1 !cos theta 1
    real*8 :: ca, ti, tt, si, ci, st, ct
    real*8 :: rs, rp, R
    real*8 :: ran
    integer r_flag

    r_flag=0
    CA=ASIN(1./N1)

    if (n1.gt.n2) then
       ca=asin(1./n1)
       if (acos(ct1).gt.ca) then
          print*,'reflect:TIR: doesnt do anything yet!no else or if or anything'
       endif
    endif

    !Fresnel Reflection

    ti=acos(ct1)
    ti=pi-ti

    si=sin(ti)
    ci=cos(ti)

    st= (n1/n2)*si
    tt=asin(st)
    ct=cos(tt)

    rs= ((n1*ci - n2*ct)/(n1*ci + n2*ct))**2
    rp= ((n1*ct - n2*ci)/(n1*ct + n2*ci))**2

   R=0.5*(rs+rp)

       call random_number(ran)
       if (ran.lt.R) then
          r_flag=1
       endif

       return

  end subroutine reflect
   end module reflect_mod


c-------------------------------------------------------------c
c                                                             c
c  Subroutine sffteu( x, y, n, m, itype )                     c
c                                                             c
c  This routine is a slight modification of a complex split   c
c  radix FFT routine presented by C.S. Burrus.  The original  c
c  program header is shown below.                             c
c                                                             c
c  Arguments:                                                 c
c     x - real array containing real parts of transform       c
c              sequence (in/out)                              c
c     y - real array containing imag parts of transform       c
c              sequence (in/out)                              c
c     n - integer length of transform (in)                    c
c     m - integer such that n = 2**m  (in)                    c
c     itype - integer job specifier (in)                      c
c              itype .ne. -1 --> foward transform             c
c              itype .eq. -1 --> backward transform           c
c                                                             c
c  The forward transform computes                             c
c     X(k) = sum_{j=0}^{N-1} x(j)*exp(-2ijk*pi/N)             c
c                                                             c
c  The backward transform computes                            c
c     x(j) = (1/N) * sum_{k=0}^{N-1} X(k)*exp(2ijk*pi/N)      c
c                                                             c
c                                                             c
c  Requires standard FORTRAN functions - sin, cos             c
c                                                             c
c  Steve Kifowit, 9 July 1997                                 c
c                                                             c
C-------------------------------------------------------------C
C  A Duhamel-Hollman Split-Radix DIF FFT                      C
C  Reference:  Electronics Letters, January 5, 1984           C
C  Complex input and output in data arrays X and Y            C
C  Length is N = 2**M                                         C
C                                                             C
C  C.S. Burrus          Rice University         Dec 1984      C
C-------------------------------------------------------------C
c
      SUBROUTINE SFFTEU( X, Y, N, M, ITYPE )
      INTEGER  N, M, ITYPE
      REAL  X(*), Y(*)
      INTEGER  I, J, K, N1, N2, N4, IS, ID, I0, I1, I2, I3
      REAL  TWOPI, E, A, A3, CC1, SS1, CC3, SS3
      REAL  R1, R2, S1, S2, S3, XT
      INTRINSIC  SIN, COS
      PARAMETER  ( TWOPI = 6.2831853071795864769 )
c
      IF ( N .EQ. 1 ) RETURN
c
      IF ( ITYPE .EQ. -1 ) THEN
	 DO 1, I = 1, N
	    Y(I) = - Y(I)
 1       CONTINUE
      ENDIF
c
      N2 = 2 * N
      DO 10, K = 1, M-1
	 N2 = N2 / 2
	 N4 = N2 / 4
	 E = TWOPI / N2
	 A = 0.0
	 DO 20, J = 1, N4
	    A3 = 3 * A
	    CC1 = COS( A )
	    SS1 = SIN( A )
	    CC3 = COS( A3 )
	    SS3 = SIN( A3 )
	    A = J * E
	    IS = J
	    ID = 2 * N2
 40         DO 30, I0 = IS, N-1, ID
	       I1 = I0 + N4
	       I2 = I1 + N4
	       I3 = I2 + N4
	       R1 = X(I0) - X(I2)
	       X(I0) = X(I0) + X(I2)
	       R2 = X(I1) - X(I3)
	       X(I1) = X(I1) + X(I3)
	       S1 = Y(I0) - Y(I2)
	       Y(I0) = Y(I0) + Y(I2)
	       S2 = Y(I1) - Y(I3)
	       Y(I1) = Y(I1) + Y(I3)
	       S3 = R1 - S2
	       R1 = R1 + S2
	       S2 = R2 - S1
	       R2 = R2 + S1
	       X(I2) = R1 * CC1 - S2 * SS1
	       Y(I2) = - S2 * CC1 - R1 * SS1
	       X(I3) = S3 * CC3 + R2 * SS3
	       Y(I3) = R2 * CC3 - S3 * SS3
 30         CONTINUE
	    IS = 2 * ID - N2 + J
	    ID = 4 * ID
	    IF ( IS .LT. N ) GOTO 40
 20      CONTINUE
 10   CONTINUE
c
C--------LAST STAGE, LENGTH-2 BUTTERFLY ----------------------C
c
      IS = 1
      ID = 4
 50   DO 60, I0 = IS, N, ID
	 I1 = I0 + 1
	 R1 = X(I0)
	 X(I0) = R1 + X(I1)
	 X(I1) = R1 - X(I1)
	 R1 = Y(I0)
	 Y(I0) = R1 + Y(I1)
	 Y(I1) = R1 - Y(I1)
 60   CONTINUE
      IS = 2 * ID - 1
      ID = 4 * ID
      IF ( IS .LT. N ) GOTO 50
c
C-------BIT REVERSE COUNTER-----------------------------------C
c
 100  J = 1
      N1 = N - 1
      DO 104, I = 1, N1
	 IF ( I .GE. J ) GOTO 101
	 XT = X(J)
	 X(J) = X(I)
	 X(I) = XT
	 XT = Y(J)
	 Y(J) = Y(I)
	 Y(I) = XT
 101     K = N / 2
 102     IF ( K .GE. J ) GOTO 103
	 J = J - K
	 K = K / 2
	 GOTO 102
 103     J = J + K
 104  CONTINUE
c
      IF ( ITYPE .EQ. -1 ) THEN
	 DO 2, I = 1, N
	    X(I) = X(I) / N
	    Y(I) = - Y(I) / N
 2       CONTINUE
      ENDIF
c
      RETURN
c
c ... End of subroutine SFFTEU ...
c
      END


! mpiexec -np 4 bin/Debug/WGFM_test2.exe
program mainWGF
use meshread_mod
use linalg_mod
use WGFM_matrices
use dipole_functions
use dipole_mod
use currents_mod
use mpi
implicit none

real(8), parameter :: pi = 4d0 * atan(1d0)
complex(8), parameter :: IU = (0d0, 1d0)

! Variables
type(Mesh) :: msh
real(8),parameter:: msh_evl(1,3) = [1d0, 0d0, 2d0]  ! Eval mesh

complex(8), allocatable :: ZMat(:, :)  ! WGFM matrix

complex(8), allocatable :: Esrc(:, :), Hsrc(:, :)
complex(8), allocatable :: MJsrc(:)
complex(8), allocatable :: Uvec(:), Vvec(:), UVvec(:)

complex(8), allocatable :: S1Pot(:, :, :)
complex(8), allocatable :: D1Pot(:, :, :)
complex(8), allocatable :: S2Pot(:, :, :)
complex(8), allocatable :: D2Pot(:, :, :)

complex(8), allocatable :: Eexact(:, :)    ! Exact electric field solution
complex(8), allocatable :: ESol(:, :)      ! WGFM electric field solution
complex(8), allocatable :: HSol(:, :)      ! WGFM magnetic field solution

real(8) :: ExNorm, Error1

! MPI variables
integer :: ierr, N_procs, id

! Parameters
real(8), parameter :: ep0 = 1d0 / (35950207149.4727056d0 * PI)  ! vacuum permittivity [F/m]
real(8), parameter :: mu0 = PI * 4d-7                           ! vacuum permeability [H/m]
real(8), parameter :: k0 = 2*PI          ! free-space wavenumber [1/m]

real(8), parameter :: ep1_r = 1d0         ! upper half-space relative permittivity
real(8), parameter :: ep2_r = 10d0         ! lower half-space relative permittivity
real(8), parameter :: ep1 = ep0*ep1_r     ! upper half-space permittivity [F/m]
real(8), parameter :: mu1 = mu0           ! upper half-space permeability [H/m]
real(8), parameter :: ep2 = ep0*ep2_r     ! lower half-space permittivity [F/m]
real(8), parameter :: mu2 = mu0           ! lower half-space permeability [H/m]

real(8), parameter :: w = k0 / sqrt(ep0 * mu0)   ! angular frequency [rad/s]
real(8), parameter :: k1 = w * sqrt(ep1 * mu1)  ! upper half-space wavenumber [1/m]
real(8), parameter :: k2 = w * sqrt(ep2 * mu2)  ! lower half-space wavenumber [1/m]

character(len=150), parameter ::  &
    file_msh = '/home/rodrigo/Dropbox/Rodrigo-Carlos/Meshes/dipoleMeshes/planeA4h0312.msh'
real(8), parameter :: win_radius = 4d0      ! Window radius
real(8), parameter :: win_cparam = 0.7d0    ! Window 'c' parameter
real(8), parameter :: gmres_tol = 1d-5      ! GMRES tolerance
logical, parameter :: total_field = .true.  ! Exact field: true = total field
                                            !              false = scattered field

! Dipole parameters
real(8), parameter :: pol(3) = [0d0, 1d0, 0d0]    ! dipole polarization vector
real(8), parameter :: src(3) = [0.5d0, 0.5d0, 2d0]    ! location of dipole source

!************************************************************************************
! MPI init
call mpi_init(ierr)
call mpi_comm_size(MPI_COMM_WORLD, N_procs, ierr)
call mpi_comm_rank(MPI_COMM_WORLD, id, ierr)
print *, "Total processes:", N_procs, "Process id:", id

! Set window type and size
call set_circ_window(win_radius, win_cparam)

! Load mesh
call load_gmsh(file_msh, msh)

! Compute WGFM matrix
if (id == 0) print *, "WGFM matrix, ", 'nEdges: ', msh%nbEdg
call genWGFMMat(msh, w, k1, k2, ep1, ep2, mu1, mu2, ZMat)
if (id == 0) print *, "done"

if (id == 0) then
    ! Compute source fields
    call ElectricDipoleOnGmsh(pol, src, k1, w, mu1, msh, Esrc, Hsrc)

    ! WGFM RHS
    call genWGFMRHS(msh, Esrc, Hsrc, MJsrc)

    ! Solve
    print *, "solving"
    allocate(Uvec(msh%nbEdg))
    allocate(Vvec(msh%nbEdg))
    allocate(UVvec(2*msh%nbEdg))
    call diagPrecond(ZMat, MJsrc)
    call gmres_solver(UVvec, ZMat, MJsrc, gmres_tol)
    !call linsolve(UVvec, ZMat, MJsrc, 2*msh%nbEdg)
    Uvec = UVvec(1 : msh%nbEdg)
    Vvec = UVvec(msh%nbEdg+1 : 2*msh%nbEdg)
    deallocate(MJsrc, UVvec, ZMat)
    print *, "done"
end if

! Compute WGFM potencials
if (id == 0) print *, "Potencial"
call genWGFMPot(msh, msh_evl, k1, k2, S1Pot, D1Pot, S2Pot, D2Pot)
if (id == 0) print *, "done"

! Compute exact solution
if (id == 0) print *, "Exact solution"
call halfspace_dipole_field_mpi(msh_evl, k0, k1, ep1_r, dcmplx(ep2_r),  &
                                src, pol, Eexact, total_field)
if (id == 0) then
    ExNorm = maxval(sqrt(abs(Eexact(:,1))**2+abs(Eexact(:,2))**2+abs(Eexact(:,3))**2))
    print *, "done"
endif

! Compute WGFM solution
if (id == 0) then
    ! Free-space electric dipole field
    call ElectricDipoleOnEvlMsh(pol, src, k1, w, mu1, msh_evl, ESol, HSol)
    deallocate(HSol)   ! HSol is not used

    ! Adjust constants
    S1Pot = S1Pot * k1**2
    D1Pot = D1Pot * iu*w*mu1

    ! WGFM solution
    ESol(:,1) = ESol(:,1) + matmul(S1Pot(:,:,1), Vvec) + matmul(D1Pot(:,:,1), Uvec)
    ESol(:,2) = ESol(:,2) + matmul(S1Pot(:,:,2), Vvec) + matmul(D1Pot(:,:,2), Uvec)
    ESol(:,3) = ESol(:,3) + matmul(S1Pot(:,:,3), Vvec) + matmul(D1Pot(:,:,3), Uvec)

    ! Error
    ESol = ESol - Eexact
    Error1 = maxval(sqrt(abs(ESol(:,1))**2+abs(ESol(:,2))**2+abs(ESol(:,3))**2))

    print *, 'nEdges ', 'h ',' Error WGFM: '
    print *, msh%nbEdg, msh%h, Error1 / ExNorm  ! Error must be 2.756022600615578E-003
    print *, "Error must be close to 2.756022600615526E-003"
end if

call MPI_Finalize(ierr)
end program