 ! xxx - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

      module cominfo

      public
      integer,   parameter  :: rnp = 8

      integer,   parameter  :: nlmx  = 60
      integer,   parameter  :: idlmx = 12
      integer,   parameter  :: mmx   = nlmx+1
      integer,   parameter  :: npemx = 200

      character             :: input*40,  inpshp*40, inpide*40
      character             ::            inpshpx*40
      integer,   parameter  :: inp_fl=50, shp_fl=51, ide_fl=52
      integer               :: ishp
      integer               :: ilect
      character             :: output*40
      integer,   parameter  :: out_fl=60, tab_fl=61, xyz_fl=62
      integer,   parameter  :: csv_fl=68, pth_fl=69

      integer               :: nl, mt, m, mnf, mef, nes
      character             :: tpl*4, refc*15, refaux*15
      real(rnp)             :: q0(mmx,3), qn(mmx,3)
      character             :: eq(mmx)*4, eqaux*10
      real(rnp)             :: cmq(3), fnor

      integer,   parameter  :: nidmx = 15
      integer               :: nid, idl(nidmx), idw
      character             :: iup(0:nidmx)*12, sim(0:nidmx)*5, dcr(0:nidmx)*75
      real(rnp)             :: p0(0:nidmx,mmx,3), vs(nidmx)
      real(rnp)             :: pw(mmx,3), pf(mmx,3)
      character             :: ep(mmx)*4, ef(mmx)*4
      integer               :: npe(nidmx), pmt(nidmx,npemx,mmx)
      logical               :: found_ideal, nl_found

      character  :: titol*80, opt*40
      logical    :: iflnm, ilst, ilbl
      logical    :: ifixp
      integer    :: nfixp, fixp(mmx)
      logical    :: screen, iout, itab, ixyz
      logical    :: ioutx, ilblx
      integer    :: iwap, iwaq
      logical    :: ipmx, itst, islct, icor, istop
      character  :: aslct*15
      integer    :: nstop
      real(rnp)  :: amx
      logical    :: ipath
      real(rnp)  :: pathk
      integer    :: mxsop
      real(rnp)  :: devia, cogen
      real(rnp)  :: thrdev, thrdev0
      real(rnp)  :: maxcsm, maxdev, maxgco
      real(rnp)  :: mincsm, mindev, mingco
      logical    :: iflt, ifltg, ifltc, ifltd
      integer,   parameter  :: flt_fl=63

      character  :: asop*2

      character, parameter  :: welco(3)*62 = &
                                  (/ "S H A P E   v2.1         Continuous Shape Measures calculation", &
                                     "(c) 2013  Electronic Structure Group, Universitat de Barcelona", &
                                     "                   Contact:  llunell@ub.edu                   " /)

      character, parameter  :: help(18)*100 = &
        (/ "%conquest      - Reads atomic coordinates generated by CSD's ConQuest program.                      ", &
           "%external      - Reads atomic coordinates from an external xyz file.                                ", &
           "%fixperm       - Restricts the calculation to a user-defined permutation.                           ", &
           "%fullout       - Generates coordinates of the reference shapes closest to each structure.           ", &
           "%maxcsm x      - Filters out structures whose shape measures are larger than x.                     ", &
           "%maxdev x      - Filters out structures whose path deviation functions are larger than x.           ", &
           "                 Also used as threshold to calculate generalized coordinate.                        ", &
           "%maxgco x      - Filters out structures whose generalized coordinates are larger than x.            ", &
           "%mincsm x      - Filters out structures whose shape measures are smaller than x.                    ", &
           "%mindev x      - Filters out structures whose path deviation functions are smaller than x.          ", &
           "%mingco x      - Filters out structures whose generalized coordinates are smaller than x.           ", &
           "%nosymbol      - Reads atomic coordinates without atomic symbols.                                   ", &
           "%path          - Performs analysis of structures along a minimal distortion pathway.                ", &
           "%reference     - Employs one or more user-defined reference shapes.                                 ", &
           "%select label  - Gives shape measures only for the structure with given label.                      ", &
           "%stop N        - Stops after analyzing N structures.                                                ", &
           "%test          - Generates xyz files of reference shapes used.                                      ", &
           "                 Structures along pathway are also generated when combined with %path.              " /)
!           "%thrdev x      - Path deviation function threshold to calculate generalized coordinate.             " /)

      real(rnp), parameter  :: eps = 10._rnp*epsilon(0._rnp)
      real(rnp), parameter  :: hug = huge(0._rnp)/2._rnp
      real(rnp), parameter  :: radians  = 3.1415926535897931_rnp/180._rnp
      character, parameter  :: digit*10 = '0123456789'
      real(rnp), parameter  :: sq3  = 3._rnp*1.7320508075688772_rnp

      end module cominfo

 ! xxx - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 ! * A les funcions cridades des del python amb arguments opcionals (mt_py: si hi ha àtom central o no),
 ! * no serveix el Defualt dins del f90 pq sempre està PRESENT encara que no vagi com argument
 ! * El defecte del python és enviar un False
 !      write(6,*) present(mt_py), mt_py
 !      mt_ctrl=.true.
 ! * A la versió 2018 l'argument del metall és un enter NO opcional amb 0 o la posició del metall (1-N)
 ! xxx - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

 ! xxx - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

      function cshm (cd_py,cr_py,na_py,mt_py)
      use cominfo
      implicit real(rnp) (a-h,o-z)
      real(rnp) :: cd_py(na_py,3), cr_py(na_py,3)
      integer :: mt_py

      ilbl=.false.
      ifixp=.false.
      ixyz=.false.
      iout=.false.
      iwap=-1
      iwaq=-1
      itst=.false.

      ipm=mt_py
      if (mt_py.eq.0) then
        nl=na_py
      else
        nl=na_py-1
      endif
      mt=0
      if (ipm.ne.0) mt=1
      m=nl+mt
      mnf=nl
      mef=max(1,mnf)
      if ((nl.lt.2).or.(nl.gt.nlmx)) stop 'ERROR * Wrong number of ligands'
      if ((ipm.lt.0).or.(ipm.gt.m)) stop 'ERROR * Invalid metal position'
      call get_topology

      nid=1
      idw=1

! * Sempre s'envia l'estructura de referència amb el metall al final
      p0(idw,:m,:)=cr_py(:m,:)
!      if (mt.eq.1) then
!        p0(idw,m,:)=cr_py(1,:)
!        p0(idw,1:nl,:)=cr_py(2:,:)
!      else
!        p0(idw,1:na_py,:)=cr_py
!      endif
      dcr(idw)=" "
      call anl_geometry(0)
      if (nl.le.60) then
        if (ichk.eq.0.and..not.ifixp) call equivper
      else
        if (itst) then
          write(out_fl,"(/2x,'This reference structure cannot be used without FIXPERM option')")
        elseif (ichk.eq.0.and..not.ifixp) then
          stop '* ERROR * FIXPERM option is needed for this number of vertices'
        endif
      endif

      refc="python_call"
      nes=1
      q0(:na_py,:)=cd_py(:,:)

      if ((ipm.ne.0).and.(ipm.ne.m)) then
        q0(ipm:m,:)=cshift(q0(ipm:m,:),1,dim=1)
      endif

      call anl_geometry (1)

      cshm=csm(0)

  999 return

      end function

 ! xxx - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

      function cshm_fix (cd_py,cr_py,na_py,mt_py)
      use cominfo
      implicit real(rnp) (a-h,o-z)
      real(rnp) :: cd_py(na_py,3), cr_py(na_py,3)
      integer :: mt_py

      ilbl=.false.
 ! Fixperm seguint l'ordre enviat des del python cd_py == cr_py \\
      ifixp=.true.
      do kfix=1,mef
        fixp(kfix)=kfix
      enddo
  ! Fixperm seguint l'ordre enviat des del python cd_py == cr_py //
      ixyz=.false.
      iout=.false.
      iwap=-1
      iwaq=-1
      itst=.false.

      ipm=mt_py
      if (mt_py.eq.0) then
        nl=na_py
      else
        nl=na_py-1
      endif
      mt=0
      if (ipm.ne.0) mt=1
      m=nl+mt
      mnf=nl
      mef=max(1,mnf)
      if ((nl.lt.2).or.(nl.gt.nlmx)) stop 'ERROR * Wrong number of ligands'
      if ((ipm.lt.0).or.(ipm.gt.m)) stop 'ERROR * Invalid metal position'
      call get_topology

      nid=1
      idw=1

! * Sempre s'envia l'estructura de referència amb el metall al final
      p0(idw,:m,:)=cr_py(:m,:)
      dcr(idw)=" "
      call anl_geometry(0)
      if (nl.le.60) then
        if (ichk.eq.0.and..not.ifixp) call equivper
      else
        if (itst) then
          write(out_fl,"(/2x,'This reference structure cannot be used without FIXPERM option')")
        elseif (ichk.eq.0.and..not.ifixp) then
          stop '* ERROR * FIXPERM option is needed for this number of vertices'
        endif
      endif

      refc="python_call"
      nes=1
      q0(:na_py,:)=cd_py(:,:)

      if ((ipm.ne.0).and.(ipm.ne.m)) then
        q0(ipm:m,:)=cshift(q0(ipm:m,:),1,dim=1)
      endif

      call anl_geometry (1)

      cshm=csm(0)

  999 return

      end function

 ! xxx - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

      function cshm_ref (cd_py,na_py,id_py,mt_py)
      use cominfo
      implicit real(rnp) (a-h,o-z)
      real(rnp) :: cd_py(na_py,3)
      integer :: id_py, mt_py

      ilbl=.false.
      ifixp=.false.
      ixyz=.false.
      iout=.false.
      iwap=-1
      iwaq=-1
      itst=.false.

      ipm=mt_py
      if (mt_py.eq.0) then
        nl=na_py
      else
        nl=na_py-1
      endif
      mt=0
      if (ipm.ne.0) mt=1
      m=nl+mt
      mnf=nl
      mef=max(1,mnf)
      if ((nl.lt.2).or.(nl.gt.nlmx)) stop 'ERROR * Wrong number of ligands'
      if ((ipm.lt.0).or.(ipm.gt.m)) stop 'ERROR * Invalid metal position'
      call get_topology

      nid=1
      idw=1
      idl(1)=id_py
      if (idl(1).le.0) stop '* ERROR * Invalid reference structure code'
      call ideal_str (0)

      refc="python_call"
      nes=1
      q0(:na_py,:)=cd_py(:,:)

      if ((ipm.ne.0).and.(ipm.ne.m)) then
        q0(ipm:m,:)=cshift(q0(ipm:m,:),1,dim=1)
      endif

      call anl_geometry (1)

      cshm_ref=csm(0)

  999 return

      end function

 ! xxx - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

      subroutine poly (cd_py,cr_py,na_py,mt_py,pl_py,cm_py)
      use cominfo
      implicit real(rnp) (a-h,o-z)
      real(rnp) :: cd_py(na_py,3), cr_py(na_py,3)
      real(rnp), intent(out) :: pl_py(na_py,3)
      real(rnp), intent(out) :: cm_py
      integer :: mt_py

      ilbl=.false.
      ifixp=.false.
      ixyz=.false.
      iout=.true.
      iwap=-1
      iwaq=-1
      itst=.false.

      ipm=mt_py
      if (mt_py.eq.0) then
        nl=na_py
      else
        nl=na_py-1
      endif
      mt=0
      if (ipm.ne.0) mt=1
      m=nl+mt
      mnf=nl
      mef=max(1,mnf)
      if ((nl.lt.2).or.(nl.gt.nlmx)) stop 'ERROR * Wrong number of ligands'
      if ((ipm.lt.0).or.(ipm.gt.m)) stop 'ERROR * Invalid metal position'
      call get_topology

      nid=1
      idw=1

! * Sempre s'envia l'estructura de referència amb el metall al final
      p0(idw,:m,:)=cr_py(:m,:)
!      if (mt.eq.1) then
!        p0(idw,m,:)=cr_py(1,:)
!        p0(idw,1:nl,:)=cr_py(2:,:)
!      else
!        p0(idw,1:na_py,:)=cr_py
!      endif
      dcr(idw)=" "
      call anl_geometry(0)
      if (nl.le.60) then
        if (ichk.eq.0.and..not.ifixp) call equivper
      else
        if (itst) then
          write(out_fl,"(/2x,'This reference structure cannot be used without FIXPERM option')")
        elseif (ichk.eq.0.and..not.ifixp) then
          stop '* ERROR * FIXPERM option is needed for this number of vertices'
        endif
      endif

      refc="python_call"
      nes=1
      q0(:na_py,:)=cd_py(:,:)

      if ((ipm.ne.0).and.(ipm.ne.m)) then
        q0(ipm:m,:)=cshift(q0(ipm:m,:),1,dim=1)
      endif

      call anl_geometry (1)

      cm_py=csm(0)

      if (mt.eq.0) then
        pl_py(:,:)=pf(:nl,:)
      else
        pl_py(1,:)=pf(m,:)
        pl_py(2:,:)=pf(:nl,:)
      endif

  999 return

      end subroutine

 ! xxx - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

      subroutine poly_fix (cd_py,cr_py,na_py,mt_py,pl_py,cm_py)
      use cominfo
      implicit real(rnp) (a-h,o-z)
      real(rnp) :: cd_py(na_py,3), cr_py(na_py,3)
      real(rnp), intent(out) :: pl_py(na_py,3)
      real(rnp), intent(out) :: cm_py
      integer :: mt_py

      ilbl=.false.
 ! Fixperm seguint l'ordre enviat des del python cd_py == cr_py \\
      ifixp=.true.
      do kfix=1,mef
        fixp(kfix)=kfix
      enddo
  ! Fixperm seguint l'ordre enviat des del python cd_py == cr_py //
      ixyz=.false.
      iout=.true.
      iwap=-1
      iwaq=-1
      itst=.false.

      ipm=mt_py
      if (mt_py.eq.0) then
        nl=na_py
      else
        nl=na_py-1
      endif
      mt=0
      if (ipm.ne.0) mt=1
      m=nl+mt
      mnf=nl
      mef=max(1,mnf)
      if ((nl.lt.2).or.(nl.gt.nlmx)) stop 'ERROR * Wrong number of ligands'
      if ((ipm.lt.0).or.(ipm.gt.m)) stop 'ERROR * Invalid metal position'
      call get_topology

      nid=1
      idw=1

