Astronet > Rukovodstvo po prakticheskoi rabote s katalogom Hipparcos

po tekstam po klyuchevym slovam v glossarii po saitam perevod po katalogu

<< 10. Prilozhenie D | Oglavlenie | Literatura >>

Razdely

11.1. Teksty programm na yazyke FORTRAN 90

11.1. Teksty programm na yazyke FORTRAN 90

Listing E 3.1. Modul' chteniya kataloga Hipparcos

MODULE HipMain
IMPLICIT NONE

! Raspolozhenie polnoi versii kataloga Hipparcos 
CHARACTER(*), PARAMETER :: HipparcosName ='D:/HIP/hip\_main.dat'
INTEGER, PARAMETER :: HipNumOfStars = 118218 ! Chislo zvezd 
INTEGER, PARAMETER :: u = 10 ! Nomer faila
TYPE THipparcos

SEQUENCE

INTEGER(4) :: HIP ! Nomer zvezdy po Hipparocs 

! Astrometricheskaya informaciya 
REAL(8) :: RAdeg,DEdeg ! ekvatorial'nye koordinaty v gradusah 
REAL(8) :: Plx ! trigonometricheskii parallaks v mas 
REAL(8) :: pmRa,pmDE ! sobstvennye dvizheniya ma*cos(d) i md 
CHARACTER(1) :: AstroRef ! Flag dlya kratnyh sistem 

! Fotometricheskaya informaciya 
REAL(4) :: VMag ! Zvezdnaya vel. po shkale Dzhonsona 
REAL(4) :: B\_V ! Pokazatel' cveta B-V po shkale Dzhonsona 

! Oshibki sootvetstvuyushih velichin
REAL(8) :: sigma\_RAdeg,sigma\_DEdeg
REAL(8) :: sigma\_Plx
REAL(8) :: sigma\_pmRa,sigma\_pmDE

CHARACTER(10) Sp ! Razvernutyi spektral'nyi klass 
LOGICAL NoRaDe ! Net dannyh o tochnyh koordinatah 
LOGICAL NoPlx ! Net dannyh o parallakse 
LOGICAL Nopm ! Net dannyh o sobstvennyh dvizheniyah 
LOGICAL NoVMag ! Net dannyh o zvezdnoi velichine 
LOGICAL NoB\_V ! Net dannyh o pokazatele cveta 

END TYPE THipparcos

CONTAINS

SUBROUTINE OpenHipparcosMain ! Otkrytie faila kataloga 
OPEN(u, file = HipparcosName)
END SUBROUTINE OpenHipparcosMain

SUBROUTINE CloseHipparcosMain ! Zakrytie faila kataloga 
CLOSE(u)
END SUBROUTINE CloseHipparcosMain

LOGICAL FUNCTION ReadHipparcosMain(s) ! Chtenie dannyh o zvezde
TYPE(THipparcos), INTENT(out) :: s
CHARACTER(450) hs ! Zapis' stroki kataloga 
IF (EOF(u)) THEN 
  ReadHipparcosMain=.false.
  RETURN
ELSE
  ReadHipparcosMain=.true.
END IF

READ(u,'(A450)') hs ! Chtenie odnoi stroki kataloga

! Sbrasyvaem flagi sobytii 
s.NoRaDe = .False. 
s.NoPlx =.False. 
s.Nopm =.False. 
s.NoVMag =.False. 
s.NoB\_V =.False. 

! Interpretaciya s 12 bait, nachinaya s 3-go - eto nomer HIP 
read(hs(3:14),*) s.hip

! Chtenie koordinat: po 12 bait s 52 i s 65 pozicii 
! Funkciya TRIM udalyaet iz stroki probely, a LEN vozvrashaet dlinu
! stroki, sootvetstvenno, esli eto 0, to v stroke tol'ko probely
IF (LEN(TRIM(hs(52:63))) == 0) THEN
  s.NoRaDe=.true. 
  s.RADeg=0.0 ! na vsyakii sluchai zapisyvaem 0 
ELSE
  READ(hs(52:63),*) s.RAdeg
END IF

IF (LEN(TRIM(hs(65:76))) == 0) THEN
  s.NoRaDe=.true. 
  s.DEDeg=0.0
