c ======================================================================
c User Subroutine UEL for linear elastic material
c All rights of reproduction or distribution in any form are reserved.
c By Irfan Habeeb CN (PhD, Technion - IIT)
c ======================================================================
      subroutine uel(rhs,amatrx,svars,energy,ndofel,nrhs,nsvars,
     1 props,nprops,coords,mcrd,nnode,u,du,v,a,jtype,time,dtime,
     2 kstep,kinc,jelem,params,ndload,jdltyp,adlmag,predef,
     3 npredf,lflags,mlvarx,ddlmag,mdload,pnewdt,jprops,njprop,period)

      include 'aba_param.inc'

! ******************** state variables in the code *********************
! svars(1) = exx ( at the instant )
! svars(2) = eyy
! svars(3) = ezz (= 0)
! svars(4) = exy
! svars(5) = sxx
! svars(6) = syy
! svars(7) = szz (= 0)
! svars(8) = sxy
! **********************************************************************
      parameter(ngauss=1, nelem=185, nsdv=8)

      dimension rhs(mlvarx,*),amatrx(ndofel,ndofel),
     1 svars(nsvars),energy(8),props(*),coords(mcrd,nnode),
     2 u(ndofel),du(mlvarx,*),v(ndofel),a(ndofel),time(2),
     3 params(3),jdltyp(mdload,*),adlmag(mdload,*),
     4 ddlmag(mdload,*),predef(2,npredf,nnode),lflags(*),jprops(*)

       real*8 aintw(3),xii(2,3),xi(2),dNdxi(3,2),dxdxi(2,2),dxidx(2,2),
     * dNdx(3,2),B(3,6),BT(6,3),eps(3),stn(4),stress(3),C(3,3),
     * ddsdde(4,4),DB(3,6),sig2(3),sdv(nsvars), shape_f(3),str(3),
     * dstran(4),B_phase(2,3),sig(4)
       real*8 E,nu,we,deter

       real*8 ceps(3),auxm3(3,3),B_B(3,3),aux(6),auxm2(6,3),stiff2(3,6),
     * antn(3,3),F1(3,3),F2(3),F3(3),F4(3), dv(6), dT,
     * epsceps,phase,aka,alc,gc,phase0,epsi,d_dot, lamda, mu
       integer I, J, K, k1, k2, k3

      common/custom/uvars(nelem, 24, ngauss)

      E = props(1)
      nu = props(2)
      lamda = E*nu/((1.d0 + nu)*(1.d0 - 2.d0*nu))
      mu = E/(2.d0*(1.d0 + nu))

      do k1 = 1, ndofel
        do k2 = 1, nrhs
          rhs(k1, k2) = 0.d0
        end do
        do k2 = 1, ndofel
          amatrx(k2, k1) = 0.d0
        end do
      end do

      do k1 = 1, 3
        aintw(k1) = 0.5d0
        shape_f(k1) = 0.d0
      end do

      do k1 = 1, 2
        do k2 = 1, 3
          xii(k1, k2) = 1.d0/3.d0
        end do
      end do

      xi(1) = xii(1, 1)
      xi(2) = xii(2, 1)

      dNdxi = 0.d0
      dNdxi(1, 1) = 1.0
      dNdxi(2, 2) = 1.0
      dNdxi(3, 1) = -1.0
      dNdxi(3, 2) = -1.0

      do k1 = 1, 2
        do k2 = 1, 2
          dxdxi(k1, k2) = 0.d0
          do k3 = 1, nnode
            dxdxi(k1, k2) = dxdxi(k1, k2) + coords(k1,k3)*dNdxi(k3, k2)
          end do
        end do
      end do

      deter = 0.d0
      deter = dxdxi(1,1)*dxdxi(2,2) - dxdxi(1,2)*dxdxi(2,1)
      if (deter .lt. 0.d0) then
        print*, 'Negative Jacobian', deter
        call xit
      end if

      dxidx(1, 1) = dxdxi(2, 2)/deter
      dxidx(2, 2) = dxdxi(1, 1)/deter
      dxidx(1, 2) = -dxdxi(1, 2)/deter
      dxidx(2, 1) = -dxdxi(2, 1)/deter

      do k1 = 1, nnode
        do k2 = 1, 2
          dNdx(k1, k2) = 0.d0
          do k3 = 1, 2
            dNdx(k1, k2) = dNdx(k1, k2) + dNdxi(k1, k3)*dxidx(k3, k2)
          end do
        end do
      end do

      iy = 0
      do k1 = 1, nnode
        ix = iy + 1
        iy = ix + 1
        B(1, ix) = dNdx(k1, 1)
        B(1, iy) = 0.d0
        B(2, ix) = 0.d0
        B(2, iy) = dNdx(k1, 2)
        B(3, ix) = dNdx(k1, 2)
        B(3, iy) = dNdx(k1, 1)
      end do

      do k1 = 1, 3
        do k2 = 1, 6
          BT(k2, k1) = B(k1, k2)
        end do
      end do

      eps = 0.d0
      do k1 = 1, 3
        do k2 = 1, 6
          eps(k1) = eps(k1) + B(k1, k2) * DU(k2, 1)
        end do
      end do

      sdv = 0.d0
      do k1 = 1, nsdv
        sdv(k1) = svars(k1)
      end do

      C = 0.d0
      C(1, 1) = lamda + 2.d0*mu
      C(1, 2) = lamda
      C(2, 1) = C(1, 2)
      C(2, 2) = C(1, 1)
      C(3, 3) = mu

      stress = 0.d0
      do k1 = 1, 3
        do k2 = 1, 3
          stress(k2) = stress(k2) + C(k2, k1)*eps(k1)
        end do
      end do

      sig(1) = stress(1)
      sig(2) = stress(2)
      sig(3) = 0.d0
      sig(4) = stress(3)

      stn(1) = eps(1)
      stn(2) = eps(2)
      stn(3) = 0.d0
      stn(4) = eps(3)

      DB = 0.d0
      do k1 = 1, 3
        do k2 = 1, 6
          do k3 = 1, 3
            DB(k1, k2) = DB(k1, k2) + C(k1, k3)*B(k3, k2)
          end do
        end do
      end do

      we = 0.d0
      we = aintw(1) * dabs(deter)

      do k1 = 1, 6
        do k2 = 1, 3
          rhs(k1, 1) = rhs(k1, 1) - we*BT(k1, k2)*stress(k2)
        end do
      end do

      do k1 = 1, 6
        do k2 = 1, 6
          do k3 = 1, 3
            amatrx(k1, k2) = amatrx(k1, k2) + we*BT(k1, k3)*DB(k3, k2)
          end do
        end do
      end do

      sdv(1:4) = stn(1:4)             ! strain
      sdv(5:8) = sig(1:4)             ! stress
      svars(1:nsdv) = sdv(1:nsdv)
      uvars(jelem, 1:nsdv, 1) = sdv(1:nsdv)

      return
      end

************************************************************************
      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)

      parameter (ngauss = 1, nelem=185, nsdv=8)
      real*8 E, nu, lamda, mu
      common/custom/uvars(nelem, 24, ngauss)

      E = props(1)
      nu = props(2)
      lamda = E*nu/((1.d0 + nu)*(1.d0 - 2.d0*nu))
      mu = E/(2.d0*(1.d0 + nu))

      do k1 = 1, 2
        do k2 = 1, 2
          ddsdde(k2, k1) = lamda
        end do
        ddsdde(k1, k1) = lamda + 2.d0*mu
      end do
      ddsdde(3,3) = mu

      do k1 = 1, ntens
        do k2 = 1, ntens
          stress(k2) = stress(k2) + ddsdde(k2, k1)*dstran(k1)
        end do
      end do

      kelem = noel - nelem
      do k1 = 1, nsdv
        statev(k1) = uvars(kelem, k1, npt)
      end do

      return
      end


!==============================================================================!
  subroutine Source_F22_K_Eps_Zeta_F(grid)
!------------------------------------------------------------------------------!
!   Calculate source terms in eliptic relaxation  equation                     !
!   for vi2 and imposing  boundary condition for f22                           !
!------------------------------------------------------------------------------!
!---------------------------------[Modules]------------------------------------!
  use Const_Mod
  use Flow_Mod
  use Rans_Mod
  use Grid_Mod
  use Control_Mod
!------------------------------------------------------------------------------!
  implicit none
!--------------------------------[Arguments]-----------------------------------!
  type(Grid_Type) :: grid
!----------------------------------[Locals]------------------------------------!
  integer :: s, c, c1, c2
  real    :: sor_11, f22hg
  real    :: a0
!==============================================================================!
!                                                                              !
!  The form of source terms are :                                              !
!                                                                              !
!      int( f22hg*dV ),                                                        !
!  where f22hg - f22hg homogenious is placed in a source coefficients b(c)     !
!                                                                              !
!      f22hg = (1.0 - Cv_1)*(vi2(c)/kin(c) - 2.0/3.0)/t_scale(c)     &         !
!              + 2.0*Cv2*p_kin(c)/(3.0*kin(c))                                 !
!                                                                              !
!    int( f22*dV ); this term is placed in a diagonal of coefficient matrix    !
!                                                                              !
!                                                                              !
!  Dimensions of certain variables                                             !
!                                                                              !
!     t_scale        [s]                                                       !
!     kin            [m^2/s^2]                                                 !
!     eps            [m^3/s^2]                                                 !
!     vi2            [m^2/s^2]                                                 !
!     f22            [-]                                                       !
!     l_scale        [m]                                                       !
!------------------------------------------------------------------------------!

  call Time_And_Length_Scale(grid)

 ! Source term f22hg
 do c = 1, grid % n_cells
   f22hg = (1.0 - c_f1 - 0.65 * p_kin(c)/density  &
         / (eps  % n(c) + TINY))                  &
         * (zeta % n(c) - TWO_THIRDS)             &
         / (t_scale(c) + TINY)                    &
         + 0.0085 * (p_kin(c)/density) / (kin % n(c) + TINY)
   b(c) = b(c) + f22hg * grid % vol(c) / (l_scale(c)**2 + TINY)
 end do

 ! Source term f22hg
 do c = 1, grid % n_cells
   sor_11 = grid % vol(c)/(l_scale(c)**2 + TINY)
   a % val(a % dia(c)) = a % val(a % dia(c)) + sor_11
 end do

 ! Imposing boundary condition for f22 on the wall
 do s = 1, grid % n_faces
   c1 = grid % faces_c(1,s)
   c2 = grid % faces_c(2,s)
   if(c2 < 0) then
     if(Grid_Mod_Bnd_Cond_Type(grid,c2) .eq. WALL .or.  &
        Grid_Mod_Bnd_Cond_Type(grid,c2) .eq. WALLFL) then

       f22 % n(c2) = -2.0 * viscosity/density * zeta % n(c1) &
                   / grid % wall_dist(c1)**2

      ! Fill in a source coefficients

      ! Linearization of the near wall terms helps to get more
       ! stable solution, especially for small wall distance.
       a0 = f_coef(s)
       b(c1) = b(c1) + a0 * f22 % n(c2)
     end if   ! end if of BC=wall
   end if    ! end if of c2<0
 end do

 end subroutine


      MODULE m_vacuz
      CONTAINS
      SUBROUTINE vacuz(
     >     e,vz,vz0,nmz,dz,
     <     uz,duz,u)
      use m_juDFT
