***********************************************************************
* This file contains various functions for analysing different
* mathematical algorithms. The routines in this file are more
* or less independent of the actual CC2D software package,
* i.e. they are not required for a proper operation of the
* simulation. Instead they allow to analyse special aspects
* of different subroutines, i.e. prescribing an analytical
* solution in the calculation of drag- and lift-forces
* to analyse the accuracy of the calculation routines.
*
* The routines here are not planned of being modular - they are
* just indended to serve for some "quick-tests".
***********************************************************************

***********************************************************************
* User-defined analysis I
*
* Calls the drag/lift-calculation with a prescribed, analytical
* solution on the unit square to test its accuracy.
***********************************************************************

      SUBROUTINE UDAN01

      IMPLICIT NONE

      INCLUDE 'cmem.inc'
      INCLUDE 'cbasictria.inc'
      INCLUDE 'ctria.inc'

      INCLUDE 'cnspts.inc'

      INCLUDE 'cinidat.inc'
      INCLUDE 'ciniopt.inc'

      INCLUDE 'cout.inc'
      INCLUDE 'cfiles.inc'

      INCLUDE 'cbasicmg.inc'
      INCLUDE 'cmgpar.inc'
      INCLUDE 'cmgadr.inc'

      EXTERNAL EXXXNC

C local variables

      INTEGER LUP,I
      DOUBLE PRECISION DFWX, DFWY,DARCLN
      INTEGER NESTAT(5)
      INTEGER IFPOST,IFILEN,ITFILM

      EXTERNAL UE,UDAAF1,UDAAF2,UDAAF3

C Prescribe solutions

      CALL PTSDAT(0D0,DBLE(NY))

      ILEV=NLMAX
      I=2
      CALL SETLEV(I)

      CALL UDAA01 (DWORK(L(LCORMG)),KWORK(L(LMID)),DWORK(KU1),
     *             DWORK(KU2),DWORK(KP))

C Evaluate drag/lift

      DFWX = 0D0
      DFWY = 0D0

C      CALL  BDFVLG(DWORK(L(LU)),DWORK(L(LV)),DWORK(L(LP)),
C     *    DWORK(L(LCORVG)),KWORK(L(LVERT)),
C     *    DWORK(L(LCORMG)),KWORK(L(LMID)),KWORK(L(LNPR)),NEL,NVE,NVT,NBCT,
C     *    EXXXNC,.FALSE.,DFWX,DFWY,DPF(1),DPF(2),NESTAT,0,DVIARX)

C      CALL  BDFVLG(DWORK(L(LU)),DWORK(L(LV)),DWORK(L(LP)),
C     *    DWORK(L(LCORVG)),KWORK(L(LVERT)),
C     *    DWORK(L(LCORMG)),KWORK(L(LMID)),KWORK(L(LNPR)),NEL,NVE,NVT,NBCT,
C     *    EXXXNC,.FALSE.,DFWX,DFWY,1D0,1D0,NESTAT,0,DVIARX)

C Use DPF1=1D0, DPF2=2D0 - then it holds:
C  cD = 2*FD/DPF2 = FD
C  cL = 2*FL/DPF2 = FL
C i.e. the drag/lift coefficients are the drag/lift forces and thus can be
C compared with analytical calculated values.

      CALL  BDFVLG(DWORK(KU1),DWORK(KU2),DWORK(KP),DWORK(L(LCORVG)),
     *    KWORK(L(LVERT)),DWORK(L(LCORMG)),KWORK(L(LMID)),
     *    KWORK(L(LNPR)),NEL,NVE,NVT,NBCT,
     *    EXXXNC,(IELT.EQ.2).OR.(IELT.EQ.3),
     *    DFWX,DFWY,1D0,2D0,NESTAT,0,DVIARX)

      PRINT *,'Drag vol-int. :  ',DFWX
      PRINT *,'Lift vol-int. :  ',DFWY

      DFWX=0D0

      CALL AFBVOL (KWORK(L(LVERT)),KWORK(L(LMID)),
     *               DWORK(L(LCORVG)),EXXXNC,8,0,DFWX)
      PRINT *,'AREA vol-int. :  ',DFWX

      DFWX=0D0
      DFWY=0D0

      CALL  BDARCL(DWORK(L(LCORVG)),KWORK(L(LVERT)),
     *          DWORK(L(LCORMG)),KWORK(L(LMID)),KWORK(L(LNPR)),
     *          NEL,NVE,NVT,NBCT,EXXXNC,0,DFWX, DARCLN,DVIARX,0,0)
      ! call not correct!!!

      PRINT *,'ARCL vol-int. :  ',DFWX

      DFWX=0D0
      DFWY=0D0

      CALL  BDFRIG(DWORK(KU1),DWORK(KU2),DWORK(KP),
     *    DWORK(L(LCORVG)),KWORK(L(LVERT)),DWORK(L(LCORMG)),
     *    KWORK(L(LMID)),KWORK(L(LNPR)),NEL,NVE,EXXXNC,
     *    (IELT.EQ.2).OR.(IELT.EQ.3),
     *    DFWX,DFWY,1D0,2D0,0)

      PRINT *
      PRINT *,'Drag line-int.:  ',DFWX
      PRINT *,'Lift line-int.:  ',DFWY
      PRINT *,'ARCL line-int.:  ',DARCLN

      PRINT *

C Analytically compute the 1-function on the interface.
C Should give the arc length:

      CALL UDAN03 (UDAAF1,0,DWORK(L(LCORVG)),KWORK(L(LVERT)),
     *          DWORK(L(LCORMG)),KWORK(L(LMID)),KWORK(L(LNPR)),NEL,
     *          NVE,EXXXNC,(IELT.EQ.2).OR.(IELT.EQ.3),DFWX)

      PRINT *,'ARCL anal. l.i.: ',DFWX

C Calculate the drag with the help of a reference
C function. Should differ from the analytical solution only
C by the effects of the cubature formula:

      CALL UDAN03 (UDAAF2,0,DWORK(L(LCORVG)),KWORK(L(LVERT)),
     *          DWORK(L(LCORMG)),KWORK(L(LMID)),KWORK(L(LNPR)),NEL,
     *          NVE,EXXXNC,(IELT.EQ.2).OR.(IELT.EQ.3),DFWX)

      PRINT *,'drag anal. l.i.: ',DFWX

C Calculate the lift with the help of a reference
C function. Should differ from the analytical solution only
C by the effects of the cubature formula:

      CALL UDAN03 (UDAAF3,0,DWORK(L(LCORVG)),KWORK(L(LVERT)),
     *          DWORK(L(LCORMG)),KWORK(L(LMID)),KWORK(L(LNPR)),NEL,
     *          NVE,EXXXNC,(IELT.EQ.2).OR.(IELT.EQ.3),DFWX)

      PRINT *,'lift anal. l.i.: ',DFWX

      IFPOST=1
      IFILEN=0
      ITFILM=0
      CALL FPOST(IFPOST,IFILEN,ITFILM,UE,MT,DFWX,DFWY,0,'')

C      PRINT *,'Drag2: ',DFWX
C      PRINT *,'Lift2: ',DFWY

C      CALL UDAN02(DWORK(KU1),DWORK(KU2),DWORK(KP),
C     *            KWORK(L(LVERT)),KWORK(L(LMID)),DWORK(L(LCORVG)),
C     *            EXXXNC,DFWX,DFWY)

C      PRINT *,'Drag appr. l.i. old: ',DFWX
C      PRINT *,'Lift appr. l.i. old: ',DFWY

      STOP

      END

***********************************************************************
* User-defined auxiliary routine I
*
* Set the values of velocity/pressure to analytical values.
*
* Warning: INTPOL overwrites dirichlet boundary values by reference
* solution for GMV-output, so when using this routine, disable
* the overwriting of the boundary values in the call to this
* subroutine - otherwise the boundary looks strange in GMV-files ;)
***********************************************************************

      SUBROUTINE UDAA01 (DCORMG,KMID,U,V,P)

      IMPLICIT NONE

      INCLUDE 'cbasictria.inc'
      INCLUDE 'ctria.inc'

C parameters

      DOUBLE PRECISION U(*),V(*),P(*),DCORMG(2,*)
      INTEGER KMID(NNVE,*)

C Reference function on the unit square:

      DOUBLE PRECISION X,Y,UF,VF,PF

      UF(X,Y) = y*(1D0-x)*(0D0-x)*(1D0-y)*(0D0-y)*exp(x)
C x*(1-x)*exp(x)
C
      VF(X,Y) = -x*(1D0-x)*(0D0-x)*(1D0-y)*(0D0-y)*exp(y)
C y*(1-y)*exp(y)
C
      PF(X,Y) = x

C local variables

      INTEGER IVT,I,IEL

      DO IVT=1,NMT
        U(IVT) = UF(DCORMG(1,IVT),DCORMG(2,IVT))
        V(IVT) = VF(DCORMG(1,IVT),DCORMG(2,IVT))
      END DO

      DO IEL=1,NEL
        X=0D0
        Y=0D0
        DO I=1,4
          X = X+DCORMG(1,KMID(I,IEL)-NVT)
          Y = Y+DCORMG(2,KMID(I,IEL)-NVT)
        END DO
        X=0.25D0*X
        Y=0.25D0*Y
        P(IEL) = PF(X,Y)
      END DO

      END

************************************************************************
*    Purpose:  Calculates lift (DFW) and drag (DAW)
*    by integration along reconstructed interface
*-----------------------------------------------------------------------
      SUBROUTINE UDAN02(DU1,DU2,DP,KVERT,KMID,DCORVG,ELE,
     *                  DFW,DAW)
      IMPLICIT NONE

      INCLUDE 'cout.inc'
      INCLUDE 'cerr.inc'

      INCLUDE 'ccub.inc'

      INCLUDE 'cbasictria.inc'
      INCLUDE 'ctria.inc'

      INCLUDE 'cbasicelem.inc'
      INCLUDE 'celem.inc'

      INCLUDE 'casmbly.inc'

      INCLUDE 'cnspts.inc'

C parameters

      DOUBLE PRECISION DU1(*),DU2(*),DP(*),DCORVG(2,*),DFW,DAW
      INTEGER KVERT(NNVE,*),KMID(NNVE,*)
      EXTERNAL ELE

C externals

      INTEGER NDFL
      EXTERNAL NDFL

C local variables

      INTEGER IELTYP,IW1,IW2,IVBD,IVT,IVT1,IVT2,ISTOP,II,IVBD1
      INTEGER IVE,JP,JDFL,IEDGE1,IEDGE2
      LOGICAL BFOUND
      DOUBLE PRECISION DLEN,PX1,PX2,PY1,PY2,PXM,PYM,DLH
      DOUBLE PRECISION DTX,DTY,DNX,DNY,DPCONT,XX,YY,DUT

      DFW=0D0
      DAW=0D0
      DLEN=0D0

      IF ((DPF(1).EQ.0D0).OR.(DPF(2).EQ.0D0)) RETURN

      BDER(1)=.TRUE.
      BDER(2)=.TRUE.
      BDER(3)=.TRUE.

      IELTYP=-1
      CALL ELE(0D0,0D0,IELTYP)
      IDFL=NDFL(IELTYP)

      NCUBP=1
      ICUBP=1

      IW1=1
      IW2=1

      DO 100 IEL=1,NEL
      IF (ISTOP.EQ.1) GOTO 1000

      CALL RCFBLI (DCORVG, KVERT, IEL, 8, 0, .FALSE.,
     *             PX1,PY1, IEDGE1, PX2,PY2, IEDGE2, BFOUND,0,0)
C     Call not correct!!!

      IF (.NOT.BFOUND) GOTO 100

      PXM=0.5D0*(PX1+PX2)
      PYM=0.5D0*(PY1+PY2)
      DLH=DSQRT((PX2-PX1)**2+(PY2-PY1)**2)

      DTX= (PX2-PX1)/DLH
      DTY= (PY2-PY1)/DLH
      DNX=-(PY2-PY1)/DLH
      DNY= (PX2-PX1)/DLH
      DPCONT=DP(IEL)
      DLEN=DLEN+DLH

      CALL NDFGL(IEL,1,IELTYP,KVERT,KMID,KDFG,KDFL)

      DO 120 IVE = 1,4
      JP=KVERT(IVE,IEL)
      KVE(IVE)=JP
      DX(IVE)=DCORVG(1,JP)
      DY(IVE)=DCORVG(2,JP)
120   CONTINUE

      XX=PXM
      YY=PYM

      CALL ELE(0D0,0D0,-2)
      CALL ELE(XX,YY,-3)

      DUT=0
      DO 130 JDFL=1,IDFL
      DUT=DUT+DU1(KDFG(JDFL))*DBAS(KDFL(JDFL),2)*DTX*DNX
     *       +DU2(KDFG(JDFL))*DBAS(KDFL(JDFL),2)*DTY*DNX
     *       +DU1(KDFG(JDFL))*DBAS(KDFL(JDFL),3)*DTX*DNY
     *       +DU2(KDFG(JDFL))*DBAS(KDFL(JDFL),3)*DTY*DNY
130   CONTINUE

      DFW=DFW+DLH*(DPF(1)*DUT*DNY-DPCONT*DNX)
      DAW=DAW-DLH*(DPF(1)*DUT*DNX+DPCONT*DNY)

100   CONTINUE

1000  DFW=2D0*DFW/DPF(2)
      DAW=2D0*DAW/DPF(2)
99999 END

