      subroutine dspdi(ap,n,kpvt,det,inert,work,job)
      integer n,job
      double precision ap(1),work(1)
      double precision det(2)
      integer kpvt(1),inert(3)
c
c     dspdi computes the determinant, inertia and inverse
c     of a double precision symmetric matrix using the factors from
c     dspfa, where the matrix is stored in packed form.
c
c     on entry
c
c        ap      double precision (n*(n+1)/2)
c                the output from dspfa.
c
c        n       integer
c                the order of the matrix a.
c
c        kpvt    integer(n)
c                the pivot vector from dspfa.
c
c        work    double precision(n)
c                work vector.  contents ignored.
c
c        job     integer
c                job has the decimal expansion  abc  where
c                   if  c .ne. 0, the inverse is computed,
c                   if  b .ne. 0, the determinant is computed,
c                   if  a .ne. 0, the inertia is computed.
c
c                for example, job = 111  gives all three.
c
c     on return
c
c        variables not requested by job are not used.
c
c        ap     contains the upper triangle of the inverse of
c               the original matrix, stored in packed form.
c               the columns of the upper triangle are stored
c               sequentially in a one-dimensional array.
c
c        det    double precision(2)
c               determinant of original matrix.
c               determinant = det(1) * 10.0**det(2)
c               with 1.0 .le. dabs(det(1)) .lt. 10.0
c               or det(1) = 0.0.
c
c        inert  integer(3)
c               the inertia of the original matrix.
c               inert(1)  =  number of positive eigenvalues.
c               inert(2)  =  number of negative eigenvalues.
c               inert(3)  =  number of zero eigenvalues.
c
c     error condition
c
c        a division by zero will occur if the inverse is requested
c        and  dspco  has set rcond .eq. 0.0
c        or  dspfa  has set  info .ne. 0 .
c
c     linpack. this version dated 08/14/78 .
c     james bunch, univ. calif. san diego, argonne nat. lab.
c
c     subroutines and functions
c
c     blas daxpy,dcopy,ddot,dswap
c     fortran dabs,iabs,mod
c
c     internal variables.
c
      double precision akkp1,ddot,temp
      double precision ten,d,t,ak,akp1
      integer ij,ik,ikp1,iks,j,jb,jk,jkp1
      integer k,kk,kkp1,km1,ks,ksj,kskp1,kstep
      logical noinv,nodet,noert
c
      noinv = mod(job,10) .eq. 0
      nodet = mod(job,100)/10 .eq. 0
      noert = mod(job,1000)/100 .eq. 0
c
      if (nodet .and. noert) go to 140
         if (noert) go to 10
            inert(1) = 0
            inert(2) = 0
            inert(3) = 0
   10    continue
         if (nodet) go to 20
            det(1) = 1.0d0
            det(2) = 0.0d0
            ten = 10.0d0
   20    continue
         t = 0.0d0
         ik = 0
         do 130 k = 1, n
            kk = ik + k
            d = ap(kk)
c
c           check if 1 by 1
c
            if (kpvt(k) .gt. 0) go to 50
c
c              2 by 2 block
c              use det (d  s)  =  (d/t * c - t) * t  ,  t = dabs(s)
c                      (s  c)
c              to avoid underflow/overflow troubles.
c              take two passes through scaling.  use  t  for flag.
c
               if (t .ne. 0.0d0) go to 30
                  ikp1 = ik + k
                  kkp1 = ikp1 + k
                  t = dabs(ap(kkp1))
                  d = (d/t)*ap(kkp1+1) - t
               go to 40
   30          continue
                  d = t
                  t = 0.0d0
   40          continue
   50       continue
c
            if (noert) go to 60
               if (d .gt. 0.0d0) inert(1) = inert(1) + 1
               if (d .lt. 0.0d0) inert(2) = inert(2) + 1
               if (d .eq. 0.0d0) inert(3) = inert(3) + 1
   60       continue
c
            if (nodet) go to 120
               det(1) = d*det(1)
               if (det(1) .eq. 0.0d0) go to 110
   70             if (dabs(det(1)) .ge. 1.0d0) go to 80
                     det(1) = ten*det(1)
                     det(2) = det(2) - 1.0d0
                  go to 70
   80             continue
   90             if (dabs(det(1)) .lt. ten) go to 100
                     det(1) = det(1)/ten
                     det(2) = det(2) + 1.0d0
                  go to 90
  100             continue
  110          continue
  120       continue
            ik = ik + k
  130    continue
  140 continue
c
c     compute inverse(a)
c
      if (noinv) go to 270
         k = 1
         ik = 0
  150    if (k .gt. n) go to 260
            km1 = k - 1
            kk = ik + k
            ikp1 = ik + k
            kkp1 = ikp1 + k
            if (kpvt(k) .lt. 0) go to 180
c
c              1 by 1
c
               ap(kk) = 1.0d0/ap(kk)
               if (km1 .lt. 1) go to 170
                  call dcopy(km1,ap(ik+1),1,work,1)
                  ij = 0
                  do 160 j = 1, km1
                     jk = ik + j
                     ap(jk) = ddot(j,ap(ij+1),1,work,1)
                     call daxpy(j-1,work(j),ap(ij+1),1,ap(ik+1),1)
                     ij = ij + j
  160             continue
                  ap(kk) = ap(kk) + ddot(km1,work,1,ap(ik+1),1)
  170          continue
               kstep = 1
            go to 220
  180       continue
c
c              2 by 2
c
               t = dabs(ap(kkp1))
               ak = ap(kk)/t
               akp1 = ap(kkp1+1)/t
               akkp1 = ap(kkp1)/t
               d = t*(ak*akp1 - 1.0d0)
               ap(kk) = akp1/d
               ap(kkp1+1) = ak/d
               ap(kkp1) = -akkp1/d
               if (km1 .lt. 1) go to 210
                  call dcopy(km1,ap(ikp1+1),1,work,1)
                  ij = 0
                  do 190 j = 1, km1
                     jkp1 = ikp1 + j
                     ap(jkp1) = ddot(j,ap(ij+1),1,work,1)
                     call daxpy(j-1,work(j),ap(ij+1),1,ap(ikp1+1),1)
                     ij = ij + j
  190             continue
                  ap(kkp1+1) = ap(kkp1+1)
     *                         + ddot(km1,work,1,ap(ikp1+1),1)
                  ap(kkp1) = ap(kkp1)
     *                       + ddot(km1,ap(ik+1),1,ap(ikp1+1),1)
                  call dcopy(km1,ap(ik+1),1,work,1)
                  ij = 0
                  do 200 j = 1, km1
                     jk = ik + j
                     ap(jk) = ddot(j,ap(ij+1),1,work,1)
                     call daxpy(j-1,work(j),ap(ij+1),1,ap(ik+1),1)
                     ij = ij + j
  200             continue
                  ap(kk) = ap(kk) + ddot(km1,work,1,ap(ik+1),1)
  210          continue
               kstep = 2
  220       continue
c
c           swap
c
            ks = iabs(kpvt(k))
            if (ks .eq. k) go to 250
               iks = (ks*(ks - 1))/2
               call dswap(ks,ap(iks+1),1,ap(ik+1),1)
               ksj = ik + ks
               do 230 jb = ks, k
                  j = k + ks - jb
                  jk = ik + j
                  temp = ap(jk)
                  ap(jk) = ap(ksj)
                  ap(ksj) = temp
                  ksj = ksj - (j - 1)
  230          continue
               if (kstep .eq. 1) go to 240
                  kskp1 = ikp1 + ks
                  temp = ap(kskp1)
                  ap(kskp1) = ap(kkp1)
                  ap(kkp1) = temp
  240          continue
  250       continue
            ik = ik + k
            if (kstep .eq. 2) ik = ik + k + 1
            k = k + kstep
         go to 150
  260    continue
  270 continue
      return
      end
      subroutine dspfa(ap,n,kpvt,info)
      integer n,kpvt(1),info
      double precision ap(1)
c
c     dspfa factors a double precision symmetric matrix stored in
c     packed form by elimination with symmetric pivoting.
c
c     to solve  a*x = b , follow dspfa by dspsl.
c     to compute  inverse(a)*c , follow dspfa by dspsl.
c     to compute  determinant(a) , follow dspfa by dspdi.
c     to compute  inertia(a) , follow dspfa by dspdi.
c     to compute  inverse(a) , follow dspfa by dspdi.
c
c     on entry
c
c        ap      double precision (n*(n+1)/2)
c                the packed form of a symmetric matrix  a .  the
c                columns of the upper triangle are stored sequentially
c                in a one-dimensional array of length  n*(n+1)/2 .
c                see comments below for details.
c
c        n       integer
c                the order of the matrix  a .
c
c     output
c
c        ap      a block diagonal matrix and the multipliers which
c                were used to obtain it stored in packed form.
c                the factorization can be written  a = u*d*trans(u)
c                where  u  is a product of permutation and unit
c                upper triangular matrices , trans(u) is the
c                transpose of  u , and  d  is block diagonal
c                with 1 by 1 and 2 by 2 blocks.
c
c        kpvt    integer(n)
c                an integer vector of pivot indices.
c
c        info    integer
c                = 0  normal value.
c                = k  if the k-th pivot block is singular. this is
c                     not an error condition for this subroutine,
c                     but it does indicate that dspsl or dspdi may
c                     divide by zero if called.
c
c     packed storage
c
c          the following program segment will pack the upper
c          triangle of a symmetric matrix.
c
c                k = 0
c                do 20 j = 1, n
c                   do 10 i = 1, j
c                      k = k + 1
c                      ap(k)  = a(i,j)
c             10    continue
c             20 continue
c
c     linpack. this version dated 08/14/78 .
c     james bunch, univ. calif. san diego, argonne nat. lab.
c
c     subroutines and functions
c
c     blas daxpy,dswap,idamax
c     fortran dabs,dmax1,dsqrt
c
c     internal variables
c
      double precision ak,akm1,bk,bkm1,denom,mulk,mulkm1,t
      double precision absakk,alpha,colmax,rowmax
      integer idamax,ij,ijj,ik,ikm1,im,imax,imaxp1,imim,imj,imk
      integer j,jj,jk,jkm1,jmax,jmim,k,kk,km1,km1k,km1km1,km2,kstep
      logical swap
c
c
c     initialize
c
c     alpha is used in choosing pivot block size.
      alpha = (1.0d0 + dsqrt(17.0d0))/8.0d0
c
      info = 0
c
c     main loop on k, which goes from n to 1.
c
      k = n
      ik = (n*(n - 1))/2
   10 continue
c
c        leave the loop if k=0 or k=1.
c
c     ...exit
         if (k .eq. 0) go to 200
         if (k .gt. 1) go to 20
            kpvt(1) = 1
            if (ap(1) .eq. 0.0d0) info = 1
c     ......exit
            go to 200
   20    continue
c
c        this section of code determines the kind of
c        elimination to be performed.  when it is completed,
c        kstep will be set to the size of the pivot block, and
c        swap will be set to .true. if an interchange is
c        required.
c
         km1 = k - 1
         kk = ik + k
         absakk = dabs(ap(kk))
c
c        determine the largest off-diagonal element in
c        column k.
c
         imax = idamax(k-1,ap(ik+1),1)
         imk = ik + imax
         colmax = dabs(ap(imk))
         if (absakk .lt. alpha*colmax) go to 30
            kstep = 1
            swap = .false.
         go to 90
   30    continue
c
c           determine the largest off-diagonal element in
c           row imax.
c
            rowmax = 0.0d0
            imaxp1 = imax + 1
            im = imax*(imax - 1)/2
            imj = im + 2*imax
            do 40 j = imaxp1, k
               rowmax = dmax1(rowmax,dabs(ap(imj)))
               imj = imj + j
   40       continue
            if (imax .eq. 1) go to 50
               jmax = idamax(imax-1,ap(im+1),1)
               jmim = jmax + im
               rowmax = dmax1(rowmax,dabs(ap(jmim)))
   50       continue
            imim = imax + im
            if (dabs(ap(imim)) .lt. alpha*rowmax) go to 60
               kstep = 1
               swap = .true.
            go to 80
   60       continue
            if (absakk .lt. alpha*colmax*(colmax/rowmax)) go to 70
               kstep = 1
               swap = .false.
            go to 80
   70       continue
               kstep = 2
               swap = imax .ne. km1
   80       continue
   90    continue
         if (dmax1(absakk,colmax) .ne. 0.0d0) go to 100
c
c           column k is zero.  set info and iterate the loop.
c
            kpvt(k) = k
            info = k
         go to 190
  100    continue
         if (kstep .eq. 2) go to 140
c
c           1 x 1 pivot block.
c
            if (.not.swap) go to 120
c
c              perform an interchange.
c
               call dswap(imax,ap(im+1),1,ap(ik+1),1)
               imj = ik + imax
               do 110 jj = imax, k
                  j = k + imax - jj
                  jk = ik + j
                  t = ap(jk)
                  ap(jk) = ap(imj)
                  ap(imj) = t
                  imj = imj - (j - 1)
  110          continue
  120       continue
c
c           perform the elimination.
c
            ij = ik - (k - 1)
            do 130 jj = 1, km1
               j = k - jj
               jk = ik + j
               mulk = -ap(jk)/ap(kk)
               t = mulk
               call daxpy(j,t,ap(ik+1),1,ap(ij+1),1)
               ijj = ij + j
               ap(jk) = mulk
               ij = ij - (j - 1)
  130       continue
