!     .................................................
!             ____  _       _   ____  _____   _
!            |  _ \| |     |_| |  _ \|  ___| |_|
!            | |_) | |___   _  | |_) | |___   _
!            |  _ /|  _  | | | |  _ /|___  | | |
!            | |   | | | | | | | |    ___| | | |
!            |_|   |_| |_| |_| |_|   |_____| |_|
!     .................................................
!     PhiPsi:     a general-purpose computational
!                 mechanics program written in Fortran.
!     Website:    http://phipsi.top
!     Author:     Shi Fang from Huaiyin Institute of
!                 Technology, HuaiAn, JiangSu, China
!     Contact me: shifang@hyit.edu.cn
!     ------------------------------------------------
!     Please cite the following papers:
!     (1)Shi F, Wang X L, Liu C, Liu H, Wu H A. An
!        XFEM-based method with reduction technique
!        for modeling hydraulic fracture propagation
!        in formations containing frictional natural
!        fractures. Engineering Fracture Mechanics,
!        2017, 173: 64-90.
!     (2)Shi F, Wang X L, Liu C, Liu H, Wu H A. A
!        coupled extended finite element approach
!        for modeling hydraulic fracturing in
!        consideration of proppant. Journal of
!        Natural Gas Science and Engineering, 2016,
!        33: 885-897.
!     (3)Shi F, Wang X L, Liu C, Liu H, Wu H A. An
!        XFEM-based numerical model to calculate
!        conductivity of propped fracture considering
!        proppant transport, embedment and crushing.
!        Journal of Petroleum Science and Engineering,
!        2018, 167: 615-626..

      subroutine Cal_B_Matrix(kesi,yita,
     &                        i_C,i_E,i_G,
     &                        c_NN,c_X_NODES,c_Y_NODES,
     &                        tem_B,num_tem_B)
c     calculate B matrix.

      use Global_Crack
      use Global_Model
      use Global_Filename
      use Global_Common
      use Global_Material

      implicit none

      integer,intent(in)::i_C,i_E,i_G
      double precision,intent(in)::c_X_NODES(4),c_Y_NODES(4)
      integer,intent(in)::c_NN(4)
      double precision,intent(in)::kesi,yita
      double precision,intent(out)::tem_B(3,40)
      integer,intent(out)::num_tem_B
      double precision detJ, J(2,2), Inverse_J(2,2)
      double precision N(2,8),dNdkesi(4,2),dNdx(4,2),Coor_AB(2,2)
      integer mat_num,c_mat_type
      double precision B_FEM(3,8),B_XFEM(3,32),BI_enr(3,2)
      integer num_B_XFEM
      integer i_N,ref_elem,i_F
      logical Flag_Check_Kink_Tip,Yes_Gauss_in_BCD,Yes_in_KAB
      double precision distance_Vertex,Global_coor_Gauss(2),
     &           Tri_KAB(3,2),Closed_Tri_KAB(4,2),
     &           H _i,omega, Coor_Tip(2),Trans_Matrix(2,2),
     &           H_Vertex,distance_Gauss,H_gp,distance_Node
      integer  i_tem
      double precision  J_gp, J_i,c_Segment(2)
      integer find_element(8)
      double precision Global_coor_Gauss_Doc(2),xp_Gauss(2),r_Gauss,
     &                 theta_Gauss,xp_Node(2),r_Node,theta_Node
      double precision dFdx(4),dFdy(4),F_Gauss(4),F_Node(4)
      double precision c_N(4),aa,bb,B_enr(3,2),BI_enr_Tip(3,8)
      integer num_BI_enr_Tip

      call Cal_N_dNdkesi_J_detJ(kesi,yita,
     &                           c_X_NODES,c_Y_NODES,
     &                           detJ,J,N,dNdkesi)

      call Matrix_Inverse(J,Inverse_J,2)

      dNdx = MATMUL(dNdkesi,Inverse_J)

      Global_coor_Gauss(1) = DOT_PRODUCT(N(1,1:7:2),c_X_NODES(1:4))
      Global_coor_Gauss(2) = DOT_PRODUCT(N(1,1:7:2),c_Y_NODES(1:4))

      mat_num    = Elem_Mat(i_E)

      ! Material type of the current element.
      c_mat_type = Material_Type(mat_num)

      !B matrix for conventional element.
      B_FEM(1:3,1:8) = 0.0D0

      if (i_C.eq.1) then
          B_FEM(1,1:8:2)   =  dNdx(:,1)
	      B_FEM(2,2:8:2)   =  dNdx(:,2)
	      B_FEM(3,1:8:2)   =  dNdx(:,2)
	      B_FEM(3,2:8:2)   =  dNdx(:,1)
      end if

      !If the element has no enriched nodes, then:
      if(maxval(Enriched_Node_Type(c_NN,i_C)).eq.0 .and.
     &   minval(Enriched_Node_Type(c_NN,i_C)).eq.0) then
          if (i_C.eq.1) then
              tem_B(1:3,1:8) = B_FEM
              num_tem_B = 8
          else
              num_tem_B = 0
          end if
      !If the element has enriched nodes, then:
      else
          B_XFEM(1:3,1:32) = 0.0D0
          num_B_XFEM = 0
          do i_N = 1,4
	          !Initialize flag of kinked crack of the tip segment.
              Flag_Check_Kink_Tip =  .False.
              Yes_Gauss_in_BCD    =  .False.
	          !-----------------------------------------------------------
		      !----------- Case 1: Heaviside enriched node ---------------
		      !-----------------------------------------------------------
              if (Enriched_Node_Type(c_NN(i_N),i_C).eq.2)then     ! Heaviside enriched node
                  ref_elem = 0
                  !if 2:fully cracked element without kink point or 3:fully cracked element with kink point, then:
		          if ((Elem_Type(i_E,i_C) .eq. 2 ).or.
     &                                (Elem_Type(i_E,i_C) .eq. 3)) then
                      ref_elem = i_E
                      !Coordinates of the 2 intersections(A,B) of the crack segment and these 4 element(fully cracked) lines.
                      Coor_AB(1,:) = [Coors_Element_Crack(ref_elem,1),
     &                               Coors_Element_Crack(ref_elem,2)]
                      Coor_AB(2,:) = [Coors_Element_Crack(ref_elem,3),
     &                               Coors_Element_Crack(ref_elem,4)]
                      if  (Elem_Type(i_E,i_C) .eq. 3) then
					      !Calculates the distance of the kink point(K) to the line(AB) composed of the 2 intersections(A,B).
                          call Cal_Signed_Distance(Coor_AB,
     &                                Coors_Vertex(ref_elem,:),
     &                                distance_Vertex)
                          call Cal_Sign(distance_Vertex,H_Vertex)
                          call Cal_Signed_Distance(Coor_AB,
     &                                Global_coor_Gauss,
     &                                distance_Gauss)
                          call Cal_Sign(distance_Gauss,H_gp)

					      if (H_Vertex*H_gp <= 0) then
					          H_gp = H_gp
                          else
					          !The triangle KAB.
					          Tri_KAB(1,:) =Coor_AB(1,:)
                              Tri_KAB(2,:) =Coor_AB(2,:)
                              Tri_KAB(3,:) =Coors_Vertex(ref_elem,:)
                              Closed_Tri_KAB(1:3,:) =  Tri_KAB
                              Closed_Tri_KAB(4,:) =  Tri_KAB(1,:)
                              call Tool_Yes_In_Poly
     &                       (Global_coor_Gauss(1),Global_coor_Gauss(2),
     &                         Closed_Tri_KAB(:,1), Closed_Tri_KAB(:,2),
     &                         4,Yes_in_KAB)

						      if (Yes_in_KAB .eqv. .True.) then
						          H_gp = -H_gp
                              end if
                          end if
                          call Cal_Signed_Distance(Coor_AB,
     &                                [c_X_NODES(i_N),c_Y_NODES(i_N)],
     &                                distance_Node)
                          call Cal_Sign(distance_Node,H_i)
                      else
                          call Cal_Signed_Distance(Coor_AB,
     &                                Global_coor_Gauss,
     &                                distance_Gauss)
                          call Cal_Sign(distance_Gauss,H_gp)
                          call Cal_Signed_Distance(Coor_AB,
     &                                [c_X_NODES(i_N),c_Y_NODES(i_N)],
     &                                distance_Node)
                          call Cal_Sign(distance_Node,H_i)
                      end if
                      !Calculate enriched B matrix.
				      BI_enr(1,:) = [dNdx(i_N,1)*(H_gp-H_i), 0.0D0]
                      BI_enr(2,:) = [0.0D0,dNdx(i_N,2)*(H_gp-H_i)]
                      BI_enr(3,:) = [dNdx(i_N,2)*(H_gp-H_i),
     &                               dNdx(i_N,1)*(H_gp-H_i)]
                  else
                      BI_enr(1:3,1:2)=0.0D0
                  end if
			      !Update B_XFEM.
                  B_XFEM(1:3,num_B_XFEM+1:num_B_XFEM+2) = BI_enr
                  num_B_XFEM = num_B_XFEM + 2

       	      !-----------------------------------------------------------
		      !----------- Case 2: Junction enriched node ----------------
		      !-----------------------------------------------------------
              elseif (Enriched_Node_Type(c_NN(i_N),i_C).eq.3)then ! Junction enriched node

              !-----------------------------------------------------------
		      !----------- Case 3: Tip enriched node ---------------------
		      !-----------------------------------------------------------
              elseif (Enriched_Node_Type(c_NN(i_N),i_C).eq.1)then ! Tip enriched node
                  ref_elem = 0
                  !Find the fully tip enriched element which the current tip enriched node attached to.
			      !Fully tip enriched element. "ref_elem" means the element which contains the crack tip.
                  if (Elem_Type(i_E,i_C) .eq. 1) then
                      ref_elem = i_E       ! The tip element.
                  else
                      !Partly tip enriched element.
                      find_element = Node_Elements(c_NN(i_N),:)

                      do i_tem=1,num_Node_Elements(c_NN(i_N))
                          if (Elem_Type(find_element(i_tem),i_C) .eq.1)
     &                                                         then
                              !The current node belongs to the tip element.
                              ref_elem = find_element(i_tem)
                              Flag_Check_Kink_Tip = .True.
                          end if
                      end do
                  end if
			      !Coordinates of the 2 intersections(A,B) of the main crack segment and these 4 element(fully cracked) lines
			      !and the coordinates of the tip.
                  Coor_AB(1,:) = [Coors_Element_Crack(ref_elem,1),
     &                            Coors_Element_Crack(ref_elem,2)]
                  Coor_AB(2,:) = [Coors_Element_Crack(ref_elem,3),
     &                            Coors_Element_Crack(ref_elem,4)]
                  c_Segment = Coor_AB(2,:) - Coor_AB(1,:)
			      omega   = atan2(c_Segment(2),c_Segment(1))
			      Coor_Tip = [Coor_AB(2,1),Coor_AB(2,2)]
			      !The transformation matrix from the local tip coordinates to the global coordinates.
                  Trans_Matrix(1,:) = [  cos(omega),sin(omega)]
			      Trans_Matrix(2,:) = [ -sin(omega),cos(omega)]

                  !Calculate the value(r,theta) of the gauss point in the local tip coordinates.
			      if (Yes_Gauss_in_BCD.eqv..False.) then
                      xp_Gauss= MATMUL(Trans_Matrix,
     &                           Global_coor_Gauss-Coor_Tip)
                      r_Gauss = sqrt(xp_Gauss(1)**2+xp_Gauss(2)**2)
                      theta_Gauss= atan2(xp_Gauss(2),xp_Gauss(1))
                  else
                      r_Gauss     = sqrt(Global_coor_Gauss_Doc(1)**2 +
     &                                   Global_coor_Gauss_Doc(2)**2)
                      theta_Gauss = atan2(Global_coor_Gauss_Doc(2),
     &                              Global_coor_Gauss_Doc(1))
                  end if
                  !Check theta.
                  if ((theta_Gauss >pi  .or. theta_Gauss < -pi)) then
                      print *,'    ********************************'
     &                             //'******************************'
                      print *, '    Error :: Angle is wrong when'
     &                          // ' calculates r and theta!'
                      print *,'    ********************************'
     &                             //'******************************'
                  end if
                  !Calculate the tip enrichment functions F and their derivative, dFdx and dFdy.
                  call Cal_F_dFdx_dFdy(r_Gauss,theta_Gauss,omega,
     &                                 c_mat_type,
     &                                 F_Gauss,dFdx,dFdy)
		          !Calculate the value(r,theta) of node in the local tip coordinates.
                  xp_Node= MATMUL(Trans_Matrix,
     &                        [c_X_NODES(i_N),c_Y_NODES(i_N)]-Coor_Tip)
                  r_Node = sqrt(xp_Node(1)**2+xp_Node(2)**2)
                  theta_Node= atan2(xp_Node(2),xp_Node(1))
                  call Cal_F(r_Node,theta_Node,omega,
     &                                 c_mat_type,F_Node)
                  BI_enr(1,:)  = [dNdx(i_N,1)*(J_gp-J_i),     0.0D0]
                  BI_enr(2,:)  = [0.0D0,      dNdx(i_N,2)*(J_gp-J_i)]
                  BI_enr(3,:)  = [dNdx(i_N,2)*(J_gp-J_i),
     &                            dNdx(i_N,1)*(J_gp-J_i)]
                  num_BI_enr_Tip = 0
                  do i_F =1,4
                      c_N(1) = N(1,1)
                      c_N(2) = N(1,3)
                      c_N(3) = N(1,5)
                      c_N(4) = N(1,7)
			          aa = dNdx(i_N,1)*(F_Gauss(i_F)-F_Node(i_F))
     &                                   + c_N(i_N)*dFdx(i_F)
			          bb = dNdx(i_N,2)*(F_Gauss(i_F)-F_Node(i_F))
     &                                   + c_N(i_N)*dFdy(i_F)
                      B_enr(1,:) = [aa,  0.0D0]
                      B_enr(2,:) = [0.0D0,  bb]
                      B_enr(3,:) = [bb,     aa]
                       BI_enr_Tip(1:3,num_BI_enr_Tip+1:num_BI_enr_Tip+2)
     &                                                           = B_enr
                       num_BI_enr_Tip = num_BI_enr_Tip +2
                  end do
                  !Update B_XFEM.
                  B_XFEM(1:3,num_B_XFEM+1:num_B_XFEM+8) = BI_enr_Tip
                  num_B_XFEM = num_B_XFEM + 8
              end if
          end do
          !B matrix of enriched element.
          if (i_C.eq.1) then
              tem_B(1:3,1:8)            = B_FEM
              tem_B(1:3,9:8+num_B_XFEM) = B_XFEM
              num_tem_B = 8 + num_B_XFEM
          else
              tem_B(1:3,1:+num_B_XFEM) = B_XFEM
              num_tem_B = num_B_XFEM
          end if
      end if

      RETURN
      END SUBROUTINE Cal_B_Matrix


