Hypothesen, die niemand braucht (4) – Wolfgang Lange

 
Neues Thema eröffnen   Neue Antwort erstellen    Alpha Centauri Foren-Übersicht -> Blogs Blogs
Vorheriges Thema anzeigen :: Nächstes Thema anzeigen  
Autor Nachricht
RelativKritisch Redaktion



Anmeldedatum: 29.12.2006
Beiträge: 240

BeitragVerfasst am: 03.01.2013, 19:44    Titel: Hypothesen, die niemand braucht (4) – Wolfgang Lange Antworten mit Zitat

Dr.-Ing. Wolfgang Lange gehört zu jenen Rentnern mit naturwissenschaftlichem Background, der seine Altersfreizeit nutzt, um die Physik zu revolutionieren. Sein „Coming out“ als Welträtsellöser hatte Dr. Lange im Jahr 2011. Seine „Neue Lorentz-Transformation“ versuchte er als Physikrevolution bei keinem geringen Magazin als den „Annalen der Physik“ zu veröffentlichen. Über deren Ablehnung zeigte sich Dr. Lange genau so empört, wie über die „Zensur“ seiner Kommentare im Blog von Dr. Markus Pössel.

Nach oben
RelativKritisch Redaktion is offline Benutzer-Profile anzeigen Private Nachricht senden
Solkar



Anmeldedatum: 29.05.2009
Beiträge: 293

BeitragVerfasst am: 18.02.2013, 12:40    Titel: Antworten mit Zitat

Hmmm.. vielleicht hilft dem einen oder anderen Welträsellöser ja ein Abakus?

Vielleicht rechnen die Herren dann ENDLICH mal Ihre "Findungen" gegen, BEVOR sie damit ans Tageslicht gehen...

Code:

!-----------------------------------------------------------------------------80
!> @file checkit.f90
!-------------------------------------------------------------------------------
!> @author Solkar
!!
!> @date Feb 16th 2013
!> @brief
!! LAPACK usage example
!! sgetrf/sgetrs applied on Galilean transform matrices
!
!> @copyright
!! (c) Solkar 2013. All rights reserved.
!! http://www.relativ-kritisch.net/forum/profile.php?mode=viewprofile&u=308
!
!> @license
!! This work is released under the GNU Public License v3 as of June 29th 2007
!! http://www.gnu.org/licenses/gpl.html
!
! Warranty: NONE, neither implied nor expressed.
! Use at own risk!
!-------------------------------------------------------------------------------
! ACKNOWLEDGEMENTS:
! http://www.netlib.org/lapack/ (LAPACK - still THE lib for LUP, AX=B & Co.)
!-------------------------------------------------------------------------------

!-----------------------------------------------------------------------------80
! MODULE iso_fortran_substitute
!> @brief some useful constants from Fortran 2003
!-------------------------------------------------------------------------------
module iso_fortran_substitute
    implicit none
    integer, parameter ::             INPUT_UNIT =   5
    integer, parameter ::            OUTPUT_UNIT =   6
    integer, parameter ::             ERROR_UNIT =   0
    integer, parameter ::             IOSTAT_END =  -1
    integer, parameter ::             IOSTAT_EOR =  -2
    integer, parameter ::   NUMERIC_STORAGE_SIZE =  32
    integer, parameter :: CHARACTER_STORAGE_SIZE =   8
    integer, parameter ::      FILE_STORAGE_SIZE =   8
end module iso_fortran_substitute

!-----------------------------------------------------------------------------80
!> @brief dumps a matrix of arbitrary size
!
!> @param[in] A matrix of REAL
!> @param[in] m INTEGER number of rows
!> @param[in] n INTEGER number of columns
!> @param[in,optional] unit INTEGER unit id
!------------------------------------------------------------------------------- 
subroutine dump(A, m, n, unit)
    use iso_fortran_substitute
    implicit none
    integer, intent(in)              :: m, n
    real, dimension(m,n), intent(in) :: A
    integer, intent(in), optional    :: unit
    integer                          :: i, u
   
    if (present(unit)) then
        u = unit
    else
        u = OUTPUT_UNIT
    end if

    do i=1,m
        write (u,*) A(i,:)
    end do
end subroutine dump

