c----------------------------------------------------- c c this code is designed to be compiled with GFORTRAN: c c gfortran query_GAIA_DR2.F -o query_GAIA_DR2.e c c To execute: c c ./query_GAIA_DR2.e c c (when you run it with no arguments, the routine will c tell you the possible arguments) c c----------------------------------------------------- c c 2018.07.23 - fixed a bug that printed out the wrong c "auxiliary" info for stars in cone c searches when RV was printed c 2018.06.12 - for the code mode you now have to enter c RA_CEN= DE_CEN= and RAD= c 2018.06.12 - I include the location for the DB in a pre-compiler c directive, so you just have to change the file location c in one place (_DBLOC_). c 2018.06.12 - include a mode where we identify stars by ID number c this requires a second data base, BASE.GDR2_IDMAP, c which has the stars in order, along with the record c number where each can be found in the main database. c 2018.06.08 - redid the catalog; there were a few stars (70) missing for c various reasons (bad gz files at the source, some at the c edge of dec-strips). The catalog now has all the stars. c Added a few paramters (suggested by Mattia) c Added RV. c Added the XY mode to push things into an HST-friendly c frame. c 2018.05.22 - implemented the DUMP mode; best to modify c the routine query_GAIA_DR2_DUMP subroutine c to selectively ouput over the whole sky c 2018.05.02 - fixed some clipping issues by expanding the blocks searched c by one all around c 2018.05.03 - add flexibility to do a box and not sort c 2018.05.07 - fixed some minor nmap_ij mapping issues; c symptoms were that some squares of the sky didn't c get searched; c dB and code should be good now c #define _NMAX_ 9 999 999 #define _DBLOC_ '/user/jayander/GAIA/BASE.GDR2' #define _DBLOC2_ '/user/jayander/GAIA/BASE.GDR2_IDMAP' program query_gaia implicit none real*8 RA_CEN ! RA center of search real*8 DE_CEN ! Dec center of search real*4 RAD ! degrees real*8, dimension(:), allocatable :: ra_o real*8, dimension(:), allocatable :: de_o real*8, dimension(:), allocatable :: era_o real*8, dimension(:), allocatable :: ede_o real*8, dimension(:), allocatable :: mg_o real*8, dimension(:), allocatable :: emg_o real*8, dimension(:), allocatable :: mb_o real*8, dimension(:), allocatable :: emb_o real*8, dimension(:), allocatable :: mr_o real*8, dimension(:), allocatable :: emr_o real*8, dimension(:), allocatable :: mura_o real*8, dimension(:), allocatable :: emura_o real*8, dimension(:), allocatable :: mude_o real*8, dimension(:), allocatable :: emude_o real*8, dimension(:), allocatable :: pi_o real*8, dimension(:), allocatable :: epi_o integer*8, dimension(:), allocatable :: id_o integer*8, dimension(:), allocatable :: nvis_o integer*8, dimension(:), allocatable :: nmat_o real*8, dimension(:), allocatable :: igof_o real*8, dimension(:), allocatable :: ixsn_o integer*8, dimension(:), allocatable :: nbad_o integer*8, dimension(:), allocatable :: ngud_o integer*8, dimension(:), allocatable :: uflg_o integer*8, dimension(:), allocatable :: gflg_o integer*8, dimension(:), allocatable :: rflg_o real*8, dimension(:), allocatable :: rv_o real*8, dimension(:), allocatable :: erv_o integer Os, Ou integer, dimension(:), allocatable :: o_o real*4, dimension(:), allocatable :: v_o character*80 STRING_PROG character*40 STRING_RA, STRING_RAo character*40 STRING_DE, STRING_DEo character*40 STRING_RAD character*20 STRING_DIAG character*80 STRING80 character*80 FILERDML logical RA_SEXIG logical DE_SEXIG logical DE_NEG real RAh, RAm, RAs real DEd, DEm, DEs integer i integer O real*8 dra, dde, ddd real*8 rd2x, rd2y integer NLIST, NLISTs character*99 LIST_STRING99 integer NLS99 character*80 FILE_LISTID logical DOLISTID logical DOLISTRD logical DOBOX logical DODUMP logical DOXY integer XY_XCEN integer XY_YCEN real XY_PSCL real XY_RDAT real*8 dYEARS real*8 RA_RDATE real*8 DE_RDATE real*8 XFRAME real*8 YFRAME logical DORV real*8 RA1, RA2, DE1, DE2 logical DIAG integer NARG, NARGs real*8 dclip integer L, Ls integer*8 id_l(_NMAX_), idu integer*4 r_l integer*4 r_id real*8 RA_MINU, RA_MAXU real*8 DE_MINU, DE_MAXU real*8 ERA_MINU, ERA_MAXU real*8 EDE_MINU, EDE_MAXU real*8 MG_MINU, MG_MAXU real*8 EMG_MINU, EMG_MAXU real*8 MB_MINU, MB_MAXU real*8 EMB_MINU, EMB_MAXU real*8 MR_MINU, MR_MAXU real*8 EMR_MINU, EMR_MAXU real*8 MURA_MINU, MURA_MAXU real*8 EMURA_MINU,EMURA_MAXU real*8 MUDE_MINU, MUDE_MAXU real*8 EMUDE_MINU,EMUDE_MAXU real*8 PI_MINU, PI_MAXU real*8 EPI_MINU, EPI_MAXU real*8 NVIS_MINU, NVIS_MAXU real*8 NMAT_MINU, NMAT_MAXU real*8 IGOF_MINU, IGOF_MAXU real*8 IXSN_MINU, IXSN_MAXU real*8 NBAD_MINU, NBAD_MAXU real*8 NGUD_MINU, NGUD_MAXU real*8 UFLG_MINU, UFLG_MAXU real*8 GFLG_MINU, GFLG_MAXU real*8 RFLG_MINU, RFLG_MAXU real*8 RV_MINU, RV_MAXU real*8 ERV_MINU, ERV_MAXU real*8 BmR_MINU, BmR_MAXU real*8 BmG_MINU, BmG_MAXU real*8 GmR_MINU, GmR_MAXU data RA_MINU, RA_MAXU / -9999.99d0, 9999.99d0 / data DE_MINU, DE_MAXU / -9999.99d0, 9999.99d0 / data ERA_MINU, ERA_MAXU / -9999.99d0, 9999.99d0 / data EDE_MINU, EDE_MAXU / -9999.99d0, 9999.99d0 / data MG_MINU, MG_MAXU / -9999.99d0, 9999.99d0 / data EMG_MINU, EMG_MAXU / -9999.99d0, 9999.99d0 / data MB_MINU, MB_MAXU / -9999.99d0, 9999.99d0 / data EMB_MINU, EMB_MAXU / -9999.99d0, 9999.99d0 / data MR_MINU, MR_MAXU / -9999.99d0, 9999.99d0 / data EMR_MINU, EMR_MAXU / -9999.99d0, 9999.99d0 / data MURA_MINU, MURA_MAXU / -9999.99d0, 9999.99d0 / data EMURA_MINU,EMURA_MAXU / -9999.99d0, 9999.99d0 / data MUDE_MINU, MUDE_MAXU / -9999.99d0, 9999.99d0 / data EMUDE_MINU,EMUDE_MAXU / -9999.99d0, 9999.99d0 / data PI_MINU, PI_MAXU / -9999.99d0, 9999.99d0 / data EPI_MINU, EPI_MAXU / -9999.99d0, 9999.99d0 / data NVIS_MINU, NVIS_MAXU / -9999.99d0, 9999.99d0 / data NMAT_MINU, NMAT_MAXU / -9999.99d0, 9999.99d0 / data IGOF_MINU, IGOF_MAXU / -9999.99d0, 9999.99d0 / data IXSN_MINU, IXSN_MAXU / -9999.99d0, 9999.99d0 / data NBAD_MINU, NBAD_MAXU / -9999.99d0, 9999.99d0 / data NGUD_MINU, NGUD_MAXU / -9999.99d0, 9999.99d0 / data UFLG_MINU, UFLG_MAXU / -9999.99d0, 9999.99d0 / data GFLG_MINU, GFLG_MAXU / -9999.99d0, 9999.99d0 / data RFLG_MINU, RFLG_MAXU / -9999.99d0, 9999.99d0 / data RV_MINU, RV_MAXU / -9999.99d0, 9999.99d0 / data ERV_MINU, ERV_MAXU / -9999.99d0, 9999.99d0 / data BmG_MINU, BmG_MAXU / -9999.99d0, 9999.99d0 / data BmR_MINU, BmR_MAXU / -9999.99d0, 9999.99d0 / data GmR_MINU, GmR_MAXU / -9999.99d0, 9999.99d0 / common / LIMITS_ / RA_MINU, RA_MAXU, . DE_MINU, DE_MAXU, . ERA_MINU, ERA_MAXU, . EDE_MINU, EDE_MAXU, . MG_MINU, MG_MAXU, . EMG_MINU, EMG_MAXU, . MB_MINU, MB_MAXU, . EMB_MINU, EMB_MAXU, . MR_MINU, MR_MAXU, . EMR_MINU, EMR_MAXU, . MURA_MINU, MURA_MAXU, . EMURA_MINU,EMURA_MAXU, . MUDE_MINU, MUDE_MAXU, . EMUDE_MINU,EMUDE_MAXU, . PI_MINU, PI_MAXU, . EPI_MINU, EPI_MAXU, . NVIS_MINU, NVIS_MAXU, . NMAT_MINU, NMAT_MAXU, . IGOF_MINU, IGOF_MAXU, . IXSN_MINU, IXSN_MAXU, . NBAD_MINU, NBAD_MAXU, . NGUD_MINU, NGUD_MAXU, . UFLG_MINU, UFLG_MAXU, . GFLG_MINU, GFLG_MAXU, . RFLG_MINU, RFLG_MAXU, . RV_MINU, RV_MAXU, . ERV_MINU, ERV_MAXU, . BmG_MINU, BmG_MAXU, . BmR_MINU, BmR_MAXU, . GmR_MINU, GmR_MAXU RA_CEN = 90.00 DE_CEN = 0.00 RAD = 0.20 DOLISTRD = .false. DOLISTID = .false. DOBOX = .false. DIAG = .false. DODUMP = .false. DOXY = .false. DORV = .false. allocate( ra_o(_NMAX_)) allocate( de_o(_NMAX_)) allocate( era_o(_NMAX_)) allocate( ede_o(_NMAX_)) allocate( mg_o(_NMAX_)) allocate( emg_o(_NMAX_)) allocate( mb_o(_NMAX_)) allocate( emb_o(_NMAX_)) allocate( mr_o(_NMAX_)) allocate( emr_o(_NMAX_)) allocate( mura_o(_NMAX_)) allocate(emura_o(_NMAX_)) allocate( mude_o(_NMAX_)) allocate(emude_o(_NMAX_)) allocate( pi_o(_NMAX_)) allocate( epi_o(_NMAX_)) allocate( id_o(_NMAX_)) allocate( nvis_o(_NMAX_)) allocate( nmat_o(_NMAX_)) allocate( igof_o(_NMAX_)) allocate( ixsn_o(_NMAX_)) allocate( nbad_o(_NMAX_)) allocate( ngud_o(_NMAX_)) allocate( uflg_o(_NMAX_)) allocate( gflg_o(_NMAX_)) allocate( rflg_o(_NMAX_)) allocate( rv_o(_NMAX_)) allocate( erv_o(_NMAX_)) allocate( o_o(_NMAX_)) allocate( v_o(_NMAX_)) if (iargc().eq.0) then print*,' ' print*,'There are currently FIVE ways to run: ' print*,' ' print*,' ' print*,'OPTION#1 --- cone search ' print*,' ' print*,' 3+ args: RA_CEN=RA DE_CEN=Dec RAD=rad (deg) ' print*,' [DIAG+] ' print*,' [RV+] ' print*,' ["XY(XCEN,YCEN,PIX_SCL,RDATE)"]' print*,' ' print*,' with ' print*,' ' print*,' RA - SEXIG or DECIMAL ' print*,' Dec - SEXIG or DECIMAL ' print*,' ' print*,' ' print*,'examples: ' print*,' ' print*,'./query_GAIA_DR2.e "RA_CEN=00:24:05.359" \' print*,' "DE_CEN=-72:04:53.20" \' print*,' RAD=1.0' print*,' ' print*,'./query_GAIA_DR2.e "RA_CEN=00:24:05.359" \' print*,' "DE_CEN=-72:04:53.20" \' print*,' RAD=0.075 \' print*,' "XY(5000,5000,50,2017.3)" ' print*,' ' print*,' (make a frame with the ACS SCALE) ' print*,' (needs to be in quotes to prevent ' print*,' parser error) ' print*,' (I have not yet double-checked the' print*,' time-pushing; need to add PI) ' print*,' ' print*,'--------' print*,' ' print*,'OPTION#2 --- list of ra/decs ' print*,' ' print*,' ./query_GAIA.e LISTRD=TXT.RDML (list of ra/dec)' print*,' ' print*,'--------' print*,' ' print*,'OPTION#3 --- ' print*,' ' print*,' ./query_GAIA.e LISTID=xxxxxxxxxx (can be a single' print*,' GAIA ID number' print*,' or a file with list' print*,' of numbers)' print*,' ' print*,'--------' print*,' ' print*,'OPTION#4 --- ' print*,' ' print*,'query_gaia_DR2: 1 arg (box):' print*,' ' print*,' ./query_GAIA.e BOX=RA1,RA2,DE1,DE2 (in deg)' print*,' ' print*,' can specify command-line delimiters,' print*,' such as: ' print*,' ' print*,' "ePI_MAXU=0.1" ' print*,' etc ' print*,' ' print*,'--------' print*,' ' print*,'OPTION#5 --- ' print*,' ' print*,' ./query_GAIA.e DUMP (ouptuts the whole catalog; ' print*,' you can modify the code ' print*,' to output the stars that ' print*,' you want; ask Jay if you ' print*,' need help with the FORTRAN)' print*,' ' print*,' can specify command-line delimiters,' print*,' such as: ' print*,' ' print*,' "ePI_MAXU=0.1" ' print*,' etc ' print*,' example ./query_GAIA_DR2.e DUMP \' print*,' EPI_MAXU=0.10000 \' print*,' EPI_MINU=0.00001 ' print*,' ' print*,'----------------------------------------------------' print*,' ' print*,'List of delimeters: ' print*,' ' print*,' RA_MINU RA_MAXU ERA_MINU ERA_MAXU' print*,' DE_MINU DE_MAXU EDE_MINU EDE_MAXU' print*,' MG_MINU MG_MAXU EMG_MINU EMG_MAXU' print*,' MB_MINU MB_MAXU EMB_MINU EMB_MAXU' print*,' MR_MINU MR_MAXU EMR_MINU EMR_MAXU' print*,' MURA_MINU MURA_MAXU EMURA_MINU EMURA_MAXU' print*,' MUDE_MINU MUDE_MAXU EMUDE_MINU EMUDE_MAXU' print*,' PI_MINU PI_MAXU EPI_MINU EPI_MAXU' print*,' NVIS_MINU NVIS_MAXU NMAT_MINU NMAT_MAXU' print*,' IGOF_MINU IGOF_MAXU IXSN_MINU IXSN_MAXU' print*,' NBAD_MINU NBAD_MAXU NGUD_MINU NGUD_MAXU' print*,' UFLG_MINU UFLG_MAXU GFLG_MINU GFLG_MAXU' print*,' RFLG_MINU RFLG_MAXU ' print*,' RV_MINU RV_MAXU ERV_MINU ERV_MAXU' print*,' ' print*,' And colors: ' print*,' BmG_MINU BmG_MAXU BmR_MINU BmR_MAXU' print*,' GmR_MINU GmR_MAXU' print*,' ' print*,' ' print*,'It outputs to STDOUT the data.' print*,' ' print*,'The routine also reports the star number (in this' print*,'list) and the tangent-plane offset in RA, Dec and' print*,'the total offset (all in degrees).' print*,' ' stop endif NARGs = iargc() call getarg(0,STRING_PROG) write(*,'(''# ARG'',i2.2,'': '',80a)') 0, STRING_PROG do NARG = 1, NARGs call getarg(NARG,STRING80) write(*,'(''# ARG'',i2.2,'': '',80a)') NARG, STRING80 if (STRING80(1:3).eq.'XY(') then DOXY = .true. do i = 4, 80 if (STRING80(i:i).eq.')') STRING80(i:i) = ' ' if (STRING80(i:i).eq.',') STRING80(i:i) = ' ' enddo read(STRING80(4:80),*) XY_XCEN, XY_YCEN, XY_PSCL, XY_RDAT if (XY_RDAT.lt.1950.or.XY_RDAT.gt.2050) . stop 'XY_RDAT should be in the form of 2012.33' goto 1 endif if (STRING80(1:3).eq.'RV+') then DORV = .true. goto 1 endif if (STRING80(1:5).eq.'DIAG+') then DIAG = .true. goto 1 endif if (STRING80(1:5).eq.'DIAG-') then DIAG = .false. goto 1 endif if (STRING80(1:8).eq.'RA_MINU=') then read(STRING80(9:80),*) RA_MINU goto 1 endif if (STRING80(1:8).eq.'RA_MAXU=') then read(STRING80(9:80),*) RA_MAXU goto 1 endif if (STRING80(1:8).eq.'DE_MINU=') then read(STRING80(9:80),*) DE_MINU goto 1 endif if (STRING80(1:8).eq.'DE_MAXU=') then read(STRING80(9:80),*) DE_MAXU goto 1 endif if (STRING80(1:8).eq.'MG_MINU=') then read(STRING80(9:80),*) MG_MINU goto 1 endif if (STRING80(1:8).eq.'MG_MAXU=') then read(STRING80(9:80),*) MG_MAXU goto 1 endif if (STRING80(1:8).eq.'MR_MINU=') then read(STRING80(9:80),*) MR_MINU goto 1 endif if (STRING80(1:8).eq.'MR_MAXU=') then read(STRING80(9:80),*) MR_MAXU goto 1 endif if (STRING80(1:8).eq.'MB_MINU=') then read(STRING80(9:80),*) MB_MINU goto 1 endif if (STRING80(1:8).eq.'MB_MAXU=') then read(STRING80(9:80),*) MB_MAXU goto 1 endif if (STRING80(1:8).eq.'PI_MINU=') then read(STRING80(9:80),*) PI_MINU goto 1 endif if (STRING80(1:8).eq.'PI_MAXU=') then read(STRING80(9:80),*) PI_MAXU goto 1 endif if (STRING80(1:8).eq.'RV_MINU=') then read(STRING80(9:80),*) RV_MINU goto 1 endif if (STRING80(1:8).eq.'RV_MAXU=') then read(STRING80(9:80),*) RV_MAXU goto 1 endif if (STRING80(1:9).eq.'ERA_MAXU=') then read(STRING80(10:80),*) ERA_MAXU goto 1 endif if (STRING80(1:9).eq.'ERA_MINU=') then read(STRING80(10:80),*) ERA_MINU goto 1 endif if (STRING80(1:9).eq.'EDE_MAXU=') then read(STRING80(10:80),*) EDE_MAXU goto 1 endif if (STRING80(1:9).eq.'EDE_MINU=') then read(STRING80(10:80),*) EDE_MINU goto 1 endif if (STRING80(1:9).eq.'EMG_MAXU=') then read(STRING80(10:80),*) EMG_MAXU goto 1 endif if (STRING80(1:9).eq.'EMG_MINU=') then read(STRING80(10:80),*) EMG_MINU goto 1 endif if (STRING80(1:9).eq.'EMB_MAXU=') then read(STRING80(10:80),*) EMB_MAXU goto 1 endif if (STRING80(1:9).eq.'EMB_MINU=') then read(STRING80(10:80),*) EMB_MINU goto 1 endif if (STRING80(1:9).eq.'EMR_MAXU=') then read(STRING80(10:80),*) EMR_MAXU goto 1 endif if (STRING80(1:9).eq.'EMR_MINU=') then read(STRING80(10:80),*) EMR_MINU goto 1 endif if (STRING80(1:9).eq.'EPI_MAXU=') then read(STRING80(10:80),*) EPI_MAXU goto 1 endif if (STRING80(1:9).eq.'EPI_MINU=') then read(STRING80(10:80),*) EPI_MINU goto 1 endif if (STRING80(1:9).eq.'ERV_MAXU=') then read(STRING80(10:80),*) ERV_MAXU goto 1 endif if (STRING80(1:9).eq.'ERV_MINU=') then read(STRING80(10:80),*) ERV_MINU goto 1 endif if (STRING80(1:10).eq.'MURA_MINU=') then read(STRING80(11:80),*) MURA_MINU goto 1 endif if (STRING80(1:10).eq.'MURA_MAXU=') then read(STRING80(11:80),*) MURA_MAXU goto 1 endif if (STRING80(1:10).eq.'MUDE_MINU=') then read(STRING80(11:80),*) MUDE_MINU goto 1 endif if (STRING80(1:10).eq.'MUDE_MAXU=') then read(STRING80(11:80),*) MUDE_MAXU goto 1 endif if (STRING80(1:10).eq.'NVIS_MINU=') then read(STRING80(11:80),*) NVIS_MINU goto 1 endif if (STRING80(1:10).eq.'NVIS_MAXU=') then read(STRING80(11:80),*) NVIS_MAXU goto 1 endif if (STRING80(1:10).eq.'NMAT_MINU=') then read(STRING80(11:80),*) NMAT_MINU goto 1 endif if (STRING80(1:10).eq.'NMAT_MAXU=') then read(STRING80(11:80),*) NMAT_MAXU goto 1 endif if (STRING80(1:10).eq.'IGOF_MINU=') then read(STRING80(11:80),*) IGOF_MINU goto 1 endif if (STRING80(1:10).eq.'IGOF_MAXU=') then read(STRING80(11:80),*) IGOF_MAXU goto 1 endif if (STRING80(1:10).eq.'IXSN_MINU=') then read(STRING80(11:80),*) IXSN_MINU goto 1 endif if (STRING80(1:10).eq.'IXSN_MAXU=') then read(STRING80(11:80),*) IXSN_MAXU goto 1 endif if (STRING80(1:10).eq.'NBAD_MINU=') then read(STRING80(11:80),*) NBAD_MINU goto 1 endif if (STRING80(1:10).eq.'NBAD_MAXU=') then read(STRING80(11:80),*) NBAD_MAXU goto 1 endif if (STRING80(1:10).eq.'NGUD_MINU=') then read(STRING80(11:80),*) NGUD_MINU goto 1 endif if (STRING80(1:10).eq.'NGUD_MAXU=') then read(STRING80(11:80),*) NGUD_MAXU goto 1 endif if (STRING80(1:10).eq.'UFLG_MINU=') then read(STRING80(11:80),*) UFLG_MINU goto 1 endif if (STRING80(1:10).eq.'UFLG_MAXU=') then read(STRING80(11:80),*) UFLG_MAXU goto 1 endif if (STRING80(1:10).eq.'GFLG_MINU=') then read(STRING80(11:80),*) GFLG_MINU goto 1 endif if (STRING80(1:10).eq.'GFLG_MAXU=') then read(STRING80(11:80),*) GFLG_MAXU goto 1 endif if (STRING80(1:10).eq.'RFLG_MINU=') then read(STRING80(11:80),*) RFLG_MINU goto 1 endif if (STRING80(1:10).eq.'RFLG_MAXU=') then read(STRING80(11:80),*) RFLG_MAXU goto 1 endif if (STRING80(1:11).eq.'EMURA_MINU=') then read(STRING80(12:80),*) EMURA_MINU goto 1 endif if (STRING80(1:11).eq.'EMURA_MAXU=') then read(STRING80(12:80),*) EMURA_MAXU goto 1 endif if (STRING80(1:11).eq.'EMUDE_MINU=') then read(STRING80(12:80),*) EMUDE_MINU goto 1 endif if (STRING80(1:11).eq.'EMUDE_MAXU=') then read(STRING80(12:80),*) EMUDE_MAXU goto 1 endif if (STRING80(1:7).eq.'LISTRD=') goto 1 if (STRING80(1:7).eq.'LISTID=') goto 1 if (STRING80(1:4).eq.'BOX=') goto 1 if (STRING80(1:4).eq.'DUMP') goto 1 if (STRING80(1:7).eq.'RA_CEN=') goto 1 if (STRING80(1:7).eq.'DE_CEN=') goto 1 if (STRING80(1:4).eq.'RAD=') goto 1 print*,'PROBLEM PARSING: ',STRING80 stop 1 continue enddo if (DORV.and.DOXY) stop 'cannot have both DOXY and DORV' call getarg(0,STRING_PROG) call getarg(1,STRING80) if (STRING80(1:7).eq.'LISTRD=') then if (DOXY) stop 'Cannot do LIST and DOXY.' DOLISTRD = .true. DORV = .true. read(STRING80(8:80),*) FILERDML open(21,file=FILERDML,status='old') endif if (STRING80(1:7).eq.'LISTID=') then if (STRING80(8:8).ge.'0'.and. . STRING80(8:8).le.'9') then Ls = 1 read(STRING80(8:80),*) id_l(1) FILE_LISTID = STRING80(8:80) else FILE_LISTID = STRING80(8:80) open(22,file=FILE_LISTID,status='old') Ls = 0 33 continue read(22,'(80a)',end=34) STRING80 if (STRING80(1:1).eq.'#') goto 33 read(STRING80,*) idu Ls = Ls + 1 if (Ls.gt._NMAX_) then print*,' ' print*,'Too many stars in LISTID file. ' print*,' ' print*,'You need to increase the compiler ' print*,'parameter _NMAX_ to get the full list' print*,' ' stop endif id_l(Ls) = idu goto 33 34 close(22) endif DOLISTID = .true. DORV = .true. write(*,'(''# '')') write(*,'(''# query_GAIA_DR2 --- '')') write(*,'(''# being run in LISTID mode '')') write(*,'(''# '')') write(*,'(''# FILE_LISTID = '',72a)') FILE_LISTID(1:72) write(*,'(''# '')') write(*,'(''# If you use this for your science, see the '')') write(*,'(''# way to credit the catalog at the bottom of'')') write(*,'(''# the file.'')') write(*,'(''# '')') write(*,117) ' ' write(*,116) ' ' write(*,115) ' ' write(*,117) ' ' do L = 1, Ls r_l = r_id(id_l(L)) call sub_query_GAIA_DR2_R(r_l, . ra_o, de_o, era_o, ede_o, . mg_o, emg_o, . mb_o, emb_o, . mr_o, emr_o, . mura_o, emura_o, . mude_o, emude_o, . pi_o, epi_o, . id_o, . nvis_o, nmat_o, . igof_o, ixsn_o, . nbad_o, ngud_o, . uflg_o, gflg_o, rflg_o, . rv_o, erv_o, . Os,DIAG,DORV) do O = 1, Os if (id_o(O).eq.id_l(L)) then Ou = O write(*,119) ra_o(Ou), de_o(Ou), . era_o(Ou)/1000., ede_o(Ou)/1000., . mg_o(Ou), emg_o(Ou)/1000., . mb_o(Ou), emb_o(Ou)/1000., . mr_o(Ou), emr_o(Ou)/1000., . mura_o(Ou), emura_o(Ou), . mude_o(Ou), emude_o(Ou), . pi_o(Ou), epi_o(Ou), . id_o(Ou), . nvis_o(Ou), nmat_o(Ou), . igof_o(Ou), ixsn_o(Ou), . nbad_o(Ou), ngud_o(Ou), . uflg_o(Ou), gflg_o(Ou), rflg_o(Ou), . dclip(dra*3600,-9999.9d0,9999.9d0), . dclip(dde*3600,-9999.9d0,9999.9d0), . dclip(ddd*3600, 0.0d0,9999.9d0), . L, . rv_o(Ou), erv_o(Ou) endif enddo enddo write(*,117) ' ' write(*,116) ' ' write(*,115) ' ' write(*,117) ' ' goto 555 stop endif if (STRING80(1:4).eq.'BOX=') then DOBOX = .true. read(STRING80(5:80),*) RA1,RA2,DE1,DE2 write(*,'(''# '')') write(*,'(''# ROUTINE: '',a80)') STRING_PROG write(*,'(''# '',a80)') STRING80 write(*,'(''# '')') write(*,'(''# RAMIN/MAX: '',2f12.6)') RA1,RA2 write(*,'(''# DEMIN/MAX: '',2f12.6)') DE1,DE2 write(*,'(''# '')') if (RA2.le.RA1) stop 'RA2.le.RA1' if (DE2.le.DE1) stop 'DE2.le.DE1' call show_delimeters write(*,'(''# '')') write(*,'(''# If you use this for your science, see the '')') write(*,'(''# way to credit the catalog at the bottom of'')') write(*,'(''# the file.'')') write(*,'(''# '')') write(*,417) write(*,416) write(*,415) write(*,417) call sub_query_GAIA_DR2_BOXOUT(RA1,RA2,DE1,DE2) write(*,417) write(*,416) write(*,415) write(*,417) goto 555 endif if (STRING80(1:4).eq.'DUMP') then call show_delimeters call sub_query_GAIA_DR2_DUMP stop endif if (.not.DOLISTRD) then call getarg(1,STRING_RAo) call getarg(2,STRING_DEo) call getarg(3,STRING_RAD) if (STRING_RAo(1:7).ne.'RA_CEN='.or. . STRING_DEo(1:7).ne.'DE_CEN='.or. . STRING_RAD(1:4).ne.'RAD=') then print*,' ' print*,'If you are not running this in ' print*,'LIST mode, BOX mode, or DUMP mode, ' print*,'then you must want CONE mode. ' print*,'This requires the first three args ' print*,'to be RA_CEN=... DE_CEN=... RAD=.. ' print*,' ' stop endif STRING_RAo = STRING_RAo(8:40) STRING_DEo = STRING_DEo(8:40) STRING_RAD = STRING_RAD(5:40) call show_delimeters endif NLIST = 0 333 continue if (DOLISTRD) then read(21,'(a99)',end=334) LIST_STRING99 read(LIST_STRING99,*) STRING_RAo, STRING_DEo NLIST = NLIST+1 STRING_RAD = "0.01" NLS99 = 1 do i = 1, 99 if (LIST_STRING99(i:i).ne.' ') NLS99 = i enddo endif STRING_RA = STRING_RAo STRING_DE = STRING_DEo RA_SEXIG = .false. do i = 1, 20 if (STRING_RA(i:i).eq.':') then RA_SEXIG = .true. STRING_RA(i:i) = ' ' endif enddo if (RA_SEXIG) then read(STRING_RA,*) RAh, RAm, RAs RA_CEN = (RAh + RAm/60.0d0 + RAs/60.0d0/60.0d0)/24.0d0*360.0d0 else read(STRING_RA,*) RA_CEN endif DE_NEG = .false. DE_SEXIG = .false. do i = 1, 20 if (STRING_DE(i:i).eq.'-') then DE_NEG = .true. STRING_DE(i:i) = ' ' endif if (STRING_DE(i:i).eq.':') then DE_SEXIG = .true. STRING_DE(i:i) = ' ' endif enddo if (DE_SEXIG) then read(STRING_DE,*) DEd, DEm, DEs DE_CEN = (DEd + DEm/60.0d0 + DEs/60.0d0/60.0d0) else read(STRING_DE,*) DE_CEN endif if (DE_NEG) DE_CEN = -DE_CEN read(STRING_RAD,*) RAD call sub_query_GAIA_DR2(RA_CEN,DE_CEN,RAD, . ra_o, de_o, era_o, ede_o, . mg_o, emg_o, . mb_o, emb_o, . mr_o, emr_o, . mura_o, emura_o, . mude_o, emude_o, . pi_o, epi_o, . id_o, . nvis_o, nmat_o, . igof_o, ixsn_o, . nbad_o, ngud_o, . uflg_o, gflg_o, rflg_o, . rv_o, erv_o, . Os,DIAG,DORV) if (DIAG) then do O = 1, Os write(88,188) ra_o(O), de_o(O), . int(era_o(O)), int(ede_o(O)), . mg_o(O), int(emg_o(O)), . mb_o(O), int(emb_o(O)), . mr_o(O), int(emr_o(O)), . mura_o(O), emura_o(O), . mude_o(O), emude_o(O), . pi_o(O), epi_o(O), . id_o(O), . nvis_o(O), nmat_o(O), . igof_o(O), ixsn_o(O), . nbad_o(O), ngud_o(O), . uflg_o(O), gflg_o(O), rflg_o(O), . O, rv_o(O), erv_o(O) 188 format(f14.10,1x,f14.10,1x,i5,1x,i5,1x, . f6.3,1x,i3,1x, . f6.3,1x,i3,1x, . f6.3,1x,i3,1x, . f8.3,1x,f5.3,1x, . f8.3,1x,f5.3,1x, . f8.3,1x,f5.3,1x, . i20,1x, . i3,1x,i3,1x, . f6.3,1x, . f6.3,1x, . i4,1x,i4,1x, . 3i1,1x, . i6,1x, . f8.3,1x,f6.3) enddo endif if (Os.gt._NMAX_) then print*,' ' print*,'THE SEARCH RETURNED TOO MANY SOURCES.' print*,'IT IS HARD-CODED TO RETURN AT MOST ' print*,'_NMAX_ = ',_NMAX_ print*,' ' print*,'BUT THE SEARCH RESULTED IN' print*,' Ns = ',Os print*,' ' print*,'NEED TO INCREASE FINDING LIMIT.' print*,' ' stop endif c---------------------------------------------- c c output the header... c if (.not.DOLISTRD.or.NLIST.eq.1) then write(*,'(''# '')') write(*,'(''# ROUTINE: '',a80)') STRING_PROG if (.not.DOLISTRD) then write(*,'(''# '',a20)') STRING_RAo write(*,'(''# '',a20)') STRING_DEo write(*,'(''# '',a20)') STRING_RAD write(*,'(''# '')') write(*,'(''# RA_CEN: '',f18.8)') RA_CEN write(*,'(''# DE_CEN: '',f18.8)') DE_CEN write(*,'(''# RAD: '',f18.8)') RAD write(*,'(''# '')') write(*,'(''# #: '',i12)') Os write(*,'(''# '')') if (DOXY) then write(*,'(''# '')') write(*,'(''# PUT OUTPUT INTO A HST-TYPE FRAME: '')') write(*,'(''# XY_XCEN: '',i5 )') XY_XCEN write(*,'(''# XY_YCEN: '',i5 )') XY_YCEN write(*,'(''# XY_PSCL: '',f8.2)') XY_PSCL write(*,'(''# XY_RDAT: '',f8.2)') XY_RDAT write(*,'(''# '')') endif endif if (DOLISTRD) then write(*,'(''# LIST: '',a80)') STRING80 endif write(*,'(''# '')') write(*,'(''# If you use this for your science, see the '')') write(*,'(''# way to credit the catalog at the bottom of'')') write(*,'(''# the file.'')') write(*,'(''# '')') endif do O = 1, Os o_o(O) = O dra = rd2x(ra_o(O),de_o(O),RA_CEN,DE_CEN) dde = rd2y(ra_o(O),de_o(O),RA_CEN,DE_CEN) ddd = sqrt(dra**2+dde**2) v_o(O) = ddd enddo call QSORTI (o_o,Os,v_o) if (DOXY) then write(*,'(''#'')') write(*,316) write(*,'(''#'')') goto 444 endif if (DOLISTRD) then if (NLIST.gt.1) goto 444 write(*,117) ' ', ' ' write(*,116) ' ', ' ' write(*,115) ' ', ' ' write(*,117) ' ', ' ' goto 444 endif if (DORV) then write(*,117) ' ' write(*,116) ' ' write(*,115) ' ' write(*,117) ' ' goto 444 endif write(*,117) write(*,116) write(*,115) write(*,117) 444 continue if (DOLISTRD) Os = 1 do O = 1, Os Ou = o_o(O) dra = rd2x(ra_o(Ou),de_o(Ou),RA_CEN,DE_CEN) dde = rd2y(ra_o(Ou),de_o(Ou),RA_CEN,DE_CEN) ddd = sqrt(dra**2+dde**2) if (mg_o(Ou).lt.1) emg_o(Ou) = 0. if (mb_o(Ou).lt.1) emb_o(Ou) = 0. if (mr_o(Ou).lt.1) emr_o(Ou) = 0. if (.not.( ddd .lt.99.9)) ddd = 99.9 if (DOXY) then dYEARS = XY_RDAT - 2015.5d0 RA_RDATE = ra_o(Ou) + dYEARS*mura_o(Ou)/1000./3600. . /cos(de_o(Ou)/180.0*3.1415927) DE_RDATE = de_o(Ou) + dYEARS*mude_o(Ou)/1000./3600. dra = rd2x(RA_RDATE,DE_RDATE,RA_CEN,DE_CEN) dde = rd2y(RA_RDATE,DE_RDATE,RA_CEN,DE_CEN) XFRAME = XY_XCEN - dra*3600.0d0*1000.0d0/XY_PSCL ! need to include parallax... YFRAME = XY_YCEN + dde*3600.0d0*1000.0d0/XY_PSCL if (XFRAME.lt.-9999.0) XFRAME = -9999.0 if (YFRAME.lt.-9999.0) YFRAME = -9999.0 if (XFRAME.gt.99999.0) XFRAME = 99999.0 if (YFRAME.gt.99999.0) YFRAME = 99999.0 write(*,319) XFRAME, YFRAME, mg_o(Ou), . RA_RDATE, DE_RDATE, . ra_o(Ou), de_o(Ou), . era_o(Ou)/1000., ede_o(Ou)/1000., . mg_o(Ou), emg_o(Ou)/1000., . mb_o(Ou), emb_o(Ou)/1000., . mr_o(Ou), emr_o(Ou)/1000., . mura_o(Ou), emura_o(Ou), . mude_o(Ou), emude_o(Ou), . pi_o(Ou), epi_o(Ou), . id_o(Ou) goto 888 endif if (DOLISTRD) then write(*,119) ra_o(Ou), de_o(Ou), . era_o(Ou)/1000., ede_o(Ou)/1000., . mg_o(Ou), emg_o(Ou)/1000., . mb_o(Ou), emb_o(Ou)/1000., . mr_o(Ou), emr_o(Ou)/1000., . mura_o(Ou), emura_o(Ou), . mude_o(Ou), emude_o(Ou), . pi_o(Ou), epi_o(Ou), . id_o(Ou), . nvis_o(Ou), nmat_o(Ou), . igof_o(Ou), ixsn_o(Ou), . nbad_o(Ou), ngud_o(Ou), . uflg_o(Ou), gflg_o(Ou), rflg_o(Ou), . dclip(dra*3600,-9999.9d0,9999.9d0), . dclip(dde*3600,-9999.9d0,9999.9d0), . dclip(ddd*3600, 0.0d0,9999.9d0), . NLIST, . rv_o(Ou), erv_o(Ou), . RA_CEN, DE_CEN, . LIST_STRING99(1:NLS99) goto 888 endif if (.not.DORV) then write(*,119) ra_o(Ou), de_o(Ou), . era_o(Ou)/1000., ede_o(Ou)/1000., . mg_o(Ou), emg_o(Ou)/1000., . mb_o(Ou), emb_o(Ou)/1000., . mr_o(Ou), emr_o(Ou)/1000., . mura_o(Ou), emura_o(Ou), . mude_o(Ou), emude_o(Ou), . pi_o(Ou), epi_o(Ou), . id_o(ou), . nvis_o(Ou), nmat_o(Ou), . igof_o(Ou), ixsn_o(Ou), . nbad_o(Ou), ngud_o(Ou), . uflg_o(Ou), gflg_o(Ou), rflg_o(Ou), . dclip(dra*3600,-9999.9d0,9999.9d0), . dclip(dde*3600,-9999.9d0,9999.9d0), . dclip(ddd*3600, 0.0d0,9999.9d0), . O goto 888 endif write(*,119) ra_o(Ou), de_o(Ou), . era_o(Ou)/1000., ede_o(Ou)/1000., . mg_o(Ou), emg_o(Ou)/1000., . mb_o(Ou), emb_o(Ou)/1000., . mr_o(Ou), emr_o(Ou)/1000., . mura_o(Ou), emura_o(Ou), . mude_o(Ou), emude_o(Ou), . pi_o(Ou), epi_o(Ou), . id_o(Ou), . nvis_o(Ou), nmat_o(Ou), . igof_o(Ou), ixsn_o(Ou), . nbad_o(Ou), ngud_o(Ou), . uflg_o(Ou), gflg_o(Ou), rflg_o(Ou), . dclip(dra*3600,-9999.9d0,9999.9d0), . dclip(dde*3600,-9999.9d0,9999.9d0), . dclip(ddd*3600, 0.0d0,9999.9d0), . O, . rv_o(Ou), erv_o(Ou) 888 continue enddo 119 format(f14.10,1x,f14.10,1x, . f7.3,1x,f7.3,1x, . f6.3,1x,f5.3,1x, . f6.3,1x,f5.3,1x, . f6.3,1x,f5.3,1x, . f8.3,1x,f5.3,1x, . f8.3,1x,f5.3,1x, . f8.3,1x,f5.3,1x, . i20,1x, . i3,1x,i3,1x, . f6.3,1x, . f6.3,1x, . i4,1x,i4,1x, . 3i2,1x, . f9.3,1x,f9.3,1x,f8.3,1x, . i8, . f9.3,1x,f6.3,1x . f12.8,1x,f12.8,1x,99a) 115 format('# (deg) ',1x,' (deg) ',1x, . ' (mas)',1x,' (mas)',1x, . ' (mag)',1x,'(mag)',1x, . ' (mag)',1x,'(mag)',1x, . ' (mag)',1x,'(mag)',1x, . '(mas/yr)',1x,'(m/y)',1x, . '(mas/yr)',1x,'(m/y)',1x, . ' (mas)',1x,'(mas)',1x, . ' ',1x, . ' ',1x,' ',1x, . ' ',1x, . ' ',1x, . ' ',1x,' ',1x, . ' ',1x, . ' (") ',1x,' (") ',1x,' (") ',1x, . ' ',1a, . ' (km/s)',1x,'(km/s)',1x,1a) 116 format('#RIGHT ASCENSN',1x,' DECLINATION',1x, . ' eRA ',1x,' eDEC',1x, . ' GMAG',1x,'eGMAG',1x, . ' BMAG',1x,'eBMAG',1x, . ' RMAG',1x,'eRMAG',1x, . ' muRA',1x,'emuRA',1x, . ' muDEC',1x,'emuDE',1x, . ' PI ',1x,' ePI',1x, . ' GAIA_DR2_ID_NUMBER ',1x, . 'NVI',1x,'NMT',1x, . ' IGOF',1x, . ' IXSN',1x, . 'NBAD',1x,'NGUD',1x, . ' U G R',1x, . ' dRA',1x,' dDEC',1x,' dTOT',1x, . ' ORDNO',1a, . ' RV',1x,' eRV',1a, . ' RA(INPUT)',1x,' DEC(INPUT)',1x, . 'INPUT FILE ---- ') 117 format('#.............',1x,'..............',1x, . '.......',1x,'.......',1x, . '......',1x,'.....',1x, . '......',1x,'.....',1x, . '......',1x,'.....',1x, . '........',1x,'.....',1x, . '........',1x,'.....',1x, . '........',1x,'.....',1x, . '....................',1x, . '...',1x,'...',1x, . '......',1x, . '......',1x, . '....',1x,'....',1x, . ' . . .',1x, . '.........',1x,'.........',1x,'........',1x, . '........',1a, . '.........',1x,'......',1a, ! for RV . '............',1x,'............',1x, ! for list . '.....................................') 415 format('# (deg) ',1x,' (deg) ',1x, . ' (mas)',1x,' (mas)',1x, . ' (mag)',1x,'(mag)',1x, . ' (mag)',1x,'(mag)',1x, . ' (mag)',1x,'(mag)',1x, . '(mas/yr)',1x,'(m/y)',1x, . '(mas/yr)',1x,'(m/y)',1x, . ' (mas)',1x,'(mas)',1x, . ' ',1x, . ' ',1x,' ',1x, . ' ',1x, . ' ',1x, . ' ',1x,' ',1x, . ' ',1x, . ' (km/s)',1x,'(km/s)',1x, . ' ') 416 format('#RIGHT ASCENSN',1x,' DECLINATION',1x, . ' eRA ',1x,' eDEC',1x, . ' GMAG',1x,'eGMAG',1x, . ' BMAG',1x,'eBMAG',1x, . ' RMAG',1x,'eRMAG',1x, . ' muRA',1x,'emuRA',1x, . ' muDEC',1x,'emuDE',1x, . ' PI ',1x,' ePI',1x, . ' GAIA_DR2_ID_NUMBER ',1x, . 'NVI',1x,'NMT',1x, . ' IGOF',1x, . ' IXSN',1x, . 'NBAD',1x,'NGUD',1x, . ' U G R',1x, . ' RV',1x,' eRV',1x, . ' ORDNO') 417 format('#.............',1x,'..............',1x, . '.......',1x,'.......',1x, . '......',1x,'.....',1x, . '......',1x,'.....',1x, . '......',1x,'.....',1x, . '........',1x,'.....',1x, . '........',1x,'.....',1x, . '........',1x,'.....',1x, . '....................',1x, . '...',1x,'...',1x, . '......',1x, . '......',1x, . '....',1x,'....',1x, . ' . . .',1x, . '........',1x, . '........',1x,'......') 319 format(f10.4,1x,f10.4,1x,f7.3,1x, . f14.10,1x,f14.10,1x, . f14.10,1x,f14.10,1x, . f7.3,1x,f7.3,1x, . f6.3,1x,f5.3,1x, . f6.3,1x,f5.3,1x, . f6.3,1x,f5.3,1x, . f8.3,1x,f5.3,1x, . f8.3,1x,f5.3,1x, . f8.3,1x,f5.3,1x, . i20) 316 format('# XFRAME',1x,' YFRAME',1x,' GMAG',1x, . ' RA(RDATE)',1x,' DEC(RDATE)',1x, . ' RA(2015.5)',1x,' DEC(2015.5)',1x, . ' eRA ',1x,' eDEC',1x, . ' GMAG',1x,'eGMAG',1x, . ' BMAG',1x,'eBMAG',1x, . ' RMAG',1x,'eRMAG',1x, . ' muRA',1x,'emuRA',1x, . ' muDEC',1x,'emuDE',1x, . ' PI ',1x,' ePI',1x, . ' GAIA_DR2_ID_NUMBER ') 135 format('# (deg) ',1x,' (deg) ',1x, . ' (mas)',1x,' (mas)',1x, . ' (mag)',1x,'(mag)',1x, . ' (mag)',1x,'(mag)',1x, . ' (mag)',1x,'(mag)',1x, . '(mas/yr)',1x,'(m/y)',1x, . '(mas/yr)',1x,'(m/y)',1x, . ' (mas)',1x,'(mas)',1x, . ' ') if (DOLISTRD) goto 333 334 close(21) if (DOXY) then write(*,'(''#'')') write(*,316) write(*,'(''#'')') goto 555 endif if (DOLISTRD) then write(*,117) ' ', ' ' write(*,116) ' ', ' ' write(*,115) ' ', ' ' write(*,117) ' ', ' ' goto 555 endif if (.not.DORV) then write(*,117) write(*,116) write(*,115) write(*,117) goto 555 endif if (DORV) then write(*,117) ' ' write(*,116) ' ' write(*,115) ' ' write(*,117) ' ' endif 555 continue write(*,'(''# '')' ) write(*,'(''# -----------------------------------------------'')') write(*,'(''# '')' ) write(*,'(''# RA -- Right Ascension, degrees '')') write(*,'(''# DE -- Declination, degrees '')') write(*,'(''# eRA -- mas; quoted error in RA '')') write(*,'(''# eDE -- mas; quoted error in RA '')') write(*,'(''# GMAG -- GAIAs green magnitude '')') write(*,'(''# eGMAG -- error in GMAG (dflx/flx) '')') write(*,'(''# BMAG -- GAIAs blue magnitude '')') write(*,'(''# eBMAG -- error in BMAG (dflx/flx) '')') write(*,'(''# RMAG -- GAIAs red magnitude '')') write(*,'(''# eRMAG -- error in BMAG (dflx/flx) '')') write(*,'(''# muRA -- proper motion in RA (mas/yr) '')') write(*,'(''# (no cos(DEC) needed) '')') write(*,'(''# emuRA -- err in RA proper motion '')') write(*,'(''# muDE -- proper motion in DEC (mas/yr) '')') write(*,'(''# emuDE -- err in DEC proper motion '')') write(*,'(''# PI -- parallax (mas) '')') write(*,'(''# ePI -- err in PI (mas) '')') write(*,'(''# # -- GAIAs DR2 ID NUMBER (int*8) '')') write(*,'(''# NVI -- visibility periods used '')') write(*,'(''# NMT -- num of astrom-matchd obsns '')') write(*,'(''# IGOF -- astrometric goodness-of-fit '')') write(*,'(''# IXSN -- astrometric excess noise '')') write(*,'(''# NGOOD -- number of good astrom obsns '')') write(*,'(''# NBAD -- number of bad astrom obsns '')') write(*,'(''# U -- flag constructed by Mattia: '')') write(*,'(''# uflag '')') write(*,'(''# = sqrt(chi2/(ngood-5)) '')') write(*,'(''# lt.(1.2*max(1., '')') write(*,'(''# exp(-0.2*(gmag-19.5)))) '')') write(*,'(''# G -- flag constructed by Mattia: '')') write(*,'(''# eval = phot_bp_rp_excess_fac '')') write(*,'(''# gflag = (eval.gt.aux1).and. '')') write(*,'(''# (eval.lt.aux2) '')') write(*,'(''# R -- radial veloicty available? '')') write(*,'(''# RV -- radial velocity (km/s) '')') write(*,'(''# eRV -- error in RV (km/s) '')') write(*,'(''# '')') write(*,'(''# -----------------------------------------------'')') write(*,'(''# '')') write(*,'(''# This work has made use of data from the '')') write(*,'(''# European Space Agency (ESA) mission {\it Gaia} '')') write(*,'(''# (\url{https://www.cosmos.esa.int/gaia}), '')') write(*,'(''# processed by the {\it Gaia} Data Processing and'')') write(*,'(''# Analysis Consortium (DPAC, '')') write(*,'(''# \url{https://www.cosmos.esa.int/web/gaia/dpac/ '')') write(*,'(''# consortium}). '')') write(*,'(''# Funding for the DPAC has been provided by '')') write(*,'(''# national institutions, in particular the '')') write(*,'(''# institutions participating in the {\it Gaia} '')') write(*,'(''# Multilateral Agreement. '')') write(*,'(''# '')') write(*,'(''# '')') write(*,'(''# If you have used Gaia DR2 data in your, '')') write(*,'(''# research, please cite both the Gaia mission '')') write(*,'(''# paper and the Gaia DR2 release paper: '')') write(*,'(''# '')') write(*,'(''# Gaia Collaboration et al. (2016) '')') write(*,'(''# "The Gaia mission" A&A 595, pp. A1. '')') write(*,'(''# Description of the Gaia mission '')') write(*,'(''# (spacecraft, instruments, survey and'')') write(*,'(''# meast principles, and operations) '')') write(*,'(''# '')') write(*,'(''# and '')') write(*,'(''# '')') write(*,'(''# Gaia Collaboration et al. (2018b) '')') write(*,'(''# "Gaia Data Release 2: Summary of the '')') write(*,'(''# contents and survey properties. '')') write(*,'(''# A&A (special issue for Gaia DR2). '')') write(*,'(''# '')') write(*,'(''# '')') STOP end c-------------------------------------------------------- c c sub_query_gaia.F - c c this is a FORTRAN subroutine that queries the GAIA catalog c c-------------------------------------------------------- subroutine sub_query_GAIA_DR2(RA_CEN,DE_CEN,RAD, . ra_o, de_o, er_o, ed_o, . mg_o, emg_o, . mb_o, emb_o, . mr_o, emr_o, . mura_o, emura_o, . mude_o, emude_o, . pi_o, epi_o, . id_o, . nvis_o, nmat_o, . igof_o, ixsn_o, . nbad_o, ngud_o, . uflg_o, gflg_o, rflg_o, . rv_o, erv_o, . Os,DIAG,DORV) implicit none real*8 RA_CEN real*8 DE_CEN real*4 RAD real*8 ra_o(_NMAX_) real*8 de_o(_NMAX_) real*8 er_o(_NMAX_) real*8 ed_o(_NMAX_) real*8 mg_o(_NMAX_) real*8 emg_o(_NMAX_) real*8 mb_o(_NMAX_) real*8 emb_o(_NMAX_) real*8 mr_o(_NMAX_) real*8 emr_o(_NMAX_) real*8 mura_o(_NMAX_) real*8 emura_o(_NMAX_) real*8 mude_o(_NMAX_) real*8 emude_o(_NMAX_) real*8 pi_o(_NMAX_) real*8 epi_o(_NMAX_) integer*8 id_o(_NMAX_) integer*8 nvis_o(_NMAX_) integer*8 nmat_o(_NMAX_) real*8 igof_o(_NMAX_) real*8 ixsn_o(_NMAX_) integer*8 nbad_o(_NMAX_) integer*8 ngud_o(_NMAX_) integer*8 uflg_o(_NMAX_) integer*8 gflg_o(_NMAX_) integer*8 rflg_o(_NMAX_) real*8 rv_o(_NMAX_) real*8 erv_o(_NMAX_) integer Os logical DIAG logical DORV integer n_o(_NMAX_) real dr_o(_NMAX_) real dd_o(_NMAX_) real*8 rd2x, rd2y real dra, dde, ddd c--------------------------------------- c integer i0 character*80 stringg character*80 STRING integer nstar real*8 RA ! RA in degrees real*8 DE ! De in degrees real*8 eRA ! error in RA (deg) real*8 eDE ! error in DE (deg) real*8 GMAG ! GMAG (in mag) real*8 eGMAG ! error in GMAG real*8 BMAG ! BMAG real*8 eBMAG ! error in BMAG real*8 RMAG ! RMAG real*8 eRMAG ! error in RMAG real*8 muRA ! pmRA (in arcsec/year) real*8 emuRA ! error in pmRA real*8 muDE ! pmDE real*8 emuDE ! error in pmDE real*8 PI ! parallax real*8 ePI ! error in parralax integer*8 LAB_I8 ! GAIA label integer*8 NVIS ! number of visibilities integer*8 NMAT ! real*8 IGOF ! real*8 IXSN ! integer*8 NBAD ! number of bad measts integer*8 NGUD ! number of good measts integer*8 UFLG ! use flag integer*8 GFLG ! good flag integer*8 RFLG ! is there a RV? real*8 RV ! rv real*8 ERV ! rv error c----------------------------------- c c read in one record at a time; this c contains the current 277-star record c byte buff50_100(50,100) byte buff5000(5000) equivalence(buff5000,buff50_100) byte locrec_b(50) integer N c------------------------------------- c c this map tells you what the first record c is for any point in the sky c integer*4 NMAP_IJ(3601,1801) byte NMAP_B(25941604) equivalence(NMAP_IJ,NMAP_B) common /NMAP_IJ_/NMAP_IJ byte B_12L(12,7224631) integer*8 ID_Q(7224631) real*4 RV_Q(7224631) real*4 eRV_Q(7224631) integer Qs common /RV_Q_/ID_Q, RV_Q, eRV_Q, Qs logical FIRST data FIRST / .true. / common /FIRST_/FIRST c--------------------------------------------------------------- integer IIMINu,IIMAXu integer IIMIN, IIMAX, IICEN integer JJMIN, JJMAX, JJCEN integer i, j real*8 rminij, rmaxij real*8 dminij, dmaxij integer Ls integer Q integer B real*8 RA_MIN, RA_MAX real*8 DE_MIN, DE_MAX integer ios integer ii, jj integer n1, n2 integer r1, r2, r integer*8 I8, I8_RV, I8_RVE byte B1_8(8) equivalence (I8,B1_8) integer*2 bsho logical unselect if (FIRST) then if (DIAG) then print*,'FIRST = ',FIRST print*,'open BASE.GDR2 for map image...' print*,' DORV = ',DORV endif Qs = 0 if (.not.DORV) then open(99,file=_DBLOC_, . status='unknown', . err=900,recl=25941604,form='UNFORMATTED', . access='DIRECT') read(99,rec=1,iostat=ios) NMAP_B close(99) endif if (DORV) then Qs = 7224631 open(99,file=_DBLOC_, . status='unknown', . err=900,recl=112651580,form='UNFORMATTED', . access='DIRECT') read(99,rec=1,iostat=ios) NMAP_B, B_12L do Q = 1, Qs do B = 1, 8 B1_8(B) = B_12L(B,Q) enddo ID_Q(Q) = I8 do B = 1, 8 B1_8(B) = 0 enddo do B = 1, 4 B1_8(B) = B_12L(B+8,Q) enddo I8_RV = I8/20000 RV_Q(Q) = -1000.0d0 + I8_RV/100.0d0 I8_RVE = I8-I8/20000*20000 eRV_Q(Q) = I8_RVE/1000.0d0 enddo close(99) endif if (DIAG) print*,'done' FIRST = .false. if (DIAG) print*,'FIRST = ',FIRST endif if (DIAG) then print*,' ' print*,'sub_query_GAIA --- ' print*,' RA_CEN: ',RA_CEN print*,' DE_CEN: ',DE_CEN print*,' RAD: ',RAD print*,' ' endif RA_MIN = RA_CEN - RAD/cos(DE_CEN*3.14159/180) RA_MAX = RA_CEN + RAD/cos(DE_CEN*3.14159/180) if (abs(DE_CEN).gt.89) then RA_MIN = 0.00 RA_MAX = 360.00 endif if (RA_MIN.lt.0) then RA_MIN = 0.0 RA_MAX = 360.0 endif if (RA_MAX.gt.360) then RA_MIN = 0.0 RA_MAX = 360.0 endif DE_MIN = DE_CEN - RAD DE_MAX = DE_CEN + RAD if (DIAG) then write(*,*) write(*,'(5x,a12,3f16.7)') '--> RA_CEN: ',RA_CEN write(*,'(5x,a12,3f16.7)') '--> DE_CEN: ',DE_CEN write(*,'(5x,a12,3f16.7)') '--> RAD: ',RAD write(*,*) write(*,'(5x,a12,3f16.7)') '--> RA_MIN: ',RA_MIN,RA_CEN,RA_MAX write(*,'(5x,a12,3f16.7)') '--> DE_MIN: ',DE_MIN,DE_CEN,DE_MAX write(*,*) endif if (DE_MIN.lt.-90.0) DE_MIN = -90.0 if (DE_MAX.gt. 90.0) DE_MAX = 90.0 if (DIAG) print*,'OPEN BASE.DATA...' open(99,file=_DBLOC_, . status='old', . recl=5000, . form='UNFORMATTED', . access='DIRECT') iicen = 1 + (RA_MIN )*10 + 0.5 jjcen = 1 + (DE_MIN+90)*10 + 0.5 iimin = 1 + RA_MIN*10 + 0.5 - 2 iimax = 1 + RA_MAX*10 + 0.5 + 2 jjmin = 1 + (DE_MIN+90)*10 + 0.5 - 2 jjmax = 1 + (DE_MAX+90)*10 + 0.5 + 2 if (iimin.lt.0001) iimin = 0001 if (iimax.gt.3601) iimax = 3601 if (jjmin.lt.0001) jjmin = 0001 if (jjmax.gt.1801) jjmax = 1801 if (DIAG) then write(*,*) write(*,*) write(*,113) 'iminmax: ',iimin,iicen,iimax, . (iimin-1)*0.1, . (iicen-1)*0.1, . (iimax-1)*0.1 write(*,113) 'jminmax: ',jjmin,jjcen,jjmax, . (jjmin-1)*0.1-90, . (jjcen-1)*0.1-90, . (jjmax-1)*0.1-90 113 format(1x,a10,1x,3i4,1x,3f15.7) write(*,*) do jj = jjmin, jjmax write(35,*) write(*,*) do ii = iimin, iimax+1 write(*,114) ii,jj,nmap_ij(ii,jj), . nmap_ij(ii,jj)-nmap_ij(iicen,jjcen) if (DIAG) write(35,114) ii,jj,nmap_ij(ii,jj), . nmap_ij(ii,jj)-nmap_ij(iicen,jjcen) 114 format(20x,i4,1x,i4,1x,2i8) enddo enddo print*,' ' endif Ls = 0 Os = 0 do j = jjmin, jjmax r1 = abs(NMAP_IJ(iimin ,j)) r2 = abs(NMAP_IJ(iimax+1,j)) if (DIAG) write( *,'(6i8)') j,iimin,iimax+1,r1,r2,r2-r1 if (DIAG) write(36,'(6i8)') j,iimin,iimax+1,r1,r2,r2-r1 if (r2.lt.r1) stop 'r2.lt.r1 problem' do r = r1, r2 read(99,rec=r+22532,iostat=ios) buff5000 if (DIAG) write(37,'(20x,i5,1x,i8,1x,i8)') j, r, Ls do q = 1, 100 call bytearr2gaiaX(buff50_100(1,q), . RA,DE,eRA,eDE, . GMAG,eGMAG,BMAG,eBMAG,RMAG,eRMAG, . muRA,emuRA,muDE,emuDE,PI,ePI, . LAB_I8, . NVIS, NMAT, IGOF, IXSN, . NBAD, NGUD, UFLG, GFLG, RFLG) Ls = Ls + 1 dra = rd2x(RA,DE,RA_CEN,DE_CEN) dde = rd2y(RA,DE,RA_CEN,DE_CEN) ddd = sqrt(dra**2+dde**2) if (DIAG) write(38,138) . j,r,dra*60*60,dde*60*60,ddd*60*60, . LAB_I8 138 format(1x,i4,1x,i9,1x,f9.2,1x,f9.2,1x,f9.2,1x,i20) if (ddd.lt.RAD) then Os = Os + 1 if (Os.le._NMAX_) then ra_o(Os) = RA de_o(Os) = DE er_o(Os) = eRA ed_o(Os) = eDE mg_o(Os) = GMAG emg_o(Os) = eGMAG mb_o(Os) = BMAG emb_o(Os) = eBMAG mr_o(Os) = RMAG emr_o(Os) = eRMAG mura_o(Os) = muRA emura_o(Os) = emuRA mude_o(Os) = muDE emude_o(Os) = emuDE pi_o(Os) = PI epi_o(Os) = ePI id_o(Os) = LAB_I8 n_o(Os) = q + (r-1)*100 nvis_o(Os) = NVIS nmat_o(Os) = NMAT igof_o(Os) = IGOF ixsn_o(Os) = IXSN nbad_o(Os) = NBAD ngud_o(Os) = NGUD uflg_o(Os) = UFLG gflg_o(Os) = GFLG rflg_o(Os) = RFLG rv_o(Os) = 0. erv_o(Os) = 0. if (DORV.and.rflg_o(Os).eq.1) then call find_rv(id_o(Os),rv_o(Os),erv_o(Os), . ID_Q,RV_Q,eRV_Q,Qs) endif if (unselect(RA,DE,eRA,eDE, . GMAG,eGMAG,BMAG,eBMAG,RMAG,eRMAG, . muRA,emuRA,muDE,emuDE,PI,ePI, . NVIS, NMAT, IGOF, IXSN, . NBAD, NGUD, UFLG, GFLG, RFLG, . RV, eRV)) Os = Os-1 endif endif enddo enddo enddo if (DIAG) print*,'TOTAL READ Ls: ',Ls if (DIAG) print*,'TOTAL INCL Os: ',Os close(99) return 900 continue print*,' ' print*,'BASE.GATA file open error ' print*,' ' stop end c------------------------------------------------------------ c c this routine accesses the database *and* outputs the data c subroutine sub_query_GAIA_DR2_BOXOUT(RA1,RA2,DE1,DE2) implicit none real*8 RA1, RA2 real*8 DE1, DE2 integer Os real*8 rd2x, rd2y real dra, dde, ddd c--------------------------------------- c integer i0 character*80 stringg character*80 STRING integer nstar real*8 RA ! RA in degrees real*8 DE ! De in degrees real*8 eRA ! error in RA (deg) real*8 eDE ! error in DE (deg) real*8 GMAG ! GMAG (in mag) real*8 eGMAG ! error in GMAG real*8 BMAG ! BMAG real*8 eBMAG ! error in BMAG real*8 RMAG ! RMAG real*8 eRMAG ! error in RMAG real*8 muRA ! pmRA (in arcsec/year) real*8 emuRA ! error in pmRA real*8 muDE ! pmDE real*8 emuDE ! error in pmDE real*8 PI ! parallax real*8 ePI ! error in parralax integer*8 LAB_I8 ! GAIA label integer*8 NVIS ! number of visibilities integer*8 NMAT ! real*8 IGOF ! real*8 IXSN ! integer*8 NBAD ! number of bad measts integer*8 NGUD ! number of good measts integer*8 UFLG ! use flag integer*8 GFLG ! good flag integer*8 RFLG ! is there a RV? real*8 RV ! rv real*8 ERV ! rv error c----------------------------------- c c read in one record at a time; this c contains the current 277-star record c byte buff50_100(50,100) byte buff5000(5000) equivalence(buff5000,buff50_100) byte locrec_b(50) integer N c------------------------------------- c c this map tells you what the first record c is for any point in the sky c integer*4 NMAP_IJ(3601,1801) byte NMAP_B(25941604) equivalence(NMAP_IJ,NMAP_B) common /NMAP_IJ_/NMAP_IJ byte B_12L(12,7224631) integer*8 ID_Q(7224631) real*4 RV_Q(7224631) real*4 eRV_Q(7224631) integer Qs common /RV_Q_/ID_Q, RV_Q, eRV_Q, Qs logical DIAG data DIAG / .false. / c--------------------------------------------------------------- integer IIMINu,IIMAXu integer IIMIN, IIMAX, IICEN integer JJMIN, JJMAX, JJCEN integer i, j real*8 rminij, rmaxij real*8 dminij, dmaxij integer Ls real*8 RA_MIN, RA_MAX real*8 DE_MIN, DE_MAX integer ios integer ii, jj integer n1, n2 integer r1, r2, r integer Q, B integer*8 I8, I8_RV, I8_RVE byte B1_8(8) equivalence (I8,B1_8) logical unselect RA_MIN = RA1 RA_MAX = RA2 DE_MIN = DE1 DE_MAX = DE2 Qs = 7224631 open(99,file=_DBLOC_, . status='unknown', . err=900,recl=112651580,form='UNFORMATTED', . access='DIRECT') read(99,rec=1,iostat=ios) NMAP_B, B_12L do Q = 1, Qs do B = 1, 8 B1_8(B) = B_12L(B,Q) enddo ID_Q(Q) = I8 do B = 1, 8 B1_8(B) = 0 enddo do B = 1, 4 B1_8(B) = B_12L(B+8,Q) enddo I8_RV = I8/20000 RV_Q(Q) = -1000.0d0 + I8_RV/100.0d0 I8_RVE = I8-I8/20000*20000 eRV_Q(Q) = I8_RVE/1000.0d0 enddo close(99) open(99,file=_DBLOC_, . status='old', . recl=5000, . form='UNFORMATTED', . access='DIRECT') iimin = 1 + RA_MIN*10 + 0.5 - 2 iimax = 1 + RA_MAX*10 + 0.5 + 2 jjmin = 1 + (DE_MIN+90)*10 + 0.5 - 2 jjmax = 1 + (DE_MAX+90)*10 + 0.5 + 2 if (iimin.lt.0001) iimin = 0001 if (iimax.gt.3600) iimax = 3600 if (jjmin.lt.0001) jjmin = 0001 if (jjmax.gt.1801) jjmax = 1801 Ls = 0 Os = 0 do j = jjmin, jjmax r1 = NMAP_IJ(iimin ,j) r2 = NMAP_IJ(iimax+1,j) do r = r1, r2 read(99,rec=r+22532,iostat=ios) buff5000 do q = 1, 100 call bytearr2gaiaX(buff50_100(1,q), . RA,DE,eRA,eDE, . GMAG,eGMAG,BMAG,eBMAG,RMAG,eRMAG, . muRA,emuRA,muDE,emuDE,PI,ePI, . LAB_I8, . NVIS, NMAT, IGOF, IXSN, . NBAD, NGUD, UFLG, GFLG, RFLG) Ls = Ls + 1 if (RA.gt.RA1.and.RA.le.RA2.and. . DE.ge.DE1.and.DE.le.DE2) then Os = Os + 1 RV = 0. eRV = 0. if (RFLG.eq.1) call find_rv(LAB_I8,RV,eRV, . ID_Q,RV_Q,eRV_Q,Qs) if (unselect(RA,DE,eRA,eDE, . GMAG,eGMAG,BMAG,eBMAG,RMAG,eRMAG, . muRA,emuRA,muDE,emuDE,PI,ePI, . NVIS, NMAT, IGOF, IXSN, . NBAD, NGUD, UFLG, GFLG, RFLG, . RV, eRV)) goto 110 write(*,119) RA, DE, eRA/1000., eDE/1000., . GMAG, eGMAG/1000., . BMAG, eBMAG/1000., . RMAG, eRMAG/1000., . muRA, emuRA, . muDE, emuDE, . PI, ePI, . LAB_I8, . NVIS, NMAT, IGOF, IXSN, . NBAD, NGUD, UFLG, GFLG, RFLG, . RV, eRV, Os 119 format(f14.10,1x,f14.10,1x, . f7.3,1x,f7.3,1x, . f6.3,1x,f5.3,1x, . f6.3,1x,f5.3,1x, . f6.3,1x,f5.3,1x, . f8.3,1x,f5.3,1x, . f8.3,1x,f5.3,1x, . f8.3,1x,f5.3,1x, . i20,1x, . i3,1x,i3,1x, . f6.3,1x, . f6.3,1x, . i4,1x,i4,1x, . 3i2,1x, . f8.3,1x,f6.3,1x,i8) 110 continue endif enddo enddo enddo if (DIAG) print*,'TOTAL READ Ls: ',Ls if (DIAG) print*,'TOTAL INCL Os: ',Os close(99) return 900 continue print*,' ' print*,'BASE.GATA file open error ' print*,' ' stop end c----------------------------------------------------- c this accesses the database *and* outputs the data c subroutine sub_query_GAIA_DR2_DUMP implicit none integer Os real*8 rd2x, rd2y real dra, dde, ddd c--------------------------------------- c integer i0 character*80 stringg character*80 STRING integer nstar real*8 RA ! RA in degrees real*8 DE ! De in degrees real*8 eRA ! error in RA (deg) real*8 eDE ! error in DE (deg) real*8 GMAG ! GMAG (in mag) real*8 eGMAG ! error in GMAG real*8 BMAG ! BMAG real*8 eBMAG ! error in BMAG real*8 RMAG ! RMAG real*8 eRMAG ! error in RMAG real*8 muRA ! pmRA (in arcsec/year) real*8 emuRA ! error in pmRA real*8 muDE ! pmDE real*8 emuDE ! error in pmDE real*8 PI ! parallax real*8 ePI ! error in parralax integer*8 LAB_I8 ! GAIA label integer*8 NVIS ! number of visibilities integer*8 NMAT ! real*8 IGOF ! real*8 IXSN ! integer*8 NBAD ! number of bad measts integer*8 NGUD ! number of good measts integer*8 UFLG ! use flag integer*8 GFLG ! good flag integer*8 RFLG ! is there a RV? real*8 RV ! rv real*8 ERV ! rv error c----------------------------------- c c read in one record at a time; this c contains the current 277-star record c byte buff50_100(50,100) byte buff5000(5000) equivalence(buff5000,buff50_100) byte locrec_b(50) integer N c------------------------------------- c c this map tells you what the first record c is for any point in the sky c integer*4 NMAP_IJ(3601,1801) byte NMAP_B(25941604) equivalence(NMAP_IJ,NMAP_B) common /NMAP_IJ_/NMAP_IJ byte B_12L(12,7224631) integer*8 ID_Q(7224631) real*4 RV_Q(7224631) real*4 eRV_Q(7224631) integer Qs common /RV_Q_/ID_Q, RV_Q, eRV_Q, Qs logical DIAG data DIAG / .false. / c--------------------------------------------------------------- c integer i, j integer ios integer r integer Q, B integer*8 I8, I8_RV, I8_RVE byte B1_8(8) equivalence (I8,B1_8) logical unselect Qs = 7224631 open(99,file=_DBLOC_, . status='unknown', . err=900,recl=112651580,form='UNFORMATTED', . access='DIRECT') read(99,rec=1,iostat=ios) NMAP_B, B_12L do Q = 1, Qs do B = 1, 8 B1_8(B) = B_12L(B,Q) enddo ID_Q(Q) = I8 do B = 1, 8 B1_8(B) = 0 enddo do B = 1, 4 B1_8(B) = B_12L(B+8,Q) enddo I8_RV = I8/20000 RV_Q(Q) = -1000.0d0 + I8_RV/100.0d0 I8_RVE = I8-I8/20000*20000 eRV_Q(Q) = I8_RVE/1000.0d0 enddo close(99) open(99,file=_DBLOC_, . status='old', . recl=5000, . form='UNFORMATTED', . access='DIRECT') c print*,'r: ',NMAP_IJ(3601,1801) Os = 0 do r = 1, NMAP_IJ(3601,1801) read(99,rec=r+22532,iostat=ios) buff5000 do q = 1, 100 call bytearr2gaiaX(buff50_100(1,q), . RA,DE,eRA,eDE, . GMAG,eGMAG,BMAG,eBMAG,RMAG,eRMAG, . muRA,emuRA,muDE,emuDE,PI,ePI, . LAB_I8, . NVIS, NMAT, IGOF, IXSN, . NBAD, NGUD, UFLG, GFLG, RFLG) if (DE.lt.-89.9999) goto 777 RV = 0. eRV = 0. if (RFLG.eq.1) then call find_rv(LAB_I8,RV,eRV,ID_Q,RV_Q,eRV_Q,Qs) endif c------------------------ c c SELECT STARS TO DUMP c if (.not.unselect(RA,DE,eRA,eDE, . GMAG,eGMAG,BMAG,eBMAG,RMAG,eRMAG, . muRA,emuRA,muDE,emuDE,PI,ePI, . NVIS, NMAT, IGOF, IXSN, . NBAD, NGUD, UFLG, GFLG, RFLG, . RV, eRV)) then Os = Os + 1 write(*,919) RA, DE, eRA/1000., eDE/1000., . GMAG, eGMAG/1000., . BMAG, eBMAG/1000., . RMAG, eRMAG/1000., . muRA, emuRA, . muDE, emuDE, . PI, ePI, . LAB_I8, . NVIS, NMAT, IGOF, IXSN, . NBAD, NGUD, UFLG, GFLG, RFLG, . RV, eRV, Os, r, q 919 format(f14.10,1x,f14.10,1x, . f7.3,1x,f7.3,1x, . f6.3,1x,f5.3,1x, . f6.3,1x,f5.3,1x, . f6.3,1x,f5.3,1x, . f8.3,1x,f5.3,1x, . f8.3,1x,f5.3,1x, . f8.3,1x,f5.3,1x, . i20,1x, . i3,1x,i3,1x, . f6.3,1x, . f6.3,1x, . i4,1x,i4,1x, . 3i2,1x, . f8.3,1x,f6.3,1x, . i8,1x,i8,1x,i8,1x,i8) endif enddo!q enddo!r 777 continue print*,'DE: ',DE,r stop 'end of data base...' 999 continue close(99) return 900 continue print*,' ' print*,'BASE.GATA file open error ' print*,' ' stop end c-------------------------------------------------------- c c sub_query_gaia.F - c c this is a FORTRAN subroutine that queries the GAIA catalog c and returns a record number c c-------------------------------------------------------- subroutine sub_query_GAIA_DR2_R(RECNO, . ra_o, de_o, er_o, ed_o, . mg_o, emg_o, . mb_o, emb_o, . mr_o, emr_o, . mura_o, emura_o, . mude_o, emude_o, . pi_o, epi_o, . id_o, . nvis_o, nmat_o, . igof_o, ixsn_o, . nbad_o, ngud_o, . uflg_o, gflg_o, rflg_o, . rv_o, erv_o, . Os,DIAG,DORV) implicit none integer*4 RECNO real*8 RA_CEN real*8 DE_CEN real*4 RAD real*8 ra_o(_NMAX_) real*8 de_o(_NMAX_) real*8 er_o(_NMAX_) real*8 ed_o(_NMAX_) real*8 mg_o(_NMAX_) real*8 emg_o(_NMAX_) real*8 mb_o(_NMAX_) real*8 emb_o(_NMAX_) real*8 mr_o(_NMAX_) real*8 emr_o(_NMAX_) real*8 mura_o(_NMAX_) real*8 emura_o(_NMAX_) real*8 mude_o(_NMAX_) real*8 emude_o(_NMAX_) real*8 pi_o(_NMAX_) real*8 epi_o(_NMAX_) integer*8 id_o(_NMAX_) integer*8 nvis_o(_NMAX_) integer*8 nmat_o(_NMAX_) real*8 igof_o(_NMAX_) real*8 ixsn_o(_NMAX_) integer*8 nbad_o(_NMAX_) integer*8 ngud_o(_NMAX_) integer*8 uflg_o(_NMAX_) integer*8 gflg_o(_NMAX_) integer*8 rflg_o(_NMAX_) real*8 rv_o(_NMAX_) real*8 erv_o(_NMAX_) integer Os logical DIAG logical DORV integer n_o(_NMAX_) real dr_o(_NMAX_) real dd_o(_NMAX_) real*8 rd2x, rd2y real dra, dde, ddd c--------------------------------------- c integer i0 character*80 stringg character*80 STRING integer nstar real*8 RA ! RA in degrees real*8 DE ! De in degrees real*8 eRA ! error in RA (deg) real*8 eDE ! error in DE (deg) real*8 GMAG ! GMAG (in mag) real*8 eGMAG ! error in GMAG real*8 BMAG ! BMAG real*8 eBMAG ! error in BMAG real*8 RMAG ! RMAG real*8 eRMAG ! error in RMAG real*8 muRA ! pmRA (in arcsec/year) real*8 emuRA ! error in pmRA real*8 muDE ! pmDE real*8 emuDE ! error in pmDE real*8 PI ! parallax real*8 ePI ! error in parralax integer*8 LAB_I8 ! GAIA label integer*8 NVIS ! number of visibilities integer*8 NMAT ! real*8 IGOF ! real*8 IXSN ! integer*8 NBAD ! number of bad measts integer*8 NGUD ! number of good measts integer*8 UFLG ! use flag integer*8 GFLG ! good flag integer*8 RFLG ! is there a RV? real*8 RV ! rv real*8 ERV ! rv error c----------------------------------- c c read in one record at a time; this c contains the current 277-star record c byte buff50_100(50,100) byte buff5000(5000) equivalence(buff5000,buff50_100) byte locrec_b(50) integer N c------------------------------------- c c this map tells you what the first record c is for any point in the sky c integer*4 NMAP_IJ(3601,1801) byte NMAP_B(25941604) equivalence(NMAP_IJ,NMAP_B) common /NMAP_IJ_/NMAP_IJ byte B_12L(12,7224631) integer*8 ID_Q(7224631) real*4 RV_Q(7224631) real*4 eRV_Q(7224631) integer Qs common /RV_Q_/ID_Q, RV_Q, eRV_Q, Qs logical FIRST data FIRST / .true. / common /FIRST_/FIRST c--------------------------------------------------------------- integer Ls integer Q integer B integer ios integer ii, jj integer n1, n2 integer r1, r2, r integer*8 I8, I8_RV, I8_RVE byte B1_8(8) equivalence (I8,B1_8) integer*2 bsho if (FIRST) then if (DIAG) then print*,'FIRST = ',FIRST print*,'open BASE.GDR2 for map image...' print*,' DORV = ',DORV endif Qs = 0 if (.not.DORV) then open(99,file=_DBLOC_, . status='unknown', . err=900,recl=25941604,form='UNFORMATTED', . access='DIRECT') read(99,rec=1,iostat=ios) NMAP_B close(99) endif if (DORV) then Qs = 7224631 open(99,file=_DBLOC_, . status='unknown', . err=900,recl=112651580,form='UNFORMATTED', . access='DIRECT') read(99,rec=1,iostat=ios) NMAP_B, B_12L do Q = 1, Qs do B = 1, 8 B1_8(B) = B_12L(B,Q) enddo ID_Q(Q) = I8 do B = 1, 8 B1_8(B) = 0 enddo do B = 1, 4 B1_8(B) = B_12L(B+8,Q) enddo I8_RV = I8/20000 RV_Q(Q) = -1000.0d0 + I8_RV/100.0d0 I8_RVE = I8-I8/20000*20000 eRV_Q(Q) = I8_RVE/1000.0d0 enddo close(99) endif if (DIAG) print*,'done' FIRST = .false. if (DIAG) print*,'FIRST = ',FIRST open(99,file=_DBLOC_, . status='old', . recl=5000, . form='UNFORMATTED', . access='DIRECT') endif read(99,rec=RECNO+22532,iostat=ios) buff5000 do q = 1, 100 call bytearr2gaiaX(buff50_100(1,q), . RA,DE,eRA,eDE, . GMAG,eGMAG,BMAG,eBMAG,RMAG,eRMAG, . muRA,emuRA,muDE,emuDE,PI,ePI, . LAB_I8, . NVIS, NMAT, IGOF, IXSN, . NBAD, NGUD, UFLG, GFLG, RFLG) Os = q ra_o(Os) = RA de_o(Os) = DE er_o(Os) = eRA ed_o(Os) = eDE mg_o(Os) = GMAG emg_o(Os) = eGMAG mb_o(Os) = BMAG emb_o(Os) = eBMAG mr_o(Os) = RMAG emr_o(Os) = eRMAG mura_o(Os) = muRA emura_o(Os) = emuRA mude_o(Os) = muDE emude_o(Os) = emuDE pi_o(Os) = PI epi_o(Os) = ePI id_o(Os) = LAB_I8 n_o(Os) = q + (r-1)*100 nvis_o(Os) = NVIS nmat_o(Os) = NMAT igof_o(Os) = IGOF ixsn_o(Os) = IXSN nbad_o(Os) = NBAD ngud_o(Os) = NGUD uflg_o(Os) = UFLG gflg_o(Os) = GFLG rflg_o(Os) = RFLG rv_o(Os) = 0. erv_o(Os) = 0. if (DORV.and.rflg_o(Os).eq.1) then call find_rv(id_o(Os),rv_o(Os),erv_o(Os), . ID_Q,RV_Q,eRV_Q,Qs) endif enddo!q return 900 continue print*,' ' print*,'BASE.GATA file open error ' print*,' ' stop end subroutine bmin2rdeem(bmin,ra,de,rae,dee,mg,i8_5) implicit none byte bmin(16) real*8 ra, de real*8 rae,dee real*8 mg integer*8 i8_5(5) integer*8 i8_n(5) byte ball(40) integer uball(40) equivalence(ball,i8_n) integer i do i = 1, 40 ball(i) = 0 enddo ball(01) = bmin(01) ball(02) = bmin(02) ball(03) = bmin(03) ball(04) = bmin(04) ball(05) = bmin(05) ball(09) = bmin(06) ball(10) = bmin(07) ball(11) = bmin(08) ball(12) = bmin(09) ball(13) = bmin(10) ball(17) = bmin(11) ball(18) = bmin(12) ball(25) = bmin(13) ball(26) = bmin(14) ball(33) = bmin(15) ball(34) = bmin(16) ra = i8_n(01)/60.d0/60.d0/1000.d0/0848.d0 de = i8_n(02)/60.d0/60.d0/1000.d0/1000.d0 - 90.0d0 rae = i8_n(03)/1000.0 dee = i8_n(04)/1000.0 mg = i8_n(05)/2000.0 i8_5(1) = i8_n(1) i8_5(2) = i8_n(2) i8_5(3) = i8_n(3) i8_5(4) = i8_n(4) i8_5(5) = i8_n(5) return end c---------------------------------------------------------- c subroutine bbbbbbbb_to_b1(b1,ba,bb,bc,bd,be,bf,bg,bh) implicit none byte b1 byte ba,bb,bc,bd byte be,bf,bg,bh integer b1u byte bax,bbx,bcx,bdx byte bex,bfx,bgx,bhx b1u = 0 b1u = b1u . + bh . + bg*002 . + bf*004 . + be*008 . + bd*016 . + bc*032 . + bb*064 . + ba*128 b1 = b1u call b1_to_bbbbbbbb(b1,bax,bbx,bcx,bdx,bex,bfx,bgx,bhx) if (ba.ne.bax.or. . bb.ne.bbx.or. . bc.ne.bcx.or. . bd.ne.bdx.or. . be.ne.bex.or. . bf.ne.bfx.or. . bg.ne.bgx.or. . bh.ne.bhx) then print*,'b1 : ',b1 print*,'b1u: ',b1u print*,' a: ',ba,bax print*,' b: ',bb,bbx print*,' c: ',bc,bcx print*,' d: ',bd,bdx print*,' e: ',be,bex print*,' f: ',bf,bfx print*,' g: ',bg,bgx print*,' h: ',bh,bhx stop endif return end c---------------------------------------------------------- c subroutine b1_to_bbbbbbbb(b1,ba,bb,bc,bd,be,bf,bg,bh) implicit none byte b1 byte ba,bb,bc,bd byte be,bf,bg,bh integer*2 b1u b1u = b1 if (b1u.lt.0) b1u = b1u + 256 ba = (b1u-b1u/2**08*2**08)/2**07 bb = (b1u-b1u/2**07*2**07)/2**06 bc = (b1u-b1u/2**06*2**06)/2**05 bd = (b1u-b1u/2**05*2**05)/2**04 be = (b1u-b1u/2**04*2**04)/2**03 bf = (b1u-b1u/2**03*2**03)/2**02 bg = (b1u-b1u/2**02*2**02)/2**01 bh = (b1u-b1u/2**01*2**01)/2**00 return end c----------------------------------------------- c c This routine will take an (ra,dec) and a c tangent-point (ra0,dec0) and will compute c the y coordinate in the tangent plane. The c tangent-plane y-axis is directed along +DEC. c The units for y will be degrees, just lilke c those for RA and DEC. c real*8 function rd2y(r,d,r0,d0) implicit none real*8 r, d real*8 r0,d0 real*8 cosra, sinra real*8 cosde, sinde real*8 cosd0, sind0 real*8 rrrr real*8 yrad real x, y, z real xx,yy,zz cosra = cos((r-r0)*3.141592654d0/180.0d0) sinra = sin((r-r0)*3.141592654d0/180.0d0) cosde = cos(d *3.141592654d0/180.0d0) sinde = sin(d *3.141592654d0/180.0d0) cosd0 = cos(d0*3.141592654d0/180.0d0) sind0 = sin(d0*3.141592654d0/180.0d0) rrrr = sind0*sinde + cosd0*cosde*cosra yrad = (cosd0*sinde-sind0*cosde*cosra)/rrrr rd2y = yrad*180.0d0/3.141592654d0 x = cosde*cos(r *3.14159/180) y = cosde*sin(r *3.14159/180) z = sinde xx = cosd0*cos(r0*3.14159/180) yy = cosd0*sin(r0*3.14159/180) zz = sind0 if (x*xx + y*yy + z*zz.lt.0) rd2y = 90 return end c----------------------------------------------- c c This routine will take an (ra,dec) and a c tangent-point (ra0,dec0) and will compute c the x coordinate in the tangent plane. The c tangent-plane x-axis is directed along -RA. c The units for x will be degrees, just lilke c those for RA and DEC. c real*8 function rd2x(r,d,r0,d0) implicit none real*8 r, d real*8 r0,d0 real*8 cosra, sinra real*8 cosde, sinde real*8 cosd0, sind0 real*8 rrrr real*8 xrad real x, y, z real xx,yy,zz cosra = cos((r-r0)*3.141592654d0/180.0d0) sinra = sin((r-r0)*3.141592654d0/180.0d0) cosde = cos(d *3.141592654d0/180.0d0) sinde = sin(d *3.141592654d0/180.0d0) cosd0 = cos(d0*3.141592654d0/180.0d0) sind0 = sin(d0*3.141592654d0/180.0d0) rrrr = sind0*sinde + cosd0*cosde*cosra xrad = cosde*sinra/rrrr rd2x = xrad*180.0d0/3.141592654d0 x = cosde*cos(r *3.14159/180) y = cosde*sin(r *3.14159/180) z = sinde xx = cosd0*cos(r0*3.14159/180) yy = cosd0*sin(r0*3.14159/180) zz = sind0 if (x*xx + y*yy + z*zz.lt.0) rd2x = 90 return end c-------------------------------------------------------------------- c c byte function use(r,d,mj,mh,mk, . rcen,dcen,jcen,hcen,kcen, . drmin,drmax, . djmin,djmax,dhmin,dhmax,dkmin,dkmax, . dxmax,dymax, . rmin,rmax,dmin,dmax, . ebmin,ebmax,elmin,elmax, . gbmin,gbmax,glmin,glmax, . jmin,jmax,hmin,hmax,kmin,kmax) implicit none real*8 r,d real mj,mh,mk real*8 rcen, dcen real jcen, hcen, kcen real drmin, drmax real djmin, djmax, dhmin, dhmax, dkmin, dkmax real dxmax, dymax real*8 rmin, rmax, dmin, dmax real*8 ebmin, ebmax, elmin, elmax real*8 gbmin, gbmax, glmin, glmax real jmin, jmax real hmin, hmax real kmin, kmax real*8 gl, gb real*8 el, eb real*8 rd2x, rd2y real*8 dx, dy, dd if (rmin.gt.0) then use = -1 if (r.lt.rmin) return use = -2 if (r.gt.rmax) return use = -3 if (d.lt.dmin) return use = -4 if (d.gt.dmax) return endif if (jmin.gt.-9.99) then use = -13 if (mj.lt.jmin) return use = -14 if (mj.gt.jmax) return endif if (hmin.gt.-9.99) then use = -15 if (mh.lt.hmin) return use = -16 if (mh.gt.hmax) return endif if (kmin.gt.-9.99) then use = -17 if (mk.lt.kmin) return use = -18 if (mk.gt.kmax) return endif if (rcen.ge.0.00) then dx = rd2x(r,d,rcen,dcen) dy = rd2y(r,d,rcen,dcen) dd = sqrt(dx**2+dy**2) use = -19 if (dd.lt.drmin) return use = -20 if (dd.gt.drmax) return use = -21 if (mj-jcen.gt.djmax) return use = -22 if (mj-jcen.lt.djmin) return use = -23 if (mh-hcen.gt.dhmax) return use = -24 if (mh-hcen.lt.dhmin) return use = -25 if (mk-kcen.gt.dkmax) return use = -26 if (mk-kcen.lt.dkmin) return use = -27 if (abs(dx).gt.dxmax) return use = -28 if (abs(dy).gt.dymax) return endif use = 1 return end c--------------------------------------------------- c integer function ubyte(b) implicit none byte b ubyte = b if (ubyte.lt.0) ubyte = ubyte + 256 return end c---------------------------------------------- c subroutine i4_to_b32(i4,b32) implicit none integer*4 i4 byte b32(32) integer*4 i4u i4u = i4 b32(01) = 0 if (i4u.lt.0) then b32(01) = 0 i4u = -i4u endif b32(02) = i4u/2**30 b32(03) = (i4u-i4u/2**30*2**30)/2**29 b32(04) = (i4u-i4u/2**29*2**29)/2**28 b32(05) = (i4u-i4u/2**28*2**28)/2**27 b32(06) = (i4u-i4u/2**27*2**27)/2**26 b32(07) = (i4u-i4u/2**26*2**26)/2**25 b32(08) = (i4u-i4u/2**25*2**25)/2**24 b32(09) = (i4u-i4u/2**24*2**24)/2**23 b32(10) = (i4u-i4u/2**23*2**23)/2**22 b32(11) = (i4u-i4u/2**22*2**22)/2**21 b32(12) = (i4u-i4u/2**21*2**21)/2**20 b32(13) = (i4u-i4u/2**20*2**20)/2**19 b32(14) = (i4u-i4u/2**19*2**19)/2**18 b32(15) = (i4u-i4u/2**18*2**18)/2**17 b32(16) = (i4u-i4u/2**17*2**17)/2**16 b32(17) = (i4u-i4u/2**16*2**16)/2**15 b32(18) = (i4u-i4u/2**15*2**15)/2**14 b32(19) = (i4u-i4u/2**14*2**14)/2**13 b32(20) = (i4u-i4u/2**13*2**13)/2**12 b32(21) = (i4u-i4u/2**12*2**12)/2**11 b32(22) = (i4u-i4u/2**11*2**11)/2**10 b32(23) = (i4u-i4u/2**10*2**10)/2**09 b32(24) = (i4u-i4u/2**09*2**09)/2**08 b32(25) = (i4u-i4u/2**08*2**08)/2**07 b32(26) = (i4u-i4u/2**07*2**07)/2**06 b32(27) = (i4u-i4u/2**06*2**06)/2**05 b32(28) = (i4u-i4u/2**05*2**05)/2**04 b32(29) = (i4u-i4u/2**04*2**04)/2**03 b32(30) = (i4u-i4u/2**03*2**03)/2**02 b32(31) = (i4u-i4u/2**02*2**02)/2**01 b32(32) = (i4u-i4u/2*2) return end c---------------------------------------------- c subroutine i2_to_b16(i2,b16) implicit none integer*2 i2 byte b16(16) integer*2 i2u integer b i2u = i2 b16(01) = 0 if (i2u.lt.0) then b16(01) = 1 i2u = -i2u endif b16(02) = (i2u-i2u/2**15*2**15)/2**14 b16(03) = (i2u-i2u/2**14*2**14)/2**13 b16(04) = (i2u-i2u/2**13*2**13)/2**12 b16(05) = (i2u-i2u/2**12*2**12)/2**11 b16(06) = (i2u-i2u/2**11*2**11)/2**10 b16(07) = (i2u-i2u/2**10*2**10)/2**09 b16(08) = (i2u-i2u/2**09*2**09)/2**08 b16(09) = (i2u-i2u/2**08*2**08)/2**07 b16(10) = (i2u-i2u/2**07*2**07)/2**06 b16(11) = (i2u-i2u/2**06*2**06)/2**05 b16(12) = (i2u-i2u/2**05*2**05)/2**04 b16(13) = (i2u-i2u/2**04*2**04)/2**03 b16(14) = (i2u-i2u/2**03*2**03)/2**02 b16(15) = (i2u-i2u/2**02*2**02)/2**01 b16(16) = (i2u-i2u/2*2) return end c---------------------------------------------- c subroutine b1_to_b8(b1,b8) implicit none byte b1 byte b8(8) integer b1u b1u = b1 if (b1u.lt.0) b1u = b1u + 256 b8(01) = (b1u-b1u/2**08*2**08)/2**07 b8(02) = (b1u-b1u/2**07*2**07)/2**06 b8(03) = (b1u-b1u/2**06*2**06)/2**05 b8(04) = (b1u-b1u/2**05*2**05)/2**04 b8(05) = (b1u-b1u/2**04*2**04)/2**03 b8(06) = (b1u-b1u/2**03*2**03)/2**02 b8(07) = (b1u-b1u/2**02*2**02)/2**01 b8(08) = (b1u-b1u/2**01*2**01)/2**00 return end c---------------------------------------------- c subroutine b8_to_b1(b8,b1) implicit none byte b8(8) byte b1 b1 = b8(8)*2**0 . + b8(7)*2**1 . + b8(6)*2**2 . + b8(5)*2**3 . + b8(4)*2**4 . + b8(3)*2**5 . + b8(2)*2**6 if (b8(1).eq.1) b1 = -b1 return end c---------------------------------------------- c subroutine b16_to_i2(b16,i2) implicit none byte b16(16) integer*2 i2 i2 = b16(16)*2**00 . + b16(15)*2**01 . + b16(14)*2**02 . + b16(13)*2**03 . + b16(12)*2**04 . + b16(11)*2**05 . + b16(10)*2**06 . + b16(09)*2**07 . + b16(08)*2**08 . + b16(07)*2**09 . + b16(06)*2**10 . + b16(05)*2**11 . + b16(04)*2**12 . + b16(03)*2**13 . + b16(02)*2**14 if (b16(01).eq.1) i2 = -i2 return end c---------------------------------------------- c subroutine b32_to_i4(b32,i4) implicit none byte b32(32) integer*4 i4 i4 = b32(32)*2**00 . + b32(31)*2**01 . + b32(30)*2**02 . + b32(29)*2**03 . + b32(28)*2**04 . + b32(27)*2**05 . + b32(26)*2**06 . + b32(25)*2**07 . + b32(24)*2**08 . + b32(23)*2**09 . + b32(22)*2**10 . + b32(21)*2**11 . + b32(20)*2**12 . + b32(19)*2**13 . + b32(18)*2**14 . + b32(17)*2**15 . + b32(16)*2**16 . + b32(15)*2**17 . + b32(14)*2**18 . + b32(13)*2**19 . + b32(12)*2**20 . + b32(11)*2**21 . + b32(10)*2**22 . + b32(09)*2**23 . + b32(08)*2**24 . + b32(07)*2**25 . + b32(06)*2**26 . + b32(05)*2**27 . + b32(04)*2**28 . + b32(03)*2**29 . + b32(02)*2**30 if (b32(01).eq.1) i4 = -i4 return end c------------------------------------------------------------- c c this routine will take a set of GAIA observables and c will combine it into my 43-byte array c subroutine gaia2bytearr(RA,DE,eRA,eDE, . GMAG,eGMAG,BMAG,eBMAG,RMAG,eRMAG, . muRA,emuRA,muDE,emuDE,PI,ePI, . LAB_I8, . bytearr43) implicit none real*8 RA ! RA in degrees real*8 DE ! De in degrees real*8 eRA ! error in RA (deg) real*8 eDE ! error in DE (deg) real*8 GMAG ! GMAG (in mag) real*8 eGMAG ! error in GMAG real*8 BMAG ! BMAG real*8 eBMAG ! error in BMAG real*8 RMAG ! RMAG real*8 eRMAG ! error in RMAG real*8 muRA ! pmRA (in mas/year) real*8 emuRA ! error in pmRA real*8 muDE ! pmDE (in mas) real*8 emuDE ! error in pmDE real*8 PI ! parallax (in mas) real*8 ePI ! error in parralax integer*8 LAB_I8 ! GAIA label byte bytearr43(43) ! output byte array c---------------------------------- c c local variables c byte BYTE8(8) integer*8 INT8 integer*8 INT8_RA integer*8 INT8_DE integer*8 INT8_eRA integer*8 INT8_eDE integer*8 INT8_GMAG integer*8 INT8_eGMAG integer*8 INT8_BMAG integer*8 INT8_eBMAG integer*8 INT8_RMAG integer*8 INT8_eRMAG integer*8 INT8_muRA integer*8 INT8_emuRA integer*8 INT8_muDE integer*8 INT8_emuDE integer*8 INT8_PI integer*8 INT8_ePI integer b integer*2 bsho equivalence(INT8,BYTE8) real*8 RAu, DEu, eRAu, eDEu real*8 GMAGu, eGMAGu real*8 BMAGu, eBMAGu real*8 RMAGu, eRMAGu real*8 muRAu, emuRAu real*8 muDEu, emuDEu real*8 PIu, ePIu c c copy to temp arrays, so I can do some c clipping (just in case) c RAu = RA DEu = DE eRAu = eRA eDEu = eDE GMAGu = GMAG eGMAGu = eGMAG BMAGu = BMAG eBMAGu = eBMAG RMAGu = RMAG eRMAGu = eRMAG muRAu = muRA emuRAu = emuRA muDEu = muDE emuDEu = emuDE PIu = PI ePIu = ePI if (RAu.lt. 0.0000) RAu = 0.0000 if (RAu.gt.360.0000) RAu = 360.0000 INT8_RA = RAu/360.00d0*1099511627776.0d0 + 0.5 if (DEu.lt.-90.0000) DEu = -90.0000 if (DEu.gt. 90.0000) DEu = 90.0000 INT8_DE = (DEu+90.00d0)/180.00d0*1099511627776.0d0 + 0.5 if (eRAu.lt. 0) eRAu = 0 if (eRAu.gt.65535) eRAu = 65535 INT8_eRA = int(eRAu+0.5) if (eDEu.lt. 0) eDEu = 0 if (eDEu.gt.65535) eDEu = 65535 INT8_eDE = int(eDEu+0.5) if (GMAGu.lt. 0.000) GMAGu = 0.000 if (GMAGu.gt.32.000) GMAGu = 32.000 INT8_GMAG = GMAGu*1000.0 + 0.5 if (eGMAGu.lt. 0.0) eGMAGu = 0.0 if (eGMAGu.gt.255.0) eGMAGu = 255.0 INT8_eGMAG = eGMAGu if (BMAGu.lt. 0.000) BMAGu = 0.000 if (BMAGu.gt.32.000) BMAGu = 32.000 INT8_BMAG = BMAGu*1000.0 + 0.5 if (eBMAGu.lt. 0.0) eBMAGu = 0.0 if (eBMAGu.gt.255.0) eBMAGu = 255.0 INT8_eBMAG = eBMAGu if (RMAGu.lt. 0.000) RMAGu = 0.000 if (RMAGu.gt.32.000) RMAGu = 32.000 INT8_RMAG = RMAGu*1000.0 + 0.5 if (eRMAGu.lt. 0.0) eRMAGu = 0.0 if (eRMAGu.gt.255.0) eRMAGu = 255.0 INT8_eRMAG = eRMAGu if (muRAu.lt.-524.285) muRAu = -524.285 if (muRAu.gt. 524.285) muRAu = 524.285 INT8_muRA = (muRAu+524.285)*1 000 + 0.5 if (emuRAu.lt.0.000) emuRAu = 0.000 if (emuRAu.gt.4.000) emuRAu = 4.000 INT8_emuRA = emuRAu*1000 + 0.5 if (muDEu.lt.-524.285) muDEu = -524.285 if (muDEu.gt. 524.285) muDEu = 524.285 INT8_muDE = (muDEu+524.285)*1 000 + 0.5 if (emuDEu.lt.0.000) emuDEu = 0.000 if (emuDEu.gt.4.000) emuDEu = 4.000 INT8_emuDE = emuDEu*1000 + 0.5 if (PIu.lt.-524.285) PIu = -524.285 if (PIu.gt. 524.285) PIu = 524.285 INT8_PI = (PIu+524.285)*1 000 + 0.5 if (ePIu.lt.0.000) ePIu = 0.000 if (ePIu.gt.4.000) ePIu = 4.000 INT8_ePI = ePIu*1000 + 0.5 c write(*,*) c write(*,'('' RA:'',f18.11,f18.11,i20)') RA, RAu, INT8_RA c write(*,'('' DE:'',f18.11,f18.11,i20)') DE, DEu, INT8_DE c write(*,'('' eRA:'',f18.11,f18.11,i20)') eRA, eRAu, INT8_eRA c write(*,'('' eDE:'',f18.11,f18.11,i20)') eDE, eDEu, INT8_eDE c write(*,*) c write(*,'('' GMAG:'',f18.11,f18.11,i20)') GMAG, GMAGu,INT8_GMAG c write(*,'(''eGMAG:'',f18.11,f18.11,i20)') eGMAG,eGMAGu,INT8_eGMAG c write(*,'('' BMAG:'',f18.11,f18.11,i20)') BMAG, BMAGu,INT8_BMAG c write(*,'(''eBMAG:'',f18.11,f18.11,i20)') eBMAG,eBMAGu,INT8_eBMAG c write(*,'('' RMAG:'',f18.11,f18.11,i20)') RMAG, RMAGu,INT8_RMAG c write(*,'(''eRMAG:'',f18.11,f18.11,i20)') eRMAG,eRMAGu,INT8_eRMAG c write(*,*) c write(*,'('' muRA:'',f18.11,f18.11,i20)') muRA, muRAu,INT8_muRA c write(*,'('' muDE:'',f18.11,f18.11,i20)') muDE, muDEu,INT8_muDE c write(*,'(''emuRA:'',f18.11,f18.11,i20)') emuRA,emuRAu,INT8_emuRA c write(*,'(''emuDE:'',f18.11,f18.11,i20)') emuDE,emuDEu,INT8_emuDE c write(*,*) c write(*,'('' PI:'',f18.11,f18.11,i20)') PI, PIu, INT8_PI c write(*,'('' ePI:'',f18.11,f18.11,i20)') ePI, ePIu, INT8_ePI c write(*,*) INT8 = INT8_RA bytearr43(01) = BYTE8(05) bytearr43(02) = BYTE8(04) bytearr43(03) = BYTE8(03) bytearr43(04) = BYTE8(02) bytearr43(05) = BYTE8(01) INT8 = INT8_DE bytearr43(06) = BYTE8(05) bytearr43(07) = BYTE8(04) bytearr43(08) = BYTE8(03) bytearr43(09) = BYTE8(02) bytearr43(10) = BYTE8(01) INT8 = INT8_eRA bytearr43(11) = BYTE8(02) bytearr43(12) = BYTE8(01) INT8 = INT8_eDE bytearr43(13) = BYTE8(02) bytearr43(14) = BYTE8(01) INT8 = INT8_GMAG bytearr43(15) = BYTE8(02) bytearr43(16) = BYTE8(01) INT8 = INT8_eGMAG bytearr43(17) = BYTE8(01) INT8 = INT8_BMAG bytearr43(18) = BYTE8(02) bytearr43(19) = BYTE8(01) INT8 = INT8_eBMAG bytearr43(20) = BYTE8(01) INT8 = INT8_RMAG bytearr43(21) = BYTE8(02) bytearr43(22) = BYTE8(01) INT8 = INT8_eRMAG bytearr43(23) = BYTE8(01) INT8 = INT8_muRA*4096 + INT8_emuRA bytearr43(24) = BYTE8(04) bytearr43(25) = BYTE8(03) bytearr43(26) = BYTE8(02) bytearr43(27) = BYTE8(01) INT8 = INT8_muDE*4096 + INT8_emuDE bytearr43(28) = BYTE8(04) bytearr43(29) = BYTE8(03) bytearr43(30) = BYTE8(02) bytearr43(31) = BYTE8(01) INT8 = INT8_PI*4096 + INT8_ePI bytearr43(32) = BYTE8(04) bytearr43(33) = BYTE8(03) bytearr43(34) = BYTE8(02) bytearr43(35) = BYTE8(01) INT8 = LAB_I8 bytearr43(36) = BYTE8(08) bytearr43(37) = BYTE8(07) bytearr43(38) = BYTE8(06) bytearr43(39) = BYTE8(05) bytearr43(40) = BYTE8(04) bytearr43(41) = BYTE8(03) bytearr43(42) = BYTE8(02) bytearr43(43) = BYTE8(01) c print*,' ' c print*,'OUTPUT: ' c do b = 01, 43 c write(*,'('' b: '',i2,1x,2i6)') b,bsho(bytearr43(b)), c . bytearr43(b) c if (b.eq.05) print*,' ' c if (b.eq.10) print*,' ' c if (b.eq.12) print*,' ' c if (b.eq.14) print*,' ' c if (b.eq.16) print*,' ' c if (b.eq.17) print*,' ' c if (b.eq.19) print*,' ' c if (b.eq.20) print*,' ' c if (b.eq.22) print*,' ' c if (b.eq.23) print*,' ' c if (b.eq.27) print*,' ' c if (b.eq.31) print*,' ' c if (b.eq.35) print*,' ' c if (b.eq.43) print*,' ' c enddo c print*,' ' return end c------------------------------------------------------------ c c this subroutine will take a byte array and c will explode it into the gaia observables c subroutine bytearr2gaia(bytearr43, . RA,DE,eRA,eDE, . GMAG,eGMAG,BMAG,eBMAG,RMAG,eRMAG, . muRA,emuRA,muDE,emuDE,PI,ePI, . LAB_I8) implicit none ! INPUT byte bytearr43(43) ! byte array ! EXTRACTED real*8 RA ! RA in degrees real*8 DE ! De in degrees real*8 eRA ! error in RA (deg) real*8 eDE ! error in DE (deg) real*8 GMAG ! GMAG (in mag) real*8 eGMAG ! error in GMAG real*8 BMAG ! BMAG real*8 eBMAG ! error in BMAG real*8 RMAG ! RMAG real*8 eRMAG ! error in RMAG real*8 muRA ! pmRA (in arcsec/year) real*8 emuRA ! error in pmRA real*8 muDE ! pmDE real*8 emuDE ! error in pmDE real*8 PI ! parallax real*8 ePI ! error in parralax integer*8 LAB_I8 ! GAIA label c------------------------------------------ c c local variables c byte BYTE8(8) integer*8 INT8 integer*8 INT8_RA integer*8 INT8_DE integer*8 INT8_eRA integer*8 INT8_eDE integer*8 INT8_GMAG integer*8 INT8_eGMAG integer*8 INT8_BMAG integer*8 INT8_eBMAG integer*8 INT8_RMAG integer*8 INT8_eRMAG integer*8 INT8_muRA integer*8 INT8_emuRA integer*8 INT8_muDE integer*8 INT8_emuDE integer*8 INT8_PI integer*8 INT8_ePI integer b integer*2 bsho equivalence(INT8,BYTE8) BYTE8(08) = 0 BYTE8(07) = 0 BYTE8(06) = 0 BYTE8(05) = bytearr43(01) BYTE8(04) = bytearr43(02) BYTE8(03) = bytearr43(03) BYTE8(02) = bytearr43(04) BYTE8(01) = bytearr43(05) INT8_RA = INT8 RA = INT8_RA*360.00d0/1099511627776.0d0 BYTE8(08) = 0 BYTE8(07) = 0 BYTE8(06) = 0 BYTE8(05) = bytearr43(06) BYTE8(04) = bytearr43(07) BYTE8(03) = bytearr43(08) BYTE8(02) = bytearr43(09) BYTE8(01) = bytearr43(10) INT8_DE = INT8 DE = -90.000d0 + INT8_DE*180.00d0/1099511627776.0d0 BYTE8(08) = 0 BYTE8(07) = 0 BYTE8(06) = 0 BYTE8(05) = 0 BYTE8(04) = 0 BYTE8(03) = 0 BYTE8(02) = bytearr43(11) BYTE8(01) = bytearr43(12) INT8_eRA = INT8 eRA = INT8_eRA BYTE8(08) = 0 BYTE8(07) = 0 BYTE8(06) = 0 BYTE8(05) = 0 BYTE8(04) = 0 BYTE8(03) = 0 BYTE8(02) = bytearr43(13) BYTE8(01) = bytearr43(14) INT8_eDE = INT8 eDE = INT8_eDE BYTE8(08) = 0 BYTE8(07) = 0 BYTE8(06) = 0 BYTE8(05) = 0 BYTE8(04) = 0 BYTE8(03) = 0 BYTE8(02) = bytearr43(15) BYTE8(01) = bytearr43(16) INT8_GMAG = INT8 GMAG = INT8_GMAG/1000.0d0 eGMAG = bsho(bytearr43(17)) BYTE8(08) = 0 BYTE8(07) = 0 BYTE8(06) = 0 BYTE8(05) = 0 BYTE8(04) = 0 BYTE8(03) = 0 BYTE8(02) = bytearr43(18) BYTE8(01) = bytearr43(19) INT8_BMAG = INT8 BMAG = INT8_BMAG/1000.0d0 eBMAG = bsho(bytearr43(20)) BYTE8(08) = 0 BYTE8(07) = 0 BYTE8(06) = 0 BYTE8(05) = 0 BYTE8(04) = 0 BYTE8(03) = 0 BYTE8(02) = bytearr43(21) BYTE8(01) = bytearr43(22) INT8_RMAG = INT8 RMAG = INT8_RMAG/1000.0d0 eRMAG = bsho(bytearr43(23)) BYTE8(08) = 0 BYTE8(07) = 0 BYTE8(06) = 0 BYTE8(05) = 0 BYTE8(04) = bytearr43(24) BYTE8(03) = bytearr43(25) BYTE8(02) = bytearr43(26) BYTE8(01) = bytearr43(27) INT8_muRA = INT8/4096 INT8_emuRA = INT8-INT8/4096*4096 muRA = INT8_muRA/1.00d3 - 524.285 emuRA = INT8_emuRA/1000.0d0 BYTE8(08) = 0 BYTE8(07) = 0 BYTE8(06) = 0 BYTE8(05) = 0 BYTE8(04) = bytearr43(28) BYTE8(03) = bytearr43(29) BYTE8(02) = bytearr43(30) BYTE8(01) = bytearr43(31) INT8_muDE = INT8/4096 INT8_emuDE = INT8-INT8/4096*4096 muDE = INT8_muDE/1.00d3 - 524.285 emuDE = INT8_emuDE/1000.0d0 BYTE8(08) = 0 BYTE8(07) = 0 BYTE8(06) = 0 BYTE8(05) = 0 BYTE8(04) = bytearr43(32) BYTE8(03) = bytearr43(33) BYTE8(02) = bytearr43(34) BYTE8(01) = bytearr43(35) INT8_PI = INT8/4096 INT8_ePI = INT8-INT8/4096*4096 PI = INT8_PI/1.00d3 - 524.285 ePI = INT8_ePI/1000.0d0 BYTE8(08) = bytearr43(36) BYTE8(07) = bytearr43(37) BYTE8(06) = bytearr43(38) BYTE8(05) = bytearr43(39) BYTE8(04) = bytearr43(40) BYTE8(03) = bytearr43(41) BYTE8(02) = bytearr43(42) BYTE8(01) = bytearr43(43) LAB_I8 = INT8 c write(*,*) c write(*,'('' QTY '',a18,a18,a20,a10)') c . ' INPUT ', c . ' OUTPUT ', c . ' REPRESENTATION' c write(*,'('' .....'',a18,a18,a20)') c . ' .................', c . ' ................', c . ' ...................' c write(*,*) c write(*,'('' :'',18x,18x,a20)') 'cumulative uas' c write(*,'('' RA:'',f18.11,f18.11,i20)') RA, RAx, INT8_RA c write(*,'('' DE:'',f18.11,f18.11,i20)') DE, DEx, INT8_DE c write(*,'('' .....'',a18,a18,a20)') c . ' .................', c . ' ................', c . ' ...................' c write(*,'('' :'',18x,18x,a20)') 'uas' c write(*,'('' eRA:'',f18.11,f18.11,i20)') eRA, eRAx, INT8_eRA c write(*,'('' eDE:'',f18.11,f18.11,i20)') eDE, eDEx, INT8_eDE c write(*,'('' .....'',a18,a18,a20)') c . ' .................', c . ' ................', c . ' ...................' c write(*,'('' :'',18x,18x,a20)') 'mmag' c write(*,'('' GMAG:'',f18.11,f18.11,i20)') GMAG, GMAGx,INT8_GMAG c write(*,'(''eGMAG:'',f18.11,f18.11,i20)') eGMAG,eGMAGx,INT8_eGMAG c write(*,'('' BMAG:'',f18.11,f18.11,i20)') BMAG, BMAGx,INT8_BMAG c write(*,'(''eBMAG:'',f18.11,f18.11,i20)') eBMAG,eBMAGx,INT8_eBMAG c write(*,'('' RMAG:'',f18.11,f18.11,i20)') RMAG, RMAGx,INT8_RMAG c write(*,'(''eRMAG:'',f18.11,f18.11,i20)') eRMAG,eRMAGx,INT8_eRMAG c write(*,'('' .....'',a18,a18,a20)') c . ' .................', c . ' ................', c . ' ...................' c write(*,'('' muRA:'',f18.11,f18.11,i20)') muRA, muRAx,INT8_muRA c write(*,'('' :'',18x,18x,a20)') 'uas/yr' c write(*,'('' muDE:'',f18.11,f18.11,i20)') muDE, muDEx,INT8_muDE c write(*,'(''emuRA:'',f18.11,f18.11,i20)') emuRA,emuRAx,INT8_emuRA c write(*,'(''emuDE:'',f18.11,f18.11,i20)') emuDE,emuDEx,INT8_emuDE c write(*,'('' .....'',a18,a18,a20)') c . ' .................', c . ' ................', c . ' ...................' c write(*,'('' :'',18x,18x,a20)') 'uas' c write(*,'('' PI:'',f18.11,f18.11,i20)') PI, PIu, INT8_PI c write(*,'('' ePI:'',f18.11,f18.11,i20)') ePI, ePIu, INT8_ePI c write(*,'('' .....'',a18,a18,a20)') c . ' .................', c . ' ................', c . ' ...................' return end c------------------------------------------------ c c turn a byte into something unsigned we can show c c integer*2 function bsho(b) c implicit none c c byte b c bsho = b c if (bsho.lt.0) bsho = bsho + 256 c c return c end c C From HDK@psuvm.psu.edu Thu Dec 8 15:27:16 MST 1994 C C The following was converted from Algol recursive to Fortran iterative C by a colleague at Penn State (a long time ago - Fortran 66, please C excuse the GoTo's). The following code also corrects a bug in the C Quicksort algorithm published in the ACM (see Algorithm 402, CACM, C Sept. 1970, pp 563-567; also you younger folks who weren't born at C that time might find interesting the history of the Quicksort C algorithm beginning with the original published in CACM, July 1961, C pp 321-322, Algorithm 64). Note that the following algorithm sorts C integer data; actual data is not moved but sort is affected by sorting C a companion index array (see leading comments). The data type being C sorted can be changed by changing one line; see comments after C declarations and subsequent one regarding comparisons(Fortran C 77 takes care of character comparisons of course, so that comment C is merely historical from the days when we had to write character C compare subprograms, usually in assembler language for a specific C mainframe platform at that time). But the following algorithm is C good, still one of the best available. SUBROUTINE QSORTI (ORD,N,A) C C==============SORTS THE ARRAY A(I),I=1,2,...,N BY PUTTING THE C ASCENDING ORDER VECTOR IN ORD. THAT IS ASCENDING ORDERED A C IS A(ORD(I)),I=1,2,...,N; DESCENDING ORDER A IS A(ORD(N-I+1)), C I=1,2,...,N . THIS SORT RUNS IN TIME PROPORTIONAL TO N LOG N . C C C ACM QUICKSORT - ALGORITHM #402 - IMPLEMENTED IN FORTRAN 66 BY C WILLIAM H. VERITY, WHV@PSUVM.PSU.EDU C CENTER FOR ACADEMIC COMPUTING C THE PENNSYLVANIA STATE UNIVERSITY C UNIVERSITY PARK, PA. 16802 C IMPLICIT INTEGER (A-Z) C DIMENSION ORD(N),POPLST(2,20) C C TO SORT DIFFERENT INPUT TYPES, CHANGE THE FOLLOWING C SPECIFICATION STATEMENTS; FOR EXAMPLE, FOR FORTRAN CHARACTER C USE THE FOLLOWING: CHARACTER *(*) A(N) C REAL A(N) REAL X,XX,Z,ZZ,Y C NDEEP=0 U1=N L1=1 DO 1 I=1,N 1 ORD(I)=I 2 IF (U1.LE.L1) RETURN C 3 L=L1 U=U1 C C PART C 4 P=L Q=U C FOR CHARACTER SORTS, THE FOLLOWING 3 STATEMENTS WOULD BECOME C X = ORD(P) C Z = ORD(Q) C IF (A(X) .LE. A(Z)) GO TO 2 C C WHERE "CLE" IS A LOGICAL FUNCTION WHICH RETURNS "TRUE" IF THE C FIRST ARGUMENT IS LESS THAN OR EQUAL TO THE SECOND, BASED ON "LEN" C CHARACTERS. C X=A(ORD(P)) Z=A(ORD(Q)) IF (X.LE.Z) GO TO 5 Y=X X=Z Z=Y YP=ORD(P) ORD(P)=ORD(Q) ORD(Q)=YP 5 IF (U-L.LE.1) GO TO 15 XX=X IX=P ZZ=Z IZ=Q C C LEFT C 6 P=P+1 IF (P.GE.Q) GO TO 7 X=A(ORD(P)) IF (X.GE.XX) GO TO 8 GO TO 6 7 P=Q-1 GO TO 13 C C RIGHT C 8 Q=Q-1 IF (Q.LE.P) GO TO 9 Z=A(ORD(Q)) IF (Z.LE.ZZ) GO TO 10 GO TO 8 9 Q=P P=P-1 Z=X X=A(ORD(P)) C C DIST C 10 IF (X.LE.Z) GO TO 11 Y=X X=Z Z=Y IP=ORD(P) ORD(P)=ORD(Q) ORD(Q)=IP 11 IF (X.LE.XX) GO TO 12 XX=X IX=P 12 IF (Z.GE.ZZ) GO TO 6 ZZ=Z IZ=Q GO TO 6 C C OUT C 13 CONTINUE IF (.NOT.(P.NE.IX.AND.X.NE.XX)) GO TO 14 IP=ORD(P) ORD(P)=ORD(IX) ORD(IX)=IP 14 CONTINUE IF (.NOT.(Q.NE.IZ.AND.Z.NE.ZZ)) GO TO 15 IQ=ORD(Q) ORD(Q)=ORD(IZ) ORD(IZ)=IQ 15 CONTINUE IF (U-Q.LE.P-L) GO TO 16 L1=L U1=P-1 L=Q+1 GO TO 17 16 U1=U L1=Q+1 U=P-1 17 CONTINUE IF (U1.LE.L1) GO TO 18 C C START RECURSIVE CALL C NDEEP=NDEEP+1 POPLST(1,NDEEP)=U POPLST(2,NDEEP)=L GO TO 3 18 IF (U.GT.L) GO TO 4 C C POP BACK UP IN THE RECURSION LIST C IF (NDEEP.EQ.0) GO TO 2 U=POPLST(1,NDEEP) L=POPLST(2,NDEEP) NDEEP=NDEEP-1 GO TO 18 C C END SORT C END QSORT C END c------------------------------------------------ c c same as rclip, but for double precision numbers c real*8 function dclip(dval,dlo,dhi) implicit none real*8 dval real*8 dlo real*8 dhi dclip = dval if (dclip.gt.dhi) dclip = dhi if (dclip.lt.dlo) dclip = dlo if (.not.(dclip.lt.dhi).and. . .not.(dclip.gt.dlo)) dclip = dhi return end c---------------------------------------------- c c this routine takes the id number of a star c and finds the RV and eRV in the sorted list c subroutine find_rv(id_i,RV_o,eRV_o, . ID_Q,RV_Q,eRV_Q,Qs) implicit none integer*8 id_i ! the input ID# real*8 RV_o ! the output rv real*8 eRV_o ! the output rv error integer Qs integer*8 ID_Q(Qs) real*4 RV_Q(Qs) real*4 eRV_Q(Qs) integer q integer q1 integer q2 if (id_i.eq.ID_q(Qs)) then RV_o = RV_Q(Q) eRV_o = eRV_Q(Q) return endif q1 = 1 q2 = Qs 1 continue q = (q1+q2)/2 if (id_i.gt.ID_Q(q)) then q1 = q goto 1 endif if (id_i.lt.ID_Q(q)) then q2 = q goto 1 endif if (id_q(q).ne.id_i) then print*,' ' print*,'PROBLEM WITH FIND_RV...' print*,' ' write(*,'( '' iq_q(q1): '',i20,i8)') id_q(q1), q1 write(*,'( '' iq_q(q ): '',i20,i8)') id_q(q ), q write(*,'( '' iq_q(q2): '',i20,i8)') id_q(q2), q2 print*,' ' write(*,'( '' iq_i : '',i20,i8)') id_i print*,' ' stop endif RV_o = RV_Q(Q) eRV_o = eRV_Q(Q) return end c------------------------------------------------------------- c c this routine will take a set of GAIA observables and c will combine it into my 43-byte array c subroutine gaia2bytearrX(RA,DE,eRA,eDE, . GMAG,eGMAG,BMAG,eBMAG,RMAG,eRMAG, . muRA,emuRA,muDE,emuDE,PI,ePI, . LAB_I8, . nvis, nmat, igof_r, ixsn_r, . nbad, ngud, uflg, gflg, rflg, . bytearr50) implicit none real*8 RA ! RA in degrees real*8 DE ! De in degrees real*8 eRA ! error in RA (deg) real*8 eDE ! error in DE (deg) real*8 GMAG ! GMAG (in mag) real*8 eGMAG ! error in GMAG real*8 BMAG ! BMAG real*8 eBMAG ! error in BMAG real*8 RMAG ! RMAG real*8 eRMAG ! error in RMAG real*8 muRA ! pmRA (in mas/year) real*8 emuRA ! error in pmRA real*8 muDE ! pmDE (in mas) real*8 emuDE ! error in pmDE real*8 PI ! parallax (in mas) real*8 ePI ! error in parralax integer*8 LAB_I8 ! GAIA label integer*8 nvis, nmat real*8 igof_r real*8 ixsn_r integer*8 nbad, ngud, uflg, gflg, rflg byte bytearr50(50) ! output byte array c---------------------------------- c c local variables c integer*8 nvisu, nmatu, igofu, ixsnu integer*8 nbadu, ngudu, uflgu, gflgu, rflgu byte BYTE8(8) integer*8 INT8 integer*8 INT8_RA integer*8 INT8_DE integer*8 INT8_eRA integer*8 INT8_eDE integer*8 INT8_GMAG integer*8 INT8_eGMAG integer*8 INT8_BMAG integer*8 INT8_eBMAG integer*8 INT8_RMAG integer*8 INT8_eRMAG integer*8 INT8_muRA integer*8 INT8_emuRA integer*8 INT8_muDE integer*8 INT8_emuDE integer*8 INT8_PI integer*8 INT8_ePI integer*8 INT8_AUX integer*8 INT8_igof integer*8 INT8_ixsn integer b integer*2 bsho equivalence(INT8,BYTE8) real*8 RAu, DEu, eRAu, eDEu real*8 GMAGu, eGMAGu real*8 BMAGu, eBMAGu real*8 RMAGu, eRMAGu real*8 muRAu, emuRAu real*8 muDEu, emuDEu real*8 PIu, ePIu c c copy to temp arrays, so I can do some c clipping (just in case) c RAu = RA DEu = DE eRAu = eRA eDEu = eDE GMAGu = GMAG eGMAGu = eGMAG BMAGu = BMAG eBMAGu = eBMAG RMAGu = RMAG eRMAGu = eRMAG muRAu = muRA emuRAu = emuRA muDEu = muDE emuDEu = emuDE PIu = PI ePIu = ePI if (RAu.lt. 0.0000) RAu = 0.0000 if (RAu.gt.360.0000) RAu = 360.0000 INT8_RA = RAu/360.00d0*1099511627776.0d0 + 0.5 if (DEu.lt.-90.0000) DEu = -90.0000 if (DEu.gt. 90.0000) DEu = 90.0000 INT8_DE = (DEu+90.00d0)/180.00d0*1099511627776.0d0 + 0.5 if (eRAu.lt. 0) eRAu = 0 if (eRAu.gt.65535) eRAu = 65535 INT8_eRA = int(eRAu+0.5) if (eDEu.lt. 0) eDEu = 0 if (eDEu.gt.65535) eDEu = 65535 INT8_eDE = int(eDEu+0.5) if (GMAGu.lt. 0.000) GMAGu = 0.000 if (GMAGu.gt.32.000) GMAGu = 32.000 INT8_GMAG = GMAGu*1000.0 + 0.5 if (eGMAGu.lt. 0.0) eGMAGu = 0.0 if (eGMAGu.gt.255.0) eGMAGu = 255.0 INT8_eGMAG = eGMAGu if (BMAGu.lt. 0.000) BMAGu = 0.000 if (BMAGu.gt.32.000) BMAGu = 32.000 INT8_BMAG = BMAGu*1000.0 + 0.5 if (eBMAGu.lt. 0.0) eBMAGu = 0.0 if (eBMAGu.gt.255.0) eBMAGu = 255.0 INT8_eBMAG = eBMAGu if (RMAGu.lt. 0.000) RMAGu = 0.000 if (RMAGu.gt.32.000) RMAGu = 32.000 INT8_RMAG = RMAGu*1000.0 + 0.5 if (eRMAGu.lt. 0.0) eRMAGu = 0.0 if (eRMAGu.gt.255.0) eRMAGu = 255.0 INT8_eRMAG = eRMAGu if (muRAu.lt.-524.285) muRAu = -524.285 if (muRAu.gt. 524.285) muRAu = 524.285 INT8_muRA = (muRAu+524.285)*1 000 + 0.5 if (emuRAu.lt.0.000) emuRAu = 0.000 if (emuRAu.gt.4.000) emuRAu = 4.000 INT8_emuRA = emuRAu*1000 + 0.5 if (muDEu.lt.-524.285) muDEu = -524.285 if (muDEu.gt. 524.285) muDEu = 524.285 INT8_muDE = (muDEu+524.285)*1 000 + 0.5 if (emuDEu.lt.0.000) emuDEu = 0.000 if (emuDEu.gt.4.000) emuDEu = 4.000 INT8_emuDE = emuDEu*1000 + 0.5 if (PIu.lt.-524.285) PIu = -524.285 if (PIu.gt. 524.285) PIu = 524.285 INT8_PI = (PIu+524.285)*1 000 + 0.5 if (ePIu.lt.0.000) ePIu = 0.000 if (ePIu.gt.4.000) ePIu = 4.000 INT8_ePI = ePIu*1000 + 0.5 if (nvis.lt. 0) nvis = 31 if (nvis.gt.31) nvis = 31 if (nmat.lt. 0) nmat = 250 if (nmat.gt.250) nmat = 250 INT8_igof = 1000 + 100.0*igof_r + 0.5 if (INT8_igof.lt.0000) INT8_igof = 0 if (INT8_igof.gt.2001) INT8_igof = 2001 INT8_ixsn = 100*ixsn_r + 0.5 if (INT8_ixsn.lt.0000) INT8_ixsn = 2001 if (INT8_ixsn.gt.2001) INT8_ixsn = 2001 if (nbad.lt. 0) nbad = 250 if (nbad.gt.250) nbad = 250 if (ngud.lt. 0) ngud = 0 if (ngud.gt.250) ngud = 250 if (uflg.gt.1) uflg = 1 if (uflg.lt.0) uflg = 0 if (rflg.gt.1) rflg = 1 if (rflg.lt.0) rflg = 0 nvisu = nvis nmatu = nmat igofu = INT8_igof ixsnu = INT8_ixsn nbadu = nbad ngudu = ngud uflgu = uflg gflgu = gflg rflgu = rflg if (nvisu.lt.0) nvisu = 0 if (nmatu.lt.0) nmatu = 0 if (igofu.lt.0) igofu = 0 if (ixsnu.lt.0) ixsnu = 0 if (nbadu.lt.0) nbadu = 0 if (ngudu.lt.0) ngudu = 0 if (uflgu.lt.0) uflgu = 0 if (gflgu.lt.0) gflgu = 0 if (rflgu.lt.0) rflgu = 0 INT8_AUX = nvisu*256*2048*2048*256*1024*2*2*2 . + nmatu* 2048*2048*256*1024*2*2*2 . + igofu* 2048*256*1024*2*2*2 . + ixsnu* 256*1024*2*2*2 . + nbadu* 1024*2*2*2 . + ngudu* 2*2*2 . + uflgu* 2*2 . + gflgu* 2 . + rflgu c write(*,*) c write(*,'('' RA:'',f18.11,f18.11,i20)') RA, RAu, INT8_RA c write(*,'('' DE:'',f18.11,f18.11,i20)') DE, DEu, INT8_DE c write(*,'('' eRA:'',f18.11,f18.11,i20)') eRA, eRAu, INT8_eRA c write(*,'('' eDE:'',f18.11,f18.11,i20)') eDE, eDEu, INT8_eDE c write(*,*) c write(*,'('' GMAG:'',f18.11,f18.11,i20)') GMAG, GMAGu,INT8_GMAG c write(*,'(''eGMAG:'',f18.11,f18.11,i20)') eGMAG,eGMAGu,INT8_eGMAG c write(*,'('' BMAG:'',f18.11,f18.11,i20)') BMAG, BMAGu,INT8_BMAG c write(*,'(''eBMAG:'',f18.11,f18.11,i20)') eBMAG,eBMAGu,INT8_eBMAG c write(*,'('' RMAG:'',f18.11,f18.11,i20)') RMAG, RMAGu,INT8_RMAG c write(*,'(''eRMAG:'',f18.11,f18.11,i20)') eRMAG,eRMAGu,INT8_eRMAG c write(*,*) c write(*,'('' muRA:'',f18.11,f18.11,i20)') muRA, muRAu,INT8_muRA c write(*,'('' muDE:'',f18.11,f18.11,i20)') muDE, muDEu,INT8_muDE c write(*,'(''emuRA:'',f18.11,f18.11,i20)') emuRA,emuRAu,INT8_emuRA c write(*,'(''emuDE:'',f18.11,f18.11,i20)') emuDE,emuDEu,INT8_emuDE c write(*,*) c write(*,'('' PI:'',f18.11,f18.11,i20)') PI, PIu, INT8_PI c write(*,'('' ePI:'',f18.11,f18.11,i20)') ePI, ePIu, INT8_ePI c write(*,*) INT8 = INT8_RA bytearr50(01) = BYTE8(05) bytearr50(02) = BYTE8(04) bytearr50(03) = BYTE8(03) bytearr50(04) = BYTE8(02) bytearr50(05) = BYTE8(01) INT8 = INT8_DE bytearr50(06) = BYTE8(05) bytearr50(07) = BYTE8(04) bytearr50(08) = BYTE8(03) bytearr50(09) = BYTE8(02) bytearr50(10) = BYTE8(01) INT8 = INT8_eRA bytearr50(11) = BYTE8(02) bytearr50(12) = BYTE8(01) INT8 = INT8_eDE bytearr50(13) = BYTE8(02) bytearr50(14) = BYTE8(01) INT8 = INT8_GMAG bytearr50(15) = BYTE8(02) bytearr50(16) = BYTE8(01) INT8 = INT8_eGMAG bytearr50(17) = BYTE8(01) INT8 = INT8_BMAG bytearr50(18) = BYTE8(02) bytearr50(19) = BYTE8(01) INT8 = INT8_eBMAG bytearr50(20) = BYTE8(01) INT8 = INT8_RMAG bytearr50(21) = BYTE8(02) bytearr50(22) = BYTE8(01) INT8 = INT8_eRMAG bytearr50(23) = BYTE8(01) INT8 = INT8_muRA*4096 + INT8_emuRA bytearr50(24) = BYTE8(04) bytearr50(25) = BYTE8(03) bytearr50(26) = BYTE8(02) bytearr50(27) = BYTE8(01) INT8 = INT8_muDE*4096 + INT8_emuDE bytearr50(28) = BYTE8(04) bytearr50(29) = BYTE8(03) bytearr50(30) = BYTE8(02) bytearr50(31) = BYTE8(01) INT8 = INT8_PI*4096 + INT8_ePI bytearr50(32) = BYTE8(04) bytearr50(33) = BYTE8(03) bytearr50(34) = BYTE8(02) bytearr50(35) = BYTE8(01) INT8 = LAB_I8 bytearr50(36) = BYTE8(08) bytearr50(37) = BYTE8(07) bytearr50(38) = BYTE8(06) bytearr50(39) = BYTE8(05) bytearr50(40) = BYTE8(04) bytearr50(41) = BYTE8(03) bytearr50(42) = BYTE8(02) bytearr50(43) = BYTE8(01) INT8 = INT8_AUX bytearr50(44) = BYTE8(07) bytearr50(45) = BYTE8(06) bytearr50(46) = BYTE8(05) bytearr50(47) = BYTE8(04) bytearr50(48) = BYTE8(03) bytearr50(49) = BYTE8(02) bytearr50(50) = BYTE8(01) c print*,' ' c print*,'OUTPUT: ' c do b = 01, 43 c write(*,'('' b: '',i2,1x,2i6)') b,bsho(bytearr50(b)), c . bytearr50(b) c if (b.eq.05) print*,' ' c if (b.eq.10) print*,' ' c if (b.eq.12) print*,' ' c if (b.eq.14) print*,' ' c if (b.eq.16) print*,' ' c if (b.eq.17) print*,' ' c if (b.eq.19) print*,' ' c if (b.eq.20) print*,' ' c if (b.eq.22) print*,' ' c if (b.eq.23) print*,' ' c if (b.eq.27) print*,' ' c if (b.eq.31) print*,' ' c if (b.eq.35) print*,' ' c if (b.eq.43) print*,' ' c enddo c print*,' ' return end c------------------------------------------------------------ c c this subroutine will take a byte array and c will explode it into the gaia observables c subroutine bytearr2gaiaX(bytearr50, . RA,DE,eRA,eDE, . GMAG,eGMAG,BMAG,eBMAG,RMAG,eRMAG, . muRA,emuRA,muDE,emuDE,PI,ePI, . LAB_I8, . nvis, nmat, igof_r, ixsn_r, . nbad, ngud, uflg, gflg, rflg) implicit none ! INPUT byte bytearr50(50) ! byte array ! EXTRACTED real*8 RA ! RA in degrees real*8 DE ! De in degrees real*8 eRA ! error in RA (deg) real*8 eDE ! error in DE (deg) real*8 GMAG ! GMAG (in mag) real*8 eGMAG ! error in GMAG real*8 BMAG ! BMAG real*8 eBMAG ! error in BMAG real*8 RMAG ! RMAG real*8 eRMAG ! error in RMAG real*8 muRA ! pmRA (in arcsec/year) real*8 emuRA ! error in pmRA real*8 muDE ! pmDE real*8 emuDE ! error in pmDE real*8 PI ! parallax real*8 ePI ! error in parralax integer*8 LAB_I8 ! GAIA label integer*8 nvis, nmat real*8 igof_r real*8 ixsn_r integer*8 igof, ixsn integer*8 nbad, ngud, uflg, gflg, rflg c------------------------------------------ c c local variables c byte BYTE8(8) integer*8 INT8 integer*8 INT8_RA integer*8 INT8_DE integer*8 INT8_eRA integer*8 INT8_eDE integer*8 INT8_GMAG integer*8 INT8_eGMAG integer*8 INT8_BMAG integer*8 INT8_eBMAG integer*8 INT8_RMAG integer*8 INT8_eRMAG integer*8 INT8_muRA integer*8 INT8_emuRA integer*8 INT8_muDE integer*8 INT8_emuDE integer*8 INT8_PI integer*8 INT8_ePI integer*8 INT8_AUX integer b integer*2 bsho integer*8 i8u equivalence(INT8,BYTE8) BYTE8(08) = 0 BYTE8(07) = 0 BYTE8(06) = 0 BYTE8(05) = bytearr50(01) BYTE8(04) = bytearr50(02) BYTE8(03) = bytearr50(03) BYTE8(02) = bytearr50(04) BYTE8(01) = bytearr50(05) INT8_RA = INT8 RA = INT8_RA*360.00d0/1099511627776.0d0 BYTE8(08) = 0 BYTE8(07) = 0 BYTE8(06) = 0 BYTE8(05) = bytearr50(06) BYTE8(04) = bytearr50(07) BYTE8(03) = bytearr50(08) BYTE8(02) = bytearr50(09) BYTE8(01) = bytearr50(10) INT8_DE = INT8 DE = -90.000d0 + INT8_DE*180.00d0/1099511627776.0d0 BYTE8(08) = 0 BYTE8(07) = 0 BYTE8(06) = 0 BYTE8(05) = 0 BYTE8(04) = 0 BYTE8(03) = 0 BYTE8(02) = bytearr50(11) BYTE8(01) = bytearr50(12) INT8_eRA = INT8 eRA = INT8_eRA BYTE8(08) = 0 BYTE8(07) = 0 BYTE8(06) = 0 BYTE8(05) = 0 BYTE8(04) = 0 BYTE8(03) = 0 BYTE8(02) = bytearr50(13) BYTE8(01) = bytearr50(14) INT8_eDE = INT8 eDE = INT8_eDE BYTE8(08) = 0 BYTE8(07) = 0 BYTE8(06) = 0 BYTE8(05) = 0 BYTE8(04) = 0 BYTE8(03) = 0 BYTE8(02) = bytearr50(15) BYTE8(01) = bytearr50(16) INT8_GMAG = INT8 GMAG = INT8_GMAG/1000.0d0 eGMAG = bsho(bytearr50(17)) BYTE8(08) = 0 BYTE8(07) = 0 BYTE8(06) = 0 BYTE8(05) = 0 BYTE8(04) = 0 BYTE8(03) = 0 BYTE8(02) = bytearr50(18) BYTE8(01) = bytearr50(19) INT8_BMAG = INT8 BMAG = INT8_BMAG/1000.0d0 eBMAG = bsho(bytearr50(20)) BYTE8(08) = 0 BYTE8(07) = 0 BYTE8(06) = 0 BYTE8(05) = 0 BYTE8(04) = 0 BYTE8(03) = 0 BYTE8(02) = bytearr50(21) BYTE8(01) = bytearr50(22) INT8_RMAG = INT8 RMAG = INT8_RMAG/1000.0d0 eRMAG = bsho(bytearr50(23)) BYTE8(08) = 0 BYTE8(07) = 0 BYTE8(06) = 0 BYTE8(05) = 0 BYTE8(04) = bytearr50(24) BYTE8(03) = bytearr50(25) BYTE8(02) = bytearr50(26) BYTE8(01) = bytearr50(27) INT8_muRA = INT8/4096 INT8_emuRA = INT8-INT8/4096*4096 muRA = INT8_muRA/1.00d3 - 524.285 emuRA = INT8_emuRA/1000.0d0 BYTE8(08) = 0 BYTE8(07) = 0 BYTE8(06) = 0 BYTE8(05) = 0 BYTE8(04) = bytearr50(28) BYTE8(03) = bytearr50(29) BYTE8(02) = bytearr50(30) BYTE8(01) = bytearr50(31) INT8_muDE = INT8/4096 INT8_emuDE = INT8-INT8/4096*4096 muDE = INT8_muDE/1.00d3 - 524.285 emuDE = INT8_emuDE/1000.0d0 BYTE8(08) = 0 BYTE8(07) = 0 BYTE8(06) = 0 BYTE8(05) = 0 BYTE8(04) = bytearr50(32) BYTE8(03) = bytearr50(33) BYTE8(02) = bytearr50(34) BYTE8(01) = bytearr50(35) INT8_PI = INT8/4096 INT8_ePI = INT8-INT8/4096*4096 PI = INT8_PI/1.00d3 - 524.285 ePI = INT8_ePI/1000.0d0 BYTE8(08) = bytearr50(36) BYTE8(07) = bytearr50(37) BYTE8(06) = bytearr50(38) BYTE8(05) = bytearr50(39) BYTE8(04) = bytearr50(40) BYTE8(03) = bytearr50(41) BYTE8(02) = bytearr50(42) BYTE8(01) = bytearr50(43) LAB_I8 = INT8 BYTE8(08) = 0 BYTE8(07) = bytearr50(44) BYTE8(06) = bytearr50(45) BYTE8(05) = bytearr50(46) BYTE8(04) = bytearr50(47) BYTE8(03) = bytearr50(48) BYTE8(02) = bytearr50(49) BYTE8(01) = bytearr50(50) INT8_AUX = INT8 i8u = INT8_AUX nvis = i8u/ 256/2048/2048/256/1024/2/2/2 i8u = i8u-nvis*256*2048*2048*256*1024*2*2*2 nmat = i8u/ 2048/2048/256/1024/2/2/2 i8u = i8u-nmat* 2048*2048*256*1024*2*2*2 igof = i8u/ 2048/256/1024/2/2/2 i8u = i8u-igof* 2048*256*1024*2*2*2 ixsn = i8u/ 256/1024/2/2/2 i8u = i8u-ixsn* 256*1024*2*2*2 nbad = i8u/ 1024/2/2/2 i8u = i8u-nbad* 1024*2*2*2 ngud = i8u/ 2/2/2 i8u = i8u-ngud* 2*2*2 uflg = i8u/ 2/2 i8u = i8u-uflg* 2*2 gflg = i8u/ 2 i8u = i8u-gflg *2 rflg = i8u igof_r = (igof-1000)/100.00 ixsn_r = (ixsn)/100.0 c write(*,*) c write(*,'('' QTY '',a18,a18,a20,a10)') c . ' INPUT ', c . ' OUTPUT ', c . ' REPRESENTATION' c write(*,'('' .....'',a18,a18,a20)') c . ' .................', c . ' ................', c . ' ...................' c write(*,*) c write(*,'('' :'',18x,18x,a20)') 'cumulative uas' c write(*,'('' RA:'',f18.11,f18.11,i20)') RA, RAx, INT8_RA c write(*,'('' DE:'',f18.11,f18.11,i20)') DE, DEx, INT8_DE c write(*,'('' .....'',a18,a18,a20)') c . ' .................', c . ' ................', c . ' ...................' c write(*,'('' :'',18x,18x,a20)') 'uas' c write(*,'('' eRA:'',f18.11,f18.11,i20)') eRA, eRAx, INT8_eRA c write(*,'('' eDE:'',f18.11,f18.11,i20)') eDE, eDEx, INT8_eDE c write(*,'('' .....'',a18,a18,a20)') c . ' .................', c . ' ................', c . ' ...................' c write(*,'('' :'',18x,18x,a20)') 'mmag' c write(*,'('' GMAG:'',f18.11,f18.11,i20)') GMAG, GMAGx,INT8_GMAG c write(*,'(''eGMAG:'',f18.11,f18.11,i20)') eGMAG,eGMAGx,INT8_eGMAG c write(*,'('' BMAG:'',f18.11,f18.11,i20)') BMAG, BMAGx,INT8_BMAG c write(*,'(''eBMAG:'',f18.11,f18.11,i20)') eBMAG,eBMAGx,INT8_eBMAG c write(*,'('' RMAG:'',f18.11,f18.11,i20)') RMAG, RMAGx,INT8_RMAG c write(*,'(''eRMAG:'',f18.11,f18.11,i20)') eRMAG,eRMAGx,INT8_eRMAG c write(*,'('' .....'',a18,a18,a20)') c . ' .................', c . ' ................', c . ' ...................' c write(*,'('' muRA:'',f18.11,f18.11,i20)') muRA, muRAx,INT8_muRA c write(*,'('' :'',18x,18x,a20)') 'uas/yr' c write(*,'('' muDE:'',f18.11,f18.11,i20)') muDE, muDEx,INT8_muDE c write(*,'(''emuRA:'',f18.11,f18.11,i20)') emuRA,emuRAx,INT8_emuRA c write(*,'(''emuDE:'',f18.11,f18.11,i20)') emuDE,emuDEx,INT8_emuDE c write(*,'('' .....'',a18,a18,a20)') c . ' .................', c . ' ................', c . ' ...................' c write(*,'('' :'',18x,18x,a20)') 'uas' c write(*,'('' PI:'',f18.11,f18.11,i20)') PI, PIu, INT8_PI c write(*,'('' ePI:'',f18.11,f18.11,i20)') ePI, ePIu, INT8_ePI c write(*,'('' .....'',a18,a18,a20)') c . ' .................', c . ' ................', c . ' ...................' return end c------------------------------------------------ c c turn a byte into something unsigned we can show c integer*2 function bsho(b) implicit none byte b bsho = b if (bsho.lt.0) bsho = bsho + 256 return end c-------------------------------------------- c c this function will return the record where c the star ID is located c c integer*4 function r_id(id) implicit none integer*8 id integer*8 nst1, id1, r1 integer*8 nst2, id2, r2 integer*8 nstb, idb, rb integer*8 NSTs integer NIT NSTs = 1 692 919 135 c write(*,116) 0,id nst1 = 1 nst2 = NSTs call nst2idNr(nst1,id1,r1) if (id.eq.id1) then r_id = r1 return endif call nst2idNr(nst2,id2,r2) if (id.eq.id2) then r_id = r2 return endif NIT = 0 1 continue NIT = NIT + 1 if (NIT.gt.50) then print*,' ' print*,'Problem with r_id ... ' print*,'Cannot find record for star ID: ',id print*,'After more than 50 binary search moves.' print*,' ' stop endif nstb = (nst1+nst2)/2 call nst2idNr(nstb,idb,rb) c write(*,116) NIT, id,idb,nstb,rb, c . id1,nst1,r1, c . id2,nst2,r2 116 format(i4,1x,i20,3(10x,i20,1x,i10,1x,i8)) if (id.gt.idb) then nst1 = nstb id1 = idb r1 = rb goto 1 endif if (id.lt.idb) then nst2 = nstb id2 = idb r2 = rb goto 1 endif c write(*,116) NIT, id,idb,nstb,rb r_id = rb return end c------------------------------------- c c c subroutine nst2idNr(NST,id,r) implicit none integer*8 NST integer*8 r integer*8 id integer*16 i16a integer*16 i16b integer*16 i16c integer i integer*2 bsho character*80 STRING byte byte_11(11) integer*16 i16 byte b_16(16) equivalence (i16,b_16) logical FIRST_ID2R data FIRST_ID2R/.true./ common /FIRST_ID2R_/ FIRST_ID2R if (FIRST_ID2R) then open(91,file=_DBLOC2_, . status='old', . recl=11, . form='UNFORMATTED', . access='DIRECT') FIRST_ID2R = .true. endif read(91,rec=NST) byte_11 do i = 1, 16 b_16(i) = 0 enddo do i = 1, 11 b_16(i) = byte_11(i) enddo do i = 1, 16 enddo i16a = i16/16929192 i16c = i16a*16929192 i16b = i16 - i16c id = i16a r = i16b return end logical function unselect(RA,DE,eRA,eDE, . GMAG,eGMAG,BMAG,eBMAG,RMAG,eRMAG, . muRA,emuRA,muDE,emuDE,PI,ePI, . NVIS, NMAT, IGOF, IXSN, . NBAD, NGUD, UFLG, GFLG, RFLG, . RV, ERV) implicit none real*8 RA ! RA in degrees real*8 DE ! De in degrees real*8 eRA ! error in RA (deg) real*8 eDE ! error in DE (deg) real*8 GMAG ! GMAG (in mag) real*8 eGMAG ! error in GMAG real*8 BMAG ! BMAG real*8 eBMAG ! error in BMAG real*8 RMAG ! RMAG real*8 eRMAG ! error in RMAG real*8 muRA ! pmRA (in mas/year) real*8 emuRA ! error in pmRA real*8 muDE ! pmDE (in mas) real*8 emuDE ! error in pmDE real*8 PI ! parallax (in mas) real*8 ePI ! error in parralax integer*8 NVIS ! number of visibilities integer*8 NMAT ! real*8 IGOF ! real*8 IXSN ! integer*8 NBAD ! number of bad measts integer*8 NGUD ! number of good measts integer*8 UFLG ! use flag integer*8 GFLG ! good flag integer*8 RFLG ! is there a RV? real*8 RV ! rv real*8 ERV ! rv error real*8 RA_MINU, RA_MAXU real*8 DE_MINU, DE_MAXU real*8 ERA_MINU, ERA_MAXU real*8 EDE_MINU, EDE_MAXU real*8 MG_MINU, MG_MAXU real*8 EMG_MINU, EMG_MAXU real*8 MB_MINU, MB_MAXU real*8 EMB_MINU, EMB_MAXU real*8 MR_MINU, MR_MAXU real*8 EMR_MINU, EMR_MAXU real*8 MURA_MINU, MURA_MAXU real*8 EMURA_MINU,EMURA_MAXU real*8 MUDE_MINU, MUDE_MAXU real*8 EMUDE_MINU,EMUDE_MAXU real*8 PI_MINU, PI_MAXU real*8 EPI_MINU, EPI_MAXU real*8 NVIS_MINU, NVIS_MAXU real*8 NMAT_MINU, NMAT_MAXU real*8 IGOF_MINU, IGOF_MAXU real*8 IXSN_MINU, IXSN_MAXU real*8 NBAD_MINU, NBAD_MAXU real*8 NGUD_MINU, NGUD_MAXU real*8 UFLG_MINU, UFLG_MAXU real*8 GFLG_MINU, GFLG_MAXU real*8 RFLG_MINU, RFLG_MAXU real*8 RV_MINU, RV_MAXU real*8 ERV_MINU, ERV_MAXU real*8 BmR_MINU, BmR_MAXU real*8 BmG_MINU, BmG_MAXU real*8 GmR_MINU, GmR_MAXU real*8 BmG, BmR, GmR common / LIMITS_ / RA_MINU, RA_MAXU, . DE_MINU, DE_MAXU, . ERA_MINU, ERA_MAXU, . EDE_MINU, EDE_MAXU, . MG_MINU, MG_MAXU, . EMG_MINU, EMG_MAXU, . MB_MINU, MB_MAXU, . EMB_MINU, EMB_MAXU, . MR_MINU, MR_MAXU, . EMR_MINU, EMR_MAXU, . MURA_MINU, MURA_MAXU, . EMURA_MINU,EMURA_MAXU, . MUDE_MINU, MUDE_MAXU, . EMUDE_MINU,EMUDE_MAXU, . PI_MINU, PI_MAXU, . EPI_MINU, EPI_MAXU, . NVIS_MINU, NVIS_MAXU, . NMAT_MINU, NMAT_MAXU, . IGOF_MINU, IGOF_MAXU, . IXSN_MINU, IXSN_MAXU, . NBAD_MINU, NBAD_MAXU, . NGUD_MINU, NGUD_MAXU, . UFLG_MINU, UFLG_MAXU, . GFLG_MINU, GFLG_MAXU, . RFLG_MINU, RFLG_MAXU, . RV_MINU, RV_MAXU, . ERV_MINU, ERV_MAXU, . BmR_MINU, BmR_MAXU, . BmG_MINU, BmG_MAXU, . GmR_MINU, GmR_MAXU unselect = .false. BmG = BMAG - GMAG BmR = BMAG - RMAG GmR = GMAG - RMAG if ( RA.lt. RA_MINU.or. RA.gt. RA_MAXU) unselect = .true. if ( DE.lt. DE_MINU.or. DE.gt. DE_MAXU) unselect = .true. if ( eRA.lt. ERA_MINU.or. eRA.gt. ERA_MAXU) unselect = .true. if ( eDE.lt. EDE_MINU.or. eDE.gt. EDE_MAXU) unselect = .true. if ( GMAG.lt. MG_MINU.or. GMAG.gt. MG_MAXU) unselect = .true. if (eGMAG.lt. EMG_MINU.or.eGMAG.gt. EMG_MAXU) unselect = .true. if ( BMAG.lt. MB_MINU.or. BMAG.gt. MB_MAXU) unselect = .true. if (eBMAG.lt. EMB_MINU.or.eBMAG.gt. EMB_MAXU) unselect = .true. if ( RMAG.lt. MR_MINU.or. RMAG.gt. MR_MAXU) unselect = .true. if (eRMAG.lt. EMR_MINU.or.eRMAG.gt. EMR_MAXU) unselect = .true. if ( muRA.lt. MURA_MINU.or. muRA.gt. MURA_MAXU) unselect = .true. if (emuRA.lt.EMURA_MINU.or.emuRA.gt.EMURA_MAXU) unselect = .true. if ( muDE.lt. MUDE_MINU.or. muDE.gt. MUDE_MAXU) unselect = .true. if (emuDE.lt.EMUDE_MINU.or.emuDE.gt.EMUDE_MAXU) unselect = .true. if ( PI.lt. PI_MINU.or. PI.gt. PI_MAXU) unselect = .true. if ( ePI.lt. EPI_MINU.or. ePI.gt. EPI_MAXU) unselect = .true. if ( NVIS.lt. NVIS_MINU.or. NVIS.gt. NVIS_MAXU) unselect = .true. if ( NMAT.lt. NMAT_MINU.or. NMAT.gt. NMAT_MAXU) unselect = .true. if ( IGOF.lt. IGOF_MINU.or. IGOF.gt. IGOF_MAXU) unselect = .true. if ( IXSN.lt. IXSN_MINU.or. IXSN.gt. IXSN_MAXU) unselect = .true. if ( NBAD.lt. NBAD_MINU.or. NBAD.gt. NBAD_MAXU) unselect = .true. if ( NGUD.lt. NGUD_MINU.or. NGUD.gt. NGUD_MAXU) unselect = .true. if ( UFLG.lt. UFLG_MINU.or. UFLG.gt. UFLG_MAXU) unselect = .true. if ( GFLG.lt. GFLG_MINU.or. GFLG.gt. GFLG_MAXU) unselect = .true. if ( RFLG.lt. RFLG_MINU.or. RFLG.gt. RFLG_MAXU) unselect = .true. if ( RV.lt. RV_MINU.or. RV.gt. RV_MAXU) unselect = .true. if ( eRV.lt. ERV_MINU.or. eRV.gt. ERV_MAXU) unselect = .true. if ( BmG.lt. BmG_MINU.or. BmG.gt. BmG_MAXU) unselect = .true. if ( BmR.lt. BmR_MINU.or. BmR.gt. BmR_MAXU) unselect = .true. if ( GmR.lt. GmR_MINU.or. GmR.gt. GmR_MAXU) unselect = .true. return end subroutine show_delimeters implicit none real*8 RA_MINU, RA_MAXU real*8 DE_MINU, DE_MAXU real*8 ERA_MINU, ERA_MAXU real*8 EDE_MINU, EDE_MAXU real*8 MG_MINU, MG_MAXU real*8 EMG_MINU, EMG_MAXU real*8 MB_MINU, MB_MAXU real*8 EMB_MINU, EMB_MAXU real*8 MR_MINU, MR_MAXU real*8 EMR_MINU, EMR_MAXU real*8 MURA_MINU, MURA_MAXU real*8 EMURA_MINU,EMURA_MAXU real*8 MUDE_MINU, MUDE_MAXU real*8 EMUDE_MINU,EMUDE_MAXU real*8 PI_MINU, PI_MAXU real*8 EPI_MINU, EPI_MAXU real*8 NVIS_MINU, NVIS_MAXU real*8 NMAT_MINU, NMAT_MAXU real*8 IGOF_MINU, IGOF_MAXU real*8 IXSN_MINU, IXSN_MAXU real*8 NBAD_MINU, NBAD_MAXU real*8 NGUD_MINU, NGUD_MAXU real*8 UFLG_MINU, UFLG_MAXU real*8 GFLG_MINU, GFLG_MAXU real*8 RFLG_MINU, RFLG_MAXU real*8 RV_MINU, RV_MAXU real*8 ERV_MINU, ERV_MAXU real*8 BmR_MINU, BmR_MAXU real*8 BmG_MINU, BmG_MAXU real*8 GmR_MINU, GmR_MAXU common / LIMITS_ / RA_MINU, RA_MAXU, . DE_MINU, DE_MAXU, . ERA_MINU, ERA_MAXU, . EDE_MINU, EDE_MAXU, . MG_MINU, MG_MAXU, . EMG_MINU, EMG_MAXU, . MB_MINU, MB_MAXU, . EMB_MINU, EMB_MAXU, . MR_MINU, MR_MAXU, . EMR_MINU, EMR_MAXU, . MURA_MINU, MURA_MAXU, . EMURA_MINU,EMURA_MAXU, . MUDE_MINU, MUDE_MAXU, . EMUDE_MINU,EMUDE_MAXU, . PI_MINU, PI_MAXU, . EPI_MINU, EPI_MAXU, . NVIS_MINU, NVIS_MAXU, . NMAT_MINU, NMAT_MAXU, . IGOF_MINU, IGOF_MAXU, . IXSN_MINU, IXSN_MAXU, . NBAD_MINU, NBAD_MAXU, . NGUD_MINU, NGUD_MAXU, . UFLG_MINU, UFLG_MAXU, . GFLG_MINU, GFLG_MAXU, . RFLG_MINU, RFLG_MAXU, . RV_MINU, RV_MAXU, . ERV_MINU, ERV_MAXU, . BmR_MINU, BmR_MAXU, . BmG_MINU, BmG_MAXU, . GmR_MINU, GmR_MAXU write(*,'(''#'')') if ( RA_MINU.gt.-9999.or. RA_MAXU.lt.9999) . write(*,337) ' RA_MINU', RA_MINU, . ' RA_MAXU', RA_MAXU if ( DE_MINU.gt.-9999.or. DE_MAXU.lt.9999) . write(*,337) ' DE_MINU', DE_MINU, . ' DE_MAXU', DE_MAXU if ( ERA_MINU.gt.-9999.or. ERA_MAXU.lt.9999) . write(*,337) ' ERA_MINU', ERA_MINU, . ' ERA_MAXU', ERA_MAXU if ( EDE_MINU.gt.-9999.or. EDE_MAXU.lt.9999) . write(*,337) ' EDE_MINU', EDE_MINU, . ' EDE_MAXU', EDE_MAXU if ( MG_MINU.gt.-9999.or. MG_MAXU.lt.9999) . write(*,337) ' MG_MINU', MG_MINU, . ' MG_MAXU', MG_MAXU if ( EMG_MINU.gt.-9999.or. EMG_MAXU.lt.9999) . write(*,337) ' EMG_MINU', EMG_MINU, . ' EMG_MAXU', EMG_MAXU if ( MB_MINU.gt.-9999.or. MB_MAXU.lt.9999) . write(*,337) ' MB_MINU', MB_MINU, . ' MB_MAXU', MB_MAXU if ( EMB_MINU.gt.-9999.or. EMB_MAXU.lt.9999) . write(*,337) ' EMB_MINU', EMB_MINU, . ' EMB_MAXU', EMB_MAXU if ( MR_MINU.gt.-9999.or. MR_MAXU.lt.9999) . write(*,337) ' MR_MINU', MR_MINU, . ' MR_MAXU', MR_MAXU if ( EMR_MINU.gt.-9999.or. EMR_MAXU.lt.9999) . write(*,337) ' EMR_MINU', EMR_MINU, . ' EMR_MAXU', EMR_MAXU if ( MURA_MINU.gt.-9999.or. MURA_MAXU.lt.9999) . write(*,337) ' MURA_MINU', MURA_MINU, . ' MURA_MAXU', MURA_MAXU if (EMURA_MINU.gt.-9999.or.EMURA_MAXU.lt.9999) . write(*,337) 'EMURA_MINU',EMURA_MINU, . 'EMURA_MAXU',EMURA_MAXU if ( MUDE_MINU.gt.-9999.or. MUDE_MAXU.lt.9999) . write(*,337) ' MUDE_MINU', MUDE_MINU, . ' MUDE_MAXU', MUDE_MAXU if (EMUDE_MINU.gt.-9999.or.EMUDE_MAXU.lt.9999) . write(*,337) 'EMUDE_MINU',EMUDE_MINU, . 'EMUDE_MAXU',EMUDE_MAXU if ( PI_MINU.gt.-9999.or. PI_MAXU.lt.9999) . write(*,337) ' PI_MINU', PI_MINU, . ' PI_MAXU', PI_MAXU if ( EPI_MINU.gt.-9999.or. EPI_MAXU.lt.9999) . write(*,337) ' EPI_MINU', EPI_MINU, . ' EPI_MAXU', EPI_MAXU if ( NVIS_MINU.gt.-9999.or. NVIS_MAXU.lt.9999) . write(*,337) ' NVIS_MINU', NVIS_MINU, . ' NVIS_MAXU', NVIS_MAXU if ( NMAT_MINU.gt.-9999.or. NMAT_MAXU.lt.9999) . write(*,337) ' NMAT_MINU', NMAT_MINU, . ' NMAT_MAXU', NMAT_MAXU if ( IGOF_MINU.gt.-9999.or. IGOF_MAXU.lt.9999) . write(*,337) ' IGOF_MINU', IGOF_MINU, . ' IGOF_MAXU', IGOF_MAXU if ( IXSN_MINU.gt.-9999.or. IXSN_MAXU.lt.9999) . write(*,337) ' IXSN_MINU', IXSN_MINU, . ' IXSN_MAXU', IXSN_MAXU if ( NBAD_MINU.gt.-9999.or. NBAD_MAXU.lt.9999) . write(*,337) ' NBAD_MINU', NBAD_MINU, . ' NBAD_MAXU', NBAD_MAXU if ( NGUD_MINU.gt.-9999.or. NGUD_MAXU.lt.9999) . write(*,337) ' NGUD_MINU', NGUD_MINU, . ' NGUD_MAXU', NGUD_MAXU if ( UFLG_MINU.gt.-9999.or. UFLG_MAXU.lt.9999) . write(*,337) ' UFLG_MINU', UFLG_MINU, . ' UFLG_MAXU', UFLG_MAXU if ( GFLG_MINU.gt.-9999.or. GFLG_MAXU.lt.9999) . write(*,337) ' GFLG_MINU', GFLG_MINU, . ' GFLG_MAXU', GFLG_MAXU if ( RFLG_MINU.gt.-9999.or. RFLG_MAXU.lt.9999) . write(*,337) ' RFLG_MINU', RFLG_MINU, . ' RFLG_MAXU', RFLG_MAXU if ( RV_MINU.gt.-9999.or. RV_MAXU.lt.9999) . write(*,337) ' RV_MINU', RV_MINU, . ' RV_MAXU', RV_MAXU if ( ERV_MINU.gt.-9999.or. ERV_MAXU.lt.9999) . write(*,337) ' ERV_MINU', ERV_MINU, . ' ERV_MAXU', ERV_MAXU if ( BmR_MINU.gt.-9999.or. BmR_MAXU.lt.9999) . write(*,337) ' BmR_MINU', BmR_MINU, . ' BmR_MAXU', BmR_MAXU if ( BmG_MINU.gt.-9999.or. BmG_MAXU.lt.9999) . write(*,337) ' BmG_MINU', BmG_MINU, . ' BmG_MAXU', BmG_MAXU if ( GmR_MINU.gt.-9999.or. GmR_MAXU.lt.9999) . write(*,337) ' GmR_MINU', GmR_MINU, . ' GmR_MAXU', GmR_MAXU 337 format('# RESTRICTION: ',a10,1x,f10.5,1x,a10,f10.5) write(*,'(''#'')') return end