ELSE
  read(hs(65:76),*) s.DEdeg
END IF

! Chtenie parallaksa - 7 bait s 80-i pozicii 
IF (LEN(TRIM(hs(80:86))) == 0) THEN
  s.NoPlx=.true. 
  s.Plx=0.0
ELSE
  read(hs(80:86),*) s.Plx
END IF

! Chtenie sobstvennyh dvizhenii: po 8 bait s 88 i s 97 pozicii 
IF (LEN(TRIM(hs(88:95))) == 0) THEN
  s.NoPM=.true. 
  s.pmRA=0.0
ELSE
  read(hs(80:86),*) s.pmRA
END IF

IF (LEN(TRIM(hs(88:95))) == 0) THEN
  s.NoPM=.true. 
  s.pmDE=0.0
ELSE
  read(hs(97:104),*) s.pmDE
END IF

s.AstroRef=hs(78:78) ! Flag kratnoi zvezdy 

! Chtenie zv.velichiny i pokazatelya cveta B-V po shkale Dzhonsona 
IF (LEN(TRIM(hs(42:46))) == 0) THEN
  s.NoVMag=.true. 
  s.VMag=0.0
ELSE
  read(hs(42:46),*) s.VMag
END IF

IF (LEN(TRIM(hs(246:251))) == 0) THEN
  s.NoB\_V=.true. 
  s.B\_V=0.0
ELSE
  read(hs(246:251),*) s.B\_V
END IF

! Dannye ob oshibkah vsegda est', esli prisutstvuyut sami velichiny
IF (.NOT. s.NoRADE) THEN
  read(hs(106:111),*) s.sigma\_RAdeg 
  read(hs(113:118),*) s.sigma\_DEdeg 
ENDIF

IF (.NOT. s.NoPlx) THEN
  read(hs(120:125),*) s.sigma\_Plx
END IF

IF (.NOT. s.Nopm) THEN
  read(hs(127:132),*) s.sigma\_pmRA
  read(hs(134:139),*) s.sigma\_pmDE
END IF

s.Sp=hs(436:445) ! Chtenie dannyh o spektral'nom klasse 

END FUNCTION ReadHipparcosMain

END MODULE HipMain

Listing E 3.2. Podschet zvezd bez dannyh o koordinatah, sobstvennyh dvizheniyah i parallaksah

PROGRAM Test2

USE HipMain

INTEGER(4) :: NoCoord = 0 ! Schetchik zvezd bez tochnyh koordinat
INTEGER(4) :: NoProp = 0 ! Schetchik zvezd bez sobstv. dvizhenii
INTEGER(4) :: NoPar = 0 ! Schetchik zvezd bez parallaksov
TYPE(THipparcos) :: s

CALL OpenHipparcosMain

DO WHILE (ReadHipparcosMain(s))
  ! Sravnenie logicheskih peremennyh
  IF (s.NoRADE) NoCoord= NoCoord+1
  IF (s.Nopm) NoProp = NoProp+1
  IF (s.NoPlx) NoPar = NoPar+1
END DO

CALL CloseHipparcosMain

print *,'No coord ',NoCoord
print *,'No PM ',NoProp
print *,'No Par ',NoPar

read *,i

END PROGRAM Test2

Listing E 3.3. Vychislenie raspredeleniya zvezd po absolyutnoi zvezdnoi velichine

PROGRAM AbsMagDistrib

USE HipMain

INTEGER, PARAMETER :: LOW = -12, HIGH=+12
TYPE(THipparcos) :: s;
INTEGER(4) :: a(-12:+12) ! statistika 
INTEGER(4) :: i ! vspomogatel'naya peremennaya 
REAL(8) :: r ! rasstoyanie 
REAL(8) :: m ! absolyutnaya zvezdnaya velichina

FORALL (i=-12:+12) A(i)=0

CALL OpenHipparcosMain();