!-------------------------------------------------------------------------------
!> @brief main routine
!------------------------------------------------------------------------------- 
program checkit
    use iso_fortran_substitute
    implicit none
    integer, parameter               :: m = 2
    integer, parameter               :: n = m
    real, dimension(m,n), parameter  :: ID = &
                                reshape((/1.0,0.0,0.0,1.0/), (/2,2/))

   
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    real, parameter       :: v  = 0.5
    ! COLUMN-major order
    real, dimension(m,n)  :: G = reshape((/1.0,0.0,-v,1.0/), (/2,2/))
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

    real, dimension(m,n)  :: GTinv ! (G^T)^(-1)) to be calc'ed
    real, dimension(m,n)  :: R, S  ! auxiliary matrices
 
    ! auxiliaries for lapack routines
    real, dimension(m,n)  :: T                    ! [inout] for sgetrf   
    integer, dimension(n) :: ipiv                 ! dto for perm array
    integer               :: lda, nrhs, ldb, info ! see sgetrf/sgetrs man pgs   

    lda = m
    nrhs = n
    ldb = m

    write (*,*) 'G'   
    call dump(G, m, n)
    write (*,*)     

    T = transpose(G)
    write (*,*) 'G^T'
    call dump(T, m, n)
    write (*,*)
   
    ! LAPACK LUP decomposition and reassembly into T
    ! T intent is input/output
    ! ipiv, info intent is output
    call sgetrf(m, n, T, lda, ipiv, info)

    if (info .eq. 0) then
        !
        ! right side of
        ! A * (A^-1) = I
        !
        R = ID

        ! LAPACK solving,for LUP T, ipiv
        ! R intent is input/output
        ! info intent is output
        call sgetrs( 'N', m, nrhs, T, lda, &
                ipiv, R, ldb, info)

        if (info .eq. 0) then
            GTinv = R
            write (*,*) '(G^T)^(-1):'
            call dump(GTinv, m, n)
            write (*,*)

            S = matmul(transpose(G), GTinv)
            write (*,*) '(G^T) * (G^T)^(-1):'
           
            call dump(S, m, n)
            write (*,*)

            S = matmul(G, GTinv)
            write (*,*) 'G * ((G^T)^(-1)):'
            call dump(S, m, n)
        else
            write (ERROR_UNIT,*) 'inversion of triangular matrix'
            call dump(T, m, n, ERROR_UNIT)
            write (ERROR_UNIT,*) 'FAILED due to sgrts argument #', -info, '.'
            write (ERROR_UNIT,*) 'Pls see sgrts man page for argument list!'
            write (ERROR_UNIT,*) 'Aborting processing.'
        end if
    else
        write (ERROR_UNIT,*) 'LUP decomposition of '
        call dump(transpose(G), n, m, ERROR_UNIT)
        if (info < 0) then
            write (ERROR_UNIT,*) 'FAILED due to sgrtf argument #', -info, '.'
            write (ERROR_UNIT,*) 'Pls see sgrtf man page for further info!'
        else
            write (ERROR_UNIT,*) 'found matrix is singular.'
        end if
        write (ERROR_UNIT,*) 'Aborting processing.'
    end if ! info of sgetrf .eq. 0

    ! this
    call exit(info)
    ! is NOT standard, but works e.g. with gfortran
    ! comment out if your compiler complains about it
end program checkit


Komplilierung (Linux/gfortran):
Code:
gfortran -o checkit checkit.f90 -llapack


Verwendung (Linux):
Code:
./checkit


Ausgabe:
Code:
 G
   1.0000000     -0.50000000   
   0.0000000       1.0000000   

 G^T
   1.0000000       0.0000000   
 -0.50000000       1.0000000   

 (G^T)^(-1):
   1.0000000       0.0000000   
  0.50000000       1.0000000   

 (G^T) * (G^T)^(-1):
   1.0000000       0.0000000   
   0.0000000       1.0000000   

 G * ((G^T)^(-1)):
  0.75000000     -0.50000000   
  0.50000000       1.0000000

_________________
Nein! Das ist bestimmt irgendwas mit Quanten!
Man muss das nämlich alles erstmal quantenmechanisch beurteilen, mit allem Drum und Dran...
Nach oben
Solkar is offline Benutzer-Profile anzeigen Private Nachricht senden
Beiträge der letzten Zeit anzeigen:   
Neues Thema eröffnen   Neue Antwort erstellen    Alpha Centauri Foren-Übersicht -> Blogs Alle Zeiten sind GMT + 1 Stunde
Seite 1 von 1

 
Gehe zu:  
Du kannst keine Beiträge in dieses Forum schreiben.
Du kannst auf Beiträge in diesem Forum nicht antworten.
Du kannst deine Beiträge in diesem Forum nicht bearbeiten.
Du kannst deine Beiträge in diesem Forum nicht löschen.
Du kannst an Umfragen in diesem Forum nicht mitmachen.


Powered by phpBB © 2001, 2005 phpBB Group
Deutsche Übersetzung von phpBB.de

Nutzungsbedingungen des Forums Alpha Centauri
Impressum: Karl Hilpolt,
Paradeplatz, 8001 Zürich, Schweiz
e-mail: webmaster (at) relativ-kritisch (dot) net