c*********************************************************************
c     integrates the vacuum wavefunction fo energy e<0 inward from the
c     last mesh point using the schrodinger equation and assuming that
c     this point is past the classical turning point.
!     (vz(i),i = 1,nmz) contains the potential on a linear mesh.
c     vz0 is the vacuum zero.
c     dz  is the spacing of the mesh points.
c     uz,duz are the value and outward normal derivative (i.e. into
c     the bulk) evaluated at the first mesh point.
c     (u(i),i=1,nmz) contains the normalized wavefunction
c     based on code by m. weinert
c*********************************************************************

      USE m_constants
      USE m_intgr, ONLY : intgz0
      IMPLICIT NONE

C     .. Scalar Arguments ..
      INTEGER, INTENT (IN) :: nmz
      REAL,    INTENT (IN) :: dz,e,vz0
      REAL,    INTENT (OUT):: duz,uz

C     .. Array Arguments ..
      REAL, INTENT (IN) :: vz(nmz)
      REAL, INTENT (OUT)::  u(nmz)

C     .. Local Scalars ..
      REAL a,eps,eru,erw,h,sk1,sk2,sk3,sk4,sl1,sl2,sl3,sl4,tnorm,u1,u10,
     +     u1p,vme,w1,w10,w1p,yn,zn,znm
      INTEGER i,it,n,n1
      LOGICAL tail

C     .. Local Arrays ..
      REAL w(nmz),wp(nmz)

C     .. Data statements ..
      DATA eps/1.e-06/
C     ..
      IF (e.GE.vz0) THEN
         WRITE (oUnit,*) 'e>vz0; e=',e,'vz0=',vz0
         CALL juDFT_error("e>vz0",calledby ="vacuz",hint
     +        ="Vacuum energy parameter too high")
      ENDIF
c---  >    set up initial conditions
      znm = (nmz-1)*dz
      a = sqrt(2.* (vz0-e))
      u(nmz) = exp(-a*znm)
      w(nmz) = a*u(nmz)
      wp(nmz) = a*a*u(nmz)
c---  >    use 4nd order runge-kutta to first few mesh points
      h = dz
      DO i = 1,4
         n = nmz + 1 - i
         yn = u(n)
         zn = w(n)
         sk1 = h*zn
         sl1 = h*wp(n)
         sk2 = h* (zn+0.5*sl1)
         sl2 = h* ((vz(n)+vz(n-1)-e)* (yn+0.5*sk1))
         sk3 = h* (zn+0.5*sl2)
         sl3 = h* ((vz(n)+vz(n-1)-e)* (yn+0.5*sk2))
         sk4 = h* (zn+sl3)
         sl4 = h* (2.* (vz(n-1)-e)* (yn+sk3))
         u(n-1) = yn + (sk1+2.*sk2+2.*sk3+sk4)/6.
         w(n-1) = zn + (sl1+2.*sl2+2.*sl3+sl4)/6.
         wp(n-1) = 2.* (vz(n-1)-e)*u(n-1)
      ENDDO
c---  >    use adams-bashforth-moulton predictor-corrector for rest
      DO  i = 5,nmz - 1
c---  >    adams-bashforth predictor (order h**5)
         n = nmz + 1 - i
         n1 = n - 1
         u10 = u(n) + h* (55.*w(n)-59.*w(n+1)+37.*w(n+2)-9.*w(n+3))/24.
         w10 = w(n) + h* (55.*wp(n)-59.*wp(n+1)+37.*wp(n+2)-9.*wp(n+3))/
     +        24.
c---  >    evaluate derivative at next point( n-1 corresponds to m+1)
         vme = 2.* (vz(n-1)-e)
         u1p = w10
         w1p = vme*u10
c---  >    adams-moulton correctors (order h**6)
         DO it = 1,10
            u1 = u(n) + h* (251.*u1p+646.*w(n)-264.*w(n+1)+106.*w(n+2)-
     +           19.*w(n+3))/720.
            w1 = w(n) + h* (251.*w1p+646.*wp(n)-264.*wp(n+1)+
     +           106.*wp(n+2)-19.*wp(n+3))/720.
c---  >    final evaluation
            u1p = w1
            w1p = vme*u1
c---  >    test quality of corrector and iterate if necessary
            eru = abs(u1-u10)/ (abs(u1)+abs(h*u1p))
            erw = abs(w1-w10)/ (abs(w1)+abs(h*w1p))
            IF (eru.LT.eps .AND. erw.LT.eps) EXIT
            u10 = u1
            w10 = w1
         ENDDO
         IF (it>10) THEN
            WRITE (oUnit,FMT=8000) n1,eru,erw
 8000       FORMAT (' ***vacuz - step may be too big - mesh point',i5,
     +           ', eru,erw=',1p,2e16.7)
         ENDIF
c---  >    store values
         u(n1) = u1
         w(n1) = w1
         wp(n1) = w1p
      ENDDO
c---  >    normalize function
      tail = .true.
      DO i = 1,nmz
         wp(i) = u(nmz+1-i)*u(nmz+1-i)
      ENDDO
      CALL intgz0(wp,dz,nmz,tnorm,tail)
      tnorm = 1./sqrt(tnorm)
      DO  i = 1,nmz
         u(i) = tnorm*u(i)
      ENDDO
      uz = u(1)
      duz = tnorm*w(1)
      RETURN
      END SUBROUTINE
      END


      SUBROUTINE DFLUX(FLUX,SOL,JSTEP,JINC,TIME,NOEL,NPT,COORDS,JLTYP,
     1                 TEMP,PRESS,SNAME)
C
      INCLUDE 'ABA_PARAM.INC'

      DIMENSION COORDS(3),FLUX(2),TIME(2)
      CHARACTER*80 SNAME

	  x=COORDS(1)
      y=COORDS(2)
      z=COORDS(3)
	  PI=3.1415926

      !焊接工艺参数，使用同一热源
      wu=110.0
      wi=10.0
      effi=0.8
      v=0.010    !圆周方向速度
	  v1=0.005   !纵向方向速度
      q=wu*wi*effi

      !焊接热源形状参数(球热源)
      a=0.003
	  b=0.003
	  c=0.003

      !起点坐标
      x1=0
      y1=-0.015
      z1=0.06

      !焊缝几何形状参数
      r=0.015

      !热源分布
	  heat=6.0*sqrt(3.0)*q/(a*b*c*PI*sqrt(PI))

          d=v*TIME(2)   !圆弧扫过的圆心角
		  d1=v1*TIME(2)      !纵向方向位移
          !焊缝圆弧扫过的圆心角
          theta=d/r
          !热源中心在总体坐标系中的坐标
          xd=x1+r*sin(theta)
		  yd=y1+r*(1-cos(theta))
          zd=z1-d1

          xx=x-xd
          yy=y-yd
          zz=z-zd

          shape=exp(-3.0*xx**2/a**2-3.0*yy**2/b**2-3.0*zz**2/c**2)

C     JLTYP＝1，表示为体热源
      JLTYP=1
      FLUX(1)=heat*shape
      RETURN
      END


	SUBROUTINE AF_SLON  ( clon, clond, iret )
C************************************************************************
C* AF_SLON								*
C*									*
C* This subroutine decodes and stores the longitude from AMDAR, AIREP,	*
C* and PIREP reports.							*
C*									*
C* AF_SLON  ( CLON, CLOND, IRET )					*
C*									*
C* Input parameters:							*
C*	CLON		CHAR*		Encoded	longitude 		*
C*	CLOND		CHAR		Direction of longitude 	 	*
C*					  "W" = west, "E" = east	*
C*									*
C* Output parameters:							*
C*	RIVALS (IRSLON)	REAL		Longitude in degrees		*
C*	IRET		INTEGER		Return code 			*
C*					  0 = normal return 		*
C*					 -1 = error during decoding	*
C*									*
C**									*
C* Log:									*
C* J. Ator/NP12		09/96						*
C* J. Ator/NP12		10/96	Allow AIREP lat/long combination 	*
C* J. Ator/NP12		08/97	New interface format, style changes	*
C* A. Hardy/GSC         03/98   Changed longitude lengths               *
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
	INCLUDE		'afcmn.cmn'
C*
	CHARACTER*(*)	clon
	CHARACTER	clond
C-----------------------------------------------------------------------
	iret = -1
C
	lclon = LEN ( clon )
	IF ( ( lclon .eq. 4 ) .or. ( lclon .eq. 5 ) ) THEN
C
C*	    The longitude was reported in degrees and minutes.
C*	    Decode the minutes.
C
	    CALL ST_INTG  ( clon ( lclon-1:lclon ), ilnmin, ier )
	    ldglon = lclon - 2
	    IF  (  ( ier .ne. 0 )  .or.
     +		 ( ( ilnmin .lt. 0 ) .or. ( ilnmin .gt. 59 ) )  )  THEN
		logmsg = 'longitude minutes '  //  clon ( lclon-1:lclon )
		CALL DC_WLOG  ( 2, 'AF', 2, logmsg, ierwlg )
		RETURN
	    END IF
	ELSE IF  ( ( lclon .le. 3 ) .and.
     +		     ( bultyp .ne. AMDAR ) )  THEN
C
C*	    The longitude was reported in degrees.
C
	    ilnmin = 0
	    ldglon = lclon
	ELSE
	    logmsg = 'longitude '  //  clon (1:lclon)
	    CALL DC_WLOG  ( 2, 'AF', 2, logmsg, ierwlg )
	    RETURN
	END IF
C
C*	Decode the degrees.
C
        CALL ST_INTG  ( clon ( 1:ldglon ), ilndeg, ier )
	IF  (  ( ier .ne. 0 )  .or.
     +	    ( ( ilndeg .lt. 0 ) .or. ( ilndeg .gt. 180 ) )  )  THEN
	    logmsg = 'longitude degrees '  //  clon (1:ldglon)
	    CALL DC_WLOG  ( 2, 'AF', 2, logmsg, ierwlg )
	    RETURN
	END IF
C
C*	Compute the longitude.
C
	slon = FLOAT ( ilndeg ) + ( FLOAT ( ilnmin ) / 60.0 )
	IF  ( clond .eq. 'W' )  THEN
	    slon = slon * (-1)
	ELSE IF  ( clond .ne. 'E' )  THEN
	    logmsg = 'longitude direction '  //  clond
	    CALL DC_WLOG  ( 2, 'AF', 2, logmsg, ierwlg )
	    RETURN
	END IF
C
C*	Store the longitude.
C
	rivals ( irslon ) = slon
C
	iret = 0
C*
	RETURN
	END


*> \brief \b CSYT03
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*       SUBROUTINE CSYT03( UPLO, N, A, LDA, AINV, LDAINV, WORK, LDWORK,
*                          RWORK, RCOND, RESID )
*
*       .. Scalar Arguments ..
*       CHARACTER          UPLO
*       INTEGER            LDA, LDAINV, LDWORK, N
*       REAL               RCOND, RESID
*       ..
*       .. Array Arguments ..
*       REAL               RWORK( * )
*       COMPLEX            A( LDA, * ), AINV( LDAINV, * ),
*      $                   WORK( LDWORK, * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> CSYT03 computes the residual for a complex symmetric matrix times
*> its inverse:
*>    norm( I - A*AINV ) / ( N * norm(A) * norm(AINV) * EPS )
*> where EPS is the machine epsilon.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] UPLO
*> \verbatim
*>          UPLO is CHARACTER*1
*>          Specifies whether the upper or lower triangular part of the
*>          complex symmetric matrix A is stored:
*>          = 'U':  Upper triangular
*>          = 'L':  Lower triangular
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The number of rows and columns of the matrix A.  N >= 0.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*>          A is COMPLEX array, dimension (LDA,N)
*>          The original complex symmetric matrix A.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*>          LDA is INTEGER
*>          The leading dimension of the array A.  LDA >= max(1,N)
*> \endverbatim
*>
*> \param[in,out] AINV
*> \verbatim
*>          AINV is COMPLEX array, dimension (LDAINV,N)
*>          On entry, the inverse of the matrix A, stored as a symmetric
*>          matrix in the same format as A.
*>          In this version, AINV is expanded into a full matrix and
*>          multiplied by A, so the opposing triangle of AINV will be
*>          changed; i.e., if the upper triangular part of AINV is
*>          stored, the lower triangular part will be used as work space.
*> \endverbatim
*>
*> \param[in] LDAINV
*> \verbatim
*>          LDAINV is INTEGER
*>          The leading dimension of the array AINV.  LDAINV >= max(1,N).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*>          WORK is COMPLEX array, dimension (LDWORK,N)
*> \endverbatim
*>
*> \param[in] LDWORK
*> \verbatim
*>          LDWORK is INTEGER
*>          The leading dimension of the array WORK.  LDWORK >= max(1,N).
*> \endverbatim
*>
*> \param[out] RWORK
*> \verbatim
*>          RWORK is REAL array, dimension (N)
*> \endverbatim
*>
*> \param[out] RCOND
*> \verbatim
*>          RCOND is REAL
*>          The reciprocal of the condition number of A, computed as
*>          RCOND = 1/ (norm(A) * norm(AINV)).
*> \endverbatim
*>
*> \param[out] RESID
*> \verbatim
*>          RESID is REAL
*>          norm(I - A*AINV) / ( N * norm(A) * norm(AINV) * EPS )
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup complex_lin
*
*  =====================================================================
      SUBROUTINE CSYT03( UPLO, N, A, LDA, AINV, LDAINV, WORK, LDWORK,
     $                   RWORK, RCOND, RESID )
*
*  -- LAPACK test routine (version 3.4.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2011
*
*     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            LDA, LDAINV, LDWORK, N
      REAL               RCOND, RESID
*     ..
*     .. Array Arguments ..
      REAL               RWORK( * )
      COMPLEX            A( LDA, * ), AINV( LDAINV, * ),
     $                   WORK( LDWORK, * )
*     ..
*
*  =====================================================================
*
*
*     .. Parameters ..
      REAL               ZERO, ONE
      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
      COMPLEX            CZERO, CONE
      PARAMETER          ( CZERO = ( 0.0E+0, 0.0E+0 ),
     $                   CONE = ( 1.0E+0, 0.0E+0 ) )
*     ..
*     .. Local Scalars ..
      INTEGER            I, J
      REAL               AINVNM, ANORM, EPS
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      REAL               CLANGE, CLANSY, SLAMCH
      EXTERNAL           LSAME, CLANGE, CLANSY, SLAMCH
*     ..
*     .. External Subroutines ..
      EXTERNAL           CSYMM
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          REAL
*     ..
*     .. Executable Statements ..
*
*     Quick exit if N = 0
*
      IF( N.LE.0 ) THEN
         RCOND = ONE
         RESID = ZERO
         RETURN
      END IF
*
*     Exit with RESID = 1/EPS if ANORM = 0 or AINVNM = 0.
*
      EPS = SLAMCH( 'Epsilon' )
      ANORM = CLANSY( '1', UPLO, N, A, LDA, RWORK )
      AINVNM = CLANSY( '1', UPLO, N, AINV, LDAINV, RWORK )
      IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN
         RCOND = ZERO
         RESID = ONE / EPS
         RETURN
      END IF
      RCOND = ( ONE/ANORM ) / AINVNM
*
*     Expand AINV into a full matrix and call CSYMM to multiply
*     AINV on the left by A (store the result in WORK).
*
      IF( LSAME( UPLO, 'U' ) ) THEN
         DO 20 J = 1, N
            DO 10 I = 1, J - 1
               AINV( J, I ) = AINV( I, J )
   10       CONTINUE
   20    CONTINUE
      ELSE
         DO 40 J = 1, N
            DO 30 I = J + 1, N
               AINV( J, I ) = AINV( I, J )
   30       CONTINUE
   40    CONTINUE
      END IF
      CALL CSYMM( 'Left', UPLO, N, N, -CONE, A, LDA, AINV, LDAINV,
     $            CZERO, WORK, LDWORK )
*
*     Add the identity matrix to WORK .
*
      DO 50 I = 1, N
         WORK( I, I ) = WORK( I, I ) + CONE
   50 CONTINUE
*
*     Compute norm(I - A*AINV) / (N * norm(A) * norm(AINV) * EPS)
*
      RESID = CLANGE( '1', N, N, WORK, LDWORK, RWORK )
*
      RESID = ( ( RESID*RCOND )/EPS ) / REAL( N )
*
      RETURN
*
*     End of CSYT03
*
      END


! MIT License
!
! Copyright (c) 2020 SHEMAT-Suite
!
! Permission is hereby granted, free of charge, to any person obtaining a copy
! of this software and associated documentation files (the "Software"), to deal
! in the Software without restriction, including without limitation the rights
! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is
! furnished to do so, subject to the following conditions:
!
! The above copyright notice and this permission notice shall be included in all
! copies or substantial portions of the Software.
!
! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
! SOFTWARE.

!>    @brief calculate one bayes step from p_k to p_k+1
!>    @param[in] p_k parameter (iteration k)
!>    @param[in] p_apr apriori parameter value
!>    @param[out] p_delta delta to the estimated parameters
!>    @param[in,out] tmp temporary vectors (unspecified values)
!>    @param[in,out] tmpM temporary martix (unspecified values)
!>    @param[in] ismpl local sample index
!>    @details
!>calculate one bayes step from p_k to p_k+1, \n
!>given jacobian and parameter set p_k. \n
!>corresponding to the definition of Tarantola (2004) p.79\n
!> -   p: parameter array\n
!> -   c: common block array\n
!> -   f: external function\n
!> -   i: compute inside this function (temporary variable)\n
!> -   p_k+1 = p_k +(S^T *C_dd^-1 *S + reg_func() *C_pp^-1)^-1 \n
!>      *(S^T *C_dd^-1 *(d -g(p_k)) - reg_func() *C_pp^-1 *(p_k -p_apr))\n
!> -   p_k+1 = p_k +\n
!>        (S^T *C_dd^-1 *S + reg_func() *C_pp^-1)^-1 *\n
!>        (S^T *C_dd^-1 *(d -g(p_k)) -\n
!>        reg_func() *C_pp^-1 *(p_k -p_apr))\n
!> -   [mpara] = [mpara] +\n
!>         ([mpara x ndata] *[ndata^2] *[ndata x mpara] +[1]*[mpara^2]) *\n
!>         ([mpara x ndata] *[ndata^2] *([ndata] -[ndata]) -\n
!>         [1]*[mpara^2] *([mpara] -[mpara]))\n
!>
!>
      SUBROUTINE step_bayes_mf(p_k,p_apr,tmp,p_delta,ismpl)
        use arrays
        use mod_genrl
        use mod_inverse
        use mod_data
        use mod_flow
        use mod_temp
        use mod_conc
        use mod_OMP_TOOLS
        use mod_linfos
        IMPLICIT NONE
        integer :: ismpl
        integer :: i, k
        INTRINSIC max, min, dabs, dsqrt
        DOUBLE PRECISION p_k(mpara), p_apr(mpara), p_delta(mpara)
        DOUBLE PRECISION tmp(max(mpara,ndata),4)
        DOUBLE PRECISION wp2_ps, ddot, reg_func
        DOUBLE PRECISION depsilon, dmaxval
        EXTERNAL wp2_ps, ddot, reg_func

!
        IF (linfos(2)>=1) WRITE(*,*) ' ... calculate (matrix free) bayes step'
!
!$OMP parallel shared(ismpl) num_threads(Tlevel_0)
!         sample init, each sample only one times
          CALL single_init(ismpl)
!$OMP end parallel

!      (S^T *C_dd^-1 *(d -g(p_k)) - reg_func() *C_pp^-1 *(p_k -p_apr))

! i:  tmp3 = d -forw
!        [ndata]
        CALL dcopy(ndata,ddata(1,cdd_pv),1,tmp(1,3),1)
        CALL daxpy(ndata,-1.0d0,sdata(1,ismpl),1,tmp(1,3),1)
!
! i:  tmp4 = StWd2 = jacobi^T *Wd2 *tmp3
!        [mpara x ndata]
        CALL step_bayes_tmp1(tmp(1,3),tmp(1,1),tmp(1,4),ismpl)
!
! i:  tmp2 = p_k -p_apr
!        [mpara]
        CALL dcopy(mpara,p_k,1,tmp(1,2),1)
        CALL daxpy(mpara,-1.0d0,p_apr,1,tmp(1,2),1)
!
! i:  tmp4 = tmp4 -reg_func() *wp2 *tmp2
!        [mpara]
        DO i = 1, mpara
          DO k = 1, mpara
            tmp(i,4) = tmp(i,4) - reg_func()*wp2_ps(i,k,ismpl)*tmp(k,2)
          END DO
        END DO

! i:  p_delta = tmpM^-1 *tmp4
!        [mpara]
        CALL set_dval(mpara,0.D0,p_delta)
!       --
!       use exstimated relative precision and computes an absolute estimation
!         best precision of all physical values / state variables
          depsilon = 1.0d-16
          IF (head_active) THEN
            CALL s_damax(I0*J0*K0,head,dmaxval)
            depsilon = max(depsilon,nltolf/min(1.0d99,dmaxval))
          ENDIF
          IF (pres_active) THEN
            CALL s_damax(I0*J0*K0,pres,dmaxval)
            depsilon = max(depsilon,nltolf/min(1.0d99,dmaxval))
          ENDIF
          IF (temp_active) THEN
            CALL s_damax(I0*J0*K0,temp,dmaxval)
            depsilon = max(depsilon,nltolt/min(1.0d99,dmaxval))
          ENDIF
          IF (trans_active) THEN
            CALL s_damax(I0*J0*K0,conc,dmaxval)
            depsilon = max(depsilon,nltolc/min(1.0d99,dmaxval))
          ENDIF
!         highest parameter value
          dmaxval = p_k(1)
          DO i = 2, mpara
            dmaxval = max(dmaxval, p_k(i))
          END DO
!         estimated precision feasibility
          depsilon = depsilon *dmaxval
#ifdef DEBUG
          WRITE(*,*) ' [I] : -> BiCGstab solver runs until residuum <',depsilon
#endif
!       --
!       for "dnrm" dummy vector
        CALL set_dval(mpara,0.D0,tmp(1,3))
!       compute "p_delta'
        WRITE(*,*) ' '
        CALL omp_bayes_solve(mpara,p_delta,tmp(1,4),r, depsilon,max(mpara,ndata),0, &
          lss_lloctmp(1,1,1,ismpl),tmp(1,1),tmp(1,3),ismpl)
        WRITE(*,*) ' [I] : finish linear system for one bayes step'
        WRITE(*,*) ' '
!
! ----------------
#ifdef DEBUG
!       debug test: S^T *C_dd^-1 *S + reg_func() *C_pp^-1) * p_delta
!       - matrix free system -
        call step_bayes_tmpm(p_delta,tmp(1,1),tmp(1,3),ismpl)
!       test result
        do i = 1, min(mpara,10)
          WRITE(*,*) ' [d] : res =',dabs((tmp(i,3)-tmp(i,4))/tmp(i,4))
        enddo
        IF (mpara>10) WRITE(*,*) ' [d] : res = ...'
