subroutine mdxsub(a_cmd,i_maxbuff,readfunc) implicit none integer I_WKSPACE integer I_MAXCOLS integer I_MAXROWS integer I_MAXSAMP parameter(I_WKSPACE = 100000) parameter(I_MAXCOLS = 100000) parameter(I_MAXROWS = 100000) parameter(I_MAXSAMP = 100000) integer I_BMAX parameter(I_BMAX=200) ! Maximum number of buffered commands integer I_EMAX parameter(I_EMAX=200) ! Maximum number of buffered expose commands integer I_FMAX ! Maximum number of data files parameter(I_FMAX= 6) integer I_CMAX ! Maximum number of data channels parameter(I_CMAX=10) integer I_DMAX ! Maximum number of displays parameter(I_DMAX=10) integer I_KMAX ! Maximum number of color tables in pulldown menu parameter(I_KMAX=20) c INPUT VARIABLES: integer i_inarg character*255 a_inarg(255) c Some Useful Local Variables character*255 a_value character*255 a_title character*255 a_sss(I_CMAX) character*200 a_nullstr character*255 a_label character*255 a_command character*255 a_fmt character*(*) a_cmd character*255 a_workdir character*255 a_colordir character*20 a_colorname(I_KMAX) character*255 a_colorfile(I_KMAX) integer i_colormax integer i_colorset integer i integer j integer ix integer iy integer ib integer ie integer i_r integer i_c integer i_d integer ir integer ic integer i_arg integer i_row integer i_col integer i_typ integer i_tmp integer i_dat ! Data file counter integer i_set ! Set Counter integer i_chn integer i_sss integer i_pid integer i_opr integer i_pfmt integer i_pset integer i_sset integer i_tset integer i_loop integer i_flip integer i_stat integer i_dflag integer i_value integer i_field integer i_default byte b_buff(4) integer i_buff equivalence(b_buff,i_buff) integer i_endian integer i_cnt integer i_err integer i_flg integer i_pos integer i_max integer i_roff integer i_log integer i_dec real*4 r_data(0:I_MAXCOLS) real*4 r_data2(0:I_MAXCOLS) integer*4 i_data(0:I_MAXCOLS) integer*4 i_data2(0:I_MAXCOLS) real*8 r_sqr real*8 r_sum real*8 r_avg real*8 r_std real*4 r_zmstrt real*4 r_expn real*4 r_setmin real*4 r_setmax real*4 r_dnx(3) real*4 r_eux(3) real*4 r_loc(3) real*4 r_pi real*4 r_rtod real*4 r_a real*4 r_e2 integer i_smode integer i_samps integer i_rsamps(I_MAXSAMP) integer i_csamps(I_MAXSAMP) integer i_tsamps(I_MAXSAMP) real*4 r_wsamps(I_MAXSAMP) real*4 r_ssamps(I_MAXSAMP) real*4 r_vsamps(I_MAXSAMP,I_CMAX) real*4 r_row(I_MAXSAMP) real*4 r_col(I_MAXSAMP) real*4 r_rowlow real*4 r_rowhigh real*4 r_collow real*4 r_colhigh real*4 r_path real*4 r_wdth real*4 r_spce real*4 r_dist integer ii integer jj integer iii integer i_cc integer i_rr integer i_clast integer i_rlast c structure / set_structure / s_set(-I_FMAX:I_CMAX) character*200 a_setname(-I_FMAX:I_CMAX) ! Parameter name character*200 a_setfile(-I_FMAX:I_CMAX) ! Data filename character*200 a_setinfo(-I_FMAX:I_CMAX) ! Header filename character*200 a_setproj(-I_FMAX:I_CMAX) ! Projection name character*16 a_setvnul(-I_FMAX:I_CMAX) ! Hex string of null value integer i_setunit(-I_FMAX:I_CMAX) ! Unit number to read set integer i_setrows(-I_FMAX:I_CMAX) ! Number of rows in set integer i_setcols(-I_FMAX:I_CMAX) ! Number of columns in set integer i_setshdr(-I_FMAX:I_CMAX) ! Number of bytes in set header integer i_setstlr(-I_FMAX:I_CMAX) ! Number of bytes in set trailer integer i_setrhdr(-I_FMAX:I_CMAX) ! Number of bytes in row header integer i_setrtlr(-I_FMAX:I_CMAX) ! Number of bytes in row trailer integer i_setchdr(-I_FMAX:I_CMAX) ! Number of bytes in column header integer i_setctlr(-I_FMAX:I_CMAX) ! Number of bytes in column trailer integer i_setvend(-I_FMAX:I_CMAX) ! Endian flag integer i_setvfmt(-I_FMAX:I_CMAX) ! Method to decode columns real*4 r_setrmlt(-I_FMAX:I_CMAX) ! Row Scale for set real*4 r_setradr(-I_FMAX:I_CMAX) ! Row Offset for set real*4 r_setcmlt(-I_FMAX:I_CMAX) ! Column Scale for set real*4 r_setcadr(-I_FMAX:I_CMAX) ! Column Offset for set real*4 r_setvmlt(-I_FMAX:I_CMAX) ! Value Scale for set real*4 r_setvadr(-I_FMAX:I_CMAX) ! Value Offset for set real*4 r_setvmin(-I_FMAX:I_CMAX) ! Minimum valid value real*4 r_setvmax(-I_FMAX:I_CMAX) ! Maximum valid value real*4 r_setvavg(-I_FMAX:I_CMAX) ! Average value in set real*4 r_setvstd(-I_FMAX:I_CMAX) ! Standard deviation of values in set real*4 r_setpegv(3,-I_FMAX:I_CMAX) ! Set Peg byte b_setvnul(0:16,-I_FMAX:I_CMAX) ! Invalid value c end structure integer i_dsp integer i_dspselect c structure / dspinfo / s_dsp character*200 a_dspctbl(-I_FMAX:I_CMAX) ! Color table file integer i_dspcnt integer i_dspchnl ! Number of sets to display integer i_dspaddr(-I_FMAX:I_CMAX) ! Add auto Scale flag integer i_dspmult(-I_FMAX:I_CMAX) ! Mult auto Scale flag integer i_dspmixv(-I_FMAX:I_CMAX) ! Method to mix set (add, multiply, max, avg) integer i_dspnumt(-I_FMAX:I_CMAX) ! Number of entries in color table integer i_dspmode(-I_FMAX:I_CMAX) integer i_dspdvdc(-I_FMAX:I_CMAX) integer i_dspactv(0:I_DMAX,-I_CMAX:I_CMAX) real*4 r_dspredt(0:255,-I_FMAX:I_CMAX) ! Values of red color table real*4 r_dspgrnt(0:255,-I_FMAX:I_CMAX) ! Values of green color table real*4 r_dspblut(0:255,-I_FMAX:I_CMAX) ! Values of blue color table real*4 r_dspcplw(-I_FMAX:I_CMAX) ! Discard if below value real*4 r_dspcphi(-I_FMAX:I_CMAX) ! Discard if above value real*4 r_dspexpn(-I_FMAX:I_CMAX) ! Exponent to raise data real*4 r_dspaddr(-I_FMAX:I_CMAX) ! Shift data by value real*4 r_dspwrap(-I_FMAX:I_CMAX) ! Wrap data by value real*4 r_dspmult(-I_FMAX:I_CMAX) ! Multiply data by value real*4 r_dspvmin(-I_FMAX:I_CMAX) ! Min value to display real*4 r_dspvmax(-I_FMAX:I_CMAX) ! Max value to display real*4 r_dspval1(-I_FMAX:I_CMAX) real*4 r_dspval2(-I_FMAX:I_CMAX) real*4 r_dspval3(-I_FMAX:I_CMAX) c end structure c structure / dspinfo / s_win character*200 a_dsptitle(0:I_DMAX) ! Window title integer i_winactv(0:I_DMAX) integer i_winrows(0:I_DMAX) ! rows offset integer i_wincols(0:I_DMAX) ! sample offset integer i_wincadr(0:I_DMAX) ! column offset to start of window integer i_winradr(0:I_DMAX) ! row offset to start of window integer i_winselc(0:I_DMAX) ! Set active flag real*4 r_winzoom(0:I_DMAX) ! Zoom factor c end structure integer i_winx ! initial window size on screen integer i_winy ! initial window size on screen integer i_wxs(6,-10:10) ! window x size integer i_wys(6,-10:10) ! window y size integer i_vxs(6,-10:10) ! viewport x size integer i_vys(6,-10:10) ! viewport y size integer i_vxo(6,-10:10) ! viewport x offset integer i_vyo(6,-10:10) ! viewport y offset integer i_int integer i_bpl integer i_ncx integer i_nrx integer i_enrx2 integer i_ponly integer i_indx(0:I_WKSPACE) real*4 r_rdat(0:I_WKSPACE) real*4 r_gdat(0:I_WKSPACE) real*4 r_bdat(0:I_WKSPACE) c save r_rdat, r_gdat,r_bdat character*255 a_file character*120 a_filename character*255 a_ptsfile character*120 a_label1 character*120 a_label2 character*160 a_labels(0:20) character*160 a_data(0:20) character*160 a_elabl(0:20) character*160 a_edata(0:20) character*120 a_nullclr character*120 a_lcolor integer*4 i_nullclr(3) integer*4 stat,i_stat32(13),i_err32 integer*4 i_msgid character*160 a_message character*200 a_out byte b_out(3*I_WKSPACE) equivalence(a_out,b_out) real*4 r_value real*4 r_val(I_WKSPACE) integer i_w integer i_win integer i_evn integer i_val integer i_key integer i_asc integer i_act integer i_debug integer i_done integer i_wait integer i_cntl integer i_shft integer i_abort integer i_pinit integer i_scroll integer i_eventmod ! number of lines read between X window event calls integer i_rcenter integer i_ccenter integer i_cpos integer i_rpos integer i_cdsp integer i_cset integer i_qubeset integer i_show integer i_region integer i_start integer i_newpoint integer i_event(0:10) integer i_button integer i_ecnt integer i_edat(0:10,I_EMAX) ! Expose Buffer data integer i_ecmd(0:10) integer i_bcnt integer i_bdat(0:10,I_BMAX) ! Action Buffer data integer i_brow ! Number of lines in action integer i_blks ! Number of blocks needed to complete action integer i_strt integer i_stop integer i_incr integer i_coff integer i_close integer i_redraw(I_DMAX) integer i_cw integer i_ch integer i_widget integer i_menu integer i_edsp integer i_ewin integer i_eevn integer i_ecol integer i_erow integer i_encx integer i_enrx integer i_lat integer i_lon integer i_str integer i_pcpad integer i_prpad character*10 a_rowfrmt character*10 a_colfrmt character*120 a_hdrfile integer i_lsize integer i_ssize real*8 r_peg(3) real*8 r_lat real*8 r_lon character*120 a_type real*8 r_str(2) real*8 r_spc(2) integer i_mbytes integer i_dbytes real r_mmul real r_madd real r_dmul real r_dadd real r_median real r_space integer i_ewupdate integer i_rstat byte b_data(0:3) character*20 a_tname(5) character*1 a_twait(5) character*120 a_tcmnd(5) character*120 a_clickcmd(6) c FUNCTIONS integer rdflen external rdflen character*40 rdflower external rdflower integer rdfnum external rdfnum integer initdk external initdk real*8 rdir external rdir real*4 wrap ! Height wrap variables external wrap integer i_CnvrtFmt external i_CnvrtFmt integer i_setvbyt external i_setvbyt character*18 version_mdx external version_mdx integer version_gx external version_gx #ifdef IO64 integer*8 i_fbytes integer*8 i_maxbuff integer*8 readfunc external readfunc integer*8 i_getfsize external i_getfsize integer*8 i_eight external i_eight #else integer*4 i_fbytes integer*4 i_maxbuff integer*4 readfunc external readfunc integer*4 i_getfsize external i_getfsize integer*4 i_eight external i_eight #endif c PROCESSING STEPS: c c Initialize pi and conversions c r_pi = 4.d0*atan(1.0d0) r_rtod = 180.0d0/r_pi c c Initialize datum stuff c r_a = 6378137.0 r_e2 = 0.00669438 c c Determine endian ness of machine c b_buff(1) = 0 b_buff(2) = 0 b_buff(3) = 0 b_buff(4) = 1 if (i_buff .eq. 1) then ! Big Endian i_endian = 1 else ! Little Endian i_endian = -1 end if c Note - The order that parameters get set is as follows: c 1) Internal parameter initialization set at the top of the program c 2) Parameters read in from the mdx.ini file in the local or home c directory c 3) Parameters on command line prior to any file name specified c 5) Parameters on command line prior to any specified set c 6) Parameters read in from the implicit file header for a given c set c 7) Parameters on command line following set specification c c headers can also be explicitly identified on the command line and c will c be given priority indicated by their location in the command line. c c Initialize set stuff c a_setname(0) = ' ' a_setfile(0) = ' ' a_setinfo(0) = ' ' a_setproj(0) = ' ' i_setunit(0) = 0 i_setrows(0) = 1000000 i_setcols(0) = 0 i_setshdr(0) = 0 i_setstlr(0) = 0 i_setrhdr(0) = 0 i_setrtlr(0) = 0 i_setchdr(0) = 0 i_setctlr(0) = 0 i_setvend(0) = i_endian i_setvfmt(0) = 4 ! REAL*4 r_setrmlt(0) = 1.0 r_setradr(0) = 0.0 r_setcmlt(0) = 1.0 r_setcadr(0) = 0.0 r_setvmlt(0) = 1.0d0 r_setvadr(0) = 0.0d0 r_setvmin(0) = -1.0d27 r_setvmax(0) = 1.0d27 a_setvnul(0) = ' ' a_filename = ' ' a_labels(0) = 'Display Parameters' a_labels(1) = 'Scale Mode:' a_labels(2) = 'SDEV Factor:' a_labels(3) = 'Offset:' a_labels(4) = 'Exponent:' a_labels(5) = 'Min Valid:' a_labels(6) = 'Max Valid:' a_labels(7) = 'Min Clip:' a_labels(8) = 'Max Clip:' a_labels(9) = 'Color Table:' a_labels(10) = ' ' a_data(0) = '0' a_data(1) = '1' a_data(2) = '2' a_data(3) = '3' a_data(4) = '4' a_data(5) = '5' a_data(6) = '6' a_data(7) = '7' a_data(8) = '8' a_data(9) = '9' a_data(10) = ' ' C C rjm: Initialize win column start and rol start C This is needed for "-P" print option C And, what the heck, initial i_data too. C do i = 0,I_MAXCOLS i_data(i) = 0 i_data2(i) = 0 end do do i = 0,I_DMAX i_wincadr(i) = 0 i_winradr(i) = 0 end do c c Initialize display stuff c i_done = 0 i_bcnt = 0 i_ecnt = 0 i_wait = 0 ! 0 = wait for event i_r = -1 a_title = ' ' i_dspchnl = 0 ! Number of channels i_winrows(0) = 0 ! Number of rows i_wincols(0) = 0 ! Number of columns r_winzoom(0) = 1.0 ! Print Zoom factor i_winx = 0 i_winy = 0 r_dspcplw(0) = -1.e27 ! Clip if below value r_dspcphi(0) = 1.e27 ! Clip if above value r_dspvmin(0) = -1.e27 ! Discard if below value r_dspvmax(0) = 1.e27 ! Discard if above value r_dspexpn(0) = 1. ! raise data to pwr r_dspaddr(0) = 0. ! Shift data by value r_dspwrap(0) = 0. ! Wrap data by value r_dspmult(0) = 0. ! Multiply data by value r_dspval1(0) = 2.0 ! Value used in computing auto scale r_dspval2(0) = 90.0 ! Value used in computing auto scale r_dspval3(0) = 1.0 ! Value used in computing auto scale i_dspaddr(0) = 1. ! Flag to enable auto scale i_dspmult(0) = 1. ! Flag to enable auto scale i_dspmixv(0) = 2 ! Method to mix sets (add, multiply, max, avg) i_dspmode(0) = 3 ! Autoscale to 90% i_dspdvdc(0) = 0 a_dspctbl(0) = ' ' ! Default color table r_winzoom(1) = 1.0 ! Screen Zoom default i_menu = 1 i_close = 1 do i=1, I_DMAX i_dspactv(i,0) = -1 do j=1,I_CMAX i_dspactv(i,-j) = -1 i_dspactv(i, j) = -1 end do i_redraw(i) = 0 end do do i=0,20 a_elabl(i) = ' ' a_edata(i) = ' ' end do a_nullclr='0,0,255' a_lcolor='white' i_abort=0 i_debug = 2 i_eventmod = 10 i_scroll = 0 i_pinit = 0 i_ponly = 0 i_pfmt = 1 i_pset = 0 i_sset = 0 i_tset = 0 i_cntl = 0 i_shft = 0 i_key = 0 i_region = 0 i_act = 0 i_smode = 1 r_wdth = 0. r_spce = 0.1 i_samps = 0 i_show = 0 i_pcpad = 31 i_prpad = 50 i_cdsp = -1 i_cset = 0 i_qubeset = 0 i_ccenter = 0 i_rcenter = 0 r_lat = -3*r_pi r_lon = -3*r_pi i_r = -2 i_dspselect = 0 i_ewupdate = 0 do i=1,5 a_tname(i)=' ' a_twait(i)=' ' a_tcmnd(i)=' ' end do a_tname(1) = 'Plot Location' a_tname(2) = 'Plot Profile' a_workdir = './' a_colordir = './' a_ptsfile = ' ' a_colorname(1) = 'Other' a_colorfile(1) = '?' a_colorname(2) = 'White' a_colorfile(2) = 'white' a_colorname(3) = 'Black' a_colorfile(3) = 'black' a_colorname(4) = 'Bitmap' a_colorfile(4) = 'bitmap' a_colorname(5) = 'Grey' a_colorfile(5) = 'grey' a_colorname(6) = 'Red' a_colorfile(6) = 'red' a_colorname(7) = 'Green' a_colorfile(7) = 'green' a_colorname(8) = 'Blue' a_colorfile(8) = 'blue' a_colorname(9) = 'CMY' a_colorfile(9) = 'cmy' a_colorname(10) = 'BGW' a_colorfile(10) = 'bgw' i_colormax=10 do i=1,6 a_clickcmd(i) = ' ' end do c c Read in MDX default file c call get_mdxdefaults(a_tname,a_tcmnd,a_twait,a_nullclr,i_pcpad,i_prpad,r_winzoom, & a_workdir,a_colordir,a_colorname,a_colorfile,i_colormax,i_close,a_clickcmd) c c Read in command line c call rdf_getfields(a_cmd,i_inarg,a_inarg) if (i_inarg .eq. 0) then return else i_arg = 0 i_dat = 0 i_set = 0 i_chn = 0 i_tmp = 0 do while(i_arg .lt. i_inarg) i_arg=i_arg + 1 a_value = a_inarg(i_arg) i_int=1 do i=1,rdflen(a_value) if (index("1234567890",a_value(i:i)) .eq. 0) i_int=0 end do c write(6,*) 'i_arg,a_value=',i_arg,' ',a_value(1:60) if (a_value .eq. ' ') then ! error else if (a_value .eq. '-V') then write(6,*) ' ' write(6,'(1x,a,a18,a)' ) ' << mdx Version ',version_mdx(), ' >> ' write(6,'(1x,a,f5.1,13x,a)') ' << graphx Version ',float(version_gx()),' >> ' write(6,*) ' ' else if (a_value .eq. '-s' .or. a_value .eq. '-samples' .or. & a_value .eq. '-cols' .or. a_value .eq. '-columns') then i_arg=i_arg+1 a_value = a_inarg(i_arg) read(a_value,*) i_setcols(i_tmp) else if (i_int .eq. 1) then ! also number of columns read(a_value,*) i_setcols(i_tmp) else if (a_value .eq. '-l' .or. a_value .eq. '-lines' .or. & a_value .eq. '-rows') then i_arg=i_arg+1 a_value = a_inarg(i_arg) read(a_value,*) i_setrows(i_tmp) else if (a_value .eq. '-col' .or. a_value .eq. '-c' .or. a_value .eq. '-cpos') then i_arg=i_arg+1 a_value = a_inarg(i_arg) read(a_value,*) i_ccenter else if (a_value .eq. '-row' .or. a_value .eq. '-r' .or. a_value .eq. '-rpos') then i_arg=i_arg+1 a_value = a_inarg(i_arg) read(a_value,*) i_rcenter else if (a_value .eq. '-lat' .or. a_value .eq. '-latitude') then i_arg=i_arg+1 a_value = a_inarg(i_arg) read(a_value,*) r_lat r_lat = r_lat/r_rtod else if (a_value .eq. '-lon' .or. a_value .eq. '-longitude') then i_arg=i_arg+1 a_value = a_inarg(i_arg) read(a_value,*) r_lon r_lon = r_lon/r_rtod else if (a_value .eq. '-shdr' .or. a_value .eq. '-set_hddr') then i_arg=i_arg+1 a_value = a_inarg(i_arg) read(a_value,*) i_setshdr(i_tmp) else if (a_value .eq. '-rhdr' .or. a_value .eq. '-row_hddr') then i_arg=i_arg+1 a_value = a_inarg(i_arg) read(a_value,*) i_setrhdr(i_tmp) else if (a_value .eq. '-chdr' .or. a_value .eq. '-col_hddr') then i_arg=i_arg+1 a_value = a_inarg(i_arg) read(a_value,*) i_setchdr(i_tmp) else if (a_value .eq. '-stlr' .or. a_value .eq. '-set_tail') then i_arg=i_arg+1 a_value = a_inarg(i_arg) read(a_value,*) i_setstlr(i_tmp) else if (a_value .eq. '-rtlr' .or. a_value .eq. '-row_tail') then i_arg=i_arg+1 a_value = a_inarg(i_arg) read(a_value,*) i_setrtlr(i_tmp) else if (a_value .eq. '-ctlr' .or. a_value .eq. '-col_tail') then i_arg=i_arg+1 a_value = a_inarg(i_arg) read(a_value,*) i_setctlr(i_tmp) else if (a_value .eq. '-vfmt' .or. a_value .eq. '-val_frmt') then i_arg=i_arg+1 a_value = a_inarg(i_arg) if (i_CnvrtFmt(a_value) .gt. 0) then i_setvfmt(i_tmp) = i_CnvrtFmt(a_value) else write(6,*) '*** Warning *** Could not parse value format for set: ', & a_setname(i_tmp)(1:max(1,rdflen(a_setname(i_tmp)))), & ' ',a_value end if else if (a_value .eq. '-rmlt' .or. a_value .eq. '-row_mult') then i_arg=i_arg+1 a_value = a_inarg(i_arg) read(a_value,*) r_setrmlt(i_tmp) else if (a_value .eq. '-radr' .or. a_value .eq. '-row_addr') then i_arg=i_arg+1 a_value = a_inarg(i_arg) read(a_value,*) r_setradr(i_tmp) else if (a_value .eq. '-cmlt' .or. a_value .eq. '-col_mult') then i_arg=i_arg+1 a_value = a_inarg(i_arg) read(a_value,*) r_setcmlt(i_tmp) else if (a_value .eq. '-cadr' .or. a_value .eq. '-col_addr') then i_arg=i_arg+1 a_value = a_inarg(i_arg) read(a_value,*) r_setcadr(i_tmp) else if (a_value .eq. '-vmlt' .or. a_value .eq. '-val_mult') then i_arg=i_arg+1 a_value = a_inarg(i_arg) read(a_value,*) r_setvmlt(i_tmp) else if (a_value .eq. '-vadr' .or. a_value .eq. '-val_addr') then i_arg=i_arg+1 a_value = a_inarg(i_arg) read(a_value,*) r_setvadr(i_tmp) else if (a_value .eq. '-plat' .or. a_value .eq. '-set_plat') then i_arg=i_arg+1 a_value = a_inarg(i_arg) read(a_value,*) r_setpegv(1,i_tmp) else if (a_value .eq. '-plon' .or. a_value .eq. '-set_plon') then i_arg=i_arg+1 a_value = a_inarg(i_arg) read(a_value,*) r_setpegv(2,i_tmp) else if (a_value .eq. '-phdg' .or. a_value .eq. '-set_phdg') then i_arg=i_arg+1 a_value = a_inarg(i_arg) read(a_value,*) r_setpegv(3,i_tmp) else if (a_value .eq. '-proj' .or. a_value .eq. '-set_proj') then i_arg=i_arg+1 a_value = a_inarg(i_arg) read(a_value,*) a_setproj(i_tmp) else if (a_value .eq. '-min' .or. a_value .eq. '-vmin' .or. a_value .eq. '-minval' .or. a_value .eq. '-val_minv') & then i_arg=i_arg+1 a_value = a_inarg(i_arg) read(a_value,*) r_setvmin(i_tmp) else if (a_value .eq. '-max' .or. a_value .eq. '-vmax' .or. a_value .eq. '-maxval' .or. a_value .eq. '-val_maxv') & then i_arg=i_arg+1 a_value = a_inarg(i_arg) read(a_value,*) r_setvmax(i_tmp) else if (a_value .eq. '-e' .or. a_value .eq. '-exp') & then i_arg=i_arg+1 a_value = a_inarg(i_arg) read(a_value,*) r_dspexpn(i_tmp) else if (a_value .eq. '-clpmin' .or. a_value .eq. '-minclp') & then i_arg=i_arg+1 a_value = a_inarg(i_arg) read(a_value,*) r_dspcplw(i_tmp) else if (a_value .eq. '-clpmax' .or. a_value .eq. '-maxclp') & then i_arg=i_arg+1 a_value = a_inarg(i_arg) read(a_value,*) r_dspcphi(i_tmp) else if (a_value .eq. '-val_endi') then i_arg=i_arg+1 a_value = a_inarg(i_arg) if (a_value .eq. 'little_endian' .or. a_value .eq. 'LITTLE_ENDIAN') then i_setvend(i_tmp) = -1 else if (a_value .eq. 'big_endian' .or. a_value .eq. 'BIG_ENDIAN') then i_setvend(i_tmp) = 1 else write(6,*) '*** Warning *** Could not parse endian-ness',a_value end if else if (a_value .eq. '-bs' .or. a_value .eq. '-B' .or. a_value .eq. '-bswap') then i_setvend(i_tmp) = -i_setvend(i_tmp) else if (a_value .eq. '-LE' .or. a_value .eq. '-le' .or. a_value .eq. '-little') then i_setvend(i_tmp) = -1 else if (a_value .eq. '-BE' .or. a_value .eq. '-be' .or. a_value .eq. '-big') then i_setvend(i_tmp) = 1 else if (a_value .eq. '-D' .or. a_value .eq. '-dc' .or. a_value .eq. '-dvdc' .or. & a_value .eq. '-dx' .or. a_value .eq. '-dvdx' .or. a_value .eq. '-slope') then i_dspdvdc(i_tmp)=1 else if (a_value .eq. '-d' .or. a_value .eq. '-wrap') then i_arg=i_arg+1 a_value = a_inarg(i_arg) read(a_value,*) r_dspwrap(i_tmp) if (r_dspwrap(i_tmp) .ne. 0.0) then r_dspmult(i_tmp) = r_dspwrap(i_tmp) i_dspmult(i_tmp) = 0 i_dspaddr(i_tmp) = 0 i_dspmode(i_tmp) = 6 end if else if (a_value .eq. '-a' .or. a_value .eq. '-addr' .or. & a_value .eq. '-add' .or. a_value .eq. '-daddr') then i_arg=i_arg+1 a_value = a_inarg(i_arg) read(a_value,*) r_dspaddr(i_tmp) i_dspaddr(i_tmp) = 0 else if (a_value .eq. '-m' .or. a_value .eq. '-mult' .or. a_value .eq. '-dmult') then i_arg=i_arg+1 a_value = a_inarg(i_arg) read(a_value,*) r_dspmult(i_tmp) i_dspmult(i_tmp) = 0 i_dspmode(i_tmp) = 1 else if (a_value .eq. '-f' .or. a_value .eq. '-fact' .or. a_value .eq. '-sdev') then i_arg=i_arg+1 a_value = a_inarg(i_arg) read(a_value,*) r_dspval1(i_tmp) i_dspmult(i_tmp) = 1 i_dspmode(i_tmp) = 2 else if (a_value .eq. '-p' .or. a_value .eq. '-percent' .or. a_value .eq. '-%') then i_arg=i_arg+1 a_value = a_inarg(i_arg) read(a_value,*) r_dspval2(i_tmp) i_dspmult(i_tmp) = 1 i_dspmode(i_tmp) = 3 else if (a_value .eq. '-cw' .or. a_value .eq. '-cws' .or. a_value .eq. '-charlie') then i_arg=i_arg+1 a_value = a_inarg(i_arg) read(a_value,*) r_dspval3(i_tmp) i_dspmult(i_tmp) = 1 i_dspmode(i_tmp) = 5 else if (a_value .eq. '-SDEV' ) then r_dspval1(i_tmp) = 2 i_dspmult(i_tmp) = 1 i_dspaddr(i_tmp) = 1 i_dspmode(i_tmp) = 2 else if (a_value .eq. '-PER' ) then r_dspval2(i_tmp) = 90 i_dspmult(i_tmp) = 1 i_dspmode(i_tmp) = 3 else if (a_value .eq. '-CW' ) then r_dspval3(i_tmp) = 1 i_dspmult(i_tmp) = 1 i_dspaddr(i_tmp) = 0 i_dspmode(i_tmp) = 5 r_dspaddr(i_tmp) = 0. else if (a_value .eq. '-WRAP' ) then i_dspmode(i_tmp) = 6 r_dspwrap(i_tmp) = r_pi i_dspaddr(i_tmp) = 0 r_dspaddr(i_tmp) = 0. else if (a_value .eq. '-z' .or. a_value .eq. '-zoom') then i_arg=i_arg+1 a_value = a_inarg(i_arg) read(a_value,*) r_winzoom(1) if (r_winzoom(1) .lt. 0.) r_winzoom(1) = abs(1./r_winzoom(1)) else if (a_value .eq. '-pz' .or. a_value .eq. '-pzoom') then i_arg=i_arg+1 a_value = a_inarg(i_arg) read(a_value,*) r_winzoom(0) if (r_winzoom(0) .lt. 0.) r_winzoom(0) = abs(1./r_winzoom(0)) else if (a_value .eq. '-vx' .or. a_value .eq. '-vxsize') then i_arg=i_arg+1 a_value = a_inarg(i_arg) read(a_value,*) i_winx else if (a_value .eq. '-vy' .or. a_value .eq. '-vysize') then i_arg=i_arg+1 a_value = a_inarg(i_arg) read(a_value,*) i_winy else if (a_value .eq. '-pcpad' .or. a_value .eq. '-pc') then i_arg=i_arg+1 a_value = a_inarg(i_arg) read(a_value,*) i_pcpad else if (a_value .eq. '-prpad' .or. a_value .eq. '-pr') then i_arg=i_arg+1 a_value = a_inarg(i_arg) read(a_value,*) i_prpad else if (a_value .eq. '-mix') then i_arg=i_arg+1 a_value = a_inarg(i_arg) if (a_value .eq. '+') then i_dspmixv(i_tmp) = 1 else if (a_value .eq. 'x' .or. a_value .eq. 'X') then i_dspmixv(i_tmp) = 2 else read(a_value,*) i_dspmixv(i_tmp) end if else if (a_value .eq. '-cmap' .or. a_value .eq. '-ctable') then i_arg=i_arg+1 a_dspctbl(i_tmp)=a_inarg(i_arg) do i=1,i_colormax if (a_dspctbl(i_tmp) .eq. a_colorname(i)) a_dspctbl(i_tmp)=a_colorfile(i) end do else if (a_value .eq. '-null') then i_arg=i_arg+1 a_setvnul(i_tmp)=a_inarg(i_arg) else if (a_value .eq. '-nc' .or. a_value .eq. '-null_color' .or & . a_value .eq. '-cnull') then i_arg=i_arg+1 a_nullclr = a_inarg(i_arg) else if (a_value .eq. '-lc' .or. a_value .eq. '-line_color' .or & . a_value .eq. '-cline') then i_arg=i_arg+1 a_lcolor = a_inarg(i_arg) else if (a_value .eq. '-workdir' .or. a_value .eq. '-work_dir') then i_arg=i_arg+1 a_workdir = a_inarg(i_arg) i_cnt=rdflen(a_workdir) if (a_workdir(i_cnt:i_cnt) .ne. '/') a_workdir=a_workdir(1:i_cnt)//'/' else if (a_value .eq. '-colordir' .or. a_value .eq. '-color_dir') then i_arg=i_arg+1 a_colordir = a_inarg(i_arg) i_cnt=rdflen(a_colordir) if (a_colordir(i_cnt:i_cnt) .ne. '/') a_colordir=a_colordir(1:i_cnt)//'/' else if (a_value .eq. '-emod') then i_arg=i_arg+1 a_value = a_inarg(i_arg) read(a_value,*) i_eventmod i_eventmod = max(1,min(1000,i_eventmod)) else if (a_value .eq. '-debug') then i_arg=i_arg+1 a_value = a_inarg(i_arg) read(a_value,*) i_debug else if (a_value .eq. '-points' .or. a_value .eq. '-pts') then i_arg=i_arg+1 a_ptsfile = a_inarg(i_arg) i_smode = 0 i_show = 1 i_event(0) = 1 ! Display i_event(1) = 0 ! Window i_event(2) = 12 ! Event i_event(3) = 0 i_event(4) = 0 i_event(5) = 43 i_event(6) = -1 c write(6,*) 'i_bcnt2 =',i_bcnt call buffer_cmd(i_event,i_bdat,i_bcnt,2,I_BMAX,i_abort,i_debug) else if (a_value .eq. '-click' .or. a_value .eq. '-clk') then i_arg=i_arg+1 a_clickcmd(1) = a_inarg(i_arg) else if (a_value .eq. '-ON' .or. a_value .eq. '-on') then i_dspactv(1,i_tmp) = 1 else if (a_value .eq. '-OFF' .or. a_value .eq. '-off') then i_dspactv(1,i_tmp) = 0 else if (a_value .eq. '-active') then i_arg=i_arg+1 a_value = a_inarg(i_arg) do i=1,I_CMAX if (a_value(i:i) .eq. '1') then i_dspactv(1,i) = 1 else if (a_value(i:i) .eq. '0') then i_dspactv(1,i) = 0 end if end do else if (a_value .eq. '-P' .or. a_value .eq. '-ponly') then i_ponly = 1 else if (a_value .eq. '-NM' .or. a_value .eq. '-nomenu') then i_menu = 0 else if (a_value .eq. '-M' .or. a_value .eq. '-menu') then i_menu = 1 else if (a_value .eq. '-NC' .or. a_value .eq. '-NOCLOSE') then i_close = 0 else if (a_value .eq. '-C' .or. a_value .eq. '-CLOSE') then i_close = 1 else if (a_value .eq. '-SRTM' .or. a_value .eq. '-srtm' .or. a_value .eq. '-SRTM30') then a_setname(-i_dat) = 'SRTM-dte' i_setchdr(-i_dat) = 0 i_setctlr(-i_dat) = 0 i_setvfmt(-i_dat) = 2 i_setcols(-i_dat) = 3601 i_setrows(-i_dat) = 3601 else if (a_value .eq. '-c8' .or. a_value .eq. '-complex*8') then a_setname(-i_dat) = 'C8-Mag C8-Pha' i_setchdr(-i_dat) = 0 i_setctlr(-i_dat) = 0 i_setvfmt(-i_dat) = 6 else if (a_value .eq. '-c2' .or. a_value .eq. '-complex*2') then a_setname(-i_dat) = 'C2-Mag C2-Pha' i_setchdr(-i_dat) = 0 i_setctlr(-i_dat) = 0 i_setvfmt(-i_dat) = 10 else if (a_value .eq. '-c4' .or. a_value .eq. '-complex*4') then a_setname(-i_dat) = 'C4-Mag C4-Pha' i_setchdr(-i_dat) = 0 i_setctlr(-i_dat) = 0 i_setvfmt(-i_dat) = 12 else if (a_value .eq. '-c8iq' .or. a_value .eq. '-complex*8iq') then a_setname(-i_dat) = 'C8-I C8-Q' i_setchdr(-i_dat) = 0 i_setctlr(-i_dat) = 0 i_setvfmt(-i_dat) = 6 else if (a_value .eq. '-rmg' ) then a_setname(-i_dat) = 'RMG-Mag RMG-Hgt' i_setrhdr(-i_dat) = 0 i_setrtlr(-i_dat) = 0 i_setvfmt(-i_dat) = 4 else if (a_value .eq. '-rmgi' ) then a_setname(-i_dat) = 'RMG-Mag RMG-Pha' i_setrhdr(-i_dat) = 0 i_setrtlr(-i_dat) = 0 i_setvfmt(-i_dat) = 4 else if (a_value .eq. '-b1' .or. a_value .eq. '-byte' .or. a_value .eq. '-b') then i_setvfmt(i_tmp) = 0 else if (a_value .eq. '-i1' .or. a_value .eq. '-integer*1') then i_setvfmt(i_tmp) = 1 else if (a_value .eq. '-i2' .or. a_value .eq. '-integer*2' .or. a_value .eq. '-si2') then i_setvfmt(i_tmp) = 2 else if (a_value .eq. '-i4' .or. a_value .eq. '-integer*4') then i_setvfmt(i_tmp) = 3 else if (a_value .eq. '-r4' .or. a_value .eq. '-real*4') then i_setvfmt(i_tmp) = 4 else if (a_value .eq. '-r8' .or. a_value .eq. '-real*8') then i_setvfmt(i_tmp) = 5 else if (a_value .eq. '-c8mag' .or. a_value .eq. 'cmag') then i_setvfmt(i_tmp) = 6 else if (a_value .eq. '-c8pha' .or. a_value .eq. 'cpha') then i_setvfmt(i_tmp) = 7 else if (a_value .eq. '-b2' .or. a_value .eq. '-byte*2' .or. a_value .eq. '-byte2') then i_setvfmt(i_tmp) = 8 else if (a_value .eq. '-stokes11' .or. a_value .eq. '-compressed_stokes') then i_setvfmt(i_tmp) = 9 else if (a_value .eq. '-c2mag') then i_setvfmt(i_tmp) = 10 else if (a_value .eq. '-c2pha') then i_setvfmt(i_tmp) = 11 else if (a_value .eq. '-c4mag') then i_setvfmt(i_tmp) = 12 else if (a_value .eq. '-c4pha') then i_setvfmt(i_tmp) = 13 else if (a_value .eq. '-r4mag' .or. a_value .eq. '-real*4_mag') then i_setvfmt(i_tmp) = 14 else if (a_value .eq. '-h' .or. a_value .eq. '-hdr') then i_arg=i_arg+1 a_setinfo(i_tmp)=a_inarg(i_arg) a_nullstr=' ' call get_setinfo( a_nullstr, & a_setinfo(i_tmp), & a_setproj(i_tmp), & i_setunit(i_tmp), & i_setrows(i_tmp), & i_setcols(i_tmp), & i_setshdr(i_tmp), & i_setstlr(i_tmp), & i_setrhdr(i_tmp), & i_setrtlr(i_tmp), & i_setchdr(i_tmp), & i_setctlr(i_tmp), & i_setvend(i_tmp), & i_setvfmt(i_tmp), & r_setvmlt(i_tmp), & r_setvadr(i_tmp), & r_setvmin(i_tmp), & r_setvmax(i_tmp), & a_setvnul(i_tmp), & r_setrmlt(i_tmp), & r_setradr(i_tmp), & r_setcmlt(i_tmp), & r_setcadr(i_tmp), & r_setpegv(1,i_tmp), & r_dspaddr(i_tmp), & r_dspmult(i_tmp), & r_dspwrap(i_tmp), & r_dspexpn(i_tmp), & r_dspcplw(i_tmp), & r_dspcphi(i_tmp), & r_dspval1(i_tmp), & r_dspval2(i_tmp), & r_dspval3(i_tmp), & i_dspmode(i_tmp), & i_dspaddr(i_tmp), & i_dspmult(i_tmp), & i_dspmixv(i_tmp), & i_dspdvdc(i_tmp), & a_dspctbl(i_tmp) ) call get_setinfo( a_setname(i_tmp), & a_setinfo(i_tmp), & a_setproj(i_tmp), & i_setunit(i_tmp), & i_setrows(i_tmp), & i_setcols(i_tmp), & i_setshdr(i_tmp), & i_setstlr(i_tmp), & i_setrhdr(i_tmp), & i_setrtlr(i_tmp), & i_setchdr(i_tmp), & i_setctlr(i_tmp), & i_setvend(i_tmp), & i_setvfmt(i_tmp), & r_setvmlt(i_tmp), & r_setvadr(i_tmp), & r_setvmin(i_tmp), & r_setvmax(i_tmp), & a_setvnul(i_tmp), & r_setrmlt(i_tmp), & r_setradr(i_tmp), & r_setcmlt(i_tmp), & r_setcadr(i_tmp), & r_setpegv(1,i_tmp), & r_dspaddr(i_tmp), & r_dspmult(i_tmp), & r_dspwrap(i_tmp), & r_dspexpn(i_tmp), & r_dspcplw(i_tmp), & r_dspcphi(i_tmp), & r_dspval1(i_tmp), & r_dspval2(i_tmp), & r_dspval3(i_tmp), & i_dspmode(i_tmp), & i_dspaddr(i_tmp), & i_dspmult(i_tmp), & i_dspmixv(i_tmp), & i_dspdvdc(i_tmp), & a_dspctbl(i_tmp) ) else if (a_value .eq. '-top' .or. a_value .eq. '-air' .or. a_value .eq. '-maghdr' .or. a_value .eq. '-dtehdr') then i_arg=i_arg+1 a_hdrfile=a_inarg(i_arg) i_mbytes=4 a_type='sch' r_mmul=1.0 r_madd=0.0 r_dmul=1.0 r_dadd=0.0 call read_hdr(a_hdrfile,i_lsize,i_ssize,r_peg,a_type, & r_str,r_spc,i_mbytes,i_dbytes,r_mmul,r_madd, & r_dmul,r_dadd,i_err) a_setinfo(i_tmp) = ' ' a_setproj(i_tmp) = a_type i_setunit(i_tmp) = 0 i_setrows(i_tmp) = i_lsize i_setcols(i_tmp) = i_ssize i_setshdr(i_tmp) = 0 i_setstlr(i_tmp) = 0 i_setrhdr(i_tmp) = 0 i_setrtlr(i_tmp) = 0 i_setchdr(i_tmp) = 0 i_setctlr(i_tmp) = 0 if (a_value .eq. '-maghdr') then if (i_mbytes .eq. 1) then i_setvfmt(i_tmp) = i_CnvrtFmt('BYTE') else if (i_mbytes .eq. 2) then i_setvfmt(i_tmp) = i_CnvrtFmt('BYTE*2') else if (i_mbytes .eq. 4) then i_setvfmt(i_tmp) = i_CnvrtFmt('REAL*4') else i_setvfmt(i_tmp) = i_CnvrtFmt('REAL*4') end if r_setvmlt(i_tmp) = r_mmul r_setvadr(i_tmp) = r_madd else if (i_dbytes .eq. 1) then i_setvfmt(i_tmp) = i_CnvrtFmt('BYTE') else if (i_dbytes .eq. 2) then i_setvfmt(i_tmp) = i_CnvrtFmt('BYTE*2') else if (i_dbytes .eq. 4) then i_setvfmt(i_tmp) = i_CnvrtFmt('REAL*4') else i_setvfmt(i_tmp) = i_CnvrtFmt('REAL*4') end if r_setvmlt(i_tmp) = r_dmul r_setvadr(i_tmp) = r_dadd end if c r_setvmin(i_tmp) = c r_setvmax(i_tmp) = c a_setvnul(i_tmp) = r_setrmlt(i_tmp) = r_spc(1) r_setradr(i_tmp) = r_str(1)+r_spc(1) r_setcmlt(i_tmp) = r_spc(2) r_setcadr(i_tmp) = r_str(2)+r_spc(2) r_setpegv(1,i_tmp) = r_peg(1) r_setpegv(2,i_tmp) = r_peg(2) r_setpegv(3,i_tmp) = r_peg(3) if (a_setfile(i_tmp) .ne. ' ') then if(a_setname(i_tmp) .eq. ' ') write(a_setname(i_tmp),'(a,i1)') 'Set_',abs(i_tmp) a_setinfo(i_tmp) = a_setfile(i_tmp)(1:max(1,rdflen(a_setfile(i_tmp))))//'.mdx' call put_setinfo(a_setname(i_tmp), & a_setinfo(i_tmp), & a_setproj(i_tmp), & i_setunit(i_tmp), & i_setrows(i_tmp), & i_setcols(i_tmp), & i_setshdr(i_tmp), & i_setstlr(i_tmp), & i_setrhdr(i_tmp), & i_setrtlr(i_tmp), & i_setchdr(i_tmp), & i_setctlr(i_tmp), & i_setvend(i_tmp), & i_setvfmt(i_tmp), & r_setvmlt(i_tmp), & r_setvadr(i_tmp), & r_setvmin(i_tmp), & r_setvmax(i_tmp), & a_setvnul(i_tmp), & r_setrmlt(i_tmp), & r_setradr(i_tmp), & r_setcmlt(i_tmp), & r_setcadr(i_tmp), & r_setpegv(1,i_tmp) ) end if else if (a_value .eq. '-set') then i_arg=i_arg+1 a_value = a_inarg(i_arg) i_chn = i_chn + 1 if (i_dat .gt. 0) then i_set = min(i_set + 1,I_CMAX) i_tmp = i_set call copy_setdata(-i_dat,i_tmp, & i_setunit,i_setrows,i_setcols, & a_setname,a_setfile,a_setinfo,a_setproj, & i_setshdr,i_setstlr,i_setrhdr,i_setrtlr,i_setchdr,i_setctlr, & r_setrmlt,r_setradr,r_setcmlt,r_setcadr,r_setvmlt,r_setvadr, & i_setvend,i_setvfmt,r_setvmin,r_setvmax,a_setvnul,r_setpegv) call copy_dspdata(-i_dat,i_tmp, & r_dspaddr,r_dspmult,r_dspwrap,r_dspexpn,r_dspcplw,r_dspcphi, & r_dspval1,r_dspval2,r_dspval3,i_dspmode,i_dspaddr,i_dspmult,i_dspmixv, & a_dspctbl,i_dspdvdc) i_dspactv(1,i_tmp) = i_dspactv(1,-i_dat) a_setname(i_tmp) = a_value if (a_setinfo(i_tmp) .eq. ' ' ) then a_setinfo(i_tmp)=a_setfile(i_tmp & )(1:rdflen(a_setfile(i_tmp)))//'.mdx' end if c type *,'looking1 at ',a_setinfo(i_tmp),' ',i_tmp call get_setinfo( a_setname(i_tmp), & a_setinfo(i_tmp), & a_setproj(i_tmp), & i_setunit(i_tmp), & i_setrows(i_tmp), & i_setcols(i_tmp), & i_setshdr(i_tmp), & i_setstlr(i_tmp), & i_setrhdr(i_tmp), & i_setrtlr(i_tmp), & i_setchdr(i_tmp), & i_setctlr(i_tmp), & i_setvend(i_tmp), & i_setvfmt(i_tmp), & r_setvmlt(i_tmp), & r_setvadr(i_tmp), & r_setvmin(i_tmp), & r_setvmax(i_tmp), & a_setvnul(i_tmp), & r_setrmlt(i_tmp), & r_setradr(i_tmp), & r_setcmlt(i_tmp), & r_setcadr(i_tmp), & r_setpegv(1,i_tmp), & r_dspaddr(i_tmp), & r_dspmult(i_tmp), & r_dspwrap(i_tmp), & r_dspexpn(i_tmp), & r_dspcplw(i_tmp), & r_dspcphi(i_tmp), & r_dspval1(i_tmp), & r_dspval2(i_tmp), & r_dspval3(i_tmp), & i_dspmode(i_tmp), & i_dspaddr(i_tmp), & i_dspmult(i_tmp), & i_dspmixv(i_tmp), & i_dspdvdc(i_tmp), & a_dspctbl(i_tmp) ) else if (i_set .eq. 1) then a_setname(0) = a_value else a_setname(0) = & a_setname(0)(1:max(1,rdflen(a_setname(0))))//' & '//a_value end if end if else if (a_value(1:1) .eq. '-' .and. a_value .ne. '-file') then ! implicit set name a_value = a_value(2:) i_chn = i_chn + 1 if (i_dat .gt. 0) then i_set = min(i_set + 1,I_CMAX) i_tmp = i_set call copy_setdata(-i_dat,i_tmp, & i_setunit,i_setrows,i_setcols, & a_setname,a_setfile,a_setinfo,a_setproj, & i_setshdr,i_setstlr,i_setrhdr,i_setrtlr,i_setchdr,i_setctlr, & r_setrmlt,r_setradr,r_setcmlt,r_setcadr,r_setvmlt,r_setvadr, & i_setvend,i_setvfmt,r_setvmin,r_setvmax,a_setvnul,r_setpegv) call copy_dspdata(-i_dat,i_tmp, & r_dspaddr,r_dspmult,r_dspwrap,r_dspexpn,r_dspcplw,r_dspcphi, & r_dspval1,r_dspval2,r_dspval3,i_dspmode,i_dspaddr,i_dspmult,i_dspmixv, & a_dspctbl,i_dspdvdc) i_dspactv(1,i_tmp) = i_dspactv(1,-i_dat) a_setname(i_tmp) = a_value if (a_setinfo(i_tmp) .eq. ' ' ) then a_setinfo(i_tmp)=a_setfile(i_tmp & )(1:rdflen(a_setfile(i_tmp)))//'.mdx' end if call get_setinfo( a_setname(i_tmp), & a_setinfo(i_tmp), & a_setproj(i_tmp), & i_setunit(i_tmp), & i_setrows(i_tmp), & i_setcols(i_tmp), & i_setshdr(i_tmp), & i_setstlr(i_tmp), & i_setrhdr(i_tmp), & i_setrtlr(i_tmp), & i_setchdr(i_tmp), & i_setctlr(i_tmp), & i_setvend(i_tmp), & i_setvfmt(i_tmp), & r_setvmlt(i_tmp), & r_setvadr(i_tmp), & r_setvmin(i_tmp), & r_setvmax(i_tmp), & a_setvnul(i_tmp), & r_setrmlt(i_tmp), & r_setradr(i_tmp), & r_setcmlt(i_tmp), & r_setcadr(i_tmp), & r_setpegv(1,i_tmp), & r_dspaddr(i_tmp), & r_dspmult(i_tmp), & r_dspwrap(i_tmp), & r_dspexpn(i_tmp), & r_dspcplw(i_tmp), & r_dspcphi(i_tmp), & r_dspval1(i_tmp), & r_dspval2(i_tmp), & r_dspval3(i_tmp), & i_dspmode(i_tmp), & i_dspaddr(i_tmp), & i_dspmult(i_tmp), & i_dspmixv(i_tmp), & i_dspdvdc(i_tmp), & a_dspctbl(i_tmp) ) else if (i_set .eq. 1) then a_setname(0) = a_value else a_setname(0) = & a_setname(0)(1:max(1,rdflen(a_setname(0))))//' & '//a_value end if end if else if (a_value .eq. '-file') then i_arg=i_arg+1 a_value = a_inarg(i_arg) end if c write(6,*) 'a_value=',a_value,i_dat,i_chn !@#$% if (i_dat .gt. 0 .and. i_chn .eq. 0) then ! last file had no sets specified if (a_setname(-i_dat) .eq. ' ') then a_label = a_setfile(-i_dat) if (a_label(1:1) .ne. '=') then do while(max(index(a_label,'/'),index(a_label,'.')) .gt. 0 .and. & max(index(a_label,'/'),index(a_label,'.')) .lt. rdflen(a_label)-1) a_label = a_label(max(index(a_label,'/'),index(a_label,'.'))+1:) end do end if a_setname(-i_dat) = a_label end if c write(6,*) 'i_dat=',i_dat c write(6,*) 'a_setname=',a_setname(-i_dat) !@#$% call rdf_getfields(a_setname(-i_dat),i_sss,a_sss) do i_chn=1,i_sss i_set = min(i_set + 1,I_CMAX) i_tmp = i_set call copy_setdata(-i_dat,i_tmp, & i_setunit,i_setrows,i_setcols, & a_setname,a_setfile,a_setinfo,a_setproj, & i_setshdr,i_setstlr,i_setrhdr,i_setrtlr,i_setchdr,i_setctlr, & r_setrmlt,r_setradr,r_setcmlt,r_setcadr,r_setvmlt,r_setvadr, & i_setvend,i_setvfmt,r_setvmin,r_setvmax,a_setvnul,r_setpegv) call copy_dspdata(-i_dat,i_tmp, & r_dspaddr,r_dspmult,r_dspwrap,r_dspexpn,r_dspcplw,r_dspcphi, & r_dspval1,r_dspval2,r_dspval3,i_dspmode,i_dspaddr,i_dspmult,i_dspmixv, & a_dspctbl,i_dspdvdc) a_setname(i_tmp) = a_sss(i_chn) i_dspactv(1,i_tmp) = i_dspactv(1,-i_dat) if (a_setinfo(i_tmp) .eq. ' ' ) then a_setinfo(i_tmp)=a_setfile(i_tmp & )(1:rdflen(a_setfile(i_tmp)))//'.mdx' end if c write(6,*) 'i_chn=',i_chn,i_tmp !@#$% call get_setinfo(a_setname(i_tmp), & a_setinfo(i_tmp), & a_setproj(i_tmp), & i_setunit(i_tmp), & i_setrows(i_tmp), & i_setcols(i_tmp), & i_setshdr(i_tmp), & i_setstlr(i_tmp), & i_setrhdr(i_tmp), & i_setrtlr(i_tmp), & i_setchdr(i_tmp), & i_setctlr(i_tmp), & i_setvend(i_tmp), & i_setvfmt(i_tmp), & r_setvmlt(i_tmp), & r_setvadr(i_tmp), & r_setvmin(i_tmp), & r_setvmax(i_tmp), & a_setvnul(i_tmp), & r_setrmlt(i_tmp), & r_setradr(i_tmp), & r_setcmlt(i_tmp), & r_setcadr(i_tmp), & r_setpegv(1,i_tmp), & r_dspaddr(i_tmp), & r_dspmult(i_tmp), & r_dspwrap(i_tmp), & r_dspexpn(i_tmp), & r_dspcplw(i_tmp), & r_dspcphi(i_tmp), & r_dspval1(i_tmp), & r_dspval2(i_tmp), & r_dspval3(i_tmp), & i_dspmode(i_tmp), & i_dspaddr(i_tmp), & i_dspmult(i_tmp), & i_dspmixv(i_tmp), & i_dspdvdc(i_tmp), & a_dspctbl(i_tmp) ) end do end if i_dat = i_dat+1 i_tmp = -i_dat i_chn = 0 c write(6,*) 'hello=',i_dat,i_tmp,i_chn !@#$% call copy_setdata(0,i_tmp, & i_setunit,i_setrows,i_setcols, & a_setname,a_setfile,a_setinfo,a_setproj, & i_setshdr,i_setstlr,i_setrhdr,i_setrtlr,i_setchdr,i_setctlr, & r_setrmlt,r_setradr,r_setcmlt,r_setcadr,r_setvmlt,r_setvadr, & i_setvend,i_setvfmt,r_setvmin,r_setvmax,a_setvnul,r_setpegv) call copy_dspdata(0,i_tmp, & r_dspaddr,r_dspmult,r_dspwrap,r_dspexpn,r_dspcplw,r_dspcphi, & r_dspval1,r_dspval2,r_dspval3,i_dspmode,i_dspaddr,i_dspmult,i_dspmixv, & a_dspctbl,i_dspdvdc) i_dspactv(1,i_tmp) = i_dspactv(1,0) a_setfile(i_tmp) = a_value c write(6,*) 'hello2=',i_dat,i_tmp,i_chn !@#$% c write(6,*) 'hello3=',a_setinfo(i_tmp) !@#$% if (a_setinfo(i_tmp) .eq. ' ' .and. a_setfile(i_tmp)(1:1) .ne. '=' .and. a_setfile(i_tmp) .ne. 'internal') then a_setinfo(i_tmp)=a_setfile(i_tmp & )(1:rdflen(a_setfile(i_tmp)))//'.mdx' c write(6,*) 'openning=',a_setname(i_tmp) !@#$% call get_airsarinfo( a_setname(i_tmp), ! Only executes if no header is specified & a_setfile(i_tmp), & a_setproj(i_tmp), & i_setunit(i_tmp), & i_setrows(i_tmp), & i_setcols(i_tmp), & i_setshdr(i_tmp), & i_setstlr(i_tmp), & i_setrhdr(i_tmp), & i_setrtlr(i_tmp), & i_setchdr(i_tmp), & i_setctlr(i_tmp), & i_setvend(i_tmp), & i_setvfmt(i_tmp), & r_setvmlt(i_tmp), & r_setvadr(i_tmp), & r_setvmin(i_tmp), & r_setvmax(i_tmp), & a_setvnul(i_tmp), & r_setrmlt(i_tmp), & r_setradr(i_tmp), & r_setcmlt(i_tmp), & r_setcadr(i_tmp), & r_setpegv(1,i_tmp), & a_dspctbl(i_tmp) ) c write(6,*) 'openning1=',a_setname(i_tmp) !@#$% call get_pdsinfo( a_setname(i_tmp), ! Only executes if no header is specified & a_setfile(i_tmp), & a_setproj(i_tmp), & i_setunit(i_tmp), & i_setrows(i_tmp), & i_setcols(i_tmp), & i_setshdr(i_tmp), & i_setstlr(i_tmp), & i_setrhdr(i_tmp), & i_setrtlr(i_tmp), & i_setchdr(i_tmp), & i_setctlr(i_tmp), & i_setvend(i_tmp), & i_setvfmt(i_tmp), & r_setvmlt(i_tmp), & r_setvadr(i_tmp), & r_setvmin(i_tmp), & r_setvmax(i_tmp), & a_setvnul(i_tmp), & r_setrmlt(i_tmp), & r_setradr(i_tmp), & r_setcmlt(i_tmp), & r_setcadr(i_tmp), & r_setpegv(1,i_tmp), & a_dspctbl(i_tmp) , i_debug ) c write(6,*) 'openning2=',a_setname(i_tmp) !@#$% call get_cubinfo( a_setname(i_tmp), ! Only executes if no header is specified & a_setfile(i_tmp), & a_setproj(i_tmp), & i_setunit(i_tmp), & i_setrows(i_tmp), & i_setcols(i_tmp), & i_setshdr(i_tmp), & i_setstlr(i_tmp), & i_setrhdr(i_tmp), & i_setrtlr(i_tmp), & i_setchdr(i_tmp), & i_setctlr(i_tmp), & i_setvend(i_tmp), & i_setvfmt(i_tmp), & r_setvmlt(i_tmp), & r_setvadr(i_tmp), & r_setvmin(i_tmp), & r_setvmax(i_tmp), & a_setvnul(i_tmp), & r_setrmlt(i_tmp), & r_setradr(i_tmp), & r_setcmlt(i_tmp), & r_setcadr(i_tmp), & r_setpegv(1,i_tmp), & a_dspctbl(i_tmp) , i_debug ) end if c write(6,*) 'openning3=',a_setinfo(i_tmp) !@#$% call get_setinfo( a_setname(i_tmp), & a_setinfo(i_tmp), & a_setproj(i_tmp), & i_setunit(i_tmp), & i_setrows(i_tmp), & i_setcols(i_tmp), & i_setshdr(i_tmp), & i_setstlr(i_tmp), & i_setrhdr(i_tmp), & i_setrtlr(i_tmp), & i_setchdr(i_tmp), & i_setctlr(i_tmp), & i_setvend(i_tmp), & i_setvfmt(i_tmp), & r_setvmlt(i_tmp), & r_setvadr(i_tmp), & r_setvmin(i_tmp), & r_setvmax(i_tmp), & a_setvnul(i_tmp), & r_setrmlt(i_tmp), & r_setradr(i_tmp), & r_setcmlt(i_tmp), & r_setcadr(i_tmp), & r_setpegv(1,i_tmp), & r_dspaddr(i_tmp), & r_dspmult(i_tmp), & r_dspwrap(i_tmp), & r_dspexpn(i_tmp), & r_dspcplw(i_tmp), & r_dspcphi(i_tmp), & r_dspval1(i_tmp), & r_dspval2(i_tmp), & r_dspval3(i_tmp), & i_dspmode(i_tmp), & i_dspaddr(i_tmp), & i_dspmult(i_tmp), & i_dspmixv(i_tmp), & i_dspdvdc(i_tmp), & a_dspctbl(i_tmp) ) c write(6,*) 'set name = ',a_setname(i_tmp) end if !@#$% end do end if if (i_dat .gt. 0 .and. i_chn .eq. 0) then ! last file had no sets specified if (a_setname(-i_dat) .eq. ' ') then a_label = a_setfile(-i_dat) if (a_label(1:1) .ne. '=') then do while(max(index(a_label,'/'),index(a_label,'.')) .gt. 0 .and. & max(index(a_label,'/'),index(a_label,'.')) .lt. rdflen(a_label)-1) a_label = a_label(max(index(a_label,'/'),index(a_label,'.'))+1:) end do end if a_setname(-i_dat) = a_label end if if (a_setname(-i_dat) .eq. ' ') then write(a_setname(-i_dat),'(a,i2)') 'Set ',i_dat end if call rdf_getfields(a_setname(-i_dat),i_sss,a_sss) do i_chn=1,i_sss i_set = min(i_set + 1,I_CMAX) i_tmp = i_set call copy_setdata(-i_dat,i_tmp, & i_setunit,i_setrows,i_setcols, & a_setname,a_setfile,a_setinfo,a_setproj, & i_setshdr,i_setstlr,i_setrhdr,i_setrtlr,i_setchdr,i_setctlr, & r_setrmlt,r_setradr,r_setcmlt,r_setcadr,r_setvmlt,r_setvadr, & i_setvend,i_setvfmt,r_setvmin,r_setvmax,a_setvnul,r_setpegv) call copy_dspdata(-i_dat,i_tmp, & r_dspaddr,r_dspmult,r_dspwrap,r_dspexpn,r_dspcplw,r_dspcphi, & r_dspval1,r_dspval2,r_dspval3,i_dspmode,i_dspaddr,i_dspmult,i_dspmixv, & a_dspctbl,i_dspdvdc) i_dspactv(1,i_tmp) = i_dspactv(1,-i_dat) a_setname(i_tmp) = a_sss(i_chn) if (a_setinfo(i_tmp) .eq. ' ' ) then a_setinfo(i_tmp)=a_setfile(i_tmp & )(1:rdflen(a_setfile(i_tmp)))//'.mdx' end if call get_setinfo( a_setname(i_tmp), & a_setinfo(i_tmp), & a_setproj(i_tmp), & i_setunit(i_tmp), & i_setrows(i_tmp), & i_setcols(i_tmp), & i_setshdr(i_tmp), & i_setstlr(i_tmp), & i_setrhdr(i_tmp), & i_setrtlr(i_tmp), & i_setchdr(i_tmp), & i_setctlr(i_tmp), & i_setvend(i_tmp), & i_setvfmt(i_tmp), & r_setvmlt(i_tmp), & r_setvadr(i_tmp), & r_setvmin(i_tmp), & r_setvmax(i_tmp), & a_setvnul(i_tmp), & r_setrmlt(i_tmp), & r_setradr(i_tmp), & r_setcmlt(i_tmp), & r_setcadr(i_tmp), & r_setpegv(1,i_tmp), & r_dspaddr(i_tmp), & r_dspmult(i_tmp), & r_dspwrap(i_tmp), & r_dspexpn(i_tmp), & r_dspcplw(i_tmp), & r_dspcphi(i_tmp), & r_dspval1(i_tmp), & r_dspval2(i_tmp), & r_dspval3(i_tmp), & i_dspmode(i_tmp), & i_dspaddr(i_tmp), & i_dspmult(i_tmp), & i_dspmixv(i_tmp), * i_dspdvdc(i_tmp), & a_dspctbl(i_tmp) ) end do end if do i_chn = 1,i_set ! In order to make the -c8 option work correctly if (a_setname(i_chn) .eq. 'C8-Mag') then i_setvfmt(i_chn) = 6 else if (a_setname(i_chn) .eq. 'C8-Pha') then i_setvfmt(i_chn) = 7 r_dspwrap(i_chn) = 2.0d0*r_pi i_dspmode(i_chn) = 6 a_dspctbl(i_chn) = 'cmy' else if (a_setname(i_chn) .eq. 'C8-I') then i_setvfmt(i_chn) = 4 i_setchdr(i_chn) = 0 i_setctlr(i_chn) = 4 else if (a_setname(i_chn) .eq. 'C8-Q') then i_setvfmt(i_chn) = 4 i_setchdr(i_chn) = 4 i_setctlr(i_chn) = 0 else if (a_setname(i_chn) .eq. 'C2-Mag') then i_setvfmt(i_chn) = 10 else if (a_setname(i_chn) .eq. 'C2-Pha') then i_setvfmt(i_chn) = 11 r_dspwrap(i_chn) = 2.0d0*r_pi i_dspmode(i_chn) = 6 a_dspctbl(i_chn) = 'cmy' else if (a_setname(i_chn) .eq. 'C4-Mag') then i_setvfmt(i_chn) = 12 else if (a_setname(i_chn) .eq. 'C4-Pha') then i_setvfmt(i_chn) = 13 r_dspwrap(i_chn) = 2.0d0*r_pi i_dspmode(i_chn) = 6 a_dspctbl(i_chn) = 'cmy' else if (a_setname(i_chn) .eq. 'SRTM-dte') then i_setvfmt(i_chn) = 2 r_dspwrap(i_chn) = 200. r_dspmult(i_chn) = r_dspwrap(i_chn) i_dspmult(i_chn) = 0 i_dspaddr(i_chn) = 0 i_dspmode(i_chn) = 6 a_dspctbl(i_chn) = 'cmy' i_str=0 do while (index(a_setfile(i_chn)(i_str+1:),'/') .gt. 0) i_str=i_str+index(a_setfile(i_chn)(i_str+1:),'/') end do read(a_setfile(i_chn)(i_str+1:),'(x,i2.2)') i_lat i_lat=i_lat+1.0 if (a_setfile(i_chn)(i_str+1:i_str+1) .eq. 'S') i_lat=-i_lat read(a_setfile(i_chn)(i_str+1:),'(4x,i3.3)') i_lon if (a_setfile(i_chn)(i_str+4:i_str+4) .eq. 'W') i_lon=-i_lon i_setcols(i_chn) = 3601 i_setrows(i_chn) = 3601 i_setvend(i_chn) = 1 a_setproj(i_chn) = 'eqa' r_setcadr(i_chn) = i_lon r_setcmlt(i_chn) = 1.0d0/3600 r_setradr(i_chn) = i_lat r_setrmlt(i_chn) = -1.0d0/3600 r_setvmin(i_chn) = -10000. end if end do do i_chn = 1,i_set ! In order to make the -rmg option work correctly if (a_setname(i_chn) .eq. 'RMG-Mag') then i_setrtlr(i_chn) = 4*i_setcols(i_chn) i_setvfmt(i_chn) = 4 else if (a_setname(i_chn) .eq. 'RMG-Hgt') then i_setrhdr(i_chn) = 4*i_setcols(i_chn) i_setvfmt(i_chn) = 4 a_dspctbl(i_chn) = 'cmy' else if (a_setname(i_chn) .eq. 'RMG-Pha') then i_setrhdr(i_chn) = 4*i_setcols(i_chn) i_setvfmt(i_chn) = 4 a_dspctbl(i_chn) = 'cmy' end if end do do i_chn = 1,i_set ! In order to make QUBE Data work better if (a_setname(i_chn) .eq. 'QUBE' .and. i_qubeset .eq. 0) then a_dspctbl(i_chn) = 'cmy' i_qubeset=1 else if (a_setname(i_chn) .eq. 'QUBE' .and. i_qubeset .eq. 1) then a_dspctbl(i_chn) = 'grey' i_dspdvdc(i_chn) = 1 i_qubeset=0 end if end do do i_chn = 1,i_set ! if (i_dspdvdc(i_chn) .eq. 1) then a_setname(i_chn) = 'd('//a_setname(i_chn)(1:max(1,rdflen(a_setname(i_chn))))//')/dc' i_setvfmt(i_chn) = -i_setvfmt(i_chn) end if end do do i_chn = 1,i_set ! set b_setvnul b_setvnul(0,i_chn) = rdflen(a_setvnul(i_chn))/2 if (i_debug .eq. -5 .or. i_debug .ge. 5) write(6,*) 'i_chn,len,a_setvnul(i_chn) ',i_chn,b_setvnul(0 & ,i_chn),'#',a_setvnul(i_chn),'#' do i=1,16 if (i .le. b_setvnul(0,i_chn)) then read(a_setvnul(i_chn)(2*i-1:2*i),fmt='(z2.2)') & b_setvnul(i,i_chn) else b_setvnul(i,i_chn) = 0 end if if (b_setvnul(i,i_chn) .ge. 128) b_setvnul(i,i_chn) = b_setvnul(i,i_chn)-256 if (i_debug .eq. -10 .or. i_debug .ge. 10) write(6,*) 'b_setvnul = ',i_chn,i,b_setvnul(i,i_chn) end do end do do i_chn = 1,i_set ! correct sign of utm northing spacing if (rdflower(a_setproj(i_chn)) .eq. 'utm') r_setrmlt(i_chn)=-r_setrmlt(i_chn) end do if (index(a_nullclr,',') .ne. 0) then i_val = index(a_nullclr,'(') if (i_val .gt. 0) a_nullclr = a_nullclr(i_val+1:) i_val = index(a_nullclr,')') if (i_val .gt. 2) a_nullclr = a_nullclr(:i_val-1) read(a_nullclr,*) i_nullclr else if (i_debug .ge. 6) write(6,*) 'looking up color: ',a_nullclr call init_dsp(a_lcolor,i_debug) call get_colorrgb(a_nullclr,i_nullclr) end if if (i_debug .ge. 5) write(6,*) 'Setting null color: ',i_nullclr do i_chn = 1,i_set if (i_debug .eq. -4 .or. i_debug .ge. 4) write(6,*) ' ' if (i_debug .eq. -4 .or. i_debug .ge. 4) write(6,*) 'setname = ',a_setname(i_chn)(1:50) if (i_debug .eq. -4 .or. i_debug .ge. 4) write(6,*) 'setfile = ',a_setfile(i_chn)(1:50) if (i_debug .eq. -4 .or. i_debug .ge. 4) write(6,*) 'setinfo = ',a_setinfo(i_chn)(1:50) if (i_debug .eq. -4 .or. i_debug .ge. 4) write(6,*) 'setproj = ',a_setproj(i_chn)(1:50) if (i_debug .eq. -4 .or. i_debug .ge. 4) write(6,*) 'setrows = ',i_setrows(i_chn) if (i_debug .eq. -4 .or. i_debug .ge. 4) write(6,*) 'setcols = ',i_setcols(i_chn) if (i_debug .eq. -4 .or. i_debug .ge. 4) write(6,*) 'setshdr = ',i_setshdr(i_chn) if (i_debug .eq. -4 .or. i_debug .ge. 4) write(6,*) 'setstlr = ',i_setstlr(i_chn) if (i_debug .eq. -4 .or. i_debug .ge. 4) write(6,*) 'setrhdr = ',i_setrhdr(i_chn) if (i_debug .eq. -4 .or. i_debug .ge. 4) write(6,*) 'setrtlr = ',i_setrtlr(i_chn) if (i_debug .eq. -4 .or. i_debug .ge. 4) write(6,*) 'setchdr = ',i_setchdr(i_chn) if (i_debug .eq. -4 .or. i_debug .ge. 4) write(6,*) 'setctlr = ',i_setctlr(i_chn) if (i_debug .eq. -4 .or. i_debug .ge. 4) write(6,*) 'setvend = ',i_setvend(i_chn) if (i_debug .eq. -4 .or. i_debug .ge. 4) write(6,*) 'setfrmt = ',i_setvfmt(i_chn) if (i_debug .eq. -4 .or. i_debug .ge. 4) write(6,*) 'setrmlt = ',r_setrmlt(i_chn) if (i_debug .eq. -4 .or. i_debug .ge. 4) write(6,*) 'setradr = ',r_setradr(i_chn) if (i_debug .eq. -4 .or. i_debug .ge. 4) write(6,*) 'setcmlt = ',r_setcmlt(i_chn) if (i_debug .eq. -4 .or. i_debug .ge. 4) write(6,*) 'setcadr = ',r_setcadr(i_chn) if (i_debug .eq. -4 .or. i_debug .ge. 4) write(6,*) 'setvmlt = ',r_setvmlt(i_chn) if (i_debug .eq. -4 .or. i_debug .ge. 4) write(6,*) 'setvadr = ',r_setvadr(i_chn) if (i_debug .eq. -4 .or. i_debug .ge. 4) write(6,*) 'setvmin = ',r_setvmin(i_chn) if (i_debug .eq. -4 .or. i_debug .ge. 4) write(6,*) 'setvmax = ',r_setvmax(i_chn) if (i_debug .eq. -4 .or. i_debug .ge. 4) write(6,*) 'dspmode = ',i_dspmode(i_chn) if (i_debug .eq. -4 .or. i_debug .ge. 4) write(6,*) 'dspaddr = ',r_dspaddr(i_chn) if (i_debug .eq. -4 .or. i_debug .ge. 4) write(6,*) 'dspmult = ',r_dspmult(i_chn) if (i_debug .eq. -4 .or. i_debug .ge. 4) write(6,*) 'dspwrap = ',r_dspwrap(i_chn) if (i_debug .eq. -4 .or. i_debug .ge. 4) write(6,*) 'dspexpn = ',r_dspexpn(i_chn) if (i_debug .eq. -4 .or. i_debug .ge. 4) write(6,*) 'dspcplw = ',r_dspcplw(i_chn) if (i_debug .eq. -4 .or. i_debug .ge. 4) write(6,*) 'dspcphi = ',r_dspcphi(i_chn) if (i_debug .eq. -4 .or. i_debug .ge. 4) write(6,*) 'dspval1 = ',r_dspval1(i_chn) if (i_debug .eq. -4 .or. i_debug .ge. 4) write(6,*) 'dspval2 = ',r_dspval2(i_chn) if (i_debug .eq. -4 .or. i_debug .ge. 4) write(6,*) 'dspval3 = ',r_dspval3(i_chn) if (i_debug .eq. -4 .or. i_debug .ge. 4) write(6,*) 'dspmode = ',i_dspmode(i_chn) if (i_debug .eq. -4 .or. i_debug .ge. 4) write(6,*) 'dspdvdx = ',i_dspdvdc(i_chn) if (i_debug .eq. -4 .or. i_debug .ge. 4) write(6,*) 'dspaddr = ',i_dspaddr(i_chn) if (i_debug .eq. -4 .or. i_debug .ge. 4) write(6,*) 'dspmult = ',i_dspmult(i_chn) if (i_debug .eq. -4 .or. i_debug .ge. 4) write(6,*) 'dspmixv = ',i_dspmixv(i_chn) if (i_debug .eq. -4 .or. i_debug .ge. 4) write(6,*) 'dspctbl = ',a_dspctbl(i_chn)(1:50) end do if (i_setcols(1) .eq. 0) then write(6,*) 'Number of columns not specified' stop ' ' end if c open image files do i_chn = 1,i_set if (a_setfile(i_chn) .ne. ' ' .and. a_setfile(i_chn)(1:1) .ne. '=') then if (a_setfile(i_chn)(1:max(1,rdflen(a_setfile(i_chn)))) .eq. 'internal' .and. i_maxbuff .gt. 0) then i_setunit(i_chn) = -i_chn i_fbytes = readfunc(1,i_chn,i_eight(0),0,b_data) if (i_debug .ge. 3) write(6,*) 'internal buffer size=',i_fbytes i_fbytes = min(i_fbytes,i_maxbuff) else i_setunit(i_chn) = initdk(20+i_chn,a_setfile(i_chn)) i_fbytes = i_getfsize(i_setunit(i_chn)) if (i_setunit(i_chn) .le. 0) stop 'set number less than or equal to zero' end if if (i_fbytes .gt. 0) then i_setrows(i_chn) = min(i_eight(i_setrows(i_chn)),(i_fbytes & -i_setshdr(i_chn)-i_setstlr(i_chn))/((i_setvbyt(i_setvfmt(i_chn)) & +i_setchdr(i_chn)+i_setctlr(i_chn))*i_setcols(i_chn)+i_setrhdr(i_chn)+i_setrtlr(i_chn) & )) c i_setunit(i_chn) = 20+i_chn c open(unit=i_setunit(i_chn),file=a_setfile(i_chn),status='old', c & form='unformatted',access='direct',recl=i_setcols(i_chn)*i_setvbyt(i_chn)) if (i_debug .eq. 2) write(6,*) 'Opening file: ',a_setfile(i_chn)(1:60) if (i_debug .gt. 2) write(6,*) 'Opening file: ',a_setfile(i_chn)(1:60),' ',i_setrows(i_chn),i_setcols(i_chn) else write(6,*) 'Error opening: ',a_setfile(i_chn)(1:60), & i_chn,i_fbytes stop ' ' end if i_pos = 0 do while (index(a_setfile(i_chn)(i_pos+1:),'/') .ne. 0) i_pos = i_pos + index(a_setfile(i_chn)(i_pos+1:),'/') end do if (a_filename .eq. ' ') then a_filename = a_setfile(i_chn)(i_pos+1:) else if (a_filename .ne. a_setfile(i_chn)(i_pos+1:)) then ! Only show filename once if same for all channels a_filename=a_filename(1:max(rdflen(a_filename),1))/ & /', '//a_setfile(i_chn)(i_pos+1:) end if end if c c Compute data stats c if (.false.) then ! disable mean and std calc on raw data file if (i_debug .ge. 3) write(6,'(1x,a,i3)') 'Computing set stats for set: ',i_chn if (i_debug .ge. 4) write(6,*) 'Number of rows/cols: ',i_setrows(i_chn) & ,i_setcols(i_chn) i_err = 0 i_cnt = 0 r_sum = 0. r_sqr = 0. r_setvavg(i_chn) = 0.0 r_setvstd(i_chn) = 0.0 do i_row = 0,i_setrows(i_chn)-1,min(max(i_setrows(i_chn)/100,1),20000) do i_col = 0, i_setcols(i_chn)-1, min(max(i_setcols(i_chn)/100,1),20000) !@#$% if (a_setfile(i_chn)(1:1) .ne. '=') then call readdat(i_setunit(i_chn), & i_setrows(i_chn), & i_setcols(i_chn), & i_setshdr(i_chn), & i_setstlr(i_chn), & i_setrhdr(i_chn), & i_setrtlr(i_chn), & i_setchdr(i_chn), & i_setctlr(i_chn), & i_setvend(i_chn)*i_endian, & i_setvfmt(i_chn), & r_setvmlt(i_chn), & r_setvadr(i_chn), & r_setvmin(i_chn), & r_setvmax(i_chn), & b_setvnul(0,i_chn), & i_row,i_col-1,3,r_data,i_data,readfunc,i_err) else do j=0,2 r_data(j)=0 i_data(j)=0 end do i_opr=1 i_flg=0 a_value = ' ' do i = 2,rdflen(a_setfile(i_chn))+1 if (index('+-*/x',a_setfile(i_chn)(i:i)) .gt. 0 .or. a_setfile(i_chn)(i:i) .eq. ' ') then if (a_value .ne. ' ') then read(a_value,*) r_value if (i_opr .eq. 1) then r_data(1)=r_data(1)+r_value else if (i_opr .eq. 2) then r_data(1)=r_data(1)-r_value else if (i_opr .eq. 3) then r_data(1)=r_data(1)*r_value else if (i_opr .eq. 4) then r_data(1)=r_data(1)/r_value end if a_value = ' ' end if end if if(a_setfile(i_chn)(i:i) .eq. '+') then i_opr=1 else if (a_setfile(i_chn)(i:i) .eq. '-') then i_opr=2 else if (a_setfile(i_chn)(i:i) .eq. 'x') then i_opr=3 else if (a_setfile(i_chn)(i:i) .eq. '/') then i_opr=4 else if (a_setfile(i_chn)(i:i) .eq. 's' .or. a_setfile(i_chn)(i:i) .eq. 'S') then i_flg=1 else if (i_flg .eq. 1) then i_flg = 0 i_tmp = max(min((ichar(a_setfile(i_chn)(i:i))-ichar('0')),i_set+1),1) if (i_tmp .gt. i_set) i_tmp=0 if (i_tmp .ne. 0) then call readdat(i_setunit(i_tmp), & i_setrows(i_tmp), & i_setcols(i_tmp), & i_setshdr(i_tmp), & i_setstlr(i_tmp), & i_setrhdr(i_tmp), & i_setrtlr(i_tmp), & i_setchdr(i_tmp), & i_setctlr(i_tmp), & i_setvend(i_tmp)*i_endian, & i_setvfmt(i_tmp), & r_setvmlt(i_tmp), & r_setvadr(i_tmp), & r_setvmin(i_tmp), & r_setvmax(i_tmp), & b_setvnul(0,i_tmp), & i_row,i_col-1,3,r_data2,i_data2,readfunc,i_err) i_data(1)=i_data(1)+i_data2(1) if (i_opr .eq. 1) then r_data(1)=r_data(1)+r_data2(1) else if (i_opr .eq. 2) then r_data(1)=r_data(1)-r_data2(1) else if (i_opr .eq. 3) then r_data(1)=r_data(1)*r_data2(1) else if (i_opr .eq. 4) then r_data(1)=r_data(1)/r_data2(1) else r_data(1)=r_data(1)+r_data2(1) end if end if else a_value = a_value(1:max(1,rdflen(a_value)))//a_setfile(i_chn)(i:i) end if end do end if !@#$% if (i_data(1) .eq. 0) then i_cnt = i_cnt + 1 r_val(min(i_cnt,I_WKSPACE)) = r_data(1) r_sum = r_sum + dble(r_data(1)) r_sqr = r_sqr + dble(r_data(1))**2 end if end do end do if (i_cnt .gt. 0) then r_setvavg(i_chn) = r_sum/max(i_cnt,1) r_setvstd(i_chn) = sqrt(max(1.d-99,(r_sqr/max(i_cnt,1)) & -r_setvavg(i_chn)**2)) if (i_debug .ge. 3) write(6,*) 'avg/std = ',r_setvavg(i_chn),r_setvstd(i_chn),i_cnt c call median(0.5,min(i_cnt,I_WKSPACE),r_val,r_median) if (i_debug .ge. 4) write(6,*) 'average = ',r_setvavg(i_chn),i_cnt if (i_debug .ge. 4) write(6,*) 'median = ',r_median,i_cnt end if end if end if enddo do i_chn = 1,i_set if (a_setfile(i_chn)(1:1) .eq. '=') then if (i_setrows(i_chn) .eq. 0) i_setrows(i_chn) = i_setrows(1) if (i_setcols(i_chn) .eq. 0) i_setcols(i_chn) = i_setcols(1) end if end do c c Set up row/column formats c write(a_rowfrmt,'(a,i2.2,a)') '(i',min(10,max(1,int(1+alog10(float(i_setrows(1)))))),')' write(a_colfrmt,'(a,i2.2,a)') '(i',min(10,max(1,int(1+alog10(float(i_setcols(1)))))),')' if (i_debug .ge. 6) write(6,*) 'row/col fmt = ',a_rowfrmt,' ',a_colfrmt c c Set some Color Table defaults c do i=1,i_set a_value = rdflower(a_setname(i)) if (a_dspctbl(i) .eq. ' ') then if (a_value(1:3) .eq. 'set') then if (i .eq. 1) a_dspctbl(i) = 'grey' if (i .eq. 2) a_dspctbl(i) = 'cmy' if (i .eq. 3) a_dspctbl(i) = 'bitmap' else if (a_value .eq. 'mag' .or. & a_value .eq. 'rcs' .or. & a_value .eq. 'amp' .or. & a_value .eq. 'amplitude' .or. & a_value .eq. 'magnitude' ) then a_dspctbl(i) = 'grey' else if (a_value .eq. 'dte' .or. & a_value .eq. 'hgt' .or. & a_value .eq. 'pha' .or. & a_value .eq. 'height' .or. & a_value .eq. 'phase' ) then a_dspctbl(i) = 'cmy' else if (a_value .eq. 'vv' ) then a_dspctbl(i) = 'blue' else if (a_value .eq. 'red' ) then a_dspctbl(i) = 'red' else if (a_value .eq. 'green' ) then a_dspctbl(i) = 'green' else if (a_value .eq. 'blue' ) then a_dspctbl(i) = 'blue' else if (a_value .eq. 'hh' ) then a_dspctbl(i) = 'green' else if (a_value .eq. 'airsar-dem') then a_dspctbl(i) = 'cmy' else if (a_value .eq. 'airsar-mag') then a_dspctbl(i) = 'grey' else if (a_value .eq. 'airsar-cor') then a_dspctbl(i) = 'grey' else if (a_value .eq. 'airsar-m11') then a_dspctbl(i) = 'grey' else a_dspctbl(i) = 'grey' end if end if end do c c Initialize graphics c do i_d=1,I_DMAX i_winactv(i_d)=0 end do i_dsp=1 i_winrows(i_dsp) = min(nint(i_setrows(1)*r_winzoom(i_dsp)),32000) i_wincols(i_dsp) = min(nint(i_setcols(1)*r_winzoom(i_dsp)),32000) i_winradr(i_dsp) = 0 i_wincadr(i_dsp) = 0 if (i_ponly .eq. 0) then call create_dsp(a_filename,i_winrows(i_dsp),i_wincols(i_dsp),i_winy,i_winx, & a_setname(1),i_set,i_d,i_menu,a_tname,i_close,a_lcolor,i_debug) if (i_debug .ge. 6) write(6,*) 'i_dsp=',i_dsp if (i_d .lt. 1 .or. i_d .gt. I_DMAX) stop 'Error creating Display' call get_wininfo(i_d,1,i_vxo(i_d,1),i_vyo(i_d,1),i_vxs(i_d,1), & i_vys(i_d,1),i_wxs(i_d,1),i_wys(i_d,1),i_widget) c & i_vys(i_d,1),i_cw,i_ch,i_widget) if (i_debug .ge. 6) write(6,*) 'from get_win',i_vxo(i_d,1),i_vyo(i_d,1),i_vxs(i_d,1) & ,i_vys(i_d,1) i_winactv(i_d) = 1 do i=1, I_CMAX if (i .le. i_set) then if (i_dspactv(i_d,i) .lt. 0) then i_dspactv(i_d,i) = 1 end if call set_button_shadow(i_d,i+1,i_dspactv(i_d,i),i_debug) c call get_colortable(a_colordir,a_dspctbl(i),i_dspnumt(i),r_dspredt(0,i),r_dspgrnt(0,i),r_dspblut(0,i),i_debug) else i_dspactv(i_d,i) = 0 end if end do else i_vxo(1,1)=0 i_vyo(1,1)=0 i_vxs(1,1)=i_wincols(1) i_vys(1,1)=i_winrows(1) end if do i=1,i_set call get_colortable(a_colordir,a_dspctbl(i),i_dspnumt(i),r_dspredt(0,i),r_dspgrnt(0,i),r_dspblut(0,i),i_debug) end do c c Start Managing Window c c c Set up to Compute display stats c do i_chn = 1,i_set i_event(0) = i_chn i_event(1) = 1 i_event(2) = 11 i_event(3) = 0 i_event(4) = 0 i_event(5) = 0 i_event(6) = 0 if (i_debug .ge. 6) write(6,*) 'i_bcnt2 =',i_bcnt call buffer_cmd(i_event,i_bdat,i_bcnt,2,I_BMAX,i_abort,i_debug) end do if (i_ponly .ne. 0) then i_event(0) = 0 ! tells data to go to print file instead of screen i_event(1) = 1 i_event(2) = 1 i_event(3) = (i_vxo(1,1)*r_winzoom(0))/r_winzoom(1) i_event(4) = (i_vyo(1,1)*r_winzoom(0))/r_winzoom(1) i_event(5) = ((min(i_vxs(1,1)+i_vxo(1,1),i_wincols(1))-i_vxo(1,1))* & r_winzoom(0))/r_winzoom(1) i_event(6) = ((min(i_vys(1,1)+i_vyo(1,1),i_winrows(1))-i_vyo(1,1))* & r_winzoom(0))/r_winzoom(1) i_event(7) = 0 i_event(8) = i_event(4) i_event(9) = i_event(6) do i_chn=1,i_set i_dspactv(0,i_chn) = 1 end do call buffer_cmd(i_event,i_bdat,i_bcnt,2,I_BMAX,i_abort,i_debug) i_dspselect=i_dsp if (i_debug .eq. -22 .or. i_debug .ge. 22) write(6,*) 'Printing:',i_event(3),i_event(4),i_event(5),i_event(6) else if (r_lat .ge. -2.0d0*r_pi .and. r_lon .ge. -2.0d0*r_pi) then r_eux(1)=r_lat r_eux(2)=r_lon r_eux(3)=0.0 c write(6,*) 'r_eux=',r_eux call get_coordinates(a_setproj(1),r_setpegv(1,1),r_dnx,r_eux,2,i_debug,i_err) c i_rcenter=((r_dnx(1)-r_setradr(1))/r_setrmlt(1)-i_winradr(1) )*r_winzoom(1) c write(6,*) 'r_dnx=',r_dnx c write(6,*) 'real center=',((r_dnx(1)-r_setradr(1))/r_setrmlt(1)-i_winradr(1) ),((r_dnx(2)-r_setcadr(1))/r_setcmlt(1)-i_wincadr(1) ) i_rcenter=((r_dnx(1)-r_setradr(1))/r_setrmlt(1)-i_winradr(1) ) i_ccenter=((r_dnx(2)-r_setcadr(1))/r_setcmlt(1)-i_wincadr(1) ) end if if (i_debug .eq. -9 .or. i_debug .ge. 9) write(6,*) 'moving scroll to',i_ccenter,i_rcenter i_d=1 if (i_winradr(i_d).ne.max(min(i_rcenter-int((32000/2)/r_winzoom(i_d)),i_setrows(1)-int(32000/r_winzoom(i_d))),0))then i_winradr(i_d)=max(min(i_rcenter-int((32000/2)/r_winzoom(i_d)),i_setrows(1)-int(32000/r_winzoom(i_d))),0) i_redraw(i_d)=1 end if if (i_wincadr(i_d).ne.max(min(i_ccenter-int((32000/2)/r_winzoom(i_d)),i_setcols(1)-int(32000/r_winzoom(i_d))),0))then i_wincadr(i_d)=max(min(i_ccenter-int((32000/2)/r_winzoom(i_d)),i_setcols(1)-int(32000/r_winzoom(i_d))),0) i_redraw(i_d)=1 end if if (i_redraw(i_d) .eq. 1) then i_redraw(i_d) = 0 i_event(0) = i_d ! Redraw window i_event(1) = 1 i_event(2) = 1 i_event(3) = i_vxo(i_d,1)-5 i_event(4) = i_vyo(i_d,1)-5 i_event(5) = i_vxs(i_d,1) i_event(6) = i_vys(i_d,1) if (i_debug .ge. 6) write(6,*) 'i_bcnt2 =',i_bcnt call buffer_cmd(i_event,i_bdat,i_bcnt,2,I_BMAX,i_abort,i_debug) end if i_cpos = nint((i_ccenter-i_wincadr(i_d))*r_winzoom(i_d)-0.5*i_vxs(i_d,1)) i_rpos = nint((i_rcenter-i_winradr(i_d))*r_winzoom(i_d)-0.5*i_vys(i_d,1)) call move_scroll(i_d,1,i_cpos,i_rpos) end if do while(i_done .eq. 0 .or. i_pinit .ne. 0) if (i_ponly .eq. 0) then i_event(0) = -1 else i_event(0) = 0 end if do while(i_event(0) .ne. 0 .and. i_done .eq. 0 .and. i_bcnt .lt. I_BMAX) call getevent(i_wait,i_event) if (i_debug .ge. 4) then if (i_event(0) .ne. 0 .and. i_event(2) .ne. 9 .and. i_debug .ge. 5) then write(6,'(1x,a,7i10)') & 'i_event=',i_event(0),i_event(1),i_event(2) & ,i_event(3),i_event(4),i_event(5),i_event(6) end if end if call buffer_cmd(i_event,i_bdat,i_bcnt,1,I_BMAX,i_abort,i_debug) if (i_debug .ge. 6) write(6,*) 'i_bcnt =',i_bcnt if (i_wait .eq. 0 .and. (i_bcnt .gt. 0 .or. i_ecnt .gt. 0)) then ! Update wait flag i_wait = 1 iy = 0 if (i_debug .ge. 7) write(6,*) 'turning wait off',i_wait & ,i_bcnt end if if (i_wait .eq. 1 .and. (i_bcnt .eq. 0 .and. i_ecnt .eq. 0)) then i_wait = 0 if (i_debug .ge. 7) write(6,*) 'turning wait on',i_wait end if end do if (i_bcnt .gt. 0) then ! Execute oldest action in buffer i_dsp = i_bdat(0,1) i_win = i_bdat(1,1) i_evn = i_bdat(2,1) if (i_dsp .lt. 0 .or. i_dsp .gt. I_DMAX) then ! do nothing else if (i_evn .eq. 1) then ! Expose Command if (i_win .eq. 1) then ! Window 1 i_col = i_bdat(3,1) i_row = i_bdat(4,1) i_ncx = i_bdat(5,1) i_nrx = i_bdat(6,1) ! number of lines in expose event if (i_ecnt .eq. I_EMAX) write(6,*) ' *** Warning *** - Too many expose commands to buffer, Skipping: ',i_col,i_row,i_ncx,i_nrx i_ecnt=min(i_ecnt+1,I_EMAX) do i=0,10 i_edat(i,i_ecnt)=i_bdat(i,1) end do i_scroll=0 if (i_ecnt .gt. 2) then ! Check if commands can be combined if (i_edat(0,i_ecnt-1) .eq. i_bdat(0,1)) then ! Both events from the same display if (i_edat(4,i_ecnt-1) .eq. i_bdat(4,1) .and. & i_edat(6,i_ecnt-1) .eq. i_bdat(6,1) ) then ! Top and bottom edges line up if (i_edat(3,i_ecnt-1)+i_edat(5,i_ecnt-1) .eq. i_bdat(3,1)) then ! Scoll right i_ecnt=i_ecnt-1 i_edat(5,i_ecnt) = i_edat(5,i_ecnt)+i_bdat(5,1) i_scroll=0 if (i_debug .eq. -4 .or. i_debug .ge. 4) write(6,*) 'Merge Scroll Right ',i_edat(3,i_ecnt),i_edat(5,i_ecnt) else if (i_bdat(3,1)+i_bdat(5,1) .eq. i_edat(3,i_ecnt-1)) then ! Scoll left i_ecnt=i_ecnt-1 i_edat(3,i_ecnt) = i_bdat(3,1) i_edat(5,i_ecnt) = i_edat(5,i_ecnt)+i_bdat(5,1) i_scroll=0 if (i_debug .eq. -4 .or. i_debug .ge. 4) write(6,*) 'Merge Scroll Left ',i_edat(3,i_ecnt),i_edat(5,i_ecnt) else if (i_debug .eq. -4 .or. i_debug .ge. 4) write(6,*) 'Horizontal Scroll not contiguous', & i_edat(3,i_ecnt-1)+i_edat(5,i_ecnt-1),i_bdat(3,1),i_bdat(3,1)+i_bdat(5,1),i_edat(3,i_ecnt-1) end if else if (i_edat(3,i_ecnt-1) .eq. i_bdat(3,1) .and. & i_edat(5,i_ecnt-1) .eq. i_bdat(5,1) ) then ! Left and right edges line upe if (i_edat(4,i_ecnt-1)+i_edat(6,i_ecnt-1) .eq. i_bdat(4,1)) then ! Scoll Down i_ecnt=i_ecnt-1 i_edat(6,i_ecnt) = i_edat(6,i_ecnt)+i_bdat(6,1) i_scroll=0 if (i_debug .eq. -4 .or. i_debug .ge. 4) write(6,*) 'Merge Scroll Down ',i_edat(4,i_ecnt),i_edat(6,i_ecnt) else if (i_bdat(4,1)+i_bdat(6,1) .eq. i_edat(4,i_ecnt-1)) then ! Scoll up i_ecnt=i_ecnt-1 i_edat(4,i_ecnt) = i_bdat(4,1) i_edat(6,i_ecnt) = i_edat(6,i_ecnt)+i_bdat(6,1) i_scroll=1 if (i_debug .eq. -4 .or. i_debug .ge. 4) write(6,*) 'Merge Scroll Up ',i_edat(4,i_ecnt),i_edat(6,i_ecnt) else if (i_debug .eq. -4 .or. i_debug .ge. 4) write(6,*) 'Vertical Scroll not contiguous', & i_edat(4,i_ecnt-1)+i_edat(6,i_ecnt-1),i_bdat(4,1),i_bdat(4,1)+i_bdat(6,1),i_edat(4,i_ecnt-1) end if end if end if end if i_edat(7,i_ecnt)=i_scroll i_edat(8,i_ecnt)=i_edat(4,i_ecnt) i_edat(9,i_ecnt)=i_edat(6,i_ecnt) do i=2,i_ecnt i_d=i_edat(0,i) i_w=i_edat(1,i) if (i_d .gt. 0 .and. i_w .eq. 1) then if (i_edat(3,i) .gt. i_vxo(i_d,i_w)+i_vxs(i_d,i_w)) then i_edat(6,i) = -2 ! delete command if (i_debug .eq. -4 .or. i_debug .ge. 4) write(6,*) '** Deleting expose: ',1 else if (i_edat(3,i)+i_edat(5,i) .lt. i_vxo(i_d,i_w)) then i_edat(6,i) = -2 ! delete command if (i_debug .eq. -4 .or. i_debug .ge. 4) write(6,*) '** Deleting expose: ',2 else if (i_edat(4,i) .gt. i_vyo(i_d,i_w)+i_vys(i_d,i_w)) then i_edat(6,i) = -2 ! delete command if (i_debug .eq. -4 .or. i_debug .ge. 4) write(6,*) '** Deleting expose: ',3 else if (i_edat(4,i)+i_edat(6,i) .lt. i_vyo(i_d,i_w)) then i_edat(6,i) = -2 ! delete command if (i_debug .eq. -4 .or. i_debug .ge. 4) write(6,*) '** Deleting expose: ',4 else i_max=min(i_edat(3,i)+i_edat(5,i),i_vxo(i_d,i_w)+i_vxs(i_d,i_w)+1) i_edat(3,i) = max(i_edat(3,i),i_vxo(i_d,i_w)-1) i_edat(5,i) = i_max-i_edat(3,i) c write(6,*) '***** ',i,i_edat(4,i),i_edat(6,i),i_vyo(i_d,i_w),i_vys(i_d,i_w) i_max=min(i_edat(4,i)+i_edat(6,i),i_vyo(i_d,i_w)+i_vys(i_d,i_w)+1) i_edat(4,i) = max(i_edat(4,i),i_vyo(i_d,i_w)-1) i_edat(6,i) = i_max-i_edat(4,i) i_edat(8,i)=i_edat(4,i) i_edat(9,i)=i_edat(6,i) c write(6,*) '***** ',i,i_edat(4,i),i_edat(6,i),i_vyo(i_d,i_w),i_vys(i_d,i_w) end if end if end do if (i_debug .ge. 7) write(6,*) 'i_ecnt0= ',i_ecnt, & i_bdat(1,i_ecnt),i_bdat(2,i_ecnt),i_bdat(3,i_ecnt), & i_bdat(4,i_ecnt),i_bdat(5,i_ecnt),i_bdat(6,i_ecnt) end if else if (i_evn .eq. 2) then ! Configure window event c if (i_win .eq. 1 .and.. i_bdat(3,1) .lt. i_vxo(i_dsp,i_win)) then ! remember if scrolling up or down c i_scroll = 1 c else c i_scroll = 0 c end if i_vxo(i_dsp,i_win) = i_bdat(3,1) ! offset of viewport i_vyo(i_dsp,i_win) = i_bdat(4,1) ! offset of viewport i_wxs(i_dsp,i_win) = i_bdat(5,1) ! size of window i_wys(i_dsp,i_win) = i_bdat(6,1) ! size of window if (i_win .eq. 1) then if (i_cset .le. 0 .and. i_cdsp .ge. 0) then i_cdsp = -1 if (i_debug .ge. 8) write(6,*) '--Setting cdsp = -1' end if if (i_debug .ge. 8) write(6,*) 'i_cdsp,i_cset = ',i_cdsp,i_cset if (i_debug .ge. 6) write(6,*) '** config1 =',i_dsp,i_win,i_bdat(3,1) & ,i_bdat(4,1),i_bdat(5,1),i_bdat(6,1) if (i_debug .eq. -21 .and. i_win .eq. 1) write(6,*) 'vxo,vyo =',i_vxo(i_dsp,i_win),i_vyo(i_dsp,i_win) end if else if (i_evn .eq. 3) then ! Configure window event i_vxs(i_dsp,i_win) = i_bdat(5,1) ! size of viewport i_vys(i_dsp,i_win) = i_bdat(6,1) ! size of viewport if (i_win .eq. 1) then if (i_cset .le. 0 .and. i_cdsp .ge. 0) then i_cdsp = -1 if (i_debug .ge. 8) write(6,*) '--Setting cdsp = -1' end if if (i_debug .ge. 8) write(6,*) 'i_cdsp,i_cset = ',i_cdsp,i_cset if (i_debug .ge. 6 .or. i_debug .eq. -6) write(6,*) '** config2 =',i_dsp,i_win,i_bdat(3,1), & i_bdat(4,1),i_bdat(5,1),i_bdat(6,1) if (i_debug .eq. -21 .and. i_win .eq. 1) write(6,*) 'vxs,vys =',i_vxs(i_dsp,i_win), & i_vys(i_dsp,i_win),i_wxs(i_dsp,i_win),i_wys(i_dsp,i_win) end if else if (i_evn .eq. 4) then ! Click in window i_button = i_bdat(3,1) i_col = i_bdat(4,1) i_row = i_bdat(5,1) if (i_debug .eq. -12 .or. i_debug .ge. 12) write(6,*) 'press win/button=',i_win,i_button c write(6,*) 'click event: ',i_dsp,i_win,i_button if (i_win .eq. 0) then ! do nothing else if (i_button .eq. 4 .and. i_win .eq. 1) then if (i_key .eq. 0) then ! Scroll Bar up if (i_debug .eq. -4 .or. i_debug .ge. 4) write(6,*) & 'Scroll up',i_vxo(i_dsp,1),min(i_wys(i_dsp,1),max(0,i_vyo(i_dsp,1)-int(0.2*i_vys(i_dsp,1)))) ! call move_scroll(i_dsp,1,i_vxo(i_dsp,1),min(i_wys(i_dsp,1),max(0,i_vyo(i_dsp,1)-int(0.2*i_vys(i_dsp,1))))) call move_scroll(i_dsp,1,i_vxo(i_dsp,1),max(0,i_vyo(i_dsp,1)-int(0.2*i_vys(i_dsp,1)))) else ! Scroll Bar left ! call move_scroll(i_dsp,1,min(i_wxs(i_dsp,1),max(0,i_vxo(i_dsp,1)-int(0.2*i_vxs(i_dsp,1)))),i_vyo(i_dsp,1)) call move_scroll(i_dsp,1,max(0,i_vxo(i_dsp,1)-int(0.2*i_vxs(i_dsp,1))),i_vyo(i_dsp,1)) end if else if (i_button .eq. 5 .and. i_win .eq. 1) then if (i_key .eq. 0) then ! Scroll Bar down ! write(6,*) 'xxx ',i_wys(i_dsp,1),i_vyo(i_dsp,1),i_vys(i_dsp,1) if (i_debug .eq. -4 .or. i_debug .ge. 4) write(6,*) & 'Scroll down',i_vxo(i_dsp,1),min(i_wys(i_dsp,1),max(0,i_vyo(i_dsp,1)+int(0.2*i_vys(i_dsp,1)))) ! call move_scroll(i_dsp,1,i_vxo(i_dsp,1),min(i_wys(i_dsp,1),max(0,i_vyo(i_dsp,1)+int(0.2*i_vys(i_dsp,1))))) call move_scroll(i_dsp,1,i_vxo(i_dsp,1),max(0,i_vyo(i_dsp,1)+int(0.2*i_vys(i_dsp,1)))) else ! Scroll Bar right ! call move_scroll(i_dsp,1,min(i_wxs(i_dsp,1),max(0,i_vxo(i_dsp,1)+int(0.2*i_vxs(i_dsp,1)))),i_vyo(i_dsp,1)) call move_scroll(i_dsp,1,max(0,i_vxo(i_dsp,1)+int(0.2*i_vxs(i_dsp,1))),i_vyo(i_dsp,1)) end if else if (i_button .eq. 6 .and. i_win .eq. 1) then if (i_key .ne. 0) then ! Scroll Bar up if (i_debug .eq. -4 .or. i_debug .ge. 4) write(6,*) & 'Scroll up',i_vxo(i_dsp,1),min(i_wys(i_dsp,1),max(0,i_vyo(i_dsp,1)-int(0.2*i_vys(i_dsp,1)))) ! call move_scroll(i_dsp,1,i_vxo(i_dsp,1),min(i_wys(i_dsp,1),max(0,i_vyo(i_dsp,1)-int(0.2*i_vys(i_dsp,1))))) call move_scroll(i_dsp,1,i_vxo(i_dsp,1),max(0,i_vyo(i_dsp,1)-int(0.2*i_vys(i_dsp,1)))) else ! Scroll Bar left ! call move_scroll(i_dsp,1,min(i_wxs(i_dsp,1),max(0,i_vxo(i_dsp,1)-int(0.2*i_vxs(i_dsp,1)))),i_vyo(i_dsp,1)) call move_scroll(i_dsp,1,max(0,i_vxo(i_dsp,1)-int(0.2*i_vxs(i_dsp,1))),i_vyo(i_dsp,1)) end if else if (i_button .eq. 7 .and. i_win .eq. 1) then if (i_key .ne. 0) then ! Scroll Bar down ! write(6,*) 'xxx ',i_wys(i_dsp,1),i_vyo(i_dsp,1),i_vys(i_dsp,1) if (i_debug .eq. -4 .or. i_debug .ge. 4) write(6,*) & 'Scroll down',i_vxo(i_dsp,1),min(i_wys(i_dsp,1),max(0,i_vyo(i_dsp,1)+int(0.2*i_vys(i_dsp,1)))) ! call move_scroll(i_dsp,1,i_vxo(i_dsp,1),min(i_wys(i_dsp,1),max(0,i_vyo(i_dsp,1)+int(0.2*i_vys(i_dsp,1))))) call move_scroll(i_dsp,1,i_vxo(i_dsp,1),max(0,i_vyo(i_dsp,1)+int(0.2*i_vys(i_dsp,1)))) else ! Scroll Bar right ! call move_scroll(i_dsp,1,min(i_wxs(i_dsp,1),max(0,i_vxo(i_dsp,1)+int(0.2*i_vxs(i_dsp,1)))),i_vyo(i_dsp,1)) call move_scroll(i_dsp,1,max(0,i_vxo(i_dsp,1)+int(0.2*i_vxs(i_dsp,1))),i_vyo(i_dsp,1)) end if else if (i_button .ge. 8) then ! ! do nothing else if (i_win .eq. 1) then ! Click in window 1 c write(6,*) 'in window 1' i_event(0) = i_dsp i_event(1) = i_win i_event(2) = 13 i_event(3) = i_button i_event(4) = i_col i_event(5) = i_row i_event(6) = 1 c write(6,*) 'adding event to buffer =',i_bcnt,i_dsp,i_win,4,-i_button call buffer_cmd(i_event,i_bdat,i_bcnt,2,I_BMAX,i_abort,i_debug) else if (i_win .eq. -1) then ! Click in label for window 1 if (i_key .eq. 0 .or. a_setproj(1) .eq. ' ' .or. & r_setrmlt(1) .eq. 0. .or. r_setcmlt(1) .eq. 0.) then if (i_debug .ge. 5) write(6,*) 'i_bdat(3,1)=',i_bdat(3,1) do i=0,20 a_elabl(i)=' ' a_edata(i)=' ' end do a_elabl(1)='Enter Col, Row: ' a_edata(1)=' ' c do i=1,10 c write(86,*) a_elabl(i) c do j=1,160 c write(86,*) ichar(a_elabl(i)(j:j)),' ',a_elabl(i)(j:j) c end do c end do call entry_window(0,a_elabl,a_edata) i_dspselect=i_dsp a_elabl(1)=' ' a_edata(1)=' ' else do i=0,20 a_elabl(i)=' ' a_edata(i)=' ' end do a_elabl(2)='Enter Lat,Lon: ' a_edata(2)=' ' call entry_window(0,a_elabl,a_edata) i_dspselect=i_dsp a_elabl(2)=' ' a_edata(2)=' ' end if else if (i_win .ge. 2 .and. i_win .le. i_set+1) then ! Click on set button ! max(4,min(i_set+1+2*i_close,I_CMAX+2)) ) then ! Click on Buttons if (i_shft .eq. 0) then if (i_button .le. 0) then if (i_debug .ge. 1) write(6,*) 'Button press error',i_button else if (i_button .eq. 1) then if (i_debug .eq. -4 .or. i_debug .ge. 4) write(6,*) 'i_dsp ',i_dsp & ,' Button',i_win-1,' - left click',i_dsp do i_chn=1,i_set if (i_chn .eq. i_win-1) then i_dspactv(i_dsp,i_win-1) = 1 call set_button_shadow(i_dsp,i_chn+1,1,i_debug) else i_dspactv(i_dsp,i_chn) = 0 call set_button_shadow(i_dsp,i_chn+1,0,i_debug) end if end do else if (i_button .eq. 2) then if (i_debug .eq. -4 .or. i_debug .ge. 4) write(6,*) 'i_dsp ',i_dsp & ,' Button',i_win-1,' - middle click' & ,i_dsp i_dspactv(i_dsp,i_win-1) = 1-i_dspactv(i_dsp,i_win-1) if (i_dspactv(i_dsp,i_win-1) .eq. 1) then call set_button_shadow(i_dsp,i_win,1,i_debug) else call set_button_shadow(i_dsp,i_win,0,i_debug) end if else if (i_button .eq. 3) then if (i_debug .eq. -4 .or. i_debug .ge. 4) write(6,*) 'i_dsp ',i_dsp & ,' Button',i_win-1,' - right click',i_dsp i_chn=i_win-1 a_labels(0)=a_setname(i_chn)(1:max(1,rdflen(a_setname(i_chn))))//' Parameters' if (i_dspmode(i_chn) .eq. 1) then a_data(1)='1|Range|SDEV|PER|NORM|CW|Wrap' else if (i_dspmode(i_chn) .eq. 2) then a_data(1)='2|Range|SDEV|PER|NORM|CW|Wrap' else if (i_dspmode(i_chn) .eq. 3) then a_data(1)='3|Range|SDEV|PER|NORM|CW|Wrap' else if (i_dspmode(i_chn) .eq. 4) then a_data(1)='4|Range|SDEV|PER|NORM|CW|Wrap' else if (i_dspmode(i_chn) .eq. 5) then a_data(1)='5|Range|SDEV|PER|NORM|CW|Wrap' else a_data(1)='6|Range|SDEV|PER|NORM|CW|Wrap' end if c write(a_data(1),'(I10)') i_dspmode(i_chn) if (i_dspmode(i_chn) .eq. 1) then a_labels(2)='Range:' write(a_data(2),'(f15.4)') r_dspmult(i_chn) a_labels(3)='Offset:' write(a_data(3),'(f15.4)') r_dspaddr(i_chn) else if (i_dspmode(i_chn) .eq. 2) then a_labels(2)='SDEV Factor:' write(a_data(2),'(f15.2)') r_dspval1(i_chn) a_labels(3)='Offset:' write(a_data(3),'(f15.4)') r_dspaddr(i_chn) else if (i_dspmode(i_chn) .eq. 3) then a_labels(2)='Percent:' write(a_data(2),'(f15.2)') r_dspval2(i_chn) a_labels(3) = '|' a_data(3) = ' ' else if (i_dspmode(i_chn) .eq. 4) then a_labels(2)=' ' write(a_data(2),'(f15.2)') r_dspmult(i_chn) a_labels(3)='|' a_data(3) =' ' write(a_data(3),'(f15.4)') r_dspaddr(i_chn) else if (i_dspmode(i_chn) .eq. 5) then a_labels(2)='CW Scale:' write(a_data(2),'(f15.2)') r_dspval3(i_chn) a_labels(3) = '|' a_data(3) = ' ' else a_labels(2)='Wrap:' write(a_data(2),'(f15.4)') r_dspwrap(i_chn) a_labels(3)='Offset:' write(a_data(3),'(f15.4)') r_dspaddr(i_chn) end if call encodeval(r_dspexpn(i_chn),a_data(4)) call encodeval(r_setvmin(i_chn),a_data(5)) call encodeval(r_setvmax(i_chn),a_data(6)) call encodeval(r_dspcplw(i_chn),a_data(7)) call encodeval(r_dspcphi(i_chn),a_data(8)) c write(a_data(4),'(f15.4)') r_dspexpn(i_chn) c write(a_data(5),'(f15.4)') r_setvmin(i_chn) c write(a_data(6),'(f15.4)') r_setvmax(i_chn) c write(a_data(7),'(f15.4)') r_dspcplw(i_chn) c write(a_data(8),'(f15.4)') r_dspcphi(i_chn) i_colorset=0 do i=1,i_colormax if (a_dspctbl(i_chn) .eq. a_colorfile(i)) i_colorset=i end do if (i_colorset .gt. 0) then write(a_data(9),'(i2)') i_colorset do i=1,i_colormax a_data(9)=a_data(9)(1:rdflen(a_data(9)))//'|'//a_colorname(i) end do if (a_data(9)(1:1) .eq. ' ') a_data(9)=a_data(9)(2:) else a_data(9)=a_dspctbl(i_chn) end if call entry_window(i_chn,a_labels,a_data) c call entry_window(i_chn,a_labels,a_data) ! Hack to get around some memory bug if (i_win .eq. 5) then c call mv_getfile(a_filename) end if end if if (i_dsp .gt. 0) then ! Redraw window 1 if event from a display click i_event(0) = i_dsp i_event(1) = 1 i_event(2) = 1 i_event(3) = i_vxo(i_dsp,1)-5 i_event(4) = i_vyo(i_dsp,1)-5 i_event(5) = i_vxs(i_dsp,1) i_event(6) = i_vys(i_dsp,1) if (i_debug .ge. 6) write(6,*) 'i_bcnt2 =',i_bcnt call buffer_cmd(i_event,i_bdat,i_bcnt,2,I_BMAX,i_abort,i_debug) end if else ! Create Colorbar i_shft = 0 i_chn=i_win-1 a_file=a_workdir(1:rdflen(a_workdir))//'colorbar.agr' open(unit=97,file=a_file,status='unknown',form='formatted') do i=0,min(i_dspnumt(i_chn)-1,252) write(97,'(5(a,i3),a)') '@map color ',i+2,' to (', & int(255*r_dspredt(i,i_chn)),', ',int(255*r_dspgrnt(i,i_chn)),', ',int(255*r_dspblut(i,i_chn)),'), "',i,' "' end do write(97,'(4(a,i3),a)') '@map color ',255,' to (',150,', ',150,', ',150,'), "Grey"' c write(6,*) 'dspmult = ',r_dspmult(i_chn),r_dspmult(i_chn)/5,alog10(r_dspmult(i_chn)/5.) c write(6,*) 'nintlog = ',nint(alog10(r_dspmult(i_chn)/5.)) c write(6,*) 'spacing = ',10.**nint(alog10(r_dspmult(i_chn)/5)) r_space = 10.**nint(alog10(r_dspmult(i_chn)/5)) if (r_space .gt. r_dspmult(i_chn)/4) r_space = r_space/2 if (r_space .gt. r_dspmult(i_chn)/4) r_space = r_space/2 if (r_space .gt. r_dspmult(i_chn)/4) r_space = r_space/2 if (r_space .lt. r_dspmult(i_chn)/8) r_space = r_space*2 if (r_space .lt. r_dspmult(i_chn)/8) r_space = r_space*2 if (r_space .lt. r_dspmult(i_chn)/8) r_space = r_space*2 c write(6,'(a,e15.4)') '@xaxis tick major ',r_space write(97,'(a)') '@version 50114' write(97,'(a)') '@g0 on' write(97,'(a)') '@with g0' write(97,'(a,e15.4)') '@ world xmin ',r_dspaddr(i_chn) write(97,'(a,e15.4)') '@ world xmax ',r_dspaddr(i_chn)+r_dspmult(i_chn) write(97,'(a,e15.4)') '@xaxis tick major ',r_space write(97,'(a)') '@view xmin 0.10' write(97,'(a)') '@view xmax 0.55' write(97,'(a)') '@view ymin 0.85' write(97,'(a)') '@view ymax 0.90' write(97,'(a)') '@xaxis on' write(97,'(a)') '@yaxis off' write(97,'(a)') '@s0 symbol 2' write(97,'(a)') '@s0 symbol size 0.2' write(97,'(a)') '@s0 symbol fill color 1' write(97,'(a)') '@s0 symbol fill pattern 1' write(97,'(a)') '@s0 symbol linewidth 1.0' write(97,'(a)') '@s0 symbol linestyle 0' write(97,'(a)') '@s0 linestyle 0' write(97,'(a)') '@s0 fill pattern 1' write(97,'(a)') '@s0 line type 0' write(97,'(a)') '@subtitle "Colorbar for '//a_setname(i_chn)(1:rdflen(a_setname(i_chn)))//'"' write(97,'(a)') '@type xycolor' do i=0,499 do j=0,100 r_value = max(r_dspcplw(i_chn),min(r_dspcphi(i_chn),i*r_dspmult(i_chn)/500+r_dspaddr(i_chn))) ! Clip data r_value = (r_value-r_dspaddr(i_chn)) ! Shift data if (i_dspmode(i_chn) .eq. 6) then ! Wrap data r_value = wrap(r_value,r_dspwrap(i_chn)) end if r_value = r_value/r_dspmult(i_chn) ! Scale data if (r_dspexpn(i_chn) .ne. 1.0) then ! Compress data r_value = min(1.0,max(0.0,r_value))**r_dspexpn(i_chn) end if i_value = max(0,min(i_dspnumt(i_chn)-1,int(i_dspnumt(i_chn)*r_value))) write(97,*) i*r_dspmult(i_chn)/500+r_dspaddr(i_chn),j/100.,min(i_value+2,254) end do end do close(97) a_command = 'xmgrace -noask -barebones -geometry 500x200 '//a_file(1:rdflen(a_file))//' &' write(6,*) 'Displaying Colorbar for ',a_setname(i_chn)(1:rdflen(a_setname(i_chn))) call system(a_command) end if else if (i_win .eq. max(4,min(i_set+1+2*i_close,I_CMAX+2)) ) then ! Click on close button if (i_close .eq. 1) call destroy_display(i_dsp) ! Closes Display change to: i_done = 1 if to quit whole program end if else if (i_evn .eq. 5) then ! button Release if (i_win .eq. 1 ) then ! button Release in window 1 i_button = i_bdat(3,1) i_col = i_bdat(4,1) i_row = i_bdat(5,1) if (i_debug .eq. -12 .or. i_debug .ge. 12) write(6,*) 'release win/button=',i_win,i_button if (i_win .eq. 1 .and. (i_button .eq. 1 .or. i_button .eq. 3)) then i_event(0) = i_dsp i_event(1) = i_win i_event(2) = 13 i_event(3) = i_button i_event(4) = i_col i_event(5) = i_row i_event(6) = 3 c write(6,*) 'adding event to buffer =',i_bcnt,i_dsp,i_win,4,-i_button call buffer_cmd(i_event,i_bdat,i_bcnt,2,I_BMAX,i_abort,i_debug) end if end if i_button = 0 else if (i_evn .eq. 6) then ! Key Press i_key = i_bdat(3,1) i_asc = i_bdat(6,1) if (i_debug .eq. -7 .or. i_debug .ge. 7) write(6,*) 'Key Press: ',i_key,i_asc if (i_key .eq. 62 .or. i_asc .eq. 65507) then i_cntl = 1 else if (i_key .eq. 64 .or. i_asc .eq. 65505) then i_shft = 1 else if (i_pset .eq. 1) then if (i_asc .eq. ichar('p') .or. i_asc .eq. ichar('P')) then i_event(0)=i_dsp i_event(1)=0 i_event(2)=0 i_event(3)=0 i_event(4)=6 i_event(5)=1 call buffer_cmd(i_event,i_bdat,i_bcnt,2,I_BMAX,i_abort,i_debug) else if (i_asc .eq. ichar('f') .or. i_asc .eq. ichar('F')) then i_event(0)=i_dsp i_event(1)=0 i_event(2)=0 i_event(3)=0 i_event(4)=6 i_event(5)=2 call buffer_cmd(i_event,i_bdat,i_bcnt,2,I_BMAX,i_abort,i_debug) else if (i_asc .eq. ichar('s') .or. i_asc .eq. ichar('S')) then i_event(0)=i_dsp i_event(1)=0 i_event(2)=0 i_event(3)=0 i_event(4)=6 i_event(5)=3 call buffer_cmd(i_event,i_bdat,i_bcnt,2,I_BMAX,i_abort,i_debug) end if i_pset = 0 i_cntl = 0 else if (i_sset .eq. 1) then if (i_asc .eq. ichar('p') .or. i_asc .eq. ichar('P')) then i_event(0)=i_dsp i_event(1)=0 i_event(2)=0 i_event(3)=0 i_event(4)=5 i_event(5)=1 call buffer_cmd(i_event,i_bdat,i_bcnt,2,I_BMAX,i_abort,i_debug) else if (i_asc .eq. ichar('l') .or. i_asc .eq. ichar('L')) then i_event(0)=i_dsp i_event(1)=0 i_event(2)=0 i_event(3)=0 i_event(4)=5 i_event(5)=2 call buffer_cmd(i_event,i_bdat,i_bcnt,2,I_BMAX,i_abort,i_debug) else if (i_asc .eq. ichar('r') .or. i_asc .eq. ichar('R')) then i_event(0)=i_dsp i_event(1)=0 i_event(2)=0 i_event(3)=0 i_event(4)=5 i_event(5)=3 call buffer_cmd(i_event,i_bdat,i_bcnt,2,I_BMAX,i_abort,i_debug) else if (i_asc .eq. ichar('c') .or. i_asc .eq. ichar('C')) then i_event(0)=i_dsp i_event(1)=0 i_event(2)=0 i_event(3)=0 i_event(4)=5 i_event(5)=4 call buffer_cmd(i_event,i_bdat,i_bcnt,2,I_BMAX,i_abort,i_debug) end if i_sset = 0 i_cntl = 0 else if (i_cntl .eq. 1) then if (i_asc .eq. ichar('a') .or. i_asc .eq. ichar('A')) then i_event(0)=i_dsp i_event(1)=0 i_event(2)=0 i_event(3)=0 i_event(4)=1 i_event(5)=1 call buffer_cmd(i_event,i_bdat,i_bcnt,2,I_BMAX,i_abort,i_debug) i_cntl = 0 else if (i_asc .eq. ichar('q') .or. i_asc .eq. ichar('Q')) then i_event(0)=i_dsp i_event(1)=0 i_event(2)=0 i_event(3)=0 i_event(4)=1 i_event(5)=2 call buffer_cmd(i_event,i_bdat,i_bcnt,2,I_BMAX,i_abort,i_debug) else if (i_asc .eq. ichar('d') .or. i_asc .eq. ichar('D')) then i_event(0)=i_dsp i_event(1)=0 i_event(2)=0 i_event(3)=0 i_event(4)=2 i_event(5)=1 call buffer_cmd(i_event,i_bdat,i_bcnt,2,I_BMAX,i_abort,i_debug) else if (i_asc .eq. ichar('k') .or. i_asc .eq. ichar('K')) then i_event(0)=i_dsp i_event(1)=0 i_event(2)=0 i_event(3)=0 i_event(4)=2 i_event(5)=2 call buffer_cmd(i_event,i_bdat,i_bcnt,2,I_BMAX,i_abort,i_debug) i_cntl = 0 else if (i_asc .eq. ichar('r') .or. i_asc .eq. ichar('R')) then ! Resize Display i_event(0)=i_dsp i_event(1)=0 i_event(2)=0 i_event(3)=0 i_event(4)=2 i_event(5)=3 call buffer_cmd(i_event,i_bdat,i_bcnt,2,I_BMAX,i_abort,i_debug) else if (i_asc .eq. ichar('n') .or. i_asc .eq. ichar('N')) then i_event(0)=i_dsp i_event(1)=0 i_event(2)=0 i_event(3)=0 i_event(4)=4 i_event(5)=1 call buffer_cmd(i_event,i_bdat,i_bcnt,2,I_BMAX,i_abort,i_debug) else if (i_asc .eq. ichar('+') .or. i_asc .eq. ichar('=')) then i_event(0)=i_dsp i_event(1)=0 i_event(2)=0 i_event(3)=0 i_event(4)=4 i_event(5)=2 call buffer_cmd(i_event,i_bdat,i_bcnt,2,I_BMAX,i_abort,i_debug) else if (i_asc .eq. ichar('-') .or. i_asc .eq. ichar('_')) then i_event(0)=i_dsp i_event(1)=0 i_event(2)=0 i_event(3)=0 i_event(4)=4 i_event(5)=3 call buffer_cmd(i_event,i_bdat,i_bcnt,2,I_BMAX,i_abort,i_debug) else if ((i_asc .eq. ichar('1') .or. i_asc .eq. ichar('!')) .and. i_set .ge. 1) then ! shortcut to open display parameter window 1 i_event(0)=i_dsp i_event(1)=2 i_event(2)=4 i_event(3)=3 i_event(4)=0 i_event(5)=0 call buffer_cmd(i_event,i_bdat,i_bcnt,2,I_BMAX,i_abort,i_debug) else if ((i_asc .eq. ichar('2') .or. i_asc .eq. ichar('@')) .and. i_set .ge. 2) then ! shortcut to open display parameter window 2 i_event(0)=i_dsp i_event(1)=3 i_event(2)=4 i_event(3)=3 i_event(4)=0 i_event(5)=0 call buffer_cmd(i_event,i_bdat,i_bcnt,2,I_BMAX,i_abort,i_debug) else if ((i_asc .eq. ichar('3') .or. i_asc .eq. ichar('#')) .and. i_set .ge. 3) then ! shortcut to open display parameter window 3 i_event(0)=i_dsp i_event(1)=4 i_event(2)=4 i_event(3)=3 i_event(4)=0 i_event(5)=0 call buffer_cmd(i_event,i_bdat,i_bcnt,2,I_BMAX,i_abort,i_debug) else if ((i_asc .eq. ichar('4') .or. i_asc .eq. ichar('$')) .and. i_set .ge. 4) then ! shortcut to open display parameter window 4 i_event(0)=i_dsp i_event(1)=5 i_event(2)=4 i_event(3)=3 i_event(4)=0 i_event(5)=0 call buffer_cmd(i_event,i_bdat,i_bcnt,2,I_BMAX,i_abort,i_debug) else if ((i_asc .eq. ichar('5') .or. i_asc .eq. ichar('%')) .and. i_set .ge. 5) then ! shortcut to open display parameter window 5 i_event(0)=i_dsp i_event(1)=6 i_event(2)=4 i_event(3)=3 i_event(4)=0 i_event(5)=0 call buffer_cmd(i_event,i_bdat,i_bcnt,2,I_BMAX,i_abort,i_debug) else if ((i_asc .eq. ichar('6') .or. i_asc .eq. ichar('^')) .and. i_set .ge. 6) then ! shortcut to open display parameter window 6 i_event(0)=i_dsp i_event(1)=6 i_event(2)=4 i_event(3)=3 i_event(4)=0 i_event(5)=0 call buffer_cmd(i_event,i_bdat,i_bcnt,2,I_BMAX,i_abort,i_debug) else if (i_asc .eq. ichar('z') .or. i_asc .eq. ichar('Z')) then i_event(0)=i_dsp i_event(1)=0 i_event(2)=0 i_event(3)=0 i_event(4)=4 i_event(5)=4 call buffer_cmd(i_event,i_bdat,i_bcnt,2,I_BMAX,i_abort,i_debug) i_cntl = 0 else if (i_asc .eq. ichar('p') .or. i_asc .eq. ichar('P')) then i_pset=1 if (i_debug .gt. 9) write(6,*) 'i_pset = ',i_pset,i_key,i_asc else if (i_asc .eq. ichar('s') .or. i_asc .eq. ichar('S')) then ! select menu set i_sset=1 if (i_debug .gt. 9) write(6,*) 'i_sset = ',i_sset,i_key,i_asc else if (i_asc .eq. ichar('t') .or. i_asc .eq. ichar('T')) then ! tool menu set i_tset=1 if (i_debug .gt. 9) write(6,*) 'i_tset = ',i_tset,i_key,i_asc end if else if (i_asc .eq. ichar('c') .or. i_asc .eq. ichar('C')) then i_samps=0 i_redraw(i_dsp) = 1 if (i_redraw(i_dsp) .eq. 1) then i_redraw(i_dsp) = 0 i_event(0) = i_dsp ! Redraw window i_event(1) = 1 i_event(2) = 1 i_event(3) = i_vxo(i_dsp,1)-5 i_event(4) = i_vyo(i_dsp,1)-5 i_event(5) = i_vxs(i_dsp,1) i_event(6) = i_vys(i_dsp,1) if (i_debug .ge. 6) write(6,*) 'i_bcnt2 =',i_bcnt call buffer_cmd(i_event,i_bdat,i_bcnt,2,I_BMAX,i_abort,i_debug) end if else if (i_asc .eq. ichar('d') .or. i_asc .eq. ichar('D')) then i_show=1-i_show do i=0,20 a_elabl(i)=' ' a_edata(i)=' ' end do a_elabl(6)='Display: ' write(a_edata(6),'(i1,a)') i_show+1,'|Off|On' ! Sample Display ON/Off a_elabl(7)='Mode: ' write(a_edata(7),'(i1,a)') i_smode+1,'|None|Point|Line|Region' call entry_window(0,a_elabl,a_edata) i_dspselect=i_dsp a_elabl(6)=' ' a_edata(6)=' ' a_elabl(7)=' ' a_edata(7)=' ' i_event(0) = i_dsp ! Redraw window i_event(1) = 1 i_event(2) = 1 i_event(3) = i_vxo(i_dsp,1)-5 i_event(4) = i_vyo(i_dsp,1)-5 i_event(5) = i_vxs(i_dsp,1) i_event(6) = i_vys(i_dsp,1) if (i_debug .ge. 6) write(6,*) 'i_bcnt2 =',i_bcnt call buffer_cmd(i_event,i_bdat,i_bcnt,2,I_BMAX,i_abort,i_debug) else if (i_asc .eq. ichar('n') .or. i_asc .eq. ichar('N')) then i_smode=0 do i=0,20 a_elabl(i)=' ' a_edata(i)=' ' end do a_elabl(6)='Display: ' write(a_edata(6),'(i1,a)') i_show+1,'|Off|On' ! Sample Display ON/Off a_elabl(7)='Mode: ' write(a_edata(7),'(i1,a)') i_smode+1,'|None|Point|Line|Region' call entry_window(0,a_elabl,a_edata) i_dspselect=i_dsp a_elabl(6)=' ' a_edata(6)=' ' a_elabl(7)=' ' a_edata(7)=' ' else if (i_asc .eq. ichar('p') .or. i_asc .eq. ichar('P')) then i_smode=1 i_show=1 do i=0,20 a_elabl(i)=' ' a_edata(i)=' ' end do a_elabl(6)='Display: ' write(a_edata(6),'(i1,a)') i_show+1,'|Off|On' ! Sample Display ON/Off a_elabl(7)='Mode: ' write(a_edata(7),'(i1,a)') i_smode+1,'|None|Point|Line|Region' call entry_window(0,a_elabl,a_edata) i_dspselect=i_dsp a_elabl(6)=' ' a_edata(6)=' ' a_elabl(7)=' ' a_edata(7)=' ' else if (i_asc .eq. ichar('l') .or. i_asc .eq. ichar('L')) then i_smode=2 i_show=1 do i=0,20 a_elabl(i)=' ' a_edata(i)=' ' end do a_elabl(6)='Display: ' write(a_edata(6),'(i1,a)') i_show+1,'|Off|On' ! Sample Display ON/Off a_elabl(7)='Mode: ' write(a_edata(7),'(i1,a)') i_smode+1,'|None|Point|Line|Region' call entry_window(0,a_elabl,a_edata) i_dspselect=i_dsp a_elabl(6)=' ' a_edata(6)=' ' a_elabl(7)=' ' a_edata(7)=' ' else if (i_asc .eq. ichar('r') .or. i_asc .eq. ichar('R')) then i_smode=3 i_show=1 do i=0,20 a_elabl(i)=' ' a_edata(i)=' ' end do a_elabl(6)='Display: ' write(a_edata(6),'(i1,a)') i_show+1,'|Off|On' ! Sample Display ON/Off a_elabl(7)='Mode: ' write(a_edata(7),'(i1,a)') i_smode+1,'|None|Point|Line|Region' call entry_window(0,a_elabl,a_edata) i_dspselect=i_dsp a_elabl(6)=' ' a_edata(6)=' ' a_elabl(7)=' ' a_edata(7)=' ' end if else if (i_evn .eq. 7) then ! Key Release if (i_bdat(3,1) .eq. 62 .or. i_bdat(6,1) .eq. 65507) i_cntl = 0 if (i_bdat(3,1) .eq. 64 .or. i_bdat(6,1) .eq. 65505) i_shft = 0 if (i_debug .eq. -7 .or. i_debug .ge. 7) write(6,*) 'Key Release: ',i_bdat(3,1),i_bdat(6,1) c i_cntl = 0 i_key = 0 i_asc = 0 else if (i_evn .eq. 8) then ! Destroy Window event if (i_debug .ge. 6) write(6,*) '*** Window Destroyed: ',i_dsp,i_win i_winactv(i_dsp) = 0 do ib = 1,i_bcnt ! Clear out any remaining event in buffer for destroyed window if (i_bdat(0,ib) .eq. i_dsp .and. i_bdat(1,ib) .eq. i_win) then do ie = 0,10 i_bdat(ie,ib) = 0 end do end if end do i_done = 1 do i_d=1,I_DMAX if (i_winactv(i_d) .eq. 1) i_done = 0 end do else if (i_evn .eq. 9) then ! Mouse motion i_button = nint(i_bdat(3,1)/256.) if (i_debug .eq. -12 .or. i_debug .ge. 12) write(6,*) 'button in motion = ',i_bdat(3,1),nint(i_bdat(3,1)/256.) if (i_button .eq. 4) then i_button = 3 end if i_col = i_bdat(4,1) i_row = i_bdat(5,1) if (i_debug .eq. -12 .or. i_debug .ge. 12) write(6,*) 'motion win/button=',i_win,i_button if (i_win .eq. 1 .and. (i_button .eq. 1 .or. i_button .eq. 3)) then i_event(0) = i_dsp i_event(1) = i_win i_event(2) = 13 i_event(3) = i_button i_event(4) = i_col i_event(5) = i_row i_event(6) = 2 c write(6,*) 'i_bcnt2 =',i_bcnt call buffer_cmd(i_event,i_bdat,i_bcnt,2,I_BMAX,i_abort,i_debug) end if else if (i_evn .eq. 10) then ! Entry Window change i_chn = i_bdat(0,1) if (i_chn .lt. 0) write(6,*) '*** i_chn Error *** ',i_chn i_field = i_bdat(4,1) i_value = i_bdat(5,1) i_msgid = i_bdat(6,1) call get_message(i_msgid,a_message) if (i_chn .gt. 0) then if (i_field .ne. 9) then if (index(a_message,'.') .eq. 0 .and. index(a_message,'*') .eq. 0 .and. & rdflen(a_message) .gt. 0) a_message=a_message(1:rdflen(a_message))//'.' end if if (i_debug .ge. 6) write(6,*) 'channel=',i_chn,' field=',i_field, & ' ival=',i_value,' msg=',a_message(1:30) if (i_field .eq. 1) then i_ewupdate=1 if (i_value .eq. 1) then ! Range Mode i_dspmult(i_chn) = 0 i_dspaddr(i_chn) = 0 i_dspmode(i_chn)=i_value else if (i_value .eq. 2) then ! SDEV Mode if (r_dspval1(i_chn) .eq. 0) r_dspval1(i_chn)=2.0 if (i_dspmode(i_chn) .eq. 2) then i_dspaddr(i_chn) = 1 end if i_dspmult(i_chn)=1 i_dspmode(i_chn)=i_value else if (i_value .eq. 3) then ! Percent Mode if (r_dspval2(i_chn) .eq. 0) r_dspval2(i_chn)=90.0 i_dspaddr(i_chn)=1 i_dspmult(i_chn)=1 i_dspmode(i_chn)=i_value else if (i_value .eq. 5) then ! CW Mode if (r_dspval3(i_chn) .eq. 0) r_dspval3(i_chn)=1.0 r_dspaddr(i_chn)=0 i_dspaddr(i_chn)=0 i_dspmult(i_chn)=1 i_dspmode(i_chn)=i_value else if (i_value .eq. 6) then if (i_dspmode(i_chn) .ne. 6) then r_dspwrap(i_chn) = r_dspmult(i_chn) r_dspaddr(i_chn) = 0 i_dspmult(i_chn) = 0 i_dspaddr(i_chn) = 0 end if i_dspmode(i_chn)=i_value end if else if (i_field .eq. 2) then call decodeval(a_message,r_value,i_err) c read(a_message,*,iostat=i_err) r_value if (i_err .ne. 0) then i_ewupdate = 1 else if (i_dspmode(i_chn) .eq. 1) then if (r_value .ne. 0.) then r_dspmult(i_chn) = r_value i_dspmult(i_chn) = 0 else i_dspmult(i_chn) = 1 r_dspval1(i_chn) = 2 end if else if (i_dspmode(i_chn) .eq. 2) then if (r_value .ne. 0. ) then r_dspval1(i_chn) = r_value i_dspmult(i_chn) = 1 else if (r_dspval1(i_chn) .eq. 0) r_dspval1(i_chn)=2.0 end if else if (i_dspmode(i_chn) .eq. 3) then if (r_value .ne. 0.) then r_dspval2(i_chn) = r_value i_dspmult(i_chn) = 1 else if (r_dspval2(i_chn) .eq. 0) r_dspval2(i_chn)=90.0 end if else if (i_dspmode(i_chn) .eq. 4) then ! undefined else if (i_dspmode(i_chn) .eq. 5) then if (r_value .ne. 0.) then r_dspval3(i_chn) = r_value i_dspmult(i_chn) = 1 else if (r_dspval3(i_chn) .eq. 0) r_dspval1(i_chn)=1.0 end if else if (i_dspmode(i_chn) .eq. 6) then if (r_value .ne. 0.) r_dspwrap(i_chn) = r_value r_dspmult(i_chn)=r_dspwrap(i_chn) end if end if else if (i_field .eq. 3) then call decodeval(a_message,r_value,i_err) if (i_err .ne. 0) then i_ewupdate = 1 else c if (r_value .ne. r_dspaddr(i_chn)) i_ewupdate = 1 r_dspaddr(i_chn) = r_value i_dspaddr(i_chn)=0 end if else if (i_field .eq. 4) then call decodeval(a_message,r_value,i_err) if (i_err .ne. 0) then i_ewupdate = 1 else c if (r_value .ne. r_dspexpn(i_chn)) i_ewupdate = 1 r_dspexpn(i_chn) = r_value end if else if (i_field .eq. 5) then call decodeval(a_message,r_value,i_err) if (i_err .ne. 0) then i_ewupdate = 1 else c if (r_value .ne. r_setvmin(i_chn)) i_ewupdate = 1 r_setvmin(i_chn) = r_value end if else if (i_field .eq. 6) then call decodeval(a_message,r_value,i_err) if (i_err .ne. 0) then i_ewupdate = 1 else c if (r_value .ne. r_setvmax(i_chn)) i_ewupdate = 1 r_setvmax(i_chn) = r_value end if else if (i_field .eq. 7) then call decodeval(a_message,r_value,i_err) if (i_err .ne. 0) then i_ewupdate = 1 else c if (r_value .ne. r_dspcplw(i_chn)) i_ewupdate = 1 r_dspcplw(i_chn) = r_value end if else if (i_field .eq. 8) then call decodeval(a_message,r_value,i_err) if (i_err .ne. 0) then i_ewupdate = 1 else c if (r_value .ne. r_dspcphi(i_chn)) i_ewupdate = 1 r_dspcphi(i_chn) = r_value end if else if (i_field .eq. 9) then c if (a_message .eq. ' ') then if (i_value .ne. 0) then i_colorset = i_value if (i_colorset .gt. 0 .and. i_colorset .le. i_colormax) then if (a_colorfile(i_colorset) .ne. a_dspctbl(i_chn)) i_ewupdate = 1 a_dspctbl(i_chn)=a_colorfile(i_colorset) if (i_colorset .eq. 1) a_dspctbl(i_chn)=' ' i_colorset = 0 end if else if (a_message .eq. ' ') a_message='?' if (a_message .ne. a_dspctbl(i_chn)) i_ewupdate = 1 a_dspctbl(i_chn)=a_message if (index(a_dspctbl(i_chn),' - not found. Using grey') .gt. 1) then a_dspctbl(i_chn)=a_dspctbl(i_chn)(1:index(a_dspctbl(i_chn),' - not found. Using grey')-1) end if end if call get_colortable(a_colordir,a_dspctbl(i_chn),i_dspnumt(i_chn), & r_dspredt(0,i_chn),r_dspgrnt(0,i_chn),r_dspblut(0,i_chn),i_debug) end if c if (i_dspmult(i_chn) .eq. 1 .or. i_dspaddr(i_chn) .eq. 1) then if (1 .eq. 1) then i_event(0) = i_chn i_event(1) = 1 i_event(2) = 11 i_event(3) = 0 i_event(4) = 0 i_event(5) = 0 i_event(6) = 0 if (i_debug .ge. 6) write(6,*) 'Going to recompute mean/Std i_bcnt2 =',i_bcnt call buffer_cmd(i_event,i_bdat,i_bcnt,2,I_BMAX,i_abort,i_debug) end if if (1 .eq. i_ewupdate) then ! Add command to buffer to re-draw entry window i_event(0) = 0 i_event(1) = i_chn+1 i_event(2) = 4 i_event(3) = 3 i_event(4) = 0 i_event(5) = 0 i_event(6) = 0 if (i_debug .ge. 6) write(6,*) 'Going to redraw entry window i_bcnt2 =',i_bcnt call buffer_cmd(i_event,i_bdat,i_bcnt,2,I_BMAX,i_abort,i_debug) i_ewupdate = 0 end if do i_d=1,I_DMAX if (i_debug .ge. 6) write(6,*) 'i_winactv=',i_winactv(i_d),i_d if (i_winactv(i_d) .eq. 1) then i_event(0) = i_d i_event(1) = 1 i_event(2) = 1 i_event(3) = i_vxo(i_d,1)-5 i_event(4) = i_vyo(i_d,1)-5 i_event(5) = i_vxs(i_d,1) i_event(6) = i_vys(i_d,1) if (i_debug .ge. 6) write(6,*) 'i_bcnt2 =',i_bcnt call buffer_cmd(i_event,i_bdat,i_bcnt,2,I_BMAX,i_abort,i_debug) end if end do c write(a_data(1),'(i10)') i_dspmode(i_chn) c if (i_dspmode(i_chn) .eq. 1) then c a_labels(2)='Range:' c write(a_data(2),'(f15.4)') r_dspmult(i_chn) c else if (i_dspmode(i_chn) .eq. 2) then c a_labels(2)='SDEV Factor:' c write(a_data(2),'(f15.2)') r_dspval1(i_chn) c else c a_labels(2)='Wrap:' c write(a_data(2),'(f15.4)') r_dspwrap(i_chn) c end if c write(a_data(3),'(f15.4)') r_dspaddr(i_chn) c write(a_data(4),'(f15.4)') r_setvmin(i_chn) c write(a_data(5),'(f15.4)') r_setvmax(i_chn) c write(a_data(6),'(f15.4)') r_dspcplw(i_chn) c write(a_data(7),'(f15.4)') r_dspcphi(i_chn) c a_data(8)=a_dspctbl(i_chn) c call entry_window(i_chn,a_labels,a_data) else if (i_field .eq. 1) then read(a_message,*,iostat=i_err) i_col,i_row if (i_err .eq. 0) then i_rcenter=i_row i_ccenter=i_col i_cdsp=i_dspselect c write(6,*) 'i_key=',i_key if (i_debug .ge. 9) write(6,*) 'moving scroll to',i_ccenter,i_rcenter if (i_winactv(i_dspselect) .ne. 0) then if (i_winradr(i_dspselect) .ne. & max(min(i_rcenter-int((32000/2)/r_winzoom(i_dspselect)), & i_setrows(1)-int(32000/r_winzoom(i_dspselect))),0) ) then i_winradr(i_dspselect) = & max(min(i_rcenter-int((32000/2)/r_winzoom(i_dspselect)), & i_setrows(1)-int(32000/r_winzoom(i_dspselect))),0) i_redraw(i_dspselect)=1 end if if (i_wincadr(i_dspselect) .ne. & max(min(i_ccenter-int((32000/2)/r_winzoom(i_dspselect)), & i_setcols(1)-int(32000/r_winzoom(i_dspselect))),0) ) then i_wincadr(i_dspselect) = & max(min(i_ccenter-int((32000/2)/r_winzoom(i_dspselect)), & i_setcols(1)-int(32000/r_winzoom(i_dspselect))),0) i_redraw(i_dspselect)=1 end if if (i_redraw(i_dspselect) .eq. 1) then i_redraw(i_dspselect) = 0 i_event(0) = i_dspselect ! Redraw window i_event(1) = 1 i_event(2) = 1 i_event(3) = i_vxo(i_dspselect,1)-5 i_event(4) = i_vyo(i_dspselect,1)-5 i_event(5) = i_vxs(i_dspselect,1) i_event(6) = i_vys(i_dspselect,1) if (i_debug .ge. 6) write(6,*) 'i_bcnt2 =',i_bcnt call buffer_cmd(i_event,i_bdat,i_bcnt,2,I_BMAX,i_abort,i_debug) end if i_cpos = nint((i_ccenter-i_wincadr(i_dspselect))*r_winzoom(i_dspselect)-0.5*i_vxs(i_dspselect,1)) i_rpos = nint((i_rcenter-i_winradr(i_dspselect))*r_winzoom(i_dspselect)-0.5*i_vys(i_dspselect,1)) call move_scroll(i_dspselect,1,i_cpos,i_rpos) end if end if else if (i_field .eq. 2) then read(a_message,*,iostat=i_err) r_lat,r_lon if (i_err .eq. 0) then r_eux(1)=r_lat/r_rtod r_eux(2)=r_lon/r_rtod r_eux(3)=0.0 call get_coordinates(a_setproj(1),r_setpegv(1,1),r_dnx,r_eux,2,i_debug,i_err) i_rcenter=((r_dnx(1)-r_setradr(1))/r_setrmlt(1)-i_winradr(1) ) i_ccenter=((r_dnx(2)-r_setcadr(1))/r_setcmlt(1)-i_wincadr(1) ) i_cdsp=i_dspselect c write(6,*) 'i_key=',i_key if (i_debug .eq. -9 .or. i_debug .ge. 9) write(6,*) 'moving scroll to',i_ccenter,i_rcenter if (i_winactv(i_dspselect) .ne. 0) then if (i_winradr(i_dspselect) .ne. & max(min(i_rcenter-int((32000/2)/r_winzoom(i_dspselect)), & i_setrows(1)-int(32000/r_winzoom(i_dspselect))),0) ) then i_winradr(i_dspselect) = & max(min(i_rcenter-int((32000/2)/r_winzoom(i_dspselect)), & i_setrows(1)-int(32000/r_winzoom(i_dspselect))),0) i_redraw(i_dspselect)=1 end if if (i_wincadr(i_dspselect) .ne. & max(min(i_ccenter-int((32000/2)/r_winzoom(i_dspselect)), & i_setcols(1)-int(32000/r_winzoom(i_dspselect))),0) ) then i_wincadr(i_dspselect) = & max(min(i_ccenter-int((32000/2)/r_winzoom(i_dspselect)), & i_setcols(1)-int(32000/r_winzoom(i_dspselect))),0) i_redraw(i_dspselect)=1 end if if (i_redraw(i_dspselect) .eq. 1) then i_redraw(i_dspselect) = 0 i_event(0) = i_dspselect ! Redraw window i_event(1) = 1 i_event(2) = 1 i_event(3) = i_vxo(i_dspselect,1)-5 i_event(4) = i_vyo(i_dspselect,1)-5 i_event(5) = i_vxs(i_dspselect,1) i_event(6) = i_vys(i_dspselect,1) if (i_debug .eq. -6 .or. i_debug .ge. 6) write(6,*) 'i_bcnt2 =',i_bcnt call buffer_cmd(i_event,i_bdat,i_bcnt,2,I_BMAX,i_abort,i_debug) end if i_cpos = nint((i_ccenter-i_wincadr(i_dspselect))*r_winzoom(i_dspselect)-0.5*i_vxs(i_dspselect,1)) i_rpos = nint((i_rcenter-i_winradr(i_dspselect))*r_winzoom(i_dspselect)-0.5*i_vys(i_dspselect,1)) call move_scroll(i_dspselect,1,i_cpos,i_rpos) end if end if else if (i_field .eq. 3) then read(a_message,*,iostat=i_err) r_winzoom(0) if (r_winzoom(0) .lt. 0) r_winzoom(0) = abs(1./r_winzoom(0)) else if (i_field .eq. 4) then if (i_value .eq. 1) then write(6,*) 'Print Format PPM' else if (i_value .eq. 2) then write(6,*) 'Raw RGB Not Supported - Using PPM' else if (i_value .eq. 3) then write(6,*) 'PostScript Not Supported - Using PPM' else write(6,*) 'Print Format Not Supported - Using PPM' end if else if (i_field .eq. 5) then if (i_debug .ge. 8) write(6,*) '--i_cdsp,i_cset = ',i_cdsp,i_cset if (i_cdsp .ne. 0 .and. i_cdsp .ne. i_dspselect) then i_rcenter=nint((i_vyo(i_dspselect,1)+ & 0.5*i_vys(i_dspselect,1))/r_winzoom(i_dspselect))+i_winradr(i_dspselect) i_ccenter=nint((i_vxo(i_dspselect,1)+ & 0.5*i_vxs(i_dspselect,1))/r_winzoom(i_dspselect))+i_wincadr(i_dspselect) end if if (i_debug .ge. 6) write(6,*) 'Center was at (col,row): ',i_ccenter,i_rcenter read(a_message,*,iostat=i_err) r_winzoom(i_dspselect) if (r_winzoom(i_dspselect) .lt. 0.) r_winzoom(i_dspselect) = abs(1./r_winzoom(i_dspselect)) i_winrows(i_dspselect) = min(nint(i_setrows(1)*r_winzoom(i_dspselect)),32000) i_wincols(i_dspselect) = min(nint(i_setcols(1)*r_winzoom(i_dspselect)),32000) call resize_win(i_dspselect,1,i_wincols(i_dspselect),i_winrows(i_dspselect)) if (i_winradr(i_dspselect) .ne. & max(min(i_rcenter-int((32000/2)/r_winzoom(i_dspselect)), & i_setrows(1)-int(32000/r_winzoom(i_dspselect))),0)) then i_winradr(i_dspselect) = & max(min(i_rcenter-int((32000/2)/r_winzoom(i_dspselect)), & i_setrows(1)-int(32000/r_winzoom(i_dspselect))),0) i_redraw(i_dspselect)=1 end if if (i_wincadr(i_dspselect) .ne. & max(min(i_ccenter-int((32000/2)/r_winzoom(i_dspselect)), & i_setcols(1)-int(32000/r_winzoom(i_dspselect))),0)) then i_wincadr(i_dspselect) = & max(min(i_ccenter-int((32000/2)/r_winzoom(i_dspselect)), & i_setcols(1)-int(32000/r_winzoom(i_dspselect))),0) i_redraw(i_dspselect)=1 end if if (i_redraw(i_dspselect) .eq. 1) then i_redraw(i_dspselect) = 0 i_event(0) = i_dspselect ! Redraw window i_event(1) = 1 i_event(2) = 1 i_event(3) = i_vxo(i_dspselect,1)-5 i_event(4) = i_vyo(i_dspselect,1)-5 i_event(5) = i_vxs(i_dspselect,1) i_event(6) = i_vys(i_dspselect,1) if (i_debug .ge. 6) write(6,*) 'i_bcnt2 =',i_bcnt call buffer_cmd(i_event,i_bdat,i_bcnt,2,I_BMAX,i_abort,i_debug) end if i_cpos = nint((i_ccenter-i_wincadr(i_dspselect))*r_winzoom(i_dspselect)-0.5*i_vxs(i_dspselect,1)) i_rpos = nint((i_rcenter-i_winradr(i_dspselect))*r_winzoom(i_dspselect)-0.5*i_vys(i_dspselect,1)) if (i_debug .ge. 9) write(6,*) 'moving scroll to',i_cpos,i_rpos call move_scroll(i_dspselect,1,i_cpos,i_rpos) i_cset = 1 i_event(0) = i_dspselect i_event(1) = 1 i_event(2) = 1 i_event(3) = i_vxo(i_dspselect,1)-5 i_event(4) = i_vyo(i_dspselect,1)-5 i_event(5) = i_vxs(i_dspselect,1) i_event(6) = i_vys(i_dspselect,1) if (i_debug .ge. 6) write(6,*) 'i_bcnt2 =',i_bcnt call buffer_cmd(i_event,i_bdat,i_bcnt,2,I_BMAX,i_abort,i_debug) if (r_winzoom(i_dspselect) .ge. 1.0) then write(a_label,'(a,i3,a)') 'ZOOM:',nint(r_winzoom(i_dspselect)),'x' else write(a_label,'(a,i3,a)') 'ZOOM:',-nint(1.0/r_winzoom(i_dspselect)),'x' end if call display_label(i_dspselect,1,a_label,1) else if (i_field .eq. 6) then ! Sample Display ON/Off if (i_value .eq. 1) then i_show = 0 else i_show = 1 end if i_event(0) = i_dspselect ! Redraw window i_event(1) = 1 i_event(2) = 1 i_event(3) = i_vxo(i_dspselect,1)-5 i_event(4) = i_vyo(i_dspselect,1)-5 i_event(5) = i_vxs(i_dspselect,1) i_event(6) = i_vys(i_dspselect,1) if (i_debug .ge. 6) write(6,*) 'i_bcnt2 =',i_bcnt call buffer_cmd(i_event,i_bdat,i_bcnt,2,I_BMAX,i_abort,i_debug) else if (i_field .eq. 7) then ! Select Mode i_smode = i_value-1 else if (i_field .eq. 8) then ! Sample Display ON/Off if (i_smode .lt. 3) then read(a_message,*,iostat=i_err) r_wdth else read(a_message,*,iostat=i_err) r_spce end if end if end if else if (i_evn .eq. 11) then ! Re-scale set i_chn = abs(i_bdat(0,1)) if (i_debug .ge. 3) write(6,'(1x,a,i3)') 'Computing display stats for set: ',i_chn i_err = 0 i_cnt = 0 r_sum = 0. r_sqr = 0. do i_row = 0,i_setrows(i_chn)-1,min(max(i_setrows(i_chn)/100,1),20000) do i_col = 0, i_setcols(i_chn)-1, min(max(i_setcols(i_chn)/100,1),20000) if (a_setfile(i_chn)(1:1) .ne. '=') then call readdat(i_setunit(i_chn), & i_setrows(i_chn), & i_setcols(i_chn), & i_setshdr(i_chn), & i_setstlr(i_chn), & i_setrhdr(i_chn), & i_setrtlr(i_chn), & i_setchdr(i_chn), & i_setctlr(i_chn), & i_setvend(i_chn)*i_endian, & i_setvfmt(i_chn), & r_setvmlt(i_chn), & r_setvadr(i_chn), & r_setvmin(i_chn), & r_setvmax(i_chn), & b_setvnul(0,i_chn), & i_row,i_col-1,3,r_data,i_data,readfunc,i_err) else c write(6,*) 'i_row,col=',i_row,i_col do j=0,2 r_data(j)=0 i_data(j)=0 end do i_opr=1 i_flg=0 a_value = ' ' do i = 2,rdflen(a_setfile(i_chn))+1 if (index('+-*/x',a_setfile(i_chn)(i:i)) .gt. 0 .or. a_setfile(i_chn)(i:i) .eq. ' ') then if (a_value .ne. ' ') then read(a_value,*) r_value if (i_opr .eq. 1) then r_data(1)=r_data(1)+r_value else if (i_opr .eq. 2) then r_data(1)=r_data(1)-r_value else if (i_opr .eq. 3) then r_data(1)=r_data(1)*r_value else if (i_opr .eq. 4) then r_data(1)=r_data(1)/r_value end if a_value = ' ' end if end if if(a_setfile(i_chn)(i:i) .eq. '+') then i_opr=1 else if (a_setfile(i_chn)(i:i) .eq. '-') then i_opr=2 else if (a_setfile(i_chn)(i:i) .eq. 'x') then i_opr=3 else if (a_setfile(i_chn)(i:i) .eq. 's' .or. a_setfile(i_chn)(i:i) .eq. 'S') then i_flg=1 else if (i_flg .eq. 1) then i_flg = 0 i_tmp = max(min((ichar(a_setfile(i_chn)(i:i))-ichar('0')),i_set+1),1) i_tmp = max(min((ichar(a_setfile(i_chn)(i:i))-48),i_set+1),0) c write(6,*) 'reading ',i_tmp,i_opr,i_data(1) if (i_tmp .gt. i_set) i_tmp=0 if (i_tmp .ne. 0) then call readdat(i_setunit(i_tmp), & i_setrows(i_tmp), & i_setcols(i_tmp), & i_setshdr(i_tmp), & i_setstlr(i_tmp), & i_setrhdr(i_tmp), & i_setrtlr(i_tmp), & i_setchdr(i_tmp), & i_setctlr(i_tmp), & i_setvend(i_tmp)*i_endian, & i_setvfmt(i_tmp), & r_setvmlt(i_tmp), & r_setvadr(i_tmp), & r_setvmin(i_tmp), & r_setvmax(i_tmp), & b_setvnul(0,i_tmp), & i_row,i_col-1,3,r_data2,i_data2,readfunc,i_err) i_data(1)=i_data(1)+i_data2(1) if (i_opr .eq. 1) then r_data(1)=r_data(1)+r_data2(1) else if (i_opr .eq. 2) then r_data(1)=r_data(1)-r_data2(1) else if (i_opr .eq. 3) then r_data(1)=r_data(1)*r_data2(1) else r_data(1)=r_data(1)+r_data2(1) end if end if else a_value = a_value(1:max(1,rdflen(a_value)))//a_setfile(i_chn)(i:i) end if end do end if !@#$% if (i_data(1) .eq. 0) then i_cnt = i_cnt + 1 i_c = 1 r_data(i_c) = max(r_dspcplw(i_chn),min(r_dspcphi(i_chn ! Clip data & ),r_data(i_c))) c if (r_dspwrap(i_chn) .ne. 0.0) r_data(i_c) = ! Wrap data c & wrap(r_data(i_c),r_dspwrap(i_chn)) r_val(min(i_cnt,I_WKSPACE)) = r_data(i_c) r_sum = r_sum + dble(r_data(i_c)) r_sqr = r_sqr + dble(r_data(i_c))**2.0d0 end if end do end do if (i_debug .ge. 5) write(6,*) 'i_cnt,r_sum,r_sqr = ',i_cnt,r_sum,r_sqr if (i_cnt .gt. 0) then r_avg = r_sum/max(i_cnt,1) r_std = sqrt(max(1.d-99,(r_sqr/max(i_cnt,1))-(r_avg)**2)) r_setvavg(i_chn)=r_avg r_setvstd(i_chn)=r_std if (i_debug .ge. 4) write(6,*) 'average = ',r_setvavg(i_chn),i_cnt if (i_dspmode(i_chn) .eq. 3) then call median( (1.-(r_dspval2(i_chn)/100))/2.,min(i_cnt,I_WKSPACE),r_val,r_median) r_dspaddr(i_chn)=r_median call median(1.-(1.-(r_dspval2(i_chn)/100))/2.,min(i_cnt,I_WKSPACE),r_val,r_median) r_dspmult(i_chn)=r_median-r_dspaddr(i_chn) if (i_debug .ge. 4) write(6,*) 'median = ',r_dspaddr(i_chn),r_median,i_cnt else if (i_dspmode(i_chn) .eq. 5) then r_dspaddr(i_chn)=0. r_dspmult(i_chn)=r_avg/(0.7*r_dspval3(i_chn)) else if (i_dspaddr(i_chn) .eq. 1) r_dspaddr(i_chn) = r_avg-(r_dspval1(i_chn)*r_std) if (i_dspmult(i_chn) .eq. 1) r_dspmult(i_chn) = 2.*r_dspval1(i_chn)*r_std end if else r_dspaddr(i_chn) = 0.0d0 r_dspmult(i_chn) = 1.0d0 end if if (i_debug .ge. 3) write(6,*) 'dsp add/mult = ',r_dspaddr(i_chn),r_dspmult(i_chn) if (i_bdat(0,1) .lt. 0) then write(a_data(1),'(i10)') i_dspmode(i_chn) if (i_dspmode(i_chn) .eq. 1) then a_labels(2)='Range:' write(a_data(2),'(f15.4)') r_dspmult(i_chn) a_labels(3)='Offset:' write(a_data(3),'(f15.4)') r_dspaddr(i_chn) else if (i_dspmode(i_chn) .eq. 2) then a_labels(2)='SDEV Factor:' write(a_data(2),'(f15.2)') r_dspval1(i_chn) a_labels(3)='Offset:' write(a_data(3),'(f15.4)') r_dspaddr(i_chn) else if (i_dspmode(i_chn) .eq. 3) then a_labels(2)='Percent:' write(a_data(2),'(f15.2)') r_dspval2(i_chn) a_labels(3) = ' ' a_data(3) = ' ' else if (i_dspmode(i_chn) .eq. 4) then a_labels(2)=' ' write(a_data(2),'(f15.2)') r_dspmult(i_chn) a_labels(3)=' ' write(a_data(3),'(f15.4)') r_dspaddr(i_chn) else if (i_dspmode(i_chn) .eq. 5) then a_labels(2)='CW Scale:' write(a_data(2),'(f15.2)') r_dspval3(i_chn) a_labels(3) = ' ' a_data(3) = ' ' else a_labels(2)='Wrap:' write(a_data(2),'(f15.4)') r_dspwrap(i_chn) a_labels(3)='Offset:' write(a_data(3),'(f15.4)') r_dspaddr(i_chn) end if call encodeval(r_dspexpn(i_chn),a_data(4)) call encodeval(r_setvmin(i_chn),a_data(5)) call encodeval(r_setvmax(i_chn),a_data(6)) call encodeval(r_dspcplw(i_chn),a_data(7)) call encodeval(r_dspcphi(i_chn),a_data(8)) c write(a_data(4),'(f15.4)') r_dspexpn(i_chn) c write(a_data(5),'(f15.4)') r_setvmin(i_chn) c write(a_data(6),'(f15.4)') r_setvmax(i_chn) c write(a_data(7),'(f15.4)') r_dspcplw(i_chn) c write(a_data(8),'(f15.4)') r_dspcphi(i_chn) i_colorset=0 do i=1,i_colormax if (a_dspctbl(i_chn) .eq. a_colorfile(i)) i_colorset=i end do if (i_colorset .gt. 0) then write(a_data(9),'(i2)') i_colorset do i=1,i_colormax a_data(9)=a_data(9)(1:rdflen(a_data(9)))//'|'//a_colorname(i) end do if (a_data(9)(1:1) .eq. ' ') a_data(9)=a_data(9)(2:) else a_data(9)=a_dspctbl(i_chn) end if call entry_window(i_chn,a_labels,a_data) end if else if (i_evn .eq. 12) then ! file name i_value = i_bdat(5,1) i_msgid = i_bdat(6,1) if (i_msgid .ge. 0) then call get_message(i_msgid,a_message) else a_message=a_ptsfile a_ptsfile=' ' end if if (i_debug .eq. -14 .or. i_debug .ge. 14) write(6,*) 'File message = ',i_msgid,i_value,' ',a_message if (i_value .eq. 43) then ! import points file open(91,file=a_message,status='old',form='formatted',iostat=i_err) i_samps=0 do while(i_err .eq. 0) read(91,'(3i8,5e15.5)',iostat=i_err) i_csamps(i_samps+1),i_rsamps(i_samps+1),i_tsamps(i_samps+1) if (i_err .eq. 0) then i_samps=i_samps+1 do i_chn=1,i_set if (1 .eq. 1) then if (a_setfile(i_chn)(1:1) .ne. '=') then call readdat(i_setunit(i_chn), & i_setrows(i_chn), & i_setcols(i_chn), & i_setshdr(i_chn), & i_setstlr(i_chn), & i_setrhdr(i_chn), & i_setrtlr(i_chn), & i_setchdr(i_chn), & i_setctlr(i_chn), & i_setvend(i_chn)*i_endian, & i_setvfmt(i_chn), & r_setvmlt(i_chn), & r_setvadr(i_chn), & r_setvmin(i_chn), & r_setvmax(i_chn), & b_setvnul(0,i_chn), & i_rr,i_cc-1,3, & r_data,i_data,readfunc,i_err) else do j=0,2 r_data(j)=0 i_data(j)=0 end do i_opr=1 i_flg=0 a_value = ' ' do iii = 2,rdflen(a_setfile(i_chn))+1 if (index('+-*/x',a_setfile(i_chn)(iii:iii)) .gt. 0 .or. a_setfile(i_chn)(iii:iii) .eq. ' ') then if (a_value .ne. ' ') then read(a_value,*) r_value if (i_opr .eq. 1) then r_data(1)=r_data(1)+r_value else if (i_opr .eq. 2) then r_data(1)=r_data(1)-r_value else if (i_opr .eq. 3) then r_data(1)=r_data(1)*r_value else if (i_opr .eq. 4) then r_data(1)=r_data(1)/r_value end if a_value = ' ' end if end if if(a_setfile(i_chn)(iii:iii) .eq. '+') then i_opr=1 else if (a_setfile(i_chn)(iii:iii) .eq. '-') then i_opr=2 else if (a_setfile(i_chn)(iii:iii) .eq. 'x') then i_opr=3 else if (a_setfile(i_chn)(iii:iii) .eq. '/') then i_opr=4 else if (a_setfile(i_chn)(iii:iii) .eq. 's' .or. a_setfile(i_chn)(iii:iii) .eq. 'S') then i_flg=1 else if (i_flg .eq. 1) then i_flg = 0 i_tmp = max(min((ichar(a_setfile(i_chn)(iii:iii))-ichar('0')),i_set+1),1) if (i_tmp .gt. i_set) i_tmp=0 if (i_tmp .ne. 0) then call readdat(i_setunit(i_tmp), & i_setrows(i_tmp), & i_setcols(i_tmp), & i_setshdr(i_tmp), & i_setstlr(i_tmp), & i_setrhdr(i_tmp), & i_setrtlr(i_tmp), & i_setchdr(i_tmp), & i_setctlr(i_tmp), & i_setvend(i_tmp)*i_endian, & i_setvfmt(i_tmp), & r_setvmlt(i_tmp), & r_setvadr(i_tmp), & r_setvmin(i_tmp), & r_setvmax(i_tmp), & b_setvnul(0,i_tmp), & i_rr,i_cc-1,3, & r_data2,i_data2,readfunc,i_err) i_data(1)=i_data(1)+i_data2(1) if (i_opr .eq. 1) then r_data(1)=r_data(1)+r_data2(1) else if (i_opr .eq. 2) then r_data(1)=r_data(1)-r_data2(1) else if (i_opr .eq. 3) then r_data(1)=r_data(1)*r_data2(1) else if (i_opr .eq. 4) then r_data(1)=r_data(1)/r_data2(1) else r_data(1)=r_data(1)+r_data2(1) end if end if else a_value = a_value(1:max(1,rdflen(a_value)))//a_setfile(i_chn)(iii:iii) end if end do end if end if if (i_samps .gt. 0) r_vsamps(i_samps,i_chn)=r_data(1) end do end if end do close(91) if (i_dspselect .eq. 0) then c write(6,*) 'dspselect = ',i_dspselect,' setting to 1' i_dspselect =1 end if i_show=1 i_event(0) = i_dspselect ! Redraw window i_event(1) = 1 i_event(2) = 1 i_event(3) = i_vxo(i_dspselect,1)-5 i_event(4) = i_vyo(i_dspselect,1)-5 i_event(5) = i_vxs(i_dspselect,1) i_event(6) = i_vys(i_dspselect,1) if (i_debug .eq. -6 .or. i_debug .ge. 6) write(6,*) 'i_bcnt2 =',i_bcnt call buffer_cmd(i_event,i_bdat,i_bcnt,2,I_BMAX,i_abort,i_debug) else if (i_value .eq. 44) then open(91,file=a_message,status='unknown',form='formatted',iostat=i_err) if (i_err .eq. 0) then do i=1,i_samps write(91,'(3i8,5e15.5)') i_csamps(i),i_rsamps(i),i_tsamps(i),(r_vsamps(i,i_chn),i_chn=1,i_set) end do end if close(91) end if else if (i_evn .eq. 13) then ! buffered mouse click event in window 1 i_button = i_bdat(3,1) i_col = i_bdat(4,1) i_row = i_bdat(5,1) i_typ = i_bdat(6,1) if (i_win .eq. 1) then ! Just making sure if (i_button .eq. 0) then ! do nothing else if (i_button .ne. 2) then ! Left or right click c write(6,*) 'left or right click' i_rcenter=i_row/r_winzoom(i_dsp)+i_winradr(i_dsp) i_ccenter=i_col/r_winzoom(i_dsp)+i_wincadr(i_dsp) if (a_clickcmd(1) .ne. ' ' .and. i_typ .eq. 1) then write(a_command,'(a,4i8,a)') a_clickcmd(1)(1:max(1,rdflen(a_clickcmd(1)))),i_button,i_ccenter,i_rcenter, & i_typ,' &' if (i_debug .eq. -17 .or. i_debug .ge. 17) write(6,*) 'cmnd:'//a_command(1:70) call system(a_command) end if if (i_debug .eq. -12 .or. i_debug .ge. 12) write(6,*) ' in event 13 (button/typ): ',i_button,i_typ i_cdsp = i_dsp i_cset = 0 a_label1=' ' a_label2=' ' if (i_smode .ne. 0 .and. i_shft .eq. 0 .and. i_typ .eq. 1 .and. (i_region .eq. 0 .or. i_smode .ne. 3)) then i_samps=0 i_redraw(i_dsp)=1 if (i_redraw(i_dsp) .eq. 1) then i_redraw(i_dsp) = 0 i_event(0) = i_dsp ! Redraw window i_event(1) = 1 i_event(2) = 1 i_event(3) = i_vxo(i_dsp,1)-5 i_event(4) = i_vyo(i_dsp,1)-5 i_event(5) = i_vxs(i_dsp,1) i_event(6) = i_vys(i_dsp,1) if (i_debug .ge. 6) write(6,*) 'i_bcnt2 =',i_bcnt call buffer_cmd(i_event,i_bdat,i_bcnt,2,I_BMAX,i_abort,i_debug) end if end if if (i_samps .eq. 0) then i_newpoint = 1 else if (i_samps .eq. 0 .or. i_typ .ne. 2 .or. & i_rsamps(i_samps) .ne. i_rcenter .or. & i_csamps(i_samps) .ne. i_ccenter) then i_newpoint = 1 else i_newpoint = 0 end if end if if (i_newpoint .eq. 1) then i_start=i_samps+1 if (i_smode .eq. 0) then ! do nothing else if (i_smode .eq. 1) then ! Point if (i_button .eq. 1 .or. i_typ .eq. 3) then i_samps = min(i_samps+1,I_MAXSAMP) i_rsamps(i_samps) = i_rcenter i_csamps(i_samps) = i_ccenter i_tsamps(i_samps) = 1 r_wsamps(i_samps) = r_wdth r_ssamps(i_samps) = r_spce end if else if (i_smode .eq. 2) then ! Line if (i_button .eq. 1 .or. i_typ .ne. 2) then i_samps = min(i_samps+1,I_MAXSAMP) i_rsamps(i_samps) = i_rcenter i_csamps(i_samps) = i_ccenter r_wsamps(i_samps) = r_wdth r_ssamps(i_samps) = r_spce if (i_typ .eq. 1) then i_tsamps(i_samps) = 2 if (i_debug .eq. -12 .or. i_debug .ge. 12) write(6,*) ' starting line: ',i_samps,i_tsamps(i_samps) else i_tsamps(i_samps) = -2 if (i_debug .eq. -12 .or. i_debug .ge. 12) write(6,*) ' continue line: ',i_samps,i_tsamps(i_samps) end if end if else if (i_smode .eq. 3) then ! Region c write(6,*) 'i_button = ',i_button if (i_region .eq. 0) then if ((i_button .eq. 1 .and. i_typ .eq. 3) .or. & (i_button .eq. 3 .and. i_typ .eq. 1) ) then i_samps=min(i_samps+1,I_MAXSAMP) i_rsamps(i_samps)=i_rcenter i_csamps(i_samps)=i_ccenter i_tsamps(i_samps)=+3 r_wsamps(i_samps) = r_wdth r_ssamps(i_samps) = r_spce i_region=i_region+1 if (i_debug .eq. -12 .or. i_debug .ge. 12) write(6,*) ' start region: ',i_region end if else if (i_typ .eq. 3) then if (i_button .eq. 1) then i_samps=min(i_samps+1,I_MAXSAMP) i_rsamps(i_samps)=i_rcenter i_csamps(i_samps)=i_ccenter i_tsamps(i_samps)=-3 r_wsamps(i_samps) = r_wdth r_ssamps(i_samps) = r_spce i_region=i_region+1 if (i_debug .eq. -12 .or. i_debug .ge. 12) write(6,*) ' add region: ',i_region else if (i_button .eq. 3) then if (i_region .eq. 1) then i_samps=min(i_samps+1,I_MAXSAMP) i_rsamps(i_samps)=i_rsamps(i_samps-i_region) i_csamps(i_samps)=i_ccenter i_tsamps(i_samps)=-3 r_wsamps(i_samps) = r_wdth r_ssamps(i_samps) = r_spce i_region=i_region+1 if (i_debug .eq. -12 .or. i_debug .ge. 12) write(6,*) ' rect 1: ',i_region i_samps=min(i_samps+1,I_MAXSAMP) i_rsamps(i_samps)=i_rcenter i_csamps(i_samps)=i_ccenter i_tsamps(i_samps)=-3 r_wsamps(i_samps) = r_wdth r_ssamps(i_samps) = r_spce i_region=i_region+1 if (i_debug .eq. -12 .or. i_debug .ge. 12) write(6,*) ' rect 2: ',i_region i_samps=min(i_samps+1,I_MAXSAMP) i_rsamps(i_samps)=i_rcenter i_csamps(i_samps)=i_csamps(i_samps-i_region) i_tsamps(i_samps)=-3 r_wsamps(i_samps) = r_wdth r_ssamps(i_samps) = r_spce i_region=i_region+1 if (i_debug .eq. -12 .or. i_debug .ge. 12) write(6,*) ' rect 3: ',i_region i_samps=min(i_samps+1,I_MAXSAMP) i_rsamps(i_samps)=i_rsamps(i_samps-i_region) i_csamps(i_samps)=i_csamps(i_samps-i_region) i_tsamps(i_samps)=-3 r_wsamps(i_samps) = r_wdth r_ssamps(i_samps) = r_spce i_region=i_region+1 if (i_debug .eq. -12 .or. i_debug .ge. 12) write(6,*) ' rect 4: ',i_region else i_samps=min(i_samps+1,I_MAXSAMP) i_rsamps(i_samps)=i_rsamps(i_samps-i_region) i_csamps(i_samps)=i_csamps(i_samps-i_region) i_tsamps(i_samps)=-3 r_wsamps(i_samps) = r_wdth r_ssamps(i_samps) = r_spce i_region=i_region+1 if (i_debug .eq. -12 .or. i_debug .ge. 12) write(6,*) ' add region: ',i_region end if i_region = 0 if (i_debug .eq. -12 .or. i_debug .ge. 12) write(6,*) ' end of region: ',i_region end if end if c end if end if if (i_debug .eq. -20 .or. i_debug .ge. 20 .and. i_samps .gt. 0) write(6,*) 'i_samps=',i_samps,i_tsamps(i_samps),i_button if (i_show .eq. 1) then ! show lines turned on do i=i_start,i_samps if (i_tsamps(i) .eq. 1) then r_row(1)=r_winzoom(i_dsp)*(i_winrows(i_dsp)/ & r_winzoom(i_dsp)-i_rsamps(i))/float(i_winrows(i_dsp))-2/float(i_winrows(i_dsp)) r_row(2)=r_winzoom(i_dsp)*(i_winrows(i_dsp)/ & r_winzoom(i_dsp)-i_rsamps(i))/float(i_winrows(i_dsp))+2/float(i_winrows(i_dsp)) r_col(1)=r_winzoom(i_dsp)*i_csamps(i)/float(i_wincols(i_dsp))-2/float(i_winrows(i_dsp)) r_col(2)=r_winzoom(i_dsp)*i_csamps(i)/float(i_wincols(i_dsp))+2/float(i_winrows(i_dsp)) call plot_data(i_dsp,i_win,2,r_col,r_row) r_row(1)=r_winzoom(i_dsp)*(i_winrows(i_dsp)/ & r_winzoom(i_dsp)-i_rsamps(i))/float(i_winrows(i_dsp))+2/float(i_winrows(i_dsp)) r_row(2)=r_winzoom(i_dsp)*(i_winrows(i_dsp)/ & r_winzoom(i_dsp)-i_rsamps(i))/float(i_winrows(i_dsp))-2/float(i_winrows(i_dsp)) r_col(1)=r_winzoom(i_dsp)*i_csamps(i)/float(i_wincols(i_dsp))-2/float(i_winrows(i_dsp)) r_col(2)=r_winzoom(i_dsp)*i_csamps(i)/float(i_wincols(i_dsp))+2/float(i_winrows(i_dsp)) call plot_data(i_dsp,i_win,2,r_col,r_row) if (i_debug .eq. -12 .or. i_debug .ge. 12) write(6,*) ' drawing line: ',i, & r_col(1),r_row(1),r_col(2),r_row(2) else if (i_tsamps(i) .lt. 0) then r_row(1)=r_winzoom(i_dsp)*(i_winrows(i_dsp)/ & r_winzoom(i_dsp)-i_rsamps(i-1))/float(i_winrows(i_dsp)) r_row(2)=r_winzoom(i_dsp)*(i_winrows(i_dsp)/ & r_winzoom(i_dsp)-i_rsamps(i))/float(i_winrows(i_dsp)) r_col(1)=r_winzoom(i_dsp)*i_csamps(i-1)/float(i_wincols(i_dsp)) r_col(2)=r_winzoom(i_dsp)*i_csamps(i)/float(i_wincols(i_dsp)) call plot_data(i_dsp,i_win,2,r_col,r_row) if (i_debug .eq. -12 .or. i_debug .ge. 12) write(6,*) ' drawing line: ',i, & i_tsamps(i),r_col(1),r_row(1),r_col(2),r_row(2) end if end do end if ! end i_show end if do i_chn=1,i_set !@#$% if (a_setfile(i_chn)(1:1) .ne. '=') then call readdat(i_setunit(i_chn), & i_setrows(i_chn), & i_setcols(i_chn), & i_setshdr(i_chn), & i_setstlr(i_chn), & i_setrhdr(i_chn), & i_setrtlr(i_chn), & i_setchdr(i_chn), & i_setctlr(i_chn), & i_setvend(i_chn)*i_endian, & i_setvfmt(i_chn), & r_setvmlt(i_chn), & r_setvadr(i_chn), & r_setvmin(i_chn), & r_setvmax(i_chn), & b_setvnul(0,i_chn), & int((i_row)/r_winzoom(i_dsp))+i_winradr(i_dsp), & int(i_col/r_winzoom(i_dsp))+i_wincadr(i_dsp)-1, & 3,r_data,i_data,readfunc,i_err) else do j=0,2 r_data(j)=0 i_data(j)=0 end do i_opr=1 i_flg=0 a_value = ' ' do i = 2,rdflen(a_setfile(i_chn))+1 if (index('+-*/x',a_setfile(i_chn)(i:i)) .gt. 0 .or. a_setfile(i_chn)(i:i) .eq. ' ') then if (a_value .ne. ' ') then read(a_value,*) r_value if (i_opr .eq. 1) then r_data(1)=r_data(1)+r_value else if (i_opr .eq. 2) then r_data(1)=r_data(1)-r_value else if (i_opr .eq. 3) then r_data(1)=r_data(1)*r_value else if (i_opr .eq. 4) then r_data(1)=r_data(1)/r_value end if a_value = ' ' end if end if if(a_setfile(i_chn)(i:i) .eq. '+') then i_opr=1 else if (a_setfile(i_chn)(i:i) .eq. '-') then i_opr=2 else if (a_setfile(i_chn)(i:i) .eq. 'x') then i_opr=3 else if (a_setfile(i_chn)(i:i) .eq. '/') then i_opr=4 else if (a_setfile(i_chn)(i:i) .eq. 's' .or. a_setfile(i_chn)(i:i) .eq. 'S') then i_flg=1 else if (i_flg .eq. 1) then i_flg = 0 i_tmp = max(min((ichar(a_setfile(i_chn)(i:i))-ichar('0')),i_set+1),1) if (i_tmp .gt. i_set) i_tmp=0 if (i_tmp .ne. 0) then call readdat(i_setunit(i_tmp), & i_setrows(i_tmp), & i_setcols(i_tmp), & i_setshdr(i_tmp), & i_setstlr(i_tmp), & i_setrhdr(i_tmp), & i_setrtlr(i_tmp), & i_setchdr(i_tmp), & i_setctlr(i_tmp), & i_setvend(i_tmp)*i_endian, & i_setvfmt(i_tmp), & r_setvmlt(i_tmp), & r_setvadr(i_tmp), & r_setvmin(i_tmp), & r_setvmax(i_tmp), & b_setvnul(0,i_tmp), & int((i_row)/r_winzoom(i_dsp))+i_winradr(i_dsp), & int(i_col/r_winzoom(i_dsp))+i_wincadr(i_dsp)-1, & 3,r_data2,i_data2,readfunc,i_err) i_data(1)=i_data(1)+i_data2(1) if (i_opr .eq. 1) then r_data(1)=r_data(1)+r_data2(1) else if (i_opr .eq. 2) then r_data(1)=r_data(1)-r_data2(1) else if (i_opr .eq. 3) then r_data(1)=r_data(1)*r_data2(1) else if (i_opr .eq. 4) then r_data(1)=r_data(1)/r_data2(1) else r_data(1)=r_data(1)+r_data2(1) end if end if else a_value = a_value(1:max(1,rdflen(a_value)))//a_setfile(i_chn)(i:i) end if end do end if if(i_samps .gt. 0) r_vsamps(i_samps,i_chn)=r_data(1) if (a_label1 .eq. ' ') then write(a_label,fmt=a_colfrmt,iostat=i_err) int(i_col/r_winzoom(i_dsp))+i_wincadr(i_dsp) a_label1='COL: '//a_label write(a_label,fmt=a_rowfrmt,iostat=i_err) int(i_row/r_winzoom(i_dsp))+i_winradr(i_dsp) a_label1=a_label1(1:rdflen(a_label1))//' ROW: '//a_label end if if (i_cntl .eq. 1 .and. a_setproj(i_chn) .ne. ' ' .and. & r_setrmlt(i_chn) .ne. 0. .and. r_setcmlt(i_chn) .ne. 0.) then r_dnx(1) = ((int(i_row/r_winzoom(i_dsp))+i_winradr(i_dsp))*r_setrmlt(i_chn))+r_setradr(i_chn) r_dnx(2) = ((int(i_col/r_winzoom(i_dsp))+i_wincadr(i_dsp))*r_setcmlt(i_chn))+r_setcadr(i_chn) r_dnx(3) = r_data(1) call get_coordinates(a_setproj(i_chn),r_setpegv(1,i_chn), & r_dnx,r_eux,1,i_debug,i_err) if (i_err .eq. 0) then r_data(1) = r_eux(3) if (a_label1(1:4) .ne. 'LAT:' .or. rdflower(a_setproj(i_chn)) .ne. 'scx') then if (i_debug .ge. 6) write(6,*) 'i_key = ',i_key if (i_debug .ge. 6) write(6,*) a_setproj(i_chn),r_eux(1)*180.0/r_pi,r_eux(2)*180.0/r_pi write(a_label,'(f10.5)') r_eux(1)*180.0/r_pi a_label1='LAT: '//a_label write(a_label,'(f11.5)',iostat=i_err) r_eux(2)*180.0/r_pi a_label1=a_label1(1:rdflen(a_label1))//' LON: '//a_label end if end if else if (i_shft .eq. 1 .and. & r_setrmlt(i_chn) .ne. 0. .and. r_setcmlt(i_chn) .ne. 0.) then r_eux(2) = ((int(i_row/r_winzoom(i_dsp))+i_winradr(i_dsp))*r_setrmlt(i_chn))+r_setradr(i_chn) r_eux(1) = ((int(i_col/r_winzoom(i_dsp))+i_wincadr(i_dsp))*r_setcmlt(i_chn))+r_setcadr(i_chn) r_eux(3) = r_data(1) if (a_label1(1:4) .ne. 'LAT:' ) then if (i_debug .ge. 6) write(6,*) 'i_key = ',i_key if (i_debug .ge. 6) write(6,*) a_setproj(i_chn),r_eux(1),r_eux(2) write(a_label,'(f10.4)') r_eux(1) a_label1='CPS: '//a_label write(a_label,'(f11.4)',iostat=i_err) r_eux(2) a_label1=a_label1(1:rdflen(a_label1))//' RPS: '//a_label end if end if if (i_data(1) .eq. 0) then ! data valid i_log=nint(alog10(abs(r_data(1)))) i_dec=8-nint(alog10(abs(r_setvavg(i_chn))+10*r_setvstd(i_chn))) if (i_debug .gt. 20) write(6,*) 'i_dec=',i_dec if ((i_dec .ge. -2 .and. i_dec .le. 12) .and. abs(i_log) .lt. 8) then write(a_fmt,'(a,i2.2,a)',iostat=i_err) '(f12.',min(10,max(0,i_dec)),')' else a_fmt='(e12.5)' end if write(a_label2(rdflen(a_label2)+1:),fmt=a_fmt,iostat=i_err) r_data(1) else ! data invalid i_log=nint(alog10(abs(r_data(1)))) i_dec=7-nint(alog10(abs(r_setvavg(i_chn))+10*r_setvstd(i_chn))) if (i_debug .gt. 20) write(6,*) 'i_dec=',i_dec,i_log if (i_dec .ge. -2 .and. i_dec .le. 12 .and. abs(i_log) .eq. 8) then write(a_fmt,'(a,i1,a)',iostat=i_err) '(f12.',min(9,max(0,i_dec)),',a1)' else a_fmt='(e12.4,a1)' end if write(a_label2(rdflen(a_label2)+1:),fmt=a_fmt,iostat=i_err) r_data(1),'*' end if end do if (r_winzoom(i_dsp) .ge. 1.0) then write(a_label,'(a,i3,a)',iostat=i_err) 'ZOOM:',nint(r_winzoom(i_dsp)),'x' else write(a_label,'(a,i3,a)',iostat=i_err) 'ZOOM:',-nint(1.0/r_winzoom(i_dsp)),'x' end if a_label=a_label(1:9)//' '//a_label1(1:max(1,rdflen(a_label1)))//' '//a_label2 call display_label(i_dsp,i_win,a_label,1) if (i_button .eq. 3 .and. i_typ .eq. 3) write(6,*) a_filename(1:max(rdflen(a_filename),1))//' '// & a_label1(1:max(1,rdflen(a_label1)))//' '//a_label2(1:max(1,rdflen(a_label2))) else if (i_button .eq. 2) then ! middle click i_rcenter=i_row/r_winzoom(i_dsp)+i_winradr(i_dsp) i_ccenter=i_col/r_winzoom(i_dsp)+i_wincadr(i_dsp) i_cdsp = i_dsp i_cset = 1 if (i_debug .ge. 8) write(6,*) '--i_cdsp,i_cset = ',i_cdsp,i_cset c if (i_debug .ge. 9) write(6,*) 'i_key=',i_key if (i_debug .ge. 9) write(6,*) 'moving scroll to',i_ccenter,i_rcenter do i_d=1,I_DMAX if (i_winactv(i_d) .ne. 0) then if ((i_key .eq. 0 .and. i_d .eq. i_dsp) .or. & (i_key .ne. 0 .and. i_d .ne. i_dsp)) then if (i_winradr(i_d) .ne. max(min(i_rcenter-int((32000/2)/r_winzoom(i_d)), & i_setrows(1)-int(32000/r_winzoom(i_d))),0) ) then i_winradr(i_d) = & max(min(i_rcenter-int((32000/2)/r_winzoom(i_d)),i_setrows(1)-int(32000/r_winzoom(i_d))),0) i_redraw(i_d)=1 end if if (i_wincadr(i_d) .ne. max(min(i_ccenter-int((32000/2)/r_winzoom(i_d)), & i_setcols(1)-int(32000/r_winzoom(i_d))),0) ) then i_wincadr(i_d) = & max(min(i_ccenter-int((32000/2)/r_winzoom(i_d)),i_setcols(1)-int(32000/r_winzoom(i_d))),0) i_redraw(i_d)=1 end if if (i_redraw(i_d) .eq. 1) then i_redraw(i_d) = 0 i_event(0) = i_d ! Redraw window i_event(1) = 1 i_event(2) = 1 i_event(3) = i_vxo(i_d,1)-5 i_event(4) = i_vyo(i_d,1)-5 i_event(5) = i_vxs(i_d,1) i_event(6) = i_vys(i_d,1) if (i_debug .ge. 6) write(6,*) 'i_bcnt2 =',i_bcnt call buffer_cmd(i_event,i_bdat,i_bcnt,2,I_BMAX,i_abort,i_debug) end if i_cpos = nint((i_ccenter-i_wincadr(i_d))*r_winzoom(i_d)-0.5*i_vxs(i_d,1)) i_rpos = nint((i_rcenter-i_winradr(i_d))*r_winzoom(i_d)-0.5*i_vys(i_d,1)) call move_scroll(i_d,1,i_cpos,i_rpos) end if end if end do end if end if else if (i_evn .eq. 0) then ! menu select i_col = i_bdat(4,1) i_row = i_bdat(5,1) if (i_debug .ge. 6) write(6,*) 'Menu Item selected:',i_dsp,i_col,i_row if (i_col .eq. 0) then if (i_row .eq. 1) then call write_greeting() else if (i_row .eq. 2) then write(6,*) 'Function not implemented yet' end if else if (i_col .eq. 1) then if (i_row .eq. 1) then if (i_debug .ge. 2) write(6,*) 'Creating new application' i_arg = 0 a_command = 'mdx' do while(i_arg .lt. i_inarg) i_arg=i_arg + 1 a_value = a_inarg(i_arg) a_command = a_command(1:rdflen(a_command))//' '//a_value end do a_command=a_command(1:rdflen(a_command))//' &' if (i_debug .ge. 6) write(6,*) 'a_command=',a_command call system(a_command) else if (i_row .eq. 2) then i_done = 1 end if else if (i_col .eq. 2) then if (i_row .eq. 1) then if (i_debug .ge. 3) write(6,*) 'Creating new display' call create_dsp(a_filename,i_winrows(i_dsp) & ,i_wincols(i_dsp),i_winy,i_winx,a_setname(1),i_set,i_d & ,i_menu,a_tname,i_close,a_lcolor,i_debug) if (i_debug .ge. 6) write(6,*) 'i_d =',i_d if (i_d .gt. 0) then i_winactv(i_d) = 1 call get_wininfo(i_d,1,i_vxo(i_d,1),i_vyo(i_d,1) & ,i_vxs(i_d,1),i_vys(i_d,1),i_wxs(i_d,1),i_wys(i_d,1) c & ,i_vxs(i_d,1),i_vys(i_d,1),i_cw,i_ch & ,i_widget) if (i_debug .ge. 6) write(6,*) 'from get_win',i_vxo(i_d,1),i_vyo(i_d & ,1),i_vxs(i_d,1),i_vys(i_d,1) i_winrows(i_d)=i_winrows(i_dsp) i_wincols(i_d)=i_wincols(i_dsp) i_winselc(i_d)=i_winselc(i_dsp) r_winzoom(i_d)=r_winzoom(i_dsp) do i=1, I_CMAX i_dspactv(i_d,i) = i_dspactv(i_dsp,i) if (i .le. i_set) then if (i_dspactv(i_d,i) .eq. 1) then call set_button_shadow(i_d,i+1,1,i_debug) else call set_button_shadow(i_d,i+1,0,i_debug) end if end if end do end if else if (i_row .eq. 2) then call destroy_display(i_dsp) else if (i_row .eq. 3) then ! Resize Display do i_chn = 1,i_set if (a_setfile(i_chn) .ne. ' ' .and. a_setfile(i_chn)(1:1) .ne. '=') then if (i_setunit(i_chn) .lt. 0) then i_fbytes = readfunc(1,i_chn,i_eight(0),0,b_data) if (i_debug .ge. 3) write(6,*) 'internal buffer size=',i_fbytes i_fbytes = min(i_fbytes,i_maxbuff) else i_fbytes = i_getfsize(i_setunit(i_chn)) c write(6,*) 'calling i_getfsize ',i_fbytes,i_setunit(i_chn) end if if (i_fbytes .gt. 0) then i_setrows(i_chn) = (i_fbytes & -i_setshdr(i_chn)-i_setstlr(i_chn))/((i_setvbyt(i_setvfmt(i_chn)) & +i_setchdr(i_chn)+i_setctlr(i_chn))*i_setcols(i_chn)+i_setrhdr(i_chn)+i_setrtlr(i_chn)) end if end if end do i_winrows(i_dsp) = min(nint(i_setrows(1)*r_winzoom(i_dsp)),32000) i_wincols(i_dsp) = min(nint(i_setcols(1)*r_winzoom(i_dsp)),32000) call resize_win(i_dsp,1,i_wincols(i_dsp),i_winrows(i_dsp)) c write(6,*) 'New number of rows = ',i_winrows(i_dsp) end if else if (i_col .eq. 3) then ! Set if (i_row .eq. 1) then write(6,*) 'Function not yet implemented' else if (i_row .eq. 2) then write(6,*) 'Function not yet implemented' else if (i_row .eq. 3) then write(6,*) 'Function not yet implemented' end if else if (i_col .eq. 4) then ! Zoom if (i_row .le. 3) then if (i_debug .ge. 8) write(6,*) '--i_cdsp,i_cset = ',i_cdsp,i_cset if (i_cdsp .ne. 0 .and. i_cdsp .ne. i_dsp) then i_rcenter=nint((i_vyo(i_dsp,1)+0.5*i_vys(i_dsp,1))/r_winzoom(i_dsp))+i_winradr(i_dsp) i_ccenter=nint((i_vxo(i_dsp,1)+0.5*i_vxs(i_dsp,1))/r_winzoom(i_dsp))+i_wincadr(i_dsp) end if if (i_debug .ge. 6) write(6,*) 'Center was at (col,row): ',i_ccenter,i_rcenter if (i_row .eq. 1) then r_winzoom(i_dsp)=1. if (i_debug .ge. 6) write(6,*) 'Zoom off: ',r_winzoom(i_dsp) else if (i_row .eq. 2) then r_winzoom(i_dsp)=r_winzoom(i_dsp)*2. if (i_debug .ge. 6) write(6,*) 'Zooming in: ',r_winzoom(i_dsp) else if (i_row .eq. 3) then r_winzoom(i_dsp)=r_winzoom(i_dsp)/2. if (i_debug .ge. 6) write(6,*) 'Zooming out: ',r_winzoom(i_dsp) end if i_winrows(i_dsp) = min(nint(i_setrows(1)*r_winzoom(i_dsp)),32000) i_wincols(i_dsp) = min(nint(i_setcols(1)*r_winzoom(i_dsp)),32000) call resize_win(i_dsp,1,i_wincols(i_dsp),i_winrows(i_dsp)) if (i_winradr(i_dsp) .ne. & max(min(i_rcenter-int((32000/2)/r_winzoom(i_dsp)),i_setrows(1)-int(32000/r_winzoom(i_dsp))),0) ) then i_winradr(i_dsp) = & max(min(i_rcenter-int((32000/2)/r_winzoom(i_dsp)),i_setrows(1)-int(32000/r_winzoom(i_dsp))),0) i_redraw(i_dsp)=1 end if if (i_wincadr(i_dsp) .ne. & max(min(i_ccenter-int((32000/2)/r_winzoom(i_dsp)),i_setcols(1)-int(32000/r_winzoom(i_dsp))),0) ) then i_wincadr(i_dsp) = & max(min(i_ccenter-int((32000/2)/r_winzoom(i_dsp)),i_setcols(1)-int(32000/r_winzoom(i_dsp))),0) i_redraw(i_dsp)=1 end if if (i_redraw(i_dsp) .eq. 1) then i_redraw(i_dsp) = 0 i_event(0) = i_dsp ! Redraw window i_event(1) = 1 i_event(2) = 1 i_event(3) = i_vxo(i_dsp,1)-5 i_event(4) = i_vyo(i_dsp,1)-5 i_event(5) = i_vxs(i_dsp,1) i_event(6) = i_vys(i_dsp,1) if (i_debug .ge. 6) write(6,*) 'i_bcnt2 =',i_bcnt call buffer_cmd(i_event,i_bdat,i_bcnt,2,I_BMAX,i_abort,i_debug) end if i_cpos = nint((i_ccenter-i_wincadr(i_dsp))*r_winzoom(i_dsp)-0.5*i_vxs(i_dsp,1)) i_rpos = nint((i_rcenter-i_winradr(i_dsp))*r_winzoom(i_dsp)-0.5*i_vys(i_dsp,1)) if (i_debug .ge. 9) write(6,*) 'moving scroll to',i_cpos,i_rpos call move_scroll(i_dsp,1,i_cpos,i_rpos) i_cset = 1 i_event(0) = i_dsp i_event(1) = 1 i_event(2) = 1 i_event(3) = i_vxo(i_dsp,1)-5 i_event(4) = i_vyo(i_dsp,1)-5 i_event(5) = i_vxs(i_dsp,1) i_event(6) = i_vys(i_dsp,1) if (i_debug .ge. 6) write(6,*) 'i_bcnt2 =',i_bcnt call buffer_cmd(i_event,i_bdat,i_bcnt,2,I_BMAX,i_abort,i_debug) else if (i_row .eq. 4) then do i=0,20 a_elabl(i)=' ' a_edata(i)=' ' end do a_elabl(5)='Zoom: ' if (r_winzoom(i_dsp) .ge. 1.0) then write(a_edata(5),*) nint(r_winzoom(i_dsp)) else write(a_edata(5),*) -nint(1.0/r_winzoom(i_dsp)) end if call entry_window(0,a_elabl,a_edata) i_dspselect=i_dsp a_elabl(5)=' ' a_edata(5)=' ' end if if (r_winzoom(i_dsp) .ge. 1.0) then write(a_label,'(a,i3,a)') 'ZOOM:',nint(r_winzoom(i_dsp)),'x' else write(a_label,'(a,i3,a)') 'ZOOM:',-nint(1.0/r_winzoom(i_dsp)),'x' end if call display_label(i_dsp,1,a_label,1) else if (i_col .eq. 5) then ! Select Menu if (i_row .eq. 1) then do i=0,20 a_elabl(i)=' ' a_edata(i)=' ' end do a_elabl(6)='Display: ' write(a_edata(6),'(i1,a)') i_show+1,'|Off|On' ! Sample Display ON/Off a_elabl(7)='Mode: ' write(a_edata(7),'(i1,a)') i_smode+1,'|None|Point|Line|Region' if (i_smode .lt.3) then a_elabl(8)='Width: ' write(a_edata(8),*) r_wdth else a_elabl(8)='Density: ' write(a_edata(8),*) r_spce end if call entry_window(0,a_elabl,a_edata) i_dspselect=i_dsp a_elabl(6)=' ' a_edata(6)=' ' a_elabl(7)=' ' a_edata(7)=' ' a_elabl(8)=' ' a_edata(8)=' ' else if (i_row .eq. 2) then call gx_getfile(a_value,43) c write(6,*) 'file:',a_value(1:70) else if (i_row .eq. 3) then call gx_getfile(a_value,44) c write(6,*) 'file:',a_value(1:70) else if (i_row .eq. 3) then else if (i_row .eq. 4) then i_samps = 0 i_redraw(i_dsp) = 1 if (i_redraw(i_dsp) .eq. 1) then i_redraw(i_dsp) = 0 i_event(0) = i_dsp ! Redraw window i_event(1) = 1 i_event(2) = 1 i_event(3) = i_vxo(i_dsp,1)-5 i_event(4) = i_vyo(i_dsp,1)-5 i_event(5) = i_vxs(i_dsp,1) i_event(6) = i_vys(i_dsp,1) if (i_debug .ge. 6) write(6,*) 'i_bcnt2 =',i_bcnt call buffer_cmd(i_event,i_bdat,i_bcnt,2,I_BMAX,i_abort,i_debug) end if end if else if (i_col .eq. 6) then ! Print Menu if (i_row .eq. 2) then call get_wininfo(i_dsp,1,i_vxo(i_dsp,1),i_vyo(i_dsp,1) & ,i_vxs(i_dsp,1),i_vys(i_dsp,1),i_wxs(i_dsp,1),i_wys(i_dsp,1) & ,i_widget) i_event(0) = 0 ! tells data to go to print file instead of screen i_event(1) = 1 i_event(2) = 1 c i_event(3) = (i_vxo(i_dsp,1)*r_winzoom(0))/r_winzoom(i_dsp) c i_event(4) = (i_vyo(i_dsp,1)*r_winzoom(0))/r_winzoom(i_dsp) i_event(3) = (max(i_vxo(i_dsp,1)-1,0)/r_winzoom(i_dsp)+i_wincadr(i_dsp))*r_winzoom(0) i_event(4) = (max(i_vyo(i_dsp,1)-1,0)/r_winzoom(i_dsp)+i_winradr(i_dsp))*r_winzoom(0) c i_event(5) = ((min(i_vxs(i_dsp,1)+i_vxo(i_dsp,1),i_wincols(i_dsp))-i_vxo(i_dsp,1))* c & r_winzoom(0))/r_winzoom(i_dsp) c i_event(6) = ((min(i_vys(i_dsp,1)+i_vyo(i_dsp,1),i_winrows(i_dsp))-i_vyo(i_dsp,1))* c & r_winzoom(0))/r_winzoom(i_dsp) i_event(5) = max((min(i_vxs(i_dsp,1)-i_pcpad,i_wincols(i_dsp)-i_vxo(i_dsp,1))/ & r_winzoom(i_dsp))*r_winzoom(0),20.) i_event(6) = (min(i_vys(i_dsp,1)-i_prpad,i_winrows(i_dsp)-i_vyo(i_dsp,1))/ & r_winzoom(i_dsp))*r_winzoom(0) i_event(7) = 0 i_event(8) = i_event(4) i_event(9) = i_event(6) if (i_debug .ge. 21 .or. i_debug .eq. -21) write(6,*) 'Print range:',i_event(3),i_event(4),i_event(5),i_event(6) do i_chn=1,i_set i_dspactv(0,i_chn) = i_dspactv(i_dsp,i_chn) end do call buffer_cmd(i_event,i_bdat,i_bcnt,2,I_BMAX,i_abort,i_debug) i_dspselect=i_dsp else if (i_row .eq. 3) then ! Print setup do i=0,20 a_elabl(i)=' ' a_edata(i)=' ' end do a_elabl(3)='Print Zoom: ' if (r_winzoom(0).ge. 1.0) then write(a_edata(3),*) nint(r_winzoom(0)) else write(a_edata(3),*) -nint(1.0/r_winzoom(0)) end if a_elabl(4)='Format: ' write(a_edata(4),'(i1,a)') i_pfmt,'|PPM|Raw RGB|PostScript' call entry_window(0,a_elabl,a_edata) i_dspselect=i_dsp a_elabl(3)=' ' a_edata(3)=' ' a_elabl(4)=' ' a_edata(4)=' ' end if else if (i_col .eq. 7) then ! Tool Menu write(6,*) 'Tool: ',a_tname(i_row)(1:max(1,rdflen(a_tname(i_row)))) if (i_row .eq. 1) then ! Plot location if (abs(i_samps) .ge. 1) then a_file=a_workdir(1:rdflen(a_workdir))//'mdx_points.dat' open(unit=19,file=a_file,status='unknown',form='formatted',iostat=i_err) if (i_err .eq. 0) then do i=1,abs(i_samps) if (i_tsamps(i) .gt. 0) write(19,*) ' ' write(19,*) i_csamps(i),i_rsamps(i),(r_vsamps(i,j),j=1,i_set),i_tsamps(i) end do close(19) a_value = 'xmgrace -free -noask -pexec "yaxes invert on" '//a_file(1:rdflen(a_file))//' &' call system(a_value) c i_samps=-abs(i_samps) else write(6,*) 'Cant open file:'//a_file(1:50) end if end if else if (i_row .eq. 2) then ! Plot Profiles if (abs(i_samps) .ge. 2) then a_file=a_workdir(1:rdflen(a_workdir))//'mdx_points.dat' open(unit=19,file=a_file,status='unknown',form='formatted',iostat=i_err) if (i_err .eq. 0) then do i=1,abs(i_samps) if (i .eq. 1) then r_path = 0.0 else r_path = r_path + sqrt(float(i_csamps(i)-i_csamps(i-1))**2.0+float(i_rsamps(i)-i_rsamps(i-1))**2.0) end if a_label=' ' do j=1,i_set if (i_dspactv(i_dsp,j) .eq. 1) then write(a_label1,*) r_vsamps(i,j) a_label = a_label(1:max(1,rdflen(a_label)))//' '//a_label1 end if end do if (i_tsamps(i) .gt. 0) write(19,*) ' ' write(19,*) r_path,' ',a_label(1:max(1,rdflen(a_label))) i_clast=i_csamps(i) i_rlast=i_rsamps(i) if (i .lt. abs(i_samps)) then if (i_tsamps(i+1) .eq. -2) then ! fill in extra points r_dist=sqrt((i_csamps(i+1)-i_csamps(i))**2.+(i_rsamps(i+1)-i_rsamps(i))**2.) do ii=1,int(r_dist/r_spce) i_cc=i_csamps(i)+nint((i_csamps(i+1)-i_csamps(i))*(ii*r_spce)/r_dist) i_rr=i_rsamps(i)+nint((i_rsamps(i+1)-i_rsamps(i))*(ii*r_spce)/r_dist) if (i_cc .ne. i_clast .or. i_rr .ne. i_rlast) then i_clast = i_cc i_rlast = i_rr a_label=' ' do i_chn=1,i_set if (i_dspactv(i_dsp,i_chn) .eq. 1) then if (a_setfile(i_chn)(1:1) .ne. '=') then call readdat(i_setunit(i_chn), & i_setrows(i_chn), & i_setcols(i_chn), & i_setshdr(i_chn), & i_setstlr(i_chn), & i_setrhdr(i_chn), & i_setrtlr(i_chn), & i_setchdr(i_chn), & i_setctlr(i_chn), & i_setvend(i_chn)*i_endian, & i_setvfmt(i_chn), & r_setvmlt(i_chn), & r_setvadr(i_chn), & r_setvmin(i_chn), & r_setvmax(i_chn), & b_setvnul(0,i_chn), & i_rr,i_cc-1,3, & r_data,i_data,readfunc,i_err) else do j=0,2 r_data(j)=0 i_data(j)=0 end do i_opr=1 i_flg=0 a_value = ' ' do iii = 2,rdflen(a_setfile(i_chn))+1 if (index('+-*/x',a_setfile(i_chn)(iii:iii)) .gt. 0 .or. a_setfile(i_chn)(iii:iii) .eq. ' ') then if (a_value .ne. ' ') then read(a_value,*) r_value if (i_opr .eq. 1) then r_data(1)=r_data(1)+r_value else if (i_opr .eq. 2) then r_data(1)=r_data(1)-r_value else if (i_opr .eq. 3) then r_data(1)=r_data(1)*r_value else if (i_opr .eq. 4) then r_data(1)=r_data(1)/r_value end if a_value = ' ' end if end if if(a_setfile(i_chn)(iii:iii) .eq. '+') then i_opr=1 else if (a_setfile(i_chn)(iii:iii) .eq. '-') then i_opr=2 else if (a_setfile(i_chn)(iii:iii) .eq. 'x') then i_opr=3 else if (a_setfile(i_chn)(iii:iii) .eq. '/') then i_opr=4 else if (a_setfile(i_chn)(iii:iii) .eq. 's' .or. a_setfile(i_chn)(iii:iii) .eq. 'S') then i_flg=1 else if (i_flg .eq. 1) then i_flg = 0 i_tmp = max(min((ichar(a_setfile(i_chn)(iii:iii))-ichar('0')),i_set+1),1) if (i_tmp .gt. i_set) i_tmp=0 if (i_tmp .ne. 0) then call readdat(i_setunit(i_tmp), & i_setrows(i_tmp), & i_setcols(i_tmp), & i_setshdr(i_tmp), & i_setstlr(i_tmp), & i_setrhdr(i_tmp), & i_setrtlr(i_tmp), & i_setchdr(i_tmp), & i_setctlr(i_tmp), & i_setvend(i_tmp)*i_endian, & i_setvfmt(i_tmp), & r_setvmlt(i_tmp), & r_setvadr(i_tmp), & r_setvmin(i_tmp), & r_setvmax(i_tmp), & b_setvnul(0,i_tmp), & i_rr,i_cc-1,3, & r_data2,i_data2,readfunc,i_err) i_data(1)=i_data(1)+i_data2(1) if (i_opr .eq. 1) then r_data(1)=r_data(1)+r_data2(1) else if (i_opr .eq. 2) then r_data(1)=r_data(1)-r_data2(1) else if (i_opr .eq. 3) then r_data(1)=r_data(1)*r_data2(1) else if (i_opr .eq. 4) then r_data(1)=r_data(1)/r_data2(1) else r_data(1)=r_data(1)+r_data2(1) end if end if else a_value = a_value(1:max(1,rdflen(a_value)))//a_setfile(i_chn)(iii:iii) end if end do end if write(a_label1,*) r_data(1) a_label = a_label(1:max(1,rdflen(a_label)))//' '//a_label1 end if end do write(19,*) r_path+sqrt((i_cc-i_csamps(i))**2.+(i_rr-i_rsamps(i))**2.),' ', & a_label(1:max(1,rdflen(a_label))) end if ! i_cc .ne. i_clast .or. i_rr .ne. i_rlast end do end if end if end do close(19) a_value = 'xmgrace -free -noask -nxy '//a_file(1:rdflen(a_file))//' &' call system(a_value) c i_samps=-abs(i_samps) else write(6,*) 'Cant open file:'//a_file(1:50) end if end if else if (i_row .ge. 3 .and. i_row .le. 5) then ! Tool 3, 4, or 5 i_act=0 do i=i_set,1,-1 if (i_dspactv(i_dsp,i) .eq. 1) i_act = i end do if (i_act .gt. 0) then a_file=a_workdir(1:rdflen(a_workdir))//'mdx_points.dat' open(unit=19,file=a_file,status='unknown',form='formatted',iostat=i_err) if (i_err .eq. 0) then c write(19,*) a_setfile(i_act)(1:rdflen(a_setfile(i_act))),' ',a_setname(i_act)(1:rdflen(a_setname(i_act))),i_setcols(i_act),i_setrows(i_act) do i=1,abs(i_samps) if (i .eq. 1 .or. i_tsamps(i) .gt. 0) then r_path = 0.0 else r_path = r_path + sqrt(float(i_csamps(i)-i_csamps(i-1))**2.0+float(i_rsamps(i)-i_rsamps(i-1))**2.0) end if write(19,'(3i8,2e15.5)') i_csamps(i),i_rsamps(i),i_tsamps(i),r_path,r_vsamps(i,i_act) end do close(19) write(a_value,'(9i10,9e15.5)') & i_setcols(i_act),i_setrows(i_act),i_setvend(i_act), & i_setvfmt(i_act),i_setshdr(i_act), & i_setrhdr(i_act),i_setrtlr(i_act), & i_setchdr(i_act),i_setctlr(i_act), & r_setvmin(i_act),r_setvmax(i_act), & r_setrmlt(i_act),r_setradr(i_act), & r_setcmlt(i_act),r_setcadr(i_act), & r_setpegv(1,i_act),r_setpegv(2,i_act),r_setpegv(3,i_act) a_value = a_file(1:rdflen(a_file))//' '//a_setfile(i_act)(1:rdflen(a_setfile(i_act)))//' '//a_value a_value = a_tcmnd(i_row)(1:rdflen(a_tcmnd(i_row)))//' '//a_value a_value = a_value(1:rdflen(a_value))//' '//a_twait(i_row) if (i_debug .eq. -9 .or. i_debug .ge. 9) write(6,*) a_value(1:rdflen(a_value)) call system(a_value) i_redraw(i_dsp)=1 else write(6,*) 'Cant open file:'//a_file(1:50) end if end if end if if (i_redraw(i_dsp) .eq. 1) then i_redraw(i_dsp) = 0 i_event(0) = i_dsp ! Redraw window i_event(1) = 1 i_event(2) = 1 i_event(3) = i_vxo(i_dsp,1)-5 i_event(4) = i_vyo(i_dsp,1)-5 i_event(5) = i_vxs(i_dsp,1) i_event(6) = i_vys(i_dsp,1) if (i_debug .ge. 6) write(6,*) 'i_bcnt2 =',i_bcnt call buffer_cmd(i_event,i_bdat,i_bcnt,2,I_BMAX,i_abort,i_debug) end if else if (i_col .eq. 8) then ! Do nothing end if end if do ib=1,i_bcnt-1 ! Move Items up in buffer do i=0,10 i_bdat(i,ib) = i_bdat(i,ib+1) end do end do i_bcnt = i_bcnt-1 else i_cset = 0 if (i_debug .ge. 8) write(6,*) '--Setting i_cset = 0' end if if (i_bcnt .eq. 0 .and. i_ecnt .gt. 0 .or. i_r .ge. 0) then ! Expose Command to execute if (i_r .le. -1) then ! just starting to process command call get_ecmd(I_WKSPACE,i_ecnt,i_edat,i_ecmd,i_debug) i_edsp = i_ecmd(0) i_ewin = i_ecmd(1) i_eevn = i_ecmd(2) i_ecol = i_ecmd(3) i_erow = i_ecmd(4) i_encx = i_ecmd(5) ! columns per line i_enrx = i_ecmd(6) ! number of lines in this segment if (i_debug .ge. 5) write(6,*) 'initializing expose' if (i_edsp .eq. 0 .and. i_pinit .eq. 0) then ! initialize printer data to file i_pinit = 1 i_pid = 30 a_file=a_workdir(1:rdflen(a_workdir))//'out.ppm' open(unit=i_pid,file=a_file,status='unknown',form='unformatted', & access='direct',recl=i_encx*3,iostat=i_err) if (i_err .ne. 0) then write(6,*) ' ' write(6,*) 'Error Opening out.ppm PPM file not created. ',i_err write(6,*) i_err=0 else a_label = 'Creating PPM file' if (i_winactv(i_dspselect) .ne. 0 )call display_label(i_dspselect,1,a_label,1) if (i_debug .ge. 2) then write(6,*) ' ' write(6,'(1x,a)') 'Creating PPM File -- ' end if a_out='P6' b_out(3)=13 do i=4,3*i_encx b_out(i)=32 end do write(a_value,'(3i15)') i_encx,i_ecmd(9),255 c write(6,*) 'a_value=',a_value(1:50) c write(6,*) 'rdflen(a_value) =',rdflen(a_value) do i = 1,rdflen(a_value) b_out(3*i_encx-rdflen(a_value)-1+i) = ichar(a_value(i:i)) end do b_out(i_encx*3) = 13 write(i_pid,rec=1,iostat=i_stat) (b_out(i),i=1,i_encx*3) end if end if i_r = 0 if (r_winzoom(i_edsp) .ge. 1) then i_strt=i_encx-1 i_stop=0 i_incr=-1 i_coff=mod(i_ecol,nint(r_winzoom(i_edsp))) c write(6,*) 'strt,stop,i_coff=',i_strt,i_stop,i_coff,i_incr else i_strt=0 i_stop=i_encx-1 i_incr=1 i_coff=0 end if else ! in the middle of reading data and filling display buffer if (i_debug .ge. 6 .and. i_r .eq. 0) write(6,*) 'gathering data for expose' if (i_debug .ge. 5) write(6,*) 'reading at line: ',i_r+1, & int(i_erow/r_winzoom(i_edsp)),int(i_ecol/r_winzoom(i_edsp)), & int(i_enrx/r_winzoom(i_edsp)),int(i_encx/r_winzoom(i_edsp)) if (i_edsp .gt. 0) then if (i_debug .ge. 4 .and. i_r .lt. i_vyo(i_edsp,i_ewin)-i_erow-2) & write(6,*) ' skipping lines at top: ',i_r,' to ',i_vyo(i_edsp,i_ewin)-i_erow-2 i_r = max(i_r,i_vyo(i_edsp,i_ewin)-i_erow-2) if (i_debug .ge. 4 .and. i_vyo(i_edsp,i_ewin)+i_vys(i_edsp,i_ewin)-i_erow .lt. i_enrx) & write(6,*) ' skipping lines at bottom: ',i_enrx,' to ', & min(i_enrx,i_vyo(i_edsp,i_ewin)+i_vys(i_edsp,i_ewin)-i_erow) i_enrx = min(i_enrx,i_vyo(i_edsp,i_ewin)+i_vys(i_edsp,i_ewin)-i_erow) end if do while (i_bcnt .le. 0 .and. i_r .lt. i_enrx) c write(6,*) 'i_r=',i_r,i_encx-1 i_dflag = 0 do i_c=0,i_encx-1 i_pos=i_c+i_r*i_encx r_rdat(i_pos)=0.0 r_gdat(i_pos)=0.0 r_bdat(i_pos)=0.0 i_indx(i_pos)=0.0 end do do i_chn = 1,i_set if (i_dspactv(i_edsp,i_chn) .eq. 1) then if (a_setfile(i_chn)(1:1) .ne. '=') then call readdat(i_setunit(i_chn), & i_setrows(i_chn), & i_setcols(i_chn), & i_setshdr(i_chn), & i_setstlr(i_chn), & i_setrhdr(i_chn), & i_setrtlr(i_chn), & i_setchdr(i_chn), & i_setctlr(i_chn), & i_setvend(i_chn)*i_endian, & i_setvfmt(i_chn), & r_setvmlt(i_chn), & r_setvadr(i_chn), & r_setvmin(i_chn), & r_setvmax(i_chn), & b_setvnul(0,i_chn), & int((i_erow+i_r)/r_winzoom(i_edsp))+i_winradr(i_edsp), & int(i_ecol/r_winzoom(i_edsp))+i_wincadr(i_edsp), & int(i_encx/r_winzoom(i_edsp))+2, & r_data,i_data,readfunc,i_err) else do j=0,int(i_encx/r_winzoom(i_edsp))+2 r_data(j)=0 i_data(j)=0 end do i_opr=1 i_flg=0 a_value=' ' do i = 2,rdflen(a_setfile(i_chn))+1 if (index('+-*/x',a_setfile(i_chn)(i:i)) .gt. 0 .or. a_setfile(i_chn)(i:i) .eq. ' ') then if (a_value .ne. ' ') then read(a_value,*) r_value if (i_opr .eq. 1) then do j=0,int(i_encx/r_winzoom(i_edsp))+2 r_data(j)=r_data(j)+r_value end do else if (i_opr .eq. 2) then do j=0,int(i_encx/r_winzoom(i_edsp))+2 r_data(j)=r_data(j)-r_value end do else if (i_opr .eq. 3) then do j=0,int(i_encx/r_winzoom(i_edsp))+2 r_data(j)=r_data(j)*r_value end do else if (i_opr .eq. 4) then do j=0,int(i_encx/r_winzoom(i_edsp))+2 r_data(j)=r_data(j)/r_value end do end if a_value = ' ' end if end if if(a_setfile(i_chn)(i:i) .eq. '+') then i_opr=1 else if (a_setfile(i_chn)(i:i) .eq. '-') then i_opr=2 else if (a_setfile(i_chn)(i:i) .eq. '*' .or. a_setfile(i_chn)(i:i) .eq. 'x') then i_opr=3 else if (a_setfile(i_chn)(i:i) .eq. '/') then i_opr=4 else if (a_setfile(i_chn)(i:i) .eq. 's' .or. a_setfile(i_chn)(i:i) .eq. 'S') then i_flg=1 else if (i_flg .eq. 1) then i_flg = 0 i_tmp = max(min((ichar(a_setfile(i_chn)(i:i))-ichar('0')),i_set+1),1) if (i_tmp .gt. i_set) i_tmp=0 if (i_tmp .ne. 0) then call readdat(i_setunit(i_tmp), & i_setrows(i_tmp), & i_setcols(i_tmp), & i_setshdr(i_tmp), & i_setstlr(i_tmp), & i_setrhdr(i_tmp), & i_setrtlr(i_tmp), & i_setchdr(i_tmp), & i_setctlr(i_tmp), & i_setvend(i_tmp)*i_endian, & i_setvfmt(i_tmp), & r_setvmlt(i_tmp), & r_setvadr(i_tmp), & r_setvmin(i_tmp), & r_setvmax(i_tmp), & b_setvnul(0,i_tmp), & int((i_erow+i_r)/r_winzoom(i_edsp))+i_winradr(i_edsp), & int(i_ecol/r_winzoom(i_edsp))+i_wincadr(i_edsp), & int(i_encx/r_winzoom(i_edsp))+2, & r_data2,i_data2,readfunc,i_err) do j=0,int(i_encx/r_winzoom(i_edsp))+2 i_data(j)=i_data(j)+i_data2(j) end do if (i_opr .eq. 1) then do j=0,int(i_encx/r_winzoom(i_edsp))+2 r_data(j)=r_data(j)+r_data2(j) end do else if (i_opr .eq. 2) then do j=0,int(i_encx/r_winzoom(i_edsp))+2 r_data(j)=r_data(j)-r_data2(j) end do else if (i_opr .eq. 3) then do j=0,int(i_encx/r_winzoom(i_edsp))+2 r_data(j)=r_data(j)*r_data2(j) end do else if (i_opr .eq. 4) then do j=0,int(i_encx/r_winzoom(i_edsp))+2 r_data(j)=r_data(j)/r_data2(j) end do else do j=0,int(i_encx/r_winzoom(i_edsp))+2 r_data(j)=r_data(j)+r_data2(j) end do end if end if else a_value = a_value(1:max(1,rdflen(a_value)))//a_setfile(i_chn)(i:i) end if end do end if do i_c = i_strt,i_stop,i_incr if (r_winzoom(i_edsp) .ne. 1.) then r_data(i_c) = r_data(int((i_c+i_coff)/r_winzoom(i_edsp))) i_data(i_c) = i_data(int((i_c+i_coff)/r_winzoom(i_edsp))) end if i_pos=i_c+i_r*i_encx if (i_data(i_c) .eq. 0 .and. i_indx(i_pos) .eq. 0) then r_data(i_c) = max(r_dspcplw(i_chn),min(r_dspcphi(i_chn),r_data(i_c))) ! Clip data r_data(i_c) = (r_data(i_c)-r_dspaddr(i_chn)) ! Shift data if (i_dspmode(i_chn) .eq. 6) then ! Wrap data r_data(i_c) = wrap(r_data(i_c),r_dspwrap(i_chn)) end if r_data(i_c) = r_data(i_c)/r_dspmult(i_chn) ! Scale data if (r_dspexpn(i_chn) .ne. 1.0) then ! Compress data r_data(i_c) = min(1.0,max(0.0,r_data(i_c)))**r_dspexpn(i_chn) end if i_data(i_c) = max(0,min(i_dspnumt(i_chn)-1,int(i_dspnumt(i_chn)*r_data(i_c)))) if (i_dflag .eq. 0) then r_rdat(i_pos) = r_dspredt(i_data(i_c),i_chn) r_gdat(i_pos) = r_dspgrnt(i_data(i_c),i_chn) r_bdat(i_pos) = r_dspblut(i_data(i_c),i_chn) else if (i_dspmixv(i_chn) .eq. 1) then ! add r_rdat(i_pos) =r_rdat(i_pos)+r_dspredt(i_data(i_c),i_chn) r_gdat(i_pos) =r_gdat(i_pos)+r_dspgrnt(i_data(i_c),i_chn) r_bdat(i_pos) =r_bdat(i_pos)+r_dspblut(i_data(i_c),i_chn) else if (i_dspmixv(i_chn) .eq. 2) then ! mult r_rdat(i_pos) =r_rdat(i_pos)*r_dspredt(i_data(i_c),i_chn) r_gdat(i_pos) =r_gdat(i_pos)*r_dspgrnt(i_data(i_c),i_chn) r_bdat(i_pos) =r_bdat(i_pos)*r_dspblut(i_data(i_c),i_chn) else if (i_dspmixv(i_chn) .eq. 3) then ! max r_rdat(i_pos) = max(r_rdat(i_pos),r_dspredt(i_data(i_c),i_chn)) r_gdat(i_pos) = max(r_gdat(i_pos),r_dspgrnt(i_data(i_c),i_chn)) r_bdat(i_pos) = max(r_bdat(i_pos),r_dspblut(i_data(i_c),i_chn)) end if & end if else i_indx(i_pos) = 1 ! mark pixel as bad and set color to default background r_rdat(i_pos) = max(0.0,min(0.9999,(i_nullclr(1)/255.))) r_gdat(i_pos) = max(0.0,min(0.9999,(i_nullclr(2)/255.))) r_bdat(i_pos) = max(0.0,min(0.9999,(i_nullclr(3)/255.))) end if end do i_dflag = 1 end if end do ! Loop over channels if (i_ponly .eq. 0 .and. mod(i_r,i_eventmod) .eq. 1) then call getevent(1,i_event) if (i_debug .ge. 5) then if (i_event(0) .ne. 0) then write(6,'(1x,a,7i10)') & 'i_event=',i_event(0),i_event(1),i_event(2) & ,i_event(3),i_event(4),i_event(5),i_event(6) end if end if if (i_event(2) .ne. 9 .or. i_button .ne. 0) call buffer_cmd(i_event,i_bdat,i_bcnt,2,I_BMAX,i_abort,i_debug) end if i_r = i_r+1 end do ! Loop over rows if (i_r .ge. i_enrx) then if (i_r .eq. i_enrx) then r_sum=0.0d0 i_bpl = i_encx i_enrx2= i_r if (i_edsp .ne. 0) then if (i_debug .eq. -3 .or. i_debug .ge. 3) write(6,*) 'call disp',i_edsp,i_ewin,i_ecol,i_erow,i_encx,i_enrx2,i_bpl call display_img(i_edsp,i_ewin,i_ecol,i_erow,i_encx,i_enrx2,i_bpl,r_rdat,r_gdat,r_bdat) if (i_show .eq. 1) then ! show lines turned on do i=1,i_samps if (.true.) then r_row(1)=r_winzoom(i_edsp)*(i_winrows(i_edsp)/r_winzoom(i_edsp)-i_rsamps(max(1,i-1))) & /float(i_winrows(i_edsp)) r_row(2)=r_winzoom(i_edsp)*(i_winrows(i_edsp)/r_winzoom(i_edsp)-i_rsamps(i )) & /float(i_winrows(i_edsp)) r_col(1)=r_winzoom(i_edsp)*i_csamps(max(1,i-1))/float(i_wincols(i_edsp)) r_col(2)=r_winzoom(i_edsp)*i_csamps(i )/float(i_wincols(i_edsp)) r_rowlow=min(r_row(1),r_row(2)) r_rowhigh=max(r_row(1),r_row(2)) r_collow=min(r_col(1),r_col(2)) r_colhigh=max(r_col(1),r_col(2)) if (r_rowlow*i_winrows(i_edsp) .ge. i_wys(i_edsp,1)-(i_erow) .or. & r_rowhigh*i_winrows(i_edsp) .le. i_wys(i_edsp,1)-(i_erow+i_enrx2)) then c if (r_rowlow*i_winrows(i_edsp) .ge. (i_erow+i_enrx2) .or. r_rowhigh*i_winrows(i_edsp) .le. i_erow) then c write(6,*) 'row expose: ',int(r_rowlow*i_winrows(i_edsp)),int(r_rowhigh*i_winrows(i_edsp)),i_wys(i_edsp,1)-(i_erow+i_enrx2),i_wys(i_edsp,1)-(i_erow) c write(6,*) 'row expose: ',int(r_rowlow*i_winrows(i_edsp)),int(r_rowhigh*i_winrows(i_edsp)),i_erow,i_erow+i_enrx2 else if (r_collow*i_wincols(i_edsp) .ge. i_ecol+i_encx .or. r_colhigh*i_wincols(i_edsp) .le. i_ecol) then ! do nothing else if (i_tsamps(i) .eq. 1) then r_row(1)=r_winzoom(i_edsp)*(i_winrows(i_edsp)/ & r_winzoom(i_edsp)-i_rsamps(i))/float(i_winrows(i_edsp))-2/float(i_winrows(i_edsp)) r_row(2)=r_winzoom(i_edsp)*(i_winrows(i_edsp)/ & r_winzoom(i_edsp)-i_rsamps(i))/float(i_winrows(i_edsp))+2/float(i_winrows(i_edsp)) r_col(1)=r_winzoom(i_edsp)*i_csamps(i)/float(i_wincols(i_edsp))-2/float(i_winrows(i_edsp)) r_col(2)=r_winzoom(i_edsp)*i_csamps(i)/float(i_wincols(i_edsp))+2/float(i_winrows(i_edsp)) call plot_data(i_edsp,1,2,r_col,r_row) r_row(1)=r_winzoom(i_edsp)*(i_winrows(i_edsp)/ & r_winzoom(i_edsp)-i_rsamps(i))/float(i_winrows(i_edsp))+2/float(i_winrows(i_edsp)) r_row(2)=r_winzoom(i_edsp)*(i_winrows(i_edsp)/ & r_winzoom(i_edsp)-i_rsamps(i))/float(i_winrows(i_edsp))-2/float(i_winrows(i_edsp)) r_col(1)=r_winzoom(i_edsp)*i_csamps(i)/float(i_wincols(i_edsp))-2/float(i_winrows(i_edsp)) r_col(2)=r_winzoom(i_edsp)*i_csamps(i)/float(i_wincols(i_edsp))+2/float(i_winrows(i_edsp)) call plot_data(i_edsp,1,2,r_col,r_row) if (i_debug .eq. -12 .or. i_debug .ge. 12) write(6,*) 're-drawing point: ',i, & r_col(1)+2,r_row(1)-2 else if (i_tsamps(i) .lt. 0) then r_row(1)=r_winzoom(i_edsp)*(i_winrows(i_edsp)/ & r_winzoom(i_edsp)-i_rsamps(max(1,i-1)))/float(i_winrows(i_edsp)) r_row(2)=r_winzoom(i_edsp)*(i_winrows(i_edsp)/ & r_winzoom(i_edsp)-i_rsamps(i))/float(i_winrows(i_edsp)) r_col(1)=r_winzoom(i_edsp)*i_csamps(max(1,i-1))/float(i_wincols(i_edsp)) r_col(2)=r_winzoom(i_edsp)*i_csamps(i)/float(i_wincols(i_edsp)) call plot_data(i_edsp,1,2,r_col,r_row) if (i_debug .eq. -12 .or. i_debug .ge. 12) write(6,*) 're-drawing line: ',i, & r_col(1),r_row(1),r_col(2),r_row(2) end if end if end if end if end do end if ! end i_show else if (i_debug .gt. 3) write(6,*) 'Printing block: ',i_ecmd(7),i_erow,i_ecmd(8) if (mod(i_ecmd(7)+1,1000) .eq. 0) write(6,*) ' Blocks remaining: ',i_ecmd(7)+1 do ir=0,i_enrx2-1 do ic=0,min(i_encx,I_WKSPACE)-1 b_out(ic*3+1) = max(0,min(255,int(r_rdat(ic+ir*i_encx)*256))) b_out(ic*3+2) = max(0,min(255,int(r_gdat(ic+ir*i_encx)*256))) b_out(ic*3+3) = max(0,min(255,int(r_bdat(ic+ir*i_encx)*256))) end do write(i_pid,rec=2+ir+i_erow-i_ecmd(8),iostat=i_stat) (b_out(ib),ib=1,3*i_encx) end do if (i_ecmd(7) .eq. 0) then close(i_pid,iostat=i_stat) i_pinit=0 if (i_ponly .ne. 0) then i_ponly=0 i_done=1 end if a_label = 'Print Complete' if (i_winactv(i_dspselect) .ne. 0 )call display_label(i_dspselect,1,a_label,1) if (i_debug .ge. 2) then write(6,*) 'Print file complete' write(6,*) ' ' end if end if end if end if i_r = -1 if (i_debug .ge. 6) write(6,*) 'i_ecnt2=',i_ecnt end if end if end if end do c !@#&% write(6,*) ' ' write(6,*) 'mdx Done' write(6,*) ' ' end subroutine get_mdxdefaults(a_tname,a_tcmnd,a_twait,a_nullclr,i_pcpad,i_prpad,r_winzoom, & a_workdir,a_colordir,a_colorname,a_colorfile,i_colormax,i_close,a_clickcmd) implicit none integer I_KMAX parameter (I_KMAX=20) character*20 a_tname(5) character*1 a_twait(5) character*120 a_tcmnd(5) character*120 a_clickcmd(6) character*120 a_nullclr character*20 a_colorname(I_KMAX) character*255 a_colorfile(I_KMAX) integer i_colormax integer i_close real*4 r_winzoom(0:5) character*255 a_workdir character*255 a_colordir integer i integer j integer i_len integer i_found integer i_inarg integer i_prpad integer i_pcpad character*255 a_inarg(255) character*120 a_home character*120 a_keyw character*120 a_valu character*120 a_unit character*120 a_dimn character*120 a_elem character*120 a_oper character*120 a_cmnt integer rdflen external rdflen integer rdfnum external rdfnum character*40 rdflower external rdflower call getenv('HOME',a_home) if (a_home .ne. ' ') then a_home=a_home(1:rdflen(a_home))//'/.MDXinit' else a_home='.MDXinit' end if call rdf_init('ERROR_SCREEN=OFF') call rdf_clear() call rdf_read(a_home) c write(6,*) 'rdfnum = ',rdfnum() do i=1,rdfnum() call rdf_viewcols(i,a_keyw,a_valu,a_unit,a_dimn,a_elem,a_oper,a_cmnt) c write(6,*) ' a_keyw:',a_keyw c write(6,*) ' a_valu:',a_valu a_keyw=rdflower(a_keyw) if (a_keyw .eq. ' ') then ! do nothing else if (a_keyw .eq. 'tool3') then i_found=3 call rdf_getfields(a_valu,i_inarg,a_inarg) if (i_inarg .ge. 2) then a_tname(i_found)=a_inarg(1) a_tcmnd(i_found)=a_inarg(2) a_twait(i_found)=' ' do j=3,i_inarg if (a_inarg(j) .ne. '&') then a_tcmnd(i_found)=a_tcmnd(i_found)(1:rdflen(a_tcmnd(i_found)))//' '//a_inarg(j) else a_twait(i_found)='&' end if end do end if else if (a_keyw .eq. 'tool4') then i_found=4 call rdf_getfields(a_valu,i_inarg,a_inarg) if (i_inarg .ge. 2) then a_tname(i_found)=a_inarg(1) a_tcmnd(i_found)=a_inarg(2) a_twait(i_found)=' ' do j=3,i_inarg if (a_inarg(j) .ne. '&') then a_tcmnd(i_found)=a_tcmnd(i_found)(1:rdflen(a_tcmnd(i_found)))//' '//a_inarg(j) else a_twait(i_found)='&' end if end do end if else if (a_keyw .eq. 'tool5') then i_found=5 call rdf_getfields(a_valu,i_inarg,a_inarg) if (i_inarg .ge. 2) then a_tname(i_found)=a_inarg(1) a_tcmnd(i_found)=a_inarg(2) a_twait(i_found)=' ' do j=3,i_inarg if (a_inarg(j) .ne. '&') then a_tcmnd(i_found)=a_tcmnd(i_found)(1:rdflen(a_tcmnd(i_found)))//' '//a_inarg(j) else a_twait(i_found)='&' end if end do end if else if (a_keyw .eq. 'click') then i_found=1 call rdf_getfields(a_valu,i_inarg,a_inarg) if (i_inarg .ge. 2) then a_clickcmd(1)=a_inarg(2) do j=3,i_inarg a_clickcmd(i_found)=a_clickcmd(i_found)(1:rdflen(a_clickcmd(i_found)))//' '//a_inarg(j) end do end if else if (a_keyw .eq. 'addtool') then i_found=0 do j=5,3,-1 if (a_tname(j) .eq. ' ') i_found=j end do if (i_found .ne. 0) then call rdf_getfields(a_valu,i_inarg,a_inarg) if (i_inarg .ge. 2) then a_tname(i_found)=a_inarg(1) a_tcmnd(i_found)=a_inarg(2) a_twait(i_found)=' ' do j=3,i_inarg if (a_inarg(j) .ne. '&') then a_tcmnd(i_found)=a_tcmnd(i_found)(1:rdflen(a_tcmnd(i_found)))//' '//a_inarg(j) else a_twait(i_found)='&' end if end do end if end if else if (a_keyw .eq. 'null_color') then a_nullclr=a_valu else if (a_keyw .eq. 'addcmap') then call rdf_getfields(a_valu,i_inarg,a_inarg) if (i_inarg .eq. 2) then i_colormax=i_colormax+1 if (i_colormax .gt. I_KMAX) then i_colormax=I_KMAX write(6,*) 'i_colormax error' end if a_colorname(i_colormax)=a_inarg(1) a_colorfile(i_colormax)=a_inarg(2) c write(6,*) 'adding color file: ',a_colorfile(i_colormax) end if else if (a_keyw .eq. 'delcmap') then call rdf_getfields(a_valu,i_inarg,a_inarg) if (i_inarg .eq. 1) then i_found=0 do j=1,i_colormax if (a_colorname(j) .eq. a_inarg(1)) i_found=i_found+1 if (j+i_found .lt. I_KMAX) then a_colorfile(j)=a_colorfile(j+i_found) a_colorname(j)=a_colorname(j+i_found) else a_colorfile(j)=' ' a_colorname(j)=' ' end if end do i_colormax=i_colormax-i_found end if else if (a_keyw .eq. 'pcpad') then read(a_valu,*) i_pcpad else if (a_keyw .eq. 'prpad') then read(a_valu,*) i_prpad else if (a_keyw .eq. 'close') then if (a_valu .eq. 'on' .or. a_valu .eq. 'ON') i_close=1 if (a_valu .eq. 'off' .or. a_valu .eq. 'OFF') i_close=0 else if (a_keyw .eq. 'zoom') then read(a_valu,*) r_winzoom(1) if (r_winzoom(1) .lt. 0.) r_winzoom(1) = abs(1./r_winzoom(1)) else if (a_keyw .eq. 'pzoom') then read(a_valu,*) r_winzoom(0) if (r_winzoom(0) .lt. 0.) r_winzoom(0) = abs(1./r_winzoom(0)) else if (a_keyw .eq. 'workdir') then a_workdir=a_valu if (a_workdir .eq. ' ') a_workdir='./' i_len=rdflen(a_workdir) if (a_workdir(i_len:i_len) .ne. '/') a_workdir=a_workdir(1:i_len)//'/' else if (a_keyw .eq. 'colordir') then a_colordir=a_valu if (a_colordir .eq. ' ') a_colordir='./' i_len=rdflen(a_colordir) if (a_colordir(i_len:i_len) .ne. '/') a_colordir=a_colordir(1:i_len)//'/' end if end do call rdf_clear() return end subroutine encodeval(r_data,a_data) implicit none real*4 r_data character*(*) a_data character*20 a_fmt integer i integer i_err a_data='*' i=13 do while (index(a_data,'*') .ne. 0 .and. i .gt. 1) i=i-1 if (i .ge. 10) then write(a_fmt,fmt='(a,i2,a)',iostat=i_err) '(f15.',i,')' else write(a_fmt,fmt='(a,i1,a)',iostat=i_err) '(f15.',i,')' end if write(a_data,fmt=a_fmt,iostat=i_err) r_data end do if (index(a_data,'*') .ne. 0) then write(a_data,fmt='(e15.8)',iostat=i_err) r_data end if return end subroutine decodeval(a_data,r_data,i_err) implicit none real*4 r_data character*(*) a_data integer i_err integer i_loc i_loc=max(index(a_data,'e'),index(a_data,'E')) if (i_loc .gt. 1 .and. index(a_data,'.') .eq. 0) then a_data=a_data(1:i_loc-1)//'.'//a_data(i_loc:) write(6,*) 'inserting a decimal at ',i_loc,' ',a_data end if read(a_data,*,iostat=i_err) r_data return end subroutine median(r_lvl,i_cnt,r_val,r_med) implicit none integer*4 i_cnt real*4 r_val(i_cnt) real*4 r_med real*4 r_lvl real*4 r_low real*4 r_hgh real*4 r_rng integer*4 i_idx integer*4 i_hist(0:11) integer*4 i integer*4 i_num integer*4 i_sum integer*4 i_low integer*4 i_hgh integer*4 i_itr c write(6,*) 'i_cnt=',i_cnt r_low=r_val(1) r_hgh=r_val(1) do i=2,i_cnt if (r_val(i) .lt. r_low) r_low=r_val(i) if (r_val(i) .gt. r_hgh) r_hgh=r_val(i) end do c write(6,*) 'looking for lvl: ',r_lvl if (r_lvl .le. 0) then r_med=r_low else if (r_lvl .ge. 1.) then r_med=r_hgh else i_idx=0 i_hist(i_idx)=i_cnt i_itr=0 do while(i_hist(i_idx) .gt. max(int(0.00001*i_cnt),1) .and. i_itr .lt. 10 .and. & r_hgh-r_low .gt. 0) i_itr=i_itr+1 c write(6,*) 'low,high = ',r_low,r_hgh c write(6,*) 'Loop',i_itr r_rng=(r_hgh-r_low) c write(6,*) 'rng = ',r_rng do i=0,11 i_hist(i)=0 end do do i=1,i_cnt c i_idx=min(max(int((10*(r_val(i)-r_low)/(r_rng))+1),0),11) i_idx=int(min(max(((10*(r_val(i)-r_low)/r_rng)+1.0),0.0),11.0)) i_hist(i_idx)=i_hist(i_idx)+1 end do i_sum=0 i_idx=0 do i=0,11 c write(6,*) 'Hist ',i,i_hist(i) i_sum=i_sum+i_hist(i) if (i_sum .le. i_cnt*r_lvl) i_idx=i+1 end do c write(6,*) 'idx = ',i_idx r_low=(r_rng*(float(i_idx-1)/10))+r_low r_hgh=r_low+r_rng/10 end do r_med = 0 i_num = 0 do i=1,i_cnt if ((r_val(i) .ge. r_low) .and. (r_val(i) .le. r_hgh)) then i_num=i_num+1 c write(6,*) 'idx,r_val=',i_num,r_val(i) r_med = r_med+r_val(i) end if end do if (i_num .gt. 0) then r_med=r_med/i_num else r_med=(r_low+r_hgh)/2 end if i_low=0 i_hgh=0 do i=1,i_cnt if (r_val(i) .lt. r_med) i_low=i_low+1 if (r_val(i) .gt. r_med) i_hgh=i_hgh+1 end do c write(6,*) 'balance=',i_low,i_hgh,i_low/float(i_low+i_hgh) end if return end #ifdef IO64 integer*8 function i_getfsize(i_setunit) implicit none integer*4 i_setunit integer*8 i_mbytes,i_fbytes integer*8 ioseek64 external ioseek64 i_mbytes= 0 ! 1E11 i_fbytes = ioseek64(i_setunit,i_mbytes,2) i_getfsize = i_fbytes+1 end #else integer*4 function i_getfsize(i_setunit) implicit none integer*4 i_setunit integer*4 i_mbytes,i_fbytes integer*4 ioseek external ioseek i_mbytes=0 ! 2147483647 i_fbytes = ioseek(i_setunit,i_mbytes,2) i_getfsize = i_fbytes+1 end #endif integer function i_setvbyt(i_setvfmt) implicit none integer i_setvfmt integer i_bytes goto (10, 20, 30, 40, 50, 60, 70, 80, 90, 100, 110, 120, 130, 140, 150), abs(i_setvfmt)+1 c write (6,*) 'i_setvbyt error = ',i_bytes i_bytes=4 goto 200 10 continue ! 0 - byte (unsigned integer*1) i_bytes=1 goto 200 20 continue ! 1 - integer*1 i_bytes=1 goto 200 30 continue ! 2 - integer*2 i_bytes=2 goto 200 40 continue ! 3 - integer*4 i_bytes=4 goto 200 50 continue ! 4 - real*4 i_bytes=4 goto 200 60 continue ! 5 - real*8 i_bytes=8 goto 200 70 continue ! 6 - complex magnitude i_bytes=8 goto 200 80 continue ! 7 - complex phase i_bytes=8 goto 200 90 continue ! 8 - unsigned integer*2 i_bytes=2 goto 200 100 continue ! 9 - stokes11 i_bytes=10 goto 200 110 continue ! 10 - Complex 2 magnitude i_bytes=2 goto 200 120 continue ! 11 - complex 2 phase i_bytes=2 goto 200 130 continue ! 12 - complex 4 magnitude i_bytes=4 goto 200 140 continue ! 13 - complex 4 phase i_bytes=4 goto 200 150 continue ! 14 - Real*4_Magnitude i_bytes=4 goto 200 200 continue i_setvbyt = i_bytes return end subroutine get_ecmd(i_wkspace,i_ecnt,i_edat,i_ecmd,i_debug) ! This subroutine retrieves expose events from the expose event buffer ! If an expose event will exceed the size of the wkspace buffer, the event ! is divided into multiple parts and output one at a time ! implicit none integer*4 i integer*4 ie integer*4 i_ecnt integer*4 i_edat(0:10,200) integer*4 i_ecmd(0:10) integer*4 i_row integer*4 i_ncx integer*4 i_nrx integer*4 i_scl integer*4 i_brow integer*4 i_blks integer*4 i_wkspace integer*4 i_debug do i=0,10 i_ecmd(i) = i_edat(i,1) end do i_row = i_edat(4,1) i_ncx = i_edat(5,1) i_nrx = i_edat(6,1) ! number of lines in expose event i_scl = i_edat(7,1) i_brow = i_wkspace/i_ncx i_blks = (i_nrx-1)/i_brow if ((i_blks .gt. 0 .or. i_edat(8,1) .ne. i_edat(4,1)) .and. i_debug .ge. 4) & write(6,*) 'Splitting expose, block ',i_blks,i_row,i_nrx if (i_scl .ne. 1) then i_ecmd(4) = i_edat(4,1) i_edat(4,1) = i_edat(4,1)+min(i_brow,i_nrx) else i_ecmd(4) = i_row+max(0,i_nrx-i_brow) end if i_ecmd(6) = min(i_brow,i_nrx) i_ecmd(7) = i_blks c if (i_blks .eq. 1 .and. i_nrx .eq. i_brow) i_ecmd(7)= 0 ! From Ron M. ! should be unnecessary with the change to the addition of a -1 in the blks calculation i_edat(6,1) = max(0,i_edat(6,1)-i_ecmd(6)) if (i_edat(6,1) .le. 0) then i_ecnt = max(i_ecnt-1,0) do ie=1,i_ecnt ! Move Items up in buffer do i=0,10 i_edat(i,ie) = i_edat(i,ie+1) end do end do end if return end real function wrap(r_value,r_wrap) implicit none real*4 r_value real*4 r_wrap real*4 r_outp c r_outp=r_value-r_wrap*nint((r_value/r_wrap)-0.5) c if (r_outp .eq. r_wrap) r_outp=0. r_outp = mod(r_value,r_wrap) if (r_value .lt. 0) r_outp=r_wrap-abs(r_outp) c if (r_wrap .eq. 100) write(6,*) '*** value,wrap,mod,outp: ',r_value,r_wrap,mod(r_value,r_wrap),r_outp wrap=r_outp return end subroutine vecmulti(r_a,r_b,r_c) implicit none real*8 r_a(3,3) real*8 r_b(3) real*8 r_c(3) r_c(1)=r_a(1,1)*r_b(1)+r_a(1,2)*r_b(2)+r_a(1,3)*r_b(3) r_c(2)=r_a(2,1)*r_b(1)+r_a(2,2)*r_b(2)+r_a(2,3)*r_b(3) r_c(3)=r_a(3,1)*r_b(1)+r_a(3,2)*r_b(2)+r_a(3,3)*r_b(3) return end subroutine vecscale(r_scale,r_a,r_b) implicit none real*8 r_scale real*8 r_a(3) real*8 r_b(3) r_b(1)=r_scale*r_a(1) r_b(2)=r_scale*r_a(2) r_b(3)=r_scale*r_a(3) return end subroutine vecaddit(r_a,r_b,r_c) implicit none real*8 r_a(3) real*8 r_b(3) real*8 r_c(3) r_c(1)=r_a(1)+r_b(1) r_c(2)=r_a(2)+r_b(2) r_c(3)=r_a(3)+r_b(3) return end c**************************************************************** subroutine tcnatm(r_a,r_e2,r_peg,r_atm) c**************************************************************** c** c** FILE NAME: tcnatm.for c** c** DATE WRITTEN:10/25/95 c** c** PROGRAMMER:Scott Shaffer c** c** FUNCTIONAL DESCRIPTION:This routine computes the transformation c** matris and translation vector needed to get between radar (t,c,n) c** coordinates and (x,y,z) WGS-84 coordinates. c** c** ROUTINES CALLED: c** c** NOTES: none c** c** UPDATE LOG: c** c***************************************************************** implicit none c INPUT VARIABLES: real*8 r_a !semimajor axis real*8 r_e2 !eccentricity squared real*8 r_peg(3) !peg latitude,longitude,heading c OUTPUT VARIABLES: real*8 r_atm(3,4) !rotation matris c LOCAL VARIABLES: integer i_type real*8 r_hgt real*8 r_slt,r_clt,r_clo,r_slo,r_chg,r_shg real*8 rdir external rdir c DATA STATEMENTS:none c PROCESSING STEPS: c first determine the rotation matris r_clt = cos(r_peg(1)) r_slt = sin(r_peg(1)) r_clo = cos(r_peg(2)) r_slo = sin(r_peg(2)) r_chg = cos(r_peg(3)) r_shg = sin(r_peg(3)) r_atm(1,1) = - r_slo*r_shg - r_slt*r_clo*r_chg r_atm(1,2) = r_slo*r_chg - r_slt*r_clo*r_shg r_atm(1,3) = r_clt*r_clo r_atm(2,1) = r_clo*r_shg - r_slt*r_slo*r_chg r_atm(2,2) = - r_clo*r_chg - r_slt*r_slo*r_shg r_atm(2,3) = r_clt*r_slo r_atm(3,1) = r_clt*r_chg r_atm(3,2) = r_clt*r_shg r_atm(3,3) = r_slt c find the translation vector i_type = 1 r_hgt = 0. call latlon(r_a,r_e2,r_atm(1,4),r_peg(1),r_peg(2),r_hgt,i_type) return end c**************************************************************** subroutine latlon(r_a,r_e2,r_v,r_lat,r_lon,r_hgt,i_type) c**************************************************************** c** c** FILE NAME: latlon.f c** c** DATE WRITTEN:7/22/93 c** c** PROGRAMMER:Scott Hensley c** c** FUNCTIONAL DESCRIPTION:This program converts a vector to c** lat,lon and height above the reference ellipsoid or given a c** lat,lon and height produces a geocentric vector. c** c** ROUTINES CALLED:none c** c** NOTES: none c** c** UPDATE LOG: c** c**************************************************************** implicit none c INPUT VARIABLES: integer i_type !1=lat,lon to vector,2= vector to lat,lon real*8 r_a !ellispoid semi-major axis real*8 r_e2 !ellipsoid eccentricity squared real*8 r_v(3) !geocentric vector (meters) real*8 r_lat !latitude (deg -90 to 90) real*8 r_lon !longitude (deg -180 to 180) real*8 r_hgt !height above ellipsoid (meters) c OUTPUT VARIABLES:see input c LOCAL VARIABLES: integer i_ft real*8 pi,r_dtor,r_re,r_q2,r_q3,r_b,r_q real*8 r_p,r_tant,r_theta c DATA STATEMENTS: data pi /3.141592653589793238d0/ data r_dtor /1.74532925199d-2/ data i_ft /0/ C FUNCTION STATEMENTS: c PROCESSING STEPS: if(i_type .eq. 1)then !convert lat,lon to vector r_re = r_a/sqrt(1.d0 - r_e2*sin(r_lat)**2) r_v(1) = (r_re + r_hgt)*cos(r_lat)*cos(r_lon) r_v(2) = (r_re + r_hgt)*cos(r_lat)*sin(r_lon) r_v(3) = (r_re*(1.d0-r_e2) + r_hgt)*sin(r_lat) elseif(i_type .eq. 2)then !convert vector to lat,lon if(i_ft .eq. 0)then r_q2 = 1.d0/(1.d0 - r_e2) r_q = sqrt(r_q2) r_q3 = r_q2 - 1.d0 r_b = r_a*sqrt(1.d0 - r_e2) end if r_lon = atan2(r_v(2),r_v(1)) r_p = sqrt(r_v(1)**2 + r_v(2)**2) r_tant = (r_v(3)/r_p)*r_q r_theta = atan(r_tant) r_tant = (r_v(3) + r_q3*r_b*sin(r_theta)**3)/ + (r_p - r_e2*r_a*cos(r_theta)**3) r_lat = atan(r_tant) r_re = r_a/sqrt(1.d0 - r_e2*sin(r_lat)**2) r_hgt = r_p/cos(r_lat) - r_re end if return end c**************************************************************** subroutine sch_to_tcn(r_a,r_v,r_lat,r_lon,r_hgt,i_type) c**************************************************************** c** c** FILE NAME: sch_to_tcn.f c** c** DATE WRITTEN:7/22/93 c** c** PROGRAMMER:Scott Hensley c** c** FUNCTIONAL DESCRIPTION:This program converts a vector to c** lat,lon and height above the reference ellipsoid or given a c** lat,lon and height produces a geocentric vector. c** c** ROUTINES CALLED:none c** c** NOTES: none c** c** UPDATE LOG: c** c**************************************************************** implicit none c INPUT VARIABLES: integer i_type !1=lat,lon to vector,2= vector to lat,lon real*8 r_a !ellispoid semi-major axis real*8 r_v(3) !geocentric vector (meters) real*8 r_lat !latitude (deg -90 to 90) real*8 r_lon !longitude (deg -180 to 180) real*8 r_hgt !height above ellipsoid (meters) c OUTPUT VARIABLES:see input c LOCAL VARIABLES: real*8 r_p C FUNCTION STATEMENTS: c PROCESSING STEPS: if(i_type .eq. 1)then !convert lat,lon to vector r_v(3) = (r_a + r_hgt)*cos(r_lat)*cos(r_lon) - r_a r_v(1) = (r_a + r_hgt)*cos(r_lat)*sin(r_lon) r_v(2) = (r_a + r_hgt)*sin(r_lat) elseif(i_type .eq. 2)then !convert vector to lat,lon, hgt r_p = sqrt(r_v(1)**2 + r_v(2)**2 + (r_v(3)+r_a)**2) r_lat = asin(r_v(2)/r_p) r_lon = atan2(r_v(1),(r_v(3)+r_a)) r_hgt = r_p - r_a end if return end c**************************************************************** c c Various curvature functions c c c**************************************************************** c** c** FILE NAME: curvature.f c** c** DATE WRITTEN: 12/02/93 c** c** PROGRAMMER:Scott Hensley c** c** FUNCTIONAL DESCRIPTION: This routine computes the curvature for c** of various types required for ellipsoidal or spherical earth c** calculations. c** c** ROUTINES CALLED:none c** c** NOTES: none c** c** UPDATE LOG: c** c***************************************************************** real*8 function reast(r_a,r_e2,r_lat) implicit none real*8 r_a,r_e2,r_lat reast = r_a/sqrt(1.d0 - r_e2*sin(r_lat)**2) end real*8 function rnorth(r_a,r_e2,r_lat) implicit none real*8 r_a,r_e2,r_lat rnorth = (r_a*(1.d0 - r_e2))/ 1 (1.d0 - r_e2*sin(r_lat)**2)**(1.5d0) end real*8 function rdir(r_a,r_e2,r_hdg,r_lat) implicit none real*8 r_a,r_e2,r_lat,r_hdg,r_re,r_rn,reast,rnorth r_re = reast(r_a,r_e2,r_lat) r_rn = rnorth(r_a,r_e2,r_lat) rdir = (r_re*r_rn)/(r_re*cos(r_hdg)**2 + r_rn*sin(r_hdg)**2) end c**************************************************************** subroutine utmtoll(r_a,r_e2,i_zone,a_grid,r_vec,r_lat, + r_lon,i_type) c**************************************************************** c** c** FILE NAME: utmtoll.f c** c** DATE WRITTEN:7/22/93 c** c** PROGRAMMER:Scott Hensley c** c** FUNCTIONAL DESCRIPTION: This routine converts between lat c** lon and utm coordinates for a datum determined from the input c** a and e2. c** c** ROUTINES CALLED:none c** c** NOTES: none c** c** UPDATE LOG: c** c**************************************************************** implicit none c INPUT VARIABLES: integer i_type !1=lat,lon to utm,2= utm to lat,lon real*8 r_a !ellispoid semi-major axis real*8 r_e2 !ellipsoid eccentricity squared real*8 r_vec(2) !Northing,Easting(m) real*8 r_lat !latitude (deg -90 to 90) real*8 r_lon !longitude (deg -180 to 180) integer i_zone !UTM zone character*1 a_grid !UTM North-South grid c OUTPUT VARIABLES:see input c LOCAL VARIABLES: integer i_ft,i_gi real*8 r_v(2) !Northing,Easting(m) real*8 pi,r_dtor real*8 r_ep2,r_k0,r_k real*8 r_fe,r_fn(2) real*8 r_e4,r_e6,r_n,r_t,r_t2,r_c,r_c2,r_ba real*8 r_a2,r_a3,r_a4,r_a5,r_a6 real*8 r_d,r_d2,r_d3,r_d4,r_d5,r_d6 real*8 r_lon0,r_lat1,r_m,r_m0,r_mu,r_lat0 real*8 r_et,r_e1,r_e12,r_e13,r_e14,r_r character*1 a_griddes(20) c DATA STATEMENTS: data pi /3.141592653589793238d0/ data r_dtor /1.74532925199d-2/ data i_ft /0/ data a_griddes /'C','D','E','F','G','H','J', + 'K','L','M','N','P','Q','R','S','T','U', + 'V','W','X'/ data r_k0 /.9996d0/ !scale at center data r_lat0 /0.d0/ data r_fe,r_fn /500000.d0,0.d0,10000000.d0/ C FUNCTION STATEMENTS:none c PROCESSING STEPS: r_ep2 = r_e2/(1.d0 - r_e2) r_e4 = r_e2**2 r_e6 = r_e2**3 pi = 4.d0*atan(1.d0) r_dtor = pi/180.d0 if (i_zone .le. 0) i_zone = int(mod(r_lon+3.d0*pi,2.d0*pi)/(r_dtor*6.d0)) + + 1 if(i_type .eq. 2)then !convert lat,lon to UTM i_zone = max(min(i_zone,60),1) r_lon0 = -pi + 6.d0*r_dtor*(i_zone-1) + 3.d0*r_dtor r_n = r_a/sqrt(1.d0 - r_e2*sin(r_lat)**2) r_t = tan(r_lat)**2 r_t2 = r_t**2 r_c = r_ep2*cos(r_lat)**2 r_ba = (r_lon - r_lon0)*cos(r_lat) r_a2 = r_ba**2 r_a3 = r_ba*r_a2 r_a4 = r_ba*r_a3 r_a5 = r_ba*r_a4 r_a6 = r_ba*r_a5 r_m = r_a*((1.d0-r_e2/4 - 3.d0*r_e4/64.d0 - + 5.d0*r_e6/256.d0)*r_lat - (3.d0*r_e2/8.d0 + + 3.d0*r_e4/32.d0 + + 45.d0*r_e6/1024.d0)*sin(2.d0*r_lat) + + (15.d0*r_e4/256.d0 + + 45.d0*r_e6/1024.d0)*sin(4.d0*r_lat) - + (35.d0*r_e6/3072.d0)* + sin(6.d0*r_lat)) r_m0 = r_a*((1.d0-r_e2/4 - 3.d0*r_e4/64.d0 - + 5.d0*r_e6/256.d0)*r_lat0 - (3.d0*r_e2/8.d0 + + 3.d0*r_e4/32.d0 + + 45.d0*r_e6/1024.d0)*sin(2.d0*r_lat0) + + (15.d0*r_e4/256.d0 + + 45.d0*r_e6/1024.d0)*sin(4.d0*r_lat0) - + (35.d0*r_e6/3072.d0)* + sin(6.d0*r_lat0)) r_vec(2) = r_k0*r_n*(r_ba+(1.d0-r_t+r_c)*r_a3/6.d0 + + (5.d0-18.d0*r_t+r_t2+72.d0*r_c-58.d0*r_ep2)*r_a5/120.d0) r_vec(2) = r_vec(2) + r_fe r_vec(1) = r_k0*(r_m - r_m0 + r_n*tan(r_lat)* + ( r_a2/2.d0 + (5.d0-r_t+9.d0*r_c+4.d0*r_c**2)* + (r_a4/24.d0) + (61.d0-58.d0*r_t+r_t2+600.d0*r_c- + 330.d0*r_ep2)*(r_a6/720.d0) )) if(r_lat .ge. 0)then r_vec(1) = r_vec(1) + r_fn(1) else r_vec(1) = r_vec(1) + r_fn(2) end if r_k = r_k0*(1.d0+(1.d0+r_ep2*cos(r_lat)**2)* + (r_vec(2)-r_fe)**2/ + (2.d0*(r_k0**2)*r_n**2)) i_gi = int((r_lat/r_dtor+80.d0)/8.d0) + 1 i_gi = max(min(i_gi,20),1) a_grid = a_griddes(i_gi) elseif(i_type .eq. 1)then !convert UTM to lat,lon r_v(1) = r_vec(1) r_v(2) = r_vec(2) r_v(2) = r_v(2) - r_fe if(r_v(1) .ge. r_fn(2))then r_v(1) = r_v(1) - r_fn(2) end if r_lon0 = -pi + 6.d0*r_dtor*(i_zone-1) + 3.d0*r_dtor r_et = sqrt(1.d0-r_e2) r_e1 = (1.d0-r_et)/(1.d0+r_et) r_e12 = r_e1**2 r_e13 = r_e1*r_e12 r_e14 = r_e1*r_e13 r_m = r_v(1)/r_k0 r_mu = r_m/(r_a*(1.d0-r_e2/4.d0-3.d0*r_e4/64.d0- + 5.d0*r_e6/256.d0)) r_lat1 = r_mu + (3.d0*r_e1/2.d0-27.d0*r_e13/32.d0)* + sin(2.d0*r_mu)+ + (21.d0*r_e12/16.d0-55.d0*r_e14/32.d0)*sin(4.d0*r_mu)+ + (51.d0*r_e13/96.d0)*sin(6.d0*r_mu) + + (1097.d0*r_e14/512.d0)*sin(8.d0*r_mu) r_n = r_a/sqrt(1.d0 - r_e2*sin(r_lat1)**2) r_r = (r_a*(1.d0-r_e2))/sqrt(1.d0 - r_e2*sin(r_lat1)**2)**3 r_t = tan(r_lat1)**2 r_t2 = r_t**2 r_c = r_ep2*cos(r_lat1)**2 r_c2 = r_c**2 r_d = r_v(2)/(r_n*r_k0) r_d2 = r_d**2 r_d3 = r_d2*r_d r_d4 = r_d3*r_d r_d5 = r_d4*r_d r_d6 = r_d5*r_d r_lat = r_lat1 - (r_n*tan(r_lat1)/r_r)*(r_d2/2.d0+ + (5.d0+3.d0*r_t+10.d0*r_c-4.d0*r_c2-9.d0*r_ep2)* + r_d4/24.d0 + + (61.d0+90*r_t+298.d0*r_c+45.d0*r_t2-252.d0*r_ep2-3.d0* + r_c2)* + (r_d6/720.d0)) r_lon = r_lon0 + (r_d - (1.d0+2.d0*r_t+r_c)*r_d3/6.d0 + + (5.d0-2.d0*r_c+28.d0*r_t-3.d0*r_c2+8.d0*r_ep2+ + 24.d0*r_t2)* + (r_d5/120.d0))/cos(r_lat1) end if end c**************************************************************** subroutine enutoll(r_a,r_e2,i_zone,a_grid,r_vec,r_lat, + r_lon,i_type) c**************************************************************** c** c** FILE NAME: enutoll.f c** c** DATE WRITTEN:7/22/93 c** c** PROGRAMMER:Scott Hensley c** c** FUNCTIONAL DESCRIPTION: This routine converts between lat c** lon and enu coordinates for a datum determined from the input c** a and e2. c** c** ROUTINES CALLED:none c** c** NOTES: none c** c** UPDATE LOG: added zone selection logic SJS 3/28/96 c** c**************************************************************** implicit none c INPUT VARIABLES: integer i_type !2=lat,lon to utm,1= utm to lat,lon real*8 r_a !ellispoid semi-major axis real*8 r_e2 !ellipsoid eccentricity squared real*8 r_vec(2) !Northing,Easting(m) real*8 r_lat !latitude (deg -90 to 90) real*8 r_lon !longitude (deg -180 to 180) integer i_zone !UTM zone character*1 a_grid !UTM North-South grid c OUTPUT VARIABLES:see input c LOCAL VARIABLES: integer i_ft,i_gi real*8 pi,r_dtor real*8 r_v(2) !Northing,Easting(m) real*8 r_ep2,r_k0,r_k real*8 r_fe,r_fn(2) real*8 r_e4,r_e6,r_n,r_t,r_t2,r_c,r_c2,r_ba real*8 r_a2,r_a3,r_a4,r_a5,r_a6 real*8 r_d,r_d2,r_d3,r_d4,r_d5,r_d6 real*8 r_lon0,r_lat1,r_m,r_m0,r_mu,r_lat0 real*8 r_et,r_e1,r_e12,r_e13,r_e14,r_r character*1 a_griddes(20) c DATA STATEMENTS: data pi /3.141592653589793238d0/ data r_dtor /1.74532925199d-2/ data i_ft /0/ data a_griddes /'C','D','E','F','G','H','J', + 'K','L','M','N','P','Q','R','S','T','U', + 'V','W','X'/ data r_k0 /.9996d0/ !scale at center data r_lat0 /0.d0/ data r_fe,r_fn /500000.d0,0.d0,10000000.d0/ C FUNCTION STATEMENTS:none c PROCESSING STEPS: r_ep2 = r_e2/(1.d0 - r_e2) r_e4 = r_e2**2 r_e6 = r_e2**3 pi = 4.d0*atan(1.d0) r_dtor = pi/180.d0 if(i_type .eq. 2)then !convert lat,lon to UTM if (i_zone .le. 0) i_zone = int(mod(r_lon+3.d0*pi,2.d0*pi)/(r_dtor*6.d0)) + + 1 i_zone = max(min(i_zone,60),1) r_lon0 = -pi + 6.d0*r_dtor*(i_zone-1) + 3.d0*r_dtor r_n = r_a/sqrt(1.d0 - r_e2*sin(r_lat)**2) r_t = tan(r_lat)**2 r_t2 = r_t**2 r_c = r_ep2*cos(r_lat)**2 r_ba = (r_lon - r_lon0)*cos(r_lat) r_a2 = r_ba**2 r_a3 = r_ba*r_a2 r_a4 = r_ba*r_a3 r_a5 = r_ba*r_a4 r_a6 = r_ba*r_a5 r_m = r_a*((1.d0-r_e2/4 - 3.d0*r_e4/64.d0 - + 5.d0*r_e6/256.d0)*r_lat - (3.d0*r_e2/8.d0 + + 3.d0*r_e4/32.d0 + + 45.d0*r_e6/1024.d0)*sin(2.d0*r_lat) + + (15.d0*r_e4/256.d0 + + 45.d0*r_e6/1024.d0)*sin(4.d0*r_lat) - + (35.d0*r_e6/3072.d0)* + sin(6.d0*r_lat)) r_m0 = r_a*((1.d0-r_e2/4 - 3.d0*r_e4/64.d0 - + 5.d0*r_e6/256.d0)*r_lat0 - (3.d0*r_e2/8.d0 + + 3.d0*r_e4/32.d0 + + 45.d0*r_e6/1024.d0)*sin(2.d0*r_lat0) + + (15.d0*r_e4/256.d0 + + 45.d0*r_e6/1024.d0)*sin(4.d0*r_lat0) - + (35.d0*r_e6/3072.d0)* + sin(6.d0*r_lat0)) r_vec(1) = r_k0*r_n*(r_ba+(1.d0-r_t+r_c)*r_a3/6.d0 + + (5.d0-18.d0*r_t+r_t2+72.d0*r_c-58.d0*r_ep2)*r_a5/120.d0) r_vec(1) = r_vec(1) + r_fe r_vec(2) = r_k0*(r_m - r_m0 + r_n*tan(r_lat)* + ( r_a2/2.d0 + (5.d0-r_t+9.d0*r_c+4.d0*r_c**2)* + (r_a4/24.d0) + (61.d0-58.d0*r_t+r_t2+600.d0*r_c- + 330.d0*r_ep2)*(r_a6/720.d0) )) if(r_lat .ge. 0)then r_vec(2) = r_vec(2) + r_fn(1) else r_vec(2) = r_vec(2) + r_fn(2) end if r_k = r_k0*(1.d0+(1.d0+r_ep2*cos(r_lat)**2)* + (r_vec(1)-r_fe)**2/ + (2.d0*(r_k0**2)*r_n**2)) i_gi = int((r_lat/r_dtor+80.d0)/8.d0) + 1 i_gi = max(min(i_gi,20),1) a_grid = a_griddes(i_gi) else if(i_type .eq. 1)then !convert UTM to lat,lon r_v(1) = r_vec(1) r_v(2) = r_vec(2) r_v(1) = r_v(1) - r_fe if(r_v(2) .ge. r_fn(2))then r_v(2) = r_v(2) - r_fn(2) end if r_lon0 = -pi + 6.d0*r_dtor*(i_zone-1) + 3.d0*r_dtor r_et = sqrt(1.d0-r_e2) r_e1 = (1.d0-r_et)/(1.d0+r_et) r_e12 = r_e1**2 r_e13 = r_e1*r_e12 r_e14 = r_e1*r_e13 r_m = r_v(2)/r_k0 r_mu = r_m/(r_a*(1.d0-r_e2/4.d0-3.d0*r_e4/64.d0- + 5.d0*r_e6/256.d0)) r_lat1 = r_mu + (3.d0*r_e1/2.d0-27.d0*r_e13/32.d0)* + sin(2.d0*r_mu)+ + (21.d0*r_e12/16.d0-55.d0*r_e14/32.d0)*sin(4.d0*r_mu)+ + (51.d0*r_e13/96.d0)*sin(6.d0*r_mu) + + (1097.d0*r_e14/512.d0)*sin(8.d0*r_mu) r_n = r_a/sqrt(1.d0 - r_e2*sin(r_lat1)**2) r_r = (r_a*(1.d0-r_e2))/sqrt(1.d0 - r_e2*sin(r_lat1)**2)**3 r_t = tan(r_lat1)**2 r_t2 = r_t**2 r_c = r_ep2*cos(r_lat1)**2 r_c2 = r_c**2 r_d = r_v(1)/(r_n*r_k0) r_d2 = r_d**2 r_d3 = r_d2*r_d r_d4 = r_d3*r_d r_d5 = r_d4*r_d r_d6 = r_d5*r_d r_lat = r_lat1 - (r_n*tan(r_lat1)/r_r)*(r_d2/2.d0+ + (5.d0+3.d0*r_t+10.d0*r_c-4.d0*r_c2-9.d0*r_ep2)* + r_d4/24.d0 + + (61.d0+90*r_t+298.d0*r_c+45.d0*r_t2-252.d0*r_ep2-3.d0* + r_c2)* + (r_d6/720.d0)) r_lon = r_lon0 + (r_d - (1.d0+2.d0*r_t+r_c)*r_d3/6.d0 + + (5.d0-2.d0*r_c+28.d0*r_t-3.d0*r_c2+8.d0*r_ep2+ + 24.d0*r_t2)* + (r_d5/120.d0))/cos(r_lat1) end if end subroutine invrstrn(r_atm,r_mta) c c This subroutine finds the inverse of an affine transformation c including the translation vector c implicit none real*8 r_atm(3,4) real*8 r_mta(3,4) real*8 r_tmp(3) real*8 r_one r_one = -1.0 call matinvrt(r_atm,r_mta) call vecmulti(r_mta,r_atm(1,4),r_tmp) call vecscale(r_one,r_tmp,r_mta(1,4)) return end subroutine matinvrt(r_a,r_b) implicit none real*8 a11 real*8 a12 real*8 a13 real*8 a21 real*8 a22 real*8 a23 real*8 a31 real*8 a32 real*8 a33 real*8 r_a(3,3) real*8 r_b(3,3) real*8 r_dd a11=r_a(1,1) a12=r_a(1,2) a13=r_a(1,3) a21=r_a(2,1) a22=r_a(2,2) a23=r_a(2,3) a31=r_a(3,1) a32=r_a(3,2) a33=r_a(3,3) r_dd=a11*(a22*a33-a23*a32)-a12*(a21*a33-a23*a31)+ & a13*(a21*a32-a22*a31) if (r_dd .ne. 0.) then r_b(1,1)=(a22*a33-a23*a32)/r_dd r_b(1,2)=(a13*a32-a12*a33)/r_dd r_b(1,3)=(a12*a23-a13*a22)/r_dd r_b(2,1)=(a23*a31-a21*a33)/r_dd r_b(2,2)=(a11*a33-a13*a31)/r_dd r_b(2,3)=(a13*a21-a11*a23)/r_dd r_b(3,1)=(a21*a32-a22*a31)/r_dd r_b(3,2)=(a12*a31-a11*a32)/r_dd r_b(3,3)=(a11*a22-a12*a21)/r_dd else write(6,*) 'Determinant = 0 in Subroutine matinvrt' r_b(1,1)=1. r_b(1,2)=0. r_b(1,3)=0. r_b(2,1)=0. r_b(2,2)=1. r_b(2,3)=0. r_b(3,1)=0. r_b(3,2)=0. r_b(3,3)=1. endif return end subroutine get_coordinates(a_setproj,r_setpegv,r_loc11,r_loc22,i_flag,i_debug,i_err) implicit none character*200 a_setproj ! Projection name integer*4 i_flag integer*4 i_debug integer*4 i_err real*4 r_setpegv(3) ! Peg Point real*4 r_row real*4 r_col real*4 r_val real*4 r_loc11(3) real*4 r_loc22(3) real*8 r_setpegvdble(3) ! Peg Point real*8 r_loc1(3) real*8 r_loc2(3) real*8 r_loc3(3) real*8 r_loc4(3) real*8 r_rtod real*8 r_rad real*8 r_hhh real*8 r_lat real*8 r_lon real*8 r_pi real*8 r_e2 real*8 r_a real*8 r_atm(3,4) real*8 r_mta(3,4) integer*4 i_zone character*1 a_grid !UTM North-South grid integer rdflen external rdflen real*8 rdir external rdir c c Initialize pi and conversions c r_pi = 4.d0*atan(1.0d0) r_rtod = 180.0d0/r_pi r_a = 6378137.0 r_e2 = 0.00669438 r_setpegvdble(1) = r_setpegv(1) r_setpegvdble(2) = r_setpegv(2) r_setpegvdble(3) = r_setpegv(3) i_zone = 0 r_lon=r_setpegv(2) r_rad = rdir(r_a,r_e2,r_setpegvdble(3),r_setpegvdble(1)) i_err=0 if (i_flag .eq. 1) then ! convert row/column to lat/lon if (i_debug .eq. -6 .or. i_debug .ge. 6) write(6,*) 'r_peglat=',r_setpegv(1) if (i_debug .eq. -6 .or. i_debug .ge. 6) write(6,*) 'r_peglon=',r_setpegv(2) if (i_debug .eq. -6 .or. i_debug .ge. 6) write(6,*) 'r_peghdg=',r_setpegv(3) if (i_debug .eq. -6 .or. i_debug .ge. 6) write(6,*) 'r_rad=',r_rad r_loc1(1) = r_loc11(1) r_loc1(2) = r_loc11(2) r_loc1(3) = r_loc11(3) if (i_debug .ge. 6) write(6,*) 'r_loc1=',r_loc1 if (a_setproj .eq. 'sch' .or. a_setproj .eq. 'SCH') then r_lon=r_loc1(1)/r_rad r_lat=r_loc1(2)/r_rad r_hhh=r_loc1(3) call tcnatm(r_a,r_e2,r_setpegvdble,r_atm) call sch_to_tcn(r_rad,r_loc3,r_lat,r_lon,r_hhh,1) call vecmulti(r_atm,r_loc3,r_loc4) ! convert from input xyz to output xyz call vecaddit(r_atm(1,4),r_loc4,r_loc4) call latlon(r_a,r_e2,r_loc4,r_lat,r_lon,r_hhh,2) else if (a_setproj .eq. 'scx' .or. a_setproj .eq. 'SCX') then r_lon=r_loc1(1)/r_rad r_lat=r_loc1(2)/r_rad r_hhh=0 call tcnatm(r_a,r_e2,r_setpegvdble,r_atm) call sch_to_tcn(r_rad,r_loc3,r_lat,r_lon,r_hhh,1) call vecmulti(r_atm,r_loc3,r_loc4) ! convert from input xyz to output xyz call vecaddit(r_atm(1,4),r_loc4,r_loc4) call latlon(r_a,r_e2,r_loc4,r_lat,r_lon,r_hhh,2) r_hhh=r_loc1(3) else if (a_setproj .eq. 'eqa' .or. a_setproj .eq. 'EQA') then r_lat=r_loc1(1)/r_rtod r_lon=r_loc1(2)/r_rtod r_hhh=r_loc1(3) else if (a_setproj .eq. 'utm' .or. a_setproj .eq. 'UTM') then call utmtoll(r_a,r_e2,i_zone,a_grid,r_loc1,r_lat,r_lon,1) if (i_debug .ge. 6) write(6,*) 'i_zone=',i_zone r_hhh=r_loc1(3) else if (a_setproj .eq. 'neu' .or. a_setproj .eq. 'NEU') then call utmtoll(r_a,r_e2,i_zone,a_grid,r_loc1,r_lat,r_lon,1) r_hhh=r_loc1(3) else if (a_setproj .eq. 'enu' .or. a_setproj .eq. 'ENU') then call enutoll(r_a,r_e2,i_zone,a_grid,r_loc1,r_lat,r_lon,1) r_hhh=r_loc1(3) else i_err=1 if (i_debug .ge. 1) write(6,*) 'Lat/Long conversion not supported for ',a_setproj(1:max(1,rdflen(a_setproj))) end if r_loc22(1)=r_lat r_loc22(2)=r_lon r_loc22(3)=r_hhh else ! convert lat/lon to row/column r_lat = r_loc22(1) r_lon = r_loc22(2) r_hhh = r_loc22(3) if (i_debug .eq. -6 .or. i_debug .ge. 6) write(6,*) 'r_lat=',r_lat if (i_debug .eq. -6 .or. i_debug .ge. 6) write(6,*) 'r_lon=',r_lon if (i_debug .eq. -6 .or. i_debug .ge. 6) write(6,*) 'r_hdg=',r_hhh if (i_debug .eq. -6 .or. i_debug .ge. 6) write(6,*) 'r_rad=',r_rad if (i_debug .eq. -6 .or. i_debug .ge. 6) write(6,*) 'Converting from lat/lon to row/column(almost) '//a_setproj if (a_setproj .eq. 'sch' .or. a_setproj .eq. 'SCH') then call latlon(r_a,r_e2,r_loc1,r_lat,r_lon,r_hhh,1) ! convert lat/lon to wgs84 xyz if (i_debug .eq. -9 .or. i_debug .ge. 9) write(6,*) 'wgs84xyz=',r_loc1 call tcnatm(r_a,r_e2,r_setpegvdble,r_atm) ! compute tcn to xyz transform call invrstrn(r_atm,r_mta) call vecmulti(r_mta,r_loc1,r_loc2) ! convert from wgs84 xyz to tcn call vecaddit(r_mta(1,4),r_loc2,r_loc2) if (i_debug .eq. -6 .or. i_debug .ge. 6) write(6,*) 'tcnxyz=',r_loc2 call sch_to_tcn(r_rad,r_loc2,r_lat,r_lon,r_hhh,2) ! convert tcn to sch r_loc11(1)=r_lon*r_rad ! Convert sch r_loc11(2)=r_lat*r_rad r_loc11(3)=r_hhh else if (a_setproj .eq. 'scx' .or. a_setproj .eq. 'SCX') then r_hhh=0.0 call latlon(r_a,r_e2,r_loc1,r_lat,r_lon,r_hhh,1) ! convert lat/lon to wgs84 xyz if (i_debug .eq. -9 .or. i_debug .ge. 9) write(6,*) 'wgs84xyz=',r_loc1 call tcnatm(r_a,r_e2,r_setpegvdble,r_atm) ! compute tcn to xyz transform c write(6,*) 'peg=',r_setpegv call invrstrn(r_atm,r_mta) call vecmulti(r_mta,r_loc1,r_loc2) ! convert from wgs84 xyz to tcn call vecaddit(r_mta(1,4),r_loc2,r_loc2) if (i_debug .eq. -9 .or. i_debug .ge. 9) write(6,*) 'tcnxyz=',r_loc2 call sch_to_tcn(r_rad,r_loc2,r_lat,r_lon,r_hhh,2) ! convert tcn to sch r_loc11(1)=r_lon*r_rad ! Convert sch r_loc11(2)=r_lat*r_rad r_loc11(3)=r_hhh else if (a_setproj .eq. 'eqa' .or. a_setproj .eq. 'EQA') then r_loc11(1)=r_lat*r_rtod r_loc11(2)=r_lon*r_rtod r_loc11(3)=r_hhh else i_err=1 if (i_debug .ge. 1) write(6,*) 'Lat/Long output not supported for ',a_setproj(1:max(1,rdflen(a_setproj))) end if end if return end subroutine buffer_cmd(i_event,i_bdat,i_bcnt,i_base,I_BMAX,i_abort,i_debug) implicit none integer*4 I_BMAX integer*4 i_event(0:10) integer*4 i_bdat(0:10,I_BMAX) integer*4 i_bcnt integer*4 i_abort integer*4 i_base integer*4 i_debug integer*4 i integer*4 j integer*4 k integer*4 ii c if ((i_event(0) .eq. 0 .and. i_event(2) .eq. 0) .or. i_event(2) .eq. 9) then if ((i_event(0) .eq. 0 .and. i_event(2) .eq. 0) ) then ! do nothing else i_bcnt = min(i_bcnt+1,I_BMAX) do i=0,10 i_bdat(i,i_bcnt) = i_event(i) end do end if return end subroutine get_colortable(a_colordir,a_dspctbl,i_dspnumt,r_dspredt,r_dspgrnt,r_dspblut,i_debug) implicit none character*(*) a_dspctbl character*(255) a_line character*(255) a_colordir character*(255) a_file integer*4 i_dspnumt integer*4 i_debug real*4 r_dspredt(0:255) real*4 r_dspgrnt(0:255) real*4 r_dspblut(0:255) integer*4 i_nrgb(0:3,0:256) integer*4 i, j, k integer*4 i_cnt integer*4 i_loc integer*4 ierr integer rdflen external rdflen if (i_debug .eq. -3 .or. i_debug .ge. 3) write(6,*) 'in get_colortable:',a_dspctbl,a_colordir if (a_dspctbl .eq. ' ' .or. a_dspctbl .eq. '?' .or. a_dspctbl .eq. '*') then c i_dspnumt=256 c do i=0,255 c r_dspredt(i) = 0. ! Values of red color table c r_dspgrnt(i) = 0. ! Values of green color table c r_dspblut(i) = 0. ! Values of blue color table c end do else if (a_dspctbl .eq. 'bitmap') then i_dspnumt=2 r_dspredt(0) = 0. ! Values of red color table r_dspgrnt(0) = 0. ! Values of green color table r_dspblut(0) = 0. ! Values of blue color table r_dspredt(1) = 1. ! Values of red color table r_dspgrnt(1) = 1. ! Values of green color table r_dspblut(1) = 1. ! Values of blue color table else if (a_dspctbl .eq. 'white') then i_dspnumt=2 do i=0,i_dspnumt-1 r_dspredt(i) = 1.0 ! Values of red color table r_dspgrnt(i) = 1.0 ! Values of green color table r_dspblut(i) = 1.0 ! Values of blue color table end do else if (a_dspctbl .eq. 'black') then i_dspnumt=2 do i=0,i_dspnumt-1 r_dspredt(i) = 0.0 ! Values of red color table r_dspgrnt(i) = 0.0 ! Values of green color table r_dspblut(i) = 0.0 ! Values of blue color table end do else if (a_dspctbl .eq. 'grey') then i_dspnumt=256 do i=0,i_dspnumt-1 r_dspredt(i) = max(0.,min(1.,i/(i_dspnumt-1.))) ! Values of red color table r_dspgrnt(i) = max(0.,min(1.,i/(i_dspnumt-1.))) ! Values of green color table r_dspblut(i) = max(0.,min(1.,i/(i_dspnumt-1.))) ! Values of blue color table end do else if (a_dspctbl .eq. 'red') then i_dspnumt=256 do i=0,i_dspnumt-1 r_dspredt(i) = max(0.,min(1.,i/(i_dspnumt-1.))) ! Values of red color table r_dspgrnt(i) = 0 ! Values of green color table r_dspblut(i) = 0 ! Values of blue color table end do else if (a_dspctbl .eq. 'green') then i_dspnumt=256 do i=0,i_dspnumt-1 r_dspredt(i) = 0 ! Values of red color table r_dspgrnt(i) = max(0.,min(1.,i/(i_dspnumt-1.))) ! Values of green color table r_dspblut(i) = 0 ! Values of blue color table end do else if (a_dspctbl .eq. 'blue') then i_dspnumt=256 do i=0,i_dspnumt-1 r_dspredt(i) = 0 ! Values of red color table r_dspgrnt(i) = 0 ! Values of green color table r_dspblut(i)=max(0.,min(1.,i/(i_dspnumt-1.))) ! Values of blue color table end do else if (a_dspctbl .eq. 'cmy') then do i=0,84 r_dspredt(i) = i*3 ! Values of red color table r_dspgrnt(i) = 255-i*3 ! Values of green color table r_dspblut(i) = 255 ! Values of blue color table end do do i=0,84 r_dspredt(i+85) = 255 ! Values of red color table r_dspgrnt(i+85) = i*3 ! Values of green color table r_dspblut(i+85) = 255-i*3 ! Values of blue color table end do do i=0,84 r_dspredt(i+170) = 255-i*3 ! Values of red color table r_dspgrnt(i+170) = 255 ! Values of green color table r_dspblut(i+170) = i*3 ! Values of blue color table end do r_dspredt(255) = 0 ! Values of red color table r_dspgrnt(255) = 255 ! Values of green color table r_dspblut(255) = 255 ! Values of blue color table i_dspnumt=256 do i=0,255 r_dspredt(i)=max(0.,min(1.,r_dspredt(i)/255.)) r_dspgrnt(i)=max(0.,min(1.,r_dspgrnt(i)/255.)) r_dspblut(i)=max(0.,min(1.,r_dspblut(i)/255.)) end do else if (a_dspctbl .eq. 'myc') then do i=0,84 r_dspredt(i) = 255 ! Values of red color table r_dspgrnt(i) = i*3 ! Values of green color table r_dspblut(i) = 255-i*3 ! Values of blue color table end do do i=0,84 r_dspredt(i+85) = 255-i*3 ! Values of red color table r_dspgrnt(i+85) = 255 ! Values of green color table r_dspblut(i+85) = i*3 ! Values of blue color table end do do i=0,84 r_dspredt(i+170) = i*3 ! Values of red color table r_dspgrnt(i+170) = 255-i*3 ! Values of green color table r_dspblut(i+170) = 255 ! Values of blue color table end do r_dspredt(255) = 255 ! Values of red color table r_dspgrnt(255) = 0 ! Values of green color table r_dspblut(255) = 255 ! Values of blue color table i_dspnumt=256 do i=0,255 r_dspredt(i)=max(0.,min(1.,r_dspredt(i)/255.)) r_dspgrnt(i)=max(0.,min(1.,r_dspgrnt(i)/255.)) r_dspblut(i)=max(0.,min(1.,r_dspblut(i)/255.)) end do else if (a_dspctbl .eq. 'bgw') then i_dspnumt=256 i_cnt = 4 i_nrgb(0,1) = 0 i_nrgb(1,1) = 25 i_nrgb(2,1) = 25 i_nrgb(3,1) = 112 i_nrgb(0,2) = 127 i_nrgb(1,2) = 34 i_nrgb(2,2) = 139 i_nrgb(3,2) = 34 i_nrgb(0,3) = 200 i_nrgb(1,3) = 139 i_nrgb(2,3) = 69 i_nrgb(3,3) = 19 i_nrgb(0,4) = 255 i_nrgb(1,4) = 180 i_nrgb(2,4) = 180 i_nrgb(3,4) = 180 do i=0,i_dspnumt-1 k=0 do j=1,i_cnt if (i_nrgb(0,j-1) .le. i .and. i_nrgb(0,j) .ge. i) then k = j end if end do if (k .eq. 0) then if (i_debug .ge. 1) write(6,*) 'Error in bgw get_colortable' end if r_dspredt(i) = i_nrgb(1,k-1)+((i_nrgb(1,k)-i_nrgb(1,k-1))*(i & -i_nrgb(0,k-1)))/(i_nrgb(0,k)-i_nrgb(0,k-1)) r_dspgrnt(i) = i_nrgb(2,k-1)+((i_nrgb(2,k)-i_nrgb(2,k-1))*(i & -i_nrgb(0,k-1)))/(i_nrgb(0,k)-i_nrgb(0,k-1)) r_dspblut(i) = i_nrgb(3,k-1)+((i_nrgb(3,k)-i_nrgb(3,k-1))*(i & -i_nrgb(0,k-1)))/(i_nrgb(0,k)-i_nrgb(0,k-1)) end do do i=0,i_dspnumt-1 r_dspredt(i)=max(0.,min(1.,r_dspredt(i)/255.)) r_dspgrnt(i)=max(0.,min(1.,r_dspgrnt(i)/255.)) r_dspblut(i)=max(0.,min(1.,r_dspblut(i)/255.)) end do else i_cnt=0 i_dspnumt=1 i_nrgb(0,0)=0 i_nrgb(1,0)=0 i_nrgb(2,0)=0 i_nrgb(3,0)=0 if (i_debug .eq. -3 .or. i_debug .ge. 3) write(6,*) 'Loading external color table: ',a_dspctbl a_file=a_dspctbl open(unit=81,file=a_file,form='formatted',status='old',iostat=ierr) if (ierr .ne. 0 .and. index(a_dspctbl,'/') .eq. 0) then a_file=a_colordir(1:rdflen(a_colordir))//a_dspctbl open(unit=81,file=a_file,form='formatted',status='old',iostat=ierr) end if if (i_debug .eq. -3 .or. i_debug .ge. 3) write(6,*) 'reading color file:',a_file if (ierr .eq. 0) then do while (ierr .eq. 0 .and. i_cnt .lt. 256) read(81,fmt='(a)',err=900,end=900) a_line if (a_line(1:1) .ne. 'c' .and. a_line(1:1) .ne. '#' .and. a_line(1:1) .ne. '!' .and. & a_line(1:1) .ne. '%' .and. a_line(1:1) .ne. '/' .and. a_line(1:1) .ne. 'C' ) then if (index(a_line,'!') .gt. 1) a_line=a_line(1:index(a_line,'!')-1) read(unit=a_line,fmt=*,iostat=ierr) i_nrgb(0,i_cnt),i_nrgb(1,i_cnt) & ,i_nrgb(2,i_cnt),i_nrgb(3,i_cnt) if (ierr .eq. 0) then if (i_debug .eq. -6 .or. i_debug .ge. 6) write(6,*) 'cfile:',i_nrgb(0,i_cnt),i_nrgb(1,i_cnt) & ,i_nrgb(2,i_cnt),i_nrgb(3,i_cnt) i_dspnumt=max(i_dspnumt,i_nrgb(0,i_cnt)+1) i_cnt=i_cnt+1 end if end if end do if (i_cnt .gt. 256) stop 'Error - External color table too big' 900 continue close(81) else do i=0,256 i_nrgb(0,i)=i i_nrgb(1,i)=i i_nrgb(2,i)=i i_nrgb(3,i)=i end do i_cnt=256 i_dspnumt=256 a_dspctbl=a_dspctbl(1:max(1,rdflen(a_dspctbl)))//' - not found. Using grey' end if i_dspnumt=min(i_dspnumt,256) if (i_debug .ge. 4) write(6,*) 'Number of colors in file: ',i_cnt if (i_debug .ge. 4) write(6,*) 'Number of colors in cmap: ',i_dspnumt do i=0,i_dspnumt-1 k=0 do j=1,i_cnt if (i_nrgb(0,j-1) .le. i .and. i_nrgb(0,j) .ge. i) then k = j end if end do if (k .eq. 0) then if (i_debug .ge. 1) write(6,*) 'Error in bgw get_colortable' end if r_dspredt(i) = i_nrgb(1,k-1)+((i_nrgb(1,k)-i_nrgb(1,k-1))*(i & -i_nrgb(0,k-1)))/(i_nrgb(0,k)-i_nrgb(0,k-1)) r_dspgrnt(i) = i_nrgb(2,k-1)+((i_nrgb(2,k)-i_nrgb(2,k-1))*(i & -i_nrgb(0,k-1)))/(i_nrgb(0,k)-i_nrgb(0,k-1)) r_dspblut(i) = i_nrgb(3,k-1)+((i_nrgb(3,k)-i_nrgb(3,k-1))*(i & -i_nrgb(0,k-1)))/(i_nrgb(0,k)-i_nrgb(0,k-1)) end do do i=0,i_dspnumt-1 r_dspredt(i)=max(0.,min(1.,r_dspredt(i)/255.)) r_dspgrnt(i)=max(0.,min(1.,r_dspgrnt(i)/255.)) r_dspblut(i)=max(0.,min(1.,r_dspblut(i)/255.)) if (i_debug .ge. 6) write(6,*) i,r_dspredt(i),r_dspgrnt(i),r_dspblut(i) end do end if return end subroutine copy_setdata(i_in,i_out,i_setunit,i_setrows,i_setcols, & a_setname,a_setfile,a_setinfo,a_setproj, & i_setshdr,i_setstlr,i_setrhdr,i_setrtlr,i_setchdr,i_setctlr, & r_setrmlt,r_setradr,r_setcmlt,r_setcadr,r_setvmlt,r_setvadr, & i_setvend,i_setvfmt,r_setvmin,r_setvmax,a_setvnul,r_setpegv) implicit none integer i_in integer i_out integer I_FMAX ! Maximum number of data files parameter(I_FMAX= 6) integer I_CMAX ! Maximum number of data channels parameter(I_CMAX=10) c structure / set_structure / s_set(*) character*200 a_setname(-I_FMAX:I_CMAX) ! Parameter name character*200 a_setfile(-I_FMAX:I_CMAX) ! Data filename character*200 a_setinfo(-I_FMAX:I_CMAX) ! Header filename character*200 a_setproj(-I_FMAX:I_CMAX) ! Projection name character*16 a_setvnul(-I_FMAX:I_CMAX) ! Hex string of null value integer i_setunit(-I_FMAX:I_CMAX) ! Unit number to read set integer i_setrows(-I_FMAX:I_CMAX) ! Number of rows in set integer i_setcols(-I_FMAX:I_CMAX) ! Number of columns in set integer i_setshdr(-I_FMAX:I_CMAX) ! Number of bytes in set header integer i_setstlr(-I_FMAX:I_CMAX) ! Number of bytes in set trailer integer i_setrhdr(-I_FMAX:I_CMAX) ! Number of bytes in row header integer i_setrtlr(-I_FMAX:I_CMAX) ! Number of bytes in row trailer integer i_setchdr(-I_FMAX:I_CMAX) ! Number of bytes in column header integer i_setctlr(-I_FMAX:I_CMAX) ! Number of bytes in column trailer integer i_setvend(-I_FMAX:I_CMAX) ! Endian flag integer i_setvfmt(-I_FMAX:I_CMAX) ! Method to decode columns real*4 r_setrmlt(-I_FMAX:I_CMAX) ! Row Scale for set real*4 r_setradr(-I_FMAX:I_CMAX) ! Row Offset for set real*4 r_setcmlt(-I_FMAX:I_CMAX) ! Column Scale for set real*4 r_setcadr(-I_FMAX:I_CMAX) ! Column Offset for set real*4 r_setvmlt(-I_FMAX:I_CMAX) ! Value Scale for set real*4 r_setvadr(-I_FMAX:I_CMAX) ! Value Offset for set real*4 r_setvmin(-I_FMAX:I_CMAX) ! Minimum valid value real*4 r_setvmax(-I_FMAX:I_CMAX) ! Maximum valid value real*4 r_setpegv(3,-I_FMAX:I_CMAX) ! Maximum valid value c end structure if (i_out .lt. -I_FMAX .or. i_out .gt. I_CMAX) write(6,*) 'i_out error in copy setdata ',i_out if (i_in .lt. -I_FMAX .or. i_in .gt. I_CMAX) write(6,*) 'i_in error in copy setdata ',i_in a_setname(i_out) = a_setname(i_in) a_setfile(i_out) = a_setfile(i_in) a_setinfo(i_out) = a_setinfo(i_in) a_setproj(i_out) = a_setproj(i_in) i_setunit(i_out) = i_setunit(i_in) i_setrows(i_out) = i_setrows(i_in) i_setcols(i_out) = i_setcols(i_in) i_setshdr(i_out) = i_setshdr(i_in) i_setstlr(i_out) = i_setstlr(i_in) i_setrhdr(i_out) = i_setrhdr(i_in) i_setrtlr(i_out) = i_setrtlr(i_in) i_setchdr(i_out) = i_setchdr(i_in) i_setctlr(i_out) = i_setctlr(i_in) i_setvend(i_out) = i_setvend(i_in) i_setvfmt(i_out) = i_setvfmt(i_in) r_setvmlt(i_out) = r_setvmlt(i_in) r_setvadr(i_out) = r_setvadr(i_in) r_setvmin(i_out) = r_setvmin(i_in) r_setvmax(i_out) = r_setvmax(i_in) a_setvnul(i_out) = a_setvnul(i_in) r_setrmlt(i_out) = r_setrmlt(i_in) r_setradr(i_out) = r_setradr(i_in) r_setcmlt(i_out) = r_setcmlt(i_in) r_setcadr(i_out) = r_setcadr(i_in) r_setvmlt(i_out) = r_setvmlt(i_in) r_setvadr(i_out) = r_setvadr(i_in) r_setvadr(i_out) = r_setvadr(i_in) r_setpegv(1,i_out) = r_setpegv(1,i_in) r_setpegv(2,i_out) = r_setpegv(2,i_in) r_setpegv(3,i_out) = r_setpegv(3,i_in) return end subroutine copy_dspdata(i_in,i_out, & r_dspaddr,r_dspmult,r_dspwrap,r_dspexpn,r_dspcplw,r_dspcphi, & r_dspval1,r_dspval2,r_dspval3,i_dspmode,i_dspaddr,i_dspmult,i_dspmixv, & a_dspctbl,i_dspdvdc) c structure / dspinfo / s_dsp implicit none integer i_in integer i_out integer I_FMAX ! Maximum number of data files parameter(I_FMAX= 6) integer I_CMAX ! Maximum number of data channels parameter(I_CMAX=10) character*200 a_dspctbl(-I_FMAX:I_CMAX) ! Color table file integer i_dspcnt integer i_dspchnl ! Number of sets to display integer i_dspaddr(-I_FMAX:I_CMAX) ! Add auto Scale flag integer i_dspmult(-I_FMAX:I_CMAX) ! Mult auto Scale flag integer i_dspmixv(-I_FMAX:I_CMAX) ! Method to mix set (add, multiply, max, avg) integer i_dspmode(-I_FMAX:I_CMAX) integer i_dspdvdc(-I_FMAX:I_CMAX) real*4 r_dspcplw(-I_FMAX:I_CMAX) ! Discard if below value real*4 r_dspcphi(-I_FMAX:I_CMAX) ! Discard if above value real*4 r_dspaddr(-I_FMAX:I_CMAX) ! Shift data by value real*4 r_dspwrap(-I_FMAX:I_CMAX) ! Wrap data by value real*4 r_dspexpn(-I_FMAX:I_CMAX) ! Compress data real*4 r_dspmult(-I_FMAX:I_CMAX) ! Multiply data by value real*4 r_dspval1(-I_FMAX:I_CMAX) real*4 r_dspval2(-I_FMAX:I_CMAX) real*4 r_dspval3(-I_FMAX:I_CMAX) c end structure if (i_out .lt. -I_FMAX .or. i_out .gt. I_CMAX) write(6,*) 'i_out error in copy dspdata ',i_out if (i_in .lt. -I_FMAX .or. i_in .gt. I_CMAX) write(6,*) 'i_in error in copy dspdata ',i_in r_dspaddr(i_out) = r_dspaddr(i_in) r_dspwrap(i_out) = r_dspwrap(i_in) r_dspexpn(i_out) = r_dspexpn(i_in) r_dspmult(i_out) = r_dspmult(i_in) r_dspcplw(i_out) = r_dspcplw(i_in) r_dspcphi(i_out) = r_dspcphi(i_in) r_dspmult(i_out) = r_dspmult(i_in) r_dspval1(i_out) = r_dspval1(i_in) r_dspval2(i_out) = r_dspval2(i_in) r_dspval3(i_out) = r_dspval3(i_in) i_dspmode(i_out) = i_dspmode(i_in) i_dspdvdc(i_out) = i_dspdvdc(i_in) i_dspaddr(i_out) = i_dspaddr(i_in) i_dspmult(i_out) = i_dspmult(i_in) i_dspmixv(i_out) = i_dspmixv(i_in) a_dspctbl(i_out) = a_dspctbl(i_in) return end subroutine init_dsp(a_lcolor,i_debug) implicit none integer i_debug integer i_clrs integer i_dxi integer i_wxi ! Number of windows integer i_wxs(0:20) ! Size of window canvas in x direction integer i_wys(0:20) ! Size of window canvas in y direction integer*4 i_type(0:20) integer*4 i_frx(0:20) integer*4 i_fry(0:20) character*80 a_labl(0:20) character*20 a_menu(0:5,0:9) character*80 a_lcolor integer init_gx external init_gx c c Initialize graphics c i_wxi = 0 i_clrs=0 i_dxi=init_gx(i_wxi,i_type,a_labl,i_wxs,i_wys,i_frx,i_fry,a_menu, & a_lcolor,i_clrs,i_debug) c write(6,*) '0 is good from init_dsp = ',i_dxi return end subroutine create_dsp(a_dspname,i_winrows,i_wincols,i_winy,i_winx,a_setname & ,i_set,i_dxi,i_menu,a_tname,i_close,a_lcolor,i_debug) implicit none integer I_CMAX parameter (I_CMAX=10) integer i integer j integer i_set character*(*) a_dspname character*(*) a_setname(i_set) integer i_winrows integer i_wincols integer i_winx integer i_winy integer i_debug integer i_menu integer i_close character*20 a_tname(5) integer i_clrs integer i_dxi integer i_wxi ! Number of windows integer i_wxs(0:20) ! Size of window canvas in x direction integer i_wys(0:20) ! Size of window canvas in y direction integer*4 i_type(0:20) integer*4 i_frx(0:20) integer*4 i_fry(0:20) character*80 a_labl(0:20) character*20 a_menu(0:5,0:9) character*80 a_lcolor integer init_gx external init_gx c c Initialize graphics c if (i_menu .eq. 1) then a_menu(0,0)= 'Application' a_menu(1,0)= 'Spawn ^A' a_menu(2,0)= 'Quit ^Q' a_menu(3,0)= ' ' a_menu(4,0)= ' ' a_menu(5,0)= ' ' a_menu(0,1)= 'Display' a_menu(1,1)= 'Open ^D' a_menu(2,1)= 'Close ^K' a_menu(3,1)= 'Resize ^R' a_menu(4,1)= ' ' a_menu(5,1)= ' ' a_menu(0,2)= 'Set' a_menu(1,2)= 'Add ^I' a_menu(2,2)= 'Delete ^K' a_menu(3,2)= 'Modify ^M' a_menu(4,2)= ' ' a_menu(5,2)= ' ' a_menu(0,3)= 'Zoom' a_menu(1,3)= 'None ^N' a_menu(2,3)= '+2x ^+' a_menu(3,3)= '-2x ^-' a_menu(4,3)= 'Other ^Z' a_menu(5,3)= ' ' a_menu(0,4)= 'Select' a_menu(1,4)= 'Mode' a_menu(2,4)= 'Import' a_menu(3,4)= 'Export' a_menu(4,4)= 'Clear' a_menu(5,4)= ' ' a_menu(0,5)= 'Print' a_menu(1,5)= 'To Printer ^PP' a_menu(2,5)= 'To File ^PF' a_menu(3,5)= 'Setup ^PS' a_menu(4,5)= ' ' a_menu(5,5)= ' ' if (a_tname(1) .ne. ' ' .or. a_tname(2) .ne. ' ' .or. & a_tname(3) .ne. ' ' .or. a_tname(4) .ne. ' ' .or. a_tname(5) .ne. ' ') then a_menu(0,6)='Tools' else a_menu(0,6)= ' ' end if a_menu(1,6)= a_tname(1) a_menu(2,6)= a_tname(2) a_menu(3,6)= a_tname(3) a_menu(4,6)= a_tname(4) a_menu(5,6)= a_tname(5) a_menu(0,7)= ' ' a_menu(1,7)= ' ' a_menu(2,7)= ' ' a_menu(3,7)= ' ' a_menu(4,7)= ' ' a_menu(5,7)= ' ' a_menu(0,8)= ' ' a_menu(1,8)= ' ' a_menu(2,8)= ' ' a_menu(3,8)= ' ' a_menu(4,8)= ' ' a_menu(5,8)= ' ' a_menu(0,9)= 'Help' a_menu(1,9)= 'Reference ^HC' a_menu(2,9)= 'Users Guide ^HT' a_menu(3,9)= ' ' a_menu(4,9)= ' ' a_menu(5,9)= ' ' else do i=0,5 do j=0,9 a_menu(i,j)=' ' end do end do end if i_wxi = max(4,min(i_set+1+2*i_close,I_CMAX+2)) if (i_debug .eq. -3 .or. i_debug .ge. 3) write(6,*) 'i_wxi = ',i_wxi i_type(1) = 4 do i=2,i_wxi i_type(i) = 6 end do a_labl(0) = a_dspname a_labl(1) = 'Image Window' do i=2,i_wxi a_labl(i) = ' ' end do if (i_close .ne. 0) a_labl(i_wxi) = 'Close' write(6,*) 'i_set=',i_set,I_CMAX do i=1,min(i_set,I_CMAX) if (a_setname(i) .ne. ' ') then a_labl(i+1)=a_setname(i) else write(a_labl(i+1),'(a,i2)') 'Set',i end if end do write(6,*) 'a_labl(i_wxi)=',a_labl(i_wxi) if (i_winx .ne. 0) then i_wxs(0) = i_winx else i_wxs(0) = min(i_wincols+28,800) end if if (i_winy .ne. 0) then i_wys(0) = i_winy else i_wys(0) = min(i_winrows+120,600) end if i_wxs(1) = i_wincols i_wys(1) = i_winrows do i=2,i_wxi i_wxs(i) = 50 i_wys(i) = 50 end do i_frx(0) = i_wxi-1 i_frx(1) = i_wxi-1 do i=2,i_wxi i_frx(i) = 1 end do i_fry(0) = 0 i_fry(1) = 400 do i=2,i_wxi i_fry(i) = -25 end do i_clrs=0 i_dxi=init_gx(i_wxi,i_type,a_labl,i_wxs,i_wys,i_frx,i_fry,a_menu, & a_lcolor,i_clrs,i_debug) if (i_debug .ge. 4) write(6,*) 'i_dxi = ',i_dxi return end **************************************************************** subroutine read_hdr(a_hdrfile,i_lsize,i_ssize,r_peg,a_type, & r_str,r_spc,i_mbytes,i_dbytes,r_mmul,r_madd, & r_dmul,r_dadd,i_err) c**************************************************************** c** c** FILE NAME: read_hdr.f c** c** DATE WRITTEN: 2/15/96 c** c** PROGRAMMER:Scott Shaffer c** c** FUNCTIONAL DESCRIPTION: Reads some of an IFPROC header file. c** c** ROUTINES CALLED:none c** c** NOTES: c** c** c***************************************************************** implicit none c INPUT VARIABLES: character*(*) a_hdrfile !header file c OUTPUT VARIABLES: character*(*) a_type integer*4 i_err integer*4 i_lsize integer*4 i_ssize integer*4 i_mbytes integer*4 i_dbytes real*8 r_peg(3) real*8 r_str(2) real*8 r_spc(2) real r_mmul real r_madd real r_dmul real r_dadd c LOCAL VARIABLES: integer*4 i integer*4 j integer*4 i_cnt integer*4 i_zone real*8 r_atm(3,4) real*8 r_pi real*8 r_rtod real*8 r_mdnc(2) real*8 r_ddnc(2) character*255 a_tmp c FUNCTION STATEMENTS: integer rdflen external rdflen c DATA STATEMENTS: none c PROCESSING STEPS: c c Initialize pi and conversions c r_pi = 4.d0*atan(1.0d0) r_rtod = 180.0d0/r_pi i_err = 1 i_cnt = 0 write(6,*) ' ' write(6,*) 'Opening hdr input file: ',a_hdrfile(1:52) open(12,file=a_hdrfile,status='old',form='formatted',err=900) write(6,*) 'Reading' do i=1,100000 read(12,'(a)',end=900) a_tmp if (a_tmp .eq. ' ') then ! do nothing else if (index(a_tmp,'Data file dimensions') .gt. 0) then read(a_tmp,*) i_lsize,i_ssize i_cnt = i_cnt + 1 else if (index(a_tmp,'Post Spacing') .gt. 0) then read(a_tmp,*) r_spc i_cnt = i_cnt + 2 else if (index(a_tmp,'Peg position (WGS-84)') .gt. 0) then read(a_tmp,*) r_peg r_peg(1) = r_peg(1)/r_rtod r_peg(2) = r_peg(2)/r_rtod r_peg(3) = r_peg(3)/r_rtod i_cnt = i_cnt + 4 else if (index(a_tmp,'UTM Zone') .gt. 0) then read(a_tmp,*) i_zone r_peg(2)=(i_zone-0.5)*(6.d0/r_rtod)-r_pi else if (index(a_tmp,'Starting corner position (s,c)') .gt. 0) then read(a_tmp,*) r_str i_cnt = i_cnt + 8 else if (index(a_tmp,'M11 M12 M13') .gt. 0) then read(a_tmp,*) r_atm(1,1),r_atm(1,2),r_atm(1,3) c i_cnt = i_cnt + 16 else if (index(a_tmp,'M21 M22 M23') .gt. 0) then read(a_tmp,*) r_atm(2,1),r_atm(2,2),r_atm(2,3) c i_cnt = i_cnt + 32 else if (index(a_tmp,'M31 M32 M33') .gt. 0) then read(a_tmp,*) r_atm(3,1),r_atm(3,2),r_atm(3,3) c i_cnt = i_cnt + 64 else if (index(a_tmp,'O1 O2 O3') .gt. 0) then read(a_tmp,*) r_atm(1,4),r_atm(2,4),r_atm(3,4) c i_cnt = i_cnt + 128 else if (index(a_tmp,'Magnitude Scale and Shift') .gt. 0) then read(a_tmp,*) r_mdnc r_mmul=r_mdnc(1) r_madd=r_mdnc(2) else if (index(a_tmp,'Elevation Scale and Shift') .gt. 0) then read(a_tmp,*) r_ddnc r_dmul=r_ddnc(1) r_dadd=r_ddnc(2) write(6,*) 'r_dm,r_da=',r_dmul,r_dadd else if (index(a_tmp,'Magnitude Bytes per Pixel') .gt. 0) then read(a_tmp,*) i_mbytes else if (index(a_tmp,'Elevation Bytes per Pixel') .gt. 0) then read(a_tmp,*) i_dbytes write(6,*) 'i_dbytes=',i_dbytes else if (index(a_tmp,'Data file type') .gt. 0) then a_type = a_tmp(1:max(1,index(a_tmp,';')-1)) do j=1,rdflen(a_type) if (ichar(a_type(1:1)) .eq. 32 .or. ichar(a_type(1:1)) .eq. 9) a_type = a_type(2:) end do end if end do close(12) stop 'Error reading header file, too many lines' 900 close(12,err=910) 910 if (i_cnt .eq. 15) i_err = 0 return end subroutine get_airsarinfo( a_setname, & a_setfile, & a_setproj, & i_setunit, & i_setrows, & i_setcols, & i_setshdr, & i_setstlr, & i_setrhdr, & i_setrtlr, & i_setchdr, & i_setctlr, & i_setvend, & i_setvfmt, & r_setvmlt, & r_setvadr, & r_setvmin, & r_setvmax, & a_setvnul, & r_setrmlt, & r_setradr, & r_setcmlt, & r_setcadr, & r_setpegv, & a_dspctbl ) c structure / set_structure / s_set(-I_FMAX:I_CMAX) character*200 a_setname ! Parameter name character*200 a_setfile ! Data filename character*200 a_setinfo ! Header filename character*200 a_setproj ! Projection name integer i_setunit ! Unit number to read set integer i_setrows ! Number of rows in set integer i_setcols ! Number of columns in set integer i_setshdr ! Number of bytes in set header integer i_setstlr ! Number of bytes in set trailer integer i_setrhdr ! Number of bytes in row header integer i_setrtlr ! Number of bytes in row trailer integer i_setchdr ! Number of bytes in column header integer i_setctlr ! Number of bytes in column trailer integer i_setvend ! Endian flag integer i_setvfmt ! Method to decode columns real*4 r_setrmlt ! Row Scale for set real*4 r_setradr ! Row Offset for set real*4 r_setcmlt ! Column Scale for set real*4 r_setcadr ! Column Offset for set real*4 r_setvmlt ! Value Scale for set real*4 r_setvadr ! Value Offset for set real*4 r_setvmin ! Minimum valid value real*4 r_setvmax ! Maximum valid value character*16 a_setvnul ! Invalid value real*4 r_setvavg ! Average value in set real*4 r_setvstd ! Standard deviation of values in set real*4 r_setpegv(3) ! Peg Point c end structure character*200 a_dspctbl integer i integer i_err integer i_unit integer i_bytes character*50 a_string(100) byte b_string(5000) real*8 r_pi real*8 r_rtod real*4 r_temp integer nread integer initdk external initdk integer closedk external closedk #ifdef IO64 integer*8 nseek integer*8 ioseek64 external ioseek64 integer*8 i_demoff integer*8 i_magoff integer*8 i_paroff #else integer*4 nseek integer*4 ioseek external ioseek integer*4 i_demoff integer*4 i_magoff integer*4 i_paroff #endif integer ioread external ioread equivalence(a_string,b_string) c c Initialize pi and conversions c r_pi = 4.d0*atan(1.0d0) r_rtod = 180.0d0/r_pi c write(6,*) 'AIRSAR: ',a_setfile(1:60) i_unit = initdk(19,a_setfile) c write(6,*) 'i_unit=',i_unit i_demoff = 0 #ifdef IO64 nseek = ioseek64(i_unit,i_demoff,0) c write(6,*) 'nseek64=',nseek #else nseek = ioseek(i_unit,i_demoff,0) c write(6,*) 'nseek=',nseek #endif c write(6,*) 'i_unit again = ',i_unit nread = ioread(i_unit,b_string(1),5000) i_demoff = -1 i_magoff = -1 i_paroff = -1 c write(6,*) 'nread=',nread nread=5000 do i=1,(nread-1)/50+1 if (a_string(i) .eq. ' ') then ! do nothing else if (index(a_string(i),'NUMBER OF SAMPLES PER RECORD =') .gt. 0) then read(a_string(i)(35:),*) i_setcols write(6,*) ' ' write(6,*) 'Reading AIRSAR header ' a_setname = 'AIRSAR-MAG' else if (index(a_string(i),'NUMBER OF LINES IN IMAGE =') .gt. 0) then read(a_string(i)(35:),*) i_setrows else if (index(a_string(i),'NUMBER OF BYTES PER SAMPLE =') .gt. 0) then read(a_string(i)(35:),*) i_bytes if (i_bytes .eq. 0) then ! do nothing else if (i_bytes .eq. 1) then i_setvfmt = 0 ! 'val_frmt = BYTE' else if (i_bytes .eq. 2) then i_setvfmt = 2 ! 'val_frmt = INTEGER*2' else if (i_bytes .eq. 4) then i_setvfmt = 4 ! 'val_frmt = REAL*4' else if (i_bytes .eq. 8) then i_setvfmt = 6 ! 'val_frmt = Complex magnitude else if (i_bytes .eq. 10) then i_setvfmt = 9 ! 'val_frmt = Compressed stokes11 a_setname = 'AIRSAR-M11' end if else if (index(a_string(i),'BYTE OFFSET OF FIRST DATA RECORD =') .gt. 0) then read(a_string(i)(35:),*) i_setshdr else if (index(a_string(i),'BYTE OFFSET OF DEM HEADER =') .gt. 0) then read(a_string(i)(35:),*) i_demoff if (i_demoff .gt. 0) a_setname = 'AIRSAR-DEM' else if (index(a_string(i),'BYTE OFFSET OF CALIBRATION HEADER =') .gt. 0) then read(a_string(i)(37:),*) i_magoff if (i_magoff .gt. 0) a_setname = 'AIRSAR-MAG' else if (index(a_string(i),'BYTE OFFSET OF PARAMETER HEADER =') .gt. 0) then read(a_string(i)(37:),*) i_paroff endif enddo if (i_demoff .ge. 0) then #ifdef IO64 nseek = ioseek64(i_unit,i_demoff,0) #else nseek = ioseek(i_unit,i_demoff,0) #endif nread = ioread(i_unit,b_string,4550) do i=1,(nread-1)/50+1 if (a_string(i)(35:) .eq. ' ') then ! do nothing else if (index(a_string(i),'X-DIRECTION POST SPACING (M) =') .gt. 0) then read(a_string(i)(35:),*) r_setrmlt else if (index(a_string(i),'Y-DIRECTION POST SPACING (M) =') .gt. 0) then read(a_string(i)(35:),*) r_setcmlt else if (index(a_string(i),'ELEVATION INCREMENT (M) =') .gt. 0) then read(a_string(i)(35:),*,iostat=i_err) r_temp if (r_temp .ne. 0.0) r_setvmlt = r_temp else if (index(a_string(i),'ELEVATION OFFSET (M) =') .gt. 0) then read(a_string(i)(35:),*,iostat=i_err) r_setvadr else if (index(a_string(i),'LATITUDE OF PEG POINT =') .gt. 0) then read(a_string(i)(35:),*) r_setpegv(1) r_setpegv(1) = r_setpegv(1) / r_rtod a_setproj = 'sch' else if (index(a_string(i),'LONGITUDE OF PEG POINT =') .gt. 0) then read(a_string(i)(35:),*) r_setpegv(2) r_setpegv(2) = r_setpegv(2) / r_rtod else if (index(a_string(i),'HEADING AT PEG POINT (DEGREES) =') .gt. 0) then read(a_string(i)(35:),*) r_setpegv(3) r_setpegv(3) = r_setpegv(3) / r_rtod else if (index(a_string(i),'ALONG-TRACK OFFSET S0 (M) =') .gt. 0) then read(a_string(i)(35:),*) r_setradr else if (index(a_string(i),'CROSS-TRACK OFFSET C0 (M) =') .gt. 0) then read(a_string(i)(35:),*) r_setcadr endif enddo end if i_err = closedk(i_unit) return end subroutine get_pdsinfo( a_setname, & a_setfile, & a_setproj, & i_setunit, & i_setrows, & i_setcols, & i_setshdr, & i_setstlr, & i_setrhdr, & i_setrtlr, & i_setchdr, & i_setctlr, & i_setvend, & i_setvfmt, & r_setvmlt, & r_setvadr, & r_setvmin, & r_setvmax, & a_setvnul, & r_setrmlt, & r_setradr, & r_setcmlt, & r_setcadr, & r_setpegv, & a_dspctbl,i_debug ) c structure / set_structure / s_set(-I_FMAX:I_CMAX) character*200 a_setname ! Parameter name character*200 a_setfile ! Data filename character*200 a_setinfo ! Header filename character*200 a_setproj ! Projection name integer i_setunit ! Unit number to read set integer i_setrows ! Number of rows in set integer i_setcols ! Number of columns in set integer i_setshdr ! Number of bytes in set header integer i_setstlr ! Number of bytes in set trailer integer i_setrhdr ! Number of bytes in row header integer i_setrtlr ! Number of bytes in row trailer integer i_setchdr ! Number of bytes in column header integer i_setctlr ! Number of bytes in column trailer integer i_setvend ! Endian flag integer i_setvfmt ! Method to decode columns real*4 r_setrmlt ! Row Scale for set real*4 r_setradr ! Row Offset for set real*4 r_setcmlt ! Column Scale for set real*4 r_setcadr ! Column Offset for set real*4 r_setvmlt ! Value Scale for set real*4 r_setvadr ! Value Offset for set real*4 r_setvmin ! Minimum valid value real*4 r_setvmax ! Maximum valid value character*16 a_setvnul ! Invalid value real*4 r_setvavg ! Average value in set real*4 r_setvstd ! Standard deviation of values in set real*4 r_setpegv(3) ! Peg Point c end structure character*200 a_dspctbl integer i integer i_err integer i_unit integer i_bytes integer i_debug integer i_recbytes integer i_label character*10000 a_string character*255 a_line character*255 a_key character*255 a_val character*255 a_object byte b_string(10000) real*8 r_pi real*8 r_rtod real*4 r_temp integer nread integer initdk external initdk integer closedk external closedk #ifdef IO64 integer*8 nseek integer*8 ioseek64 external ioseek64 integer*8 i_demoff integer*8 i_magoff integer*8 i_paroff #else integer*4 nseek integer*4 ioseek external ioseek integer*4 i_demoff integer*4 i_magoff integer*4 i_paroff #endif integer ioread external ioread integer rdflen external rdflen equivalence(a_string,b_string) c c Initialize pi and conversions c r_pi = 4.d0*atan(1.0d0) r_rtod = 180.0d0/r_pi c write(6,*) 'AIRSAR: ',a_setfile(1:60) i_unit = initdk(19,a_setfile) c write(6,*) 'i_unit=',i_unit i_demoff = 0 #ifdef IO64 nseek = ioseek64(i_unit,i_demoff,0) c write(6,*) 'nseek64=',nseek #else nseek = ioseek(i_unit,i_demoff,0) c write(6,*) 'nseek=',nseek #endif c write(6,*) 'i_unit again = ',i_unit nread = ioread(i_unit,b_string(1),10000) if (a_string(1:14) .eq. 'PDS_VERSION_ID') then i_demoff = -1 i_magoff = -1 i_paroff = -1 i_bytes = 0 write(6,*) ' ' write(6,*) 'Reading PDS Label ',index(a_string,char(10)),i_debug do while(index(a_string,char(10)) .gt. 0) a_line=a_string(1:index(a_string,char(10))) a_key = a_line(1:max(1,index(a_line,'=')-1)) a_val = a_line(max(1,index(a_line,'=')+1):) if (index(a_val,char(13)) .gt. 1) a_val = a_val(1:index(a_val,char(13))-1) if (index(a_val,char(10)) .gt. 1) a_val = a_val(1:index(a_val,char(10))-1) c write(6,*) 'length = ',rdflen(a_val) c do i=1,rdflen(a_val) c write(6,*) i,' ',ichar(a_val(i:i)),' ',a_val(i:i) c end do if (i_debug .eq. -13 .or. i_debug .ge. 13) write(6,*) 'a_line=',a_line(1:70) a_string=a_string(index(a_string,char(10))+1:) if (a_line .eq. ' ') then ! do nothing else if (a_key .eq. 'RECORD_BYTES') then read(a_val,*) i_recbytes else if (a_key .eq. 'LABEL_RECORDS') then read(a_val,*) i_label else if (a_key .eq. 'OBJECT') then c write(6,*) 'a_val=',a_val(1:70) if (a_val .eq. ' LBDR_TABLE') then a_object = 'LBIDR_TABLE' i_setcols = 32768 i_setrhdr = 1272 i_setvfmt = 4 else if (a_val .eq. ' IMAGE') then a_object = 'IMAGE' else if (a_val .eq. ' IMAGE_MAP_PROJECTION') then a_object = 'IMAGE_MAP_PROJECTION' end if c write(6,*) ' Object = ',a_object(1:30),i_setcols else if (a_key .eq. 'END_OBJECT') then a_object = ' ' else if (a_object .eq. 'LBIDR_TABLE') then if (a_key .eq. ' ROWS') then read(a_val,*) i_setrows end if else if (a_object .eq. 'IMAGE') then if (a_key .eq. ' LINE_SAMPLES') then read(a_val,*) i_setcols else if (a_key .eq. ' LINES') then read(a_val,*) i_setrows else if (a_key .eq. ' SAMPLE_TYPE') then c do i=1,25 c write(6,*) 'i/val=',i,ichar(a_line(32+i:32+i)),' ',a_line(32+i:32+i) c end do if (a_val .eq. ' ') then ! do nothing else if (a_val(1:19) .eq. ' "UNSIGNED INTEGER"') then if (i_bytes .eq. 0) then i_setvfmt = 0 ! 'val_frmt = BYTE' else if (i_bytes .eq. 1) then i_setvfmt = 0 ! 'val_frmt = BYTE' else if (i_bytes .eq. 2) then i_setvfmt = 8 ! 'val_frmt = BYTE*2' else i_setvfmt = 0 ! 'val_frmt = BYTE' end if else if (a_val(1:10) .eq. ' "INTEGER"') then c write(6,*) 'INTEGER data detected ',i_bytes if (i_bytes .eq. 0) then i_setvfmt = 3 ! 'val_frmt = INTEGER*4' else if (i_bytes .eq. 1) then i_setvfmt = 1 ! 'val_frmt = INTEGER*1' else if (i_bytes .eq. 2) then i_setvfmt = 2 ! 'val_frmt = INTEGER*2' else if (i_bytes .eq. 4) then i_setvfmt = 3 ! 'val_frmt = INTEGER*4' else i_setvfmt = 3 ! 'val_frmt = INTEGER*4' end if c write(6,*) 'i_setvfmt = ',i_setvfmt else if (a_val(1:10) .eq. ' "PC_REAL"') then if (i_bytes .eq. 0) then i_setvfmt = 4 ! 'val_frmt = REAL*4' else if (i_bytes .eq. 4) then i_setvfmt = 4 ! 'val_frmt = REAL*4' else if (i_bytes .eq. 8) then i_setvfmt = 5 ! 'val_frmt = REAL*8' else i_setvfmt = 4 ! 'val_frmt = REAL*4' end if else if (a_val(1:10) .eq. ' "COMPLEX"') then i_setvfmt = 6 ! 'val_frmt = Complex magnitude end if else if (a_key .eq. ' SAMPLE_BITS') then read(a_val,*) i_bytes i_bytes = i_bytes/8 if (i_bytes .eq. 0) then ! do nothing else if (i_bytes .eq. 1) then if (i_setvfmt .eq. 2 .or. i_setvfmt .eq. 3) then i_setvfmt = 1 ! 'val_frmt = INTEGER*1' else if (i_setvfmt .eq. 4 .or. i_setvfmt .eq. 5) then ! do nothing end if else if (i_bytes .eq. 2) then if (i_setvfmt .eq. 0) then i_setvfmt = 8 ! 'val_frmt = BYTE*2' else if (i_setvfmt .eq. 1 .or. i_setvfmt .eq. 3) then i_setvfmt = 2 ! 'val_frmt = INTEGER*2' else if (i_setvfmt .eq. 4 .or. i_setvfmt .eq. 5) then ! do nothing end if else if (i_bytes .eq. 4) then if (i_setvfmt .eq. 0 .or. i_setvfmt .eq. 8) then ! do nothing else if (i_setvfmt .eq. 1 .or. i_setvfmt .eq. 2) then i_setvfmt = 3 ! 'val_frmt = INTEGER*4' else if (i_setvfmt .eq. 5) then i_setvfmt = 4 ! 'val_frmt = REAL*4' end if else if (i_bytes .eq. 8) then if (i_setvfmt .eq. 0 .or. i_setvfmt .eq. 8) then ! do nothing else if (i_setvfmt .eq. 1 .or. i_setvfmt .eq. 2 .or. i_setvfmt .eq. 3) then ! do nothing else if (i_setvfmt .eq. 4) then i_setvfmt = 5 ! 'val_frmt = REAL*4' end if end if end if else if (a_object .eq. 'IMAGE_MAP_PROJECTION') then if (a_key .eq. ' MAP_SCALE') then read(a_val,*) r_setrmlt read(a_val,*) r_setcmlt else if (a_key .eq. ' OBLIQUE_PROJ_POLE_LATITUDE') then read(a_val,*) r_setpegv(1) r_setpegv(1) = r_setpegv(1) / r_rtod a_setproj = 'sch' else if (a_key .eq. ' OBLIQUE_PROJ_POLE_LONGITUDE') then read(a_val,*) r_setpegv(2) r_setpegv(2) = r_setpegv(2) / r_rtod else if (a_key .eq. ' OBLIQUE_PROJ_POLE_ROTATION') then read(a_val,*) r_setpegv(3) r_setpegv(3) = r_setpegv(3) / r_rtod else if (a_key .eq. ' LINE_PROJECTION_OFFSET') then read(a_val,*) r_setradr else if (a_key .eq. ' SAMPLE_PROJECTION_OFFSET') then read(a_val,*) r_setcadr endif end if enddo i_setshdr = i_recbytes*i_label end if i_err = closedk(i_unit) return end subroutine get_cubinfo( a_setname, & a_setfile, & a_setproj, & i_setunit, & i_setrows, & i_setcols, & i_setshdr, & i_setstlr, & i_setrhdr, & i_setrtlr, & i_setchdr, & i_setctlr, & i_setvend, & i_setvfmt, & r_setvmlt, & r_setvadr, & r_setvmin, & r_setvmax, & a_setvnul, & r_setrmlt, & r_setradr, & r_setcmlt, & r_setcadr, & r_setpegv, & a_dspctbl,i_debug ) c structure / set_structure / s_set(-I_FMAX:I_CMAX) character*200 a_setname ! Parameter name character*200 a_setfile ! Data filename character*200 a_setinfo ! Header filename character*200 a_setproj ! Projection name integer i_setunit ! Unit number to read set integer i_setrows ! Number of rows in set integer i_setcols ! Number of columns in set integer i_setshdr ! Number of bytes in set header integer i_setstlr ! Number of bytes in set trailer integer i_setrhdr ! Number of bytes in row header integer i_setrtlr ! Number of bytes in row trailer integer i_setchdr ! Number of bytes in column header integer i_setctlr ! Number of bytes in column trailer integer i_setvend ! Endian flag integer i_setvfmt ! Method to decode columns real*4 r_setrmlt ! Row Scale for set real*4 r_setradr ! Row Offset for set real*4 r_setcmlt ! Column Scale for set real*4 r_setcadr ! Column Offset for set real*4 r_setvmlt ! Value Scale for set real*4 r_setvadr ! Value Offset for set real*4 r_setvmin ! Minimum valid value real*4 r_setvmax ! Maximum valid value character*16 a_setvnul ! Invalid value real*4 r_setvavg ! Average value in set real*4 r_setvstd ! Standard deviation of values in set real*4 r_setpegv(3) ! Peg Point c end structure character*200 a_dspctbl integer i integer i_err integer i_unit integer i_bytes integer i_debug integer i_recbytes integer i_label character*10000 a_string character*255 a_line character*255 a_key character*255 a_val character*255 a_object character*255 a_group integer i_values character*20 a_values(20) integer i_band byte b_string(10000) real*8 r_pi real*8 r_rtod real*4 r_temp integer nread integer initdk external initdk integer closedk external closedk #ifdef IO64 integer*8 nseek integer*8 ioseek64 external ioseek64 integer*8 i_demoff integer*8 i_magoff integer*8 i_paroff #else integer*4 nseek integer*4 ioseek external ioseek integer*4 i_demoff integer*4 i_magoff integer*4 i_paroff #endif integer ioread external ioread integer rdflen external rdflen equivalence(a_string,b_string) c c Initialize pi and conversions c r_pi = 4.d0*atan(1.0d0) r_rtod = 180.0d0/r_pi c write(6,*) 'AIRSAR: ',a_setfile(1:60) i_unit = initdk(19,a_setfile) c write(6,*) 'i_unit=',i_unit i_demoff = 0 #ifdef IO64 nseek = ioseek64(i_unit,i_demoff,0) c write(6,*) 'nseek64=',nseek #else nseek = ioseek(i_unit,i_demoff,0) c write(6,*) 'nseek=',nseek #endif c write(6,*) 'i_unit again = ',i_unit nread = ioread(i_unit,b_string(1),10000) if (a_string(1:12) .eq. 'CCSD3ZF00001') then if (a_setname .eq. ' ') a_setname = 'QUBE QUBE' i_demoff = -1 i_magoff = -1 i_paroff = -1 i_bytes = 0 write(6,*) ' ' write(6,*) 'Reading CUB Label ',index(a_string,char(10)),i_debug do while(index(a_string,char(10)) .gt. 0) a_line=a_string(1:index(a_string,char(10))) a_key = a_line(1:max(1,index(a_line,'=')-1)) a_val = a_line(max(1,index(a_line,'=')+1):) if (index(a_val,char(13)) .gt. 1) a_val = a_val(1:index(a_val,char(13))-1) if (index(a_val,char(10)) .gt. 1) a_val = a_val(1:index(a_val,char(10))-1) if (i_debug .eq. -1001 .or. i_debug .ge. 1001) then write(6,*) 'length = ',rdflen(a_val) do i=1,rdflen(a_val) write(6,*) i,' ',ichar(a_val(i:i)),' ',a_val(i:i) end do end if if (i_debug .eq. -13 .or. i_debug .ge. 13) write(6,*) 'a_line=',a_line(1:70) a_string=a_string(index(a_string,char(10))+1:) if (a_line .eq. ' ') then ! do nothing else if (a_key .eq. 'RECORD_BYTES') then read(a_val,*) i_recbytes c write(6,*) 'i_recbytes=',i_recbytes,' ',a_val c else if (a_key .eq. 'LABEL_RECORDS') then c read(a_val,*) i_label c write(6,*) 'i_label=',i_label,' ',a_val else if (a_key .eq. '^QUBE') then read(a_val,*) i_label i_label=i_label-1 c write(6,*) 'i_label=',i_label,' ',a_val else if (a_key .eq. 'OBJECT') then c write(6,*) 'a_val=',a_val(1:70) if (a_val .eq. ' QUBE') then a_object = 'QUBE' else a_object = 'UNKNOWN' end if c write(6,*) ' Object = ',a_object(1:30),i_setcols else if (a_key .eq. ' GROUP') then c write(6,*) 'a_val=',a_val(1:70) if (index(a_val,' IMAGE_MAP_PROJECTION') .gt. 0) then a_group = 'IMAGE_MAP_PROJECTION' a_setproj='EQA' r_setpegv(1)=0. r_setpegv(2)=0. r_setpegv(3)=0. else a_group = 'UNKNOWN' end if c write(6,*) ' Object = ',a_object(1:30),i_setcols else if (a_key .eq. 'END_OBJECT') then a_object = ' ' else if (index(a_key,'END_GROUP') .gt. 0) then a_group = ' ' else if (a_object .eq. 'QUBE') then if (a_key .eq. ' CORE_ITEMS') then a_val=a_val(index(a_val,'(')+1:) a_val=a_val(:index(a_val,')')-1) call rdf_getfields(a_val,i_values,a_values) read(a_values(1),*) i_setcols read(a_values(2),*) i_setrows read(a_values(3),*) i_band if (i_band .ne. 1) write(6,*) 'Band error in Qube header ',i_band else if (a_key .eq. ' CORE_ITEM_BYTES') then read(a_val,*) i_bytes else if (a_key .eq. ' CORE_ITEM_TYPE') then c do i=1,25 c write(6,*) 'i/val=',i,ichar(a_line(32+i:32+i)),' ',a_line(32+i:32+i) c end do if (a_val .eq. ' ') then ! do nothing else if (a_val(1:19) .eq. ' UNSIGNED INTEGER') then if (i_bytes .eq. 0) then i_setvfmt = 0 ! 'val_frmt = BYTE' else if (i_bytes .eq. 1) then i_setvfmt = 0 ! 'val_frmt = BYTE' else if (i_bytes .eq. 2) then i_setvfmt = 8 ! 'val_frmt = BYTE*2' else i_setvfmt = 0 ! 'val_frmt = BYTE' end if else if (a_val(1:10) .eq. ' INTEGER') then c write(6,*) 'INTEGER data detected ',i_bytes if (i_bytes .eq. 0) then i_setvfmt = 3 ! 'val_frmt = INTEGER*4' else if (i_bytes .eq. 1) then i_setvfmt = 1 ! 'val_frmt = INTEGER*1' else if (i_bytes .eq. 2) then i_setvfmt = 2 ! 'val_frmt = INTEGER*2' else if (i_bytes .eq. 4) then i_setvfmt = 3 ! 'val_frmt = INTEGER*4' else i_setvfmt = 3 ! 'val_frmt = INTEGER*4' end if c write(6,*) 'i_setvfmt = ',i_setvfmt else if (a_val(1:10) .eq. ' PC_REAL') then i_setvend=-1 if (i_bytes .eq. 0) then i_setvfmt = 4 ! 'val_frmt = REAL*4' else if (i_bytes .eq. 4) then i_setvfmt = 4 ! 'val_frmt = REAL*4' else if (i_bytes .eq. 8) then i_setvfmt = 5 ! 'val_frmt = REAL*8' else i_setvfmt = 4 ! 'val_frmt = REAL*4' end if else if (a_val(1:10) .eq. ' SUN_REAL') then i_setvend=1 if (i_bytes .eq. 0) then i_setvfmt = 4 ! 'val_frmt = REAL*4' else if (i_bytes .eq. 4) then i_setvfmt = 4 ! 'val_frmt = REAL*4' else if (i_bytes .eq. 8) then i_setvfmt = 5 ! 'val_frmt = REAL*8' else i_setvfmt = 4 ! 'val_frmt = REAL*4' end if else if (a_val(1:10) .eq. ' COMPLEX') then i_setvfmt = 6 ! 'val_frmt = Complex magnitude end if else if (a_key .eq. ' SAMPLE_BITS') then read(a_val,*) i_bytes i_bytes = i_bytes/8 if (i_bytes .eq. 0) then ! do nothing else if (i_bytes .eq. 1) then if (i_setvfmt .eq. 2 .or. i_setvfmt .eq. 3) then i_setvfmt = 1 ! 'val_frmt = INTEGER*1' else if (i_setvfmt .eq. 4 .or. i_setvfmt .eq. 5) then ! do nothing end if else if (i_bytes .eq. 2) then if (i_setvfmt .eq. 0) then i_setvfmt = 8 ! 'val_frmt = BYTE*2' else if (i_setvfmt .eq. 1 .or. i_setvfmt .eq. 3) then i_setvfmt = 2 ! 'val_frmt = INTEGER*2' else if (i_setvfmt .eq. 4 .or. i_setvfmt .eq. 5) then ! do nothing end if else if (i_bytes .eq. 4) then if (i_setvfmt .eq. 0 .or. i_setvfmt .eq. 8) then ! do nothing else if (i_setvfmt .eq. 1 .or. i_setvfmt .eq. 2) then i_setvfmt = 3 ! 'val_frmt = INTEGER*4' else if (i_setvfmt .eq. 5) then i_setvfmt = 4 ! 'val_frmt = REAL*4' end if else if (i_bytes .eq. 8) then if (i_setvfmt .eq. 0 .or. i_setvfmt .eq. 8) then ! do nothing else if (i_setvfmt .eq. 1 .or. i_setvfmt .eq. 2 .or. i_setvfmt .eq. 3) then ! do nothing else if (i_setvfmt .eq. 4) then i_setvfmt = 5 ! 'val_frmt = REAL*4' end if end if else if (a_group .eq. 'IMAGE_MAP_PROJECTION') then if (index(a_key,'MAP_SCALE') .gt. 0) then read(a_val,*) r_setrmlt read(a_val,*) r_setcmlt else if (index(a_key,'LINE_PROJECTION_OFFSET') .gt. 0) then read(a_val,*) r_setradr else if (index(a_key,'SAMPLE_PROJECTION_OFFSET') .gt. 0) then read(a_val,*) r_setcadr endif end if end if enddo i_setshdr = i_recbytes*i_label end if i_err = closedk(i_unit) return end **************************************************************** subroutine get_setinfo( a_setname, & a_setinfo, & a_setproj, & i_setunit, & i_setrows, & i_setcols, & i_setshdr, & i_setstlr, & i_setrhdr, & i_setrtlr, & i_setchdr, & i_setctlr, & i_setvend, & i_setvfmt, & r_setvmlt, & r_setvadr, & r_setvmin, & r_setvmax, & a_setvnul, & r_setrmlt, & r_setradr, & r_setcmlt, & r_setcadr, & r_setpegv, & r_dspaddr, & r_dspmult, & r_dspwrap, & r_dspexpn, & r_dspcplw, & r_dspcphi, & r_dspval1, & r_dspval2, & r_dspval3, & i_dspmode, & i_dspaddr, & i_dspmult, & i_dspmixv, & i_dspdvdc, & a_dspctbl ) implicit none c INPUT VARIABLES: c OUTPUT VARIABLES: c structure / set_structure / s_set(-I_FMAX:I_CMAX) character*200 a_setname ! Parameter name character*200 a_setfile ! Data filename character*200 a_setinfo ! Header filename character*200 a_setproj ! Projection name integer i_setunit ! Unit number to read set integer i_setrows ! Number of rows in set integer i_setcols ! Number of columns in set integer i_setshdr ! Number of bytes in set header integer i_setstlr ! Number of bytes in set trailer integer i_setrhdr ! Number of bytes in row header integer i_setrtlr ! Number of bytes in row trailer integer i_setchdr ! Number of bytes in column header integer i_setctlr ! Number of bytes in column trailer integer i_setvend ! Endian flag integer i_setvfmt ! Method to decode columns real*4 r_setrmlt ! Row Scale for set real*4 r_setradr ! Row Offset for set real*4 r_setcmlt ! Column Scale for set real*4 r_setcadr ! Column Offset for set real*4 r_setvmlt ! Value Scale for set real*4 r_setvadr ! Value Offset for set real*4 r_setvmin ! Minimum valid value real*4 r_setvmax ! Maximum valid value character*16 a_setvnul ! Invalid value real*4 r_setvavg ! Average value in set real*4 r_setvstd ! Standard deviation of values in set real*4 r_setpegv(3) ! Peg Point c end structure c structure / dspinfo / s_dsp character*200 a_dspctbl ! Color table file integer i_dspcnt integer i_dspchnl ! Number of sets to display integer i_dspaddr ! Add auto Scale flag integer i_dspmult ! Mult auto Scale flag integer i_dspmixv ! Method to mix set (add, multiply, max, avg) integer i_dspnumt ! Number of entries in color table integer i_dspmode integer i_dspdvdc integer i_dspactv(0:5) c real*4 r_dspredt(0:255) ! Values of red color table c real*4 r_dspgrnt(0:255) ! Values of green color table c real*4 r_dspblut(0:255) ! Values of blue color table real*4 r_dspcplw ! Discard if below value real*4 r_dspcphi ! Discard if above value real*4 r_dspexpn ! Exponent to raise data real*4 r_dspaddr ! Shift data by value real*4 r_dspwrap ! Wrap data by value real*4 r_dspmult ! Multiply data by value real*4 r_dspvmin ! Min value to display real*4 r_dspvmax ! Max value to display real*4 r_dspval1 real*4 r_dspval2 real*4 r_dspval3 c end structure c LOCAL VARIABLES: integer*4 i integer*4 j integer*4 i_cnt integer*4 i_oper integer*4 i_set integer*4 i_stat integer*4 i_flg integer*4 i_indx character*255 a_tmp character*255 a_set character*255 a_key character*255 a_keyword character*255 a_valword character*255 a_value c FUNCTION STATEMENTS: character*320 rdfdata external rdfdata integer rdflen external rdflen integer rdfnum external rdfnum integer rdferr external rdferr integer rdfmap external rdfmap character*320 rdfdimn external rdfdimn character*320 rdfvalu external rdfvalu character*320 rdfunit external rdfunit character*320 rdfcmnt external rdfcmnt character*320 rdfelem external rdfelem character*320 rdfoper external rdfoper character*320 rdfint external rdfint character*320 rdfreal external rdfreal character*320 rdfdble external rdfdble character*40 rdflower external rdflower character*50 rdfversion external rdfversion integer*4 i_CnvrtFmt external i_CnvrtFmt call rdf_init('ERROR_SCREEN=OFF') c write(6,*) ' ' c write(6,*) rdfversion() c write(6,*) ' ' c write(6,*) ' ' call rdf_clear() call rdf_read(a_setinfo) call rdf_init('ERROR_SCREEN=ON') if (a_setname .ne. ' ') then a_key = a_setname(1:rdflen(a_setname))//'.' else a_key = ' ' end if call rdf_index(a_key(1:max(1,rdflen(a_key)))//'set_name',i_indx & ,i_flg) if (i_flg .eq. 1) then a_value=rdfdata(a_key(1:max(1,rdflen(a_key)))//'set_name','&') if (a_value .ne. ' ') a_setname = a_value end if call rdf_index(a_key(1:max(1,rdflen(a_key)))//'set_rows',i_indx & ,i_flg) c type *,a_key(1:max(1,rdflen(a_key)))//'set_rows:',i_indx,i_flg if (i_flg .eq. 1) then a_value=rdfdata(a_key(1:max(1,rdflen(a_key)))//'set_rows' & ,'pixels') if (a_value .ne. ' ') read(unit=a_value,fmt='(i10)') i_setrows end if call rdf_index(a_key(1:max(1,rdflen(a_key)))//'set_cols',i_indx & ,i_flg) if (i_flg .eq. 1) then a_value=rdfdata(a_key(1:max(1,rdflen(a_key)))//'set_cols' & ,'pixels') if (a_value .ne. ' ') read(unit=a_value,fmt='(i10)') i_setcols !@#&% change fmt end if call rdf_index(a_key(1:max(1,rdflen(a_key)))//'set_hddr',i_indx & ,i_flg) if (i_flg .eq. 1) then a_value=rdfdata(a_key(1:max(1,rdflen(a_key)))//'set_hddr' & ,'bytes') if (a_value .ne. ' ') read(unit=a_value,fmt='(i10)') i_setshdr end if call rdf_index(a_key(1:max(1,rdflen(a_key)))//'set_tail',i_indx & ,i_flg) if (i_flg .eq. 1) then a_value=rdfdata(a_key(1:max(1,rdflen(a_key)))//'set_tail' & ,'bytes') if (a_value .ne. ' ') read(unit=a_value,fmt='(i10)') i_setstlr end if call rdf_index(a_key(1:max(1,rdflen(a_key)))//'row_hddr',i_indx & ,i_flg) if (i_flg .eq. 1) then a_value=rdfdata(a_key(1:max(1,rdflen(a_key)))//'row_hddr' & ,'bytes') if (a_value .ne. ' ') read(unit=a_value,fmt='(i10)') i_setrhdr end if call rdf_index(a_key(1:max(1,rdflen(a_key)))//'row_tail',i_indx & ,i_flg) if (i_flg .eq. 1) then a_value=rdfdata(a_key(1:max(1,rdflen(a_key)))//'row_tail' & ,'bytes') if (a_value .ne. ' ') read(unit=a_value,fmt='(i10)') i_setrtlr end if call rdf_index(a_key(1:max(1,rdflen(a_key)))//'col_hddr',i_indx & ,i_flg) if (i_flg .eq. 1) then a_value=rdfdata(a_key(1:max(1,rdflen(a_key)))//'col_hddr' & ,'bytes') if (a_value .ne. ' ') read(unit=a_value,fmt='(i10)') i_setchdr end if call rdf_index(a_key(1:max(1,rdflen(a_key)))//'col_tail',i_indx & ,i_flg) if (i_flg .eq. 1) then a_value=rdfdata(a_key(1:max(1,rdflen(a_key)))//'col_tail' & ,'bytes') if (a_value .ne. ' ') read(unit=a_value,fmt='(i10)') i_setctlr end if call rdf_index(a_key(1:max(1,rdflen(a_key)))//'val_endi',i_indx & ,i_flg) if (i_flg .eq. 1) then a_value=rdfdata(a_key(1:max(1,rdflen(a_key)))//'val_endi' & ,'bytes') if (a_value .eq. ' ') then ! do nothing else if (rdflower(a_value) .eq. 'little endian') then i_setvend = -1 else if (rdflower(a_value) .eq. 'little_endian') then i_setvend = -1 else if (rdflower(a_value) .eq. 'big endian' ) then i_setvend = 1 else if (rdflower(a_value) .eq. 'big_endian' ) then i_setvend = 1 else if (rdflower(a_value) .eq. 'byte swap' ) then i_setvend = -i_setvend else if (rdflower(a_value) .eq. 'byte_swap' ) then i_setvend = -i_setvend end if end if call rdf_index(a_key(1:max(1,rdflen(a_key)))//'val_frmt',i_indx & ,i_flg) if (i_flg .eq. 1) then a_value=rdfdata(a_key(1:max(1,rdflen(a_key)))//'val_frmt','&') if (a_value .ne. ' ') i_setvfmt = i_CnvrtFmt(a_value) end if call rdf_index(a_key(1:max(1,rdflen(a_key)))//'row_mult',i_indx & ,i_flg) if (i_flg .eq. 1) then a_value=rdfdata(a_key(1:max(1,rdflen(a_key)))//'row_mult',' ') if (a_value .ne. ' ') read(unit=a_value,fmt='(f15.4)') & r_setrmlt end if call rdf_index(a_key(1:max(1,rdflen(a_key)))//'row_addr',i_indx & ,i_flg) if (i_flg .eq. 1) then a_value=rdfdata(a_key(1:max(1,rdflen(a_key)))//'row_addr',' ') if (a_value .ne. ' ') read(unit=a_value,fmt='(f15.4)') & r_setradr end if call rdf_index(a_key(1:max(1,rdflen(a_key)))//'col_mult',i_indx & ,i_flg) if (i_flg .eq. 1) then a_value=rdfdata(a_key(1:max(1,rdflen(a_key)))//'col_mult',' ') if (a_value .ne. ' ') read(unit=a_value,fmt='(f15.4)') & r_setcmlt end if call rdf_index(a_key(1:max(1,rdflen(a_key)))//'col_addr',i_indx & ,i_flg) if (i_flg .eq. 1) then a_value=rdfdata(a_key(1:max(1,rdflen(a_key)))//'col_addr',' ') if (a_value .ne. ' ') read(unit=a_value,fmt='(f15.4)') & r_setcadr end if call rdf_index(a_key(1:max(1,rdflen(a_key)))//'val_mult',i_indx ,i_flg) if (i_flg .eq. 1) then a_value=rdfdata(a_key(1:max(1,rdflen(a_key)))//'val_mult',' ') c write(6,*) 'val_mult=',a_value if (a_value .ne. ' ') read(unit=a_value,fmt='(f15.4)') r_setvmlt end if call rdf_index(a_key(1:max(1,rdflen(a_key)))//'val_addr',i_indx,i_flg) if (i_flg .eq. 1) then a_value=rdfdata(a_key(1:max(1,rdflen(a_key)))//'val_addr',' ') if (index(a_value,'.') .eq. 0) a_value=a_value(1:max(1,rdflen(a_value)))//'.' if (a_value .ne. ' ') read(unit=a_value,fmt='(f15.4)') r_setvadr c write(6,*) 'r_setvadr=',a_value end if call rdf_index(a_key(1:max(1,rdflen(a_key)))//'val_minv',i_indx ,i_flg) if (i_flg .eq. 1) then a_value=rdfdata(a_key(1:max(1,rdflen(a_key)))//'val_minv',' ') if (index(a_value,'.') .eq. 0) a_value=a_value(1:max(1,rdflen(a_value)))//'.' if (a_value .ne. ' ') read(unit=a_value,fmt='(f15.4)') r_setvmin end if call rdf_index(a_key(1:max(1,rdflen(a_key)))//'val_maxv',i_indx,i_flg) if (i_flg .eq. 1) then a_value=rdfdata(a_key(1:max(1,rdflen(a_key)))//'val_maxv',' ') if (index(a_value,'.') .eq. 0) a_value=a_value(1:max(1,rdflen(a_value)))//'.' if (a_value .ne. ' ') read(unit=a_value,fmt='(f15.4)')r_setvmax end if call rdf_index(a_key(1:max(1,rdflen(a_key)))//'val_null',i_indx,i_flg) if (i_flg .eq. 1) then a_value=rdfdata(a_key(1:max(1,rdflen(a_key)))//'val_null',' ') if (a_value .ne. ' ') a_setvnul = a_value end if call rdf_index(a_key(1:max(1,rdflen(a_key)))//'set_plat',i_indx,i_flg) if (i_flg .eq. 1) then a_value=rdfdata(a_key(1:max(1,rdflen(a_key)))//'set_plat','rad') if (a_value .ne. ' ') read(unit=a_value,fmt='(f15.4)') r_setpegv(1) end if call rdf_index(a_key(1:max(1,rdflen(a_key)))//'set_plon',i_indx,i_flg) if (i_flg .eq. 1) then a_value=rdfdata(a_key(1:max(1,rdflen(a_key)))//'set_plon','rad') if (a_value .ne. ' ') read(unit=a_value,fmt='(f15.4)') r_setpegv(2) end if call rdf_index(a_key(1:max(1,rdflen(a_key)))//'set_phdg',i_indx,i_flg) if (i_flg .eq. 1) then a_value=rdfdata(a_key(1:max(1,rdflen(a_key)))//'set_phdg','rad') if (a_value .ne. ' ') read(unit=a_value,fmt='(f15.4)') r_setpegv(3) end if call rdf_index(a_key(1:max(1,rdflen(a_key)))//'set_pegv',i_indx,i_flg) if (i_flg .eq. 1) then a_value=rdfdata(a_key(1:max(1,rdflen(a_key)))//'set_phdg','rad') if (a_value .ne. ' ') read(unit=a_value,fmt='(3f15.4)') r_setpegv end if call rdf_index(a_key(1:max(1,rdflen(a_key)))//'set_proj',i_indx,i_flg) if (i_flg .eq. 1) then a_setproj=rdfvalu(a_key(1:max(1,rdflen(a_key)))//'set_proj') end if call rdf_index(a_key(1:max(1,rdflen(a_key)))//'dsp_cmap',i_indx,i_flg) if (i_flg .eq. 1) then a_dspctbl=rdfvalu(a_key(1:max(1,rdflen(a_key)))//'dsp_cmap') end if call rdf_index(a_key(1:max(1,rdflen(a_key)))//'dsp_mode',i_indx,i_flg) if (i_flg .eq. 1) then a_value=rdfvalu(a_key(1:max(1,rdflen(a_key)))//'dsp_mode') c write(6,*) 'Mode = ','*'//a_value//'*' if (a_value .eq. ' ') then ! do nothing else if (rdflower(a_value) .eq. 'range') then i_dspmode = 1 c write(6,*) 'setting mode to 1' else if (rdflower(a_value) .eq. 'sdev') then i_dspmode = 2 else if (rdflower(a_value) .eq. 'per' .or. rdflower(a_value) .eq. 'percent') then i_dspmode = 3 else if (rdflower(a_value) .eq. 'norm' .or. rdflower(a_value) .eq. 'normal') then i_dspmode = 4 else if (rdflower(a_value) .eq. 'cw' .or. rdflower(a_value) .eq. 'charlie') then i_dspmode = 5 else if (rdflower(a_value) .eq. 'wrap') then i_dspmode = 6 end if end if call rdf_index(a_key(1:max(1,rdflen(a_key)))//'dsp_wrap',i_indx,i_flg) if (i_flg .eq. 1) then a_value=rdfvalu(a_key(1:max(1,rdflen(a_key)))//'dsp_wrap') if (a_value .ne. ' ') read(unit=a_value,fmt='(f15.4)') r_dspwrap end if call rdf_index(a_key(1:max(1,rdflen(a_key)))//'dsp_addr',i_indx,i_flg) if (i_flg .eq. 1) then a_value=rdfvalu(a_key(1:max(1,rdflen(a_key)))//'dsp_addr') if (a_value .ne. ' ') i_dspaddr=0 if (a_value .ne. ' ') read(unit=a_value,fmt='(f15.4)') r_dspaddr end if call rdf_index(a_key(1:max(1,rdflen(a_key)))//'dsp_mult',i_indx,i_flg) if (i_flg .eq. 1) then a_value=rdfvalu(a_key(1:max(1,rdflen(a_key)))//'dsp_mult') if (a_value .ne. ' ') i_dspmult=0 if (a_value .ne. ' ') read(unit=a_value,fmt='(f15.4)') r_dspmult end if call rdf_index(a_key(1:max(1,rdflen(a_key)))//'dsp_fact',i_indx,i_flg) if (i_flg .eq. 1) then a_value=rdfvalu(a_key(1:max(1,rdflen(a_key)))//'dsp_fact') if (a_value .ne. ' ') read(unit=a_value,fmt='(f15.4)') r_dspval1 end if call rdf_index(a_key(1:max(1,rdflen(a_key)))//'dsp_expn',i_indx,i_flg) if (i_flg .eq. 1) then a_value=rdfvalu(a_key(1:max(1,rdflen(a_key)))//'dsp_expn') if (a_value .ne. ' ') read(unit=a_value,fmt='(f15.4)') r_dspexpn end if call rdf_index(a_key(1:max(1,rdflen(a_key)))//'dsp_expn',i_indx,i_flg) if (i_flg .eq. 1) then a_value=rdfvalu(a_key(1:max(1,rdflen(a_key)))//'dsp_expn') if (a_value .ne. ' ') read(unit=a_value,fmt='(f15.4)') r_dspexpn end if call rdf_index(a_key(1:max(1,rdflen(a_key)))//'dsp_dvdc',i_indx,i_flg) if (i_flg .eq. 1) then a_value=rdfvalu(a_key(1:max(1,rdflen(a_key)))//'dsp_dvdc') if (rdflower(a_value) .eq. 'y' .or. rdflower(a_value) .eq. 'yes' .or. & rdflower(a_value) .eq. 't' .or. rdflower(a_value) .eq. 'true' .or. & a_value .eq. '1') then i_dspdvdc=1 else i_dspdvdc=0 end if end if return end **************************************************************** subroutine put_setinfo( a_setname, & a_setinfo, & a_setproj, & i_setunit, & i_setrows, & i_setcols, & i_setshdr, & i_setstlr, & i_setrhdr, & i_setrtlr, & i_setchdr, & i_setctlr, & i_setvend, & i_setvfmt, & r_setvmlt, & r_setvadr, & r_setvmin, & r_setvmax, & a_setvnul, & r_setrmlt, & r_setradr, & r_setcmlt, & r_setcadr, & r_setpegv ) implicit none c INPUT VARIABLES: c OUTPUT VARIABLES: c structure / set_structure / s_set(-I_FMAX:I_CMAX) character*200 a_setname ! Parameter name character*200 a_setfile ! Data filename character*200 a_setinfo ! Header filename character*200 a_setproj ! Projection name integer i_setunit ! Unit number to read set integer i_setrows ! Number of rows in set integer i_setcols ! Number of columns in set integer i_setshdr ! Number of bytes in set header integer i_setstlr ! Number of bytes in set trailer integer i_setrhdr ! Number of bytes in row header integer i_setrtlr ! Number of bytes in row trailer integer i_setchdr ! Number of bytes in column header integer i_setctlr ! Number of bytes in column trailer integer i_setvend ! Endian flag integer i_setvfmt ! Method to decode columns real*4 r_setrmlt ! Row Scale for set real*4 r_setradr ! Row Offset for set real*4 r_setcmlt ! Column Scale for set real*4 r_setcadr ! Column Offset for set real*4 r_setvmlt ! Value Scale for set real*4 r_setvadr ! Value Offset for set real*4 r_setvmin ! Minimum valid value real*4 r_setvmax ! Maximum valid value character*16 a_setvnul ! Invalid value real*4 r_setvavg ! Average value in set real*4 r_setvstd ! Standard deviation of values in set real*4 r_setpegv(3) ! Peg Point c end structure c LOCAL VARIABLES: integer*4 i integer*4 j integer*4 i_cnt integer*4 i_oper integer*4 i_set integer*4 i_stat integer*4 i_flg integer*4 i_indx character*255 a_tmp character*255 a_set character*255 a_key character*255 a_keyword character*255 a_valword character*255 a_value character*255 a_data c FUNCTION STATEMENTS: integer rdflen external rdflen integer rdfnum external rdfnum integer rdferr external rdferr integer rdfmap external rdfmap integer*4 i_CnvrtFmt external i_CnvrtFmt call rdf_init(' ') call rdf_clear() write(a_data,'(a,a)') 'set_name =',a_setname call rdf_append(a_data) write(6,*) 'set_rows = ',i_setrows write(a_data,fmt=*) 'set_rows =',i_setrows write(6,*) 'a_data=',a_data call rdf_append(a_data) write(a_data,fmt=*) 'set_cols =',i_setcols call rdf_append(a_data) write(a_data,fmt=*) 'set_hddr =',i_setshdr call rdf_append(a_data) write(a_data,fmt=*) 'set_tail =',i_setstlr call rdf_append(a_data) write(a_data,fmt=*) 'row_hddr =',i_setrhdr call rdf_append(a_data) write(a_data,fmt=*) 'row_tail =',i_setrtlr call rdf_append(a_data) write(a_data,fmt=*) 'col_hddr =',i_setchdr call rdf_append(a_data) write(a_data,fmt=*) 'col_tail =',i_setctlr call rdf_append(a_data) if (i_setvend .eq. -1) then write(a_data,fmt=*) 'val_endi = LITTLE ENDIAN' else write(a_data,fmt=*) 'val_endi = BIG ENDIAN' end if call rdf_append(a_data) If (i_setvfmt .eq. -1) then ! do nothing else if (i_setvfmt .eq. 0) then write(a_data,fmt=*) 'val_frmt = BYTE' else if (i_setvfmt .eq. 1) then write(a_data,fmt=*) 'val_frmt = INTEGER*1' else if (i_setvfmt .eq. 2) then write(a_data,fmt=*) 'val_frmt = INTEGER*2' else if (i_setvfmt .eq. 3) then write(a_data,fmt=*) 'val_frmt = INTEGER*4' else if (i_setvfmt .eq. 4) then write(a_data,fmt=*) 'val_frmt = REAL*4' else if (i_setvfmt .eq. 5) then write(a_data,fmt=*) 'val_frmt = REAL*8' else if (i_setvfmt .eq. 6) then write(a_data,fmt=*) 'val_frmt = COMPLEX_MAGNITUDE' else if (i_setvfmt .eq. 7) then write(a_data,fmt=*) 'val_frmt = COMPLEX_PHASE' else if (i_setvfmt .eq. 8) then write(a_data,fmt=*) 'val_frmt = BYTE*2' else if (i_setvfmt .eq. 9) then write(a_data,fmt=*) 'val_frmt = COMPRESSED_STOKES' else if (i_setvfmt .eq. 10) then write(a_data,fmt=*) 'val_frmt = COMPLEX*2_MAGNITUDE' else if (i_setvfmt .eq. 11) then write(a_data,fmt=*) 'val_frmt = COMPLEX*2_PHASE' else if (i_setvfmt .eq. 12) then write(a_data,fmt=*) 'val_frmt = REAL*4_MAGNITUDE' else write(6,*) 'ERROR IN PUT_SETINFO' end if call rdf_append(a_data) write(a_data,fmt=*) 'row_mult =',r_setrmlt call rdf_append(a_data) write(a_data,fmt=*) 'row_addr =',r_setradr call rdf_append(a_data) write(a_data,fmt=*) 'col_mult =',r_setcmlt call rdf_append(a_data) write(a_data,fmt=*) 'col_addr =',r_setcadr call rdf_append(a_data) write(a_data,fmt=*) 'val_mult =',r_setvmlt call rdf_append(a_data) write(a_data,fmt=*) 'val_addr =',r_setvadr call rdf_append(a_data) write(a_data,fmt=*) 'val_minv =',r_setvmin call rdf_append(a_data) write(a_data,fmt=*) 'val_maxv =',r_setvmax call rdf_append(a_data) write(a_data,'(a,a)') 'val_null =',a_setvnul call rdf_append(a_data) write(a_data,fmt=*) 'set_plat =',r_setpegv(1) call rdf_append(a_data) write(a_data,fmt=*) 'set_plon =',r_setpegv(2) call rdf_append(a_data) write(a_data,fmt=*) 'set_phdg =',r_setpegv(3) call rdf_append(a_data) write(a_data,'(a,a)') 'set_proj =',a_setproj call rdf_append(a_data) call rdf_write(a_setinfo) return end integer function i_CnvrtFmt(a_fmt) implicit none character*(*) a_fmt integer i_fmt character*20 rdfupper external rdfupper if (a_fmt .eq. ' ') then i_fmt = -1 else if (rdfupper(a_fmt) .eq. 'BYTE*1' .or. a_fmt .eq. 'BYTE') then i_fmt = 0 else if (rdfupper(a_fmt) .eq. 'INTEGER*1') then i_fmt = 1 else if (rdfupper(a_fmt) .eq. 'INTEGER*2') then i_fmt = 2 else if (rdfupper(a_fmt) .eq. 'INTEGER*4') then i_fmt = 3 else if (rdfupper(a_fmt) .eq. 'REAL*4') then i_fmt = 4 else if (rdfupper(a_fmt) .eq. 'REAL*8') then i_fmt = 5 else if (rdfupper(a_fmt) .eq. 'COMPLEX_MAGNITUDE' .or. rdfupper(a_fmt) .eq. 'COMPLEX*8_MAGNITUDE') then i_fmt = 6 else if (rdfupper(a_fmt) .eq. 'COMPLEX_PHASE' .or. rdfupper(a_fmt) .eq. 'COMPLEX*8_PHASE') then i_fmt = 7 else if (rdfupper(a_fmt) .eq. 'BYTE*2') then i_fmt = 8 else if (rdfupper(a_fmt) .eq. 'COMPRESSED_STOKES' .or. a_fmt .eq. 'STOKES11') then i_fmt = 9 else if (rdfupper(a_fmt) .eq. 'COMPLEX*2_MAGNITUDE') then i_fmt = 10 else if (rdfupper(a_fmt) .eq. 'COMPLEX*2_PHASE') then i_fmt = 11 else if (rdfupper(a_fmt) .eq. 'COMPLEX*4_MAGNITUDE') then i_fmt = 12 else if (rdfupper(a_fmt) .eq. 'COMPLEX*4_PHASE') then i_fmt = 13 else if (rdfupper(a_fmt) .eq. 'REAL*4_MAGNITUDE') then i_fmt = 14 else i_fmt = -1 endif i_CnvrtFmt = i_fmt end subroutine write_greeting() implicit none write(6,*) ' ' write(6,*) ' ' write(6,*) ' ' write(6,*) 'Usage: mdx file1 ' write(6,*) ' mdx file1 -x xval -y yval ' write(6,*) ' mdx file1 -x xval -y yval file2 -zval ' write(6,*) ' mdx file1 -set setname1 -x xval -y yval -set setname2 -z zval ' write(6,*) ' mdx file1 -x xval -set setname1 -y yval -set setname2 -z zval' write(6,*) ' ' write(6,*) 'Rules for using flags:' write(6,*) ' ' write(6,*) ' Flags specified before the first filename are used as default for ' write(6,*) ' all following files.' write(6,*) ' Flags specified after a filename but before any set names are used ' write(6,*) ' as the default for all the sets in that file.' write(6,*) ' Flags specified after a set name only apply to that set.' write(6,*) ' In general, flags that are capitalized don''t require an argument,' write(6,*) ' flags in lower case do.' write(6,*) ' ' write(6,*) 'Unobvious features:' write(6,*) ' ' write(6,*) ' To activate one desired set, left-click on that sets selector button' write(6,*) ' ' write(6,*) ' To toggle a set on or off, middle-click on that sets selector button' write(6,*) ' ' write(6,*) ' To bring up a menu of set parameters, right-click on the set selector button' write(6,*) ' ' write(6,*) ' To get an xmgrace display of a sets color bar, hold the shift key and click ' write(6,*) ' on the set selector button ' write(6,*) ' ' write(6,*) ' To center the display on a pixel that isnt currently visible, click on the location' write(6,*) ' bar just above the image and enter the pixel row/column when asked' write(6,*) ' ' write(6,*) ' To center the display on a latitude/longitude, hold the shift key down and click on ' write(6,*) ' the locationbar just above the image and enter the lat/long when asked' write(6,*) ' ' write(6,*) ' To center the display on a particular visable pixel, middle-click on that pixel' write(6,*) ' ' write(6,*) ' To center other displays on a particular visable pixel, hold the shift key down' write(6,*) ' and middle-click on that pixel' write(6,*) ' ' write(6,*) 'Flags:' write(6,*) ' ' write(6,*) '-cols, -columns, -s, or -samples = Number of samples per line' write(6,*) '-rows, -l, or -lines = Number of lines in file' write(6,*) '-shdr = Size of Header (in bytes) at top of file' write(6,*) '-rhdr = Size of header (in bytes) at start of each line' write(6,*) '-chdr = Size of header (in bytes) at start of each sample' write(6,*) '-stlr = Size of trailer (in bytes at the end of each set' write(6,*) '-rtlr = Size of trailer (in bytes) at the end of each line' write(6,*) '-ctlr = Size of trailer (in bytes) at the end of each sample' write(6,*) '-rmlt = Multiplier to convert image row number to an engineering unit' write(6,*) '-radr = Offset to convert image row number to an engineering unit' write(6,*) '-cmlt = Multiplier to convert image column number to an engineering unit' write(6,*) '-cadr = Offset to convert image column number to an engineering unit' write(6,*) '-vmlt = Multiplier to convert image data to an engineering unit' write(6,*) '-vadr = Offset to convert image data to an engineering unit' write(6,*) '-plat = Peg Latitude' write(6,*) '-plon = Peg Longitude' write(6,*) '-phdr = Peg heading' write(6,*) '-proj = Projection name' write(6,*) ' ' write(6,*) '-min, -vmin, or -minval = Minimum valid value (in engineering units)' write(6,*) '-max, -vmax, or -maxval = Maximum valid value (in engineering units)' write(6,*) ' ' write(6,*) '-e, -exp = Exponent that data is raised to after scaling between 0 and 1' write(6,*) '-addr, -a, or -daddr = Offset to shift color table in display' write(6,*) '-mult, -m, or -dmult = Scaler to stretch color table in display' write(6,*) '-cws, -cw, -charlie = Scale factor in CW mode' write(6,*) '-wrap, or -d = Wrap value for display' write(6,*) '-fact, or -f = Sets number of standard deviations to display across color table' write(6,*) '-per, percent, or -p = percent of data that is clipped in the display' write(6,*) '-clpmin, or -minclp = Minimum value before clipping during display' write(6,*) '-clpmax, or -maxclp = Maximum value before clipping during display' write(6,*) ' ' write(6,*) '-row = row of display center on startup' write(6,*) '-col = column of display center on startup' write(6,*) '-lat = latitude of display center on startup' write(6,*) '-lon = longitude of display center on startup' write(6,*) ' ' write(6,*) '-active = The following 1s and 0s set the on/off status of the sets at startup' write(6,*) '-z, or -zoom = Initial zoom of display' write(6,*) '-pz, or -pzoom = Zoom factor for printing to file' write(6,*) '-vx = x dimension of initial display window' write(6,*) '-vy = y dimension of initial display window' write(6,*) '-mix = Sets how to combine sets +, x are options' write(6,*) '-cmap, or -ctable = Name of color table to use' write(6,*) '-nc, -null_color, or -cnull = RGB color value to use for null data' write(6,*) '-emod = Number of rows to read before checking if window update (def=10)' write(6,*) '-debug = Sets debug level (def=2) ' write(6,*) '-workdir = working directory for out.ppm ' write(6,*) '-colordir = default directory for color tables' write(6,*) ' ' write(6,*) '-h = Specifies header file name' write(6,*) '-maghdr = Name of .hdr file to be used for a magnitude file (must be after set name)' write(6,*) '-dtehdr = Name of .hdr file to be used for a height file (must be after set name)' write(6,*) '-pts or -points = Filename of input selection points to overlay on display' write(6,*) ' ' write(6,*) '-pcpad = Number of pixel in column direction to reduce print size by' write(6,*) '-prpad = Number of pixel in row direction to reduce print size by' write(6,*) ' ' write(6,*) '-col, -cpos or -c = jump to specified column at start up' write(6,*) '-row, -rpos or -r = jump to specified row at start up' write(6,*) '-lat, or -latitude = jump to specified latitude at start up' write(6,*) '-lon, or -longitude = jump to specified longitude at start up' write(6,*) ' ' write(6,*) 'Display Mode Stuff ' write(6,*) '-STD = Sets display scaling to Standard deviation mode with factor at 2' write(6,*) '-PER = Sets display scaling to Percentage mode with percent set to 90%' write(6,*) '-CW = Sets display scaling to Charlie Warner mode with factor at 1' write(6,*) '-WRAP = Sets display scaling to wrap mode with a modules of Pi' write(6,*) '-ON = Turns set on at startup (default)' write(6,*) '-OFF = Turns set off at startup' write(6,*) ' ' write(6,*) '-P, -ponly = No display, only create ppm file of sets' write(6,*) '-D, -dvdc, -dc, -dx or -slope = Slope of channel in column direction' write(6,*) '-LE, -le, -little = little endian' write(6,*) '-BE, -be, -big = big endian' write(6,*) '-BS, -bs, -bswap = byte swapped from default machine format' write(6,*) '-NM = turns off main menu' write(6,*) '-C -CLOSE = enables close button in bottom right corner' write(6,*) '-NC -NOCLOSE = disables close button in bottom right corner' write(6,*) ' ' write(6,*) 'File definition shortcuts ' write(6,*) '-b1, or -byte = Unsigned byte file' write(6,*) '-b2, or -byte2 = Unsigned 2-byte integer file' write(6,*) '-i1, or -integer*1 = Signed byte file' write(6,*) '-i2, or -integer*2 = Signed 2-byte integer file' write(6,*) '-i4, or -integer*4 = Signed 4-byte integer file' write(6,*) '-r4, or -real*4 = IEEE 4-byte Float file' write(6,*) '-c2, or -complex*2 = Complex*2 (mag and phase sets)' write(6,*) '-c8, or -complex*8 = Complex*8 (mag and phase sets)' write(6,*) '-c8mag, or -cmag = Magnitude portion of a c8 file only' write(6,*) '-c8pha, or -cpha = Phase portion of a c8 file only' write(6,*) '-c2mag = Magnitude portion of a c2 file only' write(6,*) '-c2pha, = Phase portion of a c2 file only' write(6,*) '-rmg = RMG file (mag and dte sets)' write(6,*) '-vfmt or -val_frmt = Character string indicating format (i.e. real*4)' write(6,*) ' ' write(6,*) ' ' write(6,*) 'Please forward any comments or suggestions ' write(6,*) 'regarding mdx to: Scott.Shaffer@jpl.nasa.gov ' write(6,*) ' ' write(6,*) ' ' write(6,*) ' ' write(6,*) ' ' write(6,*) ' ' write(6,*) ' ' return end subroutine readdat(i_setunit, ! This version uses ioseek/read & i_setrows, & i_setcols, & i_setshdr, & i_setstlr, & i_setrhdr, & i_setrtlr, & i_setchdr, & i_setctlr, & i_setvend, & i_setvfmt, & r_setvmlt, & r_setvadr, & r_setvmin, & r_setvmax, & b_setvnul, & i_row,i_col,i_num,r_data,i_data,readfunc,i_err) implicit none integer i integer i_err integer i_num integer i_row integer i_col integer i_pos integer i_ll integer i_hh integer i_colsize integer i_rowsize integer i_setunit ! Unit number to read set integer i_setrows ! Number of rows in set integer i_setcols ! Number of columns in set integer i_setshdr ! Number of bytes in set header integer i_setstlr ! Number of bytes in set trailer integer i_setrhdr ! Number of bytes in row header integer i_setrtlr ! Number of bytes in row trailer integer i_setchdr ! Number of bytes in column header integer i_setctlr ! Number of bytes in column trailer integer i_setvend ! Endian flag integer i_setvfmt ! Method to decode columns real*4 r_setvmlt ! Value Scale for set real*4 r_setvadr ! Value Offset for set real*4 r_setvmin ! Minimum valid value real*4 r_setvmax ! Maximum valid value byte b_setvnul(0:16) ! Invalid value integer i_numxx integer nread integer ioread external ioread #ifdef IO64 integer*8 i_strtc integer*8 i_stopc integer*8 nseek integer*8 ioseek64 external ioseek64 integer*8 i_eight external i_eight integer*8 readfunc external readfunc #else integer*4 i_strtc integer*4 i_stopc integer*4 nseek integer*4 ioseek external ioseek integer*4 readfunc external readfunc #endif real*4 r_cnvrtdat external r_cnvrtdat real r_data(0:i_num-1) integer i_data(0:i_num-1) byte b_data(0:400000) real r_data2(0:100000) integer i_data2(0:100000) integer i_checknul external i_checknul integer i_setvbyt external i_setvbyt byte b_tmp(4) real*4 r_tmp equivalence(b_tmp,r_tmp) if (i_num .gt. 100000) stop 'Error - i_num too big in readdat' if (i_row .ge. 0 .and. i_row .lt. i_setrows .and. & i_col+i_num-1 .ge. 0 .and. i_col .lt. i_setcols) then i_colsize = i_setchdr + i_setctlr + i_setvbyt(i_setvfmt) i_rowsize = i_setrhdr + i_setrtlr + i_colsize*i_setcols c write(6,*) 'i_colsize=',i_colsize c write(6,*) 'i_rowsize=',i_rowsize #ifdef IO64 i_strtc = i_setshdr + i_setrhdr + i_setchdr + (i_row)*i_eight(i_rowsize) & + (max(0,i_col*i_colsize)) i_stopc = i_strtc + min(i_num,i_setcols-i_col)*i_colsize if (i_setunit .gt. 0) then nseek = ioseek64(i_setunit,i_strtc,0) if (nseek .ne. i_strtc) write(6,*) 'nseek<>i_strtc ',nseek,i_strtc i_numxx = i_stopc - i_strtc nread = ioread(i_setunit,b_data(max(0,-i_colsize*i_col)),i_numxx) else i_numxx = i_stopc - i_strtc nread = readfunc(0,-i_setunit,i_strtc,i_numxx,b_data(max(0,-i_colsize*i_col))) end if #else i_strtc = i_setshdr + i_setrhdr + i_setchdr + (i_row)*(i_rowsize) & + (max(0,i_col*i_colsize)) i_stopc = i_strtc + min(i_num,i_setcols-i_col)*i_colsize if (i_setunit .gt. 0) then nseek = ioseek(i_setunit,i_strtc,0) if (nseek .ne. i_strtc) write(6,*) 'nseek<>i_strtc ',nseek,i_strtc i_numxx = i_stopc - i_strtc nread = ioread(i_setunit,b_data(max(0,-i_colsize*i_col)),i_numxx) else i_numxx = i_stopc - i_strtc nread = readfunc(0,-i_setunit,i_strtc,i_numxx,b_data(max(0,-i_colsize*i_col))) end if #endif if (nread .ne. i_numxx) write(6,*) 'nread<>i_numxx ',nread,i_numxx do i = 0, i_num-1 if (i+i_col .ge. 0 .and. i+i_col .lt. i_setcols) then i_pos = i*i_colsize if (i_checknul(i_setvbyt(i_setvfmt),b_data(i_pos),b_setvnul) .eq. 0) ! Data not flagged as bad & then r_data(i) = r_cnvrtdat(i_setvfmt,i_setvend,b_data(i_pos)) if (r_data(i) .eq. r_data(i)) then ! Check if valid number r_data(i) = r_setvmlt*r_data(i)+r_setvadr i_data(i) = 0 if (r_setvmax .gt. r_setvmin) then ! check for bad data outside range if (r_data(i) .lt. r_setvmin .or. r_data(i) .gt. r_setvmax) then ! bad data i_data(i) = 1 end if else ! Check for bad data within range if (r_data(i) .le. r_setvmin .and. r_data(i) .ge. r_setvmax) then ! bad data i_data(i) = 1 end if end if else ! NaN or something i_data(i) = 5 end if else r_data(i) = 0 i_data(i) = 2 end if else r_data(i) = 0 i_data(i) = 3 end if c write(6,*) 'r_data=',r_data(i),i,i_row,i_col,i_strtc,i_numxx end do if (i_setvfmt .lt. 0) then do i = 0, i_num-1 r_data2(i) = r_data(i) i_data2(i) = i_data(i) end do do i = 0, i_num-1 i_ll=max(0,i-1) i_hh=min(i_num-1,i+1) if (i_data2(i_ll) .eq. 0 .and. i_data2(i_hh) .eq. 0) then i_data(i)=0 r_data(i)=(r_data2(i_hh)-r_data2(i_ll))/(i_hh-i_ll) else i_data(i)=1 r_data(i)=0 end if end do end if else do i=0,i_num-1 r_data(i) = 0 i_data(i) = 3 end do end if return end #ifdef IO64 integer*8 function i_eight(i_value4) implicit none integer*4 i_value4 i_eight=i_value4 return end #else integer*4 function i_eight(i_value4) implicit none integer*4 i_value4 i_eight=i_value4 return end #endif real*4 function r_cnvrtdat(i_fmt,i_end,b_data) implicit none integer*4 i integer*4 i_fmt integer*4 i_end byte b_data(16) byte b_value(16) integer*2 i_value2(8) integer*4 i_value4(4) real*4 r_value4(4) real*8 r_value8(2) real*4 r_val real*8 r_realval real*8 r_imagval equivalence(b_value,i_value2) equivalence(b_value,i_value4) equivalence(b_value,r_value4) equivalence(b_value,r_value8) r_val=0 goto (10,20,30,40,50,60,70,80,90,100,110,120,130,140,150), abs(i_fmt)+1 stop 'Format not recognized in r_cnvrtdat' 10 continue ! byte r_val = b_data(1) if (r_val .lt. 0.) r_val = r_val + 256 goto 200 20 continue ! integer*1 r_val = b_data(1) if (r_val .gt. 127.) r_val = r_val - 256 goto 200 30 continue ! integer*2 if (i_end .gt. 0) then b_value(1) = b_data(1) b_value(2) = b_data(2) else b_value(1) = b_data(2) b_value(2) = b_data(1) end if r_val = i_value2(1) goto 200 40 continue ! integer*4 if (i_end .gt. 0) then b_value(1) = b_data(1) b_value(2) = b_data(2) b_value(3) = b_data(3) b_value(4) = b_data(4) else b_value(1) = b_data(4) b_value(2) = b_data(3) b_value(3) = b_data(2) b_value(4) = b_data(1) end if r_val = i_value4(1) goto 200 50 continue ! Real*4 if (i_end .gt. 0) then b_value(1) = b_data(1) b_value(2) = b_data(2) b_value(3) = b_data(3) b_value(4) = b_data(4) else b_value(1) = b_data(4) b_value(2) = b_data(3) b_value(3) = b_data(2) b_value(4) = b_data(1) end if r_val = r_value4(1) goto 200 60 continue ! Real*8 if (i_end .gt. 0) then do i=1,8 b_value(i) = b_data(i) end do else do i=1,8 b_value(i) = b_data(9-i) end do end if r_val = r_value8(1) goto 200 70 continue ! Complex*8 Magnitude if (i_end .gt. 0) then do i=1,8 b_value(i) = b_data(i) end do else do i=1,4 b_value(i) = b_data(5-i) b_value(4+i) = b_data(9-i) end do end if r_realval = r_value4(1) r_imagval = r_value4(2) r_val = sqrt(r_realval**2+r_imagval**2) goto 200 80 continue ! Complex*8 Phase if (i_end .gt. 0) then do i=1,8 b_value(i) = b_data(i) end do else do i=1,4 b_value(i) = b_data(5-i) b_value(4+i) = b_data(9-i) end do end if if (r_value4(2) .eq. 0.0 .and. r_value4(1) .eq. 0.0) then r_val=0.0 else r_val = atan2(r_value4(2),r_value4(1)) end if goto 200 90 continue ! unsigned integer*2 i_value2(1) = 0 if (i_end .gt. 0) then b_value(1) = b_data(1) b_value(2) = b_data(2) else b_value(1) = b_data(2) b_value(2) = b_data(1) end if if (i_value2(1) .ge.0) then r_val = i_value2(1) else r_val = i_value2(1)+65536 end if goto 200 100 continue ! Stokes11 i_value2(1) = b_data(1) if (i_value2(1) .ge. 128) i_value2(1) = i_value2(1)-256 i_value2(2) = b_data(2) if (i_value2(2) .ge. 128) i_value2(2) = i_value2(2)-256 r_val = ((float(int(i_value2(2)))/254.0) + 1.5) * 2.**(i_value2(1)) goto 200 110 continue ! Complex*2 Magnitude r_value4(1) = b_data(1) r_value4(2) = b_data(2) r_val = sqrt(r_value4(1)**2+r_value4(2)**2) goto 200 120 continue ! Complex*2 Phase r_value4(1) = b_data(1) r_value4(2) = b_data(2) r_val = atan2(r_value4(2),r_value4(1)) goto 200 130 continue ! Complex*4 Magnitude if (i_end .gt. 0) then do i=1,4 b_value(i) = b_data(i) end do else do i=1,2 b_value(i) = b_data(3-i) b_value(2+i) = b_data(5-i) end do end if r_val = sqrt(float(int(i_value2(1)))**2+float(int(i_value2(2)))**2) goto 200 140 continue ! Complex*4 Phase if (i_end .gt. 0) then do i=1,4 b_value(i) = b_data(i) end do else do i=1,2 b_value(i) = b_data(3-i) b_value(2+i) = b_data(5-i) end do end if r_val = atan2(float(int(i_value2(2))),float(int(i_value2(1)))) goto 200 150 continue ! Real*4_Magnitude if (i_end .gt. 0) then b_value(1) = b_data(1) b_value(2) = b_data(2) b_value(3) = b_data(3) b_value(4) = b_data(4) else b_value(1) = b_data(4) b_value(2) = b_data(3) b_value(3) = b_data(2) b_value(4) = b_data(1) end if r_val = abs(r_value4(1)) goto 200 200 continue r_cnvrtdat = r_val return end real*4 function r_cnvrtdat_old(i_fmt,b_data) implicit none integer*4 i integer*4 i_fmt byte b_data(16) byte b_value(16) integer*2 i_value2(8) integer*4 i_value4(4) real*4 r_value4(4) real*4 r_value8(2) real*4 r_val equivalence(b_value,i_value2) equivalence(b_value,i_value4) equivalence(b_value,r_value4) equivalence(b_value,r_value8) r_val=0 if (i_fmt .lt. 0) then stop 'Format not recognized' else if (i_fmt .eq. 0) then ! byte r_value4(1) = b_data(1) if (r_value4(1) .lt. 0.) r_value4(1) = r_value4(1) + 256 r_val = r_value4(1) else if (i_fmt .eq. 1) then ! integer*1 r_value4(1) = b_data(1) if (r_value4(1) .gt. 127.) r_value4(1) = r_value4(1) - 256 r_val = r_value4(1) else if (i_fmt .eq. 2) then ! integer*2 do i=1,2 b_value(i) = b_data(i) end do r_val = i_value2(1) else if (i_fmt .eq. 3) then ! integer*4 do i=1,4 b_value(i) = b_data(i) end do r_val = i_value4(1) else if (i_fmt .eq. 4) then ! Real*4 do i=1,4 b_value(i) = b_data(i) end do r_val = r_value4(1) else if (i_fmt .eq. 5) then ! Real*8 do i=1,8 b_value(i) = b_data(i) end do r_val = r_value8(1) else if (i_fmt .eq. 6) then ! Complex Magnitude do i=1,8 b_value(i) = b_data(i) end do r_val = sqrt(r_value4(1)**2+r_value4(2)**2) else if (i_fmt .eq. 7) then ! Complex Phase do i=1,8 b_value(i) = b_data(i) end do r_val = atan2(r_value4(2),r_value4(1)) else write(6,*) 'Fmt = ',i_fmt stop 'Format not recognized in r_cnvrtdat' end if r_cnvrtdat_old = r_val return end integer*4 function i_checknul(i_byt,b_data,b_vnul) implicit none integer*4 i integer*4 i_byt integer*4 i_flg byte b_data(16) byte b_vnul(0:16) integer i_vnul if (b_vnul(0) .eq. 0) then i_flg = 0 else i_flg = 1 c write(6,*) 'b_vnul(0)=',b_vnul(0) i_vnul=b_vnul(0) if (i_vnul .lt. 0) i_vnul=i_vnul+256 do i=1,min(i_byt,int(b_vnul(0))) c write(6,*) b_data(i),b_vnul(i) if (b_data(i) .ne. b_vnul(i)) i_flg=0 end do end if i_checknul = i_flg return end