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,110 @@
+program main
+implicit none
+integer nsamp,mdim,mpc
+double precision sample(100,100),princomp(100,100),transdata(100,100)
+integer i,j,k
+sample(1,1)=2.5d0
+sample(2,1)=0.5d0
+sample(3,1)=2.2d0
+sample(4,1)=1.9d0
+sample(5,1)=3.1d0
+sample(6,1)=2.3d0
+sample(7,1)=2.0d0
+sample(8,1)=1.0d0
+sample(9,1)=1.5d0
+sample(10,1)=1.1d0
+sample(1,2)=2.4d0
+sample(2,2)=0.7d0
+sample(3,2)=2.9d0
+sample(4,2)=2.2d0
+sample(5,2)=3.0d0
+sample(6,2)=2.7d0
+sample(7,2)=1.6d0
+sample(8,2)=1.1d0
+sample(9,2)=1.6d0
+sample(10,2)=0.9d0
+nsamp=10
+mdim=2
+mpc=2
+call princompana(nsamp,mdim,sample,mpc,princomp(1:nsamp,1:mpc),transdata(1:nsamp,1:mdim))
+do i=1,mpc
+  do j=1,nsamp
+    write(*,*)j,princomp(j,1)
+  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)
+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)
+!---------------------------------------------------------
+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),covarmatrix(1:mdim,1:mdim),sampmean,sampadj(1:nsamp,1:mdim))
+call eigensystem
+return
+end
+
+subroutine covariancematrix(nsamp,mdim,sample,covarmatrix,sampmean,sampadj)
+implicit none
+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
+  enddo
+  covarmatrix(i,j)=covarmatrix(i,j)/dble(nsamp-1)
+enddo
+return
+end