DO WHILE (ReadHipparcosMain(s))
  IF (s.NoPlx) CYCLE ! net dannyh o parall.
  IF (s.Plx<=0.0) CYCLE ! nepolozhitel'nyi parallaks 
  IF (s.sigma\_plx/s.plx>0.5) CYCLE ! tochnost' huzhe 50\%
  r=1000.0/s.plx; ! Vychislenie rasstoyaniya v pk 
  m=S.VMag-5.0*log10(r)+5.0 ! Vychisl. absolyutnoi zvezd. velichiny
  i=FLOOR(m+0.5) ! Opredelenie indeksa yacheiki massiva 
  IF ( (i>=low) .and. (i<=high)) a(i)=a(i)+1 ! uv.na 1
END DO

CALL CloseHipparcosMain()

PRINT '(I3,1X,I7)',(i,a(i),i=-12,12)

READ *,i

END PROGRAM

Listing E 3.4. Vychislenie srednei absolyutnoi zvezdnoi velichiny zvezd, spisok kotoryh nahoditsya v faile lumin.txt

PROGRAM AVER

Use HipMain

TYPE(THipparcos) s
REAL(8) :: r ! rasstoyanie 
REAL(8) :: m ! absolyutnaya zvezdnaya velichina 
REAL(8) :: mav = 0.0 ! srednyaya absolyutnaya zvezdnaya velichina 
INTEGER(4) :: n = 0 ! kolichestvo podhodyashih zvezd 

CALL OpenHipparcosMain

! Inicializaciya kriteriya 
print '(I6 " zvezd v kriterii.")',InitCriteria('lumin.txt')

DO WHILE (ReadHipparcosMain(s))
  IF (s.NoPlx) CYCLE ! net dannyh o parall.
  IF (s.plx<=0.0) CYCLE ! nepolozhitel'nyi parallaks 
  r=1000.0/s.plx ! Vychislenie rasstoyaniya v pk 
  m=S.VMag-5.0*log10(r)+5.0 ! Vychisl. abs. zvezd. velichiny 
  IF (inCelestia(s.HIP)) THEN ! Zvezda v spiske Celestia 
    mav=mav+m ! nakoplenie summy abs. zv. velichin 
    n=n+1 ! summirovanie chisla zvezd 
  END IF
END DO

CALL ClearCriteria ! Ochistka kriteriya 
CALL CloseHipparcosMain
mav=mav/n ! Vychislenie srednego znacheniya 

print '("Srednyaya absolyutnaya zvezdnaya velichina ",F6.2,".")',mav
print '("Obrabotano ",I6," zvezd.")',n

END PROGRAM

Listing E 3.5. Ishodnyi tekst funkcii InitCriteria, InCelestia, ClearCriteria

Dobavleniya v razdel opisanii modulya HipMain

INTEGER(4), ALLOCATABLE :: List(:)
INTEGER(4) :: NList = 0

Dobavleniya v razdel procedur modulya HipMain

INTEGER(4) FUNCTION InitCriteria(name)
CHARACTER (*) :: name
INTEGER, PARAMETER :: t = 11 ! fail
INTEGER(4) :: i ! indeks dlya cikla do

OPEN(t, file = name, mode='read') ! Otkryvaem fail 

DO i=1,2 ! Propusk dvuh pervyh strok 
  READ(t,*) 
END DO

READ(t,*) NList ! V tret'ei stroke - kolichestvo zvezd 

PRINT *,NList

ALLOCATE(List(NList)) ! Vydelenie pamyati pod spisok 

DO i=4,12 ! Propusk s 4 po 12 stroku 
  READ(t,*) 
END DO

DO i=1,NList ! Chtenie nomerov zvezd
  READ(t,'(2X,I12)') List(i)
END DO

CLOSE(t)

InitCriteria=NList

END FUNCTION InitCriteria

! Ochistka kriteriya 
SUBROUTINE ClearCriteria

DEALLOCATE(List) 

NList=0

END SUBROUTINE ClearCriteria

! Funkciya proveryaet, est' li zvezda v spiske 
LOGICAL FUNCTION InCelestia(n)
INTEGER(4) :: n
INTEGER(4) :: i

InCelestia=.false. ! ob'ekt poka ne naiden 

IF (NList==0) return ! esli kriterii ne ustanovlen - vyhod 

DO i=1,NList ! obhod zvezd v cikle do
  IF (List(i)==n) THEN ! esli zvezda naidena v spiske 
    InCelestia=.true.
    EXIT ! dosrochno prervat' cikl 
  END IF 