************************************************************************
* The following routine is a modification of BDFRIG.
* It performs a line integration with a given function
* along the interface of the fictitious boundary components.
*
* This is done for testing. E.g. if the fictitious boundary is a circle,
* by inserting the function 1 the arc length of the circle should be
* calculated - if the fictitious boundary routines support exact
* reconstruction of the cubature points and weights along the
* interface.
*
* In:
*  CLDERP - Calculate function value in specific point
*  IFBC   - fictitious boundary component along which interface
*           should be integrated
*
* Out:
*  Returns the value of the integral in DVAL.
*
* ELE must be the current element, although it's not used for the
* real calculation - we perform a user-defined-only calculation.
*
* The caller has to provide the following function:
*
* SUBROUTINE CLDERP (IINFO,NIINFO,DINFO,NDINFO,DU1,DU2,DP,
*                    XX,YY,XX1,YY1,ICUBP,IELEM,ELE,BNONPR)
* --------------------------------------------------------------------
* INTEGER NIINFO,IINFO(NIINFO),NDINFO,IELEM,ICUBP
* LOGICAL BNONPR
* DOUBLE PRECISION DINFO(NDINFO),DU1(*),DU2(*),DP(*)
* DOUBLE PRECISION XX,YY,XX1,YY1
* EXTERNAL ELE
*  -> Is called once for each cubature point
*  -> Must calculate the function value in the
*     cubature point (XX,YY) on the real or (XX1,YY1) on the
*     reference element, respectively.
*  -> ICUBP = number of current cubature point on
*  -> IELEM = number of current element
*  -> The function has to store the function value in DINFO(1).
*  -> IINFO = number of fictitious boundary component that is
*     currently being analyzed.
*  -> DU1,DU2,DP is not used
*  -> For a description of the other parameters,
*     look at the documentation of the CVDERP function that has to
*     be provided to VOLINT or LININT.
************************************************************************

      SUBROUTINE UDAN03 (CLDERP,IFBC,DCORVG,KVERT,DCORMG,KMID,KNPR,NEL,
     *                   NVE,ELE,BNONPR,DVAL)
      IMPLICIT NONE

      INCLUDE 'cout.inc'
      INCLUDE 'cerr.inc'
      INCLUDE 'cmem.inc'

      INCLUDE 'cbasictria.inc'

      INCLUDE 'cbasicelem.inc'
      INCLUDE 'celem.inc'

      INCLUDE 'casmbly.inc'

      INCLUDE 'cmgadr.inc'

      INCLUDE 'ccub.inc'

C parameters
      DOUBLE PRECISION DCORVG(2,*),DCORMG(2,*)
      INTEGER KNPR(*),KVERT(NNVE,*),KMID(NNVE,*),IFBC,NEL,NVE
      DOUBLE PRECISION DVAL
      LOGICAL BNONPR

C externals - we partially use the routines of BDFRIG

      EXTERNAL ELE
      EXTERNAL UDAAIN,I000,CLDERP,UDAASM,CLGTLN,CLPRBD

C local variables

      DOUBLE PRECISION DU1,DU2,DP

C Structure of DINFO:
C   double function value
C   double integral value
C   double LineStart [2]
C   double LineEnd [2]
C
C Structure of LINFO
C   int     Current Fictitious boundary component

      DOUBLE PRECISION DINFO(6)
      INTEGER IINFO(1)

C In IINFO(1) holds the desired fictitious boundary number:

      IINFO(1) = IFBC

      CALL LININT (DU1,DU2,DP,DCORVG,KVERT,DCORMG,KMID,
     *    NEL,NVE,ELE,BNONPR,3,
     *    IINFO, 1, DINFO, 6,
     *    UDAAIN,I000,CLDERP,UDAASM,I000,CLGTLN,CLPRBD,.TRUE.,0,0)
C     Call not correct!!!

C Obtain the value:

      DVAL = DINFO(2)

99999 END

************************************************************************
* Line-integration callback-routines
************************************************************************

************************************************************************
* Initialisation
************************************************************************
      SUBROUTINE UDAAIN(IINFO,NIINFO,DINFO,NDINFO,DU1,DU2,DP,ELE,BNONPR)

      IMPLICIT NONE

C parameters

      INTEGER NIINFO,IINFO(NIINFO),NDINFO
      LOGICAL BNONPR
      DOUBLE PRECISION DINFO(NDINFO),DU1(*),DU2(*),DP(*)
      EXTERNAL ELE

C initialise values with 0

      DINFO(1) = 0D0
      DINFO(2) = 0D0

      END

************************************************************************
* Summing up the values from the cubature point to the values of
* interest.
************************************************************************
      SUBROUTINE UDAASM(IINFO,NIINFO,DINFO,NDINFO,DU1,DU2,DP,
     *                  DETJ,ICUBP,IELEM,OMEGA,
     *                  DU1V,DU1X,DU1Y,DU2V,DU2X,DU2Y,DPV)

      IMPLICIT NONE

      INCLUDE 'cmem.inc'
      INCLUDE 'cbasicelem.inc'
      INCLUDE 'casmbly.inc'

C parameters

      INTEGER NIINFO,IINFO(NIINFO),NDINFO,ICUBP,IELEM
      DOUBLE PRECISION DINFO(NDINFO),DU1(*),DU2(*),DP(*)
      DOUBLE PRECISION DETJ,OMEGA
      DOUBLE PRECISION DU1V,DU1X,DU1Y,DU2V,DU2X,DU2Y,DPV

C Multiply the value with the weight and add it to the integral value

      DINFO(2) = DINFO(2) + DINFO(1)*OMEGA

      END

************************************************************************
* Function to integrate
*
* 1-function - should give the arc length of the fictitious boundary.
************************************************************************

      SUBROUTINE UDAAF1 (IINFO,NIINFO,DINFO,NDINFO,DU1,DU2,DP,
     *                  XX,YY,XX1,YY1,ICUBP,IELEM,ELE,BNONPR)
      IMPLICIT NONE
      INTEGER NIINFO,IINFO(NIINFO),NDINFO,IELEM,ICUBP
      LOGICAL BNONPR
      DOUBLE PRECISION DINFO(NDINFO),DU1(*),DU2(*),DP(*)
      DOUBLE PRECISION XX,YY,XX1,YY1
      EXTERNAL ELE

      DINFO(1) = 1D0

      END

************************************************************************
* Function to integrate
*
* Drag-reference-function.
* Should calculate the reference drag-force f_D.
************************************************************************

      SUBROUTINE UDAAF2 (IINFO,NIINFO,DINFO,NDINFO,DU1,DU2,DP,
     *                   XX,YY,XX1,YY1,ICUBP,IELEM,ELE,BNONPR)
      IMPLICIT NONE
      INTEGER NIINFO,IINFO(NIINFO),NDINFO,IELEM,ICUBP
      LOGICAL BNONPR
      DOUBLE PRECISION DINFO(NDINFO),DU1(*),DU2(*),DP(*)
      DOUBLE PRECISION XX,YY,XX1,YY1
      EXTERNAL ELE

C Reference function on the unit square:

      DOUBLE PRECISION X,Y,UF,VF,PF,UFX,VFX,PFX,UFY,VFY,PFY

C Reference function prescribed on the unit square,
C together with their X- any Y-derivative

      UF(X,Y) = y*(1D0-x)*(0D0-x)*(1D0-y)*(0D0-y)*exp(x)
      VF(X,Y) = -x*(1D0-x)*(0D0-x)*(1D0-y)*(0D0-y)*exp(y)
      PF(X,Y) = x

      UFX(X,Y) = -y**2*x*(1-y)*exp(x)+y**2*(1-x)*(1-y)*exp(x)+
     *           y**2*(1-x)*x*(1-y)*exp(x)
      VFX(X,Y) = -2*x*(1-x)*(1-y)*y*exp(y)+x**2*(1-y)*y*exp(y)
      PFX(X,Y) = 1

      UFY(X,Y) = 2*y*(1-x)*x*(1-y)*exp(x)-y**2*(1-x)*x*exp(x)
      VFY(X,Y) = x**2*(1-x)*y*exp(y)-x**2*(1-x)*(1-y)*exp(y)-
     *           x**2*(1-x)*(1-y)*y*exp(y)
      PFY(X,Y) = 0

C local variables

      DOUBLE PRECISION DN1,DN2,AH1,AH2,DPF1,DPF2,DN
      DOUBLE PRECISION DT1,DT2,DUT
      DOUBLE PRECISION X1,Y1,X2,Y2
      DOUBLE PRECISION DU1V,DU2V,DPV,DU1X,DU1Y,DU2X,DU2Y,DPX,DPY
      INTEGER JDFL

C Calculate the function- and derivative values in the current
C cubature point:

      DU1V = UF(XX,YY)
      DU2V = VF(XX,YY)
      DPV = PF(XX,YY)

      DU1X = UFX(XX,YY)
      DU2X = VFX(XX,YY)
      DPX = PFX(XX,YY)

      DU1Y = UFY(XX,YY)
      DU2Y = VFY(XX,YY)
      DPY = PFY(XX,YY)

C Prescribe DPF1/DPF2 such that the drag coefficient c_D calculates
C to the drag force f_D.

      DPF1 = 1D0
      DPF2 = 2D0

C At first build the normal vector of the fictitious boundary component
C with the analytical prescription:

      CALL FBDNML (XX,YY,IINFO(1),DN1,DN2)

C Turn it around to get the (normalised) tangential vector:

      DT1 = DN2
      DT2 = -DN1

C Calculate the force vector. This is defined as:
C
C (FD) = int ( sigma * alpha ) dx
C (FL)    V
C
C There are now different possibilities about that sigma.
C The original and most correct formulation is the following, which
C is also known as "deformation formulation":
C
C     sigma = -p*I + dpf1*[ grad(u) + grad(u)^T ]
C
C Unfortunately this gives not the best results in the benchmark
C tests. Another formulation is the following, which is also called
C "gradient formulation":
C
C     sigma = -p*I + dpf1*[ grad(u) ]
C
C This can be used in the case that div(u)=0 - in this case
C the strong formulation of the Navier Stokes Equation, which
C can be derived using this sigma, are the same because of
C                 0 = div_h(u) = grad_h(u)^T
C for the discretised matrices!
C
C In case of line integrals there's a third possibility how to
C define that integral. This possibility was that one which was
C proposed in the original paper where the DFG-benchmark was proposed.
C It should be equivalent with the avove formulation, but to be
C honest, we haven't found out why...:
C
C     sigma = -p*I + dpf1 * [ Du_T/Dn_S ] * n
C           = -p*I + dpf1 * <Du*n,t> * t
C
C with n the normal vector and t the tangential vector to the surface.
C
C Unfortunately using nonconforming finite elements the deformation
C formulation does not give very accurate results, the results with
C the gradient formulation are much better. This is not true anymore
C if other finite elements are used: Using Q2 the deformation
C formulation gives far better results!
C
C The third method was the original method used by FeatFlow for
C line integrals around a non-fictitious boundary components.
C For fictitious boundary components it should give roughly the
C same result as the deformation formulation...

C Implementation of the deformation formulation of the stress tensor:

      AH1 = -DPV*DN1 + DPF1*(2*DU1X*DN1+(DU2X*DN2+DU1Y*DN2))
      AH2 = -DPV*DN2 + DPF1*((DU2X*DN1+DU1Y*DN1)+2*DU2Y*DN2)

C Implementation of the gradient formulation of the stress tensor:

C      AH1=-DPV*DN1 + DPF1*(DU1X*DN1+DU1Y*DN2)
C      AH2=-DPV*DN2 + DPF1*(DU2X*DN1+DU2Y*DN2)

C Implementation of the surface integral with the help of tangential
C vectors:

C      DUT = (DU1X*DN1+DU1Y*DN2)*DT1 + (DU2X*DN1+DU2Y*DN2)*DT2
C      AH1 = -DPV*DN1 + DPF1*(DUT*DT1)
C      AH2 = -DPV*DN2 + DPF1*(DUT*DT2)

C Store the drag value for the summation

      DINFO(1)=AH1

      END

************************************************************************
* Function to integrate
*
* Lift-reference-function.
* Should calculate the reference drag-force f_D.
************************************************************************

      SUBROUTINE UDAAF3 (IINFO,NIINFO,DINFO,NDINFO,DU1,DU2,DP,
     *                   XX,YY,XX1,YY1,ICUBP,IELEM,ELE,BNONPR)
      IMPLICIT NONE
      INTEGER NIINFO,IINFO(NIINFO),NDINFO,IELEM,ICUBP
      LOGICAL BNONPR
      DOUBLE PRECISION DINFO(NDINFO),DU1(*),DU2(*),DP(*)
      DOUBLE PRECISION XX,YY,XX1,YY1
      EXTERNAL ELE

C Reference function on the unit square:

      DOUBLE PRECISION X,Y,UF,VF,PF,UFX,VFX,PFX,UFY,VFY,PFY

C Reference function prescribed on the unit square,
C together with their X- any Y-derivative

      UF(X,Y) = y*(1D0-x)*(0D0-x)*(1D0-y)*(0D0-y)*exp(x)
      VF(X,Y) = -x*(1D0-x)*(0D0-x)*(1D0-y)*(0D0-y)*exp(y)
      PF(X,Y) = x

      UFX(X,Y) = -y**2*x*(1-y)*exp(x)+y**2*(1-x)*(1-y)*exp(x)+
     *           y**2*(1-x)*x*(1-y)*exp(x)
      VFX(X,Y) = -2*x*(1-x)*(1-y)*y*exp(y)+x**2*(1-y)*y*exp(y)
      PFX(X,Y) = 1

      UFY(X,Y) = 2*y*(1-x)*x*(1-y)*exp(x)-y**2*(1-x)*x*exp(x)
      VFY(X,Y) = x**2*(1-x)*y*exp(y)-x**2*(1-x)*(1-y)*exp(y)-
     *           x**2*(1-x)*(1-y)*y*exp(y)
      PFY(X,Y) = 0

C local variables

      DOUBLE PRECISION DN1,DN2,AH1,AH2,DPF1,DPF2,DN
      DOUBLE PRECISION DT1,DT2,DUT
      DOUBLE PRECISION X1,Y1,X2,Y2
      DOUBLE PRECISION DU1V,DU2V,DPV,DU1X,DU1Y,DU2X,DU2Y,DPX,DPY
      INTEGER JDFL

C Calculate the function- and derivative values in the current
C cubature point:

      DU1V = UF(XX,YY)
      DU2V = VF(XX,YY)
      DPV = PF(XX,YY)

      DU1X = UFX(XX,YY)
      DU2X = VFX(XX,YY)
      DPX = PFX(XX,YY)

      DU1Y = UFY(XX,YY)
      DU2Y = VFY(XX,YY)
      DPY = PFY(XX,YY)

C Prescribe DPF1/DPF2 such that the drag coefficient c_D calculates
C to the drag force f_D.

      DPF1 = 1D0
      DPF2 = 2D0

C At first build the normal vector of the fictitious boundary component
C with the analytical prescription:

      CALL FBDNML (XX,YY,IINFO(1),DN1,DN2)

C Turn it around to get the (normalised) tangential vector:

      DT1 = DN2
      DT2 = -DN1