! * Sempre s'envia l'estructura de referència amb el metall al final
      p0(idw,:m,:)=cr_py(:m,:)
      dcr(idw)=" "
      call anl_geometry(0)
      if (nl.le.60) then
        if (ichk.eq.0.and..not.ifixp) call equivper
      else
        if (itst) then
          write(out_fl,"(/2x,'This reference structure cannot be used without FIXPERM option')")
        elseif (ichk.eq.0.and..not.ifixp) then
          stop '* ERROR * FIXPERM option is needed for this number of vertices'
        endif
      endif

      refc="python_call"
      nes=1
      q0(:na_py,:)=cd_py(:,:)

      if ((ipm.ne.0).and.(ipm.ne.m)) then
        q0(ipm:m,:)=cshift(q0(ipm:m,:),1,dim=1)
      endif

      call anl_geometry (1)

      cm_py=csm(0)

      if (mt.eq.0) then
        pl_py(:,:)=pf(:nl,:)
      else
        pl_py(1,:)=pf(m,:)
        pl_py(2:,:)=pf(:nl,:)
      endif

  999 return

      end subroutine

 ! xxx - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

      subroutine poly_ref (cd_py,na_py,id_py,mt_py,pl_py,cm_py)
      use cominfo
      implicit real(rnp) (a-h,o-z)
      real(rnp) :: cd_py(na_py,3)
      real(rnp), intent(out) :: pl_py(na_py,3)
      real(rnp), intent(out) :: cm_py
      integer :: mt_py

      ilbl=.false.
      ifixp=.false.
      ixyz=.false.
      iout=.true.
      iwap=-1
      iwaq=-1
      itst=.false.

      ipm=mt_py
      if (mt_py.eq.0) then
        nl=na_py
      else
        nl=na_py-1
      endif
      mt=0
      if (ipm.ne.0) mt=1
      m=nl+mt
      mnf=nl
      mef=max(1,mnf)
      if ((nl.lt.2).or.(nl.gt.nlmx)) stop 'ERROR * Wrong number of ligands'
      if ((ipm.lt.0).or.(ipm.gt.m)) stop 'ERROR * Invalid metal position'
      call get_topology

      nid=1
      idw=1
      idl(1)=id_py
      if (idl(1).le.0) stop '* ERROR * Invalid reference structure code'
      call ideal_str (0)

      refc="python_call"
      nes=1
      q0(:na_py,:)=cd_py(:,:)

      if ((ipm.ne.0).and.(ipm.ne.m)) then
        q0(ipm:m,:)=cshift(q0(ipm:m,:),1,dim=1)
      endif

      call anl_geometry (1)

      cm_py=csm(0)

      if (mt.eq.0) then
        pl_py(:,:)=pf(:nl,:)
      else
        pl_py(1,:)=pf(m,:)
        pl_py(2:,:)=pf(:nl,:)
      endif

  999 return

      end subroutine

 ! xxx - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

      subroutine test (nl_py,id_py,pl_py)
      use cominfo
      implicit real(rnp) (a-h,o-z)
      real(rnp), intent(out) :: pl_py(nl_py + 1,3)

      ilbl=.false.
      ifixp=.false.
      ixyz=.false.
      iout=.true.
      iwap=-1
      iwaq=-1
      itst=.true.

      ipm=nl+1
      nl=nl_py
      mt=1
      m=nl+mt
      mnf=nl
      mef=max(1,mnf)
      if ((nl.lt.2).or.(nl.gt.nlmx)) stop 'ERROR * Wrong number of ligands'
      if ((ipm.lt.0).or.(ipm.gt.m)) stop 'ERROR * Invalid metal position'
      call get_topology

      nid=1
      idw=1
      idl(1)=id_py
      if (idl(1).le.0) stop '* ERROR * Invalid reference structure code'
      call ideal_str (0)

      pl_py(:,:)=p0(1,:m,:)

  999 return

      end subroutine

 ! xxx - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

      subroutine nextline (iunit)

      implicit real(8) (a-h,o-z)
      integer,   parameter  :: rnp = 8

      integer,   intent(in)   :: iunit
      character  :: line*80
      logical    :: ctrl

      ctrl=.false.
      do while (.not.ctrl)
        read(iunit,"(a)",end=999) line
        line=adjustl(line)
        if ((line(1:1).ne.'!').and.(len_trim(line).ne.0)) then
          backspace(iunit)
          ctrl=.true.
        endif
      enddo

  999 return

      end subroutine

 ! xxx - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

      function csm(icsm)

      use cominfo
      implicit real(rnp) (a-h,o-z)

      integer    :: ip(mmx), ipo(mmx), ipf(mmx)
      logical    :: ctrl(mmx)
      real(rnp)  :: hi(mmx,mmx,3,3), h0(3,3), h(3,3)
      logical    :: ekv(0:mmx,npemx)
      integer    :: icsm
      real(rnp), allocatable :: d2qt(:,:,:,:,:)
      real(rnp)  :: d2mn(0:mmx)
      real(rnp)  :: qmd(mmx), pmd(mmx), hcp(3,3)

      real(rnp)  :: r(3,3)
      real(rnp)  :: rpt(3,mmx)

      if (.not.ifixp.or.icsm.eq.-1) allocate(d2qt((mmx+1)/4,mmx,mmx,mmx,mmx))
      pw(1:m,:)=p0(idw,1:m,:)

      h(:,:)=0._rnp
      do i=1,mnf
      do j=1,mnf
        hi(i,j,:,:)=matmul(transpose(pw(i:i,:)),qn(j:j,:))
      enddo
      h(:,:)=h(:,:)+hi(i,i,:,:)
      enddo
      h0(:,:)=0._rnp
      do i=mnf+1,m
        h0(:,:)=h0(:,:)+matmul(transpose(pw(i:i,:)),qn(i:i,:))
      enddo
      h(:,:)=h(:,:)+h0(:,:)
      h0(:,:)=h(:,:)

      if (.not.ifixp.or.icsm.eq.-1) then
      do i=1,mef
        pmd(i)=dot_product(pw(i,:),pw(i,:))
        qmd(i)=dot_product(qn(i,:),qn(i,:))
      enddo

      d2mn(0)=0._rnp
      do iq=1,mef-3,4
      qmd(iq)=qmd(iq)+qmd(iq+1)+qmd(iq+2)+qmd(iq+3)
      iq0=(iq-1)/4+1
      d2qt(iq0,:mef,:mef,:mef,:mef)=hug
      do ia=1,mef
      do ib=1,mef
      if (ib.eq.ia) cycle
      do ic=1,mef
      if ((ic.eq.ia).or.(ic.eq.ib)) cycle
      do id=1,mef
      if ((id.eq.ia).or.(id.eq.ib).or.(id.eq.ic)) cycle
        hcp(:,:)=hi(ia,iq,:,:)+hi(ib,iq+1,:,:)+hi(ic,iq+2,:,:)+hi(id,iq+3,:,:)
        tr=suml(hcp)
        d2qt(iq0,ia,ib,ic,id)=qmd(iq)-tr**2/(pmd(ia)+pmd(ib)+pmd(ic)+pmd(id))
      enddo
      enddo
      enddo
      enddo
      d2iqmn=minval(d2qt(iq0,:mef,:mef,:mef,:mef))
      d2qt(iq0,:mef,:mef,:mef,:mef)=d2qt(iq0,:mef,:mef,:mef,:mef)-d2iqmn
      d2mn(0)=d2mn(0)+d2iqmn
      enddo
      endif

      amx2=0._rnp
      ipo(:mef)=(/(j,j=1,mef)/)

      ctrl(:mef)=.false.
      ip(:mef)=0
      idc=1
      init=0
      npew=npe(idw)
      ekv(0,:npew)=.true.
      d2mn(1:)=0._rnp

      if (.not.ifixp.or.icsm.eq.-1) then
      PERMUT: do while (idc.ne.-1)

        ip(idc)=ip(idc)+1
        if (ip(idc).gt.mef) then
          ip(idc)=0
          idc=idc-1
          if (idc.eq.0) exit PERMUT
          ctrl(ip(idc))=.false.
          cycle PERMUT
        endif
        if (ctrl(ip(idc))) cycle PERMUT

        if (any(ekv(idc-1,2:npew).and.(pmt(idw,2:npew,ip(idc)).lt.ip(idc)))) cycle PERMUT
        ekv(idc,2:npew)=(ekv(idc-1,2:npew).and.(pmt(idw,2:npew,ip(idc)).eq.ip(idc)))
        if (idc/4*4.eq.idc) then
          d2mn(idc)=d2mn(idc-1)+d2qt(idc/4,ip(idc-3),ip(idc-2),ip(idc-1),ip(idc))
        else
          d2mn(idc)=d2mn(idc-1)
        endif
        if (m-amx2/m.lt.d2mn(idc)) cycle PERMUT

        if (idc.ne.mef) then
          ctrl(ip(idc))=.true.
          idc=idc+1
          cycle PERMUT
        endif

        init=init+1
        if (init.eq.1000) then
          h(:,:)=h0(:,:)
          init=0
          ipo(:mef)=(/(j,j=1,mef)/)
        endif

        do j=1,mef
          if (ip(j).ne.ipo(j)) then
            h(:,:)=h(:,:)-hi(ipo(j),j,:,:)+hi(ip(j),j,:,:)
            ipo(j)=ip(j)
          endif
        enddo

        a=suml(h)
        a2=a**2
        if (a2.gt.amx2+1.0d-7) then
          amx2=a2
          ipf(:mef)=ip(:mef)
        endif

      enddo PERMUT

      else
        ip(:mef)=fixp(:mef)
        do j=1,mef
          if (ip(j).ne.ipo(j)) then
            h(:,:)=h(:,:)-hi(ipo(j),j,:,:)+hi(ip(j),j,:,:)
          endif
        enddo
        a=suml(h)
        a2=a**2
        amx2=a2
        ipf(:mef)=ip(:mef)
      endif
      csm=(1._rnp-amx2/m**2)*100._rnp

      if (iout) then
        do i=1,mef
          pw(i,:)=p0(idw,ipf(i),:)
          ef(i)=ep(ipf(i))
        enddo
        call svd(pw(:,:),qn(:,:),a,r(:,:))
        pf(1:m,:)=a*transpose(matmul(r(:,:),transpose(pw(1:m,:))))
        pf(1:m,:)=pf(1:m,:)/fnor
        do i=1,m
          pf(i,:)=pf(i,:)+cmq(:)
        enddo
      endif

  999 return

      end function

 ! xxx - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

      function suml (h)

      implicit real(8) (a-h,o-z)
      integer,   parameter  :: rnp = 8

      real(rnp), parameter  :: eps = 10._rnp*epsilon(0._rnp)

      real(rnp), intent(in)  :: h(3,3)

      real(rnp),  parameter  :: told = 1.e-20_rnp

      real(rnp)  :: h_(3), e_(3)
      logical    :: diag

      do i=1,3
        e_(i)=dot_product(h(:,i),h(:,i))
      enddo
      h_(1)=dot_product(h(:,3),h(:,2))
      h_(2)=dot_product(h(:,3),h(:,1))
      h_(3)=dot_product(h(:,2),h(:,1))

      do iter=1,100
        diag=.true.
        do i=2,3
          do j=1,i-1
            k=6/(i*j)
            aij=h_(k)
            aij2=aij*aij
            if (aij2.le.told) cycle
            diag=.false.
            aii=e_(i)
            ajj=e_(j)
            ded=aii-ajj
            den=abs(ded)+sqrt(ded*ded+4.0_rnp*aij2)
            if (ded.gt.0.0_rnp) then
              tg=2.0_rnp*aij/den
            else
              tg=-2.0_rnp*aij/den
            endif
            cs=1.0_rnp/sqrt(1.0_rnp+tg*tg)
            sn=cs*tg
            e0=2.0_rnp*sn*cs*aij
            cs2=cs*cs
            sn2=sn*sn
            e_(i)=cs2*aii+sn2*ajj+e0
            e_(j)=cs2*ajj+sn2*aii-e0
            h_(k)=0.0_rnp
            aux=cs*h_(i)-sn*h_(j)
            h_(j)=sn*h_(i)+cs*h_(j)
            h_(i)=aux
          enddo
        enddo
        if (diag) exit
      enddo

      if (.not.diag) stop '* ERROR * Jacobi diagonalization did not converge'

      e_(:)=abs(e_(:))
      suml=sum(sqrt(e_(:)),mask=(e_(:).gt.eps))

  999 return

      end function

 ! xxx - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

      subroutine svd (ci,cd,a,r)

      use cominfo
      implicit real(rnp) (a-h,o-z)

      real(rnp), intent(in)  :: ci(mmx,3), cd(mmx,3)
      real(rnp), intent(out) :: a, r(3,3)

      real(rnp),  parameter  :: told = 1.e-20_rnp
      real(rnp),  parameter  :: tolz = 1.e-10_rnp

      real(rnp)  :: h(3,3), u(3,3), v(3,3), l(3)
      real(rnp)  :: h_(3), e_(3), v_(3,3)
      logical    :: diag

      h(:,:)=matmul(transpose(ci(1:m,:)),cd(1:m,:))

      h_(1)=dot_product(h(:,3),h(:,2))
      h_(2)=dot_product(h(:,3),h(:,1))
      h_(3)=dot_product(h(:,2),h(:,1))
      v_(:,:)=0._rnp
      do i=1,3
        v_(i,i)=1._rnp
        e_(i)=dot_product(h(:,i),h(:,i))
      enddo

      do iter=1,100
        diag=.true.
        do i=2,3
          do j=1,i-1
            k=6/(i*j)
            aij=h_(k)
            aij2=aij*aij
            if (aij2.le.told) cycle
            diag=.false.
            aii=e_(i)
            ajj=e_(j)
            ded=aii-ajj
            den=abs(ded)+sqrt(ded*ded+4.0_rnp*aij2)
            if (ded.gt.0.0_rnp) then
              tg=2.0_rnp*aij/den
            else
              tg=-2.0_rnp*aij/den
            endif
            cs=1.0_rnp/sqrt(1.0_rnp+tg*tg)
            sn=cs*tg
            e0=2.0_rnp*sn*cs*aij
            cs2=cs*cs
            sn2=sn*sn
            e_(i)=cs2*aii+sn2*ajj+e0
            e_(j)=cs2*ajj+sn2*aii-e0
            do k0=1,3
              aux=cs*v_(k0,j)-sn*v_(k0,i)
              v_(k0,i)=sn*v_(k0,j)+cs*v_(k0,i)
              v_(k0,j)=aux
            enddo
            h_(k)=0.0_rnp
            aux=cs*h_(i)-sn*h_(j)
            h_(j)=sn*h_(i)+cs*h_(j)
            h_(i)=aux
          enddo
        enddo
        if (diag) exit
      enddo

      if (.not.diag) stop '* ERROR * Jacobi diagonalization did not converge'

      e_(:)=abs(e_(:))
      a=sum(sqrt(e_(:)),mask=(e_(:).gt.eps))/m
      i1=sum(maxloc(e_(:)))
      i3=sum(minloc(e_(:)))
      if (i1.ne.i3) then
        i2=6/(i1*i3)
        l(:)=(/sqrt(e_(i1)),sqrt(e_(i2)),sqrt(e_(i3))/)
        v(:,1)=v_(:,i1)
        v(:,2)=v_(:,i2)
        v(:,3)=v_(:,i3)
      else
        l(:)=sqrt(e_(i1))
        v(:,1)=(/1._rnp,0._rnp,0._rnp/)
        v(:,2)=(/0._rnp,1._rnp,0._rnp/)
        v(:,3)=(/0._rnp,0._rnp,1._rnp/)
      endif

      if (l(1).gt.tolz) then
        u(:,:)=matmul(h(:,:),v(:,:))
        u(:,1)=u(:,1)/l(1)
        if (l(2).gt.tolz) then
          u(:,2)=u(:,2)/l(2)
        else
          if (abs(u(1,1)).gt.tolz) then
            u(:,2)=(/u(2,1),-u(1,1),0._rnp/)
          elseif (abs(u(2,1)).gt.tolz) then
            u(:,2)=(/0._rnp,u(3,1),-u(2,1)/)
          else
            u(:,2)=(/1._rnp,0._rnp,0._rnp/)
          endif
        endif
        if (l(3).gt.tolz) then
          u(:,3)=u(:,3)/l(3)
        else
          u(:,3)=(/u(2,1)*u(3,2)-u(3,1)*u(2,2), &
                   u(3,1)*u(1,2)-u(1,1)*u(3,2), &
                   u(1,1)*u(2,2)-u(2,1)*u(1,2)/)
        endif
      else
        u(:,1)=(/1._rnp,0._rnp,0._rnp/)
        u(:,2)=(/0._rnp,1._rnp,0._rnp/)
        u(:,3)=(/0._rnp,0._rnp,1._rnp/)
      endif

      r(:,:)=matmul(v(:,:),transpose(u(:,:)))

  999 return

      end subroutine

 ! xxx - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

      subroutine get_topology

      use cominfo
      implicit real(rnp) (a-h,o-z)

      if ((nl.lt.2).or.(nl.gt.nlmx).or.(mt.lt.0).or.(mt.gt.1)) stop '* ERROR * Invalid topology'

      tpl='L'
      if (mt.eq.1) tpl='ML'
      ii=nl/10
      if (ii.ne.0) tpl=trim(tpl)//digit(ii+1:ii+1)
      ii=nl-ii*10
      tpl=trim(tpl)//digit(ii+1:ii+1)

      do i=1,nl
        ep(i)='L'
        if (.not.ilbl) ep(i)='rL'
        ii=i/10
        if (ii.ne.0) ep(i)=trim(ep(i))//digit(ii+1:ii+1)
        ii=i-ii*10
        ep(i)=trim(ep(i))//digit(ii+1:ii+1)
        if (.not.ilbl) eq(i)='e'//ep(i)(2:4)
      enddo
      ep(nl+1)='M'
      if (.not.ilbl) ep(nl+1)='rM'
      if (.not.ilbl) eq(nl+1)='eM'

      ef(:m)=ep(:m)

  999 return

      end subroutine

 ! xxx - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

      subroutine anl_geometry (nstr)

      use cominfo
      implicit real(rnp) (a-h,o-z)

      integer,   intent(in)             :: nstr

      real(rnp)  :: cd(mmx+1,3), cm(3)
      character  :: lb(mmx)*4
      integer    :: iwrt

      im=nl+1

      if (nstr.eq.0) then
        iwrt=iwap
        cd(:im,:)=p0(idw,:im,:)
        lb(:im)=ep(:im)
        if (iwrt.eq.0) write(out_fl,"(a)") trim(dcr(idw))
        if (iwrt.eq.1) write(out_fl,"(/a)") trim(dcr(idw))
        if (iwrt.eq.2) write(out_fl,"(/75('-')/a/75('-')/)") trim(dcr(idw))
      else
        iwrt=iwaq
        cd(:im,:)=q0(:im,:)
        lb(:im)=eq(:im)
        if (iwrt.ge.1.and.nes.gt.0) write(out_fl,"(a)")
        if (iwrt.ge.0) then
          if (nes.gt.0) then
            write(out_fl,"('Structure ',i5,4x,'[',a,']')") nes, trim(refc)
          else
            write(out_fl,"(/'Minimal distortion path structure at ',f7.3,'%')") 100._rnp*(mxsop+nes)/mxsop
          endif
        endif
      endif
      if (mt.eq.0) lb(im)='X'

      if (iwrt.ge.1) then
        if (nes.gt.0) then
          write(out_fl,"(4x,a4,4x,3(1x,f8.4))") lb(im), cd(im,:)
          write(out_fl,"(1000(4x,a4,4x,3(1x,f8.4)/))") (lb(i), cd(i,:), i=1,nl)
        else
          write(out_fl,"(3x,a,2x,3(1x,f8.4))") 'M', cd(im,:)
          write(out_fl,"(1000(3x,a,2x,3(1x,f8.4)/))") ('L', cd(i,:), i=1,nl)
        endif
        if (ixyz) then
          open(xyz_fl,file=trim(iup(idw))//'.xyz')
          write(xyz_fl,"(i3/)") im
          write(xyz_fl,"('N  ',4x,3(1x,f12.8))") cd(im,:)
          do i=1,nl
            write(xyz_fl,"('H  ',4x,3(1x,f12.8))") cd(i,:)
          enddo
          close(xyz_fl)
        endif
      endif

      if (iwrt.ge.2) then
        write(out_fl,"(2x,'Distances')")
        do icol=1,nl,8
          icol2=min(nl,icol+7)
          write(out_fl,"(/12x,8(5x,a4))") (lb(i), i=icol,icol2)
          write(out_fl,"(4x,a4,4x,8(1x,f8.4))") lb(im), (dist(im,i), i=icol,icol2)
          do i=1,icol2-1
            inifi=max(i-icol+1,0)
            write(out_fl,"(4x,a4,4x,a,8(1x,f8.4))") lb(i), repeat(' ',9*inifi), (dist(i,j), j=icol+inifi,icol2)
          enddo
        enddo
        if (mt.eq.1) then
          write(out_fl,"(/2x,'AnglesLML')")
        else
          write(out_fl,"(/2x,'AnglesLXL')")
        endif
        do icol=1,nl,8
          icol2=min(nl,icol+7)
          write(out_fl,"(/12x,8(5x,a4))") (lb(i), i=icol,icol2)
          do i=1,icol2-1
            inifi=max(i-icol+1,0)
            write(out_fl,"(4x,a4,4x,a,8(1x,f8.4))") lb(i), repeat(' ',9*inifi), (angl(i,im,j), j=icol+inifi,icol2)
          enddo
        enddo
      endif

      do j=1,3
        cm(j)=sum(cd(1:m,j))/m
      enddo
      if (nstr.eq.0) then
        do i=1,3
          p0(idw,1:m,i)=p0(idw,1:m,i)-cm(i)
        enddo
        fct=sqrt(m/sum(p0(idw,1:m,:)**2))
        p0(idw,1:m,:)=p0(idw,1:m,:)*fct
      else
        cmq(:)=cm(:)
        do i=1,3
          qn(1:m,i)=q0(1:m,i)-cmq(i)
        enddo
        fnor=sqrt(m/sum(qn(1:m,:)**2))
        qn(1:m,:)=qn(1:m,:)*fnor
      endif

  999 return

      contains

      function dist (ia,ib)
      integer,   intent(in)  :: ia, ib
      dist=sqrt(sum((cd(ia,:)-cd(ib,:))**2))
      return
      end function

      function angl (ia,iv,ib)
      integer,   intent(in)  :: ia, ib, iv
      angl=sqrt(sum((cd(ia,:)-cd(iv,:))**2))*sqrt(sum((cd(ib,:)-cd(iv,:))**2))
      if (angl.lt.epsilon(0._rnp)) then
        angl=huge(0._rnp)
      else
        angl=sum((cd(ia,:)-cd(iv,:))*(cd(ib,:)-cd(iv,:)))/angl
        angl=min(max(angl,-1._rnp),+1._rnp)
        angl=acos(angl)/radians
      endif
      return
      end function

      end subroutine

 ! xxx - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

      subroutine ideal_str (ichk)

      use cominfo
      implicit real(rnp) (a-h,o-z)

      integer,   intent(in)   :: ichk

      character  :: ntw*4
      logical    :: tocalc
      integer    :: nls(-1:+1), ir1(-1:+1), ir2(-1:+1), mlg(-1:+1,nlmx)
      logical    :: frcdm, cft(-1:+1)
      integer    :: trunc
      integer    :: krm(2)
      real(rnp)  :: pr(-1:+1,nlmx,3), pm(3), pcft(-1:+1,3)
      real(rnp)  :: dl2(-1:+1)
      integer    :: wnv(nlmx)
      real(rnp), allocatable :: trp(:,:)
      logical    :: john
      integer    :: ijh(5)

      if (ichk.eq.0) then
        id=idl(idw)
      else
        id=ichk
        nl_found=.true.
      endif

      iup(idw)=' '
      sim(idw)=' '
      dcr(idw)=' '
      p0(idw,:,:)=huge(0._rnp)

      tocalc=.true.
      nls(:)=0
      ir1(:)=0
      ir2(:)=0
      mlg(:,:)=1
      frcdm=.true.
      cft(:)=.false.
      krm(:)=0
      trunc=0
      john=.false.
      ijh(:)=0
      nforacase=0

      found_ideal=.true.

      if (id.eq.0) then

        tocalc=.false.
        call nextline (ide_fl)
        read(ide_fl,"(a)") iup(idw)
        call nextline (ide_fl)
        read(ide_fl,"(a)") dcr(idw)
        call nextline (ide_fl)
        read(ide_fl,"(a)") sim(idw)
        do i=1,nl+mt
          call nextline (ide_fl)
          read(ide_fl,*) p0(idw,i,:)
        enddo
        if (mt.eq.0) p0(idw,nl+1,:)=(/0.,0.,0./)

      else

        if (nl.eq.2) then
            select case (id)
              case (1)
                iup(idw)='L-2'
                sim(idw)='Dinfh'
                dcr(idw)='Linear'
                nls(0)=2
              case (2)
                iup(idw)='vT-2'
                sim(idw)='C2v'
                dcr(idw)='Divacant tetrahedron'
                tocalc=.false.
                nforacase=8
              case (3)
                iup(idw)='vOC-2'
                sim(idw)='C2v'
                dcr(idw)='Tetravacant octahedron'
                tocalc=.false.
                nforacase=9
              case default
                found_ideal=.false.
            endselect
        elseif (nl.eq.3) then
            select case (id)
              case (1)
                iup(idw)='TP-3'
                sim(idw)='D3h'
                dcr(idw)='Trigonal'
                nls(0)=3
              case (2)
                iup(idw)='vT-3'
                sim(idw)='C3v'
                dcr(idw)='Vacant tetrahedron'
                nls(:)=(/1,0,3/)
                mlg(-1,1)=0
              case (3)
                iup(idw)='fvOC-3'
                sim(idw)='C3v'
                dcr(idw)='fac-Trivacant octahedron'
                tocalc=.false.
                nforacase=10
              case (4)
                iup(idw)='mvOC-3'
                sim(idw)='C2v'
                dcr(idw)='mer-Trivacant octahedron'
                tocalc=.false.
                nforacase=11
              case default
                found_ideal=.false.
            endselect
        elseif (nl.eq.4) then
            select case (id)
              case (1)
                iup(idw)='SP-4'
                sim(idw)='D4h'
                dcr(idw)='Square'
                nls(0)=4
              case (2)
                iup(idw)='T-4'
                sim(idw)='Td'
                dcr(idw)='Tetrahedron'
                nls(:)=(/2,0,2/)
                ir1(-1)=1
              case (3)
                iup(idw)='SS-4'
                sim(idw)='C2v'
                dcr(idw)='Seesaw'
                nls(:)=(/1,4,1/)
                mlg(0,3:4)=0
              case (4)
                iup(idw)='vTBPY-4'
                sim(idw)='C3v'
                dcr(idw)='Vacant trigonal bipyramid'
                nls(:)=(/1,3,0/)
              case default
                found_ideal=.false.
            endselect
        elseif (nl.eq.5) then
            select case (id)
              case (1)
                iup(idw)='PP-5'
                sim(idw)='D5h'
                dcr(idw)='Pentagon'
                nls(0)=5
              case (2)
                iup(idw)='vOC-5'
                sim(idw)='C4v'
                dcr(idw)='Vacant octahedron'
                nls(:)=(/1,4,0/)
              case (3)
                iup(idw)='TBPY-5'
                sim(idw)='D3h'
                dcr(idw)='Trigonal bipyramid'
                nls(:)=(/1,3,1/)
              case (4)
                iup(idw)='SPY-5'
                sim(idw)='C4v'
                dcr(idw)='Spherical square pyramid'
                tocalc=.false.
                waux=cos(asin(0.25_rnp))
                p0(idw,1,:) = (/   0.000000_rnp,   0.000000_rnp,   1.000000_rnp /)
                p0(idw,2,:) = (/           waux,   0.000000_rnp,   -.250000_rnp /)
                p0(idw,3,:) = (/   0.000000_rnp,           waux,   -.250000_rnp /)
                p0(idw,4,:) = (/          -waux,   0.000000_rnp,   -.250000_rnp /)
                p0(idw,5,:) = (/   0.000000_rnp,          -waux,   -.250000_rnp /)
                p0(idw,6,:) = (/   0.000000_rnp,   0.000000_rnp,   0.000000_rnp /)
              case (5)
                iup(idw)='JTBPY-5'
                sim(idw)='D3h'
                dcr(idw)='Johnson trigonal bipyramid J12'
                john=.true.
                ijh(:)=(/3,0,1,1,1/)
              case default
                found_ideal=.false.
            endselect
        elseif (nl.eq.6) then
            select case (id)
              case (1)
                iup(idw)='HP-6'
                sim(idw)='D6h'
                dcr(idw)='Hexagon'
                nls(0)=6
              case (2)
                iup(idw)='PPY-6'
                sim(idw)='C5v'
                dcr(idw)='Pentagonal pyramid'
                nls(:)=(/1,5,0/)
              case (3)
                iup(idw)='OC-6'
                sim(idw)='Oh'
                dcr(idw)='Octahedron'
                nls(:)=(/1,4,1/)
              case (4)
                iup(idw)='TPR-6'
                sim(idw)='D3h'
                dcr(idw)='Trigonal prism'
                nls(:)=(/3,0,3/)
             case (5)
                iup(idw)='JPPY-6'
                sim(idw)='C5v'
                dcr(idw)='Johnson pentagonal pyramid J2'
                john=.true.
                ijh(:)=(/5,0,0,1,1/)
              case default
                found_ideal=.false.
            endselect
        elseif (nl.eq.7) then
            select case (id)
              case (1)
                iup(idw)='HP-7'
                sim(idw)='D7h'
                dcr(idw)='Heptagon'
                nls(0)=7
              case (2)
                iup(idw)='HPY-7'
                sim(idw)='C6v'
                dcr(idw)='Hexagonal pyramid'
                nls(:)=(/1,6,0/)
              case (3)
                iup(idw)='PBPY-7'
                sim(idw)='D5h'
                dcr(idw)='Pentagonal bipyramid'
                nls(:)=(/1,5,1/)
              case (4)
                iup(idw)='COC-7'
                sim(idw)='C3v'
                dcr(idw)='Capped octahedron'
                tocalc=.false.
                p0(idw,1,:) = (/ 0.000000000, 0.000000000, 1.000000000 /)
                p0(idw,2,:) = (/ 0.000000000,-0.977673355, 0.210130463 /)
                p0(idw,3,:) = (/ 0.846689962, 0.488836677, 0.210130463 /)
                p0(idw,4,:) = (/-0.846689962, 0.488836677, 0.210130463 /)
                p0(idw,5,:) = (/ 0.628442298,-0.362831330,-0.688050655 /)
                p0(idw,6,:) = (/-0.628442298,-0.362831330,-0.688050655 /)
                p0(idw,7,:) = (/ 0.000000000, 0.725662660,-0.688050655 /)
                p0(idw,8,:) = (/ 0.000000000, 0.000000000, 0.000000000 /)
              case (5)
                iup(idw)='CTPR-7'
                sim(idw)='C2v'
                dcr(idw)='Capped trigonal prism'
                tocalc=.false.
                p0(idw,1,:) = (/ 0.000000000, 0.000000000, 1.000000000 /)
                p0(idw,2,:) = (/ 0.686890210, 0.686890210, 0.237410359 /)
                p0(idw,3,:) = (/-0.686890210, 0.686890210, 0.237410359 /)
                p0(idw,4,:) = (/ 0.686890210,-0.686890210, 0.237410359 /)
                p0(idw,5,:) = (/-0.686890210,-0.686890210, 0.237410359 /)
                p0(idw,6,:) = (/ 0.617489029, 0.000000000,-0.786579493 /)
                p0(idw,7,:) = (/-0.617489029, 0.000000000,-0.786579493 /)
                p0(idw,8,:) = (/ 0.000000000, 0.000000000, 0.000000000 /)
              case (6)
                iup(idw)='JPBPY-7'
                sim(idw)='D5h'
                dcr(idw)='Johnson pentagonal bipyramid J13'
                john=.true.
                ijh(:)=(/5,0,1,1,1/)
              case (7)
                iup(idw)='JETPY-7'
                sim(idw)='C3v'
                dcr(idw)='Johnson elongated triangular pyramid J7'
                john=.true.
                ijh(:)=(/3,1,1,0,1/)
              case default
                found_ideal=.false.
            endselect
        elseif (nl.eq.8) then
            select case (id)
              case (1)
                iup(idw)='OP-8'
                sim(idw)='D8h'
                dcr(idw)='Octagon'
                nls(0)=8
              case (2)
                iup(idw)='HPY-8'
                sim(idw)='C7v'
                dcr(idw)='Heptagonal pyramid'
                nls(:)=(/1,7,0/)
              case (3)
                iup(idw)='HBPY-8'
                sim(idw)='D6h'
                dcr(idw)='Hexagonal bipyramid'
                nls(:)=(/1,6,1/)
              case (4)
                iup(idw)='CU-8'
                sim(idw)='Oh'
                dcr(idw)='Cube'
                nls(:)=(/4,0,4/)
              case (5)
                iup(idw)='SAPR-8'
                sim(idw)='D4d'
                dcr(idw)='Square antiprism'
                nls(:)=(/4,0,4/)
                ir1(-1)=1
              case (6)
                iup(idw)='TDD-8'
                sim(idw)='D2d'
                dcr(idw)='Triangular dodecahedron'
                tocalc=.false.
                p0(idw,1,:) = (/ -0.3194, 0.0000, 3.7605 /)
                p0(idw,2,:) = (/ 1.0000, -2.0601, 2.7719 /)
                p0(idw,3,:) = (/ 2.3194, 0.0000, 3.7605 /)
                p0(idw,4,:) = (/ 1.0000, 2.0601, 2.7719 /)
                p0(idw,5,:) = (/ -1.0601, 0.0000, 1.2281 /)
                p0(idw,6,:) = (/ 1.0000, -1.3194, 0.2395 /)
                p0(idw,7,:) = (/ 3.0601, 0.0000, 1.2281 /)
                p0(idw,8,:) = (/ 1.0000, 1.3194, 0.2395 /)
                p0(idw,9,:) = (/ 1.0000, 0.0000, 2.0000 /)
                if (itst) p0(idw,1:9,:)=p0(idw,1:9,:)/2.200_rnp
              case (7)
                iup(idw)='JGBF-8'
                sim(idw)='D2d'
                dcr(idw)='Johnson gyrobifastigium J26'
                tocalc=.false.
                waux=cos(asin(0.50_rnp))
                p0(idw,1,:) = (/   0.500000_rnp,   0.000000_rnp,           waux /)
                p0(idw,2,:) = (/   -.500000_rnp,   0.000000_rnp,           waux /)
                p0(idw,3,:) = (/   0.500000_rnp,   0.500000_rnp,   0.000000_rnp /)
                p0(idw,4,:) = (/   0.500000_rnp,   -.500000_rnp,   0.000000_rnp /)
                p0(idw,5,:) = (/   -.500000_rnp,   -.500000_rnp,   0.000000_rnp /)
                p0(idw,6,:) = (/   -.500000_rnp,   0.500000_rnp,   0.000000_rnp /)
                p0(idw,7,:) = (/   0.000000_rnp,   0.500000_rnp,          -waux /)
                p0(idw,8,:) = (/   0.000000_rnp,   -.500000_rnp,          -waux /)
                p0(idw,9,:) = (/   0.000000_rnp,   0.000000_rnp,   0.000000_rnp /)
              case (8)
                iup(idw)='JETBPY-8'
                sim(idw)='D3h'
                dcr(idw)='Johnson elongated triangular bipyramid J14'
                john=.true.
                ijh(:)=(/3,1,1,1,1/)
              case (9)
                iup(idw)='JBTPR-8'
                sim(idw)='C2v'
                dcr(idw)='Biaugmented trigonal prism J50'
                tocalc=.false.
                nforacase=1
              case (10)
                iup(idw)='BTPR-8'
                sim(idw)='C2v'
                dcr(idw)='Biaugmented trigonal prism'
                tocalc=.false.
                nforacase=2
              case (11)
                iup(idw)='JSD-8'
                sim(idw)='D2d'
                dcr(idw)='Snub diphenoid J84'
                tocalc=.false.
                nforacase=3
              case (12)
                iup(idw)='TT-8'
                sim(idw)='Td'
                dcr(idw)='Triakis tetrahedron'
                tocalc=.false.
                nforacase=4
              case (13)
                iup(idw)='ETBPY-8'
                sim(idw)='D3h'
                dcr(idw)='Elongated trigonal bipyramid'
                tocalc=.false.
                nforacase=5
              case default
                found_ideal=.false.
            endselect
        elseif (nl.eq.9) then
            select case (id)
              case (1)
                iup(idw)='EP-9'
                sim(idw)='D9h'
                dcr(idw)='Enneagon'
                nls(0)=9
              case (2)
                iup(idw)='OPY-9'
                sim(idw)='C8v'
                dcr(idw)='Octagonal pyramid'
                nls(:)=(/1,8,0/)
              case (3)
                iup(idw)='HBPY-9'
                sim(idw)='D7h'
                dcr(idw)='Heptagonal bipyramid'
                nls(:)=(/1,7,1/)
              case (4)
                iup(idw)='JTC-9'
                sim(idw)='C3v'
                dcr(idw)='Johnson triangular cupola J3'
                john=.true.
                ijh(:)=(/6,0,0,2,1/)
              case (5)
                iup(idw)='JCCU-9'
                sim(idw)='C4v'
                dcr(idw)='Capped cube J8'
                john=.true.
                ijh(:)=(/4,1,1,0,1/)
              case (6)
                iup(idw)='CCU-9'
                sim(idw)='C4v'
                dcr(idw)='Spherical-relaxed capped cube'
                tocalc=.false.
                nforacase=12
              case (7)
                iup(idw)='JCSAPR-9'
                sim(idw)='C4v'
                dcr(idw)='Capped square antiprism J10'
                john=.true.
                ijh(:)=(/4,-1,0,1,1/)
              case (8)
                iup(idw)='CSAPR-9'
                sim(idw)='C4v'
                dcr(idw)='Spherical capped square antiprism'
                tocalc=.false.
                wauxtb=68.7846*radians
                wauxtc=127.5519*radians
                wauxstb=sin(wauxtb)
                wauxctb=cos(wauxtb)
                wauxstc=sin(wauxtc)
                wauxctc=cos(wauxtc)
                p0(idw,1,:)  = (/                 0.0_rnp,                 0.0_rnp,   1.0_rnp /)
                p0(idw,2,:)  = (/   wauxstb*cos(000._rnp*radians),   wauxstb*sin(000._rnp*radians),   wauxctb /)
                p0(idw,3,:)  = (/   wauxstb*cos(090._rnp*radians),   wauxstb*sin(090._rnp*radians),   wauxctb /)
                p0(idw,4,:)  = (/   wauxstb*cos(180._rnp*radians),   wauxstb*sin(180._rnp*radians),   wauxctb /)
                p0(idw,5,:)  = (/   wauxstb*cos(270._rnp*radians),   wauxstb*sin(270._rnp*radians),   wauxctb /)
                p0(idw,6,:)  = (/   wauxstc*cos(045._rnp*radians),   wauxstc*sin(045._rnp*radians),   wauxctc /)
                p0(idw,7,:)  = (/   wauxstc*cos(135._rnp*radians),   wauxstc*sin(135._rnp*radians),   wauxctc /)
                p0(idw,8,:)  = (/   wauxstc*cos(225._rnp*radians),   wauxstc*sin(225._rnp*radians),   wauxctc /)
                p0(idw,9,:)  = (/   wauxstc*cos(315._rnp*radians),   wauxstc*sin(315._rnp*radians),   wauxctc /)
                p0(idw,10,:) = (/                 0.0_rnp,                 0.0_rnp,   0.0_rnp /)
              case (9)
                iup(idw)='JTCTPR-9'
                sim(idw)='D3h'
                dcr(idw)='Tricapped trigonal prism J51'
                tocalc=.false.
                p0(idw,1,:)  = (/    0.5000000000_rnp,    0.5000000000_rnp,     0.0000000000_rnp /)
                p0(idw,2,:)  = (/   -0.5000000000_rnp,    0.5000000000_rnp,     0.0000000000_rnp /)
                p0(idw,3,:)  = (/    0.5000000000_rnp,   -0.5000000000_rnp,     0.0000000000_rnp /)
                p0(idw,4,:)  = (/   -0.5000000000_rnp,   -0.5000000000_rnp,     0.0000000000_rnp /)
                p0(idw,5,:)  = (/    0.0000000000_rnp,    0.5000000000_rnp,    -0.8660254038_rnp /)
                p0(idw,6,:)  = (/    0.0000000000_rnp,   -0.5000000000_rnp,    -0.8660254038_rnp /)
                p0(idw,7,:)  = (/    0.8623724375_rnp,    0.0000000000_rnp,    -0.7865660925_rnp /)
                p0(idw,8,:)  = (/   -0.8623724375_rnp,    0.0000000000_rnp,    -0.7865660925_rnp /)
                p0(idw,9,:)  = (/    0.0000000000_rnp,    0.0000000000_rnp,     0.7071067827_rnp /)
                p0(idw,10,:) = (/    0.0000000000_rnp,    0.0000000000_rnp,    -0.2886751346_rnp /)
                if (itst) p0(idw,1:10,:)=p0(idw,1:10,:)/0.764_rnp
              case (10)
                iup(idw)='TCTPR-9'
                sim(idw)='D3h'
                dcr(idw)='Spherical tricapped trigonal prism'
                tocalc=.false.
                wauxl=2._rnp
                wauxx=1._rnp/sqrt(3._rnp)*wauxl
                wauxd=sqrt(3._rnp)/2._rnp*wauxl
                wauxh=sqrt(5._rnp/12._rnp)*wauxl
                wauxc=0.5_rnp
                wauxs=sin(acos(0.5_rnp))
                p0(idw,1,:)  = (/               wauxx,    0.0000000000_rnp,                wauxh /)
                p0(idw,2,:)  = (/   -wauxx/2.0000_rnp,    wauxl/2.0000_rnp,                wauxh /)
                p0(idw,3,:)  = (/   -wauxx/2.0000_rnp,   -wauxl/2.0000_rnp,                wauxh /)
                p0(idw,4,:)  = (/               wauxx,    0.0000000000_rnp,               -wauxh /)
                p0(idw,5,:)  = (/   -wauxx/2.0000_rnp,    wauxl/2.0000_rnp,               -wauxh /)
                p0(idw,6,:)  = (/   -wauxx/2.0000_rnp,   -wauxl/2.0000_rnp,               -wauxh /)
                p0(idw,7,:)  = (/              -wauxd,    0.0000000000_rnp,     0.0000000000_rnp /)
                p0(idw,8,:)  = (/         wauxc*wauxd,         wauxs*wauxd,     0.0000000000_rnp /)
                p0(idw,9,:)  = (/         wauxc*wauxd,        -wauxs*wauxd,     0.0000000000_rnp /)
                p0(idw,10,:) = (/    0.0000000000_rnp,    0.0000000000_rnp,     0.0000000000_rnp /)
              case (11)
                iup(idw)='JTDIC-9'
                sim(idw)='C3v'
                dcr(idw)='Tridiminished icosahedron J63'
                nls(:)=(/5,0,5/)
                ir1(-1)=1
                cft(-1)=.true.
                cft(+1)=.true.
                mlg(-1,1)=0
                mlg(+1,3)=0
                mlg(+1,5)=0
              case (12)
                iup(idw)='HH-9'
                sim(idw)='C2v'
                dcr(idw)='Hula-hoop'
                tocalc=.false.
                nforacase=20
              case (13)
                iup(idw)='MFF-9'
                sim(idw)='Cs'
                dcr(idw)='Muffin'
                tocalc=.false.
                nforacase=21
              case default
                found_ideal=.false.
            endselect
        elseif (nl.eq.10) then
            select case (id)
              case (1)
                iup(idw)='DP-10'
                sim(idw)='D10h'
                dcr(idw)='Decagon'
                nls(0)=10
              case (2)
                iup(idw)='EPY-10'
                sim(idw)='C9v'
                dcr(idw)='Enneagonal pyramid'
                nls(:)=(/1,9,0/)
              case (3)
                iup(idw)='OBPY-10'
                sim(idw)='D8h'
                dcr(idw)='Octagonal bipyramid'
                nls(:)=(/1,8,1/)
              case (4)
                iup(idw)='PPR-10'
                sim(idw)='D5h'
                dcr(idw)='Pentagonal prism'
                nls(:)=(/5,0,5/)
              case (5)
                iup(idw)='PAPR-10'
                sim(idw)='D5d'
                dcr(idw)='Pentagonal antiprism'
                nls(:)=(/5,0,5/)
                ir1(-1)=1
              case (6)
                iup(idw)='JBCCU-10'
                sim(idw)='D4h'
                dcr(idw)='Bicapped cube J15'
                john=.true.
                ijh(:)=(/4,1,1,1,1/)
              case (7)
                iup(idw)='JBCSAPR-10'
                sim(idw)='D4d'
                dcr(idw)='Bicapped square antiprism J17'
                john=.true.
                ijh(:)=(/4,-1,1,1,1/)
              case (8)
                iup(idw)='JMBIC-10'
                sim(idw)='C2v'
                dcr(idw)='Metabidiminished icosahedron J62'
                tocalc=.false.
                nforacase=13
              case (9)
                iup(idw)='JATDI-10'
                sim(idw)='C3v'
                dcr(idw)='Augmented tridiminished icosahedron J64'
                tocalc=.false.
                nforacase=14
              case (10)
                iup(idw)='JSPC-10'
                sim(idw)='C2v'
                dcr(idw)='Sphenocorona J87'
                tocalc=.false.
                nforacase=15
              case (11)
                iup(idw)='SDD-10'
                sim(idw)='D2'
                dcr(idw)='Staggered Dodecahedron (2:6:2)'
                tocalc=.false.
                nforacase=22
              case (12)
                iup(idw)='TD-10'
                sim(idw)='C2v'
                dcr(idw)='Tetradecahedron (2:6:2)'
                tocalc=.false.
                nforacase=23
              case (13)
                iup(idw)='HD-10'
                sim(idw)='D4h'
                dcr(idw)='Hexadecahedron (2:6:2) or (1:4:4:1)'
                tocalc=.false.
                nforacase=24
              case default
                found_ideal=.false.
            endselect
        elseif (nl.eq.11) then
            select case (id)
              case (1)
                iup(idw)='HP-11'
                sim(idw)='D11h'
                dcr(idw)='Hendecagon'
                nls(0)=11
              case (2)
                iup(idw)='DPY-11'
                sim(idw)='C10v'
                dcr(idw)='Decagonal pyramid'
                nls(:)=(/1,10,0/)
              case (3)
                iup(idw)='EBPY-11'
                sim(idw)='D9h'
                dcr(idw)='Enneagonal bipyramid'
                nls(:)=(/1,9,1/)
              case (4)
                iup(idw)='JCPPR-11'
                sim(idw)='C5v'
                dcr(idw)='Capped pentagonal prism J9'
                john=.true.
                ijh(:)=(/5,1,1,0,1/)
              case (5)
                iup(idw)='JCPAPR-11'
                sim(idw)='C5v'
                dcr(idw)='Capped pentagonal antiprism J11'
                john=.true.
                ijh(:)=(/5,-1,0,1,1/)
              case (6)
                iup(idw)='JAPPR-11'
                sim(idw)='C2v'
                dcr(idw)='Augmented pentagonal prism J52'
                tocalc=.false.
                nforacase=16
              case (7)
                iup(idw)='JASPC-11'
                sim(idw)='Cs'
                dcr(idw)='Augmented sphenocorona J87'
                tocalc=.false.
                nforacase=17
              case default
                found_ideal=.false.
            endselect
        elseif (nl.eq.12) then
            select case (id)
              case (1)
                iup(idw)='DP-12'
                sim(idw)='D12h'
                dcr(idw)='Dodecagon'
                nls(0)=12
              case (2)
                iup(idw)='HPY-12'
                sim(idw)='C11v'
                dcr(idw)='Hendecagonal pyramid'
                nls(:)=(/1,11,0/)
              case (3)
                iup(idw)='DBPY-12'
                sim(idw)='D10h'
                dcr(idw)='Decagonal bipyramid'
                nls(:)=(/1,10,1/)
              case (4)
                iup(idw)='HPR-12'
                sim(idw)='D6h'
                dcr(idw)='Hexagonal prism'
                nls(:)=(/6,0,6/)
              case (5)
                iup(idw)='HAPR-12'
                sim(idw)='D6d'
                dcr(idw)='Hexagonal antiprism'
                nls(:)=(/6,0,6/)
                ir1(-1)=1
              case (6)
                iup(idw)='TT-12'
                sim(idw)='Td'
                dcr(idw)='Truncated tetrahedron'
                nls(:)=(/2,0,2/)
                ir1(-1)=1
                trunc=-1
              case (7)
                iup(idw)='COC-12'
                sim(idw)='Oh'
                dcr(idw)='Cuboctahedron'
                nls(:)=(/4,0,4/)
                trunc=1
              case (8)
                iup(idw)='ACOC-12'
                sim(idw)='D3h'
                dcr(idw)='Anticuboctahedron J27'
                nls(:)=(/3,6,3/)
                ir1(0)=1
              case (9)
                iup(idw)='IC-12'
                sim(idw)='Ih'
                dcr(idw)='Icosahedron'
                nls(:)=(/5,0,5/)
                ir1(-1)=1
                cft(-1)=.true.
                cft(+1)=.true.
              case (10)
                iup(idw)='JSC-12'
                sim(idw)='C4v'
                dcr(idw)='Johnson square cupola J4'
                john=.true.
                ijh(:)=(/8,0,0,2,1/)
              case (11)
                iup(idw)='JEPBPY-12'
                sim(idw)='D6h'
                dcr(idw)='Johnson elongated pentagonal bipyramid J16'
                john=.true.
                ijh(:)=(/5,1,1,1,1/)
              case (12)
                iup(idw)='JBAPPR-12'
                sim(idw)='C2v'
                dcr(idw)='Biaugmented pentagonal prism J53'
                tocalc=.false.
                nforacase=18
              case (13)
                iup(idw)='JSPMC-12'
                sim(idw)='Cs'
                dcr(idw)='Sphenomegacorona J88'
                tocalc=.false.
                nforacase=19
              case default
                found_ideal=.false.
            endselect
        elseif (nl.eq.20) then
            select case (id)
              case (1)
                iup(idw)='DD-20'
                sim(idw)='Ih'
                dcr(idw)='Dodecahedron'
                tocalc=.false.
                nforacase=6
              case default
                found_ideal=.false.
            endselect
        elseif (nl.eq.24) then
            select case (id)
              case (1)
                iup(idw)='TCU-24'
                sim(idw)='Oh'
                dcr(idw)='Truncated cube'
                tocalc=.false.
                nforacase=25
              case (2)
                iup(idw)='TOC-24'
                sim(idw)='Oh'
                dcr(idw)='Truncated octahedron'
                tocalc=.false.
                nforacase=26
              case default
                found_ideal=.false.
            endselect
        elseif (nl.eq.48) then
            select case (id)
              case (1)
                iup(idw)='TCOC-48'
                sim(idw)='Oh'
                dcr(idw)='Truncated cuboctahedron'
                tocalc=.false.
                nforacase=27
              case default
                found_ideal=.false.
            endselect
        elseif (nl.eq.60) then
            select case (id)
              case (1)
                iup(idw)='TIC-60'
                sim(idw)='Ih'
                dcr(idw)='Truncated Icosahedron'
                tocalc=.false.
                nforacase=7
              case default
                found_ideal=.false.
            endselect

        else
            found_ideal=.false.
            nl_found=.false.
        endif

        if (nforacase.eq.1) then
                p0(idw,1,:) = (/  1.0000000_rnp,   0.0000000_rnp,   1.7320508_rnp /)
                p0(idw,2,:) = (/ -1.0000000_rnp,   0.0000000_rnp,   1.7320508_rnp /)
                p0(idw,3,:) = (/  1.0000000_rnp,   1.0000000_rnp,   0.0000000_rnp /)
                p0(idw,4,:) = (/ -1.0000000_rnp,   1.0000000_rnp,   0.0000000_rnp /)
                p0(idw,5,:) = (/  1.0000000_rnp,  -1.0000000_rnp,   0.0000000_rnp /)
                p0(idw,6,:) = (/ -1.0000000_rnp,  -1.0000000_rnp,   0.0000000_rnp /)
                p0(idw,7,:) = (/  0.0000000_rnp,   1.7247449_rnp,   1.5731322_rnp /)
                p0(idw,8,:) = (/  0.0000000_rnp,  -1.7247449_rnp,   1.5731322_rnp /)
                p0(idw,9,:) = (/  0.0000000_rnp,   0.0000000_rnp,   0.5773503_rnp /)
        endif
        if (nforacase.eq.2) then
                p0(idw,1,:) = (/  1.0000000_rnp,   0.0000000_rnp,   1.7320508_rnp /)
                p0(idw,2,:) = (/ -1.0000000_rnp,   0.0000000_rnp,   1.7320508_rnp /)
                p0(idw,3,:) = (/  1.0000000_rnp,   1.0000000_rnp,   0.0000000_rnp /)
                p0(idw,4,:) = (/ -1.0000000_rnp,   1.0000000_rnp,   0.0000000_rnp /)
                p0(idw,5,:) = (/  1.0000000_rnp,  -1.0000000_rnp,   0.0000000_rnp /)
                p0(idw,6,:) = (/ -1.0000000_rnp,  -1.0000000_rnp,   0.0000000_rnp /)
                p0(idw,7,:) = (/  0.0000000_rnp,   1.3228756_rnp,   1.3411129_rnp /)
                p0(idw,8,:) = (/  0.0000000_rnp,  -1.3228756_rnp,   1.3411129_rnp /)
                p0(idw,9,:) = (/  0.0000000_rnp,   0.0000000_rnp,   0.5773503_rnp /)
                if (itst) p0(idw,1:9,:)=p0(idw,1:9,:)/1.528_rnp
        endif
        if (nforacase.eq.3) then
                p0(idw,1,:) = (/ -0.5000000_rnp,   0.0000000_rnp,   0.0000000_rnp /)
                p0(idw,2,:) = (/  0.5000000_rnp,   0.0000000_rnp,   0.0000000_rnp /)
                p0(idw,3,:) = (/  0.644584_rnp,    0.0000000_rnp,   0.989492_rnp /)
                p0(idw,4,:) = (/ -0.644584_rnp,    0.0000000_rnp,   0.989492_rnp /)
                p0(idw,5,:) = (/  0.000000_rnp,   -0.5000000_rnp,   1.56786_rnp /)
                p0(idw,6,:) = (/  0.000000_rnp,    0.5000000_rnp,   1.56786_rnp /)
                p0(idw,7,:) = (/  0.0000000_rnp,  -0.644584_rnp,    0.578369_rnp /)
                p0(idw,8,:) = (/  0.0000000_rnp,   0.644584_rnp,    0.578369_rnp /)
                p0(idw,9,:) = (/  0.0000000_rnp,   0.0000000_rnp,   0.7839305_rnp /)
        endif
        if (nforacase.eq.4) then
                p0(idw,1,:) = (/   0.0000000_rnp,   0.0000000_rnp,   1.0000000_rnp /)
                p0(idw,2,:) = (/  -0.9426415_rnp,   0.0000000_rnp,  -0.3338069_rnp /)
                p0(idw,3,:) = (/   0.4713207_rnp,  -0.8163515_rnp,  -0.3338069_rnp /)
                p0(idw,4,:) = (/   0.4713207_rnp,   0.8163515_rnp,  -0.3338069_rnp /)
                p0(idw,5,:) = (/   0.0000000_rnp,   0.0000000_rnp,  -1.2175778_rnp /)
                p0(idw,6,:) = (/   1.1477393_rnp,   0.0000000_rnp,   0.4064359_rnp /)
                p0(idw,7,:) = (/  -0.5738696_rnp,   0.9939714_rnp,   0.4064359_rnp /)
                p0(idw,8,:) = (/  -0.5738696_rnp,  -0.9939714_rnp,   0.4064359_rnp /)
                p0(idw,9,:) = (/   0.0000000_rnp,   0.0000000_rnp,   0.0000000_rnp /)
        endif
        if (nforacase.eq.5) then
                p0(idw,1,:) = (/  1.0000000_rnp,   0.0000000_rnp,   1.7320508_rnp /)
                p0(idw,2,:) = (/ -1.0000000_rnp,   0.0000000_rnp,   1.7320508_rnp /)
                p0(idw,3,:) = (/  1.0000000_rnp,   1.0000000_rnp,   0.0000000_rnp /)
                p0(idw,4,:) = (/ -1.0000000_rnp,   1.0000000_rnp,   0.0000000_rnp /)
                p0(idw,5,:) = (/  1.0000000_rnp,  -1.0000000_rnp,   0.0000000_rnp /)
                p0(idw,6,:) = (/ -1.0000000_rnp,  -1.0000000_rnp,   0.0000000_rnp /)
                p0(idw,7,:) = (/  1.5275252_rnp,   0.0000000_rnp,   0.5773503_rnp /)
                p0(idw,8,:) = (/ -1.5275252_rnp,   0.0000000_rnp,   0.5773503_rnp /)
                p0(idw,9,:) = (/  0.0000000_rnp,   0.0000000_rnp,   0.5773503_rnp /)
        endif
        if (nforacase.eq.6) then
                p0(idw,01,:) = (/  1.1135164_rnp,   0.8090170_rnp,  -0.2628656_rnp /)
                p0(idw,02,:) = (/ -0.4253254_rnp,   1.3090170_rnp,  -0.2628656_rnp /)
                p0(idw,03,:) = (/ -1.3763819_rnp,   0.0000000_rnp,  -0.2628656_rnp /)
                p0(idw,04,:) = (/ -0.4253254_rnp,  -1.3090170_rnp,  -0.2628656_rnp /)
                p0(idw,05,:) = (/  1.1135164_rnp,  -0.8090170_rnp,  -0.2628656_rnp /)
                p0(idw,06,:) = (/  0.4253254_rnp,   1.3090170_rnp,   0.2628656_rnp /)
                p0(idw,07,:) = (/ -1.1135164_rnp,   0.8090170_rnp,   0.2628656_rnp /)
                p0(idw,08,:) = (/ -1.1135164_rnp,  -0.8090170_rnp,   0.2628656_rnp /)
                p0(idw,09,:) = (/  0.4253254_rnp,  -1.3090170_rnp,   0.2628656_rnp /)
                p0(idw,10,:) = (/  1.3763819_rnp,   0.0000000_rnp,   0.2628656_rnp /)
                p0(idw,11,:) = (/  0.6881910_rnp,   0.5000000_rnp,  -1.1135164_rnp /)
                p0(idw,12,:) = (/ -0.2628656_rnp,   0.8090170_rnp,  -1.1135164_rnp /)
                p0(idw,13,:) = (/ -0.8506508_rnp,   0.0000000_rnp,  -1.1135164_rnp /)
                p0(idw,14,:) = (/ -0.2628656_rnp,  -0.8090170_rnp,  -1.1135164_rnp /)
                p0(idw,15,:) = (/  0.6881910_rnp,  -0.5000000_rnp,  -1.1135164_rnp /)
                p0(idw,16,:) = (/  0.2628656_rnp,   0.8090170_rnp,   1.1135164_rnp /)
                p0(idw,17,:) = (/ -0.6881910_rnp,   0.5000000_rnp,   1.1135164_rnp /)
                p0(idw,18,:) = (/ -0.6881910_rnp,  -0.5000000_rnp,   1.1135164_rnp /)
                p0(idw,19,:) = (/  0.2628656_rnp,  -0.8090170_rnp,   1.1135164_rnp /)
                p0(idw,20,:) = (/  0.8506508_rnp,   0.0000000_rnp,   1.1135164_rnp /)
                p0(idw,21,:) = (/  0.0000000_rnp,   0.0000000_rnp,   0.0000000_rnp /)
        endif
        if (nforacase.eq.7) then
                p0(idw,01,:) = (/  1.9641672_rnp,   0.8090170_rnp,  -1.2759762_rnp /)
                p0(idw,02,:) = (/  1.3763819_rnp,   1.6180340_rnp,  -1.2759762_rnp /)
                p0(idw,03,:) = (/ -0.1624598_rnp,   2.1180340_rnp,  -1.2759762_rnp /)
                p0(idw,04,:) = (/ -1.1135164_rnp,   1.8090170_rnp,  -1.2759762_rnp /)
                p0(idw,05,:) = (/ -2.0645729_rnp,   0.5000000_rnp,  -1.2759762_rnp /)
                p0(idw,06,:) = (/ -2.0645729_rnp,  -0.5000000_rnp,  -1.2759762_rnp /)
                p0(idw,07,:) = (/ -1.1135164_rnp,  -1.8090170_rnp,  -1.2759762_rnp /)
                p0(idw,08,:) = (/ -0.1624598_rnp,  -2.1180340_rnp,  -1.2759762_rnp /)
                p0(idw,09,:) = (/  1.3763819_rnp,  -1.6180340_rnp,  -1.2759762_rnp /)
                p0(idw,10,:) = (/  1.9641672_rnp,  -0.8090170_rnp,  -1.2759762_rnp /)
                p0(idw,11,:) = (/  1.1135164_rnp,   1.8090170_rnp,   1.2759762_rnp /)
                p0(idw,12,:) = (/  0.1624598_rnp,   2.1180340_rnp,   1.2759762_rnp /)
                p0(idw,13,:) = (/ -1.3763819_rnp,   1.6180340_rnp,   1.2759762_rnp /)
                p0(idw,14,:) = (/ -1.9641672_rnp,   0.8090170_rnp,   1.2759762_rnp /)
                p0(idw,15,:) = (/ -1.9641672_rnp,  -0.8090170_rnp,   1.2759762_rnp /)
                p0(idw,16,:) = (/ -1.3763819_rnp,  -1.6180340_rnp,   1.2759762_rnp /)
                p0(idw,17,:) = (/  0.1624598_rnp,  -2.1180340_rnp,   1.2759762_rnp /)
                p0(idw,18,:) = (/  1.1135164_rnp,  -1.8090170_rnp,   1.2759762_rnp /)
                p0(idw,19,:) = (/  2.0645729_rnp,  -0.5000000_rnp,   1.2759762_rnp /)
                p0(idw,20,:) = (/  2.0645729_rnp,   0.5000000_rnp,   1.2759762_rnp /)
                p0(idw,21,:) = (/  2.3894926_rnp,   0.5000000_rnp,  -0.4253254_rnp /)
                p0(idw,22,:) = (/  2.2270327_rnp,   1.0000000_rnp,   0.4253254_rnp /)
                p0(idw,23,:) = (/  1.6392475_rnp,   1.8090170_rnp,   0.4253254_rnp /)
                p0(idw,24,:) = (/  1.2139221_rnp,   2.1180340_rnp,  -0.4253254_rnp /)
                p0(idw,25,:) = (/  0.2628656_rnp,   2.4270510_rnp,  -0.4253254_rnp /)
                p0(idw,26,:) = (/ -0.2628656_rnp,   2.4270510_rnp,   0.4253254_rnp /)
                p0(idw,27,:) = (/ -1.2139221_rnp,   2.1180340_rnp,   0.4253254_rnp /)
                p0(idw,28,:) = (/ -1.6392475_rnp,   1.8090170_rnp,  -0.4253254_rnp /)
                p0(idw,29,:) = (/ -2.2270327_rnp,   1.0000000_rnp,  -0.4253254_rnp /)
                p0(idw,30,:) = (/ -2.3894926_rnp,   0.5000000_rnp,   0.4253254_rnp /)
                p0(idw,31,:) = (/ -2.3894926_rnp,  -0.5000000_rnp,   0.4253254_rnp /)
                p0(idw,32,:) = (/ -2.2270327_rnp,  -1.0000000_rnp,  -0.4253254_rnp /)
                p0(idw,33,:) = (/ -1.6392475_rnp,  -1.8090170_rnp,  -0.4253254_rnp /)
                p0(idw,34,:) = (/ -1.2139221_rnp,  -2.1180340_rnp,   0.4253254_rnp /)
                p0(idw,35,:) = (/ -0.2628656_rnp,  -2.4270510_rnp,   0.4253254_rnp /)
                p0(idw,36,:) = (/  0.2628656_rnp,  -2.4270510_rnp,  -0.4253254_rnp /)
                p0(idw,37,:) = (/  1.2139221_rnp,  -2.1180340_rnp,  -0.4253254_rnp /)
                p0(idw,38,:) = (/  1.6392475_rnp,  -1.8090170_rnp,   0.4253254_rnp /)
                p0(idw,39,:) = (/  2.2270327_rnp,  -1.0000000_rnp,   0.4253254_rnp /)
                p0(idw,40,:) = (/  2.3894926_rnp,  -0.5000000_rnp,  -0.4253254_rnp /)
                p0(idw,41,:) = (/  1.7013016_rnp,   0.0000000_rnp,  -1.8017073_rnp /)
                p0(idw,42,:) = (/  0.8506508_rnp,   0.0000000_rnp,  -2.3274384_rnp /)
                p0(idw,43,:) = (/  0.5257311_rnp,   1.6180340_rnp,  -1.8017073_rnp /)
                p0(idw,44,:) = (/  0.2628656_rnp,   0.8090170_rnp,  -2.3274384_rnp /)
                p0(idw,45,:) = (/ -1.3763819_rnp,   1.0000000_rnp,  -1.8017073_rnp /)
                p0(idw,46,:) = (/ -0.6881910_rnp,   0.5000000_rnp,  -2.3274384_rnp /)
                p0(idw,47,:) = (/ -1.3763819_rnp,  -1.0000000_rnp,  -1.8017073_rnp /)
                p0(idw,48,:) = (/ -0.6881910_rnp,  -0.5000000_rnp,  -2.3274384_rnp /)
                p0(idw,49,:) = (/  0.5257311_rnp,  -1.6180340_rnp,  -1.8017073_rnp /)
                p0(idw,50,:) = (/  0.2628656_rnp,  -0.8090170_rnp,  -2.3274384_rnp /)
                p0(idw,51,:) = (/  1.3763819_rnp,   1.0000000_rnp,   1.8017073_rnp /)
                p0(idw,52,:) = (/  0.6881910_rnp,   0.5000000_rnp,   2.3274384_rnp /)
                p0(idw,53,:) = (/ -0.5257311_rnp,   1.6180340_rnp,   1.8017073_rnp /)
                p0(idw,54,:) = (/ -0.2628656_rnp,   0.8090170_rnp,   2.3274384_rnp /)
                p0(idw,55,:) = (/ -1.7013016_rnp,   0.0000000_rnp,   1.8017073_rnp /)
                p0(idw,56,:) = (/ -0.8506508_rnp,   0.0000000_rnp,   2.3274384_rnp /)
                p0(idw,57,:) = (/ -0.5257311_rnp,  -1.6180340_rnp,   1.8017073_rnp /)
                p0(idw,58,:) = (/ -0.2628656_rnp,  -0.8090170_rnp,   2.3274384_rnp /)
                p0(idw,59,:) = (/  1.3763819_rnp,  -1.0000000_rnp,   1.8017073_rnp /)
                p0(idw,60,:) = (/  0.6881910_rnp,  -0.5000000_rnp,   2.3274384_rnp /)
                p0(idw,61,:) = (/  0.0000000_rnp,   0.0000000_rnp,   0.0000000_rnp /)
        endif
! vT-2
        if (nforacase.eq.8) then
                p0(idw,1,:) = (/  1.0000000_rnp,   1.0000000_rnp,   1.0000000_rnp /)
                p0(idw,2,:) = (/ -1.0000000_rnp,  -1.0000000_rnp,   1.0000000_rnp /)
                p0(idw,3,:) = (/  0.0000000_rnp,   0.0000000_rnp,   0.0000000_rnp /)
                if (itst) p0(idw,1:3,:)=p0(idw,1:3,:)/1.732_rnp
        endif
! vOC-2
        if (nforacase.eq.9) then
                p0(idw,1,:) = (/  1.0000000_rnp,   0.0000000_rnp,   0.0000000_rnp /)
                p0(idw,2,:) = (/  0.0000000_rnp,   1.0000000_rnp,   0.0000000_rnp /)
                p0(idw,3,:) = (/  0.0000000_rnp,   0.0000000_rnp,   0.0000000_rnp /)
        endif
! fvOC-3
       if (nforacase.eq.10) then
                p0(idw,1,:) = (/  1.0000000_rnp,   0.0000000_rnp,   0.0000000_rnp /)
                p0(idw,2,:) = (/  0.0000000_rnp,   1.0000000_rnp,   0.0000000_rnp /)
                p0(idw,3,:) = (/  0.0000000_rnp,   0.0000000_rnp,   1.0000000_rnp /)
                p0(idw,4,:) = (/  0.0000000_rnp,   0.0000000_rnp,   0.0000000_rnp /)
        endif
! mvOC-3
        if (nforacase.eq.11) then
                p0(idw,1,:) = (/  1.0000000_rnp,   0.0000000_rnp,   0.0000000_rnp /)
                p0(idw,2,:) = (/  0.0000000_rnp,   1.0000000_rnp,   0.0000000_rnp /)
                p0(idw,3,:) = (/ -1.0000000_rnp,   0.0000000_rnp,   0.0000000_rnp /)
                p0(idw,4,:) = (/  0.0000000_rnp,   0.0000000_rnp,   0.0000000_rnp /)
        endif
! CCU-9 (spherical relaxed - esferes rigides)
       if (nforacase.eq.12) then
                p0(idw,1,:) = (/  0.641833_rnp,  0.641833_rnp,  0.419643_rnp /)
                p0(idw,2,:) = (/  0.641833_rnp, -0.641833_rnp,  0.419643_rnp /)
                p0(idw,3,:) = (/ -0.641833_rnp,  0.641833_rnp,  0.419643_rnp /)
                p0(idw,4,:) = (/ -0.641833_rnp, -0.641833_rnp,  0.419643_rnp /)
                p0(idw,5,:) = (/  0.538682_rnp,  0.538682_rnp, -0.647799_rnp /)
                p0(idw,6,:) = (/  0.538682_rnp, -0.538682_rnp, -0.647799_rnp /)
                p0(idw,7,:) = (/ -0.538682_rnp,  0.538682_rnp, -0.647799_rnp /)
                p0(idw,8,:) = (/ -0.538682_rnp, -0.538682_rnp, -0.647799_rnp /)
                p0(idw,9,:) = (/  0.000000_rnp,  0.000000_rnp,  1.000000_rnp /)
                p0(idw,10,:)= (/  0.000000_rnp,  0.000000_rnp,  0.000000_rnp /)
        endif
! JMBIC-10
        if (nforacase.eq.13) then
                p0(idw,1,:) = (/ -1.29904_rnp,    -0.41868_rnp,    -1.08764_rnp /)
                p0(idw,2,:) = (/ -1.47637_rnp,     0.89401_rnp,    -0.12350_rnp /)
                p0(idw,3,:) = (/ -0.18255_rnp,     1.87174_rnp,    -0.35643_rnp /)
                p0(idw,4,:) = (/  0.10433_rnp,    -0.25233_rnp,    -1.91647_rnp /)
                p0(idw,5,:) = (/  0.69094_rnp,    -0.41377_rnp,     0.66370_rnp /)
                p0(idw,6,:) = (/ -0.24644_rnp,     0.89705_rnp,     0.95879_rnp /)
                p0(idw,7,:) = (/  0.04038_rnp,    -1.22697_rnp,    -0.60110_rnp /)
                p0(idw,8,:) = (/  1.15696_rnp,     1.06349_rnp,     0.13000_rnp /)
                p0(idw,9,:) = (/ -0.83311_rnp,     1.05859_rnp,    -1.62131_rnp /)
                p0(idw,10,:)= (/  0.79436_rnp,     1.16328_rnp,    -1.46454_rnp /)
                p0(idw,11,:)= (/ -0.07105_rnp,     0.32233_rnp,    -0.47880_rnp /)
        endif
! JATDI-10
        if (nforacase.eq.14) then
                p0(idw,1,:) = (/ -0.00170_rnp,    -0.21996_rnp,    -1.09621_rnp /)
                p0(idw,2,:) = (/ -0.58424_rnp,    -0.89446_rnp,    -0.32955_rnp /)
                p0(idw,3,:) = (/  0.00610_rnp,    -0.88206_rnp,     0.68702_rnp /)
                p0(idw,4,:) = (/  0.95344_rnp,    -0.19993_rnp,     0.54861_rnp /)
                p0(idw,5,:) = (/  0.58424_rnp,     0.89446_rnp,     0.32955_rnp /)
                p0(idw,6,:) = (/ -0.00610_rnp,     0.88206_rnp,    -0.68702_rnp /)
                p0(idw,7,:) = (/ -0.94861_rnp,    -0.20926_rnp,     0.55346_rnp /)
                p0(idw,8,:) = (/  0.59129_rnp,    -0.88865_rnp,    -0.33254_rnp /)
                p0(idw,9,:) = (/ -0.59129_rnp,     0.88865_rnp,     0.33254_rnp /)
                p0(idw,10,:)= (/ -0.00438_rnp,     1.84859_rnp,    -0.00830_rnp /)
                p0(idw,11,:)= (/  0.00000_rnp,     0.00000_rnp,     0.00000_rnp /)
                if (itst) p0(idw,1:11,:)=p0(idw,1:11,:)/1.118_rnp
        endif
! JSPC-10
        if (nforacase.eq.15) then
                p0(idw,1,:) = (/ -11.0588_rnp,     2.87815_rnp,     -13.7223_rnp /)
                p0(idw,2,:) = (/ -11.0595_rnp,     2.9091_rnp,     -8.7224_rnp /)
                p0(idw,3,:) = (/ -8.97145_rnp,     6.6871_rnp,     -11.2455_rnp /)
                p0(idw,4,:) = (/ -6.62835_rnp,     4.6797_rnp,     -15.18_rnp /)
                p0(idw,5,:) = (/ -7.0282_rnp,     -0.0805_rnp,     -13.7034_rnp /)
                p0(idw,6,:) = (/ -7.0289_rnp,     -0.0495_rnp,     -8.7035_rnp /)
                p0(idw,7,:) = (/ -6.62945_rnp,     4.7286_rnp,     -7.2859_rnp /)
                p0(idw,8,:) = (/ -3.98895_rnp,     6.2696_rnp,     -11.2423_rnp /)
                p0(idw,9,:) = (/ -2.5614_rnp,     2.1661_rnp,     -13.7167_rnp /)
                p0(idw,10,:)= (/ -2.56205_rnp,     2.19705_rnp,     -8.7168_rnp /)
                p0(idw,11,:)= (/ -6.7517_rnp,     3.23855_rnp,     -11.2239_rnp /)
                if (itst) p0(idw,1:11,:)=p0(idw,1:11,:)/2.500_rnp
        endif
! JAPPR-11
        if (nforacase.eq.16) then
                p0(idw,1,:) = (/  0.0_rnp,    -0.707_rnp,  0.0_rnp /)
                p0(idw,2,:) = (/  0.0_rnp,     1.539_rnp,  0.5_rnp /)
                p0(idw,3,:) = (/  0.809_rnp,   0.951_rnp,  0.5_rnp /)
                p0(idw,4,:) = (/  0.5_rnp,     0.0_rnp,    0.5_rnp /)
                p0(idw,5,:) = (/ -0.5_rnp,     0.0_rnp,    0.5_rnp /)
                p0(idw,6,:) = (/ -0.809_rnp,   0.951_rnp,  0.5_rnp /)
                p0(idw,7,:) = (/  0.0_rnp,     1.539_rnp, -0.5_rnp /)
                p0(idw,8,:) = (/  0.809_rnp,   0.951_rnp, -0.5_rnp /)
                p0(idw,9,:) = (/  0.5_rnp,     0.0_rnp,   -0.5_rnp /)
                p0(idw,10,:)= (/ -0.5_rnp,     0.0_rnp,   -0.5_rnp /)
                p0(idw,11,:)= (/ -0.809_rnp,   0.951_rnp, -0.5_rnp /)
                p0(idw,12,:)= (/  0.0_rnp,     0.6882_rnp, 0.0_rnp /)
        endif
! JASPC-11 (J87)
        if (nforacase.eq.17) then
                p0(idw,1,:) = (/ -0.500000_rnp,  0.522357_rnp,  0.852727_rnp /)
                p0(idw,2,:) = (/  0.500000_rnp,  0.522357_rnp,  0.852727_rnp /)
                p0(idw,3,:) = (/  0.000000_rnp,  1.313295_rnp,  0.500000_rnp /)
                p0(idw,4,:) = (/ -0.789427_rnp,  0.957200_rnp,  0.000000_rnp /)
                p0(idw,5,:) = (/ -0.500000_rnp,  0.000000_rnp,  0.000000_rnp /)
                p0(idw,6,:) = (/  0.500000_rnp,  0.000000_rnp,  0.000000_rnp /)
                p0(idw,7,:) = (/  0.789427_rnp,  0.957200_rnp,  0.000000_rnp /)
                p0(idw,8,:) = (/  0.000000_rnp,  1.313295_rnp, -0.500000_rnp /)
                p0(idw,9,:) = (/ -0.500000_rnp,  0.522357_rnp, -0.852727_rnp /)
                p0(idw,10,:)= (/  0.500000_rnp,  0.522357_rnp, -0.852727_rnp /)
                p0(idw,11,:)= (/  0.000000_rnp, -0.341791_rnp,  0.795726_rnp /)
                p0(idw,12,:)= (/  0.000000_rnp,  0.000000_rnp,  0.000000_rnp /)
        endif
! JBAPPR-12 (J53)
        if (nforacase.eq.18) then
                p0(idw,1,:) = (/  0.850651_rnp,  0.500000_rnp,  0.000000_rnp /)
                p0(idw,2,:) = (/  0.262866_rnp,  0.500000_rnp,  0.809017_rnp /)
                p0(idw,3,:) = (/ -0.688191_rnp,  0.500000_rnp,  0.500000_rnp /)
                p0(idw,4,:) = (/ -0.688191_rnp,  0.500000_rnp, -0.500000_rnp /)
                p0(idw,5,:) = (/  0.262866_rnp,  0.500000_rnp, -0.809017_rnp /)
                p0(idw,6,:) = (/  0.850651_rnp, -0.500000_rnp,  0.000000_rnp /)
                p0(idw,7,:) = (/  0.262866_rnp, -0.500000_rnp,  0.809017_rnp /)
                p0(idw,8,:) = (/ -0.688191_rnp, -0.500000_rnp,  0.500000_rnp /)
                p0(idw,9,:) = (/ -0.688191_rnp, -0.500000_rnp, -0.500000_rnp /)
                p0(idw,10,:)= (/  0.262866_rnp, -0.500000_rnp, -0.809017_rnp /)
                p0(idw,11,:)= (/ -1.395298_rnp,  0.000000_rnp,  0.000000_rnp /)
                p0(idw,12,:)= (/  1.128820_rnp,  0.000000_rnp,  0.820135_rnp /)
                p0(idw,13,:)= (/  0.000000_rnp,  0.000000_rnp,  0.000000_rnp /)
        endif
! JSPMC-12 (J88)
        if (nforacase.eq.19) then
                p0(idw,1,:) = (/ -0.500000_rnp,  0.803997_rnp, -0.594633_rnp /)
                p0(idw,2,:) = (/ -0.854743_rnp,  1.525501_rnp,  0.000000_rnp /)
                p0(idw,3,:) = (/  0.000000_rnp,  1.664836_rnp, -0.500000_rnp /)
                p0(idw,4,:) = (/ -1.283102_rnp,  0.621893_rnp,  0.000000_rnp /)
                p0(idw,5,:) = (/  0.500000_rnp,  0.803997_rnp, -0.594633_rnp /)
                p0(idw,6,:) = (/ -0.500000_rnp,  0.000000_rnp,  0.000000_rnp /)
                p0(idw,7,:) = (/  0.000000_rnp,  1.664836_rnp,  0.500000_rnp /)
                p0(idw,8,:) = (/ -0.500000_rnp,  0.803997_rnp,  0.594633_rnp /)
                p0(idw,9,:) = (/  0.854743_rnp,  1.525501_rnp,  0.000000_rnp /)
                p0(idw,10,:)= (/  0.500000_rnp,  0.000000_rnp,  0.000000_rnp /)
                p0(idw,11,:)= (/  0.500000_rnp,  0.803997_rnp,  0.594633_rnp /)
                p0(idw,12,:)= (/  1.283102_rnp,  0.621893_rnp,  0.000000_rnp /)
                p0(idw,13,:)= (/  0.000000_rnp,  0.000000_rnp,  0.000000_rnp /)
        endif
! HH-9
        if (nforacase.eq.20) then
                p0(idw,1,:) = (/  1.00000000_rnp,           0.00000000_rnp,           0.00000000_rnp /)
                p0(idw,2,:) = (/  0.50000000_rnp,           0.86602540_rnp,           0.00000000_rnp /)
                p0(idw,3,:) = (/ -0.50000000_rnp,           0.86602540_rnp,           0.00000000_rnp /)
                p0(idw,4,:) = (/ -1.00000000_rnp,           0.00000000_rnp,           0.00000000_rnp /)
                p0(idw,5,:) = (/ -0.50000000_rnp,          -0.86602540_rnp,           0.00000000_rnp /)
                p0(idw,6,:) = (/  0.50000000_rnp,          -0.86602540_rnp,           0.00000000_rnp /)
                p0(idw,7,:) = (/  0._rnp,  0._rnp,  1._rnp /)
                p0(idw,8,:) = (/  0.5_rnp, 0._rnp,  -0.8660254038_rnp /)
                p0(idw,9,:) = (/ -0.5_rnp, 0._rnp,  -0.8660254038_rnp /)
                p0(idw,10,:)= (/  0.00000000_rnp,           0.00000000_rnp,           0.00000000_rnp /)
        endif
! MFF-9
        if (nforacase.eq.21) then
                p0(idw,1,:) = (/  0.0000_rnp,   0.8506_rnp,   0.1360_rnp /)
                p0(idw,2,:) = (/  0.8090_rnp,   0.2628_rnp,   0.1360_rnp /)
                p0(idw,3,:) = (/  0.5000_rnp,  -0.6882_rnp,   0.1360_rnp /)
                p0(idw,4,:) = (/ -0.5000_rnp,  -0.6882_rnp,   0.1360_rnp /)
                p0(idw,5,:) = (/ -0.8090_rnp,   0.2628_rnp,   0.1360_rnp /)
                p0(idw,6,:) = (/ -0.5000_rnp,  -0.2894_rnp,  -0.6400_rnp /)
                p0(idw,7,:) = (/  0.5000_rnp,  -0.2894_rnp,  -0.6400_rnp /)
                p0(idw,8,:) = (/  0.0000_rnp,   0.5766_rnp,  -0.6400_rnp /)
                p0(idw,9,:) = (/  0.0000_rnp,   0.0000_rnp,   0.8610_rnp /)
                p0(idw,10,:)= (/  0.0000_rnp,   0.0000_rnp,   0.0000_rnp /)
        endif
! SDD-10
        if (nforacase.eq.22) then
                p0(idw,1,:) = (/ -1.0_rnp,   1.732_rnp,  0.0_rnp /)
                p0(idw,2,:) = (/  1.0_rnp,   1.732_rnp,  0.0_rnp /)
                p0(idw,3,:) = (/ -2.0_rnp,   0.0_rnp,    0.0_rnp /)
                p0(idw,4,:) = (/  2.0_rnp,   0.0_rnp,    0.0_rnp /)
                p0(idw,5,:) = (/ -1.0_rnp,  -1.732_rnp,  0.0_rnp /)
                p0(idw,6,:) = (/  1.0_rnp,  -1.732_rnp,  0.0_rnp /)
                p0(idw,7,:) = (/ -1.0_rnp,   0.0_rnp,    1.732_rnp /)
                p0(idw,8,:) = (/  1.0_rnp,   0.0_rnp,    1.732_rnp /)
                p0(idw,9,:) = (/  0.5_rnp,   0.866_rnp, -1.732_rnp /)
                p0(idw,10,:)= (/ -0.5_rnp,  -0.866_rnp, -1.732_rnp /)
                p0(idw,11,:)= (/  0.0_rnp,   0.0_rnp,    0.0_rnp /)
                if (itst) p0(idw,1:11,:)=p0(idw,1:11,:)*0.5_rnp
        endif
! TD-10
        if (nforacase.eq.23) then
                p0(idw,1,:) = (/ -1.0_rnp,   1.732_rnp,  0.0_rnp /)
                p0(idw,2,:) = (/  1.0_rnp,   1.732_rnp,  0.0_rnp /)
                p0(idw,3,:) = (/ -2.0_rnp,   0.0_rnp,    0.0_rnp /)
                p0(idw,4,:) = (/  2.0_rnp,   0.0_rnp,    0.0_rnp /)
                p0(idw,5,:) = (/ -1.0_rnp,  -1.732_rnp,  0.0_rnp /)
                p0(idw,6,:) = (/  1.0_rnp,  -1.732_rnp,  0.0_rnp /)
                p0(idw,7,:) = (/ -1.0_rnp,   0.0_rnp,    1.732_rnp /)
                p0(idw,8,:) = (/  1.0_rnp,   0.0_rnp,    1.732_rnp /)
                p0(idw,9,:) = (/  0.0_rnp,   1.0_rnp,   -1.732_rnp /)
                p0(idw,10,:)= (/  0.0_rnp,  -1.0_rnp,   -1.732_rnp /)
                p0(idw,11,:)= (/  0.0_rnp,   0.0_rnp,    0.0_rnp /)
                if (itst) p0(idw,1:11,:)=p0(idw,1:11,:)*0.5_rnp
        endif
! HD-10
        if (nforacase.eq.24) then
                p0(idw,1,:) = (/ -1.0_rnp,   1.732_rnp,  0.0_rnp /)
                p0(idw,2,:) = (/  1.0_rnp,   1.732_rnp,  0.0_rnp /)
                p0(idw,3,:) = (/ -2.0_rnp,   0.0_rnp,    0.0_rnp /)
                p0(idw,4,:) = (/  2.0_rnp,   0.0_rnp,    0.0_rnp /)
                p0(idw,5,:) = (/ -1.0_rnp,  -1.732_rnp,  0.0_rnp /)
                p0(idw,6,:) = (/  1.0_rnp,  -1.732_rnp,  0.0_rnp /)
                p0(idw,7,:) = (/ -1.0_rnp,   0.0_rnp,    1.732_rnp /)
                p0(idw,8,:) = (/  1.0_rnp,   0.0_rnp,    1.732_rnp /)
                p0(idw,9,:) = (/ -1.0_rnp,   0.0_rnp,   -1.732_rnp /)
                p0(idw,10,:)= (/  1.0_rnp,   0.0_rnp,   -1.732_rnp /)
                p0(idw,11,:)= (/  0.0_rnp,   0.0_rnp,    0.0_rnp /)
                if (itst) p0(idw,1:11,:)=p0(idw,1:11,:)*0.5_rnp
        endif
! TCU-24
        if (nforacase.eq.25) then
                waux=sqrt(2._rnp)-1._rnp
                p0(idw,1,:) = (/  waux,        1.0_rnp,        1.0_rnp /)
                p0(idw,2,:) = (/ -waux,       -1.0_rnp,       -1.0_rnp /)
                p0(idw,3,:) = (/  waux,       -1.0_rnp,       -1.0_rnp /)
                p0(idw,4,:) = (/ -waux,        1.0_rnp,       -1.0_rnp /)
                p0(idw,5,:) = (/ -waux,       -1.0_rnp,        1.0_rnp /)
                p0(idw,6,:) = (/  waux,        1.0_rnp,       -1.0_rnp /)
                p0(idw,7,:) = (/ -waux,        1.0_rnp,        1.0_rnp /)
                p0(idw,8,:) = (/  waux,       -1.0_rnp,        1.0_rnp /)
                p0(idw,9,:) = (/  1.0_rnp,        waux,        1.0_rnp /)
                p0(idw,10,:)= (/ -1.0_rnp,       -waux,       -1.0_rnp /)
                p0(idw,11,:)= (/  1.0_rnp,       -waux,       -1.0_rnp /)
                p0(idw,12,:)= (/ -1.0_rnp,        waux,       -1.0_rnp /)
                p0(idw,13,:)= (/ -1.0_rnp,       -waux,        1.0_rnp /)
                p0(idw,14,:)= (/  1.0_rnp,        waux,       -1.0_rnp /)
                p0(idw,15,:)= (/ -1.0_rnp,        waux,        1.0_rnp /)
                p0(idw,16,:)= (/  1.0_rnp,       -waux,        1.0_rnp /)
                p0(idw,17,:)= (/  1.0_rnp,        1.0_rnp,        waux /)
                p0(idw,18,:)= (/ -1.0_rnp,       -1.0_rnp,       -waux /)
                p0(idw,19,:)= (/  1.0_rnp,       -1.0_rnp,       -waux /)
                p0(idw,20,:)= (/ -1.0_rnp,        1.0_rnp,       -waux /)
                p0(idw,21,:)= (/ -1.0_rnp,       -1.0_rnp,        waux /)
                p0(idw,22,:)= (/  1.0_rnp,        1.0_rnp,       -waux /)
                p0(idw,23,:)= (/ -1.0_rnp,        1.0_rnp,        waux /)
                p0(idw,24,:)= (/  1.0_rnp,       -1.0_rnp,        waux /)
                p0(idw,25,:)= (/  0.0_rnp, 0.0_rnp, 0.0_rnp /)
        endif
! TOC-24
        if (nforacase.eq.26) then
                p0(idw,1,:) = (/ 2.00000_rnp,        1.00000_rnp,        0.00000_rnp /)
                p0(idw,2,:) = (/ -2.00000_rnp,       -1.00000_rnp,        0.00000_rnp /)
                p0(idw,3,:) = (/ 2.00000_rnp,       -1.00000_rnp,        0.00000_rnp /)
                p0(idw,4,:) = (/ -2.00000_rnp,        1.00000_rnp,        0.00000_rnp /)
                p0(idw,5,:) = (/ 0.00000_rnp,        2.00000_rnp,        1.00000_rnp /)
                p0(idw,6,:) = (/ 0.00000_rnp,       -2.00000_rnp,       -1.00000_rnp /)
                p0(idw,7,:) = (/ 0.00000_rnp,        2.00000_rnp,       -1.00000_rnp /)
                p0(idw,8,:) = (/ 0.00000_rnp,       -2.00000_rnp,        1.00000_rnp /)
                p0(idw,9,:) = (/ 1.00000_rnp,        0.00000_rnp,        2.00000_rnp /)
                p0(idw,10,:)= (/ -1.00000_rnp,        0.00000_rnp,       -2.00000_rnp /)
                p0(idw,11,:)= (/ 1.00000_rnp,        0.00000_rnp,       -2.00000_rnp /)
                p0(idw,12,:)= (/ -1.00000_rnp,        0.00000_rnp,        2.00000_rnp /)
                p0(idw,13,:)= (/ 1.00000_rnp,        2.00000_rnp,        0.00000_rnp /)
                p0(idw,14,:)= (/ -1.00000_rnp,       -2.00000_rnp,        0.00000_rnp /)
                p0(idw,15,:)= (/ 1.00000_rnp,       -2.00000_rnp,        0.00000_rnp /)
                p0(idw,16,:)= (/ -1.00000_rnp,        2.00000_rnp,        0.00000_rnp /)
                p0(idw,17,:)= (/ 0.00000_rnp,        1.00000_rnp,        2.00000_rnp /)
                p0(idw,18,:)= (/ 0.00000_rnp,       -1.00000_rnp,       -2.00000_rnp /)
                p0(idw,19,:)= (/ 0.00000_rnp,        1.00000_rnp,       -2.00000_rnp /)
                p0(idw,20,:)= (/ 0.00000_rnp,       -1.00000_rnp,        2.00000_rnp /)
                p0(idw,21,:)= (/ 2.00000_rnp,        0.00000_rnp,        1.00000_rnp /)
                p0(idw,22,:)= (/ -2.00000_rnp,        0.00000_rnp,       -1.00000_rnp /)
                p0(idw,23,:)= (/ 2.00000_rnp,        0.00000_rnp,       -1.00000_rnp /)
                p0(idw,24,:)= (/ -2.00000_rnp,        0.00000_rnp,        1.00000_rnp /)
                p0(idw,25,:)= (/  0.0_rnp, 0.0_rnp, 0.0_rnp /)
        endif
! TCOC-48
        if (nforacase.eq.27) then
                wauxa=1._rnp+sqrt(2._rnp)
                wauxb=1._rnp+sqrt(8._rnp)
                p0(idw,1,:) = (/  1._rnp,        wauxa,        wauxb /)
                p0(idw,2,:) = (/  -1._rnp,       -wauxa,       -wauxb /)
                p0(idw,3,:) = (/  1._rnp,       -wauxa,       -wauxb /)
                p0(idw,4,:) = (/  -1._rnp,        wauxa,       -wauxb /)
                p0(idw,5,:) = (/  -1._rnp,       -wauxa,        wauxb /)
                p0(idw,6,:) = (/  1._rnp,        wauxa,       -wauxb /)
                p0(idw,7,:) = (/  -1._rnp,        wauxa,        wauxb /)
                p0(idw,8,:) = (/  1._rnp,       -wauxa,        wauxb /)
                p0(idw,9,:) = (/  1._rnp,        wauxb,        wauxa /)
                p0(idw,10,:)= (/  -1._rnp,       -wauxb,       -wauxa /)
                p0(idw,11,:)= (/  1._rnp,       -wauxb,       -wauxa /)
                p0(idw,12,:)= (/  -1._rnp,        wauxb,       -wauxa /)
                p0(idw,13,:)= (/  -1._rnp,       -wauxb,        wauxa /)
                p0(idw,14,:)= (/  1._rnp,        wauxb,       -wauxa /)
                p0(idw,15,:)= (/  -1._rnp,        wauxb,        wauxa /)
                p0(idw,16,:)= (/  1._rnp,       -wauxb,        wauxa /)
                p0(idw,17,:)= (/  wauxa,        1._rnp,        wauxb /)
                p0(idw,18,:)= (/  -wauxa,       -1._rnp,       -wauxb /)
                p0(idw,19,:)= (/  wauxa,       -1._rnp,       -wauxb /)
                p0(idw,20,:)= (/  -wauxa,        1._rnp,       -wauxb /)
                p0(idw,21,:)= (/  -wauxa,       -1._rnp,        wauxb /)
                p0(idw,22,:)= (/  wauxa,        1._rnp,       -wauxb /)
                p0(idw,23,:)= (/  -wauxa,        1._rnp,        wauxb /)
                p0(idw,24,:)= (/  wauxa,       -1._rnp,        wauxb /)
                p0(idw,25,:)= (/  wauxa,        wauxb,        1._rnp /)
                p0(idw,26,:)= (/  -wauxa,       -wauxb,       -1._rnp /)
                p0(idw,27,:)= (/  wauxa,       -wauxb,       -1._rnp /)
                p0(idw,28,:)= (/  -wauxa,        wauxb,       -1._rnp /)
                p0(idw,29,:)= (/  -wauxa,       -wauxb,        1._rnp /)
                p0(idw,30,:)= (/  wauxa,        wauxb,       -1._rnp /)
                p0(idw,31,:)= (/  -wauxa,        wauxb,        1._rnp /)
                p0(idw,32,:)= (/  wauxa,       -wauxb,        1._rnp /)
                p0(idw,33,:)= (/  wauxb,        wauxa,        1._rnp /)
                p0(idw,34,:)= (/  -wauxb,       -wauxa,       -1._rnp /)
                p0(idw,35,:)= (/  wauxb,       -wauxa,       -1._rnp /)
                p0(idw,36,:)= (/  -wauxb,        wauxa,       -1._rnp /)
                p0(idw,37,:)= (/  -wauxb,       -wauxa,        1._rnp /)
                p0(idw,38,:)= (/  wauxb,        wauxa,       -1._rnp /)
                p0(idw,39,:)= (/  -wauxb,        wauxa,        1._rnp /)
                p0(idw,40,:)= (/  wauxb,       -wauxa,        1._rnp /)
                p0(idw,41,:)= (/  wauxb,        1._rnp,        wauxa /)
                p0(idw,42,:)= (/  -wauxb,       -1._rnp,       -wauxa /)
                p0(idw,43,:)= (/  wauxb,       -1._rnp,       -wauxa /)
                p0(idw,44,:)= (/  -wauxb,        1._rnp,       -wauxa /)
                p0(idw,45,:)= (/  -wauxb,       -1._rnp,        wauxa /)
                p0(idw,46,:)= (/  wauxb,        1._rnp,       -wauxa /)
                p0(idw,47,:)= (/  -wauxb,        1._rnp,        wauxa /)
                p0(idw,48,:)= (/  wauxb,       -1._rnp,        wauxa /)
                p0(idw,49,:)= (/  0.0_rnp, 0.0_rnp, 0.0_rnp /)
        endif
        if (nforacase.eq.99) then
                dcr(idw)='*** NOT FOUND ***'//trim(dcr(idw))
                do kforc=1,13
                  p0(idw,kforc,:) = (/  kforc*1._rnp,   0._rnp,   0._rnp /)
                enddo
        endif

      endif

      if ((tocalc).and.(found_ideal)) then

        if (john) then
          inl=0
          alfa=360._rnp/ijh(1)*radians
          a10=0._rnp
          if (ijh(2).ne.-1) then
            a20=0._rnp
          else
            a20=alfa/2._rnp
          endif
          dvv_2=2._rnp*(1._rnp-cos(alfa))
          h10=0._rnp
          h20=0._rnp
          if (ijh(2).eq.+1) then
            h10=sqrt(dvv_2)/2._rnp
            h20=-h10
          elseif (ijh(2).eq.-1) then
            h10=sqrt(2._rnp*(cos(alfa/2._rnp)-cos(alfa)))/2._rnp
            h20=-h10
          endif
          do i=0,ijh(1)-1
            a1=a10+i*alfa
            inl=inl+1
            p0(idw,inl,:)=(/cos(a1),sin(a1),h10/)
            if (ijh(2).ne.0) then
              a2=a20+i*alfa
              inl=inl+1
              p0(idw,inl,:)=(/cos(a2),sin(a2),h20/)
            endif
          enddo
          if (ijh(3).eq.1) then
            h11=h10+sqrt(1._rnp-2._rnp*cos(alfa))
            inl=inl+1
            p0(idw,inl,:)=(/0._rnp,0._rnp,h11/)
          elseif (ijh(3).eq.2) then
            ggg=(1._rnp-cos(alfa))/(1._rnp-cos(2._rnp*alfa))
            h11=h10+sqrt(1._rnp-2._rnp*cos(alfa)+2._rnp*sqrt(ggg)*cos(alfa/2._rnp)-ggg)
            r11=sqrt(ggg)
            a11=a10+alfa/2._rnp
            do i=0,ijh(1)/2-1
              a1=a11+i*2._rnp*alfa
              inl=inl+1
              p0(idw,inl,:)=(/r11*cos(a1),r11*sin(a1),h11/)
            enddo
          endif
          if (ijh(4).eq.1) then
            h21=h20-sqrt(1._rnp-2._rnp*cos(alfa))
            inl=inl+1
            p0(idw,inl,:)=(/0._rnp,0._rnp,h21/)
          elseif (ijh(4).eq.2) then
            ggg=(1._rnp-cos(alfa))/(1._rnp-cos(2._rnp*alfa))
            h21=h20-sqrt(1._rnp-2._rnp*cos(alfa)+2._rnp*sqrt(ggg)*cos(alfa/2._rnp)-ggg)
            r21=sqrt(ggg)
            a21=a20+ijh(5)*alfa/2._rnp
            do i=0,ijh(1)/2-1
              a2=a21+i*2._rnp*alfa
              inl=inl+1
              p0(idw,inl,:)=(/r21*cos(a2),r21*sin(a2),h21/)
            enddo
          endif
          pm(:)=0._rnp
        else

        ncs=count(nls(:).ne.0)
        if ( (any(nls(:).lt.0)) .or. (nls(0).eq.1) .or. (all(nls(:).le.0)) .or. ((ncs.eq.1).and.(nls(0).eq.0)) .or. &
             (cft(+1).and.(nls(+1).eq.0)) .or. (cft(-1).and.(nls(-1).eq.0)) .or. (cft(0)) .or. (krm(2).lt.0) .or. &
             (abs(krm(1)).gt.1) ) &
          stop '* ERROR * Inconsistent reference structrure'

        do is=-1,+1
          if (nls(is).eq.0) cycle
          pr(is,1,:)=0._rnp
          ar0=360._rnp/nls(is)*radians
          dl2(is)=2._rnp*(1._rnp-cos(ar0))
          if (nls(is).eq.1) cycle
          do il=1,nls(is)
            ar=ar0*(0.5_rnp*ir1(is)+il-1)
            pr(is,il,:)=(/cos(ar),sin(ar),0._rnp/)
          enddo
        enddo
        isr=0
        if (nls(isr).le.1) isr=+1
        if (nls(isr).le.1) isr=-1
        dl2r=dl2(isr)
        do is=-1,+1
          if ((nls(is).le.1).or.(is.eq.isr)) cycle
          pr(is,1:nls(is),1:2)=pr(is,1:nls(is),1:2)*sqrt(dl2r/dl2(is))
        enddo
        if (nls(0).eq.0) then
          if ((nls(+1).eq.1).and.(nls(-1).eq.1)) then
            pr(+1,1,3)=+1._rnp
            pr(-1,1,3)=-1._rnp
          else
            z2=dl2r-dlp2(+1,-1)
            dr2=dxp2(+1)-dxp2(-1)
            if ((z2.le.0._rnp).or.(abs(dr2).ge.z2)) stop '* ERROR * Inconsistent prism shift in reference structure'
            zi=0.5_rnp/sqrt(z2)
            pr(+1,1:nls(+1),3)=zi*(z2-dr2)
            pr(-1,1:nls(-1),3)=-zi*(z2+dr2)
          endif
        else
          do is=-1,+1,2
            if (nls(is).eq.0) cycle
            if (frcdm)  z2=dxp2(0)-dxp2(is)
            if (.not.frcdm) z2=dl2r-dlp2(0,is)
            if (z2.le.0._rnp) stop '* ERROR * Inconsistent slab shift in reference structure'
            pr(is,1:nls(is),3)=is*sqrt(z2)
          enddo
        endif
        do is=-1,+1
          if (cft(is)) pcft(is,:)=(/0._rnp,0._rnp,is*dstx(is)/)
          if (ir2(is).ne.0) then
            dm=sqrt(dxp2(is))
            do il=1,nls(is)
              ar=ar0*(0.5_rnp*(ir1(is)+ir2(is))+il-1)
              pr(is,il,1:2)=(/dm*cos(ar),dm*sin(ar)/)
            enddo
          endif
        enddo
        pm(:)=0._rnp
        if (krm(2).ne.0) then
          if (krm(2).gt.nls(krm(1))) stop '* ERROR * Inconsistent metal replacement in reference structure'
          pm(:)=pr(krm(1),krm(2),:)
          mlg(krm(1),krm(2))=mlg(krm(1),krm(2))-1
        endif

        inl=0
        do is=-1,+1
          do il=1,nls(is)
            do im=1,mlg(is,il)
              inl=inl+1
              p0(idw,inl,:)=pr(is,il,:)
            enddo
          enddo
        enddo
        do ic=-1,+1
          if (.not.cft(ic)) cycle
          inl=inl+1
          p0(idw,inl,:)=pcft(ic,:)
        enddo
        if (trunc.ne.0) then
          ftr=0.5_rnp
          if (inl.lt.3) stop '* ERROR * Too few vertices for truncation option'
          dmin=huge(0._rnp)
          do iv=2,inl
            dv=sum((p0(idw,iv,:)-p0(idw,1,:))**2)
            if (dv.lt.dmin) dmin=dv
          enddo
          do ir=1,inl
            nv=0
            do iv=1,inl
              if (iv.eq.ir) cycle
              dv=sum((p0(idw,iv,:)- p0(idw,ir,:))**2)
              if (abs(dv-dmin).lt.1.e-7_rnp) then
                nv=nv+1
                wnv(nv)=iv
              endif
            enddo
            if (ir.eq.1) then
              nvref=nv
              allocate(trp(nv*inl,3))
              inlt=0
            else
              if (nv.ne.nvref) stop '* ERROR * Non equivalent vertices'
            endif
            dvmin=huge(0._rnp)
            do iv1=1,nv
            do iv2=iv1+1,nv
              dv=sum((p0(idw,iv1,:)- p0(idw,iv2,:))**2)
              if (dv.lt.dvmin) dvmin=dv
            enddo
            enddo
            if (ir.eq.1) then
              dvref=dvmin
            else
              if (abs(dvmin-dvref).gt.1.e-7_rnp) stop '* ERROR * Non equivalent distances'
            endif
            if (trunc.eq.-1) ftr=dmin/(dvmin+2._rnp*dmin)
            do iv=1,nv
              inew=inlt+1
              trp(inew,:)=p0(idw,ir,:)+ftr*(p0(idw,wnv(iv),:)-p0(idw,ir,:))
              inlt=inew
              do ic=1,inew-1
                if (sum((trp(inew,:)-trp(ic,:))**2).lt.1.e-7_rnp) then
                  inlt=inlt-1
                endif
              enddo
            enddo
          enddo
          inl=inlt
          do i=1,inl
            p0(idw,i,:)=trp(i,:)
          enddo
          deallocate(trp)
        endif
        endif
        if (inl.ne.nl) stop '* ERROR * Wrong number of ligands in the reference structrure'
        p0(idw,inl+1,:)=pm(:)
        if (itst) then
          if (trim(iup(idw)).eq."JBCCU-10") p0(idw,1:11,:)=p0(idw,1:11,:)/1.225_rnp
          if (trim(iup(idw)).eq."JETBPY-8") p0(idw,1:9,:)=p0(idw,1:9,:)/1.323_rnp
          if (trim(iup(idw)).eq."JETPY-7") p0(idw,1:8,:)=p0(idw,1:8,:)/1.323_rnp
          if (trim(iup(idw)).eq."T-4") p0(idw,1:5,:)=p0(idw,1:5,:)/1.225_rnp
          if (trim(iup(idw)).eq."TT-12") p0(idw,1:13,:)=p0(idw,1:13,:)/0.782_rnp
        endif
      endif

  888 ids=id
      do i=3,0,-1
        k=ids/10**i
        ntw(4-i:4-i)=digit(k+1:k+1)
        ids=ids-k*10**i
      enddo
      k=verify(ntw,'0')
      if (k.eq.0) k=4
      if (k.ne.1) ntw(1:k-1)=repeat(' ',k-1)

      dcr(idw)=iup(idw)//' '//ntw//' '//sim(idw)//' '//dcr(idw)(1:50)

      if (found_ideal) then
        found_ideal=((len_trim(sim(idw)).ne.0).and.(all(p0(idw,1:nl+1,:).lt.huge(0._rnp)/2._rnp)))
        if (nl+1.lt.mmx) found_ideal=((found_ideal).and.(all(p0(idw,nl+2:,:).gt.huge(0._rnp)/2._rnp)))
        if (.not.found_ideal) stop '* ERROR * Wrong geometry description'

        call anl_geometry(0)
! 2016.10 ef1 - Augment vertexs maxims sense FIXPERM ----\
!        if (nl.le.12) then
        if (nl.le.60) then
! 2016.10 ef1 - Augment vertexs maxims sense FIXPERM ----/
          if (ichk.eq.0.and..not.ifixp) call equivper
        else
          if (itst) then
            write(out_fl,"(/2x,'This reference structure cannot be used without FIXPERM option')")
          elseif (ichk.eq.0.and..not.ifixp) then
            stop '* ERROR * FIXPERM option is needed for this number of vertices'
          endif
        endif
      else
        if (ichk.eq.0) stop '* ERROR * Inexistent reference structure'
      endif

  999 return

      contains

      function dxp2 (is0)
      integer,   intent(in)   :: is0
      dxp2=sum(pr(is0,1,:2)**2)
      return
      end function

      function dlp2 (is1,is2)
      integer,   intent(in)   :: is1, is2
      dlp2=sum((pr(is1,1,:2)-pr(is2,1,:2))**2)
      return
      end function

      function dstx (is0)
      integer,   intent(in)   :: is0
      dstx=sqrt(sum(pr(is0,1,:)**2))
      return
      end function

      end subroutine

 ! xxx - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

      subroutine equivper

      use cominfo
      implicit real(rnp) (a-h,o-z)

      logical    :: ctrl(mmx)
      integer    :: ip(mmx), ipo(mmx)
      real(rnp)  :: hi(mmx,mmx,3,3), h0(3,3), h(3,3)
      real(rnp), allocatable :: d2qt(:,:,:,:,:)
      real(rnp)  :: d2mn(0:mmx)
      real(rnp)  :: qmd(mmx), pmd(mmx), hcp(3,3)

      allocate(d2qt((mmx+1)/4,mmx,mmx,mmx,mmx))
      pw(1:m,:)=p0(idw,1:m,:)

      h(:,:)=0._rnp
      do i=1,mnf
      do j=1,mnf
        hi(i,j,:,:)=matmul(transpose(pw(i:i,:)),pw(j:j,:))
      enddo
      h(:,:)=h(:,:)+hi(i,i,:,:)
      enddo
      h0(:,:)=0._rnp
      do i=mnf+1,m
        h0(:,:)=h0(:,:)+matmul(transpose(pw(i:i,:)),pw(i:i,:))
      enddo
      h(:,:)=h(:,:)+h0(:,:)
      h0(:,:)=h(:,:)

      do i=1,mef
        pmd(i)=dot_product(pw(i,:),pw(i,:))
        qmd(i)=pmd(i)
      enddo

      d2mn(0)=0._rnp
      do iq=1,mef-3,4
      qmd(iq)=qmd(iq)+qmd(iq+1)+qmd(iq+2)+qmd(iq+3)
      iq0=(iq-1)/4+1
      do ia=1,mef
      do ib=1,mef
      if (ib.eq.ia) cycle
      do ic=1,mef
      if ((ic.eq.ia).or.(ic.eq.ib)) cycle
      do id=1,mef
      if ((id.eq.ia).or.(id.eq.ib).or.(id.eq.ic)) cycle
        hcp(:,:)=hi(ia,iq,:,:)+hi(ib,iq+1,:,:)+hi(ic,iq+2,:,:)+hi(id,iq+3,:,:)
        tr=suml(hcp)
        d2qt(iq0,ia,ib,ic,id)=qmd(iq)-tr**2/(pmd(ia)+pmd(ib)+pmd(ic)+pmd(id))
      enddo
      enddo
      enddo
      enddo
      enddo

      amx2=m**2-1.d-8
      ctrl(:mef)=.false.
      ip(:mef)=0
      ipo(:mef)=(/(j,j=1,mef)/)
      idc=1
      init=0
      d2mn(1:)=0._rnp

      npe(idw)=0

      PERMUT: do while (idc.ne.-1)

        ip(idc)=ip(idc)+1
        if (ip(idc).gt.mef) then
          ip(idc)=0
          idc=idc-1
          if (idc.eq.0) exit PERMUT
          ctrl(ip(idc))=.false.
          cycle PERMUT
        endif
        if (ctrl(ip(idc))) cycle PERMUT

        if (idc/4*4.eq.idc) then
          d2mn(idc)=d2mn(idc-1)+d2qt(idc/4,ip(idc-3),ip(idc-2),ip(idc-1),ip(idc))
        else
          d2mn(idc)=d2mn(idc-1)
        endif
        if (m-amx2/m.lt.d2mn(idc)) cycle PERMUT

        if (idc.ne.mef) then
          ctrl(ip(idc))=.true.
          idc=idc+1
          cycle PERMUT
        endif

        init=init+1
        if (init.eq.1000) then
          h(:,:)=h0(:,:)
          init=0
          ipo(:mef)=(/(j,j=1,mef)/)
        endif

        do j=1,mef
          if (ip(j).ne.ipo(j)) then
            h(:,:)=h(:,:)-hi(ipo(j),j,:,:)+hi(ip(j),j,:,:)
            ipo(j)=ip(j)
          endif
        enddo

        a=suml(h)
        a2=a**2
        if (a2.gt.amx2) then
          npe(idw)=npe(idw)+1
          if (npe(idw).gt.npemx) stop '* ERROR ** ERROR * Too many equivalent permutations'
          pmt(idw,npe(idw),1:mef)=ip(1:mef)
        endif

      enddo PERMUT

      if (iwap.ge.2) then
        per=1._rnp
        do i=1,mef
          per=per*i
        enddo
        tot=per
        do i=mef+1,m
          tot=tot*i
        enddo
        write(out_fl,"(/2x,'Non-equivalent permutations',f19.0/)") per/npe(idw)
      endif

  999 return

      end subroutine

 ! xxx - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -