      subroutine calmu(va,vb)
      IMPLICIT REAL*8 (A-H,O-x,z),LOGICAL*1(y)
      parameter(maxsym=8,maxorb=500,maxorbcas=16)
      parameter(maxne=maxorbcas+2,lungo=100)
      common/dim/ iadri
      dimension ntv(maxorbcas+2),npv(maxorbcas+2)
      dimension ntn(maxorbcas+2),npn(maxorbcas+2)
      dimension ica(maxorbcas),icb(maxorbcas),it(2),ip(2)
      common/sym/ itsym(maxorb*2),its(maxsym,maxsym),nsym
      common /cs/ noac,nelac,numac(maxorbcas),itype(maxorb),is0,ms2
      common /orb/ enuc,eref,norb,noca,nocb
     *,iorb(2*maxorb),ninac,nvirt,noca0
      common/detsto/mdestod,ndestod,mdestod1,ndestod1,npie2,mpie2,
     *ctps((maxne)*lungo*2),cex(lungo)
      real*8 yij,yyij,yzij
      common/xyz/
     * xij(maxorb,maxorb),yij(maxorb,maxorb)
     *,zij(maxorb,maxorb),rij(maxorb,maxorb)                                    

      common/xxyyzz/  xxij(maxorb,maxorb),
     *zzij(maxorb,maxorb),yyij(maxorb,maxorb)
     *,xyij(maxorb,maxorb)
     *, xzij(maxorb,maxorb),yzij(maxorb,maxorb)
     *,zznuij(maxorb,maxorb)
cpent 20-11-01
      common/hacer/ iprop
cpent 20-11-01
cpent 4-12-01
      common/fmomnucl/ onucx,onucy,onucz,
     * onucxx,onucxy,onucxz,onucyy,onucyz,onuczz
cpent 4-12-01


      dimension y(maxorb*2+1)
      common/mat/ roij(maxorb,maxorb)
      dimension va(iadri),vb(iadri)
      dimension itab(2048)
      common/ronum/deltae,numero(2)
c la siguiente linea viene de la version SGI
      common/orbi/ngel(8),ndel(8),norbs(8),norb2
      yw=.false.
      print*,' '
      print*,'*********************************************'
      print*,'Todos los valores en unidades atomicas'
      print*,'*******************'
c      print*,'1er momento: 1ea0=2.541765 Db'
c      print*,'2o momento: 1ea0=1.345044 B=1.345044 Db*A'
c la siguiente linea viene de la version SGI
      norb=norb2
c
c      print*,'num. de orbitales para calcular mu', norb
c      
      nn=norb*(norb+1)/2
c      open(2,status='old',form='unformatted',file='RIJ')
c      read(2) ((rij(k,l),k=1,norb),l=1,norb)


cpent 20-11-01
c ponemos otra serie de ifs que impidan que calculemos 
c cosas que requieran datos que no hayamos leido antes
      if(iprop.eq.0.OR.iprop.eq.1)then
      print*,'M.Dipolar    Electronico                 Nuclear             
     * Total'
      amux=0.d0
      do i=1,norb
         do j=1,norb
            ij=max(i,j)*(max(i,j)-1)/2+min(i,j)
            amux=amux-roij(i,j)*xij(j,i)
c            print'(a25,2i4,3f14.6)','i,j,ro,r,amux'
c     *      ,i,j,roij(i,j),rij(j,i),amux
c            print'(a25,2i4,4f14.6)','i,j,ro,r,amux,x(j,i)'
c     *      ,i,j,roij(i,j),rij(j,i),amux,xij(j,i)
         enddo
      enddo
c      print*,'mux',amux
      write(*,432) 'mux',amux,onucx,amux+onucx
      amuy=0.d0
      do i=1,norb
         do j=1,norb
            ij=max(i,j)*(max(i,j)-1)/2+min(i,j)
            amuy=amuy-roij(i,j)*yij(j,i)
c            print'(a25,2i4,3f14.6)','i,j,ro,y,amuy'
c     *      ,i,j,roij(i,j),yij(j,i),amuy
         enddo
      enddo
c      print*,'muy',amuy
      write(*,432) 'muy',amuy,onucy,amuy+onucy
      amuz=0.d0
      do i=1,norb
         do j=1,norb
            ij=max(i,j)*(max(i,j)-1)/2+min(i,j)
            amuz=amuz-roij(i,j)*zij(j,i)
c            print'(a25,2i4,3f14.6)','i,j,ro,z,amuz'
c     *      ,i,j,roij(i,j),zij(j,i),amuz
         enddo
      enddo
c      print*,'muz',amuz
      write(*,432) 'muz',amuz,onucz,amuz+onucz
      endif
      if(iprop.eq.0.OR.iprop.eq.2)then
      print*,'*******************'
      print*,'M.Cuadrup.   Electronico                 Nuclear             
     * Total'
      amuxx=0.d0
      do i=1,norb
         do j=1,norb
            ij=max(i,j)*(max(i,j)-1)/2+min(i,j)
            amuxx=amuxx-roij(i,j)*xxij(j,i)
         enddo
      enddo
c      print*,'muxx',amuxx
      write(*,432) 'muxx',amuxx,onucxx,amuxx+onucxx
      amuxy=0.d0
      do i=1,norb
         do j=1,norb
            ij=max(i,j)*(max(i,j)-1)/2+min(i,j)
            amuxy=amuxy-roij(i,j)*xyij(j,i)
         enddo
      enddo