C Calculate the force vector. This is defined as:
C
C (FD) = int ( sigma * alpha ) dx
C (FL)    V
C
C There are now different possibilities about that sigma.
C The original and most correct formulation is the following, which
C is also known as "deformation formulation":
C
C     sigma = -p*I + dpf1*[ grad(u) + grad(u)^T ]
C
C Unfortunately this gives not the best results in the benchmark
C tests. Another formulation is the following, which is also called
C "gradient formulation":
C
C     sigma = -p*I + dpf1*[ grad(u) ]
C
C This can be used in the case that div(u)=0 - in this case
C the strong formulation of the Navier Stokes Equation, which
C can be derived using this sigma, are the same because of
C                 0 = div_h(u) = grad_h(u)^T
C for the discretised matrices!
C
C In case of line integrals there's a third possibility how to
C define that integral. This possibility was that one which was
C proposed in the original paper where the DFG-benchmark was proposed.
C It should be equivalent with the avove formulation, but to be
C honest, we haven't found out why...:
C
C     sigma = -p*I + dpf1 * [ Du_T/Dn_S ] * n
C           = -p*I + dpf1 * <Du*n,t> * t
C
C with n the normal vector and t the tangential vector to the surface.
C
C Unfortunately using nonconforming finite elements the deformation
C formulation does not give very accurate results, the results with
C the gradient formulation are much better. This is not true anymore
C if other finite elements are used: Using Q2 the deformation
C formulation gives far better results!
C
C The third method was the original method used by FeatFlow for
C line integrals around a non-fictitious boundary components.
C For fictitious boundary components it should give roughly the
C same result as the deformation formulation...

C Implementation of the deformation formulation of the stress tensor:

      AH1 = -DPV*DN1 + DPF1*(2*DU1X*DN1+(DU2X*DN2+DU1Y*DN2))
      AH2 = -DPV*DN2 + DPF1*((DU2X*DN1+DU1Y*DN1)+2*DU2Y*DN2)

C Implementation of the gradient formulation of the stress tensor:

C      AH1=-DPV*DN1 + DPF1*(DU1X*DN1+DU1Y*DN2)
C      AH2=-DPV*DN2 + DPF1*(DU2X*DN1+DU2Y*DN2)

C Implementation of the surface integral with the help of tangential
C vectors:

C      DUT = (DU1X*DN1+DU1Y*DN2)*DT1 + (DU2X*DN1+DU2Y*DN2)*DT2
C      AH1 = -DPV*DN1 + DPF1*(DUT*DT1)
C      AH2 = -DPV*DN2 + DPF1*(DUT*DT2)

C Store the drag value for the summation

      DINFO(1)=AH2

      END

***********************************************************************
* User-defined analysis 4
*
* Calculates the nodal velocity from two grids. The routine accepts
* two deformed grids TRIA1 and TRIA2, which are snapshots at different
* points in time of the simulation. DT is the time difference between
* the snapshots. UDAN04 will subtract the node positions and divide it
* by DT to get a first order approximation of the velocity of the
* nodes.
*
* In:
*   TRIA1   - STRIA-structure for the first grid
*   TRIA2   - STRIA-structure for the second grid; must be structured
*             the same way as TRIA1.
*   DT      - double
*             Time
*
* Out:
*   DU       - array [1..NVT] of double
*              Absolute node velocity
*   DUX      - array [1..NVT] of double
*              Node-velocity, X-component
*   DUY      - array [1..NVT] of double
*              Node-velocity, Y-component
*
* NVT is taken from the grid-structure!
***********************************************************************

      SUBROUTINE UDAN04 (TRIA1, TRIA2, DT,
     *                   DU, DUX, DUY)

      IMPLICIT NONE

      INCLUDE 'stria.inc'
      INCLUDE 'cmem.inc'

      DOUBLE PRECISION DT,DU(*),DUX(*),DUY(*)
      INTEGER TRIA1(SZTRIA),TRIA2(SZTRIA)

      INTEGER I,DCRVG1,DCRVG2

      DCRVG1 = L(TRIA1(OLCORVG))
      DCRVG2 = L(TRIA2(OLCORVG))
      DO I=0,TRIA1(ONVT)-1
        DUX (1+I) = (DWORK(DCRVG2+2*I)-DWORK(DCRVG1+2*I)) / DT
        DUY (1+I) = (DWORK(DCRVG2+2*I+1)-DWORK(DCRVG1+2*I+1)) / DT
        DU (1+I) = SQRT(DUX(1+I)**2+DUY(1+I)**2)
      END DO

      END


