      SUBROUTINE PRINAXIS(MXNAT,NAT,ICOMP,IXYZ,DX,A1,A2,EIGVAL)
      IMPLICIT NONE

C Arguments:

      INTEGER MXNAT,NAT
      INTEGER*2 IXYZ(MXNAT,3),ICOMP(MXNAT,3)
      REAL A1(3),A2(3),DX(3),EIGVAL(3)

C Local variables:

      INTEGER LWORK
      PARAMETER(LWORK=12)
      INTEGER 
     &   INFO,
     &   J,J1,J2,J3,JA,JD,
     &   K,LDA,LDVL,LDVR,N
      REAL DENOM,PI,ZNORM,ZNORM2
      REAL 
     &   A(3,3),A3(3),VL(3,3),WI(3),WORK(LWORK),WR(3),
     &   ZR(3,3)
      DOUBLE PRECISION DSUM
      DOUBLE PRECISION CM(3)
      CHARACTER CMSGNM*70
C***********************************************************************
C Subroutine to determine principal axes of moment of inertia tensor
C of target.
C Target is assumed to be homogeneous.
C Given:
C
C MXNAT       =limit on largest allowed value of NAT=number of dipoles
C NAT         =number of dipoles in target
C IXYZ(J,1-3) =x,y,z location of dipole Jon lattice
C DX(1-3)     =(dx/d,dy/d,dz/d) where (dx,dy,dz)=lattice spacing in
C              x,y,z directions, 
C              and d = (dx*dy*dz)**(1/3) = effective lattice spacing
C ICOMP(J,1-3)=composition for dipole J; x,y,z directions
C
C Returns:
C
C A1(1-3)     =principal axis A1 in target frame (normalized)
C A2(1-3)     =principal axis A2 in target frame (normalized)
C EIGV(1-3)   =(eigenvalues of moment of inertia tensor)/(0.4*M*aeff^2)
C              definition of aeff = (3*V/4*pi)^{1/3} , V = solid volume
C              EIGV are in decreasing order:
C              EIGV(1) is largest, EIGV(3) is smallest
C
C              A1 = principal axis with largest moment of inertia 
C              A2 = principal axis with second-largest moment of inertia
C
C B.T. Draine, Princeton Univ. Observatory, 96.01.26
C History:
C 96.01.26 (BTD) extracted from routine TARBLOCKS
C                IX,IY,IZ replaced by IXYZ
C 96.02.23 (BTD) corrected typo in 2 format statements
C                add code computing axis a3 and printing out
C                eigenvalue.
C 96.11.01 (PJF) modified to use LAPACK code rather than EIGV
C                and associated routines from NSWC package.
C 96.11.21 (BTD) modified to remove WRITE(0 and replace with
C                calls to WRIMSG
C 97.12.26 (BTD) added DX(3) to argument list, and modified to
C                compute principal axes with unequal lattice
C                spacing.
C 98.04.27 (BTD) deleted unused variables I,ZI
C 98.12.15 (BTD) Appears to be a problem with LAPACK routine SGEEV
C                when compiled using g77 under Linux.
C                Add trap to catch this problem if it occurs,
C                print out warning, and terminate execution.
C 00.06.13 (BTD) corrected error in computation of diagonal elements
C                of moment of inertia tensor (NAT/6 -> NAT/18)
c 04.05.23 (BTD) added normalized eigenvalues EIGV to argument list
C End history.
C
C Copyright (C) 1993,1994,1995,1996,1997,1998,2000,2004
C               B.T. Draine and P.J. Flatau
C This code is covered by the GNU General Public License.
C***********************************************************************
      PI=4.*ATAN(1.)

C Compute moment of inertia tensor.

      DO JD=1,3
         CM(JD)=0.
      ENDDO
      DO JA=1,NAT
         DO JD=1,3
            CM(JD)=CM(JD)+IXYZ(JA,JD)*DX(JD)
         ENDDO
      ENDDO
      DO JD=1,3
         CM(JD)=CM(JD)/NAT
      ENDDO

C Compute moment of inertia tensor

      DO J=1,3
         DO K=1,3
            A(J,K)=0.
         ENDDO
      ENDDO
      DSUM=0.
      DO K=1,3
         DO JA=1,NAT
            DSUM=DSUM+((IXYZ(JA,K)-CM(K))*DX(K))**2
         ENDDO
      ENDDO
      DO J=1,3
         A(J,J)=REAL(DSUM+(NAT/18.)*(DX(1)**2+DX(2)**2+DX(3)**2))
      ENDDO
      DO J=1,3
         DO K=1,3
            DSUM=0.
            DO JA=1,NAT
               DSUM=DSUM+(IXYZ(JA,J)-CM(J))*(IXYZ(JA,K)-CM(K))*
     &              DX(J)*DX(K)
            ENDDO
            A(J,K)=A(J,K)-REAL(DSUM)
         ENDDO
      ENDDO

C Normalize moment of inertia tensor to units of 0.4*mass*a_eff**2

      DENOM=0.4*NAT*(.75*NAT/PI)**(2./3.)
      DO 3500 K=1,3
         DO 3400 J=1,3
            A(J,K)=A(J,K)/DENOM
 3400    CONTINUE
 3500 CONTINUE

C Compute eigenvalues and eigenvectors of A(J,K)

      N=3
      LDA=3
      LDVR=3
      LDVL=3

C Call LAPACK routine SGEEV to obtain eigenvectors of moment of
C inertia tensor.  Only right eigenvectors are needed.

      CALL SGEEV('V','V',N,A,LDA,WR,WI,VL,LDVL,ZR,
     &           LDVR,WORK,LWORK,INFO)

c  ZR      (output) REAL array, dimension (LDVR,N)
c          If JOBVR = 'V', the right eigenvectors v(j) are stored one
c          after another in the columns of ZR, in the same order
c          as their eigenvalues.
c          If JOBVR = 'N', ZR is not referenced.
c          If the j-th eigenvalue is real, then v(j) = ZR(:,j),
c          the j-th column of ZR.
c          If the j-th and (j+1)-st eigenvalues form a complex
c          conjugate pair, then v(j) = ZR(:,j) + i*ZR(:,j+1) and
c          v(j+1) = ZR(:,j) = i*ZR(:,j+1).

C 98.12.06 BTD It appears that SGEEV or subsidiary LAPACK routines
C              are not executing properly under Linux g77.  This 
C              problem has not been noticed previously, and certainly
C              did not appear with the Solaris f77 compiler.  Perhaps
C              one of the LAPACK routines wass failing to SAVE some
C              variable between calls.  This problem has not recurred,
C              but in case of future problems we havee
C              introduced this trap to terminate execution in case
C              of failure of SGEEV.
C
      IF(INFO.NE.0)THEN
         WRITE(CMSGNM,FMT='(A,I4)')
     &      'Error in PRINAXIS: returned from SGEEV with INFO=',INFO
         WRITE(CMSGNM,FMT='(A)')
     &      'SGEEV is part of lapack.f'
         WRITE(CMSGNM,FMT='(A)')
     &      'possibly a problem with LAPACK routines'
         WRITE(CMSGNM,FMT='(A)')
     &      'workaround by specifying target axis by hand'
         CALL ERRMSG('FATAL','PRINAXIS',' failure in SGEEV')
      ENDIF


C Normalize the eigenvectors:

      DO J=1,3
         ZNORM2=0.
         DO K=1,3
            ZNORM2=ZNORM2+ZR(K,J)**2
         ENDDO

C Make first component of each eigenvector positive

         ZNORM=SQRT(ZNORM2)
         IF(ZR(1,J).LT.0.)THEN
            ZNORM=-ZNORM
         ELSEIF(ZR(1,J).EQ.0.)THEN
            IF(ZR(2,J).LT.0.)ZNORM=-ZNORM
         ENDIF
         DO K=1,3
            ZR(K,J)=ZR(K,J)/ZNORM
         ENDDO
      ENDDO

C Order the eigenvectors by eigenvalue, largest first:

      J1=1
      IF(WR(2).GT.WR(1))J1=2
      IF(WR(3).GT.WR(J1))J1=3
      IF(J1.EQ.1)THEN
         J2=2
         IF(WR(3).GT.WR(2))J2=3
      ELSEIF(J1.EQ.2)THEN
         J2=1
         IF(WR(3).GT.WR(1))J2=3
      ELSEIF(J1.EQ.3)THEN
         J2=1
         IF(WR(2).GT.WR(1))J2=2
      ENDIF
      DO K=1,3
         A1(K)=ZR(K,J1)
         A2(K)=ZR(K,J2)
      ENDDO

C Set J3=3 if J1+J2=1+2=3
C        2         =1+3=4
C        1         =2+3=5

      J3=6-J1-J2

C Having fixed eigenvectors a_1 and a_2, compute a_3 = a_1 x a_2

      A3(1)=A1(2)*A2(3)-A1(3)*A2(2)
      A3(2)=A1(3)*A2(1)-A1(1)*A2(3)
      A3(3)=A1(1)*A2(2)-A1(2)*A2(1)      

      EIGVAL(1)=WR(J1)
      EIGVAL(2)=WR(J2)
      EIGVAL(3)=WR(J3)

C*** enable following lines to print out eigenvalues
      WRITE(CMSGNM,FMT='(A,0PF8.5)')'I_1/.4Ma_eff^2 =',WR(J1)
      CALL WRIMSG('PRINAXIS',CMSGNM)
      WRITE(CMSGNM,FMT='(A,0PF8.5)')'I_2/.4Ma_eff^2 =',WR(J2)
      CALL WRIMSG('PRINAXIS',CMSGNM)
      WRITE(CMSGNM,FMT='(A,0PF8.5)')'I_3/.4Ma_eff^2 =',WR(J3)
      CALL WRIMSG('PRINAXIS',CMSGNM)
      WRITE(CMSGNM,FMT='(A,0P3F9.5,A)')'axis a_1 = (',A1,')'
      CALL WRIMSG('PRINAXIS',CMSGNM)
      WRITE(CMSGNM,FMT='(A,0P3F9.5,A)')'     a_2 = (',A2,')'
      CALL WRIMSG('PRINAXIS',CMSGNM)
      WRITE(CMSGNM,FMT='(A,0P3F9.5,A)')'     a_3 = (',A3,')'
      CALL WRIMSG('PRINAXIS',CMSGNM)
C***
      RETURN
      END