c
c           set the pivot array.
c
            kpvt(k) = k
            if (swap) kpvt(k) = imax
         go to 190
  140    continue
c
c           2 x 2 pivot block.
c
            km1k = ik + k - 1
            ikm1 = ik - (k - 1)
            if (.not.swap) go to 160
c
c              perform an interchange.
c
               call dswap(imax,ap(im+1),1,ap(ikm1+1),1)
               imj = ikm1 + imax
               do 150 jj = imax, km1
                  j = km1 + imax - jj
                  jkm1 = ikm1 + j
                  t = ap(jkm1)
                  ap(jkm1) = ap(imj)
                  ap(imj) = t
                  imj = imj - (j - 1)
  150          continue
               t = ap(km1k)
               ap(km1k) = ap(imk)
               ap(imk) = t
  160       continue
c
c           perform the elimination.
c
            km2 = k - 2
            if (km2 .eq. 0) go to 180
               ak = ap(kk)/ap(km1k)
               km1km1 = ikm1 + k - 1
               akm1 = ap(km1km1)/ap(km1k)
               denom = 1.0d0 - ak*akm1
               ij = ik - (k - 1) - (k - 2)
               do 170 jj = 1, km2
                  j = km1 - jj
                  jk = ik + j
                  bk = ap(jk)/ap(km1k)
                  jkm1 = ikm1 + j
                  bkm1 = ap(jkm1)/ap(km1k)
                  mulk = (akm1*bk - bkm1)/denom
                  mulkm1 = (ak*bkm1 - bk)/denom
                  t = mulk
                  call daxpy(j,t,ap(ik+1),1,ap(ij+1),1)
                  t = mulkm1
                  call daxpy(j,t,ap(ikm1+1),1,ap(ij+1),1)
                  ap(jk) = mulk
                  ap(jkm1) = mulkm1
                  ijj = ij + j
                  ij = ij - (j - 1)
  170          continue
  180       continue
c
c           set the pivot array.
c
            kpvt(k) = 1 - k
            if (swap) kpvt(k) = -imax
            kpvt(k-1) = kpvt(k)
  190    continue
         ik = ik - (k - 1)
         if (kstep .eq. 2) ik = ik - (k - 2)
         k = k - kstep
      go to 10
  200 continue
      return
      end
      double precision function pythag(a,b)
      double precision a,b
c
c     finds dsqrt(a**2+b**2) without overflow or destructive underflow
c
      double precision p,r,s,t,u
      p = dmax1(dabs(a),dabs(b))
      if (p .eq. 0.0d0) go to 20
      r = (dmin1(dabs(a),dabs(b))/p)**2
   10 continue
         t = 4.0d0 + r
         if (t .eq. 4.0d0) go to 20
         s = r/t
         u = 1.0d0 + 2.0d0*s
         p = u*p
         r = (s/u)**2 * r
      go to 10
   20 pythag = p
      return
      end
      subroutine rs(nm,n,a,w,matz,z,fv1,fv2,ierr)
c
      integer n,nm,ierr,matz
      double precision a(nm,n),w(n),z(nm,n),fv1(n),fv2(n)
c
c     this subroutine calls the recommended sequence of
c     subroutines from the eigensystem subroutine package (eispack)
c     to find the eigenvalues and eigenvectors (if desired)
c     of a real symmetric matrix.
c
c     on input
c
c        nm  must be set to the row dimension of the two-dimensional
c        array parameters as declared in the calling program
c        dimension statement.
c
c        n  is the order of the matrix  a.
c
c        a  contains the real symmetric matrix.
c
c        matz  is an integer variable set equal to zero if
c        only eigenvalues are desired.  otherwise it is set to
c        any non-zero integer for both eigenvalues and eigenvectors.
c
c     on output
c
c        w  contains the eigenvalues in ascending order.
c
c        z  contains the eigenvectors if matz is not zero.
c
c        ierr  is an integer output variable set equal to an error
c           completion code described in the documentation for tqlrat
c           and tql2.  the normal completion code is zero.
c
c        fv1  and  fv2  are temporary storage arrays.
c
c     questions and comments should be directed to burton s. garbow,
c     mathematics and computer science div, argonne national laboratory
c
c     this version dated august 1983.
c
c     ------------------------------------------------------------------
c
      if (n .le. nm) go to 10
      ierr = 10 * n
      go to 50
c
   10 if (matz .ne. 0) go to 20
c     .......... find eigenvalues only ..........
      call  tred1(nm,n,a,w,fv1,fv2)
*  tqlrat encounters catastrophic underflow on the Vax
*     call  tqlrat(n,w,fv2,ierr)
      call  tql1(n,w,fv1,ierr)
      go to 50
c     .......... find both eigenvalues and eigenvectors ..........
   20 call  tred2(nm,n,a,w,fv1,z)
      call  tql2(nm,n,w,fv1,z,ierr)
   50 return
      end
      subroutine tql1(n,d,e,ierr)
c
      integer i,j,l,m,n,ii,l1,l2,mml,ierr
      double precision d(n),e(n)
      double precision c,c2,c3,dl1,el1,f,g,h,p,r,s,s2,tst1,tst2,pythag
c
c     this subroutine is a translation of the algol procedure tql1,
c     num. math. 11, 293-306(1968) by bowdler, martin, reinsch, and
c     wilkinson.
c     handbook for auto. comp., vol.ii-linear algebra, 227-240(1971).
c
c     this subroutine finds the eigenvalues of a symmetric
c     tridiagonal matrix by the ql method.
c
c     on input
c
c        n is the order of the matrix.
c
c        d contains the diagonal elements of the input matrix.
c
c        e contains the subdiagonal elements of the input matrix
c          in its last n-1 positions.  e(1) is arbitrary.
c
c      on output
c
c        d contains the eigenvalues in ascending order.  if an
c          error exit is made, the eigenvalues are correct and
c          ordered for indices 1,2,...ierr-1, but may not be
c          the smallest eigenvalues.
c
c        e has been destroyed.
c
c        ierr is set to
c          zero       for normal return,
c          j          if the j-th eigenvalue has not been
c                     determined after 30 iterations.
c
c     calls pythag for  dsqrt(a*a + b*b) .
c
c     questions and comments should be directed to burton s. garbow,
c     mathematics and computer science div, argonne national laboratory
c
c     this version dated august 1983.
c
c     ------------------------------------------------------------------
c
      ierr = 0
      if (n .eq. 1) go to 1001
c
      do 100 i = 2, n
  100 e(i-1) = e(i)
c
      f = 0.0d0
      tst1 = 0.0d0
      e(n) = 0.0d0
c
      do 290 l = 1, n
         j = 0
         h = dabs(d(l)) + dabs(e(l))
         if (tst1 .lt. h) tst1 = h
c     .......... look for small sub-diagonal element ..........
         do 110 m = l, n
            tst2 = tst1 + dabs(e(m))
            if (tst2 .eq. tst1) go to 120
c     .......... e(n) is always zero, so there is no exit
c                through the bottom of the loop ..........
  110    continue
c
  120    if (m .eq. l) go to 210
  130    if (j .eq. 30) go to 1000
         j = j + 1
c     .......... form shift ..........
         l1 = l + 1
         l2 = l1 + 1
         g = d(l)
         p = (d(l1) - g) / (2.0d0 * e(l))
         r = pythag(p,1.0d0)
         d(l) = e(l) / (p + dsign(r,p))
         d(l1) = e(l) * (p + dsign(r,p))
         dl1 = d(l1)
         h = g - d(l)
         if (l2 .gt. n) go to 145
c
         do 140 i = l2, n
  140    d(i) = d(i) - h
c
  145    f = f + h
c     .......... ql transformation ..........
         p = d(m)
         c = 1.0d0
         c2 = c
         el1 = e(l1)
         s = 0.0d0
         mml = m - l
c     .......... for i=m-1 step -1 until l do -- ..........
         do 200 ii = 1, mml
            c3 = c2
            c2 = c
            s2 = s
            i = m - ii
            g = c * e(i)
            h = c * p
            r = pythag(p,e(i))
            e(i+1) = s * r
            s = e(i) / r
            c = p / r
            p = c * d(i) - s * g
            d(i+1) = h + s * (c * g + s * d(i))
  200    continue
c
         p = -s * s2 * c3 * el1 * e(l) / dl1
         e(l) = s * p
         d(l) = c * p
         tst2 = tst1 + dabs(e(l))
         if (tst2 .gt. tst1) go to 130
  210    p = d(l) + f
c     .......... order eigenvalues ..........
         if (l .eq. 1) go to 250
c     .......... for i=l step -1 until 2 do -- ..........
         do 230 ii = 2, l
            i = l + 2 - ii
            if (p .ge. d(i-1)) go to 270
            d(i) = d(i-1)
  230    continue
c
  250    i = 1
  270    d(i) = p
  290 continue
c
      go to 1001
c     .......... set error -- no convergence to an
c                eigenvalue after 30 iterations ..........
 1000 ierr = l
 1001 return
      end
      subroutine tql2(nm,n,d,e,z,ierr)
c
      integer i,j,k,l,m,n,ii,l1,l2,nm,mml,ierr
      double precision d(n),e(n),z(nm,n)
      double precision c,c2,c3,dl1,el1,f,g,h,p,r,s,s2,tst1,tst2,pythag
c
c     this subroutine is a translation of the algol procedure tql2,
c     num. math. 11, 293-306(1968) by bowdler, martin, reinsch, and
c     wilkinson.
c     handbook for auto. comp., vol.ii-linear algebra, 227-240(1971).
c
c     this subroutine finds the eigenvalues and eigenvectors
c     of a symmetric tridiagonal matrix by the ql method.
c     the eigenvectors of a full symmetric matrix can also
c     be found if  tred2  has been used to reduce this
c     full matrix to tridiagonal form.
c
c     on input
c
c        nm must be set to the row dimension of two-dimensional
c          array parameters as declared in the calling program
c          dimension statement.
c
c        n is the order of the matrix.
c
c        d contains the diagonal elements of the input matrix.
c
c        e contains the subdiagonal elements of the input matrix
c          in its last n-1 positions.  e(1) is arbitrary.
c
c        z contains the transformation matrix produced in the
c          reduction by  tred2, if performed.  if the eigenvectors
c          of the tridiagonal matrix are desired, z must contain
c          the identity matrix.
c
c      on output
c
c        d contains the eigenvalues in ascending order.  if an
c          error exit is made, the eigenvalues are correct but
c          unordered for indices 1,2,...,ierr-1.
c
c        e has been destroyed.
c
c        z contains orthonormal eigenvectors of the symmetric
c          tridiagonal (or full) matrix.  if an error exit is made,
c          z contains the eigenvectors associated with the stored
c          eigenvalues.
c
c        ierr is set to
c          zero       for normal return,
c          j          if the j-th eigenvalue has not been
c                     determined after 30 iterations.
c
c     calls pythag for  dsqrt(a*a + b*b) .
c
c     questions and comments should be directed to burton s. garbow,
c     mathematics and computer science div, argonne national laboratory
c
c     this version dated august 1983.
c
c     ------------------------------------------------------------------
c
      ierr = 0
      if (n .eq. 1) go to 1001
c
      do 100 i = 2, n
  100 e(i-1) = e(i)
c
      f = 0.0d0
      tst1 = 0.0d0
      e(n) = 0.0d0
c
      do 240 l = 1, n
         j = 0
         h = dabs(d(l)) + dabs(e(l))
         if (tst1 .lt. h) tst1 = h
c     .......... look for small sub-diagonal element ..........
         do 110 m = l, n
            tst2 = tst1 + dabs(e(m))
            if (tst2 .eq. tst1) go to 120
c     .......... e(n) is always zero, so there is no exit
c                through the bottom of the loop ..........
  110    continue
c
  120    if (m .eq. l) go to 220
  130    if (j .eq. 30) go to 1000
         j = j + 1
c     .......... form shift ..........
         l1 = l + 1
         l2 = l1 + 1
         g = d(l)
         p = (d(l1) - g) / (2.0d0 * e(l))
         r = pythag(p,1.0d0)
         d(l) = e(l) / (p + dsign(r,p))
         d(l1) = e(l) * (p + dsign(r,p))
         dl1 = d(l1)
         h = g - d(l)
         if (l2 .gt. n) go to 145
c
         do 140 i = l2, n
  140    d(i) = d(i) - h
c
  145    f = f + h
c     .......... ql transformation ..........
         p = d(m)
         c = 1.0d0
         c2 = c
         el1 = e(l1)
         s = 0.0d0
         mml = m - l
c     .......... for i=m-1 step -1 until l do -- ..........
         do 200 ii = 1, mml
            c3 = c2
            c2 = c
            s2 = s
            i = m - ii
            g = c * e(i)
            h = c * p
            r = pythag(p,e(i))
            e(i+1) = s * r
            s = e(i) / r
            c = p / r
            p = c * d(i) - s * g
            d(i+1) = h + s * (c * g + s * d(i))
c     .......... form vector ..........
            do 180 k = 1, n
               h = z(k,i+1)
               z(k,i+1) = s * z(k,i) + c * h
               z(k,i) = c * z(k,i) - s * h
  180       continue
c
  200    continue
c
         p = -s * s2 * c3 * el1 * e(l) / dl1
         e(l) = s * p
         d(l) = c * p
         tst2 = tst1 + dabs(e(l))
         if (tst2 .gt. tst1) go to 130
  220    d(l) = d(l) + f
  240 continue