module MaterialMod
  ! -------------------------------------------------------------------------------------------------------------------
  ! Mai 2018
  ! Maxime Tousignant
  ! maxime.tousignant@polymtl.ca
  ! -------------------------------------------------------------------------------------------------------------------
  ! Description :
  ! Calcul de la loi de comportement des materiaux magnetiques et gestion de l'historique pour l'hysteresis.
  !
  ! Ce module permet de modeliser trois types de courbes BH :
  ! 1 : lineaire permeabilite relative constante
  !     bh(1) = mattype
  !     bh(2) = mur
  ! 2 : non lineaire modele arctangente
  !     bh(1) = mattype
  !     bh(2) = murmax
  !     bh(3) = bsat
  ! 3 : non lineaire hysteretique modele de Preisach a 3n coefficients
  !     bh(1) = mattype
  !     bh(2) = natan
  !     bh(:) = ai
  !     bh(:) = bi
  !     bh(:) = ci
  ! -------------------------------------------------------------------------------------------------------------------

  ! Modules
  use ElementMod
  use ErrorMod

  ! Constantes
  ! Pi
  double precision, parameter, private                      :: pi         = 3.1415926535897932d+00
  ! Permeabilite du vide
  double precision, parameter, private                      :: mu0        = 1.2566370614359172d-06

  ! Nombre maximal de parametres pour la courbe BH
  integer, parameter                                        :: maxParam   = 256
  integer, parameter                                        :: maxAtan    = 5

  ! Nombre de points total
  integer, private                                          :: nPtsTot

  ! Historique de Preisach
  integer, parameter, private                               :: maxHistLen = 256
  ! Nombre de points dans l'historique
  integer, dimension(:), allocatable, private               :: nHist
  ! Contient prevG et partialM
  double precision, dimension(:,:), allocatable, private    :: dHist
  ! Contient les alpha
  double precision, dimension(:,:), allocatable, private    :: dHistA
  ! Contient les beta
  double precision, dimension(:,:), allocatable, private    :: dHistB

  ! Routine et fonctions privees
  private                                                   :: GetPreisachParameters
  private                                                   :: CalculPreisachBH
  private                                                   :: CalculFG
  private                                                   :: CalculFG4param
  private                                                   :: Everett
  private                                                   :: dEverettda
  private                                                   :: dEverettdb
  private                                                   :: EverettEllipse
  private                                                   :: dEverettEllipseda
  private                                                   :: dEverettEllipsedb

  contains
  ! -------------------------------------------------------------------------------------------------------------------
  subroutine InitializeMaterial (ne , bh , err)
    ! Description :
    ! Calcul de parametres supplementaires necessaires aux modeles.
    ! Initialisation de l'historique pour le modele de Preisach.
    implicit none
    ! Inputs :
    ! Nombre d'elements
    integer, intent(in)                                     :: ne
    ! Inout :
    ! Parametres de la courbe BH
    double precision, dimension(maxParam), intent(inout)    :: bh
    ! Indicateur d'erreur
    integer, intent(out)                                    :: err

    ! Variables :
    Integer                                                 :: i, ptr
    integer                                                 :: mattype
    ! Modele de Preisach
    integer                                                 :: natan
    double precision, dimension(maxAtan)                    :: ai, bi, ci
    double precision                                        :: muFmax, bsat, brem

    !Ellipse
    double precision                                        :: a, b, alpha, Hmax

    ! Erreur
    character(len=maxStrLen)                                :: from, message

    ! initialisation
    from = "InitializeMaterial"
    message = " "

    ! Type de courbe BH
    mattype = nint(bh(1))

    ! Nombre de pts total
    nPtsTot = ne*(nGauss+degPsi) + 1

    ! Verification des parametres de base et calcul des parametres supplementaires
    ! 1 : lineaire permeabilite relative constante
    if ( mattype == 1 ) then
      if ( bh(2) < 1.0d0 ) then
        err = 1
        message = "mur doit etre > 1."
        call Error (from,message )
        return
      end if

    ! 2 : non lineaire modele arctangente
    else if ( mattype == 2 ) then
      if ( bh(2) < 1.0d0 ) then
        err = 1
        message = "murmax doit etre > 1."
        call Error (from,message )
        return
      end if
      if ( bh(3) < epsilon(1.0d0) ) then
        err = 1
        message = "Bsat doit etre > 0."
        call Error (from,message )
        return
      end if
      bh(4) = 2.0d0*bh(3)/pi
      bh(5) = 0.5d0*pi*mu0*(bh(2)-1.0d0)/bh(3)

    ! 3 : non lineaire hysteretique modele de Preisach a 3n coefficients
    else if ( mattype == 3 ) then

      ! Recuperation de ntanh, ai, bi, ci
      call GetPreisachParameters (bh , natan,ai,bi,ci,muFmax,brem,bsat)

      brem = 0.0d0
      bsat = 0.0d0
      do i = 1, natan
        if ( bi(i) < epsilon(1.0d0) ) then
          err = 1
          message = "Les coefficients bi doivent etre > 0."
          call Error (from,message )
          return
        end if
        brem = brem + ai(i)*atan(ci(i)/bi(i))
        bsat = bsat + ai(i)*0.5d0*pi
      end do

      if ( brem < 0.0d0 ) then
        brem = -brem
        do i = 1, natan
          ci(i) = -ci(i)
        end do
      end if
      bh((2*natan+3):(3*natan+2)) = ci(1:natan)

      if ( bsat < brem ) then
        err = 1
        message = "Bsat doit etre > Brem."
        call Error (from,message )
        return
      end if

      ! Position initiale dans le vecteur bh
      ptr = 3*natan + 2

      ! Calcul de muFmax
      muFmax = 0.0d0
      do i = 1, natan
        muFmax = muFmax + ai(i)/bi(i)/(1.0d0+(ci(i)/bi(i))**2.0d0)
      end do
      ptr = ptr + 1
      bh(ptr) = muFmax

      ! Ajout de Brem et Bsat
      ptr = ptr + 1
      bh(ptr) = brem
      ptr = ptr + 1
      bh(ptr) = bsat

      ! Allocation de l'historique
      Allocate ( nHist(nPtsTot), stat=err )
      if ( err == 0 ) Allocate (dHist(2,nPtsTot) , stat=err)
      if ( err == 0 ) Allocate (dHistA(maxHistLen,nPtsTot) , stat=err)
      if ( err == 0 ) Allocate (dHistB(maxHistLen,nPtsTot) , stat=err)
      if ( err /= 0 ) then
        message = "Memoire insuffisante."
        call Error (from,message )
        return
      end if

      ! Initialisation de l'historique
      nHist = 1
      dHist = 0.0d0
      dHistA = 0.0d0
      dHistB = 0.0d0

    elseif ( mattype == 4 ) then
      if ( bh(2) < 0.0d0 ) then
        err = 1
        message = "Br doit etre > 0."
        call Error (from,message )
        return
      end if

    else if ( mattype == 5 ) then

      ! Recuperation de ntanh, ai, bi, ci
      Hmax = bh(4)
      call GetEllipseParameters (bh,Hmax , a,b,alpha,brem)

      ! Allocation de l'historique
      Allocate ( nHist(nPtsTot), stat=err )
      if ( err == 0 ) Allocate (dHist(2,nPtsTot) , stat=err)
      if ( err == 0 ) Allocate (dHistA(maxHistLen,nPtsTot) , stat=err)
      if ( err == 0 ) Allocate (dHistB(maxHistLen,nPtsTot) , stat=err)
      if ( err /= 0 ) then
        message = "Memoire insuffisante."
        call Error (from,message )
        return
      end if

      ! Initialisation de l'historique
      nHist = 1
      dHist = 0.0d0
      dHistA = 0.0d0
      dHistB = 0.0d0

    else if ( mattype == 6 ) then

      ! Recuperation de ntanh, ai, bi, ci
      Hmax = bh(4)
      call GetEllipseParameters (bh,Hmax, a,b,alpha,brem)

      ! Allocation de l'historique
      Allocate ( nHist(nPtsTot), stat=err )
      if ( err == 0 ) Allocate (dHist(2,nPtsTot) , stat=err)
      if ( err == 0 ) Allocate (dHistA(maxHistLen,nPtsTot) , stat=err)
      if ( err == 0 ) Allocate (dHistB(maxHistLen,nPtsTot) , stat=err)
      if ( err /= 0 ) then
        message = "Memoire insuffisante."
        call Error (from,message )
        return
      end if

      ! Initialisation de l'historique
      nHist = 1
      dHist = 0.0d0
      dHistA = 0.0d0
      dHistB = 0.0d0

    else if ( mattype == 7 ) then

      ! Recuperation de ntanh, ai, bi, ci
      brem = bh(2)
      bsat = bh(3)

      ! Allocation de l'historique
      Allocate ( nHist(nPtsTot), stat=err )
      if ( err == 0 ) Allocate (dHist(2,nPtsTot) , stat=err)
      if ( err == 0 ) Allocate (dHistA(maxHistLen,nPtsTot) , stat=err)
      if ( err == 0 ) Allocate (dHistB(maxHistLen,nPtsTot) , stat=err)
      if ( err /= 0 ) then
        message = "Memoire insuffisante."
        call Error (from,message )
        return
      end if

      ! Initialisation de l'historique
      nHist = 1
      dHist = 0.0d0
      dHistA = 0.0d0
      dHistB = 0.0d0

    end if

    return
  end subroutine InitializeMaterial
  ! -------------------------------------------------------------------------------------------------------------------
  subroutine FinalizeMaterial ()
    ! Description :
    ! Libere la memoire allouee pour l'historique
    implicit none

    if ( allocated(nHist) ) deallocate(nHist)
    if ( allocated(dHist) ) deallocate(dHist)
    if ( allocated(dHistA) ) deallocate(dHistA)
    if ( allocated(dHistB) ) deallocate(dHistB)

    return
  end subroutine FinalizeMaterial
  ! -------------------------------------------------------------------------------------------------------------------
  subroutine UpdateMaterialBH (ne,ndof,bh,H , B)
    ! Description :
    ! Calcul de B en post traitement et mise-a-jour de l'historique sur tout le domaine.
    implicit none
    ! Inputs :
    ! Discretisation
    integer, intent(in)                                     :: ne, ndof
    ! Parametres de la courbe BH
    double precision, dimension(maxParam), intent(in)       :: bh
    ! Champ mag
    double precision, dimension(ndof+1), intent(in)         :: H
    ! Outputs :
    ! Induction
    double precision, dimension(ndof+1), intent(out)        :: B

    ! Variables :
    ! Iterations
    integer                                                 :: e, i, j, k, noPt
    double precision, dimension(nGauss)                     :: Hk
    double precision                                        :: Bk

    ! Initialisation
    i = 0

    ! Premier element

    ! Noeuds
    noPt = GetNoPt (1,1,1 )
    call UpdateLocalBH (noPt,bh,H(ndof+1) , B(ndof+1))

    noPt = GetNoPt (1,2,1 )
    call UpdateLocalBH (noPt,bh,H(1) , B(1))

    noPt = GetNoPt (1,3,1 )
    call UpdateLocalBH (noPt,bh,H(2) , B(2))

    ! Pts de calcul
    do k = 1, nGauss

      ! Numero identifiant le pt de calcul
      noPt = GetNoPt(1,k,2 )

      ! Champ mag
      Hk(k) = H(ndof+1)*Psi1(k)+H(i+1)*Psi2(k)+H(i+2)*Psi3(k)

      ! Mise-a-jour de l'historique
      call UpdateLocalBH (noPt,bh,Hk(k) , Bk)

    end do

    ! Boucle sur les autres elements
    do e = 2, ne

      ! Pointeur pour les degrees de liberte
      i = i + degPsi

      ! Noeuds
      noPt = GetNoPt (e,2,1 )
      call UpdateLocalBH (noPt,bh,H(i+1) , B(i+1))

      noPt = GetNoPt (e,3,1 )
      call UpdateLocalBH (noPt,bh,H(i+2) , B(i+2))

      ! Pts de calcul
      do k = 1, nGauss

        ! Numero identifiant le pt de calcul
        noPt = GetNoPt(e,k,2 )

        ! Champ mag
        Hk(k) = H(i)*Psi1(k)+H(i+1)*Psi2(k)+H(i+2)*Psi3(k)

        ! Mise-a-jour de l'historique
        call UpdateLocalBH (noPt,bh,Hk(k) , Bk)

      end do

    end do

    return
  end subroutine UpdateMaterialBH
  ! -------------------------------------------------------------------------------------------------------------------
  subroutine UpdateLocalBH (noPt,bh,H , B)
    ! Description :
    ! Calcul de B en post traitement et mise-a-jour de l'historique en un point donne.
    implicit none
    ! Inputs :
    ! Numero identifiant le point
    integer, intent(in)                                     :: noPt
    ! Parametres de la courbe BH
    double precision, dimension(maxParam), intent(in)       :: bh
    ! Champ mag
    double precision, intent(in)                            :: H
    ! Outputs :
    ! Induction
    double precision, intent(out)                           :: B

    ! Variables :
    ! Numero du modele de courbe BH
    integer                                                 :: mattype
    double precision                                        :: dBdH

    ! Initialisation
    B = 0.0d0

    ! Modele du materiau
    mattype = nint(bh(1))

    ! 1 : lineaire permeabilite relative constante
    if ( mattype == 1 ) then
      B = mu0*bh(2)*H

    ! 2 : non lineaire modele arctangente
    else if ( mattype == 2 ) then
      B = mu0*H + bh(4)*atan(bh(5)*H)

    ! 3 : non lineaire hysteretique modele de Preisach a 3n coefficients
    else if ( mattype == 3 ) then
      call CalculPreisachBH (bh,H , nHist(noPt),dHist(1,noPt),dHist(2,noPt),                                            &
                             dHistA(1:maxHistLen,noPt),dHistB(1:maxHistLen,noPt) , B,dBdh)

  else if ( mattype == 4 ) then

    if (H < -1.0*bh(3)) then
      B = mu0*H - bh(2)
    else if (H > bh(3)) then
      B = mu0*H + bh(2)
    else
      B = (-bh(2)/(2.0d0*bh(3)**3.0d0))*(H**3.0d0)+(mu0+(3.0d0*bh(2))/(2.0d0*bh(3)))*H
    end if

  else if ( mattype == 5 ) then
    call CalculPreisachBH (bh,H , nHist(noPt),dHist(1,noPt),dHist(2,noPt),                                            &
                             dHistA(1:maxHistLen,noPt),dHistB(1:maxHistLen,noPt) , B,dBdh)

  else if ( mattype == 6 ) then
    call CalculPreisachBHEllipse (bh,H , nHist(noPt),dHist(1,noPt),dHist(2,noPt),                                            &
                              dHistA(1:maxHistLen,noPt),dHistB(1:maxHistLen,noPt) , B,dBdh)

  else if ( mattype == 7 ) then
    call CalculPreisachBH (bh,H , nHist(noPt),dHist(1,noPt),dHist(2,noPt),                                            &
                              dHistA(1:maxHistLen,noPt),dHistB(1:maxHistLen,noPt) , B,dBdh)

  end if

  return
  end subroutine UpdateLocalBH
  ! -------------------------------------------------------------------------------------------------------------------
  subroutine CalculLocalBH (noPt,bh,H , B,dBdH)
    ! Description :
    ! Calcul de B et de sa derivee en un point donne.
    implicit none
    ! Inputs :
    ! Numero identifiant le point
    integer, intent(in)                                     :: noPt
    ! Parametres de la courbe BH
    double precision, dimension(maxParam), intent(in)       :: bh
    ! Champ mag
    double precision, intent(in)                            :: H
    ! Outputs :
    ! Induction et sa derivee
    double precision, intent(out)                           :: B
    double precision, intent(out)                           :: dBdH

    ! Variables :
    ! Numero du modele de courbe BH
    integer                                                 :: mattype
    ! Modele de Preisach
    integer                                                 :: n
    double precision                                        :: prevG, partialM, prevH
    double precision, dimension(maxHistLen)                 :: prevMax, prevMin

    ! Initialisation
    B = 0.0d0
    dBdH = 0.0d0

    ! Modele du materiau
    mattype = nint(bh(1))

    ! 1 : lineaire permeabilite relative constante
    if ( mattype == 1 ) then
      B = mu0*bh(2)*H
      dBdH = mu0*bh(2)

    ! 2 : non lineaire modele arctangente
    else if ( mattype == 2 ) then
      B = mu0*H + bh(4)*atan(bh(5)*H)
      dBdH = mu0 + mu0*(bh(2)-1.0d0)/(1.0d0 + (bh(5)*H)**2.0d0)

    ! 3 : non lineaire hysteretique modele de Preisach a 3n coefficients
    else if ( mattype == 3 ) then
      n = nHist(noPt)
      prevG = dHist(1,noPt)
      partialM = dHist(2,noPt)
      prevMax = dHistA(1:maxHistLen,noPt)
      prevMin = dHistB(1:maxHistLen,noPt)
      call CalculPreisachBH (bh,H , n,prevG,partialM,prevMax,prevMin , B,dBdh)

    else if ( mattype == 4 ) then
      if (H < -1.0*bh(3)) then
        B = mu0*H - bh(2)
        dBdH = mu0
      else if (H > bh(3)) then
        B = mu0*H + bh(2)
        dBdH = mu0
      else
        B = (-bh(2)/(2.0d0*bh(3)**3.0d0))*(H**3.0d0)+(mu0+(3.0d0*bh(2))/(2.0d0*bh(3)))*H
        dBdH = (-3.0d0*bh(2)/(2.0d0*bh(3)**3.0d0))*(H**2.0d0)+(mu0+(3.0d0*bh(2))/(2.0d0*bh(3)))
      end if

    else if ( mattype == 5 ) then
      n = nHist(noPt)
      prevG = dHist(1,noPt)
      partialM = dHist(2,noPt)
      prevMax = dHistA(1:maxHistLen,noPt)
      prevMin = dHistB(1:maxHistLen,noPt)
      call CalculPreisachBH (bh,H , n,prevG,partialM,prevMax,prevMin , B,dBdh)

    else if ( mattype == 6 ) then
      n = nHist(noPt)
      prevH = dHist(1,noPt)
      partialM = dHist(2,noPt)
      prevMax = dHistA(1:maxHistLen,noPt)
      prevMin = dHistB(1:maxHistLen,noPt)
      call CalculPreisachBHEllipse (bh,H , n,prevH,partialM,prevMax,prevMin , B,dBdh)

    else if ( mattype == 7 ) then
      n = nHist(noPt)
      prevG = dHist(1,noPt)
      partialM = dHist(2,noPt)
      prevMax = dHistA(1:maxHistLen,noPt)
      prevMin = dHistB(1:maxHistLen,noPt)
      call CalculPreisachBH (bh,H , n,prevG,partialM,prevMax,prevMin , B,dBdh)

    end if

    return
  end subroutine CalculLocalBH
  ! -------------------------------------------------------------------------------------------------------------------
  function GetNoPt (e,k,type )
    ! Description :
    ! Recupere le numero unique identifiant un noeud ou un point de calcul.
    implicit none
    ! Inputs :
    ! Numero de l'element
    integer, intent(in)                                     :: e
    ! Numero du point (calcul ou neud)
    integer, intent(in)                                     :: k
    ! Type de point (1 pour noeud, 2 pour gauss)
    integer, intent(in)                                     :: type
    ! Output :
    integer                                                 :: getNoPt

    ! Calcul du numero du point
    ! Degres de liberte
    if ( type == 1 ) then
      getNoPt = 6*(e-1) + 3*(k-1) + 1

    ! Pts d'integration
    else
      getNoPt = 6*(e-1) + k + 1
      if ( k >= 3 ) getNoPt = getNoPt + 1

    end if

    return
  end function GetNoPt
  ! -------------------------------------------------------------------------------------------------------------------
  subroutine GetPreisachParameters (bh , natan,ai,bi,ci,muFmax,brem,bsat)
    ! Description :
    ! Recuperation des parametres a partir du vecteur bh.
    implicit none
    ! Inputs :
    ! Parametres de la courbe BH
    double precision, dimension(maxParam), intent(in)       :: bh
    ! Outputs :
    ! Nombre de tangentes hyperboliques
    integer, intent(out)                                    :: natan
    ! Parametres des tangentes hyperboliques
    double precision, dimension(maxAtan), intent(out)       :: ai, bi, ci
    ! Parametres supplementaires
    double precision, intent(out)                           :: muFmax, brem, bsat

    ! Variables :
    integer                                                 :: i, ptr

    ! Initialisation
    ptr = 2

    ! Recuperation du nombre de tangentes hyperboliques
    natan = nint(bh(ptr))

    ! Recuperation des ai
    do i = 1, natan
      ptr = ptr + 1
      ai(i) = bh(ptr)
    end do

    ! Recuperation des bi
    do i = 1, natan
      ptr = ptr + 1
      bi(i) = bh(ptr)
    end do

    ! Recuperation des ci
    do i = 1, natan
      ptr = ptr + 1
      ci(i) = bh(ptr)
    end do

    ! Recuperation de muFmax, Brem et Bsat
    ptr = ptr + 1
    muFmax = bh(ptr)
    ptr = ptr + 1
    brem = bh(ptr)
    ptr = ptr + 1
    bsat = bh(ptr)

    return
  end subroutine GetPreisachParameters
  ! -------------------------------------------------------------------------------------------------------------------
  subroutine CalculPreisachBH (bh,H , n,prevG,partialM,prevMax,prevMin, B,dBdH)
    ! Description :
    ! Calcul de B et sa derivee avec le modele de Preisach a 3n coefficients. Le calcul modifie l'historique.
    implicit none
    ! Inputs :
    ! Parametres de la courbe BH
    double precision, dimension(maxParam), intent(in)       :: bh
    ! Champ magnetique
    double precision, intent(in)                            :: H
    ! Inouts :
    ! Nombre de points dans l'historique
    integer, intent(inout)                                  :: n
    ! Valeur de G au pas de temps precedent
    double precision, intent(inout)                         :: prevG
    ! Valeur partielle de la magnetisation
    double precision, intent(inout)                         :: partialM
    ! Maxima precedents de G
    double precision, dimension(maxHistLen), intent(inout)  :: prevMax
    ! Minima precedents de G
    double precision, dimension(maxHistLen), intent(inout)  :: prevMin
    ! Outputs :
    ! Induction et sa derivee
    double precision, intent(out)                           :: B
    double precision, intent(out)                           :: dBdH

    ! Variables :
    integer                                                 :: j
    ! Modele de Preisach
    integer                                                 :: natan, prevn
    double precision                                        :: brem, F, dFdH, G, dGdH, Mirr, dMirrdG
    double precision                                        :: Hmax,Bdown,dBdowndH

    ! Initialisation
    B = mu0*H
    dBdH = mu0
    Mirr = 0.0d0
    dMirrdG = 0.0d0

    ! Calcul des fonctions F(H) et G(H) et recuperation de brem
    if (nint(bh(1)) == 3) then
      call CalculFG (bh,H , brem,F,dFdH,G,dGdH)
    else if (nint(bh(1)) == 5) then
      Hmax = bh(4)
      call CalculFGEllipse (bh,H,Hmax , brem,F,dFdH,G,dGdH,Bdown,dBdowndH)
    else if (nint(bh(1)) == 7) then
      call CalculFG4param (bh,H , brem,F,dFdH,G,dGdH)
    end if

    ! Calcul du modele de Preisach si existence d'une partie irreversible
    if ( brem > epsilon(1.0d0) ) then

      ! Mise-a-jour de la frontiere de Preisach
      ! Copie du nombre de points dans l'historique
      prevn = n

      ! Champ croissant
      if ( G > prevG ) then
        do j = prevn, 0, -1
          ! Saturation
          if ( j == 0 ) then
            n = 1
            prevMax(1) =  abs(G)
            prevMin(1) = -abs(G)
          ! Wipe-out ou creation d'un nouvel extremum
          elseif ( G < prevMax(j) ) then
            n = j+1
            prevMax(n) = G
            prevMin(n) = prevMin(j)
            exit
          endif
        enddo

      ! Champ decroissant
      else if ( G < prevG  ) then
        do j =  prevn, 0, -1
          ! Saturation
          if ( j == 0 ) then
            n = 1
            prevMax(1) =  abs(G)
            prevMin(1) = -abs(G)
          ! Wipe-out ou creation d'un nouvel extremum
            else if ( G > prevMin(j) ) then
            n = j+1
            prevMax(n) = prevMax(j)
            prevMin(n) = G
            exit
          endif
        enddo

      endif

      ! Calcul de la somme partielle si necessaire
      if ( prevn /= n ) then
        partialM = 0.0d0
        do j = 2, n-1
          if( prevMin(j-1) /= prevMin(j) )then
            partialM = partialM + 2.0d0*( Everett(prevMax(j),prevMin(j-1) ) - Everett(prevMax(j),prevMin(j)) )
          endif
        enddo
      endif

      ! Calcul de la contribution irreversible a l'induction
      ! Termes essentiels
      Mirr = -Everett(prevMax(1),prevMin(1) ) + 2.0d0*Everett(G,prevMin(n) )

      ! Ajout des termes supplementaires
      if( n > 1 )then
        Mirr = Mirr + partialM
        if( prevMin(n-1) /= prevMin(n) )then
          Mirr = Mirr + 2.0d0*( Everett(prevMax(n),prevMin(n-1) ) - Everett(prevMax(n),prevMin(n) ) )
        end if
      end if

      ! Calcul de la derivee de la partie irreversible
      ! Champ croissant
      if ( G > prevG ) then
        dMirrdG =  2.0d0*dEverettda(G,prevMin(n) )

      ! Champ decroissant
      else if ( G < prevG ) then
        dMirrdG = -2.0d0*dEverettdb(prevMax(n),G )

      ! Champ constant
      else
        dMirrdG = dEverettda(G,prevMin(n) ) - dEverettdb(prevMax(n),G )

      end if

      ! Normalisation
      Mirr = Mirr / brem
      dMirrdG = dMirrdG / brem

      ! Mise-a-jour de la valeur precedente de G
      prevG = G

    end if

    ! Addition des composantes reversibles et irreversibles
    ! Induction
    B = B + F + Mirr

    ! Permeabilite differentielle
    dBdH = dBdH + dFdH + dMirrdG*dGdH

    !write(*,*) B, dBdH, brem

    return
  end subroutine CalculPreisachBH