*     SB03OD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2020 NICONET e.V.
*
*     .. Parameters ..
      DOUBLE PRECISION ZERO
      PARAMETER        ( ZERO = 0.0D0 )
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, MMAX
      PARAMETER        ( NMAX = 20, MMAX = 20 )
      INTEGER          LDA, LDB, LDQ, LDX, LDWORK
      PARAMETER        ( LDA = NMAX, LDB = MAX( MMAX,NMAX ),
     $                   LDQ = NMAX, LDX = NMAX )
      PARAMETER        ( LDWORK = 4*NMAX+MIN(MMAX,NMAX) )
*     .. Local Scalars ..
      DOUBLE PRECISION SCALE, TEMP
      INTEGER          I, INFO, J, K, M, N
      CHARACTER*1      DICO, FACT, TRANS
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), B(LDB,LDB), DWORK(LDWORK),
     $                 Q(LDQ,NMAX), WR(NMAX), WI(NMAX), X(LDX,NMAX)
*     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
*     .. External Subroutines ..
      EXTERNAL         SB03OD
*     .. Intrinsic Functions ..
      INTRINSIC        MAX, MIN
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, M, DICO, FACT, TRANS
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99994 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         IF ( LSAME( FACT, 'F' ) ) READ ( NIN, FMT = * )
     $                         ( ( Q(I,J), J = 1,N ), I = 1,N )
         IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
            WRITE ( NOUT, FMT = 99993 ) M
         ELSE
            IF ( LSAME( TRANS, 'N' ) ) THEN
               READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,N ), I = 1,M )
            ELSE
               READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N )
            END IF
*           Find the Cholesky factor U.
            CALL SB03OD( DICO, FACT, TRANS, N, M, A, LDA, Q, LDQ, B,
     $                   LDB, SCALE, WR, WI, DWORK, LDWORK, INFO )
*
            IF ( INFO.NE.0 ) THEN
               WRITE ( NOUT, FMT = 99998 ) INFO
            ELSE
               WRITE ( NOUT, FMT = 99997 )
               DO 20 J = 1, N
                  WRITE ( NOUT, FMT = 99996 ) ( B(I,J), I = 1,J )
   20          CONTINUE
*              Form the solution matrix X = op(U)'*op(U).
               IF ( LSAME( TRANS, 'N' ) ) THEN
                  DO 80 I = 1, N
                     DO 60 J = I, N
                        TEMP = ZERO
                        DO 40 K = 1, I
                           TEMP = TEMP + B(K,I)*B(K,J)
   40                   CONTINUE
                        X(I,J) = TEMP
                        X(J,I) = TEMP
   60                CONTINUE
   80             CONTINUE
               ELSE
                  DO 140 I = 1, N
                     DO 120 J = I, N
                        TEMP = ZERO
                        DO 100 K = J, N
                           TEMP = TEMP + B(I,K)*B(J,K)
  100                   CONTINUE
                        X(I,J) = TEMP
                        X(J,I) = TEMP
  120                CONTINUE
  140             CONTINUE
               END IF
               WRITE ( NOUT, FMT = 99995 )
               DO 160 J = 1, N
                  WRITE ( NOUT, FMT = 99996 ) ( X(I,J), I = 1,N )
  160          CONTINUE
               WRITE ( NOUT, FMT = 99992 ) SCALE
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' SB03OD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from SB03OD = ',I2)
99997 FORMAT (' The transpose of the Cholesky factor U is ')
99996 FORMAT (20(1X,F8.4))
99995 FORMAT (/' The solution matrix X = op(U)''*op(U) is ')
99994 FORMAT (/' N is out of range.',/' N = ',I5)
99993 FORMAT (/' M is out of range.',/' M = ',I5)
99992 FORMAT (/' Scaling factor = ',F8.4)
      END


! ADDING REGULARIZATION TERM
subroutine TikhonovRegularization(nx,ny,nz,maxvp,dall,nar,rw,iw,col,count3,iso_inv,weightGcs,weightVs)
    implicit none
    integer nx,ny,nz,maxvp
    integer dall,nar
    real rw(*)
    integer iw(*),col(*)
    integer count3
    real weightGcs, weightVs
    real weight
    logical iso_inv
    integer i,j,k
    integer nvx,nvz,sc
    !-------------------------------------------------------!
    nvz=ny-2
    nvx=nx-2
    count3=0
    !----------------------------------------------------------!
    if (iso_inv) then
        weight=weightVs
        do k=1,nz-1
        do j=1,nvz
        do i=1,nvx
        if(i==1.or.i==nvx.or.j==1.or.j==nvz.or.k==1.or.k==nz-1)then
        count3=count3+1
        col(nar+1)=(k-1)*nvz*nvx+(j-1)*nvx+i
        rw(nar+1)=2.0*weight
        iw(1+nar+1)=dall+count3

        nar=nar+1
        else
        count3=count3+1
        col(nar+1)=(k-1)*nvz*nvx+(j-1)*nvx+i
        rw(nar+1)=6.0*weight
        iw(1+nar+1)=dall+count3
        rw(nar+2)=-1.0*weight
        iw(1+nar+2)=dall+count3
        col(nar+2)=(k-1)*nvz*nvx+(j-1)*nvx+i-1
        rw(nar+3)=-1.0*weight
        iw(1+nar+3)=dall+count3
        col(nar+3)=(k-1)*nvz*nvx+(j-1)*nvx+i+1
        rw(nar+4)=-1.0*weight
        iw(1+nar+4)=dall+count3
        col(nar+4)=(k-1)*nvz*nvx+(j-2)*nvx+i
        rw(nar+5)=-1.0*weight
        iw(1+nar+5)=dall+count3
        col(nar+5)=(k-1)*nvz*nvx+j*nvx+i
        rw(nar+6)=-1.0*weight
        iw(1+nar+6)=dall+count3
        col(nar+6)=(k-2)*nvz*nvx+(j-1)*nvx+i
        rw(nar+7)=-1.0*weight
        iw(1+nar+7)=dall+count3
        col(nar+7)=k*nvz*nvx+(j-1)*nvx+i

        nar=nar+7
        endif
        enddo
        enddo
        enddo
    else
        weight=weightGcs
        do sc=1,2
        do k=1,nz-1
        do j=1,nvz
        do i=1,nvx
        if(i==1.or.i==nvx.or.j==1.or.j==nvz.or.k==1.or.k==nz-1)then
        count3=count3+1
        col(nar+1)=(k-1)*nvz*nvx+(j-1)*nvx+i+(sc-1)*maxvp
        rw(nar+1)=2.0*weight
        iw(1+nar+1)=dall+count3

        nar=nar+1
        else
        count3=count3+1
        col(nar+1)=(k-1)*nvz*nvx+(j-1)*nvx+i+(sc-1)*maxvp
        rw(nar+1)=6.0*weight
        iw(1+nar+1)=dall+count3
        rw(nar+2)=-1.0*weight
        iw(1+nar+2)=dall+count3
        col(nar+2)=(k-1)*nvz*nvx+(j-1)*nvx+i-1+(sc-1)*maxvp
        rw(nar+3)=-1.0*weight
        iw(1+nar+3)=dall+count3
        col(nar+3)=(k-1)*nvz*nvx+(j-1)*nvx+i+1+(sc-1)*maxvp
        rw(nar+4)=-1.0*weight
        iw(1+nar+4)=dall+count3
        col(nar+4)=(k-1)*nvz*nvx+(j-2)*nvx+i+(sc-1)*maxvp
        rw(nar+5)=-1.0*weight
        iw(1+nar+5)=dall+count3
        col(nar+5)=(k-1)*nvz*nvx+j*nvx+i+(sc-1)*maxvp
        rw(nar+6)=-1.0*weight
        iw(1+nar+6)=dall+count3
        col(nar+6)=(k-2)*nvz*nvx+(j-1)*nvx+i+(sc-1)*maxvp
        rw(nar+7)=-1.0*weight
        iw(1+nar+7)=dall+count3
        col(nar+7)=k*nvz*nvx+(j-1)*nvx+i+(sc-1)*maxvp

        nar=nar+7
        endif
        enddo
        enddo
        enddo
        enddo
    endif
end subroutine

subroutine TikhRegul_joint(nx,ny,nz,maxvp,dall,nar,rw,iw,col,narVs,count3,weightGcs,weightVs)
    ! list
    ! count3: increase of rows, all rows= dall+count3
    ! nar   : all nonzero number of G
    ! narVs: nonzero number of G after Vs regularization
    implicit none
    integer nx,ny,nz,maxvp
    integer dall,nar
    real rw(*)
    integer iw(*),col(*)
    integer count3,narVs
    real weightGcs, weightVs
    real weight
    integer i,j,k
    integer nvx,nvz,sc
    !-------------------------------------------------------!
    nvz=ny-2
    nvx=nx-2
    count3=0
    !----------------------------------------------------------!

    weight=weightVs
    do k=1,nz-1
    do j=1,nvz
    do i=1,nvx
    if(i==1.or.i==nvx.or.j==1.or.j==nvz.or.k==1.or.k==nz-1)then
        count3=count3+1
        col(nar+1)=(k-1)*nvz*nvx+(j-1)*nvx+i
        rw(nar+1)=2.0*weight
        iw(1+nar+1)=dall+count3
        nar=nar+1
    else
        count3=count3+1
        col(nar+1)=(k-1)*nvz*nvx+(j-1)*nvx+i
        rw(nar+1)=6.0*weight
        iw(1+nar+1)=dall+count3
        rw(nar+2)=-1.0*weight
        iw(1+nar+2)=dall+count3
        col(nar+2)=(k-1)*nvz*nvx+(j-1)*nvx+i-1
        rw(nar+3)=-1.0*weight
        iw(1+nar+3)=dall+count3
        col(nar+3)=(k-1)*nvz*nvx+(j-1)*nvx+i+1
        rw(nar+4)=-1.0*weight
        iw(1+nar+4)=dall+count3
        col(nar+4)=(k-1)*nvz*nvx+(j-2)*nvx+i
        rw(nar+5)=-1.0*weight
        iw(1+nar+5)=dall+count3
        col(nar+5)=(k-1)*nvz*nvx+j*nvx+i
        rw(nar+6)=-1.0*weight
        iw(1+nar+6)=dall+count3
        col(nar+6)=(k-2)*nvz*nvx+(j-1)*nvx+i
        rw(nar+7)=-1.0*weight
        iw(1+nar+7)=dall+count3
        col(nar+7)=k*nvz*nvx+(j-1)*nvx+i
        nar=nar+7
    endif
    enddo
    enddo
    enddo
    narVs=nar

    weight=weightGcs
    do sc=1,2
    do k=1,nz-1
    do j=1,nvz
    do i=1,nvx
    if(i==1.or.i==nvx.or.j==1.or.j==nvz.or.k==1.or.k==nz-1)then
        count3=count3+1
        col(nar+1)=(k-1)*nvz*nvx+(j-1)*nvx+i+(sc)*maxvp
        rw(nar+1)=2.0*weight
        iw(1+nar+1)=dall+count3
        nar=nar+1
    else
        count3=count3+1
        col(nar+1)=(k-1)*nvz*nvx+(j-1)*nvx+i+(sc)*maxvp
        rw(nar+1)=6.0*weight
        iw(1+nar+1)=dall+count3
        rw(nar+2)=-1.0*weight
        iw(1+nar+2)=dall+count3
        col(nar+2)=(k-1)*nvz*nvx+(j-1)*nvx+i-1+(sc)*maxvp
        rw(nar+3)=-1.0*weight
        iw(1+nar+3)=dall+count3
        col(nar+3)=(k-1)*nvz*nvx+(j-1)*nvx+i+1+(sc)*maxvp
        rw(nar+4)=-1.0*weight
        iw(1+nar+4)=dall+count3
        col(nar+4)=(k-1)*nvz*nvx+(j-2)*nvx+i+(sc)*maxvp
        rw(nar+5)=-1.0*weight
        iw(1+nar+5)=dall+count3
        col(nar+5)=(k-1)*nvz*nvx+j*nvx+i+(sc)*maxvp
        rw(nar+6)=-1.0*weight
        iw(1+nar+6)=dall+count3
        col(nar+6)=(k-2)*nvz*nvx+(j-1)*nvx+i+(sc)*maxvp
        rw(nar+7)=-1.0*weight
        iw(1+nar+7)=dall+count3
        col(nar+7)=k*nvz*nvx+(j-1)*nvx+i+(sc)*maxvp
        nar=nar+7
    endif
    enddo
    enddo
    enddo
    enddo

end subroutine