c     .......... order eigenvalues and eigenvectors ..........
      do 300 ii = 2, n
         i = ii - 1
         k = i
         p = d(i)
c
         do 260 j = ii, n
            if (d(j) .ge. p) go to 260
            k = j
            p = d(j)
  260    continue
c
         if (k .eq. i) go to 300
         d(k) = d(i)
         d(i) = p
c
         do 280 j = 1, n
            p = z(j,i)
            z(j,i) = z(j,k)
            z(j,k) = p
  280    continue
c
  300 continue
c
      go to 1001
c     .......... set error -- no convergence to an
c                eigenvalue after 30 iterations ..........
 1000 ierr = l
 1001 return
      end
      subroutine tred1(nm,n,a,d,e,e2)
c
      integer i,j,k,l,n,ii,nm,jp1
      double precision a(nm,n),d(n),e(n),e2(n)
      double precision f,g,h,scale
c
c     this subroutine is a translation of the algol procedure tred1,
c     num. math. 11, 181-195(1968) by martin, reinsch, and wilkinson.
c     handbook for auto. comp., vol.ii-linear algebra, 212-226(1971).
c
c     this subroutine reduces a real symmetric matrix
c     to a symmetric tridiagonal matrix using
c     orthogonal similarity transformations.
c
c     on input
c
c        nm must be set to the row dimension of two-dimensional
c          array parameters as declared in the calling program
c          dimension statement.
c
c        n is the order of the matrix.
c
c        a contains the real symmetric input matrix.  only the
c          lower triangle of the matrix need be supplied.
c
c     on output
c
c        a contains information about the orthogonal trans-
c          formations used in the reduction in its strict lower
c          triangle.  the full upper triangle of a is unaltered.
c
c        d contains the diagonal elements of the tridiagonal matrix.
c
c        e contains the subdiagonal elements of the tridiagonal
c          matrix in its last n-1 positions.  e(1) is set to zero.
c
c        e2 contains the squares of the corresponding elements of e.
c          e2 may coincide with e if the squares are not needed.
c
c     questions and comments should be directed to burton s. garbow,
c     mathematics and computer science div, argonne national laboratory
c
c     this version dated august 1983.
c
c     ------------------------------------------------------------------
c
      do 100 i = 1, n
         d(i) = a(n,i)
         a(n,i) = a(i,i)
  100 continue
c     .......... for i=n step -1 until 1 do -- ..........
      do 300 ii = 1, n
         i = n + 1 - ii
         l = i - 1
         h = 0.0d0
         scale = 0.0d0
         if (l .lt. 1) go to 130
c     .......... scale row (algol tol then not needed) ..........
         do 120 k = 1, l
  120    scale = scale + dabs(d(k))
c
         if (scale .ne. 0.0d0) go to 140
c
         do 125 j = 1, l
            d(j) = a(l,j)
            a(l,j) = a(i,j)
            a(i,j) = 0.0d0
  125    continue
c
  130    e(i) = 0.0d0
         e2(i) = 0.0d0
         go to 300
c
  140    do 150 k = 1, l
            d(k) = d(k) / scale
            h = h + d(k) * d(k)
  150    continue
c
         e2(i) = scale * scale * h
         f = d(l)
         g = -dsign(dsqrt(h),f)
         e(i) = scale * g
         h = h - f * g
         d(l) = f - g
         if (l .eq. 1) go to 285
c     .......... form a*u ..........
         do 170 j = 1, l
  170    e(j) = 0.0d0
c
         do 240 j = 1, l
            f = d(j)
            g = e(j) + a(j,j) * f
            jp1 = j + 1
            if (l .lt. jp1) go to 220
c
            do 200 k = jp1, l
               g = g + a(k,j) * d(k)
               e(k) = e(k) + a(k,j) * f
  200       continue
c
  220       e(j) = g
  240    continue
c     .......... form p ..........
         f = 0.0d0
c
         do 245 j = 1, l
            e(j) = e(j) / h
            f = f + e(j) * d(j)
  245    continue
c
         h = f / (h + h)
c     .......... form q ..........
         do 250 j = 1, l
  250    e(j) = e(j) - h * d(j)
c     .......... form reduced a ..........
         do 280 j = 1, l
            f = d(j)
            g = e(j)
c
            do 260 k = j, l
  260       a(k,j) = a(k,j) - f * e(k) - g * d(k)
c
  280    continue
c
  285    do 290 j = 1, l
            f = d(j)
            d(j) = a(l,j)
            a(l,j) = a(i,j)
            a(i,j) = f * scale
  290    continue
c
  300 continue
c
      return
      end
      subroutine tred2(nm,n,a,d,e,z)
c
      integer i,j,k,l,n,ii,nm,jp1
      double precision a(nm,n),d(n),e(n),z(nm,n)
      double precision f,g,h,hh,scale
c
c     this subroutine is a translation of the algol procedure tred2,
c     num. math. 11, 181-195(1968) by martin, reinsch, and wilkinson.
c     handbook for auto. comp., vol.ii-linear algebra, 212-226(1971).
c
c     this subroutine reduces a real symmetric matrix to a
c     symmetric tridiagonal matrix using and accumulating
c     orthogonal similarity transformations.
c
c     on input
c
c        nm must be set to the row dimension of two-dimensional
c          array parameters as declared in the calling program
c          dimension statement.
c
c        n is the order of the matrix.
c
c        a contains the real symmetric input matrix.  only the
c          lower triangle of the matrix need be supplied.
c
c     on output
c
c        d contains the diagonal elements of the tridiagonal matrix.
c
c        e contains the subdiagonal elements of the tridiagonal
c          matrix in its last n-1 positions.  e(1) is set to zero.
c
c        z contains the orthogonal transformation matrix
c          produced in the reduction.
c
c        a and z may coincide.  if distinct, a is unaltered.
c
c     questions and comments should be directed to burton s. garbow,
c     mathematics and computer science div, argonne national laboratory
c
c     this version dated august 1983.
c
c     ------------------------------------------------------------------
c
      do 100 i = 1, n
c
         do 80 j = i, n
   80    z(j,i) = a(j,i)
c
         d(i) = a(n,i)
  100 continue
c
      if (n .eq. 1) go to 510
c     .......... for i=n step -1 until 2 do -- ..........
      do 300 ii = 2, n
         i = n + 2 - ii
         l = i - 1
         h = 0.0d0
         scale = 0.0d0
         if (l .lt. 2) go to 130
c     .......... scale row (algol tol then not needed) ..........
         do 120 k = 1, l
  120    scale = scale + dabs(d(k))
c
         if (scale .ne. 0.0d0) go to 140
  130    e(i) = d(l)
c
         do 135 j = 1, l
            d(j) = z(l,j)
            z(i,j) = 0.0d0
            z(j,i) = 0.0d0
  135    continue
c
         go to 290
c
  140    do 150 k = 1, l
            d(k) = d(k) / scale
            h = h + d(k) * d(k)
  150    continue
c
         f = d(l)
         g = -dsign(dsqrt(h),f)
         e(i) = scale * g
         h = h - f * g
         d(l) = f - g
c     .......... form a*u ..........
         do 170 j = 1, l
  170    e(j) = 0.0d0
c
         do 240 j = 1, l
            f = d(j)
            z(j,i) = f
            g = e(j) + z(j,j) * f
            jp1 = j + 1
            if (l .lt. jp1) go to 220
c
            do 200 k = jp1, l
               g = g + z(k,j) * d(k)
               e(k) = e(k) + z(k,j) * f
  200       continue
c
  220       e(j) = g
  240    continue
c     .......... form p ..........
         f = 0.0d0
c
         do 245 j = 1, l
            e(j) = e(j) / h
            f = f + e(j) * d(j)
  245    continue
c
         hh = f / (h + h)
c     .......... form q ..........
         do 250 j = 1, l
  250    e(j) = e(j) - hh * d(j)
c     .......... form reduced a ..........
         do 280 j = 1, l
            f = d(j)
            g = e(j)
c
            do 260 k = j, l
  260       z(k,j) = z(k,j) - f * e(k) - g * d(k)
c
            d(j) = z(l,j)
            z(i,j) = 0.0d0
  280    continue
c
  290    d(i) = h
  300 continue
c     .......... accumulation of transformation matrices ..........
      do 500 i = 2, n
         l = i - 1
         z(n,l) = z(l,l)
         z(l,l) = 1.0d0
         h = d(i)
         if (h .eq. 0.0d0) go to 380
c
         do 330 k = 1, l
  330    d(k) = z(k,i) / h
c
         do 360 j = 1, l
            g = 0.0d0
c
            do 340 k = 1, l
  340       g = g + z(k,i) * z(k,j)
c
            do 360 k = 1, l
               z(k,j) = z(k,j) - g * d(k)
  360    continue
c
  380    do 400 k = 1, l
  400    z(k,i) = 0.0d0
c
  500 continue
c
  510 do 520 i = 1, n
         d(i) = z(n,i)
         z(n,i) = 0.0d0
  520 continue
c
      z(n,n) = 1.0d0
      e(1) = 0.0d0
      return
      end
      subroutine daxpy(n,da,dx,incx,dy,incy)
c
c     constant times a vector plus a vector.
c     uses unrolled loops for increments equal to one.
c     jack dongarra, linpack, 3/11/78.
c     modified 12/3/93, array(1) declarations changed to array(*)
c
      double precision dx(*),dy(*),da
      integer i,incx,incy,ix,iy,m,mp1,n
c
      if(n.le.0)return
      if (da .eq. 0.0d0) return
      if(incx.eq.1.and.incy.eq.1)go to 20
c
c        code for unequal increments or equal increments
c          not equal to 1
c
      ix = 1
      iy = 1
      if(incx.lt.0)ix = (-n+1)*incx + 1
      if(incy.lt.0)iy = (-n+1)*incy + 1
      do 10 i = 1,n
        dy(iy) = dy(iy) + da*dx(ix)
        ix = ix + incx
        iy = iy + incy
   10 continue
      return
c
c        code for both increments equal to 1
c
c
c        clean-up loop
c
   20 m = mod(n,4)
      if( m .eq. 0 ) go to 40
      do 30 i = 1,m
        dy(i) = dy(i) + da*dx(i)
   30 continue
      if( n .lt. 4 ) return
   40 mp1 = m + 1
      do 50 i = mp1,n,4
        dy(i) = dy(i) + da*dx(i)
        dy(i + 1) = dy(i + 1) + da*dx(i + 1)
        dy(i + 2) = dy(i + 2) + da*dx(i + 2)
        dy(i + 3) = dy(i + 3) + da*dx(i + 3)
   50 continue
      return
      end
      subroutine  dcopy(n,dx,incx,dy,incy)
c
c     copies a vector, x, to a vector, y.
c     uses unrolled loops for increments equal to one.
c     jack dongarra, linpack, 3/11/78.
c     modified 12/3/93, array(1) declarations changed to array(*)
c
      double precision dx(*),dy(*)
      integer i,incx,incy,ix,iy,m,mp1,n
c
      if(n.le.0)return
      if(incx.eq.1.and.incy.eq.1)go to 20
c
c        code for unequal increments or equal increments
c          not equal to 1
c
      ix = 1
      iy = 1
      if(incx.lt.0)ix = (-n+1)*incx + 1
      if(incy.lt.0)iy = (-n+1)*incy + 1
      do 10 i = 1,n
        dy(iy) = dx(ix)
        ix = ix + incx
        iy = iy + incy
   10 continue
      return
c
c        code for both increments equal to 1
c
c
c        clean-up loop
c
   20 m = mod(n,7)
      if( m .eq. 0 ) go to 40
      do 30 i = 1,m
        dy(i) = dx(i)
   30 continue
      if( n .lt. 7 ) return
   40 mp1 = m + 1
      do 50 i = mp1,n,7
        dy(i) = dx(i)
        dy(i + 1) = dx(i + 1)
        dy(i + 2) = dx(i + 2)
        dy(i + 3) = dx(i + 3)
        dy(i + 4) = dx(i + 4)
        dy(i + 5) = dx(i + 5)
        dy(i + 6) = dx(i + 6)
   50 continue
      return
      end
      double precision function ddot(n,dx,incx,dy,incy)
c
c     forms the dot product of two vectors.
c     uses unrolled loops for increments equal to one.
c     jack dongarra, linpack, 3/11/78.
c     modified 12/3/93, array(1) declarations changed to array(*)
c
      double precision dx(*),dy(*),dtemp
      integer i,incx,incy,ix,iy,m,mp1,n
c
      ddot = 0.0d0
      dtemp = 0.0d0
      if(n.le.0)return
      if(incx.eq.1.and.incy.eq.1)go to 20
c
c        code for unequal increments or equal increments
c          not equal to 1
c
      ix = 1
      iy = 1
      if(incx.lt.0)ix = (-n+1)*incx + 1
      if(incy.lt.0)iy = (-n+1)*incy + 1
      do 10 i = 1,n
        dtemp = dtemp + dx(ix)*dy(iy)
        ix = ix + incx
        iy = iy + incy
   10 continue
      ddot = dtemp
      return