! -------------------------------------------------------------------------------------------------------------------
  subroutine CalculFG (bh,H , brem,F,dFdH,G,dGdH)
    ! Description :
    ! Calcul des fonction F(H) et G(H) pour le modele de Preisach. Recuperation de l'induction a remanence.
    implicit none
    ! Inputs :
    ! Parametres de la courbe BH
    double precision, dimension(maxParam), intent(in)       :: bh
    ! Champ mag
    double precision, intent(in)                            :: H
    ! Outputs :
    ! Induction a remanence
    double precision, intent(out)                           :: brem
    ! Valeur de la fonction F et sa derivee
    double precision, intent(out)                           :: F, dFdH
    ! Valeur de la fonction G et sa derivee
    double precision, intent(out)                           :: G, dGdH

    ! Variables :
    integer                                                 :: i, natan
    double precision, dimension(maxAtan)                    :: ai, bi, ci
    double precision                                        :: muFmax, bsat
    double precision                                        :: xia, xid

    ! Recuperation des parametres
    call GetPreisachParameters (bh , natan,ai,bi,ci,muFmax,brem,bsat)

    ! Cas H = 0
    if ( abs(H) < epsilon(1.0d0) ) then
      F = 0.0d0
      dFdH = muFmax
      G = 0.0d0
      dGdH = 0.0d0

    ! Cas H < 0
    else if ( H < 0.0d0 ) then

      ! Initialisation
      F = brem
      dFdH = 0.0d0
      G = -brem
      dGdH = 0.0d0

      ! Boucle sur le nombre de tangentes hyperboliques
      do i = 1, natan

        ! Calcul de la fonction reversible
        xid = (-H+ci(i))/bi(i)
        F = F - ai(i)*atan(xid)
        dFdH = dFdH + ai(i)/bi(i)/(1.0d0+xid*xid)

        ! Calcul de la fonction irreversible
        xia = (-H-ci(i))/bi(i)
        G  = G + 0.5d0*ai(i)*(atan(xid)-atan(xia))
        dGdH = dGdH - 0.5d0*ai(i)/bi(i)*(1.0d0/(1.0d0+xid*xid)-1.0d0/(1.0d0+xia*xia))

      end do

    ! Cas H > 0
    else

      ! Initialisation
      F = -brem
      dFdH = 0.0d0
      G = brem
      dGdH = 0.0d0

      ! Boucle sur le nombre de tangentes hyperboliques
      do i = 1, natan

        ! Calcul de la fonction reversible
        xid = (H+ci(i))/bi(i)
        F = F + ai(i)*atan(xid)
        dFdH = dFdH + ai(i)/bi(i)/(1.0d0+xid*xid)

        ! Calcul de la fonction irreversible
        xia = (H-ci(i))/bi(i)
        G  = G - 0.5d0*ai(i)*(atan(xid)-atan(xia))
        dGdH = dGdH - 0.5d0*ai(i)/bi(i)*(1.0d0/(1.0d0+xid*xid)-1.0d0/(1.0d0+xia*xia))

      end do

    end if

    return
  end subroutine CalculFG
  ! -------------------------------------------------------------------------------------------------------------------
  function Everett(alpha,beta )
    ! Description :
    ! Calcul de la fonction d'Everett bilineaire.
    implicit none
    ! Inputs :
    double precision, intent(in)                            :: alpha, beta
    ! Outputs :
    double precision                                        :: Everett

    Everett = -alpha*beta
    if ( Everett < 0.0d0 ) Everett = 0.0d0

    return
  end function Everett
  ! -------------------------------------------------------------------------------------------------------------------
  function dEverettda(alpha,beta )
    ! Description :
    ! Calcul de la derivee de la fonction d'Everett bilineaire.
    implicit none
    ! Inputs :
    double precision, intent(in)                            :: alpha, beta
    ! Outputs :
    double precision                                        :: dEverettda

    if ( alpha*beta < 0.0d0 ) then
      dEverettda = -beta
    else
      dEverettda = 0.0d0
    end if

    return
  end function dEverettda
  ! -------------------------------------------------------------------------------------------------------------------
  function dEverettdb(alpha,beta )
    ! Description :
    ! Calcul de la derivee de la fonction d'Everett bilineaire.
    implicit none
    ! Inputs :
    double precision, intent(in)                            :: alpha, beta
    ! Outputs :
    double precision                                        :: dEverettdb

    if ( alpha*beta < 0.0d0 ) then
      dEverettdb = -alpha
    else
      dEverettdb = 0.0d0
    end if

    return
  end function dEverettdb
  ! -------------------------------------------------------------------------------------------------------------------

  subroutine GetEllipseParameters (bh,Hmax_in , a,b,alpha,brem)
    ! Description :
    ! Recuperation des parametres de l'ellipse (a,b,alpha) a partir du vecteur bh.
    implicit none
    ! Inputs :
    ! Parametres de la courbe BH
    double precision, dimension(maxParam), intent(in)       :: bh
    double precision, intent(in)                            :: Hmax_in
    ! Outputs :
    ! Parametres supplementaires
    double precision, intent(out)                           :: a, b, alpha, brem

    !Autres
    double precision                                        :: delta, Hmax, Bmax, Hc, bnum, bdenom

    Hmax = abs(Hmax_in)
    delta = atan(-bh(3)/bh(2))
    Bmax = mu0*sqrt(bh(2)**2.0d0 + bh(3)**2.0d0)*Hmax
    Hc = Hmax*sin(delta)
    alpha = atan(Bmax/Hmax)*cos(delta*0.9d0)

    bnum = ((Hmax*sin(alpha)-Bmax*cos(delta)*cos(alpha))**2.0d0-(Hmax*sin(alpha)+Bmax*cos(delta)*sin(alpha)*tan(alpha))**2.0d0)
    bdenom = (1-((Hmax+Bmax*cos(delta)*tan(alpha))/Hc)**2.0d0)
    b = sqrt(bnum/bdenom)
    a = sqrt(((Hc*cos(alpha))**2.0d0)/(1-(Hc*sin(alpha)/b)**2.0d0))
    brem = sqrt(1.0d0/((sin(alpha)/a)**2.0d0 + (cos(alpha)/b)**2.0d0))

    return
  end subroutine GetEllipseParameters
  ! -------------------------------------------------------------------------------------------------------------------

  subroutine CalculFGEllipse (bh,H,Hmax , brem,F,dFdH,G,dGdH,Bdown,dBdowndH)
    ! Description :
    ! Calcul des fonction F(H) et G(H) pour le modele de Preisach. Recuperation de l'induction a remanence.
    implicit none
    ! Inputs :
    ! Parametres de la courbe BH
    double precision, dimension(maxParam), intent(in)       :: bh
    ! Champ mag
    double precision, intent(in)                            :: H
    double precision, intent(in)                            :: Hmax
    ! Outputs :
    ! Induction a remanence
    double precision, intent(out)                           :: brem
    ! Valeur de la fonction F et sa derivee
    double precision, intent(out)                           :: F, dFdH
    ! Valeur de la fonction G et sa derivee
    double precision, intent(out)                           :: G, dGdH
    ! Valeur de la fonction B down et sa derivee
    double precision, intent(out)                           :: Bdown, dBdowndH

    ! Variables :
    double precision                                        :: a, b, alpha
    double precision                                        :: A2, C, D, dCdH, dDdH, Bup, dBupdH,discr
    ! Recuperation des parametres
    call GetEllipseParameters (bh,Hmax , a,b,alpha,brem)
    !write(*,*) a, b, alpha, brem

    if (abs(Hmax) < epsilon(1.0d0) ) then
      brem = 0.0d0
      F = 0.0d0
      dFdH = 0.0d0
      G = 0.0d0
      dGdH = 0.0d0
      Bdown = 0.0d0
      dBdowndH = 0.0d0
    else

      if ( H < 0.0d0 ) then

        A2 = (sin(alpha)/a)**2.0d0 + (cos(alpha)/b)**2.0d0
        C = 2.0d0*cos(alpha)*sin(alpha)*(1.0d0/(a**2.0d0) - 1.0d0/(b**2.0d0))*abs(H)
        D = ((cos(alpha)/a)**2.0d0 + (sin(alpha)/b)**2.0d0)*(H**2.0d0) - 1.0d0
        dCdH = 2.0d0*cos(alpha)*sin(alpha)*(1.0d0/(a**2.0d0) - 1.0d0/(b**2.0d0))
        dDdH = 2.0d0*((cos(alpha)/a)**2.0d0 + (sin(alpha)/b)**2.0d0)*abs(H)

        discr = C**2.0d0 - 4.0d0*A2*D

        Bdown = (-C + sqrt(discr))/(2.0d0*A2)
        Bup = (-C - sqrt(discr))/(2.0d0*A2)
        dBdowndH = (-dCdH + (2.0d0*dCdH*C - 4.0d0*A2*dDdH)/(2.0d0*sqrt(discr)))/(2.0d0*A2)
        dBupdH = (-dCdH - (2.0d0*dCdH*C - 4.0d0*A2*dDdH)/(2.0d0*sqrt(discr)))/(2.0d0*A2)

        F = -(Bdown - brem -mu0*abs(H))
        G = -(brem - (Bdown-Bup)/2.0d0)
        dFdH = (dBdowndH - mu0)
        dGdH = -(dBdowndH-dBupdH)/2.0d0

      ! Cas H > 0
      else

        A2 = (sin(alpha)/a)**2.0d0 + (cos(alpha)/b)**2.0d0
        C = 2.0d0*cos(alpha)*sin(alpha)*(1.0d0/(a**2.0d0) - 1.0d0/(b**2.0d0))*(H)
        D = ((cos(alpha)/a)**2.0d0 + (sin(alpha)/b)**2.0d0)*(H**2.0d0) - 1.0d0
        dCdH = 2.0d0*cos(alpha)*sin(alpha)*(1.0d0/(a**2.0d0) - 1.0d0/(b**2.0d0))
        dDdH = 2.0d0*((cos(alpha)/a)**2.0d0 + (sin(alpha)/b)**2.0d0)*(H)

        discr = C**2.0d0 - 4.0d0*A2*D

        Bdown = (-C + sqrt(discr))/(2.0d0*A2)
        Bup = (-C - sqrt(discr))/(2.0d0*A2)
        dBdowndH = (-dCdH + (2.0d0*dCdH*C - 4.0d0*A2*dDdH)/(2.0d0*sqrt(discr)))/(2.0d0*A2)
        dBupdH = (-dCdH - (2.0d0*dCdH*C - 4.0d0*A2*dDdH)/(2.0d0*sqrt(discr)))/(2.0d0*A2)

        F = Bdown - brem -mu0*(H)
        G = brem - (Bdown-Bup)/2.0d0
        dFdH = (dBdowndH - mu0)
        dGdH = -(dBdowndH-dBupdH)/2.0d0

      end if

    end if
    !write(*,*) F, G, dFdH, dGdH
    return
  end subroutine CalculFGEllipse
  ! -------------------------------------------------------------------------------------------------------------------

  subroutine CalculPreisachBHEllipse (bh,H , n,prevH,partialM,prevMax,prevMin, B,dBdH)
    ! Description :
    ! Calcul de B et sa derivee avec le modele de Preisach a 3n coefficients. Le calcul modifie l'historique.
    implicit none
    ! Inputs :
    ! Parametres de la courbe BH
    double precision, dimension(maxParam), intent(in)       :: bh
    ! Champ magnetique
    double precision, intent(in)                            :: H
    ! Inouts :
    ! Nombre de points dans l'historique
    integer, intent(inout)                                  :: n
    ! Valeur de G au pas de temps precedent
    double precision, intent(inout)                         :: prevH
    ! Valeur partielle de la magnetisation
    double precision, intent(inout)                         :: partialM
    ! Maxima precedents de G
    double precision, dimension(maxHistLen), intent(inout)  :: prevMax
    ! Minima precedents de G
    double precision, dimension(maxHistLen), intent(inout)  :: prevMin
    double precision                                        :: E1, E2, dE1, dE2
    ! Outputs :
    ! Induction et sa derivee
    double precision, intent(out)                           :: B
    double precision, intent(out)                           :: dBdH

    ! Variables :
    integer                                                 :: j
    ! Modele de Preisach
    integer                                                 :: natan, prevn
    double precision                                        :: brem, F, dFdH, G, dGdH, Mirr, dMirrdH
    double precision                                        :: Hmax,Bdown,dBdowndH

    ! Initialisation
    B = mu0*H
    dBdH = mu0
    Mirr = 0.0d0

    ! Calcul des fonctions F(H) et G(H) et recuperation de brem
    call CalculFGEllipse (bh,H,bh(4) , brem,F,dFdH,G,dGdH,Bdown,dBdowndH)

    ! Calcul du modele de Preisach si existence d'une partie irreversible
    if ( brem > epsilon(1.0d0) ) then

      ! Mise-a-jour de la frontiere de Preisach
      ! Copie du nombre de points dans l'historique
      prevn = n

      ! Champ croissant
      if ( H > prevH ) then
        do j = prevn, 0, -1
          ! Saturation
          if ( j == 0 ) then
            n = 1
            prevMax(1) =  abs(H)
            prevMin(1) = -abs(H)
          ! Wipe-out ou creation d'un nouvel extremum
          elseif ( H < prevMax(j) ) then
            n = j+1
            prevMax(n) = H
            prevMin(n) = prevMin(j)
            exit
          endif
        enddo

      ! Champ decroissant
      else if ( H < prevH  ) then
        do j =  prevn, 0, -1
          ! Saturation
          if ( j == 0 ) then
            n = 1
            prevMax(1) =  abs(H)
            prevMin(1) = -abs(H)
          ! Wipe-out ou creation d'un nouvel extremum
            else if ( H > prevMin(j) ) then
            n = j+1
            prevMax(n) = prevMax(j)
            prevMin(n) = H
            exit
          endif
        enddo

      endif

      prevH = H

      ! Calcul de la somme partielle si necessaire
      if ( prevn /= n ) then
        partialM = 0.0d0
        do j = 2, n-1
          if( prevMin(j-1) /= prevMin(j) )then
            call EverettEllipse(prevMax(j),prevMin(j-1),bh, E1 )
            call EverettEllipse(prevMax(j),prevMin(j),bh, E2)
            partialM = partialM + 2.0d0*( E1 - E2)
          endif
        enddo
      endif

      ! Calcul de la contribution irreversible a l'induction
      ! Termes essentiels
      call EverettEllipse(prevMax(1),prevMin(1),bh, E1  )
      call EverettEllipse(H,prevMin(n),bh, E2  )
      Mirr = -E1 + 2.0d0*E2

      ! Ajout des termes supplementaires
      if( n > 1 )then
        Mirr = Mirr + partialM
        if( prevMin(n-1) /= prevMin(n) )then
          call EverettEllipse(prevMax(n),prevMin(n-1) ,bh, E1 )
          call EverettEllipse(prevMax(n),prevMin(n),bh, E2 )
          Mirr = Mirr + 2.0d0*( E1 - E2  )
        end if
      end if

      ! Calcul de la derivee de la partie irreversible
      ! Champ croissant
      if ( H > prevH ) then
        call dEverettEllipseda(H,prevMin(n),bh, dE1 )
        dMirrdH =  2.0d0*dE1

      ! Champ decroissant
      else if ( H < prevH ) then
        call dEverettEllipsedb(prevMax(n),H,bh, dE1 )
        dMirrdH = -2.0d0*dE1

      ! Champ constant
      else
        call dEverettEllipseda(H,prevMin(n),bh, dE1 )
        call dEverettEllipsedb(prevMax(n),H,bh, dE2 )
        dMirrdH = dE1 - dE2

      end if

      ! Normalisation
      !Mirr = Mirr / brem
      !dMirrdH = dMirrdH / brem

      Mirr = Mirr
      dMirrdH = dMirrdH
      ! Mise-a-jour de la valeur precedente de G

    end if

    ! Addition des composantes reversibles et irreversibles
    ! Induction
    !B = B  + Mirr
    B = Mirr

    ! Permeabilite differentielle
    !dBdH = dBdH + dMirrdH
    dBdH =  dMirrdH

    !write(*,*) B, dBdH, brem

    return
  end subroutine CalculPreisachBHEllipse