END DO
END FUNCTION InCelestia

Listingi E 4.1-4.3. Procedury perevoda koordinat i otrisovki koordinatnoi setki (Perevod v ekrannye koordinaty ne trebuetsya, poskol'ku v standartnoi biblioteke fortrana mozhno vybrat' lyubuyu udobnuyu dekartovu sistemu s veshestvennymi znacheniyami koordinat)

MODULE Projection

USE DFLIB

IMPLICIT NONE

REAL(8), PARAMETER :: PI = 3.1415926535897932384626433832795

CONTAINS

SUBROUTINE Aitoff(l,b,x,y)
REAL(8), INTENT(IN) :: l,b ! Sfericheskie koordinaty v radianah 
REAL(8), INTENT(OUT) :: x,y ! Dekartovy koordinaty 
REAL(8) :: s, l1 ! Vspomogatel'nye peremennye

IF (l>PI) THEN ! Privedenie l v diapazon -Pi do +Pi 
  l1=l-2*Pi 
ELSE 
  l1=l
END IF

S=sqrt(1.0+cos(b)*cos(l1/2)) ! Znamenatel' formul (4.1)

x=-2*cos(b)*sin(l1/2)/s
y=sin(b)/s

END SUBROUTINE Aitoff


REAL(8) FUNCTION radi(x) ! Perevod gradusov v radiany 
INTEGER, INTENT(IN) :: x

radi=x/180.0*PI

END FUNCTION radi


REAL(8) FUNCTION rad(x) ! Perevod gradusov v radiany 
REAL(8), INTENT(IN) :: x

rad=x/180.0*PI

END FUNCTION rad

SUBROUTINE AitoffGrid (Step,Gr)
INTEGER, INTENT(IN) :: Step ! Shag setki v gradusah 
LOGICAL, INTENT(IN) :: Gr ! Flag - v gradusah ili v chasah 
INTEGER :: i,j ! Peremennye ciklov do
REAL(8) :: l,b ! Galakticheskie koordinaty 
REAL(8) :: x,y ! Dekartovy koordinaty 
CHARACTER(8) s ! Stroka dlya podpisei 
INTEGER :: h ! Dlya razmetki osei 
TYPE (wxycoord) wxy
INTEGER(2) :: status2
INTEGER(4) :: status4