C************************************************************************
C
C                           HISTOGRAMMING PACKAGE
C                                 M. MANGANO
C
C************************************************************************
C
C**********************************************************************
C    SIMPLE HISTOGRAMMING PACKAGE --  SIMPLIFIED VERSION OF HBOOK
C    BY Michelangelo Mangano    NOVEMBER 1988
C    LAST REVISED NOVEMBER 9, 1988
C    LAST REVISED JUNE 12, 1989  (ADD SCATTER PLOTS)
C    LAST REVISED oct 1990 (Add multi-plots on one page, routines MULTITOP,
C         			MTFILL,...)
C    LAST REVISED Jun 2003 by FM: passed to double precision AND
C    included the date for linux
C**********************************************************************
C
C Fills up to 500 histograms with up to 100 bins.
C Gives a data file (to be specified in the calling program by assigning
C a file name to unit 98) and a topdrawer file (to be specified in the
C calling program by assigning a file name to unit 99).
C
C INITIALIZATION:
C Call once INIHIST; this just resets a few counters and logicals
C Call MBOOK(N,'TITLE',DEL,XMIN,XMAX) for each histogram to be booked.
C N (an integer) is the label of the histogram;
C 'TITLE' is the name of the histogram (no more then 100 characters);
C DEL (real*8) is the bin size;
C XMIN (real*8) is the lower limit of the first bin;
C XMAX (real*8)is the upper limit of the last  bin
C Example:
C      call mbook(2,'pt distribution',1.,10,70)
C This call initializes histogram number 2, called 'pt distribution';
C The bin size will be 1. (possibly GeV, if that's what you want), the
C first bin being  10<x<11. and the last one being 69.<x<70
C
C FILLING:
C When it's time, call MFILL(N,X,Y); this will add Y (real*8) to the bin
C in which X (real*8) happens to be, within histogram N.
C
C PLAYING AROUND:
C At the end of the day you may want to sum, divide, cancel, etc.etc.
C various histograms (bin by bin). Then you call MOPERA(I,'O',J,K,X,Y).
C The 1-character string O can take the following values:
C +  : sums       X*(hist I) with Y*(hist J) and puts the result in hist K;
C -  : subtracts  X*(hist I) with Y*(hist J) and puts the result in hist K;
C *  : multiplies X*(hist I) with Y*(hist J) and puts the result in hist K;
C /  : divides    X*(hist I) with Y*(hist J) and puts the result in hist K;
C F  : multiplies hist I by the factor X, and puts the result in hist K;
C R  : takes the square root of  hist  I, and puts the result in hist K;if
C      the value at a given bin is less than or equal to 0, puts 0 in K
C S  : takes the square      of  hist  I, and puts the result in hist K;
C L  : takes the log_10 of  hist  I, and puts the result in hist K; if the
C      value at a given bin is less than or equal to 0, puts 0 in K
C M  : statistical analysis; if I contains the weights (let's say WGT),
C      J contains variable times weight (F*WGT) and K contains the
C      variable squared times the weight (F**2*WGT), then, after using 'M',
C      J will contain the average value of the variable <F> and K will
C      contain the sigma of the average: sigma=sqrt(<F**2>-<F>**2).
C      If WGT=1. for all the entries, then it is enough to put I=J, and
C      it is not necessary to book a hist with the weights.
C V  : estimates errors for vegas evaluation of differential distributions.
C      Fill I with the values of
C      the functions do integrate times the Vegas weight (fun*wgt); fill
C      J with fun**2*wgt; then K will contain an estimate of the error
C      of the integration. Putting X=1/(#of iterations) performs the
C      avegare over the iterations, and gives the right normalization to
C      the differential distribution, I, and to the errors, K. J stays the same.
C
C FINAL ACCOUNTING:
C Now we can finalize our histograms; MFINAL(N) will calculate the integral
C of the histogram N, the mean value of the X variable and its RMS.
C If we now want to renormalize the hist's, we can call MNORM(N,X), which
C will normalize the integral to X  -- CAUTION: do not call MNORM before
C MFINAL, it will blow up.
C
C OUTPUT:
C To get a .dat file containing the values of the histograms, together with
C some information (like integral, mean values, etc.etc.) call MPRINT(N),
C for each hist N that you want in the .dat file. Before the call to MPRINT
C you want to open unit 98 and give it a name:
C     OPEN(UNIT=98,NAME='NAME.DAT',STATUS='NEW')
C If you want a topdrawer file with a plot of the hist values, call
C MTOP(N,M,'X','Y','SCALE'). The points of the plot will be taken from histogram
C N, the error bars from histogram M. 'SCALE', character*(*), determines
C the scale for y, logarithmic or linear (SCALE=LOG,LIN).
C If you do not want error bars, keep
C a histogram of zeros, or just call a hist that had not been booked.
C X will appear as a 'bottom title', and Y will appear as a 'left title'.
C The top title is by default the name of the histogram itself.
C A little box below the plot will contain some information on the plot
C itself. Before calling MTOP,
C     OPEN(UNIT=99,NAME='NAME.TOP',STATUS='NEW')
C--------------------------------------------------------------------------
C
C  COMMON/HISTO/  Histogram N
C
C   BOOK(N),      Three-letter character-string: 'NO' if histogram was not
C		  Booked, 'YES' otherwise
C   TITLE(N),     Title of the histogram
C
C   HMIN(N),      Min value of x range
C   HMAX(N),      Max value of x range
C   HDEL(N),      Bin width
C   NBIN(N),      Total number of bins
C   USCORE(N),    Total integral of underscores with x < HMIN(N)
C   OSCORE(N),    Total integral of onderscores with x > HMAX(N)
C   IUSCORE(N),   Number of entries with x < HMIN(N)
C   IOSCORE(N),   Number of entries with x > HMAX(N)
C   IENT(N),      Total number of entries within x range HMIN(N)<x<HMAX(N)
C   HINT(N),      Integral of the histogram within HMIN(N)<x<HMAX(N)
C   HAVG(N),      Average value of x, weighted over the x range of the histo
C   HSIG(N),      Quadratic dispersion of x around the average
C   HIST(N,L),    Value of bin L-th
C   XHIS(N,L),    Central x value of bin L-th
C   IHIS(N,L),    Number of entries within bin L-th
C   NHIST         Total number of booked histograms
C

      SUBROUTINE INIHIST
C*************************************************************
c     initialization
      IMPLICIT NONE
      include 'dbook.inc'
c     APPLgrid commons
      include "reweight_appl.inc"
      include "appl_common.inc"
      integer iappl
      common /for_applgrid/ iappl
c
c     LOCAL
c
      INTEGER I
C
C     START
C
      NHIST=0
      DO 1, I=1,NPLOTS
   1  BOOK(I)=' NO'
C     Initialize the number of bins of the aMCfast grids
      if(iappl.ne.0) appl_obs_nbins = 0
      END

      SUBROUTINE MBOOK(N,TIT,DEL,XMIN,XMAX)
C*************************************************************
      IMPLICIT NONE
C
C     ARGUMENTS
C
      INTEGER N
      CHARACTER*(*) TIT
      REAL*8 DEL,XMIN,XMAX
C
C     GLOBAL
C
      include 'dbook.inc'
C
C     LOCAL
C
      INTEGER I
Cq
C     START
C
      NHIST = MAX(N,NHIST)
      IF(BOOK(N)(1:1).EQ.'Y') THEN
	 CALL MWARN('MBOOK')
         WRITE(*,*) 'Histogram',N,TITLE(N),' already in use. '
         WRITE(*,*) 'superseded by ',TIT
      ENDIF
      BOOK(N) = 'YES'
      TITLE(N) = ' '//TIT
1     HDEL(N) = DEL
      NBIN(N) = INT((XMAX-XMIN)/(DEL*0.999999d0))
      IF(NBIN(N).GT.100) THEN
	WRITE(*,*) 'TOO MANY BINS (',NBIN(N),') REQUIRED IN HIST ',N
	WRITE(*,*) 'RE-ENTER BIN SIZE DELTA (OLD BIN = ',DEL,' ):'
	READ(*,*) DEL
	GO TO 1
      ENDIF
      HMIN(N) = XMIN
      HMAX(N) = NBIN(N)*DEL+XMIN
      IF(abs(HMAX(N)-XMAX).gt.0.001d0*DEL) THEN
	 CALL MWARN('MBOOK')
         WRITE(*,*)
     #'Histogram ', TIT, ' Change of upper limit:',xmax,'-->',HMAX(N)
      ENDIF
      IENT(N) = 0
      IUSCORE(N) = 0
      IOSCORE(N) = 0
      USCORE(N) = 0
      OSCORE(N) = 0
      HAVG(N) = 0
      HINT(N) = 0
      HSIG(N) = 0
      DO I=1,NBIN(N)
         XHIS(N,I)=HMIN(N)+HDEL(N)*(DFLOAT(I)-0.5d0)
         IHIS(N,I)=0
         HIST(N,I)=0
      ENDDO
      END

      SUBROUTINE MFILL4(N,X,Y)
C*************************************************************
      IMPLICIT NONE
C
C     ARGUMENTS
C
      INTEGER N
      REAL*8 X,Y
C
C     LOCAL
C
      REAL*8 XI
      INTEGER I
C
C     GLOBAL
C
      INCLUDE 'dbook.inc'
c
c     START
c

      IF(X.LT.HMIN(N)) THEN
         USCORE(N) = USCORE(N) + Y
         IUSCORE(N) = IUSCORE(N) + 1
      ELSEIF(X.GT.HMAX(N)) THEN
         OSCORE(N) = OSCORE(N) + Y
         IOSCORE(N) = IOSCORE(N) + 1
      ELSE
         XI=((X-HMIN(N))/HDEL(N))+1
         I=INT(XI)
         IENT(N)=IENT(N)+1
         IHIS(N,I)=IHIS(N,I)+1
         HIST(N,I)=HIST(N,I)+Y
      ENDIF
      END

      SUBROUTINE MINTEG(NIN,NOUT,IDIR,IPOW)
C If IPOW=1 performs the integral of the distribution contained in histogram
C NIN up to the value specified by the abscissa (if IDIR=1) or from this
C value on (if IDIR=-1). The resulting integral distribution is put into
C NOUT, which is automatically booked if NOUT.ne.NIN .  Choosing IPOW=2
C the routine will return the square root of the integral of the squares,
C as is required, for example, for the propagation of the mean quadratic error
C of a given distribution. Overscores and underscores are included.
      IMPLICIT NONE
C
C     ARGUMENTS
C
      INTEGER NIN,NOUT,IDIR,IPOW
C
C     GLOBAL
C
      INCLUDE 'dbook.inc'
c
c     LOCAL
c
      INTEGER M,I,L
      CHARACTER*14  C
      DIMENSION C(2)
      DATA C/' INTEG BELOW X',' INTEG ABOVE X'/
C
C     EXTERNAL
C
      REAL*8 SUMPOW
C
C     START
C
      IF(BOOK(NIN)(1:1).NE.'Y') RETURN
      M = NBIN(NIN)
      I = (IDIR + 3)/2
      IF(NOUT.NE.NIN.AND.BOOK(NOUT)(1:1).NE.'Y') THEN
      	CALL MBOOK(NOUT,TITLE(NIN)//C(I),
     &                HDEL(NIN),HMIN(NIN),HMAX(NIN))
      ENDIF
      IF(IDIR.EQ.1) THEN
         HIST(NOUT,1) = SUMPOW(HIST(NIN,1),USCORE(NIN),IPOW)
         IHIS(NOUT,1) = IHIS(NIN,1) + IUSCORE(NIN)
         XHIS(NOUT,1) = XHIS(NIN,1) + HDEL(NIN)/2
         DO L=2,M
            HIST(NOUT,L) = SUMPOW(HIST(NIN,L),HIST(NOUT,L-1),IPOW)
            IHIS(NOUT,L) = IHIS(NIN,L) + IHIS(NOUT,L-1)
            XHIS(NOUT,L) = XHIS(NIN,L) + HDEL(NIN)/2
         ENDDO
         OSCORE(NOUT) = SUMPOW(OSCORE(NIN),HIST(NIN,M),IPOW)
         IOSCORE(NOUT) = IOSCORE(NIN) + IHIS(NIN,M)
      ELSEIF(IDIR.EQ.-1) THEN
         HIST(NOUT,M) = SUMPOW(HIST(NIN,M),OSCORE(NIN),IPOW)
         IHIS(NOUT,M) = IHIS(NIN,M) + IOSCORE(NIN)
         XHIS(NOUT,M) = XHIS(NIN,M) - HDEL(NIN)/2
         DO L=M-1,1,-1
            HIST(NOUT,L) = SUMPOW(HIST(NIN,L),HIST(NOUT,L+1),IPOW)
            IHIS(NOUT,L) = IHIS(NIN,L) + IHIS(NOUT,L+1)
            XHIS(NOUT,L) = XHIS(NIN,L) - HDEL(NIN)/2
         ENDDO
         USCORE(NOUT) = SUMPOW(USCORE(NIN),HIST(NIN,1),IPOW)
         IUSCORE(NOUT) = IUSCORE(NIN)+IHIS(NIN,1)
      ELSE
         CALL MWARN('MINTEG')
         WRITE(*,*) 'Wrong idir in minteg: OPERATION NOT PERFORMED'
         RETURN
      ENDIF
      END

      REAL*8 FUNCTION SUMPOW(X,Y,IPOW)
C*************************************************************
      IMPLICIT NONE
C
C     ARGUMENTS
C
      REAL*8 X,Y
      INTEGER IPOW
C
C     START
C
      IF(IPOW.EQ.1) THEN
         SUMPOW = X + Y
      ELSEIF(IPOW.EQ.2) THEN
         SUMPOW = DSQRT(X**2+Y**2)
      ELSEIF(IPOW.EQ.0) THEN
         CALL MWARN('SUMPOW')
         WRITE(*,*)'Error: IPOW=0 not allowed in SUMPOW'
      ELSE
         SUMPOW = (X**IPOW+Y**IPOW)**(1./IPOW)
      ENDIF
      END

      SUBROUTINE MOPERA(I,OPER,J,K,X,Y)
C*************************************************************
      IMPLICIT NONE
C
C     ARGUMENTS
C
      INTEGER I,J,K
      CHARACTER OPER*1
      REAL*8 X,Y
C
C     LOCAL
C
      REAL*8 XXX,XSUM,XSUMSQ,XNORM,XAVG,XSQAVG
      INTEGER L
C
C     GLOBAL
C
      INCLUDE 'dbook.inc'
C
C     START
C
      IF( (BOOK(I)(1:1).NE.'Y'.AND.BOOK(I).NE.'NST') .OR.
     &    (BOOK(J)(1:1).NE.'Y'.AND.BOOK(J).NE.'NST') ) RETURN
      IF(NBIN(I).NE.NBIN(J).AND.(OPER.EQ.'+'.OR.OPER.EQ.'-'.OR.OPER.EQ.
     &    '*'.OR.OPER.EQ.'/'.OR.OPER.EQ.'M'.OR.OPER.EQ.'A')) THEN
	  CALL MWARN('MOPERA')
          WRITE(*,*) I,J
  20      FORMAT(' ****** INCOMPATIBLE OPERATION HIST ',I2,' &',I2,
     &    '*******'/)
          RETURN
      ENDIF
      IF(BOOK(K)(1:1).NE.'Y')
     &  CALL MBOOK(K,TITLE(I),HDEL(I),HMIN(I),HMAX(I))
      IF(OPER.EQ.'E') THEN
c If I contains the accumulated weights, J the accumulated squares of the
c weights and IHIS(J,1) the number of accumulated entries, 'E' will add
c the average value of I to K and will put in J the quadratic dispersion.
         IF(IHIS(J,1).NE.0) THEN
            XXX = 1./IHIS(J,1)
         ELSE
            XXX = 0
         ENDIF
         DO L=1,NBIN(I)
            XSUM   = HIST(I,L)
            XSUMSQ = HIST(J,L)
            HIST(K,L)=HIST(K,L) + XXX*HIST(I,L)
            HIST(J,L)=XXX*DSQRT(ABS(XSUMSQ-XSUM**2*XXX))
         ENDDO
         IENT(K)=IENT(K)+IENT(I)
         XSUM = USCORE(I)
         XSUMSQ = USCORE(J)
         USCORE(K) = USCORE(K)+XXX*XSUM
         USCORE(J) = XXX*DSQRT(ABS(XSUMSQ-XSUM**2*XXX))
         XSUM = OSCORE(I)
         XSUMSQ = OSCORE(J)
         OSCORE(K) = OSCORE(K)+XXX*XSUM
         OSCORE(J) = XXX*DSQRT(ABS(XSUMSQ-XSUM**2*XXX))
      ELSEIF(OPER.EQ.'Q') THEN
         DO L=1,NBIN(I)
            HIST(K,L) = SQRT(HIST(J,L)**2+HIST(I,L)**2)
         ENDDO
         USCORE(K) = SQRT(USCORE(J)**2+USCORE(I)**2)
         OSCORE(K) = SQRT(OSCORE(J)**2+OSCORE(I)**2)
      ELSEIF(OPER.EQ.'A') THEN
         DO L=1,NBIN(I)
            HIST(J,L) = HIST(J,L) + HIST(I,L)
            IHIS(J,L) = IHIS(J,L) + IHIS(I,L)
            HIST(K,L) = HIST(K,L) + HIST(I,L)**2
            IHIS(K,L) = IHIS(K,L) + 1
            HIST(I,L) = 0
            IHIS(I,L) = 0
         ENDDO
         IENT(J) = IENT(J)+IENT(I)
         IUSCORE(J) = IUSCORE(J) + IUSCORE(I)
         USCORE(J) = USCORE(J) + USCORE(I)
         IOSCORE(J) = IOSCORE(J) + IOSCORE(I)
         OSCORE(J) = OSCORE(J) + OSCORE(I)
         IENT(K) = IENT(K)+1
         IUSCORE(K) = IUSCORE(K) + 1
         USCORE(K) = USCORE(K) + USCORE(I)**2
         IOSCORE(K) = IOSCORE(K) + 1
         OSCORE(K) = OSCORE(K) + OSCORE(I)**2
         IENT(I) = 0
         IUSCORE(I) = 0
         IOSCORE(I) = 0
         USCORE(I) = 0
         OSCORE(I) = 0
      ELSEIF(OPER.EQ.'X') THEN
         DO L=1,NBIN(I)
            HIST(I,L) = 0
            IHIS(I,L) = 0
         ENDDO
         IENT(I) = 0
         IUSCORE(I) = 0
         IOSCORE(I) = 0
         USCORE(I) = 0
         OSCORE(I) = 0
      ELSE
        DO L=1,NBIN(I)
      	IF(OPER.EQ.'+') THEN
       	  HIST(K,L)=X*HIST(I,L) + Y*HIST(J,L)
      	ELSEIF(OPER.EQ.'-') THEN
      	  HIST(K,L)=X*HIST(I,L) - Y*HIST(J,L)
      	ELSEIF(OPER.EQ.'*') THEN
      	  HIST(K,L)=X*HIST(I,L) * Y*HIST(J,L)
      	ELSEIF(OPER.EQ.'/') THEN
          IF(Y.EQ.0..OR.HIST(J,L).EQ.0.) THEN
            HIST(K,L)=0.
          ELSE
            HIST(K,L)=X*HIST(I,L) / (Y*HIST(J,L))
          ENDIF
       	ELSEIF(OPER.EQ.'F') THEN
      	  HIST(K,L)=X*HIST(I,L)
      	ELSEIF(OPER.EQ.'R') THEN
          IF(HIST(I,L).GT.0.) THEN
            HIST(K,L)=X*DSQRT(HIST(I,L))
          ELSE
            HIST(K,L)=0.
          ENDIF
      	ELSEIF(OPER.EQ.'S') THEN
          HIST(K,L)=X*HIST(I,L)**2
      	ELSEIF(OPER.EQ.'L') THEN
          IF(HIST(I,L).EQ.0..OR.J.EQ.0.) THEN
             HIST(K,L)=0.
           ELSE
             HIST(K,L)=X*LOG10(Y*HIST(I,L))
           ENDIF
      	ELSEIF(OPER.EQ.'M') THEN
           IF(I.NE.J) XNORM=HIST(I,L)
           IF(I.EQ.J) XNORM=DFLOAT(IHIS(J,L))
           IF(XNORM.NE.0.) THEN
             XAVG=HIST(J,L)/XNORM
             HIST(K,L)=
     &       DSQRT(ABS(-XAVG**2+HIST(K,L)/XNORM)/DFLOAT(IHIS(I,L)))
             HIST(J,L)=XAVG
           ELSE
             HIST(K,L)=0.
             HIST(J,L)=0.
           ENDIF
      	ELSEIF(OPER.EQ.'V') THEN
           XAVG=HIST(I,L)*X
           XSQAVG=HIST(J,L)*X
           XNORM=DFLOAT(IHIS(I,L))*X
           IF(XNORM.NE.0.) THEN
              HIST(K,L)=DSQRT(ABS(XSQAVG-XAVG**2)/XNORM)
              HIST(I,L)=XAVG
           ELSE
              HIST(K,L)=0.
           ENDIF
      	ELSE
	 CALL MWARN('MOPERA')
         WRITE(*,*) OPER
   5     FORMAT(' ****** OPERATION ="',A1,'" UNKNOWN ********'/)
         RETURN
        ENDIF
        ENDDO
      	IF(OPER.EQ.'+') THEN
       	  USCORE(K)=X*USCORE(I) + Y*USCORE(J)
       	  OSCORE(K)=X*OSCORE(I) + Y*OSCORE(J)
      	ELSEIF(OPER.EQ.'-') THEN
      	  USCORE(K)=X*USCORE(I) - Y*USCORE(J)
      	  OSCORE(K)=X*OSCORE(I) - Y*OSCORE(J)
      	ELSEIF(OPER.EQ.'*') THEN
      	  USCORE(K)=X*USCORE(I) * Y*USCORE(J)
      	  OSCORE(K)=X*OSCORE(I) * Y*OSCORE(J)
      	ELSEIF(OPER.EQ.'/') THEN
          IF(Y.EQ.0..OR.USCORE(J).EQ.0.) THEN
            USCORE(K)=0.
          ELSE
            USCORE(K)=X*USCORE(I) / (Y*USCORE(J))
          ENDIF
          IF(Y.EQ.0..OR.OSCORE(J).EQ.0.) THEN
            OSCORE(K)=0.
          ELSE
            OSCORE(K)=X*OSCORE(I) / (Y*OSCORE(J))
          ENDIF
       	ELSEIF(OPER.EQ.'F') THEN
      	  USCORE(K)=X*USCORE(I)
      	  OSCORE(K)=X*OSCORE(I)
      	ELSEIF(OPER.EQ.'R') THEN
          IF(USCORE(I).GT.0.) THEN
            USCORE(K)=X*DSQRT(USCORE(I))
          ELSE
            USCORE(K)=0.
          ENDIF
          IF(OSCORE(I).GT.0.) THEN
            OSCORE(K)=X*DSQRT(OSCORE(I))
          ELSE
            OSCORE(K)=0.
          ENDIF
      	ELSEIF(OPER.EQ.'S') THEN
          USCORE(K)=X*USCORE(I)**2
          OSCORE(K)=X*OSCORE(I)**2
      	ELSEIF(OPER.EQ.'L') THEN
          IF(USCORE(I).EQ.0..OR.J.EQ.0.) THEN
             USCORE(K)=0.
           ELSE
             USCORE(K)=X*LOG10(Y*USCORE(I))
           ENDIF
          IF(OSCORE(I).EQ.0..OR.J.EQ.0.) THEN
             OSCORE(K)=0.
           ELSE
             OSCORE(K)=X*LOG10(Y*OSCORE(I))
           ENDIF
        ENDIF
      ENDIF
      RETURN
      END

      SUBROUTINE MZERO(N)
C*************************************************************
      IMPLICIT NONE
C
C     ARGUMENTS
C
      INTEGER N
C
C     LOCAL
C
      INTEGER I
C
C     GLOBAL
C
      INCLUDE 'dbook.inc'
C
C     START
C
      BOOK(N)='RES'
      IENT(N)=0
      IUSCORE(N)=0
      IOSCORE(N)=0
      HAVG(N)=0.
      HINT(N)=0.
      DO 1 I=1,NBIN(N)
   1  HIST(N,I)=0.
      END

      SUBROUTINE MRESET(N)
C*************************************************************
      IMPLICIT NONE
C
C     ARGUMENTS
C
      INTEGER N
C
C     GLOBAL
C
      INCLUDE 'dbook.inc'
C
C     START
C
      BOOK(N)='RES'
      END

      SUBROUTINE PUTTAG(J,NAME)
C*************************************************************
c Per marcare un istogramma
      IMPLICIT NONE
C
C     ARGUMENTS
C
      CHARACTER*(*) NAME
      INTEGER J
C
C     GLOBAL
C
      INCLUDE 'dbook.inc'
C
C     LOCAL
C
      CHARACTER*(*) TAG
C
C     START
C
      BOOK(J) = NAME
      RETURN
      ENTRY GETTAG(J,TAG)
      TAG = BOOK(J)
      END

      SUBROUTINE MFINAL(N)
C*************************************************************
      IMPLICIT NONE
C
C     ARGUMENTS
C
      INTEGER N
C
C     LOCAL
C
      INTEGER J,IF
      REAL*8 AVG,XIN,SIG,X
C
C     GLOBAL
C
      INCLUDE 'dbook.inc'
C
C     START
C
      IF(BOOK(N)(1:1).NE.'Y') RETURN
      AVG=0
      XIN=0
      SIG=0
      IF=0
      DO J=1,NBIN(N)
         X=HIST(N,J)
 	 AVG=AVG+X*XHIS(N,J)
         XIN=XIN+X
	 IF(X.NE.0) IF=1
      ENDDO
      IF(XIN.EQ.0) GO TO 10
      AVG = AVG/XIN
      DO J=1,NBIN(N)
         SIG=HIST(N,J)*(XHIS(N,J)-AVG)**2+SIG
      ENDDO
      SIG=DSQRT(ABS(SIG/XIN))
 10   CONTINUE
      HINT(N) = XIN
      HAVG(N) = AVG
      HSIG(N) = SIG
      END

      SUBROUTINE MNORM(N,X)
C*************************************************************
      IMPLICIT NONE
C
C     ARGUMENTS
C
      INTEGER N
      REAL*8  X
C
C     GLOBAL
C
      INCLUDE 'dbook.inc'
C
C     LOCAL
C
      INTEGER I
      REAL*8 Y
C
C     START
C
      IF(BOOK(N)(:1).NE.'Y')RETURN
      IF(HINT(N).EQ.0.) THEN
	CALL MWARN('MNORM')
	WRITE(*,*)' INTEGRAL HIST ',N,' IS ZERO: CANNOT RENORMALIZE'
	RETURN
      ELSE
	Y=X/HINT(N)
      ENDIF
      DO 1, I=1,NBIN(N)
    1 HIST(N,I)=HIST(N,I)*Y
      HINT(N)=X
      OSCORE(N)=OSCORE(N)*Y
      USCORE(N)=USCORE(N)*Y
      END

      SUBROUTINE MPRINT(N)
C*************************************************************
      IMPLICIT NONE
C
C     ARGUMENTS
C
      INTEGER N
C
C     LOCAL
C
      INTEGER INI,J
C
C     GLOBAL
C
      INCLUDE 'dbook.inc'
C
C     START
C
      DATA INI/0/
      IF(INI.EQ.0) THEN
c     CALL IDATE(IMON,IDAY,IYEAR)
c     CALL TIME(CTIME)
      INI=1
      ENDIF
      IF(BOOK(N)(:1).NE.'Y') RETURN
C      WRITE(98,7) N,IYEAR,IMON,IDAY,CTIME(1:5)
      WRITE(98,*) TITLE(N)
      DO 1 J=1,NBIN(N)
      IF(HIST(N,J).EQ.0.) GO TO 1
      WRITE(98,'(3X,F10.4,2X,E15.4)')
     &                            XHIS(N,J),HIST(N,J)
    1 CONTINUE
      WRITE(98,15) HAVG(N),HSIG(N),HINT(N)
      WRITE(98,20) IENT(N),IUSCORE(N),IOSCORE(N)
C    7 FORMAT(4X,'HIST = ',I3,'   19',I2,'-',I2,'-',I2,1X,A5/)
   10 FORMAT(4X,2E10.3)
   15 FORMAT(/' AVG =',E10.3,4X,' RMS =',E10.3,' INTEGRAL =',E10.3,/)
   20 FORMAT(' ENTRIES=',I5,4X,'UNDERSCORE=',I5,4x,'OVERSCORE=',I5,//)
      END

      SUBROUTINE MTOP4(N,M,BTIT,LTIT,SCALE)

C*************************************************************
      IMPLICIT NONE
C
C     ARGUMENTS
C
      INTEGER N,M
      CHARACTER*(*) LTIT,BTIT
      CHARACTER*(*) SCALE
C
C     GLOBAL
C
      INCLUDE 'dbook.inc'
C
C     LOCAL
C
      INTEGER INI,J
      real*8 maxbin
C
C     START
C
      DATA INI/0/
      IF(INI.EQ.0) THEN
c      CALL IDATE(IMON,IDAY,IYEAR)
c      CALL TIME(CTIME)
      INI=1
      ENDIF
      IF(BOOK(N)(:1).NE.'Y') RETURN
cRF
      IF (N.eq.1)WRITE(99,'(A)')' SET DEVICE POSTSCRIPT ORIENT=3'

      WRITE(99,100) TITLE(N),BTIT,LTIT,SCALE,HMIN(N),HMAX(N)
  100 FORMAT( /1x,
     &' SET INTENSITY 4'/,1X,
     &' SET WINDOW Y 2.5 TO 9.'/,1X,
     &' SET WINDOW X 2.5 TO 12.'/,1X,
     &' SET FONT DUPLEX '/1X,
     &' SET SYMBOL 5O SIZE 1.8'/,1X,
     &' TITLE TOP ','"',A20,'"',/1X,
     &' TITLE BOTTOM ','"',A20,'"',/1X,
     &' TITLE LEFT ','"',A20,'"',/1X,
     &' SET SCALE Y ',A,/1X,
     &' (SET TICKS TOP OFF)   '/1x,
     &' SET LIMITS X ',F10.5,' ',F10.5,/1X,
     &' SET ORDER X Y DY ')
      maxbin=0d0
      DO J=1,NBIN(N)
         maxbin=max(maxbin,abs(HIST(N,J)))
      ENDDO
      DO 1 J=1,NBIN(N)
         WRITE(99,'(3X,F10.4,2(2X,E15.4))')
     &        XHIS(N,J),HIST(N,J),HIST(M,J)
    1 CONTINUE
      WRITE(99,200)
  200 FORMAT('   HISTO')
  300 FORMAT( /1x,
     &' (INFO-BOX'/,1X,
     &' BOX 7.3 1.3 SIZE 9.5 0.7'/,1X,
     &' SET WINDOW Y 0. TO 2.'/,1X,
     &' SET TITLE SIZE -1.5'/1X,
     &' SET FONT DUPLEX '/1X,
     &' TITLE 3.8 1.4 "X-sect =',1PE10.3,'(pb)   AVG =',1PE10.3,
     &             '   RMS =',1PE10.3,'"',/1X,
     &' TITLE 3.8 1.1 "Entries =',I8,2x,'Entries =',I8,2X
     &                ,'Undersc =',I6,2X,'Oversc =',I6,'"',/1X,
     &' SET TITLE SIZE -2')
      WRITE(99,400)
  400 FORMAT('   NEW PLOT')
      END

      SUBROUTINE MULTITOP4(NH,NE,N,M,BTIT,LTIT,SCA)
C*************************************************************
      IMPLICIT NONE
C
C     ARGUMENTS
C
      INTEGER NH,NE,N,M
      CHARACTER*(*) LTIT,BTIT
      CHARACTER*(*) SCA
C
C     GLOBAL
C
      INCLUDE 'dbook.inc'
C
C     LOCAL
C
      REAL*8 YTIT,XTIT,FEXP,FMAX,FMIN,X,XMX,FMX,FMN
      REAL*8 YU,XU,YL,XL,YTIT0,YD,XTIT0,TITX,TITS,TICS,SRED,XD
      INTEGER IBIN,IPNS,J,I,NOLD,IFRAME,IFRMAX,IP,NS,MOLD
      INTEGER INI
C
C     START
C
      CHARACTER SCALE*3
      CHARACTER*7  PLOT(4)
      DATA PLOT/'SOLID','DASHES','DOTS','DOTDASH'/
C  PLOT SIZE, CORNERS
      REAL*8 WIDTH,HEIGHT,XCORN,YCORN
      DATA WIDTH,HEIGHT/11.5,8.5/,XCORN,YCORN/1.5,1./
C  PLOT VERSUS TEXT FRACTION
      REAL*8 XPFRAC,YPFRAC,XTFRAC,YTFRAC
      DATA XPFRAC,YPFRAC/0.75,0.75/,XTFRAC,YTFRAC/0.25,0.25/
C  DEFAULT SIZES
      REAL*8 TIC0,LAB0,TIT0,LABS
      DATA TIT0,LAB0,TIC0/3d0,3d0,0.06d0/
      DATA INI/0/
      IF(INI.EQ.0) THEN
c      CALL IDATE(IMON,IDAY,IYEAR)
c      CALL TIME(CTIME)
      IFRAME=0
C      WRITE(99,71) IYEAR,IMON,IDAY,CTIME(1:5)
C   71 FORMAT(4X,' (   19',I2,' -',I2,' -',I2,1X,A5/)
      INI=1
      ENDIF
      IF(SCA.EQ.'REF') THEN
	IFRAME=0
	RETURN
      ENDIF
      IF(BOOK(NH)(:1).NE.'Y') RETURN
      IFRMAX=N*M
      IFRAME=IFRAME+1
      IF(IFRAME.GT.IFRMAX.OR.N.NE.NOLD.OR.M.NE.MOLD) THEN
      	IFRAME=1
        WRITE(99,202)
C        WRITE(99,1) IMON,IDAY,CTIME(1:5)
C  1     FORMAT(' SET FONT DUPLEX',/,'  SET TITLE SIZE 2',/,
C     +      ' TITLE 12.8 9 ANGLE -90 ','" MLM   ',I2,'-',I2,1X,A5,'"')
      ENDIF
      IF(IFRAME.EQ.1) THEN
    	I=1
	J=1
      ELSEIF(IFRAME.LE.IFRMAX) THEN
	IF(I.LE.N) I=I+1
        IF(I.GT.N) THEN
		I=1
		J=J+1
	ENDIF
      ENDIF
      IF(N.EQ.NOLD) GO TO 10
      NS=N-1
      XD=WIDTH/DFLOAT(N)
      SRED=DSQRT(DFLOAT(N*M))
      TITS=TIT0/SRED
      LABS=LAB0/SRED
      TICS=TIC0/SRED
      XTIT0=0.55*XPFRAC*XD
      NOLD=N
10    IF(M.EQ.MOLD) GO TO 20
      YD=HEIGHT/DFLOAT(M)
      YTIT0=0.06*YD
      MOLD=M
20    CONTINUE
      XL=(I-1)*XD + XCORN
      YL=(M-J)*YD + YCORN
      XU=XL+XD*XPFRAC
      YU=YL+YD*YPFRAC
      IP=0
      XMX=0.
      DO IBIN=1,NBIN(NH)
        X=HIST(NH,IBIN)
        IF(X.NE.0.) THEN
           IF(XMX.EQ.0.) THEN
              FMX = X + HIST(NE,IBIN)
              FMN = X - HIST(NE,IBIN)
           ELSE
              FMX=MAX(FMX,X + HIST(NE,IBIN))
              FMN=MIN(FMN,X - HIST(NE,IBIN))
           ENDIF
        ENDIF
        XMX=MAX(XMX,ABS(X)+ HIST(NE,IBIN))
      ENDDO
      SCALE=SCA
50    IF(SCALE.EQ.'LIN') THEN
        IF(FMN.GE.0.)   FMIN=0.
        IF(FMN.LT.0.)   FMIN=FMN*1.3
        IF(FMX.GT.0.)   FMAX=FMX*1.3
        IF(FMX.LT.0.)   FMAX=0.
      ELSEIF(SCALE.EQ.'LOG') THEN
cRF
c$$$        IF(FMN.LE.0.) THEN
c$$$                SCALE='LIN'
c$$$                GO TO 50
c$$$        ENDIF
        FMAX=10.**( AINT(LOG10(ABS(FMX))+1000001) - 1000000 )
        FMIN=10.**( AINT(LOG10(ABS(FMN))+1000000) - 1000000 )
      ENDIF
      WRITE(99,100) TITS,LABS,TICS,XL,XU,YL,YU
100   FORMAT(2X,'( SET FONT DUPLEX',/,
     *       2X,'SET TITLE SIZE ',F8.4,/,
     *       2X,'SET LABEL SIZE ',F8.4,/,
     *       2X,'SET TICKS TOP OFF SIZE ',F8.4,/,
     *       2X,'SET WINDOW X ',F8.4,' TO ',F8.4,/,
     *       2X,'SET WINDOW Y ',F8.4,' TO ',F8.4)
      XTIT=XL+XTIT0
      YTIT=YU+YTIT0
      WRITE(99,101) XL,YTIT,TITLE(NH)(1:40)
101   FORMAT('  TITLE ',2(F8.4,1X),'"',A,'"')
      YTIT=YTIT-2.*YTIT0
      WRITE(99,102) XTIT,YTIT,HINT(NH)
102   FORMAT('  TITLE ',2(F8.4,1X),'" INT=',1PE10.3,'"')
      YTIT=YTIT-YTIT0
      WRITE(99,103) XTIT,YTIT,IENT(NH)
103   FORMAT('  TITLE ',2(F8.4,1X),'" ENT=',I9,'"')
      YTIT=YTIT-YTIT0
      IF(USCORE(NH).NE.0.) THEN
        WRITE(99,104) XTIT,YTIT,USCORE(NH)
104     FORMAT('  TITLE ',2(F8.4,1X),'" UFL=',1PE10.3,'"')
        YTIT=YTIT-YTIT0
      ENDIF
      IF(OSCORE(NH).NE.0.) THEN
        WRITE(99,105) XTIT,YTIT,OSCORE(NH)
105     FORMAT('  TITLE ',2(F8.4,1X),'" OFL=',1PE10.3,'"')
        YTIT=YTIT-YTIT0
      ENDIF
      WRITE(99,106) XTIT,YTIT,XU,YTIT,XTIT,YTIT,XTIT,YU
106   FORMAT(2X,'SET ORD X Y ',/,2(F8.4,1X),/,2(F8.4,1X),/,
     *       2X,'JOIN TEXT',/,
     *       2X,2(F8.4,1X),/,2(F8.4,1X),/,
     *       2X,'JOIN TEXT')
      WRITE(99,108) TITS*1.5
108   FORMAT(2X,'SET TITLE SIZE ',F8.4)
      WRITE(99,107) BTIT,XL-0.75*XD*XTFRAC,YL+(YU-YL)/3.,LTIT,SCALE,
     * HMIN(NH),HMAX(NH),FMIN,FMAX
107   FORMAT(
     &' TITLE BOTTOM ','"',A,'"',/1X,
     &' TITLE ',f10.5,f10.5,' ANGLE 90 ','"',A,'"',/1X,
     &' SET SCALE Y ',A,/1X,
     &' SET TICKS TOP OFF   '/1x,
     &' SET LIMITS X ',F10.5,' ',F10.5,/1X,
     &' SET LIMITS Y ',1PE10.3,' ',1PE10.3,/1X,
     &' SET ORDER X Y DY')
C
C  END HEADER , FILL TOPDRAWER WITH DATA
C
      ENTRY MTFILL(NH,NE,N,M,BTIT,LTIT,SCA)
      IP=IP+1
      IF(IP.GT.4) IP=1
      WRITE(99,110) TITLE(NH),HINT(NH),IENT(NH)
110   FORMAT(' ( ',A,/,' ( INT=',1PE10.3,'  ENTRIES=',I12)
      DO 200 IBIN=1,NBIN(NH)
      WRITE(99,'(3X,F10.4,2(2X,E15.4))')
     &          XHIS(NH,IBIN),HIST(NH,IBIN),HIST(NE,IBIN)
200   CONTINUE
      WRITE(99,201)  PLOT(IP)
      IF(BOOK(NE).NE.'NO')   WRITE(99,*)  '  PLOT'
201   FORMAT(2X,'HIST ',A)
202   FORMAT('   NEW PLOT',/,/)
203   RETURN
      END

      SUBROUTINE MWARN(ROUT)
C*************************************************************
      CHARACTER*(*) ROUT
      WRITE(*,*) '***********************************************'
      WRITE(*,*) '***** WARNING CALLED FROM ROUTINE ',ROUT,':'
      END

C*******************************************************************
C     END OF THE HISTOGRAMMING PACKAGE
C*******************************************************************

      subroutine mfill(n,var,www)
      implicit none
      integer n,n_by4
      double precision var,www
c     APPLgrid commons
      include "reweight_appl.inc"
      include "appl_common.inc"
      integer iappl
      common /for_applgrid/ iappl
      integer j
      if(iappl.ne.0)then
         do j=1,nh_obs
            if(n.eq.ih_obs(j))then
               appl_obs_num   = j
               appl_obs_histo = var
c     Fill the reference APPLgrid histograms
               call APPL_fill_ref
c     Fill the APPLgrid files
               call APPL_fill
            endif
         enddo
      endif
      n_by4=4*(n-1)+1
      call mfill4(n_by4,var,www)
      return
      end

      subroutine bookup(n,string,del,xl,xu)
      implicit none
      integer i,n,n_by4
      character*(*) string
      double precision del,xl,xu
c     APPLgrid commons
      include "reweight_appl.inc"
      include "appl_common.inc"
      integer iappl
      common /for_applgrid/ iappl
c     Initialize the grids only if the switch "iappl" is different from zero
c     and if the title string containes the word "central" and does not contain
c     the word "Born".
      if(iappl.ne.0.and.index(string,"central").ne.0.and.
     1                  index(string,"Born").eq.0)then
c     Observable parameters
c     Compute number of bins and edges only if they have not been given by the user.
         if(appl_obs_nbins.eq.0)then
            appl_obs_nbins = int( ( xu - xl ) / del / 0.999999d0 )
c     compute bin edges
            do i=0,appl_obs_nbins
               appl_obs_bins(i) = xl + i * del
            enddo
         endif
         appl_obs_min = appl_obs_bins(0)
         appl_obs_max = appl_obs_bins(appl_obs_nbins)
         if(abs(appl_obs_max-xu).gt.0.00000001d0)then
            write(*,*) 'APPLgrid Histogram: ',
     1                 'Change of the upper limit:',xu,'-->',
     2                  appl_obs_max
         endif
c     Initialize APPLgrid routines
         call APPL_init
c     Keep track of the position of this histogram
         nh_obs = nh_obs + 1
         ih_obs(nh_obs) = n
c     Reset number of bins to zero
         appl_obs_nbins = 0
      endif
      n_by4=4*(n-1)+1
      call bookup4(n_by4,string,del,xl,xu)
      return
      end

      subroutine MTOP(n,string1,string2,string3)
      implicit none
      integer n,n_by4,m_by4
      character*(*) string1,string2,string3
c     APPLgrid commons
      include "reweight_appl.inc"
      include "appl_common.inc"
      integer iappl
      common /for_applgrid/ iappl
      integer j
      if(iappl.ne.0)then
         do j=1,nh_obs
            if(n.eq.ih_obs(j))then
               appl_obs_num = j
               call APPL_fill_ref_out
               call APPL_term
            endif
         enddo
      endif
      n_by4=4*(n-1)+1
      m_by4=n_by4+3
c write the 'n' plots with the 'n+3' error bars
      call mtop4(n_by4,m_by4,string1,string2,string3)
      return
      end

      subroutine multitop(n,lr,lh,string1,string2,string3)
      implicit none
      integer n,n_by4,lr,lh,m_by4
      character*(*) string1,string2,string3
c     APPLgrid commons
      include "reweight_appl.inc"
      include "appl_common.inc"
      integer iappl
      common /for_applgrid/ iappl
      integer j
      if(iappl.ne.0)then
         do j=1,nh_obs
            if(n.eq.ih_obs(j))then
               appl_obs_num = j
               call APPL_fill_ref_out
               call APPL_term
            endif
         enddo
      endif
      n_by4=4*(n-1)+1
      m_by4=n_by4+3
c write the 'n' plots with the 'n+3' error bars
      call multitop4(n_by4,m_by4,lr,lh,string1,string2,string3)
      return
      end

      subroutine bookup4(n,string,del,xl,xu)
      implicit none
      integer n
      character*(*) string
      double precision del,xl,xu
c
c Per ogni istogramma da fare, ne sono richiesti quattro
c In n si accumulano i valori in outfun.
c A ogni iterazione di vegas l'istogramma n viene sommato a n+1,
c e il quadrato del suo valore viene sommato a n+2,
c L'istogramma n viene anche usato alla fine per combinare
c i totali dei vari contributi sig0,sig2, etc. mentre
c l'istogramma n+3 viene usato per combinare gli
c errori dei vari contributi sig0,sig2, etc.
c Non si vuole che n e n+3 vengano salvati o riesumati.
c Cambiando il tag in N,N+3, questo non avviene (si guardi
c in mbook e save/restart e anche mclear in questo programma.
c
      call mbook(n,  string,del,xl,xu)
      call mbook(n+1,'tmp ',del,xl,xu)
      call mbook(n+2,'tmp square',del,xl,xu)
      call mbook(n+3,'error ',del,xl,xu)
      call puttag(n,'YST')
      call puttag(n+3,'NST')
      return
      end

      subroutine accum(inclde)
      implicit real * 8 (a-h,o-z)
      include 'dbook.inc'
      PARAMETER (NMB=NPLOTS)
      character * 3 tag
      logical inclde
c
c     Accumula i valori e i valori al quadrato per l'analisi statistica,
c     e svuota l'istogramma di accumulo.
c
      do j=1,nmb-3
         call gettag(j,tag)
         if(tag.eq.'YST') then
             if (inclde) then
c Sum the results in histos 'j' onto 'j+1' and the squares to 'j+2'
c This also empties histograms 'j'
                call mopera(j,'A',j+1,j+2,dum,dum)
             else
c Only empty the histograms 'j'.
                call mopera(j,'X',j,j,dum,dum)
             endif
         endif
      enddo
      return
      end

      subroutine mclear
      implicit real * 8 (a-h,o-z)
      character * 70 files(20), filn
      data nfil/0/
c
c sum up files
      call sumfil(files,nfil)
      nfil=0
      return
      entry addfil(filn)
c adds file filn to the list of save files.
      nfil = nfil+1
      if(nfil.gt.20) then
         write(*,*) 'mclear: too many files.'
         stop
      endif
      files(nfil) = filn
      end

      subroutine sumfil(files,nfil)
      implicit real * 8 (a-h,o-z)
      include 'dbook.inc'
      PARAMETER (NMB=NPLOTS)
      external dummyinit
      character * 3 tag
      character * 70 files(*)
c
      do j=1,nfil
         call resume(files(j),dummyinit,'NO')
c
c completa l'analisi statistica
c
         do k=1,nmb-3
            call gettag(k,tag)
            if(tag.eq.'YST') then
               call addup(k)
            endif
         enddo
      enddo
      end

      subroutine dummyinit()
      return
      end

      subroutine addup(j)
      implicit none
      integer j
      real*8 dum
c
c accumula j+1 riscalato in j e pone in j+2 la stima dell'errore
c
      call mopera(j+1,'E',j+2,j,dum,dum)
c
c accumula l'errore in quadratura
c
      call mopera(j+2,'Q',j+3,j+3,dum,dum)
      end


      real*8 function splint(t,n,c,k,a,b,wrk)
c  function splint calculates the integral of a spline function s(x)
c  of degree k, which is given in its normalized b-spline representation
c
c  calling sequence:
c     aint = splint(t,n,c,k,a,b,wrk)
c
c  input parameters:
c    t    : array,length n,which contains the position of the knots
c           of s(x).
c    n    : integer, giving the total number of knots of s(x).
c    c    : array,length n, containing the b-spline coefficients.
c    k    : integer, giving the degree of s(x).
c    a,b  : real values, containing the end points of the integration
c           interval. s(x) is considered to be identically zero outside
c           the interval (t(k+1),t(n-k)).
c
c  output parameter:
c    aint : real, containing the integral of s(x) between a and b.
c    wrk  : real array, length n.  used as working space
c           on output, wrk will contain the integrals of the normalized
c           b-splines defined on the set of knots.
c
c  other subroutines required: fpintb.
c
c  references :
c    gaffney p.w. : the calculation of indefinite integrals of b-splines
c                   j. inst. maths applics 17 (1976) 37-41.
c    dierckx p. : curve and surface fitting with splines, monographs on
c                 numerical analysis, oxford university press, 1993.
c
c  author :
c    p.dierckx
c    dept. computer science, k.u.leuven
c    celestijnenlaan 200a, b-3001 heverlee, belgium.
c    e-mail : Paul.Dierckx@cs.kuleuven.ac.be
c
c  latest update : march 1987
c
c  ..scalar arguments..
      real*8 a,b
      integer n,k
c  ..array arguments..
      real*8 t(n),c(n),wrk(n)
c  ..local scalars..
      integer i,nk1
c  ..
      nk1 = n-k-1
c  calculate the integrals wrk(i) of the normalized b-splines
c  ni,k+1(x), i=1,2,...nk1.
      call fpintb(t,n,wrk,nk1,a,b)
c  calculate the integral of s(x).
      splint = 0.0d0
      do 10 i=1,nk1
        splint = splint+c(i)*wrk(i)
  10  continue
      return
      end


C
C	$Id: cshval.f,v 1.5 2008-07-27 03:10:07 haley Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
      DOUBLE PRECISION FUNCTION CSHVAL (B,H1,H2,HP1,HP2,SIGMA)
      DOUBLE PRECISION B, H1, H2, HP1, HP2, SIGMA
C
C***********************************************************
C
C                                              From SSRFPACK
C                                            Robert J. Renka
C                                  Dept. of Computer Science
C                                       Univ. of North Texas
C                                           renka@cs.unt.edu
C                                                   11/21/96
C
C   Given a line segment P1-P2 containing a point P, along
C with values and derivatives at the endpoints, this func-
C tion returns the value H(P), where H is the Hermite inter-
C polatory tension spline defined by the endpoint data.
C
C On input:
C
C       B = Local coordinate of P with respect to P1-P2:
C           P = B*P1 + (1-B)*P2, and thus B = d(P,P2)/
C           d(P1,P2), where d(P1,P2) is the distance between
C           P1 and P2.  B < 0 or B > 1 results in extrapola-
C           tion.
C
C       H1,H2 = Values interpolated at P1 and P2, respec-
C               tively.
C
C       HP1,HP2 = Products of d(P1,P2) with first order der-
C                 ivatives at P1 and P2, respectively.  HP1
C                 may, for example, be the scalar product of
C                 P2-P1 with a gradient at P1.
C
C       SIGMA = Nonnegative tension factor associated with
C               the spline.  SIGMA = 0 corresponds to a
C               cubic spline, and H approaches the linear
C               interpolant of H1 and H2 as SIGMA increases.
C
C Input parameters are not altered by this function.
C
C On output:
C
C       CSHVAL = Interpolated value H(P).
C
C SSRFPACK module required by CSHVAL:  CSSNHCSH
C
C Intrinsic functions called by CSHVAL:  ABS, EXP
C
C***********************************************************
C
      DOUBLE PRECISION B1, B2, CM, CM2, CMM, D1, D2, DUMMY,
     .                 E, E1, E2, EMS, S, SB1, SB2, SIG, SM,
     .                 SM2, TM, TM1, TM2, TS
      B1 = B
      B2 = 1. - B1
C
C Compute slope S and second differences D1 and D2 scaled
C   by the separation between P1 and P2.
C
      S = H2 - H1
      D1 = S - HP1
      D2 = HP2 - S
C
C Test the range of SIGMA.
C
      SIG = ABS(SIGMA)
      IF (SIG .LT. 1.D-9) THEN
C
C Hermite cubic interpolation:
C
        CSHVAL = H1 + B2*(HP1 + B2*(D1 + B1*(D1 - D2)))
      ELSEIF (SIG .LE. .5) THEN
C
C 0 < SIG .LE. .5.  Use approximations designed to avoid
C   cancellation error in the hyperbolic functions.
C
        SB2 = SIG*B2
        CALL CSSNHCSH (SIG, SM,CM,CMM)
        CALL CSSNHCSH (SB2, SM2,CM2,DUMMY)
        E = SIG*SM - CMM - CMM
        CSHVAL = H1 + B2*HP1 + ((CM*SM2-SM*CM2)*(D1+D2) + SIG*
     .                     (CM*CM2-(SM+SIG)*SM2)*D1)/(SIG*E)
      ELSE
C
C SIG > .5.  Use negative exponentials in order to avoid
C   overflow.  Note that EMS = EXP(-SIG).
C
        SB1 = SIG*B1
        SB2 = SIG - SB1
        E1 = EXP(-SB1)
        E2 = EXP(-SB2)
        EMS = E1*E2
        TM = 1. - EMS
        TS = TM*TM
        TM1 = 1. - E1
        TM2 = 1. - E2
        E = TM*(SIG*(1.+EMS) - TM - TM)
        CSHVAL = H1 + B2*S + (TM*TM1*TM2*(D1+D2) + SIG*
     .                      ((E2*TM1*TM1-B1*TS)*D1 +
     .                       (E1*TM2*TM2-B2*TS)*D2))/(SIG*E)
      ENDIF
      RETURN
      END


!*******************************************************************************
!
!     SUBROUTINE TO FIT THE SIGNATURES OF ACOUSTIC GLITCHES IN THE STELLAR
!     OSCILLATION FREQUENCIES
!     --------------------------------------------------------------------------
!
!     AUTHOR NAME   : KULDEEP VERMA
!     EMAIL ADDRESS : kuldeep@phys.au.dk, kuldeepv89@gmail.com
!
!*******************************************************************************
!
!     freq : (input) Input oscillation frequencies - l, n, nu(muHz), err(muHz)
!     num_of_n : (input) Array containing the number of modes for each degree
!     acoustic_radius : (input) An estimate of the acoustic radius (in s)
!     tauHe : (input) A guess for the acoustic depth of the helium ionization
!             zone (in s)
!     tauCZ : (input) A guess for the acoustic depth of the convection zone
!             base (in s)
!     param : (output) Array containing the fitted parameters
!     chi2 : (output) Chi-square of the fit
!     reg : (output) Regularization term
!     ier : (output) Error parameter, ier=0 implies successful execution
!           ier=-1 implies that routine failed to fit
!     num_of_poly_param_fq : (optional) Degree of the polynomial used + 1
!     num_of_l : (optional) Number of harmonic degrees used in the fit
!     total_num_of_param_fq : (optional) Total number of fitting parameter
!     nderiv_fq : (optional) Derivative order used in the regularization
!     num_of_initial_guess : (optional) Number of initial guesses used in the
!                            global minimum search
!     dtauHe : (optional) Defines the range of search for tauHe,
!              range - (tauHe - dtauHe, tauHe + dtauHe)
!     dtauCZ : (optional) Defines the range of search for tauCZ,
!              range - (tauCZ - dtauCZ, tauCZ + dtauCZ)
!     tol_grad_fq : (optional) Tolerance on the gradient of the cost function
!     regu_param_fq : (optional) Regularization parameter
!
!*******************************************************************************

      SUBROUTINE glitch_fit(freq,num_of_n,acoustic_radius,tauHe,tauCZ,&
            param,chi2,reg,ier,num_of_poly_param_fq,num_of_l,&
            total_num_of_param_fq,nderiv_fq,num_of_init_guess,dtauHe,&
            dtauCZ,tol_grad_fq,regu_param_fq)

      REAL*8, PARAMETER :: MU = 1.d-6, PI = 3.141592653589793d0
      REAL*8, PARAMETER :: reps = 1.d-14, aeps = 0.d0

      INTEGER :: num_of_poly_param_fq, num_of_l, total_num_of_param_fq
      INTEGER :: nderiv_fq, num_of_init_guess
      INTEGER :: i, i0, j, nfun, ier, num_of_mode
      INTEGER :: num_of_n(5)

      REAL*8 :: freq(200,4)
      REAL*8 :: acoustic_radius, tauHe, tauCZ, dtauHe, dtauCZ
      REAL*8 :: chi2, reg, chi2_tmp, reg_tmp
      REAL*8 :: tol_grad_fq, regu_param_fq
      REAL*8 :: loga, logb
      REAL*8 :: param(total_num_of_param_fq)
      REAL*8 :: dparam(total_num_of_param_fq,2)
      REAL*8 :: par(total_num_of_param_fq)
      REAL*8 :: ran_num(total_num_of_param_fq)
      REAL*8 :: grad(total_num_of_param_fq)
      REAL*8 :: hess(total_num_of_param_fq,total_num_of_param_fq)
      REAL*8 :: scratch(3*total_num_of_param_fq)
!f2py intent(in)  :: freq, num_of_n, acoustic_radius, tauHe, tauCZ
!f2py intent(out) :: param, chi2, reg, ier
!f2py INTEGER :: num_of_poly_param_fq = 5, num_of_l = 3, total_num_of_param_fq = 22
!f2py INTEGER :: nderiv_fq = 3, num_of_init_guess = 200
!f2py REAL*8  :: dtauHe = 200.0, dtauCZ = 200.0, tol_grad_fq = 1.e-3, regu_param_fq = 7.0

      ! Check for inconsistencies in the input parameters
      IF (total_num_of_param_fq .ne. num_of_poly_param_fq * num_of_l + 7) THEN
        WRITE(*,'(A50)') 'ERROR: inconsistent argument for glitch_fit!'
        STOP
      ENDIF

      ! Estimate the parameter ranges to find the global minimum
      CALL SEARCH_SPACE(tauCZ,dtauCZ,tauHe,dtauHe,dparam)

      chi2 = 1.d99
      reg  = 0.d0
      i0 = total_num_of_param_fq - 7
      num_of_mode = SUM(num_of_n)
      DO i = 1, num_of_init_guess

        ! Initial guess
        CALL RANDOM_NUMBER(ran_num)
        DO j = 1, total_num_of_param_fq
          IF (j .EQ. i0+1 .OR. j .EQ. i0+4) THEN
            loga = LOG10(dparam(j,1))
            logb = LOG10(dparam(j,2))
            par(j) = loga + (logb - loga) * ran_num(j)
            par(j) = 10.d0**par(j)
          ELSE
            par(j) = dparam(j,1) + (dparam(j,2) - dparam(j,1)) * ran_num(j)
          ENDIF
        ENDDO

        par(i0+1) = SQRT(par(i0+1))
        par(i0+4) = SQRT(par(i0+4))
        par(i0+5) = SQRT(8.d0 * PI**2 * par(i0+5)**2)
        CALL BFGS(total_num_of_param_fq,par,chi2_tmp,grad,hess,nfun,&
             reps,aeps,ier,FCN_FQ,scratch)
        par(i0+1) = par(i0+1)**2
        par(i0+3) = MODULO(par(i0+3),2*PI)
        par(i0+4) = par(i0+4)**2
        par(i0+5) = SQRT(par(i0+5)**2/(8.d0 * PI**2))
        par(i0+7) = MODULO(par(i0+7),2*PI)

        ! Consider the fit only if:
        !--------------------------
        ! (1) maximum value of derivatives w.r.t. parameters is < 1d-2,
        ! (2) Acoustic width of He ionization zone > 0.1s,
        ! (3) acoustic depths of CZ and He > 0 s,
        ! (4) acoustic depth of CZ > acoustic depth of He,
        ! (5) acoustic depth of CZ < acoustic radius.
        IF (MAXVAL(ABS(grad(:))) .LT. tol_grad_fq .AND. &
            par(i0+5) .GT. 0.1d0 .AND. &
            par(i0+2) .GT. 0.d0 .AND. par(i0+6) .GT. 0.d0 .AND. &
            par(i0+2) .GT. par(i0+6) .AND. &
            par(i0+2) .LT. acoustic_radius) THEN

          ! Update parameters if chi-square is substantially smaller
          reg_tmp = REGU_FQ(par)
          chi2_tmp = chi2_tmp - reg_tmp
          IF (chi2_tmp/chi2 .LT. 0.7d0) THEN
            chi2  = chi2_tmp
            reg   = reg_tmp
            param = par
          ! Update parameters even if chi-square is marginally smaller, but in
          ! that case make sure that the regulariation term is not too small
          ELSEIF (chi2_tmp/chi2 .GE. 0.7d0 .AND. chi2_tmp/chi2 .LT. 1.d0) THEN
            IF (reg_tmp/reg .GT. 0.1d0) THEN
              chi2  = chi2_tmp
              reg   = reg_tmp
              param = par
            ENDIF
          ENDIF
        ENDIF

      ENDDO

      !Check if the data was fitted
      ier = 0
      IF (chi2 .GT. 1.d98) THEN
        ier = -1
        param(:) = (dparam(:, 1) + dparam(:, 2)) / 2.d0
      ENDIF

      CONTAINS

      !*************************************************************************
      !TO INITIALIZE THE PARAMETER SPACE TO SEARCH FOR GLOBAL MINIMUM
      !*************************************************************************
      !
      !tauCZ : (input) Guess for the acoustic depth of the convection zone (in s)
      !dtauCZ : (input) Range around tauCZ (in s)
      !tauHe : (input) Guess for the acoustic depth of the He ionization zone (in s)
      !dtauHe : (input) Range around tauHe (in s)
      !dparam : (output) Array containing the parameter space to look for the
      !         global minimum
      !
      !Required routines : LLFIT
      !
      !*************************************************************************

      SUBROUTINE SEARCH_SPACE(tauCZ,dtauCZ,tauHe,dtauHe,dparam)

      INTEGER :: i, j, k, ns

      REAL*8 :: tauCZ, dtauCZ, tauHe, dtauHe
      REAL*8 :: dparam(:,:)
      REAL*8 :: tmp1, tmp2, dtmp1, dtmp2, chi2

      ! parameters associated with smooth component
      dparam = 0.d0
      ns = total_num_of_param_fq - 7
      j = 0
      k = 0
      DO i = 1, num_of_l
        CALL LLFIT(num_of_n(i),freq(j+1:j+num_of_n(i),2),&
             freq(j+1:j+num_of_n(i),3),freq(j+1:j+num_of_n(i),4),&
             tmp1,tmp2,dtmp1,dtmp2,chi2)
        dparam(k+1,1) = tmp1 - 0.5 * tmp1
        dparam(k+1,2) = tmp1 + 0.5 * tmp1
        dparam(k+2,1) = tmp2 - 0.2 * tmp2
        dparam(k+2,2) = tmp2 + 0.2 * tmp2
        dparam(k+3,1) = -1.d0
        dparam(k+3,2) = 1.d0
        dparam(k+4,1) = -1.d-1
        dparam(k+4,2) = 1.d-1
        dparam(k+5,1) = -1.d-3
        dparam(k+5,2) = 1.d-3
        j = j + num_of_n(i)
        k = k + num_of_poly_param_fq
      ENDDO

      ! parameters associated with CZ signature
      dparam(ns+1,1) = 1.d4
      dparam(ns+1,2) = 1.d7
      dparam(ns+2,1) = MAX(0.d0,tauCZ - dtauCZ)
      dparam(ns+2,2) = tauCZ + dtauCZ
      dparam(ns+3,1) = 0.d0
      dparam(ns+3,2) = 6.28d0

      ! parameters associated with He signature
      dparam(ns+4,1) = 1d-5
      dparam(ns+4,2) = 1.d-1
      dparam(ns+5,1) = 20.d0
      dparam(ns+5,2) = 160.d0
      dparam(ns+6,1) = MAX(0.d0,tauHe - dtauHe)
      dparam(ns+6,2) = tauHe + dtauHe
      dparam(ns+7,1) = 0.d0
      dparam(ns+7,2) = 6.28d0

      END SUBROUTINE SEARCH_SPACE

      !*************************************************************************
      !TO PERFORM A WEIGHTED LINEAR LEAST-SQUARES FIT
      !*************************************************************************
      !
      !ndata : (input) Number of data point
      !x : (input) Array of length ndata containing abscissa
      !y : (input) Array of length ndata containing ordinate
      !sig : (input) Array of length ndata containing uncertainty on y
      !a : (output) Intercept
      !b : (output) Slope
      !siga : (output) Uncertainty on the intercept
      !sigb : (output) Uncertainty on the slope
      !chi2 : (output) Chi-square of the fit
      !
      !Required routines : None
      !
      !*************************************************************************

      SUBROUTINE LLFIT(ndata,x,y,sig,a,b,siga,sigb,chi2)

      INTEGER :: ndata
      INTEGER :: i

      REAL*8 :: sig(ndata), x(ndata), y(ndata)
      REAL*8 :: a, b, chi2, siga, sigb
      REAL*8 :: sx, sy, st2, ss, sxoss, t, wt

      ss  = 0.d0
      sx  = 0.d0
      sy  = 0.d0
      st2 = 0.d0
      b   = 0.d0

      DO i = 1, ndata
        wt = 1.d0/sig(i)**2
        ss = ss + wt
        sx = sx + x(i) * wt
        sy = sy + y(i) * wt
      ENDDO

      sxoss = sx/ss

      DO i = 1, ndata
        t   = (x(i) - sxoss)/sig(i)
        st2 = st2 + t * t
        b   = b + t * y(i)/sig(i)
      ENDDO

      b = b/st2
      a = (sy - sx * b)/ss
      siga = SQRT((1.d0 + sx * sx/(ss * st2))/ss)
      sigb = SQRT(1.d0/st2)

      chi2 = 0.d0

      DO i = 1, ndata
        chi2 = chi2 + ((y(i) - a - b * x(i))/sig(i))**2
      ENDDO

      END SUBROUTINE LLFIT

      !*************************************************************************
      !TO MINIMISE A FUNCTION OF SEVERAL VARIABLES USING QUASI-NEWTON METHOD.
      !*************************************************************************
      !
      !N : (input) Number of variables
      !X : (input/output) Real array of length N containing the initial
      !	guess for the minimum.
      !	After execution it should contain the coordinates of minimiser
      !F : (output) The function value at X
      !G : (output) Real array of length N containing the gradient vector at X
      !H : (output) Real array of length N*N containing the estimated
      !	Hessian matrix at X. The first dimension of H should be N.
      !NUM : (output) Number of function evaluations used by the subroutine
      !REPS : (input) Required relative accuracy
      !AEPS : (input) Required absolute accuracy, all components of the
      !	Minimiser will be calculated with accuracy MAX(AEPS, REPS*ABS(X(I)))
      !IER : (output) Error parameter, IER=0 implies successful execution
      !	IER=53 implies that Hessian matrix at final point is probably singular
      !		The iteration may have converged to a saddle point
      !	IER=503 implies that N < 1, in which case no calculations are done
      !	IER=526 implies that iteration failed to converge to specified accuracy
      !	Other values may be set by LINMIN
      !FCN : (input) Name of the subroutine to calculate the function value
      !     and its derivatives
      !WK : Real array of length 3N used as scratch space
      !
      !SUBROUTINE FCN(N,X,F,G) to calculate the required function, must be supplied
      !	by the user. Here N is the number of variables, F is the
      !	function value at X and G is the gradient vector. X and G
      !	are real arrays of length N. F and G must be calculated by FCN.
      !
      !Required routines : LINMIN, FLNM, FCN
      !
      !*************************************************************************

      SUBROUTINE BFGS(N,X,F,G,H,NUM,REPS,AEPS,IER,FCN,WK)

      LOGICAL :: QC

      INTEGER, PARAMETER :: NIT=200
      INTEGER :: N, NUM, IER, IER1
      INTEGER :: I, J, IT, N2

      REAL*8 :: F, F1, DF, DF1, REPS, AEPS
      REAL*8 :: DG, GHG, GI, H1, H2, R1, X1, X2
      REAL*8 :: X(N), WK(3*N), H(N,N), G(N)

      EXTERNAL :: FCN

      IER=0
      IF(N.LT.1) THEN
        IER=503
        RETURN
      ENDIF

      DO 2000 I=1,N
      !Initialise the Hessian matrix to unit matrix
        DO 1800 J=1,N
1800    H(J,I)=0.0
        H(I,I)=1.0
2000  CONTINUE
      !If some variable needs to be kept fixed the corresponding
      !diagonal elements, H(I,I) should be set to zero.

      CALL FCN(N,X,F,G)
      DF=ABS(F)
      IF(DF.EQ.0.0) DF=1
      N2=2*N
      NUM=1
      H2=1.

      !The iteration loop
      DO 4000 IT=1,NIT
        DF1=0.0
        H1=H2
        H2=0.0
      !Calculating the search direction WK =S^(k)
        DO 2400 I=1,N
          WK(I)=0.0
          DO 2200 J=1,N
            H2=H2+ABS(H(I,J))
2200      WK(I)=WK(I)-H(I,J)*G(J)
          DF1=DF1+WK(I)*G(I)
2400    CONTINUE

        IF(DF1.EQ.0.0) THEN
      !If gradient vanishes, then quit
      !If Hessian matrix appears to be singular, set the error flag
          IF(ABS(H2/H1).GT.1.3D0) IER=53
          RETURN
        ENDIF

      !Initial guess for line search
        X1=0
        X2=MIN(1.D0,-2.*DF/DF1)
        F1=F
        IF(X2.LE.0.0) X2=1
        CALL LINMIN(X1,X2,F1,DF1,REPS,AEPS,IER1,FCN,WK,X,N,NUM)
        IF(IER1.GT.0) IER=IER1
      !If line search fails, then quit
        IF(IER1.GT.100) RETURN

      !The convergence test
        QC=.TRUE.
        DO 2800 I=1,N
          X(I)=WK(N+I)
          WK(N+I)=X1*WK(I)
          IF(ABS(WK(N+I)).GT.MAX(REPS*ABS(X(I)),AEPS)) QC=.FALSE.
          GI=WK(N2+I)
          WK(N2+I)=WK(N2+I)-G(I)
          G(I)=GI
2800    CONTINUE
      !It is possible to apply convergence check on Function value using DF
      !instead of X(I)
        DF=F-F1
        F=F1
        IF(QC) THEN
          IF(ABS(H2/H1).GT.1.3D0) IER=53
          RETURN
        ENDIF

      !Update the matrix using BFGS formula
        DO 3200 I=1,N
          WK(I)=0.0
          DO 3200 J=1,N
3200    WK(I)=WK(I)+H(I,J)*WK(N2+J)
        GHG=0.0
        DG=0.0
        DO 3400 I=1,N
          DG=DG+WK(N2+I)*WK(N+I)
3400    GHG=GHG+WK(I)*WK(N2+I)
        R1=(1.+GHG/DG)/DG
        DO 3600 J=1,N
          DO 3600 I=1,N
3600   H(I,J)=H(I,J)+R1*WK(N+I)*WK(N+J)-(WK(N+I)*WK(J)+WK(I)*WK(N+J))/DG

4000  CONTINUE

      !Iteration fails to converge
      IER=526
      END SUBROUTINE BFGS

      !*************************************************************************
      !TO PERFORM A LINE SEARCH FOR MINIMUM OF SEVERAL VARIABLES AS REQUIRED BY
      !QUASI-NEWTON METHODS. THIS ROUTINE SHOULD NOT BE USED FOR ANY OTHER
      !PURPOSE.
      !*************************************************************************
      !
      !X1 : (input/output) Starting value for the line search. After execution
      !	it should contain the distance to minimiser along the line
      !X2 : (input/output) Initial estimate for the minimum along the line.
      !	 This value will be modified by the subroutine.
      !F1 : (input/output) The function value at X1, this value must be supplied
      !DF1 : (output) The first derivative along the search direction at X1
      !REPS : (input) Required relative accuracy
      !AEPS : (input) Required absolute accuracy,
      !	These criterion is only used to terminate line search under
      !	certain conditions and not generally applicable to the line
      !	search. These values should be same as what is used in subroutine BFGS
      !IER : (output) Error parameter, IER=0 implies successful execution
      !	IER=54 implies that subroutine failed to find acceptable point
      !		but the function value at last point is less than
      !		that at beginning.
      !	IER=55 implies that subroutine failed to find acceptable point
      !		even though the interval has been reduced to required accuracy
      !		but the function value at last point is less than
      !		that at beginning.
      !	IER=527 implies that iteration failed to find any point where
      !		the function value is less than the starting value
      !	IER=528 implies that iteration failed to find any point where
      !		the function value is less than the starting value
      !		even though the interval has been reduced to required accuracy
      !F : (input) Name of the subroutine to calculate the function value
      !     and its derivatives
      !V : (input/output) Real array of length 3N. First N element specify
      !	the direction in which minimisation is required. The next
      !	N elements will contain the coordinates of the minimiser
      !	found by LINMIN. The last 3N elements will contain the gradient
      !	vector at the minimiser.
      !XI : (input) Real array of length N containing the coordinates of
      !	starting point for line search
      !N : (input) Number of variables in the function to minimised
      !NUM : (output) Integer variable to keep count of the number of
      !	function evaluations used so far
      !
      !SUBROUTINE F(N,X,FX,G) to calculate the required function, must be supplied
      !	by the user. Here N is the number of variables, FX is the
      !	function value at X and G is the gradient vector. X and G
      !	are real arrays of length N.
      !
      !Required routines :  FLNM, F
      !
      !*************************************************************************

      SUBROUTINE LINMIN(X1,X2,F1,DF1,REPS,AEPS,IER,F,V,XI,N,NUM)

      LOGICAL :: QB

      INTEGER, PARAMETER :: NIT=15
      INTEGER :: N, IER, NUM
      INTEGER :: I

      REAL*8, PARAMETER :: RHO=0.01D0, SIGMA=0.1D0
      REAL*8, PARAMETER :: T1=9.0, T2=0.9D0, T3=0.5D0
      REAL*8 :: REPS, AEPS
      REAL*8 :: X0, X1, X2, XA, DX, DX1
      REAL*8 :: F0, F1, F2, FA, FC, DF0, DF1, DF2, DFA, DF12
      REAL*8 :: R, R1, R2
      REAL*8 :: V(3*N), XI(N)

      EXTERNAL :: F

      IER=0
      !Select the bracketing phase
      QB=.FALSE.
      F2=FLNM(F,X2,DF2,V,XI,N,NUM)
      DX1=X2-X1
      F0=F1
      DF0=DF1
      X0=X1

      DO 2000 I=1,NIT
        FC=F0+DF0*RHO*(X2-X0)
        IF(ABS(DF2).LE.-SIGMA*DF0.AND.F2.LE.FC) THEN
      !Found an acceptable point
          X1=X2
          F1=F2
          DF1=DF2
          RETURN
        ENDIF
      !Test for bracketing
        IF(.NOT.QB) THEN
          IF(F2.GT.FC.OR.F2.GT.F1.OR.DF2.GE.0) QB=.TRUE.
        ENDIF

      !Hermite cubic interpolation
        DF12=(F2-F1)/DX1
        R=2.*DF2+DF1-3.*DF12
        R1=(3.*DF12-DF2-DF1)**2-DF1*DF2
        DX=0.0
        IF(R1.GT.0.0) THEN
          R1=SIGN(SQRT(R1),R)
          R=R+R1
          DX=-DF2*DX1/R
        ELSE
      !try parabolic interpolation
          R2=2.*(DF12-DF2)
          IF(R2.NE.0.0) DX=DX1*DF2/R2
        ENDIF

        IF(QB) THEN
      !Minimum is bracketed and hence improve on the bracket
          IF(DX.LT.-T2*DX1) DX=-T2*DX1
          IF(DX.GT.-T3*DX1) DX=-T3*DX1
          XA=X2+DX
          FA=FLNM(F,XA,DFA,V,XI,N,NUM)
          FC=F0+DF0*RHO*(XA-X0)

          IF(ABS(DFA).LE.-SIGMA*DF0.AND.FA.LE.FC) THEN
      !The new point is acceptable
            X1=XA
            F1=FA
            DF1=DFA
            RETURN
          ELSE IF(FA.GT.FC.OR.FA.GE.F1.OR.DFA.GT.0.0) THEN
            X2=XA
            F2=FA
            DF2=DFA
          ELSE
            X1=XA
            F1=FA
            DF1=DFA
          ENDIF

          DX1=X2-X1
          IF(ABS(DX1).LT.MAX(REPS*ABS(X2),AEPS)) THEN
      !If the interval is too small, then quit
            IER=528
            IF(F2.LE.F0) THEN
      !Accept the last point in any case
              X1=X2
              F1=F2
              DF1=DF2
              IER=55
            ENDIF
            RETURN
          ENDIF
        ELSE
      !Minimum hasn't been bracketed, choose the point further down.
          IF(DX.LT.X2-X1.AND.DX.GT.0) DX=X2-X1
          IF(DX.GT.T1*(X2-X1).OR.DX.LE.0.0) DX=T1*(X2-X1)
          X1=X2
          X2=X2+DX
          DX1=DX
          F1=F2
          DF1=DF2
          F2=FLNM(F,X2,DF2,V,XI,N,NUM)
        ENDIF
2000  CONTINUE

      !Iteration has failed to find an acceptable point
      IF(F2.LE.F0) THEN
      !accept this point if function value is smaller
        F1=F2
        X1=X2
        DF1=DF2
        IER=54
        RETURN
      ELSE IF(F1.LE.F0.AND.X1.NE.X0) THEN
        IER=54
        RETURN
      ENDIF

      !No acceptable point found
      IER=527
      END SUBROUTINE LINMIN

      !*************************************************************************
      !FUNCTION ROUTINE TO CALCULATE THE FUNCTION VALUE AND ITS DERIVATIVE
      !AS REQUIRED FOR LINE SEARCH.
      !*************************************************************************
      !
      !FCN : (input) Name of subroutine to calculate the required function
      !X : (input) Parameter along the line to specify the point where
      !	function evaluation is required
      !DF : (output) First derivative of function along the line at X
      !V : (input/output) Real array of length 3N, first N elements specify the
      !	direction of line search. Next N elements will contain the
      !	coordinates of the point at which function is evaluated,
      !	while the last N elements contain the gradient vector at the point
      !X0 : (input) Real array of length N, containing the coordinates
      !	of starting point for line search
      !N : (input) Number of variables in the function to be minimised
      !NUM : (input/output) Integer variable to keep count of function evaluations
      !
      !SUBROUTINE FCN(N,X,FX,G) to calculate the required function, must be supplied
      !	by the user. Here N is the number of variables, FX is the
      !	function value at X and G is the gradient vector. X and G
      !	are real arrays of length N.
      !
      !Required routines : FCN
      !
      !*************************************************************************

      FUNCTION FLNM(FCN,X,DF,V,X0,N,NUM)

      INTEGER :: N, NUM
      INTEGER :: I, N2

      REAL*8 :: FLNM, X, DF
      REAL*8 :: V(3*N),X0(N)

      EXTERNAL :: FCN

      NUM=NUM+1
      N2=2*N
      !The coordinates of the required point
      DO 1000 I=1,N
1000  V(N+I)=X0(I)+V(I)*X

      CALL FCN(N,V(N+1),FLNM,V(N2+1))
      !The first derivative along the search direction
      DF=0.0
      DO 2000 I=1,N
2000  DF=DF+V(I)*V(N2+I)
      END FUNCTION FLNM

      !*************************************************************************
      !TO COMPUTE THE FUNCTION TO BE MINIMIZED
      !*************************************************************************
      !
      !m : (input) Number of parameters
      !x : (input) Real array of length m containing the parameters
      !f : (output) The function value at x
      !g : (output) Real array of length m containing the gradient vector at x
      !
      !Required routines : FIT_FUNC_FQ, DPOLY_FQ
      !
      !*************************************************************************

      SUBROUTINE FCN_FQ(m,x,f,g)

      INTEGER :: m
      INTEGER :: i, i0, j, j0, k, l, n

      REAL*8 :: f
      REAL*8 :: x(m), g(m)
      REAL*8 :: fit_func, dpoly
      REAL*8 :: nu, piNu, factor, tmp

      f = 0.d0
      g = 0.d0
      i0 = m - 7
      DO i = 1, num_of_mode
        nu = MU * freq(i,3)
        piNu = 4.d0 * PI * nu
        l = NINT(freq(i,1))
        n = NINT(freq(i,2))
        fit_func = FIT_FUNC_FQ(l,n,freq(i,3),x)

        ! Function value
        f = f + ((freq(i,3) - fit_func)/freq(i,4))**2
        dpoly = DPOLY_FQ(l,n,nderiv_fq,x)
        f = f + (regu_param_fq * dpoly)**2

        ! Gradient
        factor = -2.d0 * (freq(i,3) - fit_func)/freq(i,4)**2
        j0 = num_of_poly_param_fq * l
        DO j = 1, num_of_poly_param_fq
          g(j0+j) = g(j0+j) + factor * freq(i,2)**(j-1)
        ENDDO
        DO j = nderiv_fq+1, num_of_poly_param_fq
          tmp = 1.d0
          DO k = 1, nderiv_fq
            tmp = tmp * (j-k)
          ENDDO
          g(j0+j) = g(j0+j) + 2.d0 * regu_param_fq**2 * dpoly * &
                    tmp * freq(i,2)**(j - nderiv_fq - 1)
        ENDDO
        g(i0+1) = g(i0+1) + factor * 2.d0 * x(i0+1) * &
                  SIN(piNu * x(i0+2) + x(i0+3))/freq(i,3)**2
        g(i0+2) = g(i0+2) + factor * x(i0+1)**2 * piNu * &
                  COS(piNu * x(i0+2) + x(i0+3))/freq(i,3)**2
        g(i0+3) = g(i0+3) + factor * x(i0+1)**2 * &
                  COS(piNu * x(i0+2) + x(i0+3))/freq(i,3)**2
        g(i0+4) = g(i0+4) + factor * 2.d0 * x(i0+4) * &
                  freq(i,3) * EXP(-(x(i0+5) * nu)**2) * &
                  SIN(piNu * x(i0+6) + x(i0+7))
        g(i0+5) = g(i0+5) - factor * x(i0+4)**2 * freq(i,3) * &
                  2.d0 * x(i0+5) * nu**2 * EXP(-(x(i0+5) * nu)**2) * &
                  SIN(piNu * x(i0+6) + x(i0+7))
        g(i0+6) = g(i0+6) + factor * x(i0+4)**2 * freq(i,3) * &
                  EXP(-(x(i0+5) * nu)**2) * piNu * &
                  COS(piNu * x(i0+6) + x(i0+7))
        g(i0+7) = g(i0+7) + factor * x(i0+4)**2 * &
                  freq(i,3) * EXP(-(x(i0+5) * nu)**2) * &
                  COS(piNu * x(i0+6) + x(i0+7))
      ENDDO

      END SUBROUTINE FCN_FQ

      !*************************************************************************
      !TO COMPUTE THE FITTING FUNCTION
      !*************************************************************************
      !
      !l : (input) Harmonic degree of the mode
      !n : (input) Radial order of the mode
      !nu : (input) Oscillation frequency of the mode (in muHz)
      !param : (input) Array containing the fitting parameters
      !FIT_FUNC_FQ : (output) Value of the fitting function
      !
      !Required routines : None
      !
      !*************************************************************************

      FUNCTION FIT_FUNC_FQ(l,n,nu,param)

      INTEGER :: l, n, i, i0

      REAL*8 :: nu, piNu
      REAL*8 :: param(:)
      REAL*8 :: FIT_FUNC_FQ

      ! Smooth term
      FIT_FUNC_FQ = 0.d0
      i0 = num_of_poly_param_fq * l
      DO i = num_of_poly_param_fq, 1, -1
        FIT_FUNC_FQ = FIT_FUNC_FQ * n + param(i0+i)
      ENDDO

      ! CZ term
      piNu = 4 * PI * MU * nu
      i0 = total_num_of_param_fq - 7
      FIT_FUNC_FQ = FIT_FUNC_FQ + (param(i0+1)/nu)**2 * &
                SIN(piNu * param(i0+2) + param(i0+3))

      ! He term
      FIT_FUNC_FQ = FIT_FUNC_FQ + param(i0+4)**2 * nu * &
                EXP(-(param(i0+5) * MU * nu)**2) * &
                SIN(piNu * param(i0+6) + param(i0+7))

      END FUNCTION FIT_FUNC_FQ

      !*************************************************************************
      !TO COMPUTE THE DERIVATIVE OF THE SMOOTH COMPONENT
      !*************************************************************************
      !
      !l : (input) Degree of the mode
      !n : (input) Radial order of the mode
      !norder : (input) Derivative order
      !param : (input) Array containing the fitting parameters
      !DPOLY_FQ : (output) Derivative of the smooth component
      !
      !Required routines : None
      !
      !*************************************************************************

      FUNCTION DPOLY_FQ(l,n,norder,param)

      INTEGER :: l, n, norder, i, i0, j

      REAL*8 :: param(:)
      REAL*8 :: DPOLY_FQ, tmp

      ! Check
      DPOLY_FQ = 0.d0
      IF (norder .GE. num_of_poly_param_fq) THEN
        RETURN
      ENDIF

      ! Derivative
      i0 = num_of_poly_param_fq * l
      DO i = num_of_poly_param_fq-norder, 1, -1
        tmp = 1.d0
        DO j = 1, norder
          tmp = tmp * (i + j - 1)
        ENDDO
        DPOLY_FQ = DPOLY_FQ * n + tmp * param(i0+i+norder)
      ENDDO

      END FUNCTION DPOLY_FQ

      !*************************************************************************
      !TO COMPUTE THE REGULARIZATION TERM
      !*************************************************************************
      !
      !param : (input) Array containing the fitted parameters.
      !
      !Required routines : DPOLY_FQ
      !
      !*************************************************************************

      FUNCTION REGU_FQ(param)

      INTEGER :: i, l, n

      REAL*8 :: param(:)
      REAL*8 :: REGU_FQ
      REAL*8 :: dpoly

      ! Check
      REGU_FQ = 0.d0
      IF (nderiv_fq .GE. num_of_poly_param_fq) THEN
        RETURN
      ENDIF

      DO i = 1, num_of_mode
        l = NINT(freq(i,1))
        n = NINT(freq(i,2))
        dpoly = DPOLY_FQ(l,n,nderiv_fq,param)
        REGU_FQ = REGU_FQ + (regu_param_fq * dpoly)**2
      ENDDO

      END FUNCTION REGU_FQ

      END SUBROUTINE glitch_fit


      function sg_ijk_to_sg_cell(i,j,k,icell)
      use comparttr_sg
!
      implicit none
!
      integer i, j, k, icell
      integer sg_ijk_to_sg_cell
!
      sg_ijk_to_sg_cell =
     1   ((i-1)+1) +
     2   ((j-1)*nxyz(icell,1)) +
     3   ((k-1)*nxyz(icell,1)*nxyz(icell,2)) +
     4     ip_touched_cells_sg(icell)
      return
      end