! -------------------------------------------------------------------------------------------------------------------

  subroutine EverettEllipse(alpha,beta,bh ,EverettEllipse_out)
    ! Description :
    ! Calcul de la fonction d'Everett bilineaire.
    implicit none
    ! Inputs :
    double precision, intent(in)                            :: alpha, beta
    double precision, dimension(maxParam), intent(in)       :: bh
    ! Outputs :
    double precision, intent(out)                           :: EverettEllipse_out
    double precision                                        :: EverettEllipse1, EverettEllipse2
    ! Variables:
    ! Induction a remanence
    double precision                                        :: brem,Bdown1,Bdown2
    double precision                                        :: A2, C, D, discr,a,b,angle, C2, D2, discr2
    double precision                                        :: beta2, alpha2

    if (alpha < -beta) then
      beta2 = -alpha
      alpha2 = -beta
    else
      alpha2 = alpha
      beta2 = beta
    end if

    call GetEllipseParameters (bh,alpha2 , a,b,angle,brem)
    if (abs(alpha2) < epsilon(1.0d0) ) then
      Bdown1 = 0.0d0
      Bdown2 = 0.0d0
    else
      A2 = (sin(angle)/a)**2.0d0 + (cos(angle)/b)**2.0d0
      C = 2.0d0*cos(angle)*sin(angle)*(1.0d0/(a**2.0d0) - 1.0d0/(b**2.0d0))*(alpha2)
      D = ((cos(angle)/a)**2.0d0 + (sin(angle)/b)**2.0d0)*(alpha2**2.0d0) - 1.0d0
      discr = C**2.0d0 - 4.0d0*A2*D
      Bdown1 = (-C + sqrt(discr))/(2.0d0*A2)

      C2 = 2.0d0*cos(angle)*sin(angle)*(1.0d0/(a**2.0d0) - 1.0d0/(b**2.0d0))*(beta2)
      D2 = ((cos(angle)/a)**2.0d0 + (sin(angle)/b)**2.0d0)*(beta2**2.0d0) - 1.0d0
      discr2 = C2**2.0d0 - 4.0d0*A2*D2
      Bdown2 = (-C2 + sqrt(discr2))/(2.0d0*A2)

    end if
    EverettEllipse1 = (Bdown1 - Bdown2 )/2.0d0

    !EverettEllipse2 = -4.979d-05*(beta2-alpha2)+4.351d-09*(beta2**2.0d0-alpha2**2.0d0)+1.392d-13*(beta2**3.0d0-alpha2**3.0d0)-&
    !6.408d-13*(beta2*alpha2**2.0d0-beta2**2.0d0 * alpha2)
    EverettEllipse2 = -5.823d-05*(beta2-alpha2)+6.94d-9*(beta2**2-alpha2**2)

    if (alpha > 1000.0d0) then
      !write(*,*) EverettEllipse1, EverettEllipse2
    end if

    EverettEllipse_out = EverettEllipse1
    return
  end subroutine EverettEllipse
  ! -------------------------------------------------------------------------------------------------------------------
  subroutine dEverettEllipseda(alpha,beta,bh, dEverettEllipseda_out )
    ! Description :
    ! Calcul de la derivee de la fonction d'Everett bilineaire.
    implicit none
    ! Inputs :
    double precision, intent(in)                            :: alpha, beta
    double precision, dimension(maxParam), intent(in)       :: bh
    ! Outputs :
    double precision, intent(out)                           :: dEverettEllipseda_out
    double precision                                        :: dEverettEllipseda1, dEverettEllipseda2
    ! Variables:
    ! Induction a remanence
    double precision                                        :: dBdowndH1, dBdowndH2
    double precision                                        :: alpha2, beta2

    if (alpha < -beta) then
      beta2 = -alpha
      alpha2 = -beta

    else
      alpha2 = alpha
      beta2 = beta
    end if
    !dEverettEllipseda2 = -4.979d-05*(-1.0d0)+4.351d-09*(-2.0d0*alpha2)+1.392d-13*(-3.0d0*alpha2**2.0d0)-&
    !6.408d-13*(2.0d0*beta2*alpha2-beta2**2.0d0)

    dEverettEllipseda2 = -5.823d-05*(-1)+6.94d-9*(-alpha2*2)

    call CalculdBdowndHmax1(alpha2,alpha2,bh, dBdowndH1)
    call CalculdBdowndHmax1(alpha2,beta2,bh, dBdowndH2)
    dEverettEllipseda1 = (dBdowndH1 -dBdowndH2 )/2.0d0
    if (alpha > 1000.0d0) then
      !write(*,*) dEverettEllipseda1, dEverettEllipseda2
    end if

    dEverettEllipseda_out = dEverettEllipseda1

    return
  end subroutine dEverettEllipseda
  ! -------------------------------------------------------------------------------------------------------------------
  subroutine dEverettEllipsedb(alpha,beta,bh, dEverettEllipsedb_out )
    ! Description :
    ! Calcul de la derivee de la fonction d'Everett bilineaire.
    implicit none
    ! Inputs :
    double precision, intent(in)                            :: alpha, beta
    double precision, dimension(maxParam), intent(in)       :: bh
    ! Outputs :
    double precision, intent(out)                           :: dEverettEllipsedb_out
    double precision                                        :: dEverettEllipsedb1, dEverettEllipsedb2
    ! Variables:
    ! Induction a remanence
    double precision                                        :: dBdowndH1, dBdowndH2

    double precision                                        :: alpha2, beta2

    if (alpha < -beta) then
      beta2 = -alpha
      alpha2 = -beta
    else
      alpha2 = alpha
      beta2 = beta
    end if
    !dEverettEllipsedb2 = -4.979d-05*(1.0d0)+4.351d-09*(2*beta2)+1.392d-13*(3*beta2**2.0d0)-&
    !6.408d-13*(alpha2**2.0d0-2.0d0*beta2 * alpha2)
    dEverettEllipsedb2 = -5.823d-05+6.94d-9*(beta2*2)

    call CalculdBdowndH(alpha2,alpha2,bh, dBdowndH1)
    call CalculdBdowndH(alpha2,beta2,bh, dBdowndH2)
    dEverettEllipsedb1 = ( dBdowndH1-dBdowndH2 )/2.0d0
    if (alpha > 1000.0d0) then
      !write(*,*) dEverettEllipsedb1, dEverettEllipsedb2
    end if

    dEverettEllipsedb_out = dEverettEllipsedb1

    return
  end subroutine dEverettEllipsedb
  ! -------------------------------------------------------------------------------------------------------------------

  subroutine CalculdBdowndH (Hmax,H,bh, dBdowndH)
    ! Description :
    ! Calcul des fonction F(H) et G(H) pour le modele de Preisach. Recuperation de l'induction a remanence.
    implicit none
    ! Inputs :
    ! Parametres de la courbe BH
    double precision, dimension(maxParam), intent(in)       :: bh
    ! Champ mag
    double precision, intent(in)                            :: H
    double precision, intent(in)                            :: Hmax
    ! Outputs :
    ! Valeur de la fonction B down et sa derivee
    double precision, intent(out)                           :: dBdowndH

    ! Variables :
    double precision                                        :: a, b, alpha, Bdown, discr, brem
    double precision                                        :: num, denom, A2, C, D
    ! Recuperation des parametres

    call GetEllipseParameters (bh,Hmax , a,b,alpha,brem)
    if (abs(Hmax) < epsilon(1.0d0) ) then
      Bdown = 0.0d0
      dBdowndH = 0.0d0
    else

      A2 = (sin(alpha)/a)**2.0d0 + (cos(alpha)/b)**2.0d0
      C = 2.0d0*cos(alpha)*sin(alpha)*(1.0d0/(a**2.0d0) - 1.0d0/(b**2.0d0))*(H)
      D = ((cos(alpha)/a)**2.0d0 + (sin(alpha)/b)**2.0d0)*(H**2.0d0) - 1.0d0
      discr = C**2.0d0 - 4.0d0*A2*D
      Bdown = (-C + sqrt(discr))/(2.0d0*A2)

      num = ((H*cos(alpha)+Bdown*sin(alpha))*cos(alpha))/a**2.0d0 + ((H*sin(alpha)-Bdown*cos(alpha))*sin(alpha))/b**2.0d0
      denom = (-(H*cos(alpha)+Bdown*sin(alpha))*sin(alpha))/a**2.0d0 + ((H*sin(alpha)-Bdown*cos(alpha))*cos(alpha))/b**2.0d0
      dBdowndH = num/denom

    end if

    return
  end subroutine CalculdBdowndH

  subroutine CalculdBdowndHmax1 (Hmax,H,bh, dBdowndHmax)
    ! Description :
    ! Calcul des fonction F(H) et G(H) pour le modele de Preisach. Recuperation de l'induction a remanence.
    implicit none
    ! Inputs :
    ! Parametres de la courbe BH
    double precision, dimension(maxParam), intent(in)       :: bh
    ! Champ mag
    double precision, intent(in)                            :: H
    double precision, intent(in)                            :: Hmax
    ! Outputs :
    ! Valeur de la fonction B down et sa derivee
    double precision, intent(out)                           :: dBdowndHmax

    ! Variables :
    double precision                                        :: a, b, alpha, Bdown, discr, brem
    double precision                                        :: num, denom, A2, C, D
    ! Recuperation des parametres

    call GetEllipseParameters (bh,Hmax , a,b,alpha,brem)

    if (abs(Hmax) < epsilon(1.0d0) ) then
      Bdown = 0.0d0
      dBdowndHmax = 0.0d0
    else
      A2 = (sin(alpha)/a)**2.0d0 + (cos(alpha)/b)**2.0d0
      C = 2.0d0*cos(alpha)*sin(alpha)*(1.0d0/(a**2.0d0) - 1.0d0/(b**2.0d0))*(H)
      D = ((cos(alpha)/a)**2.0d0 + (sin(alpha)/b)**2.0d0)*(H**2.0d0) - 1.0d0
      discr = C**2.0d0 - 4.0d0*A2*D
      Bdown = (-C + sqrt(discr))/(2.0d0*A2)

      num = ((H*sin(alpha)-Bdown*cos(alpha))**2.0d0)/(Hmax*b**2.0d0) + ((H*cos(alpha)+Bdown*sin(alpha))**2.0d0)/(Hmax*a**2.0d0)
      denom = ((H*cos(alpha)+Bdown*sin(alpha))*sin(alpha))/(a**2.0d0) - ((H*sin(alpha)-Bdown*cos(alpha))*cos(alpha))/(b**2.0d0)
      dBdowndHmax = num/denom
    end if

    return
  end subroutine CalculdBdowndHmax1

  subroutine CalculdBdowndHmax2 (Hmax,bh, dBdowndHmax)
    ! Description :
    ! Calcul des fonction F(H) et G(H) pour le modele de Preisach. Recuperation de l'induction a remanence.
    implicit none
    ! Inputs :
    ! Parametres de la courbe BH
    double precision, dimension(maxParam), intent(in)       :: bh
    ! Champ mag
    double precision, intent(in)                            :: Hmax
    ! Outputs :
    ! Valeur de la fonction B down et sa derivee
    double precision, intent(out)                           :: dBdowndHmax

    ! Variables :
    double precision                                        :: a, b, alpha, Bdown, discr, brem
    double precision                                        :: num, denom, A2, C, D
    ! Recuperation des parametres

    call GetEllipseParameters (bh,Hmax , a,b,alpha,brem)

    if (abs(Hmax) < epsilon(1.0d0) ) then
      Bdown = 0.0d0
      dBdowndHmax = 0.0d0
    else
      A2 = (sin(alpha)/a)**2.0d0 + (cos(alpha)/b)**2.0d0
      C = 2.0d0*cos(alpha)*sin(alpha)*(1.0d0/(a**2.0d0) - 1.0d0/(b**2.0d0))*(Hmax)
      D = ((cos(alpha)/a)**2.0d0 + (sin(alpha)/b)**2.0d0)*(Hmax**2.0d0) - 1.0d0
      discr = C**2.0d0 - 4.0d0*A2*D
      Bdown = (-C + sqrt(discr))/(2.0d0*A2)

      num = ((Hmax*sin(alpha)-Bdown*cos(alpha))**2.0d0)/(Hmax*b**2.0d0) + &
      ((Hmax*cos(alpha)+Bdown*sin(alpha))**2.0d0)/(Hmax*a**2.0d0)- &
      (Hmax*cos(alpha)+Bdown*sin(alpha))*cos(alpha)/a**2.0d0 - (Hmax*sin(alpha)-Bdown*cos(alpha))*sin(alpha)/b**2.0d0

      denom = ((Hmax*cos(alpha)+Bdown*sin(alpha))*sin(alpha))/(a**2.0d0) - &
      ((Hmax*sin(alpha)-Bdown*cos(alpha))*cos(alpha))/(b**2.0d0)
      dBdowndHmax = num/denom
    end if

    return
  end subroutine CalculdBdowndHmax2

  subroutine CalculFG4param (bh,H , brem,F,dFdH,G,dGdH)
    ! Description :
    ! Calcul des fonction F(H) et G(H) pour le modele de Preisach. Recuperation de l'induction a remanence.
    implicit none
    ! Inputs :
    ! Parametres de la courbe BH
    double precision, dimension(maxParam), intent(in)       :: bh
    ! Champ mag
    double precision, intent(in)                            :: H
    ! Outputs :
    ! Induction a remanence
    double precision, intent(out)                           :: brem
    ! Valeur de la fonction F et sa derivee
    double precision, intent(out)                           :: F, dFdH
    ! Valeur de la fonction G et sa derivee
    double precision, intent(out)                           :: G, dGdH

    ! Variables :
    integer                                                 :: i, natan
    double precision, dimension(maxAtan)                    :: ai, bi, ci
    double precision                                        :: muFmax, bsat
    double precision                                        :: xia, xid

    brem = bh(2)
    muFmax = bh(8)*mu0

    ! Cas H = 0
    if ( abs(H) < epsilon(1.0d0) ) then
      F = 0.0d0
      dFdH = muFmax
      G = 0.0d0
      dGdH = 0.0d0

    ! Cas H < 0
    else if ( H < 0.0d0 ) then

      F = -(bh(3)-brem)*(-H/bh(7))*(1.0d0+(-H/bh(7))**(bh(5)+1.0d0))**(-1.0d0/(bh(5)+1.0d0))
      dFdH = ((bh(3)-brem)*(1.0d0+(-H/bh(7))**(bh(5)+1.0d0))**(-1.0d0/(bh(5)+1.0d0)))/(-H*(-H/bh(7))**(bh(5))+bh(7))
      G = -brem+brem*(1.0d0+(-H/bh(6))**(bh(5)+2.0d0))**(-1.0d0)
      dGdH = (brem*(bh(5)+2.0d0)*(-H)*(-H/bh(6))**(bh(5)))/((bh(6)**2.0d0)*(1.0d0+(-H/bh(6))**(bh(5)+2.0d0))**2.0d0)

    ! Cas H > 0
    else

      F = (bh(3)-brem)*(H/bh(7))*(1.0d0+(H/bh(7))**(bh(5)+1.0d0))**(-1.0d0/(bh(5)+1.0d0))
      dFdH = ((bh(3)-brem)*(1.0d0+(H/bh(7))**(bh(5)+1.0d0))**(-1.0d0/(bh(5)+1.0d0)))/(H*(H/bh(7))**(bh(5))+bh(7))
      G = brem-brem*(1.0d0+(H/bh(6))**(bh(5)+2.0d0))**(-1.0d0)
      dGdH = (brem*(bh(5)+2.0d0)*H*(H/bh(6))**(bh(5)))/((bh(6)**2.0d0)*(1.0d0+(H/bh(6))**(bh(5)+2.0d0))**2.0d0)

    end if

    return
  end subroutine CalculFG4param