! Nanesenie setki meridianov 
status4 = SetColorRGB({\#00FF00)

DO i=-180,+180,Step
  l=radi(i) ! Perevod v radiany 
  DO j=-90,+90,5 ! Cikl postroeniya vdol' meridiana 
    ! Vychislenie tochki meridiana 
    b=radi(j) ! Perevod v radiany shiroty 
    CALL Aitoff(l,b,x,y) ! Perevod v dekartovy koordinaty 
    ! Esli tochka pervaya (j=-90), to pomeshaem graficheskii kursor
    ! v tochku (x,y) funkciei MoveTo\_W, esli tochka ne pervaya, to
    ! "procherchivaem" kursorom liniyu iz predydushei tochki 
    ! v tochku (u,v) funkciei LineTo\_W.
    IF (j==-90) THEN
      CALL MoveTo\_W(x,y,wxy) 
    ELSE 
      status2=LineTo\_W(x,y);
    END IF
  END DO ! j
END DO ! i

! Nanesenie setki parallelei - analogichno predydushemu 
DO j=-90,+90,Step
  b=radi(j)
  DO i=-180,+180,5 ! cikl postroeniya vdol' paralleli 
    l=radi(i)
    CALL Aitoff(l,b,x,y);
    IF (i==-180) THEN 
      CALL MoveTo\_W(x,y,wxy)
    ELSE 
      status2=LineTo\_W(x,y)
    END IF
  END DO ! i
END DO ! j

status2=SetFont('t"Arial"h10')
status4 = SetColorRGB({\#FFFFFF)

! Podpisi meridianov vdol' ekvatora 
DO i=-180,+180,Step  
  ! Vychislenie koordinaty tochki vyvoda nadpisi 
  l=Radi(i);
  CALL Aitoff(l,0.0\_8,x,y)
  ! Esli Gr istina, to razmetka v gradusah, inache - v chasah 
  IF (Gr) THEN 
    h=i
  ELSE 
    h=i/15 
    IF (h<0) h=h+24;
  END IF

  write(s,'(I4)') h ! Preobrazovanie znacheniya h v tekst. stroku 

  Call MoveTo\_W(x, y, wxy)

  Call OUTGTEXT(s)

END DO

! Podpisi parallelei vdol' nulevogo meridiana - analogichno 
DO j=-90,+90,Step
  IF (j /= 0) THEN ! Ekvator ne podpisyvaem 
    b=Radi(j);
    CALL Aitoff(0.0\_8,b,x,y)
    write(s,'(I4)') j 
    Call MoveTo\_W(x, y, wxy)
    Call OUTGTEXT(s)
  END IF
END DO

END SUBROUTINE AitoffGrid


SUBROUTINE Galaxy(a,d,l,b)
REAL(8), INTENT(in) :: a,d
REAL(8), INTENT(out) :: l,b
REAL(8) :: a1,sa,ca,sd,cd
REAL(8), PARAMETER :: Leo = 4.936829261 ! 282.85948083 
REAL(8), PARAMETER :: L0 = 0.57477039907 ! 32.931918056 
REAL(8), PARAMETER :: si = 0.88998807641 ! sin 62.871748611 
REAL(8), PARAMETER :: ci = 0.45598379779 ! cos 62.871748611 

a1=a-Leo
sa=sin(a1); ca=cos(a1)
sd=sin(d); cd=cos(d)
b=asin(sd*ci-cd*si*sa)
l=atan2(sd*si+cd*ci*sa,cd*ca)+L0

END SUBROUTINE Galaxy

END MODULE

Listing E 4.4. Postroenie raspredeleniya zvezd po nebesnoi sfere

Program Main

USE DFLIB
USE HipMain
USE Projection

IMPLICIT NONE
! Fizicheskoe razreshenie okna
INTEGER, PARAMETER :: MaxX = 1000, MaxY = 500 
REAL(8), PARAMETER :: LowX = -2.1 , LowY = -1.05 ! Logicheskie
REAL(8), PARAMETER :: HighX= +2.1 , HighY= +1.05 ! koordinaty 
REAL(8) :: l, b ! Galakticheskie koordinaty 
REAL(8) :: x, y ! Dekartovy koordinaty 
LOGICAL :: status1 ! Vspomogatel'nye velichiny
INTEGER(2) :: status2
INTEGER(4) :: status4
INTEGER(4) :: color ! Cvet zvezdy
TYPE(THipparcos) :: s
TYPE (windowconfig) :: wc ! Svoistva graficheskogo okna
TYPE (wxycoord) :: wxy ! Vspomogatel'naya velichina

wc.numxpixels = MaxX ! Zapolnenie struktury svoistv okna
wc.numypixels = MaxY
wc.numtextcols = -1
wc.numtextrows = -1
wc.numcolors = -1
wc.title = "Aitoff"C
wc.fontsize = \#0008000C ! 10 X 12
status1 = SETWINDOWCONFIG(wc) ! Inicializaciya grafiki
IF (.NOT. status1) status1 = SETWINDOWCONFIG(wc)
status2=SetWindow(.TRUE.,LowX, LowY, HighX, HighY)
status2=INITIALIZEFONTS( )

CALL AitoffGrid(30,.TRUE.)
CALL OpenHipparcosMain() ! Otkrytie kataloga i 
status4=InitCriteria('I-II.txt') ! inicializaciya kriteriya 

do while (ReadHipparcosMain(s)) ! Cikl chteniya zvezd 
  IF (inCelestia(s.HIP)) THEN ! Proverka kriteriya 
    SELECT CASE(S.SP(1:1)) ! Opredelenie cveta zvezdy 
    CASE ('O')
      color = RGBTOINTEGER(90,64,255)
    CASE ('B')
      color = RGBTOINTEGER(128,128,255)
    CASE ('A')
      color = RGBTOINTEGER(255,255,255)
    CASE ('F')
      color = RGBTOINTEGER(255,255,128)
    CASE ('G')
      color = RGBTOINTEGER(255,230,40)
    CASE ('K')
      color = RGBTOINTEGER(255,160,0)
    CASE ('M')
      color = RGBTOINTEGER(255,0,0)
    CASE default
      color=0
    END SELECT

    ! Perevod ekvatorial'nyh koordinat v radiany, 
    ! a zatem v galakticheskie koordinaty 
    CALL Galaxy(rad(s.RADeg),rad(s.DEDeg),l,b)

    ! Vychislenie dekartovyh koordinat proekcii Aitofa 
    CALL Aitoff(l,b,x,y) 

    ! Postavit' tochku (mozhno zamenit' na krug)
    status4=SetPixelRGB\_w(x,y,color)

  END IF
END DO

CALL ClearCriteria()
CALL CloseHipparcosMain()

! Sohranit' izobrazhenie v faile
status4=SaveImage("Aitoff.bmp"C,0,0,MaxX-1,Maxy-1)
END PROGRAM

Listing E 4.5. Formirovanie pryamougol'nyh koordinat zvezd

PROGRAM Main

USE HipMain

IMPLICIT NONE
CHARACTER(*),PARAMETER :: Criteria='O-B5' ! Imya faila kriteriya 
INTEGER(4) :: n = 0 ! Schetchik 
Type(THipparcos) :: s
REAL(8) :: r ! Rasstoyanie 
REAL(8) :: l, b ! Galakticheskie koordinaty 
REAL(8) :: x,y,z ! Dekartovy galakticheskie koordinaty 
INTEGER, PARAMETER :: f = 14 ! Fail vyvoda rezul'tatov 

OPEN(f, file=Criteria // '.DAT')

CALL OpenHipparcosMain()

! Fail spiska zvezd imeet rasshirenie .TXT 
PRINT "(I6,' zvezd v kriterii')",InitCriteria(Criteria//'.txt')

do while (ReadHipparcosMain(s))
IF (s.NoPlx) CYCLE ! net dannyh o parall.
IF (s.plx<=0.0) CYCLE ! "plohoe" znachenie parallaksa 
IF (s.sigma\_plx/s.plx>0.5) CYCLE ! nizkaya tochnost' par.

IF (inCelestia(s.HIP)) THEN
    r=1000.0/s.plx ! Vychislenie rasstoyaniya v pk 
    IF (r>500.0) CYCLE ! Otbros dalekih zvezd 

    ! Perevod v galakticheskie koordinaty 
    CALL Galaxy(rad(s.RADeg),rad(s.DEDeg),l,b)

    x=r*cos(b)*cos(l) ! Vychislenie pryamougol'nyh 
    y=r*cos(b)*sin(l) ! galakticheskih koordinat 
    z=r*sin(b)
    write(f,'(3F10.2)'), x,y,z ! Vyvod v fail 

    n=n+1 ! Uvelichenie schetchika na edinicu 

  END IF

END do

CALL ClearCriteria()
CALL CloseHipparcosMain()

Close(f)

print '(I6,"zvezd obrabotano.")',n

END PROGRAM

<< 10. Prilozhenie D | Oglavlenie | Literatura >>

Publikacii s klyuchevymi slovami: astrometriya - katalogi - Hipparcos Publikacii so slovami: astrometriya - katalogi - Hipparcos
Sm. takzhe: Dostizheniya kosmicheskoi astrometrii Sravnenie baz dannyh po ekzoplanetam Pervye ob'ekty v katalogah Skonchalsya Konstantin Vladislavovich Kuimov Konstantinu Vladislavovichu Kuimovu – 75 let Saimon N'yukom (1835 -1909) k 175-letiyu so dnya rozhdeniya. Vrashenie Zemli i prodolzhitel'nost' sutok Vse publikacii na tu zhe temu >>

Obsudit' etu publikaciyu

Versiya dlya pechati

Astrometriya - Astronomicheskie instrumenty - Astronomicheskoe obrazovanie - Astrofizika - Istoriya astronomii - Kosmonavtika, issledovanie kosmosa - Lyubitel'skaya astronomiya - Planety i Solnechnaya sistema - Solnce

Razdely

11. Prilozhenie E

11.1. Teksty programm na yazyke FORTRAN 90