c      print*,'muxy',amuxy
      write(*,432) 'muxy',amuxy,onucxy,amuxy+onucxy
      amuxz=0.d0
      do i=1,norb
         do j=1,norb
            ij=max(i,j)*(max(i,j)-1)/2+min(i,j)
            amuxz=amuxz-roij(i,j)*xzij(j,i)
         enddo
      enddo
c      print*,'muxz',amuxz
      write(*,432) 'muxz',amuxz,onucxz,amuxz+onucxz
      amuyy=0.d0
      do i=1,norb
         do j=1,norb
            ij=max(i,j)*(max(i,j)-1)/2+min(i,j)
            amuyy=amuyy-roij(i,j)*yyij(j,i)
         enddo
      enddo
c      print*,'muyy',amuyy
      write(*,432) 'muyy',amuyy,onucyy,amuyy+onucyy
      amuyz=0.d0
      do i=1,norb
         do j=1,norb
            ij=max(i,j)*(max(i,j)-1)/2+min(i,j)
            amuyz=amuyz-roij(i,j)*yzij(j,i)
         enddo
      enddo
c      print*,'muyz',amuyz
      write(*,432) 'muyz',amuyz,onucyz,amuyz+onucyz
      amuzz=0.d0
      do i=1,norb
         do j=1,norb
            ij=max(i,j)*(max(i,j)-1)/2+min(i,j)
            amuzz=amuzz-roij(i,j)*zzij(j,i)
c            print'(a25,2i4,3f14.6)','i,j,ro,zz,amuzz'
c     *      ,i,j,roij(i,j),zzij(j,i),amuzz
         enddo
      enddo
c      print*,'muzz',amuzz
      write(*,432) 'muzz',amuzz,onuczz,amuzz+onuczz
cpent 3-12-01
c ahora escribimos las formas traceless de buckingham
cpent 3-12-01
c ahora escribimos las formas traceless de buckingham
      print*,'*******************'
      traza=amuxx+amuyy+amuzz
      trazan=onucxx+onucyy+onuczz
      print*,'thetas de Buckingham (traceless)'
      print*,'Componente   Electronico                 Nuclear             
     * Total'
c      print*,'theta xx ',0.5*(3*amuxx-traza)
      thxx=0.5*(3*amuxx-traza)+0.5*(3*onucxx-trazan)
      write(*,433) 'theta xx ',0.5*(3*amuxx-traza),
     * 0.5*(3*onucxx-trazan),0.5*(3*amuxx-traza)+
     * 0.5*(3*onucxx-trazan)
c      print*,'theta xy ',0.5*(3*amuxy)
      write(*,433) 'theta xy ',0.5*(3*amuxy),
     * 0.5*(3*onucxy),0.5*(3*amuxy)+
     * 0.5*(3*onucxy)
c      print*,'theta xz ',0.5*(3*amuxz)
      write(*,433) 'theta xz ',0.5*(3*amuxz),
     * 0.5*(3*onucxz),0.5*(3*amuxz)+
     * 0.5*(3*onucxz)
c      print*,'theta yy ',0.5*(3*amuyy-traza)
      thyy=0.5*(3*amuyy-traza)+0.5*(3*onucyy-trazan)
      write(*,433) 'theta yy ',0.5*(3*amuyy-traza),
     * 0.5*(3*onucyy-trazan),0.5*(3*amuyy-traza)+
     * 0.5*(3*onucyy-trazan)
c      print*,'theta yz ',0.5*(3*amuyz)
      write(*,433) 'theta yz ',0.5*(3*amuyz),
     * 0.5*(3*onucyz),0.5*(3*amuyz)+
     * 0.5*(3*onucyz)
c      print*,'theta zz ',0.5*(3*amuzz-traza)
      thzz=0.5*(3*amuzz-traza)+0.5*(3*onuczz-trazan)
c      print*,thxx,thyy,thzz
      write(*,433) 'theta zz ',0.5*(3*amuzz-traza),
     * 0.5*(3*onuczz-trazan),0.5*(3*amuzz-traza)+
     * 0.5*(3*onuczz-trazan)
      theff=dsqrt((2.0/3.0)*(thxx*thxx+thyy*thyy+thzz*thzz))
      write(*,*) 'theta eff   ', theff
      endif

cpent 20-11-01
c otra vez los ifs...
      if(iprop.eq.0.OR.iprop.eq.1)then
      print*,'*******************'
      amu=dsqrt(amux*amux+amuy*amuy+amuz*amuz)
      amut=dsqrt((amux+onucx)*(amux+onucx)+(amuy+onucy)*(amuy+onucy)+
     $ (amuz+onucz)*(amuz+onucz))
      print*,'amu electr - ',amu
      print*,'amu total  - ',amut
      print*,'moment dipolaire de transition (electr)',amu*amu
      print*,'moment dipolaire de transition (total) ',amut*amut
      print*,'force d''oscillateur',0.666666667*amu*amu*deltae
      endif
      print*,'*********************************************'
      return
cpent 4-12-01
432   format(1x,A4,7x,G25.18,3x,G15.8,3x,G25.18,1x)      
433   format(1x,A9,2x,G25.18,3x,G15.8,3x,G25.18,1x)
      end
