New changes from l2g

w
2022-09-12 16:40:28 +00:00
parent 78eb7147d0
commit d713d4f61a
110 changed files with 87672 additions and 1098 deletions
@@ -0,0 +1,112 @@
+!      program main
+!      implicit none
+!      integer nsamp,mdim,mpc
+!      double precision sample(100,100),princomp(100,100),
+!     &transdata(100,100),x(100),eigenvector(100,100),eigenvalue(100)
+!      integer i,j,k
+!      open(unit=1,file='Table8.3.txt')
+!      read(1,*)
+!      nsamp=0
+!10    read(1,*,end=100)i,(x(j),j=1,6)
+!      if(i.le.1)goto 10
+!      nsamp=nsamp+1
+!      do j=1,6
+!        sample(nsamp,j)=x(j)
+!      enddo
+!      goto 10
+!100   close(1)
+!      mdim=6
+!      mpc=2
+!      call princompana(nsamp,mdim,sample(1:nsamp,1:mdim),mpc,
+!     &princomp(1:nsamp,1:mpc),transdata(1:nsamp,1:mdim),
+!     &eigenvector(1:mdim,1:mdim),eigenvalue)
+!      do i=1,mpc
+!        do j=1,nsamp
+!          write(*,*)j,princomp(j,i)
+!        enddo
+!      enddo
+!      do i=1,mdim
+!        do j=1,nsamp
+!          write(*,*)j,transdata(j,i)
+!        enddo
+!      enddo
+!      end
+
+      subroutine princompana(nsamp,mdim,sample,mpc,princomp,transdata,
+     &eigenvector,eigenvalue)
+      implicit none
+!-----------Inputs----------------------------------------
+!mpc is the number of principal components to keep
+      integer nsamp,mdim,mpc
+      double precision sample(nsamp,mdim)
+!-----------Outputs---------------------------------------
+!princomp is the projection of a sample on the principal axes
+!transdata is the data of the orginal sample filtered with mpc principal components
+      double precision eigenvalue(mdim),eigenvector(mdim,mdim),
+     &sampmean(mdim),princomp(nsamp,mpc),transdata(nsamp,mdim),
+     &sampadj(nsamp,mdim)
+!---------------------------------------------------------
+      integer i,j,k
+      call geteigen(nsamp,mdim,sample(1:nsamp,1:mdim),eigenvalue,
+     &eigenvector(1:mdim,1:mdim),sampmean,sampadj(1:nsamp,1:mdim))
+      do i=1,mpc
+        do j=1,nsamp
+          princomp(j,i)=0.0d0
+          do k=1,mdim
+            princomp(j,i)=princomp(j,i)+eigenvector(k,i)*sampadj(j,k)
+          enddo
+        enddo
+      enddo
+      do j=1,mdim
+        do i=1,nsamp
+          transdata(i,j)=sampmean(j)
+          do k=1,mpc
+            transdata(i,j)=transdata(i,j)+eigenvector(j,k)*princomp(i,k)
+          enddo
+        enddo
+      enddo
+      return
+      end
+
+      subroutine geteigen(nsamp,mdim,sample,eigenvalue,eigenvector,
+     &sampmean,sampadj)
+      integer nsamp,mdim
+      double precision sample(nsamp,mdim),eigenvalue(mdim),
+     &eigenvector(mdim,mdim),sampmean(mdim),sampadj(nsamp,mdim)
+!Each column is an eigenvector. The first column corresponds to the largest eigenvalue and the last column corresponds
+!to the smallest eigenvalue 
+      call covariancematrix(nsamp,mdim,sample(1:nsamp,1:mdim),
+     &eigenvector(1:mdim,1:mdim),sampmean,sampadj(1:nsamp,1:mdim))
+      call eigen_sym_up(mdim,eigenvector(1:mdim,1:mdim),eigenvalue)
+      return
+      end
+
+      subroutine covariancematrix(nsamp,mdim,sample,covarmatrix,
+     &sampmean,sampadj)
+      implicit none
+!covarmatrix is an upper trangle
+      integer nsamp,mdim
+      double precision sample(nsamp,mdim),covarmatrix(mdim,mdim),
+     &sampmean(mdim),sampadj(nsamp,mdim)
+      integer i,j,k
+      do j=1,mdim
+        sampmean(j)=0.0d0
+        do i=1,nsamp
+          sampmean(j)=sampmean(j)+sample(i,j)
+        enddo
+        sampmean(j)=sampmean(j)/dble(nsamp)
+        do i=1,nsamp
+          sampadj(i,j)=sample(i,j)-sampmean(j)
+        enddo
+      enddo
+      do i=1,mdim
+        do j=i,mdim
+          covarmatrix(i,j)=0.0d0
+          do k=1,nsamp
+            covarmatrix(i,j)=covarmatrix(i,j)+sampadj(k,i)*sampadj(k,j)
+          enddo
+          covarmatrix(i,j)=covarmatrix(i,j)/dble(nsamp-1)
+        enddo
+      enddo
+      return
+      end