end module


      SUBROUTINE SB03MY( TRANA, N, A, LDA, C, LDC, SCALE, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To solve the real Lyapunov matrix equation
C
C            op(A)'*X + X*op(A) = scale*C
C
C     where op(A) = A or A' (A**T), A is upper quasi-triangular and C is
C     symmetric (C = C'). (A' denotes the transpose of the matrix A.)
C     A is N-by-N, the right hand side C and the solution X are N-by-N,
C     and scale is an output scale factor, set less than or equal to 1
C     to avoid overflow in X. The solution matrix X is overwritten
C     onto C.
C
C     A must be in Schur canonical form (as returned by LAPACK routines
C     DGEES or DHSEQR), that is, block upper triangular with 1-by-1 and
C     2-by-2 diagonal blocks; each 2-by-2 diagonal block has its
C     diagonal elements equal and its off-diagonal elements of opposite
C     sign.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     TRANA   CHARACTER*1
C             Specifies the form of op(A) to be used, as follows:
C             = 'N':  op(A) = A    (No transpose);
C             = 'T':  op(A) = A**T (Transpose);
C             = 'C':  op(A) = A**T (Conjugate transpose = Transpose).
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrices A, X, and C.  N >= 0.
C
C     A       (input) DOUBLE PRECISION array, dimension (LDA,N)
C             The leading N-by-N part of this array must contain the
C             upper quasi-triangular matrix A, in Schur canonical form.
C             The part of A below the first sub-diagonal is not
C             referenced.
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= MAX(1,N).
C
C     C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
C             On entry, the leading N-by-N part of this array must
C             contain the symmetric matrix C.
C             On exit, if INFO >= 0, the leading N-by-N part of this
C             array contains the symmetric solution matrix X.
C
C     LDC     INTEGER
C             The leading dimension of array C.  LDC >= MAX(1,N).
C
C     SCALE   (output) DOUBLE PRECISION
C             The scale factor, scale, set less than or equal to 1 to
C             prevent the solution overflowing.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value;
C             = 1:  if A and -A have common or very close eigenvalues;
C                   perturbed values were used to solve the equation
C                   (but the matrix A is unchanged).
C
C     METHOD
C
C     Bartels-Stewart algorithm is used. A set of equivalent linear
C     algebraic systems of equations of order at most four are formed
C     and solved using Gaussian elimination with complete pivoting.
C
C     REFERENCES
C
C     [1] Bartels, R.H. and Stewart, G.W.  T
C         Solution of the matrix equation A X + XB = C.
C         Comm. A.C.M., 15, pp. 820-826, 1972.
C
C     NUMERICAL ASPECTS
C                               3
C     The algorithm requires 0(N ) operations.
C
C     CONTRIBUTOR
C
C     Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, May 1997.
C     Supersedes Release 2.0 routine SB03AY by Control Systems Research
C     Group, Kingston Polytechnic, United Kingdom, October 1982.
C     Based on DTRLYP by P. Petkov, Tech. University of Sofia, September
C     1993.
C
C     REVISIONS
C
C     V. Sima, Katholieke Univ. Leuven, Belgium, May 1999.
C
C     KEYWORDS
C
C     Continuous-time system, Lyapunov equation, matrix algebra, real
C     Schur form.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
C     ..
C     .. Scalar Arguments ..
      CHARACTER          TRANA
      INTEGER            INFO, LDA, LDC, N
      DOUBLE PRECISION   SCALE
C     ..
C     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), C( LDC, * )
C     ..
C     .. Local Scalars ..
      LOGICAL            NOTRNA, LUPPER
      INTEGER            IERR, J, K, K1, K2, KNEXT, L, L1, L2, LNEXT,
     $                   MINK1N, MINK2N, MINL1N, MINL2N
      DOUBLE PRECISION   A11, BIGNUM, DA11, DB, EPS, SCALOC, SMIN,
     $                   SMLNUM, XNORM
C     ..
C     .. Local Arrays ..
      DOUBLE PRECISION   DUM( 1 ), VEC( 2, 2 ), X( 2, 2 )
C     ..
C     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DDOT, DLAMCH, DLANHS
      EXTERNAL           DDOT, DLAMCH, DLANHS, LSAME
C     ..
C     .. External Subroutines ..
      EXTERNAL           DLABAD, DLALN2, DLASY2, DSCAL, SB03MW, XERBLA
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC          ABS, DBLE, MAX, MIN
C     ..
C     .. Executable Statements ..
C
C     Decode and Test input parameters.
C
      NOTRNA = LSAME( TRANA, 'N' )
      LUPPER = .TRUE.
C
      INFO = 0
      IF( .NOT.NOTRNA .AND. .NOT.LSAME( TRANA, 'T' ) .AND.
     $                      .NOT.LSAME( TRANA, 'C' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -4
      ELSE IF( LDC.LT.MAX( 1, N ) ) THEN
         INFO = -6
      END IF
C
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'SB03MY', -INFO )
         RETURN
      END IF
C
      SCALE = ONE
C
C     Quick return if possible.
C
      IF( N.EQ.0 )
     $   RETURN
C
C     Set constants to control overflow.
C
      EPS = DLAMCH( 'P' )
      SMLNUM = DLAMCH( 'S' )
      BIGNUM = ONE / SMLNUM
      CALL DLABAD( SMLNUM, BIGNUM )
      SMLNUM = SMLNUM*DBLE( N*N ) / EPS
      BIGNUM = ONE / SMLNUM
C
      SMIN = MAX( SMLNUM, EPS*DLANHS( 'Max', N, A, LDA, DUM ) )
C
      IF( NOTRNA ) THEN
C
C        Solve    A'*X + X*A = scale*C.
C
C        The (K,L)th block of X is determined starting from
C        upper-left corner column by column by
C
C          A(K,K)'*X(K,L) + X(K,L)*A(L,L) = C(K,L) - R(K,L),
C
C        where
C                   K-1                    L-1
C          R(K,L) = SUM [A(I,K)'*X(I,L)] + SUM [X(K,J)*A(J,L)].
C                   I=1                    J=1
C
C        Start column loop (index = L).
C        L1 (L2): column index of the first (last) row of X(K,L).
C
         LNEXT = 1
C
         DO 60 L = 1, N
            IF( L.LT.LNEXT )
     $         GO TO 60
            L1 = L
            L2 = L
            IF( L.LT.N ) THEN
               IF( A( L+1, L ).NE.ZERO )
     $            L2 = L2 + 1
               LNEXT = L2 + 1
            END IF
C
C           Start row loop (index = K).
C           K1 (K2): row index of the first (last) row of X(K,L).
C
            KNEXT = L
C
            DO 50 K = L, N
               IF( K.LT.KNEXT )
     $            GO TO 50
               K1 = K
               K2 = K
               IF( K.LT.N ) THEN
                  IF( A( K+1, K ).NE.ZERO )
     $               K2 = K2 + 1
                  KNEXT = K2 + 1
               END IF
C
               IF( L1.EQ.L2 .AND. K1.EQ.K2 ) THEN
                  VEC( 1, 1 ) = C( K1, L1 ) -
     $               ( DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) +
     $                 DDOT( L1-1, C( K1, 1 ), LDC, A( 1, L1 ), 1 ) )
                  SCALOC = ONE
C
                  A11 = A( K1, K1 ) + A( L1, L1 )
                  DA11 = ABS( A11 )
                  IF( DA11.LE.SMIN ) THEN
                     A11 = SMIN
                     DA11 = SMIN
                     INFO = 1
                  END IF
                  DB = ABS( VEC( 1, 1 ) )
                  IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN
                     IF( DB.GT.BIGNUM*DA11 )
     $                  SCALOC = ONE / DB
                  END IF
                  X( 1, 1 ) = ( VEC( 1, 1 )*SCALOC ) / A11
C
                  IF( SCALOC.NE.ONE ) THEN
C
                     DO 10 J = 1, N
                        CALL DSCAL( N, SCALOC, C( 1, J ), 1 )
   10                CONTINUE
C
                     SCALE = SCALE*SCALOC
                  END IF
                  C( K1, L1 ) = X( 1, 1 )
                  IF( K1.NE.L1 ) THEN
                     C( L1, K1 ) = X( 1, 1 )
                  END IF
C
               ELSE IF( L1.EQ.L2 .AND. K1.NE.K2 ) THEN
C
                  VEC( 1, 1 ) = C( K1, L1 ) -
     $               ( DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) +
     $                 DDOT( L1-1, C( K1, 1 ), LDC, A( 1, L1 ), 1 ) )
