!!  Copyright (C)  Stichting Deltares, 2012-2016.
!!
!!  This program is free software: you can redistribute it and/or modify
!!  it under the terms of the GNU General Public License version 3,
!!  as published by the Free Software Foundation.
!!
!!  This program is distributed in the hope that it will be useful,
!!  but WITHOUT ANY WARRANTY; without even the implied warranty of
!!  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!!  GNU General Public License for more details.
!!
!!  You should have received a copy of the GNU General Public License
!!  along with this program. If not, see <http://www.gnu.org/licenses/>.
!!
!!  contact: delft3d.support@deltares.nl
!!  Stichting Deltares
!!  P.O. Box 177
!!  2600 MH Delft, The Netherlands
!!
!!  All indications and logos of, and references to registered trademarks
!!  of Stichting Deltares remain the property of Stichting Deltares. All
!!  rights reserved.

module normal_mod

      implicit none

      integer, save              :: nb                 !  a common number of boxes
      real(8), save, allocatable :: xbox(:), ybox(:)   !  the box x and y values

   contains

!     Generate the look-up table

      subroutine norm_init ()

      real(8)  pi     !  pi
      real(8)  a      !  the ziggurat basket surface size
      real(8)  t      !  help variable to determine the tail
      integer  ibox   !  number of lookup boxes

      nb = 256
      allocate ( xbox(0:nb), ybox(0:nb) )
      pi      = 4.0d+00 * atan(1.0d+00)
      xbox(1) = 3.6484759268d+00
      ybox(1) = exp( -xbox(1)*xbox(1) / 2.0d+00 )
      t = 1.0d+00 /( 1.0d+00 + 0.3275911d+00*xbox(1)/sqrt(2.0d+00) )
      a = sqrt(pi) / 2.0d+00 * ( 0.254829592d+00*t       - 0.284496736d+00*t*t     +       &
     &                           1.421413741d+00*t*t*t   - 1.453152027d+00*t*t*t*t +       &
     &                           1.061405429d+00*t*t*t*t*t ) * ybox(1)
      a = a + ybox(1)*xbox(1)
      xbox(0) = a / ybox(1)
      ybox(0) = 0.0d+00
      do ibox = 2, nb
         ybox(ibox) = ybox(ibox-1) + a / xbox(ibox-1)
         if ( ybox(ibox) .gt. 1.0d+00 ) exit
         xbox(ibox) = sqrt( - 2.0d+00 * log(ybox(ibox)) )
      enddo
      xbox(nb) = 0.0

      end subroutine norm_init

!     draw from the normal distribution function

      real function normal ( rseed )

      real(4)  rnd  , s, a, x, y
      real(8)  rseed
      integer  i

   10 a = rnd(rseed)
      if ( a .ge. 0.5 ) then                      !  half is negative
         s =  1.0
      else
         s = -1.0
      endif
      a = 2.0d+00 * abs( a-0.5d+00 )
      i = min ( int( rnd(rseed)*nb ), nb-1 )      !  select the box
      x = a*xbox(i)                               !  in most cases direct hit
      if ( x .ge. xbox(i+1) ) then                !  in some cases refinement
         if ( i .gt. 0 ) then
            y = ybox(i) + rnd(rseed)*(ybox(i+1)-ybox(i))
            if ( y .ge. exp(-x*x/2.0) ) goto 10
         else                                     !  special treatment of the
            x = -log(rnd(rseed))/xbox(1)          !  tail (box zero)
            y = -log(rnd(rseed))
            if ( 2.0*y .le. x*x ) goto 10
            x = x + xbox(1)
         endif
      endif

      normal = s*x                                  !  half is negative
      return

      end function normal

end module


      MODULE bootsj_input
      USE stel_kinds
      INTEGER :: nrho, mbuse, nbuse, isymm0
      REAL(rprec) :: tempres, ate(0:11), ati(0:11)
      REAL(rprec) :: zeff1, dens0, teti, damp, damp_bs

      NAMELIST /bootin/ nrho, mbuse, nbuse, zeff1, dens0, teti, tempres,
     1   damp, damp_bs, isymm0, ate, ati

      CONTAINS

      SUBROUTINE read_boot_namelist (iunit, istat)
      INTEGER :: iunit, istat

      !nrho = 30; mbuse = 0; nbuse = 0; zeff1 = 1
      !dens0 = 0.3; teti = 2; tempres = -1;
      !damp = -0.01; damp_bs = -0.01; isymm0 = 0; ate = -1; ati = -1

      nrho = 30                !number of rho values to use
      mbuse = 6                !number of m (poloidal) terms in B field.
      nbuse = 4                !number of nzetah (toroidal) terms in B field.
      zeff1 = 1.0_dp           !effective ion charge
      dens0 = 0.3_dp           !central electron density in 10**20 m-3
      teti = 2.0_dp            !ratio of Te/Ti for electron to ion
                               !temperature profiles
      tempres = -one           !tempe1(i)=pres(ir)**tempres
                               !if(tempres.eq.-1.0_dp) then
                               !tempe1(i)=sqrt(pres(i))
      damp = -0.01_dp          !superceded by damp_bs
      damp_bs = -0.01_dp       !damping factor for resonances
      isymm0 = 0               !if ne.0 then force a symmetric-device calculation,

      ate    = 0
      ati    = 0
      ate(0) = -1
      ati(0) = -1
      READ (iunit, nml=bootin, iostat=istat)

      END SUBROUTINE read_boot_namelist

      SUBROUTINE write_bootsj_input(iunit,istat)
      INTEGER, INTENT(in)    :: iunit
      INTEGER, INTENT(inout) :: istat
      INTEGER ::  n
      WRITE(iunit,'(A)') '&BOOTIN'
      WRITE(iunit,"(2X,A,1X,'=',1X,I0)") 'MBUSE',mbuse
      WRITE(iunit,"(2X,A,1X,'=',1X,I0)") 'NBUSE',nbuse
      WRITE(iunit,"(2X,A,1X,'=',1X,I0)") 'ISYMM0',isymm0
      WRITE(iunit,"(2X,A,1X,'=',1X,E22.14)") 'ZEFF1',zeff1
      WRITE(iunit,"(2X,A,1X,'=',1X,E22.14)") 'DENS0',dens0
      WRITE(iunit,"(2X,A,1X,'=',1X,E22.14)") 'TETI',teti
      WRITE(iunit,"(2X,A,1X,'=',1X,E22.14)") 'TEMPRES',tempres
      WRITE(iunit,"(2X,A,1X,'=',1X,E22.14)") 'DAMP',damp
      WRITE(iunit,"(2X,A,1X,'=',1X,E22.14)") 'DAMP_BS',damp_bs
      WRITE(iunit,"(2X,A,1X,'=',4(1X,E22.14))")
     1             'ATE',(ate(n), n=0,11)
      WRITE(iunit,"(2X,A,1X,'=',4(1X,E22.14))")
     1             'ATI',(ati(n), n=0,11)
      WRITE(iunit,'(A)') '/'
      END SUBROUTINE write_bootsj_input

      SUBROUTINE BCAST_BOOTSJ_INPUT(local_master,comm,istat)
!DEC$ IF DEFINED (MPI_OPT)
      USE mpi
!DEC$ ENDIF
      IMPLICIT NONE
      INTEGER, INTENT(inout) :: comm
      INTEGER, INTENT(in)    :: local_master
      INTEGER, INTENT(inout) :: istat
      IF (istat .ne. 0) RETURN
!DEC$ IF DEFINED (MPI_OPT)
      CALL MPI_BCAST(nrho,1,MPI_INTEGER,local_master,comm,istat)
      IF (istat .ne. 0) RETURN
      CALL MPI_BCAST(mbuse,1,MPI_INTEGER,local_master,comm,istat)
      IF (istat .ne. 0) RETURN
      CALL MPI_BCAST(nbuse,1,MPI_INTEGER,local_master,comm,istat)
      IF (istat .ne. 0) RETURN
      CALL MPI_BCAST(isymm0,1,MPI_INTEGER,local_master,comm,istat)
      IF (istat .ne. 0) RETURN
      CALL MPI_BCAST(zeff1,1,MPI_DOUBLE_PRECISION,local_master,
     1               comm,istat)
      IF (istat .ne. 0) RETURN
      CALL MPI_BCAST(dens0,1,MPI_DOUBLE_PRECISION,local_master,
     1               comm,istat)
      IF (istat .ne. 0) RETURN
      CALL MPI_BCAST(teti,1,MPI_DOUBLE_PRECISION,local_master,
     1               comm,istat)
      IF (istat .ne. 0) RETURN
      CALL MPI_BCAST(tempres,1,MPI_DOUBLE_PRECISION,local_master,
     1               comm,istat)
      IF (istat .ne. 0) RETURN
      CALL MPI_BCAST(damp,1,MPI_DOUBLE_PRECISION,local_master,
     1               comm,istat)
      IF (istat .ne. 0) RETURN
      CALL MPI_BCAST(damp_bs,1,MPI_DOUBLE_PRECISION,local_master,
     1               comm,istat)
      IF (istat .ne. 0) RETURN
      CALL MPI_BCAST(ate,SIZE(ate),MPI_DOUBLE_PRECISION,local_master,
     1               comm,istat)
      IF (istat .ne. 0) RETURN
      CALL MPI_BCAST(ati,size(ati),MPI_DOUBLE_PRECISION,local_master,
     1               comm,istat)
      IF (istat .ne. 0) RETURN