#endif
! ----------------
!
        IF (linfos(2)>=1) THEN
          WRITE(*,*) ' [I] : nrm2(p_k-p_(k+1)):', dsqrt(ddot(mpara,p_delta,1,p_delta,1))
          WRITE(*,*) ' [I] : end bayes step'
        END IF
!
        RETURN
      END

!>    @brief calculate "Jacobi^T vector product"; tmpm = <tmp4> *tmpv + (reg_func() *C_pp^-1) *tmpv
!>    @param[in] tmpv input vector
!>    @param[in,out] tmp temporary helper vectors (space)
!>    @param[out] tmpm result vector
!>    @param[in] ismpl local sample index
!>    @details
!> tmpm = (<tmp4> + reg_func() *C_pp^-1) *tmpv\n
!> [mpara]\n
!>
!> - tmpm = <tmp4> *tmpv\n
!> - tmpm = tmpm + (reg_func() *C_pp^-1) *tmpv\n
      SUBROUTINE step_bayes_tmpm(tmpv,tmp,tmpm,ismpl)
        use arrays
        use mod_data
        IMPLICIT NONE
        integer :: ismpl
        integer :: i, j
        DOUBLE PRECISION tmpm(mpara), tmpv(mpara)
        DOUBLE PRECISION tmp(ndata,2)
        DOUBLE PRECISION reg_func, wp2_ps, d_max
        LOGICAL test_null
        EXTERNAL reg_func, wp2_ps, test_null

!
!       test for trivial solution, to avoid useless computation
        CALL s_damax(mpara,tmpv,d_max)
        IF (test_null(d_max)) THEN
          WRITE(*,*) ' [I] : -> Bayes matrix vector product - trivial solution, skip computation'
          CALL set_dval(mpara,0.0d0,tmpm)
          RETURN
        END IF
!
        write(*,*) "[I] : Bayes matrix vector product - computing J^T *(J*x)"
        CALL step_bayes_tmp4(tmpv,tmp,tmpm,ismpl)
        DO j = 1, mpara
          DO i = 1, mpara
            tmpm(j) = tmpm(j) + reg_func()*wp2_ps(j,i,ismpl)*tmpv(i)
          END DO
        END DO
!
        RETURN
      END

!>    @brief calculate tmp4 = <tmp1> *jacobi *tmpv
!>    @param[in] tmpv input vector
!>    @param[in,out] tmp temporary helper vectors (space)
!>    @param[out] tmp4 result vector
!>    @param[in] ismpl local sample index
!>    @details
!> tmp4 = <tmp1> *jacobi *tmpv\n
!> [mpara]\n
!>
!> - tmp(:,1) = jacobi *tmpv\n
!> - tmp4 = <tmp1> *tmp(:,1)\n
      SUBROUTINE step_bayes_tmp4(tmpv,tmp,tmp4,ismpl)
        use arrays
        use mod_data
        IMPLICIT NONE
        integer :: ismpl
        DOUBLE PRECISION tmp4(mpara), tmpv(mpara)
        DOUBLE PRECISION tmp(ndata,2)
        integer start_jacmv,end_jacmv,rate

!
        call system_clock(start_jacmv,rate)
        CALL jac_mv(tmpv,tmp(1,1),ismpl)
        call system_clock(end_jacmv)
        write(*,*) "J*x timing: ",REAL(end_jacmv-start_jacmv)/REAL(rate)
        CALL step_bayes_tmp1(tmp(1,1),tmp(1,2),tmp4,ismpl)
!
        RETURN
      END

!>    @brief calculate tmp1 = jacobi^T *Wd2 *tmpv
!>    @param[in] tmpv input vector
!>    @param[in,out] tmp temporary helper vector (space)
!>    @param[out] tmp1 result vector
!>    @param[in] ismpl local sample index
!>    @details
!> tmp1 = jacobi^T *Wd2 *tmpv\n
!> [mpara]\n
!>
!> - tmp = Wd2 *tmpv\n
!> - tmp1 = jacobi^T *tmp\n
      SUBROUTINE step_bayes_tmp1(tmpv,tmp,tmp1,ismpl)
        use arrays
        use mod_data
        IMPLICIT NONE
        integer :: ismpl
        integer :: j, k
        DOUBLE PRECISION tmp1(mpara)
        DOUBLE PRECISION tmp(ndata), tmpv(ndata)
        DOUBLE PRECISION wd2_ps
        integer start_jactmv,end_jactmv,rate
        EXTERNAL wd2_ps

!
        DO j = 1, ndata
          tmp(j) = 0.0d0
          DO k = 1, ndata
            tmp(j) = tmp(j) + wd2_ps(j,k,ismpl)*tmpv(k)
          END DO
        END DO
        call system_clock(start_jactmv,rate)
        CALL jact_mv(tmp,tmp1,ismpl)
        call system_clock(end_jactmv)

        write(*,*) "J^T*x timing: ",REAL(end_jactmv-start_jactmv)/REAL(rate)
!
        RETURN
      END


program globe_stl
  use BodyMod,    only: body
  use fluidMod,   only: fluid
  use mympiMod,   only: init_mympi,mympi_end,mympi_rank
  use gridMod,    only: xg
  use imageMod,   only: display
  use geom_shape
  use geom_global,only: pi

  implicit none
!
! -- Define parameter, declare variables
  real,parameter :: D = 2*32, Re = 30e3 ! diameter and Reynolds number
  integer :: n(3) = 32*(/4,2,2/)  ! numer of points
  integer :: b(3) = (/1,1,1/)     ! MPI blocks (product must equal n_procs)
  logical :: root                 ! root processor
  type(fluid) :: flow
  type(body) :: geom
!
! -- Initialize MPI (if MPI is OFF, b is set to 1)
  call init_mympi(3,set_blocks=b)
  root = mympi_rank()==0
!
  if(root) print *,'Setting up the grid, body and fluid'
  if(root) print *,'-----------------------------------'
  call xg(1)%stretch(n(1), -2*D, -0.5*D, 0.5*D, 5*D, h_min=2., h_max=12.,prnt=root)
  call xg(2)%stretch(n(2), -2*D, -0.5*D, 0.5*D, 2*D, h_min=2.,prnt=root)
  call xg(3)%stretch(n(3), -2*D, -0.5*D, 0.5*D, 2*D, h_min=2.,prnt=root)

! build geometry
! -- standard way, this uses stl file, but cannot probe values
  ! geom = globe(0.5*D).map.init_rigid(2,y)
! -- othe way, this uses the new derived type, can probe values
  call init_body(geom)
  call flow%init(n/b,geom,V=(/1.,0.,0./),nu=D/Re)
!
  if(root) print *,'Starting time update loop'
  if(root) print *,'-----------------------------------'
  if(root) print *,' -t- , -dt- '

  do while(flow%time<1*D)
    call geom%update(flow%time+flow%dt)   ! update position
    call flow%update(geom)
    write(9,'(f10.4,f8.4,3e16.8)') flow%time/D,flow%dt, 2.*geom%pforce(flow%pressure)/(pi*D**2/4.)
    if(mod(flow%time,0.1*D)<flow%dt) then
      if(root) print '(f6.1,",",f6.3)',flow%time/D,flow%dt
      call geom%writePoints(flow%pressure,flow%time)
      call flow%write(geom)
      call display(flow%velocity%vorticity_Z(),'out_vort',lim=20./D)
    end if
  end do

  if(root) print *,'Loop complete: writing restart files and exiting'
  if(root) print *,'-----------------------------------'
  call mympi_end

contains
!
! -- motion definition
  real(8) pure function y(t)
    real(8),intent(in) :: t
    y = 0.001*D*t
  end function y

  subroutine init_body(geom)
    class(body),intent(inout) :: geom
    class(model),pointer :: globe
    type(stlth),pointer :: ptr
    type(set) :: sets
    type(model_info) :: mod_info
    mod_info%file = '../sphere.stl'
    mod_info%s = 0.5*D*(/.01,.01,.01/) ! .stl file is a globe with D=100
    call model_init_ptr(mod_info, globe, ptr)
    sets = globe
    geom = sets.map.init_rigid(2,y)
    geom%srf => ptr
  end subroutine init_body

!   type(set) function globe(R)
!     real,intent(in) :: R
!     type(model_info) :: mod_info
!     mod_info%file = '../sphere.stl'     ! file to use
!     mod_info%s = R*(/.01,.01,.01/)         ! scale it
!     mod_info%x = (/0.,0.,0./)           ! define origin
!     mod_info%r = (/0.,0.,0./)           ! rotation
!     globe = model_init(mod_info)
! end function globe

end program globe_stl


c param_type = 1, Hicks-Henne
c              2, Kulfan
c              3, Clamped cubic spline
      subroutine shape_deform(ibeg, jbeg, iend, jend, nhhp, idim, jdim,
     1                        r, rw, drw, nwp, xw, idx, param_type)
      implicit none
      include 'dim.h'
      integer ibeg, jbeg, iend, jend, nhhp, idim, jdim, nwp
      real    r   (idim,jdim,NDIM),
     2        rw  (NDIM,*),
     3        drw (NDIM,*),
     4        xw  (*)
      integer idx(*)
      integer param_type

      integer i, j, nc, iinc, jinc
      real    x1, y1, x2, y2, ln, xp, yp, xf, yf, l, t,
     1        nx, ny, h, dh, A, B, C, D
c     For cubic spline
      real    tau(nhhp+2), cc(4,nhhp+2)
      real    ppvalu
      real    HicksHenne
      real    kulfan

c     Set increment to +1 or -1
      iinc = 1
      jinc = 1
      if(iend.lt.ibeg) iinc = -1
      if(jend.lt.jbeg) jinc = -1

c     (x1,y1) = first point, (x2,y2) = second point on curve
      if(param_type .eq. 1)then
         x1 = r(ibeg,jbeg,1)
         y1 = r(ibeg,jbeg,2)
         x2 = r(iend,jend,1)
         y2 = r(iend,jend,2)
      elseif(param_type .eq. 2)then
         x1 = 1.0
         y1 = 0.0
         x2 = 0.0
         y2 = 0.0
      elseif(param_type .eq. 3)then
         x1 = r(ibeg,jbeg,1)
         y1 = r(ibeg,jbeg,2)
         x2 = r(iend,jend,1)
         y2 = r(iend,jend,2)
         cc(1,1) = 0.0
         tau(1) = 0.0
         do i=1,nhhp
            cc(1,i+1) = xw(i)
            tau(i+1)  = (i*1.0)/(nhhp+1)
         enddo
         cc(1,nhhp+2) = 0.0
         tau(nhhp+2)      = 1.0
c        zero slope at end points: clamped spline
         cc(2,1)      = 0.0
         cc(2,nhhp+2) = 0.0
         call cubspl(tau,cc,nhhp+2,1,1)
      endif
      print*,'   First  point =',x1,y1
      print*,'   Second point =',x2,y2

      ln = sqrt( (x2-x1)**2 + (y2-y1)**2 )

      if(ln.eq.0.0 .and. nhhp.ne.0)then
         print*,'shape_deform: ln is <= 0'
         stop
      else if(ln.eq.0.0 .and. nhhp.eq.0)then
         ln = 1.0
      else if(ln.eq.0.0)then
         print*,'shape_deform: OOPS'
         print*,'ln =',ln
         print*,'nhhp =',nhhp
         stop
      endif
      nx = (y2-y1)/ln
      ny =-(x2-x1)/ln

      print*,'   Unit vector  =',nx,ny

c     Equation of line joining (x1,y1) to (x2,y2) -> Ax + By + C = 0
      A  = (y2 - y1)
      B  =-(x2 - x1)
      C  = -(y2 - y1)*x1 + (x2 - x1)*y1