c
c        code for both increments equal to 1
c
c
c        clean-up loop
c
   20 m = mod(n,5)
      if( m .eq. 0 ) go to 40
      do 30 i = 1,m
        dtemp = dtemp + dx(i)*dy(i)
   30 continue
      if( n .lt. 5 ) go to 60
   40 mp1 = m + 1
      do 50 i = mp1,n,5
        dtemp = dtemp + dx(i)*dy(i) + dx(i + 1)*dy(i + 1) +
     *   dx(i + 2)*dy(i + 2) + dx(i + 3)*dy(i + 3) + dx(i + 4)*dy(i + 4)
   50 continue
   60 ddot = dtemp
      return
      end
      subroutine  dswap (n,dx,incx,dy,incy)
c
c     interchanges two vectors.
c     uses unrolled loops for increments equal one.
c     jack dongarra, linpack, 3/11/78.
c     modified 12/3/93, array(1) declarations changed to array(*)
c
      double precision dx(*),dy(*),dtemp
      integer i,incx,incy,ix,iy,m,mp1,n
c
      if(n.le.0)return
      if(incx.eq.1.and.incy.eq.1)go to 20
c
c       code for unequal increments or equal increments not equal
c         to 1
c
      ix = 1
      iy = 1
      if(incx.lt.0)ix = (-n+1)*incx + 1
      if(incy.lt.0)iy = (-n+1)*incy + 1
      do 10 i = 1,n
        dtemp = dx(ix)
        dx(ix) = dy(iy)
        dy(iy) = dtemp
        ix = ix + incx
        iy = iy + incy
   10 continue
      return
c
c       code for both increments equal to 1
c
c
c       clean-up loop
c
   20 m = mod(n,3)
      if( m .eq. 0 ) go to 40
      do 30 i = 1,m
        dtemp = dx(i)
        dx(i) = dy(i)
        dy(i) = dtemp
   30 continue
      if( n .lt. 3 ) return
   40 mp1 = m + 1
      do 50 i = mp1,n,3
        dtemp = dx(i)
        dx(i) = dy(i)
        dy(i) = dtemp
        dtemp = dx(i + 1)
        dx(i + 1) = dy(i + 1)
        dy(i + 1) = dtemp
        dtemp = dx(i + 2)
        dx(i + 2) = dy(i + 2)
        dy(i + 2) = dtemp
   50 continue
      return
      end
      integer function idamax(n,dx,incx)
c
c     finds the index of element having max. absolute value.
c     jack dongarra, linpack, 3/11/78.
c     modified 3/93 to return if incx .le. 0.
c     modified 12/3/93, array(1) declarations changed to array(*)
c
      double precision dx(*),dmax
      integer i,incx,ix,n
c
      idamax = 0
      if( n.lt.1 .or. incx.le.0 ) return
      idamax = 1
      if(n.eq.1)return
      if(incx.eq.1)go to 20
c
c        code for increment not equal to 1
c
      ix = 1
      dmax = dabs(dx(1))
      ix = ix + incx
      do 10 i = 2,n
         if(dabs(dx(ix)).le.dmax) go to 5
         idamax = i
         dmax = dabs(dx(ix))
    5    ix = ix + incx
   10 continue
      return
c
c        code for increment equal to 1
c
   20 dmax = dabs(dx(1))
      do 30 i = 2,n
         if(dabs(dx(i)).le.dmax) go to 30
         idamax = i
         dmax = dabs(dx(i))
   30 continue
      return
      end
      SUBROUTINE DGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
*     .. Scalar Arguments ..
      DOUBLE PRECISION ALPHA,BETA
      INTEGER K,LDA,LDB,LDC,M,N
      CHARACTER TRANSA,TRANSB
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION A(LDA,*),B(LDB,*),C(LDC,*)
*     ..
*
*  Purpose
*  =======
*
*  DGEMM  performs one of the matrix-matrix operations
*
*     C := alpha*op( A )*op( B ) + beta*C,
*
*  where  op( X ) is one of
*
*     op( X ) = X   or   op( X ) = X',
*
*  alpha and beta are scalars, and A, B and C are matrices, with op( A )
*  an m by k matrix,  op( B )  a  k by n matrix and  C an m by n matrix.
*
*  Arguments
*  ==========
*
*  TRANSA - CHARACTER*1.
*           On entry, TRANSA specifies the form of op( A ) to be used in
*           the matrix multiplication as follows:
*
*              TRANSA = 'N' or 'n',  op( A ) = A.
*
*              TRANSA = 'T' or 't',  op( A ) = A'.
*
*              TRANSA = 'C' or 'c',  op( A ) = A'.
*
*           Unchanged on exit.
*
*  TRANSB - CHARACTER*1.
*           On entry, TRANSB specifies the form of op( B ) to be used in
*           the matrix multiplication as follows:
*
*              TRANSB = 'N' or 'n',  op( B ) = B.
*
*              TRANSB = 'T' or 't',  op( B ) = B'.
*
*              TRANSB = 'C' or 'c',  op( B ) = B'.
*
*           Unchanged on exit.
*
*  M      - INTEGER.
*           On entry,  M  specifies  the number  of rows  of the  matrix
*           op( A )  and of the  matrix  C.  M  must  be at least  zero.
*           Unchanged on exit.
*
*  N      - INTEGER.
*           On entry,  N  specifies the number  of columns of the matrix
*           op( B ) and the number of columns of the matrix C. N must be
*           at least zero.
*           Unchanged on exit.
*
*  K      - INTEGER.
*           On entry,  K  specifies  the number of columns of the matrix
*           op( A ) and the number of rows of the matrix op( B ). K must
*           be at least  zero.
*           Unchanged on exit.
*
*  ALPHA  - DOUBLE PRECISION.
*           On entry, ALPHA specifies the scalar alpha.
*           Unchanged on exit.
*
*  A      - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is
*           k  when  TRANSA = 'N' or 'n',  and is  m  otherwise.
*           Before entry with  TRANSA = 'N' or 'n',  the leading  m by k
*           part of the array  A  must contain the matrix  A,  otherwise
*           the leading  k by m  part of the array  A  must contain  the
*           matrix A.
*           Unchanged on exit.
*
*  LDA    - INTEGER.
*           On entry, LDA specifies the first dimension of A as declared
*           in the calling (sub) program. When  TRANSA = 'N' or 'n' then
*           LDA must be at least  max( 1, m ), otherwise  LDA must be at
*           least  max( 1, k ).
*           Unchanged on exit.
*
*  B      - DOUBLE PRECISION array of DIMENSION ( LDB, kb ), where kb is
*           n  when  TRANSB = 'N' or 'n',  and is  k  otherwise.
*           Before entry with  TRANSB = 'N' or 'n',  the leading  k by n
*           part of the array  B  must contain the matrix  B,  otherwise
*           the leading  n by k  part of the array  B  must contain  the
*           matrix B.
*           Unchanged on exit.
*
*  LDB    - INTEGER.
*           On entry, LDB specifies the first dimension of B as declared
*           in the calling (sub) program. When  TRANSB = 'N' or 'n' then
*           LDB must be at least  max( 1, k ), otherwise  LDB must be at
*           least  max( 1, n ).
*           Unchanged on exit.
*
*  BETA   - DOUBLE PRECISION.
*           On entry,  BETA  specifies the scalar  beta.  When  BETA  is
*           supplied as zero then C need not be set on input.
*           Unchanged on exit.
*
*  C      - DOUBLE PRECISION array of DIMENSION ( LDC, n ).
*           Before entry, the leading  m by n  part of the array  C must
*           contain the matrix  C,  except when  beta  is zero, in which
*           case C need not be set on entry.
*           On exit, the array  C  is overwritten by the  m by n  matrix
*           ( alpha*op( A )*op( B ) + beta*C ).
*
*  LDC    - INTEGER.
*           On entry, LDC specifies the first dimension of C as declared
*           in  the  calling  (sub)  program.   LDC  must  be  at  least
*           max( 1, m ).
*           Unchanged on exit.
*
*
*  Level 3 Blas routine.
*
*  -- Written on 8-February-1989.
*     Jack Dongarra, Argonne National Laboratory.
*     Iain Duff, AERE Harwell.
*     Jeremy Du Croz, Numerical Algorithms Group Ltd.
*     Sven Hammarling, Numerical Algorithms Group Ltd.
*
*
*     .. External Functions ..
      LOGICAL LSAME
      EXTERNAL LSAME
*     ..
*     .. External Subroutines ..
      EXTERNAL XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC MAX
*     ..
*     .. Local Scalars ..
      DOUBLE PRECISION TEMP
      INTEGER I,INFO,J,L,NCOLA,NROWA,NROWB
      LOGICAL NOTA,NOTB
*     ..
*     .. Parameters ..
      DOUBLE PRECISION ONE,ZERO
      PARAMETER (ONE=1.0D+0,ZERO=0.0D+0)
*     ..
*
*     Set  NOTA  and  NOTB  as  true if  A  and  B  respectively are not
*     transposed and set  NROWA, NCOLA and  NROWB  as the number of rows
*     and  columns of  A  and the  number of  rows  of  B  respectively.
*
      NOTA = LSAME(TRANSA,'N')
      NOTB = LSAME(TRANSB,'N')
      IF (NOTA) THEN
          NROWA = M
          NCOLA = K
      ELSE
          NROWA = K
          NCOLA = M
      END IF
      IF (NOTB) THEN
          NROWB = K
      ELSE
          NROWB = N
      END IF
*
*     Test the input parameters.
*
      INFO = 0
      IF ((.NOT.NOTA) .AND. (.NOT.LSAME(TRANSA,'C')) .AND.
     +    (.NOT.LSAME(TRANSA,'T'))) THEN
          INFO = 1
      ELSE IF ((.NOT.NOTB) .AND. (.NOT.LSAME(TRANSB,'C')) .AND.
     +         (.NOT.LSAME(TRANSB,'T'))) THEN
          INFO = 2
      ELSE IF (M.LT.0) THEN
          INFO = 3
      ELSE IF (N.LT.0) THEN
          INFO = 4
      ELSE IF (K.LT.0) THEN
          INFO = 5
      ELSE IF (LDA.LT.MAX(1,NROWA)) THEN
          INFO = 8
      ELSE IF (LDB.LT.MAX(1,NROWB)) THEN
          INFO = 10
      ELSE IF (LDC.LT.MAX(1,M)) THEN
          INFO = 13
      END IF
      IF (INFO.NE.0) THEN
          CALL XERBLA('DGEMM ',INFO)
          RETURN
      END IF