!DEC$ ENDIF
      END SUBROUTINE BCAST_BOOTSJ_INPUT

      END MODULE bootsj_input


c
c ---------------------------------------------------------------------
c    limit one cell at a time. When chagne data structure to store
c    nhood for each cell, then put loop around it and wont need nlist
c
       subroutine limitCellLP(qp,qx,qy,mitot,mjtot,irr,lstgrd,
     &                        lwidth,hx,hy,xlow,ylow,mptr,nvar,
     &                        nlist,num_neighb,num_iters,ix0,iy0,x0,y0)

      use amr_module
      implicit double precision(a-h,o-z)

      dimension qp(nvar,mitot,mjtot),qx(nvar,mitot,mjtot),
     &          qy(nvar,mitot,mjtot),irr(mitot,mjtot)
      dimension nlist(25,2)
      logical nolimiter, quad
      common /order2/ ssw, quad, nolimiter
      include "cuserdt.i"
c
c sandras variables
c
      parameter (max_num_nbor=22)
      logical  LP_success, output_debug
      double precision neighb_x(max_num_nbor)
      double precision neighb_y(max_num_nbor)
      double precision neighb_u(max_num_nbor)
      double precision Phi_x, Phi_y, LP_Dx,LP_Dy, LS_Dx, LS_Dy
      integer row_A
      logical do_pos_constr ! are we really a cutcell?
      integer my_iters, tot_iters, max_iters   ! maximum no of iterations needed in Simplex
      double precision avg_iters    ! avg number of iterations needed in Simplex
      integer count_cells
      logical added_neighbor
c
c
c     count_cells = 0
c     tot_iters = 0
c     max_iters = 0
c
          center_x = x0
          center_y = y0
c         if (added_neighbor) then
c            num_neighb = newend-2  ! don't use diagonal neighbor for limiting
c         else
c            num_neighb = newend-1 ! not counting cell itself
c         end if

          num_neighb = newend-1 ! not counting cell itself
          output_debug = .false.

          do m = 1, nvar    ! loop over the 4 variables
            row_A     = 2*num_neighb + 4
            do_pos_constr = .false.

c           if (irr(ix0,iy0) .ne. lstgrd) then
c              if (m .eq. 1 .OR. m .eq. 4) then
c                 do_pos_constr = .true.
c                 row_A = row_A + 1 ! additional pos constraint for rho, p
c              endif
c           endif

            do inbor = 1, num_neighb
              ixn = nlist(inbor+1,1)
              iyn = nlist(inbor+1,2)
              kn =  irr(ixn,iyn)
              if (kn .ne. lstgrd) then
                 xn = xcirr(kn)
                 yn = ycirr(kn)
              else
                 xn = xlow + (ixn-.5d0)*hx
                 yn = ylow + (iyn-.5d0)*hy
              endif

              neighb_x(inbor) = xn ! neighboring centroid, not diffs
              neighb_y(inbor) = yn ! neighboring centroid, not diffs

              neighb_u(inbor) = qp(m,ixn,iyn)  ! neighboring u, need to loop over m
            end do  ! do inbor = 1, num_neighb
              center_u = qp(m,ix0,iy0)
              LS_Dx = qx(m,ix0,iy0)
              LS_Dy = qy(m,ix0,iy0)

            LP_success = .false.

             call vector_lim_allineq(num_neighb,neighb_x,neighb_y,
     &               neighb_u,center_x,center_y,center_u,output_debug,
     &               row_A,Phi_x,Phi_y, LP_Dx,LP_Dy,LP_success,
     &           LS_Dx,LS_Dy,bxpt,bypt,do_pos_constr,my_iters,lpChoice)

c           Increase the count of number of iterations
c           tot_iters = tot_iters + my_iters
c           if (my_iters .GT. max_iters) then
c              max_iters = my_iters
c           endif
c           count_cells = count_cells + 1

c             write(*,402) LS_Dx,LS_Dy,LP_Dx,LP_Dy
 402         format("sandras lsq ",2e15.7,10x," limited ",2e15.7)

             if (LP_success) then
                  qx(m,ix0,iy0) = LP_Dx
                  qy(m,ix0,iy0) = LP_Dy
c                  write(*,400),m, Phi_x, Phi_y
 400              format("limiter values for m = ",i3," are ",2e15.7)
             else
                  write(*,*)"LP failure for grid cell var ",
     &                      mptr,ix0,iy0,m
                  qx(m,ix0,iy0) = 0.d0
                  qy(m,ix0,iy0) = 0.d0

c                 stop
             endif

          end do   ! do m=1,4
c
c     if (count_cells > 0) then
c        avg_iters = dble(tot_iters)/dble(count_cells)
c     else
c        avg_iters = 0
c     endif
c     write(21,*) "Avg_no_of_iters", avg_iters
c     write(23,*) "Max_no_of_iters", max_iters
c
      return
      end


#include "eiscor.h"
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! z_rot3_fusion
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! This routine uses the generators for two Givens rotations represented
! by 3 real numbers: the real and imaginary parts of a complex cosine
! and a scrictly real sine and performs a fusion. !
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! INPUT VARIABLES:
!
!  FLAG             LOGICAL
!                    .TRUE.: store product in G1 and diagonal in G2
!                    .FALSE.: store product in G2 and diagonal in G1
!
!  G1, G2           REAL(8) arrays of dimension (3)
!                    generators for givens rotations
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine z_rot3_fusion(FLAG,G1,G2)

  implicit none

  ! input variables
  logical, intent(in) :: FLAG
  real(8), intent(inout) :: G1(3), G2(3)

  ! compute variables
  real(8) :: c1r, c1i, s1
  real(8) :: c2r, c2i, s2
  real(8) :: c3r, c3i, s3r, s3i
  real(8) :: phr, phi
  real(8) :: nrm

  ! retrieve G1
  c1r = G1(1)
  c1i = G1(2)
  s1 = G1(3)

  ! retrieve G2
  c2r = G2(1)
  c2i = G2(2)
  s2 = G2(3)

  ! compute givens product
  c3r = c1r*c2r - c1i*c2i - s1*s2
  c3i = c1r*c2i + c1i*c2r
  s3r = s1*c2r + c1r*s2
  s3i = s1*c2i - c1i*s2

  ! compute phase
  call d_rot2_vec2gen(s3r,s3i,phr,phi,nrm)

  ! store product in G1 and diagonal in G2
  if (FLAG) then

      ! update G1
      c2r = c3r*phr + c3i*phi
      c2i = -c3r*phi + c3i*phr
      s2 = s3r*phr + s3i*phi
      call z_rot3_vec3gen(c2r,c2i,s2,G1(1),G1(2),G1(3),nrm)

      ! set G2
      G2(1) = phr
      G2(2) = phi
      G2(3) = 0d0

  ! store product in G2 and diagonal in G1
  else

      ! update G2
      c2r = c3r*phr - c3i*phi
      c2i = c3r*phi + c3i*phr
      s2 = s3r*phr + s3i*phi
      call z_rot3_vec3gen(c2r,c2i,s2,G2(1),G2(2),G2(3),nrm)

      ! set G2
      G1(1) = phr
      G1(2) = -phi
      G1(3) = 0d0

  end if

end subroutine z_rot3_fusion


program demo
  use coneangle_main, only: cone_angle

  integer, parameter :: dp = selected_real_kind(15, 307)
  real(dp) :: coordinates(3, 3), radii(3), alpha, axis(3)
  integer :: tangent_atoms(3), stat
  character(:), allocatable :: errmsg

  coordinates = reshape([0._dp, 0._dp, -0.52_dp, 0._dp, 0._dp, 1.76_dp, 0._dp, 0._dp, 2.86_dp], [3, 3])
  radii = [2.1_dp, 1.7_dp, 1.52_dp]
  call cone_angle(coordinates, radii, 1, alpha, axis, tangent_atoms, stat, errmsg)
  write (*, *) "Cone angle:", alpha
  write (*, *) "Cone axis:", axis
  write (*, *) "Tangent atoms:", tangent_atoms
end program demo


!    SpiralMaker software (General Node Model)
!    Computational model to simulate embryonic cleavage.
!    Copyright (C) 2014 Miquel Marin-Riera, Miguel Brun-Usan, Roland Zimm, Tommi Välikangas & Isaac Salazar-Ciudad

!    This program is free software: you can redistribute it and/or modify
!    it under the terms of the GNU General Public License as published by
!    the Free Software Foundation, either version 3 of the License, or
!    any later version.

!    This program is distributed in the hope that it will be useful,
!    but WITHOUT ANY WARRANTY; without even the implied warranty of
!    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
!    GNU General Public License for more details.

!    You should have received a copy of the GNU General Public License
!    along with this program.  If not, see <http://www.gnu.org/licenses/>.

module pola  !>>>>>>>MIQUEL MADE MODULE 3-4-13
use general
use neighboring
use io
use aleas
use genetic

contains