c     Counter for idx array
      nc = 0

      do i=ibeg,iend,iinc
         do j=jbeg,jend,jinc
            nc        = nc + 1
            nwp       = nwp + 1
            xp        = r(i,j,1)
            yp        = r(i,j,2)
            rw(1,nwp) = xp
            rw(2,nwp) = yp

            drw(1,nwp)= 0.0
            drw(2,nwp)= 0.0
            idx(nc)   = nwp
            if(nhhp.eq.0) goto 100

c           Equation of perpendicular line through (xp,yp)
c           -B x + A y + D = 0
            D = B * xp - A * yp
c           Solve for intersection point (xf,yf) = foot of perpendicular
            xf = -(A*C - B*D)/(A**2 + B**2)
            yf = -(B*C + A*D)/(A**2 + B**2)
            l  = sqrt( (xf-x1)**2 + (yf-y1)**2 )
            t         = l/ln
            if(param_type .eq. 1)then
               dh = HicksHenne(nhhp, xw, t)
               drw(1,nwp)= dh*nx
               drw(2,nwp)= dh*ny
            elseif(param_type .eq. 2)then
               t = xp
               h = kulfan(nhhp, xw, t)
               drw(1,nwp)= 0.0
               drw(2,nwp)= h - yp
            elseif(param_type .eq. 3)then
               dh = ppvalu(tau,cc,nhhp+1,4,t,0)
               drw(1,nwp)= dh*nx
               drw(2,nwp)= dh*ny
            endif

100         continue
         enddo
      enddo

      return
      end


      SUBROUTINE write_surfaces
      USE stel_constants
      USE boundary
      USE modular_coils
      USE saddle_coils
      USE saddle_surface
      USE Vwire, ONLY: nwire
      IMPLICIT NONE
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER, PARAMETER :: nphi = 9
      INTEGER :: i, k, m, n, mn, itheta, iphi, nscmax
      INTEGER :: npt
      INTEGER, DIMENSION(ncdim) :: npts
      REAL(rprec) :: v0, phi0, theta, dtheta, dphi, rws, zws
      REAL(rprec) :: ck, sk, cosmu, sinmu, cosnv, sinnv, rps, zps
      REAL(rprec), DIMENSION (nwdim1,nphi) :: rw, zw, rs, zs, rp, zp
      REAL(rprec), DIMENSION (nwdim1,2) :: xw, yw, xp, yp
      REAL(rprec), DIMENSION (ncdim, 5*ncdim) :: rpts, zpts
      REAL(rprec), DIMENSION (5*ncdim, nphi) :: rplt, zplt
!-----------------------------------------------
      OPEN(unit=22,file='surfaces.dat',status='unknown')
      OPEN(unit=25,file='topview.dat',status='unknown')
      OPEN(unit=26,file='rzpts.dat',status='unknown')

      nscMAX = ncdim/2
      dtheta = twopi/(nwire-1)
      dphi = twopi/(16*nfp)
      theta = zero

      DO n = 1, nphi
        phi0 = -pi/nfp + (n-1)*dphi

        IF (lsaddle) THEN
           v0 = nfp*phi0/twopi
           CALL eval_saddle_rz (v0, npts, rpts, zpts)
           m = 0
           DO k = 1, nsmid
              npt = npts(k)
              DO i = 1, nscmax
                 m = m + 1
                 IF (i .le. npt) THEN
                    rplt(m,n) = rpts(k,i)
                    zplt(m,n) = zpts(k,i)
                 ELSE
                    rplt(m,n) = 1000
                    zplt(m,n) = 1000
                 END IF
              END DO
           END DO
        END IF

        DO itheta = 1,nwire
           theta = dtheta*REAL(itheta-1)

!     modular winding surface at phi
           CALL rz_surf(theta,phi0,rws,zws,numsurf,
     1                   rmn_sf,zmn_sf,m_num,n_num,nfp)
           rw(itheta,n) = rws
           zw(itheta,n) = zws

!     Saddle winding surface edge at phi
           rws = 0.0
           zws = 0.0
           DO k = 1, numsurf_sad
              ck = COS(m_sad(k)*theta + nfp*n_sad(k)*phi0)
              sk = SIN(m_sad(k)*theta + nfp*n_sad(k)*phi0)
              rws = rws + rmn_sad(k)*ck
              zws = zws + zmn_sad(k)*sk
           END DO
           rs(itheta,n) = rws
           zs(itheta,n) = zws

!     Plasma surface at phi
           rps = 0.0
           zps = 0.0
           DO mn = 1, mnmax
              cosmu = COS(xm_b(mn)*theta)
              sinmu = SIN(xm_b(mn)*theta)
              cosnv = COS(xn_b(mn)*phi0)
              sinnv = SIN(xn_b(mn)*phi0)
              rps = rps + rmnc_b(mn)*(cosmu*cosnv + sinmu*sinnv)
              zps = zps + zmns_b(mn)*(sinmu*cosnv - cosmu*sinnv)
           END DO
           rp(itheta,n) = rps
           zp(itheta,n) = zps

        END DO

      END DO
      DO i = 1,nwire
        WRITE(22,1000)(rw(i,mn),zw(i,mn), mn=1,9)
      END DO
      WRITE(22,'(/)')
      DO i = 1,nwire
        WRITE(22,1000)(rs(i,mn),zs(i,mn), mn=1,9)
      END DO
      WRITE(22,'(/)')
      DO i = 1,nwire
        WRITE(22,1000)(rp(i,mn),zp(i,mn), mn=1,9)
      END DO
      IF (lsaddle) THEN
         DO m = 1,nsmid*nscmax
            WRITE(26,1000) (rplt(m,n), zplt(m,n), n=1,9)
         END DO
      END IF
 1000 FORMAT(1p,18e12.4)

!     Now WRITE data to plot topview

      dphi = twopi/(nwire-1)
      DO n = 1,2
        theta = 0.5*(n-1)*twopi
        DO iphi = 1,nwire
           phi0 = dphi*(iphi-1)

!     modular winding surface edge at phi
           CALL rz_surf(theta,phi0,rws,zws,numsurf,
     1                   rmn_sf,zmn_sf,m_num,n_num,nfp)
           xw(iphi,n) = rws*COS(phi0)
           yw(iphi,n) = rws*SIN(phi0)

!     Plasma surface edge at phi
           rps = 0.0
           zps = 0.0
           DO mn = 1, mnmax
              cosmu = COS(xm_b(mn)*theta)
              sinmu = SIN(xm_b(mn)*theta)
              cosnv = COS(xn_b(mn)*phi0)
              sinnv = SIN(xn_b(mn)*phi0)
              rps = rps + rmnc_b(mn)*(cosmu*cosnv + sinmu*sinnv)
              zps = zps + zmns_b(mn)*(sinmu*cosnv - cosmu*sinnv)
           END DO
           xp(iphi,n) = rps*COS(phi0)
           yp(iphi,n) = rps*SIN(phi0)

        END DO
      END DO

!     DO i = 1,nwire
!       WRITE(25,1000) xw(i,1), yw(i,1)
!     END DO
!     WRITE(25,'(/)')
      DO i = 1,nwire
        WRITE(25,1000) xp(i,1), yp(i,1)
      END DO
      WRITE(25,'(/)')
!     DO i = 1,nwire
!       WRITE(25,1000) xw(i,2), yw(i,2)
!     END DO
!     WRITE(25,'(/)')
      DO i = 1,nwire
        WRITE(25,1000) xp(i,2), yp(i,2)
      END DO

      CLOSE(22)
      CLOSE(25)
      CLOSE(26)

!     WRITE winding surface coefficients
      OPEN (unit=27,file='rz_coeff.dat',status='unknown')
      OPEN (unit=28,file='rz_coeff2.dat',status='unknown')
      WRITE (27,115) numsurf
      WRITE (27,120) (m_num(i), n_num(i), rmn_sf(i), zmn_sf(i),
     1                i=1, numsurf)
      WRITE (28,115) numsurf_sad
      WRITE (28,120) (m_sad(i), n_sad(i), rmn_sad(i), zmn_sad(i),
     1                i=1, numsurf_sad)
  115 FORMAT(i4)
  120 FORMAT(2i4,1p,2e16.8)
      CLOSE (27)
      CLOSE (28)

!     WRITE plasma surface coefficients
      OPEN (unit=31,file='rz_plasma.dat',status='unknown')
      OPEN (unit=32,file='rz_plasma2.dat',status='unknown')
      WRITE (31,135) mnmax
      WRITE (31,140) (xm_b(i), -xn_b(i)/nfp, rmnc_b(i), zmns_b(i),
     1                i=1, mnmax)
      WRITE (32,135) mnmax
      WRITE (32,145) (xm_b(i), -xn_b(i)/nfp, rmnc_b(i), zmns_b(i),
     1                i=1, mnmax)
  135 FORMAT(i4)
  140 FORMAT(2f8.0,2e22.12)
  145 FORMAT(2f10.0,2f20.12)
      CLOSE (31)
      CLOSE (32)

      END SUBROUTINE write_surfaces


subroutine addgnoise(xout,yout,opixels,snr,seed)
use precision
implicit none
integer :: xout,yout,seed,i,j
real(double) :: snr,maxcol,noiseamp,gasdev
real(double), dimension(:,:) :: opixels

maxcol=0.0d0
do i=1,xout
   maxcol=max(maxcol,Sum(opixels(i,:)))
enddo

noiseamp=maxcol/snr !scale based on S/N of strongest pixel.

do i=1,xout
   do j=1,yout
      opixels(i,j)=opixels(i,j)+noiseamp*gasdev(seed)
   enddo
enddo

return
end subroutine addgnoise


module CN_Consts
    use mod_parameters
    implicit none
    public
    integer:: ElemCountAct,NodeCountAct
    integer:: NodCountB,ElemCountB,iBCcount
    real*8 :: pid=3.14159265358979  !4.d0*atan(1.d0) ! a circle constant
    real*8 :: alpha=-.25d0
    real*8 :: beta=0.75d0
    real*8 :: C1,C2,C3,C4,C5
    real*8 :: sqr3_3=sqrt(3.d0)/3.d0
    real*8 :: Vh=2.0E-6 ! partial molar volume of hydrogen
    real*8 :: Temprd=293.0d0
    real*8 :: R=8.3142d0
    real*8 :: Vh_RT
    real*8 :: N1T(4,1),N2T(4,1),N3T(4,1),N4T(4,1)
    real*8 :: N1s(1,4),N2s(1,4),N3s(1,4),N4s(1,4)
    real*8 :: NtN1(4,4),NtN2(4,4),NtN3(4,4),NtN4(4,4)
    real*8 :: psi(4),eta(4)
    integer:: iPrintOutputFlag=0
    real*8 :: DtCurrent=1
    integer ::GaussIntPtsCount=4

    Interface CalConsts;                  Module Procedure CalConsts ;                   End Interface
    Interface CNCalcElemAverageFromNodes; Module Procedure CNCalcElemAverageFromNodes;   End Interface
!    ---------------------------
    contains
        subroutine CalConsts
            !--- to see only this variable from the entire module
