diff --git a/contrib/mdx/src/graphx_mdx.c b/contrib/mdx/src/graphx_mdx.c old mode 100755 new mode 100644 index e439fcbf7..4dec839a5 --- a/contrib/mdx/src/graphx_mdx.c +++ b/contrib/mdx/src/graphx_mdx.c @@ -1,15 +1,15 @@ -/* +/* -Copyright [year created], by the California Institute of Technology. -ALL RIGHTS RESERVED. United States Government Sponsorship acknowledged. -Any commercial use must be negotiated with the Office of Technology +Copyright [year created], by the California Institute of Technology. +ALL RIGHTS RESERVED. United States Government Sponsorship acknowledged. +Any commercial use must be negotiated with the Office of Technology Transfer at the California Institute of Technology. -This software may be subject to U.S. export control laws and regulations. -By accepting this document, the user agrees to comply with all applicable -U.S. export laws and regulations. User has the responsibility to obtain -export licenses, or other export authority as may be required before -exporting such information to foreign countries or providing access to +This software may be subject to U.S. export control laws and regulations. +By accepting this document, the user agrees to comply with all applicable +U.S. export laws and regulations. User has the responsibility to obtain +export licenses, or other export authority as may be required before +exporting such information to foreign countries or providing access to foreign persons. @@ -27,11 +27,11 @@ here insofar as such code may exist in this Software. #include #include -/* +/* #include Use these if no motif -#include +#include */ -#include +#include #include #include #include @@ -41,19 +41,18 @@ here insofar as such code may exist in this Software. #include #include #include -#include #include #include /* for popup window only */ -/* for VAX -struct descriptor +/* for VAX +struct descriptor { unsigned short length; unsigned char data_type, dsc_class; char *string_ptr; }; */ - + #define MAX_COLORS 256 #define SGImode @@ -74,23 +73,23 @@ const char icon_bits[] = { 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00}; /* Global variables */ -Display *dgx; -GC gc; -XtAppContext app_context; -Window root; +Display *dgx; +GC gc; +XtAppContext app_context; +Window root; Window top[6]; -Window wgx[321]; -Window fgx[321]; -Window lgx[321]; -Widget scrl[321]; -Widget labl[321]; -Widget draw[321]; -Widget form[321]; +Window wgx[321]; +Window fgx[321]; +Window lgx[321]; +Widget scrl[321]; +Widget labl[321]; +Widget draw[321]; +Widget form[321]; XmString a_llll[321]; Widget formy; -XEvent event; -Pixmap icon, disparity; -Colormap cmap; +XEvent event; +Pixmap icon, disparity; +Colormap cmap; XVisualInfo *visualList; char b_bswap[4]; int *i_bswap; @@ -107,10 +106,10 @@ int i_gmaxg, i_gmltg; int i_bmaxb, i_bmltb; int i_init = 0; int i_app = 0; -int i_ctype = 0; +int i_ctype = 0; int i_clrs = 0; -int screen; -int i_ctble; +int screen; +int i_ctble; int allocated; int i_push = 0; int i_db; @@ -119,17 +118,17 @@ int i_mxxx; int i_myyy; int i_message = 0; char a_message[1600]; -unsigned char red[MAX_COLORS], green[MAX_COLORS], blue[MAX_COLORS]; -unsigned char rred[MAX_COLORS], ggreen[MAX_COLORS], bblue[MAX_COLORS]; +unsigned char red[MAX_COLORS], green[MAX_COLORS], blue[MAX_COLORS]; +unsigned char rred[MAX_COLORS], ggreen[MAX_COLORS], bblue[MAX_COLORS]; Widget gftop; Widget ewtop[10]={0, 0, 0, 0, 0, 0, 0, 0, 0, 0}; /* Local functions */ -static void Button_quit(); +static void Button_quit(Widget w, Pixmap free, XmAnyCallbackStruct *data); static void alo_colors(); static void put_colors(); -void read_events(); -int myhandler(); +void read_events(); +int myhandler(Display *display, XErrorEvent *myerr); @@ -138,7 +137,7 @@ int myhandler(); #include /* For: file window ***********************************************************************/ -char ident[]=" Graphx v79.0 February 16, 2011 "; +char ident[]=" Graphx v80.0 April 30, 2014 "; #include #include @@ -154,8 +153,10 @@ typedef struct Widget widget; } selectData; -void closeCallBack (); -void okCallBack (); +void closeCallBack (Widget widgy, XtPointer client_info, XtPointer call_info); +// void closeCallBack (); +void okCallBack (Widget widgy, XtPointer client_info, XmFileSelectionBoxCallbackStruct *call_info); +//void okCallBack(); /*------------------------------------------------------------- ** Global Variables @@ -168,47 +169,49 @@ static XmStringCharSet charset = (XmStringCharSet) XmSTRING_DEFAULT_CHARSET; /*************************************************************************/ #ifdef SGI -int version_gx_() +void version_gpx_( char *gpx_version, size_t length ) #endif #ifdef SUN -int version_gx_() +void version_gpx_( char *gpx_version, size_t length ) #endif #ifdef M10 -int version_gx__() +void version_gpx__( char *gpx_version, size_t length ) #endif #if defined(HP) || defined(_linux) -int version_gx() +void version_gpx( char *gpx_version, size_t length ) #endif - -{ int i_version; - - i_version=79; - return(i_version); - +{ + strcpy( gpx_version," 82.0 07-Mar-2025" ); + return; } /*************************************************************************/ #ifdef SGI void get_colorrgb_(a_color,i_color) + char *a_color; + int i_color[]; #endif #ifdef SUN -void get_colorrgb_(a_color,i_color) +void get_colorrgb_(char *a_color, int i_color[]); +void get_colorrgb_(char *a_color, int i_color[]) #endif #ifdef M10 void get_colorrgb__(a_color,i_color) + char *a_color; + int i_color[]; #endif #if defined(HP) || defined(_linux) void get_colorrgb(a_color,i_color) + char *a_color; + int i_color[]; #endif #ifdef VAX void get_colorrgb__(dsc,i_color) struct descriptor *dsc; -#else - char *a_color; -#endif - int i_color[]; +#endif + { int i; int i_cnt; @@ -217,11 +220,11 @@ void get_colorrgb__(dsc,i_color) char *a_color; a_color=dsc->string_ptr; #endif - XColor rgbcolor[1], dspcolor[1]; + XColor rgbcolor[1], dspcolor[1]; i_cnt = 0; for (i=0; i < 78; i++) { - a_lbl[i] = a_color[i]; + a_lbl[i] = a_color[i]; if (a_lbl[i] != 0 && a_lbl[i] != 32 ) i_cnt = i+1; } /* enddo */ a_lbl[i_cnt] = 0; @@ -260,28 +263,37 @@ void get_colorrgb__(dsc,i_color) /*************************************************************************/ #ifdef SGI void plot_data_(i_d,i_w,i_num,r_x,r_y) + int i_d[]; + int i_w[]; + int i_num[]; + float r_x[10000], r_y[10000]; #endif #ifdef SUN -void plot_data_(i_d,i_w,i_num,r_x,r_y) +void plot_data_(int i_d[], int i_w[], int i_num[], float r_x[10000], float r_y[10000]); +void plot_data_(int i_d[], int i_w[], int i_num[], float r_x[10000], float r_y[10000]) #endif #ifdef M10 void plot_data__(i_d,i_w,i_num,r_x,r_y) + int i_d[]; + int i_w[]; + int i_num[]; + float r_x[10000], r_y[10000]; #endif #if defined(HP) || defined(_linux) void plot_data(i_d,i_w,i_num,r_x,r_y) -#endif int i_d[]; int i_w[]; int i_num[]; float r_x[10000], r_y[10000]; +#endif { int i; int i_x1,i_y1; int i_x2,i_y2; int xr, yr; unsigned int width, height, bwr, dr; - - + + /* Scale the values according to the size of the window */ XGetGeometry(dgx, wgx[i_gx[i_d[0]][i_w[0]]], &root, &xr, &yr, &width, &height, &bwr, &dr); @@ -289,12 +301,12 @@ void plot_data(i_d,i_w,i_num,r_x,r_y) printf("plot_data2 %d\n",i_num); */ for (i = 0; i < i_num[0] - 1; i++) { - + i_x1 = (int) ((r_x[i]) * width ); i_y1 = height - (int) ((r_y[i]) * height ); i_x2 = (int) ((r_x[i+1]) * width ); i_y2 = height - (int) ((r_y[i+1]) * height ); - + if (i_x1 < 0) i_x1 = 0; if (i_x1 > width) i_x1 = width; if (i_x2 < 0) i_x2 = 0; @@ -305,7 +317,7 @@ void plot_data(i_d,i_w,i_num,r_x,r_y) if (i_y2 < 0) i_y2 = 0; if (i_y2 > height) i_y2 = height; - /* printf("hi from plot_data3\n"); + /* printf("hi from plot_data3\n"); printf("plot_data3 %d %d %d %d\n",i_x1, i_y1, i_x2, i_y2); */ XDrawLine(dgx, wgx[i_gx[i_d[0]][i_w[0]]], gc, i_x1, i_y1, i_x2, i_y2); } @@ -316,17 +328,36 @@ void plot_data(i_d,i_w,i_num,r_x,r_y) /*************************************************************************/ #ifdef SGI void display_img_(i_d,i_w, i_x, i_y, i_width, i_height, i_bpl, r_rdat, r_gdat, r_bdat) + int i_d[]; + int i_w[]; + int i_x[]; + int i_y[]; + int i_width[]; + int i_height[]; + int i_bpl[]; + float r_rdat[]; + float r_gdat[]; + float r_bdat[]; #endif #ifdef SUN -void display_img_(i_d,i_w, i_x, i_y, i_width, i_height, i_bpl, r_rdat, r_gdat, r_bdat) +void display_img_(int i_d[], int i_w[], int i_x[], int i_y[], int i_width[], int i_height[], int i_bpl[], float r_rdat[], float r_gdat[], float r_bdat[]); +void display_img_(int i_d[], int i_w[], int i_x[], int i_y[], int i_width[], int i_height[], int i_bpl[], float r_rdat[], float r_gdat[], float r_bdat[]) #endif #ifdef M10 void display_img__(i_d,i_w, i_x, i_y, i_width, i_height, i_bpl, r_rdat, r_gdat, r_bdat) + int i_d[]; + int i_w[]; + int i_x[]; + int i_y[]; + int i_width[]; + int i_height[]; + int i_bpl[]; + float r_rdat[]; + float r_gdat[]; + float r_bdat[]; #endif #if defined(HP) || defined(_linux) void display_img(i_d,i_w, i_x, i_y, i_width, i_height, i_bpl, r_rdat, r_gdat, r_bdat) -#endif - int i_d[]; int i_w[]; int i_x[]; @@ -337,114 +368,116 @@ void display_img(i_d,i_w, i_x, i_y, i_width, i_height, i_bpl, r_rdat, r_gdat, r_ float r_rdat[]; float r_gdat[]; float r_bdat[]; +#endif + { #ifdef M4 unsigned char i_nbits[16000001]; #else - unsigned char i_nbits[ 400001]; + unsigned char i_nbits[ 800001]; #endif - int i, j, k, l, m, i_bpp; + int i, j, k, l, m, i_bpp; union temp { unsigned char bbb[4]; int iii[2]; long lll[1]; }; - + union temp i_pix; - + XImage xim; + - - for (i = 0 ; i < i_height[0] ; i++) for(j = 0; j < i_width[0] ; j++) { + for (i = 0 ; i < i_height[0] ; i++) for(j = 0; j < i_width[0] ; j++) { #ifdef M4 if (i*i_width[0]+j > 4000000) { #else - if (i*i_width[0]+j > 100000) { + if (i*i_width[0]+j > 200000) { #endif printf("error - %d %d %d %d %d\n",i,j,i_width[0],i_height[0],i*i_width[0]+j); exit(0); } /* endif */ k = (int)((float)(i_rmaxr)*r_rdat[i*i_bpl[0]+j]); l = (int)((float)(i_gmaxg)*r_gdat[i*i_bpl[0]+j]); - m = (int)((float)(i_bmaxb)*r_bdat[i*i_bpl[0]+j]); - if (k < 0) { + m = (int)((float)(i_bmaxb)*r_bdat[i*i_bpl[0]+j]); + if (k < 0) { printf("rdat < 0 %d \n",k); k = 0; } /* endif */ - if (k > i_rmaxr-1) { + if (k > i_rmaxr-1) { /* printf("rdat => i_rmaxr %d %d \n",k,i_rmaxr); */ k = i_rmaxr-1; } /* endif */ - - if (l < 0) { + + if (l < 0) { printf("gdat < 0 %d \n",l); l = 0; } /* endif */ - if (l > i_gmaxg-1) { + if (l > i_gmaxg-1) { /* printf("gdat => i_gmaxg %d %d \n",l,i_gmaxg); */ l = i_gmaxg-1; } /* endif */ - - if (m < 0) { + + if (m < 0) { printf("bdat < 0 %d \n",m); m = 0; } /* endif */ - if (m > i_bmaxb-1) { + if (m > i_bmaxb-1) { /* printf("bdat => i_bmaxb %d %d \n",m,i_bmaxb); */ m = i_bmaxb-1; } /* endif */ - i_pix.lll[0] = (long)(k*i_rmltr)+(long)(l*i_gmltg)+(long)(m*i_bmltb); + i_pix.lll[0] = (long)(k*i_rmltr)+(long)(l*i_gmltg)+(long)(m*i_bmltb); - if (*i_bswap == 1) { + if (*i_bswap == 1) { if (visualList[0].depth == 8) { i_bpp = 8; - i_nbits[(i*i_width[0]+j)] = i_pix.bbb[3]; + i_nbits[(i*i_width[0]+j)] = i_pix.bbb[3]; } else if (visualList[0].depth == 15) { i_bpp = 16; - i_nbits[(i*i_width[0]+j)*2+0] = i_pix.bbb[2]; - i_nbits[(i*i_width[0]+j)*2+1] = i_pix.bbb[3]; + i_nbits[(i*i_width[0]+j)*2+0] = i_pix.bbb[2]; + i_nbits[(i*i_width[0]+j)*2+1] = i_pix.bbb[3]; } else if (visualList[0].depth == 16) { i_bpp = 16; - i_nbits[(i*i_width[0]+j)*2+0] = i_pix.bbb[2]; - i_nbits[(i*i_width[0]+j)*2+1] = i_pix.bbb[3]; + i_nbits[(i*i_width[0]+j)*2+0] = i_pix.bbb[2]; + i_nbits[(i*i_width[0]+j)*2+1] = i_pix.bbb[3]; } else if (visualList[0].depth == 24) { i_bpp = 32; - i_nbits[(i*i_width[0]+j)*4+0] = i_pix.bbb[0]; - i_nbits[(i*i_width[0]+j)*4+1] = i_pix.bbb[1]; - i_nbits[(i*i_width[0]+j)*4+2] = i_pix.bbb[2]; - i_nbits[(i*i_width[0]+j)*4+3] = i_pix.bbb[3]; + i_nbits[(i*i_width[0]+j)*4+0] = i_pix.bbb[0]; + i_nbits[(i*i_width[0]+j)*4+1] = i_pix.bbb[1]; + i_nbits[(i*i_width[0]+j)*4+2] = i_pix.bbb[2]; + i_nbits[(i*i_width[0]+j)*4+3] = i_pix.bbb[3]; } else { printf("depth not supported \n"); - } } + } } else { if (visualList[0].depth == 8) { i_bpp = 8; - i_nbits[(i*i_width[0]+j)] = i_pix.bbb[3]; + i_nbits[(i*i_width[0]+j)] = i_pix.bbb[3]; } else if (visualList[0].depth == 15) { i_bpp = 16; - i_nbits[(i*i_width[0]+j)*2+1] = i_pix.bbb[2]; - i_nbits[(i*i_width[0]+j)*2+0] = i_pix.bbb[3]; + i_nbits[(i*i_width[0]+j)*2+1] = i_pix.bbb[2]; + i_nbits[(i*i_width[0]+j)*2+0] = i_pix.bbb[3]; } else if (visualList[0].depth == 16) { i_bpp = 16; - i_nbits[(i*i_width[0]+j)*2+1] = i_pix.bbb[2]; - i_nbits[(i*i_width[0]+j)*2+0] = i_pix.bbb[3]; + i_nbits[(i*i_width[0]+j)*2+1] = i_pix.bbb[2]; + i_nbits[(i*i_width[0]+j)*2+0] = i_pix.bbb[3]; } else if (visualList[0].depth == 24) { i_bpp = 32; - i_nbits[(i*i_width[0]+j)*4+3] = i_pix.bbb[0]; - i_nbits[(i*i_width[0]+j)*4+2] = i_pix.bbb[1]; - i_nbits[(i*i_width[0]+j)*4+1] = i_pix.bbb[2]; - i_nbits[(i*i_width[0]+j)*4+0] = i_pix.bbb[3]; + i_nbits[(i*i_width[0]+j)*4+3] = i_pix.bbb[0]; + i_nbits[(i*i_width[0]+j)*4+2] = i_pix.bbb[1]; + i_nbits[(i*i_width[0]+j)*4+1] = i_pix.bbb[2]; + i_nbits[(i*i_width[0]+j)*4+0] = i_pix.bbb[3]; } else { printf("depth not supported \n"); + } + } } - } - } - - xim.depth = visualList[0].depth; + + xim.depth = visualList[0].depth; xim.data = (char *)i_nbits; xim.bitmap_pad = 8; xim.width = i_width[0]; @@ -456,29 +489,38 @@ void display_img(i_d,i_w, i_x, i_y, i_width, i_height, i_bpl, r_rdat, r_gdat, r_ xim.red_mask = visualList[0].red_mask; xim.green_mask = visualList[0].green_mask; xim.blue_mask = visualList[0].blue_mask; - - XPutImage(dgx, wgx[i_gx[i_d[0]][i_w[0]]], gc, &xim, 0, 0, i_x[0], i_y[0], i_width[0], i_height[0]); + + XPutImage(dgx, wgx[i_gx[i_d[0]][i_w[0]]], gc, &xim, 0, 0, i_x[0], i_y[0], i_width[0], i_height[0]); } /*************************************************************************/ #ifdef SGI void display_label_(i_d,i_w,a_string,i_center) +int i_d[]; +int i_w[]; +int i_center[]; +char a_string[255]; #endif #ifdef SUN -void display_label_(i_d,i_w,a_string,i_center) +void display_label_(int i_d[], int i_w[], char a_string[255], int i_center[]); +void display_label_(int i_d[], int i_w[], char a_string[255], int i_center[]) #endif #ifdef M10 void display_label__(i_d,i_w,a_string,i_center) +int i_d[]; +int i_w[]; +int i_center[]; +char a_string[255]; #endif #if defined(HP) || defined(_linux) void display_label(i_d,i_w,a_string,i_center) -#endif - int i_d[]; int i_w[]; int i_center[]; char a_string[255]; +#endif + { int i; int n; @@ -488,53 +530,60 @@ char a_string[255]; /* displays a string at the top of a window */ XmString motif_string; Arg args[2]; - + i_cnt = 0; for (i=0; i < 254; i++) { - a_lbl[i] = a_string[i]; + a_lbl[i] = a_string[i]; if (a_lbl[i] != 0 && a_lbl[i] != 32 ) i_cnt = i+1; } /* enddo */ a_lbl[i_cnt] = 0; motif_string = XmStringCreate((char *)a_lbl, XmSTRING_DEFAULT_CHARSET); - + if (i_db > 8-1) printf("i_center = %d\n",i_center[0]); - - n = 0; + + n = 0; XtSetArg(args[n], XmNlabelString, motif_string);n++; if (i_center[0]==1) {XtSetArg(args[n],XmNalignment,XmALIGNMENT_BEGINNING);n++;} else {XtSetArg(args[n],XmNalignment,XmALIGNMENT_CENTER);n++; } /* endif */ - + XtSetValues(labl[i_gx[i_d[0]][i_w[0]]], args, n); - XFlush(dgx); - + XFlush(dgx); + } /*************************************************************************/ char *a_lll; Widget main_windowew[10],rowcolew[10]; - + #ifdef SGI void entry_window_(i_chn,a_label,a_data) +int i_chn[1]; +char a_label[3360]; +char a_data[3360]; #endif #ifdef SUN -void entry_window_(i_chn,a_label,a_data) +void entry_window_(int i_chn[1], char a_label[3360], char a_data[3360]); +void entry_window_(int i_chn[1], char a_label[3360], char a_data[3360]) #endif #ifdef M10 void entry_window__(i_chn,a_label,a_data) +int i_chn[1]; +char a_label[3360]; +char a_data[3360]; #endif #if defined(HP) || defined(_linux) void entry_window(i_chn,a_label,a_data) -#endif - int i_chn[1]; char a_label[3360]; char a_data[3360]; +#endif + { - static char a_labels[21][160]; + static char a_labels[21][160]; static char a_datas[21][160]; static char a_smenu[21][160]; char a_title[160]; @@ -548,11 +597,12 @@ char a_data[3360]; int jjj; int nnn; Arg args[10]; - void print_result(); - void ewManager(); - void ewdsp_reset(); - - + void print_result(Widget textwin, char *label); + void ewManager(Widget textwin, XtPointer client_info, XtPointer call_info); +// void ewdsp_reset(); + void ewdsp_reset(Widget w, XtPointer client_info); + XtPointer XtPtmp; + if (i_db > 8-1) printf("inside entry_window %d\n",i_chn[0]); if (ewtop[i_chn[0]] != 0) { if (i_db > 8-1) printf("raising window to forground %d\n",i_chn[0]); @@ -565,7 +615,7 @@ char a_data[3360]; /* printf("parsing title %d\n",i_chn[0]); */ num=0; for (i=0; i<159; i++) { - a_title[i] = a_label[i]; + a_title[i] = a_label[i]; if (a_title[i] != 0 && a_title[i] != 32 ) num = i+1; } /* enddo */ /* printf("num= %d\n",num); */ @@ -575,30 +625,30 @@ char a_data[3360]; /* XtSetArg(args[n], XmNdepth, visualList[0].depth); n++; XtSetArg(args[n], XmNvisual, visualList[0].visual); n++; XtSetArg(args[n], XmNcolormap, cmap); n++; */ - + if (i_db > 7-1) printf("creating new entry window\n"); ewtop[i_chn[0]] = XtAppCreateShell(NULL,"appClass", - topLevelShellWidgetClass,dgx, - args, n); + topLevelShellWidgetClass,dgx, + args, n); /* * Create main window. */ - n = 0; - main_windowew[i_chn[0]] = XtCreateManagedWidget("main", - xmMainWindowWidgetClass, ewtop[i_chn[0]], - args, n); - XtAddCallback(main_windowew[i_chn[0]], XmNdestroyCallback, - ewdsp_reset, (XtPointer)i_chn[0]); + n = 0; + main_windowew[i_chn[0]] = XtCreateManagedWidget("main", + xmMainWindowWidgetClass, ewtop[i_chn[0]], + args, n); + memset( (void *)&XtPtmp, 0, sizeof( XtPointer ) ); memcpy( (void *)&XtPtmp, (void *)i_chn, 4 ); + XtAddCallback(main_windowew[i_chn[0]], XmNdestroyCallback, (void *)&ewdsp_reset, XtPtmp ); } /* end if */ - + if (i_db > 8-1) printf("Creating new rowcol widget %d\n",i_chn[0]); rowcolew[i_chn[0]] = XtVaCreateWidget("rowcol", xmRowColumnWidgetClass, main_windowew[i_chn[0]], NULL); - + if (i_db > 8-1) printf("Parsing lables\n"); /* for (i = 0; i < XtNumber(a_labels); i++) { */ @@ -608,20 +658,20 @@ char a_data[3360]; jjj=0; nnn=0; /* printf("i= %d\n",i); */ - + for (j=0; j<159; j++) { - a_datas[i][j] = a_data[(i*160+j)]; + a_datas[i][j] = a_data[(i*160+j)]; if (a_datas[i][j] != 0 && a_datas[i][j] != 32 ) num = j+1; - if (a_datas[i][j] != 124) { /* looks for a "|" */ - a_smenu[iii][jjj]=a_datas[i][j]; - if (a_datas[i][j] != 0 && a_datas[i][j] != 32 ) nnn = jjj+1; - jjj=jjj+1; } - else { - a_smenu[iii][nnn]=0; - iii=iii+1; - jjj=0; - nnn=0; - } /* endif */ + if (a_datas[i][j] != 124) { /* looks for a "|" */ + a_smenu[iii][jjj]=a_datas[i][j]; + if (a_datas[i][j] != 0 && a_datas[i][j] != 32 ) nnn = jjj+1; + jjj=jjj+1; } + else { + a_smenu[iii][nnn]=0; + iii=iii+1; + jjj=0; + nnn=0; + } /* endif */ } /* enddo */ a_datas[i][num] = 0; @@ -631,104 +681,107 @@ char a_data[3360]; if (i_db > 9-1) printf("a_datas[%d] = %s\n",i,a_datas[i]); num=0; for (j=0; j<159; j++) { - a_labels[i][j] = a_label[160*i+j]; + a_labels[i][j] = a_label[160*i+j]; if (a_labels[i][j] != 0 && a_labels[i][j] != 32 ) num = j+1; } /* enddo */ a_labels[i][num] = 0; if (i_db > 9-1) printf("a_labels[%d] = %s\n",i,a_labels[i]); /* printf("num of %d = %d\n",i,num); */ if (num != 0) { - formwin_e = XtVaCreateWidget("form", xmFormWidgetClass, rowcolew[i_chn[0]], - XmNfractionBase, 10, - XmNheight, 35, /* added to force correct size on mac and pc !@#$% SJS 2/5/03 */ - NULL); + formwin_e = XtVaCreateWidget("form", xmFormWidgetClass, rowcolew[i_chn[0]], + XmNfractionBase, 10, + XmNheight, 35, /* added to force correct size on mac and pc !@#$% SJS 2/5/03 */ + NULL); if (a_labels[i][0] != 124) { - labelwidgit_e = XtVaCreateManagedWidget(a_labels[i], - xmLabelGadgetClass, formwin_e, - XmNtopAttachment, XmATTACH_FORM, - XmNbottomAttachment, XmATTACH_FORM, - XmNleftAttachment, XmATTACH_FORM, - XmNrightAttachment, XmATTACH_POSITION, - XmNrightPosition, 3, - XmNalignment, XmALIGNMENT_END, - NULL); - - if (iii==0) { - - textwin = XtVaCreateManagedWidget("textwin", - xmTextFieldWidgetClass, formwin_e, - XmNrightAttachment, XmATTACH_FORM, - XmNleftAttachment, XmATTACH_POSITION, - XmNleftPosition, 4, - XmNtraversalOn, True, - XmNvalue, a_datas[i], - NULL); - + labelwidgit_e = XtVaCreateManagedWidget(a_labels[i], + xmLabelGadgetClass, formwin_e, + XmNtopAttachment, XmATTACH_FORM, + XmNbottomAttachment, XmATTACH_FORM, + XmNleftAttachment, XmATTACH_FORM, + XmNrightAttachment, XmATTACH_POSITION, + XmNrightPosition, 3, + XmNalignment, XmALIGNMENT_END, + NULL); + + if (iii==0) { + + textwin = XtVaCreateManagedWidget("textwin", + xmTextFieldWidgetClass, formwin_e, + XmNrightAttachment, XmATTACH_FORM, + XmNleftAttachment, XmATTACH_POSITION, + XmNleftPosition, 4, + XmNtraversalOn, True, + XmNvalue, a_datas[i], + NULL); + /* When user hits return, print the label+value of textwin */ - if (i_db > 9-1) printf("a_labels[%d] %d %s\n",i,&a_labels[i],a_labels[i]); - a_lll = (char *) &a_labels[i]; + if (i_db > 9-1) printf("a_labels[%d] %lu %s\n",i, (unsigned long) &a_labels[i],a_labels[i]); + a_lll = (char *) &a_labels[i]; /* XtAddCallback(textwin, XmNactivateCallback,print_result, (XtPointer)a_lll); */ - i_flag=(i_chn[0]*10000)+((i)*100)+0; - if (i_db > 9-1) printf("Adding Callback %d\n",i_flag); - XtAddCallback(textwin, XmNlosingFocusCallback,ewManager, (XtPointer)i_flag); - XtAddCallback(textwin, XmNactivateCallback,ewManager, (XtPointer)i_flag); + i_flag=(i_chn[0]*10000)+((i)*100)+0; + if (i_db > 9-1) printf("Adding Callback %d\n",i_flag); + memset( (void *)&XtPtmp, 0, sizeof( XtPointer ) ); memcpy( (void *)&XtPtmp, (void *)&i_flag, 4 ); + XtAddCallback(textwin, XmNlosingFocusCallback, ewManager, XtPtmp ); + XtAddCallback(textwin, XmNactivateCallback, ewManager, XtPtmp ); - if (i_db > 8-1) printf("a_lll = %d %s %d %d %d\n",a_lll,a_lll,*(a_lll+0),*(a_lll+1),*(a_lll+2)); + + if (i_db > 8-1) printf("a_lll = %s %s %d %d %d\n",a_lll,a_lll,*(a_lll+0),*(a_lll+1),*(a_lll+2)); XtAddCallback(textwin, XmNactivateCallback, - (XtCallbackProc)XmProcessTraversal, (XtPointer)XmTRAVERSE_NEXT_TAB_GROUP); + (void *) &(XmProcessTraversal), (XtPointer)XmTRAVERSE_NEXT_TAB_GROUP); } - - else { - - if (i_db > 8-1) printf("Creating option_menu widget. Default=%d\n",jjj); + + else { + + if (i_db > 8-1) printf("Creating option_menu widget. Default=%d\n",jjj); n = 0; pd_menu = XmCreatePulldownMenu(formwin_e, "My_Pulldown_Menu",args, n); - if (i_db > 8-1) printf("Creating submenus %d\n",iii); + if (i_db > 8-1) printf("Creating submenus %d\n",iii); - for (j=1;j 8-1) printf("adding pulldown option %d: %s\n",j, a_smenu[j]); + for (j=1;j 8-1) printf("adding pulldown option %d: %s\n",j, a_smenu[j]); /* menu_item[j] = XtVaCreateManagedWidget(a_smenu[j],xmPushButtonGadgetClass,pd_menu,NULL); */ n=0; - menu_item[j] = XmCreatePushButton(pd_menu,a_smenu[j],args,n); + menu_item[j] = XmCreatePushButton(pd_menu,a_smenu[j],args,n); XtManageChild(menu_item[j]); - XtAddCallback(menu_item[j],XmNactivateCallback, ewManager, (XtPointer)i_flag); + memset( (void *)&XtPtmp, 0, sizeof( XtPointer ) ); memcpy( (void *)&XtPtmp, (void *)&i_flag, 4 ); + XtAddCallback(menu_item[j],XmNactivateCallback, ewManager, XtPtmp ); } /* End do */ /* XtManageChild(pd_menu); */ - n = 0; - XtSetArg(args[n], XmNrightAttachment, XmATTACH_FORM); n++; - XtSetArg(args[n], XmNleftAttachment, XmATTACH_POSITION); n++; - XtSetArg(args[n], XmNleftPosition, 4); n++; - XtSetArg(args[n], XmNsubMenuId, pd_menu); n++; - XtSetArg(args[n], XmNbuttonCount, iii); n++; - XtSetArg(args[n], XmNmenuHistory, menu_item[jjj]); n++; + n = 0; + XtSetArg(args[n], XmNrightAttachment, XmATTACH_FORM); n++; + XtSetArg(args[n], XmNleftAttachment, XmATTACH_POSITION); n++; + XtSetArg(args[n], XmNleftPosition, 4); n++; + XtSetArg(args[n], XmNsubMenuId, pd_menu); n++; + XtSetArg(args[n], XmNbuttonCount, iii); n++; + XtSetArg(args[n], XmNmenuHistory, menu_item[jjj]); n++; op_menu = XmCreateOptionMenu(formwin_e,(char *)XmStringCreateSimple("Option_Menu"),args,n); + + XtManageChild(op_menu); - XtManageChild(op_menu); - - } + } } else { - labelwidgit_e = XtVaCreateManagedWidget(NULL, - xmLabelGadgetClass, formwin_e, - XmNtopAttachment, XmATTACH_FORM, - XmNbottomAttachment, XmATTACH_FORM, - XmNleftAttachment, XmATTACH_FORM, - XmNrightAttachment, XmATTACH_POSITION, - XmNrightPosition, 3, - XmNalignment, XmALIGNMENT_END, - NULL); + labelwidgit_e = XtVaCreateManagedWidget(NULL, + xmLabelGadgetClass, formwin_e, + XmNtopAttachment, XmATTACH_FORM, + XmNbottomAttachment, XmATTACH_FORM, + XmNleftAttachment, XmATTACH_FORM, + XmNrightAttachment, XmATTACH_POSITION, + XmNrightPosition, 3, + XmNalignment, XmALIGNMENT_END, + NULL); } - + XtManageChild(formwin_e); } @@ -741,22 +794,22 @@ char a_data[3360]; -void print_result(textwin, label) /* To debug entry window */ -Widget textwin; -char *label; +void print_result(Widget textwin, char *label) /* To debug entry window */ +/* Widget textwin; +char *label; */ { char *value = XmTextFieldGetString(textwin); - printf("%d %s %s\n", label, label, value); - printf("%d %d %d %d\n", label, *(label+0), *(label+1), *(label+2)); + printf("%s %s %s\n", label, label, value); + printf("%s %d %d %d\n", label, *(label+0), *(label+1), *(label+2)); XtFree(value); } /*******************************************************************/ -void ewManager(textwin, client_info, call_info) -Widget textwin; +void ewManager(Widget textwin, XtPointer client_info, XtPointer call_info) +/* Widget textwin; XtPointer client_info; -XtPointer call_info; +XtPointer call_info; */ { /* char *value = XmTextFieldGetString(textwin); */ char *value; @@ -769,42 +822,43 @@ XtPointer call_info; XEvent client_event; - i_data = (int) client_info; - i_edsp = (int)(i_data/10000); - i_exxx = (int)((i_data - (10000*i_edsp))/100); - i_eyyy = (int)((i_data - (10000*i_edsp)) - (100*i_exxx)); - - /* printf("eyyy=%d\n",i_eyyy); */ - value=" "; - if (i_eyyy == 0) value = XmTextFieldGetString(textwin); - if (i_db > 7-1) printf("Set: %d, Entry: %d, SubEntry: %d, Value: %s\n",i_edsp,i_exxx,i_eyyy,value); - + /* i_data = (int) client_info; NO ! */ + memcpy( (void *)&i_data, (void *) &client_info, 4 ); + i_edsp = (int)(i_data/10000); + i_exxx = (int)((i_data - (10000*i_edsp))/100); + i_eyyy = (int)((i_data - (10000*i_edsp)) - (100*i_exxx)); + + /* printf("eyyy=%d\n",i_eyyy); */ + value=" "; + if (i_eyyy == 0) value = XmTextFieldGetString(textwin); + if (i_db > 7-1) printf("Set: %d, Entry: %d, SubEntry: %d, Value: %s\n",i_edsp,i_exxx,i_eyyy,value); + /* printf("%d %s %s\n", label, label, value); printf("%d %d %d %d\n", label, *(label+0), *(label+1), *(label+2)); */ - i_message = i_message+1; - if(i_message==10) i_message=0; - - client_event.xclient.type = ClientMessage; - client_event.xclient.display = dgx; - client_event.xclient.window = XtWindow(textwin); - client_event.xclient.format = 32; - client_event.xclient.data.l[0] = i_edsp; - client_event.xclient.data.l[1] = i_exxx; - client_event.xclient.data.l[2] = i_eyyy; - client_event.xclient.data.l[3] = 10; - client_event.xclient.data.l[4] = i_message; + i_message = i_message+1; + if(i_message==10) i_message=0; + + client_event.xclient.type = ClientMessage; + client_event.xclient.display = dgx; + client_event.xclient.window = XtWindow(textwin); + client_event.xclient.format = 32; + client_event.xclient.data.l[0] = i_edsp; + client_event.xclient.data.l[1] = i_exxx; + client_event.xclient.data.l[2] = i_eyyy; + client_event.xclient.data.l[3] = 10; + client_event.xclient.data.l[4] = i_message; /* XSendEvent(dgx,wgx[i_gx[i_edsp][1]],False,ButtonReleaseMask,&client_event); */ /* XSendEvent(dgx,XtWindow(ewtop[i_edsp]),False,ButtonReleaseMask,&client_event); This should have worked arrrggg */ for (i=1;i<5+1;i++) { if (top[i] != 0) j=i; } + + if (i_db > 7-1) printf("j= %d\n",j); + XSendEvent(dgx,wgx[i_gx[j][1]],False,ButtonReleaseMask,&client_event); - if (i_db > 7-1) printf("j= %d\n",j); - XSendEvent(dgx,wgx[i_gx[j][1]],False,ButtonReleaseMask,&client_event); - - for (i=0;i<160;i++) {a_message[i_message*160+i] = *(value+i);} - if (i_db > 7-1) printf("message= %s\n",&a_message[i_message*160]); + for (i=0;i<160;i++) {a_message[i_message*160+i] = *(value+i);} + if (i_db > 7-1) printf("message= %s\n",&a_message[i_message*160]); /* XtFree(value); */ } @@ -812,30 +866,35 @@ XtPointer call_info; /*************************************************************************/ #ifdef SGI void get_message_(i_msg,a_msg) +int i_msg[1]; +char a_msg[160]; #endif #ifdef SUN -void get_message_(i_msg,a_msg) +void get_message_(int i_msg[1], char a_msg[160]); +void get_message_(int i_msg[1], char a_msg[160]) #endif #ifdef M10 void get_message__(i_msg,a_msg) +int i_msg[1]; +char a_msg[160]; #endif #if defined(HP) || defined(_linux) void get_message(i_msg,a_msg) -#endif - int i_msg[1]; char a_msg[160]; +#endif + { int i; int i_flag; - + i_flag = 0; for (i=0; i < 160; i++) { a_msg[i] = a_message[i_msg[0]*160+i]; a_message[i_msg[0]*160+i]=0; if(a_msg[i]==0 | i_flag == 1) { a_msg[i]=32; - i_flag = 1; + i_flag = 1; } } if (i_db > 7-1) printf("msg=%s\n",a_msg); @@ -843,13 +902,14 @@ char a_msg[160]; } -void ewdsp_reset(w, client_info) -Widget w; -XtPointer client_info; +void ewdsp_reset(Widget w, XtPointer client_info) +/* Widget w; +XtPointer client_info; */ { int idata; - - idata = (int) client_info; + + /* idata = (int) client_info; NO ! */ + memcpy( (void *)&idata, (void *) &client_info, 4 ); if (i_db > 11-1) printf("setting ewtop to 0 %d\n", idata); ewtop[idata]=0; @@ -857,49 +917,50 @@ XtPointer client_info; -void closeCallBack (widgy, client_info, call_info) -Widget widgy; /* widget id */ -XtPointer client_info; /* data from application */ -XtPointer call_info; /* data from widget class */ +void closeCallBack (Widget widgy, XtPointer client_info, XtPointer call_info) +/* Widget widgy; widget id */ +/* XtPointer client_info; data from application */ +/* XtPointer call_info; data from widget class */ { -/* XDestroyWindow(dgx,XtWindow(gftop)); */ - XtDestroyWidget(gftop); +/* XDestroyWindow(dgx,XtWindow(gftop)); */ + XtDestroyWidget(gftop); } /*************************************************************************/ -void MenuManager (widgy, client_info, call_info) -Widget widgy; /* widget id */ -XtPointer client_info; /* data from application */ -XtPointer call_info; /* data from widget class */ +void MenuManager (Widget widgy, XtPointer client_info, XtPointer call_info) +// Widget widgy; /* widget id */ +// XtPointer client_info; /* data from application */ +// XtPointer call_info; /* data from widget class */ { int i_data; XEvent client_event; - i_data = (int) client_info; - i_mdsp = (int)(i_data/100); - i_mxxx = (int)((i_data - (100*i_mdsp))/10); - i_myyy = (int)((i_data - (100*i_mdsp)) - (10*i_mxxx)); - - if (i_db > 8-1) printf("Pull Down Window Number = %d %d %d %d\n",i_data, i_mdsp, i_mxxx,i_myyy); - - client_event.xclient.type = ClientMessage; - client_event.xclient.display = dgx; - client_event.xclient.window = wgx[i_gx[i_mdsp][0]]; - client_event.xclient.format = 32; - client_event.xclient.data.l[0] = i_mdsp; - client_event.xclient.data.l[1] = i_mxxx; - client_event.xclient.data.l[2] = i_myyy; - client_event.xclient.data.l[3] = 0; - client_event.xclient.data.l[4] = 0; + /* i_data = (int) client_info; NO ! */ + memcpy( (void *)&i_data, (void *) &client_info, 4 ); + i_mdsp = (int)(i_data/100); + i_mxxx = (int)((i_data - (100*i_mdsp))/10); + i_myyy = (int)((i_data - (100*i_mdsp)) - (10*i_mxxx)); + + if (i_db > 8-1) printf("Pull Down Window Number = %d %d %d %d\n",i_data, i_mdsp, i_mxxx,i_myyy); + + client_event.xclient.type = ClientMessage; + client_event.xclient.display = dgx; + client_event.xclient.window = wgx[i_gx[i_mdsp][0]]; + client_event.xclient.format = 32; + client_event.xclient.data.l[0] = i_mdsp; + client_event.xclient.data.l[1] = i_mxxx; + client_event.xclient.data.l[2] = i_myyy; + client_event.xclient.data.l[3] = 0; + client_event.xclient.data.l[4] = 0; XSendEvent(dgx,wgx[i_gx[i_mdsp][0]],False,ButtonReleaseMask,&client_event); } /*************************************************************************/ -void ButtonManager (widgy, client_info, call_info) -Widget widgy; /* widget id */ -XtPointer client_info; /* data from application */ -XtPointer call_info; /* data from widget class */ +void ButtonManager (Widget widgy, XtPointer client_info, XtPointer call_info) +// Widget widgy; /* widget id */ +// XtPointer client_info; /* data from application */ +// XtPointer call_info; /* data from widget class */ { int i_g; /* XFontStruct *font1; */ @@ -907,22 +968,23 @@ XtPointer call_info; /* data from widget class */ int xr, yr; unsigned int width, height, bwr, dr; - i_g = (int) client_info; - - /* printf("Button Number = %d %d %d\n",i_g, i_dx[i_g], i_wx[i_g]); */ + /* i_g = (int) client_info; NO ! */ + memcpy( (void *)&i_g, (void *) &client_info, 4 ); + + /* printf("Button Number = %d %d %d\n",i_g, i_dx[i_g], i_wx[i_g]); */ - XtVaGetValues(draw[i_g],XmNfontList, &fontlist, NULL); - - /* XtVaGetValues(draw[i_gx[i_dx[i_g]][0]],XmNfontList, &fontlist, NULL); */ - - /* font1==XLoadQueryFont(dgx, "-*-courier-*-r-*--12-*"); - XmFontListCreate(font1, XmSTRING_DEFAULT_CHARSET); */ + XtVaGetValues(draw[i_g],XmNfontList, &fontlist, NULL); + + /* XtVaGetValues(draw[i_gx[i_dx[i_g]][0]],XmNfontList, &fontlist, NULL); */ + + /* font1==XLoadQueryFont(dgx, "-*-courier-*-r-*--12-*"); + XmFontListCreate(font1, XmSTRING_DEFAULT_CHARSET); */ XGetGeometry(dgx, wgx[i_g], &root, &xr, &yr, &width, &height, &bwr, &dr); - /* printf("Button width/height = %d %d \n", width, height); */ + /* printf("Button width/height = %d %d \n", width, height); */ XmStringDraw(dgx,wgx[i_g],fontlist,a_llll[i_g],gc,width/2,height/2-9,0,XmALIGNMENT_CENTER, - XmSTRING_DIRECTION_L_TO_R,NULL); + XmSTRING_DIRECTION_L_TO_R,NULL); } @@ -930,26 +992,31 @@ XtPointer call_info; /* data from widget class */ /*************************************************************************/ #ifdef SGI void gx_getfile_(a_file,i_inflag) + char a_file[120]; + int i_inflag[0]; #endif #ifdef SUN -void gx_getfile_(a_file,i_inflag) +void gx_getfile_(char a_file[120], int i_inflag[0]); +void gx_getfile_(char a_file[120], int i_inflag[0]) #endif #ifdef M10 void gx_getfile__(a_file,i_inflag) + char a_file[120]; + int i_inflag[0]; #endif #if defined(HP) || defined(_linux) -void gx_getfile(dsc,i_inflag) -#endif - +void gx_getfile(a_file,i_inflag) char a_file[120]; int i_inflag[0]; +#endif + { int n; Arg args[10]; Widget main_window, menu_bar, menu_pane, button, fsbox; - Widget cascade, temp; - XmString str1; - + Widget cascade, temp; + XmString str1; + XtPointer XtPtmp; int i; int i_cnt; @@ -960,7 +1027,7 @@ void gx_getfile(dsc,i_inflag) /* printf("i_flag in getfile = %d\n",i_flag); */ i_cnt = 0; for (i=0; i < 118; i++) { - a_lbl[i] = a_file[i]; + a_lbl[i] = a_file[i]; if (a_lbl[i] != 0 && a_lbl[i] != 32 ) i_cnt = i+1; } /* enddo */ a_lbl[i_cnt] = 0; @@ -968,77 +1035,78 @@ void gx_getfile(dsc,i_inflag) /* * Initialize the toolkit. */ - + n = 0; /* XtSetArg(args[n], XmNtitle, "Filenames"); n++; XtSetArg(args[n], XmNdepth, visualList[0].depth); n++; XtSetArg(args[n], XmNvisual, visualList[0].visual); n++; XtSetArg(args[n], XmNcolormap, cmap); n++; */ - + if (i_db > 3-1) printf("Creating shell\n"); gftop = XtAppCreateShell(NULL,"appClass", - topLevelShellWidgetClass,dgx, - args, n); + topLevelShellWidgetClass,dgx, + args, n); /* gftop = XtAppCreateShell(NULL,"appClass", - overrideShellWidgetClass,dgx, - args, n); */ + overrideShellWidgetClass,dgx, + args, n); */ if (i_db > 4-1) printf("Made top level shell\n"); - /* + /* * Create main window. - */ + */ - n = 0; - main_window = XmCreateMainWindow (gftop, "main1", args, n); - XtManageChild (main_window); + n = 0; + main_window = XmCreateMainWindow (gftop, "main1", args, n); + XtManageChild (main_window); - /* - * Create menu bar in main window. - */ + /* + * Create menu bar in main window. + */ - n = 0; - menu_bar = XmCreateMenuBar (main_window, "menu_bar", args, n); - XtManageChild (menu_bar); + n = 0; + menu_bar = XmCreateMenuBar (main_window, "menu_bar", args, n); + XtManageChild (menu_bar); - /* - * Create "Actions" pulldown menu. - */ + /* + * Create "Actions" pulldown menu. + */ - n = 0; - menu_pane = XmCreatePulldownMenu (menu_bar, "menu_pane", args, n); + n = 0; + menu_pane = XmCreatePulldownMenu (menu_bar, "menu_pane", args, n); - n = 0; - button = XmCreatePushButton (menu_pane, "Close", args, n); - XtManageChild (button); - XtAddCallback (button, XmNactivateCallback, closeCallBack, NULL); + n = 0; + button = XmCreatePushButton (menu_pane, "Close", args, n); + XtManageChild (button); + XtAddCallback (button, XmNactivateCallback, closeCallBack, NULL); - n = 0; - XtSetArg (args[n], XmNsubMenuId, menu_pane); n++; - cascade = XmCreateCascadeButton (menu_bar, "Window", args, n); - XtManageChild (cascade); + n = 0; + XtSetArg (args[n], XmNsubMenuId, menu_pane); n++; + cascade = XmCreateCascadeButton (menu_bar, "Window", args, n); + XtManageChild (cascade); - str1 = XmStringCreateLtoR ("Files", XmSTRING_DEFAULT_CHARSET); + str1 = XmStringCreateLtoR ("Files", XmSTRING_DEFAULT_CHARSET); n = 0; XtSetArg (args[n], XmNlistLabelString, str1); n++; fsbox = XmCreateFileSelectionBox (main_window, "fileselect", args, n); - XtManageChild (fsbox); + XtManageChild (fsbox); XmStringFree (str1); - XtAddCallback (fsbox, XmNokCallback, okCallBack, (XtPointer)i_flag); + memset( (void *)&XtPtmp, 0, sizeof( XtPointer ) ); memcpy( (void *)&XtPtmp, (void *)&i_flag, 4 ); + XtAddCallback (fsbox, XmNokCallback, (void *)&okCallBack, XtPtmp ); /* PS Edit added (void *)& */ - temp = XmFileSelectionBoxGetChild (fsbox, XmDIALOG_CANCEL_BUTTON); - XtUnmanageChild (temp); - temp = XmFileSelectionBoxGetChild (fsbox, XmDIALOG_HELP_BUTTON); - XtUnmanageChild (temp); + temp = XmFileSelectionBoxGetChild (fsbox, XmDIALOG_CANCEL_BUTTON); + XtUnmanageChild (temp); + temp = XmFileSelectionBoxGetChild (fsbox, XmDIALOG_HELP_BUTTON); + XtUnmanageChild (temp); /* * Set Main Window areas. */ - XmMainWindowSetAreas (main_window, menu_bar, NULL, NULL, NULL, fsbox); + XmMainWindowSetAreas (main_window, menu_bar, NULL, NULL, NULL, fsbox); /* * Realize the widget hierarchy and enter the main loop. @@ -1049,14 +1117,14 @@ void gx_getfile(dsc,i_inflag) void -okCallBack (widgy, client_info, call_info) - Widget widgy; +okCallBack (Widget widgy, XtPointer client_info, XmFileSelectionBoxCallbackStruct *call_info) +/* Widget widgy; XtPointer client_info; - XmFileSelectionBoxCallbackStruct *call_info; + XmFileSelectionBoxCallbackStruct *call_info; */ { Arg args[10]; - XmString pathstring = NULL; - XmString carraige_rtn = NULL; + XmString pathstring = NULL; + XmString carraige_rtn = NULL; XEvent client_event; int i, j; @@ -1068,98 +1136,114 @@ okCallBack (widgy, client_info, call_info) int n, stat_val; static XmStringCharSet charset = (XmStringCharSet) XmSTRING_DEFAULT_CHARSET; - char *path; + char *path; - i_data = (int) client_info; + /* i_data = (int) client_info; NO ! */ + memcpy( (void *)&i_data, (void *) &client_info, 4 ); i_edsp = 0; - value=" "; - value = XmTextFieldGetString(widgy); + value=" "; + value = XmTextFieldGetString(widgy); n = 0; - carraige_rtn = XmStringCreateLtoR ("\012\012", charset); - pathstring = XmStringConcat (call_info->value, carraige_rtn); - XmStringGetLtoR (call_info->value, charset, &path); + carraige_rtn = XmStringCreateLtoR ("\012\012", charset); + pathstring = XmStringConcat (call_info->value, carraige_rtn); + XmStringGetLtoR (call_info->value, charset, &path); XtDestroyWidget(gftop); /* this line closes file selection window */ - i_message = i_message+1; - if(i_message==10) i_message=0; + i_message = i_message+1; + if(i_message==10) i_message=0; - client_event.xclient.type = ClientMessage; - client_event.xclient.display = dgx; - client_event.xclient.format = 32; - client_event.xclient.data.l[0] = 0; - client_event.xclient.data.l[1] = 0; - client_event.xclient.data.l[2] = i_data; - client_event.xclient.data.l[3] = 12; - client_event.xclient.data.l[4] = i_message; + client_event.xclient.type = ClientMessage; + client_event.xclient.display = dgx; + client_event.xclient.format = 32; + client_event.xclient.data.l[0] = 0; + client_event.xclient.data.l[1] = 0; + client_event.xclient.data.l[2] = i_data; + client_event.xclient.data.l[3] = 12; + client_event.xclient.data.l[4] = i_message; for (i=1;i<5+1;i++) { if (top[i] != 0) j=i; } - - if (i_db > 7-1) printf("okCallBack j= %d\n",j); - XSendEvent(dgx,wgx[i_gx[j][1]],False,ButtonReleaseMask,&client_event); - - for (i=0;i<160;i++) {a_message[i_message*160+i] = *(path+i);} - if (i_db > 7-1) printf("message= %s\n",&a_message[i_message*160]); - - + + if (i_db > 7-1) printf("okCallBack j= %d\n",j); + XSendEvent(dgx,wgx[i_gx[j][1]],False,ButtonReleaseMask,&client_event); + + for (i=0;i<160;i++) {a_message[i_message*160+i] = *(path+i);} + if (i_db > 7-1) printf("message= %s\n",&a_message[i_message*160]); + + } /*************************************************************************/ #ifdef SGI void topwin_(i_w) + int i_w[]; #endif #ifdef SUN -void topwin_(i_w) +void topwin_(int i_w[]); +void topwin_(int i_w[]) #endif #ifdef M10 void topwin_(i_w) + int i_w[]; #endif #if defined(HP) || defined(_linux) void topwin(i_w) -#endif - int i_w[]; +#endif + { if (top[i_w[0]] != 0) XRaiseWindow(dgx, top[i_w[0]]); - + } /*************************************************************************/ #ifdef SGI void get_wininfo_(i_d, i_w, i_vx, i_vy, i_vw, i_vh, i_cw, i_ch,i_widget) + int i_d[]; + int i_w[]; + int i_vx[], i_vy[]; + int i_vw[], i_vh[]; + int i_cw[], i_ch[]; + int i_widget[]; #endif #ifdef SUN -void get_wininfo_(i_d, i_w, i_vx, i_vy, i_vw, i_vh, i_cw, i_ch,i_widget) +void get_wininfo_(int i_d[], int i_w[], int i_vx[], int i_vy[], int i_vw[], int i_vh[], int i_cw[], int i_ch[] , int i_widget[]); +void get_wininfo_(int i_d[], int i_w[], int i_vx[], int i_vy[], int i_vw[], int i_vh[], int i_cw[], int i_ch[] , int i_widget[]) #endif #ifdef M10 void get_wininfo__(i_d, i_w, i_vx, i_vy, i_vw, i_vh, i_cw, i_ch,i_widget) + int i_d[]; + int i_w[]; + int i_vx[], i_vy[]; + int i_vw[], i_vh[]; + int i_cw[], i_ch[]; + int i_widget[]; #endif #if defined(HP) || defined(_linux) void get_wininfo(i_d, i_w, i_vx, i_vy, i_vw, i_vh, i_cw, i_ch,i_widget) -#endif - int i_d[]; int i_w[]; int i_vx[], i_vy[]; int i_vw[], i_vh[]; int i_cw[], i_ch[]; int i_widget[]; +#endif { int xr, yr; unsigned int width, height, bwr, dr; XGetGeometry(dgx, wgx[i_gx[i_d[0]][i_w[0]]], &root, &xr, &yr, &width, &height, &bwr, &dr); - + i_vx[0] = -xr; i_vy[0] = -yr; i_cw[0] = width; @@ -1181,7 +1265,7 @@ void get_wininfo(i_d, i_w, i_vx, i_vy, i_vw, i_vh, i_cw, i_ch,i_widget) if (i_db == -21) printf("scroll bar size= %d %d %d %d\n",xr,yr,width,height); } - + i_widget[0] = i_push; } @@ -1189,23 +1273,31 @@ void get_wininfo(i_d, i_w, i_vx, i_vy, i_vw, i_vh, i_cw, i_ch,i_widget) /*************************************************************************/ #ifdef SGI void move_scroll_(i_d,i_w,i_x,i_y) + int i_d[]; + int i_w[]; + int i_x[]; + int i_y[]; #endif #ifdef SUN -void move_scroll_(i_d,i_w,i_x,i_y) +void move_scroll_(int i_d[], int i_w[], int i_x[], int i_y[]); +void move_scroll_(int i_d[], int i_w[], int i_x[], int i_y[]) #endif #ifdef M10 void move_scroll__(i_d,i_w,i_x,i_y) + int i_d[]; + int i_w[]; + int i_x[]; + int i_y[]; #endif #if defined(HP) || defined(_linux) void move_scroll(i_d,i_w,i_x,i_y) -#endif - int i_d[]; int i_w[]; int i_x[]; int i_y[]; +#endif -{ +{ Widget vsb; Widget hsb; @@ -1228,10 +1320,10 @@ void move_scroll(i_d,i_w,i_x,i_y) XmNsliderSize, &slider_size, XmNvalue, &value, NULL); - -/* + +/* printf("inc=%d, max=%d, min=%d, page=%d, slider=%d, value=%d\n", - increment,maximum,minimum,page_incr,slider_size,value); + increment,maximum,minimum,page_incr,slider_size,value); */ value=i_y[0]; @@ -1251,50 +1343,59 @@ void move_scroll(i_d,i_w,i_x,i_y) if (value < minimum) value = minimum; if (value > maximum-slider_size) value = maximum-slider_size; XmScrollBarSetValues(hsb,value,slider_size,increment,page_incr,True); - + /* The following code would change the slider positions, but not move the data properly n = 0; XtSetArg(args[n], XmNvalue, i_x[0]); n++; - XtSetValues(hsb, args, n); + XtSetValues(hsb, args, n); n = 0; XtSetArg(args[n], XmNvalue, i_y[0]); n++; - XtSetValues(vsb, args, n); + XtSetValues(vsb, args, n); xwc.x=-i_x[0]; xwc.y=-i_y[0]; - XConfigureWindow(dgx, wgx[i_gx[i_d[0]][i_w[0]]], CWX | CWY, &xwc); + XConfigureWindow(dgx, wgx[i_gx[i_d[0]][i_w[0]]], CWX | CWY, &xwc); */ - + } /*************************************************************************/ #ifdef SGI void resize_win_(i_d,i_w,i_x,i_y) + int i_d[]; + int i_w[]; + int i_x[]; + int i_y[]; #endif #ifdef SUN -void resize_win_(i_d,i_w,i_x,i_y) +void resize_win_(int i_d[], int i_w[], int i_x[], int i_y[]); +void resize_win_(int i_d[], int i_w[], int i_x[], int i_y[]) #endif #ifdef M10 void resize_win__(i_d,i_w,i_x,i_y) + int i_d[]; + int i_w[]; + int i_x[]; + int i_y[]; #endif #if defined(HP) || defined(_linux) void resize_win(i_d,i_w,i_x,i_y) -#endif - int i_d[]; int i_w[]; int i_x[]; int i_y[]; +#endif -{ - unsigned int wide; - unsigned int high; +{ + unsigned int wide; + unsigned int high; + int n; Arg args[10]; - + int maximum=30000; int minimum=100; @@ -1311,7 +1412,7 @@ void resize_win(i_d,i_w,i_x,i_y) /* xwc.width=wide; ! for some reason, this code did not update the scoll bars properly xwc.height=high; XConfigureWindow(dgx, wgx[i_gx[i_d[0]][i_w[0]]], CWWidth | CWHeight, &xwc); */ - + /* XResizeWindow(dgx,wgx[i_gx[i_d[0]][i_w[0]]],wide,high); */ /* XtResizeWidget(draw[i_gx[i_d[0]][i_w[0]]],wide,high); */ @@ -1322,29 +1423,37 @@ void resize_win(i_d,i_w,i_x,i_y) XtSetValues(draw[i_gx[i_d[0]][i_w[0]]], args, n); XFlush(dgx); - + } /*************************************************************************/ #ifdef SGI void set_button_shadow_(i_d,i_w,i_shadow,i_debug) + int i_d[]; + int i_w[]; + int i_shadow[]; + int i_debug[]; #endif #ifdef SUN -void set_button_shadow_(i_d,i_w,i_shadow,i_debug) +void set_button_shadow_(int i_d[], int i_w[], int i_shadow[], int i_debug[]); +void set_button_shadow_(int i_d[], int i_w[], int i_shadow[], int i_debug[]) #endif #ifdef M10 void set_button_shadow__(i_d,i_w,i_shadow,i_debug) + int i_d[]; + int i_w[]; + int i_shadow[]; + int i_debug[]; #endif #if defined(HP) || defined(_linux) void set_button_shadow(i_d,i_w,i_shadow,i_debug) -#endif - int i_d[]; int i_w[]; int i_shadow[]; int i_debug[]; +#endif -{ +{ int n; Arg args[10]; @@ -1357,96 +1466,112 @@ void set_button_shadow(i_d,i_w,i_shadow,i_debug) XtSetArg(args[n], XmNshadowType, XmSHADOW_OUT); n++; if (i_debug[0] > 7-1) printf("setting shadow out %d %d\n",i_d[0],i_w[0]); } - - XtSetValues(draw[i_gx[i_d[0]][i_w[0]]], args, n); - -/* if (i_tx[i_g] == 0) { - XtVaSetValues(draw[i_g],XmNshadowType, XmSHADOW_IN,NULL); - } - else { - XtVaSetValues(draw[i_g],XmNshadowType, XmSHADOW_OUT,NULL); - i_tx[i_g]=1; + + XtSetValues(draw[i_gx[i_d[0]][i_w[0]]], args, n); + +/* if (i_tx[i_g] == 0) { + XtVaSetValues(draw[i_g],XmNshadowType, XmSHADOW_IN,NULL); + } + else { + XtVaSetValues(draw[i_g],XmNshadowType, XmSHADOW_OUT,NULL); + i_tx[i_g]=1; } */ - + } /*************************************************************************/ #ifdef SGI void move_win_(i_d,i_w,i_x,i_y) + int i_d[]; + int i_w[]; + int i_x[]; + int i_y[]; #endif #ifdef SUN -void move_win_(i_d,i_w,i_x,i_y) +void move_win_(int i_d[], int i_w[], int i_x[], int i_y[]); +void move_win_(int i_d[], int i_w[], int i_x[], int i_y[]) #endif #ifdef M10 void move_win__(i_d,i_w,i_x,i_y) + int i_d[]; + int i_w[]; + int i_x[]; + int i_y[]; #endif #if defined(HP) || defined(_linux) void move_win(i_d,i_w,i_x,i_y) -#endif - int i_d[]; int i_w[]; int i_x[]; int i_y[]; +#endif -{ +{ XWindowChanges xwc; xwc.x=-i_x[0]; xwc.y=-i_y[0]; XConfigureWindow(dgx, wgx[i_gx[i_d[0]][i_w[0]]], CWX | CWY, &xwc); - + } /*************************************************************************/ #ifdef SGI void destroy_display_(i_d) + int i_d[]; #endif #ifdef SUN -void destroy_display_(i_d) +void destroy_display_(int i_d[]); +void destroy_display_(int i_d[]) #endif #ifdef M10 void destroy_display__(i_d) + int i_d[]; #endif #if defined(HP) || defined(_linux) void destroy_display(i_d) + int i_d[]; #endif - int i_d[]; -{ +{ XUnmapWindow(dgx,top[i_d[0]]); - XDestroyWindow(dgx,top[i_d[0]]); + XDestroyWindow(dgx,top[i_d[0]]); } /*************************************************************************/ #ifdef SGI void getevent_(i_flg,i_event) + int i_flg[]; + int i_event[10]; #endif #ifdef SUN -void getevent_(i_flg,i_event) +void getevent_(int i_flg[], int i_event[10]); +void getevent_(int i_flg[], int i_event[10]) #endif #ifdef M10 void getevent_(i_flg,i_event) + int i_flg[]; + int i_event[10]; #endif #if defined(HP) || defined(_linux) void getevent(i_flg,i_event) -#endif - int i_flg[]; int i_event[10]; +#endif + { XEvent report; int i; int i_loop; - char buffer[40]; - int bufsize = 40; - KeySym keysym; - XComposeStatus compose; + char buffer[40]; + int bufsize = 40; + KeySym keysym; + XComposeStatus compose; i_event[0] = 0; i_event[1] = 0; @@ -1456,7 +1581,7 @@ void getevent(i_flg,i_event) i_event[5] = 0; i_event[6] = 0; i_event[7] = 0; - if (i_flg[0] == 0 | XPending(dgx) ) { + if ( (i_flg[0] == 0) | XPending(dgx) ) { i_loop = 0; while(i_loop == 0) { XtAppNextEvent(app_context,&report); @@ -1489,7 +1614,7 @@ void getevent(i_flg,i_event) /* } */ /* end case */ switch (report.type) { case Expose: - for(i=1; i 9-1) printf("report=ClientMessage %d %d %d\n",report.xclient.data.l[0], + if (i_db > 9-1) printf("report=ClientMessage %ld %ld %ld\n",report.xclient.data.l[0], report.xclient.data.l[1],report.xclient.data.l[2]); i_event[0] = report.xclient.data.l[0]; i_event[1] = 0; @@ -1690,26 +1815,31 @@ void getevent(i_flg,i_event) } /* endif */ XtDispatchEvent(&report); if (i_flg[0] == 1 && !XPending(dgx)) i_loop = 1; - } /* end while */ - } /* end if */ + } /* end while */ + } /* end if */ } /*************************************************************************/ #ifdef SGI void clear_win_(i_d,i_w) + int i_d[]; + int i_w[]; #endif #ifdef SUN -void clear_win_(i_d,i_w) +void clear_win_(int i_d[], int i_w[]); +void clear_win_(int i_d[], int i_w[]) #endif #ifdef M10 void clear_win__(i_d,i_w) + int i_d[]; + int i_w[]; #endif #if defined(HP) || defined(_linux) void clear_win(i_d,i_w) -#endif - int i_d[]; int i_w[]; +#endif + { XClearWindow(dgx, wgx[i_gx[i_d[0]][i_w[0]]]); } @@ -1717,18 +1847,23 @@ void clear_win(i_d,i_w) /*************************************************************************/ #ifdef SGI void get_dialog_(a_msg,a_rsp) + char a_msg[]; + char a_rsp[]; #endif #ifdef SUN -void get_dialog_(a_msg,a_rsp) +void get_dialog_(char a_msg[], char a_rsp[]); +void get_dialog_(char a_msg[], char a_rsp[]) #endif #ifdef M10 void get_dialog__(a_msg,a_rsp) + char a_msg[]; + char a_rsp[]; #endif #if defined(HP) || defined(_linux) void get_dialog(a_msg,a_rsp) -#endif char a_msg[]; char a_rsp[]; +#endif { XEvent report; @@ -1736,19 +1871,19 @@ void get_dialog(a_msg,a_rsp) int i_loop; static Window pop_win; - char buffer[40]; - int bufsize; - int start_x,start_y; - KeySym keysym; - XComposeStatus compose; - int count; - unsigned int pop_width, pop_height; - char a_lbl[40]; + char buffer[40]; + int bufsize; + int start_x,start_y; + KeySym keysym; + XComposeStatus compose; + int count; + unsigned int pop_width, pop_height; + char a_lbl[40]; int x,y; - int length; + int length; int i_cnt; int i_event[10]; - GC def_gc; + GC def_gc; i_event[0] = 0; i_event[1] = 0; @@ -1767,7 +1902,7 @@ void get_dialog(a_msg,a_rsp) i_cnt=0; for (j=0; j < 39; j++) { a_rsp[j] = 0; - a_lbl[j] = a_msg[j]; + a_lbl[j] = a_msg[j]; if (a_lbl[j] != 0 && a_lbl[j] != 32 ) i_cnt = j+1; } /* enddo */ if (i_cnt == 40) i_cnt = 39; @@ -1776,15 +1911,15 @@ void get_dialog(a_msg,a_rsp) pop_width = 300; pop_height = 75; - pop_win = XCreateSimpleWindow(dgx, root,x,y,pop_width,pop_height, - 3,BlackPixel(dgx,screen),WhitePixel(dgx,screen)); - + pop_win = XCreateSimpleWindow(dgx, root,x,y,pop_width,pop_height, + 3,BlackPixel(dgx,screen),WhitePixel(dgx,screen)); + def_gc = DefaultGC(dgx, screen); /* Calculate starting position of string in window */ start_x = 5; start_y = 20; - XSelectInput(dgx,pop_win,ExposureMask | KeyPressMask ); + XSelectInput(dgx,pop_win,ExposureMask | KeyPressMask ); XMapWindow(dgx,pop_win); @@ -1793,14 +1928,14 @@ void get_dialog(a_msg,a_rsp) XNextEvent(dgx,&report); switch (report.type) { case Expose: - if (report.xexpose.window == pop_win) { + if (report.xexpose.window == pop_win) { XDrawString(dgx,pop_win,def_gc,start_x,start_y ,a_lbl,strlen(a_lbl)); XDrawString(dgx,pop_win,def_gc,start_x,start_y+15,a_rsp,strlen(a_rsp)); } break; case KeyPress: - if (report.xkey.window == pop_win) { - count = XLookupString(&report.xkey, buffer,bufsize,&keysym,&compose); + if (report.xkey.window == pop_win) { + count = XLookupString(&report.xkey, buffer,bufsize,&keysym,&compose); if (count == 40) count=39; buffer[count]=0; if ((keysym == XK_Return) || (keysym == XK_KP_Enter) || @@ -1816,12 +1951,13 @@ void get_dialog(a_msg,a_rsp) else if ((keysym >= XK_Shift_L) && (keysym <= XK_Hyper_R)); /* Do Nothing because it's a modifier key */ else if ((keysym >= XK_F1) && (keysym <= XK_F35)) { - if (buffer == NULL) printf("Unmapped function key\n"); +// if (buffer == NULL) printf("Unmapped function key\n"); /* PS Edit... apparently this is always true */ + if (0==0) printf("Unmapped function key\n"); /* PS Edit.. just making it get rid of warning from above */ else if ((strlen(a_rsp) + strlen(buffer)) >= 40) { XBell(dgx,100); } else { strcat(a_rsp,buffer); } } else if ((keysym == XK_BackSpace) || (keysym == XK_Delete)) { if ((length = strlen(a_rsp)) > 0) { - a_rsp[length - 1] = (char)NULL; + a_rsp[length - 1] = '\0'; XClearWindow(dgx,pop_win); } else { XBell(dgx,100); } } @@ -1832,7 +1968,7 @@ void get_dialog(a_msg,a_rsp) XDrawString(dgx,pop_win,def_gc,start_x,start_y ,a_lbl,strlen(a_lbl)); XDrawString(dgx,pop_win,def_gc,start_x,start_y+15,a_rsp,strlen(a_rsp)); break; - + } break; default: @@ -1849,18 +1985,18 @@ void get_dialog(a_msg,a_rsp) } /* endif */ } /* endif */ XtDispatchEvent(&report); - } /* end while */ - + } /* end while */ + for (j=0; j < 38; j++) { if (a_rsp[j] == 0 ) a_rsp[j]=32; } /* enddo */ } /*************************************************************************/ -int myhandler (display, myerr) -Display *display; -XErrorEvent *myerr; -{ +int myhandler (Display *display,XErrorEvent *myerr) +/* Display *display; +XErrorEvent *myerr; */ +{ char msg[80]; char ttt[80]; strcpy(ttt ,"BadDrawable (invalid Pixmap or Window parameter)"); @@ -1876,17 +2012,40 @@ XErrorEvent *myerr; /*************************************************************************/ #ifdef SGI int init_gx_(i_wxi,i_typ,a_labl,i_wxs,i_wys,i_frx,i_fry,a_menu,a_lcolor,i_cin,i_din) + int i_wxi[]; + int i_typ[]; + int i_wxs[]; + int i_wys[]; + int i_frx[]; + int i_fry[]; + int i_cin[]; + int i_din[]; + + char a_menu[]; + char a_labl[]; + char a_lcolor[]; #endif #ifdef SUN -int init_gx_(i_wxi,i_typ,a_labl,i_wxs,i_wys,i_frx,i_fry,a_menu,a_lcolor,i_cin,i_din) +int init_gx_(int i_wxi[], int i_typ[], char a_labl[], int i_wxs[], int i_wys[], int i_frx[], int i_fry[], char a_menu[], char a_lcolor[], int i_cin[], int i_din[]); +int init_gx_(int i_wxi[], int i_typ[], char a_labl[], int i_wxs[], int i_wys[], int i_frx[], int i_fry[], char a_menu[], char a_lcolor[], int i_cin[], int i_din[]) #endif #ifdef M10 int init_gx__(i_wxi,i_typ,a_labl,i_wxs,i_wys,i_frx,i_fry,a_menu,a_lcolor,i_cin,i_din) + int i_wxi[]; + int i_typ[]; + int i_wxs[]; + int i_wys[]; + int i_frx[]; + int i_fry[]; + int i_cin[]; + int i_din[]; + + char a_menu[]; + char a_labl[]; + char a_lcolor[]; #endif #if defined(HP) || defined(_linux) int init_gx(i_wxi,i_typ,a_labl,i_wxs,i_wys,i_frx,i_fry,a_menu,a_lcolor,i_cin,i_din) -#endif - int i_wxi[]; int i_typ[]; int i_wxs[]; @@ -1899,16 +2058,18 @@ int init_gx(i_wxi,i_typ,a_labl,i_wxs,i_wys,i_frx,i_fry,a_menu,a_lcolor,i_cin,i_d char a_menu[]; char a_labl[]; char a_lcolor[]; -{ +#endif + +{ Widget toplevel, maintoplevel; Widget main_dx, form1, pane; - Widget temp; + Widget temp; Widget menu_bar, menu_pane, button, cascade; - + Arg args[15]; int n = 1; - char *ww1[2]; - char ww2[80]; + char *ww1[2]; + char ww2[80]; char a_lbl[1000]; char a_clr[1000]; char a_title[20]; @@ -1930,9 +2091,9 @@ int init_gx(i_wxi,i_typ,a_labl,i_wxs,i_wys,i_frx,i_fry,a_menu,a_lcolor,i_cin,i_d int *depths; int default_depth; Visual *default_visual; - Status rc; /* return status of various Xlib functions. */ + Status rc; /* return status of various Xlib functions. */ XColor red, brown, blue, yellow, green, linec; - static char *visual_class[] = { + static char *visual_class[] = { "StaticGray", "GrayScale", "StaticColor", @@ -1940,16 +2101,17 @@ int init_gx(i_wxi,i_typ,a_labl,i_wxs,i_wys,i_frx,i_fry,a_menu,a_lcolor,i_cin,i_d "TrueColor", "DirectColor" }; - + XErrorHandler defaulterr; Widget vsb; Widget hsb; - + XtPointer XtPtmp; + ww1[0] = &ww2[0]; strcpy (ww2,"Graphx"); - + i_db = i_din[0]; - + if (i_db > 3-1) printf("Start.\n"); /* Initialize the intrinsics */ @@ -1957,23 +2119,23 @@ int init_gx(i_wxi,i_typ,a_labl,i_wxs,i_wys,i_frx,i_fry,a_menu,a_lcolor,i_cin,i_d if (i_init == 0) { i_init = 1; i_bswap= (int *)&b_bswap; - b_bswap[0]=0; - b_bswap[1]=0; - b_bswap[2]=0; - b_bswap[3]=1; - if (*i_bswap == 1) { - if (i_db > 4-1) printf("This Machine is Big Endian\n"); } - else { - if (i_db > 4-1) printf("This Machine is Little Endian\n"); - if (i_db > 4-1) printf("i_bswap=%d\n",*i_bswap); - } + b_bswap[0]=0; + b_bswap[1]=0; + b_bswap[2]=0; + b_bswap[3]=1; + if (*i_bswap == 1) { + if (i_db > 4-1) printf("This Machine is Big Endian\n"); } + else { + if (i_db > 4-1) printf("This Machine is Little Endian\n"); + if (i_db > 4-1) printf("i_bswap=%d\n",*i_bswap); + } i_clrs = i_cin[0]; if (i_clrs < 0) i_clrs = 0; if (i_clrs > 256) i_clrs = 256; if (i_db > 1-1) printf("Initializing X toolkit\n"); i_cnt[0]=0; for (j=0; j < 78; j++) { - a_lbl[j] = a_labl[(j)]; + a_lbl[j] = a_labl[(j)]; if (a_lbl[j] != 0 && a_lbl[j] != 32 ) i_cnt[0] = j+1; } /* enddo */ a_lbl[i_cnt[0]] = 0; @@ -2001,7 +2163,7 @@ int init_gx(i_wxi,i_typ,a_labl,i_wxs,i_wys,i_frx,i_fry,a_menu,a_lcolor,i_cin,i_d printf(" Depth(%d)=%d\n",j,depths[j]); } /* enddo */ } /* enddo */ - + default_depth = DefaultDepth(dgx,screen); if (i_db > 3-1) printf("Default Depth = %d\n",default_depth); @@ -2018,24 +2180,24 @@ int init_gx(i_wxi,i_typ,a_labl,i_wxs,i_wys,i_frx,i_fry,a_menu,a_lcolor,i_cin,i_d printf(" \n"); printf("Number of visuals: %d\n",visualsMatched); for (j=0; j 2-1) printf("Using visual ID=%d size=%d bpc=%d depth=%d type=%s\n", + if (i_db > 2-1) printf("Using visual ID=%lu size=%d bpc=%d depth=%d type=%s\n", visualList[0].visualid, visualList[0].colormap_size, visualList[0].bits_per_rgb, @@ -2084,21 +2246,21 @@ int init_gx(i_wxi,i_typ,a_labl,i_wxs,i_wys,i_frx,i_fry,a_menu,a_lcolor,i_cin,i_d i_bmltb = i_bmltb*2; } } - + i_rmaxr=i_rmaxr+1; i_gmaxg=i_gmaxg+1; i_bmaxb=i_bmaxb+1; - + if (i_db > 4-1) { - printf(" red_mask=%d\n",visualList[0].red_mask); - printf(" grn_mask=%d\n",visualList[0].green_mask); - printf(" blu_mask=%d\n",visualList[0].blue_mask); + printf(" red_mask=%lu\n",visualList[0].red_mask); + printf(" grn_mask=%lu\n",visualList[0].green_mask); + printf(" blu_mask=%lu\n",visualList[0].blue_mask); printf("red max,mult = %d %d\n", i_rmaxr,i_rmltr); printf("grn max,mult = %d %d\n", i_gmaxg,i_gmltg); printf("blu max,mult = %d %d\n", i_bmaxb,i_bmltb); } - defaulterr=XSetErrorHandler(myhandler); + defaulterr=XSetErrorHandler(myhandler); /*XSetErrorHandler(defaulterr);*/ i_ctble = visualList[0].colormap_size; @@ -2110,17 +2272,17 @@ int init_gx(i_wxi,i_typ,a_labl,i_wxs,i_wys,i_frx,i_fry,a_menu,a_lcolor,i_cin,i_d cmap = XDefaultColormap(dgx, screen); } else { */ - if (i_db > 3-1) printf("creating private color map\n"); + if (i_db > 3-1) printf("creating private color map\n"); cmap = XCreateColormap(dgx,RootWindow(dgx,screen),visualList[0].visual,AllocNone); /* } -*/ +*/ } } /* endif */ - if (i_db > 5-1) printf("dgx = %d \n",dgx); - if (i_db > 5-1) printf("root = %d\n",root); - - if (i_wxi[0] == 0) return(0); + if (i_db > 5-1) printf("dgx = %lu \n", (unsigned long) dgx); + if (i_db > 5-1) printf("root = %lu\n",root); + + if (i_wxi[0] == 0) return(0); if (i_wxi[0] > 10) i_wxi[0] = 10; if (i_wxs[0] < 1 ) i_wxs[0] = 500; if (i_wys[0] < 1 ) i_wys[0] = 400; @@ -2138,8 +2300,8 @@ int init_gx(i_wxi,i_typ,a_labl,i_wxs,i_wys,i_frx,i_fry,a_menu,a_lcolor,i_cin,i_d XtSetArg(args[n], XmNheight, i_wys[0]); n++; XtSetArg(args[n], XmNdepth, visualList[0].depth); n++; XtSetArg(args[n], XmNvisual, visualList[0].visual); n++; - XtSetArg(args[n], XmNcolormap, cmap); n++; - + XtSetArg(args[n], XmNcolormap, cmap); n++; + i_d=0; i_app = i_app+1; for (i=1; i < 5+1; i++) { @@ -2157,41 +2319,41 @@ int init_gx(i_wxi,i_typ,a_labl,i_wxs,i_wys,i_frx,i_fry,a_menu,a_lcolor,i_cin,i_d if (i_db > 3-1) printf("creating shell %d %d\n",i_app, i_d); toplevel = XtAppCreateShell(NULL,"appClass", - topLevelShellWidgetClass,dgx, - args, n); + topLevelShellWidgetClass,dgx, + args, n); n = 0; XtSetArg(args[n], XmNsashWidth, 0); n++; XtSetArg(args[n], XmNsashHeight, 0); n++; XtSetArg(args[n], XmNdepth, visualList[0].depth); n++; XtSetArg(args[n], XmNvisual, visualList[0].visual); n++; - XtSetArg(args[n], XmNcolormap, cmap); n++; - main_dx = XtCreateManagedWidget("main", - xmMainWindowWidgetClass, toplevel, - args, n); + XtSetArg(args[n], XmNcolormap, cmap); n++; + main_dx = XtCreateManagedWidget("main", + xmMainWindowWidgetClass, toplevel, + args, n); n = 0; XtSetArg(args[n], XmNsashWidth, 0); n++; XtSetArg(args[n], XmNsashHeight, 0); n++; XtSetArg(args[n], XmNdepth, visualList[0].depth); n++; XtSetArg(args[n], XmNvisual, visualList[0].visual); n++; - XtSetArg(args[n], XmNcolormap, cmap); n++; - form1 = XtCreateManagedWidget("form", - xmFormWidgetClass, main_dx, - args, n); - - /* - * Create menu bar in main window. - */ + XtSetArg(args[n], XmNcolormap, cmap); n++; + form1 = XtCreateManagedWidget("form", + xmFormWidgetClass, main_dx, + args, n); + + /* + * Create menu bar in main window. + */ if (i_db > 6-1) printf("Creating Menubar\n"); - n = 0; + n = 0; /* XtSetArg(args[n], XmNdepth, visualList[0].depth); n++; XtSetArg(args[n], XmNvisual, visualList[0].visual); n++; XtSetArg(args[n], XmNcolormap, cmap); n++; */ - menu_bar = XmCreateMenuBar (main_dx, "menu_bar", args, n); + menu_bar = XmCreateMenuBar (main_dx, "menu_bar", args, n); if (i_db > 6-1) printf("Managing Menubar\n"); - XtManageChild (menu_bar); + XtManageChild (menu_bar); i_g = 0; for (l=1; l<321;l++) { @@ -2208,77 +2370,78 @@ int init_gx(i_wxi,i_typ,a_labl,i_wxs,i_wys,i_frx,i_fry,a_menu,a_lcolor,i_cin,i_d i_dx[i_g] = i_d; i_wx[i_g] = i_w; i_gx[i_dx[i_g]][i_wx[i_g]]=i_g; - if (i_db > 5-1) printf("menu ** i_d,i_w,i_g = %d %d %d \n",i_d,i_w,i_g); + if (i_db > 5-1) printf("menu ** i_d,i_w,i_g = %d %d %d \n",i_d,i_w,i_g); - for (i=0;i<9+1; i++) { - num = 0; + for (i=0;i<9+1; i++) { + num = 0; for (j=0; j < 19; j++) { - a_lbl[j] = a_menu[(i*6*20+j)]; + a_lbl[j] = a_menu[(i*6*20+j)]; /* if (a_lbl[j] == "|" ) num = j; */ if (a_lbl[j] != 0 && a_lbl[j] != 32 ) num = j+1; } /* enddo */ a_lbl[num] = 0; - if (num != 0) { - - /* Create pulldown menu. */ + if (num != 0) { + /* Create pulldown menu. */ + i_w = 0; /* printf("hello 3\n"); */ - n = 0; + n = 0; /* XtSetArg(args[n], XmNdepth, visualList[0].depth); n++; XtSetArg(args[n], XmNvisual, visualList[0].visual); n++; XtSetArg(args[n], XmNcolormap, cmap); n++; */ - menu_pane = XmCreatePulldownMenu (menu_bar, "", args, n); + menu_pane = XmCreatePulldownMenu (menu_bar, "", args, n); /* printf("hello 4\n"); */ - for (j=0; j<19; j++) a_title[j] = a_lbl[j]; + for (j=0; j<19; j++) a_title[j] = a_lbl[j]; for (j=1; j<5+1; j++) { num=0; for (k=0; k<19; k++) { - a_lbl[k] = a_menu[(i*20*6+j*20+k)]; + a_lbl[k] = a_menu[(i*20*6+j*20+k)]; if (a_lbl[k] != 0 && a_lbl[k] != 32 ) num = k+1; } /* enddo */ a_lbl[num] = 0; - if (num != 0) { + if (num != 0) { - n = 0; + n = 0; if (i != 9) { - i_flag=(i_d*100)+((i+1)*10)+j; } + i_flag=(i_d*100)+((i+1)*10)+j; } else { - i_flag=(i_d*100)+j; + i_flag=(i_d*100)+j; } /* end if */ /* XtSetArg(args[n], XmNdepth, visualList[0].depth); n++; XtSetArg(args[n], XmNvisual, visualList[0].visual); n++; XtSetArg(args[n], XmNcolormap, cmap); n++; */ - button = XmCreatePushButton (menu_pane, a_lbl, args, n); - - XtManageChild (button); - XtAddCallback (button, XmNactivateCallback, MenuManager, (XtPointer)i_flag); + button = XmCreatePushButton (menu_pane, a_lbl, args, n); + + XtManageChild (button); + memset( (void *)&XtPtmp, 0, sizeof( XtPointer ) ); memcpy( (void *)&XtPtmp, (void *)&i_flag, 4 ); + XtAddCallback (button, XmNactivateCallback, MenuManager, XtPtmp ); } } /* enddo */ - - n = 0; + + n = 0; /* XtSetArg(args[n], XmNdepth, visualList[0].depth); n++; XtSetArg(args[n], XmNvisual, visualList[0].visual); n++; XtSetArg(args[n], XmNcolormap, cmap); n++; */ - XtSetArg(args[n], XmNsubMenuId, menu_pane); n++; - cascade = XmCreateCascadeButton (menu_bar, a_title, args, n); - XtManageChild (cascade); - - if (i == 9) { - n = 0; - XtSetArg (args[n], XmNmenuHelpWidget, cascade); n++; - XtSetValues (menu_bar, args, n); - } + XtSetArg(args[n], XmNsubMenuId, menu_pane); n++; + cascade = XmCreateCascadeButton (menu_bar, a_title, args, n); + XtManageChild (cascade); + if (i == 9) { + n = 0; + XtSetArg (args[n], XmNmenuHelpWidget, cascade); n++; + XtSetValues (menu_bar, args, n); + } + /* printf("hello 5\n"); */ - } - } + } + } if (i_db > 4-1) printf("creating pane\n"); n = 0; @@ -2287,16 +2450,16 @@ int init_gx(i_wxi,i_typ,a_labl,i_wxs,i_wys,i_frx,i_fry,a_menu,a_lcolor,i_cin,i_d XtSetArg(args[n], XmNdepth, visualList[0].depth); n++; XtSetArg(args[n], XmNvisual, visualList[0].visual); n++; XtSetArg(args[n], XmNcolormap, cmap); n++; - XtSetArg(args[n], XmNtopAttachment, XmATTACH_FORM); n++; + XtSetArg(args[n], XmNtopAttachment, XmATTACH_FORM); n++; XtSetArg(args[n], XmNbottomAttachment, XmATTACH_FORM); n++; XtSetArg(args[n], XmNleftAttachment, XmATTACH_FORM); n++; XtSetArg(args[n], XmNrightAttachment, XmATTACH_FORM); n++; XtSetArg(args[n], XmNtopOffset, 10); n++; pane = XtCreateManagedWidget("pane", - xmPanedWindowWidgetClass, form1, - args, n); + xmPanedWindowWidgetClass, form1, + args, n); ix = 0; - if (i_db > 5-1) printf("i_d = %d \n",i_d); + if (i_db > 5-1) printf("i_d = %d \n",i_d); if (i_db > 5-1) printf("i_wxi = %d \n",i_wxi[0]); for (i_w=1; i_w < i_wxi[0]+1; i_w++) { if (i_db > 6-1) printf("loop. %d %d %d \n",i_w,ix,i_frx[i_w]); @@ -2314,7 +2477,7 @@ int init_gx(i_wxi,i_typ,a_labl,i_wxs,i_wys,i_frx,i_fry,a_menu,a_lcolor,i_cin,i_d i_dx[i_g] = i_d; i_wx[i_g] = i_w; i_gx[i_d][i_w]=i_g; - if (i_db > 5-1) printf("i_d,i_w,i_g = %d %d %d \n",i_d,i_w,i_g); + if (i_db > 5-1) printf("i_d,i_w,i_g = %d %d %d \n",i_d,i_w,i_g); if (ix == 0) { n = 0; XtSetArg(args[n], XmNborderWidth, 0); n++; @@ -2333,9 +2496,9 @@ int init_gx(i_wxi,i_typ,a_labl,i_wxs,i_wys,i_frx,i_fry,a_menu,a_lcolor,i_cin,i_d /* XtSetArg(args[n], XmNdepth, visualList[0].depth); n++; XtSetArg(args[n], XmNvisual, visualList[0].visual); n++; XtSetArg(args[n], XmNcolormap, cmap); n++; */ - formy = XtCreateManagedWidget("form", - xmFormWidgetClass, pane, - args, n); + formy = XtCreateManagedWidget("form", + xmFormWidgetClass, pane, + args, n); } /* endif */ if (ix+i_frx[i_w] > i_frx[0]) i_frx[i_w] = i_frx[0]-ix; @@ -2354,22 +2517,22 @@ int init_gx(i_wxi,i_typ,a_labl,i_wxs,i_wys,i_frx,i_fry,a_menu,a_lcolor,i_cin,i_d /* XtSetArg(args[n], XmNdepth, visualList[0].depth); n++; XtSetArg(args[n], XmNvisual, visualList[0].visual); n++; XtSetArg(args[n], XmNcolormap, cmap); n++; */ - form[i_g] = XtCreateWidget("subform", - xmFormWidgetClass, formy, - args, n); + form[i_g] = XtCreateWidget("subform", + xmFormWidgetClass, formy, + args, n); ix = ix+i_frx[i_w]; if (ix == i_frx[0]) ix = 0; i_cnt[i_w] = 0; for (j=0; j < 78; j++) { - a_lbl[j] = a_labl[(i_w*80+j)]; + a_lbl[j] = a_labl[(i_w*80+j)]; if (a_lbl[j] != 0 && a_lbl[j] != 32 ) i_cnt[i_w] = j+1; } /* enddo */ a_lbl[i_cnt[i_w]] = 0; if (i_db > 8-1) printf("i_cnt = %d %d \n",i_cnt[i_w],i_w); - if (i_db > 8-1) printf("i_typ = %d \n",i_typ[i_w]); + if (i_db > 8-1) printf("i_typ = %d \n",i_typ[i_w]); if (i_typ[i_w] == 5) i_typ[i_w] = -4; /* to be backward compatible with graphx14 */ i_tttt = i_typ[i_w]; @@ -2395,14 +2558,14 @@ int init_gx(i_wxi,i_typ,a_labl,i_wxs,i_wys,i_frx,i_fry,a_menu,a_lcolor,i_cin,i_d XtSetArg(args[n], XmNcolormap, cmap); n++; */ draw[i_g] = XtCreateManagedWidget(a_lbl, - xmPushButtonWidgetClass, form[i_g], - args, n); } + xmPushButtonWidgetClass, form[i_g], + args, n); } else { draw[i_g] = form[i_g]; } /* endif */ - XtManageChild(form[i_g]); + XtManageChild(form[i_g]); XtManageChild(draw[i_g]); break; @@ -2411,17 +2574,17 @@ int init_gx(i_wxi,i_typ,a_labl,i_wxs,i_wys,i_frx,i_fry,a_menu,a_lcolor,i_cin,i_d n = 0; XtSetArg(args[n], XmNborderWidth, 0); n++; XtSetArg(args[n], XmNrightAttachment, XmATTACH_FORM); n++; - XtSetArg(args[n], XmNleftAttachment, XmATTACH_FORM); n++; + XtSetArg(args[n], XmNleftAttachment, XmATTACH_FORM); n++; XtSetArg(args[n], XmNheight, i_wys[i_w]); n++; /* XtSetArg(args[n], XmNdepth, visualList[0].depth); n++; XtSetArg(args[n], XmNvisual, visualList[0].visual); n++; XtSetArg(args[n], XmNcolormap, cmap); n++; */ - XtSetArg(args[n], XmNlabelString, XmStringCreateSimple(a_lbl)); n++; + XtSetArg(args[n], XmNlabelString, XmStringCreateSimple(a_lbl)); n++; draw[i_g] = XtCreateWidget(" ", - xmLabelWidgetClass, form[i_g], - args, n); + xmLabelWidgetClass, form[i_g], + args, n); - XtManageChild(form[i_g]); + XtManageChild(form[i_g]); XtManageChild(draw[i_g]); break; @@ -2430,17 +2593,17 @@ int init_gx(i_wxi,i_typ,a_labl,i_wxs,i_wys,i_frx,i_fry,a_menu,a_lcolor,i_cin,i_d n = 0; XtSetArg(args[n], XmNborderWidth, 0); n++; XtSetArg(args[n], XmNrightAttachment, XmATTACH_FORM); n++; - XtSetArg(args[n], XmNleftAttachment, XmATTACH_FORM); n++; + XtSetArg(args[n], XmNleftAttachment, XmATTACH_FORM); n++; labl[i_g] = XtCreateWidget(" ", - xmLabelWidgetClass, form[i_g], - args, n); - + xmLabelWidgetClass, form[i_g], + args, n); + n = 0; temp = labl[i_g]; XtSetArg(args[n], XmNtopAttachment, XmATTACH_WIDGET); n++; XtSetArg(args[n], XmNtopWidget, temp); n++; - XtSetArg(args[n], XmNbottomAttachment, XmATTACH_FORM); n++; - XtSetArg(args[n], XmNleftAttachment, XmATTACH_FORM); n++; + XtSetArg(args[n], XmNbottomAttachment, XmATTACH_FORM); n++; + XtSetArg(args[n], XmNleftAttachment, XmATTACH_FORM); n++; XtSetArg(args[n], XmNrightAttachment, XmATTACH_FORM); n++; XtSetArg(args[n], XmNborderWidth, 1); n++; XtSetArg(args[n], XmNwidth, i_wxs[i_w]); n++; @@ -2448,11 +2611,11 @@ int init_gx(i_wxi,i_typ,a_labl,i_wxs,i_wys,i_frx,i_fry,a_menu,a_lcolor,i_cin,i_d /* XtSetArg(args[n], XmNdepth, visualList[0].depth); n++; XtSetArg(args[n], XmNvisual, visualList[0].visual); n++; XtSetArg(args[n], XmNcolormap, cmap); n++; */ - draw[i_g] = XtCreateWidget("draw", - xmDrawingAreaWidgetClass, form[i_g], - args, n); + draw[i_g] = XtCreateWidget("draw", + xmDrawingAreaWidgetClass, form[i_g], + args, n); - XtManageChild(form[i_g]); + XtManageChild(form[i_g]); XtManageChild(labl[i_g]); XtManageChild(draw[i_g]); @@ -2462,12 +2625,12 @@ int init_gx(i_wxi,i_typ,a_labl,i_wxs,i_wys,i_frx,i_fry,a_menu,a_lcolor,i_cin,i_d n = 0; XtSetArg(args[n], XmNborderWidth, 0); n++; XtSetArg(args[n], XmNrightAttachment, XmATTACH_FORM); n++; - XtSetArg(args[n], XmNleftAttachment, XmATTACH_FORM); n++; + XtSetArg(args[n], XmNleftAttachment, XmATTACH_FORM); n++; labl[i_g] = XtCreateWidget(" ", - xmLabelWidgetClass, form[i_g], - args, n); - if (i_db > 99-1) printf("labl = %d \n",labl[i_g]); - + xmLabelWidgetClass, form[i_g], + args, n); + if (i_db > 99-1) printf("labl = %ld \n",(long) labl[i_g]); + n = 0; temp = labl[i_g]; XtSetArg(args[n], XmNscrollingPolicy, XmAUTOMATIC); n++; @@ -2478,15 +2641,15 @@ int init_gx(i_wxi,i_typ,a_labl,i_wxs,i_wys,i_frx,i_fry,a_menu,a_lcolor,i_cin,i_d XtSetArg(args[n], XmNrightAttachment, XmATTACH_POSITION); n++; XtSetArg(args[n], XmNrightPosition, 100); n++; XtSetArg(args[n], XmNleftAttachment, XmATTACH_FORM); n++; - XtSetArg(args[n], XmNvisualPolicy, XmVARIABLE); n++; + XtSetArg(args[n], XmNvisualPolicy, XmVARIABLE); n++; /* XtSetArg(args[n], XmNdepth, visualList[0].depth); n++; XtSetArg(args[n], XmNvisual, visualList[0].visual); n++; XtSetArg(args[n], XmNcolormap, cmap); n++; */ - scrl[i_g] = XtCreateWidget("scroll", - xmScrolledWindowWidgetClass, form[i_g], - args, n); - if (i_db > 99-1) printf("scrl = %d \n",scrl[i_g]); - + scrl[i_g] = XtCreateWidget("scroll", + xmScrolledWindowWidgetClass, form[i_g], + args, n); + if (i_db > 99-1) printf("scrl = %ld \n",(long) scrl[i_g]); + n = 0; XtSetArg(args[n], XmNwidth, i_wxs[i_w]); n++; XtSetArg(args[n], XmNheight, i_wys[i_w]); n++; @@ -2494,30 +2657,30 @@ int init_gx(i_wxi,i_typ,a_labl,i_wxs,i_wys,i_frx,i_fry,a_menu,a_lcolor,i_cin,i_d /* XtSetArg(args[n], XmNdepth, visualList[0].depth); n++; XtSetArg(args[n], XmNvisual, visualList[0].visual); n++; XtSetArg(args[n], XmNcolormap, cmap); n++; */ - draw[i_g] = XtCreateWidget("draw", - xmDrawingAreaWidgetClass, scrl[i_g], - args, n); - if (i_db > 99-1) printf("draw = %d \n",draw[i_g]); - + draw[i_g] = XtCreateWidget("draw", + xmDrawingAreaWidgetClass, scrl[i_g], + args, n); + if (i_db > 99-1) printf("draw = %ld \n", (long) draw[i_g]); + XtVaGetValues(scrl[i_g],XmNhorizontalScrollBar,&hsb,NULL); XtVaGetValues(scrl[i_g],XmNverticalScrollBar, &vsb,NULL); XmScrolledWindowSetAreas(scrl[i_g],hsb,vsb,draw[i_g]); - if (i_db > 99-1) printf("Set scroll \n"); - - XtManageChild(form[i_g]); - if (i_db > 99-1) printf("Managing form \n"); + if (i_db > 99-1) printf("Set scroll \n"); + + XtManageChild(form[i_g]); + if (i_db > 99-1) printf("Managing form \n"); XtManageChild(labl[i_g]); - if (i_db > 99-1) printf("Managing labl \n"); + if (i_db > 99-1) printf("Managing labl \n"); XtManageChild(scrl[i_g]); - if (i_db > 99-1) printf("Managing scrl \n"); + if (i_db > 99-1) printf("Managing scrl \n"); XtManageChild(draw[i_g]); - if (i_db > 99-1) printf("Managing draw \n"); + if (i_db > 99-1) printf("Managing draw \n"); break; - + case 5: - + break; case 6: if (i_cnt[i_w] > 0) { @@ -2526,11 +2689,11 @@ int init_gx(i_wxi,i_typ,a_labl,i_wxs,i_wys,i_frx,i_fry,a_menu,a_lcolor,i_cin,i_d XtSetArg(args[n], XmNtopAttachment, XmATTACH_FORM); n++; XtSetArg(args[n], XmNbottomAttachment, XmATTACH_FORM); n++; -/* For some reason, with both of the following statements active togeter, mdxs genrates error messages - (BadDrawable) on the SGI and other machines, even though it appears to work properly. To eliminate - the error messages, I could have comment out next line. Instead, I trap the error in myhandler and - don't display it. This could mask other errors, however, and should be better understood. */ - +/* For some reason, with both of the following statements active togeter, mdxs genrates error messages + (BadDrawable) on the SGI and other machines, even though it appears to work properly. To eliminate + the error messages, I could have comment out next line. Instead, I trap the error in myhandler and + don't display it. This could mask other errors, however, and should be better understood. */ + XtSetArg(args[n], XmNrightAttachment, XmATTACH_FORM); n++; XtSetArg(args[n], XmNleftAttachment, XmATTACH_FORM); n++; @@ -2549,33 +2712,35 @@ int init_gx(i_wxi,i_typ,a_labl,i_wxs,i_wys,i_frx,i_fry,a_menu,a_lcolor,i_cin,i_d XtSetArg(args[n], XmNheight, i_wys[i_w]); n++; draw[i_g] = XtCreateManagedWidget(a_lbl, - xmDrawnButtonWidgetClass, form[i_g], - args, n); + xmDrawnButtonWidgetClass, form[i_g], + args, n); - i_flag=i_g; /* (i_d*100)+((i_w+1)*10)+j; */ - a_llll[i_g]=XmStringCreateSimple(a_lbl); - XtAddCallback(draw[i_g],XmNactivateCallback,ButtonManager, (XtPointer)i_flag); - XtAddCallback(draw[i_g],XmNexposeCallback, ButtonManager, (XtPointer)i_flag); - XtAddCallback(draw[i_g],XmNresizeCallback, ButtonManager, (XtPointer)i_flag); + i_flag=i_g; /* (i_d*100)+((i_w+1)*10)+j; */ + a_llll[i_g]=XmStringCreateSimple(a_lbl); + memset( (void *)&XtPtmp, 0, sizeof( XtPointer ) ); memcpy( (void *)&XtPtmp, (void *)&i_flag, 4 ); + XtAddCallback(draw[i_g],XmNactivateCallback,ButtonManager, XtPtmp ); + XtAddCallback(draw[i_g],XmNexposeCallback, ButtonManager, XtPtmp ); + XtAddCallback(draw[i_g],XmNresizeCallback, ButtonManager, XtPtmp ); + n = 0; XtSetArg(args[n], XmNborderWidth, 0); n++; XtSetArg(args[n], XmNrightAttachment, XmATTACH_FORM); n++; - XtSetArg(args[n], XmNleftAttachment, XmATTACH_FORM); n++; + XtSetArg(args[n], XmNleftAttachment, XmATTACH_FORM); n++; XtSetArg(args[n], XmNheight, i_wys[i_w]); n++; - XtSetArg(args[n], XmNlabelString, XmStringCreateSimple(a_lbl)); n++; + XtSetArg(args[n], XmNlabelString, XmStringCreateSimple(a_lbl)); n++; labl[i_g] = XtCreateWidget(" ", - xmLabelWidgetClass, draw[i_g], - args, n); - + xmLabelWidgetClass, draw[i_g], + args, n); + } else { draw[i_g] = form[i_g]; } /* endif */ - XtManageChild(form[i_g]); - XtManageChild(draw[i_g]); + XtManageChild(form[i_g]); + XtManageChild(draw[i_g]); break; @@ -2588,80 +2753,80 @@ int init_gx(i_wxi,i_typ,a_labl,i_wxs,i_wys,i_frx,i_fry,a_menu,a_lcolor,i_cin,i_d * Set Main Window areas. */ -/* if (i_db > 5-1) printf("setting window areas\n"); - XmMainWindowSetAreas (main_dx, menu_bar, NULL, NULL, NULL, pane); */ +/* if (i_db > 5-1) printf("setting window areas\n"); + XmMainWindowSetAreas (main_dx, menu_bar, NULL, NULL, NULL, pane); */ - if (i_db > 5-1) printf("Realizing top level widget\n"); + if (i_db > 5-1) printf("Realizing top level widget\n"); XtRealizeWidget(toplevel); - if (i_db > 5-1) printf("getting top window id\n"); + if (i_db > 5-1) printf("getting top window id\n"); top[i_d] = XtWindow(toplevel); - if (i_db > 5-1) printf("top= %d %d\n",top[i_d],i_d); + if (i_db > 5-1) printf("top= %lu %d\n",top[i_d],i_d); XGetWindowAttributes(dgx,top[i_d],&xwa); - if (i_db > 5-1) printf("got window attributes\n"); + if (i_db > 5-1) printf("got window attributes\n"); XSetWindowColormap(dgx,top[i_d],cmap); i_g=i_gx[i_d][0]; wgx[i_g] = XtWindow(menu_bar); - if (i_db > 6-1) printf("menu wgx= %d %d\n",wgx[i_g],i_g); + if (i_db > 6-1) printf("menu wgx= %lu %d\n",wgx[i_g],i_g); - if (i_db > 6-1) printf("wgx= %d %d\n",wgx[i_g],i_g); + if (i_db > 6-1) printf("wgx= %lu %d\n",wgx[i_g],i_g); XSelectInput(dgx,wgx[i_g],ExposureMask | ButtonPressMask | ButtonReleaseMask | PointerMotionMask | - KeyPressMask | KeyReleaseMask | StructureNotifyMask); - + KeyPressMask | KeyReleaseMask | StructureNotifyMask); + for (i_w=1; i_w < i_wxi[0]+1; i_w++) { i_g=i_gx[i_d][i_w]; fgx[i_g] = XtWindow(form[i_g]); - wgx[i_g] = XtWindow(draw[i_g]); /* get the window id's for drawing */ + wgx[i_g] = XtWindow(draw[i_g]); /* get the window id's for drawing */ XSetWindowColormap(dgx,top[i_d],cmap); - if (i_type[i_g] == 3) lgx[i_g] = XtWindow(labl[i_g]); /* get the labels id's for drawing */ - if (i_type[i_g] == 4) lgx[i_g] = XtWindow(labl[i_g]); /* get the labels id's for drawing */ - if (i_db > 6-1) printf("fgx= %d %d\n",fgx[i_g],i_g); - if (i_db > 6-1) printf("wgx= %d %d\n",wgx[i_g],i_g); + if (i_type[i_g] == 3) lgx[i_g] = XtWindow(labl[i_g]); /* get the labels id's for drawing */ + if (i_type[i_g] == 4) lgx[i_g] = XtWindow(labl[i_g]); /* get the labels id's for drawing */ + if (i_db > 6-1) printf("fgx= %lu %d\n",fgx[i_g],i_g); + if (i_db > 6-1) printf("wgx= %lu %d\n",wgx[i_g],i_g); /* if (i_type[i_g] == 4) printf("lgx= %d %d\n",lgx[i_g],i_g); */ XSelectInput(dgx,wgx[i_g],ExposureMask | ButtonPressMask | ButtonReleaseMask | PointerMotionMask | - KeyPressMask | KeyReleaseMask | StructureNotifyMask); + KeyPressMask | KeyReleaseMask | StructureNotifyMask); XSelectInput(dgx,fgx[i_g],ExposureMask | ButtonPressMask | ButtonReleaseMask | PointerMotionMask | - KeyPressMask | KeyReleaseMask | StructureNotifyMask); + KeyPressMask | KeyReleaseMask | StructureNotifyMask); if (i_typ[i_w] < 0) { /* XGetWindowAttributes(dgx,wgx[i_g],xwa); */ xswa.backing_store=Always; XChangeWindowAttributes(dgx,wgx[i_g],CWBackingStore,&xswa); - if (i_db > 6-1) printf("BackingStore set to always %d, %d\n",i_d,i_w); + if (i_db > 6-1) printf("BackingStore set to always %d, %d\n",i_d,i_w); } else { xswa.backing_store=NotUseful; XChangeWindowAttributes(dgx,wgx[i_g],CWBackingStore,&xswa); - if (i_db > 6-1) printf("BackingStore set to NotUseful %d, %d\n",i_d,i_w); + if (i_db > 6-1) printf("BackingStore set to NotUseful %d, %d\n",i_d,i_w); } /* Endif */ } /* Enddo */ /* Create the mdx icon */ icon = XCreateBitmapFromData(dgx, top[i_d], icon_bits, - icon_width, icon_height); - + icon_width, icon_height); + i_cnt[0]=0; for (j=0; j < 78; j++) { - a_lbl[j] = a_labl[(j)]; + a_lbl[j] = a_labl[(j)]; if (a_lbl[j] != 0 && a_lbl[j] != 32 ) i_cnt[0] = j+1; } /* enddo */ a_lbl[i_cnt[0]] = 0; if (i_cnt[0] == 0) strcpy(a_lbl,"GraphX"); - XSetStandardProperties(dgx, top[i_d], a_lbl, a_lbl, - icon, ww1, 1, NULL); + XSetStandardProperties(dgx, top[i_d], a_lbl, a_lbl, + icon, ww1, 1, NULL); -/* screen = DefaultScreen(dgx); */ - /* gc = DefaultGC(dgx, screen); */ +/* screen = DefaultScreen(dgx); */ + /* gc = DefaultGC(dgx, screen); */ /* gc = XCreateGC(dgx,top[i_d],0,NULL); */ i_cnt[0]=0; for (j=0; j < 78; j++) { - a_clr[j] = a_lcolor[(j)]; + a_clr[j] = a_lcolor[(j)]; if (a_clr[j] != 0 && a_clr[j] != 32 ) i_cnt[0] = j+1; } /* enddo */ a_clr[i_cnt[0]] = 0; - if (i_cnt[0]=0) { + if (i_cnt[0]==0) { /* edited by PS to make this a logical instead of an assignment */ rc = XAllocNamedColor(dgx, cmap, "white", &linec, &linec);} else { rc = XAllocNamedColor(dgx, cmap, a_clr, &linec, &linec); @@ -2670,7 +2835,7 @@ int init_gx(i_wxi,i_typ,a_labl,i_wxs,i_wys,i_frx,i_fry,a_menu,a_lcolor,i_cin,i_d printf("XAllocNamedColor - failed to allocated forground color %s. Using 'white' \n",a_clr); XSetForeground(dgx,gc,WhitePixel(dgx,screen)); } else { - XSetForeground(dgx,gc,linec.pixel); + XSetForeground(dgx,gc,linec.pixel); } XSetBackground(dgx,gc,BlackPixel(dgx,screen)); @@ -2681,14 +2846,14 @@ int init_gx(i_wxi,i_typ,a_labl,i_wxs,i_wys,i_frx,i_fry,a_menu,a_lcolor,i_cin,i_d for (i_g=1; i_g<321; i_g++) { if (i_dx[i_g] != 0) i_gmax = i_g; if (i_dx[i_g]>i_dmax) i_dmax=i_dx[i_g]; - if (i_wx[i_g]>i_wmax) i_wmax=i_wx[i_g]; + if (i_wx[i_g]>i_wmax) i_wmax=i_wx[i_g]; } if (i_db > 2-1) printf("Graphx initialization complete\n"); if (i_db > 6-1) printf("i_dmax= %d \n",i_dmax); if (i_db > 6-1) printf("i_wmax= %d \n",i_wmax); if (i_db > 6-1) printf("i_gmax= %d \n",i_gmax); if (i_db > 7-1) printf("i_wx= %d %d %d %d %d %d %d\n",i_wx[1],i_wx[2],i_wx[3],i_wx[4],i_wx[5],i_wx[6],i_wx[7]); - if (i_db > 7-1) printf("wgx = %d %d %d %d %d %d %d\n",wgx[1],wgx[2],wgx[3],wgx[4],wgx[5],wgx[6],wgx[7]); + if (i_db > 7-1) printf("wgx = %lu %lu %lu %lu %lu %lu %lu\n",wgx[1],wgx[2],wgx[3],wgx[4],wgx[5],wgx[6],wgx[7]); return(i_d); } @@ -2704,17 +2869,17 @@ void free_graphics() } -static void Button_quit(w, free, data) - Widget w; +static void Button_quit(Widget w, Pixmap free, XmAnyCallbackStruct *data) +/* Widget w; Pixmap free; - XmAnyCallbackStruct *data; + XmAnyCallbackStruct *data; */ { /* Quit Graphsub */ - cmap = XDefaultColormap(dgx, screen); + cmap = XDefaultColormap(dgx, screen); if (top[1] != 0) XSetWindowColormap(dgx,top[1],cmap); - XFlush(dgx); + XFlush(dgx); XFreeColormap(dgx,cmap); - XFreePixmap(XtDisplay(w), free); + XFreePixmap(XtDisplay(w), free); free_graphics(); exit(0); } @@ -2725,8 +2890,8 @@ void read_events() { XFlush(dgx); while(XPending(dgx)) { - XtNextEvent(&event); - XtDispatchEvent(&event); + XtNextEvent(&event); + XtDispatchEvent(&event); } } @@ -2738,18 +2903,21 @@ void read_events() /*************************************************************************/ #ifdef SGI int initdk_(i_flag, a_filename) +int *i_flag; char *a_filename; #endif #ifdef SUN -int initdk_(i_flag, a_filename) +int initdk_(int *i_flag, char *a_filename); +int initdk_(int *i_flag, char *a_filename) #endif #ifdef M10 int initdk_(i_flag, a_filename) +int *i_flag; char *a_filename; #endif #if defined(HP) || defined(_linux) int initdk(i_flag, a_filename) +int *i_flag; char *a_filename; #endif -int *i_flag; char *a_filename; { int i; int i_stat; for(i=0; i < strlen(a_filename); i++) @@ -2761,15 +2929,15 @@ int *i_flag; char *a_filename; if( (i_stat = open(a_filename,O_CREAT|O_RDWR,0666)) < 0) { printf(" Cannot open the filename: %s\n",a_filename); } - } else { + } else { printf(" Open filename %s as READ ONLY\n",a_filename); } /* end if */ } else { printf(" Open filename %s as RDWR \n",a_filename); } /* endif */ - if( i_stat < 0 ) i_stat = open(a_filename,O_CREAT|O_RDWR,0666); - if(i_stat == -1)printf(" Cannot open the filename: %s\n",a_filename); + if( i_stat < 0 ) i_stat = open(a_filename,O_CREAT|O_RDWR,0666); + if(i_stat == -1)printf(" Cannot open the filename: %s\n",a_filename); } else { if((i_stat=open(a_filename,O_RDONLY)) < 0){ printf(" Cannot open the filename: %s\n",a_filename); @@ -2781,20 +2949,25 @@ int *i_flag; char *a_filename; /*************************************************************************/ #ifdef SGI int iowrit_(i_chan, b_buff, bytes) +int *i_chan, *bytes; +char *b_buff; #endif #ifdef SUN -int iowrit_(i_chan, b_buff, bytes) +int iowrit_(int *i_chan, char *b_buff, int *bytes); +int iowrit_(int *i_chan, char *b_buff, int *bytes) #endif #ifdef M10 int iowrit_(i_chan, b_buff, bytes) +int *i_chan, *bytes; +char *b_buff; #endif #if defined(HP) || defined(_linux) int iowrit(i_chan, b_buff, bytes) -#endif - int *i_chan, *bytes; char *b_buff; -{ +#endif + +{ int nbytes; nbytes = write(*i_chan, b_buff, *bytes); if(nbytes != *bytes) fprintf(stderr, @@ -2806,20 +2979,25 @@ char *b_buff; /*************************************************************************/ #ifdef SGI int ioread_(i_chan, b_buff, bytes) +int *i_chan, *bytes ; +char *b_buff; #endif #ifdef SUN -int ioread_(i_chan, b_buff, bytes) +int ioread_(int *i_chan, char *b_buff, int *bytes); +int ioread_(int *i_chan, char *b_buff, int *bytes) #endif #ifdef M10 int ioread_(i_chan, b_buff, bytes) +int *i_chan, *bytes ; +char *b_buff; #endif #if defined(HP) || defined(_linux) int ioread(i_chan, b_buff, bytes) -#endif - int *i_chan, *bytes ; char *b_buff; -{ +#endif + +{ int nbytes; nbytes = read(*i_chan, b_buff, *bytes); /* if(nbytes != *bytes) fprintf(stderr, @@ -2832,19 +3010,22 @@ char *b_buff; /*************************************************************************/ #ifdef SGI int ioseek_(i_chan, lbyte,i_flag) +int *i_chan, *i_flag, *lbyte; #endif #ifdef SUN -int ioseek_(i_chan, lbyte,i_flag) +int ioseek_(int *i_chan, int *lbyte, int *i_flag); +int ioseek_(int *i_chan, int *lbyte, int *i_flag) #endif #ifdef M10 int ioseek_(i_chan, lbyte,i_flag) +int *i_chan, *i_flag, *lbyte; #endif #if defined(HP) || defined(_linux) int ioseek(i_chan, lbyte,i_flag) +int *i_chan, *i_flag, *lbyte; #endif -int *i_chan, *i_flag, *lbyte; -{ +{ int nloc; off_t ibytes; ibytes = *lbyte ; @@ -2864,19 +3045,24 @@ int *i_chan, *i_flag, *lbyte; /*************************************************************************/ #ifdef SGI long long ioseek64_(i_chan, lbyte,i_flag) +int *i_chan, *i_flag; +long long *lbyte; #endif #ifdef SUN -long long ioseek64_(i_chan, lbyte,i_flag) +long long ioseek64_(int *i_chan, long *lbyte, int *i_flag); +long long ioseek64_(int *i_chan, long *lbyte, int *i_flag) #endif #ifdef M10 long long ioseek64_(i_chan, lbyte,i_flag) +int *i_chan, *i_flag; +long long *lbyte; #endif #if defined(HP) || defined(_linux) long long ioseek64(i_chan, lbyte,i_flag) -#endif int *i_chan, *i_flag; long long *lbyte; -{ +#endif +{ long long nloc; off_t ibytes; ibytes = *lbyte; @@ -2899,18 +3085,22 @@ long long *lbyte; /*************************************************************************/ #ifdef SGI int closedk_(i_chan) +int *i_chan; #endif #ifdef SUN -int closedk_(i_chan) +int closedk_(int *i_chan); +int closedk_(int *i_chan) #endif #ifdef M10 int closedk_(i_chan) +int *i_chan; #endif #if defined(HP) || defined(_linux) int closedk(i_chan) +int *i_chan; #endif -int *i_chan; { return(close(*i_chan)); } + diff --git a/contrib/mdx/src/mdx.F b/contrib/mdx/src/mdx.F old mode 100755 new mode 100644 index 9152e0169..a2048270e --- a/contrib/mdx/src/mdx.F +++ b/contrib/mdx/src/mdx.F @@ -1,9651 +1,9829 @@ - 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 +c!@##$%^&012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012 +c! 1 2 3 4 5 6 7 8 9 10 11 12 13 +c +c Copyright 2001, by the California Institute of Technology. +c ALL RIGHTS RESERVED. United States Government Sponsorship acknowledged. +c Any commercial use must be negotiated with the Office of Technology +c Transfer at the California Institute of Technology. +c +c This software may be subject to U.S. export control laws and regulations. +c By accepting this document, the user agrees to comply with all applicable +c U.S. export laws and regulations. User has the responsibility to obtain +c export licenses, or other export authority as may be required before +c exporting such information to foreign countries or providing access to +c foreign persons. +c +c*************************************************************** + + program mdx + +c**************************************************************** +c** +c** FILE NAME: mdx.f +c** +c** PROGRAM NAME: mdx +c** +c** DATE STARTED: 12/7/2001 +c** +c** PROGRAMMER: Scott Shaffer +c** Jet Propulsion Lab +c** +c** DESCRIPTION: This program displays images +c** in a variaty of image formats including byte, +c** integer*2, integer*4, real*4, and complex. +c** +c** ROUTINES CALLED: +c** init_gx +c** get_wininfo +c** getevent +c** setcolor +c** display_label +c** display_rmg +c** getarg +c** plus others +c** +c** NOTES: Tons of Fun +c** +c** +c** UPDATE LOG: +cc* +cc* v178 2009-03-13 Fixed error created in v177 that caused an extra squaring of magnitude for c8 images +cc* added flag for GFORTRAN compiling to handle declaration of iargc +cc* +cc* v186 2010-01-11 Fixed initialization on entry windows for unsed fields +cc* +cc* v187 2010-01-12 Increased PPM conversion array sizes to handle same limit as screen display +cc* +cc* v190 2010-03-07 SJS - added flag (shift key) to show position in meters when clicking on image +cc* +cc* v191 2012-02-22 SJS - Minor changes to report buffer overrun info and allow addr/mult to be entered in .mdx file +cc* +cc* v192 2012-03-13 SJS - Added flag for reading SRTM 30mx30m tiles +cc* +cc* v193 2012-03-21 SJS - Increased maximum number of channels to 8, added -r4mag data type +cc* +cc* v194 2013-03-29 SJS - Incorporated initialization that Ron suggested to fix printing with -P, also increased to 10 channels +cc* +cc* v195 2014-04-30 RJM - added code at CRJM1, need larger a_cmd line length +cc* +cc* v196 2021-03-27 SJS - added c16 +cc* +cc* v197 2025-03-07 SJS - Clean up code +c***************************************************************** + + implicit none + + character*10000 a_cmd + character*1000 a_value + + integer i_arg + integer i_inarg + + integer rdflen + external rdflen + +#ifdef IO64 + integer*8 mdxfunc_sample + external mdxfunc_sample + + integer*8 i_eight + external i_eight +#else + integer*4 mdxfunc_sample + external mdxfunc_sample + + integer*4 i_eight + external i_eight +#endif + + + character*18 version_mdx + external version_mdx + + character*18 version_gpx + external version_gpx + + character*50 rdfversion + external rdfversion + + integer i,j + byte b_data(4000000) + real*4 r_data(1000000) + equivalence(b_data,r_data) + + a_cmd = ' ' + i_inarg = command_argument_count() + if (i_inarg .eq. 0) then + write(6,*) ' ' + write(6,'(1x,a,a17,a)' ) ' << mdx Version ',version_mdx(),' >> ' + write(6,'(1x,a,a18,a)' ) ' << graphx Version ',version_gpx(),' >> ' + write(6,*) rdfversion() + write(6,*) ' ' + call write_greeting() + stop 'done' + else + do i_arg =1, i_inarg + call getarg(i_arg,a_value) +c write(6,*) i_arg,':',a_value(1:20) + do i=1,rdflen(a_value)+1 + if (ichar(a_value(i:i)) .eq. 0) a_value(i:i)=' ' + end do + if (a_cmd .eq. ' ') then + a_cmd = a_value + else + a_cmd = a_cmd(:max(rdflen(a_cmd),1))//' '//a_value + end if + end do + end if +c write(6,*) a_cmd + + + do i=1,500 + do j=1,500 + r_data(i+(j-1)*500) = i+j/500. + end do + end do + i=int(mdxfunc_sample(2,1,i_eight(0),4*500*500,b_data)) +c write(6,*) 'Calling mdxsub' + call mdxsub(a_cmd,i_eight(4000000),mdxfunc_sample) + end + + +#ifdef IO64 + integer*8 function mdxfunc_sample(i_flag,i_chn,i_start,i_num,b_data) + + implicit none + +c +c Input Variables +c + integer*4 i_flag ! Controls weather the function is returning data or the size of the buffer. Can also do other functions + integer*4 i_chn ! Provides subroutine with the channel number + integer*8 i_start ! Start byte of data to be displayed - Is also an output + integer*4 i_num ! Number of bytes to be displayed + byte b_data(*) ! Data buffer + +c +c Local Variables +c + integer*4 i ! Counter + integer*8 i_back ! Returned value - number of bytes read or total bytes in file + integer*8 i_bmax ! Max number of bytes in the internal file + byte b_buff(4000000) ! Internal buffer of image data + + data i_bmax /0/ + + save i_bmax + save b_buff +#else + integer*4 function mdxfunc_sample(i_flag,i_chn,i_start,i_num,b_data) + + implicit none + +c +c Input Variables +c + integer*4 i_flag + integer*4 i_chn + integer*4 i_start + integer*4 i_num + byte b_data(1) + +c +c Local Variables +c + integer*4 i ! Counter + integer*4 i_back ! Returned value - + integer*4 i_bmax + byte b_buff(4000000) + + data i_bmax /0/ + + save i_bmax + save b_buff + +#endif + + if (i_flag .eq. 0) then ! return image data in byte array + i_back = 0 + do i=1,i_num + if (i_start+i .ge. 1 .and. i_start+i .le. i_bmax) then + b_data(i)=b_buff(i_start+i) + i_back=i_back+1 + end if + end do + else if (i_flag .eq. 1) then ! return number of bytes in image array + i_back = i_bmax + else if (i_flag .eq. 2) then ! load data into image array (not called within mdx) + i_back=0 + do i=1,i_num + if (i_start+i .ge. 1 .and. i_start+i .le. 4000000) then + b_buff(i_start+i) = b_data(i) + i_back = i_back+1 + if (i_start+i .gt. i_bmax) i_bmax=i_start+i + end if + end do + else if (i_flag .eq. 3) then ! clears image array buffer (not called inside mdx) + i_bmax = 0 + i_back = 0 + end if + mdxfunc_sample = i_back + return + end + + character*(*) function version_mdx() + + version_mdx = '197.0 07-Mar-2025' + return + end + + subroutine mdxsub(a_cmd,i_maxbuff,readfunc) + + implicit none + + integer I_WKSPACE + integer I_MAXCOLS + integer I_MAXROWS + parameter(I_WKSPACE = 200000) ! CRJM1 + parameter(I_MAXCOLS = 200000) ! CRJM1 + parameter(I_MAXROWS = 200000) ! CRJM1 + + 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 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_stat + integer i_dflag + integer i_value + integer i_field + + 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_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) + save r_data + save r_data2 + save i_data + save i_data2 + + real*8 r_sqr + real*8 r_sum + real*8 r_avg + real*8 r_std + + real*4 r_dnx(3) + real*4 r_eux(3) + + real*8 r_pi + real*8 r_rtod + + integer i_smode + integer i_samps + integer i_rsamps(I_MAXCOLS) + integer i_csamps(I_MAXCOLS) + integer i_tsamps(I_MAXCOLS) + real*4 r_wsamps(I_MAXCOLS) + real*4 r_ssamps(I_MAXCOLS) + real*4 r_vsamps(I_MAXCOLS,I_CMAX) + save i_rsamps + save i_csamps + save i_tsamps + save r_wsamps + save r_ssamps + save r_vsamps + + real*4 r_row(I_MAXROWS) + real*4 r_col(I_MAXCOLS) + real*4 r_rowlow + real*4 r_rowhigh + real*4 r_collow + real*4 r_colhigh + real*4 r_path + save r_row + save r_col + + real*4 r_wdth + real*4 r_spce + real*4 r_dist + + integer ii + 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_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 + 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(I_DMAX,-10:10) ! window x size + integer i_wys(I_DMAX,-10:10) ! window y size + integer i_vxs(I_DMAX,-10:10) ! viewport x size + integer i_vys(I_DMAX,-10:10) ! viewport y size + integer i_vxo(I_DMAX,-10:10) ! viewport x offset + integer i_vyo(I_DMAX,-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) + save i_indx, 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 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) + save r_val + + 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_strt + integer i_stop + integer i_incr + integer i_coff + + integer i_close + + integer i_redraw(I_DMAX) + 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 + 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 + + byte cnvt_to_byte + external cnvt_to_byte + + character*18 version_mdx + external version_mdx + + character*18 version_gpx + external version_gpx + + character*50 rdfversion + external rdfversion + +#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 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) = real(-1.0d27) + r_setvmax(0) = real( 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' .or. a_value .eq. '-v') then + write(6,*) ' ' + write(6,'(1x,a,a17,a)' ) ' << mdx Version ',version_mdx(),' >> ' + write(6,'(1x,a,a18,a)' ) ' << graphx Version ',version_gpx(),' >> ' + write(6,*) rdfversion() + 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 (abs(r_dspwrap(i_tmp)) .gt. 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) = real(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)(1:len(a_dspctbl(i_tmp))) + do i=1,i_colormax + if (a_dspctbl(i_tmp) .eq. a_colorname(i)) a_dspctbl(i_tmp)=a_colorfile(i)(1:len(a_dspctbl(i_tmp))) + end do + else if (a_value .eq. '-null') then + i_arg=i_arg+1 + a_setvnul(i_tmp)=a_inarg(i_arg)(1:len(a_setvnul)) + 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)(1:len(a_nullclr)) + 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)(1:len(a_lcolor)) + 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)(1:len(a_clickcmd(1))) + 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. '-c16' .or. a_value .eq. '-complex*16') then + a_setname(-i_dat) = 'C16-Mag C16-Pha' + i_setchdr(-i_dat) = 0 + i_setctlr(-i_dat) = 0 + i_setvfmt(-i_dat) = 15 + 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. '-c16iq' .or. a_value .eq. '-complex*16iq') then + a_setname(-i_dat) = 'C16-I C16-Q' + i_setchdr(-i_dat) = 0 + i_setctlr(-i_dat) = 0 + i_setvfmt(-i_dat) = 15 + 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. '-c16mag' ) then + i_setvfmt(i_tmp) = 15 + else if (a_value .eq. '-c16pha' ) then + i_setvfmt(i_tmp) = 16 + 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)(1:len(a_setinfo(i_tmp))) + 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)(1:len(a_hdrfile)) + + 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) = real(r_spc(1)) + r_setradr(i_tmp) = real(r_str(1)+r_spc(1)) + r_setcmlt(i_tmp) = real(r_spc(2)) + r_setcadr(i_tmp) = real(r_str(2)+r_spc(2)) + r_setpegv(1,i_tmp) = real(r_peg(1)) + r_setpegv(2,i_tmp) = real(r_peg(2)) + r_setpegv(3,i_tmp) = real(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_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(1:len(a_setname(i_tmp))) + 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(1:len(a_setname(0))) + 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(1:len(a_setname(i_tmp))) + 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(1:len(a_setname(0))) + 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(1:len(a_setname(-i_dat))) + 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)(1:len(a_setname(i_tmp))) + + 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(1:len(a_setfile(i_tmp))) + +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_setrows(i_tmp), + & i_setcols(i_tmp), + & i_setshdr(i_tmp), + & i_setvfmt(i_tmp), + & r_setvmlt(i_tmp), + & r_setvadr(i_tmp), + & r_setrmlt(i_tmp), + & r_setradr(i_tmp), + & r_setcmlt(i_tmp), + & r_setcadr(i_tmp), + & r_setpegv(1,i_tmp) ) +c write(6,*) 'openning1=',a_setname(i_tmp) !@#$% + call get_pdsinfo( ! Only executes if no header is specified + & a_setfile(i_tmp), + & a_setproj(i_tmp), + & i_setrows(i_tmp), + & i_setcols(i_tmp), + & i_setshdr(i_tmp), + & i_setrhdr(i_tmp), + & i_setvfmt(i_tmp), + & r_setrmlt(i_tmp), + & r_setradr(i_tmp), + & r_setcmlt(i_tmp), + & r_setcadr(i_tmp), + & r_setpegv(1,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_setrows(i_tmp), + & i_setcols(i_tmp), + & i_setshdr(i_tmp), + & i_setvend(i_tmp), + & i_setvfmt(i_tmp), + & r_setrmlt(i_tmp), + & r_setradr(i_tmp), + & r_setcmlt(i_tmp), + & r_setcadr(i_tmp), + & r_setpegv(1,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(1:len(a_setname(-i_dat))) + 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)(1:len(a_setname(i_tmp))) + + 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. '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) = real(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) = real(2.0d0*r_pi) + i_dspmode(i_chn) = 6 + a_dspctbl(i_chn) = 'cmy' + else 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) = real(2.0d0*r_pi) + i_dspmode(i_chn) = 6 + a_dspctbl(i_chn) = 'cmy' + else if (a_setname(i_chn) .eq. 'C16-Mag') then + i_setvfmt(i_chn) = 15 + else if (a_setname(i_chn) .eq. 'C16-Pha') then + i_setvfmt(i_chn) = 16 + r_dspwrap(i_chn) = real(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. 'C16-I') then + i_setvfmt(i_chn) = 5 + i_setchdr(i_chn) = 0 + i_setctlr(i_chn) = 8 + else if (a_setname(i_chn) .eq. 'C16-Q') then + i_setvfmt(i_chn) = 5 + i_setchdr(i_chn) = 8 + i_setctlr(i_chn) = 0 + 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 + 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) = real(1.0d0/3600) + r_setradr(i_chn) = i_lat + r_setrmlt(i_chn) = real(-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) = cnvt_to_byte(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) = cnvt_to_byte(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_set .lt. 1) then + write(6,*) ' ' + stop ' ' + end if + 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) = int(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) = real(r_sum/max(i_cnt,1)) + r_setvstd(i_chn) = real(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) = int((i_vxo(1,1)*r_winzoom(0))/r_winzoom(1)) + i_event(4) = int((i_vyo(1,1)*r_winzoom(0))/r_winzoom(1)) + i_event(5) = int(((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) = int(((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)=real(r_lat) + r_eux(2)=real(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=int(((r_dnx(1)-r_setradr(1))/r_setrmlt(1)-i_winradr(1) )) + i_ccenter=int(((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)(1:len(a_data(9))) + 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)(1:len(a_dspctbl(i_chn))) + 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)=real(r_lat/r_rtod) + r_eux(2)=real(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=int(((r_dnx(1)-r_setradr(1))/r_setrmlt(1)-i_winradr(1) )) + i_ccenter=int(((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 +c write(6,*) 'a_value=',a_value + 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)=real(r_avg) + r_setvstd(i_chn)=real(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)=real(r_avg/(0.7*r_dspval3(i_chn))) + else + if (i_dspaddr(i_chn) .eq. 1) r_dspaddr(i_chn) = real(r_avg-(r_dspval1(i_chn)*r_std)) + if (i_dspmult(i_chn) .eq. 1) r_dspmult(i_chn) = real(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)(1:len(a_data(9))) + 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(1:len(a_message)) + 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=int(i_row/r_winzoom(i_dsp)+i_winradr(i_dsp)) + i_ccenter=int(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_MAXCOLS) + 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_MAXCOLS) + 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_MAXCOLS) + 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_MAXCOLS) + 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_MAXCOLS) + 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_MAXCOLS) + 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_MAXCOLS) + 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_MAXCOLS) + 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_MAXCOLS) + 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(1:len(a_label1)-5) + + 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(1:len(a_label1)-5) + + 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(1:len(a_label1)-5) + + 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=int(i_row/r_winzoom(i_dsp)+i_winradr(i_dsp)) + i_ccenter=int(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) = int((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) = int((max(i_vxo(i_dsp,1)-1,0)/r_winzoom(i_dsp)+i_wincadr(i_dsp))*r_winzoom(0)) + i_event(4) = int((max(i_vyo(i_dsp,1)-1,0)/r_winzoom(i_dsp)+i_winradr(i_dsp))*r_winzoom(0)) + +c i_event(5) = int(((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) = int(((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) = int(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) = int((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(max(1,i-1)))**2.0+float(i_rsamps(i)-i_rsamps(max(1,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(max(1,i-1)))**2.0+float(i_rsamps(i)-i_rsamps(max(1,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) = cnvt_to_byte(max(0,min(255,int(r_rdat(ic+ir*i_encx)*256)))) + b_out(ic*3+2) = cnvt_to_byte(max(0,min(255,int(r_gdat(ic+ir*i_encx)*256)))) + b_out(ic*3+3) = cnvt_to_byte(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)(1:len(a_tname(i_found))) + a_tcmnd(i_found)=a_inarg(2)(1:len(a_tcmnd(i_found))) + 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)(1:len(a_tname(i_found))) + a_tcmnd(i_found)=a_inarg(2)(1:len(a_tcmnd(i_found))) + 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)(1:len(a_tname(i_found))) + a_tcmnd(i_found)=a_inarg(2)(1:len(a_tcmnd(i_found))) + 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)(1:len(a_clickcmd(1))) + 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)(1:len(a_tname(i_found))) + a_tcmnd(i_found)=a_inarg(2)(1:len(a_tcmnd(i_found))) + 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)(1:len(a_colorname(i_colormax))) + a_colorfile(i_colormax)=a_inarg(2)(1:len(a_colorfile(i_colormax))) +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 + + byte function cnvt_to_byte(i_input) + + implicit none + integer*4 i_input + + cnvt_to_byte = i_input + + 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,160, 170), 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 +160 continue ! 6 - complex magnitude + i_bytes=16 + goto 200 +170 continue ! 7 - complex phase + i_bytes=16 + 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 ! Number of lines in action + integer*4 i_blks ! Number of blocks needed to complete action + 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 (abs(r_dd) .gt. epsilon(0.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_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)=real(r_lat) + r_loc22(2)=real(r_lon) + r_loc22(3)=real(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)=real(r_lon*r_rad) ! Convert sch + r_loc11(2)=real(r_lat*r_rad) + r_loc11(3)=real(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)=real(r_lon*r_rad) ! Convert sch + r_loc11(2)=real(r_lat*r_rad) + r_loc11(3)=real(r_hhh) + else if (a_setproj .eq. 'eqa' .or. a_setproj .eq. 'EQA') then + r_loc11(1)=real(r_lat*r_rtod) + r_loc11(2)=real(r_lon*r_rtod) + r_loc11(3)=real(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 + + if (i_debug .eq. -71) write(6,*) 'In buffer_cmd ',i_base,i_abort ! dummy debut to avoid unused dummy-argument-error +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 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_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' + + 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 + + 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=real(r_mdnc(1)) + r_madd=real(r_mdnc(2)) + else if (index(a_tmp,'Elevation Scale and Shift') .gt. 0) then + read(a_tmp,*) r_ddnc + r_dmul=real(r_ddnc(1)) + r_dadd=real(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_setrows, + & i_setcols, + & i_setshdr, + & i_setvfmt, + & r_setvmlt, + & r_setvadr, + & r_setrmlt, + & r_setradr, + & r_setcmlt, + & r_setcadr, + & r_setpegv ) + +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_setproj ! Projection name + 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_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_setpegv(3) ! Peg Point +c end structure + + + 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 (abs(r_temp) .gt. 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) = real(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) = real(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) = real(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_setfile, + & a_setproj, + & i_setrows, + & i_setcols, + & i_setshdr, + & i_setrhdr, + & i_setvfmt, + & r_setrmlt, + & r_setradr, + & r_setcmlt, + & r_setcadr, + & r_setpegv, + & i_debug ) + +c structure / set_structure / s_set(-I_FMAX:I_CMAX) + character*200 a_setfile ! Data filename + character*200 a_setproj ! Projection name + 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_setrhdr ! Number of bytes in row header + 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_setpegv(3) ! Peg Point +c end structure + + 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 + + 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) = real(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) = real(r_setpegv(2) / r_rtod) + else if (a_key .eq. ' OBLIQUE_PROJ_POLE_ROTATION') then + read(a_val,*) r_setpegv(3) + r_setpegv(3) = real(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_setrows, + & i_setcols, + & i_setshdr, + & i_setvend, + & i_setvfmt, + & r_setrmlt, + & r_setradr, + & r_setcmlt, + & r_setcadr, + & r_setpegv, + & 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_setproj ! Projection name + 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_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_setpegv(3) ! Peg Point +c end structure + + 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 + + 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_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_setpegv(3) ! Peg Point +c end structure + +c structure / dspinfo / s_dsp + character*200 a_dspctbl ! Color table file + 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_dspmode + integer i_dspdvdc +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_dspval1 + real*4 r_dspval2 + real*4 r_dspval3 +c end structure + +c LOCAL VARIABLES: + + integer*4 i_flg + integer*4 i_indx + + character*255 a_key + character*320 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(1:len(a_setname)) + 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(1:len(a_setvnul)) + 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_value=rdfvalu(a_key(1:max(1,rdflen(a_key)))//'set_proj') + a_setproj=a_value(1:len(a_setproj)) + 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_value=rdfvalu(a_key(1:max(1,rdflen(a_key)))//'dsp_cmap') + a_dspctbl=a_value(1:len(a_dspctbl)) + 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_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_setinfo ! Header filename + character*200 a_setproj ! Projection name + 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_setpegv(3) ! Peg Point +c end structure + + +c LOCAL VARIABLES: + + 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 if (rdfupper(a_fmt) .eq. 'COMPLEX*16_MAGNITUDE') then + i_fmt = 15 + else if (rdfupper(a_fmt) .eq. 'COMPLEX*16_PHASE') then + i_fmt = 16 + 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,*) '-c16,or -complex*16 = 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,*) '-c16mag, or = Magnitude portion of a c8 file only' + write(6,*) '-c16pha, or = 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,*) 'To create a set using simple math functions using previously defined sets, have the' + write(6,*) ' set name start with an "=" sign. Use "s" followed by the set number to indicate' + write(6,*) ' the set to use. For example, to display the sum of set 1 and set 2 use the ' + write(6,*) ' following: ' + write(6,*) ' ' + write(6,*) ' -set =s1+s2' + write(6,*) ' ' + write(6,*) ' The valid operations are + - x /. Operations are performed left to right on the ' + write(6,*) ' running total' + 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) + + integer I_MAXCOLS + parameter(I_MAXCOLS = 200000) !@#$% This line needs to be modified to match I_MAXCOLS values + byte b_data(0:I_MAXCOLS) + save b_data + + real*4 r_last + real*4 r_next + + integer*4 i_last + integer*4 i_next + + 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) + + i_err=0 + + 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 = int(i_stopc - i_strtc) + nread = ioread(i_setunit,b_data(max(0,-i_colsize*i_col)),i_numxx) + else + i_numxx = int(i_stopc - i_strtc) + nread = int(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 (abs(r_data(i) - r_data(i)) .lt.epsilon(0.0)) 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 + r_last=r_data(0) + i_last=i_data(0) + do i = 0, i_num-1 + r_next=r_data(i) + i_next=i_data(i) + i_ll=max(0,i-1) + i_hh=min(i_num-1,i+1) + if (i_last .eq. 0 .and. i_data(i_hh) .eq. 0) then + i_data(i)=0 + r_data(i)=(r_data(i_hh)-r_last)/(i_hh-i_ll) + else + i_data(i)=1 + r_data(i)=0 + end if + r_last=r_next + i_last=i_next + 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,160,170), 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 = real(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 = real(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 (abs(r_value4(2)) .lt. epsilon(0.0) .and. abs(r_value4(1)) .lt. epsilon(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) = int2(i_value2(1)-256) + i_value2(2) = b_data(2) + if (i_value2(2) .ge. 128) i_value2(2) = int2(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 + +160 continue ! Complex*16 Magnitude + if (i_end .gt. 0) then + do i=1,16 + 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) + b_value( 8+i) = b_data(13-i) + b_value(12+i) = b_data(17-i) + end do + end if + r_realval = r_value8(1) + r_imagval = r_value8(2) + r_val = real(sqrt(r_realval**2+r_imagval**2)) + goto 200 + +170 continue ! Complex*16 Phase + if (i_end .gt. 0) then + do i=1,16 + 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) + b_value( 8+i) = b_data(13-i) + b_value(12+i) = b_data(17-i) + end do + end if + if (abs(r_value8(2)) .lt. epsilon(0.0d0) .and. abs(r_value8(1)) .lt. epsilon(0.0d0)) then + r_val=0.0 + else + r_val = real(atan2(r_value8(2),r_value8(1))) + end if + 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 diff --git a/contrib/mdx/src/mdx_main.F b/contrib/mdx/src/mdx_main.F index ce77460d8..b6473ee04 100644 --- a/contrib/mdx/src/mdx_main.F +++ b/contrib/mdx/src/mdx_main.F @@ -1,11 +1,11 @@ c!@##$%^&012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012 -c! 1 2 3 4 5 6 7 8 9 10 11 12 13 +c! 1 2 3 4 5 6 7 8 9 10 11 12 13 c c Copyright 2001, by the California Institute of Technology. c ALL RIGHTS RESERVED. United States Government Sponsorship acknowledged. c Any commercial use must be negotiated with the Office of Technology c Transfer at the California Institute of Technology. -c +c c This software may be subject to U.S. export control laws and regulations. c By accepting this document, the user agrees to comply with all applicable c U.S. export laws and regulations. User has the responsibility to obtain @@ -64,6 +64,11 @@ program mdx cc* cc* v194 2013-03-29 SJS - Incorporated initialization that Ron suggested to fix printing with -P, also increased to 10 channels cc* +cc* v195 2014-04-30 RJM - added code at CRJM1, need larger a_cmd line length +cc* +cc* v196 2021-03-27 SJS - added c16 +cc* +cc* v197 2025-03-07 SJS - Clean up code c***************************************************************** implicit none @@ -76,7 +81,7 @@ program mdx integer rdflen external rdflen - + #ifdef IO64 integer*8 mdxfunc_sample external mdxfunc_sample @@ -94,28 +99,32 @@ program mdx character*18 version_mdx external version_mdx + + character*18 version_gpx + external version_gpx - integer version_gx - external version_gx + character*50 rdfversion + external rdfversion integer i,j byte b_data(4000000) real*4 r_data(1000000) equivalence(b_data,r_data) - - a_cmd = '-V' + + a_cmd = ' ' i_inarg = command_argument_count() if (i_inarg .eq. 0) 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,*) ' ' + write(6,'(1x,a,a17,a)' ) ' << mdx Version ',version_mdx(),' >> ' + write(6,'(1x,a,a18,a)' ) ' << graphx Version ',version_gpx(),' >> ' + write(6,*) rdfversion() + write(6,*) ' ' call write_greeting() stop 'done' else do i_arg =1, i_inarg call getarg(i_arg,a_value) -c write(6,*) i_arg,':',a_value(1:20) +c write(6,*) i_arg,':',a_value(1:20) do i=1,rdflen(a_value)+1 if (ichar(a_value(i:i)) .eq. 0) a_value(i:i)=' ' end do @@ -126,7 +135,7 @@ program mdx end if end do end if -c write(6,*) a_cmd +c write(6,*) a_cmd do i=1,500 @@ -134,8 +143,8 @@ program mdx r_data(i+(j-1)*500) = i+j/500. end do end do - i=mdxfunc_sample(2,1,i_eight(0),4*500*500,b_data) -c write(6,*) 'Calling mdxsub' + i=int(mdxfunc_sample(2,1,i_eight(0),4*500*500,b_data)) +c write(6,*) 'Calling mdxsub' call mdxsub(a_cmd,i_eight(4000000),mdxfunc_sample) end @@ -222,8 +231,3 @@ integer*4 function mdxfunc_sample(i_flag,i_chn,i_start,i_num,b_data) return end - character*(*) function version_mdx() - - version_mdx = '194.0 29-Mar-2013' - return - end diff --git a/contrib/mdx/src/mdx_subs.F b/contrib/mdx/src/mdx_subs.F index a571f8255..b7db064e6 100644 --- a/contrib/mdx/src/mdx_subs.F +++ b/contrib/mdx/src/mdx_subs.F @@ -1,9657 +1,9596 @@ - 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_dspaddr = 0 - r_dspaddr = 0. - 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_dspaddr = 0 - r_dspaddr = 0. - 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_dspaddr = 0 - r_dspaddr = 0. - 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 + character*(*) function version_mdx() + + version_mdx = '197.0 07-Mar-2025' + return + end + + subroutine mdxsub(a_cmd,i_maxbuff,readfunc) + + implicit none + + integer I_WKSPACE + integer I_MAXCOLS + integer I_MAXROWS + parameter(I_WKSPACE = 200000) ! CRJM1 + parameter(I_MAXCOLS = 200000) ! CRJM1 + parameter(I_MAXROWS = 200000) ! CRJM1 + + 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 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_stat + integer i_dflag + integer i_value + integer i_field + + 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_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) + save r_data + save r_data2 + save i_data + save i_data2 + + real*8 r_sqr + real*8 r_sum + real*8 r_avg + real*8 r_std + + real*4 r_dnx(3) + real*4 r_eux(3) + + real*8 r_pi + real*8 r_rtod + + integer i_smode + integer i_samps + integer i_rsamps(I_MAXCOLS) + integer i_csamps(I_MAXCOLS) + integer i_tsamps(I_MAXCOLS) + real*4 r_wsamps(I_MAXCOLS) + real*4 r_ssamps(I_MAXCOLS) + real*4 r_vsamps(I_MAXCOLS,I_CMAX) + save i_rsamps + save i_csamps + save i_tsamps + save r_wsamps + save r_ssamps + save r_vsamps + + real*4 r_row(I_MAXROWS) + real*4 r_col(I_MAXCOLS) + real*4 r_rowlow + real*4 r_rowhigh + real*4 r_collow + real*4 r_colhigh + real*4 r_path + save r_row + save r_col + + real*4 r_wdth + real*4 r_spce + real*4 r_dist + + integer ii + 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_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 + 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(I_DMAX,-10:10) ! window x size + integer i_wys(I_DMAX,-10:10) ! window y size + integer i_vxs(I_DMAX,-10:10) ! viewport x size + integer i_vys(I_DMAX,-10:10) ! viewport y size + integer i_vxo(I_DMAX,-10:10) ! viewport x offset + integer i_vyo(I_DMAX,-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) + save i_indx, 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 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) + save r_val + + 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_strt + integer i_stop + integer i_incr + integer i_coff + + integer i_close + + integer i_redraw(I_DMAX) + 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 + 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 + + byte cnvt_to_byte + external cnvt_to_byte + + character*18 version_mdx + external version_mdx + + character*18 version_gpx + external version_gpx + + character*50 rdfversion + external rdfversion + +#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 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) = real(-1.0d27) + r_setvmax(0) = real( 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' .or. a_value .eq. '-v') then + write(6,*) ' ' + write(6,'(1x,a,a17,a)' ) ' << mdx Version ',version_mdx(),' >> ' + write(6,'(1x,a,a18,a)' ) ' << graphx Version ',version_gpx(),' >> ' + write(6,*) rdfversion() + 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 (abs(r_dspwrap(i_tmp)) .gt. 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) = real(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)(1:len(a_dspctbl(i_tmp))) + do i=1,i_colormax + if (a_dspctbl(i_tmp) .eq. a_colorname(i)) a_dspctbl(i_tmp)=a_colorfile(i)(1:len(a_dspctbl(i_tmp))) + end do + else if (a_value .eq. '-null') then + i_arg=i_arg+1 + a_setvnul(i_tmp)=a_inarg(i_arg)(1:len(a_setvnul)) + 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)(1:len(a_nullclr)) + 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)(1:len(a_lcolor)) + 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)(1:len(a_clickcmd(1))) + 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. '-c16' .or. a_value .eq. '-complex*16') then + a_setname(-i_dat) = 'C16-Mag C16-Pha' + i_setchdr(-i_dat) = 0 + i_setctlr(-i_dat) = 0 + i_setvfmt(-i_dat) = 15 + 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. '-c16iq' .or. a_value .eq. '-complex*16iq') then + a_setname(-i_dat) = 'C16-I C16-Q' + i_setchdr(-i_dat) = 0 + i_setctlr(-i_dat) = 0 + i_setvfmt(-i_dat) = 15 + 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. '-c16mag' ) then + i_setvfmt(i_tmp) = 15 + else if (a_value .eq. '-c16pha' ) then + i_setvfmt(i_tmp) = 16 + 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)(1:len(a_setinfo(i_tmp))) + 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)(1:len(a_hdrfile)) + + 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) = real(r_spc(1)) + r_setradr(i_tmp) = real(r_str(1)+r_spc(1)) + r_setcmlt(i_tmp) = real(r_spc(2)) + r_setcadr(i_tmp) = real(r_str(2)+r_spc(2)) + r_setpegv(1,i_tmp) = real(r_peg(1)) + r_setpegv(2,i_tmp) = real(r_peg(2)) + r_setpegv(3,i_tmp) = real(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_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(1:len(a_setname(i_tmp))) + 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(1:len(a_setname(0))) + 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(1:len(a_setname(i_tmp))) + 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(1:len(a_setname(0))) + 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(1:len(a_setname(-i_dat))) + 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)(1:len(a_setname(i_tmp))) + + 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(1:len(a_setfile(i_tmp))) + +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_setrows(i_tmp), + & i_setcols(i_tmp), + & i_setshdr(i_tmp), + & i_setvfmt(i_tmp), + & r_setvmlt(i_tmp), + & r_setvadr(i_tmp), + & r_setrmlt(i_tmp), + & r_setradr(i_tmp), + & r_setcmlt(i_tmp), + & r_setcadr(i_tmp), + & r_setpegv(1,i_tmp) ) +c write(6,*) 'openning1=',a_setname(i_tmp) !@#$% + call get_pdsinfo( ! Only executes if no header is specified + & a_setfile(i_tmp), + & a_setproj(i_tmp), + & i_setrows(i_tmp), + & i_setcols(i_tmp), + & i_setshdr(i_tmp), + & i_setrhdr(i_tmp), + & i_setvfmt(i_tmp), + & r_setrmlt(i_tmp), + & r_setradr(i_tmp), + & r_setcmlt(i_tmp), + & r_setcadr(i_tmp), + & r_setpegv(1,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_setrows(i_tmp), + & i_setcols(i_tmp), + & i_setshdr(i_tmp), + & i_setvend(i_tmp), + & i_setvfmt(i_tmp), + & r_setrmlt(i_tmp), + & r_setradr(i_tmp), + & r_setcmlt(i_tmp), + & r_setcadr(i_tmp), + & r_setpegv(1,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(1:len(a_setname(-i_dat))) + 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)(1:len(a_setname(i_tmp))) + + 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. '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) = real(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) = real(2.0d0*r_pi) + i_dspmode(i_chn) = 6 + a_dspctbl(i_chn) = 'cmy' + else 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) = real(2.0d0*r_pi) + i_dspmode(i_chn) = 6 + a_dspctbl(i_chn) = 'cmy' + else if (a_setname(i_chn) .eq. 'C16-Mag') then + i_setvfmt(i_chn) = 15 + else if (a_setname(i_chn) .eq. 'C16-Pha') then + i_setvfmt(i_chn) = 16 + r_dspwrap(i_chn) = real(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. 'C16-I') then + i_setvfmt(i_chn) = 5 + i_setchdr(i_chn) = 0 + i_setctlr(i_chn) = 8 + else if (a_setname(i_chn) .eq. 'C16-Q') then + i_setvfmt(i_chn) = 5 + i_setchdr(i_chn) = 8 + i_setctlr(i_chn) = 0 + 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 + 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) = real(1.0d0/3600) + r_setradr(i_chn) = i_lat + r_setrmlt(i_chn) = real(-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) = cnvt_to_byte(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) = cnvt_to_byte(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_set .lt. 1) then + write(6,*) ' ' + stop ' ' + end if + 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) = int(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) = real(r_sum/max(i_cnt,1)) + r_setvstd(i_chn) = real(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) = int((i_vxo(1,1)*r_winzoom(0))/r_winzoom(1)) + i_event(4) = int((i_vyo(1,1)*r_winzoom(0))/r_winzoom(1)) + i_event(5) = int(((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) = int(((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)=real(r_lat) + r_eux(2)=real(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=int(((r_dnx(1)-r_setradr(1))/r_setrmlt(1)-i_winradr(1) )) + i_ccenter=int(((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)(1:len(a_data(9))) + 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)(1:len(a_dspctbl(i_chn))) + 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)=real(r_lat/r_rtod) + r_eux(2)=real(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=int(((r_dnx(1)-r_setradr(1))/r_setrmlt(1)-i_winradr(1) )) + i_ccenter=int(((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 +c write(6,*) 'a_value=',a_value + 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)=real(r_avg) + r_setvstd(i_chn)=real(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)=real(r_avg/(0.7*r_dspval3(i_chn))) + else + if (i_dspaddr(i_chn) .eq. 1) r_dspaddr(i_chn) = real(r_avg-(r_dspval1(i_chn)*r_std)) + if (i_dspmult(i_chn) .eq. 1) r_dspmult(i_chn) = real(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)(1:len(a_data(9))) + 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(1:len(a_message)) + 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=int(i_row/r_winzoom(i_dsp)+i_winradr(i_dsp)) + i_ccenter=int(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_MAXCOLS) + 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_MAXCOLS) + 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_MAXCOLS) + 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_MAXCOLS) + 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_MAXCOLS) + 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_MAXCOLS) + 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_MAXCOLS) + 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_MAXCOLS) + 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_MAXCOLS) + 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(1:len(a_label1)-5) + + 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(1:len(a_label1)-5) + + 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(1:len(a_label1)-5) + + 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=int(i_row/r_winzoom(i_dsp)+i_winradr(i_dsp)) + i_ccenter=int(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) = int((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) = int((max(i_vxo(i_dsp,1)-1,0)/r_winzoom(i_dsp)+i_wincadr(i_dsp))*r_winzoom(0)) + i_event(4) = int((max(i_vyo(i_dsp,1)-1,0)/r_winzoom(i_dsp)+i_winradr(i_dsp))*r_winzoom(0)) + +c i_event(5) = int(((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) = int(((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) = int(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) = int((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(max(1,i-1)))**2.0+float(i_rsamps(i)-i_rsamps(max(1,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(max(1,i-1)))**2.0+float(i_rsamps(i)-i_rsamps(max(1,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) = cnvt_to_byte(max(0,min(255,int(r_rdat(ic+ir*i_encx)*256)))) + b_out(ic*3+2) = cnvt_to_byte(max(0,min(255,int(r_gdat(ic+ir*i_encx)*256)))) + b_out(ic*3+3) = cnvt_to_byte(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)(1:len(a_tname(i_found))) + a_tcmnd(i_found)=a_inarg(2)(1:len(a_tcmnd(i_found))) + 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)(1:len(a_tname(i_found))) + a_tcmnd(i_found)=a_inarg(2)(1:len(a_tcmnd(i_found))) + 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)(1:len(a_tname(i_found))) + a_tcmnd(i_found)=a_inarg(2)(1:len(a_tcmnd(i_found))) + 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)(1:len(a_clickcmd(1))) + 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)(1:len(a_tname(i_found))) + a_tcmnd(i_found)=a_inarg(2)(1:len(a_tcmnd(i_found))) + 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)(1:len(a_colorname(i_colormax))) + a_colorfile(i_colormax)=a_inarg(2)(1:len(a_colorfile(i_colormax))) +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 + + byte function cnvt_to_byte(i_input) + + implicit none + integer*4 i_input + + cnvt_to_byte = i_input + + 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,160, 170), 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 +160 continue ! 6 - complex magnitude + i_bytes=16 + goto 200 +170 continue ! 7 - complex phase + i_bytes=16 + 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 ! Number of lines in action + integer*4 i_blks ! Number of blocks needed to complete action + 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 (abs(r_dd) .gt. epsilon(0.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_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)=real(r_lat) + r_loc22(2)=real(r_lon) + r_loc22(3)=real(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)=real(r_lon*r_rad) ! Convert sch + r_loc11(2)=real(r_lat*r_rad) + r_loc11(3)=real(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)=real(r_lon*r_rad) ! Convert sch + r_loc11(2)=real(r_lat*r_rad) + r_loc11(3)=real(r_hhh) + else if (a_setproj .eq. 'eqa' .or. a_setproj .eq. 'EQA') then + r_loc11(1)=real(r_lat*r_rtod) + r_loc11(2)=real(r_lon*r_rtod) + r_loc11(3)=real(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 + + if (i_debug .eq. -71) write(6,*) 'In buffer_cmd ',i_base,i_abort ! dummy debut to avoid unused dummy-argument-error +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 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_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' + + 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 + + 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=real(r_mdnc(1)) + r_madd=real(r_mdnc(2)) + else if (index(a_tmp,'Elevation Scale and Shift') .gt. 0) then + read(a_tmp,*) r_ddnc + r_dmul=real(r_ddnc(1)) + r_dadd=real(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_setrows, + & i_setcols, + & i_setshdr, + & i_setvfmt, + & r_setvmlt, + & r_setvadr, + & r_setrmlt, + & r_setradr, + & r_setcmlt, + & r_setcadr, + & r_setpegv ) + +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_setproj ! Projection name + 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_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_setpegv(3) ! Peg Point +c end structure + + + 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 (abs(r_temp) .gt. 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) = real(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) = real(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) = real(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_setfile, + & a_setproj, + & i_setrows, + & i_setcols, + & i_setshdr, + & i_setrhdr, + & i_setvfmt, + & r_setrmlt, + & r_setradr, + & r_setcmlt, + & r_setcadr, + & r_setpegv, + & i_debug ) + +c structure / set_structure / s_set(-I_FMAX:I_CMAX) + character*200 a_setfile ! Data filename + character*200 a_setproj ! Projection name + 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_setrhdr ! Number of bytes in row header + 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_setpegv(3) ! Peg Point +c end structure + + 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 + + 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) = real(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) = real(r_setpegv(2) / r_rtod) + else if (a_key .eq. ' OBLIQUE_PROJ_POLE_ROTATION') then + read(a_val,*) r_setpegv(3) + r_setpegv(3) = real(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_setrows, + & i_setcols, + & i_setshdr, + & i_setvend, + & i_setvfmt, + & r_setrmlt, + & r_setradr, + & r_setcmlt, + & r_setcadr, + & r_setpegv, + & 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_setproj ! Projection name + 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_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_setpegv(3) ! Peg Point +c end structure + + 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 + + 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_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_setpegv(3) ! Peg Point +c end structure + +c structure / dspinfo / s_dsp + character*200 a_dspctbl ! Color table file + 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_dspmode + integer i_dspdvdc +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_dspval1 + real*4 r_dspval2 + real*4 r_dspval3 +c end structure + +c LOCAL VARIABLES: + + integer*4 i_flg + integer*4 i_indx + + character*255 a_key + character*320 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(1:len(a_setname)) + 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(1:len(a_setvnul)) + 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_value=rdfvalu(a_key(1:max(1,rdflen(a_key)))//'set_proj') + a_setproj=a_value(1:len(a_setproj)) + 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_value=rdfvalu(a_key(1:max(1,rdflen(a_key)))//'dsp_cmap') + a_dspctbl=a_value(1:len(a_dspctbl)) + 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_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_setinfo ! Header filename + character*200 a_setproj ! Projection name + 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_setpegv(3) ! Peg Point +c end structure + + +c LOCAL VARIABLES: + + 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 if (rdfupper(a_fmt) .eq. 'COMPLEX*16_MAGNITUDE') then + i_fmt = 15 + else if (rdfupper(a_fmt) .eq. 'COMPLEX*16_PHASE') then + i_fmt = 16 + 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,*) '-c16,or -complex*16 = 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,*) '-c16mag, or = Magnitude portion of a c8 file only' + write(6,*) '-c16pha, or = 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,*) 'To create a set using simple math functions using previously defined sets, have the' + write(6,*) ' set name start with an "=" sign. Use "s" followed by the set number to indicate' + write(6,*) ' the set to use. For example, to display the sum of set 1 and set 2 use the ' + write(6,*) ' following: ' + write(6,*) ' ' + write(6,*) ' -set =s1+s2' + write(6,*) ' ' + write(6,*) ' The valid operations are + - x /. Operations are performed left to right on the ' + write(6,*) ' running total' + 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) + + integer I_MAXCOLS + parameter(I_MAXCOLS = 200000) !@#$% This line needs to be modified to match I_MAXCOLS values + byte b_data(0:I_MAXCOLS) + save b_data + + real*4 r_last + real*4 r_next + + integer*4 i_last + integer*4 i_next + + 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) + + i_err=0 + + 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 = int(i_stopc - i_strtc) + nread = ioread(i_setunit,b_data(max(0,-i_colsize*i_col)),i_numxx) + else + i_numxx = int(i_stopc - i_strtc) + nread = int(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 (abs(r_data(i) - r_data(i)) .lt.epsilon(0.0)) 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 + r_last=r_data(0) + i_last=i_data(0) + do i = 0, i_num-1 + r_next=r_data(i) + i_next=i_data(i) + i_ll=max(0,i-1) + i_hh=min(i_num-1,i+1) + if (i_last .eq. 0 .and. i_data(i_hh) .eq. 0) then + i_data(i)=0 + r_data(i)=(r_data(i_hh)-r_last)/(i_hh-i_ll) + else + i_data(i)=1 + r_data(i)=0 + end if + r_last=r_next + i_last=i_next + 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,160,170), 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 = real(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 = real(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 (abs(r_value4(2)) .lt. epsilon(0.0) .and. abs(r_value4(1)) .lt. epsilon(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) = int2(i_value2(1)-256) + i_value2(2) = b_data(2) + if (i_value2(2) .ge. 128) i_value2(2) = int2(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 + +160 continue ! Complex*16 Magnitude + if (i_end .gt. 0) then + do i=1,16 + 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) + b_value( 8+i) = b_data(13-i) + b_value(12+i) = b_data(17-i) + end do + end if + r_realval = r_value8(1) + r_imagval = r_value8(2) + r_val = real(sqrt(r_realval**2+r_imagval**2)) + goto 200 + +170 continue ! Complex*16 Phase + if (i_end .gt. 0) then + do i=1,16 + 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) + b_value( 8+i) = b_data(13-i) + b_value(12+i) = b_data(17-i) + end do + end if + if (abs(r_value8(2)) .lt. epsilon(0.0d0) .and. abs(r_value8(1)) .lt. epsilon(0.0d0)) then + r_val=0.0 + else + r_val = real(atan2(r_value8(2),r_value8(1))) + end if + 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