subroutine pol_physic(celd,vx,vy,vz)		!this subroutine applies a physical criterion to determine the cell polarisation for division to take place
											!(namely it will polarize in the cell's longer axis)
											!a linear regression is calculated using all the cell's nodes and the resulting vector will be normal to the plane of division
integer,intent(in)::celd
integer::num,tipi
real*8::unum
integer::i,j,k,ii,jj,kk
real*8 ::d
real*8::a,b,c,xm,ym,zm,sxx,sxy,syy,sxz,szz,syz,thet,cost,sint
real*8::k11,k22,k12,k10,k01,k00
real*8::c2,c1,c0
real*8::dm,rho,phi,p,q,r
real*8::ka,kb,ku,kv,kw
real*8,intent(out)::vx,vy,vz
real*8,allocatable::px(:),py(:),pz(:)

	tipi=node(cels(celd)%node(1))%tipus

	if(tipi<3)then	!if epithelial, we only calculate the regression for the top layer (we ignore cell depth,because it causes artifacts if we take all the epithelial nodes)
		num=cels(celd)%nunodes
		allocate(px(num),py(num),pz(num))
		ii=0
		do i=1,num				!we load the cell's nodes
			j=cels(celd)%node(i)
		end do
		num=ii
	else
		num=cels(celd)%nunodes
		unum=1d0/num
		allocate(px(num),py(num),pz(num))
!		print*,"num",num
		do i=1,num				!we load the cell's nodes
			j=cels(celd)%node(i)
			px(i)=node(j)%x
			py(i)=node(j)%y
			pz(i)=node(j)%z
!			print*,"px",px(i),"py",py(i),"pz",pz(i)
		end do
	end if

	unum=1d0/num
!	print*,"num",num

	xm=0;ym=0;zm=0			!averages
	do i=1,num
		xm=xm+px(i)
		ym=ym+py(i)
		zm=zm+pz(i)
	end do

	xm=xm*unum
	ym=ym*unum
	zm=zm*unum

	sxx=0;sxy=0;syy=0;sxz=0;szz=0;syz=0		!covariances
	do i=1,num
		sxx=sxx+px(i)**2
		sxy=sxy+px(i)*py(i)
		syy=syy+py(i)**2
		sxz=sxz+px(i)*pz(i)
		szz=szz+pz(i)**2
		syz=syz+py(i)*pz(i)
	end do
	sxx=sxx*unum-(xm**2)
	sxy=sxy*unum-xm*ym
	syy=syy*unum-(ym**2)
	sxz=sxz*unum-xm*zm
	szz=szz*unum-(zm**2)
	syz=syz*unum-ym*zm
	if(sxx<=epsilod) sxx=1d-5       !if one of the covariances are 0 (which means the surface is perfectly flat on one coordinate plane
    if(sxy<=epsilod) sxy=1d-5       !the algorithm crashes, so we do the trick of assigning a very small value
    if(syy<=epsilod) syy=1d-5
    if(sxz<=epsilod) sxz=1d-5
    if(syz<=epsilod) syz=1d-5
    if(szz<=epsilod) szz=1d-5

	!from here on it's fucking black magic!
	thet=0.5d0*atan(2*sxy/(sxx-Syy))

	cost=cos(thet)
	sint=sin(thet)

!	print*,"thet",thet,"cost",cost,"sint",sint

	k11=(syy+szz)*cost**2+(sxx+szz)*sint**2-2*sxy*cost*sint
	k22=(syy+szz)*sint**2+(sxx+szz)*cost**2+2*sxy*cost*sint
	k12=-sxy*(cost**2-sint**2)+(sxx-syy)*cost*sint
	k10=sxz*cost+syz*sint
	k01=-sxz*sint+syz*cost
	k00=sxx+syy
	c2=-k00-k11-k22
	c1=k00*k11+k00*k22+k11*k22-k01**2-k10**2
	c0=k01**2*k11+k10**2*k22-k00*k11*k22
	p=c1-(c2**2)/3d0
	q=2*(c2**3)/27d0-(c1*c2)/3d0+c0
	r=(q**2)/4d0+(p**3)/27d0

!	print*,"p",p,"q",q,"r",r

	if(r>0)then
		a=-c2/3d0
		b=(-0.5d0*q+sqrt(r))
		c=(-0.5d0*q-sqrt(r))
!		print*,"A",a,"B",b,"C",c
		if(b<0)then
			b=-(-b)**(1d0/3d0)
		end if
		if(c<0)then
			c=-(-c)**(1d0/3d0)
		end if
!		print*,"A",a,"B",b,"C",c
		dm=a+b+c
	else
		rho=sqrt(-p**3/27d0)
		phi=acos(-q/(2*rho))
		a=-c2/3d0+2*(rho**(1d0/3d0))*cos(phi/3d0)
		b=-c2/3d0+2*(rho**(1d0/3d0))*cos((phi+2*pi)/3d0)
		c=-c2/3d0+2*(rho**(1d0/3d0))*cos((phi+4*pi)/3d0)
		dm=min(a,b,c)
	end if
	ka=-k10*cost/(k11-dm)+k01*sint/(k22-dm)
	kb=-k10*sint/(k11-dm)-k01*cost/(k22-dm)

!	print*,"ka",ka,"kb",kb

	ku=((1+kb**2)*xm-ka*kb*ym+ka*zm)/(1+ka**2+kb**2)
	kv=(-ka*kb*xm+(1+ka**2)*ym+kb*zm)/(1+ka**2+kb**2)
	kw=(ka*xm+kb*ym+(ka**2+kb**2)*zm)/(1+ka**2+kb**2)

!	print*,"vectortip",ku,kv,kw
!	print*,"centerpoint",xm,ym,zm

	vx=xm-ku;vy=ym-kv;vz=zm-kw

        d=1d0/sqrt(vx**2+vy**2+vz**2)  ! >>> Is 21-6-14

        vx=vx*d ; vy=vy*d ; vz=vz*d    ! >>> Is 21-6-14

end subroutine pol_physic

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

subroutine polarigen(kceld,kgen)
integer:: kceld,nnod,ggr,ccen,kgen
real*8::a,b,c,d,e,ax,ay,az,bx,by,bz,cx,cy,cz,iwx,iwy,iwz,alfa,s

        nnod=cels(kceld)%nunodes
        iwy=1d10 ; cx=0d0 ; cy=0d0 ; cz=0d0
	a=cels(kceld)%cex ; b=cels(kceld)%cey ; c=cels(kceld)%cez

        do i=1,nnod                                                     ! (gen) in the centroid (in the closest node)
          j=cels(kceld)%node(i)
            d=sqrt((node(j)%x-a)**2+(node(j)%y-b)**2+(node(j)%z-c)**2)
          if(d.le.iwy)then;iwy=d;ccen=j;endif
        end do

        alfa=0.0d0                                                 ! concentration in the central node
        kk=kgen!whonpag(nparam_per_node+8,k)
        if (gex(ccen,kk)>0.0d0) then
          alfa=alfa+gex(ccen,kk)!*gen(kk)%wa(nparam_per_node+8)   ! wa in units of probability such that it makes things to go from 0 to 1
        end if

        iwx=0d0 ; iwy=0d0 ; iwz=0d0                                        ! vector of the gradient within a cell
        do i=1,nnod
            j=cels(kceld)%node(i)
              d=sqrt((node(j)%x-a)**2+(node(j)%y-b)**2+(node(j)%z-c)**2)
              if (d<epsilod) cycle
              d=1d0/d                                                   ! module of radial vectors to get unitary vectors
              s=0.0d0
                kk=kgen!whonpag(nparam_per_node+8,k)
                if (gex(j,kk)>0.0d0) then
                  s=s+gex(j,kk)!*gen(kk)%wa(nparam_per_node+8)
                end if
              iwx=iwx+((node(j)%x-a)*d)*(s-alfa)                   ! and ignore shape/siwze effects
              iwy=iwy+((node(j)%y-b)*d)*(s-alfa)
              iwz=iwz+((node(j)%z-c)*d)*(s-alfa)
        end do

        if((iwx.eq.0).and.(iwy.eq.0).and.(iwz.eq.0))then            ! if the gene has uniform expresion, the vector is random ! >>>Miguel1-7-14
          call random_number(a)                                  ! >>>Miguel1-7-14
          k=int(a*nvaloq)+1                                      ! >>>Miguel1-7-14
          cels(kceld)%polx=particions_esfera(k,1) ; cels(kceld)%poly=particions_esfera(k,2)
          cels(kceld)%polz=particions_esfera(k,3)
        else                                                     ! >>>Miguel1-7-14
          a=iwx**2+iwy**2+iwz**2
          if(a==0)then
            cels(kceld)%polx=0d0 ; cels(kceld)%poly=0d0 ; cels(kceld)%polz=0d0	! unitary resultant vector (gradient polariwzation)
          else
            d=1d0/sqrt(a)
            cels(kceld)%polx=iwx*d ; cels(kceld)%poly=iwy*d ; cels(kceld)%polz=iwz*d	! unitary resultant vector (gradient polariwzation)
          end if
          if((iwx.eq.0d0).and.(iwy.eq.0d0).and.(iwz.eq.0d0))then                     ! miguel27-11-13
            cels(kceld)%polx=0d0 ; cels(kceld)%poly=0d0 ; cels(kceld)%polz=0d0
          endif   ! miguel27-11-13
        endif                                                    ! >>>Miguel1-7-14
end subroutine

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

subroutine pol_special(celd,actin)		! the same as befre, but using only nodes with some amount of certain gene(s) !>>>Miguel 28-1-15

integer,intent(in)::celd
integer::num,tipi,actin
real*8::unum
integer::i,j,k,ii,jj,kk
real*8 ::d
real*8::a,b,c,xm,ym,zm,sxx,sxy,syy,sxz,szz,syz,thet,cost,sint
real*8::k11,k22,k12,k10,k01,k00
real*8::c2,c1,c0
real*8::dm,rho,phi,p,q,r
real*8::ka,kb,ku,kv,kw
real*8::vx,vy,vz
real*8,allocatable::px(:),py(:),pz(:)
integer,allocatable :: which(:)

        allocate(which(cels(celd)%nunodes)) ; which=0
        num=0
        do i=1,cels(celd)%nunodes
          j=cels(celd)%node(i)
          if(gex(j,actin).gt.1d1)then
            num=num+1 ; which(num)=j
              !if((ncels.gt.1).and.(gex(j,4).lt.1d1))then
              !num=num-1 ; end if
          end if
        end do
	!write(*,*)'celd',celd,'nunodes',cels(celd)%nunodes,'num',num
	allocate(px(num),py(num),pz(num))
	do i=1,num				!we load the cell's nodes
		j=which(i)
		px(i)=node(j)%x
		py(i)=node(j)%y
		pz(i)=node(j)%z
	end do

	unum=1d0/num
	xm=0;ym=0;zm=0			!averages
	do i=1,num
		xm=xm+px(i) ; ym=ym+py(i) ; zm=zm+pz(i)
	end do

	xm=xm*unum ; ym=ym*unum ; zm=zm*unum
	sxx=0;sxy=0;syy=0;sxz=0;szz=0;syz=0		!covariances
	do i=1,num
		sxx=sxx+px(i)**2          ; 	sxy=sxy+px(i)*py(i)
		syy=syy+py(i)**2          ; 	sxz=sxz+px(i)*pz(i)
		szz=szz+pz(i)**2          ; 	syz=syz+py(i)*pz(i)
	end do
	sxx=sxx*unum-(xm**2)     ;    sxy=sxy*unum-xm*ym
	syy=syy*unum-(ym**2)     ;    sxz=sxz*unum-xm*zm
	szz=szz*unum-(zm**2)     ;    syz=syz*unum-ym*zm
	if(sxx<=epsilod) sxx=1d-5       !if one of the covariances are 0 (which means the surface is perfectly flat on one coordinate plane
        if(sxy<=epsilod) sxy=1d-5       !the algorithm crashes, so we do the trick of assigning a very small value
        if(syy<=epsilod) syy=1d-5
        if(sxz<=epsilod) sxz=1d-5
        if(syz<=epsilod) syz=1d-5
        if(szz<=epsilod) szz=1d-5

	!from here on it's fucking black magic!
	thet=0.5d0*atan(2*sxy/(sxx-Syy))
	cost=cos(thet) ; sint=sin(thet)
	k11=(syy+szz)*cost**2+(sxx+szz)*sint**2-2*sxy*cost*sint
	k22=(syy+szz)*sint**2+(sxx+szz)*cost**2+2*sxy*cost*sint
	k12=-sxy*(cost**2-sint**2)+(sxx-syy)*cost*sint
	k10=sxz*cost+syz*sint ; k01=-sxz*sint+syz*cost ; k00=sxx+syy
	c2=-k00-k11-k22  ;  c1=k00*k11+k00*k22+k11*k22-k01**2-k10**2
	c0=k01**2*k11+k10**2*k22-k00*k11*k22
	p=c1-(c2**2)/3d0 ; q=2*(c2**3)/27d0-(c1*c2)/3d0+c0
	r=(q**2)/4d0+(p**3)/27d0

	if(r>0)then
		a=-c2/3d0 ; b=(-0.5d0*q+sqrt(r)) ; c=(-0.5d0*q-sqrt(r))
		if(b<0)then ; b=-(-b)**(1d0/3d0) ; end if
		if(c<0)then ; c=-(-c)**(1d0/3d0) ; end if
		dm=a+b+c
	else
		rho=sqrt(-p**3/27d0) ; phi=acos(-q/(2*rho))
		a=-c2/3d0+2*(rho**(1d0/3d0))*cos(phi/3d0)
		b=-c2/3d0+2*(rho**(1d0/3d0))*cos((phi+2*pi)/3d0)
		c=-c2/3d0+2*(rho**(1d0/3d0))*cos((phi+4*pi)/3d0)
		dm=min(a,b,c)
	end if

	ka=-k10*cost/(k11-dm)+k01*sint/(k22-dm)
	kb=-k10*sint/(k11-dm)-k01*cost/(k22-dm)
	ku=((1+kb**2)*xm-ka*kb*ym+ka*zm)/(1+ka**2+kb**2)
	kv=(-ka*kb*xm+(1+ka**2)*ym+kb*zm)/(1+ka**2+kb**2)
	kw=(ka*xm+kb*ym+(ka**2+kb**2)*zm)/(1+ka**2+kb**2)

	vx=xm-ku ; vy=ym-kv ; vz=zm-kw
        d=1d0/sqrt(vx**2+vy**2+vz**2)  ! >>> Is 21-6-14

        cels(celd)%spolx=vx*d ; cels(celd)%spoly=vy*d ; cels(celd)%spolz=vz*d    ! >>> Is 21-6-14

        deallocate(which)

end subroutine pol_special
!!!!!!!!!

end module pola


MODULE m_veqC2T

! ----------------------------------------------------------------------
! MODULE: m_veqC2T.f03
! ----------------------------------------------------------------------
! Purpose:
!  Module for calling the subroutine 'veqC2T'
! ----------------------------------------------------------------------
! Author :	Dr. Thomas Papanikolaou at Geoscience Australia & Frontier-SI
! Created:	5 August 2019
! ----------------------------------------------------------------------

      IMPLICIT NONE
      !SAVE

Contains

SUBROUTINE veqC2T (mjd, sec00, veqZ_C, veqP_C, veqZ_T, veqP_T)

! ----------------------------------------------------------------------
! SUBROUTINE: veqC2T
! ----------------------------------------------------------------------
! Purpose:
!  Variational Equations solution (matrices per epoch) transformation
!  from inertial (ICRF) to terrestrial (ITRF) reference frame
! ----------------------------------------------------------------------
! Input arguments:
! - mjd:		Modified Julian Day number (including the fraction of the day) in Terrestrial Time (TT)
! - sec00:		Seconds since the start of the day 00h
! - veqZ_C:		State transition matrix (6x6) at the input epoch in inertial reference frame (ICRF)
! - veqP_C:		Sensitivity matrix (6 x Np) at the input epoch in inertial reference frame (ICRF)
!
! Output arguments:
! - veqZ_T:		State transition matrix (6x6) at the input epoch in terrestrial inertial reference frame (ITRF)
! - veqP_T:		Sensitivity matrix (6 x Np) at the input epoch in terrestrial reference frame (ITRF)
! ----------------------------------------------------------------------
! Author :	Dr. Thomas Papanikolaou at Geoscience Australia & Frontier-SI
! Created:	5 August 2019
! ----------------------------------------------------------------------

      USE mdl_precision
      USE mdl_eop
      IMPLICIT NONE

! ----------------------------------------------------------------------
! Dummy arguments declaration
! ----------------------------------------------------------------------
! IN
      REAL (KIND = prec_d) :: mjd, sec00
      REAL (KIND = prec_d), DIMENSION(6,6), INTENT(IN) :: veqZ_C
      REAL (KIND = prec_d), DIMENSION(:,:), ALLOCATABLE, INTENT(IN) :: veqP_C
! ----------------------------------------------------------------------
! OUT
      REAL (KIND = prec_d), DIMENSION(6,6), INTENT(OUT) :: veqZ_T
      REAL (KIND = prec_d), DIMENSION(:,:), ALLOCATABLE, INTENT(OUT) :: veqP_T
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Local variables declaration
! ----------------------------------------------------------------------
      REAL (KIND = prec_d) :: veqZ_r_crs(3,6), veqZ_v_crs(3,6)
      REAL (KIND = prec_d) :: veqZ_r_trs(3,6), veqZ_v_trs(3,6)

      REAL (KIND = prec_d), DIMENSION(:,:), ALLOCATABLE :: veqP_r_crs, veqP_v_crs
      REAL (KIND = prec_d), DIMENSION(:,:), ALLOCATABLE :: veqP_r_trs, veqP_v_trs
      INTEGER (KIND = prec_int8) :: sz1, sz2
      INTEGER (KIND = prec_int2) :: AllocateStatus, DeAllocateStatus
      INTEGER (KIND = prec_int8) :: Nparam, N1

	  REAL (KIND = prec_d) :: mjd_TT, mjd_GPS, mjd_TAI, mjd_UTC
      DOUBLE PRECISION EOP_cr(7)
      DOUBLE PRECISION CRS2TRS(3,3), TRS2CRS(3,3), d_CRS2TRS(3,3), d_TRS2CRS(3,3)
! ----------------------------------------------------------------------

mjd_TT = mjd

! ----------------------------------------------------------------------
! ICRF to ITRF Transformation matrices (including derivatives) based on EOP data
CALL EOP (mjd_TT, EOP_cr, CRS2TRS, TRS2CRS, d_CRS2TRS, d_TRS2CRS)
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! VEQ matrices in celestial reference system (ICRS)
! ----------------------------------------------------------------------
veqZ_r_crs = veqZ_C(1:3,:)
veqZ_v_crs = veqZ_C(4:6,:)

sz1 = size(veqP_C, DIM = 1)
sz2 = size(veqP_C, DIM = 2)
N1 = 3
Nparam = sz2
! Dynamic allocatable arrays
ALLOCATE (veqP_r_crs(3,Nparam), STAT = AllocateStatus)
ALLOCATE (veqP_v_crs(3,Nparam), STAT = AllocateStatus)
veqP_r_crs = veqP_C(1:3,:)
veqP_v_crs = veqP_C(4:6,:)

ALLOCATE (veqP_r_trs(3,Nparam), STAT = AllocateStatus)
ALLOCATE (veqP_v_trs(3,Nparam), STAT = AllocateStatus)
ALLOCATE (veqP_T(6,Nparam), STAT = AllocateStatus)
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Transformation of state transition matrix
! ----------------------------------------------------------------------
!veqZ_trs = [veqZ_r_trs; veqZ_v_trs]
!veqZ_r_trs = CRS2TRS * veqZ_r
!veqZ_v_trs = CRS2TRS * veqZ_v + d_CRS2TRS * veqZ_r

veqZ_r_trs = MATMUL(CRS2TRS, veqZ_r_crs)
veqZ_v_trs = MATMUL(CRS2TRS, veqZ_v_crs) + MATMUL(d_CRS2TRS, veqZ_r_crs)

veqZ_T(1:3,:) = veqZ_r_trs
veqZ_T(4:6,:) = veqZ_v_trs
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Transformation of sensitivity matrix
! ----------------------------------------------------------------------
!veqP_trs = [veqP_r_trs; veqP_v_trs]
!veqP_r_trs = CRS2TRS * veqP_r
!veqP_v_trs = CRS2TRS * veqP_v + d_CRS2TRS * veqP_r

veqP_r_trs = MATMUL(CRS2TRS, veqP_r_crs)
veqP_v_trs = MATMUL(CRS2TRS, veqP_v_crs) + MATMUL(d_CRS2TRS, veqP_r_crs)

veqP_T(1:3,:) = veqP_r_trs
veqP_T(4:6,:) = veqP_v_trs
! ----------------------------------------------------------------------

END SUBROUTINE

END MODULE


c ---------------------------------------------------------
      SUBROUTINE DDRVEOF(X,NROW,NCOL,NOBS,MSTA,XMSG,NEVAL,EVAL,EVEC,
     +                  PCVAR,TRACE,IOPT,JOPT,CSSM,LCSSM,WORK,LWORK,
     +                  WEVAL,IWORK,LIWORK,IFAIL,LIFAIL,IER)
      DOUBLE PRECISION XMSG
      DOUBLE PRECISION TRACE
      DOUBLE PRECISION TOL
      DOUBLE PRECISION DEPSMACH
      DOUBLE PRECISION VLOW
      DOUBLE PRECISION VUP

c driver to calculate :
C*PL*ERROR* Comment line too long
c .   the principal components (eignvalues and corresponding eigenvectors)
c .       of the data array x. x may contain missing observations.
c .       if it has msg data, this will calculate a var-cov matrix
c .       but it may not be positive definite.

c .       USES LAPACK/BLAS ROUTINES

c nomenclature :
C*PL*ERROR* Comment line too long
c .   x         - matrix containing the data.  it contains n observations
c .               for each of m stations or grid pts.
C*PL*ERROR* Comment line too long
c .   nrow,ncol - exact row (observation) and column (station) dimensions
c .               of x in the calling routine.
c .   nobs      - actual number of observations (nobs <= nrow)
c .   msta      - actual number of stations     (msta <= ncol)
c .   xmsg      - missing code (if no obs are missing set to some
c .               number which will not be encountered)
c .   neval     - no. of eigenvalues and eigen vectors to be computed.
C*PL*ERROR* Comment line too long
c .               neval <= msta , if not msta eigenvalues and eigenvectors
c .               will be computed and ier = -2.
c .   eval      - vector containing the eigenvalues in DESCENDING order.
c .               eval must be at least neval in length.
c .   evec      - an array which will contains the eigenvector info.
c .               this must be dimensioned at least (ncol,neval) in the
c .               calling routine. There is some normalization done
c .               but I am not sure waht it is.
C*PL*ERROR* Comment line too long
c .   pcvar     - contains the % variance associated with each eigenvalue.
c .               this must be dimensioned at least neval in length.
c .   trace     - trace of the variance - covariance matrix.in the
c .               case of a var-covar matrix , the trace should
c .               equal the sum of all possible eigenvalues.
c .   iopt      - not used; kept for compatibility with old routine
c .   jopt      - =  0 : use var-covar matrix in prncmp
c .                  1 : use correlation matrix in prncmp
c .   cssm      - real vector to hold the covariance/correlation matrix
c .   lcssm     - length of cssm =msta*(msta+1)/2
c .   work      - real vector
c .   weval     - = msta
c .   lwork     - = 8*msta
c .   iwork     - integer vector
c .   liwork    - = 5*msta
c .   ifail     - integer vector
c .   lifail    - = msta
c .   ier       - error code

c NOTE: upon return if one want to get loadings,
c       something like this should be tried.
c
c           to calculate the coef or amplitude vector
c           associated with the n th eigenvector
c           mult the anomaly matrix (datam) times the
c           transpose of the eigenvector
c               meval = neval
c               do n=1,meval
c                  evwrk(n) = 0.
c                 do nyr=1,nyrs
c                    evyran(nyr,n) = 0.0
c                    evyrpv(nyr,n) = 0.0
c                   do m=1,msta
c                      if (datam(nyr,m).ne.xmsg) then
c                          temp = evec(m,n)*datam(nyr,m)
c                          evyran(nyr,n) = evyran(nyr,n) + temp
c                          evyrpv(nyr,n) = evyrpv(nyr,n) + temp*temp
c                          evwrk(n) = evwrk(n) + temp*temp
c                      endif
c                   enddo
c                 enddo
c               .
c               enddo

      DOUBLE PRECISION X(1:NROW,1:NCOL),EVAL(*),EVEC(1:NCOL,*)
      REAL PCVAR(*)
      INTEGER*8 LCSSM
      DOUBLE PRECISION CSSM(LCSSM),WORK(LWORK),WEVAL(LIFAIL)
      INTEGER IWORK(LIWORK),IFAIL(LIFAIL)

      CHARACTER*16 LABEL
C*PT*WARNING* Already double-precision
      DOUBLE PRECISION TEMP

      DATA IPR/6/
      DATA IPRFLG/1/
c calculate covariance or correlation matrix in symmetric storage mode

      IER = 0
      IF (JOPT.EQ.0) THEN
          CALL DVCMSSM(X,NROW,NCOL,NOBS,MSTA,XMSG,CSSM,LSSM,IER)
      ELSE
          CALL DCRMSSM(X,NROW,NCOL,NOBS,MSTA,XMSG,CSSM,LSSM,IER)
      END IF
      IF (IER.NE.0) THEN
          WRITE (IPR,FMT=
     +'(//'' sub drveof: ier,jopt= '',2i3
     +   ,'' returned from vcmssm/crmssm'')') IER,JOPT
          IF (IER.GT.0) RETURN
      END IF

c activate if print of cov/cor matrix [work] is desired

      IF (IPRFLG.EQ.2) THEN
          IF (JOPT.EQ.0) THEN
              LABEL(1:15) = 'covar matrix:  '
          ELSE
              LABEL(1:15) = 'correl matrix: '
          END IF
          WRITE (IPR,FMT='(//,a15,''sym storage mode'')') LABEL(1:15)
          CALL DSSMIOX(CSSM,MSTA)
      END IF

c calculate the trace  before it is destroyed by sspevx

      NA = 0
C*PT*WARNING* Already double-precision (DBLE)
      TEMP = DBLE(0.D0)
      DO NN = 1,MSTA
          NA = NA + NN
C*PT*WARNING* Already double-precision (DBLE)
          TEMP = TEMP + DBLE(CSSM(NA))
      END DO
C*PT*WARNING* Already double-precision (DBLE)
      IF (TEMP.EQ.DBLE(0.D0)) THEN
          IER = -88
          WRITE (IPR,FMT=
     +'(//'' sub drveof: ier,jopt= '',2i3
     +   ,'' trace=0.0'')') IER,JOPT
          RETURN
      END IF
      TRACE = TEMP

c calculate the specified number of eigenvalues and the corresponding
c .   eigenvectors.

      MEVAL = MIN(NEVAL,MSTA)

      TOL = 10.D0*DEPSMACH(IPR)
      VLOW = 0.0D0
      VUP = 0.0D0
      ILOW = MAX(MSTA-MEVAL+1,1)
      IUP = MSTA
      CALL DSPEVX('V','I','U',MSTA,CSSM,VLOW,VUP,ILOW,IUP,TOL,MEVOUT,
     +            WEVAL,EVEC,NCOL,WORK,IWORK,IFAIL,INFO)

      IF (INFO.NE.0) THEN
          IER = IER + INFO
          WRITE (IPR,FMT=
     +'(//,'' sub drveof: sspevx error: info=''
     +      ,   i9)') INFO
          WRITE (IPR,FMT=
     +'(   '' sub drveof: sspevx error: ifail=''
     +      ,   20i5)') (IFAIL(I),I=1,MIN(20,MSTA))
      END IF

c reverse the order of things from "sspevx" so
c .   largest eigenvalues/vectors are first.

      DO N = 1,MEVAL
          WORK(N) = WEVAL(N)
      END DO
      DO N = 1,MEVAL
          EVAL(N) = WORK(NEVAL+1-N)
      END DO

      DO N = 1,MSTA
          DO NN = 1,NEVAL
              WORK(NN) = EVEC(N,NN)
          END DO
          DO NN = 1,NEVAL
              EVEC(N,NN) = WORK(NEVAL+1-NN)
          END DO
      END DO
C
C Convert EVEC and EVAL to single precision real
C
      DO N = 1,MEVAL
          PCVAR(N) = REAL(EVAL(N)/TRACE)*100.
      END DO

      RETURN
      END

      SUBROUTINE DNCLDRV(XX,X,NROW,NCOL,NOBS,NSTA,XMSG,NEVAL,EVAL,EVEC,
     +                 PCVAR,TRACE,IOPT,JOPT,PCRIT,EVECX,CSSM,LCSSM,
     +                 WORK,LWORK,WEVAL,IWORK,LIWORK,IFAIL,LIFAIL,IER)
      DOUBLE PRECISION PCRITX

      INTEGER NROW,NCOL,NOBS,NSTA,NEVAL,IOPT,JOPT,IER
      INTEGER*8 LCSSM
      INTEGER LWORK,LIWORK,LIFAIL
      DOUBLE PRECISION XX(NROW,NCOL),EVAL(NEVAL),EVEC(NCOL,NEVAL),
     +                 PCRIT,XMSG,TRACE,X(NROW,NCOL),
     +                 EVECX(NCOL,NEVAL)
      DOUBLE PRECISION CSSM(LCSSM),WORK(LWORK),WEVAL(LIFAIL)
      REAL PCVAR(NEVAL)
      INTEGER IWORK(LIWORK),IFAIL(LIFAIL)

      DATA IPR/6/
      DATA IPRFLG/1/

      PCRITX = PCRIT*0.01D0
c                                   ! counts the total number of
c                                   ! locations with > pcrit non=msg
      MSTA = 0
      DO NC = 1,NSTA
c                                   ! counter for this location
          KNT = 0
          DO NR = 1,NOBS
              IF (XX(NR,NC).NE.XMSG) THEN
                  KNT = KNT + 1
              END IF
          END DO
          IF (DBLE(KNT)/DBLE(NOBS).GE.PCRITX) THEN
              MSTA = MSTA + 1
              DO IROW = 1,NROW
                  X(IROW,MSTA) = XX(IROW,NC)
              END DO
          END IF
      END DO

c      write (*,'(//'' sub dncldrv: nrow,ncol,nobs,msta= ''
c     1              ,4i3)') nrow,ncol,nobs,msta
      CALL DDRVEOF(X,NROW,NCOL,NOBS,MSTA,XMSG,NEVAL,EVAL,EVECX,PCVAR,
     +             TRACE,IOPT,JOPT,CSSM,LCSSM,WORK,LWORK,WEVAL,IWORK,
     +             LIWORK,IFAIL,LIFAIL,IER)

c before returning put the evecs in the correct location

C preset the return array to msg
      DO NE = 1,NEVAL
          DO NC = 1,NCOL
              EVEC(NC,NE) = XMSG
          END DO
      END DO
c                                   ! counts the total number of
c                                   ! locations with > pcrit non=msg
      MSTA = 0
      DO NC = 1,NSTA
c counter for this location
          KNT = 0
          DO NR = 1,NOBS
              IF (XX(NR,NC).NE.XMSG) THEN
                  KNT = KNT + 1
              END IF
          END DO
          IF (DBLE(KNT)/DBLE(NOBS).GE.PCRITX) THEN
              MSTA = MSTA + 1
              DO IEVAL = 1,NEVAL
                  EVEC(NC,IEVAL) = EVECX(MSTA,IEVAL)
              END DO
          END IF
      END DO

      RETURN
      END


subroutine qinit(meqn,mbc,mx,my,xlower,ylower,dx,dy,q,maux,aux)

    use geoclaw_module, only: sea_level
    use dz_module

    implicit none

    ! Input
    integer(kind=4), intent(in) :: meqn, mbc, mx, my, maux
    real(kind=8), intent(in) :: xlower, ylower, dx, dy

    real(kind=8), intent(in out) :: q(meqn,1-mbc:mx+mbc,1-mbc:my+mbc)
    real(kind=8), intent(in out) :: aux(maux,1-mbc:mx+mbc,1-mbc:my+mbc)

    ! Locals
    integer :: i, j

    dxfine = min(dxfine, dx)
    write(35, *) 'dxfine: ',dxfine

    ! Topo is set in b4step2:
    call b4step2(mbc,mx,my,meqn,q,xlower,ylower,dx,dy,0.d0,dt,maux,aux)

    do i = 1 - mbc, mx + mbc
        do j = 1 - mbc, my + mbc

            q(1, i, j) = max(0.d0, sea_level - aux(1, i, j))
            q(2, i, j) = 0.d0
            q(3, i, j) = 0.d0
        end do
    end do

end subroutine qinit


! { dg-do run }
! { dg-require-effective-target sse2_runtime { target { i?86-*-* x86_64-*-* } } }
! { dg-additional-options "-msse2 -mfpmath=sse" { target { i?86-*-* x86_64-*-* } } }

program test_underflow_control
  use ieee_arithmetic
  use iso_fortran_env

  logical l
  real, volatile :: x
  double precision, volatile :: y
  integer, parameter :: kx = kind(x), ky = kind(y)

  if (ieee_support_underflow_control(x)) then

    x = tiny(x)
    call ieee_set_underflow_mode(.true.)
    x = x / 2000._kx
    if (x == 0) STOP 1
    call ieee_get_underflow_mode(l)
    if (.not. l) STOP 2

    x = tiny(x)
    call ieee_set_underflow_mode(.false.)
    x = x / 2000._kx
    if (x > 0) STOP 3
    call ieee_get_underflow_mode(l)
    if (l) STOP 4

  end if

  if (ieee_support_underflow_control(y)) then

    y = tiny(y)
    call ieee_set_underflow_mode(.true.)
    y = y / 2000._ky
    if (y == 0) STOP 5
    call ieee_get_underflow_mode(l)
    if (.not. l) STOP 6

    y = tiny(y)
    call ieee_set_underflow_mode(.false.)
    y = y / 2000._ky
    if (y > 0) STOP 7
    call ieee_get_underflow_mode(l)
    if (l) STOP 8

  end if

end program


!>
!> @brief       Parallel TDMA test subroutine
!> @author      Ji-Hoon Kang (jhkang@kisti.re.kr), Korea Institute of Science and Technology Information
!> @date        20 January 2019
!> @version     0.1
!> @par         Copyright
!>              Copyright (c) 2018 by Ji-Hoon Kang. All rights reserved.
!> @par         License
!>              This project is release under the terms of the MIT License (see LICENSE in )
!>
program main

    use mpi
    use tdma_parallel

    implicit none

    integer(kind=4), parameter :: n = 32
    integer(kind=4)     :: i
    integer(kind=4)     :: nprocs, myrank
    integer(kind=4)     :: n_mpi
    integer(kind=4)     :: ierr

    real(kind=8), allocatable, dimension(:) :: a_mpi, b_mpi, c_mpi, x_mpi, r_mpi
    real(kind=8), allocatable, dimension(:) :: a_ver, b_ver, c_ver, r_ver

    call mpi_init(ierr)
    call mpi_comm_size(MPI_COMM_WORLD, nprocs, ierr)
    call mpi_comm_rank(MPI_COMM_WORLD, myrank, ierr)

    n_mpi = n / nprocs

    allocate(a_mpi(0:n_mpi+1))
    allocate(b_mpi(0:n_mpi+1))
    allocate(c_mpi(0:n_mpi+1))
    allocate(r_mpi(0:n_mpi+1))
    allocate(x_mpi(0:n_mpi+1))

    allocate(a_ver(0:n_mpi+1))
    allocate(b_ver(0:n_mpi+1))
    allocate(c_ver(0:n_mpi+1))
    allocate(r_ver(0:n_mpi+1))

    do i = 0, n_mpi+1
        a_mpi(i) = 0.0
        b_mpi(i) = 1.0
        c_mpi(i) = 0.0
        r_mpi(i) = 0.0
        x_mpi(i) = 0.0
    enddo

    do i = 1, n_mpi
        a_mpi(i) = 1.0 !+0.01*(i+myrank*n_mpi)
        c_mpi(i) = 1.0 !+0.02*(i+myrank*n_mpi)
        b_mpi(i) = -(a_mpi(i)+c_mpi(i))-0.1 !-0.02*(i+myrank*n_mpi)*(i+myrank*n_mpi)
        r_mpi(i) = dble(i-1+myrank*n_mpi)
        a_ver(i) = a_mpi(i)
        b_ver(i) = b_mpi(i)
        c_ver(i) = c_mpi(i)
        r_ver(i) = r_mpi(i)
    enddo

    call tdma_setup    (n, nprocs, myrank)
    call Thomas_pcr_solver (a_mpi, b_mpi, c_mpi, r_mpi, x_mpi)
!    call cr_pcr_solver (a_mpi, b_mpi, c_mpi, r_mpi, x_mpi)
    call verify_solution(a_ver, b_ver, c_ver, r_ver, x_mpi)

    deallocate(a_mpi)
    deallocate(b_mpi)
    deallocate(c_mpi)
    deallocate(r_mpi)
    deallocate(x_mpi)
    deallocate(a_ver)
    deallocate(b_ver)
    deallocate(c_ver)
    deallocate(r_ver)

    call mpi_finalize(ierr)

end program


! 7.53
! Записать нули на места элементов, образованных пересечением главной и побочной диагоналей
! у верхних треугольных матрицы Z и Y

program ex_7_53
   implicit none

   integer, allocatable    :: Z(:,:)
   integer                 :: In, Out, size_of_Z, i, column, k
   character(*), parameter :: output_file = "output.txt", input_file = "../data/input.txt"

   open (file=input_file, newunit=In)
      read(In, *) size_of_Z
      allocate(Z(size_of_Z,size_of_Z))
      read(In, *) (Z(i,:), i = 1, size_of_Z)

   close (In)

   k = nint(size_of_Z / 2.0)

   do concurrent (column = 1:size_of_Z)
      Z(1:(k - abs(k - column)),column) = 0
   end do

   open (file=output_file, newunit=Out)
      write(Out, *) '-z-'
      write(Out,*) Z(1,:)
      write(Out,*) Z(2,:)
      write(Out,*) Z(3,:)
      write(Out,*) Z(4,:)
      write(Out,*) Z(5,:)
   close (Out)

end program ex_7_53


!############################################################################################
!
! Copyright 2019 Bharat Mahajan
!
! Licensed under the Apache License, Version 2.0 (the "License");
! you may not use this file except in compliance with the License.
! You may obtain a copy of the License at
!
!    http://www.apache.org/licenses/LICENSE-2.0
!
! Unless required by applicable law or agreed to in writing, software
! distributed under the License is distributed on an "AS IS" BASIS,
! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
! See the License for the specific language governing permissions and
! limitations under the License.
!
!> \brief       DiffEq module
!! \details     It provides the differential equations and event functions
!!              for the test cases used for FLINT library testing.
!! \author      Bharat Mahajan
!! \date        01/25/2019
!
!############################################################################################

module MyDiffEq

    use FLINT
    use, intrinsic :: IEEE_ARITHMETIC

    implicit none

    ! user diff eq system

    type, extends(DiffEqSys) :: TBSys
        real(WP) :: mu = 0.2_WP
        real(WP) :: GM = 398600.436233_wp
    contains
        procedure :: F => TwoBodyDE
        procedure :: G => SampleEventTB
    end type TBSys

    type, extends(DiffEqSys) :: CR3BPSys
        real(WP) :: mu = 0.012277471_WP
        real(WP) :: GM = 0.0_wp
    contains
        procedure :: F => CR3BPDE
        procedure :: G => SampleEventCR3BP
    end type CR3BPSys

    contains

    function TwoBodyDE(me, X, Y, Params)

        implicit none

        intrinsic :: size
        class(TBSys), intent(in) :: me !< Differential Equation object
        real(WP), intent(in) :: X
        real(WP), intent(in), dimension(:) :: Y
        real(WP), intent(in), dimension(:), optional :: Params

        real(WP), dimension(size(Y)) :: TwoBodyDE
        real(WP) :: MyParams

        if (present(Params)) then
            MyParams = Params(1)
        else
            MyParams = 1.0_WP
        end if

        TwoBodyDE(1:3) = Y(4:6)
        TwoBodyDE(4:6) = -me%GM/(norm2(Y(1:3))**3)*Y(1:3)

        ! add impulse with DV = 1 km/s
        !if(X > 100 .AND. X < 200) TwoBodyDE(4:6) = TwoBodyDE(4:6) + 0.006

        ! add finite maneuver
        !if(X > 50000 .AND. X < 100000) TwoBodyDE(4:6) = TwoBodyDE(4:6) + 0.006/100.0

    end function TwoBodyDE

    function CR3BPDE(me, X, Y, Params)

        implicit none

        intrinsic :: size

        class(CR3BPSys), intent(in) :: me !< Differential Equation object
        real(WP), intent(in) :: X
        real(WP), intent(in), dimension(:) :: Y
        real(WP), intent(in), dimension(:), optional :: Params

        real(WP), dimension(size(Y)) :: CR3BPDE

        real(WP) :: MyParams

        real(WP), dimension(2) :: R1, R2

        if (present(Params)) then
            MyParams = Params(1)
        else
            MyParams = 1.0_WP
        end if

        R1 =  [(Y(1) + me%mu), Y(2)]
        R2 =  [(Y(1) - 1 + me%mu), Y(2)]

        CR3BPDE(1:3) = Y(4:6)
        CR3BPDE(4) = Y(1) + 2.0*Y(5) - (1.0-me%mu)*(Y(1) + me%mu)/norm2(R1)**3 &
                                - me%mu*(Y(1) - 1.0 + me%mu)/norm2(R2)**3

        CR3BPDE(5) = Y(2) - 2.0*Y(4) - (1.0-me%mu)*Y(2)/norm2(R1)**3 &
                                - me%mu*Y(2)/norm2(R2)**3
        CR3BPDE(6) = 0.0

        ! add impulse
        !if(X > 100 .AND. X < 200) TwoBodyDE(4:6) = TwoBodyDE(4:6) + 0.5*TwoBodyDE(4:6)

    end function CR3BPDE

    subroutine SampleEventTB(me, X, Y, EvalEvents, Value, Direction, LocEvent, LocEventAction)

        implicit none
        class(TBSys), intent(in) :: me !< Differential Equation object
        real(WP), intent(in) :: X
        real(WP), dimension(:), intent(inout) :: Y
        integer, dimension(:), intent(in) :: EvalEvents
        real(WP), dimension(:), intent(out) :: Value
        integer, dimension(:), intent(out) :: Direction
        integer, intent(in), optional :: LocEvent
        integer(kind(FLINT_EVENTACTION_CONTINUE)), intent(out), optional :: LocEventAction

        if (EvalEvents(1)==1) Value(1) = norm2(Y(1:3)) - 20000.0

        if (EvalEvents(2)==1) Value(2) = 1 !Y(3)

        Direction = [0,0]

        if (present(LocEvent)) LocEventAction = FLINT_EVENTACTION_CONTINUE

    end subroutine SampleEventTB

    subroutine SampleEventCR3BP(me, X, Y, EvalEvents, Value, Direction, LocEvent, LocEventAction)

        implicit none
        class(CR3BPSys), intent(in) :: me !< Differential Equation object
        real(WP), intent(in) :: X
        real(WP), dimension(:), intent(inout) :: Y
        integer, dimension(:), intent(in) :: EvalEvents
        real(WP), dimension(:), intent(out) :: Value
        integer, dimension(:), intent(out) :: Direction
        integer, intent(in), optional :: LocEvent
        integer(kind(FLINT_EVENTACTION_CONTINUE)), intent(out), optional :: LocEventAction

        ! Event-1: detect a narrow square pulse or a discontinuous
        ! event in both directions.
        ! This will need a small event step size to detect!
        ! We will also mask this event after the first detection to
        ! reduce unnecessary event checking after the first detection.
        if (EvalEvents(1) == 1) then
            if (X > 0.5 .AND. X < 0.5005) then
                Value(1) = 1
            else
                Value(1) = -1
            end if
            Direction(1) = 0
        end if

        ! Event-2: only detect y2-crossings in the region y1>0
        if (EvalEvents(2) == 1) then
            if (Y(1) < 0.0) then
                Value(2) = IEEE_VALUE(1.0,IEEE_QUIET_NAN)
            else
                Value(2) = Y(2)
            end if
            Direction(2) = 1 ! detect in the increasing direction
        end if

        ! Event-3: Detect y2 crossings in region y1<0
        if (EvalEvents(3)==1) then
            if (Y(1) > 0.0) then
                Value(3) = IEEE_VALUE(1.0,IEEE_QUIET_NAN)
            else
                Value(3) = Y(2)
            end if
            Direction(3) = 1 ! detect in the increasing direction
        end if

        ! Set actions for each event if located
        if (present(LocEvent) .AND. present(LocEventAction)) then

            if (LocEvent == 1) then
                LocEventAction = IOR(FLINT_EVENTACTION_CONTINUE, &
                                    FLINT_EVENTACTION_MASK)
            else if (LocEvent == 2) then
                ! Mask the event-2 after first trigger
                LocEventAction = IOR(FLINT_EVENTACTION_CONTINUE, &
                                        FLINT_EVENTACTION_MASK)
            else if (LocEvent == 3) then
                ! Event-3 has been triggered
                ! now change the solution back to the initial condition
                ! and mask this event
                Y = [0.994_WP, 0.0_WP, 0.0_WP, 0.0_WP, -2.00158510637908252240537862224_WP, 0.0_WP]
                LocEventAction = IOR(FLINT_EVENTACTION_CHANGESOLY,&
                                        FLINT_EVENTACTION_MASK)
            end if
        end if

    end subroutine SampleEventCR3BP

    function TBIOM(mu, X)
        real(wp), intent(in) :: mu
        real(wp), dimension(:), intent(in) :: X
        real(wp) :: TBIOM

        ! Keplerian energy
        TBIOM = norm2(X(4:6))**2/2 - mu/norm2(X(1:3))
    end function TBIOM

    function JacobiC(mu, X)
        real(wp), intent(in) :: mu
        real(wp), dimension(:,:), intent(in) :: X
        real(wp), dimension(size(X,2)) :: JacobiC
        real(wp), dimension(size(X,2)) :: Omega
        real(WP), dimension(size(X,2)) :: r1, r2

        r1 = sqrt((X(1,:) + mu)**2 + X(2,:)**2 + X(3,:)**2)
        r2 = sqrt((X(1,:) - 1.0 + mu)**2 + X(2,:)**2+X(3,:)**2)
        Omega = 1.0/2.0*sum(X(1:3,:)**2,1) + (1.0-mu)/r1 + mu/r2
        ! Jacobian's Constant
        JacobiC = sum(X(4:6,:)**2,1)/2 - Omega
    end function JacobiC

end module MyDiffEq


      program ovfl01

      i = 2**30
      j = i - 1
      k = i + j
      l = k + 1
      print *, l

      if(l.ge.0) then
         print *, 'l is positive'
      else
         print *, 'l is strictly negative'
      endif

      end


C$Procedure      PCKE20 ( PCK, evaluate record, type 20 )

      SUBROUTINE PCKE20 ( ET, RECORD, EULANG )

C$ Abstract
C
C     Evaluate a single PCK data record from a segment of type 20
C     (Chebyshev Polynomials, rotation derivative only).
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     PCK
C
C$ Keywords
C
C     ORIENTATION
C     ROTATION
C     TRANSFORMATION
C
C$ Declarations

      DOUBLE PRECISION      ET
      DOUBLE PRECISION      RECORD   ( * )
      DOUBLE PRECISION      EULANG   ( 6 )

C$ Brief_I/O
C
C     Variable  I/O  Description
C     --------  ---  --------------------------------------------------
C     ET         I   Evaluation epoch.
C     RECORD     I   Data record.
C     EULANG     O   Euler angles and their derivatives.
C
C$ Detailed_Input
C
C     ET          is an epoch at which the Euler angles state is to be
C                 computed. The epoch is represented as seconds past
C                 J2000 TDB.
C
C
C     RECORD      is a data record which, when evaluated at epoch ET,
C                 will yield Euler angles and Euler angle rates
C                 representing the orientation and angular velocity,
C                 with respect to its base frame, of the reference
C                 frame associated with the input record.
C
C                 The structure of the record is as follows:
C
C                    +--------------------------------------+
C                    | record size (excluding this element) |
C                    +--------------------------------------+
C                    | Coverage interval midpoint           |
C                    +--------------------------------------+
C                    | Coverage interval radius             |
C                    +--------------------------------------+
C                    | Coeffs for ANGLE_1 rate              |
C                    +--------------------------------------+
C                    | Coeffs for ANGLE_2 rate              |
C                    +--------------------------------------+
C                    | Coeffs for ANGLE_3 rate              |
C                    +--------------------------------------+
C                    | ANGLE_1 at interval midpoint         |
C                    +--------------------------------------+
C                    | ANGLE_2 at interval midpoint         |
C                    +--------------------------------------+
C                    | ANGLE_3 at interval midpoint         |
C                    +--------------------------------------+
C
C                 In the above record
C
C                    - Times are expressed as seconds past J2000 TDB.
C                    - Angular components have units of radians.
C                    - Rate coefficients have units of radians/s.
C
C                 RECORD must be declared by the caller with size large
C                 enough to accommodate the largest record that can be
C                 returned by PCKR20.
C
C
C$ Detailed_Output
C
C     EULANG      is a 6-vector containing Euler angles and their
C                 derivatives at time ET. The angles occupy the first
C                 three elements of EULANG; the rates follow. The order
C                 of the components is
C
C                    ( ANGLE_1, ANGLE_2, ANGLE_3,
C                      rate_1,  rate_2,  rate_3  )
C
C                 The angular units are radians; the rate units are
C                 radians/second.
C
C                 The Euler angles represent the orientation, relative
C                 to its base frame, of the PCK frame associated with
C                 the input record. The angles, which are numbered
C                 according to their ordinal position in the logical
C                 records, define a transformation matrix R as follows:
C
C                    R = [ ANGLE_3 ]  [ ANGLE_2 ]  [ ANGLE_1 ]
C                                   3            1            3
C
C                 Here the notation
C
C                    [ THETA ]
C                             i
C
C                 denotes a reference frame rotation of THETA radians
C                 in the right-hand sense about the ith coordinate
C                 axis. See the Rotation Required Reading for further
C                 discussion of this notation.
C
C                 The matrix R transforms vectors expressed in the base
C                 frame to vectors expressed in the PCK frame associated
C                 with RECORD by left multiplication:
C
C                    V    = R * V
C                     PCK        FRAME
C
C                 In cases where the PCK frame is a body-fixed,
C                 right-handed frame with its +Z axis aligned with a
C                 body's north pole, the orientation angles are related
C                 to right ascension (RA) and declination (DEC) of the
C                 PCK frame's north pole, and prime meridian
C                 orientation (W), by the equations
C
C                    ANGLE_1 = RA   + pi/2 radians
C                    ANGLE_2 = pi/2 - DEC  radians
C                    ANGLE_3 = W           radians
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     1) If the input record contains an invalid coefficient count,
C        the error will be diagnosed by a routine in the call tree of
C        this routine.
C
C     2) If the input record contains invalid domain transformation
C        parameters, the error will be diagnosed by a routine in the
C        call tree of this routine.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     The exact format and structure of type 20 (Chebyshev polynomials,
C     position only) segments are described in the PCK Required Reading
C     file.
C
C     A type 20 segment contains three sets of Chebyshev coefficients,
C     one set each for the derivatives with respect to time of the
C     Euler angles phi, delta and psi. PCKE20 calls the routine SPKE20
C     for each set to evaluate the polynomial and its first derivative.
C
C$ Examples
C
C     The PCKEnn routines are almost always used in conjunction with
C     the corresponding PCKRnn routines, which read the records from
C     binary PCK files.
C
C     The data returned by the PCKRnn routine are in their rawest form,
C     taken directly from the segment.  As such, they will be
C     meaningless to a user unless he/she understands the structure of
C     the data type completely. Given that understanding, however, the
C     PCKRnn routines might be used to examine raw segment data before
C     evaluating it with the PCKEnn routines.
C
C
C     Here we load a binary PCK files and use PCKE20 to get the
C     Euler angles.
C
C  C
C  C     Load binary PCK file.
C  C
C        CALL PCKLOF ('example.pck', HANDLE)
C
C  C
C  C     Get a segment applicable to a specified body and epoch.
C  C
C        CALL PCKSFS ( BODY, ET, HANDLE, DESCR, IDENT, FOUND )
C
C        IF ( FOUND ) THEN
C  C
C  C        Look at parts of the descriptor.
C  C
C           CALL DAFUS ( DESCR, ND, NI, DCD, ICD )
C           TYPE   = ICD( NT )
C           REF    = ICD( NR )
C
C           IF ( TYPE .EQ. 20 ) THEN
C  C
C  C           Read in Chebyshev coefficients from segment.
C  C
C              CALL PCKR20 ( HANDLE, DESCR, ET, RECORD )
C  C
C  C           Call evaluation routine to get Euler angles
C  C           phi, delta, w.
C  C
C              CALL PCKE20 ( ET, RECORD, EULANG )
C
C
C     The Euler angles and their derivatives are returned
C     in EULANG.
C
C$ Restrictions
C
C     None.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     N.J. Bachman (JPL)
C     K.S. Zukor   (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.0.0, 17-JAN-2014 (NJB) (KSZ)
C
C-&

C$ Index_Entries
C
C     evaluate pck_type_20 record
C
C-&

C
C     SPICELIB functions
C
      DOUBLE PRECISION      TWOPI
      LOGICAL               RETURN

C
C     Standard SPICE error handling.
C
      IF ( RETURN () ) THEN
         RETURN
      END IF

      CALL CHKIN ( 'PCKE20' )

C
C     Call evaluation routine to get Euler angles
C     phi, delta, w.
C
      CALL SPKE20 ( ET, RECORD, EULANG )

C
C     Map the third angle into the range (-2pi, 2pi).
C
      EULANG(3) = MOD ( EULANG(3), TWOPI() )

      CALL CHKOUT ( 'PCKE20' )
      RETURN
      END


      function area(r,z,ix)
c     implicit double precision (a-h,o-z)                                    dp
      dimension r(*),z(*),ix(*),xdr(4),xdz(4)
      do 10 i=1,4
      xdr(i)=r(ix(i))
   10 xdz(i)=z(ix(i))
      zd42=xdz(4)-xdz(2)
      ac1=xdr(2)*(xdz(3)-xdz(4))+xdr(3)*zd42+xdr(4)*(xdz(2)-xdz(3))
      ac2=xdr(2)*(xdz(4)-xdz(1))+xdr(4)*(xdz(1)-xdz(2))-xdr(1)*zd42
      area=ac1+ac2
      return
      end


      subroutine clawpatch_time_sync_setup(mx,my,mbc,dx,dy,
     &                                     area,edgelengths,
     &                                     area0,area1,area2,area3,
     &                                     el0, el1, el2, el3,
     &                                     manifold)

      implicit none

      integer mx,my,mbc
      integer manifold
      double precision dx,dy

      double precision area0(my), area1(my), area2(mx), area3(mx)
      double precision el0(my), el1(my), el2(mx), el3(mx)

      integer i,j
      double precision dxdy

      include "metric_terms.i"

      if (manifold .eq. 1) then
         do j = 1,my
            area0(j) = area(1,j)
            area1(j) = area(mx,j)
            el0(j) = edgelengths(1,j,1)
            el1(j) = edgelengths(mx+1,j,1)
         enddo

         do i = 1,mx
            area2(i) = area(i,1)
            area3(i) = area(i,my)
            el2(i) = edgelengths(i,1,2)
            el3(i) = edgelengths(i,my+1,2)
         enddo
      else
         dxdy = dx*dy
         do j = 1,my
            area0(j) = dxdy
            area1(j) = dxdy
            el0(j) = dy
            el1(j) = dy
         enddo
         do i = 1,mx
            area2(i) = dxdy
            area3(i) = dxdy
            el2(i) = dx
            el3(i) = dx
         enddo
      endif

      end