!!!!!!!            use CN_Objects_manager ,only: GaussIntPtsCount
            implicit none
            real*8 ::N(GaussIntPtsCount,4)
            integer i

            C1=beta*(1+alpha)
            C2=beta*alpha
            C3=(1-beta)*(1+alpha)
            C4=(1-beta)*alpha
            C5=(1+alpha)*alpha
            Vh_RT=Vh/(R*Tempr)
            psi(1:4)=(/-sqr3_3, sqr3_3, sqr3_3, -sqr3_3/)
            eta(1:4)=(/-sqr3_3, -sqr3_3, sqr3_3, sqr3_3/)

            do i=1,GaussIntPtsCount
                N(i,1)=0.25d0*(1.-psi(i))*(1.-eta(i))
                N(i,2)=0.25d0*(1.+psi(i))*(1.-eta(i))
                N(i,3)=0.25d0*(1.+psi(i))*(1.+eta(i))
                N(i,4)=0.25d0*(1.-psi(i))*(1.+eta(i))
            enddo

            N1s(1,1:4)=N(1,1:4)
            N2s(1,1:4)=N(2,1:4)
            N3s(1,1:4)=N(3,1:4)
            N4s(1,1:4)=N(4,1:4)

            call matrixtrans(N(1,1:4),N1T,1,4)
            call matrixtrans(N(2,1:4),N2T,1,4)
            call matrixtrans(N(3,1:4),N3T,1,4)
            call matrixtrans(N(4,1:4),N4T,1,4)

            NtN1=matmul(N1T,N1s)
            NtN2=matmul(N2T,N2s)
            NtN3=matmul(N3T,N3s)
            NtN4=matmul(N4T,N4s)

        end subroutine
!    ---------------------------
        subroutine printconsts
                write ( *,* )pi,alpha,beta,c1,c2,c3,c4,c5
                write ( *,* )psi
                write ( *,* )eta

        end subroutine
!!!        --------------------------------------- to cal. the average at the element knowing the nodes values
!!!        ---------------------------------------
        subroutine CNCalcElemAverageFromNodes (ElemCount, NodeCount,ElemConnect,rNodesIn,rElemOut)
            implicit none
            integer,   intent(in) :: ElemCount, NodeCount
            integer,    intent(in) :: ElemConnect(ElemCount,4)
            real*8,    intent(in) :: rNodesIn(NodeCount)
            real*8,    intent(out):: rElemOut(ElemCount)
            real*8 ::Valn1,Valn2,Valn3,Valn4
            integer i

            do i=1,ElemCount
                Valn1=rNodesIn(ElemConnect(i,1))
                Valn2=rNodesIn(ElemConnect(i,2))
                Valn3=rNodesIn(ElemConnect(i,3))
                Valn4=rNodesIn(ElemConnect(i,4))
                rElemOut(i)=0.25*(Valn1+Valn2+Valn3+Valn4)
            enddo

        end subroutine CNCalcElemAverageFromNodes

end module CN_Consts
! ###########################################################
! ###########################################################
module CN_BaseClass
    implicit none
    TYPE CN_Base
!!!!        integer :: GaussIntPtsCount=4
        integer :: iSolutionActive=0
        integer :: iBCcount=0
!!!!!!        rRn=Rqg .... rRn_1=Rqo    .... rRn_2=Rqor ....
!!!!!!        rTn=Tinit .. rTn_1=Tinitd .... rTn_2=Tinitdold ....
        real*8 , ALLOCATABLE :: rRn_1(:),rRn_2(:)
        real*8 , ALLOCATABLE :: rTn_1(:),rTn_2(:)
        real*8 , ALLOCATABLE :: rThermal_Diff_Ele(:)
        real*8 , ALLOCATABLE :: rBCTempConc(:)
        integer, ALLOCATABLE :: iBCNodeID(:)

     contains ! Computation of area for rectangles.
        procedure ::AllocateMem => CN_Base_AllocateMem
        procedure ::CleanMem => CN_Base_CleanMem
        procedure ::CNSetBCdataBase => CN_Base_CNSetBCdata
        procedure ::CN_Base_GetSolution
        procedure ::CN_Base_ForceBCs
        procedure ::CNBase_InitiateTn_1
        procedure ::CNBase_CopyNode

    ENDTYPE
        Interface init_CN_Base;                    Module Procedure init_CN_Base;                 End Interface
!!        Interface AllocateMem;                Module Procedure CN_Base_AllocateMem;          End Interface
!!        Interface CleanMem;                   Module Procedure CN_Base_CleanMem;             End Interface
!!        Interface CNSetBCdataBase;            Module Procedure CN_Base_CNSetBCdata;          End Interface

        contains
            type ( CN_Base )function init_CN_Base ( mNodCountB,mElemCountB )
!            use CN_Consts
                integer, intent(in) :: mNodCountB,mElemCountB

!                NodCountB=mNodCountB
!                ElemCountB=mElemCountB
                init_CN_Base%iBCcount=0

            end function init_CN_Base
!!!        --------------------------------------- to allocate memory for the Rn's and CTn's
        subroutine CN_Base_AllocateMem (tCN_object)
            use CN_Consts
            class ( CN_Base ), intent(inout) :: tCN_object
            integer ne,nn

            if(tCN_object%iSolutionActive == 0) return

            ne=ElemCountB
            nn=NodCountB
            allocate(tCN_object%rTn_1(nn),tCN_object%rTn_2(nn))
            allocate(tCN_object%rRn_1(nn),tCN_object%rRn_2(nn))
            allocate(tCN_object%rBCTempConc(nn),tCN_object%iBCNodeID(nn))
            allocate(tCN_object%rThermal_Diff_Ele(ne))

            tCN_object%rTn_1       = 0
            tCN_object%rTn_2       = 0
            tCN_object%rRn_1       = 0
            tCN_object%rRn_2       = 0
            tCN_object%rBCTempConc = 0
            tCN_object%iBCNodeID   = 0
            tCN_object%rThermal_Diff_Ele      = 0

        end subroutine CN_Base_AllocateMem
!!!        --------------------------------------- to clean the memory for the Rn's and CTn's
        subroutine CN_Base_CleanMem (tCN_object)
            class ( CN_Base ), intent(inout) :: tCN_object

            if(tCN_object%iSolutionActive == 0) return

            IF (ALLOCATED (tCN_object%rTn_1))           DEALLOCATE (tCN_object%rTn_1)
            IF (ALLOCATED (tCN_object%rTn_2))           DEALLOCATE (tCN_object%rTn_2)
            IF (ALLOCATED (tCN_object%rRn_1))           DEALLOCATE (tCN_object%rRn_1)
            IF (ALLOCATED (tCN_object%rRn_2))           DEALLOCATE (tCN_object%rRn_2)
            IF (ALLOCATED (tCN_object%rBCTempConc))     DEALLOCATE (tCN_object%rBCTempConc)
            IF (ALLOCATED (tCN_object%iBCNodeID))       DEALLOCATE (tCN_object%iBCNodeID)
            IF (ALLOCATED (tCN_object%rThermal_Diff_Ele))       DEALLOCATE (tCN_object%rThermal_Diff_Ele)

        end subroutine CN_Base_CleanMem
!!!        --------------------------------------- to clean the memory for the Rn's and CTn's
        subroutine CN_Base_CNSetBCdata (tCN_object,NodeID,BC_thermal_t,BC_thermal_flag)
            implicit none
            class ( CN_Base ), intent(inout) :: tCN_object
            real,    intent(in) :: BC_thermal_t
            integer, intent(in) :: BC_thermal_flag,NodeID

            if(tCN_object%iSolutionActive == 0) return

            tCN_object%rBCTempConc(NodeID) = BC_thermal_t
            if(BC_thermal_flag == 1)then
                tCN_object%iBCcount = tCN_object%iBCcount+1
                tCN_object%iBCNodeID(tCN_object%iBCcount) = NodeID
            endif

        end subroutine CN_Base_CNSetBCdata
!!!        --------------------------------------- to clean the memory for the Rn's and CTn's
        subroutine CN_Base_ForceBCs (tCN_object,TdSol,rTn)
            use CN_Consts,only:NodeCountAct
            implicit none
            class ( CN_Base ), intent(inout) :: tCN_object
            real*8,    intent(inout) :: TdSol(NodeCountAct)
            real*8,    intent(in) :: rTn(NodeCountAct)
            integer NodeID,i

            if(tCN_object%iSolutionActive == 0) return

            do i=1,tCN_object%iBCcount
                NodeID=tCN_object%iBCNodeID(i)
                TdSol(NodeID) =rTn(NodeID)
            enddo

        end subroutine CN_Base_ForceBCs
!!!        --------------------------------------- to clean the memory for the Rn's and CTn's
        subroutine CNBase_InitiateTn_1 (obj,ElemConnect)
            use CN_Consts!,only:NodeCountAct,ElemCountAct
            implicit none
            class ( CN_Base ), intent(inout) :: obj
            integer,    intent(in) :: ElemConnect(ElemCountAct,4)
!!!!            real*8,    intent(out):: rThermal_Diff_Ele(ElemCountAct)
!!!!            integer i,n1,n2,n3,n4

            if(obj%iSolutionActive == 0) return ! if not active then return

            !---- initialize the Tn_1 from the input
            obj%rTn_1(1:NodeCountAct) = obj%rBCTempConc(1:NodeCountAct)
!!!!!            write(*,*)obj%rBCTempConc(1:NodeCountAct)
!!!!!            write(*,*)obj%rTn_1(1:NodeCountAct)
!!!!!            write(*,*)ElemConnect

            !---- initialize the T or C at the element from the initial values at the nodes
            CALL CNCalcElemAverageFromNodes (ElemCountAct, NodeCountAct,ElemConnect,obj%rTn_1,obj%rThermal_Diff_Ele)

        end subroutine CNBase_InitiateTn_1
!!!        --------------------------------------- to clean the memory for the Rn's and CTn's
        subroutine CNBase_CopyNode (obj,n,m)
            implicit none
            class ( CN_Base ), intent(inout) :: obj
            integer,    intent(in) :: n,m

            obj%rTn_1(n)=obj%rTn_1(m)
            obj%rTn_2(n)=obj%rTn_2(m)
            obj%rRn_1(n)=obj%rRn_1(m)
            obj%rRn_2(n)=obj%rRn_2(m)

!!!!!!            Rqold(n)=Rqold(m)
!!!!!!            Rqolder(n)=Rqolder(m)
!!!!!!            Tinit(n)=Tinit(m)
!!!!!!            Tinitdold(n)=Tinitdold(m)

        end subroutine CNBase_CopyNode

!!!        --------------------------------------- to clean the memory for the Rn's and CTn's

        subroutine CN_Base_GetSolution (obj,DtCondDiff,ElemConnect,Cglobal,Kglobal,rRn,rTn)
            use CN_Consts !!!!,only:NodeCountAct
            implicit none
            class ( CN_Base ), intent(inout) :: obj
            integer,    intent(in) :: ElemConnect(ElemCountAct,4)
            real*8, intent(in) :: DtCondDiff
            real*8, intent(in) ::  Cglobal(NodeCountAct,NodeCountAct), Kglobal(NodeCountAct,NodeCountAct), rRn(NodeCountAct)
            real*8, intent(out) ::  rTn(NodeCountAct)

            real*8 RHS(NodeCountAct)
            real*8 Tcoeff1(NodeCountAct,NodeCountAct),Rnew(NodeCountAct)
            real*8 Rold(NodeCountAct),Rolder(NodeCountAct)
            real*8 RHS2(NodeCountAct),LHS(NodeCountAct,NodeCountAct),TdSol(NodeCountAct)
            real*8 Tcoeff2(NodeCountAct,NodeCountAct)
            integer  IPIV(NodeCountAct),n
            integer ::INFO_flag=0

            if(obj%iSolutionActive == 0) return

            n=NodeCountAct
            LHS(1:n,1:n)=1./DtCondDiff*Cglobal(1:n,1:n) + (beta)*Kglobal(1:n,1:n)*(1.+alpha)
            Tcoeff1(1:n,1:n)=1./DtCondDiff*Cglobal(1:n,1:n) + (beta)*Kglobal(1:n,1:n)*(alpha)- (1.-beta)*(1.+alpha)*Kglobal(1:n,1:n)
            Tcoeff2(1:n,1:n)=(1.-beta)*Kglobal(1:n,1:n)*alpha

            Rold(1:n)=-(beta)*(alpha)*obj%rRn_1(1:n)+(1.-beta)*(1.+alpha)*obj%rRn_1(1:n)
            Rnew(1:n)=(beta)*rRn(1:n)*(1.+alpha)
            Rolder(1:n)=-(1.-beta)*(alpha)*obj%rRn_2(1:n)

