*     -----------------
*     PROGRAMME EXAMPLE
*     -----------------
*
*     Reference : Bureau des Longitudes - PBGF9502.
*
*     ------
*     Object
*     ------
*
*     This program is an example of use of VSOP87 subroutine.
*     It computes the coordinates of a planet for a version of VSOP87.
*     VSOP87 (main version) : elliptic coordinates J2000
*     VSOP87A : heliocentric rectangular coordinates J2000
*     VSOP87B : heliocentric spherical   coordinates J2000
*     VSOP87C : heliocentric rectangular coordinates of date
*     VSOP87D : heliocentric spherical   coordinates of date
*     VSOP87E : barycentric  rectangular coordinates J2000
*     The frame is referred to the dynamical equinox and ecliptic.
*     The time scale is the dynamical barycentric time TDB.
*
*     ------------
*     Declarations
*     ------------
*
      implicit double precision (a-h,o-z)
      logical fexist
      integer day,month,year,d0,h0,dt,datmod
      character rep,a(0:5)
      character*4 ext(0:9)
      character*6 prefix
      character*7 vers
      character*21 body(0:9)
      character*40 fich
      character*37 coord(4)
      character*39 reper(2)
      dimension r(6),kbody(0:8,0:5),maxbody(0:5),prec0(0:9)
      data a/' ','A','B','C','D','E'/
      data ext/'.sun','.mer','.ven','.ear','.mar','.jup',
     .         '.sat','.ura','.nep','.emb'/
      data body/'SUN','MERCURY','VENUS','EARTH','MARS','JUPITER',
     .          'SATURN','URANUS','NEPTUNE','EARTH-MOON BARYCENTER'/
      data coord/'Heliocentric elliptic coordinates.',
     .           'Heliocentric rectangular coordinates.',
     .           'Heliocentric spherical coordinates.',
     .           'Barycentric rectangular coordinates.'/
      data reper/'Dynamical equinox and ecliptic J2000.',
     .           'Dynamical equinox and ecliptic of date.'/
      data prec0/1.d-8,0.6d-8,2.5d-8,2.5d-8,10.d-8,35.d-8,70.d-8,
     .           8.d-8,42.d-8,2.5d-8/
      data kbody/1,2,4,5,6,7,8,9,10,
     .           1,2,3,4,5,6,7,8,9,
     .           1,2,3,4,5,6,7,8,10,
     .           1,2,3,4,5,6,7,8,10,
     .           1,2,3,4,5,6,7,8,10,
     .           0,1,2,3,4,5,6,7,8/
      data maxbody/7,8,7,7,7,8/
      data prefix/'VSOP87'/
      menu=4
      lu0=0
*
*     ----------------
*     Version and body
*     ----------------
*
100   continue
      if (menu.ne.1.and.menu.ne.4) goto 200
      call CLRSCR
      print 1000
      print 2001
      read (*,3001,iostat=nerr) ivers
      if (nerr.ne.0) goto 100
      if (ivers.lt.0.or.ivers.gt.5) goto 100
      vers='VSOP87'//a(ivers)
      call CLRSCR
      print 1000
      print 2002, vers
      do i=0,maxbody(ivers)
         nbody=kbody(i,ivers)
         print 2003, nbody,body(nbody)
      enddo
      print 2004
      read (*,3004,iostat=nerr) ibody
      if (nerr.ne.0) goto 100
      irep=0
      do i=0,maxbody(ivers)
         if (kbody(i,ivers).eq.ibody) irep=1
      enddo
      if (irep.eq.0) goto 100
      print 1001
      read 3000, rep
      if (rep.eq.'N'.or.rep.eq.'n') goto 100
*
*     ----------------
*     Open file VSOP87
*     ----------------
*
      lu=ivers*10+10+ibody
      if (lu0.ne.0.and.lu0.ne.lu) close (lu0)
      if (ivers.eq.0) fich=prefix//ext(ibody)
      if (ivers.ne.0) fich=prefix//a(ivers)//ext(ibody)
      inquire (file=fich,exist=fexist)
      if (fexist) then
         if (lu.ne.lu0) then
            open (lu,file=fich,status='old',iostat=nerr)
            if (nerr.ne.0) goto 610
            lu0=lu
         endif
      else
         goto 620
      endif
*
*     -------------
*     Datation mode
*     -------------
*
200   continue
      if (menu.ne.2.and.menu.ne.4) goto 300
      call CLRSCR
      print 1000
      print 2005
      read (*,3005,iostat=nerr) datmod
      if (nerr.ne.0) goto 200
      if (datmod.lt.1.or.datmod.gt.2) goto 200
      if (datmod.eq.1) then
         print 2006
         read (*,3006,iostat=nerr) t0
         if (nerr.ne.0) goto 200
         if (t0.lt.1.d0) goto 200
      else
         print 2007
         read (*,3007,iostat=nerr) d0
         if (nerr.ne.0) goto 200
         call DATEJD (d0,0,td)
         if (td.eq.0.d0) goto 200
         print 2008
         read (*,3008,iostat=nerr) h0
         if (nerr.ne.0) goto 200
         call DATEJD (d0,h0,t0)
         if (t0.eq.0.d0) goto 200
      endif
      t=t0
      print 2009
      read (*,3009,iostat=nerr) dt
      if (nerr.ne.0.or.dt.lt.0) goto 200
      nj=dt/1000000
      nh=mod(dt,1000000)/10000
      nm=mod(dt,10000)/100
      ns=mod(dt,100)
      if (nj.gt.100.or.nh.gt.24.or.nm.gt.60.or.ns.gt.60) goto 200
      pas=nj+nh/24.d0+nm/1440.d0+ns/86400.d0
      print 1001
      read 3000, rep
      if (rep.eq.'N'.or.rep.eq.'n') goto 200
*
*     --------------------------
*     Precision level (relative)
*     --------------------------
*
300   continue
      if (menu.ne.3.and.menu.ne.4) goto 400
      call CLRSCR
      print 1000
      print 2010
      read (*,3010,iostat=nerr) iprec
      if (nerr.ne.0) goto 300
      if (iprec.lt.1.or.iprec.gt.2) goto 300
      if (iprec.eq.1) then
         prec=0.d0
      else
         print 2011, prec0(ibody)
         read (*,3011,iostat=nerr) prec
         if (nerr.ne.0) goto 300
         if (prec.lt.prec0(ibody).or.prec.gt.1.d-2) goto 300
         print 1001
         read 3000, rep
         if (rep.eq.'N'.or.rep.eq.'n') goto 300
      endif
*
*     ----------------------------
*     Computation of the ephemeris
*     ----------------------------
*
400   continue
      print 2012
*
      call VSOP87 (t,ivers,ibody,prec,lu,r,ierr)
*
      if (ierr.ne.0) goto 600
      call JDDATE (t,idate,iheur)
      jdate=abs(idate)
      day=mod(jdate,100)
      month=mod(jdate/100,100)
      year=idate/10000
      nh=iheur/10000
      nm=mod(iheur/100,100)
      ns=mod(iheur,100)
      ic=1
      ir=1
      if (ivers.eq.1.or.ivers.eq.3) ic=2
      if (ivers.eq.2.or.ivers.eq.4) ic=3
      if (ivers.eq.5) ic=4
      if (ivers.eq.3.or.ivers.eq.4) ir=2
*
410   continue
      call CLRSCR
      if (prec.lt.prec0(ibody)) then
         print 4001, vers,body(ibody),coord(ic),reper(ir),
     .               day,month,year,t,nh,nm,ns
      else
         print 4002, vers,body(ibody),coord(ic),reper(ir),
     .               day,month,year,t,nh,nm,ns,prec
      endif
      if (ivers.eq.0) print 4003,r
      if (ivers.eq.1.or.ivers.eq.3.or.ivers.eq.5)
     .   print 4004, r(1),r(4),r(2),r(5),r(3),r(6)
      if (ivers.eq.2.or.ivers.eq.4)
     .   print 4005, r(1),r(4),r(2),r(5),r(3),r(6)
      print 2013
      read 3000, rep
      if (rep.ne.'+'.and.rep.ne.'-') goto 500
      if (dt.eq.0) goto 410
      if (rep.eq.'+') t=t+pas
      if (rep.eq.'-') t=t-pas
      goto 400
*
*     -------------------
*     Another computation
*     -------------------
*
500   continue
      call CLRSCR
      print 1000
      print 2014
      read (*,3014,iostat=nerr) menu
      if (nerr.ne.0) goto 500
      if (menu.lt.0.or.menu.gt.4) goto 500
      if (menu.ne.0) goto 100
      call CLRSCR
      print 1000
      print 2015
      pause ' Program terminated : Hit Enter'
      stop
*
*     ---------------
*     Errors Messages
*     ---------------
*
600   continue
      call CLRSCR
      print 1000
      if (ierr.eq.1) print 5001, ivers
      if (ierr.eq.2) print 5002, ibody
      if (ierr.eq.3) print 5003, prec
      if (ierr.eq.4) print 5004, fich
      pause ' Program terminated : Hit Enter'
      stop
610   continue
      call CLRSCR
      print 1000
      print 5005, fich
      pause ' Program terminated : Hit Enter'
      stop
620   continue
      call CLRSCR
      print 1000
      print 5006, fich
      pause ' Program terminated : Hit Enter'
      stop
*
*     -------
*     Formats
*     -------
*
1000  format (2x,'PLANETARY SOLUTION VSOP87'/
     .        2x,'-------------------------')
1001  format (/2x,'Confirm your choice (y/n) ? ',$)
*
2001  format (/2x,'Choice of the version'/
     .        /2x,'0 : VSOP87 (main solution), elliptic coordinates'
     .        /2x,'    dynamical equinox and ecliptic J2000'/
     .        /2x,'1 : VSOP87A, heliocentric rectangular coordinates'
     .        /2x,'    dynamical equinox and ecliptic J2000'/
     .        /2x,'2 : VSOP87B, heliocentric spherical coordinates'
     .        /2x,'    dynamical equinox and ecliptic J2000'/
     .        /2x,'3 : VSOP87C, heliocentric rectangular coordinates'
     .        /2x,'    dynamical equinox and ecliptic of the date'/
     .        /2x,'4 : VSOP87D, heliocentric spherical coordinates'
     .        /2x,'    dynamical equinox and ecliptic of the date'/
     .        /2x,'5 : VSOP87E, barycentric rectangular coordinates'
     .        /2x,'    dynamical equinox and ecliptic J2000'/
     .        /2x,'Enter your choice ? ',$)
2002  format (/2x,'Choice of the body in version ',a7/)
2003  format (2x,i1,' : ',a21)
2004  format (/2x,'Enter your choice ? ',$)
2005  format (/2x,'Datation mode'/
     .        /2x,'1 : computation with julian dates'
     .        /2x,'2 : computation with calendar dates'/
     .        /2x,'Enter your choice ? ',$)
2006  format (/2x,'Enter the initial julian date'
     .        /2x,'don''t forget the decimal point ---> ',$)
2007  format (/2x,'Enter the initial date'
     .        /2x,'format : +/-yyyymmdd -------------> ',$)
2008  format (/2x,'Enter the initial time'
     .        /2x,'format : hhmmss ------------------> ',$)
2009  format (/2x,'Enter the time step (<100 days)'
     .        /2x,'format : ddhhmmss ----------------> ',$)
2010  format (/2x,'Precision level'/
     .        /2x,'1 : computation with the complete solution'
     .        /2x,'2 : computation with a truncated solution'/
     .        /2x,'Enter your choice ? ',$)
2011  format (/2x,'Enter the relative precision level'
     .        /2x,'between ',f11.9,' and 0.01'
     .        /2x,'don''t forget the decimal point -----> ',$)
2012  format (/2x,'Wait Please . . .')
2013  format (/2x,77('-')//2x,'Choice of time :      next time -> +',
     .        '      previous time -> -      stop -> 0'/
     .        /2x,'Enter your choice ? ',$)
2014  format (/2x,'Another computation'/
     .        /2x,'0 : stop'/
     .        /2x,'1 : with new version or body'
     .        /2x,'2 : with new datation mode'
     .        /2x,'3 : with new precision level'/
     .        /2x,'4 : with new parameters'/
     .        /2x,'Enter your choice ? ',$)
