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