SUBROUTINE GETSTA(idim,is,ia,ticsec, *amag,icat,PLNR,STNR,TA,TD,ALP,DEL,WA,WD,isatz *,alpagk,delagk,pma,pmd,ipix) C IMPLICIT REAL*8(A-H,O-Z) Parameter (t0=2451544.5d0,PI=3.1415926535897932D0) c parameter(iden(1)=' 2mas',iden(2)=' A',iden(3)=' A') c parameter(iden(4)=' B',iden(5)=' C',iden(6)=' D') C c integer*2 magc,magu,magb,magv,magr,magj,magh,magk C FUER BEOB-FILE: c CHARACTER isatz*104,kat*104,ioutp*104 CHARACTER isatz*120,kat*120,ioutp*120 CHARACTER ipix*24 CHARACTER PLNR*4,STNR*4,idout*20 c INTEGER*2 ICAT,ID1,ID2,IMAG,IEP,IPZA,IPZD,JCAT,ISIGA,ISIGD DIMENSION TA(IDIM),TD(IDIM) DIMENSION ALP(IDIM),AMAG(IDIM) DIMENSION DEL(IDIM) DIMENSION ICAT(IDIM),kepa(idim) DIMENSION WA(IDIM),WD(IDIM) DIMENSION PLNR(IDIM),STNR(IDIM) DIMENSION isatz(IDIM) character*6 iden(5),id1 character*20 id2 ioutp(1:10) = 'xxxxxx-9.9' ioutp(11:20) = 'xxxxxx-9.9' ioutp(21:30) = 'xxxxxx-9.9' ioutp(31:40) = 'xxxxxx-9.9' ioutp(41:50) = 'xxxxxx-9.9' iden(1)=' 2mas' iden(2)=' A' iden(3)=' B' iden(4)=' C' iden(5)=' D' C ****************************************************************** C VERSION FUER ein neues identifikationsfile, (hier gsc mit 2mass) C Diese Subroutine kuemmert sich nicht mehr um die Verwaltung C des Beobachtungsfiles. Sie erhaelt is Saetze isatz und gibt C hieraus ia Beobachtungen aus hier ia = is C ****************************************************************** C s2=dsqrt(2.d0) PIH = .5D0*PI rad = pi/180.d0 ia = is idout = ' none' DO 1 I = 1, is kat = Isatz(i) c read(kat,'(24x,f12.7,f13.8,1x,i4,1x,i2,1x,i2,t73,f5.1,a6,a20)') read(kat,'(a23,1x,7x,1x,7x,1x,f11.7,1x,f12.8,1x,i4,1x,i2,1x,i2, *12x,1x,f4.1,1x,a5,1x,a20)') *ipix, alg,delg,ij,im,id,cmag,id1,id2 ioutp(51:74) = kat(1:24) do k = 1,5 if (id1.eq.iden(k)) then ianf = (k-1)*10+1 iend = ianf+5 ioutp(ianf:iend) = id1 ianf = iend +1 iend = ianf+3 c ioutp(ianf:iend) = kat(74:77) ioutp(ianf:iend) = kat(90:94) end if end do if(id1.eq.iden(1)) then isiga = 800 idout = id2 if(cmag.gt.14.d0.and.camg.lt.15.d0) * isiga = 800 + (cmag-14.d0)*200 if(cmag.ge.15.d0) * isiga = 1000 + (cmag-15.d0)*1500 else isiga = 2300 end if siga = dfloat(isiga)*1.d-4 sigd = dfloat(isigd)*1.d-4 epa = dfloat(ij)+(im-1)*30.d0/365.d0+dfloat(id-1)/365.d0 TA(I)= epa TD(I)= epa ALP(I)=alg*rad DEL(I)=delg*rad+pih AMAG(I)= cmag WA(I)=siga WD(I)=siga ICAT(I)=2 c write(99,'(i3,3a)') i, kat(151:154), kat(116:139), isatz(i)(116:139) c write(99,'(i3,a,4f10.5)') i,kat(151:154),wa(i),wd(i),ta(i),td(i) 1 continue ioutp(101:120) = id2 isatz(1) = ioutp C RETURN C END C C SUBROUTINE CHSORT (NDIM,N,I1,CH,nbyte) C----------------------------------------------------------------------- C EDITION PS.008 88/09/09 SR 2003/12/09 C----------------------------------------------------------------------- C SORT AN ARRAY IN CORE (CHAracter, ASCENDING) C ANALOG ZU PGCSORT C----------------------------------------------------------------------- C Argument Type I/O Meaning C -------- ---- --- ------- C NDIM I*4 IN MAX. NUMBER OF RECORDS. SAME AS IN DIMENSION C N I*4 IN ACTUAL NUMBER OF RECORDS C I1 I*4 I/O ARRAY CONTAINING RECORDS TO BE SORTED C CH CH* Ch4 I/O ARRAY CONTAINING character string sorted along C I1 C nbyte I*4 I/O LAENGE DES STRINGS CH (MAX. 500) C----------------------------------------------------------------------- IMPLICIT REAL*8 (A-H,O-Z),INTEGER (I-N) character*(*) ch character*(500) str DIMENSION I1(NDIM),CH(NDIM) C ---------------------------------------------------------------- C PRINT*,'CHSORT: > (N=',N,')' C NSORT = 0 IF ( nbyte .GE. 501 ) GO TO 992 IF ( N .GE. NDIM ) GO TO 991 M=N C --- LOOP 101 --- 101 M=M/2 IF ( M .EQ. 0 ) GO TO 900 J=1 K=N-M C --- LOOP 102 --- 102 I=J 103 L=I+M IF (I1(I) .LT.I1(L) ) GO TO 104 C --- SORT BLOCK (START) --- C NSORT = NSORT + 1 II=I1(I) STR(1:nbyte)=CH(I) I1(I)=I1(L) CH(I)=CH(L) I1(L)=II CH(L)=STR(1:nbyte) C --- SORT BLOCK (END) --- I=I-M IF(I.GE.1) GOTO 103 104 J=J+1 IF(J.LE.K) GOTO 102 C --- END LOOP 102 --------------- GOTO 101 C --- END LOOP 101 --------------- 900 CONTINUE C PRINT*,'PGCSRT: < (NSORT=',NSORT,')' RETURN c 991 WRITE(6,'(A,I5)')' SORT 1: MAX. NUMBER OF RECORDS REACHED N=',N 991 RETURN 992 WRITE(6,'(A,I5)')' SORT 1: character string groesser 500',nbyte END