!c     modifying C and K matrices for prescribed temperatures
            RHS2(1:n)=matmul(Tcoeff1(1:n,1:n),obj%rTn_1(1:n))+ matmul(Tcoeff2(1:n,1:n),obj%rTn_2(1:n))+ &
                        Rold(1:n)+Rnew(1:n)+Rolder(1:n)
!      to apply the effect of thermal loading
            call obj%CN_Base_ForceBCs (TdSol,rTn)

            call ThermalSetLoading(n,RHS2,LHS,obj%rTn_1)

           call DGESV(n,1,LHS,n,IPIV,RHS2,n,INFO_flag)
            if(INFO_flag.eq.0)then
                  TdSol(1:n)=RHS2(1:n)
              write(*,*)'solve successful',DtCondDiff
            endif

            if(INFO_flag.ne.0)then
              write(*,*)'solve unsuccessful',DtCondDiff
              call bye(2)
            endif
!------------------------------------------------
!      update only the nodes that has ICs not BCs
!   ----------------------------------testing

            call ThermalLdSetToSol(n,TdSol)

            rTn(1:n)=TdSol(1:n)

            obj%rRn_2(1:n)=obj%rRn_1(1:n)       ! save value at n step
            obj%rRn_1(1:n)=rRn(1:n)

            obj%rTn_2(1:n)=obj%rTn_1(1:n)
            obj%rTn_1(1:n)=rTn(1:n)

            !---- cal. the T or C at the element from the values at the nodes
            CALL CNCalcElemAverageFromNodes (ElemCountAct, NodeCountAct,ElemConnect,rTn,obj%rThermal_Diff_Ele)

        end subroutine CN_Base_GetSolution

end module CN_BaseClass
! ###########################################################
! ###########################################################
module CN_Thermal
    use CN_BaseClass
    implicit none
!!!        ---------------------------------------
    type,extends( CN_Base):: ThermalClass
        real*8 , ALLOCATABLE :: rThermal_DijSij(:)

        contains
!!!!!!!!!        procedure ::ThermalClass
        procedure ::CN_Thermal_CleanMem
!!!!!!!!!            Interface CN_Thermal_CleanMem;                Module Procedure CN_Thermal_CleanMem ;          End Interface
    end type ThermalClass
            Interface init_ThermalClass;                       Module Procedure init_ThermalClass ;            End Interface
!!!        ---------------------------------------
!!!        ---------------------------------------
        contains
        type ( ThermalClass )function init_ThermalClass ( mNodCountB,mElemCountB )
            integer, intent(in) :: mNodCountB,mElemCountB

                init_ThermalClass%CN_Base=init_CN_Base(mNodCountB,mElemCountB)
                init_ThermalClass%iSolutionActive=1
                Call init_ThermalClass%AllocateMem()

                allocate(init_ThermalClass%rThermal_DijSij(mElemCountB))

        end function init_ThermalClass
! ###########################################################
! ###########################################################
        subroutine CN_Thermal_CleanMem (tCN_object)
            class ( ThermalClass ), intent(inout) :: tCN_object

            call tCN_object%CleanMem()
            IF (ALLOCATED (tCN_object%rThermal_DijSij))           DEALLOCATE (tCN_object%rThermal_DijSij)

        end subroutine CN_Thermal_CleanMem
end module CN_Thermal
! ###########################################################
! ###########################################################
module CN_Diffusion
    use CN_BaseClass
    implicit none
!!!        ---------------------------------------
    type,extends( CN_Base):: DiffusionClass
    end type DiffusionClass
!!!        ---------------------------------------
!!!        ---------------------------------------
    Interface init_DiffusionClass;                Module Procedure init_DiffusionClass ;          End Interface

!!!        ---------------------------------------
        contains
        type ( DiffusionClass )function init_DiffusionClass ( mNodCountB,mElemCountB )
            integer, intent(in) :: mNodCountB,mElemCountB

                init_DiffusionClass%CN_Base=init_CN_Base(mNodCountB,mElemCountB)
                init_DiffusionClass%iSolutionActive=1
                Call init_DiffusionClass%AllocateMem()

        end function init_DiffusionClass
end module CN_Diffusion
! ###########################################################


      FUNCTION sumx(x,n)
C     Function to compute the sum of a vector.  Use double precision
C       summation, but return a single precision answer.
C     Robert Grumbine 12/09/1993.

      IMPLICIT none

      INTEGER n
      REAL sumx, x(n)

      DOUBLE PRECISION sum
      INTEGER i

      sum = 0.
      DO i = 1, n
        sum = sum + DBLE(x(i))
      ENDDO
      sumx = SNGL(sum)
      RETURN
      END


use plantfem
implicit none

type(IO_) :: f
type(Random_) :: random

! open file
call f%open("gaussian_noise.txt","w")

! i_i is a default loop variable.
! Loop over 1,000 times.
do i_i =1,1000
    ! ... and write ITER, RANDOM NUMBER
    call f%write(i_i,random%gauss(mu=0.0d0, sigma=0.10d0) )
enddo
call f%close()

! plot graph
call f%plot("gaussian_noise.txt", "w l")

end


program test_airybi
  use types, only: dp
  use constants, only: i_
  use utils, only: assert
  use special, only: airybi
  implicit none

  ! check a few value against the ones computed with SciPy:
  integer :: i
  real(dp), parameter :: eps = 1d-14
  real(dp), parameter :: xReal(5) = [1.1_dp, 3.0_dp, 10.0_dp, 2.1_dp, 5.5_dp]
  real(dp), parameter :: xImag(5) = [0.1_dp, -0.3_dp, 2.5_dp, -1.8_dp, 2.0_dp]

  complex(dp), parameter :: correctResults(5) = [(1.299900779689054930443603552703D+00, 1.060290624984279589382296649092D-01),&
       (1.219954982972653745321167662041D+01, -6.511549752437751692468737019226D+00),&
       (-2.663057456595905125141143798828D+06, 2.762998408228511214256286621094D+08),&
       (-1.531578027758900617527615395375D+00, -1.157033930943324406825922778808D+00),&
       (-1.140718548954242521631385898218D+02, -1.292974440780106533566140569746D+03)]

  do i = 1,5
     call assert(abs(airybi(xReal(i)+i_*xImag(i)) - correctResults(i)) < eps)
  end do

end program test_airybi


      program day03
      character c
      integer wire, n, x(3), w(3), grid(3,1000), i
      integer ans(2), xsct(2)
      data x/3*0/, i/1/, ans/2*1 000 000 000/, wire/1/, grid/3000 * 0/

c     Read first wire direction
 2    read(*,*) c, n
      if (c.eq.'-') then
c        Go to second wire
         x = 0
         go to 3
      end if

c     Move to new position
      call move(x, c, n)
      i = i + 1
c     Record next position and total distance
      grid(1,i) = x(1)
      grid(2,i) = x(2)
      grid(3,i) = x(3)
      go to 2

c     Read second wire
 3    read(*,*) c, n
      if (c.eq.'-') go to 4

c     Remember previous position and total distance
      w(1) = x(1)
      w(2) = x(2)
      w(3) = x(3)

c     Move to next position
      call move(x, c, n)

c     Find intersection with first wire
      call intersect(grid, w, x, i, xsct)
      ans(1) = min(xsct(1), ans(1))
      ans(2) = min(xsct(2), ans(2))
      go to 3

c     Write answers to part 1 & 2
 4    write(*,*) ans
      end

      function intersection(x, y, z)
      integer x(4), y(4), z(2), x0, x1, x2, y0, y1, y2
      logical intersection

      intersection = .false.
c     A rather verbose way of seeing if two line segments are orthogonal
      if (x(1).eq.x(3)) then
         x0 = min(y(1), y(3))
         x1 = x(1)
         x2 = max(y(1), y(3))

         y0 = min(x(2), x(4))
         y1 = y(2)
         y2 = max(x(2), x(4))
         go to 90
      else
         x0 = min(x(1), x(3))
         x1 = y(1)
         x2 = max(x(1), x(3))

         y0 = min(y(2), y(4))
         y1 = x(2)
         y2 = max(y(2), y(4))
         go to 90
      end if

c     Determine the point of intersection
 90   if ( x0.lt.x1 .and. x1.lt.x2 .and.
     &     y0.lt.y1 .and. y1.lt.y2) then
         intersection = .true.
         z(1) = x1
         z(2) = y1
      end if

      return
      end

      subroutine intersect(grid, x, y, i, out)
      integer i, j, k, x(3), y(3), grid(3,*)
      integer z(4), w(4), v(2), out(2)
      real norm
      logical intersection

c     Set something really high in case there is no intersect
      out = 1 000 000 000

      z(1) = x(1)
      z(2) = x(2)
      z(3) = y(1)
      z(4) = y(2)

      w(1) = grid(1,1)
      w(2) = grid(2,1)

c     Check each length of wire 1
      do k = 2, i
         w(3) = grid(1,k)
         w(4) = grid(2,k)

c        Find any intersection point of wire 1 & 2
         if (intersection(z, w, v)) then
c           For part 1 - record manhattan distance to origin
            out(1) = abs(v(1)) + abs(v(2))

c           For part 2 - record total wire length from intersection point
            norm = float((x(1)-v(1))**2 + (x(2)-v(2))**2)
            out(2) = sqrt(norm) + x(3)

            norm = float((w(1)-v(1))**2 + (w(2)-v(2))**2)
            out(2) = out(2) + sqrt(norm) + grid(3,k-1)
            return
         end if

         w(1) = w(3)
         w(2) = w(4)
      end do
      return
      end

      subroutine move(x, c, n)
      integer x(3), n
      character c
      if (c.eq.'L') x(1) = x(1) - n
      if (c.eq.'R') x(1) = x(1) + n
      if (c.eq.'U') x(2) = x(2) - n
      if (c.eq.'D') x(2) = x(2) + n
      x(3) = x(3) + n
      return
      end


module SUNDMAN
! Description:
!    Contains the event functions for the regularized formulations when
!    integrated with the XRA15 solver, and auxiliary routines.
!
! Author:
!    Davide Amato
!    Space Dynamics Group - Technical University of Madrid
!    d.amato@upm.es
!
! ==============================================================================

use KINDS, only: dk,qk
implicit none

contains

function TIMETOUT(eqs,neq,tstar,s,x)
! Description:
!    Event function for output at a prescribed time using XRA15 with regularized
!    formulations. It computes the difference between the current time
!    (computed from the state vector of any regularized formulation) and the
!    output time tstar.
!
! ==============================================================================

use SETTINGS,  only: flag_time_EDr,flag_time_GDr
use TRANSFORM, only: DEDROMO_TE2TIME,DGDROMO_TE2TIME

! INPUTS
integer,intent(in)   ::  eqs,neq
real(dk),intent(in)  ::  s,tstar,x(1:neq)

! OUTPUT
real(dk)  ::  TIMETOUT

! LOCALS
real(dk)  ::  t

! ==============================================================================