2015  format (///)
*
3000  format (a)
3001  format (i2)
3004  format (i2)
3005  format (i2)
3006  format (f14.6)
3007  format (i10)
3008  format (i7)
3009  format (i9)
3010  format (i2)
3011  format (f12.9)
3014  format (i2)
*
4001  format (2x,'PLANETARY SOLUTION ',a7,5x,'BODY : ',a21
     .        /2x,77('-')//2x,a37,1x,a39/
     .        /2x,'Date : ',i2.2,' / ',i2.2,' / ',i5,
     .        t41,'Julian date : ',f14.6
     .        /2x,'Time : ',i2.2,'h ',i2.2,'m ',i2.2,'s TDB',
     .        t41,'Precision of the complete solution')
4002  format (2x,'PLANETARY SOLUTION ',a7,5x,'BODY : ',a21
     .        /2x,77('-')//2x,a37,1x,a39/
     .        /2x,'Date : ',i2.2,' / ',i2.2,' / ',i5,
     .        t41,'Julian date : ',f14.6
     .        /2x,'Time : ',i2.2,'h ',i2.2,'m ',i2.2,'s TDB',
     .        t41,'Relative precision : ',f10.9)
4003  format (/2x,'Semi-major axis :  ',f13.10,' au',
     .        t41,'Mean longitude :   ',f13.10,' rad'
     .        /2x,'k = e*cos(p) :     ',f13.10,' rad',
     .        t41,'h = e*sin(p) :     ',f13.10,' rad'
     .        /2x,'q = sin(g)*cos(G) :',f13.10,' rad',
     .        t41,'p = sin(g)*sin(G) :',f13.10,' rad'/
     .        /2x,'e : eccentricity',
     .        t41,'p : perihelion longitude'
     .        /2x,'g : semi-iclination',
     .        t41,'G : ascending node longitude')
4004  format (/2x,'X :',f14.10,' au',t41,'X'' :',f14.10,' ua/d'
     .        /2x,'Y :',f14.10,' au',t41,'Y'' :',f14.10,' ua/d'
     .        /2x,'Z :',f14.10,' au',t41,'Z'' :',f14.10,' ua/d')
4005  format (/2x,'Longitude :',f14.10,' rad',
     .        t41,'vitesse  :',f14.10,' rad/d'
     .        /2x,'Latitude : ',f14.10,' rad',
     .        t41,'vitesse  :',f14.10,' rad/d'
     .        /2x,'Radius :   ',f14.10,' au',
     .        t41,'vitesse  :',f14.10,' au/d')
*
5001  format (/2x,'*****  Error *****'/
     .        /2x,'Wrong version index : ',i1/)
5002  format (/2x,'*****  Error *****'/
     .        /2x,'Wrong body index : ',i1/)
5003  format (/2x,'*****  Error *****'/
     .        /2x,'Wrong precision level : ',d9.2/)
5004  format (/2x,'*****  Error *****'/
     .        /2x,'Fatal reading file error : ',a40/)
5005  format (/2x,'*****  Error *****'/
     .        /2x,'Fatal open file error : ',a40/)
5006  format (/2x,'***** File Error *****'/
     .        /2x,'Missing file : ',a40/)
*
      end
*
*
*
      subroutine JDDATE (tjd,idate,ihour)
*-----------------------------------------------------------------------
*
*     Object :
*     Conversion   Julian date ---> Calendar date    (Meeus formular).
*
*     Input :
*     tjd         julian date (real double precision).
*
*     Ouput :
*     idate       calendar date (integer).
*                 julian calendar before 1582 october 15
*                 gregorian calendar after.
*                 code: *yyyymmdd (* sign).
*     ihour       hour (integer).
*                 code: hhmmss.
*
*-----------------------------------------------------------------------
      implicit double precision (a-h,o-z)
      integer day,month,year
      idate=0
      ihour=0
      if (tjd.lt.0.d0) return
      t=tjd+0.5d0/86400.d0+0.5d0
      z=dint(t)
      f=t-z
      if (z.lt.2299161.d0) then
         a=z
      else
         x=dint((z-1867216.25d0)/36524.25d0)
         a=z+1.d0+x-dint(x/4.d0)
      endif
      b=a+1524.d0
      c=dint((b-122.1d0)/365.25d0)
      d=dint(365.25d0*c)
      e=dint((b-d)/30.6001d0)
      day=b-d-dint(30.6001d0*e)
      month=e-1.d0
      if (e.lt.13.5d0) then
         month=e-1.d0
      else
         month=e-13.d0
      endif
      if (month.lt.3) then
         year=c-4715.d0
      else
         year=c-4716.d0
      endif
      is=+1
      if (year.lt.0) is=-1
      idate=((iabs(year)*100+month)*100+day)*is
      f=f*24.d0
      ih=f
      f=(f-ih)*60.d0
      im=f
      f=(f-im)*60.d0
      is=f
      ihour=(ih*100+im)*100+is
      return
      end
*
*
*
      subroutine DATEJD (idate,ihour,tjd)
*-----------------------------------------------------------------------
*
*     Object :
*     Conversion   Calendar date -> Julian date    (Meeus formular).
*
*     Input :
*     idate       calendar date gregorian/julian (integer).
*                 julian calendar before 1582 october 15
*                 gregorian calendar after.
*                 code: *yyyymmdd (* sign).
*     ihour       hour (integer).
*                 code: hhmmss.
*
*     Output
*     tjd         julian date (real double precision).
*
*-----------------------------------------------------------------------
      implicit double precision (a-h,o-z)
      integer day,month,year
      dimension lm(12)
      data lm/31,28,31,30,31,30,31,31,30,31,30,31/
      tjd=0.d0
      year=idate/10000
      if (year.lt.-4713.or.year.gt.5000) return
      kdate=iabs(idate)-iabs(year)*10000
      month=kdate/100
      if (month.lt.1.or.month.gt.12) return
      day=kdate-month*100
      lm(2)=28
      if (mod(year,4).eq.0) then
         lm(2)=29
         if (year.gt.1582) then
            ncent=year/100
            if (mod(year,100).eq.0.and.mod(ncent,4).ne.0) lm(2)=28
         endif
      endif
      if (day.lt.1.or.day.gt.lm(month)) return
      is=ihour
      ih=ihour/10000
      if (ih.lt.0.or.ih.gt.24) return
      is=is-ih*10000
      im=is/100
      if (im.lt.0.or.im.gt.60) return
      is=is-im*100
      if (is.lt.0.or.is.gt.60) return
      a=0.d0
      b=0.d0
      c=0.d0
      if (month.gt.2) then
         y=year
         m=month
      else
         y=year-1
         m=month+12
      endif
      if (y.lt.0.d0) then
         c=-0.75d0
      else
         if (idate.ge.15821015) then
            a=dint(y/100.d0)
            b=2.d0-a+dint(a/4.d0)
         endif
      endif
      tjd=dint(365.25d0*y+c)+dint(30.6001d0*(m+1))+day+
     .    dfloat(ih)/24.d0+dfloat(im)/1440.d0+dfloat(is)/86400.d0+
     .    1720994.5d0+b
      return
      end
*
*
*
      subroutine CLRSCR
*-----------------------------------------------------------------------
*
*     ref : bdl-gf9412
*
*     Object :
*     Clear the screen.
*
*     Remark :
*     *DOS  for DOS system.
*     *UNX  for UNIX system.
*
*-----------------------------------------------------------------------
*
*DOS  character*7 escscr
*DOS  escscr=char(27)//char(91)//'2J'//char(27)//char(91)//'H'
*DOS  write (*,'(2x,a)') escscr
*
*UNX  call system ('clear')
*
      call system ('clear')
*
      return
      end
*
*
*
      subroutine VSOP87 (tdj,ivers,ibody,prec,lu,r,ierr)
*-----------------------------------------------------------------------
*
*     Reference : Bureau des Longitudes - PBGF9502
*
*     Object :
*
*     Substitution of time in VSOP87 solution written on a file.
*     The file corresponds to a version of VSOP87 theory and to a body.
*
*     Input :
*
*     tdj      julian date (real double precision).
*              time scale : dynamical time TDB.
*
*     ivers    version index (integer).
*              0: VSOP87 (initial solution).
*                 elliptic coordinates
*                 dynamical equinox and ecliptic J2000.
*              1: VSOP87A.
*                 rectangular coordinates
*                 heliocentric positions and velocities
*                 dynamical equinox and ecliptic J2000.
*              2: VSOP87A.
*                 spherical coordinates
*                 heliocentric positions and velocities
*                 dynamical equinox and ecliptic J2000.
*              3: VSOP87C.
*                 rectangular coordinates
*                 heliocentric positions and velocities
*                 dynamical equinox and ecliptic of the date.
*              4: VSOP87D.
*                 spherical coordinates
*                 heliocentric positions and velocities
*                 dynamical equinox and ecliptic of the date.
*              5: VSOP87E.
*                 rectangular coordinates
*                 barycentric positions and velocities
*                 dynamical equinox and ecliptic J2000.
*
*     ibody    body index (integer).
*              0: Sun
*              1: Mercury
*              2: Venus
*              3: Earth
*              4: Mars
*              5: Jupiter
*              6: Saturn
*              7: Uranus
*              8: Neptune
*              9: Earth-Moon barycenter
*
*     prec     relative precision (real double precision).
*
*              if prec is equal to 0 then the precision is the precision
*                 p0 of the complete solution VSOP87.
*                 Mercury    p0 =  0.6 10**-8
*                 Venus      p0 =  2.5 10**-8
*                 Earth      p0 =  2.5 10**-8
*                 Mars       p0 = 10.0 10**-8
*                 Jupiter    p0 = 35.0 10**-8
*                 Saturn     p0 = 70.0 10**-8
*                 Uranus     p0 =  8.0 10**-8
*                 Neptune    p0 = 42.0 10**-8
*
*              if prec is not equal to 0, let us say in between p0 and
*              10**-2, the precision is :
*                 for the positions :
*                 - prec*a0 au for the distances.
*                 - prec rd for the other variables.
*                 for the velocities :
*                 - prec*a0 au/day for the distances.
*                 - prec rd/day for the other variables.
*                   a0 is semi-major axis of the body.
*                 Mercury    a0 =  0.3871 ua
*                 Venus      a0 =  0.7233 ua
*                 Earth      a0 =  1.0000 ua
*                 Mars       a0 =  1.5237 ua
*                 Jupiter    a0 =  5.2026 ua
*                 Saturn     a0 =  9.5547 ua
*                 Uranus     a0 = 19.2181 ua
*                 Neptune    a0 = 30.1096 ua
*
*     lu       logical unit index of the file (integer).
*              The file corresponds to a version of VSOP87 theory and
*              a body, and it must be defined and opened before the
*              first call to subroutine VSOP87.
*
*     Output :
*
*     r(6)     array of the results (real double precision).
*
*              for elliptic coordinates :
*                  1: semi-major axis (au)
*                  2: mean longitude (rd)
*                  3: k = e*cos(pi) (rd)
*                  4: h = e*sin(pi) (rd)
*                  5: q = sin(i/2)*cos(omega) (rd)
*                  6: p = sin(i/2)*sin(omega) (rd)
*                     e:     eccentricity
*                     pi:    perihelion longitude
*                     i:     inclination
*                     omega: ascending node longitude
*
*              for rectangular coordinates :
*                  1: position x (au)
*                  2: position y (au)
*                  3: position z (au)
*                  4: velocity x (au/day)
*                  5: velocity y (au/day)
*                  6: velocity z (au/day)
*
*              for spherical coordinates :
*                  1: longitude (rd)
*                  2: latitude (rd)
*                  3: radius (au)
*                  4: longitude velocity (rd/day)
*                  5: latitude velocity (rd/day)
*                  6: radius velocity (au/day)
*
*     ierr     error index (integer).
*                  0: no error.
*                  1: file error (check up ivers index).
*                  2: file error (check up ibody index).
*                  3: precision error (check up prec parameter).
*                  4: reading file error.
*
*-----------------------------------------------------------------------
*
*     --------------------------------
*     Declarations and initializations
*     --------------------------------
*
      implicit double precision (a-h,o-z)
      character*7 bo,body(0:9)
      dimension r(6),t(-1:5),a0(0:9)
      data body/'SUN','MERCURY','VENUS','EARTH','MARS','JUPITER',
     .          'SATURN','URANUS','NEPTUNE','EMB'/
      data a0/0.01d0,0.3871d0,0.7233d0,1.d0,1.5237d0,5.2026d0,
     .        9.5547d0,19.2181d0,30.1096d0,1.d0/
      data dpi/6.283185307179586d0/
      data t/0.d0,1.d0,5*0.d0/
      data t2000/2451545.d0/
      data a1000/365250.d0/
      k=0
      ideb=0
*
      rewind (lu,err=500)
      do i=1,6
         r(i)=0.d0
      enddo
*
      t(1)=(tdj-t2000)/a1000
      do i=2,5
         t(i)=t(1)*t(i-1)
      enddo
*
      ierr=3
      if (prec.lt.0.d0.or.prec.gt.1.d-2) return
      q=dmax1(3.d0,-dlog10(prec+1.d-50))
*
*     -------------------------------------
*     File reading and substitution of time
*     -------------------------------------
*
100   continue
      read (lu,1001,end=400,err=500) iv,bo,ic,it,in
*
      if (ideb.eq.0) then
         ideb=1
         ierr=1
         if (iv.ne.ivers) return
         ierr=2
         if (bo.ne.body(ibody)) return
         ierr=0
         if (iv.eq.0) k=2
         if (iv.eq.2.or.iv.eq.4) k=1
      endif
*
      if (in.eq.0) goto 100
*
      p=prec/10.d0/(q-2)/(dabs(t(it))+it*dabs(t(it-1))*1.d-4+1.d-50)
      if (k.eq.0.or.(k.ne.0.and.ic.eq.5-2*k)) p=p*a0(ibody)
*
      do 200 n=1,in
         nn=n
         read (lu,1002,err=500) a,b,c
         if (dabs(a).lt.p) goto 300
         u=b+c*t(1)
         cu=dcos(u)
         r(ic)=r(ic)+a*cu*t(it)
         if (iv.eq.0) goto 200
         su=dsin(u)
         r(ic+3)=r(ic+3)+t(it-1)*it*a*cu-t(it)*a*c*su
200   continue
*
      goto 100
300   continue
*
      if (nn.eq.in) goto 100
*
      do n=nn+1,in
         read (lu,1002,err=500)
      enddo
      goto 100
*
400   continue
      if (iv.ne.0) then
         do i=4,6
            r(i)=r(i)/a1000
         enddo
      endif
*
      if (k.eq.0) return
*
      r(k)=dmod(r(k),dpi)
      if (r(k).lt.0.d0) r(k)=r(k)+dpi
      return
*
500   continue
      ierr=4
      return
*
*     -------
*     Formats
*     -------
*
1001  format (17x,i1,4x,a7,12x,i1,17x,i1,i7)
1002  format (79x,f18.11,f14.11,f20.11)
*
      end


Module m_inssor
Integer, Parameter :: kdp = selected_real_kind(15)
public :: inssor
private :: kdp
private :: R_inssor, I_inssor, D_inssor
interface inssor
  module procedure d_inssor, r_inssor, i_inssor
end interface inssor
contains

Subroutine D_inssor (XDONT)
!  Sorts XDONT into increasing order (Insertion sort)
! __________________________________________________________
!  This subroutine uses insertion sort. It does not use any
!  work array and is faster when XDONT is of very small size
!  (< 20), or already almost sorted, but worst case behavior
!  can happen fairly probably (initially inverse sorted).
!  In many cases, the quicksort or merge sort method is faster.
!  Michel Olagnon - Apr. 2000
! __________________________________________________________
! __________________________________________________________
! __________________________________________________________
      Real (kind=kdp), Dimension (:), Intent (InOut) :: XDONT
! __________________________________________________________
      Real (Kind=kdp) :: XWRK, XMIN
!
! __________________________________________________________
!
      Integer :: ICRS, IDCR, NDON
!
      NDON = Size (XDONT)
!
! We first bring the minimum to the first location in the array.
! That way, we will have a "guard", and when looking for the
! right place to insert a value, no loop test is necessary.
!
      If (XDONT (1) < XDONT (NDON)) Then
          XMIN = XDONT (1)
      Else
          XMIN = XDONT (NDON)
          XDONT (NDON) = XDONT (1)
      Endif
      Do IDCR = NDON-1, 2, -1
         XWRK = XDONT(IDCR)
         IF (XWRK < XMIN) Then
            XDONT (IDCR) = XMIN
            XMIN = XWRK
         End If
      End Do
      XDONT (1) = XMIN
!
! The first value is now the minimum
! Loop over the array, and when a value is smaller than
! the previous one, loop down to insert it at its right place.
!
      Do ICRS = 3, NDON
         XWRK = XDONT (ICRS)
         IDCR = ICRS - 1
         If (XWRK < XDONT(IDCR)) Then
            XDONT (ICRS) = XDONT (IDCR)
            IDCR = IDCR - 1
            Do
               If (XWRK >= XDONT(IDCR)) Exit
               XDONT (IDCR+1) = XDONT (IDCR)
               IDCR = IDCR - 1
            End Do
            XDONT (IDCR+1) = XWRK
         End If
      End Do
!
      Return
!
End Subroutine D_inssor

Subroutine R_inssor (XDONT)
!  Sorts XDONT into increasing order (Insertion sort)
! __________________________________________________________
!  This subroutine uses insertion sort. It does not use any
!  work array and is faster when XDONT is of very small size
!  (< 20), or already almost sorted, but worst case behavior
!  can happen fairly probably (initially inverse sorted).
!  In many cases, the quicksort or merge sort method is faster.
!  Michel Olagnon - Apr. 2000
! __________________________________________________________
! __________________________________________________________
! _________________________________________________________
      Real, Dimension (:), Intent (InOut) :: XDONT
! __________________________________________________________
      Real :: XWRK, XMIN
!
! __________________________________________________________
!
      Integer :: ICRS, IDCR, NDON
!
      NDON = Size (XDONT)
!
! We first bring the minimum to the first location in the array.
! That way, we will have a "guard", and when looking for the
! right place to insert a value, no loop test is necessary.
!
      If (XDONT (1) < XDONT (NDON)) Then
          XMIN = XDONT (1)
      Else
          XMIN = XDONT (NDON)
          XDONT (NDON) = XDONT (1)
      Endif
      Do IDCR = NDON-1, 2, -1
         XWRK = XDONT(IDCR)
         IF (XWRK < XMIN) Then
            XDONT (IDCR) = XMIN
            XMIN = XWRK
         End If
      End Do
      XDONT (1) = XMIN
!
! The first value is now the minimum
! Loop over the array, and when a value is smaller than
! the previous one, loop down to insert it at its right place.
!
      Do ICRS = 3, NDON
         XWRK = XDONT (ICRS)
         IDCR = ICRS - 1
         If (XWRK < XDONT(IDCR)) Then
            XDONT (ICRS) = XDONT (IDCR)
            IDCR = IDCR - 1
            Do
               If (XWRK >= XDONT(IDCR)) Exit
               XDONT (IDCR+1) = XDONT (IDCR)
               IDCR = IDCR - 1
            End Do
            XDONT (IDCR+1) = XWRK
         End If
      End Do
!
      Return
!
End Subroutine R_inssor
Subroutine I_inssor (XDONT)
!  Sorts XDONT into increasing order (Insertion sort)
! __________________________________________________________
!  This subroutine uses insertion sort. It does not use any
!  work array and is faster when XDONT is of very small size
!  (< 20), or already almost sorted, but worst case behavior
!  can happen fairly probably (initially inverse sorted).
!  In many cases, the quicksort or merge sort method is faster.
!  Michel Olagnon - Apr. 2000
! __________________________________________________________
! __________________________________________________________
! __________________________________________________________
      Integer, Dimension (:), Intent (InOut)  :: XDONT
! __________________________________________________________
      Integer :: XWRK, XMIN
!
! __________________________________________________________
!
      Integer :: ICRS, IDCR, NDON
!
      NDON = Size (XDONT)
!
! We first bring the minimum to the first location in the array.
! That way, we will have a "guard", and when looking for the
! right place to insert a value, no loop test is necessary.
!
      If (XDONT (1) < XDONT (NDON)) Then
          XMIN = XDONT (1)
      Else
          XMIN = XDONT (NDON)
          XDONT (NDON) = XDONT (1)
      Endif
      Do IDCR = NDON-1, 2, -1
         XWRK = XDONT(IDCR)
         IF (XWRK < XMIN) Then
            XDONT (IDCR) = XMIN
            XMIN = XWRK
         End If
      End Do
      XDONT (1) = XMIN
!
! The first value is now the minimum
! Loop over the array, and when a value is smaller than
! the previous one, loop down to insert it at its right place.
!
      Do ICRS = 3, NDON
         XWRK = XDONT (ICRS)
         IDCR = ICRS - 1
         If (XWRK < XDONT(IDCR)) Then
            XDONT (ICRS) = XDONT (IDCR)
            IDCR = IDCR - 1
            Do
               If (XWRK >= XDONT(IDCR)) Exit
               XDONT (IDCR+1) = XDONT (IDCR)
               IDCR = IDCR - 1
            End Do
            XDONT (IDCR+1) = XWRK
         End If
      End Do
!
      Return
!
End Subroutine I_inssor
end module m_inssor


! This module treats data from population synthesis code and applies
! criterion from Limoges et al. 2015
module synthetic
    use, intrinsic :: iso_fortran_env, dp=>real64
    use files, only: getNumberOfLines, &
                     getNewUnit
    use derived_types, only: Star
    use criterion, only: splitDataForUVWvsUVW, &
                         splitDataForUVWvsMbol
    use plot_uvw, only: plotUVWvsUVW
    use plot_mbol, only: plotUVWvsMbol
    use math, only: getSD
    implicit none

    private

    public :: treatSynthData

        character(len = *), parameter :: INPUT_PATH &
            = '/home/georgy/Documents/program/WD_population_40pc/output_data&
              &/boot_rowell_thin_1.out'
contains

    subroutine treatSynthData(limogesCriterionIsUsed)

        logical, intent(in) :: limogesCriterionIsUsed
        integer :: numberOfWDs, &
                   unitInput, &
                   i
        type (Star), dimension(:), allocatable :: whiteDwarfs
        real*8, dimension(22) :: inputData
        type (Star), dimension(:), allocatable :: sampleUvsV, &
                                                  sampleUvsW, &
                                                  sampleVvsW, &
                                                  sampleUvsMbol, &
                                                  sampleVvsMbol, &
                                                  sampleWvsMbol

        numberOfWDs = getNumberOfLines(INPUT_PATH)

        allocate(whiteDwarfs(numberOfWDs))

        print *, "Data from population synthesis code"
        print *, "Number of White Dwarfs:", numberOfWDs

        open(getNewUnit(unitInput), file = INPUT_PATH, status='old')

        do i = 1, numberOfWDs
            read(unitInput, *) inputData
            whiteDwarfs(i)%magnitude = inputData(4)
            whiteDwarfs(i)%rightAscension = inputData(10)
            whiteDwarfs(i)%declination = inputData(11)
            whiteDwarfs(i)%distance = inputData(12) * 1.d3  ! kpc to pc
            whiteDwarfs(i)%vel = inputData(20:22)
        end do

        call whiteDwarfs(:)%equatToGalact
        call whiteDwarfs(:)%galactToXYZ

        if (limogesCriterionIsUsed) then
            print *, "Limoges criterion is used"
            call splitDataForUVWvsUVW(whiteDwarfs, &
                                      sampleUvsV, &
                                      sampleUvsW, &
                                      sampleVvsW)
            call splitDataForUVWvsMbol(whiteDwarfs, &
                                       sampleUvsMbol, &
                                       sampleVvsMbol, &
                                       sampleWvsMbol)
            call plotUVWvsUVW(sampleUvsV, &
                              sampleUvsW, &
                              sampleVvsW, &
                              "synthetic")
            call plotUVWvsMbol(sampleUvsMbol, &
                               sampleVvsMbol, &
                               sampleWvsMbol, &
                               "synthetic")
            print *, "Average velocity components:", &
                sum(sampleUvsMbol(:)%vel(1)) / size(sampleUvsMbol), &
                sum(sampleVvsMbol(:)%vel(2)) / size(sampleVvsMbol), &
                sum(sampleWvsMbol(:)%vel(3)) / size(sampleWvsMbol)
            print *, "Standart deviations:        ", &
                getSD(sampleUvsMbol(:)%vel(1)), &
                getSD(sampleVvsMbol(:)%vel(2)), &
                getSD(sampleWvsMbol(:)%vel(3))
        else
            call plotUVWvsUVW(whiteDwarfs, "synthetic")
            call plotUVWvsMbol(whiteDwarfs, "synthetic")
            print *, "Average velocity components:", &
                sum(whiteDwarfs(:)%vel(1)) / size(whiteDwarfs), &
                sum(whiteDwarfs(:)%vel(2)) / size(whiteDwarfs), &
                sum(whiteDwarfs(:)%vel(3)) / size(whiteDwarfs)
            print *, "Standart deviations:        ", &
                getSD(whiteDwarfs(:)%vel(1)), &
                getSD(whiteDwarfs(:)%vel(2)), &
                getSD(whiteDwarfs(:)%vel(3))
        end if
    end subroutine
end module


!     Convert between lat/long and Arctic polar stereographic
!     coordinates for mixed tri/quads.
!     Input: <fname> (grid format); lat/long must be in degrees
!     Output: out_<fname>
!     Depths are not changed.
!     ifort -O2 -mcmodel=medium -CB -Bstatic -o arctic_stereo arctic_stereo.f90
      implicit real*8(a-h,o-z)
      character*70 fname
      dimension nm(4)

      pi=3.1415926
      print*, "Input file name:"
      read(*,'(a70)') fname
      print*, '1: from lat/long to stereo; -1: from stereo to lat/long:'
!'
      read*, ifl
      if(iabs(ifl).ne.1) then
        print*, "Incorrect input of ifl",ifl
        stop
      endif

      open(12,file=fname,status='old')
      open(13,file="out_"//fname,status='replace')
      read(12,*)
      read(12,*)ne,np
      write(13,*)
      write(13,*)ne,np
      do i=1,np
        read(12,*)j,xtmp,ytmp,dp
        call stereographic(ifl,xtmp,ytmp,xout,yout)
        write(13,'(i10,2(1x,f24.11),1x,e17.8)')j,xout,yout,dp
      enddo !i
      do i=1,ne
        read(12,*)j,k,nm(1:k)
        write(13,*)j,k,nm(1:k)
      enddo !i
      close(12)
      close(13)

      stop
      end

!     Polar stereographic projection
!     LOn/lat inputs/outputs in degrees
      subroutine stereographic(ifl,xin,yin,xout,yout)
      implicit real*8(a-h,o-z)
      parameter(re=6378206.4)
      parameter(pi=3.1415926)
      integer, intent(in) :: ifl
      real*8, intent(in) :: xin,yin
      real*8, intent(out) :: xout,yout

      if(ifl==1) then !lat/lon to stereo
        xin1=xin*pi/180 !lon
        yin1=yin*pi/180

        !3D frame
        xnd=re*cos(yin1)*cos(xin1)
        ynd=re*cos(yin1)*sin(xin1)
        znd=re*sin(yin1)

        if(re+znd==0.d0) then
          print*, 'STEREO: remove south pole,',xin,yin,znd
          stop
        endif
        xout=2*re*xnd/(re+znd) !meters
        yout=2*re*ynd/(re+znd)
      else !ifl=-1; stereo to lat/lon
        rlam=atan2(yin,xin) !radian
        tmp=2*re*cos(rlam)+xin
        if(tmp==0.d0) then
          print*, 'STEREO: south pole encountered,',tmp,xin,yin
          stop
        endif
        half_phi=atan((2*re*cos(rlam)-xin)/tmp)

        xout=rlam/pi*180
        yout=half_phi*2/pi*180
      endif

      return
      end


!##############################################################################
!# Tutorial 021a: Solve a simple nonlinear system using the Picard iteration
!##############################################################################
!# Solves the system
!#
!#    -Laplace(u) - u + u^3 = f
!#
!# with a Newton iteration.
!#
!# Applies the block assembly for the defect and the Picard matrix.
!# No usage of template matrices. Linear systems are solved using
!# the Gauss elimination.
!##############################################################################

module tutorial021a

  ! Include basic Feat-2 modules
  use fsystem
  use genoutput

  use triangulation
  use meshgeneration

  use derivatives
  use element
  use cubature
  use spatialdiscretisation
  use linearalgebra
  use linearsystemscalar
  use linearsystemblock
  use bilinearformevaluation

  use feevaluation2
  use blockmatassemblybase
  use blockmatassembly
  use blockmatassemblystdop

  use discretebc
  use bcassembly
  use meshregion
  use vectorfilters
  use matrixfilters

  use linearsolver
  use collection

  use ucd

  implicit none
  private

  public :: start_tutorial021a

contains

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

!<subroutine>

  subroutine fgetBoundaryValuesMR (Icomponents,rdiscretisation,rmeshRegion,&
      cinfoNeeded,Iwhere,Dwhere,Dcoords,Dvalues,rcollection)

!<description>
  ! Auxiliary function that returns values on the boundary.
!</description>

!<input>
  ! Component specifier.
  integer, dimension(:), intent(in) :: Icomponents

  ! Discretisation structure of the underlying equation.
  type(t_spatialDiscretisation), intent(in) :: rdiscretisation

  ! Mesh region that is currently being processed.
  type(t_meshRegion), intent(in) :: rmeshRegion

  ! The type of information, the routine should calculate.
  integer, intent(in) :: cinfoNeeded

  ! Information about the DOF to be processed
  integer, dimension(4), intent(in) :: Iwhere

  ! The coordinates of the point which is currently processed.
  real(DP), dimension(:), intent(in) :: Dwhere

  ! The coordinates of the point for which the boundary values are to be calculated.
  real(DP), dimension(:), intent(in) :: Dcoords
!</input>

!<inputoutput>
  ! Optional: A collection structure to provide additional information.
  type(t_collection), intent(inout), optional :: rcollection
!</inputoutput>

!<output>
  ! Dvalues(1) receives the calculated value on the boundary.
  real(DP), dimension(:), intent(out) :: Dvalues
!</output>

!</subroutine>

    ! Zero boundary values.
    Dvalues(1) = 0.0_DP

  end subroutine

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

!<subroutine>

  subroutine fcalcDefect(rvectorData,rassemblyData,rvectorAssembly,&
      npointsPerElement,nelements,revalVectors,rcollection)

!<description>
    ! Calculates the nonlinear defect.
!</description>

!<inputoutput>
    ! Vector data of all subvectors. The arrays p_Dentry of all subvectors
    ! have to be filled with data.
    type(t_bmaVectorData), dimension(:), intent(inout), target :: RvectorData
!</inputoutput>

!<input>
    ! Data necessary for the assembly. Contains determinants and
    ! cubature weights for the cubature,...
    type(t_bmaVectorAssemblyData), intent(in) :: rassemblyData

    ! Structure with all data about the assembly
    type(t_bmaVectorAssembly), intent(in) :: rvectorAssembly

    ! Number of points per element
    integer, intent(in) :: npointsPerElement

    ! Number of elements
    integer, intent(in) :: nelements

    ! Values of FEM functions automatically evaluated in the
    ! cubature points.
    type(t_fev2Vectors), intent(in) :: revalVectors

    ! User defined collection structure
    type(t_collection), intent(inout), target, optional :: rcollection
!</input>

!</subroutine>

    ! Local variables
    real(DP) :: dbasI, dbasIx, dbasIy, du, dux, duy, dx, dy, df
    integer :: iel, icubp, idofe
    real(DP), dimension(:,:), pointer :: p_DlocalVector
    real(DP), dimension(:,:,:,:), pointer :: p_DbasTest
    real(DP), dimension(:,:), pointer :: p_DcubWeight
    type(t_bmaVectorData), pointer :: p_rvectorData
    real(DP), dimension(:,:,:), pointer :: p_Dpoints
    real(DP), dimension(:,:,:), pointer :: p_Du

    ! Get cubature weights data
    p_DcubWeight => rassemblyData%p_DcubWeight

    ! Get the coordinates of the cubature points
    p_Dpoints => rassemblyData%revalElementSet%p_DpointsReal

    ! Get the data arrays of the subvector
    p_rvectorData => RvectorData(1)
    p_DlocalVector => p_rvectorData%p_Dentry
    p_DbasTest => p_rvectorData%p_DbasTest

    ! Function u in the cubature points
    p_Du => revalVectors%p_RvectorData(1)%p_Ddata

    ! Loop over the elements in the current set.
    do iel = 1,nelements

      ! Loop over all cubature points on the current element
      do icubp = 1,npointsPerElement

        ! Get the coordinates of the cubature point.
        dx = p_Dpoints(1,icubp,iel)
        dy = p_Dpoints(2,icubp,iel)

        ! Right-hand side f
        df = 100.0_DP*sin(2.0_DP*SYS_PI*dx)*sin(2.0_DP*SYS_PI*dy)

        ! Function value / derivative of u
        du  = p_Du(icubp,iel,DER_FUNC2D)
        dux = p_Du(icubp,iel,DER_DERIV2D_X)
        duy = p_Du(icubp,iel,DER_DERIV2D_Y)

        ! Outer loop over the DOF's i=1..ndof on our current element,
        ! which corresponds to the (test) basis functions Psi_i:
        do idofe=1,p_rvectorData%ndofTest

          ! Fetch the contributions of the (test) basis functions Psi_i
          ! into dbasI
          dbasI = p_DbasTest(idofe,DER_FUNC,icubp,iel)
          dbasIx = p_DbasTest(idofe,DER_DERIV2D_X,icubp,iel)
          dbasIy = p_DbasTest(idofe,DER_DERIV2D_Y,icubp,iel)

          ! Multiply the values of the basis functions
          ! (1st derivatives) by the cubature weight and sum up
          ! into the local vectors.
          !
          ! def  =  f - [-Laplace u - u + u^3]
          p_DlocalVector(idofe,iel) = p_DlocalVector(idofe,iel) + &
              p_DcubWeight(icubp,iel) * &
              ( df * dbasI  -  dux * dbasIx  -    duy * dbasIy  &
                            +   du * dbasI   -  du**3 * dbasI )

        end do ! idofe

      end do ! icubp

    end do ! iel

  end subroutine

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

!<subroutine>

  subroutine fcalcMatrix(RmatrixData,rassemblyData,rmatrixAssembly,&
      npointsPerElement,nelements,revalVectors,rcollection)

!<description>
    ! Calculates the Picard iteration matrix of the operator
    ! "F(u) = -Laplace(u) - u + u^3 - f".
!</description>

!<inputoutput>
    ! Matrix data of all matrices. The arrays p_Dentry of all submatrices
    ! have to be filled with data.
    type(t_bmaMatrixData), dimension(:,:), intent(inout), target :: RmatrixData
!</inputoutput>

!<input>
    ! Data necessary for the assembly. Contains determinants and
    ! cubature weights for the cubature,...
    type(t_bmaMatrixAssemblyData), intent(in) :: rassemblyData

    ! Structure with all data about the assembly
    type(t_bmaMatrixAssembly), intent(in) :: rmatrixAssembly

    ! Number of points per element
    integer, intent(in) :: npointsPerElement

    ! Number of elements
    integer, intent(in) :: nelements

    ! Values of FEM functions automatically evaluated in the
    ! cubature points.
    type(t_fev2Vectors), intent(in) :: revalVectors

    ! User defined collection structure
    type(t_collection), intent(inout), target, optional :: rcollection
!</input>

!</subroutine>

    real(DP) :: dbasI, dbasJ, du
    integer :: iel, icubp, idofe, jdofe
    real(DP), dimension(:,:,:), pointer :: p_DlocalMatrix11
    real(DP), dimension(:,:,:,:), pointer :: p_DbasTrial,p_DbasTest
    real(DP), dimension(:,:), pointer :: p_DcubWeight
    real(DP), dimension(:,:,:), pointer :: p_Du

    ! =====================================================
    ! We have the operator
    !
    !    F(u) = -Laplace(u) - u + u^3 - f
    !         = -Laplace(u) - u + u^2 u - f
    !         = G(u)u
    !
    ! with the Picard operator
    !
    !    G(u)v = -Laplace(v) - v + u^2 v - f
    !
    ! being linear in v for fixed u. Thus, the Picard iteration
    ! matrix reads
    !
    !    A(u) = -Laplace - M + " u^2*M "
    !
    ! with the last term understood as the matrix from the bilinear
    ! form "(u^2 phi_j, phi_i)".
    ! =====================================================

    ! Laplace
    call bma_docalc_laplace (RmatrixData,rassemblyData,rmatrixAssembly,&
      npointsPerElement,nelements,1.0_DP,1,1)

    ! Mass
    call bma_docalc_mass (RmatrixData,rassemblyData,rmatrixAssembly,&
      npointsPerElement,nelements,-1.0_DP,1,1)

    ! (u^2*phi_j, phi_i)
    p_DcubWeight => rassemblyData%p_DcubWeight
    p_DbasTrial => RmatrixData(1,1)%p_DbasTrial
    p_DbasTest => RmatrixData(1,1)%p_DbasTest
    p_DlocalMatrix11 => RmatrixData(1,1)%p_Dentry

    p_Du => revalVectors%p_RvectorData(1)%p_Ddata

    do iel = 1,nelements
      do icubp = 1,npointsPerElement
        du  = p_Du(icubp,iel,DER_FUNC2D)

        do idofe=1,RmatrixData(1,1)%ndofTest
          dbasI  = p_DbasTest(idofe,DER_FUNC2D,icubp,iel)

          do jdofe=1,RmatrixData(1,1)%ndofTrial
            dbasJ  = p_DbasTrial(jdofe,DER_FUNC2D,icubp,iel)

            p_DlocalMatrix11(jdofe,idofe,iel) = p_DlocalMatrix11(jdofe,idofe,iel) + &
                p_DcubWeight(icubp,iel) * du**2 * dbasJ*dbasI

          end do
        end do
      end do
    end do

  end subroutine

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

  subroutine start_tutorial021a

    ! Declare some variables.
    type(t_triangulation) :: rtriangulation
    type(t_spatialDiscretisation) :: rspatialDiscr
    type(t_blockDiscretisation) :: rblockDiscr
    type(t_matrixBlock) :: rmatrix
    type(t_vectorBlock) :: rdefect, rsolution, rtemp
    type(t_scalarCubatureInfo), target :: rcubatureInfo
    type(t_discreteBC) :: rdiscreteBC
    type(t_meshRegion) :: rmeshRegion
    type(t_ucdExport) :: rexport
    character(LEN=SYS_STRLEN) :: spostdir

    type(t_fev2Vectors) :: rcoeffVectors
    type(t_linsolNode), pointer :: p_rsolverNode
    integer :: ierror

    real(DP) :: depsRel,dresInit,dres
    integer :: ite

    ! Print a message
    call output_lbrk()
    call output_separator (OU_SEP_STAR)
    call output_line ("This is FEAT-2. Tutorial 021a")
    call output_separator (OU_SEP_MINUS)

    ! =================================
    ! Create a brick mesh
    ! =================================

    ! The mesh must always be in "standard" format.
    ! First create a 11x11-mesh on [0,1]x[0,1], then convert to standard.
    call meshgen_rectangular2DQuadMesh (rtriangulation, 0.0_DP, 1.0_DP, 0.0_DP, 1.0_DP, 10, 10)
    call tria_initStandardMeshFromRaw (rtriangulation)

    ! =================================
    ! Discretise with Q1.
    !
    ! Create a structure rspatialDiscr
    ! which describes the discretisation.
    ! We generate a 1x1 system with Q1.
    ! =================================

    ! Create a spatial discretisation with Q1
    call spdiscr_initDiscr_simple (rspatialDiscr,EL_Q1_2D,rtriangulation)

    ! Create a block discretisation with 1 block Q1.
    call spdiscr_initBlockDiscr (rblockDiscr,rtriangulation)
    call spdiscr_appendBlockComponent (rblockDiscr,rspatialDiscr)
    call spdiscr_commitBlockDiscr (rblockDiscr)

    ! =================================
    ! Assemble a matrix, a RHS and create
    ! an empty solution vector.
    ! =================================

    ! Use a Gauss 3x3 formula for the discretisation.
    call spdiscr_createDefCubStructure (rspatialDiscr,rcubatureInfo,CUB_GEN_AUTO_G3)

    ! -----------------------------------------------------
    ! Initialise a block matrix and block vectors
    ! corresponding to the block discretisation.
    call lsysbl_createMatrix (rblockDiscr,rmatrix)
    call lsysbl_createVector (rblockDiscr,rdefect)
    call lsysbl_createVector (rblockDiscr,rsolution)
    call lsysbl_createVector (rblockDiscr,rtemp)

    ! Create an empty matrix in block (1,1) in CSR format
    call bilf_createMatrixStructure (rmatrix,1,1,LSYSSC_MATRIX9)
    call lsysbl_allocEmptyMatrix (rmatrix)

    ! =================================
    ! Discretise boundary conditions
    ! =================================

    ! Initialise a boundary condition structure
    call bcasm_initDiscreteBC(rdiscreteBC)

    ! Get a mesh region for the complete boundary
    call mshreg_createFromNodalProp(rmeshRegion, rtriangulation, MSHREG_IDX_ALL)

    ! Discretise Dirichlet boundary conditions
    call bcasm_newDirichletBConMR (rblockDiscr, 1, rdiscreteBC, &
        rmeshRegion, fgetBoundaryValuesMR)

    call mshreg_done(rmeshregion)

    ! =================================
    ! Initialise linear solver
    ! =================================

    ! Create an UMFPACK solver.
    call linsol_initUMFPACK4 (p_rsolverNode)

    ! Attach the system matrix
    call linsol_setMatrix (p_rsolverNode, rmatrix)

    ! Symbolic factorisation
    call linsol_initStructure (p_rsolverNode, ierror)

    if (ierror .ne. LINSOL_ERR_NOERROR) then
      call output_line ("Error during symbolic factorisation.")
      call sys_halt()
    end if

    ! =================================
    ! Newton iteration
    ! =================================

    ! Nonlinear solution vector. Impose boundary conditions.
    call lsysbl_clearVector (rsolution)
    call vecfil_discreteBCsol (rsolution,rdiscreteBC)

    ! Relative stopping criterion
    depsrel = 1E-10_DP

    ! Current iteration counter
    ite = 0

    do
      ! =========================================
      ! Nonlinear defect
      ! =========================================
      call lsysbl_clearVector (rdefect)

      ! Evaluate solution + 1st derivative in the calculation of the RHS vector.
      ! The first derivative is necessary for -Laplace(u) in the RHS.
      call fev2_addVectorToEvalList (rcoeffVectors,rsolution%RvectorBlock(1),1)
      call bma_buildVector (rdefect,BMA_CALC_STANDARD,&
          fcalcDefect, revalVectors=rcoeffVectors,rcubatureInfo=rcubatureInfo)
      call fev2_releaseVectorList(rcoeffVectors)

      ! Boundary conditions in the defect vector
      call vecfil_discreteBCdef (rdefect,rdiscreteBC)

      ! =========================================
      ! Residual check
      ! =========================================

      ! Get the norm of the residual
      dres = lsysbl_vectorNorm (rdefect,LINALG_NORML2)

      if (ite .eq. 0) then
        dresInit = dres
      end if

      call output_line ("Ite "//trim(sys_siL(ite,10))//", ||RES|| = "//sys_sdEL(dres,10))

      ! Stopping criterion
      if (dres .le. dresInit * depsrel) exit

      ! We start the next iteration.
      ite = ite + 1

      ! =========================================
      ! Newton matrix of the operator
      ! =========================================
      call lsysbl_clearMatrix (rmatrix)

      ! Evaluate the solution (without derivative) during the calculation of
      ! the matrix. The solution is the nonlinearity.
      call fev2_addVectorToEvalList (rcoeffVectors,rsolution%RvectorBlock(1),0)
      call bma_buildMatrix (rmatrix,BMA_CALC_STANDARD,&
          fcalcMatrix, revalVectors=rcoeffVectors,rcubatureInfo=rcubatureInfo)
      call fev2_releaseVectorList(rcoeffVectors)

      ! Boundary conditions
      call matfil_discreteBC (rmatrix,rdiscreteBC)

      ! =========================================
      ! Solve the linear subproblem
      ! =========================================

      ! Initialise the data of the solver
      call linsol_initData (p_rsolverNode, ierror)
      if (ierror .ne. LINSOL_ERR_NOERROR) then
        call output_line("Matrix singular!",OU_CLASS_ERROR)
        call sys_halt()
      end if

      ! Solve the system or die trying
      call linsol_precondDefect (p_rsolverNode, rdefect)

      ! Release solver data and structure
      call linsol_doneData (p_rsolverNode)

      ! =========================================
      ! Update the nonlinear solution
      ! =========================================

      ! Update the nonlinear solution
      call lsysbl_vectorLinearComb (rdefect,rsolution,1.0_DP,1.0_DP)

      ! Re-impose boundary conditions -- to be on the safe side.
      call vecfil_discreteBCsol (rsolution,rdiscreteBC)

    end do

    ! =========================================
    ! Cleanup linear solver
    ! =========================================

    ! Symbolic data
    call linsol_doneStructure (p_rsolverNode)

    ! Remaining solver data
    call linsol_releaseSolver (p_rsolverNode)

    ! =================================
    ! Create output files
    ! =================================

    call output_line ("Writing postprocessing files...")

    ! Open / write / close; write the solution to a VTK file.
    if (sys_getenv_string("POSTDIR",spostdir)) then
      call ucd_startVTK (rexport,UCD_FLAG_STANDARD,rtriangulation,&
                       trim(spostdir)//"/tutorial021a.vtk")
    else
    call ucd_startVTK (rexport,UCD_FLAG_STANDARD,rtriangulation,&
                       "post/tutorial021a.vtk")
    end if

    call ucd_addVectorByVertex (rexport, "solution", &
        UCD_VAR_STANDARD, rsolution%RvectorBlock(1))
    call ucd_write (rexport)
    call ucd_release (rexport)

    ! =================================
    ! Cleanup
    ! =================================

    ! Release the BC
    call bcasm_releaseDiscreteBC(rdiscreteBC)

    ! Release the matrix/vectors
    call lsysbl_releaseMatrix (rmatrix)
    call lsysbl_releaseVector (rtemp)
    call lsysbl_releaseVector (rdefect)
    call lsysbl_releaseVector (rsolution)

    ! Release the discretisation
    call spdiscr_releaseBlockDiscr (rblockDiscr)
    call spdiscr_releaseDiscr (rspatialDiscr)

    ! Cubature done.
    call spdiscr_releaseCubStructure (rcubatureInfo)

    ! Release the triangulation
    call tria_done (rtriangulation)

  end subroutine

end module


      subroutine tdgeo(couple1,qu,kf,ne,k,ltyp,iv,nut,nfam)
      use kyparam
      use tfstk
      use ffs
      use ffs_pointer
      use tffitcode
      use mathfun
      implicit none
      integer*4 kf,ne,k,ltyp,iv,nut,nfam,ip,j,j1,j2,
     $     k1
      integer*4 kbe,kbg
      real*8 dtrans(36),dcod(6),dcod0(6),
     $     trans1(4,5),s,couple1,qu,theta,al,drj1,drj2,c1,c2,
     $     cost,sint,yr1,yr2,yr3,xr,dz1,dz2,dx3,dy3,dx,dy,
     $     dr1,dr2,dr3,v
      if(ne .eq. iorgr)then
        return
      endif
      if(ne .gt. iorgr .and. (k .ge. ne .or. k .lt. iorgr) .or.
     1   ne .lt. iorgr .and. (k .lt. ne .or. k .ge. iorgr))then
        return
      endif
      s=couple1*sign(1.d0,dble(ne-iorgr))
      if(ltyp .eq. 1)then
        if(kf .ge. mfitgx .and. kf .le. mfitgz)then
          qu=qu+s*geo(kf-mfitgx+1,3,k)
        endif
      elseif(ltyp .eq. icBEND)then
        if(iv .eq. ky_ANGL_BEND)then
          ip=idelc(k)
          theta=rlist(idval(ip)+5)
          if(kf .ge. mfitgx .and. kf .le. mfitgz)then
            al=rlist(idval(ip)+1)
            j=kf-mfitgx+1
            j1=mod(j,3)+1
            j2=6-j-j1
            drj1=geo(j1,4,ne)-geo(j1,4,k+1)
            drj2=geo(j2,4,ne)-geo(j2,4,k+1)
            v=rlist(latt(k)+2)
            if(v .eq. 0.d0)then
              c1=0.d0
              c2=-.5d0
            else
              c1=sinc(v)/v**2
              c2=(sin(v*.5d0)-v*cos(v*.5d0))*2.d0*sin(v*.5d0)/v**2
            endif
            if(theta .ne. 0.d0)then
              cost=cos(theta)
              sint=sin(theta)
              yr1=-cost*geo(j1,2,k)-sint*geo(j1,1,k)
              yr2=-cost*geo(j2,2,k)-sint*geo(j2,1,k)
              xr =cost*geo(j,1,k)-sint*geo(j,2,k)
            else
              yr1=-geo(j1,2,k)
              yr2=-geo(j2,2,k)
              xr =geo(j,1,k)
            endif
            qu=qu+(yr1*drj2-yr2*drj1
     1           +al*(c1*geo(j,3,k)+c2*xr))*s
          elseif(kf .ge. mfitchi1 .and. kf .le. mfitchi3)then
            if(theta .ne. 0.d0)then
              cost=cos(theta)
              sint=sin(theta)
              yr1=-cost*geo(1,2,k)-sint*geo(1,1,k)
              yr2=-cost*geo(2,2,k)-sint*geo(2,1,k)
              yr3=-cost*geo(3,2,k)-sint*geo(3,1,k)
            else
              yr1=-geo(1,2,k)
              yr2=-geo(2,2,k)
              yr3=-geo(3,2,k)
            endif
            select case (kf)
            case (mfitchi2)
              qu=qu+s*(yr1*geo(2,3,ne)-yr2*geo(1,3,ne))
     $             /hypot(geo(1,3,ne),geo(2,3,ne))
c     $             /sqrt(geo(1,3,ne)**2+geo(2,3,ne)**2)
            case (mfitchi1)
              dz1=-geo(2,3,ne)*yr3+geo(3,3,ne)*yr2
              dz2=-geo(3,3,ne)*yr1+geo(1,3,ne)*yr3
              qu=qu+(geo(1,3,ne)*dz2-geo(2,3,ne)*dz1)
     $             /(geo(1,3,ne)**2+geo(2,3,ne)**2)*s
            case default
              dx3=-geo(1,1,ne)*yr2+geo(2,1,ne)*yr1
              dy3=-geo(1,2,ne)*yr2+geo(2,2,ne)*yr1
              qu=qu+(-geo(3,2,ne)*dx3+geo(3,1,ne)*dy3)
     $             /(geo(3,1,ne)**2+geo(3,2,ne)**2)*s
            end select
          endif
        elseif(iv .eq. ky_L_BEND)then
          if(kf .ge. mfitgx .and. kf .le. mfitgz)then
            qu=qu+s*geo(kf-mfitgx+1,3,k+1)
          endif
        endif
      elseif(ltyp .le. icDODECA .or. ltyp .eq. icMULT)then
        call tfbndsol(k,kbg,kbe)
        if(kbe .ne. 0)then
          ip=idelc(k)
          dx=rlist(idval(ip)+kytbl(kwDX,ltyp))
          dy=rlist(idval(ip)+kytbl(kwDY,ltyp))
          k1=k+1
          call qdtrans(ltyp,itwissp(k),k,k1,
     $         iv,dtrans,dcod0,0,nfam,nut)
c      write(*,'(a,4i5,1p8g13.5)')'qdtrans ',k1,kbe,
c     $         itwissp(k),itwissp(kbe),
c     $         utwiss(mfitr1:mfitr4,0,itwissp(k1)),
c     $         utwiss(mfitr1:mfitr4,0,itwissp(kbe))
          call tftmatu(
     $         utwiss(1,0,itwissp(k1)),utwiss(1,0,itwissp(kbe)),
     $         0.d0,0.d0,
     $         trans1,k1,kbe,.false.,.false.)
          dcod(1:4)=trans1(1:4,1)*dcod0(1)+trans1(1:4,2)*dcod0(2)
     $             +trans1(1:4,3)*dcod0(3)+trans1(1:4,4)*dcod0(4)
          yr1=-dcod(4)*geo(1,1,kbe)+dcod(2)*geo(1,2,kbe)
          yr2=-dcod(4)*geo(2,1,kbe)+dcod(2)*geo(2,2,kbe)
          yr3=-dcod(4)*geo(3,1,kbe)+dcod(2)*geo(3,2,kbe)
          dr1=geo(1,4,ne)-geo(1,4,kbe)
          dr2=geo(2,4,ne)-geo(2,4,kbe)
          dr3=geo(3,4,ne)-geo(3,4,kbe)
          select case (kf)
          case (mfitgx)
            qu=qu+s*(-dr2*yr3+dr3*yr2
     $           +dcod(1)*geo(1,1,kbe)+dcod(3)*geo(1,2,kbe))
          case (mfitgy)
            qu=qu+s*(-dr3*yr1+dr1*yr3
     $           +dcod(1)*geo(2,1,kbe)+dcod(3)*geo(2,2,kbe))
          case (mfitgz)
            qu=qu+s*(-dr1*yr2+dr2*yr1
     $           +dcod(1)*geo(3,1,kbe)+dcod(3)*geo(3,2,kbe))
          case (mfitchi2)
            qu=qu+s*(yr1*geo(2,3,ne)-yr2*geo(1,3,ne))
     $           /hypot(geo(1,3,ne),geo(2,3,ne))
c     $           /sqrt(geo(1,3,ne)**2+geo(2,3,ne)**2)
          case (mfitchi1)
            dz1=-geo(2,3,ne)*yr3+geo(3,3,ne)*yr2
            dz2=-geo(3,3,ne)*yr1+geo(1,3,ne)*yr3
            qu=qu+(geo(1,3,ne)*dz2-geo(2,3,ne)*dz1)
     $           /(geo(1,3,ne)**2+geo(2,3,ne)**2)*s
          case default
            dx3=-geo(1,1,ne)*yr2+geo(2,1,ne)*yr1
            dy3=-geo(1,2,ne)*yr2+geo(2,2,ne)*yr1
            qu=qu+(-geo(3,2,ne)*dx3+geo(3,1,ne)*dy3)
     $           /(geo(3,1,ne)**2+geo(3,2,ne)**2)*s
          end select
        endif
      endif
      return
      end


c###cngtim.for
      FUNCTION CNGTIM(TIME,XTHETA,ISW)
C--------------------------------
C     /////////////////////////////////////////////
C
C     IF ISW=1
C     THIS FUNCTION CONVERTS UNIVERSAL TIME (TIME GREATER THAN
C     OR EQUAL TO ZERO BUT LESS THAN 24) IN HOURS TO LOCAL TIME
C     AT LOCAL REFRENCE LONGITUDE (THETA GREATER THAN OR EQUAL
C     TO ZERO AND LESS THAN OR EQUAL TO 360 DEGREES) IN DEGREES EAST
C
C
C     IF ISW=-1
C     THIS FUNCTION CONVERTS LOCAL TIME (TIME GREATER THAN
C     OR EQUAL TO ZERO BUT LESS THAN 24)
C     AT LOCAL REFRENCE LONGITUDE (THETA GREATER THAN OR EQUAL
C     TO ZERO AND LESS THAN OR EQUAL TO 360 DEGREES) IN DEGREES EAST
C     TO UNIVERSAL TIME
C
C
C     FUNCTION VALUE IS ZERO IF THERE IS NO DAY CHANGE
C
C     FUNCTION VALUE IS 1 IF THE DAY SHOULD BE ADVANCED
C
C     FUNCTION VALUE IS -1 IF THE DAY SHOULD BE RETARDED
C
C     /////////////////////////////////////////////
      IF(XTHETA) 80,75,85
   75 CNGTIM=0
      RETURN
   80  THETA=360. + XTHETA
      GO TO 90
   85 THETA=XTHETA
   90  CONTINUE
C
C     THE FUNCTION STARTS HERE
C
      INT1 = THETA / 180.
      INT2 = THETA / 360.
      FINT1 = INT1
      FINT2 = INT2
      FISW = ISW
      TIME = TIME + FISW * (THETA / 15.0 - FINT1 * 24. + FINT2 * 24.)
      INT1 = (TIME - 23.99999999) / 24.0
      INT2 = TIME / 24.0
      CNGTIM = INT1 + INT2
      IF (TIME)100, 105, 105
  100 TIME = TIME + 24.
  105 TIME = TIME - FINT2 * 24.
  110 IF(TIME) 115, 120, 120
  115 TIME = TIME + 24.
      GO TO 110
  120 IF(TIME - 24.) 130, 130, 125
  125 TIME = TIME - 24.
      GO TO 110
  130 CONTINUE
      RETURN
      END
C--------------------------------


      subroutine evolve_eqrpsi(n_a1,n_alpha,n_beta,n_rPHI,n_rPI,n_rpsi,n
     &p1_a1,np1_alpha,np1_beta,np1_rPHI,np1_rPI,np1_rpsi,x,Nx,ht,myzero,
     &zepsdis,phys_bdy,res)
      implicit none
      integer i
      integer Nx
      real*8 ht
      real*8 myzero
      real*8 zepsdis
      real*8 n_a1(Nx)
      real*8 n_alpha(Nx)
      real*8 n_beta(Nx)
      real*8 n_rPHI(Nx)
      real*8 n_rPI(Nx)
      real*8 n_rpsi(Nx)
      real*8 np1_a1(Nx)
      real*8 np1_alpha(Nx)
      real*8 np1_beta(Nx)
      real*8 np1_rPHI(Nx)
      real*8 np1_rPI(Nx)
      real*8 np1_rpsi(Nx)
      real*8 x(Nx)
      integer phys_bdy(2)
      real*8 res(Nx)
      real*8 qb
      if (phys_bdy(1) .eq. 1) then
      do i=1, 1, 1
      qb = 0.1333333333333333D1 * np1_rpsi(i + 1) - 0.3333333333333333D0
     # * np1_rpsi(i + 2)
      res(i)=qb
      end do
      endif
      if (phys_bdy(1) .eq. 1) then
      do i=2, 2, 1
      qb = np1_rpsi(i) - 0.32D2 / (0.32D2 + 0.7D1 * zepsdis) * ht * ((-0
     #.1D1 * n_rpsi(i) + np1_rpsi(i)) / ht - 0.5000000000000000D0 * np1_
     #alpha(i) / np1_a1(i) * np1_rPI(i) - 0.5000000000000000D0 * np1_bet
     #a(i) * np1_rPHI(i) - 0.5000000000000000D0 * n_alpha(i) / n_a1(i) *
     # n_rPI(i) - 0.5000000000000000D0 * n_beta(i) * n_rPHI(i) + 0.31250
     #00000000000D-1 * zepsdis / ht * (0.7D1 * np1_rpsi(i) + np1_rpsi(i
     #+ 2) - 0.4D1 * np1_rpsi(i + 1) - 0.4D1 * np1_rpsi(i - 1)) + 0.3125
     #000000000000D-1 * zepsdis / ht * (0.7D1 * n_rpsi(i) + n_rpsi(i + 2
     #) - 0.4D1 * n_rpsi(i + 1) - 0.4D1 * n_rpsi(i - 1)))
      res(i)=qb
      end do
      endif
      do i=3, Nx-2, 1
      qb = np1_rpsi(i) - 0.16D2 / (0.16D2 + 0.3D1 * zepsdis) * ht * ((-0
     #.1D1 * n_rpsi(i) + np1_rpsi(i)) / ht - 0.5000000000000000D0 * np1_
     #alpha(i) / np1_a1(i) * np1_rPI(i) - 0.5000000000000000D0 * np1_bet
     #a(i) * np1_rPHI(i) - 0.5000000000000000D0 * n_alpha(i) / n_a1(i) *
     # n_rPI(i) - 0.5000000000000000D0 * n_beta(i) * n_rPHI(i) + 0.31250
     #00000000000D-1 * zepsdis / ht * (0.6D1 * np1_rpsi(i) + np1_rpsi(i
     #+ 2) + np1_rpsi(i - 2) - 0.4D1 * np1_rpsi(i + 1) - 0.4D1 * np1_rps
     #i(i - 1)) + 0.3125000000000000D-1 * zepsdis / ht * (0.6D1 * n_rpsi
     #(i) + n_rpsi(i + 2) + n_rpsi(i - 2) - 0.4D1 * n_rpsi(i + 1) - 0.4D
     #1 * n_rpsi(i - 1)))
      res(i)=qb
      end do
      do i=Nx-1, Nx-1, 1
      qb = np1_rpsi(i) - 0.1D1 * ht * ((-0.1D1 * n_rpsi(i) + np1_rpsi(i)
     #) / ht - 0.5000000000000000D0 * np1_alpha(i) / np1_a1(i) * np1_rPI
     #(i) - 0.5000000000000000D0 * np1_beta(i) * np1_rPHI(i) - 0.5000000
     #000000000D0 * n_alpha(i) / n_a1(i) * n_rPI(i) - 0.5000000000000000
     #D0 * n_beta(i) * n_rPHI(i))
      res(i)=qb
      end do
      if (phys_bdy(2) .eq. 1) then
      do i=Nx, Nx, 1
      qb = np1_rpsi(i) - 0.1D1 * ht * ((-0.1D1 * n_rpsi(i) + np1_rpsi(i)
     #) / ht - 0.1D1 * myzero * x(i))
      res(i)=qb
      end do
      endif
      END


!
! Copyright (C) 2001-2007 Quantum ESPRESSO group
! This file is distributed under the terms of the
! GNU General Public License. See the file `License'
! in the root directory of the present distribution,
! or http://www.gnu.org/copyleft/gpl.txt .
!
!
#define ZERO ( 0.D0, 0.D0 )
#define ONE  ( 1.D0, 0.D0 )
!
!----------------------------------------------------------------------------
SUBROUTINE ccgdiagg( npwx, npw, nbnd, npol, psi, e, btype, precondition, &
                     ethr, maxter, reorder, notconv, avg_iter )
  !----------------------------------------------------------------------------
  !
  ! ... "poor man" iterative diagonalization of a complex hermitian matrix
  ! ... through preconditioned conjugate gradient algorithm
  ! ... Band-by-band algorithm with minimal use of memory
  ! ... Calls h_1psi and s_1psi to calculate H|psi> and S|psi>
  ! ... Works for generalized eigenvalue problem (US pseudopotentials) as well
  !
  USE constants,        ONLY : pi
  USE kinds,            ONLY : DP
  USE mp_global,        ONLY : intra_bgrp_comm
  USE mp,               ONLY : mp_sum
  !
  IMPLICIT NONE
  !
  ! ... I/O variables
  !
  INTEGER,     INTENT(IN)    :: npwx, npw, nbnd, npol, maxter
  INTEGER,     INTENT(IN)    :: btype(nbnd)
  REAL(DP),    INTENT(IN)    :: precondition(npwx*npol), ethr
  COMPLEX(DP), INTENT(INOUT) :: psi(npwx*npol,nbnd)
  REAL(DP),    INTENT(INOUT) :: e(nbnd)
  INTEGER,     INTENT(OUT)   :: notconv
  REAL(DP),    INTENT(OUT)   :: avg_iter
  !
  ! ... local variables
  !
  INTEGER                  :: i, j, m, iter, moved
  COMPLEX(DP), ALLOCATABLE :: hpsi(:), spsi(:), lagrange(:), &
                              g(:), cg(:), scg(:), ppsi(:), g0(:)
  REAL(DP)                 :: psi_norm, a0, b0, gg0, gamma, gg, gg1, &
                              cg0, e0, es(2)
  REAL(DP)                 :: theta, cost, sint, cos2t, sin2t
  LOGICAL                  :: reorder
  INTEGER                  :: kdim, kdmx, kdim2
  REAL(DP)                 :: empty_ethr, ethr_m
  !
  ! ... external functions
  !
  REAL (DP), EXTERNAL :: ddot
  !
  !
  CALL start_clock( 'ccgdiagg' )
  !
  empty_ethr = MAX( ( ethr * 5.D0 ), 1.D-5 )
  !
  IF ( npol == 1 ) THEN
     !
     kdim = npw
     kdmx = npwx
     !
  ELSE
     !
     kdim = npwx * npol
     kdmx = npwx * npol
     !
  END IF
  !
  kdim2 = 2 * kdim
  !
  ALLOCATE( spsi( kdmx ) )
  ALLOCATE( scg(  kdmx ) )
  ALLOCATE( hpsi( kdmx ) )
  ALLOCATE( g(    kdmx ) )
  ALLOCATE( cg(   kdmx ) )
  ALLOCATE( g0(   kdmx ) )
  ALLOCATE( ppsi( kdmx ) )
  !
  ALLOCATE( lagrange( nbnd ) )
  !
  avg_iter = 0.D0
  notconv  = 0
  moved    = 0
  !
  ! ... every eigenfunction is calculated separately
  !
  DO m = 1, nbnd
     !
     IF ( btype(m) == 1 ) THEN
        !
        ethr_m = ethr
        !
     ELSE
        !
        ethr_m = empty_ethr
        !
     END IF
     !
     spsi     = ZERO
     scg      = ZERO
     hpsi     = ZERO
     g        = ZERO
     cg       = ZERO
     g0       = ZERO
     ppsi     = ZERO
     lagrange = ZERO
     !
     ! ... calculate S|psi>
     !
     CALL s_1psi( npwx, npw, psi(1,m), spsi )
     !
     ! ... orthogonalize starting eigenfunction to those already calculated
     !
     CALL ZGEMV( 'C', kdim, m, ONE, psi, kdmx, spsi, 1, ZERO, lagrange, 1 )
     !
     CALL mp_sum( lagrange( 1:m ), intra_bgrp_comm )
     !
     psi_norm = DBLE( lagrange(m) )
     !
     DO j = 1, m - 1
        !
        psi(:,m)  = psi(:,m) - lagrange(j) * psi(:,j)
        !
        psi_norm = psi_norm - &
                   ( DBLE( lagrange(j) )**2 + AIMAG( lagrange(j) )**2 )
        !
     END DO
     !
     psi_norm = SQRT( psi_norm )
     !
     psi(:,m) = psi(:,m) / psi_norm
     !
     ! ... calculate starting gradient (|hpsi> = H|psi>) ...
     !
     CALL h_1psi( npwx, npw, psi(1,m), hpsi, spsi )
     !
     ! ... and starting eigenvalue (e = <y|PHP|y> = <psi|H|psi>)
     !
     ! ... NB:  ddot(2*npw,a,1,b,1) = REAL( zdotc(npw,a,1,b,1) )
     !
     e(m) = ddot( kdim2, psi(1,m), 1, hpsi, 1 )
     !
     CALL mp_sum( e(m), intra_bgrp_comm )
     !
     ! ... start iteration for this band
     !
     iterate: DO iter = 1, maxter
        !
        ! ... calculate  P (PHP)|y>
        ! ... ( P = preconditioning matrix, assumed diagonal )
        !
        g(:)    = hpsi(:) / precondition(:)
        ppsi(:) = spsi(:) / precondition(:)
        !
        ! ... ppsi is now S P(P^2)|y> = S P^2|psi>)
        !
        es(1) = ddot( kdim2, spsi(1), 1, g(1), 1 )
        es(2) = ddot( kdim2, spsi(1), 1, ppsi(1), 1 )
        !
        CALL mp_sum( es , intra_bgrp_comm )
        !
        es(1) = es(1) / es(2)
        !
        g(:) = g(:) - es(1) * ppsi(:)
        !
        ! ... e1 = <y| S P^2 PHP|y> / <y| S S P^2|y> ensures that
        ! ... <g| S P^2|y> = 0
        ! ... orthogonalize to lowest eigenfunctions (already calculated)
        !
        ! ... scg is used as workspace
        !
        CALL s_1psi( npwx, npw, g(1), scg(1) )
        !
        CALL ZGEMV( 'C', kdim, ( m - 1 ), ONE, psi, &
                    kdmx, scg, 1, ZERO, lagrange, 1  )
        !
        CALL mp_sum( lagrange( 1:m-1 ), intra_bgrp_comm )
        !
        DO j = 1, ( m - 1 )
           !
           g(:)   = g(:)   - lagrange(j) * psi(:,j)
           scg(:) = scg(:) - lagrange(j) * psi(:,j)
           !
        END DO
        !
        IF ( iter /= 1 ) THEN
           !
           ! ... gg1 is <g(n+1)|S|g(n)> (used in Polak-Ribiere formula)
           !
           gg1 = ddot( kdim2, g(1), 1, g0(1), 1 )
           !
           CALL mp_sum( gg1, intra_bgrp_comm )
           !
        END IF
        !
        ! ... gg is <g(n+1)|S|g(n+1)>
        !
        g0(:) = scg(:)
        !
        g0(:) = g0(:) * precondition(:)
        !
        gg = ddot( kdim2, g(1), 1, g0(1), 1 )
        !
        CALL mp_sum( gg, intra_bgrp_comm )
        !
        IF ( iter == 1 ) THEN
           !
           ! ... starting iteration, the conjugate gradient |cg> = |g>
           !
           gg0 = gg
           !
           cg(:) = g(:)
           !
        ELSE
           !
           ! ... |cg(n+1)> = |g(n+1)> + gamma(n) * |cg(n)>
           !
           ! ... Polak-Ribiere formula :
           !
           gamma = ( gg - gg1 ) / gg0
           gg0   = gg
           !
           cg(:) = cg(:) * gamma
           cg(:) = g + cg(:)
           !
           ! ... The following is needed because <y(n+1)| S P^2 |cg(n+1)>
           ! ... is not 0. In fact :
           ! ... <y(n+1)| S P^2 |cg(n)> = sin(theta)*<cg(n)|S|cg(n)>
           !
           psi_norm = gamma * cg0 * sint
           !
           cg(:) = cg(:) - psi_norm * psi(:,m)
           !
        END IF
        !
        ! ... |cg> contains now the conjugate gradient
        !
        ! ... |scg> is S|cg>
        !
        CALL h_1psi( npwx, npw, cg(1), ppsi(1), scg(1) )
        !
        cg0 = ddot( kdim2, cg(1), 1, scg(1), 1 )
        !
        CALL mp_sum(  cg0 , intra_bgrp_comm )
        !
        cg0 = SQRT( cg0 )
        !
        ! ... |ppsi> contains now HP|cg>
        ! ... minimize <y(t)|PHP|y(t)> , where :
        ! ...                         |y(t)> = cos(t)|y> + sin(t)/cg0 |cg>
        ! ... Note that  <y|P^2S|y> = 1, <y|P^2S|cg> = 0 ,
        ! ...           <cg|P^2S|cg> = cg0^2
        ! ... so that the result is correctly normalized :
        ! ...                           <y(t)|P^2S|y(t)> = 1
        !
        a0 = 2.D0 * ddot( kdim2, psi(1,m), 1, ppsi(1), 1 ) / cg0
        !
        CALL mp_sum(  a0 , intra_bgrp_comm )
        !
        b0 = ddot( kdim2, cg(1), 1, ppsi(1), 1 ) / cg0**2
        !
        CALL mp_sum(  b0 , intra_bgrp_comm )
        !
        e0 = e(m)
        !
        theta = 0.5D0 * ATAN( a0 / ( e0 - b0 ) )
        !
        cost = COS( theta )
        sint = SIN( theta )
        !
        cos2t = cost*cost - sint*sint
        sin2t = 2.D0*cost*sint
        !
        es(1) = 0.5D0 * (   ( e0 - b0 ) * cos2t + a0 * sin2t + e0 + b0 )
        es(2) = 0.5D0 * ( - ( e0 - b0 ) * cos2t - a0 * sin2t + e0 + b0 )
        !
        ! ... there are two possible solutions, choose the minimum
        !
        IF ( es(2) < es(1) ) THEN
           !
           theta = theta + 0.5D0 * pi
           !
           cost = COS( theta )
           sint = SIN( theta )
           !
        END IF
        !
        ! ... new estimate of the eigenvalue
        !
        e(m) = MIN( es(1), es(2) )
        !
        ! ... upgrade |psi>
        !
        psi(:,m) = cost * psi(:,m) + sint / cg0 * cg(:)
        !
        ! ... here one could test convergence on the energy
        !
        IF ( ABS( e(m) - e0 ) < ethr_m ) EXIT iterate
        !
        ! ... upgrade H|psi> and S|psi>
        !
        spsi(:) = cost * spsi(:) + sint / cg0 * scg(:)
        !
        hpsi(:) = cost * hpsi(:) + sint / cg0 * ppsi(:)
        !
     END DO iterate
     !
     IF ( iter >= maxter ) notconv = notconv + 1
     !
     avg_iter = avg_iter + iter + 1
     !
     ! ... reorder eigenvalues if they are not in the right order
     ! ... ( this CAN and WILL happen in not-so-special cases )
     !
     IF ( m > 1 .AND. reorder ) THEN
        !
        IF ( e(m) - e(m-1) < - 2.D0 * ethr_m ) THEN
           !
           ! ... if the last calculated eigenvalue is not the largest...
           !
           DO i = m - 2, 1, - 1
              !
              IF ( e(m) - e(i) > 2.D0 * ethr_m ) EXIT
              !
           END DO
           !
           i = i + 1
           !
           moved = moved + 1
           !
           ! ... last calculated eigenvalue should be in the
           ! ... i-th position: reorder
           !
           e0 = e(m)
           !
           ppsi(:) = psi(:,m)
           !
           DO j = m, i + 1, - 1
              !
              e(j) = e(j-1)
              !
              psi(:,j) = psi(:,j-1)
              !
           END DO
           !
           e(i) = e0
           !
           psi(:,i) = ppsi(:)
           !
           ! ... this procedure should be good if only a few inversions occur,
           ! ... extremely inefficient if eigenvectors are often in bad order
           ! ... ( but this should not happen )
           !
        END IF
        !
     END IF
     !
  END DO
  !
  avg_iter = avg_iter / DBLE( nbnd )
  !
  DEALLOCATE( lagrange )
  DEALLOCATE( ppsi )
  DEALLOCATE( g0 )
  DEALLOCATE( cg )
  DEALLOCATE( g )
  DEALLOCATE( hpsi )
  DEALLOCATE( scg )
  DEALLOCATE( spsi )
  !
  CALL stop_clock( 'ccgdiagg' )
  !
  RETURN
  !
END SUBROUTINE ccgdiagg


      FUNCTION bnldev(pp,n,idum)

      implicit none
      INTEGER idum,n
      REAL*8 bnldev,pp,PI
CU    USES gammln,ran1
      PARAMETER (PI=3.141592654d0)
      INTEGER j,nold
      REAL*8 am,em,en,g,oldg,p,pc,pclog,plog,pold,sq,t,y,gammln,ran1
      SAVE nold,pold,pc,plog,pclog,en,oldg
      DATA nold /-1/, pold /-1.0d0/

      if(pp.le.0.5)then
        p=pp
      else
        p=1.-pp
      endif
      am=n*p
      if (n.lt.25)then
        bnldev=0.
        do 11 j=1,n
          if(ran1(idum).lt.p)bnldev=bnldev+1.
11      continue
      else if (am.lt.1.) then
        g=exp(-am)
        t=1.
        do 12 j=0,n
          t=t*ran1(idum)
          if (t.lt.g) goto 1
12      continue
        j=n
1       bnldev=j
      else
        if (n.ne.nold) then
          en=n
          oldg=gammln(en+1.)
          nold=n
        endif
        if (abs(p-pold) > 1.0e-8) then
          pc=1.-p
          plog=log(p)
          pclog=log(pc)
          pold=p
        endif
        sq=sqrt(2.*am*pc)
2       y=tan(PI*ran1(idum))
        em=sq*y+am
        if (em.lt.0..or.em.ge.en+1.) goto 2
        em=int(em)
        t=1.2*sq*(1.+y**2)*exp(oldg-gammln(em+1.)-gammln(en-em+1.)+em*
     *plog+(en-em)*pclog)
        if (ran1(idum).gt.t) goto 2
        bnldev=em
      endif
      if (abs(p-pp) > 1.0e-8) bnldev=dble(n)-bnldev
      return
      END

      FUNCTION ran1(idum)
      INTEGER idum,IA,IM,IQ,IR,NTAB,NDIV
      REAL*8 ran1,AM,EPS,RNMX
      PARAMETER (IA=16807,IM=2147483647,AM=1./IM,IQ=127773,IR=2836,
     *NTAB=32,NDIV=1+(IM-1)/NTAB,EPS=1.2e-7,RNMX=1.-EPS)
      INTEGER j,k,iv(NTAB),iy
      SAVE iv,iy
      DATA iv /NTAB*0/, iy /0/
      if (idum.le.0.or.iy.eq.0) then
        idum=max(-idum,1)
        do 11 j=NTAB+8,1,-1
          k=idum/IQ
          idum=IA*(idum-k*IQ)-IR*k
          if (idum.lt.0) idum=idum+IM
          if (j.le.NTAB) iv(j)=idum
11      continue
        iy=iv(1)
      endif
      k=idum/IQ
      idum=IA*(idum-k*IQ)-IR*k
      if (idum.lt.0) idum=idum+IM
      j=1+iy/NDIV
      iy=iv(j)
      iv(j)=idum
      ran1=min(AM*iy,RNMX)
      return
      END

      FUNCTION gammln(xx)
      REAL*8 gammln,xx
      INTEGER j
      REAL*8 ser,stp,tmp,x,y,cof(6)
      SAVE cof,stp
      DATA cof,stp/76.18009172947146d0,-86.50532032941677d0,
     *24.01409824083091d0,-1.231739572450155d0,.1208650973866179d-2,
     *-.5395239384953d-5,2.5066282746310005d0/
      x=xx
      y=x
      tmp=x+5.5d0
      tmp=(x+0.5d0)*log(tmp)-tmp
      ser=1.000000000190015d0
      do 11 j=1,6
        y=y+1.d0
        ser=ser+cof(j)/y
11    continue
      gammln=tmp+log(stp*ser/x)
      return
      END


!> IMPACT
!! \author Rolf Henniger, Institute of Fluid Dynamics, ETH Zurich (henniger@ifd.mavt.ethz.ch)
!! \date Mai 2005 - Dec 2011

!> \brief module
module cmod_DivGrad2ndOOp

  use iso_c_binding

  implicit none

contains

  subroutine Op_getCDG_dir( &
      M,                    &
      N,                    &
      BL,                   &
      BU,                   &
      BCL,                  &
      BCU,                  &
      yu,                   &
      xp,                   &
      xu,                   &
      cDG ) bind( c, name='Op_getCDG_dir' )

    implicit none

    integer(c_int), intent(in)    :: M

    integer(c_int), intent(in)    :: N

    integer(c_int), intent(in)    :: BL
    integer(c_int), intent(in)    :: BU

    integer(c_int), intent(in)    :: BCL
    integer(c_int), intent(in)    :: BCU

    real(c_double), intent(in)    :: yu(0:M)

    real(c_double), intent(in)    :: xp(bl:N+bu)

    real(c_double), intent(in)    :: xu(bl:N+bu)

    real(c_double), intent(inout) :: cDG(-1:1,1:N)

    real(c_double)                :: cGp( 0:1,0:N)

    real(c_double)                :: cDu(-1:0,1:N)

    integer(c_int)                :: i

    cDG = 0.

    cGp = 0.
    cDu = 0.

    !---------------------------------------------------------------------------!
    ! Achtung: Falls nicht periodisch, wird hier am Rand ein Fehler gemacht,    !
    !          der nur über die Sonderbehandlung weiter unten korrigiert wird!  !
    !---------------------------------------------------------------------------!

    do i = 0, N
      cGp(0,i) = -1./( xp(i+1) - xp(i) )
      cGp(1,i) =  1./( xp(i+1) - xp(i) )
    end do

    do i = 1, N
      cDu(-1,i) = -1./( xu(i) - xu(i-1) )
      cDu( 0,i) =  1./( xu(i) - xu(i-1) )
    end do

    if( BCL > 0 ) then
      cGp(:,0) = 0.
      cDu(:,1) = 0.
      cDu(0,1) = 1./( yu(1) - yu(0) ) ! TEST!!! Der Schoenheit halber, s.u.
      !cDu(0,1) = 1./( xp(2) - xp(1) ) ! TEST!!! Der Schoenheit halber, s.u.
      !cDu(0,1) =  1./(xu(1) - xu (0)) !! shoudl be the same
    end if

    if( BCU > 0 ) then
      cGp(:,N) =  0.
      cDu(:,N) =  0.
      cDu(-1,N) = -1./( yu(M) - yu(M-1) )
      !cDu(-1,N) = -1./( xp(N) - xp(N-1) ) ! consistency bad, good convergence,
      ! consistency prefered
      !cDu(-1,N) = -1./( xu(N) - xu(N-1) ) ! TEST!!! Das geht in die Hose ...
      !cDu(-1,N) = -1./( yu(M+1) - yu(M) )
    end if
    !-------------------------------------------------------------------------------------------
    do i = 1, N
      cDG(-1,i) = cDu(-1,i)*cGp(0,i-1)
      cDG( 0,i) = cDu(-1,i)*cGp(1,i-1) + cDu(0,i)*cGp(0,i)
      cDG( 1,i) =                        cDu(0,i)*cGp(1,i)
    end do

    ! Faktor 2 kommt von der Approximation DH-¹D ~= DI-¹G, wobei I hier das
    ! Interpolationspolynom am Rand darstellt
    if( BCL > 0 ) then
      cDG( :,1) = 2.*cDG(:,1)
      cDG(-1,1) = 0.
    end if
    if( BCU > 0 ) then
      cDG( :,N) = 2.*cDG(:,N)
      cDG( 1,N) = 0.
    end if

    if( BCL == -2) then
      cDG( 1,1) = cDG( 1, 1 ) + cDG( -1, 1 )
      cDG(-1,1) = 0.
    end if

    if( BCU == -2 ) then
      cDG(-1,N) = cDG(-1, N ) + cDG( 1, N )
      cDG( 1,N) = 0.
    end if

  end subroutine Op_getCDG_dir

end module cmod_DivGrad2ndOOp


module hamiltonian

   use data_struct, only: dcsr3

   public:: J2Ham, N0Ham, Ham

contains

   ! create matrix representation for J^2 part
   subroutine J2Ham( A, N, M, c )

      implicit none
      type( dcsr3 ), intent(inout) :: A
      integer, intent(in) :: N, M
      double precision, intent(in) :: c

      real bounds(3)
      integer kmin, kmax, k, nnz, i, nsize

      if( allocated(A%rowind) ) deallocate(A%rowind)
      if( allocated(A%col) ) deallocate(A%col)
      if( allocated(A%val) ) deallocate(A%val)

      ! Even magnetization case
      if( modulo(M, 2) .eq. 0 ) then

         bounds = (/ 0.0, real(M)/2.0, -real(M)/2.0 /)
         kmin   = ceiling( maxval( bounds ) )

         bounds = (/ real(N)/2.0, real(N)-real(M)/2.0, real(N)+real(M)/2.0 /)
         kmax   = floor( minval( bounds ) )

         ! number of nonzero elements
         nsize  = (kmax-kmin+1)
         nnz    = 2*(nsize)-1

         allocate( A%val(nnz), A%col(nnz), A%rowind(nsize+1) )

         A%rowind(1) = 1
         A%m = nsize

         do k=kmin, kmax

            ! update values and columns
            i = A%rowind(k-kmin+1)

            A%val(i) = 1.d0/( 2.d0*dble(N) )*( dble(N) + dble(M)**2 + &
                       ( dble(N) - 2.d0*dble(k) )*( 2.d0*dble(N) + 1.d0 - &
                       2.d0*( dble(N) - 2.d0*dble(k) ) ) )
            A%col(i) = k-kmin+1

            A%val(i) = c * A%val(i)

            if( k<kmax ) then
               A%val(i+1) = 1.d0/dble(N)*SQRT( ( dble(k) + 1.d0 + dble(M)/2.d0 )*&
                            ( dble(k) + 1.d0 - dble(M)/2.d0 )*( dble(N) - 2.d0*dble(k) )*&
                            ( dble(N) - 2.d0*dble(k) - 1.d0 ) )
               A%col(i+1) = k-kmin+2

               A%val(i+1) = c * A%val(i+1)

            endif

            ! update csr rowindex
            if( k< kmax ) then
               i = k-kmin+2
               A%rowind(i) = A%rowind(i-1) + 2
            else
               i = k-kmin+2
               A%rowind(i) = A%rowind(i-1) + 1
            endif

         enddo

      else

         bounds = (/ 0.0, real(M+1)/2.0, -real(M-1)/2.0 /)
         kmin   = ceiling( maxval( bounds ) )

         bounds = (/ real(N-1)/2.0, real(N)-real(M+1)/2.0, real(N)+real(M-1)/2.0 /)
         kmax   = floor( minval( bounds ) )

         ! number of nonzero elements
         nsize  = (kmax-kmin+1)
         nnz    = 2*(nsize)-1

         allocate( A%rowind(nsize+1), A%col(nnz), A%val(nnz) )

         A%rowind(1) = 1
         A%m = nsize

         do k=kmin, kmax

            ! update values and columns
            i = A%rowind(k-kmin+1)

            A%val(i) = 1.d0/( 2.d0*dble(N) )*( dble(N) + dble(M)**2 + &
                       ( dble(N) - 2.d0*dble(k) - 1.d0 )*( 2.d0*dble(N) + 1.d0 - &
                       2.d0*( real(N) - 2.d0*dble(k) - 1.d0 ) ) )
            A%col(i) = k-kmin+1

            A%val(i) = c * A%val(i)

            if( k<kmax ) then
               A%val(i+1) = 1.d0/dble(N)*SQRT( ( dble(k) + 1.5d0 + dble(M)/2.d0 )*&
                            ( dble(k) + 1.5d0 - dble(M)/2.d0 )*( dble(N) - 2.d0*dble(k) - 1.d0 )*&
                            ( dble(N) - 2.d0*dble(k) - 2.d0 ) )
               A%col(i+1) = k-kmin+2

               A%val(i+1) = c * A%val(i+1)

            endif

            ! update csr rowindex
            if( k< kmax ) then
               i = k-kmin+2
               A%rowind(i) = A%rowind(i-1) + 2
            else
               i = k-kmin+2
               A%rowind(i) = A%rowind(i-1) + 1
            endif

         enddo

      endif

   end subroutine

   ! create N0 matrix representation
   subroutine N0Ham( A, N, M, q )

      implicit none
      type( dcsr3 ), intent(inout) :: A
      integer, intent(in) :: N, M
      double precision, intent(in) :: q

      real bounds(3)
      integer kmin, kmax, k, nnz, i, nsize

      if( allocated(A%rowind) ) deallocate(A%rowind)
      if( allocated(A%col) ) deallocate(A%col)
      if( allocated(A%val) ) deallocate(A%val)

      ! Even magnetization case
      if( modulo(M, 2) .eq. 0 ) then

         bounds = (/ 0.0, real(M)/2.0, -real(M)/2.0 /)
         kmin   = ceiling( maxval( bounds ) )

         bounds = (/ real(N)/2.0, real(N)-real(M)/2.0, real(N)+real(M)/2.0 /)
         kmax   = floor( minval( bounds ) )

         ! number of nonzero elements
         nsize  = (kmax-kmin+1)
         nnz    = nsize

         allocate( A%rowind(nsize+1), A%col(nnz), A%val(nnz) )

         A%rowind(1) = 1
         A%m = nsize

         do k=kmin, kmax

            i = k-kmin+1
            A%rowind(i+1) = A%rowind(i) + 1
            A%col(i)      = i
            A%val(i)      = q * 2.d0*dble(k)

         enddo

      else

         bounds = (/ 0.0, real(M+1)/2.0, -real(M-1)/2.0 /)
         kmin   = ceiling( maxval( bounds ) )

         bounds = (/ real(N-1)/2.0, real(N)-real(M+1)/2.0, real(N)+real(M-1)/2.0 /)
         kmax   = floor( minval( bounds ) )

         ! number of nonzero elements
         nsize  = (kmax-kmin+1)
         nnz    = nsize

         allocate( A%rowind(nsize+1), A%col(nnz), A%val(nnz) )

         A%rowind(1) = 1
         A%m = nsize

         do k=kmin, kmax

            i = k-kmin+1
            A%rowind(i+1) = A%rowind(i) + 1
            A%col(i)      = i
            A%val(i)      = q * ( 2.d0*dble(k) + 1.d0 )

         enddo

      endif

   end subroutine

   !> Information about c and q is stored in
   !> matrixes J2 and N0
   subroutine Ham( A, J2, N0 )

      implicit none
      type( dcsr3 ), intent(inout) :: A
      type( dcsr3 ), intent(in) :: J2, N0

      character trans
      integer request
      integer m, n, nzmax, info, sort, nnz

      trans = 'N'
      m = J2%m
      n = maxval(J2%col)

      if( allocated(A%rowind) ) then
         if( size(A%rowind,1) .ne. m+1 ) then
            deallocate(A%rowind)
            allocate( A%rowind(m+1) )
            A%m = m
         endif
      else
         allocate( A%rowind(m+1) )
         A%m = m
      endif

      ! double call to mkl_dcsradd
      request=1
      call mkl_dcsradd( trans, request, sort, m, n,&
                        J2%val, J2%col, J2%rowind,&
                        1.d0,&
                        N0%val, N0%col, N0%rowind,&
                        A%val, A%col, A%rowind,&
                        nzmax, info )

      nnz = A%rowind(m+1)-1

      if( allocated(A%col) ) then
         if( size(A%col,1) .ne. m+1 ) then
            deallocate(A%col)
            allocate( A%col(nnz) )
         endif
      else
         allocate( A%col(nnz) )
      endif

      if( allocated(A%val) ) then
         if( size(A%val,1) .ne. m+1 ) then
            deallocate(A%val)
            allocate( A%val(nnz) )
         endif
      else
         allocate( A%val(nnz) )
      endif

      request=2
      call mkl_dcsradd( trans, request, sort, m, n,&
                        J2%val, J2%col, J2%rowind,&
                        1.d0,&
                        N0%val, N0%col, N0%rowind,&
                        A%val, A%col, A%rowind,&
                        nzmax, info )

   end subroutine

end module


  subroutine tinvu (sDCM, tin, cmin, tn, cmn, sintin, costin, sinfin, &
       & cosfin, sintn, costn, sinfn, cosfn, v, u, tin1)

! ======================================================================
!
!     Calculation of tin1, v, & u
!     tin1 is kinetic energy of the cascade particle in a frame in
!         which the nuclear partner particle is at rest.
!     u is the total energy available in the center-of-momentum frame.
!     v is the velocity of the center-of-momentum frame of the
!         interacting particles with respect to the nucleus.
!
!     The four variables ....in correspond to the direction of the
!     momentum of the cascade particle; those ....n to the direction
!     of the target particle (or two-particle state, for absorption)
!     in the lab.
!
!     Called by: ABSORP POINTE
!
!   CEM95 written by S. G. Mashnik
!
!   Edited by A. J. Sierk,  LANL  T-2  February-March, 1996.
!   Edited by AJS  July, 1997.
!   Edited by A. J. Sierk, LANL T-16  October, 2003.
!   Edited by AJS, LANL T-2, December, 2011.
!   Edited by LMK, XCP-3, July 2013 (included error protection)
!
! ======================================================================

    use, intrinsic:: iso_fortran_env, only: int32, real64
    use standardDCMParams, only: one, two

    implicit none
    class(StandardDCM), intent(inout) :: sDCM
    real(real64), intent(in   ) :: tin      ! Kinetic and rest energies of particle 1
    real(real64), intent(in   ) :: cmin
    real(real64), intent(in   ) :: tn       ! Kinetic and rest energies of particle 2
    real(real64), intent(in   ) :: cmn
    real(real64), intent(in   ) :: sintin   ! Angles of one particle 1
    real(real64), intent(in   ) :: costin
    real(real64), intent(in   ) :: sinfin
    real(real64), intent(in   ) :: cosfin
    real(real64), intent(in   ) :: sintn    ! Angles of one particle 2
    real(real64), intent(in   ) :: costn
    real(real64), intent(in   ) :: sinfn
    real(real64), intent(in   ) :: cosfn
    real(real64), intent(  out) :: v(3)     ! Velocity in CP system of interacting particles
    real(real64), intent(  out) :: u        ! Energy available in CP system
    real(real64), intent(  out) :: tin1     ! Kinetic energy of cascade partner

    real(real64) :: ein, en, fac, pin, pinx, piny, pinz, pn, pnx, pny, &
         & pnz, temp, v2

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

!   Momentum and total energy of cascade particle in lab frame:
    pin = sqrt(abs(tin*(tin + two*cmin)))
    pinx = pin*sintin*cosfin
    piny = pin*sintin*sinfin
    pinz = pin*costin
    ein = tin + cmin
!   Momentum and total energy of Fermi sea particle (or of pair of
!   nucleons for pion absorption) in lab rframe:
    pn = sqrt(abs(tn*(tn + two*cmn)))
    pnx = pn*sintn*cosfn
    pny = pn*sintn*sinfn
    pnz = pn*costn
    en = tn + cmn
!   Total energy in lab frame.
    fac = ein + en
!   Velocity of the center-of-momentum system of the 2 (or 3)
!   particles in the lab frame.
    if (fac < div0Lim .and. fac > -div0Lim) then
       fac = div0Lim
       write(sDCM%io%message,1000) "65-67"
       call sDCM%io%print(4, 3, sDCM%io%message)
    end if
    v(1) = (pinx + pnx)/fac
    v(2) = (piny + pny)/fac
    v(3) = (pinz + pnz)/fac
    v2 = v(1)**2 + v(2)**2 + v(3)**2
!   Lorentz transformation of total energy into C.M. frame.
    u = fac*sqrt(abs(one - v2))
!   KINETIC energy of projectile in target rest frame
    temp = two*cmn
    if (temp < div0Lim .and. temp > -div0Lim) then
       temp = div0Lim
       write(sDCM%io%message, 1000) "77"
       call sDCM%io%print(4, 3, sDCM%io%message)
    end if
    tin1 = (u**2 - (cmin + cmn)**2)/(temp)
    return

! ======================================================================
1000 format("Divide by zero error prevented in 'tinvu.f90', line(s) ", A)
! ======================================================================
  end subroutine tinvu


      subroutine imhl (rs, xk, eim, icusp)
      implicit double precision (a-h,o-z)

c     what is xk?  k**2 - mu + kf**2?

c written by j. mustre (march 1988)
c code is based on analytical expression derived by john rehr.
c it leaves the real part, calculated in rhl unchanged.
c
c modified by j. rehr  (oct 1991) - adds quinn approximation for
c losses due to electron-hole pairs below the plasmon turn on
c see new subroutine quinn.f, which incorporates r. albers coding of
c j.j. quinn's approximations for details.

      include 'const.h'
c     alph is Hedin-Lundquist parameter
      parameter (alph = 4.0 / 3.0)
      external ffq

      integer icount
      save icount
      data icount /0/

      icusp=0
      xf = fa / rs
      ef = xf**2 / 2

c     xk0 is xk normalized by k fermi.
      xk0 = xk/xf
c     set to fermi level if below fermi level
      if (xk0 .lt. 1.00001) then
         xk0 = 1.00001
      endif

c     wp is given in units of the fermi energy in the formula below.
      wp = sqrt (3 / rs**3) / ef
      xs = wp**2 - (xk0**2 - 1)**2

      eim = 0
      if (xs .lt. 0.)  then
         q2 = sqrt ( (sqrt(alph**2-4*xs) - alph) / 2 )
         qu = min (q2, (1+xk0))
         d1 = qu - (xk0 - 1)
         if (d1 .gt. 0)  then
            eim = ffq (qu,ef,xk,wp,alph) - ffq (xk0-1,ef,xk,wp,alph)
         endif
      endif
      call cubic (xk0, wp, alph, rad, qplus, qminus)

      if (rad .le. 0) then
         d2 = qplus - (xk0 + 1)
         if (d2 .gt. 0)  then
            eim = eim + ffq (qplus,ef,xk,wp,alph) -
     1                  ffq (xk0+1,ef,xk,wp,alph)
         endif
         d3 = (xk0-1) - qminus
         if (d3 .gt. 0)  then
            eim = eim + ffq (xk0-1,ef,xk,wp,alph) -
     1                  ffq (qminus,ef,xk,wp,alph)
c           beginning of the imaginary part and position of the cusp x0
            icusp = 1
         endif
      endif

      call quinn (xk0, rs, wp, ef, ei)
      if (eim .ge. ei)  eim = ei

      icount = icount+1
      return
      end


    !> Pressure Load for nonlinear elasticity in a total lagrangian formulation
    !!
    !!
	!! @param iShiftU = nint(CommonPar(1))
	!! @param iShiftDeltaU = nint(CommonPar(2))
	!! @param iFemType  = nint(CommonPar(3)) !!! of the associated volume element (one dimension higher)
	!! @param iLoadProg = nint(CommonPar(4))
	!! @param LoadPar = CommonPar(5:10)

!     ------------------------------------------------------------------
Subroutine NeumannRefTraction(AE, BE, MaxLRows, XLL, NDim, iDofT, NodELT, Sol0, &
						Sol1, CommonPar, Param, JParam, DelT, DTm, Time)
!     ------------------------------------------------------------------
	use funcAux
	use loadingLib
	use finiteStrainLib
	use ptsGaussLib

	IMPLICIT NONE

	!   ===== SUBROUTINE ARGUMENTS  =======
	integer :: MaxLRows,Ndim,iDofT,NodELT ! all integers
	Real*8 :: DelT, DTm,Time ! all reals
	! Reals Vectors and matrices
	Real*8  :: AE(MaxLRows,MaxLRows), BE(MaxLRows), XLL(*), Sol0(*), Sol1(*), &
		Param(*), JParam(*), CommonPar(*)

	!   =====   END ARGUMENTS  =======

	Integer :: iLoadProg, iShiftDeltaU, iShiftU
	integer, parameter :: NdimE = 2
	real*8 , allocatable ::  Xel(:) !! all have dimension NodG*NdimE
	Real*8 :: normal0(NdimE) , vecU(NdimE), lengthLine, LoadPar(6), pm
	Real*8 :: Traction(2)
	type(ptGaussClass) :: PtG

	iShiftU = nint(CommonPar(1))
	iShiftDeltaU = nint(CommonPar(2))
	iLoadProg = nint(CommonPar(3))
	LoadPar = CommonPar(4:9)

	call chooseLoad(iLoadProg)
	call pressureLoad(pm,Time,DelT,LoadPar)

	call getSliceAllocate(Xel,XLL,1,NodELT,1 ,NdimE, Ndim)

	VecU = Xel(NdimE + 1 : 2*NdimE) - Xel(1:NdimE)

	lengthLine = dsqrt(dot_product(vecU,vecU))
	normal0(1) = vecU(2)/lengthLine
	normal0(2) = -vecU(1)/lengthLine

	write(0,*) "============================= > pm = " , pm
	Traction = -pm*normal0

	AE = 0.0d0
	BE = 0.0d0

	BE(iShiftDeltaU + 1 ) = 0.5d0*lengthLine*Traction(1)
	BE(iShiftDeltaU + 2 ) = 0.5d0*lengthLine*Traction(2)

	BE(iDofT + iShiftDeltaU + 1 ) = 0.5d0*lengthLine*Traction(1)
	BE(iDofT + iShiftDeltaU + 2 ) = 0.5d0*lengthLine*Traction(2)

end subroutine

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
Subroutine NeumannRefTractionS(Coupling,CommonPar,iDofT,Ndim,MaxLRows,iAdd)
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	use funcAux
	use ptsGaussLib

	IMPLICIT NONE
	Integer :: MaxLRows,Ndim,iDofT, iAdd
	Integer   Coupling(MaxLRows,MaxLRows)
	Real*8 CommonPar(*)
	Integer :: iShiftDeltaU

	iShiftDeltaU=nint(CommonPar(2))

	Coupling(iShiftDeltaU + 1, iShiftDeltaU + 1 ) = 1
	Coupling(iShiftDeltaU + 2, iShiftDeltaU + 2 ) = 1

	Coupling(iDofT + iShiftDeltaU + 1, iDofT + iShiftDeltaU + 1 ) = 1
	Coupling(iDofT + iShiftDeltaU + 2, iDofT + iShiftDeltaU + 2 ) = 1

end Subroutine