      SUBROUTINE PRINAXIS(MXNAT,NAT,ICOMP,IXYZ,A1,A2)
C Arguments:
      INTEGER MXNAT,NAT
      INTEGER*2 IXYZ(MXNAT,3),ICOMP(MXNAT,3)
      REAL A1(3),A2(3)
C
C Local variables:
      INTEGER LWORK
      PARAMETER(LWORK=12)
      INTEGER 
     &   I,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),VR(3,3),WI(3),WORK(LWORK),WR(3),
     &   ZI(3,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 J on lattice
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
C where 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 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 End history.
C
C Copyright (C) 1993,1994,1995,1996,1998 B.T. Draine and P.J. Flatau
C This code is covered by the GNU General Public License.
C***********************************************************************
      PI=4.*ATAN(1.)
C
C Compute center of mass (assuming uniform density).
C
      DO JD=1,3
         CM(JD)=0.
      ENDDO
      DO JA=1,NAT
         DO JD=1,3
            CM(JD)=CM(JD)+IXYZ(JA,JD)
         ENDDO
      ENDDO
      DO JD=1,3
         CM(JD)=CM(JD)/NAT
      ENDDO
C
C Compute moment of inertia tensor
C
      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))**2
         ENDDO
      ENDDO
      DO J=1,3
         A(J,J)=DSUM+NAT/6.
      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))
            ENDDO
            A(J,K)=A(J,K)-DSUM
         ENDDO
      ENDDO
C
C Normalize moment of inertia tensor to units of 0.4*mass*a_eff**2
C
      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*** diagnostic
c      write(0,*)'in prinaxis:'
c      write(0,*)'center of mass CM=',CM
c      write(0,*)'--- normalized moment of inertia tensor A ---'
c      write(0,*)(a(1,k),k=1,3)
c      write(0,*)(a(2,k),k=1,3)
c      write(0,*)(a(3,k),k=1,3)
c***
C
C Compute eigenvalues and eigenvectors of A(J,K)
C
      N=3
      LDA=3
      LDVR=3
      LDVL=3
C calling sequence of SGEEV from "lapack.f"
C      CALL SGEEV( JOBVL, JOBVR, N, A, LDA, WR, WI, VL, LDVL, VR,
C     $                  LDVR, WORK, LWORK, INFO )
C
C in fact only right eignevectors are needed
C
      CALL SGEEV( 'V', 'V', N, a, LDA, WR, WI, VL, LDVL, VR,
     $                  LDVR, WORK, LWORK, INFO )

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 is failing to SAVE some
C              variable between calls.  In any event, we have 
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)')
     &      'LAPACK routines may not work under Linux g77'
         WRITE(CMSGNM,FMT='(A)')
     &      'workaround by specifying target axis by hand'
         CALL ERRMSG('FATAL','PRINAXIS',' failure in SGEEV')
      ENDIF
C
c  VR      (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 VR, in the same order
c          as their eigenvalues.
c          If JOBVR = 'N', VR is not referenced.
c          If the j-th eigenvalue is real, then v(j) = VR(:,j),
c          the j-th column of VR.
c          If the j-th and (j+1)-st eigenvalues form a complex
c          conjugate pair, then v(j) = VR(:,j) + i*VR(:,j+1) and
c          v(j+1) = VR(:,j) = i*VR(:,j+1).

C Copy to zr and zi arrays. This is for historical reasons
C because of previous use of "NSWC Library of mathematical subroutines".
C (code eigv). There is a slight differnce between "eigv"
C and "sgeev" drivers in that eigenvectors in "eigv" are returned 
C as "complex" and "real" part but "sgeev" return just one matrix.
C Now, for real eigenvalues the complex part of eignevector should
C be 0. Thus, there should not be a difference between "eigv"
C and "sgeev" driver. 
C  
      do i=1,3
       do j=1,3
        zr(i,j)=vr(i,j)
        zi(i,j)=0.
       enddo      
      enddo
C
C Normalize the eigenvectors:
C
      DO 4000 J=1,3
         ZNORM2=0.
         DO 3800 K=1,3
            ZNORM2=ZNORM2+ZR(K,J)**2+ZI(K,J)**2
 3800    CONTINUE
C
C Make first component of each eigenvector positive
C
         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 3900 K=1,3
            ZR(K,J)=ZR(K,J)/ZNORM
            ZI(K,J)=ZI(K,J)/ZNORM
 3900    CONTINUE
 4000 CONTINUE
C
C Order the eigenvectors by eigenvalue, largest first:
C
      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 4100 K=1,3
         A1(K)=ZR(K,J1)
         A2(K)=ZR(K,J2)
 4100 CONTINUE
C
C Set J3=3 if J1+J2=1+2=3
C        2         =1+3=4
C        1         =2+3=5
C
      J3=6-J1-J2
C
C Having fixed eigenvectors a_1 and a_2, compute a_3=a_1xa_2
C
      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)      
C
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