select case (eqs)
  case(-2)
    TIMETOUT = x(5) - tstar
  case(2)
    TIMETOUT = x(10) - tstar
  case(3)
    ! Compute time from EDromo state and subtract to tstar
    t = DEDROMO_TE2TIME(x,s,flag_time_EDr)
    TIMETOUT = t - tstar
  case(4)
    ! Compute time from GDromo state and subtract to tstar
    t = DGDROMO_TE2TIME(x,s,flag_time_GDr)
    TIMETOUT = t - tstar
end select

contains

  function CSUM(add)
  ! Kahan's summation algorithm (AKA compensated summation).
  ! Ref: https://en.wikipedia.org/wiki/Kahan_summation_algorithm

  real(dk),intent(in) :: add(:)
  real(dk) :: CSUM
  real(dk) :: c,y,t,summ
  integer :: i,length

  length = size(add,1)
  c = 0._dk
  summ = 0._dk

  do i=1,length
    y = add(i) - c
    t = summ + y
    c = (t - summ) - y
    summ = t

  end do
  CSUM = summ

  end function CSUM

end function TIMETOUT

function DSUND(eqs,neq,s,x,xdot)
! Description:
!   Computes the value of dt/ds for the regularized formulations. It is a driver
!   subroutine calling DSUND_KS, DSUND_EDROMO, DSUND_GDROMO.
!
! ==============================================================================

! INPUTS
integer,intent(in)   ::  eqs,neq
real(dk),intent(in)  ::  s,x(1:neq),xdot(1:neq)
! OUTPUTS
real(dk)  ::  DSUND

select case (eqs)
  case(-2)
    DSUND = xdot(5)
  case(2)
    DSUND = DSUND_KS(neq,s,x)
  case(3)
    DSUND = DSUND_EDROMO(neq,s,x)
  case(4)
    DSUND = DSUND_GDROMO(neq,s,x)
end select

end function DSUND

function DDSUND(eqs,neq,s,x,xdot)
! Description:
!    Computes the value of d^2t/ds^2 for the regularized formulations. It is a
!    driver subroutine calling DDSUND_KS, DDSUND_EDROMO, DDSUND_GDROMO.
!
! ==============================================================================

! INPUTS
integer,intent(in)   ::  eqs,neq
real(dk),intent(in)  ::  s,x(1:neq),xdot(1:neq)
! OUTPUTS
real(dk)  ::  DDSUND

select case (eqs)
  case(-2)
    DDSUND = 2._dk*dot_product(x(1:4),xdot(1:4))
  case(2)
    DDSUND = DDSUND_KS(neq,s,x)
  case(3)
    DDSUND = DDSUND_EDROMO(neq,s,x,xdot)
  case(4)
    DDSUND = DDSUND_GDROMO(neq,s,x,xdot)
end select

end function DDSUND

function DSUND_KS(neq,s,u)
! Gives the value of dt/ds for the KS formulation.

! INPUTS
integer,intent(in)   ::  neq
real(dk),intent(in)  ::  s,u(1:neq)

! OUTPUT
real(dk)  ::  DSUND_KS

! ==============================================================================

DSUND_KS = dot_product(u(1:4),u(1:4))

end function DSUND_KS

function DSUND_EDROMO(neq,s,l)
! Description:
!    Gives the value of dt/ds for the EDromo formulation.
!
! ==============================================================================

! INPUTS
integer,intent(in)  :: neq
real(dk),intent(in) :: s,l(1:neq)

! OUTPUT
real(dk) :: DSUND_EDROMO

! LOCALS
real(dk) :: rho

! ==============================================================================

rho = 1._dk - l(1)*cos(s) - l(2)*sin(s)
DSUND_EDROMO = (l(3)**1.5_dk)*rho

end function DSUND_EDROMO

function DSUND_GDROMO(neq,s,l)
! Description:
!    Gives the value of dt/ds for the GDromo formulation.
!
! ==============================================================================

! INPUTS
integer,intent(in)  :: neq
real(dk),intent(in) :: s,l(1:neq)

! OUTPUT
real(dk) :: DSUND_GDROMO

! LOCALS
real(dk) :: rho

! ==============================================================================

rho = l(1)*cosh(s) + l(2)*sinh(s) - 1._dk
DSUND_GDROMO = (l(3)**1.5_dk)*rho

end function DSUND_GDROMO

function DDSUND_KS(neq,s,u)
! Description:
!    Gives the value of d^2t/ds^2 for the KS formulation.
!
! ==============================================================================

! INPUTS
integer,intent(in)   ::  neq
real(dk),intent(in)  ::  s,u(1:neq)

! OUTPUT
real(dk)  ::  DDSUND_KS

! ==============================================================================

DDSUND_KS = 2._dk*dot_product(u(1:4),u(5:8))

end function DDSUND_KS

function DDSUND_EDROMO(neq,s,l,ldot)
! Description:
!    Gives the value of d^2t/ds^2 for the EDromo formulation.
!
! ==============================================================================

! INPUTS
integer,intent(in)   ::  neq
real(dk),intent(in)  ::  s,l(1:neq),ldot(1:neq)

! OUTPUT
real(dk)  ::  DDSUND_EDROMO

! LOCALS
real(dk)  ::  cs,ss
real(dk)  ::  rho,zeta
real(dk)  ::  term_en,term_ecc

! ==============================================================================

cs = cos(s); ss = sin(s)

rho = 1._dk - l(1)*cs - l(2)*ss
zeta = l(1)*ss - l(2)*cs
term_en = 1.5_dk*sqrt(l(3))*rho*ldot(3)
term_ecc = (l(3)**1.5_dk)*(zeta - ldot(1)*cs - ldot(2)*ss)
DDSUND_EDROMO = term_en + term_ecc

end function DDSUND_EDROMO

function DDSUND_GDROMO(neq,s,l,ldot)
! Description:
!    Gives the value of d^2t/ds^2 for the GDromo formulation.
!
! ==============================================================================

! INPUTS
integer,intent(in)   ::  neq
real(dk),intent(in)  ::  s,l(1:neq),ldot(1:neq)

! OUTPUT
real(dk)  ::  DDSUND_GDROMO

! LOCALS
real(dk)  ::  chs,shs
real(dk)  ::  rho,zeta
real(dk)  ::  term_en,term_ecc

! ==============================================================================

chs = cosh(s); shs = sinh(s)

rho = l(1)*chs + l(2)*shs - 1._dk
zeta = l(1)*shs + l(2)*chs
term_en = 1.5_dk*sqrt(l(3))*rho*ldot(3)
term_ecc = (l(3)**1.5_dk)*(zeta + ldot(1)*chs + ldot(2)*shs)
DDSUND_GDROMO = term_en + term_ecc

end function DDSUND_GDROMO

end module SUNDMAN


!!! The Computer Language Benchmarks Game
!!!   http://shootout.alioth.debian.org/
!!!
!!!      contributed by George R. Gonzalez
!!!      fixed by Simon Geard

program mandelbrot
    IMPLICIT NONE
    INTEGER, PARAMETER                      :: WantedPrecision = 8, Iterations = 50
    INTEGER                                 :: w, h,   Len,   i
    INTEGER                                 :: y, x, LenOut, row
    REAL( WantedPrecision )                 :: limit, limit2
    REAL( WantedPrecision )                 :: rx, ry, rw, rh
    REAL( WantedPrecision )                 :: Zr, Zi, Cr, Ci, Tr, Ti
    REAL( WantedPrecision )                 :: zero, one, v1p5, two
    CHARACTER(10)                           :: NUM
    INTEGER(1), ALLOCATABLE, DIMENSION( : ) :: OUTA
    INTEGER                                 :: OUTP, OUTB, OutUnit
    INTEGER(1), ALLOCATABLE, DIMENSION( : ) :: OutBuf
    INTEGER(1)                              :: B
    LOGICAL                                 :: Ans
    CONTINUE
    OutUnit = 6
    Call GetArg( 1, NUM )
    READ( NUM, *, END = 100 ) w;  h = w;    rw = w; rh = h
    Len = w * h
    ALLOCATE( OUTA ( Len ) )
    OUTA = 0
    OUTB = 0;
    limit = 2.0; limit2 = limit * limit
    IF( w < 1000 ) THEN
        WRITE( UNIT = OutUnit, FMT = "( 'P4', /, I3, 1X, I3 )" ) w, h
    ELSE
        WRITE( UNIT = OutUnit, FMT = "( 'P4', /, I4, 1X, I4 )" ) w, h
    ENDIF

    DO y = 0,h-1
        ry = y

        DO x = 0,w-1
            rx = x;
            Zr = 0.0;Zi = 0.0;Tr = 0.0;Ti = 0.0;
            Cr = 2.0 * rx / rw - 1.5
            Ci = 2.0 * ry / rh - 1.0
            Ans = .TRUE.
            i = 0;
            OUTB = OUTB + 1

            DO WHILE(  i < Iterations   .AND.   Ans  )
                Zi    =       2.0 * Zr * Zi + Ci
                Zr    =       Tr - Ti + Cr
                Ti    =       Zi * Zi
                Tr    =       Zr * Zr
                i     =       i + 1
                Ans   =       Tr + Ti <= limit2
            END DO

            IF( Ans ) OUTA( OUTB ) = 1;
          END DO

    END DO

   LenOut = Len / 8 + 10 + h;
   ALLOCATE( OutBuf( LenOut ) )

   I = 0;  OUTP = 0; B = 0; row = 0

   DO WHILE( I < OUTB )
      I = I + 1
      B = ISHFT( B, 1 ) + OUTA( I )
      row = row + 1
      IF( IAND( I, 7 ) == 0 ) THEN
         OUTP = OUTP + 1
         OutBuf( OUTP ) = B;
         B              = 0
      ELSEIF(  row >= w - 1 ) THEN
         OUTP = OUTP + 1

         DO WHILE( IAND( I, 7 ) /= 0 )
            B = ISHFT( B, 1 )
            I = I + 1
         END DO

         OutBuf( OUTP ) = B;
         B              = 0
         row            = 0
      ENDIF
   ENDDO

   WRITE( OutUnit, FMT = "(10000000A1)" , advance='no') ( OutBuf(I),I=1,OUTP )

100     CONTINUE

end program mandelbrot


      PROGRAM TABLES
C
C     Produce a formatted multiplication table of the kind memorised by rote
C     when in primary school. Only print the top half triangle of products.
C
C     23 Nov 15 - 0.1   - Adapted from original for VAX FORTRAN - MEJT
C     24 Nov 15 - 0.2   - FORTRAN IV version adapted from VAX FORTRAN and
C                         compiled using Microsoft FORTRAN-80 - MEJT
C
      DIMENSION K(12)
      DIMENSION A(6)
      DIMENSION L(12)
C
      COMMON //A
      EQUIVALENCE (A(1),L(1))
C
      DATA A/'(1H ',',I2,','1H|,','01X,','I3,1','2I4)'/
C
      WRITE(1,1) (I,I=1,12)
    1 FORMAT(4H0  |,12I4,/,4H --+12(4H----))
C
C     Overlaying the format specifier with an integer array makes it possibe
C     to modify the number of blank spaces.  The number of blank spaces is
C     stored as two consecuitive ASCII characters that overlay on the
C     integer value in L(7) in the ordr low byte, high byte.
C
      DO 3 I=1,12
        L(7)=(48+(I*4-3)-((I*4-3)/10)*10)*256+48+((I*4-3)/10)
        DO 2 J=1,12
          K(J)=I*J
    2   CONTINUE
        WRITE(1,A)I,(K(J), J = I,12)
    3 CONTINUE
C
      END