C
                  VEC( 2, 1 ) = C( K2, L1 ) -
     $               ( DDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 ) +
     $                 DDOT( L1-1, C( K2, 1 ), LDC, A( 1, L1 ), 1 ) )
C
                  CALL DLALN2( .TRUE., 2, 1, SMIN, ONE, A( K1, K1 ),
     $                         LDA, ONE, ONE, VEC, 2, -A( L1, L1 ),
     $                         ZERO, X, 2, SCALOC, XNORM, IERR )
                  IF( IERR.NE.0 )
     $               INFO = 1
C
                  IF( SCALOC.NE.ONE ) THEN
C
                     DO 20 J = 1, N
                        CALL DSCAL( N, SCALOC, C( 1, J ), 1 )
   20                CONTINUE
C
                     SCALE = SCALE*SCALOC
                  END IF
                  C( K1, L1 ) = X( 1, 1 )
                  C( K2, L1 ) = X( 2, 1 )
                  C( L1, K1 ) = X( 1, 1 )
                  C( L1, K2 ) = X( 2, 1 )
C
               ELSE IF( L1.NE.L2 .AND. K1.EQ.K2 ) THEN
C
                  VEC( 1, 1 ) = C( K1, L1 ) -
     $               ( DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) +
     $                 DDOT( L1-1, C( K1, 1 ), LDC, A( 1, L1 ), 1 ) )
C
                  VEC( 2, 1 ) = C( K1, L2 ) -
     $               ( DDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 ) +
     $                 DDOT( L1-1, C( K1, 1 ), LDC, A( 1, L2 ), 1 ) )
C
                  CALL DLALN2( .TRUE., 2, 1, SMIN, ONE, A( L1, L1 ),
     $                         LDA, ONE, ONE, VEC, 2, -A( K1, K1 ),
     $                         ZERO, X, 2, SCALOC, XNORM, IERR )
                  IF( IERR.NE.0 )
     $               INFO = 1
C
                  IF( SCALOC.NE.ONE ) THEN
C
                     DO 30 J = 1, N
                        CALL DSCAL( N, SCALOC, C( 1, J ), 1 )
   30                CONTINUE
C
                     SCALE = SCALE*SCALOC
                  END IF
                  C( K1, L1 ) = X( 1, 1 )
                  C( K1, L2 ) = X( 2, 1 )
                  C( L1, K1 ) = X( 1, 1 )
                  C( L2, K1 ) = X( 2, 1 )
C
               ELSE IF( L1.NE.L2 .AND. K1.NE.K2 ) THEN
C
                  VEC( 1, 1 ) = C( K1, L1 ) -
     $               ( DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) +
     $                 DDOT( L1-1, C( K1, 1 ), LDC, A( 1, L1 ), 1 ) )
C
                  VEC( 1, 2 ) = C( K1, L2 ) -
     $               ( DDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 ) +
     $                 DDOT( L1-1, C( K1, 1 ), LDC, A( 1, L2 ), 1 ) )
C
                  VEC( 2, 1 ) = C( K2, L1 ) -
     $               ( DDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 ) +
     $                 DDOT( L1-1, C( K2, 1 ), LDC, A( 1, L1 ), 1 ) )
C
                  VEC( 2, 2 ) = C( K2, L2 ) -
     $               ( DDOT( K1-1, A( 1, K2 ), 1, C( 1, L2 ), 1 ) +
     $                 DDOT( L1-1, C( K2, 1 ), LDC, A( 1, L2 ), 1 ) )
C
                  IF( K1.EQ.L1 ) THEN
                     CALL SB03MW( .FALSE., LUPPER, A( K1, K1 ), LDA,
     $                            VEC, 2, SCALOC, X, 2, XNORM, IERR )
                     IF( LUPPER ) THEN
                        X( 2, 1 ) = X( 1, 2 )
                     ELSE
                        X( 1, 2 ) = X( 2, 1 )
                     END IF
                  ELSE
                     CALL DLASY2( .TRUE., .FALSE., 1, 2, 2, A( K1, K1 ),
     $                            LDA, A( L1, L1 ), LDA, VEC, 2, SCALOC,
     $                            X, 2, XNORM, IERR )
                  END IF
                  IF( IERR.NE.0 )
     $               INFO = 1
C
                  IF( SCALOC.NE.ONE ) THEN
C
                     DO 40 J = 1, N
                        CALL DSCAL( N, SCALOC, C( 1, J ), 1 )
   40                CONTINUE
C
                     SCALE = SCALE*SCALOC
                  END IF
                  C( K1, L1 ) = X( 1, 1 )
                  C( K1, L2 ) = X( 1, 2 )
                  C( K2, L1 ) = X( 2, 1 )
                  C( K2, L2 ) = X( 2, 2 )
                  IF( K1.NE.L1 ) THEN
                     C( L1, K1 ) = X( 1, 1 )
                     C( L2, K1 ) = X( 1, 2 )
                     C( L1, K2 ) = X( 2, 1 )
                     C( L2, K2 ) = X( 2, 2 )
                  END IF
               END IF
C
   50       CONTINUE
C
   60    CONTINUE
C
      ELSE
C
C        Solve    A*X + X*A' = scale*C.
C
C        The (K,L)th block of X is determined starting from
C        bottom-right corner column by column by
C
C            A(K,K)*X(K,L) + X(K,L)*A(L,L)' = C(K,L) - R(K,L),
C
C        where
C                      N                     N
C            R(K,L) = SUM [A(K,I)*X(I,L)] + SUM [X(K,J)*A(L,J)'].
C                    I=K+1                 J=L+1
C
C        Start column loop (index = L).
C        L1 (L2): column index of the first (last) row of X(K,L).
C
         LNEXT = N
C
         DO 120 L = N, 1, -1
            IF( L.GT.LNEXT )
     $         GO TO 120
            L1 = L
            L2 = L
            IF( L.GT.1 ) THEN
               IF( A( L, L-1 ).NE.ZERO )
     $            L1 = L1 - 1
               LNEXT = L1 - 1
            END IF
            MINL1N = MIN( L1+1, N )
            MINL2N = MIN( L2+1, N )
C
C           Start row loop (index = K).
C           K1 (K2): row index of the first (last) row of X(K,L).
C
            KNEXT = L
C
            DO 110 K = L, 1, -1
               IF( K.GT.KNEXT )
     $            GO TO 110
               K1 = K
               K2 = K
               IF( K.GT.1 ) THEN
                  IF( A( K, K-1 ).NE.ZERO )
     $               K1 = K1 - 1
                  KNEXT = K1 - 1
               END IF
               MINK1N = MIN( K1+1, N )
               MINK2N = MIN( K2+1, N )
C
               IF( L1.EQ.L2 .AND. K1.EQ.K2 ) THEN
                  VEC( 1, 1 ) = C( K1, L1 ) -
     $               ( DDOT( N-K1, A( K1, MINK1N ), LDA,
     $                       C( MINK1N, L1 ), 1 ) +
     $                 DDOT( N-L1, C( K1, MINL1N ), LDC,
     $                       A( L1, MINL1N ), LDA ) )
                  SCALOC = ONE
C
                  A11 = A( K1, K1 ) + A( L1, L1 )
                  DA11 = ABS( A11 )
                  IF( DA11.LE.SMIN ) THEN
                     A11 = SMIN
                     DA11 = SMIN
                     INFO = 1
                  END IF
                  DB = ABS( VEC( 1, 1 ) )
                  IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN
                     IF( DB.GT.BIGNUM*DA11 )
     $                  SCALOC = ONE / DB
                  END IF
                  X( 1, 1 ) = ( VEC( 1, 1 )*SCALOC ) / A11
C
                  IF( SCALOC.NE.ONE ) THEN
C
                     DO 70 J = 1, N
                        CALL DSCAL( N, SCALOC, C( 1, J ), 1 )
   70                CONTINUE
C
                     SCALE = SCALE*SCALOC
                  END IF
                  C( K1, L1 ) = X( 1, 1 )
                  IF( K1.NE.L1 ) THEN
                     C( L1, K1 ) = X( 1, 1 )
                  END IF
C
               ELSE IF( L1.EQ.L2 .AND. K1.NE.K2 ) THEN
C
                  VEC( 1, 1 ) = C( K1, L1 ) -
     $               ( DDOT( N-K2, A( K1, MINK2N ), LDA,
     $                       C( MINK2N, L1 ), 1 ) +
     $                 DDOT( N-L2, C( K1, MINL2N ), LDC,
     $                       A( L1, MINL2N ), LDA ) )
C
                  VEC( 2, 1 ) = C( K2, L1 ) -
     $               ( DDOT( N-K2, A( K2, MINK2N ), LDA,
     $                     C( MINK2N, L1 ), 1 ) +
     $                 DDOT( N-L2, C( K2, MINL2N ), LDC,
     $                     A( L1, MINL2N ), LDA ) )
C
                  CALL DLALN2( .FALSE., 2, 1, SMIN, ONE, A( K1, K1 ),
     $                         LDA, ONE, ONE, VEC, 2, -A( L1, L1 ),
     $                         ZERO, X, 2, SCALOC, XNORM, IERR )
                  IF( IERR.NE.0 )
     $               INFO = 1
C
                  IF( SCALOC.NE.ONE ) THEN
C
                     DO 80 J = 1, N
                        CALL DSCAL( N, SCALOC, C( 1, J ), 1 )
   80                CONTINUE
C
                     SCALE = SCALE*SCALOC
                  END IF
                  C( K1, L1 ) = X( 1, 1 )
                  C( K2, L1 ) = X( 2, 1 )
                  C( L1, K1 ) = X( 1, 1 )
                  C( L1, K2 ) = X( 2, 1 )
C
               ELSE IF( L1.NE.L2 .AND. K1.EQ.K2 ) THEN
C
                  VEC( 1, 1 ) = C( K1, L1 ) -
     $               ( DDOT( N-K1, A( K1, MINK1N ), LDA,
     $                       C( MINK1N, L1 ), 1 ) +
     $                 DDOT( N-L2, C( K1, MINL2N ), LDC,
     $                       A( L1, MINL2N ), LDA ) )
C
                  VEC( 2, 1 ) = C( K1, L2 ) -
     $               ( DDOT( N-K1, A( K1, MINK1N ), LDA,
     $                       C( MINK1N, L2 ), 1 ) +
     $                 DDOT( N-L2, C( K1, MINL2N ), LDC,
     $                       A( L2, MINL2N ), LDA ) )
C
                  CALL DLALN2( .FALSE., 2, 1, SMIN, ONE, A( L1, L1 ),
     $                         LDA, ONE, ONE, VEC, 2, -A( K1, K1 ),
     $                         ZERO, X, 2, SCALOC, XNORM, IERR )
                  IF( IERR.NE.0 )
     $               INFO = 1
C
                  IF( SCALOC.NE.ONE ) THEN
C
                     DO 90 J = 1, N
                        CALL DSCAL( N, SCALOC, C( 1, J ), 1 )
   90                CONTINUE
C
                     SCALE = SCALE*SCALOC
                  END IF
                  C( K1, L1 ) = X( 1, 1 )
                  C( K1, L2 ) = X( 2, 1 )
                  C( L1, K1 ) = X( 1, 1 )
                  C( L2, K1 ) = X( 2, 1 )
C
               ELSE IF( L1.NE.L2 .AND. K1.NE.K2 ) THEN
C
                  VEC( 1, 1 ) = C( K1, L1 ) -
     $               ( DDOT( N-K2, A( K1, MINK2N ), LDA,
     $                       C( MINK2N, L1 ), 1 ) +
     $                 DDOT( N-L2, C( K1, MINL2N ), LDC,
     $                       A( L1, MINL2N ), LDA ) )
C
                  VEC( 1, 2 ) = C( K1, L2 ) -
     $               ( DDOT( N-K2, A( K1, MINK2N ), LDA,
     $                       C( MINK2N, L2 ), 1 ) +
     $                 DDOT( N-L2, C( K1, MINL2N ), LDC,
     $                       A( L2, MINL2N ), LDA ) )
C
                  VEC( 2, 1 ) = C( K2, L1 ) -
     $               ( DDOT( N-K2, A( K2, MINK2N ), LDA,
     $                       C( MINK2N, L1 ), 1 ) +
     $                 DDOT( N-L2, C( K2, MINL2N ), LDC,
     $                       A( L1, MINL2N ), LDA ) )
C
                  VEC( 2, 2 ) = C( K2, L2 ) -
     $               ( DDOT( N-K2, A( K2, MINK2N ), LDA,
     $                       C( MINK2N, L2 ), 1 ) +
     $                 DDOT( N-L2, C( K2, MINL2N ), LDC,
     $                       A( L2, MINL2N ), LDA ) )
C
                  IF( K1.EQ.L1 ) THEN
                     CALL SB03MW( .TRUE., LUPPER, A( K1, K1 ), LDA, VEC,
     $                            2, SCALOC, X, 2, XNORM, IERR )
                     IF( LUPPER ) THEN
                        X( 2, 1 ) = X( 1, 2 )
                     ELSE
                        X( 1, 2 ) = X( 2, 1 )
                     END IF
                  ELSE
                     CALL DLASY2( .FALSE., .TRUE., 1, 2, 2, A( K1, K1 ),
     $                            LDA, A( L1, L1 ), LDA, VEC, 2, SCALOC,
     $                            X, 2, XNORM, IERR )
                  END IF
                  IF( IERR.NE.0 )
     $               INFO = 1
C
                  IF( SCALOC.NE.ONE ) THEN
C
                     DO 100 J = 1, N
                        CALL DSCAL( N, SCALOC, C( 1, J ), 1 )
  100                CONTINUE
C
                     SCALE = SCALE*SCALOC
                  END IF
                  C( K1, L1 ) = X( 1, 1 )
                  C( K1, L2 ) = X( 1, 2 )
                  C( K2, L1 ) = X( 2, 1 )
                  C( K2, L2 ) = X( 2, 2 )
                  IF( K1.NE.L1 ) THEN
                     C( L1, K1 ) = X( 1, 1 )
                     C( L2, K1 ) = X( 1, 2 )
                     C( L1, K2 ) = X( 2, 1 )
                     C( L2, K2 ) = X( 2, 2 )
                  END IF
               END IF
C
  110       CONTINUE
C
  120    CONTINUE
C
      END IF
C
      RETURN
C *** Last line of SB03MY ***
      END