1      subroutine argos_diana_covar()
2c
3c $Id$
4c
5      implicit none
6c
7#include "argos_diana_common.fh"
8#include "mafdecls.fh"
9#include "msgids.fh"
10#include "global.fh"
11#include "util.fh"
12c
13      integer i,j,k
14c
15      filpca=card(8:80)
16      if(index(filpca,'.pca').eq.0)
17     + filpca=filpca(1:index(filpca,' ')-1)//'.pca'
18c
19      if(nsel.eq.0) call md_abort('No atoms selected',0)
20c
21      if(active) call argos_diana_edfinal()
22      call argos_diana_edinit()
23      active=.true.
24c
25      call ga_distribution(ga_trj,me,il,ih,jl,jh)
26      call ga_access(ga_trj,il,ih,jl,jh,ndx,ld)
27c
28c      call argos_diana_xaver(dbl_mb(ndx),nsa,min((me+1)*nfrme,nfrtot)-me*nfrdim,
29c     + dbl_mb(i_xadat),nsa)
30c
31      call argos_diana_cov(int_mb(i_ndx),dbl_mb(i_cov),int_mb(i_isel),
32     + dbl_mb(ndx),dbl_mb(i_xadat))
33c
34      call ga_scale(ga_cov,1.0d0/dble(nfrtot))
35c
36c      call argos_diana_pcovar(int_mb(i_ndx),dbl_mb(i_cov),int_mb(i_isel))
37c
38      if(me.eq.0) then
39      if(util_print('frames_read',print_debug)) then
40      write(*,'(/,a)') ' Covariance matrix generation completed'
41      endif
42      endif
43c
44      call ga_sync()
45c
46      call ga_diag_std(ga_cov,ga_vec,dbl_mb(i_cov))
47c
48      call ga_sync()
49      do 19 i=1,3*nsel
50      int_mb(i_ord+i-1)=i
51   19 continue
52      do 17 i=1,3*nsel-1
53      do 18 j=i+1,3*nsel
54      if(abs(dbl_mb(i_cov-1+int_mb(i_ord+i-1))).lt.
55     + abs(dbl_mb(i_cov-1+int_mb(i_ord+j-1)))) then
56      k=int_mb(i_ord+i-1)
57      int_mb(i_ord+i-1)=int_mb(i_ord+j-1)
58      int_mb(i_ord+j-1)=k
59      endif
60   18 continue
61   17 continue
62c
63      if(me.eq.0) then
64      open(unit=lfnpca,file=filpca(1:index(filpca,' ')-1),
65     + form='formatted',status='unknown')
66      write(lfnpca,1000) 3*nsel,nsa
67 1000 format(2i7)
68      write(lfnpca,1001) (dbl_mb(i_cov-1+int_mb(i_ord+i-1)),i=1,3*nsel)
69 1001 format(6e12.5)
70      endif
71c
72      return
73      end
74