*
*     Quick return if possible.
*
      IF ((M.EQ.0) .OR. (N.EQ.0) .OR.
     +    (((ALPHA.EQ.ZERO).OR. (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN
*
*     And if  alpha.eq.zero.
*
      IF (ALPHA.EQ.ZERO) THEN
          IF (BETA.EQ.ZERO) THEN
              DO 20 J = 1,N
                  DO 10 I = 1,M
                      C(I,J) = ZERO
   10             CONTINUE
   20         CONTINUE
          ELSE
              DO 40 J = 1,N
                  DO 30 I = 1,M
                      C(I,J) = BETA*C(I,J)
   30             CONTINUE
   40         CONTINUE
          END IF
          RETURN
      END IF
*
*     Start the operations.
*
      IF (NOTB) THEN
          IF (NOTA) THEN
*
*           Form  C := alpha*A*B + beta*C.
*
              DO 90 J = 1,N
                  IF (BETA.EQ.ZERO) THEN
                      DO 50 I = 1,M
                          C(I,J) = ZERO
   50                 CONTINUE
                  ELSE IF (BETA.NE.ONE) THEN
                      DO 60 I = 1,M
                          C(I,J) = BETA*C(I,J)
   60                 CONTINUE
                  END IF
                  DO 80 L = 1,K
                      IF (B(L,J).NE.ZERO) THEN
                          TEMP = ALPHA*B(L,J)
                          DO 70 I = 1,M
                              C(I,J) = C(I,J) + TEMP*A(I,L)
   70                     CONTINUE
                      END IF
   80             CONTINUE
   90         CONTINUE
          ELSE
*
*           Form  C := alpha*A'*B + beta*C
*
              DO 120 J = 1,N
                  DO 110 I = 1,M
                      TEMP = ZERO
                      DO 100 L = 1,K
                          TEMP = TEMP + A(L,I)*B(L,J)
  100                 CONTINUE
                      IF (BETA.EQ.ZERO) THEN
                          C(I,J) = ALPHA*TEMP
                      ELSE
                          C(I,J) = ALPHA*TEMP + BETA*C(I,J)
                      END IF
  110             CONTINUE
  120         CONTINUE
          END IF
      ELSE
          IF (NOTA) THEN
*
*           Form  C := alpha*A*B' + beta*C
*
              DO 170 J = 1,N
                  IF (BETA.EQ.ZERO) THEN
                      DO 130 I = 1,M
                          C(I,J) = ZERO
  130                 CONTINUE
                  ELSE IF (BETA.NE.ONE) THEN
                      DO 140 I = 1,M
                          C(I,J) = BETA*C(I,J)
  140                 CONTINUE
                  END IF
                  DO 160 L = 1,K
                      IF (B(J,L).NE.ZERO) THEN
                          TEMP = ALPHA*B(J,L)
                          DO 150 I = 1,M
                              C(I,J) = C(I,J) + TEMP*A(I,L)
  150                     CONTINUE
                      END IF
  160             CONTINUE
  170         CONTINUE
          ELSE
*
*           Form  C := alpha*A'*B' + beta*C
*
              DO 200 J = 1,N
                  DO 190 I = 1,M
                      TEMP = ZERO
                      DO 180 L = 1,K
                          TEMP = TEMP + A(L,I)*B(J,L)
  180                 CONTINUE
                      IF (BETA.EQ.ZERO) THEN
                          C(I,J) = ALPHA*TEMP
                      ELSE
                          C(I,J) = ALPHA*TEMP + BETA*C(I,J)
                      END IF
  190             CONTINUE
  200         CONTINUE
          END IF
      END IF
*
      RETURN
*
*     End of DGEMM .
*
      END
      LOGICAL          FUNCTION LSAME( CA, CB )
****************************************************************************
*                                                                          *
*   DATA PARALLEL BLAS based on MPL                                        *
*                                                                          *
*   Version 1.0   1/9-92 ,                                                 *
*   For MasPar MP-1 computers                                              *
*                                                                          *
*   para//ab, University of Bergen, NORWAY                                 *
*                                                                          *
*   These programs must be called using F90 style array syntax.            *
*   Note that the F77 style calling sequence has been retained             *
*   in this version for compatibility reasons, be aware that               *
*   parameters related to the array dimensions and shape therefore may     *
*   be redundant and without any influence.                                *
*   The calling sequence may be changed in a future version.               *
*   Please report any BUGs, ideas for improvement or other                 *
*   comments to                                                            *
*                    adm@parallab.uib.no                                   *
*                                                                          *
*   Future versions may then reflect your suggestions.                     *
*   The most current version of this software is available                 *
*   from netlib@nac.no , send the message `send index from maspar'         *
*                                                                          *
*   REVISIONS:                                                             *
*                                                                          *
****************************************************************************
*
*  -- LAPACK auxiliary routine (preliminary version) --
*     Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab,
*     Courant Institute, NAG Ltd., and Rice University
*     March 26, 1990
*
*     .. Scalar Arguments ..
      CHARACTER          CA, CB
*     ..
*
*  Purpose
*  =======
*
*  LSAME returns .TRUE. if CA is the same letter as CB regardless of
*  case.
*
*  This version of the routine is only correct for ASCII code.
*  Installers must modify the routine for other character-codes.
*
*  For EBCDIC systems the constant IOFF must be changed to -64.
*  For CDC systems using 6-12 bit representations, the system-
*  specific code in comments must be activated.
*
*  Arguments
*  =========
*
*  CA      (input) CHARACTER*1
*  CB      (input) CHARACTER*1
*          CA and CB specify the single characters to be compared.
*
*
*     .. Parameters ..
      INTEGER            IOFF
      PARAMETER        ( IOFF = 32 )
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ICHAR
*     ..
*     .. Executable Statements ..
*
*     Test if the characters are equal
*
      LSAME = CA.EQ.CB
*
*     Now test for equivalence
*
      IF( .NOT.LSAME ) THEN
         LSAME = ICHAR( CA ) - IOFF.EQ.ICHAR( CB )
      END IF
      IF( .NOT.LSAME ) THEN
         LSAME = ICHAR( CA ).EQ.ICHAR( CB ) - IOFF
      END IF
*
      RETURN
*
*  The following comments contain code for CDC systems using 6-12 bit
*  representations.
*
*     .. Parameters ..
*     INTEGER            ICIRFX
*     PARAMETER        ( ICIRFX=62 )
*     .. Scalar arguments ..
*     CHARACTER*1        CB
*     .. Array arguments ..
*     CHARACTER*1        CA(*)
*     .. Local scalars ..
*     INTEGER            IVAL
*     .. Intrinsic functions ..
*     INTRINSIC          ICHAR, CHAR
*     .. Executable statements ..
*
*     See if the first character in string CA equals string CB.
*
*     LSAME = CA(1) .EQ. CB .AND. CA(1) .NE. CHAR(ICIRFX)
*
*     IF (LSAME) RETURN
*
*     The characters are not identical. Now check them for equivalence.
*     Look for the 'escape' character, circumflex, followed by the
*     letter.
*
*     IVAL = ICHAR(CA(2))
*     IF (IVAL.GE.ICHAR('A') .AND. IVAL.LE.ICHAR('Z')) THEN
*        LSAME = CA(1) .EQ. CHAR(ICIRFX) .AND. CA(2) .EQ. CB
*     END IF
*
*     RETURN
*
*     End of LSAME
*
      END
      SUBROUTINE XERBLA( SRNAME, INFO )
****************************************************************************
*                                                                          *
*   DATA PARALLEL BLAS based on MPL                                        *
*                                                                          *
*   Version 1.0   1/9-92 ,                                                 *
*   For MasPar MP-1 computers                                              *
*                                                                          *
*   para//ab, University of Bergen, NORWAY                                 *
*                                                                          *
*   These programs must be called using F90 style array syntax.            *
*   Note that the F77 style calling sequence has been retained             *
*   in this version for compatibility reasons, be aware that               *
*   parameters related to the array dimensions and shape therefore may     *
*   be redundant and without any influence.                                *
*   The calling sequence may be changed in a future version.               *
*   Please report any BUGs, ideas for improvement or other                 *
*   comments to                                                            *
*                    adm@parallab.uib.no                                   *
*                                                                          *
*   Future versions may then reflect your suggestions.                     *
*   The most current version of this software is available                 *
*   from netlib@nac.no , send the message `send index from maspar'         *
*                                                                          *
*   REVISIONS:                                                             *
*                                                                          *
****************************************************************************
*
*  -- LAPACK auxiliary routine (preliminary version) --
*     Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab,
*     Courant Institute, NAG Ltd., and Rice University
*     March 26, 1990
*
*     .. Scalar Arguments ..
      CHARACTER*6        SRNAME
      INTEGER            INFO
*     ..
*
*  Purpose
*  =======
*
*  XERBLA  is an error handler for the LAPACK routines.
*  It is called by an LAPACK routine if an input parameter has an
*  invalid value.  A message is printed and execution stops.
*
*  Installers may consider modifying the STOP statement in order to
*  call system-specific exception-handling facilities.
*
*  Arguments
*  =========
*
*  SRNAME  (input) CHARACTER*6
*          The name of the routine which called XERBLA.
*
*  INFO    (input) INTEGER
*          The position of the invalid parameter in the parameter list
*          of the calling routine.
*
*
      WRITE( *, FMT = 9999 )SRNAME, INFO
*
      STOP
*
 9999 FORMAT( ' ** On entry to ', A6, ' parameter number ', I2, ' had ',
     $      'an illegal value' )
*
*     End of XERBLA
*
      END


      SUBROUTINE LMRGNO(PARA,XMOM,NMOM)
C***********************************************************************
C*                                                                     *
C*  FORTRAN CODE WRITTEN FOR INCLUSION IN IBM RESEARCH REPORT RC20525, *
C*  'FORTRAN ROUTINES FOR USE WITH THE METHOD OF L-MOMENTS, VERSION 3' *
C*                                                                     *
C*  J. R. M. HOSKING                                                   *
C*  IBM RESEARCH DIVISION                                              *
C*  T. J. WATSON RESEARCH CENTER                                       *
C*  YORKTOWN HEIGHTS                                                   *
C*  NEW YORK 10598, U.S.A.                                             *
C*                                                                     *
C*  VERSION 3     AUGUST 1996                                          *
C*                                                                     *
C***********************************************************************
C
C  L-MOMENT RATIOS FOR THE GENERALIZED NORMAL DISTRIBUTION
C
C  PARAMETERS OF ROUTINE:
C  PARA   * INPUT* ARRAY OF LENGTH 3. CONTAINS THE PARAMETERS OF THE
C                  DISTRIBUTION, IN THE ORDER XI, ALPHA, K (LOCATION,
C                  SCALE, SHAPE).
C  XMOM   *OUTPUT* ARRAY OF LENGTH NMOM. ON EXIT, CONTAINS THE L-MOMENTS
C                  LAMBDA-1, LAMBDA-2, TAU-3, TAU-4, ... .
C  NMOM   * INPUT* NUMBER OF L-MOMENTS TO BE FOUND. AT MOST 20.
C
C  OTHER ROUTINES USED: DERF
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DOUBLE PRECISION PARA(3),XMOM(NMOM),EST(20),ESTX(20),SUM(20),
     *  ZMOM(20)
      DATA ZERO/0D0/,HALF/0.5D0/,ONE/1D0/
C
C         ARRAY ZMOM CONTAINS L-MOMENTS OF THE STANDARD NORMAL DIST.
C
      DATA ZMOM/
     *  0D0,   0.56418 95835 47756 287D 0,
     *  0D0,   0.12260 17195 40890 947D 0,
     *  0D0,   0.43661 15389 50024 944D-1,
     *  0D0,   0.21843 13603 32508 776D-1,
     *  0D0,   0.12963 50158 01507 746D-1,
     *  0D0,   0.85296 21241 91705 402D-2,
     *  0D0,   0.60138 90151 79323 333D-2,
     *  0D0,   0.44555 82586 47650 150D-2,
     *  0D0,   0.34264 32435 78076 985D-2,
     *  0D0,   0.27126 79630 48139 365D-2/
C
C         RRT2 IS 1/SQRT(2), RRTPI IS 1/SQRT(PI)
C
      DATA RRT2 /0.70710 67811 86547 524D0/
      DATA RRTPI/0.56418 95835 47756 287D0/
C
C         RANGE,EPS,MAXIT CONTROL THE ITERATIVE PROCEDURE FOR NUMERICAL
C         INTEGRATION
C
      DATA RANGE/5D0/,EPS/1D-8/,MAXIT/10/
C
      U=PARA(1)
      A=PARA(2)
      G=PARA(3)
      IF(A.LE.ZERO)GOTO 1000
      IF(NMOM.GT.20)GOTO 1010
C
C         TEST FOR K=0
C
      IF(DABS(G).GT.EPS)GOTO 5
      XMOM(1)=U
      IF(NMOM.EQ.1)RETURN
      XMOM(2)=A*ZMOM(2)
      IF(NMOM.EQ.2)RETURN
      DO 2 I=3,NMOM
    2 XMOM(I)=ZMOM(I)
      RETURN
    5 CONTINUE
C
C         LAMBDA-1
C
      EGG=DEXP(HALF*G*G)
      ALAM1=(ONE-EGG)/G
      XMOM(1)=U+A*ALAM1
      IF(NMOM.EQ.1)RETURN
C
C         LAMBDA-2
C
      ALAM2=EGG*DERF(HALF*G)/G
      XMOM(2)=A*ALAM2
      IF(NMOM.EQ.2)RETURN
C
C         HIGHER MOMENTS. THE INTEGRAL DEFINING LAMBDA-R IS EVALUATED
C         BY ITERATIVE APPLICATION OF THE TRAPEZIUM RULE.
C
C         - INITIAL ESTIMATE, USING 16 ORDINATES  (THE 'DO 20' LOOP
C           CALCULATES LEGENDRE POLYNOMIALS RECURSIVELY)
C
      CC=-G*RRT2
      XMIN=CC-RANGE
      XMAX=CC+RANGE
      DO 10 M=3,NMOM
   10 SUM(M)=ZERO
      N=16
      XINC=(XMAX-XMIN)/N
      DO 30 I=1,N-1
      X=XMIN+I*XINC
      E=DEXP(-((X-CC)**2))
      D=DERF(X)
      P1=ONE
      P=D
      DO 20 M=3,NMOM
      C1=M+M-3
      C2=M-2
      C3=M-1
      P2=P1
      P1=P
      P=(C1*D*P1-C2*P2)/C3
   20 SUM(M)=SUM(M)+E*P
   30 CONTINUE
      DO 40 M=3,NMOM
   40 EST(M)=SUM(M)*XINC
C
C         - DOUBLE THE NUMBER OF ORDINATES UNTIL CONVERGED
C
      DO 90 IT=1,MAXIT
      DO 50 M=3,NMOM
   50 ESTX(M)=EST(M)
      N=N*2
      XINC=(XMAX-XMIN)/N
      DO 70 I=1,N-1,2
      X=XMIN+I*XINC
      E=DEXP(-((X-CC)**2))
      D=DERF(X)
      P1=ONE
      P=D
      DO 60 M=3,NMOM
      C1=M+M-3
      C2=M-2
      C3=M-1
      P2=P1
      P1=P
      P=(C1*D*P1-C2*P2)/C3
   60 SUM(M)=SUM(M)+E*P
   70 CONTINUE
C
C         --- TEST FOR CONVERGENCE
C
      NOTCGD=0
      DO 80 M=NMOM,3,-1
      EST(M)=SUM(M)*XINC
      IF(DABS(EST(M)-ESTX(M)).GT.EPS*DABS(EST(M)))NOTCGD=M
   80 CONTINUE
      IF(NOTCGD.EQ.0)GOTO 100
   90 CONTINUE
C
      WRITE(6,7020)NOTCGD-1
  100 CONTINUE
      CONST=-DEXP(CC*CC)*RRTPI/(ALAM2*G)
      DO 110 M=3,NMOM
  110 XMOM(M)=CONST*EST(M)
      RETURN
C
 1000 WRITE(6,7000)
      RETURN
 1010 WRITE(6,7010)
      RETURN
C
 7000 FORMAT(' *** ERROR *** ROUTINE LMRGNO : PARAMETERS INVALID')
 7010 FORMAT(' *** ERROR *** ROUTINE LMRGNO : PARAMETER NMOM TOO LARGE')
 7020 FORMAT(' ** WARNING ** ROUTINE LMRGNO :',
     *  ' ITERATION HAS NOT CONVERGED. ONLY THE FIRST',I3,
     *  ' L-MOMENTS ARE RELIABLE.')
      END


!##############################################################################
!# ****************************************************************************
!# <name> optcanalysis </name>
!# ****************************************************************************
!#
!# <purpose>
!# This module contains routines to perform error analysis for the solution
!# of the optimal control problem. Here, routines can be found that calculate
!# the functional, which is to be minimised by the theory:
!#
!# $$ min J(y,u) = 1/2||y-z||_{L^2} + \gamma/2||y(T)-z(T)||_{L^2} + \alpha/2||u||^2 $$
!#
!# The following routines can be found here:
!#
!# 1.) cc_optc_stationaryFunctional
!#     -> Calculates the value of the stationary functional which is to be
!#        minimised:
!#     $$ J(y,u) = 1/2||y-z||_{L^2} + \alpha/2||u||^2 $$
!#
!# 1.) cc_optc_nonstatFunctional
!#     -> Calculates the value of the stationary functional which is to be
!#        minimised:
!#     $$ J(y,u) = 1/2||y-z||^2_{L^2} + \alpha/2||u||^2_{L^2} + gamma/2||y(T)-z(T)||^2_{L^2}$$
!#
!# </purpose>
!##############################################################################

module optcanalysis

  use fsystem
  use linearsystemblock
  use pprocerror
  use spacetimevectors
  use user_callback
  use spacematvecassembly

  implicit none

contains

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

!<subroutine>

  subroutine cc_optc_stationaryFunctional (rsolution,dalpha,Derror,rcollection)

!<description>
  ! This function calculates the value of the functional which is to be
  ! minimised in the stationary optimal control problem.
  ! The functional is defined as
  !   $$ J(y,u) = 1/2||y-z||_{L^2}^2  + \alpha/2||u||^2 $$
  ! over a spatial domain $\Omega$.
  !
  ! For this purpose, the routine evaluates the user-defined callback functions
  ! ffunction_TargetX and ffunction_TargetY. The collection must be initialised
  ! for postprocessing before calling his routine!
!</description>

!<input>
  ! Solution vector to compute the norm/error from.
  type(t_vectorBlock), intent(IN) :: rsolution

  ! Regularisation parameter $\alpha$.
  real(DP), intent(IN) :: dalpha

  ! Collection structure of the main application. Is passed to the callback routines.
  type(t_collection), intent(INOUT) :: rcollection
!</input>

!<output>
  ! Returns information about the error.
  ! Derror(1) = ||y-z||_{L^2}.
  ! Derror(2) = ||u||.
  ! Derror(3) = J(y,u) = 1/2||y-z||_{L^2}^2  + \alpha/2||u||^2.
  ! Norm of the error functional.
  real(DP), dimension(:), intent(OUT) :: Derror
!</output>

!</subroutine>

    ! local variables
    real(DP),dimension(2) :: Derr

    ! Perform error analysis to calculate and add 1/2||y-z||_{L^2}.
    call pperr_scalar (rsolution%RvectorBlock(1),PPERR_L2ERROR,Derr(1),&
                       ffunction_TargetX,rcollection)

    call pperr_scalar (rsolution%RvectorBlock(2),PPERR_L2ERROR,Derr(2),&
                       ffunction_TargetY,rcollection)

    Derror(1) = (0.5_DP*(Derr(1)**2+Derr(2)**2))
    Derror(2) = 0.0_DP

    ! Calculate \alpha/2||u||^2.
    if (dalpha .ne. 0.0_DP) then
      call pperr_scalar (rsolution%RvectorBlock(4),PPERR_L2ERROR,Derr(1))

      call pperr_scalar (rsolution%RvectorBlock(5),PPERR_L2ERROR,Derr(2))

      Derror(2) = (0.5_DP*(Derr(1)**2+Derr(2)**2))

      ! Because of u=-lambda/alpha we have:
      !    alpha/2 ||u||^2 = alpha/2 ||lambda/alpha||^2 = 1/(2*alpha) ||lambda||^2
    end if

    Derror(3) = 0.5_DP * Derror(1)+(0.5_DP/dalpha) * Derror(2)
    Derror(1) = sqrt(Derror(1))
    Derror(2) = sqrt(Derror(2))

  end subroutine

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

!<subroutine>

  subroutine cc_optc_nonstatFunctional (rproblem,rsolution,rtempVector,&
      dalpha,dgamma,Derror)

!<description>
  ! This function calculates the value of the functional which is to be
  ! minimised in the stationary optimal control problem.
  ! The functional is defined as
  !   $$ J(y,u) = 1/2||y-z||^2_{L^2} + \alpha/2||u||^2_{L^2} + gamma/2||y(T)-z(T)||^2_{L^2}$$
  ! over a spatial domain $\Omega$.
  !
  ! For this purpose, the routine evaluates the user-defined callback functions
  ! ffunction_TargetX and ffunction_TargetY. The collection must be initialised
  ! for postprocessing before calling his routine!
  !
  ! The function z is given implicitely in the problem structure rproblem
  ! and evaluated in ffunction_TargetX and ffunction_TargetY!
!</description>

!<input>
  ! Solution vector to compute the norm/error from.
  type(t_spacetimeVector), intent(IN) :: rsolution

  ! Regularisation parameter $\alpha$.
  real(DP), intent(IN) :: dalpha

  ! Regularisation parameter $\gamma$.
  real(DP), intent(IN) :: dgamma
!</input>

!<inputoutput>
  ! Problem structure defining z and the time discretisation.
  type(t_problem), intent(INOUT) :: rproblem

  ! A block temp vector with size and structure of the subvectors in rsolution.
  type(t_vectorBlock), intent(INOUT) :: rtempVector
!</inputoutput>

!<output>
  ! Returns information about the error.
  ! Derror(1) = ||y-z||_{L^2}.
  ! Derror(2) = ||u||_{L^2}.
  ! Derror(3) = ||y(T)-z(T)||_{L^2}.
  ! Derror(4) = J(y,u).
  real(DP), dimension(:), intent(OUT) :: Derror
!</output>

!</subroutine>

    ! local variables
    integer :: isubstep
    real(DP) :: dtstep,dtime
    real(DP),dimension(2) :: Derr
    real(dp), dimension(:), pointer :: p_Dx

    Derror(1:4) = 0.0_DP
    dtstep = rsolution%p_rtimeDiscretisation%dtstep

    call lsysbl_getbase_double (rtempVector,p_Dx)

    do isubstep = 0,rsolution%NEQtime-1
      ! Current point in time
      dtime = rproblem%rtimedependence%dtimeInit + isubstep*dtstep

      ! Get the solution.
      ! Evaluate the space time function in rvector in the point
      ! in time dtime. Independent of the discretisation in time,
      ! this will give us a vector in space.
      !CALL sptivec_getTimestepData (rsolution, 1+isubstep, rtempVector)
      call tmevl_evaluate(rsolution,dtime,rtempVector)

      ! Initialise the collection for the assembly process with callback routines.
      ! This stores the simulation time in the collection and sets the
      ! current subvector z for the callback routines.
      call cc_initCollectForAssembly (rproblem,dtime,rproblem%rcollection)

      ! Compute:
      ! Derror(1) = ||y-z||^2_{L^2}.

      ! Perform error analysis to calculate and add 1/2||y-z||^2_{L^2}.
      call pperr_scalar (rtempVector%RvectorBlock(1),PPERR_L2ERROR,Derr(1),&
                        ffunction_TargetX,rproblem%rcollection)

      call pperr_scalar (rtempVector%RvectorBlock(2),PPERR_L2ERROR,Derr(2),&
                        ffunction_TargetY,rproblem%rcollection)

      ! We use the summed trapezoidal rule.
      if ((isubstep .eq. 0) .or. (isubstep .eq. rsolution%NEQtime-1)) then
        Derror(1) = Derror(1) + 0.5_DP*0.5_DP*(Derr(1)**2 + Derr(2)**2) * dtstep
      else
        Derror(1) = Derror(1) + 0.5_DP*(Derr(1)**2 + Derr(2)**2) * dtstep
      end if

      ! Compute:
      ! Derror(3) = ||y(T)-z(T)||^2
      if (isubstep .eq. rsolution%NEQtime-1) then
        Derror(3) = 0.5_DP*(Derr(1)**2+Derr(2)**2)
      end if

      ! Compute:
      ! Derror(2) = ||u|| = ||P[min/max](-1/alpha lambda)||^2_{L^2}.
      ! For that purpose, scale the lambda part and project it if necessary.
      call lsyssc_scaleVector (rtempVector%RvectorBlock(4),-1.0_DP/dalpha)
      call lsyssc_scaleVector (rtempVector%RvectorBlock(5),-1.0_DP/dalpha)

      if (rproblem%roptControl%ccontrolConstraints .ne. 0.0_DP) then
        call cc_projectControlTimestep (rtempVector%RvectorBlock(4),&
            rproblem%roptControl%dumin1,rproblem%roptControl%dumax1)
        call cc_projectControlTimestep (rtempVector%RvectorBlock(5),&
            rproblem%roptControl%dumin2,rproblem%roptControl%dumax2)
      end if

      call pperr_scalar (rtempVector%RvectorBlock(4),PPERR_L2ERROR,Derr(1))
      call pperr_scalar (rtempVector%RvectorBlock(5),PPERR_L2ERROR,Derr(2))

      ! We use the summed trapezoidal rule.
      if ((isubstep .eq. 0) .or. (isubstep .eq. rsolution%NEQtime-1)) then
        Derror(2) = Derror(2) + 0.05_DP*0.5_DP*(Derr(1)**2+Derr(2)**2) * dtstep
      else
        Derror(2) = Derror(2) + 0.5_DP*(Derr(1)**2+Derr(2)**2) * dtstep
      end if

      call cc_doneCollectForAssembly (rproblem,rproblem%rcollection)

    end do

    ! Normalise...
    ! Derror(1) = Derror(1) / REAL(rsolution%NEQtime,DP)
    ! Derror(2) = Derror(2) / REAL(rsolution%NEQtime,DP)

    ! Calculate J(.)
    Derror(4) = 0.5_DP * Derror(1)  +  0.5_DP * dgamma * Derror(3)

    if (dalpha .ne. 0.0_DP) then
      ! Calculate:
      !    alpha/2 ||u||^2
      Derror(4) = Derror(4) + 0.5_DP*dalpha * Derror(2)

      ! Calculate ||u|| = 1/alpha ||lambda||
      Derror(2) = 1.0_DP/dalpha * sqrt(Derror(2))
    else
      Derror(2) = 0.0_DP
    end if

    ! And the rest
    Derror(3) = sqrt(Derror(3))
    Derror(1) = sqrt(Derror(1))

  end subroutine

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

!<subroutine>

  subroutine ffunction_analyticalRef (cderivative,rdiscretisation, &
                nelements,npointsPerElement,Dpoints, &
                IdofsTest,rdomainIntSubset,&
                Dvalues,rcollection)

  use basicgeometry
  use triangulation
  use collection
  use scalarpde
  use domainintegration

!<description>
  ! Analytical reference solution given by an expression.
!</description>

!<input>
  ! This is a DER_xxxx derivative identifier (from derivative.f90) that
  ! specifies what to compute: DER_FUNC=function value, DER_DERIV_X=x-derivative,...
  ! The result must be written to the Dvalue-array below.
  integer, intent(IN)                                         :: cderivative

  ! The discretisation structure that defines the basic shape of the
  ! triangulation with references to the underlying triangulation,
  ! analytic boundary boundary description etc.
  type(t_spatialDiscretisation), intent(IN)                   :: rdiscretisation

  ! Number of elements, where the coefficients must be computed.
  integer, intent(IN)                                         :: nelements

  ! Number of points per element, where the coefficients must be computed
  integer, intent(IN)                                         :: npointsPerElement

  ! This is an array of all points on all the elements where coefficients
  ! are needed.
  ! DIMENSION(NDIM2D,npointsPerElement,nelements)
  ! Remark: This usually coincides with rdomainSubset%p_DcubPtsReal.
  real(DP), dimension(:,:,:), intent(IN)  :: Dpoints

  ! An array accepting the DOF's on all elements trial in the trial space.
  ! DIMENSION(\#local DOF's in trial space,Number of elements)
  integer, dimension(:,:), intent(IN) :: IdofsTest

  ! This is a t_domainIntSubset structure specifying more detailed information
  ! about the element set that is currently being integrated.
  ! It's usually used in more complex situations (e.g. nonlinear matrices).
  type(t_domainIntSubset), intent(IN)              :: rdomainIntSubset

  ! Optional: A collection structure to provide additional
  ! information to the coefficient routine.
  type(t_collection), intent(INOUT), optional      :: rcollection

!</input>

!<output>
  ! This array has to receive the values of the (analytical) function
  ! in all the points specified in Dpoints, or the appropriate derivative
  ! of the function, respectively, according to cderivative.
  !   DIMENSION(npointsPerElement,nelements)
  real(DP), dimension(:,:), intent(OUT)                      :: Dvalues
!</output>

!</subroutine>

    real(DP) :: dtime
    integer :: i,j,icomponent

    real(DP), dimension(:), allocatable :: DvaluesAct

    type(t_fparser), pointer :: p_rparser
    real(dp), dimension(:,:), allocatable :: p_Dval

    ! Get the parser object with the RHS expressions from the collection
    p_rparser => collct_getvalue_pars (rcollection, 'SOLPARSER')

    ! Current time
    dtime = rcollection%DquickAccess(1)

    ! X/Y component
    icomponent = rcollection%IquickAccess(1)

    ! Prepare the array with the values for the function.
    ! X-coordinate, Y-coordinate, time.
    allocate(p_Dval(3,npointsPerElement*nelements))
    do i=1,nelements
      do j=1,npointsPerElement
        p_Dval (1,(i-1)*npointsPerElement+j) = Dpoints(1,j,i)
        p_Dval (2,(i-1)*npointsPerElement+j) = Dpoints(2,j,i)
        p_Dval (3,(i-1)*npointsPerElement+j) = dtime
      end do
    end do

    ! Evaluate the 1st expression for the X-rhs
    allocate(DvaluesAct(npointsPerElement*nelements))
    call fparser_evalFunction (p_rparser, icomponent, 2, p_Dval, DvaluesAct)

    ! Reshape the data, that's it.
    do i=0,nelements-1
      do j=1,npointsPerElement
        Dvalues(j,i+1) = DvaluesAct(i*npointsPerElement+j)
      end do
    end do

    deallocate(DvaluesAct)
    deallocate(p_Dval)

  end subroutine

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

!<subroutine>

  subroutine cc_optc_analyticalError (rproblem,rsolution,rtempVector,&
      dalpha,dgamma,&
      ssolutionExpressionY1,ssolutionExpressionY2,ssolutionExpressionP,&
      ssolutionExpressionLAMBDA1,ssolutionExpressionLAMBDA2,ssolutionExpressionXI,&
      derrorU,derrorP,derrorLambda,derrorXi)

!<description>
  ! Computes the L2-error $||y-y0||_2$ of the given solution y to a reference
  ! solution y0 given as expression.
!</description>

!<input>
  ! Solution vector to compute the norm/error from.
  type(t_spacetimeVector), intent(IN) :: rsolution

  ! Regularisation parameter $\alpha$.
  real(DP), intent(IN) :: dalpha

  ! Regularisation parameter $\gamma$.
  real(DP), intent(IN) :: dgamma

  ! Expression specifying the analytical solution y0 / p0, primal/dual.
  character(LEN=SYS_STRLEN) :: ssolutionExpressionY1,ssolutionExpressionY2,ssolutionExpressionP
  character(LEN=SYS_STRLEN) :: ssolutionExpressionLAMBDA1,ssolutionExpressionLAMBDA2
  character(LEN=SYS_STRLEN) :: ssolutionExpressionXI
!</input>

!<inputoutput>
  ! Problem structure defining z and the time discretisation.
  type(t_problem), intent(INOUT) :: rproblem

  ! A block temp vector with size and structure of the subvectors in rsolution.
  type(t_vectorBlock), intent(INOUT) :: rtempVector
!</inputoutput>

!<output>
  ! Returns information about the error. ||y-y0||_{L^2}.
  real(DP), intent(OUT) :: derrorU

  ! Returns information about the error in the pressure. ||p-p0||_{L^2}.
  real(DP), intent(OUT) :: derrorP

  ! Returns information about the error. ||lambda-lambda0||_{L^2}.
  real(DP), intent(OUT) :: derrorLambda

  ! Returns information about the error in the pressure. ||xi-xi0||_{L^2}.
  real(DP), intent(OUT) :: derrorXi
!</output>

!</subroutine>

    ! local variables
    integer :: isubstep,i
    real(DP) :: dtstep,dtime
    real(DP),dimension(6) :: Derr
    character(LEN=10), dimension(3), parameter :: EXPR_VARIABLES = &
      (/'X    ','Y    ','TIME '/)
    type(t_collection) :: rcollection
    type(t_fparser) :: rsolParser
    real(dp), dimension(:), pointer :: p_Ddata

    call lsysbl_getbase_double (rtempVector,p_Ddata)

    derrorU = 0.0_DP
    derrorP = 0.0_DP
    derrorLambda = 0.0_DP
    derrorXi = 0.0_DP
    dtstep = rsolution%p_rtimeDiscretisation%dtstep

    ! Create a parser and to evaluate the expression.
    call fparser_create (rsolParser,6)

    ! Compile the two expressions+
    if (ssolutionExpressionY1 .ne. "") then
      call fparser_parseFunction (rsolParser,1, ssolutionExpressionY1, EXPR_VARIABLES)
    else
      call fparser_parseFunction (rsolParser,1, "0", EXPR_VARIABLES)
    end if
    if (ssolutionExpressionY2 .ne. "") then
      call fparser_parseFunction (rsolParser,2, ssolutionExpressionY2, EXPR_VARIABLES)
    else
      call fparser_parseFunction (rsolParser,2, "0", EXPR_VARIABLES)
    end if
    if (ssolutionExpressionP .ne. "") then
      call fparser_parseFunction (rsolParser,3, ssolutionExpressionP, EXPR_VARIABLES)
    else
      call fparser_parseFunction (rsolParser,3, "0", EXPR_VARIABLES)
    end if

    if (ssolutionExpressionLAMBDA1 .ne. "") then
      call fparser_parseFunction (rsolParser,4, ssolutionExpressionLAMBDA1, EXPR_VARIABLES)
    else
      call fparser_parseFunction (rsolParser,4, "0", EXPR_VARIABLES)
    end if
    if (ssolutionExpressionLAMBDA2 .ne. "") then
      call fparser_parseFunction (rsolParser,5, ssolutionExpressionLAMBDA2, EXPR_VARIABLES)
    else
      call fparser_parseFunction (rsolParser,5, "0", EXPR_VARIABLES)
    end if
    if (ssolutionExpressionXi .ne. "") then
      call fparser_parseFunction (rsolParser,6, ssolutionExpressionXi, EXPR_VARIABLES)
    else
      call fparser_parseFunction (rsolParser,6, "0", EXPR_VARIABLES)
    end if

    ! Put the parser to the problem collection to be usable in a callback
    ! routine.
    call collct_init(rcollection)
    call collct_setvalue_pars (rcollection, 'SOLPARSER', &
        rsolParser, .true.)

    do isubstep = 0,rsolution%NEQtime-1
      ! Current point in time
      dtime = rproblem%rtimedependence%dtimeInit + isubstep*dtstep

      rcollection%DquickAccess(1) = dtime

      ! Get the solution.
      ! Evaluate the space time function in rvector in the point
      ! in time dtime. Independent of the discretisation in time,
      ! this will give us a vector in space.
      !CALL sptivec_getTimestepData (rsolution, 1+isubstep, rtempVector)
      call tmevl_evaluate(rsolution,dtime,rtempVector)

      ! Compute:
      ! Derror(1) = ||y-z||^2_{L^2}.

      ! Perform error analysis to calculate and add 1/2||y-z||^2_{L^2},...
      do i=1,6
        rcollection%IquickAccess(1) = i
        call pperr_scalar (rtempVector%RvectorBlock(i),PPERR_L2ERROR,Derr(i),&
                          ffunction_analyticalRef,rcollection)
      end do

      ! We use the summed trapezoidal rule.
      if ((isubstep .eq. 0) .or. (isubstep .eq. rsolution%NEQtime-1)) then
        derrorU = derrorU + 0.5_DP*0.5_DP*(Derr(1)**2 + Derr(2)**2) * dtstep
        derrorP = derrorP + 0.5_DP*Derr(3)**2 * dtstep

        derrorLambda = derrorLambda + 0.5_DP*0.5_DP*(Derr(4)**2 + Derr(5)**2) * dtstep
        derrorXi = derrorXi + 0.5_DP*Derr(6)**2 * dtstep
      else
        derrorU = derrorU + 0.5_DP*(Derr(1)**2 + Derr(2)**2) * dtstep
        derrorP = derrorP + Derr(3)**2 * dtstep

        derrorLambda = derrorLambda + 0.5_DP*(Derr(4)**2 + Derr(5)**2) * dtstep
        derrorXi = derrorXi + Derr(6)**2 * dtstep
      end if
      call output_line("error("//trim(sys_siL(isubstep+1,10))//") = "// &
        trim(sys_sdEL(Derr(1),10))//" / "//&
        trim(sys_sdEL(Derr(2),10))//" / "// &
        trim(sys_sdEL(Derr(3),10))//" / "// &
        trim(sys_sdEL(Derr(4),10))//" / "//&
        trim(sys_sdEL(Derr(5),10))//" / "// &
        trim(sys_sdEL(Derr(6),10)))

    end do

    derrorU = sqrt(derrorU)
    derrorP = sqrt(derrorP)
    derrorLambda = sqrt(derrorLambda)
    derrorXi = sqrt(derrorXi)

    ! Clean up
    call collct_deletevalue (rcollection, 'SOLPARSER')
    call collct_done(rcollection)

    ! Release the parser
    call fparser_release(rsolParser)

  end subroutine

end module


subroutine condinit

 ! ------------------------------------ !
 !           Initial Condition          !
 !    [ Kelvi-Helmholtz instability ]   !
 ! ------------------------------------ !

 !**************************************************!
 !  MPI PARALLEL VERSION: VALENTINI-FAGANELLO 2009  !
 !   3D PARALLEL VERSION: FAGANELLO 2010            !
 !**************************************************!

 !**************************************************!
 !  FLR corrected MHD equilibria:   CERRI 2011      !
 !                                                  !
 !  for details see:                                !
 !                                                  !
 !  Cerri et al., Phys. Plasmas 20, 112112 (2013)   !
 !                                                  !
 !**************************************************!

use parameter_mod
use dom_distr_mod
use box_mod
use fields_UJ_mod
use fields_DP_mod
use fields_EB_mod
use parallel_mod

IMPLICIT NONE

integer :: ix, iy, iz, ir, iky, ikz

REAL(dp) :: ky, kz, zkk, pph, xx, ab, zz
REAL(dp) :: n0, B0
REAL(dp) :: T0i_para, T0i_perp, T0e_para, T0e_perp
REAL(dp) :: gam_i_perp, gam_i_para, gam_e_perp, gam_e_para
REAL(dp) :: gaminv_i_perp, gam_tilde
REAL(dp) :: beta_i_perp, beta_e_perp
REAL(dp) :: beta_i_perp_tilde, beta_e_perp_tilde
REAL(dp) :: C_0, C_1, C_inf
REAL(dp) :: Den_inf, Dinv_inf!, DeltaDen
REAL(dp) :: pi_para_inf, pi_perp_inf, pe_para_inf, pe_perp_inf, anis_i_0, anis_e_0
REAL(dp) :: Ti_para_inf, Ti_perp_inf, Te_para_inf, Te_perp_inf

REAL(dp),ALLOCATABLE :: equil(:)
REAL(dp),ALLOCATABLE :: f_0(:), fnct(:), equilDen(:), equilB(:)
REAL(dp),ALLOCATABLE :: gx1(:,:,:)
REAL(dp),ALLOCATABLE :: gy1(:), phs(:)
REAL(dp),ALLOCATABLE :: zx(:)
REAL(dp),ALLOCATABLE :: g0(:,:,:), gt(:,:,:)

 CHARACTER*13  filen_DT
 CHARACTER*1 F_1
 CHARACTER*2 F_2
 CHARACTER*3 F_3
 CHARACTER*4 F_4

allocate(equil(nxl))
allocate(f_0(nxl))
allocate(fnct(nxl))
allocate(equilB(nxl))
allocate(equilDen(nxl))
allocate(g0(nxl,ny,nz))
allocate(gx1(nxl,ny,nz))
allocate(gy1(ny))
allocate(phs(ny))
allocate(gt(nx,nyt,nz))
allocate(zx(nx))

SELECT CASE (istart)

 CASE (0)   !*** istart=0 ==> first RUN ***!

  !**********************************************!
  !  MHD one-fluid velocity: shear flow along x  !
  !                                              !
  !  Uy(x) = Aeq * tanh[ (x - Lx/2) / Leq ]      !
  !                                              !
  !  (Leq in d_i units, Aeq in v_A units)        !
  !**********************************************!

   Ux = 0.
   Uz = 0.

   equil = Aeq * dtanh((x(ixlg:ixlg+nxl-1) - xl*0.5d0 ) / Leq)

   if (mpime==0) then
   write(6,*) ' ----------------------------- '
   write(6,*) ' U_0, L_U  = ', Aeq, Leq
   write(6,*) ' ----------------------------- '
   endif

   do iz=1, nz
    do iy=1, ny  !  nyl == ny
     Uy(:,iy,iz) = equil(:)
    enddo
   enddo

  !------------------------------------------------------------!
  ! 2D incompressible perturbations on U: dU = e_z x grad(phi) !
  !------------------------------------------------------------!

   ir = 1

   call random_seed(ir)

   call random_number(phs)

  ! Sum up modes on phi (2D --> no kz)

   g0 = 0.

   do iky = 1, MIN(Ny/8,16)
     ky  = float(iky)
     zkk = 1.0 / ky
     pph = (phs(ir) - 0.5) * 2.0 * pgreco
     ir = ir + 1
     do iz = 1, nz
       do iy = 1, ny
         do ix = 1, nxl
           xx = x(ixlg+ix-1) - xl/2.0
           ab = abs(xx)/Leq
           IF (ab .GE. 9.0)  then
             g0(ix,iy,iz)= 0.0
           ELSE
             g0(ix,iy,iz) = g0(ix,iy,iz) + cos(ky * y(iy) * hyl + pph) * zkk *&
             exp(-1.0 * xx ** 2.0 / Leq ** 2.0)
           ENDIF
         enddo
       enddo
     enddo
   enddo

  ! compute: dU = ez x grad(phi)
  ! (multiplied by ampl, so that max(|dU|) ~ ampl)

   CALL traspdist( g0, gt, 1 )

   do iz = 1, nz
     do iy = 1, nyt
       call  derx_1( gt(:,iy,iz), zx )
       gt(:,iy,iz) = zx
     enddo
   enddo

   CALL traspdist( gx1, gt, -1 )

   Uy = Uy + ampl * gx1

   do iz = 1, nz
     do ix = 1, nxl
       call  dery_1( g0(ix,:,iz), gy1 )
       Ux(ix,:,iz) = - ampl * gy1
     enddo
   enddo

   Uz = 0.0

deallocate(g0)
deallocate(gx1)
deallocate(gy1)
deallocate(equil)
deallocate(phs)
deallocate(gt)
deallocate(zx)

  !**************************************************!
  ! Compute FLR-corrected MHD equilibrium            !
  ! ------------------------------------------------ !
  !  for details see:                                !
  !                                                  !
  !  Cerri et al., Phys. Plasmas 20, 112112 (2013)   !
  !                                                  !
  !**************************************************!

   !-- politropic index of the equilibrium
   !   (default: isothermal initial condition)

   gam_i_perp = 1.0d0
   gam_i_para = 1.0d0

   gam_e_perp = 1.0d0
   gam_e_para = 1.0d0

   gaminv_i_perp = 1.0d0 / gam_i_perp

   !-- equilibrium quantities "at infinity"

   !density
   Den_inf = 1.0d0
   Dinv_inf = 1.0d0 / Den_inf
   !ion pressures and temperatures
   anis_i_0 = 0.0d0     ! ion anisotropy at infinity (A = Pperp/Ppara - 1)
   pi_para_inf = 0.5d0  ! (note: beta_inf = 0.5*p_inf/B0 => 0.5d0 -> beta = 1)
   pi_perp_inf = (1.0d0 + anis_i_0)*pi_para_inf
   Ti_para_inf = Dinv_inf * pi_para_inf
   Ti_perp_inf = Dinv_inf * pi_perp_inf
   !electron pressures and temperatures
   anis_e_0 = 0.0d0     ! electron anisotropy at infinity (A = Pperp/Ppara - 1)
   pe_para_inf = 0.5d0 ! (0.5d0 --> beta = 1)
   pe_perp_inf = (1.0d0 + anis_e_0)*pe_para_inf
   Te_para_inf = Dinv_inf * pe_para_inf
   Te_perp_inf = Dinv_inf * pe_perp_inf
   !perpendicular plasma betas
   beta_i_perp = (2.0d0 * pi_perp_inf) / B00    ! ions
   beta_e_perp = (2.0d0 * pe_perp_inf) / B00    ! elettrons

   ! useful quantities: "reduced" betas and gamma
   ! [see: Cerri et al., PoP 20, 112112 (2013)]
   gam_tilde = (gam_e_perp - gam_i_perp)*gaminv_i_perp
   beta_i_perp_tilde = beta_i_perp / (1.0d0 + beta_i_perp + beta_e_perp)
   beta_e_perp_tilde = beta_e_perp / (1.0d0 + beta_i_perp + beta_e_perp)

   if (mpime==0) then
   write(6,*) ' ------------------------------------------------------------------ '
   write(6,*) ' gam_i_perp,  gam_i_para,  gam_e_perp,  gam_e_para,  gam_tilde  '
   write(6,*) ' ',gam_i_perp, gam_i_para, gam_e_perp, gam_e_para, gam_tilde
   write(6,*) ' Den_inf,  pi_para_inf,  pi_perp_inf,  pe_para_inf,  pe_perp_inf  '
   write(6,*) ' ',Den_inf, pi_para_inf, pi_perp_inf, pe_para_inf, pe_perp_inf
   write(6,*) ' Ti_para_inf,  Ti_perp_inf,  Te_para_inf,  Te_perp_inf  '
   write(6,*) ' ',Ti_para_inf, Ti_perp_inf, Te_para_inf, Te_perp_inf
   write(6,*) ' beta_i_perp,  beta_e_perp,  beta_i_perp_tilde,  beta_e_perp_tilde  '
   write(6,*) ' ',beta_i_perp, beta_e_perp, beta_i_perp_tilde, beta_e_perp_tilde
   write(6,*) ' ------------------------------------------------------------------ '
   endif

   if (mpime==0) then
   write(6,*) ' ----------------------------- '
   write(6,*) ' Delta_N  = ', DeltaDen
   write(6,*) ' ----------------------------- '
   endif

  ! compute FLR-correction function for equivalent MHD profiles
  ! [see: Cerri et al., PoP 20, 112112 (2013)]

  if (flr_on .eq. 1) then
    C_0 = (0.5d0/dsqrt(B00))*(Aeq / Leq)*beta_i_perp_tilde
    equilDen(:) = 1.0d0 - 0.5d0*DeltaDen*Dinv_inf*(1.0d0 - dtanh((x(ixlg:ixlg+nxl-1) - xl*0.5d0 ) / Leq) )
    f_0(:) = 1.0d0 / (1.0d0 - C_0*equilDen(:)*(1.0d0 - (dtanh((x(ixlg:ixlg+nxl-1) - xl*0.5d0 ) / Leq) )**2.0)  )
  else
    f_0(:) = 1.0d0
  endif

  fnct(:) = equilDen(:) * f_0(:)

  !*** Compute actual equilibrium profiles ***!

   !density
   do iz=1, nz
     do iy=1, ny  !  nyl == ny
      Den(:,iy,iz) = Den_inf * (fnct(:)**gaminv_i_perp)
     enddo
   enddo

   Dinv = 1.0d0 / Den

   !gyrotropic ion pressures
   do iz = 1, nz
     do iy = 1, ny  ! nyl == ny
       pi_perp(:,iy,iz) = pi_perp_inf * fnct(:)
     enddo
   enddo
   do iz=1, nz
     do iy=1, ny  ! nyl == ny
       pi_para(:,iy,iz) = pi_para_inf * (fnct(:)**(gam_i_para*gaminv_i_perp))
     enddo
   enddo

   !gyrotropic electron pressures
   do iz = 1, nz
     do iy = 1, ny  ! nyl == ny
       pe_perp(:,iy,iz) = pe_perp_inf * (fnct(:)**(gam_e_perp*gaminv_i_perp))
     enddo
   enddo
   do iz=1, nz
     do iy=1, ny  ! nyl == ny
       pe_para(:,iy,iz) = pe_para_inf * (fnct(:)**(gam_e_para*gaminv_i_perp))
     enddo
   enddo

  !gyrotropic temperatures: simply T = p/n
  Ti_perp = Dinv * pi_perp
  Ti_para = Dinv * pi_para
  Te_perp = Dinv * pe_perp
  Te_para = Dinv * pe_para

 !*** equilibrium magnetic field

  !make sure that B is in (y,z) plane
  !(i.e., not perpendicular to the flow)
  Bx = 0.d0

  !FLR-corrected equilibrium profile
  equilB(:) = (1.0d0+beta_i_perp+beta_e_perp)*f_0(:) - (beta_i_perp+beta_e_perp)*fnct(:)
  do iz=1, nz
    do iy=1, ny  !  nyl == ny
      do ix=1, nxl
        Bz(ix,iy,iz) = dsqrt(B00*equilB(ix)) * dcos(angolo)
      enddo
    enddo
  enddo
  do iz=1, nz
    do iy=1, ny  !  nyl == ny
      do ix=1, nxl
        By(ix,iy,iz) = dsqrt(B00*equilB(ix)) * dsin(angolo)
      enddo
    enddo
  enddo

deallocate(f_0)
deallocate(fnct)
deallocate(equilB)
deallocate(equilDen)

 !*****************************************************************!
 ! Compute: passive tracer (defined on the initial velocity shear) !
 !   [ note: this is problem dependent, adjust at will ]           !
 !*****************************************************************!

  do iz = 1, nz
    do ix = 1, nxl
      Tracciante(ix,:,iz) = 0.6 + 0.4 * dtanh(( x(ix + ixlg - 1)-xl*0.5d0) / Leq)
    enddo
  enddo

 !***********************************!
 ! Compute: initial current density  !
 !***********************************!

  call corrente

 !********************************************************!
 ! Compute: initial fluid velocities (ions and electrons) !
 !********************************************************!

  call u_ei

 !*********************************!
 ! Compute: initial electric field !
 !*********************************!

  call ohm

 !**************************!
 ! Compute: inital momentum !
 !**************************!

  nU_x = Den * Ux
  nU_y = Den * Uy
  nU_z = Den * Uz

 CASE(+1)   !istart = 1 -> Restart from existing RUN using the same timestep dt

  !***********!
  !  RESTART  !
  ! (same dt) !
  !***********!

  l_rst_me=l_rst+mpime

 if ( mpime.lt.10 ) then
   write( F_1, '(1i1)' ) mpime
   filen_DT  = 'DATA_TF_000'//F_1
 endif

 if ( mpime.ge.10.and.mpime.le.99 ) then
   write( F_2, '(1i2)' ) mpime
   filen_DT  = 'DATA_TF_00'//F_2
 endif

 if ( mpime.gt.99 ) then
   write( F_3, '(1i3)' ) mpime
   filen_DT  = 'DATA_TF_0'//F_3
 endif

 if ( (mpime.gt.999) .and. (mpime.le.9999) ) then
   write( F_4, '(1i4)' ) mpime
   filen_DT  = 'DATA_TF_'//F_4
 endif

 OPEN(l_rst_me,status='unknown', form='unformatted',file=filen_DT)

 READ(l_rst_me) ioutt, ioutx
 READ(l_rst_me) tempo, tt_last, tx_last
 READ(l_rst_me) Ti_para, Ti_perp, Te_para, Te_perp
 READ(l_rst_me) Uex, Uey, Uez, Uix, Uiy, Uiz, Ux, Uy, Uz, Jx, Jy, Jz
 READ(l_rst_me) Den, Dinv, pe_para, pe_perp, pi_para, pi_perp, nU_x, nU_y, nU_z
 READ(l_rst_me) Ex, Ey, Ez, Bx, By, Bz, Tracciante!, Tracciante_e

 CLOSE(l_rst_me)

 CASE(+2)   !istart = 2 -> Restart from existing RUN, but using a different timestep dt

  !****************!
  !     RESTART    !
  ! (different dt) !
  !****************!

  l_rst_me=l_rst+mpime

 if ( mpime.lt.10 ) then
   write( F_1, '(1i1)' ) mpime
   filen_DT  = 'DATA_TF_000'//F_1
 endif

 if ( (mpime.ge.10) .and. (mpime.le.99) ) then
   write( F_2, '(1i2)' ) mpime
   filen_DT  = 'DATA_TF_00'//F_2
 endif

 if ( (mpime.gt.99) .and. (mpime.le.999) ) then
   write( F_3, '(1i3)' ) mpime
   filen_DT  = 'DATA_TF_0'//F_3
 endif

 if ( (mpime.gt.999) .and. (mpime.le.9999) ) then
   write( F_4, '(1i4)' ) mpime
   filen_DT  = 'DATA_TF_'//F_4
 endif

 OPEN(l_rst_me,status='unknown', form='unformatted',file=filen_DT)

 READ(l_rst_me) ioutt, ioutx
 READ(l_rst_me) tempo, tt_last, tx_last
 READ(l_rst_me) Ti_para, Ti_perp, Te_para, Te_perp
 READ(l_rst_me) Uex, Uey, Uez, Uix, Uiy, Uiz, Ux, Uy, Uz, Jx, Jy, Jz
 READ(l_rst_me) Den, Dinv, pe_para, pe_perp, pi_para, pi_perp, nU_x, nU_y, nU_z
 READ(l_rst_me) Ex, Ey, Ez, Bx, By, Bz, Tracciante

 CLOSE(l_rst_me)

END SELECT

 !*************************************!
 ! Compute: initial gyroviscous tensor !
 !*************************************!

  if (flr_on .eq. 1) then
    write(6,*) ''
    write(6,*) ' IONS FLR: ON! '
    call flr_i
  else !if (flr_on .eq. 0) then
    write(6,*) ''
    write(6,*) ' NO IONS FLR: G_i set to zero! '
    Gi_xx = 0.0d0
    Gi_xy = 0.0d0
    Gi_xz = 0.0d0
    Gi_yz = 0.0d0
  !else
  !  write(6,*) ''
  !  write(6,*) '*****************************************'
  !  write(6,*) '***          !!! WARNING !!!          ***'
  !  write(6,*) '*****************************************'
  !  write(6,*) '*  invalid value for FLR_ON parameter!  *'
  !  write(6,*) '* ------------------------------------- *'
  !  write(6,*) '*    FLR_ON must have 1 or 0 value...   *'
  !  write(6,*) '*****************************************'
  endif

 if (mpime==0) then
 write(6,*) ' --------------------------------------------- '
 write(6,*) 'SUBROUTINE CONDINIT, B00, angolo, Lx, Ly, Lz :'
 write(6,805) B00, angolo,  x(nx)-x(1), y(ny) - y(1), z(nz) - z(1)
 write(6,*) ' --------------------------------------------- '
 endif

622  format(1x, 2(2x, 1i4), 2(2x, 1e11.4))
822  format(1x, 2(2x, 1f5.1), 2(2x, 1e11.4))
802  format(1x, 2(2x, 1e11.4))
803  format(1x, 3(2x, 1e11.4))
805  format(1x, 5(2x, 1e11.4))

end subroutine