C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C***************************** C** Program 'lauegen' ** ****** L D M ****** C***************************** C C Purpose: Generate Laue patterns and reflections lists; Determine and C refine crystal orientations. C C Author: John W. Campbell, May 1990 (Original version) C Sep 1993 (Incorporation of LDM) C Sep 1994 Version 3.0 with soft-limits C determinations C Oct 1994 Version 3.1 with 'automatic' C refinements including lg_refine command C Nov 1994 Soft limit commands lg_dmin, lg_lmin C Nov 1994 Allow for overwrite of existing files C Nov 1994 Default is to write a log file named C 'lauegen.log'. May be suppressed C by giving log file name of 'none' C via command line arg '-l logfile' C or environment variable LAUEGEN_LOG C Nov 1994 Log writing of new parameters file C Aug 1996 Version 4.1 C Add spot size determining option, C spot integration, automatic C refinement option and command line C processing options. C Feb 1997 Version 4.2 C Allow deconvolution of spatially C overlapped spots C Feb 1997 Version 5.0 C Add option for Gnomonic projection C simulations C Jul 1997 Version 6.0 C Allow for new treatment of overloads. C Changes for LIRL/LSM related mods. C Cylindrical detector option. 'mar' C and 'pfbyte' image formats. Allow C different width & height limits for C image display. (Changes to libraries C LRL, LFN, LIRL, LDM and MTZ o/p format) C C C C Program uses xdl_view (X-windows) routines. C C This version uses the Laue Data Module (LDM) and related program C independent functions C C Externally Selectable Options C ============================= C C The following environment variables (logical names on Vax) may be set C C LAUEGEN_FONT Set to a value from 1 to 5 to select font size C for the parameter tables, menu area, io-window etc. C (the default is 2) C C LAUEGEN_LOG Set to the name of a log file (this will be used C unless a log file name was set via the command C line arguments). If the value is 'NONE' no log file C will be written unless specified in the command C line arguments. C C LAUEGEN_UPD Parameter updates flags for other packs/plates. C Follow by a number with flags set for parameters C to be updated as follows (value is sum of the C numbers given for the required flags): C default C Update lambda_min, lambda_max 1 y C Update d_min 2 y C Update phix, phiy, phiz 4 y C Update c_to_f 8 y C Update x_cen_f, y_cen_f 16 y C Update x_c, y_c 32 y C Update w_c 64 n C Update y_scale 128 y C Update twist, tilt 256 y C Update bulge 512 n C Update roff, toff 1024 y C Update spd parameters 2048 y C Update spot size parameters 4096 y C C default is equivalent to 7615 (all=8191) C C Command line arguments C ====================== C C One of the following may be given -x (or x) Run in interactive mode on an C X-windows terminal C -t (or t) Run on a text terminal with C command input C -b (or b) Run in backround mode C C In addition the code -l (or l) may be given followed by the name of C an output log file. This will override any one set via the LAUEGEN_LOG C environment variable and the program will not itself prompt for a log C file name. C C====================================================================== C INCLUDE 'implicit_none.finc' C C C====== PARAMETERS: C INCLUDE 'lauegen_limits.finc' INCLUDE 'screen_params.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'ip1_entries.finc' INCLUDE 'ip2_entries.finc' INCLUDE 'film_pack.finc' INCLUDE 'prog_flags.finc' INCLUDE 'spot_box.finc' INCLUDE 'gnom_rmin.finc' INCLUDE 'file_units.finc' INCLUDE 'cell_input.finc' INCLUDE 'process_omit.finc' INCLUDE 'spot_data.finc' INCLUDE 'lauegen_observed_spots.finc' INCLUDE 'image.finc' INCLUDE 'selrefs.finc' INCLUDE 'matches.finc' INCLUDE 'symbol_types.finc' INCLUDE 'refine_params.finc' INCLUDE 'meas_spots.finc' INCLUDE 'conics.finc' INCLUDE 'lauegen_auto_params.finc' INCLUDE 'get_soft.finc' INCLUDE 'auto_soft.finc' INCLUDE 'spot_sizes.finc' INCLUDE 'bg_progress.finc' INCLUDE 'upd_flags.finc' INCLUDE 'autorefn_flags.finc' INCLUDE 'integ_pars.finc' INCLUDE 'lirl_pars.finc' INCLUDE 'save_pkpl.finc' C C====== FUNCTION TYPES: C INTEGER INTFP INTEGER LENSTR INTEGER IARGC C C====== LOCALS: C C C====== xdl_view setup parameters C INTEGER NUMC INTEGER NCOLORS(2) INTEGER NPLANES(2) C INTEGER NUMC ! Number of colormaps C INTEGER NCOLORS(2) ! Array of NUMC 'ncolors' numbers C INTEGER NPLANES(2) ! Array of NUMC 'nplanes' numbers C C====== Miscellaneous parameters C LOGICAL EOF LOGICAL QUIT LOGICAL PROC_SAV INTEGER I INTEGER IERR INTEGER IVHLIST(10) INTEGER IVH INTEGER IV INTEGER NARG INTEGER IOP INTEGER IFLAG INTEGER IFAIL INTEGER IUPD INTEGER ND INTEGER LL INTEGER LISTE(2) INTEGER IRET REAL FP CHARACTER*20 FONTSTR CHARACTER*2 ERRSTR CHARACTER*150 CMDLIN CHARACTER*2 CMD_OPTS(8) CHARACTER*(MAXFLEN) LOG_FILE CHARACTER*8 DATSTR CHARACTER*8 TIMSTR CHARACTER*80 HEADER CHARACTER*8 UPDSTR CHARACTER*20 TMPSTR C LOGICAL EOF !End of file input flag C LOGICAL QUIT !Quit program flag C LOGICAL PROC_SAV !Save value of 'PROCESS' mode flag C INTEGER I !Temp/loop variable C INTEGER IERR !Error return flag C INTEGER IVHLIST(10) !View-object handles list for getting events C INTEGER IVH !View-object handle from getting events C INTEGER IV !Integer value from INTFP C INTEGER NARG !No. of command line arguments C INTEGER IOP !Command line option number C INTEGER IFLAG !Parameter status flag C INTEGER IFAIL !File opening flag C INTEGER IUPD !Flag for setting required parameter updates C INTEGER ND !No. of decimal places flag C INTEGER LL !String length (significant) C INTEGER LISTE(2) !Dummy array for SET_PAR1_VALS,SET_PAR2_VALS calls C INTEGER IRET !Return flag form CHECK_INTEGRATED C REAL FP !Real value from INTFP C CHARACTER*20 FONTSTR !Character string to receive value of LAUEGEN_FONT C !environment variable C CHARACTER*2 ERRSTR !Error string (dummy) C CHARACTER*150 CMDLIN !Command line C CHARACTER*2 CMD_OPTS(8) !Command line options C CHARACTER*(MAXFLEN) LOG_FILE !Name of log file C CHARACTER*8 DATSTR !Date string C CHARACTER*8 TIMSTR !Time string C CHARACTER*80 HEADER !Log file header C CHARACTER*8 UPDSTR !Parameter updates flag string C CHARACTER*20 TMPSTR DATA CMD_OPTS/'-X','X','-T','T','-B','B','-L','L'/ C C------------------------------------------------------------------------------- C C====== Set current version C VERSTR = '6.0' C C====== Preliminary initialisations C LG_MODE = 1 CALL TRWSET (5, 6, 0, 0, 0) LOG_FILE = ' ' C C====== Extend LDM parameter set with parameters required by LAUEGEN C CALL EXTEND_LDM C C====== Interpret command line arguments C NARG = IARGC() IF (NARG.GT.0) THEN I = 0 10 I = I + 1 IF (I.GT.NARG) GO TO 20 CALL UGTARG (I, CMDLIN) CALL CCPUPC (CMDLIN) CALL GETOPT (CMD_OPTS, 8, CMDLIN, IOP, IERR) IF (IERR.GT.0) GO TO 10 IF (IOP.EQ.1.OR.IOP.EQ.2) THEN LG_MODE = 1 ELSE IF (IOP.EQ.3.OR.IOP.EQ.4) THEN LG_MODE = 2 ELSE IF (IOP.EQ.5.OR.IOP.EQ.6) THEN LG_MODE = 3 ELSE IF (IOP.EQ.7.OR.IOP.EQ.8) THEN IF (I.LT.NARG) THEN I = I + 1 CALL UGTARG (I, LOG_FILE) END IF END IF GO TO 10 END IF C C====== Initialise the xdl_view routines C 20 IF (LG_MODE.EQ.1) THEN NUMC = 1 NCOLORS(1) = 72 NPLANES(1) = 0 CALL XDLF_OPEN_VIEW (NUMC, NCOLORS, NPLANES, IERR) IF (IERR.GT.0) THEN WRITE (6,2001) IERR IF (IERR.NE.1) STOP END IF END IF C C====== Assign the view-object handles C IVH_BASE = 1 IVH_PAR1 = 2 IVH_PAR2 = 3 IVH_PAR3 = 4 IVH_MENU = 5 IVH_IOW = 6 IVH_CMD = 7 IVH_BAR = 8 IVH_FILM = 9 IVH_GRAPH = 10 IVH_BASE_AUT = 11 IVH_TABL_AUT = 12 IVH_MENU_AUT = 13 IVH_IOW_AUT = 14 IVH_SIM = 15 IVH_AUTR_BASE = 16 IVH_AUTR_TAB = 17 IVH_AUTR_GRA = 18 IVH_AUTR_MEN = 19 IVH_CNCL_BUT = 20 IVH_PROF_TAB = 21 C C====== Set logical unit nos. C IUN_LOG = 10 IUN_GEN = 20 IUN_MATCH = 21 IUN_REFLIST = 22 IUN_GE1 = 23 IUN_GE2 = 24 IUN_SPOTS = 25 C C====== Initialise flags C CALL INIT_FLAGS C C====== Initialise symbol types C ISYMBTYP(1) = 2 ICOLRTYP(1) = 3 ISYMBTYP(2) = 2 ICOLRTYP(2) = 5 ISYMBTYP(3) = 4 ICOLRTYP(3) = 1 ISYMBTYP(4) = 24 ICOLRTYP(4) = 1 ISYMBTYP(5) = 4 ICOLRTYP(5) = 4 ISYMBTYP(6) = 4 ICOLRTYP(6) = 1 ISYMBTYP(7) = 4 ICOLRTYP(7) = 1 ISYMBTYP(8) = 3 ICOLRTYP(8) = 5 ISYMBTYP(9) = 24 ICOLRTYP(9) = 1 ISYMBTYP(10) = 13 ICOLRTYP(10) = 4 ISYMBTYP(11) = 10 ICOLRTYP(11) = 1 C C====== Other initialisations C MAX_OBSERVED = MAX_OBS CALL SET_OMIT (1) KDX_LIRL = -1 KDX_INTFLAGS = -1 KEY_LOG = 1 CALL INIT_LIRL C C====== Get required font size (LAUEGEN_FONT) C IFONT = 2 CALL UGTENV ('LAUEGEN_FONT',FONTSTR) IF (FONTSTR.NE.' ') THEN IF (INTFP(FONTSTR,FP,IV).EQ.1) THEN IF (IV.GE.1.AND.IV.LE.5) IFONT = IV END IF END IF C C====== Open log file if defined (LAUEGEN_LOG) C IF (LOG_FILE.EQ.' ') THEN CALL UGTENV ('LAUEGEN_LOG',LOG_FILE) END IF TMPSTR = LOG_FILE CALL CCPUPC (TMPSTR) IF (LOG_FILE.EQ.' ') LOG_FILE = 'lauegen.log' IF (TMPSTR.NE.'NONE') THEN IFAIL = 1 CALL CCPDPN (-IUN_LOG, LOG_FILE,'UNKNOWN','F',0,IFAIL) IF (IFAIL.LT.0) THEN WRITE (6,2002) LOG_FILE(1:LENSTR(LOG_FILE)) STOP END IF ELSE IUN_LOG = 0 END IF IF (IUN_LOG.GT.0) THEN CALL CCPDAT(DATSTR) CALL UTIME(TIMSTR) HEADER = 'LAUEGEN program (version' CALL STR_ADDS (HEADER, VERSTR, 1) CALL STR_ADDS (HEADER, '): Run on', 0) CALL STR_ADDS (HEADER, DATSTR, 1) CALL STR_ADDS (HEADER, 'at',1) CALL STR_ADDS (HEADER, TIMSTR, 1) LL = LENSTR(HEADER) WRITE (IUN_LOG,6000) HEADER(1:LL) WRITE (IUN_LOG,6001) ('=',I = 1, LL) WRITE (IUN_LOG,6002) END IF C C====== See if parameter update flags set (LAUEGEN_UPD) C IUPD = -1 CALL UGTENV ('LAUEGEN_UPD',UPDSTR) IF (UPDSTR.NE.' ') THEN IF (INTFP(UPDSTR,FP,IV).EQ.1) THEN IF (IV.GE.0.AND.IV.LE.8191) IUPD = IV END IF END IF CALL SET_UPD_FLAGS(IUPD) C C====== Set default LDM values and cell input values C CALL LDM_RESET (' ', 0, 0, IERR, ERRSTR) CALL LDM_CH_RESET(0) CALL LDM_GET_A (CELL_INPUT(1), IFLAG, ND) CALL LDM_GET_B (CELL_INPUT(2), IFLAG, ND) CALL LDM_GET_C (CELL_INPUT(3), IFLAG, ND) CALL LDM_GET_ALPHA (CELL_INPUT(4), IFLAG, ND) CALL LDM_GET_BETA (CELL_INPUT(5), IFLAG, ND) CALL LDM_GET_GAMMA (CELL_INPUT(6), IFLAG, ND) CALL RESET_CELL C C====== Other initial settings C CALL INIT_SETTINGS C C====== Set up initial screen (X-windows mode) C IF (LG_MODE.EQ.1) THEN CALL SCREEN_SETUP C C====== Setup parameter tables 1&2 with default values (X-windows mode) C CALL SET_PAR12_NAM CALL SET_OMIT (2) CALL SET_PAR1_VALS (0, LISTE) CALL SET_PAR2_VALS (0, LISTE) C C====== Input from main menu (X-windows mode) C CALL SEL_FUNC ELSE C C====== Terminal or background/batch modes C PROC_SAV = PROCESS 100 IF (LG_MODE.EQ.2) THEN IF (PROCESS) THEN CALL TPROMP ('lauegen process > ') ELSE CALL TPROMP ('lauegen > ') END IF END IF CALL TREAD (CMDLIN,EOF) IF (EOF) GO TO 200 IF (LG_MODE.EQ.3) THEN IF (IUN_LOG.GT.0) WRITE (IUN_LOG,1001) + 'Command > ',CMDLIN(1:LENSTR(CMDLIN)) END IF CALL CMD_INPUT (CMDLIN, QUIT) IF (QUIT) THEN CALL CHECK_INTEGRATED (2, 1, IRET) IF (IRET.LT.2) GO TO 200 GO TO 100 END IF IF (.NOT.PROCESS.AND.PROC_SAV) THEN CALL CHECK_INTEGRATED (1, 1, IRET) IF (IRET.EQ.2) PROCESS = .TRUE. END IF IF (PROCESS.AND..NOT.PROC_SAV) THEN CALL CHECK_INTEGRATED (5, 1, IRET) IF (IUN_LOG.GT.0) THEN WRITE (IUN_LOG,1000) WRITE (IUN_LOG,1010) CALL LDM_WRITE (IUN_LOG, 3) WRITE (IUN_LOG,1020) END IF CALL LDM_CH_RESET (0) END IF PROC_SAV = PROCESS GO TO 100 END IF C C====== End of processing C 200 IF (IUN_LOG.GT.0) THEN WRITE (IUN_LOG,1002) CALL LDM_WRITE (IUN_LOG, 3) END IF STOP C C====== Format statements C 1001 FORMAT (/,A,A) 1002 FORMAT (/,'LDM Parameters at Program Quit',/, + '==============================',/) 1000 FORMAT (/,'Process Mode Entered',/, + '====================',/) 1010 FORMAT ('Current LDM parameter values:-',/) 1020 FORMAT (' ') C 2001 FORMAT (/,'**Error code', I2, ' from xdlf_open_view**') 2002 FORMAT (/,'**Error** Cannot open log file: ',A) C 6000 FORMAT (/,A) 6001 FORMAT (120A1) 6002 FORMAT (' ') END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** A_CALC ** C************************** C C SUBROUTINE A_CALC (ORIENT, PHIS, A_MAT) C INCLUDE 'implicit_none.finc' C C C Purpose: Calculates the master matrix, a_mat, from the crystal system, C crystal alignment and cell parameters. C This is then premultiplied by the phi matrices. C Purpose: C C Author: Based on code from GENLAUE by Clifton et al. C C Arguments: C REAL ORIENT(3,3) REAL PHIS(3) REAL A_MAT(3,3) C C ORIENT (R) Orientation matrix from crystal setting & cell parameters C PHIS (R) The three missetting angles C A_MAT (W) The master matrix C C====== Parameter statements C C C====== GLOBALS: C C C====== FUNCTION TYPES: C C C====== LOCALS: C REAL PC(3,3) INTEGER I, J C C------------------------------------------------------------------------------ C C C====== Define phi rotation matrix C CALL MTX_ROTATE(PHIS,PC) C C====== Apply phi rotations C CALL MTX_MULT(PC,ORIENT,A_MAT,3,3,3) RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C****************************** C** AUTO_CLEARINT_CTL ** C****************************** C C SUBROUTINE AUTO_CLEARINT_CTL (OPTSTR, IPKPL_DF, IERR) C INCLUDE 'implicit_none.finc' C C Purpose: Control deletion of integrated intensities C C Author: John W. Campbell, January 1996 C C Arguments: C CHARACTER*(*) OPTSTR INTEGER IPKPL_DF INTEGER IERR C C OPTSTR (R) Line containing non-default options codes C IPKPL_DF (R) Default flag for plate/pack/all = 1/2/3 C IERR (W) Error flag =0 OK, =1 options error (error messages C handled from within this routine) C C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'film_pack.finc' INCLUDE 'prog_flags.finc' INCLUDE 'file_units.finc' INCLUDE 'lirl_pars.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR INTEGER NXTTOK INTEGER LENSTR C C====== LOCALS: C INTEGER IPKPL INTEGER INP(3) INTEGER NKEYS INTEGER IKEY INTEGER KERR INTEGER LL INTEGER M1 INTEGER M2 INTEGER I INTEGER II INTEGER NPACKS INTEGER NPLATES INTEGER IFLAG INTEGER IPL CHARACTER*8 KEYS(3) CHARACTER*4 SEP CHARACTER*80 ERRSTR CHARACTER*80 ERRSTR2 CHARACTER*25 NAME CHARACTER*120 STR C INTEGER IPKPL !Process plate/pack/all flag flag C INTEGER INP(3) !Flags for option key already input C INTEGER NKEYS !No. of option keys C INTEGER IKEY !Option key number C INTEGER KERR !Error flag C INTEGER LL !Index to last character processed in string C INTEGER M1 !Index to first character in token C INTEGER M2 !Index to final character in token C INTEGER I !Temp/loop variable C INTEGER II !LDM_INTFP function return value C INTEGER NPACKS !No. of packs C INTEGER NPLATES !No. of plates/pack C INTEGER IFLAG !Parameter status flag C INTEGER IPL !Plates loop counter C CHARACTER*8 KEYS(3) !Option keys C CHARACTER*4 SEP !Token separator characters C CHARACTER*80 ERRSTR !Error string C CHARACTER*80 ERRSTR2 !Subsidiary error string C CHARACTER*25 NAME !Option key name C CHARACTER*120 STR !Message string DATA SEP /' ,='/ DATA KEYS /'PLATE', + 'PACK', + 'ALL'/ C C C------------------------------------------------------------------------------- IERR = 0 ERRSTR = ' ' ERRSTR2 = ' ' IF (IUN_LOG.GT.0) WRITE (IUN_LOG, 1000) C C====== Check pack C CALL LDM_GET_NUMP (NPACKS, IFLAG) CALL LDM_GET_NPLAT (NPLATES, IFLAG) IF (IPACK.LT.1.OR.IPACK.GT.NPACKS) THEN ERRSTR = 'Current pack number is invalid' ERRSTR2 = 'Pack =' CALL STR_ADDI (ERRSTR2, IPACK, 1) CALL STR_ADDS (ERRSTR2, ', plate =', 1) CALL STR_ADDI (ERRSTR2, IPLATE, 1) CALL AUTO_CLEARINT_ERR (IUN_LOG, ERRSTR, ERRSTR2) IERR = 1 RETURN END IF C C====== Interpret command string C DO 10 I = 1, 3 INP(I) = 0 10 CONTINUE IPKPL = 0 NKEYS = 3 SEP(2:2) = CHAR(9) LL = 0 100 I = NXTTOK (OPTSTR, SEP, LL, M1, M2) IF (I.EQ.-1) GO TO 200 IF (I.EQ.0) GO TO 100 NAME = OPTSTR(M1:M2) CALL CCPUPC (NAME) CALL GETOPT (KEYS, NKEYS, NAME, IKEY, KERR) IF (KERR.NE.0) THEN IF (KERR.EQ.1) ERRSTR = 'Ambiguous option' IF (KERR.EQ.2) ERRSTR = 'Invalid option' ERRSTR2 = 'Option string:' CALL STR_ADDS (ERRSTR2, NAME, 1) CALL AUTO_CLEARINT_ERR (IUN_LOG, ERRSTR, ERRSTR2) IERR = 1 RETURN END IF IF (INP(IKEY).EQ.1) THEN ERRSTR = 'Duplicate option' ERRSTR2 = 'Option string:' CALL STR_ADDS (ERRSTR2, NAME, 1) CALL AUTO_CLEARINT_ERR (IUN_LOG, ERRSTR, ERRSTR2) IERR = 1 RETURN END IF IF (IPKPL.NE.0) THEN ERRSTR = 'Inconsistent option' ERRSTR2 = 'Option string:' CALL STR_ADDS (ERRSTR2, NAME, 1) CALL AUTO_CLEARINT_ERR (IUN_LOG, ERRSTR, ERRSTR2) IERR = 1 RETURN END IF INP(IKEY) = 1 IPKPL = IKEY GO TO 100 C C====== Set pack range C 200 IF (IPKPL.EQ.0) IPKPL = IPKPL_DF IF (IPKPL.EQ.1) THEN IF (IUN_LOG.GT.0) THEN STR = 'Intensities cleared for pack' CALL STR_ADDI(STR,IPACK,1) CALL STR_ADDS(STR,', plate',0) CALL STR_ADDI(STR,IPLATE,1) WRITE(IUN_LOG,1010) WRITE(IUN_LOG,1020) STR(1:LENSTR(STR)) WRITE(IUN_LOG,1010) END IF CALL LIRLF_DELETE (KDX_LIRL, IPACK, IPLATE, KERR) CALL INTFLAG_SET (IPACK, IPLATE, 0) ELSE IF (IPKPL.EQ.2) THEN IF (IUN_LOG.GT.0) THEN STR = 'Intensities cleared for pack' CALL STR_ADDI(STR,IPACK,1) WRITE(IUN_LOG,1010) WRITE(IUN_LOG,1020) STR(1:LENSTR(STR)) WRITE(IUN_LOG,1010) END IF CALL LIRLF_DELETE (KDX_LIRL, IPACK, 0, KERR) DO 250 IPL = 1, NPLATES CALL INTFLAG_SET (IPACK, IPL, 0) 250 CONTINUE ELSE IF (IUN_LOG.GT.0) THEN STR = 'Intensities cleared for all packs and plates' WRITE(IUN_LOG,1010) WRITE(IUN_LOG,1020) STR(1:LENSTR(STR)) WRITE(IUN_LOG,1010) END IF CALL INIT_LIRL RETURN END IF RETURN C C====== Format statements C 1000 FORMAT (/,'==Automatic Clear Intensities==') 1010 FORMAT(' ') 1020 FORMAT(A) END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C******************************* C** AUTO_CLEARINT_ERR ** C******************************* C C SUBROUTINE AUTO_CLEARINT_ERR (KUN_LOG, ERRSTR, ERRSTR2) C INCLUDE 'implicit_none.finc' C C Purpose: Handle command line requested clear intensities errors C C Author: John W. Campbell, January 1996 C C Arguments: C INTEGER KUN_LOG CHARACTER*(*) ERRSTR CHARACTER*(*) ERRSTR2 C C Parameters: C C KUN_LOG i (R) Unit number for log file (0 if none) C ERRSTR c (R) Error string (max 80 chars) C ERRSTR2 c (R) Subsidiary error string - may be blank (max 80 C chars) C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'prog_flags.finc' INCLUDE 'file_units.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR INTEGER LENSTR C C====== LOCALS: C CHARACTER*120 STR C LOGICAL EOF !End of file flag C C------------------------------------------------------------------------------- C C C====== Write message to log file if required C IF (IUN_LOG.GT.0) THEN WRITE (IUN_LOG,6010) ERRSTR(1:LENSTR(ERRSTR)) IF (ERRSTR2.NE.' ') WRITE (IUN_LOG,6010) + ERRSTR2(1:LENSTR(ERRSTR2)) END IF C C====== Output message etc. depending on program mode C IF (LG_MODE.EQ.1) THEN STR = '**Error**' CALL STR_ADDS (STR, ERRSTR, 1) CALL LMESSAGE (IVH_CMD, STR) IF (ERRSTR2.NE.' ') THEN STR = '**Error**' CALL STR_ADDS (STR, ERRSTR2, 1) CALL LMESSAGE (IVH_CMD, STR) END IF RETURN ELSE IF (LG_MODE.EQ.2) THEN STR = '**Error**' CALL STR_ADDS (STR, ERRSTR, 1) CALL TWRITE (STR) IF (ERRSTR2.NE.' ') THEN STR = '**Error**' CALL STR_ADDS (STR, ERRSTR2, 1) CALL TWRITE (STR) END IF RETURN END IF RETURN C C====== Format statements C 6000 FORMAT (A) 6010 FORMAT ('**Error** ',A) END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** AUTO_CNTL ** C************************** C C SUBROUTINE AUTO_CNTL C INCLUDE 'implicit_none.finc' C C Purpose: Control auto-indexing (Elder) option C C Author: John W. Campbell, February 1992 C C Arguments: C C None C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'file_units.finc' INCLUDE 'meas_spots.finc' INCLUDE 'lauegen_auto_params.finc' INCLUDE 'prog_flags.finc' INCLUDE 'image.finc' INCLUDE 'symbol_types.finc' C C====== FUNCTION TYPES: C LOGICAL CCPEXS INTEGER XDLSTR INTEGER NXTTOK C C====== LOCALS: C LOGICAL EXISTS LOGICAL CENTRE_READ INTEGER IERR INTEGER NVIEW INTEGER IVHLIST(2) INTEGER IVHLST2(2) INTEGER IVH INTEGER ITEM INTEGER IQUIT INTEGER M_READ INTEGER M_MEAS INTEGER M_CURRENT INTEGER I INTEGER J INTEGER IFAIL INTEGER M1 INTEGER M2 INTEGER NVALS INTEGER IYN INTEGER NUMP INTEGER IFLAG REAL X_CEN_F REAL Y_CEN_F REAL W_F REAL VALUES(20) CHARACTER*80 STR CHARACTER*(MAXFLEN) FILNAM CHARACTER*(MAXFLEN) SPOTS_FILE CHARACTER*25 NAMES(3) CHARACTER*25 QUITNAM C C LOGICAL EXISTS !File exists flag C LOGICAL CENTRE_READ !Centre read from file flag C INTEGER IERR !Error return flag C INTEGER NVIEW !No. of view-object for getting events C INTEGER IVHLIST(2) !List of view-object handles for getting events C INTEGER IVHLST2(2) !2'nd list of view-object handles C INTEGER IVH !Returned view-object handle from getting events C INTEGER ITEM !Menu item number C INTEGER IQUIT !Quit box selected flag C INTEGER M_READ !Menu item no. for: 'Read Spots File' C INTEGER M_MEAS !Menu item no. for: 'Measure Spots on Image' C INTEGER M_CURRENT !Menu item no. for: 'Use Current Spots' C INTEGER I !Temp/loop variable C INTEGER J !Temp/loop variable C INTEGER IFAIL !File open failure flag C INTEGER M1 !Token start position C INTEGER M2 !Token end position C INTEGER NVALS !Number of numerical values in spots file record C INTEGER IYN !Return flag from yes/no notice C INTEGER NUMP !Number of packs C INTEGER IFLAG !Parameter status flag C REAL X_CEN_F !x centre from fids or input (rasters) C REAL Y_CEN_F !y centre from fids or input (rasters) C REAL W_F !omega from fids or 0.0 (degrees) C REAL VALUES(20) !Numerical values from spots file record C CHARACTER*80 STR !Temp character string C CHARACTER*(MAXFLEN) FILNAM !File name as input C CHARACTER*(MAXFLEN) SPOTS_FILE !Spots file name C CHARACTER*25 NAMES(3) !Menu item names C CHARACTER*25 QUITNAM !Quit box label DATA NAMES /'Read Spots File', + 'Measure Spots on Image', + 'Use Current Spots'/ DATA QUITNAM /'Return to Previous Menu'/ C C------------------------------------------------------------------------------- C C====== Reset to key plate if current plate is not key plate C CALL SET_KEYPLATE C C====== Find source of spots for auto-indexing C M_READ = 1 M_MEAS = 2 M_CURRENT = 3 50 CALL XDLF_MENU_AREA_SETMENU (IVH_MENU, 3, XDLSTR(NAMES), 24, + XDLSTR('Autoindexing Spots Menu'), 23, + XDLSTR(QUITNAM), 24, 0, IERR) C C====== Set up list of view-object handles C NVIEW = 1 IVHLIST(1) = IVH_MENU C C====== Start event loop C 100 CALL XDLF_GET_EVENTS (NVIEW, IVHLIST, IVH) IF (IVH.EQ.IVH_MENU) THEN C C====== Menu item selected C CALL XDLF_MENU_AREA_GETITEM (IVH_MENU, ITEM, IQUIT) C C====== Quit selected C IF (IQUIT.EQ.1) RETURN C C====== Read Spots File C IF (ITEM.EQ.M_READ) THEN 102 CALL LPROMPT + (IVH_IOW, 'File name (default ext=.spots): ') IVHLST2(1) = IVH_IOW CALL XDLF_GET_EVENTS (1, IVHLST2, IVH) CALL XDLF_IO_WINDOW_GETSTRING (IVH_IOW, XDLSTR(FILNAM), + MAXFLEN, IERR) IF (FILNAM.EQ.' ') GO TO 100 CALL FILEXT (FILNAM, 'spots', SPOTS_FILE, I) EXISTS = CCPEXS (SPOTS_FILE) IF (.NOT.EXISTS) THEN CALL LMESSAGE(IVH_IOW,'**File not found**') GO TO 102 END IF IFAIL = 1 CALL CCPDPN (-IUN_SPOTS, SPOTS_FILE,'READONLY','F',0,IFAIL) IF (IFAIL.LT.0) THEN CALL LMESSAGE(IVH_IOW,'**Error in opening the file**') GO TO 102 END IF READ (IUN_SPOTS,'(A)',END=104) STR J = 0 IF (NXTTOK (STR, ' ', J, M1, M2).EQ.0) THEN CALL LMESSAGE (IVH_IOW, + '**File does not start with ''spots:'' keyword**') CLOSE (IUN_SPOTS) GO TO 102 END IF CALL CCPUPC(STR) IF (STR(M1:M2).NE.'SPOTS:') THEN CALL LMESSAGE (IVH_IOW, + '**File does not start with ''spots:'' keyword**') CLOSE (IUN_SPOTS) GO TO 102 END IF NUM_INP_SPOTS = 0 CENTRE_READ = .FALSE. 103 READ (IUN_SPOTS,'(A)',END=104) STR IF (STR.EQ.' ') GO TO 103 CALL STRVAL (STR, ' =', 20, VALUES, NVALS) IF (NVALS.NE.2) THEN CALL LMESSAGE(IVH_IOW,'**Invalid format in record**') GO TO 103 END IF IF (.NOT.CENTRE_READ) THEN XCEN_SPOTS = VALUES(1) YCEN_SPOTS = VALUES(2) IXCEN_SPOTS = NINT(XCEN_SPOTS) IYCEN_SPOTS = NINT(YCEN_SPOTS) CENTRE_READ = .TRUE. GO TO 103 END IF IF (NUM_INP_SPOTS.GE.MAX_MEAS) THEN CALL LMESSAGE (IVH_IOW,'**Spots list full**') GO TO 104 END IF NUM_INP_SPOTS = NUM_INP_SPOTS + 1 XINP_SPOTS(NUM_INP_SPOTS) = VALUES(1) YINP_SPOTS(NUM_INP_SPOTS) = VALUES(2) IXINP_SPOTS(NUM_INP_SPOTS) = NINT(XINP_SPOTS(NUM_INP_SPOTS)) IYINP_SPOTS(NUM_INP_SPOTS) = NINT(YINP_SPOTS(NUM_INP_SPOTS)) GO TO 103 104 CLOSE (IUN_SPOTS) IF (NUM_INP_SPOTS.EQ.0) THEN CALL ERR_NOTICE(1,'**No spots read**') GO TO 100 ENDIF STR = 'Number of spots input =' CALL STR_ADDI(STR,NUM_INP_SPOTS,1) CALL LMESSAGE(IVH_IOW,STR) C C====== Measure Image C ELSE IF (ITEM.EQ.M_MEAS) THEN C C====== Check that pack input C CALL LDM_GET_NUMP (NUMP, IFLAG) IF (NUMP.EQ.0) THEN CALL ERR_NOTICE (1, '**Number of packs is zero**') GO TO 100 END IF C C====== Open image file if not already done C CALL CHK_OPN(IERR) IF (IERR.GT.0) GO TO 100 C C====== Get (default) centre position C CALL FILM_CENTRE (X_CEN_F, Y_CEN_F, W_F) XCEN_SPOTS = X_CEN_F YCEN_SPOTS = Y_CEN_F IXCEN_SPOTS = NINT(XCEN_SPOTS) IYCEN_SPOTS = NINT(YCEN_SPOTS) C C====== Display film/image-plate image C CALL SHOW_IMAGE (1, IERR) IF (IERR.EQ.1) GO TO 100 C C====== Display centre symbol C CALL XDLF_IMAGE_SYMBOL (IVH_FILM, + IXCEN_SPOTS, IYCEN_SPOTS, + ISYMBTYP(5), ICOLRTYP(5), 1, IERR) CALL MEASURE_IMG CALL XDLF_IMAGE_SETTINGS (IVH_FILM, MINTHR, MAXTHR, + MONO_THR, ICONTRAST, ICOLOR_OPT, IOVLY_OPT, IBG_OPT, + MAG_OPT, ISHOW_INT, IERR) CALL XDLF_DELETE_VIEW_OBJECT (IVH_FILM, IERR) IF (NUM_INP_SPOTS.EQ.0) THEN CALL ERR_NOTICE(0,'**No spots measured**') GO TO 50 END IF C C====== Use Current Spots C ELSE IF (ITEM.EQ.M_CURRENT) THEN IF (NUM_INP_SPOTS.EQ.0) THEN CALL ERR_NOTICE(1,'**No current spots**') GO TO 100 END IF END IF C C====== Check that some spots given C 200 IF (NUM_INP_SPOTS.EQ.0) THEN CALL ERR_NOTICE(0, + '**No spots yet defined for auto-indexing**') GO TO 50 END IF IF (NUM_INP_SPOTS.LT.3) THEN CALL ERR_NOTICE(0,'**Less than 3 spots defined**') GO TO 50 END IF C C====== Input index limits and spot positions error C NRAD2_AUT = 10 STR = 'Limit of h**2+k**2+l**2 (max=' CALL STR_ADDI(STR,MAX_AUTO_RAD2,0) CALL STR_ADDS(STR,')',0) CALL IOW_ASKI(IVH_IOW,STR,NRAD2_AUT) IF (NRAD2_AUT.GT.MAX_AUTO_RAD2) THEN STR = '**Maximum value exceeded, reset to' CALL STR_ADDI(STR,MAX_AUTO_RAD2,1) CALL STR_ADDS(STR,'**',0) CALL LMESSAGE(IVH_IOW,STR) NRAD2_AUT = MAX_AUTO_RAD2 END IF SPERR = 0.5 CALL IOW_ASKF(IVH_IOW,'Error in spot positions (mm)', + SPERR,2) C C====== Call auto-indexing routine C CALL AUTO_IDX C C====== See if any solutions C IF (NSTORE_AUT.LE.0) THEN CALL YESNO_NOTICE (0, 'Retry with different limits', + IYN) IF (IYN.EQ.1) GO TO 200 ELSE CALL AUTO_SEL END IF END IF RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** AUTO_IDX ** C************************** C C SUBROUTINE AUTO_IDX C INCLUDE 'implicit_none.finc' C C Purpose: Auto indexing (Method of M.Elder) C C Author: Modified version of M. Elder's INDEXL C C Arguments: C C None C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'lauegen_auto_params.finc' INCLUDE 'meas_spots.finc' INCLUDE 'film_pack.finc' C C====== FUNCTION TYPES: C C C====== LOCALS: C INTEGER I INTEGER J INTEGER K INTEGER II INTEGER L INTEGER N INTEGER NSOL INTEGER MAX_M INTEGER NOBS INTEGER IDET INTEGER NBAD_DET INTEGER IHKL(3,MAX_AUTO_SPOTS) INTEGER IPSOL(MAX_AUTO_SOLNS,MAX_AUTO_SPOTS) INTEGER ISPOT(3,MAX_AUTO_SPOTS) INTEGER ITCNT INTEGER IDIR INTEGER ITIM INTEGER IFLAG INTEGER ND INTEGER IERR REAL CTOF REAL MM_RAST_X REAL MM_RAST_Y REAL XX REAL XF REAL XQ REAL YQ REAL ZQ REAL YF REAL PI REAL RMSD REAL DEV REAL DEVSAV REAL SOL(3,3) REAL NEWSOL(3,3) REAL ADJ REAL ANG(3) REAL ANGL(MAX_AUTO_SPOTS,MAX_AUTO_SPOTS) REAL XSPOT(4,MAX_AUTO_SPOTS) REAL XC(5,MAX_AUTO_SPOTS) REAL RKEY(MAX_AUTO_SOLNS) CHARACTER*80 STR CHARACTER*2 ERRSTR C INTEGER I !Temp/loop variable C INTEGER J !Temp/loop variable C INTEGER K !Temp/loop variable C INTEGER II !Temp/loop variable C INTEGER L !Loop counter over found solutions C INTEGER N !No. of spots used in autoindexing C INTEGER NSOL !No. of solutions found for max. no. of matches C INTEGER MAX_M !Maximum number of matches for found solutions C INTEGER NOBS !No. of observations for evaluating orientation C and missetting angles C INTEGER IDET !Error flag from EVANGL C INTEGER NBAD_DET !No. of solutions with bad determinants C INTEGER IHKL(3,MAX_AUTO_SPOTS) !Indices of reflections used C for evaluating orientation C INTEGER IPSOL(MAX_AUTO_SOLNS,MAX_AUTO_SPOTS) !Lists of matching spots C for each solution C INTEGER ISPOT(3,MAX_AUTO_SPOTS) !Indices assigned to spots C INTEGER ITCNT !Iteration count for refining angles C INTEGER IDIR !Refinement flag C INTEGER ITIM !Refinement flag C INTEGER IFLAG !Parameter status flag C INTEGER ND !No. of decimal places flag C INTEGER IERR !Error flag C REAL CTOF !Crystal to film distance C REAL MM_RAST_X !Conversion mm to x-rasters C REAL MM_RAST_Y !Conversion mm to y-rasters C REAL XX !Temp variable C REAL XF !Film x coordinate C REAL YF !Film y coordinate C REAL XQ !Detector x coordinate wrt 'q' axes (see LDM_DTOQAX) C REAL YQ !Detector y coordinate wrt 'q' axes (see LDM_DTOQAX) C REAL ZQ !Detector z coordinate wrt 'q' axes (see LDM_DTOQAX) C REAL PI !Pi C REAL RMSD !Rms deviation C REAL DEV !Current rms deviation for solution C REAL DEVSAV !Saved value of DEV from previous iteration C REAL SOL(3,3) !Rotation matrix C REAL NEWSOL(3,3) !New rotation matrix C REAL ADJ !Adjustment step for refining angles C REAL ANG(3) !Current values of missetting angles C REAL ANGL(MAX_AUTO_SPOTS,MAX_AUTO_SPOTS) !Angles between observed spots C REAL XSPOT(4,MAX_AUTO_SPOTS) !Observed spots parameters C REAL XC(5,MAX_AUTO_SPOTS) !Positions of reflections used C for evaluating orientation C (observed and calculated) C REAL RKEY(MAX_AUTO_SOLNS) !Array for sorting (indexing) solutions C CHARACTER*80 STR !Temporary string C CHARACTER*2 ERRSTR !Error string (dummy) C C------------------------------------------------------------------------------- C PI = 3.14159265 NSTORE_AUT = 0 CALL LDM_GET_CTOF (IPACK, IPLATE, CTOF, IFLAG, ND, IERR, ERRSTR) CALL LDM_MMRAST (IPACK, IPLATE, MM_RAST_X, MM_RAST_Y) C C====== Get the angles between possible nodal reflections C CALL LMESSAGE(IVH_IOW, + '*Pre-calculating angles between low index reflections*') NREF_AUT = 0 CALL INDANG C C====== Get spots for auto-indexing C IF (NUM_INP_SPOTS.GT.MAX_AUTO_SPOTS) THEN STR = '**Spot list truncated to maximum of' CALL STR_ADDI(STR,MAX_AUTO_SPOTS,1) CALL STR_ADDS(STR,'spots**',1) CALL ERR_NOTICE(0,STR) END IF N = MIN (MAX_AUTO_SPOTS,NUM_INP_SPOTS) DO 10 I = 1,N XF = (XINP_SPOTS(I)-XCEN_SPOTS)/MM_RAST_X YF = (YINP_SPOTS(I)-YCEN_SPOTS)/MM_RAST_Y CALL LDM_DTOQAX (XF, YF, CTOF, XQ, YQ, ZQ) XSPOT(1,I) = XF XSPOT(2,I) = YF XSPOT(3,I) = PI/2.0 - 0.5*ATAN2(SQRT(XQ**2+YQ**2),ZQ) XSPOT(4,I) = ATAN2(YQ,XQ) 10 CONTINUE C C====== Calculate the angles between the spots C 90 DO 110 I = 2 , N DO 100 J = 1 , I - 1 ANGL(I,J) = COS(XSPOT(4,J))*SIN(XSPOT(3,J))*COS(XSPOT(4,I)) + *SIN(XSPOT(3,I)) + SIN(XSPOT(4,J)) + *SIN(XSPOT(3,J))*SIN(XSPOT(4,I))*SIN(XSPOT(3,I)) + + COS(XSPOT(3,J))*COS(XSPOT(3,I)) IF (ABS(ANGL(I,J)).GT.1.0) ANGL(I,J) = SIGN(1.0,ANGL(I,J)) ANGL(I,J) = ACOS(ANGL(I,J)) 100 CONTINUE 110 CONTINUE C C====== Now try to match these angles against the pre-calculated ones C CALL INDMAT(N,ANGL,NSOL,IPSOL,MAX_M) IF (NSOL.EQ.0) THEN CALL ERR_NOTICE(0,'**No solutions found**') RETURN END IF MAX_MATCH_AUT = MAX_M C C====== Loop over all the solutions C NBAD_DET = 0 L = 0 200 L = L + 1 DO 210 I = 1 , N K = IPSOL(L,I) IF (K.EQ.0) THEN ISPOT(1,I) = 0 ISPOT(2,I) = 0 ISPOT(3,I) = 0 ELSE ISPOT(1,I) = INDX_AUT(K,1) ISPOT(2,I) = INDX_AUT(K,2) ISPOT(3,I) = INDX_AUT(K,3) END IF 210 CONTINUE C C====== Calculate orientation C 220 NOBS = 0 DO 230 I = 1 , N IF (ISPOT(1,I).NE.0 .OR. ISPOT(2,I).NE.0 .OR. ISPOT(3,I).NE.0) + THEN NOBS = NOBS + 1 IHKL(1,NOBS) = ISPOT(1,I) IHKL(2,NOBS) = ISPOT(2,I) IHKL(3,NOBS) = ISPOT(3,I) XC(1,NOBS) = XSPOT(1,I) XC(2,NOBS) = XSPOT(2,I) END IF 230 CONTINUE CALL EVANGL(NOBS,IHKL,XC,ANG,RMSD,DEV,SOL,IDET) IF (IDET.EQ.2) THEN NBAD_DET = NBAD_DET + 1 GO TO 310 END IF C C====== Store data relating to current solution C IF (NSTORE_AUT.GE.MAX_AUTO_SOLNS) THEN CALL ERR_NOTICE(0,'**Too many solutions**') GO TO 350 ENDIF NSTORE_AUT = NSTORE_AUT + 1 STNOBS(NSTORE_AUT) = NOBS DO 235 II = 1,NOBS STHKL(NSTORE_AUT,1,II) = IHKL(1,II) STHKL(NSTORE_AUT,2,II) = IHKL(2,II) STHKL(NSTORE_AUT,3,II) = IHKL(3,II) STXC(NSTORE_AUT,1,II) = XC(1,II) STXC(NSTORE_AUT,2,II) = XC(2,II) 235 CONTINUE STDEV0(NSTORE_AUT) = DEV C C====== Perform initial refinement of angles C ADJ = DEV/20. ITCNT = 0 270 DO 290 K = 1 , 4 I = K IF (I.GT.3) I = I - 3 IDIR = 1 ITIM = 0 280 DEVSAV = DEV ITIM = ITIM + 1 ANG(I) = ANG(I) - ADJ*(IDIR-2) CALL EROTMT(ANG,NEWSOL,SOL,RMSD) CALL EVCOOR(NEWSOL,XC,DEV,NOBS,IDET) ITCNT = ITCNT + 1 IF (ITCNT.GE.100) GO TO 300 IF (DEV.LT.DEVSAV) GO TO 280 ANG(I) = ANG(I) + ADJ*(IDIR-2) DEV = DEVSAV IF (ITIM.LE.1) THEN IF (IDIR.LE.1) THEN IDIR = 3 ITIM = 0 GO TO 280 END IF END IF 290 CONTINUE IF (ADJ.LT.0.02) GO TO 300 ADJ = ADJ/5. GO TO 270 300 STDEV(NSTORE_AUT) = DEV STANG(NSTORE_AUT,1) = ANG(1) STANG(NSTORE_AUT,2) = ANG(2) STANG(NSTORE_AUT,3) = ANG(3) DO 305 II = 1,NOBS STXC(NSTORE_AUT,3,II) = XC(3,II) STXC(NSTORE_AUT,4,II) = XC(4,II) STXC(NSTORE_AUT,5,II) = XC(5,II) 305 CONTINUE 310 IF (L.LT.NSOL) GO TO 200 C C====== End of solutions reached C 350 IF (NSTORE_AUT.EQ.0) THEN CALL ERR_NOTICE(0,'**No valid solutions found**') RETURN END IF C C====== Sort solutions C DO 400 I = 1, NSTORE_AUT IP_AUT(I) = I RKEY(I) = STDEV(I) 400 CONTINUE IF (NSTORE_AUT.GT.1) THEN DO 450 J = 2, NSTORE_AUT II = IP_AUT(J) XX = RKEY(J) DO 410 I = J-1,1,-1 IF (RKEY(I).LE.XX) GO TO 420 IP_AUT(I+1) = IP_AUT(I) RKEY(I+1) = RKEY(I) 410 CONTINUE I=0 420 IP_AUT(I+1) = II RKEY(I+1) = XX 450 CONTINUE END IF RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C****************************** C** AUTO_INTEGRATE_CTL ** C****************************** C C SUBROUTINE AUTO_INTEGRATE_CTL (IOP, SKIP_INT, OPTSTR, IPKPL_DF, + NPROF_DF, PROMIN_DF, PROF_ROT_DF, + IPRF_ALL_DF, NOVLD_DF, IERR) C INCLUDE 'implicit_none.finc' C C Purpose: Control automatic integration C C Author: John W. Campbell, December 1995 C C Arguments: C INTEGER IOP LOGICAL SKIP_INT CHARACTER*(*) OPTSTR INTEGER IPKPL_DF INTEGER NPROF_DF REAL PROMIN_DF LOGICAL PROF_ROT_DF INTEGER IPRF_ALL_DF INTEGER NOVLD_DF INTEGER IERR C C IOP (R) = 1 called from Integration options menu C = 2 called via command line input C SKIP_INT (R) Skip integration for a plate if already done C OPTSTR (R) Line containing non-default options codes & values C IPKPL_DF (R) Default plate/pack/all flag 1/2/3 C NPROF_DF (R) Default NPROF value C PROMIN_DF (R) Default PROMIN value C PROF_ROT_DF (R) Default PROF_ROT value C IPRF_ALL_DF (R) Default value for IPRF_ALL flag 0 = use key plate profiles C for all plates in pack, 1 = get profiles for each plate C NOVLD_DF (R) Default value for no. of overload pixels allowed in C an 'OK' spot for integration C IERR (W) Error flag =0 OK, C =1 error (Note that reporting of errors is done within C this routine. C =100 Cancelled C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'film_pack.finc' INCLUDE 'prog_flags.finc' INCLUDE 'file_units.finc' INCLUDE 'image.finc' INCLUDE 'integ_pars.finc' INCLUDE 'lirl_pars.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR INTEGER NXTTOK INTEGER LENSTR INTEGER LDM_INTFP LOGICAL CMD_CNCL EXTERNAL CMD_CNCL EXTERNAL INTEGRATE_PROGRESS C C====== LOCALS: C LOGICAL NEXT LOGICAL PROF_ONLY LOGICAL OKNOD LOGICAL SPOV LOGICAL CLOS LOGICAL MEAS LOGICAL BAD LOGICAL OVLD LOGICAL ANY_TO_INT LOGICAL PROF_ROT_USE INTEGER IMG_PK INTEGER IMG_PL INTEGER NPACKS INTEGER NPLATES INTEGER IFLAG INTEGER NPROF_USE INTEGER IPRF_ALL_USE INTEGER NOVLD_USE INTEGER IPKPL INTEGER ISING_PLATE INTEGER INP(8) INTEGER NKEYS INTEGER IKEY INTEGER KERR INTEGER JERR INTEGER LL INTEGER M1 INTEGER M2 INTEGER I INTEGER II INTEGER ND INTEGER IV INTEGER NXRAST INTEGER NYRAST INTEGER NF_OFF INTEGER IORD INTEGER ISWAP INTEGER IPK INTEGER IPL INTEGER LISTE(2) INTEGER KEYPLATE INTEGER ICONT INTEGER IPP INTEGER IFLG INTEGER IRFL INTEGER NUMSPOTS INTEGER ISPOT INTEGER IH INTEGER IK INTEGER IL INTEGER IH_N INTEGER IK_N INTEGER IL_N INTEGER MULT INTEGER MINHARM INTEGER MAXHARM INTEGER INCHARM INTEGER ICODE INTEGER ICODE_TYPE INTEGER ISPAT INTEGER ICLOS INTEGER IMEAS INTEGER IBAD INTEGER IOVLD INTEGER IPK_MIN INTEGER IPK_MAX INTEGER NUMREFS INTEGER NOV REAL FP REAL PROMIN_USE REAL ALAM REAL DMTHR2 REAL ALNOD REAL DTHR2NOD REAL AI REAL SIGI REAL XD REAL YD REAL XFD REAL YFD CHARACTER*2 VALSTR CHARACTER*12 KEYS(8) CHARACTER*4 SEP CHARACTER*80 ERRSTR CHARACTER*80 ERRSTR2 CHARACTER*80 KERRSTR CHARACTER*25 NAME CHARACTER*120 STR C LOGICAL NEXT !Continue with next pack flag C LOGICAL PROF_ONLY !Calculate profiles only flag C LOGICAL OKNOD !Non-overlapped nodal flag C LOGICAL SPOV !Spatial overlap flag C LOGICAL CLOS !Spot too close to integrated flag C LOGICAL MEAS !Intensity measured flag C LOGICAL BAD !Bad spot flag C LOGICAL OVLD !Overload flag C LOGICAL ANY_TO_INT !Any plates to integrate flag C LOGICAL PROF_ROT_USE !Profiles rotate flag to use C INTEGER IMG_PK !Pack no. of current image read, 0 if none C INTEGER IMG_PL !Plate no. of current image read, 0 if none C INTEGER NPACKS !No. of packs C INTEGER NPLATES !No. of plates C INTEGER IFLAG !Parameter status flag C INTEGER NPROF_USE !No. of profile bins to use C INTEGER IPRF_ALL_USE !Profiles for all plates flag to use C INTEGER NOVLD_USE !No. OK overload pixels to use C INTEGER IPKPL !Process plate/pack/all flag flag C INTEGER ISING_PLATE !Single plate no./flag (0=all plates) C INTEGER INP(8) !Flags for option key already input C INTEGER NKEYS !No. of option keys C INTEGER IKEY !Option key number C INTEGER KERR !Error flag C INTEGER JERR !Error flag C INTEGER LL !Index to last character processed in string C INTEGER M1 !Index to first character in token C INTEGER M2 !Index to final character in token C INTEGER I !Temp/loop variable C INTEGER II !LDM_INTFP function return value C INTEGER ND !No. of decimal places flag C INTEGER IV !Integer value C INTEGER NXRAST !No. x-rasters C INTEGER NYRAST !No. y-rasters C INTEGER NF_OFF !Offset between start of slow rasters in image C INTEGER IORD !Axis order flag C INTEGER ISWAP !Byte swap flag C INTEGER IPK !Pack loop variable C INTEGER IPL !Plates loop variable C INTEGER LISTE(2) !List of parameter table entries to be updated C INTEGER KEYPLATE !Key plate C INTEGER ICONT !Continue on error flag C INTEGER IPP !Loop for keyplate then other plates C INTEGER IFLG !Plate integrated flag C INTEGER IRFL !Plate refined flag C INTEGER NUMSPOTS !No. of spots C INTEGER ISPOT !Spot number C INTEGER IH !'h' index C INTEGER IK !'k' index C INTEGER IL !'l' index C INTEGER IH_N !Nodal 'h' index C INTEGER IK_N !Nodal 'k' index C INTEGER IL_N !Nodal 'l' index C INTEGER MULT !Multiplicity C INTEGER MINHARM !Minimum harmonic C INTEGER MAXHARM !Maximum harmonic C INTEGER INCHARM !Harmonic increment C INTEGER ICODE !Integration routine flags code C INTEGER ICODE_TYPE !Code type of integration routines C INTEGER ISPAT !Spatial overlap flag C INTEGER ICLOS !Spots 'too close to integrate' flag C INTEGER IMEAS !Intensity measured flag C INTEGER IBAD !Bad spot flag C INTEGER IOVLD !Overload spot flag C INTEGER IPK_MIN !Minimum pack no. for integration loop C INTEGER IPK_MAX !Maximum pack no. for integration loop C INTEGER NUMREFS !No. of reflns in LIRL C INTEGER NOV !No. of overloaded pixels ia spot C REAL FP !Real value C REAL PROMIN_USE !PROMIN value to use C REAL ALAM !Lambda value C REAL DMTHR2 !Dmin-threshold**2 C REAL ALNOD !Nodal lambda value C REAL DTHR2NOD !Nodal dmin-threshold**2 value C REAL AI !Integrated intensity C REAL SIGI !sig(AI) C REAL XD !'x' spot position on detector (rasters) C REAL YD !'y' spot position on detector (rasters) C REAL XFD !'x' coordinate value for spot (mm) C REAL YFD !'y' coordinate value for spot (mm) C CHARACTER*2 VALSTR !Parameter value string (dummy) C CHARACTER*12 KEYS(8) !Option keys C CHARACTER*4 SEP !Token separator characters C CHARACTER*80 ERRSTR !Error string C CHARACTER*80 ERRSTR2 !Subsidiary error string C CHARACTER*80 KERRSTR !Error string C CHARACTER*25 NAME !Option key name C CHARACTER*120 STR !Message string DATA SEP /' ,='/ DATA KEYS /'PLATE', + 'PACK', + 'ALL', + 'NPROF', + 'PROMIN', + 'PROF_ALL', + 'PROF_ROTATE', + 'OVLIM'/ C C C------------------------------------------------------------------------------- IERR = 0 ERRSTR = ' ' ERRSTR2 = ' ' IF (IUN_LOG.GT.0) WRITE (IUN_LOG, 1000) C C====== See if an image already read C IMG_PK = 0 IMG_PL = 0 IF (IPACK_OPN.GT.0.AND.IPLATE_OPN.GT.0) THEN IF (FILM_OPEN.AND.FILM_READ) THEN IMG_PK = IPACK_OPN IMG_PL = IPLATE_OPN END IF END IF C C====== Set menu/command-window flag C IF (IOP.LT.2) THEN MENU_I_INP = .TRUE. ELSE MENU_I_INP = .FALSE. END IF C C====== Check pack C CALL LDM_GET_NUMP (NPACKS, IFLAG) CALL LDM_GET_NPLAT (NPLATES, IFLAG) IF (IPACK.LT.1.OR.IPACK.GT.NPACKS) THEN ERRSTR = 'Current pack number is invalid' ERRSTR2 = 'Pack =' CALL STR_ADDI (ERRSTR2, IPACK, 1) CALL STR_ADDS (ERRSTR2, ', plate =', 1) CALL STR_ADDI (ERRSTR2, IPLATE, 1) CALL AUTO_INTEGRATE_ERR (IUN_LOG, 0, ERRSTR, ERRSTR2, NEXT) IERR = 1 RETURN END IF C C====== Set control parameters to be used to required defaults C NPROF_USE = NPROF_DF PROMIN_USE = PROMIN_DF PROF_ROT_USE = PROF_ROT_DF IPRF_ALL_USE = IPRF_ALL_DF NOVLD_USE = NOVLD_DF C C====== Interpret command string C DO 10 I = 1, 8 INP(I) = 0 10 CONTINUE IPKPL = 0 NKEYS = 8 SEP(2:2) = CHAR(9) LL = 0 100 I = NXTTOK (OPTSTR, SEP, LL, M1, M2) IF (I.EQ.-1) GO TO 200 IF (I.EQ.0) GO TO 100 NAME = OPTSTR(M1:M2) CALL CCPUPC (NAME) CALL GETOPT (KEYS, NKEYS, NAME, IKEY, KERR) IF (KERR.NE.0) THEN IF (KERR.EQ.1) ERRSTR = 'Ambiguous option' IF (KERR.EQ.2) ERRSTR = 'Invalid option' ERRSTR2 = 'Option string:' CALL STR_ADDS (ERRSTR2, NAME, 1) CALL AUTO_INTEGRATE_ERR (IUN_LOG, 0, ERRSTR, ERRSTR2, NEXT) IERR = 1 RETURN END IF IF (INP(IKEY).EQ.1) THEN ERRSTR = 'Duplicate option' ERRSTR2 = 'Option string:' CALL STR_ADDS (ERRSTR2, NAME, 1) CALL AUTO_INTEGRATE_ERR (IUN_LOG, 0, ERRSTR, ERRSTR2, NEXT) IERR = 1 RETURN END IF IF (IKEY.LE.3) THEN IF (IPKPL.NE.0) THEN ERRSTR = 'Inconsistent option' ERRSTR2 = 'Option string:' CALL STR_ADDS (ERRSTR2, NAME, 1) CALL AUTO_INTEGRATE_ERR (IUN_LOG, 0, ERRSTR, ERRSTR2, NEXT) IERR = 1 RETURN ELSE INP(IKEY) = 1 IPKPL = IKEY END IF ELSE INP(IKEY) = 1 I = NXTTOK (OPTSTR, SEP, LL, M1, M2) IF (I.LE.0) THEN ERRSTR = 'Option' CALL STR_ADDS (ERRSTR, NAME, 1) CALL STR_ADDS (ERRSTR, 'not followed by a value', 1) CALL AUTO_INTEGRATE_ERR (IUN_LOG, 0, ERRSTR, ERRSTR2, NEXT) IERR = 1 RETURN END IF II = LDM_INTFP (OPTSTR(M1:M2), FP, IV, ND) IF (IKEY.EQ.4) THEN IF (II.NE.1.OR.IV.LT.1.OR.IV.GT.17) GO TO 150 NPROF_USE = IV ELSE IF (IKEY.EQ.5) THEN IF (II.LE.0.OR.FP.LE.0.0) GO TO 150 PROMIN_USE = FP ELSE IF (IKEY.EQ.6) THEN STR = OPTSTR(M1:M2) CALL CCPUPC(STR) IF (STR.NE.'YES'.AND.STR.NE.'NO') GO TO 150 IF (STR.EQ.'YES') IPRF_ALL_USE = 1 IF (STR.EQ.'NO') IPRF_ALL_USE = 0 ELSE IF (IKEY.EQ.7) THEN STR = OPTSTR(M1:M2) CALL CCPUPC(STR) IF (STR.NE.'YES'.AND.STR.NE.'NO') GO TO 150 IF (STR.EQ.'YES') PROF_ROT_USE = .TRUE. IF (STR.EQ.'NO') PROF_ROT_USE = .FALSE. ELSE IF (IKEY.EQ.8) THEN IF (II.NE.1.OR.IV.LT.0) GO TO 150 NOVLD_USE = IV END IF END IF GO TO 100 C C====== Invalid value C 150 ERRSTR = OPTSTR(M1:M2) CALL STR_ADDS (ERRSTR, 'is not a valid value for option', 1) CALL STR_ADDS (ERRSTR, NAME, 1) CALL AUTO_INTEGRATE_ERR (IUN_LOG, 0, ERRSTR, ERRSTR2, NEXT) IERR = 1 RETURN C C====== Set pack range C 200 ISING_PLATE = 0 IF (IPKPL.EQ.0) IPKPL = IPKPL_DF IF (IPKPL.EQ.1) THEN IPK_MIN = IPACK IPK_MAX = IPACK ISING_PLATE = IPLATE ELSE IF (IPKPL.EQ.2) THEN IPK_MIN = IPACK IPK_MAX = IPACK ELSE IPK_MIN = 1 CALL LDM_GET_NUMP (IPK_MAX, IFLAG) IF (IPK_MAX.LT.1) IPK_MAX = 1 END IF C C====== Check for skip integration if single plate C IF (SKIP_INT.AND.ISING_PLATE.GT.0) THEN CALL INTFLAG_GET (IPACK, ISING_PLATE, IFLG) IF (IFLG.GT.0) THEN STR = 'Integration was already done for pack' CALL STR_ADDI(STR,IPACK,1) CALL STR_ADDS(STR,', plate',0) CALL STR_ADDI(STR,IPLATE,1) CALL STR_ADDS(STR,'(skipped)',1) WRITE(IUN_LOG,1010) WRITE(IUN_LOG,1020) STR(1:LENSTR(STR)) WRITE(IUN_LOG,1010) RETURN END IF END IF C C====== Get some image related details C CALL LDM_GET_NXRAS (NXRAST, IFLAG) CALL LDM_GET_NYRAS (NYRAST, IFLAG) CALL LDM_GET_AXORD (VALSTR, IORD, ISWAP, IFLAG) IF (LG_MODE.EQ.1) CALL CMD_CNCL_BUT IF (CMD_CNCL(0)) GO TO 900 JPROG_X = 0 JPROG_Y = 0 IF (LG_MODE.EQ.1) CALL XDLF_VIEW_OBJECT_ROOTXY (IVH_CMD,8,35, + JPROG_X,JPROG_Y,KERR) C C====== Loop through required packs C====== =========================== C INTEG_LASTPK = 0 INTEG_LASTPL = 0 DO 2500 IPK = IPK_MIN, IPK_MAX ICONT = 2 IF (IPK.EQ.IPK_MAX) ICONT = 0 CALL LDM_GET_KEYP (IPK, KEYPLATE, IFLAG, KERR, ERRSTR) IF (KEYPLATE.LT.1.OR.KEYPLATE.GT.NPLATES) THEN ERRSTR = 'Keyplate' CALL STR_ADDI (ERRSTR, KEYPLATE, 1) CALL STR_ADDS (ERRSTR,'out of range for pack',1) CALL STR_ADDI (ERRSTR, IPK,1) ERRSTR2 = ' ' CALL AUTO_INTEGRATE_ERR (IUN_LOG, ICONT, ERRSTR, + ERRSTR2, NEXT) IF (.NOT.NEXT) THEN IERR = 1 GO TO 2600 END IF IF (CMD_CNCL(0)) GO TO 900 GO TO 2500 END IF IPACK = IPK DO 2100 IPP = 1, 2 DO 2000 IPL = 1, NPLATES IF (IPP.EQ.1.AND.IPL.NE.KEYPLATE) GO TO 2000 IF (IPP.EQ.2.AND.IPL.EQ.KEYPLATE) GO TO 2000 PROF_ONLY = .FALSE. IF (ISING_PLATE.GT.0) THEN IF (IPRF_ALL_USE.EQ.1) THEN IF (IPL.NE.ISING_PLATE) GO TO 2000 ELSE IF (IPL.EQ.KEYPLATE) THEN IF (IPL.NE.ISING_PLATE) PROF_ONLY = .TRUE. ELSE IF (IPL.NE.ISING_PLATE) GO TO 2000 END IF END IF ELSE CALL INTFLAG_GET (IPK, IPL, IFLG) IF (IFLG.GT.0) THEN IF (SKIP_INT) THEN IF (IUN_LOG.GT.0) THEN STR = 'Integration was already done for pack' CALL STR_ADDI(STR,IPACK,1) CALL STR_ADDS(STR,', plate',0) CALL STR_ADDI(STR,IPL,1) CALL STR_ADDS(STR,'(skipped)',1) WRITE(IUN_LOG,1010) WRITE(IUN_LOG,1020) STR(1:LENSTR(STR)) WRITE(IUN_LOG,1010) END IF IF (IPRF_ALL_USE.EQ.1) THEN GO TO 2000 ELSE IF (IPL.EQ.KEYPLATE) THEN PROF_ONLY = .TRUE. ANY_TO_INT = .FALSE. DO 220 I = 1, NPLATES IF (I.EQ.KEYPLATE) GO TO 220 CALL INTFLAG_GET (IPK, I, IFLG) IF (IFLG.EQ.0) ANY_TO_INT = .TRUE. 220 CONTINUE IF (.NOT.ANY_TO_INT) GO TO 2000 ELSE GO TO 2000 END IF END IF ELSE CALL LIRLF_DELETE (KDX_LIRL, IPK, IPL, KERR) IF (IUN_LOG.GT.0) THEN STR = '*Warning*' CALL STR_ADDS (STR, + 'Previous intensities deleted for pack', 1) CALL STR_ADDI(STR,IPK,1) CALL STR_ADDS(STR,', plate',0) CALL STR_ADDI(STR,IPL,1) WRITE(IUN_LOG,1010) WRITE(IUN_LOG,1020) STR(1:LENSTR(STR)) WRITE(IUN_LOG,1010) END IF CALL INTFLAG_SET (IPK, IPL, 0) END IF END IF END IF IPLATE = IPL ICONT = 1 IF (IPLATE.EQ.NPLATES) ICONT = 2 IF (ISING_PLATE.GT.0) ICONT = 0 IF (ICONT.EQ.2.AND.IPK.EQ.IPK_MAX) ICONT = 0 IF (ICONT.EQ.1.AND.IPLATE.EQ.KEYPLATE.AND. + IPRF_ALL_USE.EQ.0) ICONT = 2 C C====== Update parameter tables C IF (LG_MODE.EQ.1) THEN CALL SET_PAR1_VALS (0, LISTE) CALL SET_PAR2_VALS (0, LISTE) END IF IF (PROF_ONLY) THEN STR = '==Determining profiles for pack' ELSE STR = '==Integration for pack' END IF CALL STR_ADDI (STR, IPK, 1) CALL STR_ADDS (STR, ', plate', 1) CALL STR_ADDI (STR, IPLATE, 1) CALL STR_ADDS (STR,'==',0) IF (LG_MODE.EQ.1) THEN CALL LMESSAGE (IVH_IOW, STR) ELSE IF (LG_MODE.EQ.2) THEN CALL TWRITE (STR) END IF C C====== Check that plate refined C CALL LDM_GET_RFL (IPACK, IPLATE, IRFL, IFLAG, + KERR, ERRSTR) IF (IRFL.EQ.0) THEN ERRSTR = 'Key plate not refined' ERRSTR2 = 'Cannot determine required profiles' CALL AUTO_INTEGRATE_ERR (IUN_LOG, ICONT, ERRSTR, + ERRSTR2, NEXT) IF (.NOT.NEXT) THEN IERR = 1 GO TO 2600 END IF IF (ICONT.EQ.1) GO TO 2000 GO TO 2500 END IF C C====== Read image if not already read C IF (IPACK.NE.IMG_PK.OR.IPLATE.NE.IMG_PL) THEN CALL LAUEGEN_RIMG (IPACK, IPLATE, ITYPE, NF_OFF, IMG, + MAX_IMG_WORDS, KERR, KERRSTR) IF (KERR.NE.0) THEN ERRSTR = 'Error reading image for pack' CALL STR_ADDI (ERRSTR, IPACK, 1) CALL STR_ADDS (ERRSTR, ', plate', 0) CALL STR_ADDI (ERRSTR, IPLATE, 1) ERRSTR2 = KERRSTR IMG_PK = 0 IMG_PL = 0 CALL AUTO_INTEGRATE_ERR (IUN_LOG, ICONT, ERRSTR, + ERRSTR2, NEXT) IF (.NOT.NEXT) THEN IERR = 1 GO TO 2600 END IF IF (ICONT.EQ.1) GO TO 2000 GO TO 2500 END IF IMG_PK = IPACK IMG_PL = IPLATE END IF NF_OFF = NFRASTS IF (CMD_CNCL(0)) GO TO 900 C C====== Generate reflection list C CALL LRL_GEN (IPACK, IPLATE, .FALSE., 2, KERR, ERRSTR) IF (KERR.NE.0) THEN ERRSTR2 = ' ' CALL AUTO_INTEGRATE_ERR (IUN_LOG, ICONT, ERRSTR, + ERRSTR2, NEXT) IF (.NOT.NEXT) THEN IERR = 1 GO TO 2600 END IF IF (ICONT.EQ.1) GO TO 2000 GO TO 2500 END IF IF (IORD.LE.4) THEN CALL LRL_SORT (3) ELSE CALL LRL_SORT (4) END IF C C====== Form profiles if key plate or profiles required for all plates C IF (IPP.EQ.1.OR.IPRF_ALL_USE.EQ.1) THEN JPROG_PASS = 0 CALL LFN_SAINT (IPACK, IPLATE, 1, IMG, ITYPE, IORD, + NFRASTS, NXRAST, NYRAST, PROMIN_USE, + NPROF_USE, PROF_ROT_USE, NOVLD_USE, + INTEGRATE_PROGRESS, + CMD_CNCL, KERR, ERRSTR) IF (LG_MODE.EQ.1) THEN CALL XDLF_DELETE_VIEW_OBJECT (IVH_BAR, JERR) END IF IF (KERR.NE.0) THEN ERRSTR2 = ' ' CALL AUTO_INTEGRATE_ERR (IUN_LOG, ICONT, ERRSTR, + ERRSTR2, NEXT) IF (.NOT.NEXT) THEN IERR = 1 GO TO 2600 END IF IF (ICONT.EQ.1) GO TO 2000 GO TO 2500 END IF IF (IUN_LOG.GT.0) THEN WRITE(IUN_LOG,1010) STR = 'Determine integration profiles for pack' CALL STR_ADDI(STR,IPACK,1) CALL STR_ADDS(STR,', plate',0) CALL STR_ADDI(STR,IPLATE,1) WRITE(IUN_LOG,1020) STR(1:LENSTR(STR)) WRITE(IUN_LOG,1010) STR = 'Number of profile bins =' CALL STR_ADDI (STR, NPROF_USE, 1) WRITE(IUN_LOG,1020) STR(1:LENSTR(STR)) WRITE(IUN_LOG,1010) STR = + 'Minimum intensity for inclusion in profiles =' CALL STR_ADDF (STR, PROMIN_USE, 1, 1) WRITE(IUN_LOG,1020) STR(1:LENSTR(STR)) WRITE(IUN_LOG,1010) CALL LFN_LIST_PROFS (IUN_LOG, 0, 0, 0, 80, + 2, 2, KERR, ERRSTR) END IF END IF IPRF_PK = IPACK IPRF_PL = IPLATE IF (PROF_ONLY) THEN INTEG_LASTPK = 0 INTEG_LASTPL = 0 GO TO 2000 END IF C C====== Integrate plate C JPROG_PASS = 0 CALL LFN_SAINT (IPACK, IPLATE, 2, IMG, ITYPE, IORD, + NFRASTS, NXRAST, NYRAST, PROMIN_USE, + NPROF_USE, PROF_ROT_USE, NOVLD_USE, + INTEGRATE_PROGRESS, CMD_CNCL, + KERR, ERRSTR) IF (LG_MODE.EQ.1) THEN CALL XDLF_DELETE_VIEW_OBJECT (IVH_BAR, JERR) END IF IF (KERR.NE.0) THEN ERRSTR2 = ' ' CALL AUTO_INTEGRATE_ERR (IUN_LOG, ICONT, ERRSTR, + ERRSTR2, NEXT) IF (.NOT.NEXT) THEN IERR = 1 GO TO 2600 END IF IF (ICONT.EQ.1) GO TO 2000 GO TO 2500 END IF IF (IUN_LOG.GT.0) THEN WRITE(IUN_LOG,1010) STR = 'Integrate intensities for pack' CALL STR_ADDI(STR,IPACK,1) CALL STR_ADDS(STR,', plate',0) CALL STR_ADDI(STR,IPLATE,1) WRITE(IUN_LOG,1020) STR(1:LENSTR(STR)) WRITE(IUN_LOG,1010) IF (IPRF_ALL_USE.EQ.1) THEN STR = + 'Profile determination from each plate in pack' ELSE STR = 'Profile determination from key plate only' END IF WRITE(IUN_LOG,1020) STR(1:LENSTR(STR)) WRITE(IUN_LOG,1010) STR = 'Number of overload pixels allowed in a spot =' CALL STR_ADDI (STR, NOVLD_USE, 1) WRITE(IUN_LOG,1020) STR(1:LENSTR(STR)) WRITE(IUN_LOG,1010) END IF C C====== Set last pack/plate integrated flags C INTEG_LASTPK = IPACK INTEG_LASTPL = IPLATE C C====== Copy spot data to internal LIRL C CALL LRL_NUMSPOTS(NUMSPOTS) IF (NUMSPOTS.EQ.0) THEN IF (CMD_CNCL(0)) GO TO 900 GO TO 2000 END IF CALL LIRLF_NUMREFS (KDX_LIRL, NUMREFS) DO 500 ISPOT = 1, NUMSPOTS CALL LRL_GET (ISPOT, IH, IK, IL, XD, YD, ALAM, + DMTHR2, MULT, OKNOD, SPOV, KERR) IF (MULT.GT.1) THEN CALL LRL_GET_HARM (ISPOT, IH, IK, IL, + IH_N, IK_N, IL_N, + MULT, MINHARM, MAXHARM, + INCHARM, + ALNOD, DTHR2NOD, KERR) ELSE MINHARM = 0 MAXHARM = 0 INCHARM = 0 END IF CALL LRL_GET_XFYFD (ISPOT, XFD, YFD, KERR) CALL LRL_GET_OVLP (ISPOT, SPOV, CLOS, KERR) CALL LRL_GET_INT (ISPOT, AI, SIGI, MEAS, BAD, OVLD, + ICODE, ICODE_TYPE, KERR) ISPAT = 0 ICLOS = 0 IMEAS = 0 IBAD = 0 IOVLD = 0 IF (SPOV) ISPAT = 1 IF (CLOS) ICLOS = 1 IF (MEAS) IMEAS = 1 IF (BAD) IBAD = 1 IF (OVLD) IOVLD = 1 C C====== Suppress any intensities from spatial overlaps which are too close C====== to deconvolute in integration C IF (CLOS) THEN IMEAS = 0 AI = 0.0 SIGI = 0.0 END IF CALL LIRLF_ADDREF (KDX_LIRL, IH, IK, IL, IPACK, + IPLATE, 0, XFD, YFD, ALAM, MULT, + MINHARM, MAXHARM, + INCHARM, AI, SIGI, + ISPAT, ICLOS, + IMEAS, IBAD, IOVLD, ICODE, KERR) IF (KERR.LT.0) THEN ERRSTR = 'Cannot allocate required memory' ERRSTR2 = 'Integration terminated' CALL AUTO_INTEGRATE_ERR (IUN_LOG, 0, ERRSTR, + ERRSTR2, NEXT) CALL LIRLF_DELETE (KDX_LIRL, IPACK, IPLATE, KERR) GO TO 2600 END IF CALL LRL_GET_OVPIX (ISPOT, NOV, KERR) CALL LIRLF_SET_OVPIX (KDX_LIRL, NUMREFS+ISPOT, NOV, + KERR) 500 CONTINUE CALL INTFLAG_SET (IPACK, IPLATE, 1) CALL LOG_INT_TAB1 IF (CMD_CNCL(0)) GO TO 900 2000 CONTINUE 2100 CONTINUE 2500 CONTINUE 2600 IF (LG_MODE.EQ.1) THEN CALL XDLF_DELETE_VIEW_OBJECT (IVH_CNCL_BUT, KERR) END IF RETURN C C====== Cancel requested C 900 CALL AUTO_INTEGRATE_ERR (IUN_LOG, -1, + '==Integration interrupted==', ' ', NEXT) IERR = 100 IF (LG_MODE.EQ.1) THEN CALL XDLF_DELETE_VIEW_OBJECT (IVH_CNCL_BUT, KERR) END IF RETURN C C====== Format statements C 1000 FORMAT (/,'==Automatic Integration==') 1010 FORMAT(' ') 1020 FORMAT(A) END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C******************************** C** AUTO_INTEGRATE_ERR ** C******************************** C C SUBROUTINE AUTO_INTEGRATE_ERR (KUN_LOG, ICONT, ERRSTR, ERRSTR2, + NEXT) C C INCLUDE 'implicit_none.finc' C C Purpose: Handle auto-integrate errors C C Author: John W. Campbell, December 1995 C INTEGER KUN_LOG INTEGER ICONT CHARACTER*(*) ERRSTR CHARACTER*(*) ERRSTR2 LOGICAL NEXT C C Parameters as for LFN_REFN_ERR C C KUN_LOG i (R) Unit number for log file C ICONT i (R) = 0 treat as error which terminates integration C = 1 may continue with next plate if desired C = 2 may continue with next pack if required C =-1 interrupted C ERRSTR c (R) Error string (max 80 chars) C ERRSTR2 c (R) Subsidiary error string - may be blank (max 80 C chars) C NEXT l (W) Set by the routine. If .true. then integration will C be continued with next pack or plate. If .false. C then integration will be terminated. Note: the C routine must set it to .false. ICONT is 0 or -1. C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' INCLUDE 'screen_params.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'prog_flags.finc' INCLUDE 'file_units.finc' INCLUDE 'integ_pars.finc' INCLUDE 'film_pack.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR INTEGER LENSTR C C====== LOCALS: C LOGICAL EOF INTEGER IBUTTON INTEGER IXROOT INTEGER IYROOT CHARACTER*170 STR CHARACTER*60 STR2 C LOGICAL EOF !End of file flag on terminal read C INTEGER IBUTTON !Button selected from error notice C INTEGER IXROOT !Root window x-position for error notice C INTEGER IYROOT !Root window y-position for error notice C CHARACTER*170 STR !String for error message C CHARACTER*60 STR2 !TEmp string C C------------------------------------------------------------------------------- C NEXT = .FALSE. C C====== Write message to log file if required C IF (IUN_LOG.GT.0) THEN STR = 'Error during integration of pack' CALL STR_ADDI (STR, IPACK, 1) CALL STR_ADDS (STR, ',plate', 0) CALL STR_ADDI (STR, IPLATE, 1) WRITE (IUN_LOG,6010) STR(1:LENSTR(STR)) IF (ICONT.LT.0) THEN WRITE (IUN_LOG,6000) ERRSTR(1:LENSTR(ERRSTR)) ELSE WRITE (IUN_LOG,6010) ERRSTR(1:LENSTR(ERRSTR)) IF (ERRSTR2.NE.' ') WRITE (IUN_LOG,6010) + ERRSTR2(1:LENSTR(ERRSTR2)) END IF END IF C C====== Output message etc. depending on program mode C IF (LG_MODE.EQ.1) THEN IF (MENU_I_INP) THEN IF (ICONT.LT.0) THEN CALL LMESSAGE (IVH_IOW, ERRSTR) RETURN ELSE STR = '**' CALL STR_ADDS (STR, ERRSTR, 0) IF (ERRSTR2.NE.' ') THEN CALL STR_ADDS (STR, ':', 1) CALL STR_ADDS (STR, ERRSTR2, 1) END IF CALL STR_ADDS (STR, '**', 0) IF (ICONT.EQ.0) THEN CALL ERR_NOTICE (3, STR) RETURN ELSE CALL NOTICE_POSN(3, IXROOT, IYROOT) IF (ICONT.EQ.1) THEN STR2 = 'Continue with next plate?' ELSE STR2 = 'Continue with next pack?' END IF CALL XDLF_POPUP_NOTICE (IXROOT, IYROOT, + XDLSTR(STR), LENSTR(STR), + XDLSTR(STR2), LENSTR(STR2), + XDLSTR('Yes'), 3, + XDLSTR('No'), 2, + IFONT, 1, IBUTTON) NEXT = .TRUE. IF (IBUTTON.EQ.2) NEXT = .FALSE. RETURN END IF END IF ELSE IF (ICONT.LT.0) THEN CALL LMESSAGE (IVH_CMD, ERRSTR) RETURN ELSE STR = '**Error**' CALL STR_ADDS (STR, ERRSTR, 1) CALL LMESSAGE (IVH_CMD, STR) IF (ERRSTR2.NE.' ') THEN STR = '**Error**' CALL STR_ADDS (STR, ERRSTR2, 1) CALL LMESSAGE (IVH_CMD, STR) END IF IF (ICONT.EQ.0) RETURN NEXT = .FALSE. IF (ICONT.EQ.1) THEN CALL IOW_ASKQ (IVH_CMD, 'Continue with next plate', + NEXT) ELSE CALL IOW_ASKQ (IVH_CMD, 'Continue with next pack', + NEXT) END IF RETURN END IF END IF ELSE IF (LG_MODE.EQ.2) THEN IF (ICONT.LT.0) THEN CALL TWRITE (ERRSTR) RETURN ELSE STR = '**Error**' CALL STR_ADDS (STR, ERRSTR, 1) CALL TWRITE (STR) IF (ERRSTR2.NE.' ') THEN STR = '**Error**' CALL STR_ADDS (STR, ERRSTR2, 1) CALL TWRITE (STR) END IF IF (ICONT.EQ.0) RETURN NEXT = .FALSE. IF (ICONT.EQ.1) THEN CALL TASKQ ('Continue with next plate', NEXT, EOF) ELSE CALL TASKQ ('Continue with next pack', NEXT, EOF) END IF IF (EOF) NEXT = .FALSE. RETURN END IF END IF RETURN C C====== Format statements C 6000 FORMAT (A) 6010 FORMAT ('**Error** ',A) END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C***************************** C** AUTO_REFINE_CTL ** C***************************** C C SUBROUTINE AUTO_REFINE_CTL (IOP, OPTSTR, IPKPL_DF, ICLL_DF, + NODS_DF, NODF_DF) C INCLUDE 'implicit_none.finc' C C Purpose: Control LAUEGEN's auto-refinement requests C C Author: John W. Campbell, October 1994 C C Arguments: C INTEGER IOP CHARACTER*(*) OPTSTR INTEGER IPKPL_DF INTEGER ICLL_DF INTEGER NODS_DF INTEGER NODF_DF C C IOP (R) Option = 1 Auto-refine plate called from refinement menu C = 2 Auto-refine pack called from refinement menu C = 3 Auto-refine from command line input C OPTSTR (R) Auto refinement routine's option string (see LFN_AUTO_REFN) C IPKPL_DF (R) Default value for plate/pack/all (1,2,3) C ICLL_DF (R) Default refine cell flag 1=yes, 2=no C NODS_DF (R) Default nodal index for initial refinements (4-12) e.g. 4 C NODF_DF (R) Default nodal index for final refinements (4-12) e.g. 6 C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' INCLUDE 'screen_params.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'ip1_entries.finc' INCLUDE 'spot_data.finc' INCLUDE 'image.finc' INCLUDE 'upd_flags.finc' INCLUDE 'film_pack.finc' INCLUDE 'prog_flags.finc' INCLUDE 'file_units.finc' INCLUDE 'autorefn_flags.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR EXTERNAL REFINE_PROGRESS EXTERNAL AUTO_REFINE_ERR LOGICAL CMD_CNCL EXTERNAL CMD_CNCL EXTERNAL LAUEGEN_RIMG C C====== LOCALS: C LOGICAL UPD(9) LOGICAL ANY INTEGER I INTEGER J INTEGER IMG_PK INTEGER IMG_PL INTEGER IERR INTEGER IVHLIST(2) INTEGER IVH INTEGER NE INTEGER LISTE(20) REAL RMS CHARACTER*80 ERRSTR CHARACTER*80 ERRSTR2 CHARACTER*8 NAMES(2) CHARACTER*60 STR C LOGICAL UPD(9) !Other pack/plate parameter update flags C LOGICAL ANY !Any rms values determined flag C INTEGER I !Temp/loop variable C INTEGER J !Temp/loop variable C INTEGER IMG_PK !Pack no. of current image read, 0 if none C INTEGER IMG_PL !Plate no. of current image read, 0 if none C INTEGER IERR !Error flag C INTEGER IVHLIST(2) !View-object handles list for getting events C INTEGER IVH !Returned view-object handle from get events C INTEGER NE !No of parameters to update C INTEGER LISTE(20) !List of parameters to update C REAL RMS !Rms error C CHARACTER*80 ERRSTR !Error string C CHARACTER*80 ERRSTR2 !Second error string C CHARACTER*8 NAMES(2) !Menu item names C CHARACTER*60 STR !Temp string DATA NAMES/'CONTINUE',' '/ C C------------------------------------------------------------------------------- C C====== See if an image already read C IMG_PK = 0 IMG_PL = 0 IF (IPACK_OPN.GT.0.AND.IPLATE_OPN.GT.0) THEN IF (FILM_OPEN.AND.FILM_READ) THEN IMG_PK = IPACK_OPN IMG_PL = IPLATE_OPN END IF END IF C C====== Set menu/command-window flag C IF (IOP.LT.3) THEN MEN_INP = .TRUE. ELSE MEN_INP = .FALSE. END IF C C====== Set other pack/plate parameter update flags C UPD(1) = UPD_PHIS UPD(2) = UPD_CTOF UPD(3) = UPD_XCYC UPD(4) = UPD_WC UPD(5) = UPD_YSCAL UPD(6) = UPD_TT UPD(7) = UPD_BULG UPD(8) = UPD_RTOFF UPD(9) = UPD_SPD C C====== Initialise rms results histogram C DO 10 I = 1, 11 NRMS(I) = 0 10 CONTINUE C C====== Set up auto-refinement screen C IF (LG_MODE.EQ.1) THEN IF (MEN_INP) THEN CALL AUTOREFN_SCRN ELSE CALL CMD_CNCL_BUT END IF END IF IERR = 0 IF (CMD_CNCL(0)) GO TO 500 C C====== Auto-refine C CALL LFN_AUTO_REFN (IPACK, IPLATE, OPTSTR, IPKPL_DF, ICLL_DF, + NODS_DF, NODF_DF, IMG_PK, IMG_PL, + LAUEGEN_RIMG, IMG, MAX_IMG_WORDS, ITYPE, + NFRASTS, IUN_LOG, REFINE_PROGRESS, + AUTO_REFINE_ERR, + MAX_HALF_BOX, ISPOT_DATA, ISWORK, + CMD_CNCL, RMS, UPD, IERR, + ERRSTR, ERRSTR2) C C====== Procedure completed, output rms summary C 500 ANY = .FALSE. DO 505 I = 1, 11 IF (NRMS(I).GT.0) ANY = .TRUE. 505 CONTINUE IF (LG_MODE.EQ.1) THEN IF (ANY) THEN CALL LMESSAGE (IVH_IOW, 'Refinement rms summary:') CALL LMESSAGE (IVH_IOW, + '-----------------------------------------------') CALL LMESSAGE (IVH_IOW, + '< .01 .02 .03 .04 .05 .06 .07 .08 .09 .10 >=.10') STR = ' ' DO 510 I = 1, 11 IF (NRMS(I).LE.0) GO TO 510 J = 4*I - 1 IF (I.EQ.11) J = J + 2 WRITE (STR(J:J+2),'(I3)') NRMS(I) 510 CONTINUE CALL LMESSAGE (IVH_IOW, STR) CALL LMESSAGE (IVH_IOW, + '-----------------------------------------------') END IF IF (MEN_INP) THEN CALL XDLF_MENU_AREA_SETMENU (IVH_AUTR_MEN, 1, + XDLSTR(NAMES), 8, + XDLSTR(' '), -1, XDLSTR(' '), -1, + IFONT, IERR) IVHLIST(1) = IVH_AUTR_MEN CALL XDLF_GET_EVENTS (1, IVHLIST, IVH) CALL XDLF_DELETE_VIEW_OBJECT (IVH_AUTR_BASE, IERR) ELSE CALL XDLF_DELETE_VIEW_OBJECT (IVH_CNCL_BUT, IERR) END IF ELSE IF (LG_MODE.EQ.2.AND.ANY) THEN CALL TWRITE ('Refinement rms summary:') CALL TWRITE( + '-----------------------------------------------') CALL TWRITE ( + '< .01 .02 .03 .04 .05 .06 .07 .08 .09 .10 >=.10') STR = ' ' DO 520 I = 1, 11 IF (NRMS(I).LE.0) GO TO 520 J = 4*I - 1 IF (I.EQ.11) J = J + 2 WRITE (STR(J:J+2),'(I3)') NRMS(I) 520 CONTINUE CALL TWRITE (STR) CALL TWRITE ( + '-----------------------------------------------') END IF C C====== Update parameter tables C CALL RESET_CELL IF (LG_MODE.EQ.1) THEN NE = 0 NE = NE + 1 LISTE(NE) = IP_PACK NE = NE + 1 LISTE(NE) = IP_PLATE NE = NE + 1 LISTE(NE) = IP_PHIX NE = NE + 1 LISTE(NE) = IP_PHIY NE = NE + 1 LISTE(NE) = IP_PHIZ NE = NE + 1 LISTE(NE) = IP_A NE = NE + 1 LISTE(NE) = IP_B NE = NE + 1 LISTE(NE) = IP_C NE = NE + 1 LISTE(NE) = IP_ALPH NE = NE + 1 LISTE(NE) = IP_BETA NE = NE + 1 LISTE(NE) = IP_GAMM CALL SET_PAR1_VALS (NE, LISTE) CALL SET_PAR2_VALS (0, LISTE) END IF RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C***************************** C** AUTO_REFINE_ERR ** C***************************** C C SUBROUTINE AUTO_REFINE_ERR (KUN_LOG, ICONT, ERRSTR, ERRSTR2, + NEXT) C C INCLUDE 'implicit_none.finc' C C Purpose: Handle auto-refinement errors C C NOTE: PARAMETERS MUST MATCH THOSE REQUIRED BY LFN_AUTO_REFN ROUTINE C C C Author: John W. Campbell, October 1994 C INTEGER KUN_LOG INTEGER ICONT CHARACTER*(*) ERRSTR CHARACTER*(*) ERRSTR2 LOGICAL NEXT C C Parameters as for LFN_REFN_ERR C C KUN_LOG i (R) Unit number for log file as passed to LFN_AUTO_REFN C ICONT i (R) = 0 treat as error which terminates refinent C = 1 may continue with next plate if desired C = 2 may continue with next pack if required C =-1 interrupted C ERRSTR c (R) Error string (max 80 chars) C ERRSTR2 c (R) Subsidiary error string - may be blank (max 80 C chars) C NEXT l (W) Set by the routine. If .true. then refinement will C be continued with next pack or plate. If .false. C then refinement will be terminated. Note: the C routine must set it to .false. ICONT is 0 or -1. C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' INCLUDE 'screen_params.finc' INCLUDE 'autorefn_flags.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'prog_flags.finc' INCLUDE 'file_units.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR INTEGER LENSTR C C====== LOCALS: C LOGICAL EOF INTEGER IBUTTON INTEGER IXROOT INTEGER IYROOT CHARACTER*170 STR CHARACTER*60 STR2 C LOGICAL EOF !End of file flag on terminal read C INTEGER IBUTTON !Button selected from error notice C INTEGER IXROOT !Root window x-position for error notice C INTEGER IYROOT !Root window y-position for error notice C CHARACTER*170 STR !String for error message C CHARACTER*60 STR2 !TEmp string C C------------------------------------------------------------------------------- C NEXT = .FALSE. C C====== Write message to log file if required C IF (IUN_LOG.GT.0) THEN IF (ICONT.LT.0) THEN WRITE (IUN_LOG,6000) ERRSTR(1:LENSTR(ERRSTR)) ELSE WRITE (IUN_LOG,6010) ERRSTR(1:LENSTR(ERRSTR)) IF (ERRSTR2.NE.' ') WRITE (IUN_LOG,6010) + ERRSTR2(1:LENSTR(ERRSTR2)) END IF END IF C C====== Output message etc. depending on program mode C IF (LG_MODE.EQ.1) THEN IF (MEN_INP) THEN IF (ICONT.LT.0) THEN CALL LMESSAGE (IVH_IOW, ERRSTR) RETURN ELSE STR = '**' CALL STR_ADDS (STR, ERRSTR, 0) IF (ERRSTR2.NE.' ') THEN CALL STR_ADDS (STR, ':', 1) CALL STR_ADDS (STR, ERRSTR2, 1) END IF CALL STR_ADDS (STR, '**', 0) IF (ICONT.EQ.0) THEN CALL ERR_NOTICE (3, STR) RETURN ELSE CALL NOTICE_POSN(3, IXROOT, IYROOT) IF (ICONT.EQ.1) THEN STR2 = 'Continue with next plate?' ELSE STR2 = 'Continue with next pack?' END IF CALL XDLF_POPUP_NOTICE (IXROOT, IYROOT, + XDLSTR(STR), LENSTR(STR), + XDLSTR(STR2), LENSTR(STR2), + XDLSTR('Yes'), 3, + XDLSTR('No'), 2, + IFONT, 1, IBUTTON) NEXT = .TRUE. IF (IBUTTON.EQ.2) NEXT = .FALSE. RETURN END IF END IF ELSE IF (ICONT.LT.0) THEN CALL LMESSAGE (IVH_CMD, ERRSTR) RETURN ELSE STR = '**Error**' CALL STR_ADDS (STR, ERRSTR, 1) CALL LMESSAGE (IVH_CMD, STR) IF (ERRSTR2.NE.' ') THEN STR = '**Error**' CALL STR_ADDS (STR, ERRSTR2, 1) CALL LMESSAGE (IVH_CMD, STR) END IF IF (ICONT.EQ.0) RETURN NEXT = .FALSE. IF (ICONT.EQ.1) THEN CALL IOW_ASKQ (IVH_CMD, 'Continue with next plate', + NEXT) ELSE CALL IOW_ASKQ (IVH_CMD, 'Continue with next pack', + NEXT) END IF RETURN END IF END IF ELSE IF (LG_MODE.EQ.2) THEN IF (ICONT.LT.0) THEN CALL TWRITE (ERRSTR) RETURN ELSE STR = '**Error**' CALL STR_ADDS (STR, ERRSTR, 1) CALL TWRITE (STR) IF (ERRSTR2.NE.' ') THEN STR = '**Error**' CALL STR_ADDS (STR, ERRSTR2, 1) CALL TWRITE (STR) END IF IF (ICONT.EQ.0) RETURN NEXT = .FALSE. IF (ICONT.EQ.1) THEN CALL TASKQ ('Continue with next plate', NEXT, EOF) ELSE CALL TASKQ ('Continue with next pack', NEXT, EOF) END IF IF (EOF) NEXT = .FALSE. RETURN END IF END IF RETURN C C====== Format statements C 6000 FORMAT (A) 6010 FORMAT ('**Error** ',A) END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** AUTO_SCREEN ** C************************** C C SUBROUTINE AUTO_SCREEN C INCLUDE 'implicit_none.finc' C C Purpose: Set up screen for handling auto-indexing C C Author: John W. Campbell, March 1992 C C Arguments: C C None C C====== Parameter statements C INCLUDE 'screen_params.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR C C====== LOCALS: C C====== Layout parameters C INTEGER IWIDTH_FRAME INTEGER IHEIGHT_FRAME INTEGER IX_TABLE INTEGER IY_TABLE INTEGER ITABW INTEGER ITABH INTEGER IX_MENU INTEGER IY_MENU INTEGER MENW INTEGER MENH INTEGER MENUW INTEGER MENUH INTEGER IX_IOW INTEGER IY_IOW INTEGER IOW_W INTEGER IOW_H INTEGER ICOL2_W INTEGER IROW2_H INTEGER MITEMS INTEGER MCHARS INTEGER NCOLS_T INTEGER NCOLS_IOW INTEGER NROWS_T INTEGER NROWS_IOW C INTEGER IWIDTH_FRAME ! Width of the base frame C INTEGER IHEIGHT_FRAME ! Height of the base frame C INTEGER IX_TABLE ! X position of the text table C INTEGER IY_TABLE ! Y position of the text table C INTEGER ITABW ! Text table width required C INTEGER ITABH ! Text table height required C INTEGER IX_MENU ! X position of the menu area C INTEGER IY_MENU ! Y position of the menu area C INTEGER MENW ! Menu width required C INTEGER MENH ! Menu height required C INTEGER MENUW ! Menu width to be used C INTEGER MENUH ! Menu height to be used C INTEGER IX_IOW ! X position of the io_window C INTEGER IY_IOW ! Y position of the io_window C INTEGER IOW_W ! io_window text area width needed C INTEGER IOW_H ! io_window text area height needed C INTEGER IOW_USEW ! io_window width to use C INTEGER IROW2_H ! height of second row of layout C INTEGER MITEMS ! No. of items in menu area (max) C INTEGER MCHARS ! No. of chars (max) in menu item name/title C INTEGER NCOLS_T ! No. columns needed in text table C INTEGER NCOLS_IOW ! No. columns needed in io-window C INTEGER NROWS_T ! No. rows needed in text table C INTEGER NROWS_IOW ! No. rows needed in io-window C C====== Miscellaneous parameters C INTEGER IERR INTEGER IXROOT INTEGER IYROOT C C INTEGER IERR !Error return flag C INTEGER IXROOT !Root window x position for autoindexing screen layout C INTEGER IYROOT !Root window y position for autoindexing screen layout C C------------------------------------------------------------------------------- C C C====== Calculate size requirements and layout parameters C MITEMS = 15 MCHARS = 25 NCOLS_T = 60 NCOLS_IOW = 60 NROWS_T = 18 NROWS_IOW = 16 CALL XDLF_MENU_AREA_GETSIZE (MITEMS, MCHARS, + IFONT, 1, MCHARS, MENW, MENH) CALL XDLF_TEXT_TABLE_GETSIZE (NCOLS_T, NROWS_T, IFONT, + ITABW, ITABH) CALL XDLF_IO_WINDOW_GETSIZE (NCOLS_IOW, NROWS_IOW, IFONT, 1, + IOW_W, IOW_H) C C====== X coordinates and widths C MENUW = MENW IX_MENU = IBORDER IX_TABLE = IBORDER + MENUW + ISEP IX_IOW = IBORDER + MENUW + ISEP ICOL2_W = ITABW IF (IOW_W.GT.ICOL2_W) ICOL2_W = IOW_W IWIDTH_FRAME = 2*IBORDER + ISEP + MENUW + ICOL2_W + 2 C C====== Y coordinates and heights C IY_MENU = IBORDER IY_TABLE = IBORDER IY_IOW = IBORDER + ITABH + ISEP IROW2_H = IOW_H IF (MENH.GT.ITABH+ISEP+IOW_H) IROW2_H = MENH - ISEP - ITABH MENUH = ITABH + ISEP + IROW2_H IHEIGHT_FRAME = 2*IBORDER + ITABH + ISEP + IROW2_H + 2 C C====== Create main frame C CALL XDLF_VIEW_OBJECT_ROOTXY(IVH_BASE,0,0,IXROOT,IYROOT,IERR) CALL XDLF_BASE_FRAME (IVH_BASE_AUT, IWIDTH_FRAME, IHEIGHT_FRAME, + XDLSTR('Autoindex'), 9, XDLSTR('auto'), 4, IXROOT, IYROOT) C C====== Set up text table C CALL XDLF_TEXT_TABLE (IVH_TABL_AUT, IVH_BASE_AUT, + IX_TABLE, IY_TABLE, + 0, 0, 0, + ICOL2_W, ITABH, IFONT, IERR) IF (IERR.GT.0) THEN WRITE (6,2002) IERR STOP ENDIF C C====== Set up menu area C CALL XDLF_MENU_AREA (IVH_MENU_AUT, IVH_BASE_AUT, + IX_MENU, IY_MENU, 0, + MITEMS, MCHARS, IFONT, 1, MCHARS, + MENUW, MENUH, IERR) IF (IERR.GT.0) THEN WRITE (6,2003) IERR STOP ENDIF C C====== Set up io-window area C CALL XDLF_IO_WINDOW (IVH_IOW_AUT, IVH_BASE_AUT, + IX_IOW, IY_IOW, + 0, 0, 0, + ICOL2_W, IROW2_H, IFONT, 100, IERR) IF (IERR.GT.0) THEN WRITE (6,2004) IERR STOP ENDIF C C====== Return C RETURN C C====== Format statements C 2002 FORMAT (/,'**Error code', I2, ' from xdlf_text_table**') 2003 FORMAT (/,'**Error code', I2, ' from xdlf_menu_area**') 2004 FORMAT (/,'**Error code', I2, ' from xdlf_io_window**') END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** AUTO_SEL ** C************************** C C SUBROUTINE AUTO_SEL C INCLUDE 'implicit_none.finc' C C Purpose: Select/show/re-refine etc. autoindexing solutions C C Author: John W. Campbell, March 1992 C C Arguments: C C None C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'lauegen_auto_params.finc' INCLUDE 'file_units.finc' INCLUDE 'ip1_entries.finc' INCLUDE 'film_pack.finc' INCLUDE 'image.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR INTEGER LENSTR LOGICAL CCPEXS C C====== LOCALS: C LOGICAL SEL LOGICAL CONT LOGICAL EXISTS INTEGER IFAIL INTEGER M_SEL INTEGER M_SHOW INTEGER M_REFINE INTEGER M_LIST INTEGER M_SAVE INTEGER I INTEGER N INTEGER LC INTEGER IYN INTEGER NSHOW INTEGER IERR INTEGER LIN_MSG INTEGER M_ITEM INTEGER ISOLN INTEGER NSEL INTEGER NITEMS INTEGER NVIEW INTEGER IVHLIST(2) INTEGER IVH INTEGER IQUIT INTEGER NE INTEGER LISTE(4) INTEGER IFLAG INTEGER ND REAL XD REAL YD REAL SAV_PHIS(3) REAL SAV_SPINDLE CHARACTER*(MAXFLEN) FILNAM CHARACTER*(MAXFLEN) PAR_FILE CHARACTER*25 M2ITEMS(11) CHARACTER*80 STR CHARACTER*2 ERRSTR C LOGICAL SEL !Solution selected flag C LOGICAL CONT !Continue with writing file flag C LOGICAL EXISTS !File already exists flag C INTEGER IFAIL !File open failure flag C INTEGER M_SEL !Menu item number for: Select Solution C INTEGER M_SHOW !Menu item number for: Show Solution C INTEGER M_REFINE !Menu item number for: Refine Solution C INTEGER M_LIST !Menu item number for: List Solution C INTEGER M_SAVE !Menu item number for: Save Solution C INTEGER I !Temp/loop variable C INTEGER N !Points to current solution in sorted list C INTEGER LC !Line count for listing solution data in sections C INTEGER IYN !Return flag from YESNO_NOTICE C INTEGER NSHOW !No. of solutions to be shown in text table C INTEGER IERR !Error flag C INTEGER LIN_MSG !Line number in text table for no. of solns. message C INTEGER M_ITEM !Menu item number from Autoindexing menu C INTEGER ISOLN !Solution number to be used for current option C INTEGER NSEL !Number of solutions with entries on selection menu C INTEGER NITEMS !Number of items in solution number selection menu C INTEGER NVIEW !Number of view_objects for getting events C INTEGER IVHLIST(2) !List of view-object handles for getting events C INTEGER IVH !Returned view object handle from getting events C INTEGER IQUIT !Quit flag from menus C INTEGER NE !Number of parameter table entries to update C INTEGER LISTE(4) !List of parameter table 1 entries to be updated C INTEGER IFLAG !Parameter status flag C INTEGER ND !No. of decimal places flag C REAL XD !Difference in x between obs and calc spot position C REAL YD !Difference in y between obs and calc spot position C REAL SAV_PHIS(3) !Save current PhiX, PhiY, PhiZ values C REAL SAV_SPINDLE !Save current spindle value C CHARACTER*(MAXFLEN) FILNAM !Temp file name C CHARACTER*(MAXFLEN) PAR_FILE !.gen file name C CHARACTER*25 M2ITEMS(11) !Solution numbers selection menu items C CHARACTER*80 STR !Temp output string C CHARACTER*2 ERRSTR !Error string (dummy) C C------------------------------------------------------------------------------- C C C====== Set up screen for handling the solutions C CALL AUTO_SCREEN C C====== Set up menu item numbers for handling the solutions C M_SEL = 1 M_SHOW = 2 M_REFINE = 3 M_LIST = 4 M_SAVE = 5 SEL = .FALSE. C C====== Show best results in text table C CALL XDLF_TEXT_TABLE_TEXT (IVH_TABL_AUT, + XDLSTR('Autoindexing Results'), 20, 1, 18, 1, IERR) CALL XDLF_TEXT_TABLE_TEXT (IVH_TABL_AUT, + XDLSTR('No. PhiX PhiY PhiZ'), 30, 3, 1, 0, IERR) CALL XDLF_TEXT_TABLE_TEXT (IVH_TABL_AUT, + XDLSTR('Unrefined-rms Refined-rms'), 26, 3, 34, 0, IERR) NSHOW = NSTORE_AUT IF (NSHOW.GT.10) NSHOW = 10 DO 100 I = 1, NSHOW N = IP_AUT(I) WRITE (STR,'(I2,1X,3F9.2)') I, STANG(N,1), STANG(N,2), + STANG(N,3) CALL XDLF_TEXT_TABLE_TEXT (IVH_TABL_AUT, XDLSTR(STR), 30, + 4+I, 1, 0, IERR) WRITE(STR,'(F13.3)') STDEV0(N) CALL XDLF_TEXT_TABLE_TEXT (IVH_TABL_AUT, XDLSTR(STR), 13, + 4+I, 34, 0, IERR) WRITE (STR,'(F11.3)') STDEV(N) CALL XDLF_TEXT_TABLE_TEXT (IVH_TABL_AUT, XDLSTR(STR), 11, + 4+I, 49, 0, IERR) 100 CONTINUE IF (NSTORE_AUT.GT.NSHOW) THEN STR = '(+' CALL STR_ADDI(STR,NSTORE_AUT-NSHOW,1) CALL STR_ADDS(STR,'other poorer solutions)',1) CALL XDLF_TEXT_TABLE_TEXT (IVH_TABL_AUT, XDLSTR(STR), + LENSTR(STR), 16, 1, 0, IERR) ENDIF LIN_MSG = 16 IF (NSTORE_AUT.GT.NSHOW) LIN_MSG = 18 STR = 'Best results have' CALL STR_ADDI(STR,NSTORE_AUT,1) CALL STR_ADDS(STR,'solutions with',1) CALL STR_ADDI(STR,MAX_MATCH_AUT,1) CALL STR_ADDS(STR,'matches',1) CALL XDLF_TEXT_TABLE_TEXT (IVH_TABL_AUT, XDLSTR(STR), + LENSTR(STR), LIN_MSG, 1, 0, IERR) C C====== Process Menu C 200 CALL SET_MENU6 NVIEW = 1 IVHLIST(1) = IVH_MENU_AUT C C====== Start event loop C CALL XDLF_GET_EVENTS (NVIEW, IVHLIST, IVH) IF (IVH.EQ.IVH_MENU_AUT) THEN C C====== Menu item selected C CALL XDLF_MENU_AREA_GETITEM (IVH_MENU_AUT, M_ITEM, IQUIT) C C====== Quit box selected C IF (IQUIT.EQ.1) THEN IF (.NOT.SEL) THEN CALL YESNO_NOTICE (2, + 'No solution selected - still quit?', + IYN) IF (IYN.EQ.2) GO TO 200 END IF CALL XDLF_DELETE_VIEW_OBJECT (IVH_IOW_AUT, IERR) CALL XDLF_DELETE_VIEW_OBJECT (IVH_TABL_AUT, IERR) CALL XDLF_DELETE_VIEW_OBJECT (IVH_MENU_AUT, IERR) CALL XDLF_DELETE_VIEW_OBJECT (IVH_BASE_AUT, IERR) RETURN END IF C C====== Get required solution number C NSEL = NSTORE_AUT IF (NSEL.GT.10) NSEL = 10 DO 220 I = 1, NSEL M2ITEMS(I) = 'Solution' CALL STR_ADDI(M2ITEMS(I),I,1) 220 CONTINUE M2ITEMS(NSEL+1) = 'Enter Solution Number' NITEMS = NSEL + 1 NVIEW = 1 IVHLIST(1) = IVH_MENU_AUT CALL XDLF_MENU_AREA_SETMENU (IVH_MENU_AUT, NITEMS, + XDLSTR(M2ITEMS), 25, + XDLSTR('Solution Number Menu'), 20, + XDLSTR('Quit Selection'), 14, 0, IERR) CALL XDLF_GET_EVENTS (NVIEW, IVHLIST, IVH) CALL XDLF_MENU_AREA_GETITEM (IVH_MENU_AUT, ISOLN, IQUIT) IF (IQUIT.EQ.1) GO TO 200 IF (ISOLN.EQ.NSEL+1) THEN 240 ISOLN = 1 CALL IOW_ASKI (IVH_IOW_AUT, 'Solution number', ISOLN) IF (ISOLN.LT.1.OR.ISOLN.GT.NSTORE_AUT) THEN CALL LMESSAGE (IVH_IOW_AUT,'**Solution not stored**') GO TO 240 END IF END IF C C====== Select the solution C IF (M_ITEM.EQ.M_SEL) THEN IF (SEL) THEN CALL YESNO_NOTICE(2, + 'Another solution already accepted - override?', + IYN) IF (IYN.EQ.2) GO TO 200 END IF N = IP_AUT(ISOLN) CALL LDM_SET_PHIX (IPACK, STANG(N,1), IERR, ERRSTR) CALL LDM_SET_PHIY (IPACK, STANG(N,2), IERR, ERRSTR) CALL LDM_SET_PHIZ (IPACK, STANG(N,3), IERR, ERRSTR) CALL LDM_SET_SPIN (IPACK, 0.0, IERR, ERRSTR) SEL = .TRUE. NE = 0 NE = NE + 1 LISTE(NE) = IP_PHIX NE = NE + 1 LISTE(NE) = IP_PHIY NE = NE + 1 LISTE(NE) = IP_PHIZ NE = NE + 1 LISTE(NE) = IP_SPINDL CALL SET_PAR1_VALS (NE, LISTE) C C====== Show the solution (predicted pattern on displayed image) C ELSE IF (M_ITEM.EQ.M_SHOW) THEN N = IP_AUT(ISOLN) CALL SHOW_IMAGE(2, IERR) IF (IERR.EQ.1) GO TO 200 CALL LDM_GET_PHIX (IPACK, SAV_PHIS(1), IFLAG, ND, IERR, + ERRSTR) CALL LDM_GET_PHIY (IPACK, SAV_PHIS(2), IFLAG, ND, IERR, + ERRSTR) CALL LDM_GET_PHIZ (IPACK, SAV_PHIS(3), IFLAG, ND, IERR, + ERRSTR) CALL LDM_GET_SPIN (IPACK, SAV_SPINDLE, IFLAG, ND, IERR, + ERRSTR) CALL LDM_SET_PHIX (IPACK, STANG(N,1), IERR, ERRSTR) CALL LDM_SET_PHIY (IPACK, STANG(N,2), IERR, ERRSTR) CALL LDM_SET_PHIZ (IPACK, STANG(N,3), IERR, ERRSTR) CALL LDM_SET_SPIN (IPACK, 0.0, IERR, ERRSTR) CALL SHOW_PREDICT(2) CALL XDLF_IMAGE_SETTINGS (IVH_FILM, MINTHR, MAXTHR, + MONO_THR, ICONTRAST, ICOLOR_OPT, IOVLY_OPT, IBG_OPT, + MAG_OPT, ISHOW_INT, IERR) CALL XDLF_DELETE_VIEW_OBJECT(IVH_FILM,IERR) CALL LDM_SET_PHIX (IPACK, SAV_PHIS(1), IERR, ERRSTR) CALL LDM_SET_PHIY (IPACK, SAV_PHIS(2), IERR, ERRSTR) CALL LDM_SET_PHIZ (IPACK, SAV_PHIS(3), IERR, ERRSTR) CALL LDM_SET_SPIN (IPACK, SAV_SPINDLE, IERR, ERRSTR) GO TO 200 C C====== Refine solution further C ELSE IF (M_ITEM.EQ.M_REFINE) THEN N = IP_AUT(ISOLN) CALL REFIN_AUT(N) IF (ISOLN.LE.NSHOW) THEN WRITE (STR,'(3F9.2)') STANG(N,1), STANG(N,2), STANG(N,3) CALL XDLF_TEXT_TABLE_TEXT (IVH_TABL_AUT, XDLSTR(STR), 30, + 4+ISOLN, 4, 0, IERR) WRITE (STR,'(F11.3)') STDEV(N) CALL XDLF_TEXT_TABLE_TEXT (IVH_TABL_AUT, XDLSTR(STR), 11, + 4+ISOLN, 49, 0, IERR) END IF GO TO 200 C C====== List solution (showing individual observations) C ELSE IF (M_ITEM.EQ.M_LIST) THEN N = IP_AUT(ISOLN) LC = 0 I = 0 CALL LMESSAGE(IVH_IOW_AUT, + ' h k l xobs yobs xcalc'// + ' ycalc xdiff ydiff') 300 I = I + 1 LC = LC + 1 XD = ABS(STXC(N,1,I)-STXC(N,3,I)) YD = ABS(STXC(N,2,I)-STXC(N,4,I)) WRITE (STR,'(3I3,6F8.2)') + STHKL(N,1,I), STHKL(N,2,I), STHKL(N,3,I), + STXC(N,1,I), STXC(N,2,I), STXC(N,3,I), STXC(N,4,I), + XD, YD CALL LMESSAGE(IVH_IOW_AUT,STR) IF (LC.EQ.10.AND.I.LT.STNOBS(N)) THEN LC = 0 CALL XDLF_IO_WINDOW_PRINT (IVH_IOW_AUT, + XDLSTR('Enter to continue...'), 25, 0, IERR) NVIEW = 1 IVHLIST(1) = IVH_IOW_AUT CALL XDLF_GET_EVENTS (NVIEW, IVHLIST, IVH) END IF IF (I.LT.STNOBS(N)) GO TO 300 STR = 'PhiX =' CALL STR_ADDF(STR,STANG(N,1),2,1) CALL STR_ADDS(STR,', PhiY =',0) CALL STR_ADDF(STR,STANG(N,2),2,1) CALL STR_ADDS(STR,', PhiZ =',0) CALL STR_ADDF(STR,STANG(N,3),2,1) CALL LMESSAGE(IVH_IOW_AUT,STR) STR = 'rms =' CALL STR_ADDF(STR,STDEV(N),3,1) CALL STR_ADDS(STR,'from',1) CALL STR_ADDF(STR,STDEV0(N),3,1) CALL LMESSAGE(IVH_IOW_AUT,STR) GO TO 200 C C====== Save solution (in a parameter file C ELSE IF (M_ITEM.EQ.M_SAVE) THEN N = IP_AUT(ISOLN) 610 CALL LPROMPT + (IVH_IOW_AUT, 'File name (default ext=.ldm): ') NVIEW = 1 IVHLIST(1) = IVH_IOW_AUT CALL XDLF_GET_EVENTS (NVIEW, IVHLIST, IVH) CALL XDLF_IO_WINDOW_GETSTRING (IVH_IOW_AUT, XDLSTR(FILNAM), + MAXFLEN, IERR) IF (FILNAM.EQ.' ') GO TO 200 CALL FILEXT (FILNAM, 'ldm', PAR_FILE, I) CONT = .TRUE. EXISTS = CCPEXS (PAR_FILE) IF (EXISTS) THEN CALL LMESSAGE(IVH_IOW_AUT,'**File already exists**') CONT = .FALSE. CALL IOW_ASKQ (IVH_IOW_AUT, 'Overwrite file', CONT) END IF IF (.NOT.CONT) GO TO 610 IFAIL = 1 CALL CCPDPN (-IUN_GEN, PAR_FILE,'UNKNOWN','F',0,IFAIL) IF (IFAIL.LT.0) THEN CALL LMESSAGE(IVH_IOW_AUT, + '**Error in opening the file**') GO TO 610 END IF CALL LDM_GET_PHIX (IPACK, SAV_PHIS(1), IFLAG, ND, IERR, + ERRSTR) CALL LDM_GET_PHIY (IPACK, SAV_PHIS(2), IFLAG, ND, IERR, + ERRSTR) CALL LDM_GET_PHIZ (IPACK, SAV_PHIS(3), IFLAG, ND, IERR, + ERRSTR) CALL LDM_GET_SPIN (IPACK, SAV_SPINDLE, IFLAG, ND, IERR, + ERRSTR) CALL LDM_SET_PHIX (IPACK, STANG(N,1), IERR, ERRSTR) CALL LDM_SET_PHIY (IPACK, STANG(N,2), IERR, ERRSTR) CALL LDM_SET_PHIZ (IPACK, STANG(N,3), IERR, ERRSTR) CALL LDM_SET_SPIN (IPACK, 0.0, IERR, ERRSTR) CALL WRITE_PARFIL (PAR_FILE) CLOSE (UNIT=IUN_GEN) CALL LDM_SET_PHIX (IPACK, SAV_PHIS(1), IERR, ERRSTR) CALL LDM_SET_PHIY (IPACK, SAV_PHIS(2), IERR, ERRSTR) CALL LDM_SET_PHIZ (IPACK, SAV_PHIS(3), IERR, ERRSTR) CALL LDM_SET_SPIN (IPACK, SAV_SPINDLE, IERR, ERRSTR) GO TO 200 END IF END IF GO TO 200 END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** AUTO_SOFT_CTL ** C************************** C C SUBROUTINE AUTO_SOFT_CTL (IOPT, LINE, IPKALL_DF, NPROF_DF, + PRF_ROT_DF,PROMIN_DF, FRAC_DF, + SIGTEST_DF, FRTEST_DF, + NBINS_DF, BINW_DF, IERR) C INCLUDE 'implicit_none.finc' C C Purpose: Control soft limits calculation from command line requests C C Author: John W. Campbell, November 1994 C C Arguments: C INTEGER IOPT CHARACTER*(*) LINE INTEGER IPKALL_DF INTEGER NPROF_DF LOGICAL PRF_ROT_DF REAL PROMIN_DF REAL FRAC_DF REAL SIGTEST_DF REAL FRTEST_DF INTEGER NBINS_DF REAL BINW_DF INTEGER IERR C C IOPT (R) Soft limit type, 1=dmin, 2=lmin C LINE (R) Line containing non-default options codes & values C IPKALL_DF (R) Default pac/all flag 1/2 C NPROF_DF (R) Default no. of profile bins C PRF_ROT_DF (R) Default rotate profiles flag C PROMIN_DF (R) Default PROMIN value C FRAC_DF (R) Default FRAC value C SIGTEST_DF (R) Default SIGTEST value C FRTEST_DF (R) Default FRTEST value C NBINS_DF (R) DEfault NBINS value C BINW_DF (R) Default BINW value C IERR (W) Error flag =0 OK, =1 error (Note that reporting of errors C is done within this (or called) routines. C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'prog_flags.finc' INCLUDE 'film_pack.finc' INCLUDE 'get_soft.finc' INCLUDE 'image.finc' INCLUDE 'file_units.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR EXTERNAL SOFT_INTEG_PROGRESS LOGICAL CMD_CNCL EXTERNAL CMD_CNCL EXTERNAL LAUEGEN_RIMG EXTERNAL SOFT_LIST EXTERNAL AUTO_SOFT_ERR EXTERNAL SOFT_PROGRESS C C====== LOCALS: C INTEGER IMG_PK INTEGER IMG_PL INTEGER NF_OFF INTEGER NMEAS(MAX_SOFT_BINS) INTEGER NGTSIG(MAX_SOFT_BINS) REAL RBIN(MAX_SOFT_BINS) CHARACTER*80 ERRSTR CHARACTER*80 ERRSTR2 C INTEGER IMG_PK !Pack of currently read image, 0 if none C INTEGER IMG_PL !Plate of currently read image, 0 if none C INTEGER NF_OFF !Offset between start of successive image C rasters C INTEGER NMEAS(MAX_SOFT_BINS) !Nos. of measured spots in bins C INTEGER NGTSIG(MAX_SOFT_BINS) !Nos. of significant spots in bins C REAL RBIN(MAX_SOFT_BINS) !Significant/measured ratios for bins C CHARACTER*80 ERRSTR !Error string (dummy) C CHARACTER*80 ERRSTR2 !Second error string (dummy) C C------------------------------------------------------------------------------- C IERR = 0 C C====== See if an image already read C IMG_PK = 0 IMG_PL = 0 IF (IPACK_OPN.GT.0.AND.IPLATE_OPN.GT.0) THEN IF (FILM_OPEN.AND.FILM_READ) THEN IMG_PK = IPACK_OPN IMG_PL = IPLATE_OPN END IF END IF CALL LFN_AUTO_SOFT (IPACK, IPLATE, IOPT, LINE, + IPKALL_DF, NPROF_DF, PRF_ROT_DF, PROMIN_DF, + FRAC_DF, SIGTEST_DF, FRTEST_DF, + NBINS_DF, BINW_DF, + IMG_PK, IMG_PL, LAUEGEN_RIMG, + IMG, MAX_IMG_WORDS, ITYPE, NFRASTS, + IUN_LOG, SOFT_PROGRESS, SOFT_INTEG_PROGRESS, + SOFT_LIST, AUTO_SOFT_ERR, CMD_CNCL, + MAX_SOFT_BINS, NMEAS, NGTSIG, RBIN, + 2, IERR, ERRSTR, ERRSTR2) RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C**************************** C** AUTO_SOFT_ERR ** C**************************** C C SUBROUTINE AUTO_SOFT_ERR (KUN_LOG, ICONT, ERRSTR, ERRSTR2, NEXT) C INCLUDE 'implicit_none.finc' C C Purpose: Handle automatic soft limit determination errors C C NOTE: PARAMETERS MUST MATCH THOSE REQUIRED BY LFN_AUTO_SOFT ROUTINE C C Author: John W. Campbell, November 1994 C C Arguments: C INTEGER KUN_LOG INTEGER ICONT CHARACTER*(*) ERRSTR CHARACTER*(*) ERRSTR2 LOGICAL NEXT C C Parameters as for LFN_SOFT_ERR C C KUN_LOG i (R) Unit number for log file (0 if none) C ICONT i (R) = 0 treat as error which terminates procedure C = 1 may continue with next pack if desired C =-1 interrupted C ERRSTR c (R) Error string (max 80 chars) C ERRSTR2 c (R) Subsidiary error string - may be blank (max 80 C chars) C NEXT l (W) Set by the routine. If .true. then procedure will C be continued with next pack. If .false. C then procedure will be terminated. Note: the C routine must set it to .false. ICONT is 0 or -1. C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'prog_flags.finc' INCLUDE 'file_units.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR INTEGER LENSTR C C====== LOCALS: C LOGICAL EOF CHARACTER*120 STR C LOGICA EOF !End of file flag C CHARACTER*120 STR !Temp. string C C------------------------------------------------------------------------------- C NEXT = .FALSE. C C====== Write message to log file if required C IF (IUN_LOG.GT.0) THEN IF (ICONT.LT.0) THEN WRITE (IUN_LOG,6000) ERRSTR(1:LENSTR(ERRSTR)) ELSE WRITE (IUN_LOG,6010) ERRSTR(1:LENSTR(ERRSTR)) IF (ERRSTR2.NE.' ') WRITE (IUN_LOG,6010) + ERRSTR2(1:LENSTR(ERRSTR2)) END IF END IF C C====== Output message etc. depending on program mode C IF (LG_MODE.EQ.1) THEN IF (ICONT.LT.0) THEN CALL LMESSAGE (IVH_CMD, ERRSTR) RETURN ELSE STR = '**Error**' CALL STR_ADDS (STR, ERRSTR, 1) CALL LMESSAGE (IVH_CMD, STR) IF (ERRSTR2.NE.' ') THEN STR = '**Error**' CALL STR_ADDS (STR, ERRSTR2, 1) CALL LMESSAGE (IVH_CMD, STR) END IF IF (ICONT.EQ.0) RETURN NEXT = .FALSE. IF (ICONT.EQ.1) THEN CALL IOW_ASKQ (IVH_CMD, 'Continue with next pack', + NEXT) END IF RETURN END IF ELSE IF (LG_MODE.EQ.2) THEN IF (ICONT.LT.0) THEN CALL TWRITE (ERRSTR) RETURN ELSE STR = '**Error**' CALL STR_ADDS (STR, ERRSTR, 1) CALL TWRITE (STR) IF (ERRSTR2.NE.' ') THEN STR = '**Error**' CALL STR_ADDS (STR, ERRSTR2, 1) CALL TWRITE (STR) END IF IF (ICONT.EQ.0) RETURN NEXT = .FALSE. IF (ICONT.EQ.1) THEN CALL TASKQ ('Continue with next pack', NEXT, EOF) END IF IF (EOF) NEXT = .FALSE. RETURN END IF END IF RETURN C C====== Format statements C 6000 FORMAT (A) 6010 FORMAT ('**Error** ',A) END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C******************************* C** AUTO_SPOTSIZE_CTL ** C******************************* C C SUBROUTINE AUTO_SPOTSIZE_CTL (OPTSTR, IPKALL_DF, NBINS_DF, + SDCUT_DF, THRFAC_DF, EXPAND_DF, + IERR) C INCLUDE 'implicit_none.finc' C C Purpose: Control spot size determination from command line input C C Author: John W. Campbell, Setpember 1995 C C Arguments: C CHARACTER*(*) OPTSTR INTEGER IPKALL_DF INTEGER NBINS_DF REAL SDCUT_DF REAL THRFAC_DF REAL EXPAND_DF INTEGER IERR C C OPTSTR (R) Line containing non-default options codes & values C IPKALL_DF (R) Default is for pack/all 1/2 C NBINS_DF (R) Default no. bins for theta analysis for LFN_SPOTS_ANALYSE C SDCUT_DF (R) Default 'standard deviation cutoff' for LFN_FINDSPOTS C THRFAC_DF (R) Default threshold factor for LFN_FINDSPOTS C EXPAND_DF (R) Default spot size expand factor for LFN_SPOTS_ANA_LIS etc. C IERR (W) Error flag =0 OK, C =1 error (Note that reporting of errors is done within C this routine. C =100 Cancelled C None C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'ip2_entries.finc' INCLUDE 'film_pack.finc' INCLUDE 'prog_flags.finc' INCLUDE 'file_units.finc' INCLUDE 'image.finc' INCLUDE 'spot_sizes.finc' INCLUDE 'upd_flags.finc' INCLUDE 'bg_progress.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR INTEGER NXTTOK INTEGER LDM_INTFP EXTERNAL SPOT_PROGRESS LOGICAL CMD_CNCL EXTERNAL CMD_CNCL EXTERNAL BG_PROGRESS EXTERNAL BG_CNCL C C====== LOCALS: C LOGICAL NEXT INTEGER IMG_PK INTEGER IMG_PL INTEGER NBINS INTEGER NPACKS INTEGER NPLATES INTEGER IFLAG INTEGER IPKALL INTEGER INP(6) INTEGER I INTEGER II INTEGER IL INTEGER M1 INTEGER M2 INTEGER NKEYS INTEGER IKEY INTEGER KERR INTEGER JERR INTEGER ND INTEGER IV INTEGER IPK_MIN INTEGER IPK_MAX INTEGER NXRAST INTEGER NYRAST INTEGER NF_OFF INTEGER IORDER INTEGER ISWAP INTEGER IPK INTEGER LISTE(2) INTEGER KPACK INTEGER KPLATE INTEGER KEYPLATE INTEGER ICONT INTEGER NPBOX INTEGER IPCNT INTEGER MINDX_SPOT INTEGER NUMB_L(64) INTEGER NREJ_L(64) INTEGER NGOOD_L(64) INTEGER NUMB_W(64) INTEGER NREJ_W(64) INTEGER NGOOD_W(64) INTEGER NSPOT REAL FP REAL SDCUT REAL THRFAC REAL EXPAND REAL MM_RAST_X REAL MM_RAST_Y REAL RMIN REAL RMAX REAL XLOW REAL XHIGH REAL YLOW REAL YHIGH REAL REXCLUDE REAL SEL_LEN REAL SEL_WID REAL SPT_LEN REAL SPT_WID REAL BIN_S_L(64) REAL BIN_E_L(64) REAL SUM_L (64) REAL VAR_L(64) REAL SDEV_L(64) REAL AVE_L(64) REAL SGOOD_L(64) REAL BIN_S_W(64) REAL BIN_E_W(64) REAL SUM_W (64) REAL VAR_W(64) REAL SDEV_W(64) REAL AVE_W(64) REAL SGOOD_W(64) REAL X_CEN_F REAL Y_CEN_F REAL W_F REAL X_C REAL Y_C REAL XCEN REAL YCEN CHARACTER*2 VALSTR CHARACTER*12 KEYS(6) CHARACTER*80 ERRSTR CHARACTER*80 KERRSTR CHARACTER*80 ERRSTR2 CHARACTER*25 NAME CHARACTER*120 STR CHARACTER*4 SEP C LOGICAL NEXT !Continue with next pack flag C INTEGER IMG_PK !Pack no. of current image read, 0 if none C INTEGER IMG_PL !Plate no. of current image read, 0 if none C INTEGER NBINS !No. of angular bins for spot size analysis C INTEGER NPACKS !No. of packs C INTEGER NPLATES !No. of plates C INTEGER IFLAG !Parameter status flag C INTEGER IPKALL !Process all/pack flag C INTEGER INP(6) !Flags for option key already input C INTEGER I !Temp/loop variable C INTEGER II !LDM_INTFP function return value C INTEGER IL !Index to last character processed in string C INTEGER M1 !Index to first character in token C INTEGER M2 !Index to final character in token C INTEGER NKEYS !No. of option keys C INTEGER IKEY !Option key number C INTEGER KERR !Error flag C INTEGER JERR !Error flag C INTEGER ND !No. of decimal places flag C INTEGER IV !Integer value C INTEGER IPK_MIN !Minimum pack number for processing C INTEGER IPK_MAX !Maximum pack number for processing C INTEGER NXRAST !No. x-rasters C INTEGER NYRAST !No. y-rasters C INTEGER NF_OFF !Offset between start of slow rasters in image C INTEGER IORDER !Axis order flag C INTEGER ISWAP !Byte swap flag C INTEGER IPK !Pack loop variable C INTEGER LISTE(2) !List of parameter table entries to be updated C INTEGER KPACK !Pack number, 0 = all packs C INTEGER KPLATE !Plate number, 0 = all plates C INTEGER KEYPLATE !Key plate C INTEGER ICONT !Continue on error flag C INTEGER NPBOX !Box size for background searches C INTEGER IPCNT !Percent threshold for background points C INTEGER MINDX_SPOT !Index for spots list in memory records C INTEGER NUMB_L(64) !Spot length analysis parameters C INTEGER NREJ_L(64) !" C INTEGER NGOOD_L(64) !" C INTEGER NUMB_W(64) !Spot width analysis parameters C INTEGER NREJ_W(64) !" c INTEGER NGOOD_W(64) !" C INTEGER NSPOT !No. of spots found C REAL FP !Real value C REAL SDCUT !Standard deviation cutoff C REAL THRFAC !Threshold factor (*background) for spots C REAL EXPAND !Expansion factor: ave obs. -> proposed C REAL MM_RAST_X !Conversion mm to x-rasters C REAL MM_RAST_Y !Conversion mm to y-rasters C REAL RMIN !RMIN parameter converted to rasters C REAL RMAX !RMAX parameter converted to rasters C REAL XLOW !Low x limit in rasters C REAL XHIGH !High x limit in rasters C REAL YLOW !Low y limit in raster C REAL YHIGH !High y limit in rasters C REAL REXCLUDE !Exclusion adjustment to RMIN, RMAX (rasters) C REAL SEL_LEN !Determined spot length (rasters) C REAL SEL_WID !Determined spot width (rasters) C REAL SPT_LEN !Spot length (proposed) in mm C REAL SPT_WID !Spot width (proposed) in mm C REAL BIN_S_L(64) !Spot length analysis parameters C REAL BIN_E_L(64) !" C REAL SUM_L (64) !" C REAL VAR_L(64) !" C REAL SDEV_L(64) !" C REAL AVE_L(64) !" C REAL SGOOD_L(64) !" C REAL BIN_S_W(64) !Spot width analysis parameters C REAL BIN_E_W(64) !" C REAL SUM_W (64) !" C REAL VAR_W(64) !" C REAL SDEV_W(64) !" C REAL AVE_W(64) !" C REAL SGOOD_W(64) !" C REAL X_CEN_F !X centre C REAL Y_CEN_F !Y centre C REAL W_F !Omega C REAL X_C !x_c in mm C REAL Y_C !y_c in mm C REAL XCEN !X centre (corrected) in rasters C REAL YCEN !Y centre (corrected) in rasters C CHARACTER*2 VALSTR !Parameter value string (dummy) C CHARACTER*12 KEYS(6) !Option keys C CHARACTER*80 ERRSTR !Error string C CHARACTER*80 KERRSTR !Error string C CHARACTER*80 ERRSTR2 !Subsidiary error string C CHARACTER*25 NAME !Option key name C CHARACTER*120 STR !Message string C CHARACTER*4 SEP !Token separator characters DATA SEP /' ,='/ DATA KEYS /'PACK', + 'ALL', + 'THRESH', + 'NBINS', + 'SDCUT', + 'EXPAND'/ C C C------------------------------------------------------------------------------- IERR = 0 ERRSTR = ' ' ERRSTR2 = ' ' C C====== See if an image already read C IMG_PK = 0 IMG_PL = 0 IF (IPACK_OPN.GT.0.AND.IPLATE_OPN.GT.0) THEN IF (FILM_OPEN.AND.FILM_READ) THEN IMG_PK = IPACK_OPN IMG_PL = IPLATE_OPN END IF END IF C C====== Check pack/plate C CALL LDM_GET_NUMP (NPACKS, IFLAG) CALL LDM_GET_NPLAT (NPLATES, IFLAG) IF (IPACK.LT.1.OR.IPACK.GT.NPACKS) THEN ERRSTR = 'Current pack number is invalid' ERRSTR2 = 'Pack =' CALL STR_ADDI (ERRSTR2, IPACK, 1) CALL STR_ADDS (ERRSTR2, ', plate =', 0) CALL STR_ADDI (ERRSTR2, IPLATE, 1) CALL AUTO_SPOTSIZE_ERR (IUN_LOG, 0, ERRSTR, ERRSTR2, NEXT) IERR = 1 RETURN END IF IF (IPLATE.LT.1.OR.IPLATE.GT.NPLATES) THEN ERRSTR = 'Current plate number is invalid' ERRSTR2 = 'Pack =' CALL STR_ADDI (ERRSTR2, IPACK, 1) CALL STR_ADDS (ERRSTR2, ', plate =', 0) CALL STR_ADDI (ERRSTR2, IPLATE, 1) CALL AUTO_SPOTSIZE_ERR (IUN_LOG, 0, ERRSTR, ERRSTR2, NEXT) IERR = 1 RETURN END IF C C====== Get control parameter defaults C NBINS = NBINS_DF SDCUT = SDCUT_DF THRFAC = THRFAC_DF EXPAND = EXPAND_DF C C====== Interpret command string C DO 10 I = 1, 6 INP(I) = 0 10 CONTINUE IPKALL = 0 NKEYS = 6 SEP(2:2) = CHAR(9) IL = 0 100 I = NXTTOK (OPTSTR, SEP, IL, M1, M2) IF (I.EQ.-1) GO TO 200 IF (I.EQ.0) GO TO 100 NAME = OPTSTR(M1:M2) CALL CCPUPC (NAME) CALL GETOPT (KEYS, NKEYS, NAME, IKEY, KERR) IF (KERR.NE.0) THEN IF (KERR.EQ.1) ERRSTR = 'Ambiguous option' IF (KERR.EQ.2) ERRSTR = 'Invalid option' ERRSTR2 = 'Option string:' CALL STR_ADDS (ERRSTR2, NAME, 1) CALL AUTO_SPOTSIZE_ERR (IUN_LOG, 0, ERRSTR, ERRSTR2, NEXT) IERR = 1 RETURN END IF IF (INP(IKEY).EQ.1) THEN ERRSTR = 'Duplicate option' ERRSTR2 = 'Option string:' CALL STR_ADDS (ERRSTR2, NAME, 1) CALL AUTO_SPOTSIZE_ERR (IUN_LOG, 0, ERRSTR, ERRSTR2, NEXT) IERR = 1 RETURN END IF IF (IKEY.LE.2) THEN IF (IPKALL.NE.0) THEN ERRSTR = 'Inconsistent option' ERRSTR2 = 'Option string:' CALL STR_ADDS (ERRSTR2, NAME, 1) CALL AUTO_SPOTSIZE_ERR (IUN_LOG, 0, ERRSTR, ERRSTR2, NEXT) IERR = 1 RETURN ELSE INP(IKEY) = 1 IPKALL = IKEY END IF ELSE INP(IKEY) = 1 I = NXTTOK (OPTSTR, SEP, IL, M1, M2) IF (I.LE.0) THEN ERRSTR = 'Option' CALL STR_ADDS (ERRSTR, NAME, 1) CALL STR_ADDS (ERRSTR, 'not followed by a value', 1) CALL AUTO_SPOTSIZE_ERR (IUN_LOG, 0, ERRSTR, ERRSTR2, NEXT) IERR = 1 RETURN END IF II = LDM_INTFP (OPTSTR(M1:M2), FP, IV, ND) IF (II.LE.0) THEN ERRSTR = 'Option' CALL STR_ADDS (ERRSTR, NAME, 1) CALL STR_ADDS (ERRSTR, 'not followed by a valid value', 1) CALL AUTO_SPOTSIZE_ERR (IUN_LOG, 0, ERRSTR, ERRSTR2, NEXT) IERR = 1 RETURN END IF IF (IKEY.EQ.3) THEN IF (FP.LE.1.0) GO TO 150 THRFAC = FP ELSE IF (IKEY.EQ.4) THEN IF (II.NE.1.OR.IV.LT.1.OR.IV.GT.64) GO TO 150 NBINS = IV ELSE IF (IKEY.EQ.5) THEN IF (FP.LE.0.0) GO TO 150 SDCUT = FP ELSE IF (IKEY.EQ.6) THEN IF (FP.LE.1.0) GO TO 150 EXPAND = FP END IF END IF GO TO 100 C C====== Invalid value C 150 ERRSTR = OPTSTR(M1:M2) CALL STR_ADDS (ERRSTR, 'is not a valid value for option', 1) CALL STR_ADDS (ERRSTR, NAME, 1) CALL AUTO_SPOTSIZE_ERR (IUN_LOG, 0, ERRSTR, ERRSTR2, NEXT) IERR = 1 RETURN C C====== Set pack range C 200 IF (IPKALL.EQ.0) IPKALL = IPKALL_DF IF (IPKALL.EQ.1) THEN IPK_MIN = IPACK IPK_MAX = IPACK ELSE IPK_MIN = 1 CALL LDM_GET_NUMP (IPK_MAX, IFLAG) IF (IPK_MAX.LT.1) IPK_MAX = 1 END IF C C====== Get some image related details C CALL LDM_GET_NXRAS (NXRAST, IFLAG) CALL LDM_GET_NYRAS (NYRAST, IFLAG) CALL LDM_GET_AXORD (VALSTR, IORDER, ISWAP, IFLAG) CALL LDM_GET_XLOW (XLOW, IFLAG, ND) CALL LDM_GET_XHIGH (XHIGH, IFLAG, ND) CALL LDM_GET_YLOW (YLOW, IFLAG, ND) CALL LDM_GET_YHIGH (YHIGH, IFLAG, ND) IF (LG_MODE.EQ.1) CALL CMD_CNCL_BUT IF (CMD_CNCL(0)) GO TO 900 ISP_PROGX = 0 ISP_PROGY = 0 IF (LG_MODE.EQ.1) CALL XDLF_VIEW_OBJECT_ROOTXY (IVH_CMD,8,35, + ISP_PROGX,ISP_PROGY,KERR) IBG_PROGX = ISP_PROGX IBG_PROGY = ISP_PROGY C C====== Loop through required packs C====== =========================== C DO 2000 IPK = IPK_MIN, IPK_MAX ICONT = 1 IF (IPK.EQ.IPK_MAX) ICONT = 0 CALL LDM_GET_KEYP (IPK, KEYPLATE, IFLAG, KERR, ERRSTR) IF (KEYPLATE.LT.1.OR.KEYPLATE.GT.NPLATES) THEN ERRSTR = 'Keyplate' CALL STR_ADDI (ERRSTR, KEYPLATE, 1) CALL STR_ADDS (ERRSTR,'out of range for pack',1) CALL STR_ADDI (ERRSTR, IPK,1) ERRSTR2 = ' ' CALL AUTO_SPOTSIZE_ERR (IUN_LOG, ICONT, ERRSTR, + ERRSTR2, NEXT) IF (.NOT.NEXT) THEN IERR = 1 GO TO 2010 END IF IF (CMD_CNCL(0)) GO TO 900 GO TO 2000 END IF IPACK = IPK IPLATE = KEYPLATE C C====== Update parameter tables C IF (LG_MODE.EQ.1) THEN CALL SET_PAR1_VALS (0, LISTE) CALL SET_PAR2_VALS (0, LISTE) END IF STR = '==Determining spot size for pack' CALL STR_ADDI (STR, IPACK, 1) CALL STR_ADDS (STR, 'using plate', 1) CALL STR_ADDI (STR, IPLATE, 1) CALL STR_ADDS (STR, '==', 0) IF (LG_MODE.EQ.1) THEN CALL LMESSAGE (IVH_IOW, STR) ELSE IF (LG_MODE.EQ.2) THEN CALL TWRITE (STR) END IF C C====== Read image if not already read C IF (IPACK.NE.IMG_PK.OR.IPLATE.NE.IMG_PL) THEN CALL LAUEGEN_RIMG (IPACK, IPLATE, ITYPE, NF_OFF, IMG, + MAX_IMG_WORDS, KERR, KERRSTR) IF (KERR.NE.0) THEN ERRSTR = 'Error reading image for pack' CALL STR_ADDI (ERRSTR, IPACK, 1) CALL STR_ADDS (ERRSTR, ', plate', 0) CALL STR_ADDI (ERRSTR, IPLATE, 1) ERRSTR2 = KERRSTR ICONT = 1 IF (IPACK.EQ.IPK_MAX) ICONT = 0 IMG_PK = 0 IMG_PL = 0 CALL AUTO_SPOTSIZE_ERR (IUN_LOG, ICONT, ERRSTR, + ERRSTR2, NEXT) IF (.NOT.NEXT) THEN IERR = 1 GO TO 2010 END IF GO TO 2000 END IF IMG_PK = IPACK IMG_PL = IPLATE END IF NF_OFF = NFRASTS IF (CMD_CNCL(0)) GO TO 900 C C====== 2-D background calculations C NPBOX = 2 * ((NFRASTS/NCMP)/50) + 1 IPCNT = 50 PROG_BG_ON = .FALSE. CALL XDLF_BG_CALC_PROG (IMG, ITYPE, NSRASTS, NFRASTS, NFRASTS, + NCMP, NPBOX, -IPCNT, IMG_BG, NF_BGOFF, + BG_PROGRESS, BG_CNCL, KERR) IF (LG_MODE.EQ.1) THEN IF (PROG_BG_ON) CALL XDLF_DELETE_VIEW_OBJECT (IVH_BAR, JERR) END IF IF (KERR.EQ.-1) GO TO 900 IF (KERR.EQ.2) THEN ERRSTR = 'Search box too big for image' ERRSTR2 = ' ' CALL AUTO_SPOTSIZE_ERR (IUN_LOG, 0, ERRSTR, ERRSTR2, NEXT) IERR = 1 GO TO 2010 END IF CALL FILM_CENTRE (X_CEN_F, Y_CEN_F, W_F) CALL LDM_GET_XC (IPACK, IPLATE, X_C, IFLAG, ND, KERR, ERRSTR) CALL LDM_GET_YC (IPACK, IPLATE, Y_C, IFLAG, ND, KERR, ERRSTR) CALL LDM_MMRAST (IPACK, IPLATE, MM_RAST_X, MM_RAST_Y) CALL LDM_GET_RMIN (RMIN, IFLAG, ND) RMIN = RMIN*MM_RAST_X CALL LDM_GET_RMAX (RMAX, IFLAG, ND) RMAX = RMAX*MM_RAST_X XCEN = X_CEN_F + X_C*MM_RAST_X YCEN = Y_CEN_F + Y_C*MM_RAST_Y IF (NXRAST.GT.MAX_RASTS.OR.NYRAST.GT.MAX_RASTS) THEN ERRSTR = 'Too many rasters in image for spot search' ERRSTR2 = ' ' IERR = 1 GO TO 2010 END IF REXCLUDE = FLOAT(NPBOX*NCMP)/SQRT(2.0) C C====== Determine spot size C CALL LFN_FINDSPOTS (IMG, ITYPE, IORDER, NF_OFF, + NXRAST, NYRAST, IMG_BG, NF_BGOFF, + NCMP, ISP_DATA, ISP_WORK, XCEN, YCEN, + RMIN, RMAX, + XLOW, XHIGH, YLOW, YHIGH, REXCLUDE, + THRFAC, + SPOT_PROGRESS, CMD_CNCL, + MINDX_SPOT, NSPOT, KERR, ERRSTR) IF (LG_MODE.EQ.1) THEN IF (PROG_BAR) CALL XDLF_DELETE_VIEW_OBJECT (IVH_BAR, JERR) END IF IF (KERR.NE.0) THEN CALL DMLF_FREE (MINDX_SPOT, JERR) IF (KERR.EQ.100) GO TO 900 CALL AUTO_SPOTSIZE_ERR (IUN_LOG, 0, ERRSTR, ERRSTR2, NEXT) IERR = 1 GO TO 2010 END IF IF (NSPOT.EQ.0) THEN CALL DMLF_FREE (MINDX_SPOT, KERR) ERRSTR = 'No spots found' ERRSTR2 = ' ' CALL AUTO_SPOTSIZE_ERR (IUN_LOG, 0, ERRSTR, ERRSTR2, NEXT) IERR = 1 GO TO 2010 END IF CALL LFN_SPOTS_ANALYSE (MINDX_SPOT, 1, SDCUT, NBINS, + BIN_S_L, BIN_E_L, SUM_L, NUMB_L, + VAR_L, SDEV_L, AVE_L, NREJ_L, SGOOD_L, + NGOOD_L, SEL_LEN, KERR, ERRSTR) CALL LFN_SPOTS_ANALYSE (MINDX_SPOT, 2, SDCUT, NBINS, + BIN_S_W, BIN_E_W, SUM_W, NUMB_W, + VAR_W, SDEV_W, AVE_W, NREJ_W, SGOOD_W, + NGOOD_W, SEL_WID, KERR, ERRSTR) CALL DMLF_FREE (MINDX_SPOT, KERR) SPT_LEN = EXPAND*SEL_LEN/MM_RAST_X SPT_WID = EXPAND*SEL_WID/MM_RAST_X CALL LDM_SET_SPOTL (IPACK, IPLATE, SPT_LEN, KERR, ERRSTR) CALL LDM_SET_SPOTW (IPACK, IPLATE, SPT_WID, KERR, ERRSTR) IF (LG_MODE.EQ.1) THEN LISTE(1) = IP_STRK_L LISTE(2) = IP_STRK_W CALL SET_PAR2_VALS (2, LISTE) END IF STR = 'New spot length =' CALL STR_ADDF (STR, SPT_LEN, 2, 1) CALL STR_ADDS (STR, 'mm', 1) IF (LG_MODE.EQ.1) THEN CALL LMESSAGE(IVH_IOW, STR) ELSE IF (LG_MODE.EQ.2) THEN CALL TWRITE (STR) END IF STR = 'New spot width =' CALL STR_ADDF (STR, SPT_WID, 2, 1) CALL STR_ADDS (STR, 'mm', 1) IF (LG_MODE.EQ.1) THEN CALL LMESSAGE(IVH_IOW, STR) ELSE IF (LG_MODE.EQ.2) THEN CALL TWRITE (STR) END IF CALL OTHERS_UPD (1, UPD_SPOT, KPACK, KPLATE) CALL LDM_SET_SPOTL (KPACK, KPLATE, SPT_LEN, KERR, ERRSTR) CALL LDM_SET_SPOTW (KPACK, KPLATE, SPT_WID, KERR, ERRSTR) IF (IUN_LOG.GT.0) WRITE(IUN_LOG,'('' '')') IF (IUN_LOG.GT.0) CALL LFN_SPOTS_ANA_LIS (IUN_LOG, 0, 1, + ISPOT_NBIN, BIN_S_L, BIN_E_L, SGOOD_L, + NGOOD_L, NREJ_L, SEL_LEN, 1.0/MM_RAST_X, + THRFAC, SDCUT, EXPAND, IPACK, IPLATE) IF (IUN_LOG.GT.0) CALL LFN_SPOTS_ANA_LIS (IUN_LOG, 0, 2, + ISPOT_NBIN, BIN_S_W, BIN_E_W, SGOOD_W, + NGOOD_W, NREJ_W, SEL_WID, 1.0/MM_RAST_X, + THRFAC, SDCUT, EXPAND, IPACK, IPLATE) IF (CMD_CNCL(0)) GO TO 900 2000 CONTINUE 2010 IF (LG_MODE.EQ.1) THEN CALL XDLF_DELETE_VIEW_OBJECT (IVH_CNCL_BUT, KERR) END IF RETURN C C====== Cancel requested C 900 CALL AUTO_SPOTSIZE_ERR (IUN_LOG, -1, + '==Spot size determination interrupted==', ' ', NEXT) IERR = 100 IF (LG_MODE.EQ.1) THEN CALL XDLF_DELETE_VIEW_OBJECT (IVH_CNCL_BUT, KERR) END IF RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C******************************* C** AUTO_SPOTSIZE_ERR ** C******************************* C C SUBROUTINE AUTO_SPOTSIZE_ERR (KUN_LOG, ICONT, ERRSTR, ERRSTR2, + NEXT) C INCLUDE 'implicit_none.finc' C C Purpose: Handle command line requested spotsize determination errors C C Author: John W. Campbell, September 1995 C C Arguments: C INTEGER KUN_LOG INTEGER ICONT CHARACTER*(*) ERRSTR CHARACTER*(*) ERRSTR2 LOGICAL NEXT C C Parameters: C C KUN_LOG i (R) Unit number for log file (0 if none) C ICONT i (R) = 0 treat as error which terminates procedure C = 1 may continue with next pack if desired C =-1 interrupted C ERRSTR c (R) Error string (max 80 chars) C ERRSTR2 c (R) Subsidiary error string - may be blank (max 80 C chars) C NEXT l (W) Set by the routine. If .true. then procedure will C be continued with next pack. If .false. C then procedure will be terminated. Note: the C routine must set it to .false. ICONT is 0 or -1. C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'prog_flags.finc' INCLUDE 'file_units.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR INTEGER LENSTR C C====== LOCALS: C LOGICAL EOF CHARACTER*120 STR C LOGICA EOF !End of file flag C CHARACTER*120 STR !Temp. string C C------------------------------------------------------------------------------- C NEXT = .FALSE. C C====== Write message to log file if required C IF (IUN_LOG.GT.0) THEN IF (ICONT.LT.0) THEN WRITE (IUN_LOG,6000) ERRSTR(1:LENSTR(ERRSTR)) ELSE WRITE (IUN_LOG,6010) ERRSTR(1:LENSTR(ERRSTR)) IF (ERRSTR2.NE.' ') WRITE (IUN_LOG,6010) + ERRSTR2(1:LENSTR(ERRSTR2)) END IF END IF C C====== Output message etc. depending on program mode C IF (LG_MODE.EQ.1) THEN IF (ICONT.LT.0) THEN CALL LMESSAGE (IVH_CMD, ERRSTR) RETURN ELSE STR = '**Error**' CALL STR_ADDS (STR, ERRSTR, 1) CALL LMESSAGE (IVH_CMD, STR) IF (ERRSTR2.NE.' ') THEN STR = '**Error**' CALL STR_ADDS (STR, ERRSTR2, 1) CALL LMESSAGE (IVH_CMD, STR) END IF IF (ICONT.EQ.0) RETURN NEXT = .FALSE. IF (ICONT.EQ.1) THEN CALL IOW_ASKQ (IVH_CMD, 'Continue with next pack', + NEXT) END IF RETURN END IF ELSE IF (LG_MODE.EQ.2) THEN IF (ICONT.LT.0) THEN CALL TWRITE (ERRSTR) RETURN ELSE STR = '**Error**' CALL STR_ADDS (STR, ERRSTR, 1) CALL TWRITE (STR) IF (ERRSTR2.NE.' ') THEN STR = '**Error**' CALL STR_ADDS (STR, ERRSTR2, 1) CALL TWRITE (STR) END IF IF (ICONT.EQ.0) RETURN NEXT = .FALSE. IF (ICONT.EQ.1) THEN CALL TASKQ ('Continue with next pack', NEXT, EOF) END IF IF (EOF) NEXT = .FALSE. RETURN END IF END IF RETURN C C====== Format statements C 6000 FORMAT (A) 6010 FORMAT ('**Error** ',A) END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C******************************* C** AUTO_WRITEINT_CTL ** C******************************* C C SUBROUTINE AUTO_WRITEINT_CTL (OPTSTR, IPKALL_DF, INT_FTYP_DF, + INT_TEMPL_DF, SCAL_INT_DF, IERR) C INCLUDE 'implicit_none.finc' C C Purpose: Control writing of integrated intensities files from C command line input C C Author: John W. Campbell, January 1996 C C Arguments: C CHARACTER*(*) OPTSTR INTEGER IPKALL_DF CHARACTER*(*) INT_FTYP_DF CHARACTER*(*) INT_TEMPL_DF REAL SCAL_INT_DF INTEGER IERR C C OPTSTR (R) Line containing non-default options codes & values C IPKALL_DF (R) Default is for pack/all 1/2 C INT_FTYP_DF (R) Default file type string 'mtz' or 'ge' C INT_TEMPL_DF (R) Default template for intensities file names C SCAL_INT_DF (R) Default o/p intensities scaling factor C IERR (W) Error flag =0 OK, C =1 error (Note that reporting of errors is done within C this routine. C =100 Cancelled C None C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'film_pack.finc' INCLUDE 'file_units.finc' INCLUDE 'prog_flags.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR INTEGER NXTTOK INTEGER LDM_INTFP LOGICAL CCPEXS C C====== LOCALS: C LOGICAL NEXT LOGICAL ANY_INT LOGICAL ANY_PRES LOGICAL EXISTS INTEGER IPKALL INTEGER INP(5) INTEGER I INTEGER II INTEGER IL INTEGER M1 INTEGER M2 INTEGER NKEYS INTEGER IKEY INTEGER KERR INTEGER ND INTEGER IV INTEGER IPK_MIN INTEGER IPK_MAX INTEGER IPK INTEGER IPL INTEGER IFLG INTEGER ICONT INTEGER NPACKS INTEGER NPLATES INTEGER IFLAG INTEGER IRET INTEGER JLEN INTEGER ILEN INTEGER IFAIL INTEGER INT_TYPE INTEGER LISTE(2) REAL FP REAL SCALE_INT CHARACTER*12 KEYS(5) CHARACTER*80 ERRSTR CHARACTER*80 ERRSTR2 CHARACTER*25 NAME CHARACTER*120 STR CHARACTER*4 SEP CHARACTER*6 INT_FTYP CHARACTER*(MAXFLEN) FILNAM CHARACTER*(MAXFLEN) MTZ_FILE CHARACTER*(MAXFLEN) GE1_FILE CHARACTER*(MAXFLEN) GE2_FILE CHARACTER*(MAXFLEN) INT_TEMPL C LOGICAL NEXT !Continue with next pack flag C LOGICAL ANY_INT !Any intensities present flag C LOGICAL ANY_PRES !.ge1 and/or .ge2 file already present flag C LOGICAL EXISTS !File exists flag C INTEGER IPKALL !Process all/pack flag C INTEGER INP(5) !Flags for option key already input C INTEGER I !Temp/loop variable C INTEGER II !LDM_INTFP function return value C INTEGER IL !Index to last character processed in string C INTEGER M1 !Index to first character in token C INTEGER M2 !Index to final character in token C INTEGER NKEYS !No. of option keys C INTEGER IKEY !Option key number C INTEGER KERR !Error flag C INTEGER ND !No. of decimal places flag C INTEGER IV !Integer value C INTEGER IPK_MIN !Minimum pack number for processing C INTEGER IPK_MAX !Maximum pack number for processing C INTEGER IPK !Pack loop variable C INTEGER IPL !Plate loop variable C INTEGER IFLG !Integration status flag C INTEGER ICONT !Continue on error flag C INTEGER NPACKS !No. of packs C INTEGER NPLATES !No. of plates C INTEGER IFLAG !Parameter status flag C INTEGER IRET !Return flag from MTZ file check routines C INTEGER JLEN !Length of filename up to extension C INTEGER ILEN !Length of filename up to extension C INTEGER IFAIL !File open failure flag C INTEGER INT_TYPE !Intensities file type flag =1 mtz,=2 ge1/.ge2 C INTEGER LISTE(2) !List of parameter table entries to be updated C REAL FP !Floating point value C REAL SCALE_INT !Scale factor for output intensities C CHARACTER*12 KEYS(5) !Option keys C CHARACTER*80 ERRSTR !Error string C CHARACTER*80 ERRSTR2 !Subsidiary error string C CHARACTER*25 NAME !Option key name C CHARACTER*120 STR !Message string C CHARACTER*4 SEP !Token separator characters C CHARACTER*6 INT_FTYP !Output file type code C CHARACTER*(MAXFLEN) FILNAM !File name C CHARACTER*(MAXFLEN) MTZ_FILE !MTZ file name C CHARACTER*(MAXFLEN) GE1_FILE !.ge1 file name C CHARACTER*(MAXFLEN) GE2_FILE !.ge2 file name C CHARACTER*(MAXFLEN) INT_TEMPL !File name template DATA SEP /' ,='/ DATA KEYS /'PACK', + 'ALL', + 'INT_FTYPE', + 'INT_TEMPLATE', + 'SCALE_INT'/ C C C------------------------------------------------------------------------------- IERR = 0 ERRSTR = ' ' ERRSTR2 = ' ' IF (IUN_LOG.GT.0) WRITE (IUN_LOG, 1000) C C====== Check pack/plate C CALL LDM_GET_NUMP (NPACKS, IFLAG) CALL LDM_GET_NPLAT (NPLATES, IFLAG) IF (IPACK.LT.1.OR.IPACK.GT.NPACKS) THEN ERRSTR = 'Current pack number is invalid' ERRSTR2 = 'Pack =' CALL STR_ADDI (ERRSTR2, IPACK, 1) CALL STR_ADDS (ERRSTR2, ', plate =', 0) CALL STR_ADDI (ERRSTR2, IPLATE, 1) CALL AUTO_WRITEINT_ERR (IUN_LOG, 0, ERRSTR, ERRSTR2, NEXT) IERR = 1 RETURN END IF IF (IPLATE.LT.1.OR.IPLATE.GT.NPLATES) THEN ERRSTR = 'Current plate number is invalid' ERRSTR2 = 'Pack =' CALL STR_ADDI (ERRSTR2, IPACK, 1) CALL STR_ADDS (ERRSTR2, ', plate =', 0) CALL STR_ADDI (ERRSTR2, IPLATE, 1) CALL AUTO_WRITEINT_ERR (IUN_LOG, 0, ERRSTR, ERRSTR2, NEXT) IERR = 1 RETURN END IF C C====== Get control parameter defaults C INT_TEMPL = INT_TEMPL_DF INT_FTYP = INT_FTYP_DF SCALE_INT = SCAL_INT_DF C C====== Interpret command string C DO 10 I = 1, 5 INP(I) = 0 10 CONTINUE IPKALL = 0 NKEYS = 5 SEP(2:2) = CHAR(9) IL = 0 100 I = NXTTOK (OPTSTR, SEP, IL, M1, M2) IF (I.EQ.-1) GO TO 200 IF (I.EQ.0) GO TO 100 NAME = OPTSTR(M1:M2) CALL CCPUPC (NAME) CALL GETOPT (KEYS, NKEYS, NAME, IKEY, KERR) IF (KERR.NE.0) THEN IF (KERR.EQ.1) ERRSTR = 'Ambiguous option' IF (KERR.EQ.2) ERRSTR = 'Invalid option' ERRSTR2 = 'Option string:' CALL STR_ADDS (ERRSTR2, NAME, 1) CALL AUTO_WRITEINT_ERR (IUN_LOG, 0, ERRSTR, ERRSTR2, NEXT) IERR = 1 RETURN END IF IF (INP(IKEY).EQ.1) THEN ERRSTR = 'Duplicate option' ERRSTR2 = 'Option string:' CALL STR_ADDS (ERRSTR2, NAME, 1) CALL AUTO_WRITEINT_ERR (IUN_LOG, 0, ERRSTR, ERRSTR2, NEXT) IERR = 1 RETURN END IF IF (IKEY.LE.2) THEN IF (IPKALL.NE.0) THEN ERRSTR = 'Inconsistent option' ERRSTR2 = 'Option string:' CALL STR_ADDS (ERRSTR2, NAME, 1) CALL AUTO_WRITEINT_ERR (IUN_LOG, 0, ERRSTR, ERRSTR2, NEXT) IERR = 1 RETURN ELSE INP(IKEY) = 1 IPKALL = IKEY END IF ELSE INP(IKEY) = 1 I = NXTTOK (OPTSTR, SEP, IL, M1, M2) IF (I.LE.0) THEN ERRSTR = 'Option' CALL STR_ADDS (ERRSTR, NAME, 1) CALL STR_ADDS (ERRSTR, 'not followed by a value', 1) CALL AUTO_WRITEINT_ERR (IUN_LOG, 0, ERRSTR, ERRSTR2, NEXT) IERR = 1 RETURN END IF II = LDM_INTFP (OPTSTR(M1:M2), FP, IV, ND) IF (IKEY.EQ.3) THEN STR = OPTSTR(M1:M2) CALL CCPUPC(STR) IF (STR.NE.'MTZ'.AND.STR.NE.'GE') GO TO 150 INT_FTYP = STR INT_TYPE = 1 CALL CCPUPC (INT_FTYP) IF (INT_FTYP.EQ.'GE') INT_TYPE = 2 ELSE IF (IKEY.EQ.4) THEN IF (INDEX(OPTSTR(M1:M2),'#').EQ.0) GO TO 150 INT_TEMPL = OPTSTR(M1:M2) ELSE IF (IKEY.EQ.5) THEN IF (II.LE.0.OR.FP.LE.0.0) GO TO 150 SCALE_INT = FP END IF END IF GO TO 100 C C====== Invalid value C 150 ERRSTR = OPTSTR(M1:M2) CALL STR_ADDS (ERRSTR, 'is not a valid value for option', 1) CALL STR_ADDS (ERRSTR, NAME, 1) CALL AUTO_WRITEINT_ERR (IUN_LOG, 0, ERRSTR, ERRSTR2, NEXT) IERR = 1 RETURN C C====== Set pack range C 200 IF (IPKALL.EQ.0) IPKALL = IPKALL_DF IF (IPKALL.EQ.1) THEN IPK_MIN = IPACK IPK_MAX = IPACK ELSE IPK_MIN = 1 CALL LDM_GET_NUMP (IPK_MAX, IFLAG) IF (IPK_MAX.LT.1) IPK_MAX = 1 END IF CALL LDM_GET_NPLAT (NPLATES, IFLAG) C C====== Loop through required packs C====== =========================== C DO 2000 IPK = IPK_MIN, IPK_MAX ICONT = 1 IF (IPK.EQ.IPK_MAX) ICONT = 0 ANY_INT = .FALSE. DO 250 IPL = 1, NPLATES CALL INTFLAG_GET (IPK, IPL, IFLG) IF (IFLG.GT.0) ANY_INT = .TRUE. 250 CONTINUE IF (.NOT.ANY_INT) THEN IERR = 1 ERRSTR = 'No integrated intensities for pack' CALL STR_ADDI (ERRSTR, IPK, 1) ERRSTR2 = ' ' CALL AUTO_WRITEINT_ERR (IUN_LOG, ICONT, ERRSTR, + ERRSTR2, NEXT) IF (.NOT.NEXT) RETURN GO TO 2000 END IF STR = '==Writing intensities file for pack' CALL STR_ADDI (STR, IPK, 1) CALL STR_ADDS (STR, '==', 0) IF (LG_MODE.EQ.1) THEN CALL LMESSAGE (IVH_IOW, STR) ELSE IF (LG_MODE.EQ.2) THEN CALL TWRITE (STR) END IF IPACK = IPK IF (LG_MODE.EQ.1) THEN CALL SET_PAR1_VALS (0, LISTE) CALL SET_PAR2_VALS (0, LISTE) END IF CALL INT_FILNAM (INT_TEMPL, MTZ_FILE) IF (INT_TYPE.EQ.1) THEN CALL MTZ_CHK1 (MTZ_FILE, IRET) IF (IRET.EQ.1) THEN IERR = 1 ERRSTR = 'MTZ file exists and cannot be overwritten' ERRSTR2 = MTZ_FILE CALL AUTO_WRITEINT_ERR (IUN_LOG, ICONT, ERRSTR, + ERRSTR2, NEXT) IF (.NOT.NEXT) RETURN GO TO 2000 END IF IF (IRET.EQ.2.) THEN CALL LOG_MSG (IVH_IOW, + '*Warning* Existing mtz file overwritten', 1) END IF CALL MTZ_CHK2 (MTZ_FILE, IRET) IF (IRET.EQ.1) THEN IERR = 1 ERRSTR = 'Cannot open MTZ file' ERRSTR2 = MTZ_FILE CALL AUTO_WRITEINT_ERR (IUN_LOG, ICONT, ERRSTR, + ERRSTR2, NEXT) IF (.NOT.NEXT) RETURN GO TO 2000 END IF ELSE CALL INT_FILNAM (INT_TEMPL, FILNAM) CALL FILEXT (FILNAM, 'xxx', GE1_FILE, ILEN) CALL FILEXT (FILNAM(1:ILEN), 'ge1', GE1_FILE, JLEN) CALL FILEXT (FILNAM(1:ILEN), 'ge2', GE2_FILE, JLEN) ANY_PRES = .FALSE. EXISTS = CCPEXS (GE1_FILE) IF (EXISTS) ANY_PRES = .TRUE. EXISTS = CCPEXS (GE2_FILE) IF (EXISTS) ANY_PRES = .TRUE. IF (ANY_PRES) THEN CALL LOG_MSG (IVH_IOW, + '*Warning* Existing .ge1/.ge2 files overwritten', 1) END IF IFAIL = 1 CALL CCPDPN (-IUN_GE1, GE1_FILE,'UNKNOWN','DU',19,IFAIL) IF (IFAIL.LT.0) THEN IERR = 1 ERRSTR = 'Cannot open the .ge1 file' ERRSTR2 = GE1_FILE CALL AUTO_WRITEINT_ERR (IUN_LOG, ICONT, ERRSTR, + ERRSTR2, NEXT) IF (.NOT.NEXT) RETURN GO TO 2000 END IF IFAIL = 1 CALL CCPDPN (-IUN_GE2, GE2_FILE,'UNKNOWN','DU',2,IFAIL) IF (IFAIL.LT.0) THEN IERR = 1 ERRSTR = 'Cannot open the .ge2 file' ERRSTR2 = GE2_FILE CALL AUTO_WRITEINT_ERR (IUN_LOG, ICONT, ERRSTR, + ERRSTR2, NEXT) IF (.NOT.NEXT) RETURN GO TO 2000 END IF END IF CALL WRITE_INTFILE (IPK, INT_TYPE, SCALE_INT, + MTZ_FILE, GE1_FILE, GE2_FILE, KERR) IF (KERR.EQ.1) THEN IERR = 1 ERRSTR = 'Memory allocation error' ERRSTR2 = 'Could not write files' CALL AUTO_WRITEINT_ERR (IUN_LOG, ICONT, ERRSTR, + ERRSTR2, NEXT) IF (.NOT.NEXT) RETURN END IF 2000 CONTINUE RETURN C C====== Format statements C 1000 FORMAT (/,'==Automatic Intensities File Writing==') 1010 FORMAT(' ') 1020 FORMAT(A) END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C******************************* C** AUTO_WRITEINT_ERR ** C******************************* C C SUBROUTINE AUTO_WRITEINT_ERR (KUN_LOG, ICONT, ERRSTR, ERRSTR2, + NEXT) C INCLUDE 'implicit_none.finc' C C Purpose: Handle command line requested write intensities files errors C C Author: John W. Campbell, January 1996 C C Arguments: C INTEGER KUN_LOG INTEGER ICONT CHARACTER*(*) ERRSTR CHARACTER*(*) ERRSTR2 LOGICAL NEXT C C Parameters: C C KUN_LOG i (R) Unit number for log file (0 if none) C ICONT i (R) = 0 treat as error which terminates procedure C = 1 may continue with next pack if desired C =-1 interrupted C ERRSTR c (R) Error string (max 80 chars) C ERRSTR2 c (R) Subsidiary error string - may be blank (max 80 C chars) C NEXT l (W) Set by the routine. If .true. then procedure will C be continued with next pack. If .false. C then procedure will be terminated. Note: the C routine must set it to .false. ICONT is 0 or -1. C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'prog_flags.finc' INCLUDE 'file_units.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR INTEGER LENSTR C C====== LOCALS: C LOGICAL EOF CHARACTER*120 STR C LOGICAL EOF !End of file flag C CHARACTER*120 STR !Temp. string C C------------------------------------------------------------------------------- C NEXT = .FALSE. C C====== Write message to log file if required C IF (IUN_LOG.GT.0) THEN IF (ICONT.LT.0) THEN WRITE (IUN_LOG,6000) ERRSTR(1:LENSTR(ERRSTR)) ELSE WRITE (IUN_LOG,6010) ERRSTR(1:LENSTR(ERRSTR)) IF (ERRSTR2.NE.' ') WRITE (IUN_LOG,6010) + ERRSTR2(1:LENSTR(ERRSTR2)) END IF END IF C C====== Output message etc. depending on program mode C IF (LG_MODE.EQ.1) THEN IF (ICONT.LT.0) THEN CALL LMESSAGE (IVH_CMD, ERRSTR) RETURN ELSE STR = '**Error**' CALL STR_ADDS (STR, ERRSTR, 1) CALL LMESSAGE (IVH_CMD, STR) IF (ERRSTR2.NE.' ') THEN STR = '**Error**' CALL STR_ADDS (STR, ERRSTR2, 1) CALL LMESSAGE (IVH_CMD, STR) END IF IF (ICONT.EQ.0) RETURN NEXT = .FALSE. IF (ICONT.EQ.1) THEN CALL IOW_ASKQ (IVH_CMD, 'Continue with next pack', + NEXT) END IF RETURN END IF ELSE IF (LG_MODE.EQ.2) THEN IF (ICONT.LT.0) THEN CALL TWRITE (ERRSTR) RETURN ELSE STR = '**Error**' CALL STR_ADDS (STR, ERRSTR, 1) CALL TWRITE (STR) IF (ERRSTR2.NE.' ') THEN STR = '**Error**' CALL STR_ADDS (STR, ERRSTR2, 1) CALL TWRITE (STR) END IF IF (ICONT.EQ.0) RETURN NEXT = .FALSE. IF (ICONT.EQ.1) THEN CALL TASKQ ('Continue with next pack', NEXT, EOF) END IF IF (EOF) NEXT = .FALSE. RETURN END IF END IF RETURN C C====== Format statements C 6000 FORMAT (A) 6010 FORMAT ('**Error** ',A) END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** AUTOREFN_SCRN ** C************************** C C SUBROUTINE AUTOREFN_SCRN C INCLUDE 'implicit_none.finc' C C Purpose: Set up screen for displaying progress of auto-refinement C C Author: John W. Campbell, October 1994 C C Arguments: C C None C C====== Parameter statements C INCLUDE 'screen_params.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR C C====== LOCALS: C C====== Layout parameters C INTEGER IWIDTH_FRAME INTEGER IHEIGHT_FRAME INTEGER NCOLS_T INTEGER NROWS_T INTEGER NWID_G INTEGER NHGT_G INTEGER IX INTEGER IY INTEGER IX1 INTEGER IY1 INTEGER IX2 INTEGER IY2 INTEGER IX3 INTEGER IY3 INTEGER IX4 INTEGER IY4 INTEGER IW INTEGER IH INTEGER IW1 INTEGER IH1 INTEGER IW2 INTEGER IH2 INTEGER IW3 INTEGER IH3 INTEGER IW4 INTEGER IH4 INTEGER IERR INTEGER KXROOT INTEGER KYROOT INTEGER KERR REAL TH_XO REAL TH_YO CHARACTER*8 NAMES(2) C INTEGER IWIDTH_FRAME ! Width of the base frame C INTEGER IHEIGHT_FRAME ! Height of the base frame C INTEGER NCOLS_T ! No. columns needed in text table C INTEGER NROWS_T ! No. rows needed in text table C INTEGER NWID_G ! Width of graphics window C INTEGER NHGT_G ! Height of graphics window C INTEGER IX ! X position for view-object C INTEGER IY ! Y position for view-object C INTEGER IX1 ! X position for view-object C INTEGER IY1 ! Y position for view-object C INTEGER IX2 ! X position for view-object C INTEGER IY2 ! Y position for view-object C INTEGER IX3 ! X position for view-object C INTEGER IY3 ! Y position for view-object C INTEGER IX4 ! X position for view-object C INTEGER IY4 ! Y position for view-object C INTEGER IW ! Width for view-object C INTEGER IH ! Height for view-object C INTEGER IW1 ! Width for object C INTEGER IH1 ! Height for object C INTEGER IW2 ! Width for object C INTEGER IH2 ! Height for object C INTEGER IW3 ! Width for object C INTEGER IH3 ! Height for object C INTEGER IW4 ! Width for object C INTEGER IH4 ! Height for object C INTEGER IERR ! Error return flag C INTEGER KXROOT ! Root window 'x' position C INTEGER KYROOT ! Root window 'y' position C INTEGER KERR ! Error flag C REAL TH_XO ! X origin for 'thermometer' C REAL TH_YO ! Y origin for 'thermometer' C CHARACTER*8 NAMES(2) ! Dummy names for menu item C DATA NAMES/' ',' '/ C C------------------------------------------------------------------------------- C C C====== Calculate size requirements for the view objects C NCOLS_T = 50 NROWS_T = 25 NWID_G = 100 NHGT_G = 220 C C====== Get sizes of individual objects C CALL XDLF_TEXT_TABLE_GETSIZE (NCOLS_T, NROWS_T, IFONT, IW1, IH1) CALL XDLF_CONTROL_BUTTON_GETSIZE (0, IFONT, 2, 8, IW2, IH2) CALL XDLF_GRAPH_WIN_GETSIZE (NWID_G, NHGT_G, IW3, IH3) CALL XDLF_MENU_AREA_GETSIZE (1, 10, 2, 0, 0, IW4, IH4) C C====== Get layout parameters C CALL XDLF_LAYOUT_INIT (IERR) CALL XDLF_LAYOUT_SET_SINGLE (XDLSTR('tab'), 3, IW1, IH1, + 0, 0, IERR) CALL XDLF_LAYOUT_SET_SINGLE (XDLSTR('but'), 3, IW2, IH2, + 0, 0, IERR) CALL XDLF_LAYOUT_SET_SINGLE (XDLSTR('gra'), 3, IW3, IH3, + 0, 0, IERR) CALL XDLF_LAYOUT_SET_SINGLE (XDLSTR('men'), 3, IW4, IH4, + 0, 0, IERR) CALL XDLF_LAYOUT_SET_PAIR (1, 1, XDLSTR('butgra'), 6, + XDLSTR('but'), 3, XDLSTR('gra'), 3, + 0, 0, ISEP, 10, IERR) CALL XDLF_LAYOUT_SET_PAIR (1, 1, XDLSTR('butgramen'), 9, + XDLSTR('butgra'), 6, XDLSTR('men'), 3, + 0, 0, ISEP, 80, IERR) CALL XDLF_LAYOUT_SET_PAIR (0, 1, XDLSTR('all'), 3, + XDLSTR('tab'), 3, + XDLSTR('butgramen'), 9, + 0, 0, ISEP, 75, IERR) CALL XDLF_LAYOUT (XDLSTR('all'), 3, IBORDER, IBORDER, + IW, IH, IERR) C C====== Get positions C CALL XDLF_LAYOUT_GET_POSITION (XDLSTR('tab'), 3, IX1, IY1, + IW1, IH1, IERR) CALL XDLF_LAYOUT_GET_POSITION (XDLSTR('but'), 3, IX2, IY2, + IW2, IH2, IERR) CALL XDLF_LAYOUT_GET_POSITION (XDLSTR('gra'), 3, IX3, IY3, + IW3, IH3, IERR) CALL XDLF_LAYOUT_GET_POSITION (XDLSTR('men'), 3, IX4, IY4, + IW4, IH4, IERR) C C====== Create base frame C IWIDTH_FRAME = IW + 2*IBORDER IHEIGHT_FRAME = IH + 2*IBORDER CALL XDLF_VIEW_OBJECT_ROOTXY(IVH_PAR1,0,0,KXROOT,KYROOT,KERR) KYROOT = KYROOT - 30 IF (KYROOT.LT.0) KYROOT = 0 CALL XDLF_BASE_FRAME (IVH_AUTR_BASE, IWIDTH_FRAME, IHEIGHT_FRAME, + XDLSTR('Auto-refine'), 11, XDLSTR('autoref'), 7, + KXROOT, KYROOT) C C====== Create text table C CALL XDLF_TEXT_TABLE (IVH_AUTR_TAB, IVH_AUTR_BASE, IX1, IY1, + 0, 0, 0, IW1, IH1, IFONT, IERR) IF (IERR.NE.0) THEN WRITE (6,2001) STOP END IF C C====== Create 'cancel' button C CALL XDLF_CONTROL_BUTTON (IVH_CNCL_BUT, IVH_AUTR_BASE, IX2, IY2, + 0, 1, 1, IFONT, 2, + XDLSTR('CANCEL'), 6, 8, + XDLSTR(' '), 1, 1, 1, IW2, IH2, IERR) IF (IERR.NE.0) THEN WRITE (6,2002) STOP END IF C C====== Create graph window C CALL XDLF_GRAPH_WIN (IVH_AUTR_GRA, IVH_AUTR_BASE, IX3, IY3, + 0, 0, NWID_G, NHGT_G, IW3, IH3, 0, 0, IERR) IF (IERR.NE.0) THEN WRITE (6,2003) STOP END IF C C====== Create menu area C CALL XDLF_MENU_AREA (IVH_AUTR_MEN, IVH_AUTR_BASE, IX4, IY4, + 0, 1, 8, IFONT, 0, 0, IW4, IH4, IERR) IF (IERR.NE.0) THEN WRITE (6,2004) STOP END IF C C====== Draw 'thermomter' on graph window C CALL XDLF_GRAPH_WIN_MAP (IVH_AUTR_GRA, 0.0, FLOAT(NWID_G), + 0.0, FLOAT(NHGT_G), 0.0, 1.0, 0.0, 1.0, + 0, IERR) TH_XO = 50.0 TH_YO = 50.0 CALL XDLF_GRAPH_WIN_STYLE (IVH_AUTR_GRA, -1, 2, -1, IERR) CALL XDLF_GRAPH_WIN_LINE (IVH_AUTR_GRA, TH_XO-3.5, TH_YO-10.0, + TH_XO-3.5, TH_YO+155.0, + IERR) CALL XDLF_GRAPH_WIN_LINE (IVH_AUTR_GRA, TH_XO+4.0, TH_YO-10.0, + TH_XO+4.0, TH_YO+155.0, + IERR) CALL XDLF_GRAPH_WIN_ARC (IVH_AUTR_GRA, TH_XO, TH_YO+155.0, + 3.5, 3.5, 0.0, 180.0, 0, IERR) CALL XDLF_GRAPH_WIN_LINE (IVH_AUTR_GRA, TH_XO-20.0, TH_YO+25.0, + TH_XO+20.0, TH_YO+25.0, + IERR) CALL XDLF_GRAPH_WIN_STYLE (IVH_AUTR_GRA, 0, 1, 2, IERR) CALL XDLF_GRAPH_WIN_LINE (IVH_AUTR_GRA, TH_XO-20.0, TH_YO, + TH_XO+20.0, TH_YO, + IERR) CALL XDLF_GRAPH_WIN_XTEXT (IVH_AUTR_GRA, TH_XO+25.0, TH_YO-5.0, + XDLSTR('0.00'), 4, 0, IERR) CALL XDLF_GRAPH_WIN_LINE (IVH_AUTR_GRA, TH_XO-20.0, TH_YO+50.0, + TH_XO+20.0, TH_YO+50.0, + IERR) CALL XDLF_GRAPH_WIN_XTEXT (IVH_AUTR_GRA, TH_XO+25.0, TH_YO+20.0, + XDLSTR('0.05'), 4, 0, IERR) CALL XDLF_GRAPH_WIN_XTEXT (IVH_AUTR_GRA, TH_XO+25.0, TH_YO+45.0, + XDLSTR('0.10'), 4, 0, IERR) CALL XDLF_GRAPH_WIN_LINE (IVH_AUTR_GRA, TH_XO-20.0, TH_YO+75.0, + TH_XO+20.0, TH_YO+75.0, + IERR) CALL XDLF_GRAPH_WIN_XTEXT (IVH_AUTR_GRA, TH_XO+25.0, TH_YO+70.0, + XDLSTR('0.15'), 4, 0, IERR) CALL XDLF_GRAPH_WIN_LINE (IVH_AUTR_GRA, TH_XO-20.0, TH_YO+100.0, + TH_XO+20.0, TH_YO+100.0, + IERR) CALL XDLF_GRAPH_WIN_XTEXT (IVH_AUTR_GRA, TH_XO+25.0, TH_YO+95.0, + XDLSTR('0.20'), 4, 0, IERR) CALL XDLF_GRAPH_WIN_LINE (IVH_AUTR_GRA, TH_XO-20.0, TH_YO+125.0, + TH_XO+20.0, TH_YO+125.0, + IERR) CALL XDLF_GRAPH_WIN_XTEXT (IVH_AUTR_GRA, TH_XO+25.0, TH_YO+120.0, + XDLSTR('0.25'), 4, 0, IERR) CALL XDLF_GRAPH_WIN_LINE (IVH_AUTR_GRA, TH_XO-20.0, TH_YO+150.0, + TH_XO+20.0, TH_YO+150.0, + IERR) CALL XDLF_GRAPH_WIN_XTEXT (IVH_AUTR_GRA, TH_XO+25.0, TH_YO+145.0, + XDLSTR('0.30'), 4, 0, IERR) CALL XDLF_GRAPH_WIN_STYLE (IVH_AUTR_GRA, 2, 1, -1, IERR) CALL XDLF_GRAPH_WIN_ARC (IVH_AUTR_GRA, TH_XO, TH_YO-25.0, + 14.0, 14.0, 0.0, 360.0, 1, IERR) CALL XDLF_GRAPH_WIN_STYLE (IVH_AUTR_GRA, 0, 2, -1, IERR) CALL XDLF_GRAPH_WIN_ARC (IVH_AUTR_GRA, TH_XO, TH_YO-25.0, + 15.0, 15.0, 95.0, 350.0, 0, IERR) CALL XDLF_GRAPH_WIN_STYLE (IVH_AUTR_GRA, 2, 1, -1, IERR) CALL XDLF_GRAPH_WIN_RECTANGLE (IVH_AUTR_GRA, TH_XO-2.5, + TH_YO-15.0, TH_XO+2.5, TH_YO, + 1, IERR) CALL XDLF_GRAPH_WIN_SETID (IVH_AUTR_GRA, 2, IERR) C C====== Return C CALL XDLF_FLUSH_EVENTS (0) RETURN C C====== Format statements C 2001 FORMAT (/,'**Error code', I2, ' from xdlf_text_table**') 2002 FORMAT (/,'**Error code', I2, ' from xdlf_control_button**') 2003 FORMAT (/,'**Error code', I2, ' from xdlf_graph_win**') 2004 FORMAT (/,'**Error code', I2, ' from xdlf_menu_area**') END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** BG_CALC ** C************************** C C SUBROUTINE BG_CALC C INCLUDE 'implicit_none.finc' C C Purpose: Control background image calculations C C Author: John W. Campbell, February 1992 C C Arguments: C C None C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' INCLUDE 'image.finc' INCLUDE 'file_units.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR C C====== LOCALS: C INTEGER IERR INTEGER NPBOX INTEGER IPCNT INTEGER IOPT INTEGER NVIEW INTEGER IVHLIST(2) INTEGER IVH INTEGER ITEM INTEGER IQUIT INTEGER M_2D INTEGER M_RADX INTEGER M_RADY INTEGER IORD INTEGER ISWAP INTEGER IFLAG CHARACTER*2 VALSTR CHARACTER*25 NAMES(3) CHARACTER*25 QUITNAM C C INTEGER IERR !Error return flag C INTEGER NPBOX !Box size for background searches C INTEGER NVIEW !No. of view-object for getting events C INTEGER IVHLIST(2) !List of view-object handles for getting events C INTEGER IVH !Returned view-object handle from getting events C INTEGER ITEM !Menu item number C INTEGER IQUIT !Quit box selected flag C INTEGER IPCNT !Percent threshold for background points C INTEGER IOPT !Strip direction 1=x, 2=y C INTEGER M_2D !Menu item no. for: '2-D Search' C INTEGER M_RADX !Menu item no. for: 'Radial x strip' C INTEGER M_RADY !Menu item no. for: 'radial y strip' C INTEGER IORD !Axis order flag 1-8 C INTEGER ISWAP !Byte swap flag C INTEGER IFLAG !Parameter status flag C CHARACTER*2 VALSTR !Parameter value string (dummy) C CHARACTER*25 NAMES(3) !Menu item names C CHARACTER*25 QUITNAM !Quit box label DATA NAMES /'2-D Search', * 'Radial X Strip', * 'Radial Y Strip'/ DATA QUITNAM /'Return to Previous Menu'/ C C------------------------------------------------------------------------------- C C====== Get axis order flag C CALL LDM_GET_AXORD (VALSTR, IORD, ISWAP, IFLAG) C C====== Find type of background calculation required C M_2D = 1 M_RADX = 2 M_RADY = 3 CALL XDLF_MENU_AREA_SETMENU (IVH_MENU, 3, XDLSTR(NAMES), 24, * XDLSTR('Background Menu'), 15, * XDLSTR(QUITNAM), 24, 0, IERR) C C====== Set up list of view-object handles C NVIEW = 1 IVHLIST(1) = IVH_MENU C C====== Start event loop C 100 CALL XDLF_GET_EVENTS (NVIEW, IVHLIST, IVH) IF (IVH.EQ.IVH_MENU) THEN C C====== Menu item selected C CALL XDLF_MENU_AREA_GETITEM (IVH_MENU, ITEM, IQUIT) C C====== Quit selected C IF (IQUIT.EQ.1) RETURN C C====== 2-D Background Search C IF (ITEM.EQ.M_2D) THEN NPBOX = 11 CALL IOW_ASKI (IVH_IOW, * 'Box size (compressed pixels - odd)', NPBOX) IPCNT = 50 CALL IOW_ASKI (IVH_IOW, 'Percentage of background pixels', * IPCNT) CALL LMESSAGE (IVH_IOW, + '==Starting background calculation==') CALL XDLF_BG_CALC (IMG, ITYPE, NSRASTS, NFRASTS, NFRASTS, + NCMP, NPBOX, IPCNT, IMG_BG, NF_BGOFF, + IERR) IF (IERR.EQ.2) THEN CALL LMESSAGE (IVH_IOW, + '**Search box too big for image**') GO TO 100 END IF CALL XDLF_IMAGE_BACKGROUND (IVH_FILM, IMG_BG, NCMP, + NF_BGOFF, IERR) CALL LMESSAGE (IVH_IOW, + '==Background calculation complete==') C C====== Radial Strip C ELSE IF (ITEM.EQ.M_RADX.OR.ITEM.EQ.M_RADY) THEN NPBOX = 21 CALL IOW_ASKI (IVH_IOW, * 'Strip width (compressed pixels - odd)', NPBOX) IPCNT = 50 CALL IOW_ASKI (IVH_IOW, 'Percentage of background pixels', * IPCNT) IF (IORD.LT.5) THEN IOPT = 2 IF (ITEM.EQ.M_RADY) IOPT = 1 ELSE IOPT = 1 IF (ITEM.EQ.M_RADY) IOPT = 2 END IF CALL LMESSAGE (IVH_IOW, + '==Starting background calculation==') CALL XDLF_BG_STRIP(IMG,ITYPE,NSRASTS,NFRASTS,NFRASTS,NCMP, + NPBOX,50,IOPT,IBGAVE,NBG,IERR) IF (IERR.EQ.1) THEN CALL LMESSAGE (IVH_IOW, '**Insufficient memory**') GO TO 100 END IF IF (IERR.EQ.2) THEN CALL LMESSAGE (IVH_IOW, * '**Search box too big for image**') GO TO 100 END IF CALL XDLF_BG_RADIMG(ITYPE,NSRASTS/NCMP,NFRASTS/NCMP, + NF_BGOFF,IBGAVE,NBG,IMG_BG,IERR) CALL XDLF_IMAGE_BACKGROUND (IVH_FILM, IMG_BG, NCMP, + NF_BGOFF, IERR) CALL LMESSAGE (IVH_IOW, + '==Background calculation complete==') END IF END IF RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C********************* C** BG_CNCL ** C********************* C C SUBROUTINE BG_CNCL(ICANCL) C INCLUDE 'implicit_none.finc' C C Purpose: Detect cancelling of command window processing command during C 2-D background calculation C C Author: John W. Campbell, November 1994 C C C Arguments: C INTEGER ICANCL C C ICANCL (W) Return 0 to continue, 1 to cancel C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'prog_flags.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR C C====== LOCALS: C INTEGER IVHLIST(2) INTEGER IVH C INTEGER IVHLIST(2) !List of view-object handles for getting events C INTEGER IVH !Returned view-object handle from getting events C C------------------------------------------------------------------------------- C ICANCL = 0 IF (LG_MODE.NE.1) RETURN IVHLIST(1) = IVH_CNCL_BUT CALL XDLF_GET_EVENTS (-1, IVHLIST, IVH) IF (IVH.EQ.IVH_CNCL_BUT) ICANCL = 1 RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** BG_DUMMY_CNCL ** C************************** C C SUBROUTINE BG_DUMMY_CNCL (ICANCL) C INCLUDE 'implicit_none.finc' C C Purpose: Dummy cancel routine for 2-D background calculation C C Author: John W. Campbell, October 1995 C C Arguments: C INTEGER ICANCL C ICANCL (W) Return 0 to continue, 1 to cancel C C====== Parameter statements C C C====== GLOBALS: C C C====== FUNCTION TYPES: C C C====== LOCALS: C C C------------------------------------------------------------------------------- C ICANCL = 0 RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************ C** BG_PROGRESS ** C************************ C C SUBROUTINE BG_PROGRESS (IFLAG, NSTRIP, ISTRIP) C INCLUDE 'implicit_none.finc' C C Purpose: Monitor progess of 2-D background calculation routine C C Author: John W. Campbell, October 1995 C C Arguments: C INTEGER IFLAG INTEGER NSTRIP INTEGER ISTRIP C C IFLAG (R) = 0 start, =1 in progress, =2 done C NSTRIP (R) Total no. of strips of image to process C ISTRIP (R) Current strip (1 to NSTRIP) C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'prog_flags.finc' INCLUDE 'bg_progress.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR C C====== LOCALS: C INTEGER IERR C C INTEGER IERR !Error flag C C------------------------------------------------------------------------------- C IF (IFLAG.EQ.0) THEN IF (LG_MODE.EQ.1) THEN CALL XDLF_PROGRESS_BAR (IVH_BAR, IBG_PROGX, IBG_PROGY, + XDLSTR('Calculating 2-D background:'), 27, 150, NSTRIP, + 2, 6) PROG_BG_ON = .TRUE. ELSE IF (LG_MODE.EQ.2) THEN CALL TWRITE ('==Calculating 2-D background==') END IF ELSE IF (IFLAG.EQ.1) THEN IF (LG_MODE.NE.1) RETURN IF (MOD(ISTRIP,5).NE.0) RETURN CALL XDLF_PROGRESS_BAR_VALUE (IVH_BAR, ISTRIP, IERR) ELSE IF (IFLAG.EQ.2) THEN IF (LG_MODE.EQ.1) THEN CALL XDLF_DELETE_VIEW_OBJECT (IVH_BAR, IERR) PROG_BG_ON = .FALSE. ELSE IF (LG_MODE.EQ.2) THEN CALL TWRITE ('==Background calculation complete==') END IF END IF RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** CALC_CONIC ** C************************** C C SUBROUTINE CALC_CONIC (NCSPOTS, X, Y, COEFF, IERR) C INCLUDE 'implicit_none.finc' C C Purpose: Calculate conic from spot positions C C Author: John W. Campbell, February 1992 C C Arguments: C INTEGER NCSPOTS DOUBLE PRECISION X(NCSPOTS) DOUBLE PRECISION Y(NCSPOTS) DOUBLE PRECISION COEFF(5) INTEGER IERR C C NCSPOTS (R) No. of measured spot positions on conic C X() (R) Spot x positions C Y() (R) Spot y positions C COEFF() (W) Conic coefficients C IERR (W) Error flag =0 OK, =1 Singular matrix C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' C C====== GLOBALS: C INCLUDE 'conics.finc' C C====== FUNCTION TYPES: C C C====== LOCALS: C INTEGER I INTEGER J INTEGER K INTEGER NC DOUBLE PRECISION A(MAX_CONIC_SPOTS,5) DOUBLE PRECISION AT(5,MAX_CONIC_SPOTS) DOUBLE PRECISION AN(5,5) DOUBLE PRECISION AI(5,5) DOUBLE PRECISION RHS(5) DOUBLE PRECISION DET C INTEGER I !Loop variable C INTEGER J !Loop variable C INTEGER K !Loop variable C INTEGER NC !No. of conic spots C DOUBLE PRECISION A(MAX_CONIC_SPOTS,5) !Left hand side 'A' matrix C DOUBLE PRECISION AT(5,MAX_CONIC_SPOTS) !Transpose of matrix 'A' C DOUBLE PRECISION AN(5,5) !Normal matrix C DOUBLE PRECISION AI(5,5) !Inverse of normal matrix C DOUBLE PRECISION RHS(5) !Right hand side elements C DOUBLE PRECISION DET !Determinant of normal matrix C C------------------------------------------------------------------------------- C C C====== Set up matrix 'A' C NC = NCSPOTS IF (NC.GT.MAX_CONIC_SPOTS) NC = MAX_CONIC_SPOTS DO 10 I = 1, NC A(I,1) = (X(I)*X(I))/(CONIC_SCAL*CONIC_SCAL) A(I,2) = (X(I)*Y(I))/(CONIC_SCAL*CONIC_SCAL) A(I,3) = (Y(I)*Y(I))/(CONIC_SCAL*CONIC_SCAL) A(I,4) = X(I)/CONIC_SCAL A(I,5) = Y(I)/CONIC_SCAL 10 CONTINUE C C====== Get transpose of 'A' in 'AT' C DO 40 I = 1, 5 DO 30 J = 1, NC AT(I,J) = A(J,I) 30 CONTINUE 40 CONTINUE C C====== Set Normal Matrix 'AN' C DO 60 I = 1, 5 DO 55 J = 1, 5 AN(I,J) = 0.0 DO 50 K = 1, NC AN(I,J) = AN(I,J) + AT(I,K)*A(K,J) 50 CONTINUE 55 CONTINUE 60 CONTINUE C C====== Get Right Hand Side elements 'AT.g' (g=unit vector) C DO 80 I = 1,5 RHS(I) = 0.0 DO 70 K = 1, NC RHS(I) = RHS(I) + AT(I,K) 70 CONTINUE 80 CONTINUE C C====== Inverts Normal Matrix C CALL INVMAT(AN, AI, 5, 5, 0, DET, IERR) IF (IERR.EQ.1) RETURN C C====== Calculate the coefficients C DO 100 I = 1, 5 COEFF(I) = 0.0 DO 90 K = 1, 5 COEFF(I) = COEFF(I) + AI(I,K)*RHS(K) 90 CONTINUE 100 CONTINUE RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** CALC_LAUE ** C************************** C C SUBROUTINE CALC_LAUE (DISTOR) C INCLUDE 'implicit_none.finc' C C Purpose: Calculate Laue Pattern (Generate reflections, find overlaps and C find nodals as needed) C C Author: John W. Campbell, July 1991 C C Arguments: C LOGICAL DISTOR C C DISTOR (R) Distortion correct coordinates .TRUE .yes, .FALSE. no C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' C C====== GLOBALS: C INCLUDE 'film_pack.finc' INCLUDE 'view_handles.finc' C C====== FUNCTION TYPES: C C C====== LOCALS: C INTEGER IERR INTEGER NUMSPOTS INTEGER NUMREFL INTEGER NUMSING INTEGER NUMMULT INTEGER NUMSPAT INTEGER NUMCLOS CHARACTER*80 ERRSTR CHARACTER*80 STR C INTEGER IERR !Error flag C INTEGER NUMSPOTS !No. of spots generated C INTEGER NUMREFL !No. of reflections generated C INTEGER NUMSING !No. of singles C INTEGER NUMMULT !No. of multiples C INTEGER NUMSPAT !No. of spatially overlapped spots C INTEGER NUMCLOS !No. too close to measure C CHARACTER*80 ERRSTR !Error message string C CHARACTER*80 STR !Output messages string C C------------------------------------------------------------------------------- C C C====== Generate reflections and find overlaps C CALL LMESSAGE (IVH_IOW, + '==Generating reflections and finding overlaps==') CALL LRL_GEN (IPACK, IPLATE, DISTOR, 2, IERR, ERRSTR) CALL LRL_COUNTS (NUMSPOTS, NUMREFL, NUMSING, NUMMULT, NUMSPAT, + NUMCLOS) STR = 'Number of spots =' CALL STR_ADDI (STR, NUMSPOTS, 1) CALL LMESSAGE (IVH_IOW, STR) STR = 'Number of reflections =' CALL STR_ADDI (STR, NUMREFL, 1) CALL LMESSAGE (IVH_IOW, STR) STR = 'Number of singles =' CALL STR_ADDI (STR, NUMSING, 1) CALL LMESSAGE (IVH_IOW, STR) STR = 'Number of multiples =' CALL STR_ADDI (STR, NUMMULT, 1) CALL LMESSAGE (IVH_IOW, STR) STR = 'Number spatially overlapped =' CALL STR_ADDI (STR, NUMSPAT, 1) CALL LMESSAGE (IVH_IOW, STR) STR = 'Number too close to integrate =' CALL STR_ADDI (STR, NUMCLOS, 1) CALL LMESSAGE (IVH_IOW, STR) RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** CELL_CHK ** C************************** C C SUBROUTINE CELL_CHK(IOPT) C INCLUDE 'implicit_none.finc' C C Purpose: Handle saving of cell parameters during command input C C Author: John W. Campbell, October 1993 C C Arguments: C INTEGER IOPT C C IOPT (R) Flag = 0, clear cell updated flags C = 1, save any input values then reset cell to be C consistent with crystal system C C====== Parameter statements C C C====== GLOBALS: C INCLUDE 'cell_input.finc' C C====== FUNCTION TYPES: C C C====== LOCALS: C LOGICAL CLL INTEGER I INTEGER IFLAG INTEGER ND INTEGER IERR CHARACTER*2 ERRSTR C LOGICAL CLL !Cell changed flag C INTEGER I !Temp/loop variable C INTEGER IFLAG !Parameter status flag C INTEGER ND !No. of decimal places flag C INTEGER IERR !Error flag C CHARACTER*2 ERRSTR !Error string (dummy) C C------------------------------------------------------------------------------- C IF (IOPT.EQ.0) THEN DO 10 I = 1, 6 CELL_CH(I) = .FALSE. 10 CONTINUE SYST_CH = .FALSE. ELSE IF (SYST_CH) THEN CALL LDM_SET_A (CELL_INPUT(1), IERR, ERRSTR) CALL LDM_SET_B (CELL_INPUT(2), IERR, ERRSTR) CALL LDM_SET_C (CELL_INPUT(3), IERR, ERRSTR) CALL LDM_SET_ALPHA (CELL_INPUT(4), IERR, ERRSTR) CALL LDM_SET_BETA (CELL_INPUT(5), IERR, ERRSTR) CALL LDM_SET_GAMMA (CELL_INPUT(6), IERR, ERRSTR) END IF CLL = .FALSE. IF (CELL_CH(1)) THEN CALL LDM_GET_A (CELL_INPUT(1), IFLAG, ND) CLL = .TRUE. ELSE IF (CELL_CH(2)) THEN CALL LDM_GET_B (CELL_INPUT(2), IFLAG, ND) CLL = .TRUE. ELSE IF (CELL_CH(3)) THEN CALL LDM_GET_C (CELL_INPUT(3), IFLAG, ND) CLL = .TRUE. ELSE IF (CELL_CH(4)) THEN CALL LDM_GET_ALPHA (CELL_INPUT(4), IFLAG, ND) CLL = .TRUE. ELSE IF (CELL_CH(5)) THEN CALL LDM_GET_BETA (CELL_INPUT(5), IFLAG, ND) CLL = .TRUE. ELSE IF (CELL_CH(6)) THEN CALL LDM_GET_GAMMA (CELL_INPUT(6), IFLAG, ND) CLL = .TRUE. END IF IF (SYST_CH.OR.CLL) CALL RESET_CELL END IF RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C**************************** C** CHECK_INTEGRATED ** C**************************** C C SUBROUTINE CHECK_INTEGRATED (ICNTXT, ICMD, IRET) C INCLUDE 'implicit_none.finc' C C Purpose: Check whether data integrated and whether written to file C and give appropriate warnings etc. Allow option to continue C or not (unless in batch mode) C C Author: John W. Campbell, January 1996 C C Arguments: C INTEGER ICNTXT INTEGER ICMD INTEGER IRET C ICNTXT (R) Context of call flag =1 end process request C =2 quit program request C =3 reset program defaults request C =4 read parameters file request C =5 enter process C ICMD (R) Input is from command window flag =1 yes, =0 no C IRET (W) Return flag =0 no integrated data present C =1 integrated data present but continue anyway C =2 integrated data present or not all written C - do not coninue with current option C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' INCLUDE 'screen_params.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'file_units.finc' INCLUDE 'prog_flags.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR INTEGER LENSTR C C====== LOCALS: C LOGICAL ANY_UNW LOGICAL ANY_INT LOGICAL OK_CONT LOGICAL EOF INTEGER NUMP INTEGER NPLATES INTEGER IFLAG INTEGER IPK INTEGER IPL INTEGER IFLG INTEGER IXROOT INTEGER IYROOT INTEGER IBUTTON CHARACTER*80 STR C LOGICAL ANY_UNW !Any unwritten intensities flag C LOGICAL ANY_INT !Any integrated intensities present flag C LOGICAL OK_CONT !OK to continue with requested option C LOGICAL EOF !End of file on terminal input C INTEGER NUMP !No. of packs C INTEGER NPLATES !No. of plates/pack C INTEGER IFLAG !Parameter status flag C INTEGER IPK !Loop counter for packs C INTEGER IPL !Loop counter for plates C INTEGER IFLG !Intensities status flag C INTEGER IXROOT !Root window 'x' position for popup notice C INTEGER IYROOT !Root window 'y' position for popup notice C INTEGER IBUTTON !Button from popup notice C CHARACTER*80 STR !Message string C C------------------------------------------------------------------------------- C IRET = 0 CALL LDM_GET_NUMP (NUMP, IFLAG) IF (NUMP.EQ.0) RETURN CALL LDM_GET_NPLAT (NPLATES, IFLAG) ANY_UNW = .FALSE. ANY_INT = .FALSE. DO 20 IPK = 1, NUMP DO 10 IPL = 1, NPLATES CALL INTFLAG_GET (IPK, IPL, IFLG) IF (IFLG.GT.0) ANY_INT = .TRUE. IF (IFLG.EQ.1) ANY_UNW = .TRUE. 10 CONTINUE 20 CONTINUE IF (.NOT.ANY_INT) RETURN IRET = 1 IF (ANY_UNW.AND.ICNTXT.LT.5) THEN IF (ICNTXT.EQ.1) THEN STR = 'Exit from process mode anyway' ELSE IF (ICNTXT.EQ.2) THEN STR = 'Quit program anyway' ELSE IF (ICNTXT.EQ.3) THEN STR = 'Reset program defaults anyway' ELSE IF (ICNTXT.EQ.4) THEN STR = 'Read new parameters file anyway' END IF IF (LG_MODE.EQ.1) THEN IF (ICMD.EQ.1) THEN CALL NOTICE_POSN(3, IXROOT, IYROOT) ELSE CALL NOTICE_POSN(0, IXROOT, IYROOT) END IF CALL STR_ADDS (STR,'?',0) CALL XDLF_POPUP_NOTICE (IXROOT, IYROOT, + XDLSTR('*Not all integrated intensities written to file*'), + 48, + XDLSTR(STR), LENSTR(STR), + XDLSTR('Yes'), 3, + XDLSTR('No'), 2, + IFONT, 1, IBUTTON) IF (IBUTTON.EQ.1) THEN IRET = 1 ELSE IF (IBUTTON.EQ.2) THEN IRET = 2 END IF ELSE IF (LG_MODE.EQ.2) THEN CALL TWRITE ( + '*Warning* Not all intensities written to file') OK_CONT = .FALSE. CALL TASKQ(STR,OK_CONT,EOF) IF (OK_CONT.OR.EOF) THEN IRET = 1 ELSE IRET = 2 END IF END IF END IF IF (IRET.EQ.2) RETURN IF (ICNTXT.EQ.1) THEN IF (ANY_UNW.AND.IUN_LOG.GT.0) WRITE (IUN_LOG,6000) RETURN ELSE IF (ICNTXT.EQ.2) THEN IF (ANY_UNW.AND.IUN_LOG.GT.0) WRITE (IUN_LOG,6010) RETURN ELSE IF (ICNTXT.EQ.3.OR.ICNTXT.EQ.4) THEN IF (LG_MODE.EQ.1) THEN IF (ICMD.EQ.1) THEN CALL NOTICE_POSN(3, IXROOT, IYROOT) ELSE CALL NOTICE_POSN(0, IXROOT, IYROOT) END IF CALL XDLF_POPUP_NOTICE (IXROOT, IYROOT, + XDLSTR('**All current intensities will be cleared**'), + 43, + XDLSTR('Continue with request?'), 22, + XDLSTR('Yes'), 3, + XDLSTR('No'), 2, + IFONT, 1, IBUTTON) IF (IBUTTON.EQ.1) THEN IRET = 1 ELSE IF (IBUTTON.EQ.2) THEN IRET = 2 END IF ELSE IF (LG_MODE.EQ.2) THEN CALL TWRITE ( + '**All current intensities will be cleared**') OK_CONT = .FALSE. CALL TASKQ('Continue with request',OK_CONT,EOF) IF (OK_CONT.OR.EOF) THEN IRET = 1 ELSE IRET = 2 END IF END IF IF (IRET.EQ.2) RETURN IF (ANY_UNW.AND.IUN_LOG.GT.0) WRITE (IUN_LOG,6020) IF (IUN_LOG.GT.0) WRITE (IUN_LOG,6030) ELSE IF (ICNTXT.EQ.5) THEN IF (LG_MODE.EQ.1) THEN IF (ICMD.EQ.1) THEN CALL NOTICE_POSN(3, IXROOT, IYROOT) ELSE CALL NOTICE_POSN(0, IXROOT, IYROOT) END IF CALL XDLF_POPUP_NOTICE (IXROOT, IYROOT, + XDLSTR('*Intensities present*'), 21, + XDLSTR('Keep intensities?'), 17, + XDLSTR('Yes'), 3, + XDLSTR('No'), 2, + IFONT, 1, IBUTTON) IF (IBUTTON.EQ.2) THEN CALL INIT_LIRL IF (IUN_LOG.GT.0) WRITE(IUN_LOG, 6030) END IF ELSE IF (LG_MODE.EQ.2) THEN CALL TWRITE ( + '*Intensities present*') OK_CONT = .TRUE. CALL TASKQ('Keep intensities',OK_CONT,EOF) IF (.NOT.OK_CONT.AND..NOT.EOF) THEN CALL INIT_LIRL IF (IUN_LOG.GT.0) WRITE(IUN_LOG, 6030) END IF RETURN END IF END IF RETURN C C====== Format statements C 6000 FORMAT(/, + '*Warning* Exiting process mode with unwritten intensities') 6010 FORMAT(/, + '*Warning* Quitting program with unwritten intensities') 6020 FORMAT(/, + '*Warning* Unwritten intensities deleted') 6030 FORMAT(/, + '*Warning* Current intensities cleared') END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** CHK_OPN ** C************************** C C SUBROUTINE CHK_OPN (IQUIT) C INCLUDE 'implicit_none.finc' C C Purpose: Check that current plate file is open (open if not) and allow C for correction of file name if needed (in an interactive mode) C C Author: John W. Campbell, January 1992 C C Arguments: C INTEGER IQUIT C C IQUIT (W) Return flag =0 OK, >0 file cannot be opened C =1 missing file declared C =2 file name input abandoned C =3 cannot handle requested file type C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'prog_flags.finc' INCLUDE 'ip2_entries.finc' INCLUDE 'file_units.finc' INCLUDE 'film_pack.finc' C C====== FUNCTION TYPES: C LOGICAL CCPEXS INTEGER XDLSTR INTEGER LENSTR C C====== LOCALS: C LOGICAL EXISTS LOGICAL TRY_AGAIN LOGICAL EOF INTEGER IPOSL INTEGER IFLAG INTEGER IERR INTEGER KFLAG INTEGER IFTYPE INTEGER LISTE(2) CHARACTER*2 VALSTR CHARACTER*2 ERRSTR CHARACTER*26 UC CHARACTER*120 STR CHARACTER*(MAXFLEN) FILNAM C LOGICAL EXISTS !File exists flag C LOGICAL TRY_AGAIN !Try again for filename input flag C LOGICAL EOF !End of file input C INTEGER IPOSL !Position of film letter in file name C INTEGER IFLAG !Flag return from GET_FILNAM C INTEGER IERR !Error flag C INTEGER KFLAG !Parameter status flag C INTEGER IFTYPE !Image file type flag C INTEGER LISTE(2) !Parameter value changed flags C CHARACTER*2 ERRSTR !Error string (dummy) C CHARACTER*2 VALSTR !Parameter value string (dummy) C CHARACTER*26 UC !Upper case letters C CHARACTER*80 STR !Message & temp string C CHARACTER*(MAXFLEN) FILNAM !File name string C DATA UC/'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/ C C------------------------------------------------------------------------------- C IQUIT = 0 IF (IPACK.EQ.IPACK_OPN.AND.IPLATE.EQ.IPLATE_OPN + .AND.FILM_OPEN) RETURN CALL LDM_GET_IMDAT (VALSTR, IFTYPE, KFLAG) IF (IFTYPE.LT.1.OR.IFTYPE.GT.4) THEN CALL LOG_MSG(IVH_IOW, + '**Error** Cannot handle requested image data type',1) IF (LG_MODE.EQ.3) STOP IQUIT = 3 RETURN END IF IF (FILM_OPEN) THEN IF (IFTYPE.EQ.1) THEN CALL XDLF_CLOSE_FILM_FILE (IFD, IERR) ELSE IF (IFTYPE.EQ.2.OR.IFTYPE.EQ.3.OR.IFTYPE.EQ.4) THEN CALL XDLF_CLOSE_I2 (IFD, IERR) END IF FILM_OPEN = .FALSE. FILM_READ = .FALSE. IPACK_OPN = 0 IPLATE_OPN = 0 END IF CALL LDM_FILENAME (IPACK, IPLATE, FILNAM) IF (FILNAM.EQ.' ') GO TO 120 STR = FILNAM CALL CCPUPC (STR) IF (STR.EQ.'MISSING') THEN IQUIT = 1 RETURN END IF IF (IFTYPE.EQ.1) THEN CALL XDLF_OPEN_FILM_FILE (XDLSTR(FILNAM),LENSTR(FILNAM), + IFD, IERR) ELSE IF (IFTYPE.EQ.2.OR.IFTYPE.EQ.3.OR.IFTYPE.EQ.4) THEN CALL XDLF_OPEN_I2(XDLSTR(FILNAM),LENSTR(FILNAM), + IFD, IERR) END IF IF (IERR.EQ.0) THEN FILM_OPEN = .TRUE. IPACK_OPN = IPACK IPLATE_OPN = IPLATE RETURN END IF STR = '**Error** Cannot open file:' CALL STR_ADDS(STR,FILNAM,1) CALL LOG_MSG(IVH_IOW,STR,1) IF (LG_MODE.EQ.3) STOP 100 TRY_AGAIN = .TRUE. IF (LG_MODE.EQ.1) THEN CALL IOW_ASKQ(IVH_IOW,'Input a new file name',TRY_AGAIN) ELSE IF (LG_MODE.EQ.2) THEN CALL TASKQ('Input a new file name',TRY_AGAIN,EOF) IF (EOF) THEN IQUIT = 2 RETURN END IF END IF IF (.NOT.TRY_AGAIN) THEN IQUIT = 2 RETURN END IF 120 STR = 'File name for plate' CALL STR_ADDI(STR,IPLATE,1) IF (IPLATE.LE.26) THEN CALL STR_ADDS(STR,'(',1) CALL STR_ADDS(STR,UC(IPLATE:IPLATE),0) CALL STR_ADDS(STR,')',0) END IF CALL STR_ADDS(STR,': ',0) IF (LG_MODE.EQ.1) THEN CALL LPROMPT(IVH_IOW, STR) ELSE IF (LG_MODE.EQ.2) THEN CALL TPROMP (STR) END IF CALL GET_FILNAM(IPLATE, FILNAM, IPOSL, IFLAG) IF (IFLAG.EQ.-2) THEN CALL LDM_SET_FNAME (IPACK, IPLATE, 'missing', IERR, ERRSTR) IF (LG_MODE.EQ.1) THEN LISTE(1) = IP_FNAM CALL SET_PAR2_VALS (1, LISTE) END IF IQUIT = 1 RETURN END IF IF (IFLAG.LT.0) GO TO 100 EXISTS = CCPEXS (FILNAM) IF (.NOT.EXISTS) THEN IF (LG_MODE.EQ.1) THEN CALL LMESSAGE (IVH_IOW, '**Error** File not found') ELSE IF (LG_MODE.EQ.2) THEN CALL TWRITE ('**Error** File not found') END IF GO TO 100 END IF IF (IFTYPE.EQ.1) THEN CALL XDLF_OPEN_FILM_FILE (XDLSTR(FILNAM),LENSTR(FILNAM), + IFD, IERR) IF (IERR.EQ.1) THEN IF (LG_MODE.EQ.1) THEN CALL LMESSAGE (IVH_IOW, + '**Error** Error in opening file') ELSE IF (LG_MODE.EQ.2) THEN CALL TWRITE ('**Error** Error in opening file') END IF GO TO 100 END IF ELSE IF (IFTYPE.EQ.2.OR.IFTYPE.EQ.3.OR.IFTYPE.EQ.4) THEN CALL XDLF_OPEN_I2(XDLSTR(FILNAM),LENSTR(FILNAM), + IFD, IERR) IF (IERR.EQ.1) THEN IF (LG_MODE.EQ.1) THEN CALL LMESSAGE (IVH_IOW, + '**Error** Error in opening file') ELSE IF (LG_MODE.EQ.2) THEN CALL TWRITE ('**Error** Error in opening file') END IF GO TO 100 END IF END IF CALL LDM_SET_FNAME (IPACK, IPLATE, FILNAM, IERR, ERRSTR) IF (LG_MODE.EQ.1) THEN LISTE(1) = IP_FNAM CALL SET_PAR2_VALS (1,LISTE) END IF FILM_OPEN = .TRUE. IPACK_OPN = IPACK IPLATE_OPN = IPLATE RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** CHK_REFINE ** C************************** C C SUBROUTINE CHK_REFINE (IQUIT) C INCLUDE 'implicit_none.finc' C C Purpose: Check that current plate is appropriate for refinement C C Author: John W. Campbell, May 1993 C C Arguments: C INTEGER IQUIT C C IQUIT (W) Flag =0 OK, continue with refinement C =1 do not continue with this refinement C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' INCLUDE 'screen_params.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'film_pack.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR C C====== LOCALS: C LOGICAL OTHER_REFINED INTEGER I INTEGER KEYPLATE INTEGER IERR INTEGER IFLAG INTEGER IXROOT INTEGER IYROOT INTEGER IRFL INTEGER IBUTTON INTEGER NPLATES CHARACTER*2 ERRSTR C LOGICAL OTHER_REFINED !Plates other than the key plate refined flag C INTEGER I !Temp/loop variable C INTEGER KEYPLATE !Key plate C INTEGER IERR !Error flag C INTEGER IFLAG !Parameter status flag C INTEGER IXROOT !Root window x position for warning notice C INTEGER IYROOT !Root window y position for warning notice C INTEGER IRFL !Plate refined 0 = no, >0 = yes C INTEGER IBUTTON !Notice returned button no. C INTEGER NPLATES !No. plates in a pack C CHARACTER*2 ERRSTR !Error string (dummy) C C------------------------------------------------------------------------------- C IQUIT = 0 C C====== Get key plate for current pack C CALL LDM_GET_KEYP (IPACK, KEYPLATE, IFLAG, IERR, ERRSTR) C C====== Check refinement status of other plates C IF (IPLATE.NE.KEYPLATE) THEN CALL LDM_GET_RFL(IPACK, KEYPLATE, IRFL, IFLAG, IERR, ERRSTR) IF (IRFL.EQ.0) THEN CALL NOTICE_POSN(1, IXROOT, IYROOT) CALL XDLF_POPUP_NOTICE (IXROOT, IYROOT, + XDLSTR('**Key plate not yet refined**'), 29, + XDLSTR('Continue in spite of this?'), 26, + XDLSTR('Yes'), 3, + XDLSTR('No'), 2, + IFONT, 1, IBUTTON) IF (IBUTTON.EQ.2) THEN IQUIT = 1 RETURN END IF END IF ELSE OTHER_REFINED = .FALSE. CALL LDM_GET_NPLAT (NPLATES, IFLAG) IF (NPLATES.LT.2) RETURN DO 100 I = 1, NPLATES IF (I.EQ.KEYPLATE) GO TO 100 CALL LDM_GET_RFL(IPACK, I, IRFL, IFLAG, IERR, ERRSTR) IF (IRFL.GT.0) OTHER_REFINED = .TRUE. 100 CONTINUE IF (OTHER_REFINED) THEN CALL NOTICE_POSN(1, IXROOT, IYROOT) CALL XDLF_POPUP_NOTICE (IXROOT, IYROOT, + XDLSTR( + '**Other plates will need to be re-refined**'), + 43, + XDLSTR('Continue to refine key plate?'), 29, + XDLSTR('Yes'), 3, + XDLSTR('No'), 2, + IFONT, 1, IBUTTON) IF (IBUTTON.EQ.2) THEN IQUIT = 1 RETURN END IF END IF END IF RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C********************* C** CMD_CNCL ** C********************* C C LOGICAL FUNCTION CMD_CNCL(IDUM) C INCLUDE 'implicit_none.finc' C C Purpose: Detect cancelling of command window processing command C C Author: John W. Campbell, November 1994 C C Return: Return .false. continue processing C .true. cancel processing C C Arguments: C INTEGER IDUM C C IDUM (R) Dummy parameter C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'prog_flags.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR C C====== LOCALS: C INTEGER IVHLIST(2) INTEGER IVH C INTEGER IVHLIST(2) !List of view-object handles for getting events C INTEGER IVH !Returned view-object handle from getting events C C------------------------------------------------------------------------------- C CMD_CNCL = .FALSE. IF (LG_MODE.NE.1) RETURN IVHLIST(1) = IVH_CNCL_BUT CALL XDLF_GET_EVENTS (-1, IVHLIST, IVH) IF (IVH.EQ.IVH_CNCL_BUT) CMD_CNCL = .TRUE. RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** CMD_CNCL_BUT ** C************************** C C SUBROUTINE CMD_CNCL_BUT C INCLUDE 'implicit_none.finc' C C Purpose: Create command window cancel button C C Author: John W. Campbell, November 1994 C C Arguments: C C None C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' INCLUDE 'screen_params.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR C C====== LOCALS: C INTEGER IERR C C INTEGER IERR !Error flag C C------------------------------------------------------------------------------- C CALL XDLF_CONTROL_BUTTON (IVH_CNCL_BUT, IVH_CMD, + 360, 35, + 0, 1, 1, IFONT, 2, + XDLSTR('CANCEL'), 6, 8, + XDLSTR(' '), 1, 1, 1, 0, 0, IERR) CALL XDLF_DELAY(50) CALL XDLF_FLUSH_EVENTS(0) CALL XDLF_DELAY(50) CALL XDLF_FLUSH_EVENTS(0) RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** CMD_INPUT ** C************************** C C SUBROUTINE CMD_INPUT (STR, QUIT) C INCLUDE 'implicit_none.finc' C C Purpose: Process command window (/command line) input C C Author: John W. Campbell, September 1993 C C Arguments: C CHARACTER*(*) STR LOGICAL QUIT C C STR (R) String read from command window (/command line) C QUIT (W) Quit program flag =.true. quit, =.false. do not C C====== Parameter statements C INCLUDE 'screen_params.finc' INCLUDE 'lauegen_limits.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'ip1_entries.finc' INCLUDE 'prog_flags.finc' INCLUDE 'film_pack.finc' INCLUDE 'cell_input.finc' INCLUDE 'integ_pars.finc' INCLUDE 'auto_soft.finc' INCLUDE 'file_units.finc' C C====== FUNCTION TYPES: C LOGICAL CCPEXS EXTERNAL PAR_CHK INTEGER XDLSTR INTEGER NXTTOK INTEGER INTFP C C====== LOCALS: C LOGICAL EOF LOGICAL CONT LOGICAL EXISTS INTEGER II INTEGER IL INTEGER M1 INTEGER M2 INTEGER INDIRECT INTEGER IFLAG INTEGER KFLAG INTEGER LFLAG INTEGER IERR INTEGER KPACK INTEGER KPLATE INTEGER IVAL INTEGER ND INTEGER ITYP INTEGER LISTE(2) INTEGER I INTEGER NSPG INTEGER NSYMP INTEGER NSYM INTEGER IOP INTEGER NOPTS INTEGER NPACKS INTEGER NPLATES INTEGER NBINS INTEGER IRET INTEGER IFAIL REAL VALUE REAL SDCUT REAL THRFAC REAL EXPAND CHARACTER*1000 LINE CHARACTER*150 TMPSTR CHARACTER*20 KEYWORD CHARACTER*120 VALSTR CHARACTER*80 BADTOK CHARACTER*80 ERRSTR CHARACTER*80 ERRSTR2 CHARACTER*10 SPGNAM CHARACTER*20 CMD CHARACTER*20 CMD_OPTS(15) CHARACTER*6 INT_FTYP CHARACTER*(MAXFLEN) FILNAM CHARACTER*(MAXFLEN) PAR_FILE CHARACTER*(MAXFLEN) INT_TEMPL C LOGICAL EOF !End of file on input flag C LOGICAL CONT !Continue flag C LOGICAL EXISTS !File exists flag C INTEGER II !Return flag from NXTTOK C INTEGER IL !Character count for NXTTOK C INTEGER M1 !Start character position of token C INTEGER M2 !End character position of token C INTEGER INDIRECT !Indirection pointer for LDM_READSTR C INTEGER IFLAG !Flag from LDM_READSTR routine C INTEGER KFLAG !Flag from LDM_PARSEITEM routine C INTEGER LFLAG !Parameter status flag C INTEGER IERR !Error flag C INTEGER KPACK !Pack number/flag C INTEGER KPLATE !Plate number/flag C INTEGER IVAL !Integer parameter value C INTEGER ND !No. of decimal places flag C INTEGER ITYP !Parameter type flag C INTEGER LISTE(2) !Parameter table update flags C INTEGER I !Temp/loop variable C INTEGER NSPG !Space group number/flag C INTEGER NSYMP !No. of primitive symmetry operators C INTEGER NSYM !No. of symmetry operators C INTEGER IOP !Option number C INTEGER NOPTS !No. of options C INTEGER NPACKS !No. of packs C INTEGER NPLATES !No. of plates C INTEGER NBINS !No. of angular bins for spot size analysis C INTEGER IRET !Return code form CHECK_INTEGRATED C INTEGER IFAIL !File open error flag C REAL VALUE !Real parameter value C REAL SDCUT !Standard deviation cutoff C REAL THRFAC !Threshold factor (*background) for spots C REAL EXPAND !Expansion factor: ave obs. -> proposed C CHARACTER*1000 LINE !Logical line buffer C CHARACTER*150 TMPSTR !Temporary string C CHARACTER*20 KEYWORD !LDM parameter name string C CHARACTER*120 VALSTR !Parameter value string C CHARACTER*80 BADTOK !Bad token string C CHARACTER*80 ERRSTR !Error message string C CHARACTER*80 ERRSTR2 !Error message string C CHARACTER*10 SPGNAM !Space group name C CHARACTER*20 CMD !Command C CHARACTER*20 CMD_OPTS(15) !Command options C CHARACTER*6 INT_FTYP !Intensities o/p file type code C CHARACTER*(MAXFLEN) FILNAM !Temp file name C CHARACTER*(MAXFLEN) PAR_FILE !Parameter (.ldm) file name C CHARACTER*(MAXFLEN) INT_TEMPL !Intensities file name template flag DATA CMD_OPTS /'QUIT', + 'PROCESS', + 'END', + 'DEFAULTS', + 'PACK', + 'PLATE', + 'LG_SPOTSIZE', + 'LG_REFINE', + 'LG_DMIN', + 'LG_LMIN', + 'LG_INTEGRATE', + 'LG_WRITEINT', + 'LG_CLEARINT', + 'LG_READLDM', + 'LG_WRITELDM'/ C C------------------------------------------------------------------------------- C QUIT = .FALSE. IF (STR.EQ.' ') RETURN NOPTS = 15 LINE = STR INDIRECT = 0 C C====== Get next logical line C 100 CALL LDM_READSTR (LINE, 10, INDIRECT, IFLAG, IERR) IF (IERR.GT.0) THEN IF (IERR.EQ.2) THEN CALL CMD_MSG (IVH_CMD, + '**Error** Error opening an indirect file') ELSE IF (IERR.EQ.3) THEN CALL CMD_MSG (IVH_CMD, + '**Error** Too many indirect files') ELSE TMPSTR = '**Error** LDM_READSTR error =' CALL STR_ADDI (TMPSTR, IERR, 1) CALL CMD_MSG (IVH_CMD, TMPSTR) END IF RETURN END IF IF (IFLAG.EQ.-1) RETURN CALL CELL_CHK(0) CALL LDM_CHK_PARSE (LINE, PAR_CHK, KFLAG, BADTOK, ERRSTR) CALL CELL_CHK(1) IF (KFLAG.EQ.0) THEN IF (LG_MODE.EQ.1) THEN CALL SET_PAR1_VALS (0, LISTE) CALL SET_PAR2_VALS (0, LISTE) END IF GO TO 600 END IF IF (KFLAG.LT.0) THEN CALL CMD_MSG (IVH_CMD, '**Error** LDM parsing error') TMPSTR = 'Bad token:' CALL STR_ADDS (TMPSTR, BADTOK,1) CALL CMD_MSG (IVH_CMD, TMPSTR) TMPSTR = 'Error message:' CALL STR_ADDS (TMPSTR, ERRSTR,1) CALL CMD_MSG (IVH_CMD, TMPSTR) GO TO 600 END IF C C====== Program command C IL = 0 II = NXTTOK (LINE, ' ,', IL, M1, M2) IF (II.LE.0) GO TO 600 IF (LINE(M1:M1).EQ.'?') THEN C C====== LDM parameter value requested C IL = M1 II = NXTTOK (LINE, ' ,', IL, M1, M2) IF (II.LE.0) GO TO 600 CALL LDM_PARSEITEM (LINE(M1:M2), KEYWORD, KPACK, KPLATE, + ITYP, IERR) IF (IERR.NE.0) THEN IF (IERR.EQ.1) THEN CALL CMD_MSG (IVH_CMD, + '**Error** Invalid LDM parameter name') ELSE IF (IERR.EQ.-1) THEN CALL CMD_MSG (IVH_CMD, + '**Error** Not a pack specific parameter') ELSE IF (IERR.EQ.-2) THEN CALL CMD_MSG (IVH_CMD, + '**Error** Not a plate specific parameter') ELSE IF (IERR.EQ.-3) THEN CALL CMD_MSG (IVH_CMD, + '**Error** Invalid pack/plate syntax') END IF GO TO 600 END IF IF (KEYWORD.EQ.'SYMMETRY') THEN CALL LDM_GET_SPGRP (NSPG, SPGNAM, NSYMP, NSYM) IF (NSYM.EQ.0) THEN CALL CMD_MSG (IVH_CMD, 'undefined') ELSE IF (NSPG.GT.0.OR.SPGNAM.NE.' ') THEN TMPSTR = 'space group number:' CALL STR_ADDI (TMPSTR, NSPG, 1) CALL CMD_MSG (IVH_CMD, TMPSTR) TMPSTR = 'space group name:' CALL STR_ADDS (TMPSTR, SPGNAM, 1) CALL CMD_MSG (IVH_CMD, TMPSTR) ELSE TMPSTR = 'Number of symmetry operators:' CALL STR_ADDI(TMPSTR, NSYM, 1) CALL CMD_MSG (IVH_CMD, TMPSTR) DO 150 I = 1, NSYM CALL LDM_SYMM_STR (I, TMPSTR) CALL CMD_MSG (IVH_CMD, TMPSTR) 150 CONTINUE END IF END IF ELSE IF (KPACK.EQ.0) KPACK = IPACK IF (KPLATE.EQ.0) KPLATE = IPLATE CALL LDM_GET (KEYWORD, KPACK, KPLATE, VALSTR, VALUE, ND, + IVAL, LFLAG, ITYP, IERR, ERRSTR) IF (IERR.NE.0) THEN IF (IERR.EQ.-1) THEN CALL CMD_MSG (IVH_CMD, + '**Error** Invalid pack number') ELSE IF (IERR.EQ.-2) THEN CALL CMD_MSG (IVH_CMD, + '**Error** Invalid pack number') END IF GO TO 600 ELSE TMPSTR = 'Parameter value:' CALL STR_ADDS (TMPSTR, VALSTR, 1) CALL CMD_MSG (IVH_CMD, TMPSTR) END IF END IF GO TO 600 ELSE C C====== Look for program command C IF (LINE(M2:M2).EQ.'>') THEN M2 = M2 - 1 END IF CMD = LINE(M1:M2) CALL CCPUPC (CMD) IOP = 0 DO 200 I = 1, NOPTS IF (CMD.EQ.CMD_OPTS(I)) THEN IOP = I GO TO 210 END IF 200 CONTINUE 210 IF (IOP.EQ.0) THEN CALL CMD_MSG (IVH_CMD, + '**Error** Unknown parameter/command') GO TO 600 END IF C C====== Quit C IF (IOP.EQ.1) THEN IF (PROCESS) THEN CALL CMD_MSG (IVH_CMD, + '**Error** Invalid in Process Mode') GO TO 600 ENDIF QUIT = .TRUE. RETURN C C====== Enter Process mode C ELSE IF (IOP.EQ.2) THEN PROCESS = .TRUE. IF (LINE(M2+1:).NE.' ') GO TO 590 C C====== Exit from Process mode C ELSE IF (IOP.EQ.3) THEN PROCESS = .FALSE. IF (LINE(M2+1:).NE.' ') GO TO 590 C C====== Reset program defaults C ELSE IF (IOP.EQ.4) THEN IF (PROCESS) THEN CALL CMD_MSG (IVH_CMD, + '**Error** Invalid in Process Mode') GO TO 600 ENDIF CALL CHECK_INTEGRATED (3, 1, IRET) IF (IRET.EQ.2) GO TO 600 CALL LOG_HEAD ('RESET PROGRAM DEFAULTS (defaults command)' + ,3) CALL LDM_RESET (' ', 0, 0, IERR, ERRSTR) CALL LDM_GET_A (CELL_INPUT(1), LFLAG, ND) CALL LDM_GET_B (CELL_INPUT(2), LFLAG, ND) CALL LDM_GET_C (CELL_INPUT(3), LFLAG, ND) CALL LDM_GET_ALPHA (CELL_INPUT(4), LFLAG, ND) CALL LDM_GET_BETA (CELL_INPUT(5), LFLAG, ND) CALL LDM_GET_GAMMA (CELL_INPUT(6), LFLAG, ND) CALL INIT_FLAGS CALL INIT_SETTINGS CALL INIT_LIRL CALL RESET_CELL IF (LG_MODE.EQ.1) THEN CALL SET_PAR1_VALS (0, LISTE) CALL SET_PAR2_VALS (0, LISTE) END IF IF (LINE(M2+1:).NE.' ') GO TO 590 C C====== Reset pack number C ELSE IF (IOP.EQ.5) THEN II = NXTTOK (LINE, ' ,', IL, M1, M2) IF (II.LE.0) THEN CALL CMD_MSG (IVH_CMD, + '**Error** Pack number must be given') GO TO 600 END IF IF (INTFP (LINE(M1:M2),VALUE,IVAL).NE.1) THEN CALL CMD_MSG (IVH_CMD, + '**Error** Invalid syntax for pack number') GO TO 600 END IF CALL LDM_GET_NUMP (NPACKS, LFLAG) IF (IVAL.LT.1.OR.(IVAL.GT.1.AND.IVAL.GT.NPACKS)) THEN CALL CMD_MSG (IVH_CMD, + '**Error** Pack number out of range') GO TO 600 END IF IF (IVAL.NE.IPACK) THEN IPACK = IVAL IF (LG_MODE.EQ.1) THEN CALL SET_PAR1_VALS (0, LISTE) CALL SET_PAR2_VALS (0, LISTE) END IF END IF IF (LINE(M2+1:).NE.' ') GO TO 590 C C====== Reset plate number C ELSE IF (IOP.EQ.6) THEN II = NXTTOK (LINE, ' ,', IL, M1, M2) IF (II.LE.0) THEN CALL CMD_MSG (IVH_CMD, + '**Error** Plate number must be given') GO TO 600 END IF IF (INTFP (LINE(M1:M2),VALUE,IVAL).NE.1) THEN CALL CMD_MSG (IVH_CMD, + '**Error** Invalid syntax for plate number') GO TO 600 END IF CALL LDM_GET_NPLAT (NPLATES, LFLAG) IF (IVAL.LT.1.OR.(IVAL.GT.1.AND.IVAL.GT.NPLATES)) THEN CALL CMD_MSG (IVH_CMD, + '**Error** Plate number out of range') GO TO 600 END IF IF (IVAL.NE.IPLATE) THEN IPLATE = IVAL IF (LG_MODE.EQ.1) THEN CALL SET_PAR1_VALS (0, LISTE) CALL SET_PAR2_VALS (0, LISTE) END IF END IF IF (LINE(M2+1:).NE.' ') GO TO 590 C C====== PROCESS OPTION - Determine spot sizes C ELSE IF (IOP.EQ.7) THEN IF (.NOT.PROCESS) THEN CALL CMD_MSG (IVH_CMD, + '**Error** Only valid in Process Mode') GO TO 600 ENDIF CALL LOG_CHANGES (1) CALL LDM_CH_RESET (1) CALL LOG_HEAD ('Determine spot sizes (lg_spotsize command)' + ,3) CALL LG_SPOTSIZE_PROMPT (LINE(M2+1:), IERR) IF (IERR.NE.0) GO TO 600 CALL SPOTSIZE_DFLTS (NBINS, SDCUT, THRFAC, EXPAND) CALL SAVE_PKPL CALL AUTO_SPOTSIZE_CTL (LINE(M2+1:), 1, NBINS, SDCUT, + THRFAC, EXPAND, IERR) CALL RESTORE_PKPL CALL LDM_CH_RESET (1) C C====== PROCESS OPTION - Auto-refinement C ELSE IF (IOP.EQ.8) THEN IF (.NOT.PROCESS) THEN CALL CMD_MSG (IVH_CMD, + '**Error** Only valid in Process Mode') GO TO 600 ENDIF CALL LOG_CHANGES (1) CALL LDM_CH_RESET (1) CALL LOG_HEAD ( + 'Auto-Refine Orientation (lg_refine command)',3) CALL LG_REFINE_PROMPT (LINE(M2+1:), IERR) IF (IERR.NE.0) GO TO 600 CALL SAVE_PKPL CALL AUTO_REFINE_CTL (3, LINE(M2+1:), 2, 1, 4, 6) CALL RESTORE_PKPL CALL LDM_CH_RESET (1) C C====== PROCESS OPTION - Improve 'dmin' C ELSE IF (IOP.EQ.9) THEN IF (.NOT.PROCESS) THEN CALL CMD_MSG (IVH_CMD, + '**Error** Only valid in Process Mode') GO TO 600 ENDIF CALL LOG_CHANGES (1) CALL LDM_CH_RESET (1) CALL LOG_HEAD ('Improve Soft Limits (lg_dmin command)',3) CALL SET_PROMIN CALL LG_SOFT_PROMPT (1, LINE(M2+1:), IERR) IF (IERR.NE.0) GO TO 600 CALL SAVE_PKPL CALL AUTO_SOFT_CTL (1, LINE(M2+1:), 1, NPROF, + PRF_ROT, PROMIN, + FRAC_AUT, SIGTEST_AUT, FRTEST_AUT, + NUMBINS_AUT, BINW_AUT, IERR) CALL RESTORE_PKPL CALL LDM_CH_RESET (1) C C====== PROCESS OPTION - Improve 'lambda-min' C ELSE IF (IOP.EQ.10) THEN IF (.NOT.PROCESS) THEN CALL CMD_MSG (IVH_CMD, + '**Error** Only valid in Process Mode') GO TO 600 ENDIF CALL LOG_CHANGES (1) CALL LDM_CH_RESET (1) CALL LOG_HEAD ('Improve Soft Limits (lg_lmin command)',3) CALL SET_PROMIN CALL LG_SOFT_PROMPT (2, LINE(M2+1:), IERR) IF (IERR.NE.0) GO TO 600 CALL SAVE_PKPL CALL AUTO_SOFT_CTL (2, LINE(M2+1:), 1, NPROF, + PRF_ROT, PROMIN, + FRAC_AUT, SIGTEST_AUT, FRTEST_AUT, + NUMBINS_AUT, BINW_AUT, IERR) CALL RESTORE_PKPL CALL LDM_CH_RESET (1) C C====== PROCESS OPTION - Integrate Spots C ELSE IF (IOP.EQ.11) THEN IF (.NOT.PROCESS) THEN CALL CMD_MSG (IVH_CMD, + '**Error** Only valid in Process Mode') GO TO 600 ENDIF CALL LOG_CHANGES (1) CALL LDM_CH_RESET (1) CALL LOG_HEAD ('Integrate Spots (lg_integrate command)',3) CALL SET_PROMIN CALL LG_INTEGRATE_PROMPT (LINE(M2+1:), IERR) IF (IERR.NE.0) GO TO 600 CALL SAVE_PKPL CALL AUTO_INTEGRATE_CTL (2, .FALSE., LINE(M2+1:), 2, + NPROF, PROMIN, PRF_ROT, + IPRF_ALL, NOVLD, IERR) CALL RESTORE_PKPL CALL LDM_CH_RESET (1) C C====== PROCESS OPTION - Write integrated intensities files C ELSE IF (IOP.EQ.12) THEN IF (.NOT.PROCESS) THEN CALL CMD_MSG (IVH_CMD, + '**Error** Only valid in Process Mode') GO TO 600 ENDIF CALL LOG_CHANGES (1) CALL LDM_CH_RESET (1) CALL LOG_HEAD ( + 'Write Intensities Files (lg_writeint command)',3) CALL SET_SCALINT CALL LG_WRITEINT_PROMPT (LINE(M2+1:), IERR) IF (IERR.NE.0) GO TO 600 CALL SAVE_PKPL CALL AUTO_WRITEINT_CTL (LINE(M2+1:), 2, ERRSTR, + INT_TEMPLATE, SCAL_INT, IERR) CALL RESTORE_PKPL CALL LDM_CH_RESET (1) C C====== PROCESS OPTION - Clear intensities from LIRL C ELSE IF (IOP.EQ.13) THEN CALL LOG_CHANGES (1) CALL LDM_CH_RESET (1) CALL LOG_HEAD ( + 'Clear Intensities (lg_clearint command)',3) CALL LG_CLEARINT_PROMPT (LINE(M2+1:), IERR) IF (IERR.NE.0) GO TO 600 CALL AUTO_CLEARINT_CTL (LINE(M2+1:), 2, IERR) CALL LDM_CH_RESET (1) C C====== PROCESS OPTION - Read LDM parameters file C ELSE IF (IOP.EQ.14) THEN IF (PROCESS) THEN CALL CMD_MSG (IVH_CMD, + '**Error** Not valid in Process Mode') GO TO 600 ENDIF CALL CHECK_INTEGRATED (4, 1, IRET) IF (IRET.EQ.2) GO TO 600 CALL LOG_HEAD ( + 'Read LDM Parameter File (lg_readldm command)',3) II = NXTTOK (LINE, ' ,', IL, M1, M2) IF (II.LE.0) THEN ERRSTR = 'No file name given' ERRSTR2 = ' ' CALL PARFIL_ERR (ERRSTR, ERRSTR2) GO TO 600 END IF IF (LINE(M1:M1).EQ.'>') THEN IF (LG_MODE.EQ.3) THEN CALL CMD_MSG (IVH_CMD, + '**Error** Prompt request invalid in batch/background mode') GO TO 600 END IF IF (LG_MODE.EQ.1) THEN CALL LPROMPT (IVH_CMD, 'File name: ') CALL LREAD (IVH_CMD, FILNAM) ELSE CALL TPROMP ('File name: ') CALL TREAD (FILNAM, EOF) IF (EOF) GO TO 600 IF (FILNAM.EQ.' ') GO TO 600 END IF ELSE FILNAM = LINE(M1:M2) END IF CALL FILEXT (FILNAM, 'ldm', PAR_FILE, I) EXISTS = CCPEXS (PAR_FILE) IF (.NOT.EXISTS) THEN ERRSTR = 'File not found' ERRSTR2 = PAR_FILE CALL PARFIL_ERR (ERRSTR, ERRSTR2) GO TO 600 END IF IFAIL = 1 CALL CCPDPN (-IUN_GEN, PAR_FILE,'READONLY','F',0,IFAIL) IF (IFAIL.LT.0) THEN ERRSTR = 'Cannot open the input .ldm file' ERRSTR2 = PAR_FILE CALL PARFIL_ERR (ERRSTR, ERRSTR2) GO TO 600 END IF CALL LOG_CHANGES (1) CALL LDM_CH_RESET (1) CALL READ_PAR_FILE (.TRUE., PAR_FILE) CALL LDM_CH_RESET (1) C C====== PROCESS OPTION - Write LDM parameters file C ELSE IF (IOP.EQ.15) THEN CALL LOG_HEAD ( + 'Write LDM Parameter File (lg_writeldm command)',3) II = NXTTOK (LINE, ' ,', IL, M1, M2) IF (II.LE.0) THEN ERRSTR = 'No file name given' ERRSTR2 = ' ' CALL PARFIL_ERR (ERRSTR, ERRSTR2) GO TO 600 END IF IF (LINE(M1:M1).EQ.'>') THEN IF (LG_MODE.EQ.3) THEN CALL CMD_MSG (IVH_CMD, + '**Error** Prompt request invalid in batch/background mode') GO TO 600 END IF IF (LG_MODE.EQ.1) THEN CALL LPROMPT (IVH_CMD, 'File name: ') CALL LREAD (IVH_CMD, FILNAM) ELSE CALL TPROMP ('File name: ') CALL TREAD (FILNAM, EOF) IF (EOF) GO TO 600 IF (FILNAM.EQ.' ') GO TO 600 END IF ELSE FILNAM = LINE(M1:M2) END IF CALL FILEXT (FILNAM, 'ldm', PAR_FILE, I) EXISTS = CCPEXS (PAR_FILE) IF (EXISTS) THEN IF (LG_MODE.EQ.1) THEN CALL LMESSAGE(IVH_CMD,'**File already exists**') CONT = .FALSE. CALL IOW_ASKQ (IVH_CMD, 'Overwrite file', CONT) ELSE IF (LG_MODE.EQ.2) THEN CALL TWRITE ('**File already exists**') CONT = .FALSE. CALL TASKQ ('Overwrite file', CONT, EOF) IF (EOF) GO TO 600 ELSE CONT = .TRUE. END IF IF (.NOT.CONT) GO TO 600 END IF IFAIL = 1 CALL CCPDPN (-IUN_GEN, PAR_FILE,'UNKNOWN','F',0,IFAIL) IF (IFAIL.LT.0) THEN ERRSTR = 'Cannot open the output .ldm file' ERRSTR2 = PAR_FILE CALL PARFIL_ERR (ERRSTR, ERRSTR2) GO TO 600 END IF CALL LOG_CHANGES (1) CALL LDM_CH_RESET (1) CALL WRITE_PARFIL (PAR_FILE) CALL LDM_CH_RESET (1) CLOSE (UNIT=IUN_GEN) END IF END IF GO TO 600 C C====== Extraneous info. found on line C 590 CALL CMD_MSG (IVH_CMD, '*Warning* Extraneous information ignored') CALL CMD_MSG (IVH_CMD, LINE(M2+1:)) C C====== Get next logical line C 600 IF (IFLAG.EQ.0) RETURN GO TO 100 END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** CMD_MSG ** C************************** C SUBROUTINE CMD_MSG (IVH_W, CHSTR) C INCLUDE 'implicit_none.finc' C C Purpose: Output a message string in response to command input C to the command window, terminal or log file C C Author: John W. Campbell, October 1993 C C Arguments: C INTEGER IVH_W CHARACTER*(*) CHSTR C C IVH_W (R) View-object handle for the io-window C CHSTR (R) The message string C C Declarations C ============ C C GLOBALS: C INCLUDE 'prog_flags.finc' INCLUDE 'file_units.finc' C C FUNCTION TYPES: C INTEGER XDLSTR C C LOCALS: C INTEGER LENS INTEGER I INTEGER IERR INTEGER NCH C INTEGER LENS !Length of the character string C INTEGER I !Loop counter C INTEGER IERR !Error return C INTEGER NCH !No. characters up to last non-blank character C C------------------------------------------------------------------------------- C C====== Find length of message string up to last non-blank C LENS = LEN (CHSTR) NCH = 1 DO 100 I = LENS, 1, -1 IF (CHSTR(I:I).NE.' ') THEN NCH = I GO TO 200 ENDIF 100 CONTINUE C C====== Output the message to io/window, terminal or log file C 200 IF (LG_MODE.EQ.1) THEN CALL XDLF_IO_WINDOW_PRINT (IVH_W, XDLSTR(CHSTR), NCH, 2, IERR) ELSE IF (LG_MODE.EQ.2) THEN CALL TWRITE (CHSTR) ELSE IF (LG_MODE.EQ.3) THEN IF (IUN_LOG.GT.0) WRITE (IUN_LOG,1001) CHSTR(1:NCH) END IF RETURN C C====== Format statements C 1001 FORMAT (' ',A) END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** CONIC_CENTRE ** C************************** C C SUBROUTINE CONIC_CENTRE C INCLUDE 'implicit_none.finc' C C Purpose: Input conic spots & calculate centre C C Author: John W. Campbell, February 1992 C C Arguments: C C None C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' INCLUDE 'screen_params.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'ip1_entries.finc' INCLUDE 'image.finc' INCLUDE 'file_units.finc' INCLUDE 'spot_data.finc' INCLUDE 'conics.finc' INCLUDE 'symbol_types.finc' INCLUDE 'meas_spots.finc' INCLUDE 'film_pack.finc' INCLUDE 'spot_box.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR INTEGER INTFP INTEGER LENSTR EXTERNAL CONIC_FN C C====== LOCALS: C LOGICAL CONICS_COMPLETE LOGICAL CEN_OK INTEGER I INTEGER J INTEGER M_CALC INTEGER M_CENT INTEGER M_REDO INTEGER NVIEW INTEGER IVHLIST(3) INTEGER IVH INTEGER IQUIT INTEGER ITEM INTEGER IERR INTEGER IXPIX INTEGER IYPIX INTEGER IXSIZ INTEGER IYSIZ INTEGER NOVER INTEGER ITHRESH INTEGER IBG INTEGER ISTYP INTEGER IOP INTEGER ITYP INTEGER IV INTEGER ITM INTEGER IP_STYP INTEGER IP_SBOX INTEGER IP_THRESH INTEGER ICONIC INTEGER IFLAG INTEGER IYN INTEGER NXRAST INTEGER NYRAST INTEGER ISPIX INTEGER IFPIX INTEGER IORD INTEGER ISWAP INTEGER ND INTEGER LISTE(2) REAL CGX REAL CGY REAL FP REAL XTEMP REAL YTEMP REAL MM_RAST_X REAL MM_RAST_Y DOUBLE PRECISION CEN(2) DOUBLE PRECISION ACC DOUBLE PRECISION FMIN DOUBLE PRECISION FVECC(MAX_CONICS) DOUBLE PRECISION W(12) CHARACTER*80 STR CHARACTER*(MAX_P3SCROLL_CHARS) PVAL CHARACTER*25 NAMES(3) CHARACTER*25 QUITNAM CHARACTER*6 SMETHOD(2) CHARACTER*6 SMETHOD_UC(2) CHARACTER*2 VALSTR CHARACTER*2 ERRSTR C LOGICAL CONICS_COMPLETE !All allowed conics input flag C LOGICAL CEN_OK !Found centre OK flag C INTEGER I !Temp/loop variable C INTEGER J !Temp/loop variable C INTEGER M_CALC !Menu item number for 'Calculate Conic' C INTEGER M_CENT !Menu item number for 'Calculate Centre' C INTEGER M_REDO !Menu item number for 'Redo Current Conic' C INTEGER NVIEW !No. of view-objects for getting events C INTEGER IVHLIST(3) !List of view-objects for getting events C INTEGER IVH !Returned view-object handle from events input C INTEGER IQUIT !Quit box selected flag =1 yes, =0 no C INTEGER ITEM !Item no. selected from the menu C INTEGER IERR !Error return flag C INTEGER IXPIX !x pixel value from film image view-object C INTEGER IYPIX !y pixel value from film image view-object C INTEGER IXSIZ !Spot box half size x C INTEGER IYSIZ !Spot box half size y C INTEGER NOVER !no. of pixels over the threshold value C INTEGER ITHRESH !Threshold value C INTEGER IBG !Background value at spot position C INTEGER ISTYP !Spot method 1=c_of_g, 2=input (cursor) C INTEGER IOP !Option from GETOPT C INTEGER ITYP !Type of number input flag (from INTFP) C INTEGER IV !Integer value returned from INTFP C INTEGER ITM !Parameter table selected item number C INTEGER IP_STYP !Parameter table 3 item: Spot method C INTEGER IP_SBOX !Parameter table 3 item: Spot box size C INTEGER IP_THRESH !Parameter table 3 item: Spot threshold C INTEGER ICONIC !Count of current conic being input C INTEGER IFLAG !Flag from refinement routine / parameter status flag C INTEGER IYN !Return flag fro yes-no notice C INTEGER NXRAST !No. x-rasters C INTEGER NYRAST !No. y-rasters C INTEGER ISPIX !Pixel position along slow axis C INTEGER IFPIX !Pixel position along fast axis C INTEGER IORD !Axis order flag 1-8 C INTEGER ISWAP !Byte swap flag C INTEGER ND !No. of decimal places flag C INTEGER LISTE(2) !Parameter updates list C INTEGER ND !No. of decimal places flag C INTEGER LISTE(2) !Parameter updates list C REAL MM_RAST_X !mm to x-rasters conversion factor C REAL MM_RAST_Y !mm to y-rastrs conversion factor C REAL CGX !x centre of gravity C REAL CGY !y centre of gravity C REAL FP !Floating point value returned from INTFP C REAL XTEMP !Temp. refined x centre position C REAL YTEMP !Temp. refined y centre position C DOUBLE PRECISION CEN(2) !Position of estimated/refined centre C DOUBLE PRECISION ACC !Accuracy parameter for Powell refinement C DOUBLE PRECISION FMIN !Refined minimum value sum of squares C DOUBLE PRECISION FVECC(MAX_CONICS) !Calculated function values C DOUBLE PRECISION W(12) !Work array for Powell refinement C CHARACTER*80 STR !Temporary string C CHARACTER*(MAX_P3SCROLL_CHARS) PVAL !Return string from parameter table 3 C CHARACTER*25 NAMES(3) !Names for the menu items C CHARACTER*25 QUITNAM !Quit box label C CHARACTER*6 SMETHOD(2) !Spot method option strings C CHARACTER*6 SMETHOD_UC(2) !Spot method option strings (upper case) C CHARACTER*2 VALSTR !paramter value string (dummy) C CHARACTER*2 ERRSTR !Error string (dummy) DATA NAMES /'Calculate Conic', + 'Calculate Centre', + 'Redo Current Conic'/ DATA QUITNAM /'Abort Centre Calculation'/ DATA SMETHOD /'c_of_g','input'/ DATA SMETHOD_UC /'C_OF_G','INPUT'/ C------------------------------------------------------------------------------- C C C====== Clear symbols from image C CALL XDLF_IMAGE_CLEAR_SYMBOLS (IVH_FILM, IERR) C C====== Initialisations C CONICS_COMPLETE = .FALSE. NUM_CONICS = 0 DO 10 I=1,MAX_CONICS NUM_CONIC_SPOTS(I) = 0 10 CONTINUE ICONIC = 1 CALL LDM_MMRAST (IPACK, IPLATE, MM_RAST_X, MM_RAST_Y) CALL LDM_GET_NXRAS (NXRAST, IFLAG) CALL LDM_GET_NYRAS (NYRAST, IFLAG) CALL LDM_GET_AXORD (VALSTR, IORD, ISWAP, IFLAG) CONIC_SCAL = MAX(NXRAST,NYRAST) CALL LDM_GET_STHR (SPOT_INPUT_THRESH, IFLAG, ND) C C====== Set up parameter table 3 C IP_STYP = 1 IP_SBOX = 3 IP_THRESH = 4 ISTYP = 1 CALL XDLF_PARAM_TABLE_SETITEM (IVH_PAR3, IP_STYP, + XDLSTR('Spot method:'), 12, + XDLSTR(SMETHOD(1)),6, 0, 0, IERR) CALL XDLF_PARAM_TABLE_SETMENU (IVH_PAR3, IP_STYP, + 2, XDLSTR(SMETHOD), 6, IERR) WRITE (STR,'(F8.2)') SPOT_INPUT_BOX CALL LJUST (STR) CALL XDLF_PARAM_TABLE_SETITEM (IVH_PAR3, IP_SBOX, + XDLSTR('Spot box (mm):'), 14, + XDLSTR(STR), LENSTR(STR), 0, 0, IERR) WRITE (STR,'(F8.1)') SPOT_INPUT_THRESH CALL LJUST (STR) CALL XDLF_PARAM_TABLE_SETITEM (IVH_PAR3, IP_THRESH, + XDLSTR('Spot threshold:'), 15, + XDLSTR(STR), LENSTR(STR), 0, 1, IERR) C C====== Set up menu C M_CALC = 1 M_CENT = 2 M_REDO = 3 CALL XDLF_MENU_AREA_SETMENU (IVH_MENU, 3, XDLSTR(NAMES), 24, + XDLSTR('Conic Centre Menu'), 17, + XDLSTR(QUITNAM), 24, 0, IERR) C C====== Set up event loop for first menu input C 50 STR = 'Input Conic' CALL STR_ADDI(STR,ICONIC,1) CALL STR_ADDS(STR,' Spot Positions',1) CALL XDLF_IMAGE_INPUT_MESSAGE (IVH_FILM, + XDLSTR(STR), 40, IERR) NVIEW = 3 IF (CONICS_COMPLETE) NVIEW = 2 IVHLIST(1) = IVH_MENU IVHLIST(2) = IVH_PAR3 IVHLIST(3) = IVH_FILM 100 CALL XDLF_GET_EVENTS (NVIEW, IVHLIST, IVH) C C====== Menu item selected C IF (IVH.EQ.IVH_MENU) THEN CALL XDLF_MENU_AREA_GETITEM (IVH_MENU, ITEM, IQUIT) C C====== Quit selected C IF (IQUIT.EQ.1) THEN CALL XDLF_PARAM_TABLE_CLEARITEMS (IVH_PAR3, IERR) RETURN END IF C C====== Calculate Conic C IF (ITEM.EQ.M_CALC) THEN IF (CONICS_COMPLETE) THEN CALL ERR_NOTICE(1,'**All Allowed Conics Completed**') GO TO 100 END IF IF (NUM_CONIC_SPOTS(ICONIC).LT.5) THEN CALL ERR_NOTICE(1,'**Minimum of 5 spots needed**') GO TO 100 END IF CALL CALC_CONIC (NUM_CONIC_SPOTS(ICONIC), + XCONIC(1,ICONIC),YCONIC(1,ICONIC), + COEFFS(1,ICONIC),IERR) IF (IERR.EQ.1) THEN CALL YESNO_NOTICE (1, + '**Singular Matrix** Retry with more spots?',IYN) IF (IYN.EQ.1) GO TO 100 CALL XDLF_IMAGE_CLEAR_SYMBOLS(IVH_FILM, IERR) NUM_CONIC_SPOTS(ICONIC) = 0 IF (NUM_CONICS.EQ.0) GO TO 100 DO 120 I=1,NUM_CONICS DO 110 J=1,NUM_CONIC_SPOTS(I) CALL XDLF_IMAGE_SYMBOL(IVH_FILM, + NINT(XCONIC(J,I)), NINT(YCONIC(J,I)), + ISYMBTYP(7),ICOLRTYP(7), 1, IERR) 110 CONTINUE 120 CONTINUE GO TO 100 END IF NUM_CONICS = NUM_CONICS + 1 IF (NUM_CONICS.EQ.MAX_CONICS) THEN CALL ERR_NOTICE (1,'*All Allowed Conics now Input*') CONICS_COMPLETE = .TRUE. GO TO 100 ELSE ICONIC = ICONIC + 1 END IF GO TO 50 C C====== Calculate Centre C ELSE IF (ITEM.EQ.M_CENT) THEN IF (.NOT.CONICS_COMPLETE + .AND.NUM_CONIC_SPOTS(ICONIC).GT.0) THEN CALL ERR_NOTICE(1,'**Last conic not yet calculated**') GO TO 100 END IF IF (NUM_CONICS.LT.3) THEN CALL ERR_NOTICE(1,'**Minimum of three conics needed**') GO TO 100 END IF CEN(1) = (NXRAST/2.0)/CONIC_SCAL CEN(2) = (NYRAST/2.0)/CONIC_SCAL ACC = 1.0D-8 CALL SSQMIN(NUM_CONICS,2,CEN,ACC,100,CONIC_FN,FMIN, + FVECC,IFLAG,W) IF (IFLAG.EQ.-1) THEN CALL ERR_NOTICE(1,'**Failure(s) finding line minima**') GO TO 100 END IF CALL XDLF_VIEW_OBJECT_RAISE (IVH_BASE, IERR) IF (IFLAG.EQ.-1) THEN CALL LMESSAGE(IVH_IOW, + '*Refinement terminated after 100 iterations*') ELSE STR = 'Refinement completed after' CALL STR_ADDI(STR,IFLAG,1) CALL STR_ADDS(STR,'iterations',1) CALL LMESSAGE(IVH_IOW,STR) ENDIF STR = 'Refined centre: x =' XTEMP = CEN(1)*CONIC_SCAL YTEMP = CEN(2)*CONIC_SCAL CALL STR_ADDF(STR,XTEMP,2,1) CALL STR_ADDS(STR,', y =',0) CALL STR_ADDF(STR,YTEMP,2,1) CALL LMESSAGE(IVH_IOW,STR) CEN_OK = .TRUE. CALL IOW_ASKQ(IVH_IOW,'Accept value for the centre', + CEN_OK) CALL XDLF_VIEW_OBJECT_RAISE (IVH_FILM, IERR) IF (CEN_OK) THEN XCEN_SPOTS = XTEMP YCEN_SPOTS = YTEMP IXCEN_SPOTS = NINT(XCEN_SPOTS) IYCEN_SPOTS = NINT(YCEN_SPOTS) CALL XDLF_PARAM_TABLE_CLEARITEMS (IVH_PAR3, IERR) RETURN END IF GO TO 50 C C====== Redo Current Conic C ELSE IF (ITEM.EQ.M_REDO) THEN IF (CONICS_COMPLETE) GO TO 100 IF (NUM_CONIC_SPOTS(ICONIC).EQ.0) GO TO 100 NUM_CONIC_SPOTS(ICONIC) = 0 CALL XDLF_IMAGE_CLEAR_SYMBOLS(IVH_FILM, IERR) IF (NUM_CONICS.EQ.0) GO TO 100 DO 220 I=1,NUM_CONICS DO 210 J=1,NUM_CONIC_SPOTS(I) CALL XDLF_IMAGE_SYMBOL(IVH_FILM, + NINT(XCONIC(J,I)), NINT(YCONIC(J,I)), + ISYMBTYP(7),ICOLRTYP(7), 1, IERR) 210 CONTINUE 220 CONTINUE GO TO 100 END IF GO TO 100 C C====== Spot position input C ELSE IF (IVH.EQ.IVH_FILM) THEN CALL XDLF_IMAGE_GETPIX (IVH_FILM, IXPIX, IYPIX, IERR) IF (ISTYP.EQ.1) THEN IXSIZ = NINT (SPOT_INPUT_BOX*MM_RAST_X) IXSIZ = IXSIZ/2 IF (IXSIZ.LT.1) IXSIZ = 1 IF (IXSIZ.GT.MAX_HALF_BOX) THEN CALL ERR_NOTICE (0,'**Spot box size too large**') GO TO 100 END IF IYSIZ = NINT (SPOT_INPUT_BOX*MM_RAST_Y) IYSIZ = IYSIZ/2 IF (IYSIZ.LT.1) IYSIZ = 1 IF (IYSIZ.GT.MAX_HALF_BOX) THEN CALL ERR_NOTICE (0,'**Spot box size too large**') GO TO 100 END IF CALL SFPIX (IXPIX,IYPIX,ISPIX,IFPIX) CALL XDLF_BG_VALIMG(ISPIX,IFPIX,IMG_BG,ITYPE,NF_BGOFF, + NCMP,IBG, IERR) ITHRESH = IBG + NINT(SPOT_INPUT_THRESH) CALL SPOT_C_OF_G (IXPIX, IYPIX, IXSIZ, IYSIZ, ISPOT_DATA, + ISWORK, ITHRESH, IMG, ITYPE, IORD, NFRASTS, + NXRAST, NYRAST, NOVER, + CGX, CGY, IERR) IF (IERR.LT.0) THEN CALL ERR_NOTICE (0,'**Error in spot_c_of_g call**') GO TO 100 ELSE IF (IERR.EQ.2) THEN CALL ERR_NOTICE (0, + '**Spot box outside range of image**') GO TO 100 ELSE IF (NOVER.EQ.0) THEN CALL ERR_NOTICE (0,'**No pixels above threshold**') GO TO 100 END IF IXPIX = NINT (CGX) IF (IXPIX.LT.1) IXPIX = 1 IF (IXPIX.GT.NXRAST) IXPIX = NXRAST IYPIX = NINT (CGY) IF (IYPIX.LT.1) IYPIX = 1 IF (IYPIX.GT.NYRAST) IYPIX = NYRAST END IF IF (NUM_CONIC_SPOTS(ICONIC).GE.MAX_CONIC_SPOTS) THEN CALL ERR_NOTICE (0, + '**Spot list full for current conic**') GO TO 100 END IF NUM_CONIC_SPOTS(ICONIC) = NUM_CONIC_SPOTS(ICONIC) + 1 J = NUM_CONIC_SPOTS(ICONIC) IF (ISTYP.EQ.1) THEN XCONIC(J,ICONIC) = CGX YCONIC(J,ICONIC) = CGY ELSE XCONIC(J,ICONIC) = IXPIX YCONIC(J,ICONIC) = IYPIX END IF C C====== Display symbol C CALL XDLF_IMAGE_SYMBOL (IVH_FILM, + NINT(XCONIC(J,ICONIC)), NINT(YCONIC(J,ICONIC)), + ISYMBTYP(7), ICOLRTYP(7), 1, IERR) GO TO 100 C C====== Parameter table input C ELSE IF (IVH.EQ.IVH_PAR3) THEN CALL XDLF_PARAM_TABLE_GETVALUE (IVH_PAR3, ITM, + XDLSTR(PVAL), MAX_P3SCROLL_CHARS, IERR) IF (ITM.EQ.IP_STYP) THEN CALL LJUST (PVAL) CALL CCPUPC (PVAL) CALL GETOPT (SMETHOD_UC, 2, PVAL, IOP, IERR) IF (IERR.EQ.1) THEN CALL XDLF_PARAM_TABLE_ERROR (IVH_PAR3, ITM, + XDLSTR('**Ambiguous selection**'), 23, IERR) GO TO 100 END IF IF (IERR.EQ.2) THEN CALL XDLF_PARAM_TABLE_ERROR (IVH_PAR3, ITM, + XDLSTR('**Invalid Method**'), 18, IERR) RETURN END IF ISTYP = IOP CALL XDLF_PARAM_TABLE_SETVALUE (IVH_PAR3, ITM, + XDLSTR(SMETHOD(ISTYP)), 6, 0, IERR) ELSE IF (ITM.EQ.IP_SBOX) THEN ITYP = INTFP (PVAL, FP, IV) IF (ITYP.EQ.0) THEN CALL XDLF_PARAM_TABLE_ERROR (IVH_PAR3, ITM, + XDLSTR('**Invalid Number Format**'), 25, IERR) GO TO 100 END IF IF (FP.LE.0) THEN CALL XDLF_PARAM_TABLE_ERROR (IVH_PAR3, ITM, + XDLSTR('**Value must be greater than zero**'), 35, IERR) GO TO 100 END IF SPOT_INPUT_BOX = FP WRITE (STR,'(F8.2)') SPOT_INPUT_BOX CALL LJUST(STR) CALL XDLF_PARAM_TABLE_SETVALUE (IVH_PAR3, ITM, + XDLSTR(STR), LENSTR(STR), 0, IERR) ELSE IF (ITM.EQ.IP_THRESH) THEN ITYP = INTFP (PVAL, FP, IV) IF (ITYP.EQ.0) THEN CALL XDLF_PARAM_TABLE_ERROR (IVH_PAR3, ITM, + XDLSTR('**Invalid Number Format**'), 25, IERR) GO TO 100 END IF IF (FP.LE.0) THEN CALL XDLF_PARAM_TABLE_ERROR (IVH_PAR3, ITM, + XDLSTR('**Value must be greater than zero**'), 35, IERR) GO TO 100 END IF SPOT_INPUT_THRESH = FP WRITE (STR,'(F8.1)') SPOT_INPUT_THRESH CALL LJUST(STR) CALL XDLF_PARAM_TABLE_SETVALUE (IVH_PAR3, ITM, + XDLSTR(STR), LENSTR(STR), 0, IERR) CALL LDM_SET_STHR (SPOT_INPUT_THRESH, IERR, ERRSTR) LISTE(1) = IP_STHR CALL SET_PAR1_VALS (1, LISTE) END IF GO TO 100 END IF GO TO 100 END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** CONIC_FN ** C************************** C C SUBROUTINE CONIC_FN (M,N,FVECC,X) C INCLUDE 'implicit_none.finc' C C Purpose: C C Author: John W. Campbell, February 1992 C C Arguments: C INTEGER M INTEGER N DOUBLE PRECISION FVECC(M) DOUBLE PRECISION X(N) C C M (R) No. of observations C N (R) No. of parameters C FVECC (W) The M calculated function values C X (R) The current parameter values C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'conics.finc' C C====== FUNCTION TYPES: C C C====== LOCALS: C INTEGER I C INTEGER I !Loop variable C C------------------------------------------------------------------------------- C DO 10 I = 1, M FVECC(I) = COEFFS(1,I)*X(1)*X(1) + COEFFS(2,I)*X(1)*X(2) + + COEFFS(3,I)*X(2)*X(2) + COEFFS(4,I)*X(1) + + COEFFS(5,I)*X(2) - 1.0 10 CONTINUE RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** DISPLAY_OPT ** C************************** C C SUBROUTINE DISPLAY_OPT C INCLUDE 'implicit_none.finc' C C Purpose: Handle Display/Measure program option C C Author: John W. Campbell, February 1992 C C C Arguments: C C None C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'meas_spots.finc' INCLUDE 'film_pack.finc' INCLUDE 'symbol_types.finc' INCLUDE 'image.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR C C====== LOCALS: C LOGICAL NORMAL_IMAGE INTEGER NVIEW INTEGER IVHLIST(2) INTEGER IVH INTEGER ITEM INTEGER IQUIT INTEGER IERR INTEGER NUMP INTEGER IFLAG INTEGER M_MEASURE INTEGER M_PREDICT INTEGER M_DISTOR_X INTEGER M_DISTOR_Y INTEGER M_NORMAL INTEGER IPACK_SAV INTEGER IPLATE_SAV INTEGER IMGSET(11) REAL X_CEN_F REAL Y_CEN_F REAL W_F CHARACTER*25 NAMES(5) CHARACTER*25 QUITNAM C LOGICAL NORMAL_IMAGE !Normal image displayed flag C INTEGER NVIEW !Number of view-objects from which data is to be input C INTEGER IVHLIST(2) !View-object handles list for getting data C INTEGER IVH !View-object handle of view-object returning data C INTEGER ITEM !Item number selected from menu C INTEGER IQUIT !Quit flag C INTEGER IERR !Error flag C INTEGER NUMP !Number of packs C INTEGER IFLAG !Parameter status flag C INTEGER M_MEASURE !Menu item number for: Measure Image C INTEGER M_PREDICT !Menu item number for: Show Predicted Pattern C INTEGER M_DISTOR_X !Menu item number for: X-distortion image C INTEGER M_DISTOR_Y !Menu item number for: Y-distortion image C INTEGER M_NORMAL !Menu item number for: Re-display Normal Image C INTEGER IPACK_SAV !Saves current pack number C INTEGER IPLATE_SAV !Saves current plate number C INTEGER IMGSET(11) !Array in which to save current image display settings C REAL X_CEN_F !x centre from fids or input (rasters) C REAL Y_CEN_F !y centre from fids or input (rasters) C REAL W_F !omega from fids or 0.0 (degrees) C CHARACTER*25 NAMES(5) !Menu item names C CHARACTER*25 QUITNAM !Quit box label DATA NAMES /'Measure Image', + 'Show Predicted Pattern', + 'X-distortion Image', + 'Y-distortion Image', + 'Re-display Normal Image'/ DATA QUITNAM /'Return to Previous Menu'/ C C------------------------------------------------------------------------------- C C C====== Check that pack input C CALL LDM_GET_NUMP (NUMP, IFLAG) IF (NUMP.EQ.0) THEN CALL ERR_NOTICE (1, '**Number of packs is zero**') RETURN END IF C C====== Get (default) centre position C 10 CALL CHK_OPN (IQUIT) IF (IQUIT.GT.0) RETURN CALL FILM_CENTRE (X_CEN_F, Y_CEN_F, W_F) XCEN_SPOTS = X_CEN_F YCEN_SPOTS = Y_CEN_F IXCEN_SPOTS = NINT(XCEN_SPOTS) IYCEN_SPOTS = NINT(YCEN_SPOTS) C C====== Display film/image-plate image C NORMAL_IMAGE = .TRUE. CALL SHOW_IMAGE (1, IERR) IF (IERR.EQ.1) RETURN C C====== Display centre symbol C CALL XDLF_IMAGE_SYMBOL (IVH_FILM, IXCEN_SPOTS, IYCEN_SPOTS, + ISYMBTYP(5), ICOLRTYP(5), 1, IERR) C C====== Set up menu C M_MEASURE = 1 M_PREDICT = 2 M_DISTOR_X = 3 M_DISTOR_Y = 4 M_NORMAL = 5 50 CALL XDLF_MENU_AREA_SETMENU (IVH_MENU, 5, XDLSTR(NAMES), 25, + XDLSTR('Display/Measure Menu'), 20, + XDLSTR(QUITNAM), 25, 0, IERR) C C====== Set up list of view-object handles C NVIEW = 2 IVHLIST(1) = IVH_MENU IVHLIST(2) = IVH_PAR1 C C====== Start event loop C 100 CALL XDLF_GET_EVENTS (NVIEW, IVHLIST, IVH) IF (IVH.EQ.IVH_MENU) THEN C C====== Menu item selected C CALL XDLF_MENU_AREA_GETITEM (IVH_MENU, ITEM, IQUIT) C C====== Quit box selected C IF (IQUIT.EQ.1) THEN CALL XDLF_IMAGE_SETTINGS (IVH_FILM, MINTHR, MAXTHR, + MONO_THR, ICONTRAST, ICOLOR_OPT, IOVLY_OPT, IBG_OPT, + MAG_OPT, ISHOW_INT, IERR) CALL XDLF_DELETE_VIEW_OBJECT (IVH_FILM, IERR) RETURN END IF C C====== Measure Image C IF (ITEM.EQ.M_MEASURE) THEN IF (.NOT.NORMAL_IMAGE) THEN CALL ERR_NOTICE(1,'**Cannot measure distortion image**') END IF CALL MEASURE_IMG GO TO 50 C C====== Show Predicted pattern C ELSE IF (ITEM.EQ.M_PREDICT) THEN IF (.NOT.NORMAL_IMAGE) THEN CALL ERR_NOTICE(1, + '**Cannot predict on distortion image**') END IF CALL SHOW_PREDICT (1) CALL XDLF_IMAGE_SYMBOL (IVH_FILM, + IXCEN_SPOTS, IYCEN_SPOTS, + ISYMBTYP(5), ICOLRTYP(5), 1, IERR) GO TO 50 C C====== X-distortion Image C ELSE IF (ITEM.EQ.M_DISTOR_X) THEN IF (NORMAL_IMAGE) THEN CALL XDLF_IMAGE_SETTINGS (IVH_FILM, MINTHR, MAXTHR, + MONO_THR, ICONTRAST, ICOLOR_OPT, IOVLY_OPT, IBG_OPT, + MAG_OPT, ISHOW_INT, IERR) END IF CALL XDLF_DELETE_VIEW_OBJECT (IVH_FILM, IERR) CALL DISTOR_IMAGE (1) NORMAL_IMAGE = .FALSE. GO TO 50 C C====== Y-distortion Image C ELSE IF (ITEM.EQ.M_DISTOR_Y) THEN IF (NORMAL_IMAGE) THEN CALL XDLF_IMAGE_SETTINGS (IVH_FILM, MINTHR, MAXTHR, + MONO_THR, ICONTRAST, ICOLOR_OPT, IOVLY_OPT, IBG_OPT, + MAG_OPT, ISHOW_INT, IERR) END IF CALL XDLF_DELETE_VIEW_OBJECT (IVH_FILM, IERR) CALL DISTOR_IMAGE (2) NORMAL_IMAGE = .FALSE. GO TO 50 C C====== Re-display Normal Image C ELSE IF (ITEM.EQ.M_NORMAL) THEN IF (NORMAL_IMAGE) GO TO 50 CALL XDLF_DELETE_VIEW_OBJECT (IVH_FILM, IERR) CALL SHOW_IMAGE (1, IERR) NORMAL_IMAGE = .TRUE. GO TO 50 END IF C C====== Parameter table 1 input C ELSE IF (IVH.EQ.IVH_PAR1) THEN IPACK_SAV = IPACK IPLATE_SAV = IPLATE CALL PAR1_INPUT IF (IPACK.NE.IPACK_SAV.OR.IPLATE.NE.IPLATE_SAV) THEN CALL XDLF_IMAGE_SETTINGS (IVH_FILM, MINTHR, MAXTHR, + MONO_THR, ICONTRAST, ICOLOR_OPT, IOVLY_OPT, IBG_OPT, + MAG_OPT, ISHOW_INT, IERR) CALL XDLF_DELETE_VIEW_OBJECT (IVH_FILM, IERR) GO TO 10 END IF END IF GO TO 100 END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C**************************** C** DISTOR_IMAGE ** C**************************** C C SUBROUTINE DISTOR_IMAGE (IXY) C INCLUDE 'implicit_none.finc' C C Purpose: Create and display an image showing the distortion corrections C image if needed) C C Author: John W. Campbell, December 1993 C C Arguments: C INTEGER IXY C C IXY (R) =1 show x-distortion, =2 show y-distortion C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' INCLUDE 'screen_params.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'prog_flags.finc' INCLUDE 'film_pack.finc' INCLUDE 'image.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR C C====== LOCALS: C LOGICAL WITHIN INTEGER KERR INTEGER IDUMMY(2) INTEGER KXROOT INTEGER KYROOT INTEGER IFLAG INTEGER NXRAST INTEGER NYRAST INTEGER MSRASTS INTEGER MFRASTS INTEGER ND INTEGER NXP INTEGER NYP INTEGER MCMP INTEGER IXR INTEGER IYR INTEGER IP INTEGER IFAST INTEGER ISLOW INTEGER IX INTEGER IY INTEGER IRED(64) INTEGER IGREEN(64) INTEGER IBLUE(64) INTEGER MINV INTEGER MAXV INTEGER MINTH INTEGER MAXTH REAL MM_RAST_X REAL MM_RAST_Y REAL XCEN REAL YCEN REAL COS_WC REAL SIN_WC REAL XF REAL YF REAL X_CEN_F REAL Y_CEN_F REAL X_C REAL Y_C REAL W_C REAL CTOF REAL XLOW REAL XHIGH REAL YLOW REAL YHIGH REAL XMIN REAL XMAX REAL YMIN REAL YMAX REAL XFD REAL YFD CHARACTER*2 VALSTR CHARACTER*2 ERRSTR CHARACTER*80 STR C LOGICAL WITHIN !Pixel within limits flag C INTEGER KERR !Error flag C INTEGER IDUMMY(2) !Dummy array for film display routine C INTEGER KXROOT !Root window x position for image display C INTEGER KYROOT !Root window y position for image display C INTEGER IFLAG !Parameter status flag C INTEGER NXRAST !No. of x-rasters C INTEGER NYRAST !No. of y-rasters C INTEGER MSRASTS !No. of slow rasters C INTEGER MFRASTS !No. of fast rasters C INTEGER ND !No. of decimaol places flag for parameter value C INTEGER NXP !Minimum compression factor required for x C INTEGER NYP !Minimum compression factor required for y C INTEGER MCMP !Compression factor for distortion image C INTEGER IXR !X root window position for progress bar C INTEGER IYR !Y root window position for progress bar C INTEGER IP !Index into image array C INTEGER IFAST !Fast loop index C INTEGER ISLOW !Slow loop index C INTEGER IX !x raster position for current pixel C INTEGER IY !Y raster position for current pixel C INTEGER IRED(64) !Red colormap components C INTEGER IGREEN(64) !Green colormap components C INTEGER IBLUE(64) !Blue colormap components C INTEGER MINV !Minimum value in distortion image C INTEGER MAXV !Maximum value in distortion image C INTEGER MINTH !Minimum threshold C INTEGER MAXTH !Maximum threshold C REAL MM_RAST_X !Conversion factor mm to x-rasters C REAL MM_RAST_Y !Conversion factor mm to y-rasters C REAL XCEN !X centre (corrected) in rasters C REAL YCEN !Y centre (corrected) in rasters C REAL COS_WC !cos(w-c) C REAL SIN_WC !sin(w_c) C REAL XF !x raster coordinate converted to mm from centre C REAL YF !y raster coordinate converted to mm from centre C REAL X_CEN_F !Uncorrected x-centre in rasters C REAL Y_CEN_F !Uncorrected y-centre in rasters C REAL X_C !x_c in mm C REAL Y_C !y_c in mm C REAL W_C !w_c in degrees C REAL CTOF !Crystal to film distance C REAL XLOW !Low x limit in rasters C REAL XHIGH !High x limit in rasters C REAL YLOW !Low y limit in raster C REAL YHIGH !High y limit in rasters C REAL XMIN !Min allowed x (mm from centre) C REAL XMAX !Max allowed x (mm from centre) C REAL YMIN !Min allowed y (mm from centre) C REAL YMAX !Max allowed y (mm from centre) C REAL XFD !Distortion corrected x coordinate (mm from centre) C REAL YFD !Distortion corrected y coordinate (mm from centre) C CHARACTER*2 VALSTR !Value string (dummy) C CHARACTER*2 ERRSTR !Error string (dummy) C CHARACTER*80 STR !Message string C C------------------------------------------------------------------------------- C C C====== Get LDM parameters C DOUBLE PRECISION COSD, SIND EXTERNAL COSD, SIND CALL LDM_MMRAST (IPACK, IPLATE, MM_RAST_X, MM_RAST_Y) CALL LDM_GET_NXRAS (NXRAST, IFLAG) CALL LDM_GET_NYRAS (NYRAST, IFLAG) CALL LDM_GET_CTOF (IPACK, IPLATE, CTOF, IFLAG, ND, KERR, ERRSTR) CALL LDM_GET_XCENF (IPACK, IPLATE, X_CEN_F, IFLAG, + ND, KERR, ERRSTR) CALL LDM_GET_YCENF (IPACK, IPLATE, Y_CEN_F, IFLAG, + ND, KERR, ERRSTR) CALL LDM_GET_XC (IPACK, IPLATE, X_C, IFLAG, ND, KERR, ERRSTR) CALL LDM_GET_YC (IPACK, IPLATE, Y_C, IFLAG, ND, KERR, ERRSTR) CALL LDM_GET_WC (IPACK, IPLATE, W_C, IFLAG, ND, KERR, ERRSTR) COS_WC = COSD(W_C) SIN_WC = SIND(W_C) IF (X_CEN_F.GT.0.0.AND.Y_CEN_F.GT.0.0) THEN XCEN = X_CEN_F + X_C*MM_RAST_X YCEN = Y_CEN_F + Y_C*MM_RAST_Y ELSE XCEN = NXRAST/2 YCEN = NYRAST/2 END IF CALL LDM_GET_XLOW (XLOW, IFLAG, ND) CALL LDM_GET_XHIGH (XHIGH, IFLAG, ND) CALL LDM_GET_YLOW (YLOW, IFLAG, ND) CALL LDM_GET_YHIGH (YHIGH, IFLAG, ND) C C====== Calculate allowed x, y limits in mm from predicted centre based on C xlow, xhigh, ylow, yhigh C XMIN = (1.0 - XCEN)/MM_RAST_X XMAX = (NXRAST - XCEN)/MM_RAST_X YMIN = (1.0 - YCEN)/MM_RAST_Y YMAX = (NYRAST - YCEN)/MM_RAST_Y IF (XLOW.GT.0.0) XMIN = (XLOW - XCEN)/MM_RAST_X IF (XHIGH.GT.0.0) XMAX = (XHIGH - XCEN)/MM_RAST_X IF (YLOW.GT.0.0) YMIN = (YLOW - YCEN)/MM_RAST_Y IF (YHIGH.GT.0.0) YMAX = (YHIGH - YCEN)/MM_RAST_Y NXP = (NXRAST + MAX_IMG_SIZE - 1)/MAX_IMG_SIZE NYP = (NYRAST + MAX_IMG_SIZE - 1)/MAX_IMG_SIZE MCMP = MAX(NXP,NYP) CALL XDLF_VIEW_OBJECT_ROOTXY (IVH_IOW,20,20,IXR,IYR,KERR) IF (MCMP.GT.1) THEN STR = '*Distortion Image compressed by' CALL STR_ADDI(STR,MCMP,1) CALL STR_ADDS(STR,'to 1 from full image*',1) CALL LMESSAGE(IVH_IOW,STR) END IF MSRASTS = NXRAST/MCMP MFRASTS = NYRAST/MCMP C C====== Create Distortion image C MINV = 10000000 MAXV = -10000000 CALL XDLF_PROGRESS_BAR (IVH_BAR, IXR, IYR, + XDLSTR('Forming distortion image:'), 25, 100, MSRASTS, + IFONT, 5) IP = 0 DO 200 ISLOW = 1, MSRASTS IX = (ISLOW-1)*MCMP + MCMP/2 + 1 XF = (FLOAT(IX)-XCEN)/MM_RAST_X DO 150 IFAST = 1, MFRASTS IY = (IFAST-1)*MCMP + MCMP/2 + 1 YF = (FLOAT(IY)-YCEN)/MM_RAST_Y WITHIN = .TRUE. IF (XF.LT.XMIN.OR.XF.GT.XMAX) WITHIN = .FALSE. IF (YF.LT.YMIN.OR.YF.GT.YMAX) WITHIN = .FALSE. IP = IP + 1 IF (WITHIN) THEN CALL LDM_CORR (IPACK, IPLATE, COS_WC, SIN_WC, CTOF, + XF, YF, XFD, YFD) IF (IXY.EQ.1) THEN DISTOR_IMG(IP) = NINT(100.0*(XFD-XF)*MM_RAST_X) ELSE DISTOR_IMG(IP) = NINT(100.0*(YFD-YF)*MM_RAST_Y) END IF ELSE DISTOR_IMG(IP) = 0 END IF IF (DISTOR_IMG(IP).GT.MAXV) MAXV = DISTOR_IMG(IP) IF (DISTOR_IMG(IP).LT.MINV) MINV = DISTOR_IMG(IP) 150 CONTINUE CALL XDLF_PROGRESS_BAR_VALUE (IVH_BAR, ISLOW, KERR) 200 CONTINUE CALL XDLF_DELETE_VIEW_OBJECT (IVH_BAR, KERR) C C====== Display distortion image C KXROOT = 0 KYROOT = 0 CALL XDLF_VIEW_OBJECT_ROOTXY(IVH_PAR1,0,0,KXROOT,KYROOT,KERR) KYROOT = KYROOT - 30 IF (KYROOT.LT.0) KYROOT = 0 MINTH = MINV MAXTH = MAXV CALL XDLF_IMAGE (IVH_FILM,0,KXROOT,KYROOT,1,DISTOR_IMG,3, + MSRASTS,MFRASTS,MFRASTS, + 1,1,NXRAST/MCMP,NYRAST/MCMP,1,1,2, + MINV,MAXV,MINTH,MAXTH,0,0, + 1,1,1024,1,KERR) CALL XDLF_IMAGE_AXNAMES (IVH_FILM,XDLSTR('x'),1,XDLSTR('y'),1, + KERR) CALL IMAGE_COLOURS (IRED, IGREEN, IBLUE) CALL XDLF_IMAGE_SET_COLORMAP (IVH_FILM, IRED, IGREEN, IBLUE, + KERR) RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** DRAW_CIRC ** C************************** C C SUBROUTINE DRAW_CIRC (IVH_IMG, IXC, IYC, RAD, N, IV, ICOLR, LAST) C INCLUDE 'implicit_none.finc' C C Purpose: Draw circle on image C C Author: John W. Campbell, October 1993 C C Arguments: C INTEGER IVH_IMG INTEGER IXC INTEGER IYC REAL RAD INTEGER N INTEGER IERR INTEGER IV INTEGER ICOLR LOGICAL LAST C C IVH_IMG (R) View-object handle for the image C IXC (R) X centre of circle (pixel number) C IYC (R) Y centre of circle (pixel number) C RAD (R) Radius of circle in raster units (real) C N (R) No. of segments for circle draw C IV (R) Vector id C ICOLR (R) Color no. C LAST (R) = .TRUE. update magnifying window when circle drawn, C = .FALSE. do not C C====== Parameter statements C C C====== GLOBALS: C C C====== FUNCTION TYPES: C C C====== LOCALS: C INTEGER I INTEGER IMAG INTEGER IX1, IY1 INTEGER IX2, IY2 REAL TH REAL DTH C C------------------------------------------------------------------------------- C TH = 0.0 DTH = 6.28319/N IMAG = 0 DO 100 I = 1, N IX1 = NINT(IXC + RAD*COS(TH)) IY1 = NINT(IYC + RAD*SIN(TH)) TH = TH + DTH IX2 = NINT(IXC + RAD*COS(TH)) IY2 = NINT(IYC + RAD*SIN(TH)) IF (LAST.AND.I.EQ.N) IMAG = 1 CALL XDLF_IMAGE_VECT (IVH_IMG, IV, IX1, IY1, IX2, IY2, + ICOLR, 1, IMAG, IERR) 100 CONTINUE RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** EDIT_FIDS ** C************************** C C SUBROUTINE EDIT_FIDS C INCLUDE 'implicit_none.finc' C C Purpose: Allow editing of fid values via popup parameter table and menu C C Author: John W. Campbell, January 1992 C C Arguments: C C None C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' INCLUDE 'screen_params.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'film_pack.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR INTEGER LENSTR INTEGER INTFP C C====== LOCALS: C INTEGER IVH_POPFR INTEGER IVH_POPPT INTEGER IVH_POPMN INTEGER NP_NAME_CHARS INTEGER NP_VAL_CHARS INTEGER JP_FIDX1 INTEGER JP_FIDY1 INTEGER JP_FIDX2 INTEGER JP_FIDY2 INTEGER JP_FIDX3 INTEGER JP_FIDY3 INTEGER P_WIDTH INTEGER P_HEIGHT INTEGER M_WIDTH INTEGER M_HEIGHT INTEGER IWIDTH_FRAME INTEGER IHEIGHT_FRAME INTEGER IX_PARM INTEGER IY_PARM INTEGER IX_MENU INTEGER IY_MENU INTEGER IXROOT INTEGER IYROOT INTEGER NVIEW INTEGER IVHLIST(2) INTEGER IVH INTEGER ITEM INTEGER IQUIT INTEGER IERR INTEGER ITYP INTEGER IFLAG INTEGER ND INTEGER IV REAL XHALF REAL YHALF REAL VALUE REAL MM_RAST_X REAL MM_RAST_Y CHARACTER*15 MENU_STRS(2) CHARACTER*15 PVAL CHARACTER*80 ERRSTR C C INTEGER IVH_POPFR !View-object handle for pop-up frame C INTEGER IVH_POPPT !View-object handle for parameter table C INTEGER IVH_POPMN !View-object handle for menu C INTEGER NP_NAME_CHARS !Max no. chars in parameter table name C INTEGER NP_VAL_CHARS !Max no. chars in pareter table value C INTEGER JP_FIDX1 !Item numbers in param. table for fidx1 C INTEGER JP_FIDY1 !Item numbers in param. table for fidy1 C INTEGER JP_FIDX2 !Item numbers in param. table for fidx2 C INTEGER JP_FIDY2 !Item numbers in param. table for fidy2 C INTEGER JP_FIDX3 !Item numbers in param. table for fidx3 C INTEGER JP_FIDY3 !Item numbers in param. table for fidy3 C INTEGER P_WIDTH !Parameter table width C INTEGER P_HEIGHT !Parameter table height C INTEGER M_WIDTH !Menu area width C INTEGER M_HEIGHT !Menu area height C INTEGER IWIDTH_FRAME !Width of pop-up frame C INTEGER IHEIGHT_FRAME !Height of pop-up frame C INTEGER IX_PARM !X position of parameter table within frame C INTEGER IY_PARM !Y position of parameter table within frame C INTEGER IX_MENU !X position of menu area within frame C INTEGER IY_MENU !Y position of menu area within frame C INTEGER IXROOT !Root X position of pop-up frame C INTEGER IYROOT !Root Y position of pop_up frame C INTEGER NVIEW !No. of view-objects for getting events C INTEGER IVHLIST(2) !List of view-object handles for getting events C INTEGER IVH !Returned view-object handle from getting events C INTEGER ITEM !Item no. modified in parameter table C INTEGER IQUIT !Quit button flage from menu C INTEGER IERR !Error flag C INTEGER ITYP !Return flag from INTFP C INTEGER IFLAG !Parameter status flag C INTEGER ND !No. of decimal places flag C INTEGER IV !Integer value C REAL XHALF !Half of image along x C REAL YHALF !Half of image aling y C REAL VALUE !Real parameter value C REAL MM_RAST_X !Convert mm to x-rasters C REAL MM_RAST_Y !Convert mm to y-rasters C CHARACTER*15 MENU_STRS(2) !Menu strings C CHARACTER*15 PVAL !String for parameter table input value C CHARACTER*80 ERRSTR !Error message string C C====== Data statements C DATA MENU_STRS/'Arndt-Wonacott','Huber'/ C C------------------------------------------------------------------------------- C CALL LDM_MMRAST (IPACK, IPLATE, MM_RAST_X, MM_RAST_Y) CALL LDM_GET_NXRAS (IV, IFLAG) XHALF = IV/2.0 CALL LDM_GET_NYRAS (IV, IFLAG) YHALF = IV/2.0 IVH_POPFR = 100 IVH_POPPT = 101 IVH_POPMN = 102 NP_NAME_CHARS = 18 NP_VAL_CHARS = 10 JP_FIDX1 = 1 JP_FIDY1 = 2 JP_FIDX2 = 3 JP_FIDY2 = 4 JP_FIDX3 = 5 JP_FIDY3 = 6 CALL XDLF_VIEW_OBJECT_ROOTXY(IVH_PAR1,100,0,IXROOT,IYROOT,IERR) C C====== Get required parameter table size and menu size C CALL XDLF_PARAM_TABLE_GETSIZE (1, 6, NP_NAME_CHARS, NP_VAL_CHARS, + 1, IFONT, 1, P_WIDTH, P_HEIGHT) CALL XDLF_MENU_AREA_GETSIZE (2, 20, IFONT, 1, 0, + M_WIDTH, M_HEIGHT) C C====== Get required size for pop-up frame and positions of windows C IWIDTH_FRAME = 2*IBORDER + P_WIDTH + 8 IHEIGHT_FRAME = 2*IBORDER + P_HEIGHT + ISEP + M_HEIGHT + 8 IX_PARM = IBORDER + 4 IY_PARM = IBORDER + 4 IX_MENU = IBORDER + 4 IY_MENU = IBORDER + 4 + P_HEIGHT + ISEP C C====== Create pop-up base frame C CALL XDLF_POPUP_FRAME (IVH_POPFR, IXROOT, IYROOT, IWIDTH_FRAME, + IHEIGHT_FRAME, 5) C C====== Create parameter_table & menu (Note: Use param width for menu) C CALL XDLF_PARAM_TABLE (IVH_POPPT, IVH_POPFR, IX_PARM, IY_PARM, + 0, 1, 6, NP_NAME_CHARS, + NP_VAL_CHARS, NP_VAL_CHARS, + XDLSTR('Fiducials'), 9, IFONT, + 1, IERR) CALL XDLF_MENU_AREA (IVH_POPMN, IVH_POPFR, IX_MENU, IY_MENU, 0, + 2, 20, IFONT, 1, 0, P_WIDTH, M_HEIGHT, IERR) C C====== Set up menu C CALL XDLF_MENU_AREA_SETMENU (IVH_POPMN, 2, + XDLSTR(MENU_STRS), 15, XDLSTR(' '), -1, + XDLSTR('Continue'), 8, IFONT, IERR) C C====== Set up parameter table entries C CALL LDM_GET_FIDX1 (VALUE, IFLAG, ND) VALUE = XHALF + VALUE*MM_RAST_X/100.0 WRITE (PVAL,'(F8.1)') VALUE CALL LJUST(PVAL) CALL XDLF_PARAM_TABLE_SETITEM (IVH_POPPT, JP_FIDX1, + XDLSTR('fidx1 (rasters):'), 16, XDLSTR(PVAL), 15, + 0, 0, IERR) CALL LDM_GET_FIDY1 (VALUE, IFLAG, ND) VALUE = YHALF + VALUE*MM_RAST_Y/100.0 WRITE (PVAL,'(F8.1)') VALUE CALL LJUST(PVAL) CALL XDLF_PARAM_TABLE_SETITEM (IVH_POPPT, JP_FIDY1, + XDLSTR('fidy1 (rasters):'), 16, XDLSTR(PVAL), 15, + 0, 0, IERR) CALL LDM_GET_FIDX2 (VALUE, IFLAG, ND) VALUE = XHALF + VALUE*MM_RAST_X/100.0 WRITE (PVAL,'(F8.1)') VALUE CALL LJUST(PVAL) CALL XDLF_PARAM_TABLE_SETITEM (IVH_POPPT, JP_FIDX2, + XDLSTR('fidx2 (rasters):'), 16, XDLSTR(PVAL), 15, + 0, 0, IERR) CALL LDM_GET_FIDY2 (VALUE, IFLAG, ND) VALUE = YHALF + VALUE*MM_RAST_Y/100.0 WRITE (PVAL,'(F8.1)') VALUE CALL LJUST(PVAL) CALL XDLF_PARAM_TABLE_SETITEM (IVH_POPPT, JP_FIDY2, + XDLSTR('fidy2 (rasters):'), 16, XDLSTR(PVAL), 15, + 0, 0, IERR) CALL LDM_GET_FIDX3 (VALUE, IFLAG, ND) VALUE = XHALF + VALUE*MM_RAST_X/100.0 WRITE (PVAL,'(F8.1)') VALUE CALL LJUST(PVAL) CALL XDLF_PARAM_TABLE_SETITEM (IVH_POPPT, JP_FIDX3, + XDLSTR('fidx3 (rasters):'), 16, XDLSTR(PVAL), 15, + 0, 0, IERR) CALL LDM_GET_FIDY3 (VALUE, IFLAG, ND) VALUE = YHALF + VALUE*MM_RAST_Y/100.0 WRITE (PVAL,'(F8.1)') VALUE CALL LJUST(PVAL) CALL XDLF_PARAM_TABLE_SETITEM (IVH_POPPT, JP_FIDY3, + XDLSTR('fidy3 (rasters):'), 16, XDLSTR(PVAL), 15, + 0, 0, IERR) C C====== Get input from the menu and/or parameter table C NVIEW = 2 IVHLIST(1) = IVH_POPMN IVHLIST(2) = IVH_POPPT 200 CALL XDLF_GET_EVENTS (NVIEW, IVHLIST, IVH) C C====== Parameter table input C IF (IVH.EQ.IVH_POPPT) THEN CALL XDLF_PARAM_TABLE_GETVALUE (IVH_POPPT, ITEM, + XDLSTR(PVAL), 15, IERR) ITYP = INTFP (PVAL, VALUE, IV) IF (ITYP.EQ.0) THEN CALL XDLF_PARAM_TABLE_ERROR (IVH_POPPT, ITEM, + XDLSTR('**Invalid syntax**'), 18, IERR) GO TO 200 END IF IF (VALUE.LE.0) THEN CALL XDLF_PARAM_TABLE_ERROR (IVH_POPPT, ITEM, + XDLSTR('**Value must be greater than zero**'), 35, IERR) GO TO 200 END IF IF (ITEM.EQ.JP_FIDX1) THEN VALUE = 100.0*(VALUE-XHALF)/MM_RAST_X CALL LDM_SET_FIDX1 (VALUE, IERR, ERRSTR) IF (IERR.NE.0) GO TO 800 GO TO 200 ELSE IF (ITEM.EQ.JP_FIDY1) THEN VALUE = 100.0*(VALUE-YHALF)/MM_RAST_Y CALL LDM_SET_FIDY1 (VALUE, IERR, ERRSTR) IF (IERR.NE.0) GO TO 800 GO TO 200 ELSE IF (ITEM.EQ.JP_FIDX2) THEN VALUE = 100.0*(VALUE-XHALF)/MM_RAST_X CALL LDM_SET_FIDX2 (VALUE, IERR, ERRSTR) IF (IERR.NE.0) GO TO 800 GO TO 200 ELSE IF (ITEM.EQ.JP_FIDY2) THEN VALUE = 100.0*(VALUE-YHALF)/MM_RAST_Y CALL LDM_SET_FIDY2 (VALUE, IERR, ERRSTR) IF (IERR.NE.0) GO TO 800 GO TO 200 ELSE IF (ITEM.EQ.JP_FIDX3) THEN VALUE = 100.0*(VALUE-XHALF)/MM_RAST_X CALL LDM_SET_FIDX3 (VALUE, IERR, ERRSTR) IF (IERR.NE.0) GO TO 800 GO TO 200 ELSE IF (ITEM.EQ.JP_FIDY3) THEN VALUE = 100.0*(VALUE-YHALF)/MM_RAST_Y CALL LDM_SET_FIDY3 (VALUE, IERR, ERRSTR) IF (IERR.NE.0) GO TO 800 GO TO 200 END IF C C====== Menu input C ELSE IF (IVH.EQ.IVH_POPMN) THEN CALL XDLF_MENU_AREA_GETITEM (IVH_POPMN, ITEM, IQUIT) IF (IQUIT.EQ.1) THEN CALL XDLF_DELETE_VIEW_OBJECT (IVH_POPMN, IERR) CALL XDLF_DELETE_VIEW_OBJECT (IVH_POPPT, IERR) CALL XDLF_DELETE_VIEW_OBJECT (IVH_POPFR, IERR) RETURN ELSE IF (ITEM.EQ.1) THEN CALL LDM_SET_FIDX1 (-5000.0, IERR, ERRSTR) CALL LDM_SET_FIDY1 (-4000.0, IERR, ERRSTR) CALL LDM_SET_FIDX2 (-5000.0, IERR, ERRSTR) CALL LDM_SET_FIDY2 (4000.0, IERR, ERRSTR) CALL LDM_SET_FIDX3 (5000.0, IERR, ERRSTR) CALL LDM_SET_FIDY3 (4000.0, IERR, ERRSTR) ELSE IF (ITEM.EQ.2) THEN CALL LDM_SET_FIDX1 (-4000.0, IERR, ERRSTR) CALL LDM_SET_FIDY1 (5000.0, IERR, ERRSTR) CALL LDM_SET_FIDX2 (-4000.0, IERR, ERRSTR) CALL LDM_SET_FIDY2 (-5000.0, IERR, ERRSTR) CALL LDM_SET_FIDX3 (4000.0, IERR, ERRSTR) CALL LDM_SET_FIDY3 (-5000.0, IERR, ERRSTR) ENDIF END IF CALL LDM_GET_FIDX1 (VALUE, IFLAG, ND) VALUE = XHALF + VALUE*MM_RAST_X/100.0 WRITE (PVAL,'(F8.1)') VALUE CALL LJUST(PVAL) CALL XDLF_PARAM_TABLE_SETVALUE (IVH_POPPT, JP_FIDX1, + XDLSTR(PVAL), 15, 0, IERR) CALL LDM_GET_FIDY1 (VALUE, IFLAG, ND) VALUE = YHALF + VALUE*MM_RAST_Y/100.0 WRITE (PVAL,'(F8.1)') VALUE CALL LJUST(PVAL) CALL XDLF_PARAM_TABLE_SETVALUE (IVH_POPPT, JP_FIDY1, + XDLSTR(PVAL), 15, 0, IERR) CALL LDM_GET_FIDX2 (VALUE, IFLAG, ND) VALUE = XHALF + VALUE*MM_RAST_X/100.0 WRITE (PVAL,'(F8.1)') VALUE CALL LJUST(PVAL) CALL XDLF_PARAM_TABLE_SETVALUE (IVH_POPPT, JP_FIDX2, + XDLSTR(PVAL), 15, 0, IERR) CALL LDM_GET_FIDY2 (VALUE, IFLAG, ND) VALUE = YHALF + VALUE*MM_RAST_Y/100.0 WRITE (PVAL,'(F8.1)') VALUE CALL LJUST(PVAL) CALL XDLF_PARAM_TABLE_SETVALUE (IVH_POPPT, JP_FIDY2, + XDLSTR(PVAL), 15, 0, IERR) CALL LDM_GET_FIDX3 (VALUE, IFLAG, ND) VALUE = XHALF + VALUE*MM_RAST_X/100.0 WRITE (PVAL,'(F8.1)') VALUE CALL LJUST(PVAL) CALL XDLF_PARAM_TABLE_SETVALUE (IVH_POPPT, JP_FIDX3, + XDLSTR(PVAL), 15, 0, IERR) CALL LDM_GET_FIDY3 (VALUE, IFLAG, ND) VALUE = YHALF + VALUE*MM_RAST_Y/100.0 WRITE (PVAL,'(F8.1)') VALUE CALL LJUST(PVAL) CALL XDLF_PARAM_TABLE_SETVALUE (IVH_POPPT, JP_FIDY3, + XDLSTR(PVAL), 15, 0, IERR) END IF GO TO 200 C C====== Parameter value error C 800 CALL XDLF_PARAM_TABLE_ERROR (IVH_POPPT, ITEM, + XDLSTR(ERRSTR), LENSTR(ERRSTR), IERR) GO TO 200 END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** EDIT_SPD ** C************************** C C SUBROUTINE EDIT_SPD C INCLUDE 'implicit_none.finc' C C Purpose: Allow editing of spd values via popup parameter table and menu C C Author: John W. Campbell, September 1993 C C Arguments: C C None C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' INCLUDE 'screen_params.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'ip2_entries.finc' INCLUDE 'film_pack.finc' INCLUDE 'upd_flags.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR INTEGER LENSTR INTEGER INTFP INTEGER LDM_SPDMAX C C====== LOCALS: C INTEGER IVH_POPFR INTEGER IVH_POPPT INTEGER IVH_POPMN INTEGER NP_NAME_CHARS INTEGER NP_VAL_CHARS INTEGER JP_SPDXN INTEGER JP_SPDXMIN INTEGER JP_SPDXMAX INTEGER JP_SPDX1 INTEGER JP_SPDYN INTEGER JP_SPDYMIN INTEGER JP_SPDYMAX INTEGER JP_SPDY1 INTEGER P_WIDTH INTEGER P_HEIGHT INTEGER M_WIDTH INTEGER M_HEIGHT INTEGER IWIDTH_FRAME INTEGER IHEIGHT_FRAME INTEGER IX_PARM INTEGER IY_PARM INTEGER IX_MENU INTEGER IY_MENU INTEGER IXROOT INTEGER IYROOT INTEGER NVIEW INTEGER IVHLIST(2) INTEGER IVH INTEGER ITEM INTEGER IQUIT INTEGER IERR INTEGER ITYP INTEGER IFLAG INTEGER ND INTEGER IV INTEGER KPACK INTEGER KPLATE INTEGER LISTE(2) INTEGER IVAL INTEGER MAX_SPD INTEGER I INTEGER LL REAL VALUE REAL VAL(2) CHARACTER*22 MENU_STRS(3) CHARACTER*15 PVAL CHARACTER*80 ERRSTR CHARACTER*20 SPDNAM C C INTEGER IVH_POPFR !View-object handle for pop-up frame C INTEGER IVH_POPPT !View-object handle for parameter table C INTEGER IVH_POPMN !View-object handle for menu C INTEGER NP_NAME_CHARS !Max no. chars in parameter table name C INTEGER NP_VAL_CHARS !Max no. chars in pareter table value C INTEGER JP_SPDXN !Param table item no. for spdx_n C INTEGER JP_SPDXMIN !Param table item no. for spdx_min C INTEGER JP_SPDXMAX !Param table item no. for spdx_max C INTEGER JP_SPDX1 !Param table item no. for spdx1 C INTEGER JP_SPDYN !Param table item no. for spdy_n C INTEGER JP_SPDYMIN !Param table item no. for spdy_min C INTEGER JP_SPDYMAX !Param table item no. for spdy_max C INTEGER JP_SPDY1 !Param table item no. for spdy1 C INTEGER P_WIDTH !Parameter table width C INTEGER P_HEIGHT !Parameter table height C INTEGER M_WIDTH !Menu area width C INTEGER M_HEIGHT !Menu area height C INTEGER IWIDTH_FRAME !Width of pop-up frame C INTEGER IHEIGHT_FRAME !Height of pop-up frame C INTEGER IX_PARM !X position of parameter table within frame C INTEGER IY_PARM !Y position of parameter table within frame C INTEGER IX_MENU !X position of menu area within frame C INTEGER IY_MENU !Y position of menu area within frame C INTEGER IXROOT !Root X position of pop-up frame C INTEGER IYROOT !Root Y position of pop_up frame C INTEGER NVIEW !No. of view-objects for getting events C INTEGER IVHLIST(2) !List of view-object handles for getting events C INTEGER IVH !Returned view-object handle from getting events C INTEGER ITEM !Item no. modified in parameter table C INTEGER IQUIT !Quit button flage from menu C INTEGER IERR !Error flag C INTEGER ITYP !Return flag from INTFP C INTEGER IFLAG !Parameter status flag C INTEGER ND !No. of decimal places flag C INTEGER IV !Integer value C INTEGER KPACK !Pack no. or 0 for all packs update C INTEGER KPLATE !Plate no. or 0 for all plates update C INTEGER LISTE(2) !Parameter items for parameter table updates C INTEGER IVAL !Integer parameter value C INTEGER MAX_SPD !Maximum spd coefficient no. C INTEGER I !Temp/loop variable C INTEGER LL !String length C REAL VALUE !Real parameter value C REAL VAL(2) !Real parameter values array C CHARACTER*22 MENU_STRS(3) !Menu strings C CHARACTER*15 PVAL !String for parameter table input value C CHARACTER*80 ERRSTR !Error message string C CHARACTER*20 SPDNAM !Name of SPD.. parameter C C====== Data statements C DATA MENU_STRS/'Zero spdx coefficients', + 'Zero spdy coefficients', + 'Zero all coefficients'/ C C------------------------------------------------------------------------------- C C====== Initialisations C IVH_POPFR = 100 IVH_POPPT = 101 IVH_POPMN = 102 MAX_SPD = LDM_SPDMAX(0) NP_NAME_CHARS = 14 NP_VAL_CHARS = 12 JP_SPDXN = 1 JP_SPDXMIN = 2 JP_SPDXMAX = 3 JP_SPDX1 = 4 JP_SPDYN = MAX_SPD + 4 JP_SPDYMIN = MAX_SPD + 5 JP_SPDYMAX = MAX_SPD + 6 JP_SPDY1 = MAX_SPD + 7 C C====== Get position for popup frame C CALL XDLF_VIEW_OBJECT_ROOTXY(IVH_PAR1,100,0,IXROOT,IYROOT,IERR) C C====== Get required parameter table size and menu size C CALL XDLF_PARAM_TABLE_GETSIZE (2, MAX_SPD+3, + NP_NAME_CHARS, NP_VAL_CHARS, + 1, IFONT, 1, P_WIDTH, P_HEIGHT) CALL XDLF_MENU_AREA_GETSIZE (3, 25, IFONT, 1, 0, + M_WIDTH, M_HEIGHT) C C====== Get required size for pop-up frame and positions of windows C IWIDTH_FRAME = 2*IBORDER + P_WIDTH + 8 IHEIGHT_FRAME = 2*IBORDER + P_HEIGHT + ISEP + M_HEIGHT + 8 IX_PARM = IBORDER + 4 IY_PARM = IBORDER + 4 IX_MENU = IBORDER + 4 IY_MENU = IBORDER + 4 + P_HEIGHT + ISEP C C====== Create pop-up base frame C CALL XDLF_POPUP_FRAME (IVH_POPFR, IXROOT, IYROOT, IWIDTH_FRAME, + IHEIGHT_FRAME, 5) C C====== Create parameter_table & menu (Note: Use param width for menu) C CALL XDLF_PARAM_TABLE (IVH_POPPT, IVH_POPFR, IX_PARM, IY_PARM, + 0, 2, MAX_SPD+3, NP_NAME_CHARS, + NP_VAL_CHARS, NP_VAL_CHARS, + XDLSTR('Spatial Distortion'), 18, + IFONT, 1, IERR) CALL XDLF_MENU_AREA (IVH_POPMN, IVH_POPFR, IX_MENU, IY_MENU, 0, + 3, 25, IFONT, 1, 0, P_WIDTH, M_HEIGHT, IERR) C C====== Set up menu C CALL XDLF_MENU_AREA_SETMENU (IVH_POPMN, 3, + XDLSTR(MENU_STRS), 22, XDLSTR(' '), -1, + XDLSTR('Continue'), 8, IFONT, IERR) C C====== Set up parameter table entries C CALL LDM_GET_SPDXN (IPACK, IPLATE, IVAL, IFLAG, IERR, ERRSTR) WRITE (PVAL,'(I8)') IVAL CALL LJUST(PVAL) CALL XDLF_PARAM_TABLE_SETITEM (IVH_POPPT, JP_SPDXN, + XDLSTR('spdx_n:'), 7, XDLSTR(PVAL), 15, + 0, 0, IERR) CALL LDM_GET_SXMIN (IPACK, IPLATE, VALUE, IFLAG, ND, + IERR, ERRSTR) WRITE (PVAL,'(F8.2)') VALUE CALL LJUST(PVAL) CALL XDLF_PARAM_TABLE_SETITEM (IVH_POPPT, JP_SPDXMIN, + XDLSTR('spdx_min (mm):'), 14, XDLSTR(PVAL), 15, + 0, 0, IERR) CALL LDM_GET_SXMAX (IPACK, IPLATE, VALUE, IFLAG, ND, + IERR, ERRSTR) WRITE (PVAL,'(F8.2)') VALUE CALL LJUST(PVAL) CALL XDLF_PARAM_TABLE_SETITEM (IVH_POPPT, JP_SPDXMAX, + XDLSTR('spdx_max (mm):'), 14, XDLSTR(PVAL), 15, + 0, 0, IERR) DO 100 I = 1, MAX_SPD CALL LDM_GET_SPDX (I, IPACK, IPLATE, VAL, IFLAG, ND, + IERR, ERRSTR) WRITE (PVAL,'(E12.4)') VAL(1) CALL LJUST(PVAL) SPDNAM = 'spdx' CALL STR_ADDI(SPDNAM,I,0) LL = LENSTR(SPDNAM) CALL XDLF_PARAM_TABLE_SETITEM (IVH_POPPT, JP_SPDX1+I-1, + XDLSTR(SPDNAM), LL, XDLSTR(PVAL), 15, + 0, 0, IERR) 100 CONTINUE CALL LDM_GET_SPDYN (IPACK, IPLATE, IVAL, IFLAG, IERR, ERRSTR) WRITE (PVAL,'(I8)') IVAL CALL LJUST(PVAL) CALL XDLF_PARAM_TABLE_SETITEM (IVH_POPPT, JP_SPDYN, + XDLSTR('spdy_n:'), 7, XDLSTR(PVAL), 15, + 0, 0, IERR) CALL LDM_GET_SYMIN (IPACK, IPLATE, VALUE, IFLAG, ND, + IERR, ERRSTR) WRITE (PVAL,'(F8.2)') VALUE CALL LJUST(PVAL) CALL XDLF_PARAM_TABLE_SETITEM (IVH_POPPT, JP_SPDYMIN, + XDLSTR('spdy_min (mm):'), 14, XDLSTR(PVAL), 15, + 0, 0, IERR) CALL LDM_GET_SYMAX (IPACK, IPLATE, VALUE, IFLAG, ND, + IERR, ERRSTR) WRITE (PVAL,'(F8.2)') VALUE CALL LJUST(PVAL) CALL XDLF_PARAM_TABLE_SETITEM (IVH_POPPT, JP_SPDYMAX, + XDLSTR('spdy_max (mm):'), 14, XDLSTR(PVAL), 15, + 0, 0, IERR) DO 110 I = 1, MAX_SPD CALL LDM_GET_SPDY (I, IPACK, IPLATE, VAL, IFLAG, ND, + IERR, ERRSTR) WRITE (PVAL,'(E12.4)') VAL(1) CALL LJUST(PVAL) SPDNAM = 'spdy' CALL STR_ADDI(SPDNAM,I,0) LL = LENSTR(SPDNAM) CALL XDLF_PARAM_TABLE_SETITEM (IVH_POPPT, JP_SPDY1+I-1, + XDLSTR(SPDNAM), LL, XDLSTR(PVAL), 15, + 0, 0, IERR) 110 CONTINUE C C====== Get input from the menu and/or parameter table C NVIEW = 2 IVHLIST(1) = IVH_POPMN IVHLIST(2) = IVH_POPPT 200 CALL XDLF_GET_EVENTS (NVIEW, IVHLIST, IVH) C C====== Parameter table input C IF (IVH.EQ.IVH_POPPT) THEN CALL XDLF_PARAM_TABLE_GETVALUE (IVH_POPPT, ITEM, + XDLSTR(PVAL), 15, IERR) IF (ITEM.EQ.JP_SPDXN) THEN CALL OTHERS_UPD (2, UPD_SPD, KPACK, KPLATE) CALL LDM_SET ('SPDX_N', KPACK, KPLATE, PVAL, + IERR, ERRSTR) IF (IERR.NE.0) GO TO 800 LISTE(1) = IP_SPDX CALL SET_PAR2_VALS (1, LISTE) ELSE IF (ITEM.EQ.JP_SPDXMIN) THEN CALL OTHERS_UPD (2, UPD_SPD, KPACK, KPLATE) CALL LDM_SET ('SPDX_MIN', KPACK, KPLATE, PVAL, IERR, ERRSTR) IF (IERR.NE.0) GO TO 800 ELSE IF (ITEM.EQ.JP_SPDXMAX) THEN CALL OTHERS_UPD (2, UPD_SPD, KPACK, KPLATE) CALL LDM_SET ('SPDX_MAX', KPACK, KPLATE, PVAL, IERR, ERRSTR) IF (IERR.NE.0) GO TO 800 ELSE IF (ITEM.GE.JP_SPDX1.AND.ITEM.LE.JP_SPDX1+MAX_SPD-1) THEN CALL OTHERS_UPD (2, UPD_SPD, KPACK, KPLATE) SPDNAM = 'SPDX' CALL STR_ADDI(SPDNAM,ITEM-JP_SPDX1+1,0) CALL LDM_SET (SPDNAM, KPACK, KPLATE, PVAL, IERR, ERRSTR) IF (IERR.NE.0) GO TO 800 ELSE IF (ITEM.EQ.JP_SPDYN) THEN CALL OTHERS_UPD (2, UPD_SPD, KPACK, KPLATE) CALL LDM_SET ('SPDY_N', KPACK, KPLATE, PVAL, + IERR, ERRSTR) IF (IERR.NE.0) GO TO 800 LISTE(1) = IP_SPDY CALL SET_PAR2_VALS (1, LISTE) ELSE IF (ITEM.EQ.JP_SPDYMIN) THEN CALL OTHERS_UPD (2, UPD_SPD, KPACK, KPLATE) CALL LDM_SET ('SPDY_MIN', KPACK, KPLATE, PVAL, IERR, ERRSTR) IF (IERR.NE.0) GO TO 800 ELSE IF (ITEM.EQ.JP_SPDYMAX) THEN CALL OTHERS_UPD (2, UPD_SPD, KPACK, KPLATE) CALL LDM_SET ('SPDY_MAX', KPACK, KPLATE, PVAL, IERR, ERRSTR) IF (IERR.NE.0) GO TO 800 ELSE IF (ITEM.GE.JP_SPDY1.AND.ITEM.LE.JP_SPDY1+MAX_SPD-1) THEN CALL OTHERS_UPD (2, UPD_SPD, KPACK, KPLATE) SPDNAM = 'SPDY' CALL STR_ADDI(SPDNAM,ITEM-JP_SPDY1+1,0) CALL LDM_SET (SPDNAM, KPACK, KPLATE, PVAL, IERR, ERRSTR) IF (IERR.NE.0) GO TO 800 END IF C C====== Menu input C ELSE IF (IVH.EQ.IVH_POPMN) THEN CALL XDLF_MENU_AREA_GETITEM (IVH_POPMN, ITEM, IQUIT) IF (IQUIT.EQ.1) THEN CALL XDLF_DELETE_VIEW_OBJECT (IVH_POPMN, IERR) CALL XDLF_DELETE_VIEW_OBJECT (IVH_POPPT, IERR) CALL XDLF_DELETE_VIEW_OBJECT (IVH_POPFR, IERR) RETURN ELSE CALL OTHERS_UPD (2, UPD_SPD, KPACK, KPLATE) WRITE (PVAL,'(E12.4)') 0.0 CALL LJUST(PVAL) IF (ITEM.EQ.1) THEN DO 120 I = 1, MAX_SPD VAL(1) = 0.0 CALL LDM_SET_SPDX (I, KPACK, KPLATE, VAL, + IERR, ERRSTR) CALL XDLF_PARAM_TABLE_SETVALUE (IVH_POPPT, + JP_SPDX1+I-1, + XDLSTR(PVAL), 15, 0, IERR) 120 CONTINUE ELSE IF (ITEM.EQ.2) THEN DO 130 I = 1, MAX_SPD VAL(1) = 0.0 CALL LDM_SET_SPDY (I, KPACK, KPLATE, VAL, + IERR, ERRSTR) CALL XDLF_PARAM_TABLE_SETVALUE (IVH_POPPT, + JP_SPDY1+I-1, + XDLSTR(PVAL), 15, 0, IERR) 130 CONTINUE ELSE IF (ITEM.EQ.3) THEN DO 140 I = 1, MAX_SPD VAL(1) = 0.0 CALL LDM_SET_SPDX (I, KPACK, KPLATE, VAL, + IERR, ERRSTR) CALL XDLF_PARAM_TABLE_SETVALUE (IVH_POPPT, + JP_SPDX1+I-1, + XDLSTR(PVAL), 15, 0, IERR) 140 CONTINUE DO 150 I = 1, MAX_SPD VAL(1) = 0.0 CALL LDM_SET_SPDY (I, KPACK, KPLATE, VAL, + IERR, ERRSTR) CALL XDLF_PARAM_TABLE_SETVALUE (IVH_POPPT, + JP_SPDY1+I-1, + XDLSTR(PVAL), 15, 0, IERR) 150 CONTINUE ENDIF END IF END IF GO TO 200 C C====== Parameter value error C 800 CALL XDLF_PARAM_TABLE_ERROR (IVH_POPPT, ITEM, + XDLSTR(ERRSTR), LENSTR(ERRSTR), IERR) GO TO 200 END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** EROTMT ** C************************** C C SUBROUTINE EROTMT(ANG,B,A,RMSD) C INCLUDE 'implicit_none.finc' C C Purpose: Use the formulae of the preceding routine to calculate the new C matrix (B), from the rotation angles in degrees (ANG). RMSD returns C the root mean square deviation of new matrix elements from old (A). C C Author: Modified version of M. Elder's routine C C Arguments: C REAL ANG(3) REAL B(3,3) REAL A(3,3) REAL RMSD C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' C C====== FUNCTION TYPES: C C C====== LOCALS: C REAL CX,CY,CZ,RAD,SX,SY,SZ INTEGER I,J C C------------------------------------------------------------------------------- C RAD = 180./3.14159265 CX = COS(ANG(1)/RAD) CY = COS(ANG(2)/RAD) CZ = COS(ANG(3)/RAD) SX = SIN(ANG(1)/RAD) SY = SIN(ANG(2)/RAD) SZ = SIN(ANG(3)/RAD) B(1,1) = CY*CZ B(1,2) = SX*SY*CZ - CX*SZ B(1,3) = CX*SY*CZ + SX*SZ B(2,1) = CY*SZ B(2,2) = SX*SY*SZ + CX*CZ B(2,3) = CX*SY*SZ - SX*CZ B(3,1) = -SY B(3,2) = SX*CY B(3,3) = CX*CY RMSD = 0. DO 30 I = 1 , 3 DO 20 J = 1 , 3 RMSD = (A(I,J)-B(I,J))**2 + RMSD 20 CONTINUE 30 CONTINUE RMSD = SQRT(RMSD/9.) RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** ERR_NOTICE ** C************************** C C SUBROUTINE ERR_NOTICE (ITYP, MESSAGE) C INCLUDE 'implicit_none.finc' C C Purpose: Output a popup notice error/warning message for 'lauegen' with a C 'Continue' box C C Author: John W. Campbell, August 1991 C C Arguments: C INTEGER ITYP CHARACTER*(*) MESSAGE C C ITYP (R) = 0, Position notice at default position (no arrow on notice) C = 1, Position notice at last selected menu item position (arrow C on notice in this case) C = 2, Position notice at last selected menu item position on C autoindexing solutions menu C = 3. position on command window C MESSAGE (R) The error/warning message C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' INCLUDE 'screen_params.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR INTEGER LENSTR C C====== LOCALS: C INTEGER IXROOT INTEGER IYROOT INTEGER IARROW INTEGER IBUTTON C INTEGER IXROOT !X root position for popup notice C INTEGER IYROOT !Y root position for popup notice C INTEGER IARROW !Arrow required flag 0=no, 1=yes C INTEGER IBUTTON !Returns selected button C C------------------------------------------------------------------------------- C C====== Get the required position C CALL NOTICE_POSN (ITYP, IXROOT, IYROOT) C C====== Output the popup notice C IARROW = 0 IF (ITYP.EQ.1) IARROW = 1 CALL XDLF_POPUP_NOTICE (IXROOT, IYROOT, + XDLSTR(MESSAGE), LENSTR(MESSAGE), + XDLSTR(' '), -1, + XDLSTR('Continue'), 8, + XDLSTR(' '), -1, + IFONT, IARROW, IBUTTON) RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** EVANGL ** C************************** C C SUBROUTINE EVANGL(NOBS,IHKL,XC,ANG,RMSD,DEV,SOL,IDET) C INCLUDE 'implicit_none.finc' C C Purpose: On entry have nobs reflections with indices in ihkl. C Observed film coords (mm) are in xc C C Firstly, calculate the standard reciprocal lattice coords C (x) from the indices. C C Author: Modified version of M. Elder's routine C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' C C Arguments: C INTEGER NOBS INTEGER IHKL(3,MAX_AUTO_SPOTS) REAL XC(5,MAX_AUTO_SPOTS) REAL ANG(3) REAL RMSD REAL DEV REAL SOL(3,3) INTEGER IDET C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'lauegen_auto_params.finc' INCLUDE 'film_pack.finc' C C====== FUNCTION TYPES: C C C====== LOCALS: C REAL RF,TH INTEGER I,ICOD,J,K REAL A(3,3),AA(3,3),AAA(3,20),AC1(3,3),AC2(3,3),AC3(3,3),AC4(3,3) REAL AC5(3,3),AC6(3,3),AI(3,3),NEWSOL(3,3),XTMP(3),XX(3) REAL RCELL(6),CCELL(6) REAL CTOF, CELL(6) INTEGER ISYST, IFLAG, ND, IERR CHARACTER*2 VALSTR, ERRSTR C C------------------------------------------------------------------------------- C CALL LDM_GET_CTOF (IPACK, IPLATE, CTOF, IFLAG, ND, IERR, ERRSTR) CALL LDM_GET_A (CELL(1), IFLAG, ND) CALL LDM_GET_B (CELL(2), IFLAG, ND) CALL LDM_GET_C (CELL(3), IFLAG, ND) CALL LDM_GET_ALPHA (CELL(4), IFLAG, ND) CALL LDM_GET_BETA (CELL(5), IFLAG, ND) CALL LDM_GET_GAMMA (CELL(6), IFLAG, ND) CALL RECCEL(RCELL,CELL,1.0) CALL LDM_GET_SYST (VALSTR, ISYST, IFLAG) CALL CELLCX(ISYST,CCELL,RCELL,2,2) DO 10 I = 1,3 DO 5 J=1,3 AA(I,J) = 0.0 5 CONTINUE 10 CONTINUE CALL MATS(AA,AC1,AC2,AC3,AC4,AC5,AC6,CCELL) DO 30 I = 1 , NOBS DO 20 J = 1 , 3 X_AUT(J,I) = AA(J,1)*IHKL(1,I) + AA(J,2)*IHKL(2,I) + + AA(J,3)*IHKL(3,I) 20 CONTINUE DS2_AUT(I) = X_AUT(1,I)**2 + X_AUT(2,I)**2 + X_AUT(3,I)**2 30 CONTINUE C C====== Now calculate the observed reciprocal lattice points (b) C DO 40 I = 1 , NOBS CALL LDM_DTOR (XC(1,I), XC(2,I), DS2_AUT(I), CTOF, + B_AUT(1,I), B_AUT(2,I), B_AUT(3,I)) 40 CONTINUE C C====== Now calculate the x-transpose.x matrix (a) and invert it (ai). C DO 70 I = 1 , 3 DO 60 J = 1 , 3 A(I,J) = 0. DO 50 K = 1 , NOBS A(I,J) = A(I,J) + X_AUT(I,K)*X_AUT(J,K) 50 CONTINUE 60 CONTINUE 70 CONTINUE CALL MINV_AUT(A,AI,ICOD) C C====== If the matrix was not inverted (determinant near zero) C====== return immediately C IF (ICOD.EQ.1) THEN IDET = 2 RETURN END IF C C====== Now store in aaa the (a-transpose.a)inverted.a-transpose matrix C DO 100 I = 1 , 3 DO 90 J = 1 , NOBS AAA(I,J) = 0. DO 80 K = 1 , 3 AAA(I,J) = AAA(I,J) + AI(I,K)*X_AUT(K,J) 80 CONTINUE 90 CONTINUE 100 CONTINUE C C====== Now loop through the 3 sets of simultaneous equations, calculating C====== the 3 vector solutions - stored in sol. C DO 130 I = 1 , 3 DO 120 J = 1 , 3 SOL(I,J) = 0. DO 110 K = 1 , NOBS SOL(I,J) = SOL(I,J) + AAA(J,K)*B_AUT(I,K) 110 CONTINUE 120 CONTINUE 130 CONTINUE C C====== Now unravel the actual rotation angles from the matrix sol. C CALL FNDANG(SOL,ANG,NEWSOL,IDET,RMSD) IF (IDET.EQ.2) RETURN C C====== The rotation matrix derived from these angles is now in newsol. C====== Apply it to get calculated film coordinates to compare with C====== the observed ones. C CALL EVCOOR(NEWSOL,XC,DEV,NOBS,IDET) RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** EVCOOR ** C************************** C C SUBROUTINE EVCOOR(NEWSOL,XC,DEV,NOBS,IDET) C INCLUDE 'implicit_none.finc' C C Purpose: Evaluate the film coords (xc(3-5,i)) from the standard r.l. coords C (x_aut) using the matrix (newsol), and returning rmsdev in dev. C C C Author: Modified version of M. Elder's routine C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' C C Arguments: C REAL NEWSOL(3,3) REAL XC(5,MAX_AUTO_SPOTS) REAL DEV INTEGER NOBS INTEGER IDET C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'lauegen_auto_params.finc' INCLUDE 'film_pack.finc' C C====== FUNCTION TYPES: C LOGICAL LDM_RTOD C C====== LOCALS: C LOGICAL RECORDED REAL XF, YF, XX(3), CT, DSTAR2 REAL RF INTEGER I,J REAL XTMP(3) INTEGER IFLAG, ND, IERR CHARACTER*2 ERRSTR C C------------------------------------------------------------------------------- C DEV = 0. DO 30 I = 1 , NOBS C C====== Change the sign of the 3rd standard r.l. coordinate if det=-1 C IF (IDET.NE.0) THEN XTMP(3) = -X_AUT(3,I) XTMP(2) = -X_AUT(2,I) XTMP(1) = -X_AUT(1,I) ELSE XTMP(3) = X_AUT(3,I) XTMP(2) = X_AUT(2,I) XTMP(1) = X_AUT(1,I) END IF DO 20 J = 1 , 3 XX(J) = NEWSOL(J,1)*XTMP(1) + NEWSOL(J,2)*XTMP(2) + + NEWSOL(J,3)*XTMP(3) 20 CONTINUE RF = DS2_AUT(I)/(2.0*XX(1)) DSTAR2 = DS2_AUT(I) CALL LDM_GET_CTOF (IPACK, IPLATE, CT, IFLAG, ND, + IERR, ERRSTR) RECORDED = LDM_RTOD (XX(1), XX(2), XX(3), DSTAR2, CT, + XF, YF) XC(3,I) = XF XC(4,I) = YF XC(5,I) = -RF + XX(1) DEV = (XC(3,I)-XC(1,I))**2 + (XC(4,I)-XC(2,I))**2 + DEV 30 CONTINUE DEV = SQRT(DEV/NOBS) RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** EXAMINE_SPOTS ** C************************** C C SUBROUTINE EXAMINE_SPOTS C INCLUDE 'implicit_none.finc' C C Purpose: Examine individual spots after integration C C Author: John W. Campbell, January 1996 C C Arguments: C C None C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'film_pack.finc' INCLUDE 'lirl_pars.finc' INCLUDE 'symbol_types.finc' INCLUDE 'image.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR C C====== LOCALS: C LOGICAL IMG_DISP LOGICAL RESET_PLATE LOGICAL NODF LOGICAL SPAT LOGICAL BAD LOGICAL OVL INTEGER M_SHOW INTEGER M_SELI INTEGER M_INDX INTEGER M_DISMISS INTEGER IPACK_SAV INTEGER IPLATE_SAV INTEGER LISTE(2) INTEGER NVIEW INTEGER IVHLIST(2) INTEGER IVH INTEGER ITEM INTEGER IQUIT INTEGER IERR INTEGER NUMSPOTS INTEGER IXPIX INTEGER IYPIX INTEGER IH INTEGER IK INTEGER IL INTEGER MULT INTEGER I INTEGER ISPOT INTEGER IXSPOT INTEGER IYSPOT INTEGER JH INTEGER JK INTEGER JL INTEGER NVALS INTEGER IVHLST2(2) REAL XFD REAL YFD REAL BLAM REAL DTHR REAL DSQMIN REAL DSQ REAL VALUES(20) CHARACTER*25 NAMES(4) CHARACTER*25 QUITNAM CHARACTER*80 ERRSTR CHARACTER*25 STR C LOGICAL IMG_DISP !Image is currently displayed flag C LOGICAL RESET_PLATE !Plate reset flag C LOGICAL NODF !OK nodal flag C LOGICAL SPAT !Spatially overlapped flag C LOGICAL BAD !Bad spot flag C LOGICAL OVL !Overload flag C INTEGER M_SHOW !Menu item no.: Show Image C INTEGER M_SELI !Menu item no.: Select From Image C INTEGER M_INDX !Menu item no.: Select By Index C INTEGER M_DISMISS !Menu item no.: Dismiss Image C INTEGER IPACK_SAV !Save current pack C INTEGER IPLATE_SAV !Save current plate C INTEGER LISTE(2) !List of parameter table entries to be updated C INTEGER NVIEW !No. of view-objects for getting events C INTEGER IVHLIST(2) !List of view-object handles for getting events C INTEGER IVH !Returned view-object handle from getting events C INTEGER ITEM !Item no. from menu selection C INTEGER IQUIT !Quit button flage from menu C INTEGER IERR !Error flag C INTEGER NUMSPOTS !No. of spots in LRL C INTEGER IXPIX !'x' pixel position of selected spot C INTEGER IYPIX !'y' pixel position of selected spot C INTEGER IH !'h' index C INTEGER IK !'k' index C INTEGER IL !'l' index C INTEGER MULT !Multiplicity C INTEGER I !Temp/loop variable C INTEGER ISPOT !Spot number C INTEGER IXSPOT !Spot 'x' pixel position on image (predicted) C INTEGER IYSPOT !Spot 'y' pixel position on image (predicted) C INTEGER JH !Requested reflection 'h' index C INTEGER JK !Requested reflection 'k' index C INTEGER JL !Requested reflection 'l' index C INTEGER NVALS !No. of input values C INTEGER IVHLST2(2) !2'nd list of view-object handles C REAL YFD !yf position of spot C REAL BLAM !Lambda value of spot C REAL DTHR !Dminthresholds2 value of spot C REAL DSQMIN !Distance squared check C REAL DSQ !Distance squared from sel. posn to predicted spot C REAL VALUES(20) !Numerical values from input string C CHARACTER*25 NAMES(4) !Menu item names C CHARACTER*25 QUITNAM !Quit button string C CHARACTER*80 ERRSTR !Error string C CHARACTER*25 STR !Input string DATA NAMES /'Show Image', + 'Select From Image', + 'Select By Index', + 'Dismiss Image'/ DATA QUITNAM /'Return to Previous Menu'/ C C------------------------------------------------------------------------------- C C C====== Set up & process menu C M_SHOW = 1 M_SELI = 2 M_INDX = 3 M_DISMISS = 4 IMG_DISP = .FALSE. RESET_PLATE = .FALSE. IF (INTEG_LASTPK.NE.IPACK.OR.INTEG_LASTPL.NE.IPLATE) THEN IPACK_SAV = IPACK IPLATE_SAV = IPLATE IPACK = INTEG_LASTPK IPLATE = INTEG_LASTPL CALL SET_PAR1_VALS (0, LISTE) CALL SET_PAR2_VALS (0, LISTE) END IF CALL LRL_GEN (IPACK, IPLATE, .FALSE., 2, IERR, ERRSTR) CALL LRL_NUMSPOTS (NUMSPOTS) IF (NUMSPOTS.EQ.0) THEN CALL ERR_NOTICE (1, '**No predicted spots**') IF (RESET_PLATE) THEN IPACK = IPACK_SAV IPLATE = IPLATE_SAV CALL SET_PAR1_VALS (0, LISTE) CALL SET_PAR2_VALS (0, LISTE) END IF RETURN END IF C C====== Set up list of view-object handles C NVIEW = 1 IVHLIST(1) = IVH_MENU IVHLIST(2) = IVH_FILM 50 CALL XDLF_MENU_AREA_SETMENU (IVH_MENU, 4, XDLSTR(NAMES), 25, + XDLSTR('Examine Spots Menu'), 18, + XDLSTR(QUITNAM), 25, 0, IERR) C C C====== Start event loop C 100 CALL XDLF_GET_EVENTS (NVIEW, IVHLIST, IVH) IF (IVH.EQ.IVH_MENU) THEN C C====== Menu item selected C CALL XDLF_MENU_AREA_GETITEM (IVH_MENU, ITEM, IQUIT) C C====== Quit selected C IF (IQUIT.EQ.1) THEN IF (RESET_PLATE) THEN IPACK = IPACK_SAV IPLATE = IPLATE_SAV CALL SET_PAR1_VALS (0, LISTE) CALL SET_PAR2_VALS (0, LISTE) END IF IF (IMG_DISP) CALL XDLF_DELETE_VIEW_OBJECT (IVH_FILM, IERR) RETURN END IF C C====== Show Image C IF (ITEM.EQ.M_SHOW) THEN NVIEW = 1 IF (IMG_DISP) THEN CALL XDLF_IMAGE_CLEAR_SYMBOLS (IVH_FILM, IERR) GO TO 100 END IF CALL SHOW_IMAGE (1, IERR) IF (IERR.NE.0) GO TO 50 IMG_DISP = .TRUE. GO TO 100 C C====== Select From Image C ELSE IF (ITEM.EQ.M_SELI) THEN IF (.NOT.IMG_DISP) THEN CALL SHOW_IMAGE (1, IERR) IF (IERR.NE.0) GO TO 50 IMG_DISP = .TRUE. END IF CALL XDLF_IMAGE_INPUT_MESSAGE (IVH_FILM, * XDLSTR('Input Spot Position'), 19, IERR) NVIEW = 2 GO TO 100 C C====== Select By Index C ELSE IF (ITEM.EQ.M_INDX) THEN IF (IMG_DISP) THEN CALL XDLF_IMAGE_CLEAR_SYMBOLS (IVH_FILM, IERR) CALL XDLF_VIEW_OBJECT_RAISE (IVH_BASE, IERR) END IF NVIEW = 1 150 CALL LPROMPT (IVH_IOW, 'Reflection Indices: ') IVHLST2(1) = IVH_IOW CALL XDLF_GET_EVENTS (1, IVHLST2, I) CALL XDLF_IO_WINDOW_GETSTRING (IVH_IOW, XDLSTR(STR), + 25, IERR) CALL STRVAL (STR, ' ,', 20, VALUES, NVALS) IF (NVALS.EQ.0) THEN IF (IMG_DISP) THEN CALL XDLF_VIEW_OBJECT_RAISE (IVH_FILM, IERR) END IF GO TO 100 END IF IF (NVALS.NE.3) THEN CALL LMESSAGE(IVH_IOW,'**Invalid indices**') GO TO 150 END IF JH = NINT(VALUES(1)) JK = NINT(VALUES(2)) JL = NINT(VALUES(3)) ISPOT = 0 DO 160 I = 1, NUMSPOTS CALL LRL_GET (I, IH, IK, IL, XFD, YFD, BLAM, DTHR, + MULT, NODF, SPAT, IERR) IF (IH.EQ.JH.AND.IK.EQ.JK.AND.IL.EQ.JL) THEN ISPOT = I IXSPOT = NINT(XFD) IYSPOT = NINT(YFD) GO TO 170 END IF 160 CONTINUE CALL ERR_NOTICE (1, + '**Reflection not found in predicted spots list**') IF (IMG_DISP) THEN CALL XDLF_VIEW_OBJECT_RAISE (IVH_FILM, IERR) END IF GO TO 100 170 IF (IMG_DISP) THEN CALL XDLF_VIEW_OBJECT_RAISE (IVH_FILM, IERR) CALL XDLF_IMAGE_SYMBOL (IVH_FILM, IXSPOT, IYSPOT, + ISYMBTYP(11), ICOLRTYP(11), 1, IERR) END IF CALL INTEG_SINGSPOT (ISPOT, IMG_DISP) GO TO 50 C C====== Dismiss Image C ELSE IF (ITEM.EQ.M_DISMISS) THEN IF (.NOT.IMG_DISP) GO TO 100 CALL XDLF_DELETE_VIEW_OBJECT (IVH_FILM, IERR) IMG_DISP = .FALSE. NVIEW = 1 GO TO 100 END IF GO TO 100 C C====== Input from image C ELSE IF (IVH.EQ.IVH_FILM) THEN CALL XDLF_IMAGE_GETPIX (IVH_FILM, IXPIX, IYPIX, IERR) CALL XDLF_IMAGE_CLEAR_SYMBOLS (IVH_FILM, IERR) ISPOT = 0 DSQMIN = 18.0*NCMP*NCMP DO 200 I = 1, NUMSPOTS CALL LRL_GET (I, IH, IK, IL, XFD, YFD, BLAM, DTHR, + MULT, NODF, SPAT, IERR) DSQ = (IXPIX-XFD)*(IXPIX-XFD) + (IYPIX-YFD)*(IYPIX-YFD) IF (DSQ.LT.DSQMIN) THEN ISPOT = I IXSPOT = NINT(XFD) IYSPOT = NINT(YFD) DSQMIN = DSQ END IF 200 CONTINUE IF (ISPOT.EQ.0) THEN CALL ERR_NOTICE (0, + '**No predicted spot close to selected position**') GO TO 100 END IF CALL XDLF_IMAGE_SYMBOL (IVH_FILM, IXSPOT, IYSPOT, + ISYMBTYP(11), ICOLRTYP(11), 1, IERR) CALL INTEG_SINGSPOT (ISPOT, IMG_DISP) GO TO 50 END IF GO TO 100 END C LAST UPDATE: C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C******************************* C** FACTOR_INDEX ** C******************************* C C SUBROUTINE FACTOR_INDEX (H, K, L) C INCLUDE 'implicit_none.finc' C C Purpose: To factor out the HCF of 3 indices. C C Author: Based on code from GENLAUE by Clifton et al. C C Arguments: C INTEGER H INTEGER K INTEGER L C C H (M) h index C K (M) k index C L (M) l index C C====== FUNCTION TYPES: C INTEGER HCF C C====== LOCALS: C INTEGER HCF1, HCF2 C C------------------------------------------------------------------------------ C HCF1 = HCF(H,K) HCF2 = HCF(HCF1,L) H = H/HCF2 K = K/HCF2 L = L/HCF2 RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** FILM_CENTRE ** C************************** C C SUBROUTINE FILM_CENTRE (X_CEN_F,Y_CEN_F,OMEGA) C INCLUDE 'implicit_none.finc' C C Purpose: Check/get film centre from fids or input values C C Author: John W. Campbell, January 1992 C C **** Assumes that CHK_OPN has been called previously **** C C Arguments: C REAL X_CEN_F REAL Y_CEN_F REAL OMEGA C C X_CEN_F (W) X centre position (raster units) C Y_CEN_F (W) Y centre position (raster units) C OMEGA (W) Omega offset (degrees) (Now all contained in W_C) C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' INCLUDE 'screen_params.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'ip2_entries.finc' INCLUDE 'prog_flags.finc' INCLUDE 'film_pack.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR C C====== LOCALS: C INTEGER IXROOT INTEGER IYROOT INTEGER IRETN INTEGER IFLAG INTEGER ND INTEGER IERR INTEGER IFID INTEGER NXRAST INTEGER NYRAST INTEGER LISTE(2) REAL F_THRESH CHARACTER*2 VALSTR CHARACTER*2 ERRSTR CHARACTER*80 STR C C INTEGER IXROOT !Root X position for pop-up notice C INTEGER IYROOT !Root Y position for pop-up notice C INTEGER IRETN !Return flag from pop-up notice C INTEGER IFLAG !Parameter status flag C INTEGER ND !Number of decimal places flag C INTEGER IERR !Error flag C INTEGER IFID !Fiducials present flag C INTEGER NXRAST !No. of x-rasters C INTEGER NYRAST !No. of y-rasters C INTEGER LISTE(2) !Parameters reset flags C REAL F_THRESH !Fiducials threshold C CHARACTER*2 VALSTR !Parameter value string (dummy) C CHARACTER*2 ERRSTR !Error string (dummy) C CHARACTER*80 STR !Message string C C------------------------------------------------------------------------------- C CALL LDM_GET_XCENF (IPACK, IPLATE, X_CEN_F, IFLAG, ND, + IERR, ERRSTR) CALL LDM_GET_YCENF (IPACK, IPLATE, Y_CEN_F, IFLAG, ND, + IERR, ERRSTR) IF (X_CEN_F.GT.0.0.AND.Y_CEN_F.GT.0.0) THEN CALL LDM_GET_WC (IPACK, IPLATE, OMEGA, IFLAG, ND, + IERR, ERRSTR) RETURN END IF CALL LDM_GET_FIDT (VALSTR, IFID, IFLAG) IF (IFID.EQ.1) THEN CALL LDM_GET_FTHR (F_THRESH, IFLAG, ND) CALL GET_FIDS (F_THRESH, IERR) CALL LDM_GET_XCENF (IPACK, IPLATE, X_CEN_F, IFLAG, ND, + IERR, ERRSTR) CALL LDM_GET_YCENF (IPACK, IPLATE, Y_CEN_F, IFLAG, ND, + IERR, ERRSTR) ELSE STR = '*Warning* Using image mid-point as centre for pack' CALL STR_ADDI (STR, IPACK, 1) CALL STR_ADDS (STR, ', plate',0) CALL STR_ADDI (STR, IPLATE, 1) CALL LOG_MSG (IVH_IOW, STR, 1) CALL LDM_GET_NXRAS (NXRAST, IFLAG) CALL LDM_GET_NYRAS (NYRAST, IFLAG) X_CEN_F = NXRAST/2.0 Y_CEN_F = NYRAST/2.0 CALL LDM_SET_XCENF (IPACK, IPLATE, X_CEN_F, IERR, ERRSTR) CALL LDM_SET_YCENF (IPACK, IPLATE, Y_CEN_F, IERR, ERRSTR) IF (LG_MODE.EQ.1) THEN LISTE(1) = IP_XCENF LISTE(2) = IP_YCENF CALL SET_PAR2_VALS(2, LISTE) END IF END IF CALL LDM_GET_WC (IPACK, IPLATE, OMEGA, IFLAG, ND, + IERR, ERRSTR) RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** FIND_SEL_NODS ** C************************** C C SUBROUTINE FIND_SEL_NODS (ITYP, IRAISE, IOPT, IHIST, IHM, + IKM, ILM) C INCLUDE 'implicit_none.finc' C C Purpose: Find nodal reflections and select index for nodal C selection for refinement etc. C C Author: Based on code from FIND_NODALS from GENLAUE by Clifton et al. C C Arguments: C INTEGER ITYP INTEGER IRAISE INTEGER IOPT INTEGER IHIST INTEGER IHM, IKM, ILM C C ITYP (R) Flag =1 using main base frame / io-window C =2 using auto-indexing solutions base frame / io-window C IRAISE (R) Flag =0 no raising of windows required C =1 raise I/O window at start and film-image at end C IOPT (R) Option flag = 0 Use h,k,l limits given C = 1 Request input of nodal index limit C = 2 Request input of nodal h, k, l limits C IHIST (R) Histogram flag = 0 Do not display nodals histogram C = 1 Display nodals histogram C IHM, IKM, ILM (R) Nodal index maxima for h, k, l (only used if IOPT=0) C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'lauegen_observed_spots.finc' INCLUDE 'selrefs.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR INTEGER NBITST INTEGER NODAL_INDEX INTEGER HCF C C====== LOCALS: C LOGICAL SPAT, NODFLG INTEGER JH, JK, JL INTEGER OFFSET INTEGER IVH_IOW_USE INTEGER IVH_BASE_USE INTEGER NODALS(2*MAX_HKL_LIMIT+1, 2*MAX_HKL_LIMIT+1, + 2*MAX_HKL_LIMIT+1) INTEGER I, J, SEL_NODAL_HKL INTEGER SEL_NODAL_H, SEL_NODAL_K, SEL_NODAL_L INTEGER H, K, L, HCF1, HCF2 INTEGER NODAL_HIST(20) INTEGER NOD_IDX INTEGER NUMSPOTS INTEGER IERR INTEGER NL, NLIN INTEGER MULT REAL XFD, YFD, ALAM, DTHR2 CHARACTER*80 STR C C------------------------------------------------------------------------------ C C====== Initialisations C CALL LRL_NUMSPOTS (NUMSPOTS) IVH_IOW_USE = IVH_IOW IF (ITYP.EQ.2) IVH_IOW_USE = IVH_IOW_AUT IVH_BASE_USE = IVH_BASE IF (ITYP.EQ.2) IVH_BASE_USE = IVH_BASE_AUT SEL_NODAL_H = IABS(IHM) SEL_NODAL_K = IABS(IKM) SEL_NODAL_L = IABS(ILM) IF (SEL_NODAL_H.GT.MAX_HKL_LIMIT) SEL_NODAL_H = MAX_HKL_LIMIT IF (SEL_NODAL_K.GT.MAX_HKL_LIMIT) SEL_NODAL_K = MAX_HKL_LIMIT IF (SEL_NODAL_L.GT.MAX_HKL_LIMIT) SEL_NODAL_K = MAX_HKL_LIMIT OFFSET=MAX_HKL_LIMIT+1 DO 20 I = 1 , MAX_HKL_LIMIT NODAL_HIST(I) = 0 20 CONTINUE C C====== Clear array of pointers C DO 50 K = 1 , 2*MAX_HKL_LIMIT+1 DO 40 J = 1 , 2*MAX_HKL_LIMIT+1 DO 30 I = 1 , 2*MAX_HKL_LIMIT+1 NODALS(I,J,K) = 0 30 CONTINUE 40 CONTINUE 50 CONTINUE C C====== Find the nodals C IF (NUMSPOTS.GT.0) THEN DO 60 I = 1 , NUMSPOTS CALL LRL_GET (I, JH, JK, JL, XFD, YFD, ALAM, + DTHR2, MULT, NODFLG, SPAT, IERR) H = JH K = JK L = JL NOD_IDX = NODAL_INDEX(H,K,L) IF (NOD_IDX.LE.MAX_HKL_LIMIT) THEN C C====== Check if it was a spatial C IF (.NOT.SPAT) THEN C C====== Found a nodal! C CALL FACTOR_INDEX(H,K,L) IF (NODALS(H+OFFSET,K+OFFSET,L+OFFSET).EQ.0) THEN C C====== Inc the histogram (but count distinct nodals) C====== -------- C NODAL_HIST(NOD_IDX) = NODAL_HIST(NOD_IDX) + 1 END IF NODALS(H+OFFSET,K+OFFSET,L+OFFSET) = I END IF END IF 60 CONTINUE END IF IF (IRAISE.EQ.1) CALL XDLF_VIEW_OBJECT_RAISE (IVH_BASE_USE, + IERR) C C====== Calc cumulative totals C DO 70 I = 1 , MAX_HKL_LIMIT - 1 NODAL_HIST(I+1) = NODAL_HIST(I+1) + NODAL_HIST(I) 70 CONTINUE C C====== Output histogram if required C IF (IHIST.EQ.1) THEN CALL LMESSAGE(IVH_IOW_USE,'Histogram of nodal spots') CALL LMESSAGE(IVH_IOW_USE,'========================') NLIN = (MAX_HKL_LIMIT+3)/4 I = 0 DO 80 NL = 1, NLIN K = 1 STR = ' ' DO 75 J = 1, 4 I = I + 1 IF (I.LE.MAX_HKL_LIMIT) THEN CALL STR_ADDI(STR(K:),I,0) IF (I.LT.10) THEN CALL STR_ADDI(STR(K:),NODAL_HIST(I),3) ELSE CALL STR_ADDI(STR(K:),NODAL_HIST(I),2) END IF END IF K = K + 15 75 CONTINUE CALL LMESSAGE(IVH_IOW_USE,STR) 80 CONTINUE END IF C C====== Input selection criteria if required C IF (IOPT.EQ.1) THEN 90 SEL_NODAL_HKL = 4 CALL IOW_ASKI(IVH_IOW_USE,'Nodal spot selection index', + SEL_NODAL_HKL) IF (SEL_NODAL_HKL.LT.1) THEN CALL LMESSAGE(IVH_IOW_USE,'**Must be greater than 0**') GO TO 90 END IF IF (SEL_NODAL_HKL.GT.MAX_HKL_LIMIT) THEN STR = '**Must be less than or equal to' CALL STR_ADDI(STR,MAX_HKL_LIMIT,1) CALL STR_ADDS(STR,'**',0) CALL LMESSAGE(IVH_IOW_USE,STR) GO TO 90 END IF SEL_NODAL_H = SEL_NODAL_HKL SEL_NODAL_K = SEL_NODAL_HKL SEL_NODAL_L = SEL_NODAL_HKL ELSE IF (IOPT.EQ.2) THEN 92 SEL_NODAL_H = 4 CALL IOW_ASKI(IVH_IOW_USE,'Nodal spot selection h index', + SEL_NODAL_H) IF (SEL_NODAL_H.LT.1) THEN CALL LMESSAGE(IVH_IOW_USE,'**Must be greater than 0**') GO TO 92 END IF IF (SEL_NODAL_H.GT.MAX_HKL_LIMIT) THEN STR = '**Must be less than or equal to' CALL STR_ADDI(STR,MAX_HKL_LIMIT,1) CALL STR_ADDS(STR,'**',0) CALL LMESSAGE(IVH_IOW_USE,STR) GO TO 92 END IF 94 SEL_NODAL_K = 4 CALL IOW_ASKI(IVH_IOW_USE,'Nodal spot selection k index', + SEL_NODAL_K) IF (SEL_NODAL_K.LT.1) THEN CALL LMESSAGE(IVH_IOW_USE,'**Must be greater than 0**') GO TO 94 END IF IF (SEL_NODAL_K.GT.MAX_HKL_LIMIT) THEN STR = '**Must be less than or equal to' CALL STR_ADDI(STR,MAX_HKL_LIMIT,1) CALL STR_ADDS(STR,'**',0) CALL LMESSAGE(IVH_IOW_USE,STR) GO TO 94 END IF 96 SEL_NODAL_L = 4 CALL IOW_ASKI(IVH_IOW_USE,'Nodal spot selection l index', + SEL_NODAL_L) IF (SEL_NODAL_L.LT.1) THEN CALL LMESSAGE(IVH_IOW_USE,'**Must be greater than 0**') GO TO 96 END IF IF (SEL_NODAL_L.GT.MAX_HKL_LIMIT) THEN STR = '**Must be less than or equal to' CALL STR_ADDI(STR,MAX_HKL_LIMIT,1) CALL STR_ADDS(STR,'**',0) CALL LMESSAGE(IVH_IOW_USE,STR) GO TO 96 END IF END IF C C====== Now assign found nodal spots to the sel_nodals vector C NUM_SELECT = 0 DO 120 K = OFFSET - SEL_NODAL_H , OFFSET + SEL_NODAL_H DO 110 J = OFFSET - SEL_NODAL_K , OFFSET + SEL_NODAL_K DO 100 I = OFFSET - SEL_NODAL_L , OFFSET + SEL_NODAL_L IF (NODALS(I,J,K).NE.0) THEN NUM_SELECT = NUM_SELECT + 1 IF (NUM_SELECT.LE.MAX_OBS) THEN SEL_REFS(NUM_SELECT) = NODALS(I,J,K) END IF IF (NUM_SELECT.EQ.MAX_OBS+1) THEN STR = '**Number of refinement'// + ' reflections truncated to' CALL STR_ADDI(STR,MAX_OBS,1) CALL STR_ADDS(STR,'**',0) CALL ERR_NOTICE(0,STR) END IF END IF 100 CONTINUE 110 CONTINUE 120 CONTINUE NUM_SELECT = MIN(NUM_SELECT,MAX_OBS) WRITE (STR,'(I8)') NUM_SELECT CALL LJUST(STR) CALL STR_ADDS(STR,'nodal spots',1) CALL LMESSAGE(IVH_IOW_USE,STR) IF (IRAISE.EQ.1) CALL XDLF_VIEW_OBJECT_RAISE (IVH_FILM, IERR) RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** FNDANG ** C************************** C C SUBROUTINE FNDANG(A,ANG,B,IDET,RMSD) C INCLUDE 'implicit_none.finc' C C Purpose: Find missetting angles C C====== A contains a matrix with the following form C C====== cy.cz sx.sy.cz - cx.sz cx.sy.cz + sx.sz C C====== cy.sz sx.sy.sz + cx.cz cx.sy.sz - sx.cz C C====== -sy sx.cy cx.cy C C====== and on return ang should contain the corresponding angles - x,y,z C====== cy stands for cos(y), etc. C C Author: Modified version of M. Elder's routine C C Arguments: C REAL A(3,3) REAL ANG(3) REAL B(3,3) INTEGER IDET REAL RMSD C C IDET = 0 OK C = 1 Determinant was -1 so matrix signs were reversed C = 2 Transformation matrix not a true rotation matrix C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' C C====== FUNCTION TYPES: C C C====== LOCALS: C LOGICAL ADJUST REAL ADET,CON,CY,DET,PI,SY,X,XMZ,XPZ,Y,Z INTEGER I,J C C------------------------------------------------------------------------------- C PI = 3.14159265 C C====== First check for det=1 for true rotation matrix C IDET = 0 DET = A(1,1)*A(2,2)*A(3,3) + A(1,2)*A(2,3)*A(3,1) + A(1,3)*A(2,1) + *A(3,2) - A(1,2)*A(2,1)*A(3,3) - A(1,1)*A(2,3)*A(3,2) + - A(1,3)*A(2,2)*A(3,1) ADET = ABS(DET) IF (ABS(1.0-ADET).GT.0.1) THEN IDET = 2 RETURN END IF IF (DET.LT.0.0) THEN DO 30 I = 1 , 3 DO 20 J = 1 , 3 A(I,J) = -A(I,J) 20 CONTINUE 30 CONTINUE IDET = 1 END IF C C====== Evaluate y from a(3,1): range -pi/2 to +pi/2 C====== There is an ambiguity since pi-y gives same sin, but this is C====== taken care of by x and z each +pi C ANG(2) = ASIN(-A(3,1)) C C====== Guard against cy very close to zero C IF ((1.-ABS(A(3,1))).GT.0.001) THEN ANG(1) = ATAN2(A(3,2),A(3,3)) ANG(3) = ATAN2(A(2,1),A(1,1)) XPZ = ATAN2(-(A(1,2)+A(2,3)),-(A(1,3)-A(2,2))) XMZ = ATAN2((A(1,2)-A(2,3)),(A(1,3)+A(2,2))) X = 0.5*(XPZ+XMZ) Z = 0.5*(XPZ-XMZ) IF (ABS(ANG(1)-X).GT.0.1) THEN IF (ANG(1).GT.X) CON = PI IF (ANG(1).LT.X) CON = -PI X = X + CON END IF IF (ABS(ANG(3)-Z).GT.0.1) THEN IF (ANG(3).GT.Z) CON = PI IF (ANG(3).LT.Z) CON = -PI Z = Z + CON END IF ANG(1) = 0.5*(ANG(1)+X) ANG(3) = 0.5*(ANG(3)+Z) C C====== Adjust angle 2 unless special cases of ANG(1) & ANG(3) with C====== zero sines or cosines (Extra check put in by jwc 31/1/96) C ADJUST = .TRUE. IF (ABS(SIN(ANG(1))).LT.0.00001) ADJUST = .FALSE. IF (ABS(COS(ANG(1))).LT.0.00001) ADJUST = .FALSE. IF (ABS(SIN(ANG(3))).LT.0.00001) ADJUST = .FALSE. IF (ABS(COS(ANG(3))).LT.0.00001) ADJUST = .FALSE. IF (ABS(SIN(ANG(1)+ANG(3))).LT.0.00001) ADJUST = .FALSE. IF (ABS(COS(ANG(1)+ANG(3))).LT.0.00001) ADJUST = .FALSE. IF (ADJUST) THEN CY = 0.25*(A(3,3)/COS(ANG(1))+A(3,2)/SIN(ANG(1))+A(1,1) + /COS(ANG(3))+A(2,1)/SIN(ANG(3))) SY = 0.5*((A(1,2)+A(2,3))/SIN(ANG(1)+ANG(3)) + +1+(A(1,3)-A(2,2))/COS(ANG(1)+ANG(3))+1) Y = ATAN2(SY,CY) ANG(2) = (ANG(2)+2.*Y)/3. END IF ELSE IF (A(3,1).LT.0.0) THEN C C====== This is the case when y=pi/2, sy=1, cy=0. The top right 2*2 of the C====== a matrix has terms s(x-z),c(x-z)/c(x-z),-s(x-z). Assume z=0. C====== ( lt above changed from gt by Pella Aug 86) C ANG(1) = ATAN2((A(1,2)-A(2,3)),(A(1,3)+A(2,2))) ANG(3) = 0. ELSE C C====== This is the case when y=-pi/2, sy=-1, cy=0. The top right 2*2 of C====== the a matrix has terms -s(x+z),-c(x+z)/c(x+z),-s(x+z). Assume z=0. C ANG(1) = ATAN2((-A(1,2)-A(2,3)),(-A(1,3)+A(2,2))) ANG(3) = 0. END IF C C====== Evaluate the true rotation matrix, angles in degrees. C DO 40 I = 1 , 3 ANG(I) = ANG(I)*180./PI 40 CONTINUE CALL EROTMT(ANG,B,A,RMSD) RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** GDIST_FN ** C************************** C C SUBROUTINE GDIST_FN (M,N,FVECC,X) C INCLUDE 'implicit_none.finc' C C Purpose: Calculate distances of points from lines for gnomonic centre C determination C C Author: John W. Campbell, February 1993 C C Arguments: C INTEGER M INTEGER N DOUBLE PRECISION FVECC(M) DOUBLE PRECISION X(N) C C M (R) No. of observations C N (R) No. of parameters C FVECC (W) The M calculated function values C X (R) The current parameter values C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'film_pack.finc' INCLUDE 'conics.finc' C C====== FUNCTION TYPES: C C C====== LOCALS: C INTEGER I INTEGER J INTEGER IFLAG INTEGER ND INTEGER IERR REAL MM_RAST_X REAL MM_RAST_Y REAL CTOF DOUBLE PRECISION R DOUBLE PRECISION RR DOUBLE PRECISION TWOTH DOUBLE PRECISION THG DOUBLE PRECISION XG(3) DOUBLE PRECISION YG(3) DOUBLE PRECISION Q DOUBLE PRECISION CRHO DOUBLE PRECISION SRHO DOUBLE PRECISION PIOV2 CHARACTER*2 ERRSTR C INTEGER I !Loop variable (over observations) C INTEGER J !Loop variable (over set of 3 points) C INTEGER IFLAG !Parameter status flag C INTEGER ND !No. of decimal places flag C INTEGER IERR !Error flag C REAL MM_RAST_X !Conversion factor mm to x-rasters C REAL MM_RAST_Y !Conversion factor mm to y-rasters C REAL CTOF !Crystal-film distance C DOUBLE PRECISION R !Distance of centre of unconverted spot C DOUBLE PRECISION RR !Distance from centre of converted spot C DOUBLE PRECISION TWOTH !2*theta value of spot C DOUBLE PRECISION THG !90-theta value for gnomonic coords. C DOUBLE PRECISION XG(3) !Gnomonic 'x' coords of line and point C DOUBLE PRECISION YG(3) !Gnomonic 'y' coords of line and point C DOUBLE PRECISION Q !Distance between end points of line C DOUBLE PRECISION CRHO !cos(rho) (rho = rotation angle of line wrt x) C DOUBLE PRECISION SRHO !sin(rho) C DOUBLE PRECISION PIOV2 !Pi/2.0 C CHARACTER*2 ERRSTR !Error string (dummy) C DATA PIOV2/1.5707963/ C C------------------------------------------------------------------------------- C C C====== Three points are associated with each line; points 1 and 3 are the C====== end points; point 2 is the point whose distance from the line is C====== determined for the minimisation to get the best centre position. C CALL LDM_GET_CTOF (IPACK, IPLATE, CTOF, IFLAG, ND, IERR, ERRSTR) CALL LDM_MMRAST (IPACK, IPLATE, MM_RAST_X, MM_RAST_Y) DO 20 I = 1, M DO 10 J = 1,3 R = SQRT((XCONIC(J,I)-X(1))**2 + (YCONIC(J,I)-X(2))**2) TWOTH = ATAN (R/(CTOF*MM_RAST_X)) THG = PIOV2 - TWOTH/2.0 RR = CTOF*MM_RAST_X*TAN(THG) XG(J) = X(1) + (XCONIC(J,I)-X(1))*RR/R YG(J) = X(2) + (YCONIC(J,I)-X(2))*RR/R 10 CONTINUE Q = SQRT((XG(3)-XG(1))**2+(YG(3)-YG(1))**2) CRHO = (XG(3)-XG(1))/Q SRHO = (YG(3)-YG(1))/Q FVECC(I) = (YG(2)-YG(1))*CRHO - (XG(2)-XG(1))*SRHO 20 CONTINUE RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** GET_FIDS ** C************************** C C SUBROUTINE GET_FIDS (F_THRESH, IERR) C INCLUDE 'implicit_none.finc' C C Purpose: Get fids (if required and not already found) for current film/plate C C Author: John W. Campbell, January 1992 C C Arguments: C REAL F_THRESH INTEGER IERR C C F_THRESH (R) Starting threshold for fids search C IERR (W) Error flag =0 OK, C =1 Found on retry C =2 Found on 2'nd retry C =3 Not found or other error (centre set to C image mid point) C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'ip2_entries.finc' INCLUDE 'prog_flags.finc' INCLUDE 'file_units.finc' INCLUDE 'film_pack.finc' INCLUDE 'spot_data.finc' INCLUDE 'image.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR INTEGER LENSTR C C====== LOCALS: C INTEGER KERR INTEGER I INTEGER NF_FID INTEGER ITHRESH INTEGER NOVER INTEGER IXC INTEGER IYC INTEGER IXSIZ INTEGER IYSIZ INTEGER IVAL INTEGER IFLAG INTEGER ND INTEGER NXRAST INTEGER NYRAST INTEGER NF_OFF INTEGER JERR INTEGER LISTE(3) INTEGER IORD INTEGER ISWAP INTEGER NTRIES REAL FIDBOX REAL RASTER REAL FIDX(3) REAL FIDY(3) REAL FIDX1 REAL FIDY1 REAL FIDX2 REAL FIDY2 REAL FIDX3 REAL FIDY3 REAL X_CEN_F REAL Y_CEN_F REAL W_F REAL CGX REAL CGY REAL BOX REAL F_THR REAL MM_RAST_X REAL MM_RAST_Y REAL XHALF REAL YHALF CHARACTER*80 STR CHARACTER*2 VALSTR CHARACTER*2 ERRSTR C INTEGER KERR !Error flag C INTEGER I !Temp/loop variable C INTEGER NF_FID !No. of fids found C INTEGER ITHRESH !Threshold for fids search C INTEGER NOVER !No. pixel values over theshold C INTEGER IXC !Pixel x centre of search box C INTEGER IYC !Pixel y centre of search box C INTEGER IXSIZ !Half size x of search box C INTEGER IYSIZ !Half size y of search box C INTEGER IVAL !Integer parameter value C INTEGER IFLAG !Parameter status flag C INTEGER ND !Number of decimal places flag C INTEGER NXRAST !No. x-rasters C INTEGER NYRAST !No. y-rasters C INTEGER NF_OFF !Offset between start of slow rasters in image C INTEGER JERR !Error flag C INTEGER LISTE(3) !Parameter reset flags C INTEGER IORD !Axis order flag 1-8 C INTEGER ISWAP !Byte swap flag C INTEGER NTRIES !No. of tries at finding fiducials C REAL FIDBOX !Fids box size in mm. C REAL RASTER !Raster size (microns) C REAL FIDX(3) !Found fid x positions C REAL FIDY(3) !Found fid y positions C REAL FIDX1 !Fiducial search positions C REAL FIDY1 ! " C REAL FIDX2 ! " C REAL FIDY2 ! " C REAL FIDX3 ! " C REAL FIDY3 ! " C REAL X_CEN_F !Plate x-centre (rasters) C REAL Y_CEN_F !Plate y-centre (rasters) C REAL W_F !Omega-f C REAL CGX !Centre of gravity x of found fid C REAL CGY !Centre of gravity y of found fid C REAL BOX !Current size of seach box (mm) C REAL F_THR !Current threshold value C REAL MM_RAST_X !mm to x-rasters conversion C REAL MM_RAST_Y !mm to y-rasters conversion C REAL XHALF !x mid-point of image C REAL YHALF !y mid-point of image C CHARACTER*80 STR !Message string C CHARACTER*2 VALSTR !Parameter value string (dummy) C CHARACTER*2 ERRSTR !Error string (dummy) C C------------------------------------------------------------------------------- C IERR = 0 CALL LDM_GET_FIDT (VALSTR, IVAL, IFLAG) IF (IVAL.EQ.0) RETURN CALL LDM_GET_FBOX (FIDBOX, IFLAG, ND) CALL LDM_GET_AXORD (VALSTR, IORD, ISWAP, IFLAG) CALL LDM_GET_XCENF (IPACK, IPLATE, X_CEN_F, IFLAG, ND, + JERR, ERRSTR) CALL LDM_GET_YCENF (IPACK, IPLATE, Y_CEN_F, IFLAG, ND, + JERR, ERRSTR) IF (X_CEN_F.GT.0.0.OR.Y_CEN_F.GT.0.0) RETURN CALL LDM_GET_RAST (RASTER, IFLAG, ND) CALL LDM_GET_NXRAS (NXRAST, IFLAG) CALL LDM_GET_NYRAS (NYRAST, IFLAG) CALL LDM_MMRAST (IPACK, IPLATE, MM_RAST_X, MM_RAST_Y) XHALF = NXRAST/2.0 YHALF = NYRAST/2.0 STR = 'Finding fiducials for pack' CALL STR_ADDI (STR, IPACK, 1) CALL STR_ADDS (STR, ', plate',0) CALL STR_ADDI (STR, IPLATE,1) CALL LOG_HEAD (STR, 1) IF (.NOT.FILM_READ) THEN CALL READ_IMAGE (0, IMG, MAX_IMG_WORDS, ITYPE, NF_OFF, + JERR, ERRSTR) IF (.NOT.FILM_READ) THEN CALL LOG_MSG (IVH_IOW, + '**Error** Unable to read image file',1) GO TO 800 END IF END IF NTRIES = 1 NF_FID = 0 BOX = FIDBOX F_THR = F_THRESH GO TO 150 C C====== Modify threshold for retry C 100 IF (NTRIES.EQ.3) GO TO 800 NTRIES = NTRIES + 1 F_THR = 0.5*F_THR STR = 'Retrying with lowered threshold of' CALL STR_ADDF (STR,F_THR,1,1) CALL LOG_MSG (IVH_IOW,STR,1) IERR = NTRIES - 1 NF_FID = 0 C C====== Search for fids C 150 IXSIZ = NINT (1000.0*BOX)/RASTER IXSIZ = IXSIZ/2 IF (IXSIZ.GT.MAX_HALF_BOX) THEN CALL LOG_MSG(IVH_IOW, + '**Error** Fid box size too large for program',1) GO TO 800 END IF IYSIZ = NINT (1000.0*BOX)/RASTER IYSIZ = IYSIZ/2 IF (IYSIZ.GT.MAX_HALF_BOX) THEN CALL LOG_MSG(IVH_IOW, + '**Error** Fid box size too large for program',1) GO TO 800 END IF ITHRESH = NINT(F_THR) CALL CHK_OPN (KERR) IF (KERR.GT.0) THEN CALL LOG_MSG(IVH_IOW,'**Error** cannot open image file',1) GO TO 800 END IF DO 200 I=1,3 IF (I.EQ.1) THEN CALL LDM_GET_FIDX1 (FIDX1, IFLAG, ND) CALL LDM_GET_FIDY1 (FIDY1, IFLAG, ND) IXC = NINT(XHALF + FIDX1*MM_RAST_X/100.0) IYC = NINT(YHALF + FIDY1*MM_RAST_Y/100.0) ELSE IF (I.EQ.2) THEN CALL LDM_GET_FIDX2 (FIDX2, IFLAG, ND) CALL LDM_GET_FIDY2 (FIDY2, IFLAG, ND) IXC = NINT(XHALF + FIDX2*MM_RAST_X/100.0) IYC = NINT(YHALF + FIDY2*MM_RAST_Y/100.0) ELSE IF (I.EQ.3) THEN CALL LDM_GET_FIDX3 (FIDX3, IFLAG, ND) CALL LDM_GET_FIDY3 (FIDY3, IFLAG, ND) IXC = NINT(XHALF + FIDX3*MM_RAST_X/100.0) IYC = NINT(YHALF + FIDY3*MM_RAST_Y/100.0) ENDIF STR = 'Searching for fiducial number' CALL STR_ADDI (STR, I, 1) CALL LOG_MSG (IVH_IOW,STR,1) CALL SPOT_C_OF_G (IXC, IYC, IXSIZ, IYSIZ, ISPOT_DATA, + ISWORK, ITHRESH, IMG, ITYPE, IORD, + NFRASTS, NXRAST, NYRAST, NOVER, + CGX,CGY,KERR) IF (KERR.LT.0) THEN CALL LOG_MSG (IVH_IOW, + '**Error** Invalid spot_c_of_g call',1) GO TO 800 ELSE IF (KERR.EQ.2) THEN CALL LOG_MSG (IVH_IOW, + '**Error** Fid box outside range of image',1) GO TO 800 ELSE IF (NOVER.EQ.0) THEN CALL LOG_MSG (IVH_IOW, + '**Error** No pixels above threshold',0) GO TO 200 ELSE FIDX (I) = CGX FIDY (I) = CGY NF_FID = NF_FID + 1 STR = 'Fiducial found at x =' CALL STR_ADDF (STR, CGX, 1, 1) CALL STR_ADDS (STR,', y =',0) CALL STR_ADDF (STR, CGY, 1,1) CALL LOG_MSG (IVH_IOW, STR,0) ENDIF 200 CONTINUE IF (NF_FID.EQ.3) THEN X_CEN_F = (FIDX(1)+FIDX(3))/2.0 Y_CEN_F = (FIDY(1)+FIDY(3))/2.0 W_F = (FIDY(3)-FIDY(2)) / (FIDX(3)-FIDX(2)) W_F = 57.29578*ATAN(W_F) CALL LDM_SET_XCENF (IPACK, IPLATE, X_CEN_F, IERR, ERRSTR) CALL LDM_SET_YCENF (IPACK, IPLATE, Y_CEN_F, IERR, ERRSTR) CALL LDM_SET_WC (IPACK, IPLATE, W_F, IERR, ERRSTR) IF (LG_MODE.EQ.1) THEN LISTE(1) = IP_XCENF LISTE(2) = IP_YCENF LISTE(3) = IP_WC CALL SET_PAR2_VALS(3, LISTE) END IF ELSE STR = '**Error** Only' CALL STR_ADDI(STR, NF_FID, 1) CALL STR_ADDS(STR,'fiducials found',1) CALL LOG_MSG (IVH_IOW,STR,1) GO TO 100 END IF RETURN C C====== Error conditions, reset centre to mid point of image C 800 IERR = 3 CALL LOG_MSG (IVH_IOW, + '*Warning* Using image mid-point as centre',1) X_CEN_F = NXRAST/2.0 Y_CEN_F = NYRAST/2.0 CALL LDM_SET_XCENF (IPACK, IPLATE, X_CEN_F, IERR, ERRSTR) CALL LDM_SET_YCENF (IPACK, IPLATE, Y_CEN_F, IERR, ERRSTR) IF (LG_MODE.EQ.1) THEN LISTE(1) = IP_XCENF LISTE(2) = IP_YCENF CALL SET_PAR2_VALS(2, LISTE) END IF RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** GET_FILNAM ** C************************** C C SUBROUTINE GET_FILNAM (KFILM,FILNAM,IPOSL,IFLAG) C INCLUDE 'implicit_none.finc' C C Purpose: Read in (/expand file name) A reply of ! indicates a missing file C C Author: John W. Campbell, January 1992 C C Arguments: C INTEGER KFILM CHARACTER*(*) FILNAM INTEGER IPOSL INTEGER IFLAG C C KFILM (R) Film/plate number C FILNAM (W) Returns file name C IPOSL (W) Position in file name of last character before the extension C IFLAG (W) = 0 OK C = -1 blank C = -2 missing file indicated C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'prog_flags.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR INTEGER LENSTR C C====== LOCALS: C LOGICAL EOF INTEGER NVIEW INTEGER IVHLIST(2) INTEGER IVH INTEGER IERR INTEGER L CHARACTER*(MAXFLEN) FILTEMP CHARACTER*(MAXFLEN) PATH CHARACTER*(MAXFLEN) NAME CHARACTER*(MAXFLEN) LOGNAM CHARACTER*20 TYPE CHARACTER*20 VERS CHARACTER*10 STR C LOGICAL EOF !End of file input flag C INTEGER NVIEW !No. of view-objects for getting events C INTEGER IVHLIST(2) !List of view-objects for getting events C INTEGER IVH !Returned view-object handle C INTEGER IERR !Error flag C INTEGER L !String length C CHARACTER*(MAXFLEN) FILTEMP !Temporary input file name C CHARACTER*(MAXFLEN) PATH !Path parsed from file name C CHARACTER*(MAXFLEN) NAME !Name parsed from file name C CHARACTER*(MAXFLEN) LOGNAM !Path from 'film' environment variable C CHARACTER*20 TYPE !Type parsed from file name C CHARACTER*20 VERS !Version parsed from file name C CHARACTER*10 STR !Temp. string C C C------------------------------------------------------------------------------- C FILNAM = ' ' IFLAG = -1 IPOSL = 0 IF (LG_MODE.EQ.1) THEN NVIEW = 1 IVHLIST(1) = IVH_IOW CALL XDLF_GET_EVENTS (NVIEW, IVHLIST, IVH) CALL XDLF_IO_WINDOW_GETSTRING (IVH_IOW, XDLSTR(FILTEMP), + MAXFLEN, IERR) IF (FILTEMP.EQ.' ') RETURN ELSE IF (LG_MODE.EQ.2) THEN CALL TREAD (FILTEMP, EOF) IF (EOF.OR.FILTEMP.EQ.' ') RETURN END IF CALL LJUST(FILTEMP) STR = FILTEMP CALL CCPUPC (STR) IF (STR.EQ.'MISSING') THEN IFLAG = -2 RETURN END IF CALL FILEXT (FILTEMP, 'dat', FILNAM, IPOSL) C C====== Find default directory from environment variable FILM if set C====== and if no path was specified C CALL CCPPSF(FILNAM,PATH,NAME,TYPE,VERS) IF (PATH.EQ.' ') THEN CALL UGTENV('FILM',LOGNAM) IF (LOGNAM.NE.' ') THEN FILTEMP = FILNAM FILNAM = LOGNAM L = LENSTR(FILNAM) FILNAM(L+1:) = FILTEMP IPOSL = IPOSL + L END IF END IF IFLAG = 0 RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** GET_REFPARS ** C************************** C C SUBROUTINE GET_REFPARS (IFLAG, JFLAG, KFLAG, IFCELL, KQUIT) C INCLUDE 'implicit_none.finc' C C Purpose: Get list of parameters to be refined & select refinement option C C Author: John W. Campbell, January 1992 C C Arguments: C INTEGER IFLAG(7) INTEGER JFLAG(6) INTEGER KFLAG(6) INTEGER IFCELL INTEGER KQUIT C C IFLAG(7) (W) Set flags for general setting parameters to be refined C (0=no, 1=yes) C JFLAG(6) (W) Set flags for cell parameters to be refined (0=no, 1=yes) C KFLAG(6) (W) Set flags for distortion parameters to be refined C (0=no, 1=yes) C IFCELL (W) Refine cell flag 0=no, 1=yes C KQUIT (W) Quit flag =1 quit refinement, =0 continue with refinement C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' INCLUDE 'screen_params.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'film_pack.finc' INCLUDE 'refine_params.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR INTEGER INTFP C C====== LOCALS: C LOGICAL ALL LOGICAL CLR_DISTOR LOGICAL CLR_SPD LOGICAL CLR_CTOF LOGICAL CLR_XCYC INTEGER NP INTEGER NCP(7) INTEGER IVH_POPFR INTEGER IVH_POPPT INTEGER IVH_POPMN INTEGER NP_NAME_CHARS INTEGER NP_VAL_CHARS INTEGER JP_PHI(3) INTEGER JP_CTOF INTEGER JP_XC INTEGER JP_YC INTEGER JP_WC INTEGER JP_RFC INTEGER JP_CELL(6) INTEGER JP_DISTOR INTEGER JP_SPD INTEGER JP_TWIST INTEGER JP_TILT INTEGER JP_BULGE INTEGER JP_YSCAL INTEGER JP_ROFF INTEGER JP_TOFF INTEGER JP_SPDXY INTEGER JP_SPDX INTEGER JP_SPDY INTEGER JP_RFTYP INTEGER JP_TUNE(3) INTEGER NL INTEGER I INTEGER IFDISTOR INTEGER P_WIDTH INTEGER P_HEIGHT INTEGER M_WIDTH INTEGER M_HEIGHT INTEGER IWIDTH_FRAME INTEGER IHEIGHT_FRAME INTEGER IX_PARM INTEGER IY_PARM INTEGER IX_MENU INTEGER IY_MENU INTEGER IXROOT INTEGER IYROOT INTEGER NVIEW INTEGER IVHLIST(2) INTEGER IVH INTEGER ITEM INTEGER IQUIT INTEGER IERR INTEGER J INTEGER IOP INTEGER ITYP INTEGER IV INTEGER ISYST INTEGER DISTOR_TYPE INTEGER LFLAG INTEGER KEYPLATE REAL X CHARACTER*15 CELL_STR(6,7) CHARACTER*6 RFSTR(2) CHARACTER*6 MENU_STRS(2) CHARACTER*10 TMPSTR CHARACTER*15 PVAL CHARACTER*2 VALSTR CHARACTER*2 ERRSTR C C LOGICAL ALL !Checks for all cell parameters refine request C LOGICAL CLR_DISTOR !Clear main distortion parameters flag C LOGICAL CLR_SPD !Clear polynomial spd parameters flag C LOGICAL CLR_CTOF !Clear refine ctof flag C LOGICAL CLR_XCYC !Clear refine x_c, y_c flags C INTEGER NP !No. of refineable parameters (apart from cell) C INTEGER NCP(7) !No. of unique cell params foreach crystal system C INTEGER IVH_POPFR !View-object handle for pop-up frame C INTEGER IVH_POPPT !View-object handle for parameter table C INTEGER IVH_POPMN !View-object handle for menu C INTEGER NP_NAME_CHARS !Max no. chars in parameter table name C INTEGER NP_VAL_CHARS !Max no. chars in pareter table value C INTEGER JP_PHI(3) !Item numbers in param. table for Phi's C INTEGER JP_CTOF !Item number in param. table for c-to-f C INTEGER JP_XC !Item number in param. table for x_c C INTEGER JP_YC !Item number in param. table for y_c C INTEGER JP_WC !Item number in param. table for w_c C INTEGER JP_RFC !Item number in param. table for Refine cell C INTEGER JP_CELL(6) !Item numbers in param. table for cell params. C INTEGER JP_DISTOR !Item number in param table for Refine distortion. C INTEGER JP_SPD !Item number in param table for SPD polynominal C INTEGER JP_TWIST !Item number in param table for twist C INTEGER JP_TILT !Item number in param table for tilt C INTEGER JP_BULGE !Item number in param table for bulge C INTEGER JP_YSCAL !Item number in param table for y_scale C INTEGER JP_ROFF !Item number in table for roff C INTEGER JP_TOFF !Item number in table for toff C INTEGER JP_SPDXY !Item number in table for spdxy C INTEGER JP_SPDX !Item number in table for spd_x C INTEGER JP_SPDY !Item number in table for spd_y C INTEGER JP_RFTYP !Item number in param. table for Refinement type C INTEGER JP_TUNE(3) !Item numbers in param. table for tuning params C INTEGER NL !Parameter table line no. count C INTEGER I !Temp/loop variable C INTEGER IFDISTOR !Refine main distortion parameters flag C INTEGER P_WIDTH !Parameter table width C INTEGER P_HEIGHT !Parameter table height C INTEGER M_WIDTH !Menu area width C INTEGER M_HEIGHT !Menu area height C INTEGER IWIDTH_FRAME !Width of pop-up frame C INTEGER IHEIGHT_FRAME !Height of pop-up frame C INTEGER IX_PARM !X position of parameter table within frame C INTEGER IY_PARM !Y position of parameter table within frame C INTEGER IX_MENU !X position of menu area within frame C INTEGER IY_MENU !Y position of menu area within frame C INTEGER IXROOT !Root X position of pop-up frame C INTEGER IYROOT !Root Y position of pop_up frame C INTEGER NVIEW !No. of view-objects for getting events C INTEGER IVHLIST(2) !List of view-object handles for getting events C INTEGER IVH !Returned view-object handle from getting events C INTEGER ITEM !Item no. modified in parameter table C INTEGER IQUIT !Quit button flage from menu C INTEGER IERR !Error flag C INTEGER J !Temp/loop variable C INTEGER IOP !Option no. from an options list C INTEGER ITYP !Number type from INTFP C INTEGER IV !Integer value C INTEGER ISYST !Crystal system C INTEGER DISTOR_TYPE !Distortion type flag C INTEGER LFLAG !Parameter status flag C INTEGER KEYPLATE !Key plate C REAL X !Temp real value C CHARACTER*15 CELL_STR(6,7) !Cell parameter strings C CHARACTER*6 RFSTR(2) !Refinement type strings C CHARACTER*6 MENU_STRS(2) !Menu strings C CHARACTER*10 TMPSTR !Temporary string for parameter o/p value C CHARACTER*15 PVAL !String for parameter table input value C CHARACTER*2 VALSTR !Parameter value string (dummy) C CHARACTER*2 ERRSTR !Error string (dummy) C C====== Data statements C DATA NCP/6,4,3,2,2,2,1/ DATA CELL_STR/ + 'Refine a:','Refine b:','Refine c:', + 'Refine alpha:','Refine beta:','Refine gamma:', + 'Refine a:','Refine b:','Refine c:', + 'Refine beta:',' ',' ', + 'Refine a:','Refine b:','Refine c:', + ' ',' ',' ', + 'Refine a:','Refine c:',' ', + ' ',' ',' ', + 'Refine a:','Refine c:',' ', + ' ',' ',' ', + 'Refine a:','Refine alpha:',' ', + ' ',' ',' ', + 'Refine a:',' ',' ', + ' ',' ',' '/ DATA RFSTR/'LSR','Powell'/ DATA MENU_STRS/'REFINE',' '/ C C------------------------------------------------------------------------------- C CALL LDM_GET_KEYP (IPACK, KEYPLATE, LFLAG, IERR, ERRSTR) CALL LDM_GET_SYST (VALSTR, ISYST, LFLAG) CALL LDM_GET_DSTOR (VALSTR, DISTOR_TYPE, LFLAG) IVH_POPFR = 100 IVH_POPPT = 101 IVH_POPMN = 102 NP_NAME_CHARS = 15 NP_VAL_CHARS = 10 CALL XDLF_VIEW_OBJECT_ROOTXY(IVH_PAR1,100,0,IXROOT,IYROOT,IERR) DO 5 I = 1,7 IFLAG(I) = 0 5 CONTINUE DO 6 I = 1,6 JFLAG(I) = 0 6 CONTINUE DO 7 I = 1,6 KFLAG(I) = 0 7 CONTINUE IFCELL = 0 IFDISTOR = 0 DO 10 I=1,3 JP_PHI(I) = 0 10 CONTINUE JP_CTOF = 0 JP_XC = 0 JP_YC = 0 JP_WC = 0 JP_RFC = 0 DO 20 I=1,6 JP_CELL(I) = 0 20 CONTINUE JP_RFTYP = 0 DO 30 I= 1,3 JP_TUNE(I) = 0 30 CONTINUE IF (IPLATE.EQ.KEYPLATE) THEN JP_PHI(1) = 1 JP_PHI(2) = 2 JP_PHI(3) = 3 JP_CTOF = 4 JP_XC = 5 JP_YC = 6 NL = 6 ELSE JP_CTOF = 1 JP_XC = 2 JP_YC = 3 JP_WC = 4 NL = 4 END IF IF (IPLATE.EQ.KEYPLATE) THEN NL = NL + 2 JP_RFC = NL DO 40 I = 1, NCP(ISYST) NL = NL + 1 JP_CELL(I) = NL 40 CONTINUE END IF NL = NL + 2 JP_DISTOR = NL NL = NL + 1 JP_YSCAL = NL NL = NL + 1 JP_TWIST = NL NL = NL + 1 JP_TILT = NL IF (DISTOR_TYPE.EQ.1) THEN JP_ROFF = 0 JP_TOFF = 0 NL = NL + 1 JP_BULGE = NL ELSE IF (DISTOR_TYPE.EQ.2) THEN JP_BULGE = 0 NL = NL + 1 JP_ROFF = NL NL = NL + 1 JP_TOFF = NL ELSE JP_BULGE = 0 JP_ROFF = 0 JP_TOFF = 0 END IF IF (DISTOR_TYPE.EQ.3) THEN NL = NL + 2 JP_SPD = NL NL = NL + 1 JP_SPDXY = NL NL = NL + 1 JP_SPDX = NL NL = NL + 1 JP_SPDY = NL ELSE JP_SPD = 0 JP_SPDX = 0 JP_SPDX = 0 END IF NL = NL + 2 JP_RFTYP = NL DO 50 I= 1,3 NL = NL + 1 JP_TUNE(I) = NL 50 CONTINUE C C====== Get required parameter table size and menu size C CALL XDLF_PARAM_TABLE_GETSIZE (1, NL, NP_NAME_CHARS, NP_VAL_CHARS, + 1, IFONT, 1, P_WIDTH, P_HEIGHT) CALL XDLF_MENU_AREA_GETSIZE (1, 20, IFONT, 1, 0, + M_WIDTH, M_HEIGHT) C C====== Get required size for pop-up frame and positions of windows C IWIDTH_FRAME = 2*IBORDER + P_WIDTH + 8 IHEIGHT_FRAME = 2*IBORDER + P_HEIGHT + ISEP + M_HEIGHT + 8 IX_PARM = IBORDER + 4 IY_PARM = IBORDER + 4 IX_MENU = IBORDER + 4 IY_MENU = IBORDER + 4 + P_HEIGHT + ISEP C C====== Create pop-up base frame C c CALL XDLF_POPUP_FRAME (IVH_POPFR, IXROOT, IYROOT, IWIDTH_FRAME, c + IHEIGHT_FRAME, 5) CALL XDLF_BASE_FRAME (IVH_POPFR, IWIDTH_FRAME, IHEIGHT_FRAME, + XDLSTR('Refine'), 6, + XDLSTR('Refine'), 6, IXROOT, IYROOT) C C====== Create parameter_table & menu (Note: Use param width for menu) C CALL XDLF_PARAM_TABLE (IVH_POPPT, IVH_POPFR, IX_PARM, IY_PARM, + 0, 1, NL, NP_NAME_CHARS, + NP_VAL_CHARS, NP_VAL_CHARS, + XDLSTR('Refinement Parameters'), 21, IFONT, + 1, IERR) CALL XDLF_MENU_AREA (IVH_POPMN, IVH_POPFR, IX_MENU, IY_MENU, 0, + 1, 20, IFONT, 1, 0, P_WIDTH, M_HEIGHT, IERR) C C====== Set up menu C CALL XDLF_MENU_AREA_SETMENU (IVH_POPMN, 1, + XDLSTR(MENU_STRS), 6, XDLSTR(' '), -1, + XDLSTR('Quit Refinement'), 15, IFONT, IERR) C C====== Set up parameter table entries C IF (JP_PHI(1).GT.0) THEN CALL XDLF_PARAM_TABLE_SETITEM (IVH_POPPT, JP_PHI(1), + XDLSTR('Refine PhiX:'), 12, XDLSTR(' '), 1, + 3, 0, IERR) IFLAG(1) = 1 END IF IF (JP_PHI(2).GT.0) THEN CALL XDLF_PARAM_TABLE_SETITEM (IVH_POPPT, JP_PHI(2), + XDLSTR('Refine PhiY:'), 12, XDLSTR(' '), 1, + 3, 0, IERR) IFLAG(2) = 1 END IF IF (JP_PHI(3).GT.0) THEN CALL XDLF_PARAM_TABLE_SETITEM (IVH_POPPT, JP_PHI(3), + XDLSTR('Refine PhiZ:'), 12, XDLSTR(' '), 1, + 3, 0, IERR) IFLAG(3) = 1 END IF IF (JP_CTOF.GT.0) THEN CALL XDLF_PARAM_TABLE_SETITEM (IVH_POPPT, JP_CTOF, + XDLSTR('Refine c_to_f:'), 14, XDLSTR(' '), 1, + 3, 0, IERR) IFLAG(4) = 1 END IF IF (JP_XC.GT.0) THEN CALL XDLF_PARAM_TABLE_SETITEM (IVH_POPPT, JP_XC, + XDLSTR('Refine x_c:'), 10, XDLSTR(' '), 1, + 3, 0, IERR) IFLAG(5) = 1 END IF IF (JP_YC.GT.0) THEN CALL XDLF_PARAM_TABLE_SETITEM (IVH_POPPT, JP_YC, + XDLSTR('Refine y_c:'), 10, XDLSTR(' '), 1, + 3, 0, IERR) IFLAG(6) = 1 END IF IF (JP_WC.GT.0) THEN CALL XDLF_PARAM_TABLE_SETITEM (IVH_POPPT, JP_WC, + XDLSTR('Refine w_c:'), 10, XDLSTR(' '), 1, + 3, 0, IERR) IFLAG(7) = 1 END IF IF (JP_RFC.GT.0) THEN CALL XDLF_PARAM_TABLE_SETITEM (IVH_POPPT, JP_RFC, + XDLSTR('Refine cell:'), 12, XDLSTR(' '), 1, + 4, 0, IERR) END IF DO 100 I=1,6 IF (JP_CELL(I).GT.0) THEN CALL XDLF_PARAM_TABLE_SETITEM (IVH_POPPT, JP_CELL(I), + XDLSTR(CELL_STR(I,ISYST)), 15, XDLSTR(' '), 1, + 4, 0, IERR) END IF 100 CONTINUE IF (JP_DISTOR.GT.0) THEN CALL XDLF_PARAM_TABLE_SETITEM (IVH_POPPT, JP_DISTOR, + XDLSTR('Distortion:'), 11, XDLSTR(' '), 1, + 4, 0, IERR) END IF IF (JP_YSCAL.GT.0) THEN CALL XDLF_PARAM_TABLE_SETITEM (IVH_POPPT, JP_YSCAL, + XDLSTR('Refine y_scale:'), 15, XDLSTR(' '), 1, + 4, 0, IERR) END IF IF (JP_TWIST.GT.0) THEN CALL XDLF_PARAM_TABLE_SETITEM (IVH_POPPT, JP_TWIST, + XDLSTR('Refine twist:'), 13, XDLSTR(' '), 1, + 4, 0, IERR) END IF IF (JP_TILT.GT.0) THEN CALL XDLF_PARAM_TABLE_SETITEM (IVH_POPPT, JP_TILT, + XDLSTR('Refine tilt:'), 12, XDLSTR(' '), 1, + 4, 0, IERR) END IF IF (JP_BULGE.GT.0) THEN CALL XDLF_PARAM_TABLE_SETITEM (IVH_POPPT, JP_BULGE, + XDLSTR('Refine bulge:'), 13, XDLSTR(' '), 1, + 4, 0, IERR) END IF IF (JP_ROFF.GT.0) THEN CALL XDLF_PARAM_TABLE_SETITEM (IVH_POPPT, JP_ROFF, + XDLSTR('Refine roff:'), 12, XDLSTR(' '), 1, + 4, 0, IERR) END IF IF (JP_TOFF.GT.0) THEN CALL XDLF_PARAM_TABLE_SETITEM (IVH_POPPT, JP_TOFF, + XDLSTR('Refine toff:'), 12, XDLSTR(' '), 1, + 4, 0, IERR) END IF IF (JP_SPD.GT.0) THEN CALL XDLF_PARAM_TABLE_SETITEM (IVH_POPPT, JP_SPD, + XDLSTR('Polynomial fit:'), 15, XDLSTR(' '), 1, + 4, 0, IERR) END IF IF (JP_SPDXY.GT.0) THEN CALL XDLF_PARAM_TABLE_SETITEM (IVH_POPPT, JP_SPDXY, + XDLSTR('Refine spdxy:'), 13, XDLSTR(' '), 1, + 4, 0, IERR) END IF IF (JP_SPDX.GT.0) THEN CALL XDLF_PARAM_TABLE_SETITEM (IVH_POPPT, JP_SPDX, + XDLSTR('Refine spd_x:'), 13, XDLSTR(' '), 1, + 4, 0, IERR) END IF IF (JP_SPDY.GT.0) THEN CALL XDLF_PARAM_TABLE_SETITEM (IVH_POPPT, JP_SPDY, + XDLSTR('Refine spd_y:'), 13, XDLSTR(' '), 1, + 4, 0, IERR) END IF IF (JP_RFTYP.GT.0) THEN CALL XDLF_PARAM_TABLE_SETITEM (IVH_POPPT, JP_RFTYP, + XDLSTR('Method:'), 7, XDLSTR(RFSTR(IRFN_TYP)), 6, + 0, 0, IERR) CALL XDLF_PARAM_TABLE_SETMENU (IVH_POPPT, JP_RFTYP, 2, + XDLSTR(RFSTR), 6, IERR) IF (IRFN_TYP.EQ.1) THEN X = LSR_SHFLM WRITE (TMPSTR,'(F10.4)') X CALL LJUST(TMPSTR) CALL XDLF_PARAM_TABLE_SETITEM (IVH_POPPT, JP_TUNE(1), + XDLSTR('Shift limit:'), 12, XDLSTR(TMPSTR), 10, + 0, 0, IERR) X = LSR_DSTEP WRITE (TMPSTR,'(E10.3)') X CALL LJUST(TMPSTR) CALL XDLF_PARAM_TABLE_SETITEM (IVH_POPPT, JP_TUNE(2), + XDLSTR('Deriv. step:'), 12, XDLSTR(TMPSTR), 10, + 0, 0, IERR) X = LSR_DAMP WRITE (TMPSTR,'(F10.2)') X CALL LJUST(TMPSTR) CALL XDLF_PARAM_TABLE_SETITEM (IVH_POPPT, JP_TUNE(3), + XDLSTR('Damp factor:'), 12, XDLSTR(TMPSTR), 10, + 0, 0, IERR) ELSE X = POWELL_ACC WRITE (TMPSTR,'(E10.3)') X CALL LJUST(TMPSTR) CALL XDLF_PARAM_TABLE_SETITEM (IVH_POPPT, JP_TUNE(1), + XDLSTR('Accuracy:'), 9, XDLSTR(TMPSTR), 10, + 0, 0, IERR) END IF END IF C C====== Get input from the menu and/or parameter table C NVIEW = 2 IVHLIST(1) = IVH_POPMN IVHLIST(2) = IVH_POPPT 200 CALL XDLF_GET_EVENTS (NVIEW, IVHLIST, IVH) C C====== Parameter table input C IF (IVH.EQ.IVH_POPPT) THEN CLR_DISTOR = .FALSE. CLR_SPD = .FALSE. CLR_CTOF = .FALSE. CLR_XCYC = .FALSE. CALL XDLF_PARAM_TABLE_GETVALUE (IVH_POPPT, ITEM, + XDLSTR(PVAL), 15, IERR) IF (ITEM.EQ.JP_PHI(1)) THEN IFLAG(1) = 0 IF (PVAL.EQ.'Yes') IFLAG(1) = 1 ELSE IF (ITEM.EQ.JP_PHI(2)) THEN IFLAG(2) = 0 IF (PVAL.EQ.'Yes') IFLAG(2) = 1 ELSE IF (ITEM.EQ.JP_PHI(3)) THEN IFLAG(3) = 0 IF (PVAL.EQ.'Yes') IFLAG(3) = 1 ELSE IF (ITEM.EQ.JP_CTOF) THEN IFLAG(4) = 0 IF (PVAL.EQ.'Yes') IFLAG(4) = 1 IF (DISTOR_TYPE.EQ.3) CLR_SPD = .TRUE. ELSE IF (ITEM.EQ.JP_XC) THEN IFLAG(5) = 0 IF (PVAL.EQ.'Yes') IFLAG(5) = 1 IF (DISTOR_TYPE.EQ.3) CLR_SPD = .TRUE. ELSE IF (ITEM.EQ.JP_YC) THEN IFLAG(6) = 0 IF (PVAL.EQ.'Yes') IFLAG(6) = 1 IF (DISTOR_TYPE.EQ.3) CLR_SPD = .TRUE. ELSE IF (ITEM.EQ.JP_WC) THEN IFLAG(7) = 0 IF (PVAL.EQ.'Yes') IFLAG(7) = 1 ELSE IF (ITEM.EQ.JP_DISTOR) THEN IFDISTOR = 0 IF (PVAL.EQ.'Yes') IFDISTOR = 1 J = 4 IF (IFDISTOR.EQ.1) J=3 KFLAG(1) = IFDISTOR CALL XDLF_PARAM_TABLE_SETVALUE (IVH_POPPT, + JP_YSCAL, XDLSTR(' '),1,J,IERR) KFLAG(2) = IFDISTOR CALL XDLF_PARAM_TABLE_SETVALUE (IVH_POPPT, + JP_TWIST, XDLSTR(' '),1,J,IERR) KFLAG(3) = IFDISTOR CALL XDLF_PARAM_TABLE_SETVALUE (IVH_POPPT, + JP_TILT, XDLSTR(' '),1,J,IERR) IF (DISTOR_TYPE.EQ.1) THEN KFLAG(4) = IFDISTOR CALL XDLF_PARAM_TABLE_SETVALUE (IVH_POPPT, + JP_BULGE, XDLSTR(' '),1,J,IERR) ELSE IF (DISTOR_TYPE.EQ.2) THEN KFLAG(4) = IFDISTOR CALL XDLF_PARAM_TABLE_SETVALUE (IVH_POPPT, + JP_ROFF, XDLSTR(' '),1,J,IERR) KFLAG(5) = IFDISTOR CALL XDLF_PARAM_TABLE_SETVALUE (IVH_POPPT, + JP_TOFF, XDLSTR(' '),1,J,IERR) ELSE IF (DISTOR_TYPE.EQ.3) THEN IF (IFDISTOR.EQ.1) CLR_SPD = .TRUE. END IF ELSE IF (ITEM.EQ.JP_YSCAL) THEN KFLAG(1) = 0 IF (PVAL.EQ.'Yes') KFLAG(1) = 1 IF (IFDISTOR.EQ.0) THEN IFDISTOR = 1 CALL XDLF_PARAM_TABLE_SETVALUE (IVH_POPPT, + JP_DISTOR, XDLSTR(' '),1,3,IERR) END IF IF (DISTOR_TYPE.EQ.3) CLR_SPD = .TRUE. ELSE IF (ITEM.EQ.JP_TWIST) THEN KFLAG(2) = 0 IF (PVAL.EQ.'Yes') KFLAG(2) = 1 IF (IFDISTOR.EQ.0) THEN IFDISTOR = 1 CALL XDLF_PARAM_TABLE_SETVALUE (IVH_POPPT, + JP_DISTOR, XDLSTR(' '),1,3,IERR) END IF IF (DISTOR_TYPE.EQ.3) CLR_SPD = .TRUE. ELSE IF (ITEM.EQ.JP_TILT) THEN KFLAG(3) = 0 IF (PVAL.EQ.'Yes') KFLAG(3) = 1 IF (IFDISTOR.EQ.0) THEN IFDISTOR = 1 CALL XDLF_PARAM_TABLE_SETVALUE (IVH_POPPT, + JP_DISTOR, XDLSTR(' '),1,3,IERR) END IF IF (DISTOR_TYPE.EQ.3) CLR_SPD = .TRUE. ELSE IF (ITEM.EQ.JP_BULGE.AND.DISTOR_TYPE.EQ.1) THEN KFLAG(3) = 0 IF (PVAL.EQ.'Yes') KFLAG(3) = 1 IF (IFDISTOR.EQ.0) THEN IFDISTOR = 1 CALL XDLF_PARAM_TABLE_SETVALUE (IVH_POPPT, + JP_DISTOR, XDLSTR(' '),1,3,IERR) END IF ELSE IF (ITEM.EQ.JP_ROFF.AND.DISTOR_TYPE.EQ.2) THEN KFLAG(3) = 0 IF (PVAL.EQ.'Yes') KFLAG(3) = 1 IF (IFDISTOR.EQ.0) THEN IFDISTOR = 1 CALL XDLF_PARAM_TABLE_SETVALUE (IVH_POPPT, + JP_DISTOR, XDLSTR(' '),1,3,IERR) END IF ELSE IF (ITEM.EQ.JP_TOFF.AND.DISTOR_TYPE.EQ.2) THEN KFLAG(4) = 0 IF (PVAL.EQ.'Yes') KFLAG(4) = 1 IF (IFDISTOR.EQ.0) THEN IFDISTOR = 1 CALL XDLF_PARAM_TABLE_SETVALUE (IVH_POPPT, + JP_DISTOR, XDLSTR(' '),1,3,IERR) END IF ELSE IF (ITEM.EQ.JP_SPD.AND.DISTOR_TYPE.EQ.3)THEN J = 4 IF (PVAL.EQ.'Yes') J = 3 KFLAG(4) = 4 - J CALL XDLF_PARAM_TABLE_SETVALUE (IVH_POPPT, + JP_SPDXY, XDLSTR(' '),1,J,IERR) KFLAG(5) = 4 - J CALL XDLF_PARAM_TABLE_SETVALUE (IVH_POPPT, + JP_SPDX, XDLSTR(' '),1,J,IERR) KFLAG(6) = 4 - J CALL XDLF_PARAM_TABLE_SETVALUE (IVH_POPPT, + JP_SPDY, XDLSTR(' '),1,J,IERR) IF (J.EQ.3) THEN CLR_DISTOR = .TRUE. CLR_CTOF = .TRUE. CLR_XCYC = .TRUE. END IF ELSE IF (ITEM.EQ.JP_SPDXY.AND.DISTOR_TYPE.EQ.3) THEN KFLAG(4) = 0 IF (PVAL.EQ.'Yes') KFLAG(4) = 1 CALL XDLF_PARAM_TABLE_SETVALUE (IVH_POPPT, + JP_SPD, XDLSTR(' '),1,3,IERR) IF (KFLAG(4).EQ.1) THEN CLR_DISTOR = .TRUE. CLR_CTOF = .TRUE. CLR_XCYC = .TRUE. END IF ELSE IF (ITEM.EQ.JP_SPDX.AND.DISTOR_TYPE.EQ.3) THEN KFLAG(5) = 0 IF (PVAL.EQ.'Yes') KFLAG(5) = 1 CALL XDLF_PARAM_TABLE_SETVALUE (IVH_POPPT, + JP_SPD, XDLSTR(' '),1,3,IERR) IF (KFLAG(5).EQ.1) THEN CLR_DISTOR = .TRUE. CLR_CTOF = .TRUE. CLR_XCYC = .TRUE. END IF ELSE IF (ITEM.EQ.JP_SPDY.AND.DISTOR_TYPE.EQ.3) THEN KFLAG(6) = 0 IF (PVAL.EQ.'Yes') KFLAG(6) = 1 CALL XDLF_PARAM_TABLE_SETVALUE (IVH_POPPT, + JP_SPD, XDLSTR(' '),1,3,IERR) IF (KFLAG(6).EQ.1) THEN CLR_DISTOR = .TRUE. CLR_CTOF = .TRUE. CLR_XCYC = .TRUE. END IF ELSE IF (ITEM.EQ.JP_RFTYP) THEN CALL GETOPT (RFSTR, 2, PVAL, IOP, IERR) IF (IERR.EQ.2) THEN CALL XDLF_PARAM_TABLE_ERROR (IVH_POPPT, JP_RFTYP, + XDLSTR('**Invalid refinement type**'), 27, IERR) CALL XDLF_VIEW_OBJECT_RAISE (IVH_POPFR, IERR) GO TO 200 END IF IRFN_TYP = IOP CALL XDLF_PARAM_TABLE_SETVALUE (IVH_POPPT, JP_RFTYP, + XDLSTR(RFSTR(IRFN_TYP)), 6, 0, IERR) DO 144 I = 1,3 CALL XDLF_PARAM_TABLE_DELITEM (IVH_POPPT, JP_TUNE(I), + IERR) 144 CONTINUE IF (IRFN_TYP.EQ.1) THEN X = LSR_SHFLM WRITE (TMPSTR,'(F10.4)') X CALL LJUST(TMPSTR) CALL XDLF_PARAM_TABLE_SETITEM (IVH_POPPT, JP_TUNE(1), + XDLSTR('Shift limit:'), 12, XDLSTR(TMPSTR), 10, + 0, 0, IERR) X = LSR_DSTEP WRITE (TMPSTR,'(E10.3)') X CALL LJUST(TMPSTR) CALL XDLF_PARAM_TABLE_SETITEM (IVH_POPPT, JP_TUNE(2), + XDLSTR('Deriv. step:'), 12, XDLSTR(TMPSTR), 10, + 0, 0, IERR) X = LSR_DAMP WRITE (TMPSTR,'(F10.2)') X CALL LJUST(TMPSTR) CALL XDLF_PARAM_TABLE_SETITEM (IVH_POPPT, JP_TUNE(3), + XDLSTR('Damp factor:'), 12, XDLSTR(TMPSTR), 10, + 0, 0, IERR) ELSE X = POWELL_ACC WRITE (TMPSTR,'(E10.3)') X CALL LJUST(TMPSTR) CALL XDLF_PARAM_TABLE_SETITEM (IVH_POPPT, JP_TUNE(1), + XDLSTR('Accuracy:'), 9, XDLSTR(TMPSTR), 10, + 0, 0, IERR) END IF ELSE IF (ITEM.EQ.JP_TUNE(1)) THEN ITYP = INTFP(PVAL,X,IV) IF (ITYP.EQ.0) THEN CALL XDLF_PARAM_TABLE_ERROR (IVH_POPPT, ITEM, + XDLSTR('**Invalid Number Format**'), 25, IERR) CALL XDLF_VIEW_OBJECT_RAISE (IVH_POPFR, IERR) GO TO 200 END IF IF (IRFN_TYP.EQ.1) THEN LSR_SHFLM = X ELSE IF (IRFN_TYP.EQ.2) THEN POWELL_ACC = X END IF ELSE IF (ITEM.EQ.JP_TUNE(2)) THEN ITYP = INTFP(PVAL,X,IV) IF (ITYP.EQ.0) THEN CALL XDLF_PARAM_TABLE_ERROR (IVH_POPPT, ITEM, + XDLSTR('**Invalid Number Format**'), 25, IERR) CALL XDLF_VIEW_OBJECT_RAISE (IVH_POPFR, IERR) GO TO 200 END IF IF (IRFN_TYP.EQ.1) THEN LSR_DSTEP = X END IF ELSE IF (ITEM.EQ.JP_TUNE(3)) THEN ITYP = INTFP(PVAL,X,IV) IF (ITYP.EQ.0) THEN CALL XDLF_PARAM_TABLE_ERROR (IVH_POPPT, ITEM, + XDLSTR('**Invalid Number Format**'), 25, IERR) CALL XDLF_VIEW_OBJECT_RAISE (IVH_POPFR, IERR) GO TO 200 END IF IF (IRFN_TYP.EQ.1) THEN LSR_DAMP = X END IF ELSE IF (ITEM.EQ.JP_RFC) THEN IFCELL = 0 IF (PVAL.EQ.'Yes') IFCELL = 1 DO 210 I=1, NCP(ISYST) J = 4 IF (IFCELL.EQ.1.AND.I.NE.1) J = 3 CALL XDLF_PARAM_TABLE_SETVALUE (IVH_POPPT, JP_CELL(I), + XDLSTR(' '), 1, J, IERR) JFLAG(I) = 4 - J 210 CONTINUE ELSE DO 250 I = 1, NCP(ISYST) IF (ITEM.EQ.JP_CELL(I)) THEN IF (PVAL.EQ.'Yes') THEN JFLAG(I) = 1 IF (IFCELL.EQ.0) THEN IFCELL = 1 CALL XDLF_PARAM_TABLE_SETVALUE (IVH_POPPT, + JP_RFC, XDLSTR(' '), 1, 3, IERR) END IF ALL = .TRUE. DO 245 J = 1, NCP(ISYST) IF (JFLAG(J).EQ.0) ALL = .FALSE. 245 CONTINUE IF (ALL) THEN JFLAG(1) = 0 CALL XDLF_PARAM_TABLE_SETVALUE (IVH_POPPT, + JP_CELL(1), XDLSTR(' '), 1, 4, IERR) END IF ELSE JFLAG(I) = 0 END IF END IF 250 CONTINUE END IF C C====== Set/unset dependent distortion parameters C IF (CLR_DISTOR) THEN IFDISTOR = 0 CALL XDLF_PARAM_TABLE_SETVALUE (IVH_POPPT, + JP_DISTOR, XDLSTR(' '),1,4,IERR) KFLAG(1) = 0 CALL XDLF_PARAM_TABLE_SETVALUE (IVH_POPPT, + JP_YSCAL, XDLSTR(' '),1,4,IERR) KFLAG(2) = 0 CALL XDLF_PARAM_TABLE_SETVALUE (IVH_POPPT, + JP_TWIST, XDLSTR(' '),1,4,IERR) KFLAG(3) = 0 CALL XDLF_PARAM_TABLE_SETVALUE (IVH_POPPT, + JP_TILT, XDLSTR(' '),1,4,IERR) END IF IF (CLR_SPD) THEN CALL XDLF_PARAM_TABLE_SETVALUE (IVH_POPPT, + JP_SPD, XDLSTR(' '),1,4,IERR) KFLAG(4) = 0 CALL XDLF_PARAM_TABLE_SETVALUE (IVH_POPPT, + JP_SPDXY, XDLSTR(' '),1,4,IERR) KFLAG(5) = 0 CALL XDLF_PARAM_TABLE_SETVALUE (IVH_POPPT, + JP_SPDX, XDLSTR(' '),1,4,IERR) KFLAG(6) = 0 CALL XDLF_PARAM_TABLE_SETVALUE (IVH_POPPT, + JP_SPDY, XDLSTR(' '),1,4,IERR) END IF IF (CLR_CTOF) THEN CALL XDLF_PARAM_TABLE_SETVALUE (IVH_POPPT, + JP_CTOF, XDLSTR(' '),1,4,IERR) IFLAG(4) = 0 END IF IF (CLR_XCYC) THEN CALL XDLF_PARAM_TABLE_SETVALUE (IVH_POPPT, + JP_XC, XDLSTR(' '),1,4,IERR) IFLAG(5) = 0 CALL XDLF_PARAM_TABLE_SETVALUE (IVH_POPPT, + JP_YC, XDLSTR(' '),1,4,IERR) IFLAG(6) = 0 END IF C C====== Menu input C ELSE IF (IVH.EQ.IVH_POPMN) THEN CALL XDLF_MENU_AREA_GETITEM (IVH_POPMN, ITEM, IQUIT) IF (IQUIT.EQ.1) THEN KQUIT = 1 GOTO 500 ELSE KQUIT = 0 GO TO 500 END IF END IF GO TO 200 C C====== Remove pop-up C 500 CALL XDLF_DELETE_VIEW_OBJECT (IVH_POPMN, IERR) CALL XDLF_DELETE_VIEW_OBJECT (IVH_POPPT, IERR) CALL XDLF_DELETE_VIEW_OBJECT (IVH_POPFR, IERR) END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** GNOM_CENTRE ** C************************** C C SUBROUTINE GNOM_CENTRE C INCLUDE 'implicit_none.finc' C C Purpose: Input conic spots (start, middle end) & calculate centre using C gnomonic projection coords to minimise the distances of the C 'middle' points from the lines between the start and end points. C i.e. makes use of fact that in the gnomonic projection the C conics should be transformed to straight lines C C Author: John W. Campbell, February 1993 C C Arguments: C C None C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' INCLUDE 'screen_params.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'ip1_entries.finc' INCLUDE 'image.finc' INCLUDE 'file_units.finc' INCLUDE 'spot_data.finc' INCLUDE 'symbol_types.finc' INCLUDE 'meas_spots.finc' INCLUDE 'film_pack.finc' INCLUDE 'spot_box.finc' INCLUDE 'conics.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR INTEGER INTFP INTEGER LENSTR EXTERNAL GDIST_FN C C====== LOCALS: C LOGICAL CONICS_COMPLETE LOGICAL CEN_OK INTEGER I INTEGER J INTEGER M_CENT INTEGER M_REDO INTEGER NVIEW INTEGER IVHLIST(3) INTEGER IVH INTEGER IQUIT INTEGER ITEM INTEGER IERR INTEGER IXPIX INTEGER IYPIX INTEGER ISPIX INTEGER IFPIX INTEGER IXSIZ INTEGER IYSIZ INTEGER NOVER INTEGER ITHRESH INTEGER IBG INTEGER ISTYP INTEGER IOP INTEGER ITYP INTEGER IV INTEGER ITM INTEGER IP_STYP INTEGER IP_SBOX INTEGER IP_THRESH INTEGER ICONIC INTEGER JCONIC INTEGER IFLAG INTEGER IYN INTEGER NXRAST INTEGER NYRAST INTEGER IORD INTEGER ISWAP INTEGER ND INTEGER LISTE(2) REAL MM_RAST_X REAL MM_RAST_Y REAL CGX REAL CGY REAL FP REAL XTEMP REAL YTEMP DOUBLE PRECISION CEN(2) DOUBLE PRECISION ACC DOUBLE PRECISION FMIN DOUBLE PRECISION FVECC(MAX_CONICS) DOUBLE PRECISION W(12) CHARACTER*80 STR CHARACTER*(MAX_P3SCROLL_CHARS) PVAL CHARACTER*25 NAMES(2) CHARACTER*25 QUITNAM CHARACTER*6 SMETHOD(2) CHARACTER*6 SMETHOD_UC(2) CHARACTER*11 MSG(3) CHARACTER*2 VALSTR CHARACTER*2 ERRSTR C LOGICAL CONICS_COMPLETE !All allowed conics now input C LOGICAL CEN_OK !Found centre OK flag C INTEGER I !Temp/loop variable C INTEGER J !Temp/loop variable C INTEGER M_CENT !Menu item number for 'Calculate Centre' C INTEGER M_REDO !Menu item number for 'Redo Current Conic' C INTEGER NVIEW !No. of view-objects for getting events C INTEGER IVHLIST(3) !List of view-objects for getting events C INTEGER IVH !Returned view-object handle from events input C INTEGER IQUIT !Quit box selected flag =1 yes, =0 no C INTEGER ITEM !Item no. selected from the menu C INTEGER IERR !Error return flag C INTEGER IXPIX !x pixel value from film image view-object C INTEGER IYPIX !y pixel value from film image view-object C INTEGER ISPIX !Pixel position along slow axis C INTEGER IFPIX !Pixel position along fast axis C INTEGER IXSIZ !Spot box half size x C INTEGER IYSIZ !Spot box half size y C INTEGER NOVER !no. of pixels over the threshold value C INTEGER ITHRESH !Threshold value C INTEGER IBG !Background value at spot position C INTEGER ISTYP !Spot method 1=c_of_g, 2=input (cursor) C INTEGER IOP !Option from GETOPT C INTEGER ITYP !Type of number input flag (from INTFP) C INTEGER IV !Integer value returned from INTFP C INTEGER ITM !Parameter table selected item number C INTEGER IP_STYP !Parameter table 3 item: Spot method C INTEGER IP_SBOX !Parameter table 3 item: Spot box size C INTEGER IP_THRESH !Parameter table 3 item: Spot threshold C INTEGER ICONIC !Count of current conic being input C INTEGER JCONIC !Current spot in conic 1-3, start, middle end C INTEGER IFLAG !Flag from refinement routine / parameter status flag C INTEGER IYN !Return flag fro yes-no notice C INTEGER NXRAST !No. x-rasters C INTEGER NYRAST !No. y-rasters C INTEGER IORD !Axis order flag 1-8 C INTEGER ISWAP !Byte swap flag C INTEGER ND !No. of decimal places flag C INTEGER LISTE(2) !Parameter updates list C REAL MM_RAST_X !mm to x-rasters conversion factor C REAL MM_RAST_Y !mm to y-rastrs conversion factor C REAL CGX !x centre of gravity C REAL CGY !y centre of gravity C REAL FP !Floating point value returned from INTFP C REAL XTEMP !Temp. refined x centre position C REAL YTEMP !Temp. refined y centre position C DOUBLE PRECISION CEN(2) !Position of estimated/refined centre C DOUBLE PRECISION ACC !Accuracy parameter for Powell refinement C DOUBLE PRECISION FMIN !Refined minimum value sum of squares C DOUBLE PRECISION FVECC(MAX_CONICS) !Calculated function values C DOUBLE PRECISION W(12) !Work array for Powell refinement C CHARACTER*80 STR !Temporary string C CHARACTER*(MAX_P3SCROLL_CHARS) PVAL !Return string from parameter table 3 C CHARACTER*25 NAMES(2) !Names for the menu items C CHARACTER*25 QUITNAM !Quit box label C CHARACTER*6 SMETHOD(2) !Spot method option strings C CHARACTER*6 SMETHOD_UC(2) !Spot method option strings (upper case) C CHARACTER*11 MSG(3) !Messages indicating which spot to input C CHARACTER*2 VALSTR !paramter value string (dummy) C CHARACTER*2 ERRSTR !Error string (dummy) DATA NAMES /'Redo Current Conic', + 'Calculate Centre'/ DATA QUITNAM /'Abort Centre Calculation'/ DATA SMETHOD /'c_of_g','input'/ DATA SMETHOD_UC /'C_OF_G','INPUT'/ DATA MSG/'start spot','middle spot','end spot'/ C------------------------------------------------------------------------------- C C C====== Clear symbols from image C CALL XDLF_IMAGE_CLEAR_SYMBOLS (IVH_FILM, IERR) C C====== Initialisations C CALL LDM_GET_STHR (SPOT_INPUT_THRESH, IFLAG, ND) CALL LDM_MMRAST (IPACK, IPLATE, MM_RAST_X, MM_RAST_Y) CALL LDM_GET_NXRAS (NXRAST, IFLAG) CALL LDM_GET_NYRAS (NYRAST, IFLAG) CALL LDM_GET_AXORD (VALSTR, IORD, ISWAP, IFLAG) CONICS_COMPLETE = .FALSE. NUM_CONICS = 0 ICONIC = 1 JCONIC = 1 C C====== Set up parameter table 3 C IP_STYP = 1 IP_SBOX = 3 IP_THRESH = 4 ISTYP = 1 CALL XDLF_PARAM_TABLE_SETITEM (IVH_PAR3, IP_STYP, + XDLSTR('Spot method:'), 12, + XDLSTR(SMETHOD(1)),6, 0, 0, IERR) CALL XDLF_PARAM_TABLE_SETMENU (IVH_PAR3, IP_STYP, + 2, XDLSTR(SMETHOD), 6, IERR) WRITE (STR,'(F8.2)') SPOT_INPUT_BOX CALL LJUST (STR) CALL XDLF_PARAM_TABLE_SETITEM (IVH_PAR3, IP_SBOX, + XDLSTR('Spot box (mm):'), 14, + XDLSTR(STR), LENSTR(STR), 0, 0, IERR) WRITE (STR,'(F8.1)') SPOT_INPUT_THRESH CALL LJUST (STR) CALL XDLF_PARAM_TABLE_SETITEM (IVH_PAR3, IP_THRESH, + XDLSTR('Spot threshold:'), 15, + XDLSTR(STR), LENSTR(STR), 0, 1, IERR) C C====== Set up menu C M_REDO = 1 M_CENT = 2 CALL XDLF_MENU_AREA_SETMENU (IVH_MENU, 2, XDLSTR(NAMES), 24, + XDLSTR('Gnomonic Centre Menu'), 20, + XDLSTR(QUITNAM), 24, 0, IERR) C C====== Set up event loop for first menu input C 50 STR = 'Input Conic' CALL STR_ADDI(STR,ICONIC,1) CALL STR_ADDS(STR,MSG(JCONIC),1) CALL XDLF_IMAGE_INPUT_MESSAGE (IVH_FILM, + XDLSTR(STR), 40, IERR) NVIEW = 3 IF (CONICS_COMPLETE) NVIEW = 2 IVHLIST(1) = IVH_MENU IVHLIST(2) = IVH_PAR3 IVHLIST(3) = IVH_FILM 100 CALL XDLF_GET_EVENTS (NVIEW, IVHLIST, IVH) C C====== Menu item selected C IF (IVH.EQ.IVH_MENU) THEN CALL XDLF_MENU_AREA_GETITEM (IVH_MENU, ITEM, IQUIT) C C====== Quit selected C IF (IQUIT.EQ.1) THEN CALL XDLF_PARAM_TABLE_CLEARITEMS (IVH_PAR3, IERR) RETURN END IF C C====== Redo Current Conic C IF (ITEM.EQ.M_REDO) THEN IF (CONICS_COMPLETE) GO TO 100 IF (JCONIC.EQ.1) GO TO 100 JCONIC = 1 CALL XDLF_IMAGE_CLEAR_SYMBOLS(IVH_FILM, IERR) IF (NUM_CONICS.EQ.0) GO TO 50 DO 220 I=1,NUM_CONICS DO 210 J=1,3 CALL XDLF_IMAGE_SYMBOL(IVH_FILM, + NINT(XCONIC(J,I)), NINT(YCONIC(J,I)), + ISYMBTYP(7),ICOLRTYP(7), 1, IERR) 210 CONTINUE 220 CONTINUE GO TO 50 C C====== Calculate Centre C ELSE IF (ITEM.EQ.M_CENT) THEN IF (.NOT.CONICS_COMPLETE + .AND.JCONIC.NE.1) THEN CALL ERR_NOTICE(1,'**Last conic not completed**') GO TO 100 END IF IF (NUM_CONICS.LT.3) THEN CALL ERR_NOTICE(1,'**Minimum of three conics needed**') GO TO 100 END IF CEN(1) = NXRAST/2.0 CEN(2) = NYRAST/2.0 ACC = 1.0D-8 CALL SSQMIN(NUM_CONICS,2,CEN,ACC,100,GDIST_FN,FMIN, + FVECC,IFLAG,W) IF (IFLAG.EQ.-1) THEN CALL ERR_NOTICE(1,'**Failure(s) finding line minima**') GO TO 100 END IF CALL XDLF_VIEW_OBJECT_RAISE (IVH_BASE, IERR) IF (IFLAG.EQ.-1) THEN CALL LMESSAGE(IVH_IOW, + '*Refinement terminated after 100 iterations*') ELSE STR = 'Refinement completed after' CALL STR_ADDI(STR,IFLAG,1) CALL STR_ADDS(STR,'iterations',1) CALL LMESSAGE(IVH_IOW,STR) ENDIF STR = 'Refined centre: x =' XTEMP = CEN(1) YTEMP = CEN(2) CALL STR_ADDF(STR,XTEMP,2,1) CALL STR_ADDS(STR,', y =',0) CALL STR_ADDF(STR,YTEMP,2,1) CALL LMESSAGE(IVH_IOW,STR) CEN_OK = .TRUE. CALL IOW_ASKQ(IVH_IOW,'Accept value for the centre', + CEN_OK) CALL XDLF_VIEW_OBJECT_RAISE (IVH_FILM, IERR) IF (CEN_OK) THEN XCEN_SPOTS = XTEMP YCEN_SPOTS = YTEMP IXCEN_SPOTS = NINT(XCEN_SPOTS) IYCEN_SPOTS = NINT(YCEN_SPOTS) CALL XDLF_PARAM_TABLE_CLEARITEMS (IVH_PAR3, IERR) RETURN END IF GO TO 50 END IF GO TO 100 C C====== Spot position input C ELSE IF (IVH.EQ.IVH_FILM) THEN CALL XDLF_IMAGE_GETPIX (IVH_FILM, IXPIX, IYPIX, IERR) IF (ISTYP.EQ.1) THEN IXSIZ = NINT (SPOT_INPUT_BOX*MM_RAST_X) IXSIZ = IXSIZ/2 IF (IXSIZ.LT.1) IXSIZ = 1 IF (IXSIZ.GT.MAX_HALF_BOX) THEN CALL ERR_NOTICE (0,'**Spot box size too large**') GO TO 100 END IF IYSIZ = NINT (SPOT_INPUT_BOX*MM_RAST_Y) IYSIZ = IYSIZ/2 IF (IYSIZ.LT.1) IYSIZ = 1 IF (IYSIZ.GT.MAX_HALF_BOX) THEN CALL ERR_NOTICE (0,'**Spot box size too large**') GO TO 100 END IF CALL SFPIX (IXPIX,IYPIX,ISPIX,IFPIX) CALL XDLF_BG_VALIMG(ISPIX,IFPIX,IMG_BG,ITYPE,NF_BGOFF, + NCMP, IBG, IERR) ITHRESH = IBG + NINT(SPOT_INPUT_THRESH) CALL SPOT_C_OF_G (IXPIX, IYPIX, IXSIZ, IYSIZ, ISPOT_DATA, + ISWORK, ITHRESH, IMG, ITYPE, IORD, NFRASTS, + NXRAST, NYRAST, NOVER, + CGX, CGY, IERR) IF (IERR.LT.0) THEN CALL ERR_NOTICE (0,'**Error in spot_c_of_g call**') GO TO 100 ELSE IF (IERR.EQ.2) THEN CALL ERR_NOTICE (0, + '**Spot box outside range of image**') GO TO 100 ELSE IF (NOVER.EQ.0) THEN CALL ERR_NOTICE (0,'**No pixels above threshold**') GO TO 100 END IF IXPIX = NINT (CGX) IF (IXPIX.LT.1) IXPIX = 1 IF (IXPIX.GT.NXRAST) IXPIX = NXRAST IYPIX = NINT (CGY) IF (IYPIX.LT.1) IYPIX = 1 IF (IYPIX.GT.NYRAST) IYPIX = NYRAST END IF IF (ISTYP.EQ.1) THEN XCONIC(JCONIC,ICONIC) = CGX YCONIC(JCONIC,ICONIC) = CGY ELSE XCONIC(JCONIC,ICONIC) = IXPIX YCONIC(JCONIC,ICONIC) = IYPIX END IF C C====== Display symbol C CALL XDLF_IMAGE_SYMBOL (IVH_FILM, + NINT(XCONIC(JCONIC,ICONIC)), + NINT(YCONIC(JCONIC,ICONIC)), + ISYMBTYP(7), ICOLRTYP(7), 1, IERR) IF (JCONIC.EQ.3) THEN NUM_CONICS = NUM_CONICS + 1 IF (NUM_CONICS.EQ.MAX_CONICS) THEN CALL ERR_NOTICE (1,'*All Allowed Conics now Input*') CONICS_COMPLETE = .TRUE. GO TO 100 ELSE ICONIC = ICONIC + 1 END IF JCONIC = 1 ELSE JCONIC = JCONIC + 1 END IF GO TO 50 C C====== Parameter table input C ELSE IF (IVH.EQ.IVH_PAR3) THEN CALL XDLF_PARAM_TABLE_GETVALUE (IVH_PAR3, ITM, + XDLSTR(PVAL), MAX_P3SCROLL_CHARS, IERR) IF (ITM.EQ.IP_STYP) THEN CALL LJUST (PVAL) CALL CCPUPC (PVAL) CALL GETOPT (SMETHOD_UC, 2, PVAL, IOP, IERR) IF (IERR.EQ.1) THEN CALL XDLF_PARAM_TABLE_ERROR (IVH_PAR3, ITM, + XDLSTR('**Ambiguous selection**'), 23, IERR) GO TO 100 END IF IF (IERR.EQ.2) THEN CALL XDLF_PARAM_TABLE_ERROR (IVH_PAR3, ITM, + XDLSTR('**Invalid Method**'), 18, IERR) RETURN END IF ISTYP = IOP CALL XDLF_PARAM_TABLE_SETVALUE (IVH_PAR3, ITM, + XDLSTR(SMETHOD(ISTYP)), 6, 0, IERR) ELSE IF (ITM.EQ.IP_SBOX) THEN ITYP = INTFP (PVAL, FP, IV) IF (ITYP.EQ.0) THEN CALL XDLF_PARAM_TABLE_ERROR (IVH_PAR3, ITM, + XDLSTR('**Invalid Number Format**'), 25, IERR) GO TO 100 END IF IF (FP.LE.0) THEN CALL XDLF_PARAM_TABLE_ERROR (IVH_PAR3, ITM, + XDLSTR('**Value must be greater than zero**'), 35, IERR) GO TO 100 END IF SPOT_INPUT_BOX = FP WRITE (STR,'(F8.2)') SPOT_INPUT_BOX CALL LJUST(STR) CALL XDLF_PARAM_TABLE_SETVALUE (IVH_PAR3, ITM, + XDLSTR(STR), LENSTR(STR), 0, IERR) ELSE IF (ITM.EQ.IP_THRESH) THEN ITYP = INTFP (PVAL, FP, IV) IF (ITYP.EQ.0) THEN CALL XDLF_PARAM_TABLE_ERROR (IVH_PAR3, ITM, + XDLSTR('**Invalid Number Format**'), 25, IERR) GO TO 100 END IF IF (FP.LE.0) THEN CALL XDLF_PARAM_TABLE_ERROR (IVH_PAR3, ITM, + XDLSTR('**Value must be greater than zero**'), 35, IERR) GO TO 100 END IF SPOT_INPUT_THRESH = FP WRITE (STR,'(F8.1)') SPOT_INPUT_THRESH CALL LJUST(STR) CALL XDLF_PARAM_TABLE_SETVALUE (IVH_PAR3, ITM, + XDLSTR(STR), LENSTR(STR), 0, IERR) CALL LDM_SET_STHR (SPOT_INPUT_THRESH, IERR, ERRSTR) LISTE(1) = IP_STHR CALL SET_PAR1_VALS (1, LISTE) END IF GO TO 100 END IF GO TO 100 END C LAST UPDATE: C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************* C** HCF ** C************************* C C INTEGER FUNCTION HCF (II,JJ) C INCLUDE 'implicit_none.finc' C C Purpose: To calculate h.c.f. of 2 integers C C Author: Based on code from GENLAUE by Clifton et al. C C Arguments: C INTEGER II INTEGER JJ C C II (R) First integer C JJ (R) Second integer C C====== LOCALS: C INTEGER I, J, ISAV, K C C------------------------------------------------------------------------------ C I = II J = JJ IF (I.EQ.J) THEN HCF = I RETURN END IF IF (I.LT.J) THEN ISAV = I I = J J = ISAV END IF IF (J.EQ.0) THEN HCF = I RETURN END IF 20 K = MOD(I,J) IF (K.EQ.0) THEN HCF = J RETURN END IF I = J J = K GO TO 20 END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C*************************** C** IMAGE_COLOURS ** C*************************** C SUBROUTINE IMAGE_COLOURS (IRED, IGREEN, IBLUE) C C Purpose: Get 64 colour colourscale for false coloured images C C blue...green...yellow...orange...red (low...high) C C Author: John W. Campbell, December 1993 C C Arguments: C INTEGER IRED(64) INTEGER IGREEN(64) INTEGER IBLUE(64) C IRED (W) Red components for the 64 colours (0-65535) C IGREEN (W) Green components for the 64 colours (0-65535) C IBLUE (W) Blue components for the 64 colours (0-65535) C C====== FUNCTION TYPES: C C C====== LOCALS: C INTEGER I INTEGER ICOLR INTEGER IV REAL H REAL S REAL V REAL R REAL G REAL B REAL TH REAL P1 REAL P2 REAL P3 REAL FR C INTEGER I !Temp variable C INTEGER ICOLR !Colours loop variable C INTEGER IV !Integer value C REAL H !Hue 0-1.0 C REAL S !Saturation 0-1.0 C REAL V !Value 0-1.0 C REAL R !Red component 0-1.0 C REAL G !Green component 0-1.0 C REAL B !Blue component C REAL TH !Hue angle C REAL P1 !Temp variable C REAL P2 !Temp variable C REAL P3 !Temp variable C REAL FR !Fraction C C------------------------------------------------------------------------------- C C====== Loop through the 64 colours C DO 100 ICOLR = 1, 64 TH = 3.14159*(ICOLR-1)/63.0 H = 240.0*(1.0-COS(TH))/2.0 S = 1.0 V = 1.0 C C====== Convert to RGB C IF (H.EQ.360.0) H = 0.0 H = H/60.0 IV = FLOAT(INT(H)) FR = H - IV P1 = V * (1.0-S) P2 = V * (1.0 - (S*FR)) P3 = V * (1.0 - (S * (1.0-FR))) I = INT(IV) IF (I.EQ.0) THEN R = V G = P3 B = P1 ELSE IF (I.EQ.1) THEN R = P2 G = V B = P1 ELSE IF (I.EQ.2) THEN R = P1 G = V B = P3 ELSE IF (I.EQ.3) THEN R = P1 G = P2 B = V ELSE IF (I.EQ.4) THEN R = P3 G = P1 B = V ELSE IF (I.EQ.5) THEN R = V G = P1 B = P2 END IF C C====== Store RGB colour components C IRED(65-ICOLR) = 65535*R IGREEN(65-ICOLR) = 65535*G IBLUE(65-ICOLR) = 65535*B 100 CONTINUE RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** INDANG ** C************************** C C SUBROUTINE INDANG C INCLUDE 'implicit_none.finc' C C C Purpose: This is a dual purpose routine C if nref=0 on entry then first generate reflections with small hkl C otherwise nref reflections have already been generated C C Author: Modified version of M. Elder's routine C C Arguments: C C None C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'lauegen_auto_params.finc' C C====== FUNCTION TYPES: C C C====== LOCALS: C LOGICAL ABSNT INTEGER I,II,IIT,IITT,ITEST,J,JJ,JJT,JJTT,JTEST,KK,KKT,KKTT,M,MM INTEGER ISYST, IFLAG, ND, LATT REAL CELL(6) INTEGER NMAX,NRAD2 REAL AA(3,3),AC1(3,3),AC2(3,3),AC3(3,3),AC4(3,3),AC5(3,3) REAL AC6(3,3) REAL RCELL(6), CCELL(6) CHARACTER*80 STR CHARACTER*2 VALSTR C C------------------------------------------------------------------------------- C CALL LDM_GET_LATT (VALSTR, LATT, IFLAG) IF (NREF_AUT.LE.0) THEN C C====== Generate reflections in a sphere, maximum index is limited by C====== the nrad2 limit which follows C NMAX = MAX_AUTO_INDX NRAD2 = NRAD2_AUT DO 60 II = -NMAX , NMAX ITEST = II**2 IF (ITEST.LE.NRAD2) THEN DO 50 JJ = -NMAX , NMAX JTEST = ITEST + JJ**2 IF (JTEST.LE.NRAD2) THEN DO 40 KK = -NMAX , NMAX IF ((JTEST+KK**2).GT.NRAD2) GO TO 40 IF (II.EQ.0 .AND. JJ.EQ.0 .AND. KK.EQ.0) + GO TO 40 C C====== Identify harmonics C DO 30 M = 2 , NMAX IF ((IABS(MOD(II,M))+IABS(MOD(JJ,M))+IABS(MOD + (KK,M))).EQ.0) THEN IF (LATT.EQ.1) GO TO 40 IIT = II/M JJT = JJ/M KKT = KK/M DO 20 MM = 1 , M - 1 IITT = IIT*MM JJTT = JJT*MM KKTT = KKT*MM C C====== and eliminate them if the fundamental or lower harmonic is present. C CALL LDM_SYSABS(IITT,JJTT,KKTT,ABSNT) IF (.NOT.ABSNT) GO TO 40 20 CONTINUE END IF 30 CONTINUE C C====== Eliminate systematic absences if there are any C IF (LATT.NE.1) THEN CALL LDM_SYSABS(II,JJ,KK,ABSNT) IF (ABSNT) GO TO 40 END IF NREF_AUT = NREF_AUT + 1 INDX_AUT(NREF_AUT,1) = II INDX_AUT(NREF_AUT,2) = JJ INDX_AUT(NREF_AUT,3) = KK IF (NREF_AUT.EQ.MAX_AUTO_REFS) THEN STR = '*Only room for' CALL STR_ADDI(STR,MAX_AUTO_REFS,1) CALL STR_ADDS(STR,'standard reflections*',1) CALL LMESSAGE (IVH_IOW,STR) CALL LMESSAGE (IVH_IOW,'*Sphere incomplete*') GO TO 70 END IF 40 CONTINUE END IF 50 CONTINUE END IF 60 CONTINUE WRITE(STR,'(I10)')NREF_AUT CALL LJUST(STR) CALL STR_ADDS(STR,'reflections stored',1) CALL LMESSAGE(IVH_IOW,STR) END IF C C====== Evaluate the standard orientation matrix and then the r. l. coords C 70 DO 72 I=1,3 DO 71 J=1,3 AA(I,J) = 0.0 71 CONTINUE 72 CONTINUE CALL LDM_GET_A (CELL(1), IFLAG, ND) CALL LDM_GET_B (CELL(2), IFLAG, ND) CALL LDM_GET_C (CELL(3), IFLAG, ND) CALL LDM_GET_ALPHA (CELL(4), IFLAG, ND) CALL LDM_GET_BETA (CELL(5), IFLAG, ND) CALL LDM_GET_GAMMA (CELL(6), IFLAG, ND) CALL RECCEL(RCELL,CELL,1.0) CALL LDM_GET_SYST (VALSTR, ISYST, IFLAG) CALL CELLCX(ISYST,CCELL,RCELL,2,2) CALL MATS(AA,AC1,AC2,AC3,AC4,AC5,AC6,CCELL) DO 80 I = 1 , NREF_AUT XREF_AUT(1,I) = AA(1,1)*INDX_AUT(I,1) + AA(1,2)*INDX_AUT(I,2) + + AA(1,3)*INDX_AUT(I,3) XREF_AUT(2,I) = AA(2,1)*INDX_AUT(I,1) + AA(2,2)*INDX_AUT(I,2) + + AA(2,3)*INDX_AUT(I,3) XREF_AUT(3,I) = AA(3,1)*INDX_AUT(I,1) + AA(3,2)*INDX_AUT(I,2) + + AA(3,3)*INDX_AUT(I,3) XREF_AUT(4,I) = SQRT(XREF_AUT(1,I)**2+XREF_AUT(2,I)**2 + +XREF_AUT(3,I)**2) 80 CONTINUE C C====== Now loop through all pairs of reflections calculating inter-planar C====== angles C DO 100 I = 1 , NREF_AUT DO 90 J = 1 , I IF (I.EQ.J) THEN A_AUT(I,J) = 0.0 GO TO 90 END IF A_AUT(I,J) = (XREF_AUT(1,I)*XREF_AUT(1,J) + +XREF_AUT(2,I)*XREF_AUT(2,J) + +XREF_AUT(3,I)*XREF_AUT(3,J)) + /(XREF_AUT(4,I)*XREF_AUT(4,J)) IF (ABS(A_AUT(I,J)).GT.0.9999) THEN A_AUT(I,J) = 1. END IF A_AUT(I,J) = ACOS(A_AUT(I,J)) A_AUT(J,I) = A_AUT(I,J) 90 CONTINUE 100 CONTINUE RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** INDCHK ** C************************** C C SUBROUTINE INDCHK(I,ITEST) C INCLUDE 'implicit_none.finc' C C Purpose: Check to see if reflection in position i of indx is in the C unique set of reflections because of lattice symmetry. C return itest=1 if so, else itest=0. C C Author: Modified version of M. Elder's routine C C Arguments: C INTEGER I INTEGER ITEST C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'lauegen_auto_params.finc' C C====== FUNCTION TYPES: C C C====== LOCALS: C INTEGER IH,IK,IL,ISYST,IFLAG CHARACTER*2 VALSTR C C------------------------------------------------------------------------------- C CALL LDM_GET_SYST (VALSTR, ISYST, IFLAG) ITEST = 0 IH = INDX_AUT(I,1) IK = INDX_AUT(I,2) IL = INDX_AUT(I,3) IF (ISYST.EQ.2) THEN C C====== Monoclinic C IF (IK.LT.0) RETURN IF (IH.LT.0) RETURN IF (IH.EQ.0 .AND. IL.LT.0) RETURN GO TO 20 ELSE IF (ISYST.EQ.3) THEN C C====== Orthorhombic C IF (IH.LT.0) RETURN IF (IK.LT.0) RETURN IF (IL.LT.0) RETURN GO TO 20 ELSE IF (ISYST.EQ.4) THEN C C====== Tetragonal C IF (IH.LT.0) RETURN IF (IK.LT.0) RETURN IF (IL.LT.0) RETURN IF (IH.GT.IK) RETURN GO TO 20 ELSE IF (ISYST.EQ.5) THEN C C====== Hexagonal C IF (IH.LT.0) RETURN IF (IL.LT.0) RETURN IF (IK.LT.0) RETURN IF (IK.GT.IH) RETURN GO TO 20 ELSE IF (ISYST.EQ.6) THEN C C====== Rhombohedral C IF (IH.LT.0) RETURN IF (IK.LT.0) RETURN ELSE IF (ISYST.NE.7) THEN C C====== Triclinic C IF (IH.LT.0) RETURN IF (IH.EQ.0 .AND. IK.LT.0) RETURN IF (IH.EQ.0 .AND. IK.EQ.0 .AND. IL.LT.0) RETURN GO TO 20 END IF C C====== Cubic C IF (IH.LT.0) RETURN IF (IK.LT.0) RETURN IF (IL.LT.0) RETURN IF (IH.GT.IK) RETURN IF (IK.GT.IL) RETURN C C====== Acceptable C 20 ITEST = 1 RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** INDMAT ** C************************** C C SUBROUTINE INDMAT(NOBS,ANGL,NSOL,IPSOL,MAX_M) C INCLUDE 'implicit_none.finc' C C Purpose: Try to match the spots C C Target is at least 3 matches of nobs nodals against nref C calculated spots. C C Aim at 3 matches (max_m), with angles between spots agreeing with C pre-calculated angles to within delta (difference of cosines). C C Author: Modified version of M. Elder's routine C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' C C Arguments: C INTEGER NOBS REAL ANGL(MAX_AUTO_SPOTS,MAX_AUTO_SPOTS) INTEGER NSOL INTEGER IPSOL(MAX_AUTO_SOLNS,MAX_AUTO_SPOTS) INTEGER MAX_M C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'lauegen_auto_params.finc' INCLUDE 'film_pack.finc' C C====== FUNCTION TYPES: C C C====== LOCALS: C REAL DELTA_ANG REAL CTOF INTEGER I,IPJ,ITEST,J,K,MC,N INTEGER IP(MAX_AUTO_SPOTS),KP(2,3),KPP(2) INTEGER IFLAG, ND, IERR CHARACTER*2 ERRSTR C C------------------------------------------------------------------------------- C C====== Set angular tolerance C CALL LDM_GET_CTOF (IPACK, IPLATE, CTOF, IFLAG, ND, IERR, ERRSTR) DELTA_ANG = 1.4*ATAN2(1.4*SPERR,CTOF) MAX_M = 4 C C====== NSOL counts equivalent solutions (sets of matches having same max_m) C====== I moves along the standard reflections (up to nref) C====== MC counts matches so far in the solution being studied C====== N moves along the user's measured spots (up to nobs) C NSOL = 0 I = 1 MC = 0 N = 1 C C====== If there is no match so far then the present possible match must C====== be assumed to be true C 20 IF (MC.EQ.0) THEN C C====== Before accepting this first match check that it is not going to C====== introduce unnecessary ambiguities because of lattice symmetry. C CALL INDCHK(I,ITEST) IF (ITEST.EQ.0) GO TO 70 GO TO 40 END IF C C====== Determine if this possible match is compatible with earlier ones C====== the requirement is that all angle pairs involving this match must C====== agree with the corresponding calculated standard pairs C DO 30 J = 1 , N - 1 IPJ = IP(J) IF (IPJ.NE.0) THEN IF (ABS(ANGL(N,J)-A_AUT(IPJ,I)).GT.DELTA_ANG) GO TO 70 END IF 30 CONTINUE C C====== All pairs agree so this match is acceptable - add to list C====== IP is the array containing the matches for the current solution C 40 IP(N) = I MC = MC + 1 C C====== Take the next of the spots in the input list C====== try to match it first against the first standard C 50 IF (N.EQ.NOBS) THEN C C====== End of a solution - test how many matches C IF (MC.GE.MAX_M) THEN IF (MC.GT.MAX_M) THEN C C====== The best solution so far C NSOL = 1 MAX_M = MC ELSE C C====== Another equally good solution C NSOL = NSOL + 1 END IF C C====== Add this solution to the list - but do not overflow the array C IF (NSOL.LE.MAX_AUTO_SOLNS) THEN DO 60 K = 1 , NOBS IPSOL(NSOL,K) = IP(K) 60 CONTINUE END IF END IF GO TO 80 ELSE N = N + 1 I = 1 GO TO 20 END IF C C====== Try the next of the standards as a possible match C 70 IF (I.EQ.NREF_AUT) THEN C C====== This spot can not be matched successfully C IP(N) = 0 C C====== To avoid wasting time - check that it is still possible to reach C====== the target (max_m) even if all remaining spots can be matched C IF ((MC+NOBS-N).GE.MAX_M) GO TO 50 ELSE I = I + 1 GO TO 20 END IF C C====== This point is where the last step in the current solution is C====== reversed and a new solution looked for C 80 I = IP(N) IF (I.GT.0) THEN MC = MC - 1 GO TO 70 ELSE N = N - 1 IF (N.GT.0) GO TO 80 C C====== The end C RETURN END IF END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C*************************** C** INIT_FLAGS ** C*************************** C SUBROUTINE INIT_FLAGS C C Purpose: Initialise program flags C C Author: John W. Campbell, September 1994 C C Arguments: C C None C C====== GLOBALS: C INCLUDE 'prog_flags.finc' C C====== FUNCTION TYPES: C C C====== LOCALS: C C C------------------------------------------------------------------------------- C FILM_READ = .FALSE. FILM_OPEN = .FALSE. PROCESS = .FALSE. IPACK_OPN = 0 IPLATE_OPN = 0 RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** INIT_LIRL ** C************************** C C SUBROUTINE INIT_LIRL C INCLUDE 'implicit_none.finc' C C Purpose: Initialise LIRL and integration flags C C Author: John W. Campbell, December 1995 C C Arguments: C C None C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'lirl_pars.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR INTEGER LDM_PKMAX INTEGER LDM_PLMAX C C====== LOCALS: C INTEGER I INTEGER NFLAGS INTEGER IERR INTEGER IARR(2) C INTEGER I !Temp/loop variable C INTEGER NFLAGS !No. of integration flags C INTEGER IERR !Error flag C INTEGER IARR(2) !Array for setting flag C C------------------------------------------------------------------------------- C C====== Initialise or re-initialise LIRL C IF (KDX_LIRL.GE.0) THEN CALL LIRLF_FREE (KDX_LIRL, IERR) KDX_LIRL = -1 END IF CALL LIRLF_INIT (1000, 1000, 0, 0, KDX_LIRL) IF (KDX_LIRL.LT.0) THEN WRITE (6,2001) KDX_LIRL STOP END IF C C====== Set up integration flags list if required C NFLAGS = LDM_PKMAX(0)*LDM_PLMAX(0) IF (KDX_INTFLAGS.LT.0) THEN CALL DMLF_INIT (NFLAGS, 10, 1, KDX_INTFLAGS) IF (KDX_INTFLAGS.LT.0) THEN WRITE (6,2002) KDX_INTFLAGS STOP END IF IARR(1) = 0 DO 100 I = 1, NFLAGS CALL DMLF_ADDREC (KDX_INTFLAGS, IARR, IERR) 100 CONTINUE ELSE C C====== Clear integration flags C IARR(1) = 0 DO 110 I = 1, NFLAGS CALL DMLF_PUTREC (KDX_INTFLAGS, I, IARR, IERR) 110 CONTINUE END IF C C====== Clear profiles determined flags C IPRF_PK = 0 IPRF_PL = 0 C C====== Clear last integrated plate flags C INTEG_LASTPK = 0 INTEG_LASTPL = 0 C C====== Format statements C 2001 FORMAT (/,'**Error** Cannot allocate LIRL, code =',I3,/) 2002 FORMAT (/,'**Error** Cannot allocate integration flags', + ', code =',I3,/) C END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C*************************** C** INIT_SETTINGS ** C*************************** C SUBROUTINE INIT_SETTINGS C C Purpose: Initialise program parameter settings C C Author: John W. Campbell, September 1994 C C Arguments: C C None C C C====== PARAMETERS: C INCLUDE 'lauegen_limits.finc' C C====== GLOBALS: C INCLUDE 'film_pack.finc' INCLUDE 'gnom_rmin.finc' INCLUDE 'get_soft.finc' INCLUDE 'spot_sizes.finc' INCLUDE 'lauegen_observed_spots.finc' INCLUDE 'matches.finc' C C====== FUNCTION TYPES: C C C====== LOCALS: C LOGICAL IDUM_PRF_ROT INTEGER IDUM_NPROF REAL RDUM_PROMIN C LOGICAL IDUM_PRF_ROT !Dummy value for prf_rot (LAUEGEN uses its own C extended LDM parameter value) C INTEGER IDUM_NPROF !Dummy value for nprof (LAUEGEN uses its own C extended LDM parameter value) C REAL RDUM_PROMIN !Dummy value for promin (LAUEGEN uses its own C extended LDM parameter value) C C------------------------------------------------------------------------------- C IPACK = 1 IPLATE = 1 NUM_OBS = 0 NUM_MATCH = 0 NUM_SELECT = 0 NUM_INP_SPOTS = 0 IFILM_SPOTS = 0 SPOT_INPUT_BOX = 1.0 GNOMR = 0.0 CALL LFN_SOFT_DF (1, MAX_SOFT_BINS, IDUM_NPROF, IDUM_PRF_ROT, + RDUM_PROMIN, SOFT_FRAC, + SOFT_SIGTEST, SOFT_FRTEST, + ISOFT_D_NUMBINS, SOFT_DMIN_WIDTH) CALL LFN_SOFT_DF (2, MAX_SOFT_BINS, IDUM_NPROF, IDUM_PRF_ROT, + RDUM_PROMIN, SOFT_FRAC, + SOFT_SIGTEST, SOFT_FRTEST, + ISOFT_L_NUMBINS, SOFT_LMIN_WIDTH) CALL SPOTSIZE_DFLTS (ISPOT_NBIN, SPOT_SDCUT, SPOT_THRFAC, + SPOT_EXPAND) RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** INPUT_SPOTS ** C************************** C C SUBROUTINE INPUT_SPOTS C INCLUDE 'implicit_none.finc' C C Purpose: Input measured spot positions (esp. for auto-indexing) C C Author: John W. Campbell, February 1992 C C Arguments: C C None C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' INCLUDE 'screen_params.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'ip1_entries.finc' INCLUDE 'image.finc' INCLUDE 'file_units.finc' INCLUDE 'spot_data.finc' INCLUDE 'meas_spots.finc' INCLUDE 'symbol_types.finc' INCLUDE 'film_pack.finc' INCLUDE 'spot_box.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR INTEGER INTFP INTEGER LENSTR C C====== LOCALS: C INTEGER I INTEGER I_ADD INTEGER I_DEL INTEGER IADDEL INTEGER NVIEW INTEGER IVHLIST(3) INTEGER IVH INTEGER IQUIT INTEGER ITEM INTEGER IERR INTEGER IXPIX INTEGER IYPIX INTEGER ISPIX INTEGER IFPIX INTEGER IXSIZ INTEGER IYSIZ INTEGER NOVER INTEGER ID INTEGER IDSQMIN INTEGER IDSQLIM INTEGER ISPOT INTEGER ITHRESH INTEGER IBG INTEGER ISTYP INTEGER IOP INTEGER ITYP INTEGER IV INTEGER ITM INTEGER IP_STYP INTEGER IP_SBOX INTEGER IP_THRESH INTEGER NXRAST INTEGER NYRAST INTEGER IFLAG INTEGER IORD INTEGER ISWAP INTEGER ND INTEGER LISTE(2) REAL MM_RAST_X REAL MM_RAST_Y REAL CGX REAL CGY REAL FP CHARACTER*80 STR CHARACTER*(MAX_P3SCROLL_CHARS) PVAL CHARACTER*25 NAMES(2) CHARACTER*25 QUITNAM CHARACTER*6 SMETHOD(2) CHARACTER*6 SMETHOD_UC(2) CHARACTER*2 VALSTR CHARACTER*2 ERRSTR C INTEGER I !Loop counter C INTEGER I_ADD !Menu item number for 'Add Spots' C INTEGER I_DEL !Menu item number for 'Delete Spots' C INTEGER IADDEL !Flag =1 add, =2 delete spots C INTEGER NVIEW !No. of view-objects for getting events C INTEGER IVHLIST(3) !List of view-objects for getting events C INTEGER IVH !Returned view-object handle from events input C INTEGER IQUIT !Quit box selected flag =1 yes, =0 no C INTEGER ITEM !Item no. selected from the menu C INTEGER IERR !Error return flag C INTEGER IXPIX !x pixel value from film image view-object C INTEGER IYPIX !y pixel value from film image view-object C INTEGER ISPIX !Pixel position along slow axis C INTEGER IFPIX !Pixel position along fast axis C INTEGER IXSIZ !Spot box half size x C INTEGER IYSIZ !Spot box half size y C INTEGER NOVER !no. of pixels over the threshold value C INTEGER ID !Distance squared C INTEGER IDSQMIN !Minimum distance squared so far found C INTEGER IDSQLIM !Max limit of IDSQMIN to consider a match C INTEGER ISPOT !Spot number of closest selected spot C INTEGER ITHRESH !Threshold value C INTEGER IBG !Background value at spot position C INTEGER ISTYP !Spot method 1=c_of_g, 2=input (cursor) C INTEGER IOP !Option from GETOPT C INTEGER ITYP !Type of number input flag (from INTFP) C INTEGER IV !Integer value returned from INTFP C INTEGER ITM !Parameter table selected item number C INTEGER IP_STYP !Parameter table 3 item: Spot method C INTEGER IP_SBOX !Parameter table 3 item: Spot box size C INTEGER IP_THRESH !Parameter table 3 item: Spot threshold C INTEGER NXRAST !No. x-rasters C INTEGER NYRAST !No. y-rasters C INTEGER IFLAG !Parameter status flag C INTEGER IORD !Axis order flag 1-8 C INTEGER ISWAP !Byte swap flag C INTEGER ND !No. of decimal places flag C INTEGER LISTE(2) !Parameter updates list C REAL MM_RAST_X !mm to x-rasters conversion factor C REAL MM_RAST_Y !mm to y-rastrs conversion factor C REAL CGX !x centre of gravity C REAL CGY !y centre of gravity C REAL FP !Floating point value returned from INTFP C CHARACTER*80 STR !Temporary string C CHARACTER*(MAX_P3SCROLL_CHARS) PVAL !Return string from parameter table 3 C CHARACTER*25 NAMES(2) !Names for the menu items C CHARACTER*25 QUITNAM !Quit box label C CHARACTER*6 SMETHOD(2) !Spot method option strings C CHARACTER*6 SMETHOD_UC(2) !Spot method option strings (upper case) C CHARACTER*2 VALSTR !paramter value string (dummy) C CHARACTER*2 ERRSTR !Error string (dummy) DATA NAMES /'Add Spots', + 'Delete Spots'/ DATA QUITNAM /'End Spots Input'/ DATA SMETHOD /'c_of_g','input'/ DATA SMETHOD_UC /'C_OF_G','INPUT'/ C------------------------------------------------------------------------------- C C====== Set IDSQLIM C IDSQLIM = 18 * NCMP * NCMP C C====== Other initialisations C CALL LDM_GET_STHR (SPOT_INPUT_THRESH, IFLAG, ND) CALL LDM_MMRAST (IPACK, IPLATE, MM_RAST_X, MM_RAST_Y) CALL LDM_GET_NXRAS (NXRAST, IFLAG) CALL LDM_GET_NYRAS (NYRAST, IFLAG) CALL LDM_GET_AXORD (VALSTR, IORD, ISWAP, IFLAG) C C====== Set up parameter table 3 C IP_STYP = 1 IP_SBOX = 3 IP_THRESH = 4 ISTYP = 1 CALL XDLF_PARAM_TABLE_SETITEM (IVH_PAR3, IP_STYP, + XDLSTR('Spot method:'), 12, + XDLSTR(SMETHOD(1)),6, 0, 0, IERR) CALL XDLF_PARAM_TABLE_SETMENU (IVH_PAR3, IP_STYP, + 2, XDLSTR(SMETHOD), 6, IERR) WRITE (STR,'(F8.2)') SPOT_INPUT_BOX CALL LJUST (STR) CALL XDLF_PARAM_TABLE_SETITEM (IVH_PAR3, IP_SBOX, + XDLSTR('Spot box (mm):'), 14, + XDLSTR(STR), LENSTR(STR), 0, 0, IERR) WRITE (STR,'(F8.1)') SPOT_INPUT_THRESH CALL LJUST (STR) CALL XDLF_PARAM_TABLE_SETITEM (IVH_PAR3, IP_THRESH, + XDLSTR('Spot threshold:'), 15, + XDLSTR(STR), LENSTR(STR), 0, 1, IERR) C C====== Set up menu C I_ADD = 1 I_DEL = 2 CALL XDLF_MENU_AREA_SETMENU (IVH_MENU, 2, XDLSTR(NAMES), 24, * XDLSTR('Input Spots'), 11, * XDLSTR(QUITNAM), 24, 0, IERR) C C====== Set up event loop for first menu input C IADDEL = 1 CALL XDLF_IMAGE_INPUT_MESSAGE (IVH_FILM, * XDLSTR('Input Spot Positions'), 20, IERR) NVIEW = 3 IVHLIST(1) = IVH_MENU IVHLIST(2) = IVH_FILM IVHLIST(3) = IVH_PAR3 100 CALL XDLF_GET_EVENTS (NVIEW, IVHLIST, IVH) C C====== Menu item selected C IF (IVH.EQ.IVH_MENU) THEN CALL XDLF_MENU_AREA_GETITEM (IVH_MENU, ITEM, IQUIT) C C====== Quit selected C IF (IQUIT.EQ.1) THEN CALL XDLF_PARAM_TABLE_CLEARITEMS (IVH_PAR3, IERR) RETURN END IF C C====== Add spots C IF (ITEM.EQ.I_ADD) THEN IADDEL = 1 CALL XDLF_IMAGE_INPUT_MESSAGE (IVH_FILM, * XDLSTR('Input Spot Positions'), 20, IERR) GO TO 100 C C====== Delete spots C ELSE IF (ITEM.EQ.I_DEL) THEN IADDEL = 2 CALL XDLF_IMAGE_INPUT_MESSAGE (IVH_FILM, * XDLSTR('Select Spots to Delete'), 22, IERR) GO TO 100 END IF GO TO 100 C C====== Spot position input C ELSE IF (IVH.EQ.IVH_FILM) THEN C C====== Add spot: Find spot C IF (IADDEL.EQ.1) THEN CALL XDLF_IMAGE_GETPIX (IVH_FILM, IXPIX, IYPIX, IERR) IF (ISTYP.EQ.1) THEN IXSIZ = NINT (SPOT_INPUT_BOX*MM_RAST_X) IXSIZ = IXSIZ/2 IF (IXSIZ.LT.1) IXSIZ = 1 IF (IXSIZ.GT.MAX_HALF_BOX) THEN CALL ERR_NOTICE (1,'**Spot box size too large**') GO TO 100 END IF IYSIZ = NINT (SPOT_INPUT_BOX*MM_RAST_Y) IYSIZ = IYSIZ/2 IF (IYSIZ.LT.1) IYSIZ = 1 IF (IYSIZ.GT.MAX_HALF_BOX) THEN CALL ERR_NOTICE (1,'**Spot box size too large**') GO TO 100 END IF CALL SFPIX (IXPIX,IYPIX,ISPIX,IFPIX) CALL XDLF_BG_VALIMG(ISPIX,IFPIX,IMG_BG,ITYPE,NF_BGOFF, + NCMP, IBG, IERR) ITHRESH = IBG + NINT(SPOT_INPUT_THRESH) CALL SPOT_C_OF_G (IXPIX, IYPIX, IXSIZ, IYSIZ, ISPOT_DATA, + ISWORK, ITHRESH, IMG, ITYPE, IORD, NFRASTS, + NXRAST, NYRAST, NOVER, + CGX, CGY, IERR) IF (IERR.LT.0) THEN CALL ERR_NOTICE (0,'**Error in spot_c_of_g call**') GO TO 100 ELSE IF (IERR.EQ.2) THEN CALL ERR_NOTICE (1, + '**Spot box outside range of image**') GO TO 100 ELSE IF (NOVER.EQ.0) THEN CALL ERR_NOTICE (1,'**No pixels above threshold**') GO TO 100 END IF IXPIX = NINT (CGX) IF (IXPIX.LT.1) IXPIX = 1 IF (IXPIX.GT.NXRAST) IXPIX = NXRAST IYPIX = NINT (CGY) IF (IYPIX.LT.1) IYPIX = 1 IF (IYPIX.GT.NYRAST) IYPIX = NYRAST END IF C C====== Add spot to spot list C IF (NUM_INP_SPOTS.GE.MAX_MEAS) THEN CALL ERR_NOTICE (1,'**Spot list full**') GO TO 100 END IF NUM_INP_SPOTS = NUM_INP_SPOTS + 1 IXINP_SPOTS(NUM_INP_SPOTS) = IXPIX IYINP_SPOTS(NUM_INP_SPOTS) = IYPIX IF (ISTYP.EQ.1) THEN XINP_SPOTS(NUM_INP_SPOTS) = CGX YINP_SPOTS(NUM_INP_SPOTS) = CGY ELSE XINP_SPOTS(NUM_INP_SPOTS) = IXPIX YINP_SPOTS(NUM_INP_SPOTS) = IYPIX END IF C C====== Display symbol C CALL XDLF_IMAGE_SYMBOL (IVH_FILM, IXPIX, IYPIX, + ISYMBTYP(6), ICOLRTYP(6), 1, IERR) GO TO 100 C C====== Delete spot: Identify the spot in the list of spots C ELSE IF (IADDEL.EQ.2) THEN IF (NUM_INP_SPOTS.EQ.0) THEN CALL ERR_NOTICE (1,'**No spots in the list**') GO TO 100 END IF CALL XDLF_IMAGE_GETPIX_OVLY (IVH_FILM, 1, IXPIX, IYPIX, * IERR) IDSQMIN = NXRAST*NXRAST + NYRAST*NYRAST DO 200 I = 1, NUM_INP_SPOTS ID = (IXPIX-IXINP_SPOTS(I))*(IXPIX-IXINP_SPOTS(I)) + * (IYPIX-IYINP_SPOTS(I))*(IYPIX-IYINP_SPOTS(I)) IF (ID.LT.IDSQMIN) THEN IDSQMIN = ID ISPOT = I END IF 200 CONTINUE C C====== Do not delete closest symbol if too far away C IF (IDSQMIN.GT.IDSQLIM) GO TO 100 C C====== Delete symbol from the display C CALL XDLF_IMAGE_DEL_SYMBOL (IVH_FILM, + IXINP_SPOTS(ISPOT), IYINP_SPOTS(ISPOT), + ISYMBTYP(6), ICOLRTYP(6), 1, IERR) C C====== Delete spot from the spots list C IF (ISPOT.LT.NUM_INP_SPOTS) THEN DO 300 I = ISPOT+1, NUM_INP_SPOTS IXINP_SPOTS(I-1) = IXINP_SPOTS(I) IYINP_SPOTS(I-1) = IYINP_SPOTS(I) XINP_SPOTS(I-1) = XINP_SPOTS(I) YINP_SPOTS(I-1) = YINP_SPOTS(I) 300 CONTINUE NUM_INP_SPOTS = NUM_INP_SPOTS - 1 GO TO 100 END IF END IF C C====== Parameter table input C ELSE IF (IVH.EQ.IVH_PAR3) THEN CALL XDLF_PARAM_TABLE_GETVALUE (IVH_PAR3, ITM, + XDLSTR(PVAL), MAX_P3SCROLL_CHARS, IERR) IF (ITM.EQ.IP_STYP) THEN CALL LJUST (PVAL) CALL CCPUPC (PVAL) CALL GETOPT (SMETHOD_UC, 2, PVAL, IOP, IERR) IF (IERR.EQ.1) THEN CALL XDLF_PARAM_TABLE_ERROR (IVH_PAR3, ITM, + XDLSTR('**Ambiguous selection**'), 23, IERR) GO TO 100 END IF IF (IERR.EQ.2) THEN CALL XDLF_PARAM_TABLE_ERROR (IVH_PAR3, ITM, + XDLSTR('**Invalid Method**'), 18, IERR) RETURN END IF ISTYP = IOP CALL XDLF_PARAM_TABLE_SETVALUE (IVH_PAR3, ITM, + XDLSTR(SMETHOD(ISTYP)), 6, 0, IERR) ELSE IF (ITM.EQ.IP_SBOX) THEN ITYP = INTFP (PVAL, FP, IV) IF (ITYP.EQ.0) THEN CALL XDLF_PARAM_TABLE_ERROR (IVH_PAR3, ITM, + XDLSTR('**Invalid Number Format**'), 25, IERR) GO TO 100 END IF IF (FP.LE.0) THEN CALL XDLF_PARAM_TABLE_ERROR (IVH_PAR3, ITM, + XDLSTR('**Value must be greater than zero**'), 35, IERR) GO TO 100 END IF SPOT_INPUT_BOX = FP WRITE (STR,'(F8.2)') SPOT_INPUT_BOX CALL LJUST(STR) CALL XDLF_PARAM_TABLE_SETVALUE (IVH_PAR3, ITM, + XDLSTR(STR), LENSTR(STR), 0, IERR) ELSE IF (ITM.EQ.IP_THRESH) THEN ITYP = INTFP (PVAL, FP, IV) IF (ITYP.EQ.0) THEN CALL XDLF_PARAM_TABLE_ERROR (IVH_PAR3, ITM, + XDLSTR('**Invalid Number Format**'), 25, IERR) GO TO 100 END IF IF (FP.LE.0) THEN CALL XDLF_PARAM_TABLE_ERROR (IVH_PAR3, ITM, + XDLSTR('**Value must be greater than zero**'), 35, IERR) GO TO 100 END IF SPOT_INPUT_THRESH = FP WRITE (STR,'(F8.1)') SPOT_INPUT_THRESH CALL LJUST(STR) CALL XDLF_PARAM_TABLE_SETVALUE (IVH_PAR3, ITM, + XDLSTR(STR), LENSTR(STR), 0, IERR) CALL LDM_SET_STHR (SPOT_INPUT_THRESH, IERR, ERRSTR) LISTE(1) = IP_STHR CALL SET_PAR1_VALS (1, LISTE) END IF GO TO 100 END IF GO TO 100 END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** INT_FILNAM ** C************************** C C SUBROUTINE INT_FILNAM (INT_TEMPL, FILNAM) C INCLUDE 'implicit_none.finc' C C Purpose: Get file name for intensities file for current pack from C template, explcit file name & file type parameters C C Author: John W. Campbell, December 1995 C C Arguments: C CHARACTER*(*) INT_TEMPL CHARACTER*(*) FILNAM C C INT_TEMPL (R) Template from which to form file name or blank to form name C from the current value of the INT_TEMPLATE parameter C FILNAM (W) Returns intensities file name for current pack (Note that C extension will be returned as 'ge*' for .ge1/.ge2 type C file output. C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'film_pack.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR INTEGER LENSTR C C====== LOCALS: C INTEGER I_TYP INTEGER IPID INTEGER NDIG INTEGER LL INTEGER I INTEGER J INTEGER ILEN INTEGER IVAL INTEGER IFLAG INTEGER ITYP INTEGER IERR INTEGER ND REAL FP CHARACTER*(MAXFLEN) FNAM CHARACTER*(MAXFLEN) STR1 CHARACTER*(MAXFLEN) STR2 CHARACTER*(MAXFLEN) TEMPLATE CHARACTER*80 STR CHARACTER*8 FRM CHARACTER*2 ERRSTR C INTEGER I_TYP !Intensities file type 1=mtz, 2=.ge1/.ge2 C INTEGER IPID !Pack id. C INTEGER NDIG !No. of digits in '#' field C INTEGER LL !String length C INTEGER I !Temp/loop variable C INTEGER J !Temp/loop variable C INTEGER ILEN !File name less extension length C INTEGER IVAL !Integer parameter value C INTEGER IFLAG !Parameter status flag C INTEGER ITYP !Parameter type flag C INTEGER IERR !Error flag C INTEGER ND !No. of decimal places flag C REAL FP !Real parameter value C CHARACTER*(MAXFLEN) FNAM !File name string C CHARACTER*(MAXFLEN) STR1 !Temp string C CHARACTER*(MAXFLEN) STR2 !Temp string C CHARACTER*80 STR !Temp string C CHARACTER*(MAXFLEN) TEMPLATE !File name template string C CHARACTER*8 FRM !Format string C CHARACTER*2 ERRSTR !Error string (dummy) DATA FRM /'(I25.XX)'/ C C------------------------------------------------------------------------------- C C====== Find file type C CALL LDM_GET ('INT_FTYPE', IPACK, IPLATE, STR, FP, ND, IVAL, + IFLAG, ITYP, IERR, ERRSTR) I_TYP = 1 IF (STR.EQ.'ge') I_TYP = 2 C C====== Form name from template C IF (INT_TEMPL.EQ.' ') THEN CALL LDM_GET ('INT_TEMPLATE', IPACK, IPLATE, TEMPLATE, + FP, ND, IVAL, IFLAG, ITYP, IERR, ERRSTR) ELSE TEMPLATE = INT_TEMPL END IF NDIG = 1 STR1 = ' ' STR2 = ' ' LL = LENSTR(TEMPLATE) I = 0 J = 0 10 I = I + 1 IF (I.LE.LL) THEN IF (TEMPLATE(I:I).NE.'#') THEN J = J + 1 STR1(J:J) = TEMPLATE(I:I) GO TO 10 END IF END IF 20 I = I + 1 IF (I.LE.LL) THEN IF (TEMPLATE(I:I).EQ.'#') THEN NDIG = NDIG + 1 GO TO 20 END IF END IF IF (I.LE.LL) STR2 = TEMPLATE(I:LL) C C====== Now add pack_id C CALL LDM_GET_PID (IPACK, IPID, IFLAG, IERR, ERRSTR) FNAM = STR1 WRITE (FRM(6:7),'(I2.2)')NDIG WRITE (STR,FRM) IPID LL = LENSTR(STR) J = 0 DO 30 I = 1, LL IF (STR(I:I).NE.' ') THEN STR = STR(I:LL) GO TO 40 END IF 30 CONTINUE 40 CALL STR_ADDS(FNAM,STR,0) CALL STR_ADDS (FNAM,STR2,0) IF (I_TYP.EQ.1) THEN FILNAM = FNAM ELSE CALL FILEXT (FNAM, 'xxx', FILNAM, ILEN) FNAM = FILNAM(1:ILEN) CALL FILEXT (FNAM, 'ge*', FILNAM, ILEN) END IF RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** INT_PTAB3 ** C************************** C C SUBROUTINE INT_PTAB3 (IOP) C INCLUDE 'implicit_none.finc' C C Purpose: Set up parameter table 3 for integration opion & return current C parameter values via common (or update table) C C Author: John W. Campbell, December 1995 C C Arguments: C INTEGER IOP C C IOP (R) Flag =0 set up table, C =1 get value from parameter table & update table C =2 just update table C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' INCLUDE 'screen_params.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'film_pack.finc' INCLUDE 'integ_pars.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR INTEGER LENSTR C C====== LOCALS: C INTEGER IP_FTYP INTEGER IP_TEMPL INTEGER IP_NPROF INTEGER IP_ROTAT INTEGER IP_PROMIN INTEGER IP_PRALL INTEGER IP_SCAL INTEGER IP_OVLIM INTEGER ITEM INTEGER IVAL INTEGER IFLAG INTEGER ITYP INTEGER IERR INTEGER ND INTEGER ITOG REAL FP CHARACTER*20 STR CHARACTER*80 ERRSTR CHARACTER*(MAX_P3SCROLL_CHARS) PVAL CHARACTER*(MAXFLEN) INT_TEMPL C INTEGER IP_FTYP !Parameter table 3 item: Intensities file type C INTEGER IP_TEMPL !Parameter table 3 item: File template C INTEGER IP_NPROF !Parameter table 3 item: No. profile bins C INTEGER IP_ROTAT !Parameter table 3 item: Rotate profiles flag C INTEGER IP_PROMIN !Parameter table 3 item: Min I for profiles C INTEGER IP_PRALL !Parameter table 3 item: Profiles for all plates C INTEGER IP_SCAL !Parameter table 3 item: Intensities o/p scale C INTEGER IP_OVLIM !Parameter table 3 item: No. allowed ovld. pix. C INTEGER ITEM !Returned parameter table item number C INTEGER IVAL !Integer parameter value C INTEGER IFLAG !Parameter status flag C INTEGER ITYP !Parameter type flag C INTEGER IERR !Error flag C INTEGER ND !No. of decimal places flag C INTEGER ITOG !Parameter table toggle flag C REAL FP !Real parameter value C CHARACTER*20 STR !Temp string C CHARACTER*80 ERRSTR !Error string C CHARACTER*(MAX_P3SCROLL_CHARS) PVAL !Returned parameter value string C CHARACTER*(MAXFLEN) INT_TEMPL !File name template string C C------------------------------------------------------------------------------- C IP_FTYP = 1 IP_TEMPL = 2 IP_NPROF = 3 IP_ROTAT = 4 IP_PROMIN = 5 IP_PRALL = 6 IP_OVLIM = 7 IP_SCAL = 8 C C====== Get value from parameter table if update option C IF (IOP.EQ.1) THEN CALL XDLF_PARAM_TABLE_GETVALUE (IVH_PAR3, ITEM, + XDLSTR(PVAL), MAX_P3SCROLL_CHARS, IERR) IF (ITEM.EQ.IP_FTYP) THEN CALL LDM_SET ('INT_FTYPE', IPACK, IPLATE, PVAL, + IERR, ERRSTR) IF (IERR.NE.0) GO TO 810 ELSE IF (ITEM.EQ.IP_TEMPL) THEN CALL LDM_SET ('INT_TEMPLATE', IPACK, IPLATE, PVAL, + IERR, ERRSTR) IF (IERR.NE.0) GO TO 810 ELSE IF (ITEM.EQ.IP_NPROF) THEN CALL LDM_SET ('NPROF', IPACK, IPLATE, PVAL, + IERR, ERRSTR) IF (IERR.NE.0) GO TO 810 ELSE IF (ITEM.EQ.IP_ROTAT) THEN CALL LDM_SET ('PROF_ROTATE', IPACK, IPLATE, PVAL, + IERR, ERRSTR) IF (IERR.NE.0) GO TO 810 ELSE IF (ITEM.EQ.IP_PROMIN) THEN CALL LDM_SET ('PROMIN', IPACK, IPLATE, PVAL, + IERR, ERRSTR) IF (IERR.NE.0) GO TO 810 ELSE IF (ITEM.EQ.IP_PRALL) THEN CALL LDM_SET ('PROF_ALL', IPACK, IPLATE, PVAL, + IERR, ERRSTR) IF (IERR.NE.0) GO TO 810 ELSE IF (ITEM.EQ.IP_OVLIM) THEN CALL LDM_SET ('OVLIM', IPACK, IPLATE, PVAL, + IERR, ERRSTR) IF (IERR.NE.0) GO TO 810 ELSE IF (ITEM.EQ.IP_SCAL) THEN CALL LDM_SET ('SCALE_INT', IPACK, IPLATE, PVAL, + IERR, ERRSTR) IF (IERR.NE.0) GO TO 810 END IF END IF C C====== Update all parameters C C C====== Intensities file type C CALL LDM_GET ('INT_FTYPE', IPACK, IPLATE, STR, FP, ND, INT_TYP, + IFLAG, ITYP, IERR, ERRSTR) INT_TYP = 1 IF (STR.EQ.'ge') INT_TYP = 2 IF (IOP.EQ.0) THEN CALL XDLF_PARAM_TABLE_SETITEM (IVH_PAR3, IP_FTYP, + XDLSTR('int_ftype:'), 10, + XDLSTR(STR), LENSTR(STR), 0, 1, IERR) ELSE CALL XDLF_PARAM_TABLE_SETVALUE (IVH_PAR3, IP_FTYP, + XDLSTR(STR), LENSTR(STR), 0, IERR) END IF C C====== Intensities file template C CALL LDM_GET ('INT_TEMPLATE', IPACK, IPLATE, INT_TEMPL, + FP, ND, IVAL, IFLAG, ITYP, IERR, ERRSTR) IF (IOP.EQ.0) THEN CALL XDLF_PARAM_TABLE_SETITEM (IVH_PAR3, IP_TEMPL, + XDLSTR('int_template:'), 13, + XDLSTR(INT_TEMPL), LENSTR(INT_TEMPL), 0, 1, IERR) ELSE CALL XDLF_PARAM_TABLE_SETVALUE (IVH_PAR3, IP_TEMPL, + XDLSTR(INT_TEMPL), LENSTR(INT_TEMPL), 0, IERR) END IF C C====== No. of profile fitting bins C CALL LDM_GET ('NPROF', IPACK, IPLATE, STR, + FP, ND, NPROF, IFLAG, ITYP, IERR, ERRSTR) WRITE (STR,'(I8)') NPROF CALL LJUST(STR) IF (IOP.EQ.0) THEN CALL XDLF_PARAM_TABLE_SETITEM (IVH_PAR3, IP_NPROF, + XDLSTR('nprof:'), 6, + XDLSTR(STR), LENSTR(STR), 0, 1, IERR) ELSE CALL XDLF_PARAM_TABLE_SETVALUE (IVH_PAR3, IP_NPROF, + XDLSTR(STR), LENSTR(STR), 0, IERR) END IF C C====== Rotate profiles C PRF_ROT = .FALSE. CALL LDM_GET ('PROF_ROTATE', IPACK, IPLATE, STR, + FP, ND, IVAL, IFLAG, ITYP, IERR, ERRSTR) IF (STR.EQ.'yes') PRF_ROT = .TRUE. ITOG = 4 IF (PRF_ROT) ITOG = 3 IF (IOP.EQ.0) THEN CALL XDLF_PARAM_TABLE_SETITEM (IVH_PAR3, IP_ROTAT, + XDLSTR('prof_rotate:'), 12, + XDLSTR(' '), 1, ITOG, 1, IERR) ELSE CALL XDLF_PARAM_TABLE_SETVALUE (IVH_PAR3, IP_ROTAT, + XDLSTR(' '), LENSTR(' '), ITOG, IERR) END IF C C====== PROMIN C CALL LDM_GET ('PROMIN', IPACK, IPLATE, STR, + PROMIN, ND, IVAL, IFLAG, ITYP, IERR, ERRSTR) WRITE (STR,'(F8.1)') PROMIN CALL LJUST (STR) IF (IOP.EQ.0) THEN CALL XDLF_PARAM_TABLE_SETITEM (IVH_PAR3, IP_PROMIN, + XDLSTR('promin:'), 7, + XDLSTR(STR), LENSTR(STR), 0, 1, IERR) ELSE CALL XDLF_PARAM_TABLE_SETVALUE (IVH_PAR3, IP_PROMIN, + XDLSTR(STR), LENSTR(STR), 0, IERR) END IF C C====== Profiles for all bins C IPRF_ALL = 0 CALL LDM_GET ('PROF_ALL', IPACK, IPLATE, STR, + FP, ND, IVAL, IFLAG, ITYP, IERR, ERRSTR) IF (STR.EQ.'yes') IPRF_ALL = 1 IF (IOP.EQ.0) THEN CALL XDLF_PARAM_TABLE_SETITEM (IVH_PAR3, IP_PRALL, + XDLSTR('prof_all:'), 9, + XDLSTR(' '), 1, 4-IPRF_ALL, 1, IERR) ELSE CALL XDLF_PARAM_TABLE_SETVALUE (IVH_PAR3, IP_PRALL, + XDLSTR(' '), LENSTR(' '), 4-IPRF_ALL, IERR) END IF C C====== No. of allowed overloaded pixels - OVLIM C CALL LDM_GET ('OVLIM', IPACK, IPLATE, STR, + FP, ND, NOVLD, IFLAG, ITYP, IERR, ERRSTR) WRITE (STR,'(I8)') NOVLD CALL LJUST(STR) IF (IOP.EQ.0) THEN CALL XDLF_PARAM_TABLE_SETITEM (IVH_PAR3, IP_OVLIM, + XDLSTR('ovlim:'), 6, + XDLSTR(STR), LENSTR(STR), 0, 1, IERR) ELSE CALL XDLF_PARAM_TABLE_SETVALUE (IVH_PAR3, IP_OVLIM, + XDLSTR(STR), LENSTR(STR), 0, IERR) END IF C C====== Scale for output intensities - SCALE_INT C CALL LDM_GET ('SCALE_INT', IPACK, IPLATE, STR, + SCAL_INT, ND, IVAL, IFLAG, ITYP, IERR, ERRSTR) WRITE (STR,'(F8.3)') SCAL_INT CALL LJUST (STR) IF (IOP.EQ.0) THEN CALL XDLF_PARAM_TABLE_SETITEM (IVH_PAR3, IP_SCAL, + XDLSTR('scale_int:'), 10, + XDLSTR(STR), LENSTR(STR), 0, 1, IERR) ELSE CALL XDLF_PARAM_TABLE_SETVALUE (IVH_PAR3, IP_SCAL, + XDLSTR(STR), LENSTR(STR), 0, IERR) END IF RETURN C C====== General Error Condition C 810 CALL XDLF_PARAM_TABLE_ERROR (IVH_PAR3, ITEM, + XDLSTR(ERRSTR), LENSTR(ERRSTR), IERR) RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** INTEG_SINGSPOT ** C************************** C C SUBROUTINE INTEG_SINGSPOT (ISPOT, IMG_DISP) C INCLUDE 'implicit_none.finc' C C Purpose: Integrate a single spot and show results C C Author: John W. Campbell, January 1996 C C Arguments: C INTEGER ISPOT LOGICAL IMG_DISP C C ISPOT (R) No. of spot to be integrated in LRL C IMG_DISP (R) Image is displayed flag C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' INCLUDE 'screen_params.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'image.finc' INCLUDE 'film_pack.finc' INCLUDE 'file_units.finc' INCLUDE 'integ_pars.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR INTEGER LENSTR EXTERNAL LFN_SOFT_PROG LOGICAL LFN_DUMMY_CNCL EXTERNAL LFN_DUMMY_CNCL C C====== LOCALS: C LOGICAL DRAW_PLOT LOGICAL LOGGED LOGICAL PROF_ROT LOGICAL BAD INTEGER M_PLOT1 INTEGER M_PLOT2 INTEGER M_PLOT3 INTEGER M_LOG INTEGER NVIEW INTEGER IVHLIST(2) INTEGER IVH INTEGER ITEM INTEGER IQUIT INTEGER IERR INTEGER IPK INTEGER IPL INTEGER NPHALF INTEGER NUMPIX INTEGER NPROFS INTEGER NCOLS INTEGER NROWS INTEGER LL INTEGER I INTEGER IXROOT INTEGER IYROOT INTEGER ICOL INTEGER IROW INTEGER IBOLD INTEGER KSPOT INTEGER KH INTEGER KK INTEGER KL INTEGER NPIX INTEGER NREJ INTEGER IXMIN INTEGER IXMAX INTEGER IYMIN INTEGER IYMAX INTEGER IPLOT_CUR INTEGER IXP INTEGER IYP INTEGER IMASK INTEGER IREJ INTEGER NXRAST INTEGER NYRAST INTEGER IORD INTEGER ISWAP INTEGER IFLAG INTEGER IX INTEGER IY INTEGER IXLIM INTEGER IYLIM INTEGER IPIX INTEGER NCH INTEGER NPAD INTEGER ICODE REAL PROMIN_DUM REAL XPOS REAL YPOS REAL BACKG(3) REAL AI REAL SIGI REAL PIXMAX REAL PRFMAX REAL SCPIX REAL SCPRF REAL PIXV REAL PROF REAL SUBPR REAL SBMIN CHARACTER*25 NAMES(4) CHARACTER*25 QUITNAM CHARACTER*80 STR CHARACTER*80 ERRSTR CHARACTER*4 FMT CHARACTER*5 DOT CHARACTER*5 STAR CHARACTER*5 OVSP CHARACTER*5 OVLD C LOGICAL DRAW_PLOT !Drawing of plot required flag C LOGICAL LOGGED !Spot details written to log file flag C LOGICAL PROF_ROT !Rotate profile flag C LOGICAL BAD !Bad spot flag C INTEGER M_PLOT1 !Menu item no.: Scaled Pixels Plot C INTEGER M_PLOT2 !Menu item no.: BG Subtracted Pixels Plot C INTEGER M_PLOT3 !Menu item no.: Scaled Spot Profile Plot C INTEGER M_LOG !Menu item no.: Output Plots to Logfile C INTEGER NVIEW !No. of view-objects for getting events C INTEGER IVHLIST(2) !List of view-object handles for getting events C INTEGER IVH !Returned view-object handle from getting events C INTEGER ITEM !Item no. from menu selection C INTEGER IQUIT !Quit button flage from menu C INTEGER IERR !Error flag C INTEGER IPK !Pack no. from latest profile calculated C INTEGER IPL !Plate no. from latest profile calculated C INTEGER NPHALF !Half width of profile boxes C INTEGER NUMPIX !No. of pixels in profile C INTEGER NPROFS !No. of profile bins C INTEGER NCOLS !No. of columns for profiles text table C INTEGER NROWS !No. of rows for profiles text table C INTEGER LL !Length of character string C INTEGER I !Temp/loop variable C INTEGER IXROOT !Root 'x' position for profiles text table C INTEGER IYROOT !Root 'y' position for profiles text table C INTEGER ICOL !Column no. for character in profiles text table C INTEGER IROW !Row no. for character in profiles text table C INTEGER IBOLD !Bold print & colour flag C INTEGER KSPOT !Spot no. in LRL of integrated spot C INTEGER KH !'h' index of integrated spot C INTEGER KK !'k' index of integrated spot C INTEGER KL !'l' index of integrated spot C INTEGER NPIX !No. of pixels in spot C INTEGER NREJ !No. of rejected pixels C INTEGER IXMIN !Minimum 'x' pixel offset in spot data C INTEGER IXMAX !Maximum 'x' pixel offset in spot data C INTEGER IYMIN !Minimum 'y' pixel offset in spot data C INTEGER IYMAX !Maximum 'y' pixel offset in spot data C INTEGER IPLOT_CUR !Current plot type no. C INTEGER IXP !'x' offset of current pixel C INTEGER IYP !'y' offset of current pixel C INTEGER IMASK !Pixel mask flag C INTEGER IREJ !Reject pixel flag C INTEGER NXRAST !No. x-rasters C INTEGER NYRAST !No. y-rasters C INTEGER IORD !Axis order flag C INTEGER ISWAP !Byte swap flag C INTEGER IFLAG !Parameter status flag C INTEGER IX !Loop counter through 'x' pixel positions C INTEGER IY !Loop counter through 'y' pixel positions C INTEGER IXLIM !Half size limit for 'x' pixels C INTEGER IYLIM !Half size limit for 'y' pixels C INTEGER IPIX !Scaled pixel value for output C INTEGER NCH !No. of characters per pixel value o/p field C INTEGER NPAD !Pad for left hand side of rows data output C INTEGER ICODE !Integration code flag C REAL PROMIN_DUM !Dummy vale for 'PROMIN' C REAL XPOS !'x' position of spot C REAL YPOS !'y' position of spot C REAL BACKG(3) !Background plane parameters C REAL AI !Integrated intensity C REAL SIGI !sig(I) C REAL PIXMAX !Maximum pixel value in spot C REAL PRFMAX !Maximum pixel value in spot profile C REAL SCPIX !Scaling factor for plotting pixel data C REAL SCPRF !Scaling factor for plotting spot profile data C REAL PIXV !Spot pixel value C REAL PROF !Spot profile value C REAL SUBPR !Background subtracted spot profile pixel value C REAL SBMIN !Minimum (scaled) bg subtracted pixel value C CHARACTER*25 NAMES(4) !Menu item names C CHARACTER*25 QUITNAM !Quit button string C CHARACTER*80 STR !Temp string C CHARACTER*80 ERRSTR !Error string C CHARACTER*4 FMT !Format statement for integer field C CHARACTER*5 DOT !String for point not included C CHARACTER*5 STAR !String for omitted pixel border C CHARACTER*5 OVSP !String for omitted overlapped pixel C CHARACTER*5 OVLD !String for omitted overloaded pixel DATA NAMES /'Scaled Pixels Plot', + 'BG Subtracted Pixels Plot', + 'Scaled Spot Profile Plot', + 'Output Plots to Logfile'/ DATA QUITNAM /'Return to Previous Menu'/ C C------------------------------------------------------------------------------- C C====== Initialisations C LOGGED = .FALSE. CALL LDM_GET_NXRAS (NXRAST, IFLAG) CALL LDM_GET_NYRAS (NYRAST, IFLAG) CALL LDM_GET_AXORD (STR, IORD, ISWAP, IFLAG) C C====== Integrate spot C CALL LFN_GET_PROFPARS (IPK, IPL, NPHALF, NUMPIX, NPROFS, + PROF_ROT) PROMIN_DUM = 100.0 CALL LFN_SAINT (IPACK, IPLATE, 10+ISPOT, IMG, ITYPE, IORD, + NFRASTS, NXRAST, NYRAST, PROMIN_DUM, NPROFS, + PROF_ROT, NOVLD, LFN_SOFT_PROG, LFN_DUMMY_CNCL, + IERR, ERRSTR) IF (IERR.NE.0) THEN IF (IERR.EQ.10) THEN CALL ERR_NOTICE (0,'**Too close to integrate**') ELSE IF (IERR.EQ.11) THEN CALL ERR_NOTICE (0, + '**<3 non-overlapped background pixels**') ELSE IF (IERR.EQ.12) THEN CALL ERR_NOTICE (0,'**No non-overlapped peak pixels**') ELSE IF (IERR.EQ.20) THEN CALL ERR_NOTICE (0,'**Integration box out of limits**') ELSE CALL ERR_NOTICE (0,'**Integration error**') END IF RETURN END IF C C====== Get spot parameters C CALL LFN_GET_SPOTPARS (KSPOT, KH, KK, KL, XPOS, YPOS, NPIX, + NREJ, BACKG, AI, SIGI, IERR, ERRSTR) C C====== Set up spot plots display window C IPLOT_CUR = 1 IXMIN = 0 IXMAX = 0 IYMIN = 0 IYMAX = 0 PIXMAX = 0.0 PRFMAX = 0.0 SBMIN = 0.0 DO 20 I = 1, NPIX CALL LFN_GET_SPOTPIX (I, IXP, IYP, IMASK, PIXV, PROF, SUBPR, + IREJ, IERR) IF (IXP.LT.IXMIN) IXMIN = IXP IF (IXP.GT.IXMAX) IXMAX = IXP IF (IYP.LT.IYMIN) IYMIN = IYP IF (IYP.GT.IYMAX) IYMAX = IYP IF (PIXV.GT.PIXMAX) PIXMAX = PIXV IF (PROF.GT.PRFMAX) PRFMAX = PROF IF (SUBPR.LT.SBMIN) SBMIN = SUBPR 20 CONTINUE IXLIM = IABS(IXMIN) IF (IXMAX.GT.IXLIM) IXLIM = IXMAX IYLIM = IABS(IYMIN) IF (IYMAX.GT.IYLIM) IYLIM = IYMAX SCPIX = 1.0 IF (PIXMAX.GT.0.0) SCPIX = 99.0/PIXMAX SCPRF = 1.0 IF (PRFMAX.GT.0.0) SCPRF = 99.0/PRFMAX SBMIN = SCPIX*SBMIN I = NINT(-SBMIN) NCH = 3 FMT = '(I3)' DOT = ' .' STAR = ' *' OVSP = ' X' OVLD = ' +' IF (I.GT.9) THEN NCH = 4 FMT = '(I4)' DOT = ' .' STAR = ' *' OVSP = ' X' OVLD = ' +' END IF IF (I.GT.99) THEN NCH = 5 FMT = '(I5)' DOT = ' .' STAR = ' *' OVSP = ' X' OVLD = ' +' END IF NCOLS = NCH*(2*IXLIM+1) + 1 I = NCOLS IF (NCOLS.LT.60) THEN NCOLS = 60 END IF NPAD = (NCOLS-I)/2 NROWS =2*(2*IYLIM+1) + 7 CALL XDLF_VIEW_OBJECT_ROOTXY (IVH_PAR1,0,0,IXROOT,IYROOT,IERR) IF (IMG_DISP) THEN IXROOT = IXROOT + 30 IYROOT = IYROOT + 30 END IF CALL XDLF_TEXT_TABLE (IVH_PROF_TAB, 0, IXROOT, IYROOT, 0, NCOLS, + NROWS, 0, 0, IFONT, IERR) DRAW_PLOT = .TRUE. C C====== Set up list of view-object handles C NVIEW = 1 IVHLIST(1) = IVH_MENU C C====== Set up & process menu C M_PLOT1 = 1 M_PLOT2 = 2 M_PLOT3 = 3 M_LOG = 4 50 CALL XDLF_MENU_AREA_SETMENU (IVH_MENU, 4, XDLSTR(NAMES), 25, + XDLSTR('Spot Plots Menu'), 15, + XDLSTR(QUITNAM), 25, 0, IERR) C C====== Draw requested spot plot if needed C IF (DRAW_PLOT) THEN CALL XDLF_TEXT_TABLE_CLEAR (IVH_PROF_TAB, IERR) STR = 'Spot' CALL STR_ADDI (STR, KH, 1) CALL STR_ADDI (STR, KK, 1) CALL STR_ADDI (STR, KL, 1) CALL STR_ADDS (STR, 'at x =', 1) CALL STR_ADDF (STR, XPOS, 1, 1) CALL STR_ADDS (STR, ', y =', 0) CALL STR_ADDF (STR, YPOS, 1, 1) CALL STR_ADDS (STR, '(pack',1) CALL STR_ADDI (STR, IPACK, 1) CALL STR_ADDS (STR, ', plate', 0) CALL STR_ADDI (STR, IPLATE, 1) CALL STR_ADDS (STR, ')', 0) LL = LENSTR(STR) CALL XDLF_TEXT_TABLE_TEXT (IVH_PROF_TAB, XDLSTR(STR), LL, + 1, 1, 0, IERR) STR = 'Intensity =' CALL STR_ADDF (STR, AI, 1, 1) CALL STR_ADDS (STR, ', sig(I) =', 0) CALL STR_ADDF (STR, SIGI, 1, 1) CALL LFN_GET_SPOTCODE (BAD, ICODE, IERR, ERRSTR) IF (BAD) THEN CALL STR_ADDS (STR, '- BAD SPOT, icode =',1) CALL STR_ADDI (STR, ICODE, 1) END IF LL = LENSTR(STR) CALL XDLF_TEXT_TABLE_TEXT (IVH_PROF_TAB, XDLSTR(STR), LL, + 3, 1, 0, IERR) STR = 'BG plane: a =' CALL STR_ADDF (STR, BACKG(1), -3, 1) CALL STR_ADDS (STR, ', b =', 0) CALL STR_ADDF (STR, BACKG(2), -3, 1) CALL STR_ADDS (STR, ', c =', 0) CALL STR_ADDF (STR, BACKG(3), -3, 1) LL = LENSTR(STR) CALL XDLF_TEXT_TABLE_TEXT (IVH_PROF_TAB, XDLSTR(STR), LL, + 5, 1, 0, IERR) STR = ' ' IF (IPLOT_CUR.EQ.1) THEN STR = 'Pixel values plot (scaled to 99 by' CALL STR_ADDF (STR, SCPIX, -3, 1) CALL STR_ADDS (STR, ')', 0) ELSE IF (IPLOT_CUR.EQ.2) THEN STR = + 'BG subtracted pixel values (scaled as for pixel values plot)' ELSE IF (IPLOT_CUR.EQ.3) THEN STR = 'Spot profile plot (scaled to 99 by' CALL STR_ADDF (STR, SCPRF, -3, 1) CALL STR_ADDS (STR, ')', 0) END IF LL = LENSTR(STR) CALL XDLF_TEXT_TABLE_TEXT (IVH_PROF_TAB, XDLSTR(STR), LL, + NROWS, 1, 0, IERR) IF (IPLOT_CUR.EQ.1) THEN DO 100 IY = -IYLIM, IYLIM DO 90 IX = -IXLIM, IXLIM IBOLD = 1 STR = DOT DO 70 I = 1, NPIX CALL LFN_GET_SPOTPIX (I, IXP, IYP, IMASK, PIXV, + PROF, SUBPR, IREJ, IERR) IF (IERR.EQ.0) THEN IF (IXP.EQ.IX.AND.IYP.EQ.IY) THEN IPIX = NINT (PIXV*SCPIX) WRITE (STR,FMT) IPIX IBOLD = 1 GO TO 80 END IF END IF 70 CONTINUE 80 ICOL = 1 + NCH*(IX+IXLIM) + NPAD IROW = 7 + 2*(IYLIM-IY) CALL XDLF_TEXT_TABLE_TEXT (IVH_PROF_TAB, + XDLSTR(STR), NCH, + IROW, ICOL, IBOLD, IERR) 90 CONTINUE 100 CONTINUE ELSE IF (IPLOT_CUR.EQ.2) THEN DO 200 IY = -IYLIM, IYLIM DO 190 IX = -IXLIM, IXLIM IBOLD = 1 STR = DOT DO 170 I = 1, NPIX CALL LFN_GET_SPOTPIX (I, IXP, IYP, IMASK, PIXV, + PROF, SUBPR, IREJ, IERR) IF (IERR.EQ.0) THEN IF (IXP.EQ.IX.AND.IYP.EQ.IY) THEN IF (IMASK.LT.0) THEN IBOLD = 0 STR = STAR IF (IMASK.EQ.-2) THEN STR = OVSP END IF IF (IMASK.EQ.-3) THEN STR = OVLD END IF GO TO 180 END IF IPIX = NINT (SUBPR*SCPIX) WRITE (STR,FMT) IPIX IBOLD = 3 IF (IMASK.LE.1) IBOLD = 10 IF (IREJ.EQ.1) IBOLD = 6 GO TO 180 END IF END IF 170 CONTINUE 180 ICOL = 1 + NCH*(IX+IXLIM) + NPAD IROW = 7 + 2*(IYLIM-IY) CALL XDLF_TEXT_TABLE_TEXT (IVH_PROF_TAB, + XDLSTR(STR), NCH, + IROW, ICOL, IBOLD, IERR) 190 CONTINUE 200 CONTINUE ELSE IF (IPLOT_CUR.EQ.3) THEN DO 300 IY = -IYLIM, IYLIM DO 290 IX = -IXLIM, IXLIM IBOLD = 1 STR = DOT DO 270 I = 1, NPIX CALL LFN_GET_SPOTPIX (I, IXP, IYP, IMASK, PIXV, + PROF, SUBPR, IREJ, IERR) IF (IERR.EQ.0) THEN IF (IXP.EQ.IX.AND.IYP.EQ.IY) THEN IF (IMASK.LT.0) THEN IBOLD = 0 STR = STAR IF (IMASK.EQ.-2) THEN STR = OVSP END IF IF (IMASK.EQ.-3) THEN STR = OVLD END IF GO TO 280 END IF IPIX = NINT (PROF*SCPRF) WRITE (STR,FMT) IPIX IBOLD = 3 IF (IMASK.LE.1) IBOLD = 10 GO TO 280 END IF END IF 270 CONTINUE 280 ICOL = 1 + NCH*(IX+IXLIM) + NPAD IROW = 7 + 2*(IYLIM-IY) CALL XDLF_TEXT_TABLE_TEXT (IVH_PROF_TAB, + XDLSTR(STR), NCH, + IROW, ICOL, IBOLD, IERR) 290 CONTINUE 300 CONTINUE END IF DRAW_PLOT = .FALSE. END IF C C C====== Start event loop C 500 CALL XDLF_GET_EVENTS (NVIEW, IVHLIST, IVH) IF (IVH.EQ.IVH_MENU) THEN C C====== Menu item selected C CALL XDLF_MENU_AREA_GETITEM (IVH_MENU, ITEM, IQUIT) C C====== Quit selected C IF (IQUIT.EQ.1) THEN CALL XDLF_DELETE_VIEW_OBJECT (IVH_PROF_TAB, IERR) RETURN END IF C C====== Show First Plot C IF (ITEM.EQ.M_PLOT1) THEN IF (IPLOT_CUR.NE.1) THEN IPLOT_CUR = 1 DRAW_PLOT = .TRUE. END IF GO TO 50 C C====== Show Second Plot C ELSE IF (ITEM.EQ.M_PLOT2) THEN IF (IPLOT_CUR.NE.2) THEN IPLOT_CUR = 2 DRAW_PLOT = .TRUE. END IF GO TO 50 C C====== Show Third Plot C ELSE IF (ITEM.EQ.M_PLOT3) THEN IF (IPLOT_CUR.NE.3) THEN IPLOT_CUR = 3 DRAW_PLOT = .TRUE. END IF GO TO 50 C C====== Log Spot Plots C ELSE IF (ITEM.EQ.M_LOG) THEN IF (LOGGED) GO TO 50 IF (IUN_LOG.GT.0) THEN WRITE (IUN_LOG, '('' '')') CALL LFN_LIST_INTSPOT (IUN_LOG, 0, .TRUE., .TRUE., + .TRUE., .TRUE., IERR, ERRSTR) END IF LOGGED = .TRUE. GO TO 500 END IF GO TO 500 END IF GO TO 500 END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** INTEG_STATUS ** C************************** C C SUBROUTINE INTEG_STATUS C INCLUDE 'implicit_none.finc' C C Purpose: Display/edit integration status C C Author: John W. Campbell, December 1995 C C Arguments: C C None C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' INCLUDE 'screen_params.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'lirl_pars.finc' INCLUDE 'file_units.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR INTEGER LENSTR C C====== LOCALS: C INTEGER I INTEGER NUMP INTEGER NPLATES INTEGER IFLAG INTEGER M_FIRST INTEGER M_NEXT INTEGER M_PREV INTEGER M_DELPL INTEGER M_DELPK INTEGER M_CLEAR INTEGER ICUR_PK INTEGER IPK INTEGER IPL INTEGER IFLG INTEGER IXROOT INTEGER IYROOT INTEGER IBUTTON INTEGER NVIEW INTEGER IVHLIST(2) INTEGER IVH INTEGER ITEM INTEGER IQUIT INTEGER IERR CHARACTER*25 NAMES(6) CHARACTER*25 QUITNAM CHARACTER*35 STATSTR(3) CHARACTER*80 STR C INTEGER I !Temp/loop variable C INTEGER NUMP !No. of packs C INTEGER NPLATES !No. of plates C INTEGER IFLAG !Parameter status flag C INTEGER M_FIRST !Menu item no.: Show First Pack Status C INTEGER M_NEXT !Menu item no.: Show Next Pack Status C INTEGER M_PREV !Menu item no.: Show Previous Pack Status C INTEGER M_DELPL !Menu item no.: Delete a Plate C INTEGER M_DELPK !Menu item no.: Delete a Pack C INTEGER M_CLEAR !Menu item no.: Clear All Intensities C INTEGER ICUR_PK !Current pack for status display C INTEGER IPK !Pack number C INTEGER IPL !Plate number C INTEGER IFLG !Integration status flag C INTEGER IXROOT !Root 'x' position for popup notice C INTEGER IYROOT !Root 'y' position for popup notice C INTEGER IBUTTON !Button return from popup notice C INTEGER NVIEW !No. of view-object for getting events C INTEGER IVHLIST(2) !List of view-object handles for getting events C INTEGER IVH !Returned view-object handle from getting events C INTEGER ITEM !Menu item number C INTEGER IQUIT !Quit box selected flag C INTEGER IERR !Error flag C CHARACTER*25 NAMES(6) !Menu item names C CHARACTER*25 QUITNAM !Quit box label C CHARACTER*35 STATSTR(3) !Integration status strings C CHARACTER*80 STR !Message string DATA NAMES /'Show First Pack Status', + 'Show Next Pack Status', + 'Show Previous Pack Status', + 'Delete a Plate', + 'Delete a Pack', + 'Clear All Intensities'/ DATA QUITNAM /'Return to Previous Menu'/ DATA STATSTR /'Not Integrated', + 'Integrated', + 'Integrated and written to a file'/ C C------------------------------------------------------------------------------- C C====== Initialisations C ICUR_PK = 1 CALL LDM_GET_NUMP (NUMP, IFLAG) CALL LDM_GET_NPLAT (NPLATES, IFLAG) C C====== Menu items C M_FIRST = 1 M_NEXT = 2 M_PREV = 3 M_DELPL = 4 M_DELPK = 5 M_CLEAR = 6 C C====== 50 CALL XDLF_MENU_AREA_SETMENU (IVH_MENU, 6, XDLSTR(NAMES), 25, + XDLSTR('Integration Status Menu'), 23, + XDLSTR(QUITNAM), 25, 0, IERR) C C====== Set up list of view-object handles C NVIEW = 1 IVHLIST(1) = IVH_MENU C C====== Show status of pack ICUR_PK C 60 CALL LMESSAGE (IVH_IOW, ' ') STR = 'Status flags for pack' CALL STR_ADDI (STR, ICUR_PK, 1) CALL LMESSAGE (IVH_IOW, STR) CALL LMESSAGE (IVH_IOW, ' ') DO 70 I = 1, NPLATES STR = 'Plate' CALL STR_ADDI (STR, I, 1) CALL STR_ADDS (STR, ':', 0) CALL INTFLAG_GET (ICUR_PK, I, IFLG) CALL STR_ADDS (STR, STATSTR(IFLG+1), 1) CALL LMESSAGE (IVH_IOW, STR) 70 CONTINUE C C====== Start event loop C 100 CALL XDLF_GET_EVENTS (NVIEW, IVHLIST, IVH) IF (IVH.EQ.IVH_MENU) THEN C C====== Menu item selected C CALL XDLF_MENU_AREA_GETITEM (IVH_MENU, ITEM, IQUIT) C C====== Quit selected C IF (IQUIT.EQ.1) THEN CALL LMESSAGE (IVH_IOW, ' ') CALL LMESSAGE (IVH_IOW, 'Exit from Integration Status') CALL LMESSAGE (IVH_IOW, ' ') CALL LMESSAGE (IVH_IOW, ' ') RETURN END IF C C====== Status of first pack C IF (ITEM.EQ.M_FIRST) THEN IF (ICUR_PK.EQ.1) GO TO 100 ICUR_PK = 1 GO TO 60 C C====== Status of next pack C ELSE IF (ITEM.EQ.M_NEXT) THEN IF (ICUR_PK.GE.NUMP) GO TO 100 ICUR_PK = ICUR_PK + 1 GO TO 60 C C====== Status of previous pack C ELSE IF (ITEM.EQ.M_PREV) THEN IF (ICUR_PK.LE.1) GO TO 100 ICUR_PK = ICUR_PK - 1 GO TO 60 C C====== Delete a Plate C ELSE IF (ITEM.EQ.M_DELPL) THEN IPK = ICUR_PK CALL IOW_ASKI (IVH_IOW, 'Pack number', IPK) IF (IPK.LT.1.OR.IPK.GT.NUMP) GO TO 100 IPL = 1 CALL IOW_ASKI(IVH_IOW, 'Plate number', IPL) IF (IPK.LT.1.OR.IPK.GT.NPLATES) GO TO 100 CALL INTFLAG_GET (IPK, IPL, IFLG) IF (IFLG.GT.0) THEN CALL LIRLF_DELETE (KDX_LIRL, IPK, IPL, IERR) IF (IUN_LOG.GT.0) THEN STR = '*Warning*' CALL STR_ADDS (STR, + 'Previous intensities deleted for pack', 1) CALL STR_ADDI(STR,IPK,1) CALL STR_ADDS(STR,', plate',0) CALL STR_ADDI(STR,IPL,1) WRITE(IUN_LOG,1010) WRITE(IUN_LOG,1020) STR(1:LENSTR(STR)) WRITE(IUN_LOG,1010) END IF CALL INTFLAG_SET (IPK, IPL, 0) END IF ICUR_PK = IPK GO TO 60 C C====== Delete a Pack C ELSE IF (ITEM.EQ.M_DELPK) THEN IPK = ICUR_PK IPK = ICUR_PK CALL IOW_ASKI (IVH_IOW, 'Pack number', IPK) IF (IPK.LT.1.OR.IPK.GT.NUMP) GO TO 100 DO 120 I = 1, NPLATES CALL INTFLAG_GET (IPK, I, IFLG) IF (IFLG.EQ.0) GO TO 120 CALL LIRLF_DELETE (KDX_LIRL, IPK, I, IERR) CALL INTFLAG_SET (IPK, I, 0) 120 CONTINUE IF (IUN_LOG.GT.0) THEN STR = '*Warning*' CALL STR_ADDS (STR, + 'Previous intensities deleted for pack', 1) CALL STR_ADDI(STR,IPK,1) WRITE(IUN_LOG,1010) WRITE(IUN_LOG,1020) STR(1:LENSTR(STR)) WRITE(IUN_LOG,1010) END IF ICUR_PK = IPK GO TO 60 C C====== Clear All Intensities C ELSE IF (ITEM.EQ.M_CLEAR) THEN CALL NOTICE_POSN(1, IXROOT, IYROOT) CALL XDLF_POPUP_NOTICE (IXROOT, IYROOT, + XDLSTR('Are you sure you want to clear all intensities?'), + 47, + XDLSTR(' '), -1, + XDLSTR('Yes'), 3, + XDLSTR('No'), 2, + IFONT, 1, IBUTTON) IF (IBUTTON.EQ.2) GO TO 100 CALL INIT_LIRL IF (IUN_LOG.GT.0) THEN STR = '*Warning* All previous intensities cleared' WRITE(IUN_LOG,1010) WRITE(IUN_LOG,1020) STR(1:LENSTR(STR)) WRITE(IUN_LOG,1010) END IF ICUR_PK = 1 GO TO 60 END IF END IF GO TO 100 C C====== Format statements C 1010 FORMAT(' ') 1020 FORMAT(A) END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C*************************** C** INTEGRATE_CALC ** C*************************** C C SUBROUTINE INTEGRATE_CALC (KEYPLATE, KQUIT) C INCLUDE 'implicit_none.finc' C C Purpose: Integrate current plate with interactive options to display results C C Author: John W. Campbell, December 1995 C C Arguments: C INTEGER KEYPLATE INTEGER KQUIT C C KEYPLATE (R) Key plate for current pack C KQUIT (W) Quit flag =0 OK, =1 quit on error C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' INCLUDE 'screen_params.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'film_pack.finc' INCLUDE 'prog_flags.finc' INCLUDE 'image.finc' INCLUDE 'lirl_pars.finc' INCLUDE 'integ_pars.finc' INCLUDE 'file_units.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR INTEGER LENSTR EXTERNAL INTEGRATE_PROGRESS EXTERNAL LFN_DUMMY_CNCL C C====== LOCALS: C LOGICAL OKNOD LOGICAL SPOV LOGICAL CLOS LOGICAL MEAS LOGICAL BAD LOGICAL OVLD LOGICAL DET_PROFS INTEGER IORD INTEGER ISWAP INTEGER IRFL INTEGER IFLG INTEGER IFLAG INTEGER ND INTEGER IXROOT INTEGER IYROOT INTEGER IBUTTON INTEGER IERR INTEGER JERR INTEGER NF_OFF INTEGER IPL_SAV INTEGER KPLATE INTEGER NXRAST INTEGER NYRAST INTEGER NUMSPOTS INTEGER ISPOT INTEGER IH INTEGER IK INTEGER IL INTEGER IH_N INTEGER IK_N INTEGER IL_N INTEGER MULT INTEGER MINHARM INTEGER MAXHARM INTEGER INCHARM INTEGER ICODE INTEGER ICODE_TYPE INTEGER ISPAT INTEGER ICLOS INTEGER IMEAS INTEGER IBAD INTEGER IOVLD INTEGER NPLATES INTEGER NUMREFS INTEGER NOV REAL X_CEN_F REAL Y_CEN_F REAL W_F REAL ALAM REAL DMTHR2 REAL ALNOD REAL DTHR2NOD REAL AI REAL SIGI REAL XD REAL YD REAL XFD REAL YFD REAL SPOTW CHARACTER*2 VALSTR CHARACTER*80 ERRSTR CHARACTER*120 STR C LOGICAL OKNOD !Non-overlapped nodal flag C LOGICAL SPOV !Spatial overlap flag C LOGICAL CLOS !Spot too close to integrated flag C LOGICAL MEAS !Intensity measured flag C LOGICAL BAD !Bad spot flag C LOGICAL OVLD !Overload flag C LOGICAL DET_PROFS !Determine profiles flag C INTEGER IORD !Axis order flag 1-8 C INTEGER ISWAP !Byte swap flag C INTEGER IRFL !Plate refined flag = 1 yes, = 0 no C INTEGER IFLG !Integrated plate flag C INTEGER IFLAG !Parameter status flag C INTEGER ND !No. of decimal places flag C INTEGER IXROOT !Root window x position for popup notice C INTEGER IYROOT !Root window y position for popup notice C INTEGER IBUTTON !Button from popup notice C INTEGER IERR !Error flag C INTEGER JERR !Error flag C INTEGER NF_OFF !Offset between start of slow rasters in image C INTEGER IPL_SAV !Save current plate no. C INTEGER KPLATE !Plate for determinining profiles C INTEGER NXRAST !No. x-rasters C INTEGER NYRAST !No. y-rasters C INTEGER NUMSPOTS !No. of spots C INTEGER ISPOT !Spot number C INTEGER IH !'h' index C INTEGER IK !'k' index C INTEGER IL !'l' index C INTEGER IH_N !Nodal 'h' index C INTEGER IK_N !Nodal 'k' index C INTEGER IL_N !Nodal 'l' index C INTEGER MULT !Multiplicity C INTEGER MINHARM !Minimum harmonic C INTEGER MAXHARM !Maximum harmonic C INTEGER INCHARM !Harmonic increment C INTEGER ICODE !Integration routine flags code C INTEGER ICODE_TYPE !Code type of integration routines C INTEGER ISPAT !Spatial overlap flag C INTEGER ICLOS !Spots 'too close to integrate' flag C INTEGER IMEAS !Intensity measured flag C INTEGER IBAD !Bad spot flag C INTEGER IOVLD !Overload spot flag C INTEGER NPLATES !No. of plates in a pack C INTEGER NUMREFS !No. of reflns in LIRL C INTEGER NOV !No. of overloaded pixels ia spot C REAL X_CEN_F !X centre C REAL Y_CEN_F !Y centre C REAL W_F !Omega C REAL ALAM !Lambda value C REAL DMTHR2 !Dmin-threshold**2 C REAL ALNOD !Nodal lambda value C REAL DTHR2NOD !Nodal dmin-threshold**2 value C REAL AI !Integrated intensity C REAL SIGI !sig(AI) C REAL XD !'x' spot position on detector (rasters) C REAL YD !'y' spot position on detector (rasters) C REAL XFD !'x' coordinate value for spot (mm) C REAL YFD !'y' coordinate value for spot (mm) C REAL SPOTW !Spot width C CHARACTER*2 VALSTR !Paramter value string (dummy) C CHARACTER*80 ERRSTR !Error message string C CHARACTER*120 STR !Message string C C------------------------------------------------------------------------------- C C C====== Initialisations C KQUIT = 0 CALL LDM_GET_AXORD (VALSTR, IORD, ISWAP, IFLAG) CALL LDM_GET_NXRAS (NXRAST, IFLAG) CALL LDM_GET_NYRAS (NYRAST, IFLAG) C C====== Get progress bar position C CALL XDLF_VIEW_OBJECT_ROOTXY (IVH_IOW,20,20,JPROG_X,JPROG_Y,IERR) C C====== Open film/image-plate file if needed C CALL CHK_OPN(IERR) IF (IERR.GT.0) THEN KQUIT = 1 RETURN END IF C C====== Read image if not already read C IF (.NOT.FILM_READ) CALL READ_IMAGE (0, IMG, MAX_IMG_WORDS, + ITYPE, NF_OFF, JERR, ERRSTR) IF (.NOT.FILM_READ) THEN KQUIT = 1 RETURN END IF CALL FILM_CENTRE (X_CEN_F, Y_CEN_F, W_F) C C====== Check that plate has been refined C CALL LDM_GET_RFL(IPACK, IPLATE, IRFL, IFLAG, IERR, ERRSTR) IF (IRFL.EQ.0) THEN CALL NOTICE_POSN(1, IXROOT, IYROOT) CALL XDLF_POPUP_NOTICE (IXROOT, IYROOT, + XDLSTR('**Plate not yet refined**'), 25, + XDLSTR('Continue in spite of this?'), 26, + XDLSTR('Yes'), 3, + XDLSTR('No'), 2, + IFONT, 1, IBUTTON) IF (IBUTTON.EQ.2) THEN KQUIT = 1 RETURN END IF END IF C C====== Check if plate already integrated C CALL INTFLAG_GET (IPACK, IPLATE, IFLG) IF (IFLG.GT.0) THEN CALL NOTICE_POSN(1, IXROOT, IYROOT) CALL XDLF_POPUP_NOTICE (IXROOT, IYROOT, + XDLSTR('*Plate already integrated*'), 26, + XDLSTR('Redo integration?'), 17, + XDLSTR('Yes'), 3, + XDLSTR('No'), 2, + IFONT, 1, IBUTTON) IF (IBUTTON.EQ.1) THEN CALL LIRLF_DELETE (KDX_LIRL, IPACK, IPLATE, IERR) IF (IUN_LOG.GT.0) THEN STR = '*Warning*' CALL STR_ADDS (STR, + 'Previous intensities deleted for pack', 1) CALL STR_ADDI(STR,IPACK,1) CALL STR_ADDS(STR,', plate',0) CALL STR_ADDI(STR,IPLATE,1) WRITE(IUN_LOG,1010) WRITE(IUN_LOG,1020) STR(1:LENSTR(STR)) WRITE(IUN_LOG,1010) END IF CALL INTFLAG_SET (IPACK, IPLATE, 0) ELSE KQUIT = 1 RETURN END IF END IF C C====== Clear last pack/plate integrated flags C INTEG_LASTPK = 0 INTEG_LASTPL = 0 C C====== Determine required profiles if not already done C DET_PROFS = .FALSE. IF (IPRF_ALL.EQ.1) THEN IF (IPACK.NE.IPRF_PK.OR.IPLATE.NE.IPRF_PL) THEN DET_PROFS = .TRUE. KPLATE = IPLATE END IF ELSE IF (IPACK.NE.IPRF_PK.OR.KEYPLATE.NE.IPRF_PL) THEN CALL LDM_GET_NPLAT (NPLATES, IFLAG) IF (KEYPLATE.GT.NPLATES) THEN CALL ERR_NOTICE (1, '**Key plate out of valid range**') KQUIT = 1 RETURN END IF DET_PROFS = .TRUE. KPLATE = KEYPLATE END IF END IF IF (DET_PROFS) THEN IPL_SAV = IPLATE IPLATE = KPLATE CALL CALC_LAUE (.FALSE.) IF (IORD.LE.4) THEN CALL LRL_SORT (3) ELSE CALL LRL_SORT (4) END IF JPROG_PASS = 0 CALL LFN_SAINT (IPACK, IPLATE, 1, IMG, ITYPE, IORD, + NFRASTS, NXRAST, NYRAST, PROMIN, NPROF, + PRF_ROT, NOVLD, + INTEGRATE_PROGRESS, LFN_DUMMY_CNCL, + IERR, ERRSTR) CALL XDLF_DELETE_VIEW_OBJECT (IVH_BAR, JERR) IPLATE = IPL_SAV IF (IERR.NE.0) THEN STR = '**Error**' CALL STR_ADDS (STR,ERRSTR,1) CALL LMESSAGE (IVH_IOW, STR) KQUIT = 1 RETURN END IF IPRF_PK = IPACK IPRF_PL = KPLATE IF (IUN_LOG.GT.0) THEN WRITE(IUN_LOG,1010) STR = 'Determine integration profiles for pack' CALL STR_ADDI(STR,IPACK,1) CALL STR_ADDS(STR,', plate',0) CALL STR_ADDI(STR,IPLATE,1) WRITE(IUN_LOG,1020) STR(1:LENSTR(STR)) WRITE(IUN_LOG,1010) STR = 'Number of profile bins =' CALL STR_ADDI (STR, NPROF, 1) WRITE(IUN_LOG,1020) STR(1:LENSTR(STR)) WRITE(IUN_LOG,1010) CALL LDM_GET_SPOTW (IPACK, IPLATE, SPOTW, IFLAG, ND, + IERR, ERRSTR) IF (PRF_ROT.AND.SPOTW.NE.0.0) THEN STR = 'Profiles rotated for elliptical spots' ELSE STR = 'Profiles not rotated' END IF WRITE(IUN_LOG,1020) STR(1:LENSTR(STR)) WRITE(IUN_LOG,1010) STR = 'Minimum intensity for inclusion in profiles =' CALL STR_ADDF (STR, PROMIN, 1, 1) WRITE(IUN_LOG,1020) STR(1:LENSTR(STR)) WRITE(IUN_LOG,1010) CALL LFN_LIST_PROFS (IUN_LOG, 0, 0, 0, 80, 2, 2, IERR, + ERRSTR) END IF END IF C C====== Integrate spots of current plate C CALL CALC_LAUE (.FALSE.) IF (IORD.LE.4) THEN CALL LRL_SORT (3) ELSE CALL LRL_SORT (4) END IF JPROG_PASS = 0 CALL LFN_SAINT (IPACK, IPLATE, 2, IMG, ITYPE, IORD, + NFRASTS, NXRAST, NYRAST, PROMIN, NPROF, + PRF_ROT, NOVLD, + INTEGRATE_PROGRESS, LFN_DUMMY_CNCL, + IERR, ERRSTR) CALL XDLF_DELETE_VIEW_OBJECT (IVH_BAR, JERR) IF (IUN_LOG.GT.0) THEN WRITE(IUN_LOG,1010) STR = 'Integrate intensities for pack' CALL STR_ADDI(STR,IPACK,1) CALL STR_ADDS(STR,', plate',0) CALL STR_ADDI(STR,IPLATE,1) WRITE(IUN_LOG,1020) STR(1:LENSTR(STR)) WRITE(IUN_LOG,1010) IF (IPRF_ALL.EQ.1) THEN STR = 'Profile determination from each plate in pack' ELSE STR = 'Profile determination from key plate only' END IF WRITE(IUN_LOG,1020) STR(1:LENSTR(STR)) WRITE(IUN_LOG,1010) STR = 'Number of overload pixels allowed in a spot =' CALL STR_ADDI (STR, NOVLD, 1) WRITE(IUN_LOG,1020) STR(1:LENSTR(STR)) WRITE(IUN_LOG,1010) END IF IF (IERR.NE.0) THEN STR = '**Error**' CALL STR_ADDS (STR,ERRSTR,1) CALL LOG_MSG (IVH_IOW, STR, 1) KQUIT = 1 RETURN END IF C C====== Save pack & plate no. C INTEG_LASTPK = IPACK INTEG_LASTPL = IPLATE C C====== Save integrated intensities data in LIRL C CALL LRL_NUMSPOTS (NUMSPOTS) IF (NUMSPOTS.GT.0) THEN CALL LIRLF_NUMREFS (KDX_LIRL, NUMREFS) DO 100 ISPOT = 1, NUMSPOTS CALL LRL_GET (ISPOT, IH, IK, IL, XD, YD, ALAM, DMTHR2, + MULT, OKNOD, SPOV, IERR) IF (MULT.GT.1) THEN CALL LRL_GET_HARM (ISPOT, IH, IK, IL, IH_N, IK_N, IL_N, + MULT, MINHARM, MAXHARM, INCHARM, + ALNOD, DTHR2NOD, IERR) ELSE MINHARM = 0 MAXHARM = 0 INCHARM = 0 END IF CALL LRL_GET_XFYFD (ISPOT, XFD, YFD, IERR) CALL LRL_GET_OVLP (ISPOT, SPOV, CLOS, IERR) CALL LRL_GET_INT (ISPOT, AI, SIGI, MEAS, BAD, OVLD, ICODE, + ICODE_TYPE, IERR) ISPAT = 0 ICLOS = 0 IMEAS = 0 IBAD = 0 IOVLD = 0 IF (SPOV) ISPAT = 1 IF (CLOS) ICLOS = 1 IF (MEAS) IMEAS = 1 IF (BAD) IBAD = 1 IF (OVLD) IOVLD = 1 IF (CLOS) THEN IMEAS = 0 AI = 0.0 SIGI = 0.0 END IF CALL LIRLF_ADDREF (KDX_LIRL, IH, IK, IL, IPACK, IPLATE, 0, + XFD, YFD, ALAM, MULT, MINHARM, MAXHARM, + INCHARM, AI, SIGI, ISPAT, ICLOS, + IMEAS, IBAD, IOVLD, ICODE, IERR) IF (IERR.LT.0) THEN CALL LIRLF_DELETE (KDX_LIRL, IPACK, IPLATE, JERR) CALL NOTICE_POSN(1, IXROOT, IYROOT) ERRSTR = '**Error** Cannot allocate memory required' CALL XDLF_POPUP_NOTICE (IXROOT, IYROOT, + XDLSTR(ERRSTR), LENSTR(ERRSTR), + XDLSTR('Integrated intensities deleted'), 30, + XDLSTR('Continue'), 8, + XDLSTR(' '), -1, + IFONT, 1, IBUTTON) IF (IUN_LOG.GT.0) THEN WRITE (IUN_LOG,1050) ERRSTR(1:LENSTR(ERRSTR)) ERRSTR = '**Error** Integrated intensities deleted' WRITE (IUN_LOG,1050) ERRSTR(1:LENSTR(ERRSTR)) END IF GO TO 110 END IF CALL LRL_GET_OVPIX (ISPOT, NOV, IERR) CALL LIRLF_SET_OVPIX (KDX_LIRL, NUMREFS+ISPOT, NOV, IERR) 100 CONTINUE 110 CALL INTFLAG_SET (IPACK, IPLATE, 1) END IF C C====== Log statistics C CALL LOG_INT_TAB1 RETURN C C====== Format statements C 1010 FORMAT(' ') 1020 FORMAT(A) 1050 FORMAT (/,A) END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C******************************* C** INTEGRATE_PROGRESS ** C******************************* C C SUBROUTINE INTEGRATE_PROGRESS (IPASS, NSPOT, ISPOT) C INCLUDE 'implicit_none.finc' C C Purpose: Monitor progess of integration passes C C Author: John W. Campbell, December 1995 C C Arguments: C INTEGER IPASS INTEGER NSPOT INTEGER ISPOT C C IPASS (R) Integration pass C NSPOT (R) Total no. spots to integrate C ISPOT (R) No. of last spot integrated C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'lirl_pars.finc' INCLUDE 'prog_flags.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR C C====== LOCALS: C INTEGER IERR C C INTEGER IERR !Error flag C C------------------------------------------------------------------------------- C IF (JPROG_PASS.EQ.IPASS) THEN IF (LG_MODE.NE.1) RETURN IF (MOD(ISPOT,20).NE.0) RETURN CALL XDLF_PROGRESS_BAR_VALUE (IVH_BAR, ISPOT, IERR) ELSE IF (LG_MODE.EQ.1) THEN IF (IPASS.EQ.1) THEN CALL XDLF_PROGRESS_BAR (IVH_BAR, JPROG_X, JPROG_Y, + XDLSTR('Forming profiles:'), 17, 150, NSPOT, + 2, 1) ELSE IF (IPASS.EQ.2) THEN CALL XDLF_PROGRESS_BAR (IVH_BAR, JPROG_X, JPROG_Y, + XDLSTR('Integrating spots:'), 18, 150, NSPOT, + 2, 5) END IF ELSE IF (LG_MODE.EQ.2) THEN IF (IPASS.EQ.1) THEN CALL TWRITE ('==Forming profiles==') ELSE IF (IPASS.EQ.2) THEN CALL TWRITE ('==Integrating spots==') END IF END IF JPROG_PASS = IPASS END IF RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C**************************** C** INTEGRATE_SHOW ** C**************************** C C SUBROUTINE INTEGRATE_SHOW C INCLUDE 'implicit_none.finc' C C Purpose: Examine integration results after an interactive integration request C C Author: John W. Campbell, January 1996 C C Arguments: C C None C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR C C====== LOCALS: C INTEGER M_PROFS INTEGER M_SPOTS INTEGER M_STATS INTEGER NVIEW INTEGER IVHLIST(2) INTEGER IVH INTEGER ITEM INTEGER IQUIT INTEGER IERR CHARACTER*25 NAMES(3) CHARACTER*25 QUITNAM C INTEGER M_PROFS !Menu item no.: Examine Profiles C INTEGER M_SPOTS !Menu item no.: Examine Individual Spots C INTEGER M_STATS !Menu item no.: Integration Statistics C INTEGER NVIEW !No. of view-objects for getting events C INTEGER IVHLIST(2) !List of view-object handles for getting events C INTEGER IVH !Returned view-object handle from getting events C INTEGER ITEM !Item no. from menu selection C INTEGER IQUIT !Quit button flage from menu C INTEGER IERR !Error flag C CHARACTER*25 NAMES(3) !Menu item names C CHARACTER*25 QUITNAM !Quit button string DATA NAMES /'Examine Profiles', + 'Examine Individual Spots', + 'Integration Statistics'/ DATA QUITNAM /'Return to Previous Menu'/ C C------------------------------------------------------------------------------- C M_PROFS = 1 M_SPOTS = 2 M_STATS = 3 50 CALL XDLF_MENU_AREA_SETMENU (IVH_MENU, 3, XDLSTR(NAMES), 25, + XDLSTR('Integration Results Menu'), 24, + XDLSTR(QUITNAM), 25, 0, IERR) C C====== Set up list of view-object handles C NVIEW = 1 IVHLIST(1) = IVH_MENU C C====== Start event loop C 100 CALL XDLF_GET_EVENTS (NVIEW, IVHLIST, IVH) IF (IVH.EQ.IVH_MENU) THEN C C====== Menu item selected C CALL XDLF_MENU_AREA_GETITEM (IVH_MENU, ITEM, IQUIT) C C====== Quit selected C IF (IQUIT.EQ.1) RETURN C C====== Show Profiles C IF (ITEM.EQ.M_PROFS) THEN CALL SHOW_PROFILES GO TO 50 C C====== Examine Individual Spots C ELSE IF (ITEM.EQ.M_SPOTS) THEN CALL EXAMINE_SPOTS GO TO 50 C C====== Integration Statistics C ELSE IF (ITEM.EQ.M_STATS) THEN CALL SHOW_INTSTATS GO TO 50 END IF GO TO 100 END IF GO TO 100 END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** INTFLAG_GET ** C************************** C C SUBROUTINE INTFLAG_GET (IPACK, IPLATE, IFLG) C INCLUDE 'implicit_none.finc' C C Purpose: Get integration flag C C Author: John W. Campbell, December 1995 C C Arguments: C INTEGER IPACK INTEGER IPLATE INTEGER IFLG C C IPACK (R) Pack no. C IPLATE (R) Plate no. C IFLG (W) The flag =0 clear, C =1 integrated & stored in LIRL C =2 as for 1 but data also written to o/p file C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'lirl_pars.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR INTEGER LDM_PLMAX C C====== LOCALS: C INTEGER IREC INTEGER IARR(2) INTEGER IERR C INTEGER IREC !Record pointer C INTEGER IARR(2) !Record buffer C INTEGER IERR !Error flag C C------------------------------------------------------------------------------- C IREC = (IPACK-1)*LDM_PLMAX(0) + IPLATE CALL DMLF_GETREC (KDX_INTFLAGS, IREC, IARR, IERR) IFLG = IARR(1) RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** INTFLAG_SET ** C************************** C C SUBROUTINE INTFLAG_SET (IPACK, IPLATE, IFLG) C INCLUDE 'implicit_none.finc' C C Purpose: Set integration flag C C Author: John W. Campbell, December 1995 C C Arguments: C INTEGER IPACK INTEGER IPLATE INTEGER IFLG C C IPACK (R) Pack no. C IPLATE (R) Plate no. C IFLG (R) The flag =0 clear, C =1 integrated & stored in LIRL C =2 as for 1 but data also written to o/p file C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'lirl_pars.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR INTEGER LDM_PLMAX C C====== LOCALS: C INTEGER IREC INTEGER IARR(2) INTEGER IERR C INTEGER IREC !Record pointer C INTEGER IARR(2) !Record buffer C INTEGER IERR !Error flag C C------------------------------------------------------------------------------- C IREC = (IPACK-1)*LDM_PLMAX(0) + IPLATE IARR(1) = IFLG CALL DMLF_PUTREC (KDX_INTFLAGS, IREC, IARR, IERR) RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C*********************** C** INTFP ** C*********************** C C FUNCTION INTFP (CHSTR, FP, IV) C C Purpose: Decode a character string into a number (floating and integer) C C Author: John W. Campbell C C RETURN: = 0 Syntax error in the number C = 1 integer (no decimal point present) C = 2 floating point (decimal point present or E format) C = -1 blank string C C Arguments: C C CHSTR (R) Character string containing the number to be decoded C (Leading spaces ignored; further space terminates C the number string interpreted) C FP (W) Returns the value as a floating point value (0.0 if C synatx error) C IV (W) Returns the value as an integer (the nearest integer C if value contained a decimal point) (0 if syntax error) C C C Declarations C ============ C C LOCALS: C CHARACTER*(*) CHSTR CHARACTER*15 DIG LOGICAL END, START DOUBLE PRECISION FPVAL, X, S DATA DIG /'eE0123456789.+-'/ C C------------------------------------------------------------------------------- C C C====== Initialisations C FPVAL = 0.0 FP = 0.0 IV = 0 END = .FALSE. START = .FALSE. IEXP = 0 M1 = 3 M2 = 15 I = 0 IMAX = LEN (CHSTR) IF (CHSTR.EQ.' ') THEN INTFP = -1 RETURN ENDIF C C====== Interpret Number C 100 S = 1.0 ID = 0 IFDEC = 0 X = 0.0 120 I = I + 1 IF (I.GT.IMAX) THEN END = .TRUE. IF (IEXP.EQ.1) GO TO 600 GO TO 500 ENDIF IF (CHSTR(I:I).EQ.' ') THEN IF (START) I = IMAX GO TO 120 ENDIF J = INDEX(DIG(M1:M2),CHSTR(I:I)) IF (J.EQ.0) GO TO 800 START = .TRUE. J = J + M1 - 1 M1 = 1 + 2*IEXP C C====== Digit C IF (J.GE.3.AND.J.LE.12) THEN ID = ID + IFDEC X = 10.0 * X + J - 3 IF (M2.GT.13) M2 = 13 GO TO 120 C C====== Decimal point C ELSE IF (J.EQ.13) THEN IF (IEXP.EQ.1) GO TO 800 IFDEC = 1 M2 = 12 GO TO 120 C C====== Sign C ELSE IF (J.GE.14) THEN IF (J.EQ.15) S = -1.0 M2 = 13 GO TO 120 C C====== Exponent C ELSE IEXP = 1 M1 = 3 M2 = 15 ENDIF C C====== Evaluate number C 500 FPVAL = S * X / (10**ID) IF (END) THEN FP = FPVAL IV = NINT (FP) INTFP = 1 IF (IFDEC.GT.0) INTFP = 2 RETURN ENDIF GO TO 100 C C====== Evaluate and apply exponent C 600 IEX = NINT (S*X) FPVAL = FPVAL * 10.0**IEX FP = FPVAL IV = NINT (FP) INTFP = 2 RETURN C C====== Error Condition C 800 INTFP = 0 RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** IOW_ASKF ** C************************** C SUBROUTINE IOW_ASKF (IVH, STR, VALUE, ND) C C Purpose: Output a text prompt to an I/O window with a default real value C Read in and return a real value. C C If the reply has invalid syntax then the prompt will be repeated C C (Max length for reply and value in prompt is 25 characters) C C Author: John W. Campbell, May 1991 C C Arguments: C INTEGER IVH CHARACTER*(*) STR REAL VALUE INTEGER ND C IVH (R) View-object handle for the I/O window C STR (R) Character string for the question C The default value will be appended as ' [value]: ' C Total prompt may not exceed 120 characters. C VALUE (R/W) On input: the default value C On output: the value read in C ND (R) The number of decimal places for the value in the prompt C (if -ve then use E format) (Max 99) C C C====== FUNCTION TYPES: C INTEGER XDLSTR REAL FPVAL C C====== LOCALS: C LOGICAL ERR INTEGER IERR INTEGER LL INTEGER L INTEGER I INTEGER IVH_RET INTEGER IVHLIST(2) REAL X CHARACTER*25 FPSTR CHARACTER*120 PROMPT CHARACTER*8 FMT C LOGICAL ERR !Floating point number error flag C INTEGER IERR !Error return flag C INTEGER LL !Length of prompt stripped of trailing blanks C INTEGER L !Character counter C INTEGER I !Temp/loop variable C INTEGER IVH_RET !View-object handle from XDLF_GET_EVENTS C INTEGER IVHLIST(2) !View-object handles list for XDLF_GET_EVENTS C REAL X !Real value input C CHARACTER*25 FPSTR !Value string C CHARACTER*120 PROMPT !Prompt string C CHARACTER*8 FMT !Format statement array C C------------------------------------------------------------------------------- C C====== Get length less trailing blanks C LL = LEN(STR) DO 100 L=LL,1,-1 IF (STR(L:L).NE.' ') GO TO 120 100 CONTINUE L=1 C C====== Write floating point value to a string C 120 IF (ND.GT.0) THEN FMT = '(F25. )' WRITE (FMT(6:7),'(I2.2)') ND WRITE (FPSTR,FMT) VALUE ELSE IF (ND.LT.0) THEN FMT = '(E25. )' WRITE (FMT(6:7),'(I2.2)') -ND WRITE (FPSTR,FMT) VALUE ELSE WRITE (FPSTR,'(I25)') NINT(VALUE) ENDIF C C====== Form prompt string C PROMPT = STR(1:L)//' [' L = L + 2 DO 130 I=1,25 IF (FPSTR(I:I).NE.' ') THEN L = L + 1 PROMPT(L:L) = FPSTR(I:I) ENDIF 130 CONTINUE PROMPT(L+1:) =']: ' L = L + 3 C C====== Output prompt C 200 CALL XDLF_IO_WINDOW_PRINT (IVH, XDLSTR(PROMPT), L, 0, IERR) C C====== Get reply C IVHLIST(1) = IVH CALL XDLF_GET_EVENTS (1, IVHLIST, IVH_RET) CALL XDLF_IO_WINDOW_GETSTRING (IVH, XDLSTR(FPSTR), 25, IERR) IF (FPSTR.EQ.' ') RETURN X = FLPVAL(FPSTR,ERR) IF (ERR) GO TO 200 VALUE = X RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** IOW_ASKI ** C************************** C SUBROUTINE IOW_ASKI (IVH, STR, IVALUE) C C Purpose: Output a text prompt to an I/O window with a default integer value C Read in and return an integer value. C C If the reply has invalid syntax then the prompt will be repeated C C (Max length for reply and value in prompt is 25 characters) C C Author: John W. Campbell, May 1991 C C Arguments: C INTEGER IVH CHARACTER*(*) STR INTEGER IVALUE C IVH (R) View-object handle for the I/O window C STR (R) Character string for the question C The default value will be appended as ' [value]: ' C Total prompt may not exceed 120 characters. C IVALUE (R/W) On input: the default value C On output: the value read in (nearest integer if a floating C point number is given) C C C====== FUNCTION TYPES: C INTEGER XDLSTR REAL FPVAL C C====== LOCALS: C LOGICAL ERR INTEGER IERR INTEGER LL INTEGER L INTEGER I INTEGER IVH_RET INTEGER IVHLIST(2) REAL X CHARACTER*25 XSTR CHARACTER*120 PROMPT C LOGICAL ERR !Floating point number error flag C INTEGER IERR !Error return flag C INTEGER LL !Length of prompt stripped of trailing blanks C INTEGER L !Character counter C INTEGER I !Temp/loop variable C INTEGER IVH_RET !View-object handle from XDLF_GET_EVENTS C INTEGER IVHLIST(2) !View-object handles list for XDLF_GET_EVENTS C REAL X !Real value input C CHARACTER*25 XSTR !Value string C CHARACTER*120 PROMPT !Prompt string C C------------------------------------------------------------------------------- C C====== Get length less trailing blanks C LL = LEN(STR) DO 100 L=LL,1,-1 IF (STR(L:L).NE.' ') GO TO 120 100 CONTINUE L=1 C C====== Write integer value to a string C 120 WRITE (XSTR,'(I25)') IVALUE C C====== Form prompt string C PROMPT = STR(1:L)//' [' L = L + 2 DO 130 I=1,25 IF (XSTR(I:I).NE.' ') THEN L = L + 1 PROMPT(L:L) = XSTR(I:I) ENDIF 130 CONTINUE PROMPT(L+1:) =']: ' L = L + 3 C C====== Output prompt C 200 CALL XDLF_IO_WINDOW_PRINT (IVH, XDLSTR(PROMPT), L, 0, IERR) C C====== Get reply C IVHLIST(1) = IVH CALL XDLF_GET_EVENTS (1, IVHLIST, IVH_RET) CALL XDLF_IO_WINDOW_GETSTRING (IVH, XDLSTR(XSTR), 25, IERR) IF (XSTR.EQ.' ') RETURN X = FLPVAL(XSTR,ERR) IF (ERR) GO TO 200 IVALUE = NINT(X) RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** IOW_ASKQ ** C************************** C SUBROUTINE IOW_ASKQ (IVH, STR, REPLY) C C Purpose: Output a text prompt to an I/O window with yes/no options C Read in yes/no reply and return answer as a logical flag C C If the reply has invalid syntax then the prompt will be repeated C C Author: John W. Campbell, May 1991 C C Arguments: C INTEGER IVH CHARACTER*(*) STR LOGICAL REPLY C IVH (R) View-object handle for the I/O window C STR (R) Character string for the question C (The string ' (y/n) [y]: ' or ' (y/n) [n]: ' will be appended) C Total prompt may not exceed 120 characters. C REPLY (R/W) Logical flag: On input .true. if default reply is yes C .false. if default reply is no C On output .true. if reply was yes C .false. if reply was no C C====== FUNCTION TYPES: C INTEGER XDLSTR C C====== LOCALS: C INTEGER IERR INTEGER LL INTEGER L INTEGER I INTEGER IVH_RET INTEGER IVHLIST(2) CHARACTER*20 YESNO CHARACTER*120 PROMPT C INTEGER IERR !Error return flag C INTEGER LL !Length of prompt stripped of trailing blanks C INTEGER L !Character counter C INTEGER I !Temp/loop variable C INTEGER IVH_RET !View-object handle from XDLF_GET_EVENTS C INTEGER IVHLIST(2) !View-object handles list for XDLF_GET_EVENTS C CHARACTER*20 YESNO !Reply string C CHARACTER*120 PROMPT !Prompt string C C------------------------------------------------------------------------------- C C====== Get length less trailing blanks C LL = LEN(STR) DO 100 L=LL,1,-1 IF (STR(L:L).NE.' ') GO TO 120 100 CONTINUE L=1 C C====== Form prompt string C 120 IF (REPLY) THEN PROMPT = STR(1:L)//' (y/n) [y]: ' ELSE PROMPT = STR(1:L)//' (y/n) [n]: ' ENDIF L = L + 12 C C====== Output prompt C 200 CALL XDLF_IO_WINDOW_PRINT (IVH, XDLSTR(PROMPT), L, 0, IERR) C C====== Get reply C IVHLIST(1) = IVH CALL XDLF_GET_EVENTS (1, IVHLIST, IVH_RET) CALL XDLF_IO_WINDOW_GETSTRING (IVH, XDLSTR(YESNO), 20, IERR) IF (YESNO.EQ.' ') RETURN DO 300 I=1,20 IF (YESNO(I:I).NE.' ') THEN IF (YESNO(I:I).EQ.'y'.OR.YESNO(I:I).EQ.'Y') THEN REPLY = .TRUE. RETURN ELSE IF (YESNO(I:I).EQ.'n'.OR.YESNO(I:I).EQ.'N') THEN REPLY = .FALSE. RETURN ELSE GO TO 200 ENDIF ENDIF 300 CONTINUE RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** LAM_HIST ** C************************** C C SUBROUTINE LAM_HIST (LAMBDA_BINS) C INCLUDE 'implicit_none.finc' C C Purpose: Get wavelength histogram (16 bins) C C Author: John W. Campbell, February 1992 (based on LAMBDA_HIST from GENLAUE) C C Arguments: C INTEGER LAMBDA_BINS(16) C C LAMBDA_BINS(16) (W) Returned histogram C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'film_pack.finc' C C====== FUNCTION TYPES: C C C====== LOCALS: C LOGICAL SPAT LOGICAL NODFLG INTEGER I INTEGER J INTEGER IFLAG INTEGER ND INTEGER IERR INTEGER NUMSPOTS INTEGER JH INTEGER JK INTEGER JL INTEGER MULT REAL DTHR2 REAL XFD REAL YFD REAL BIN_CUTOFF(16) REAL LAMBDA REAL WMIN REAL WMAX CHARACTER*2 ERRSTR C LOGICAL SPAT !Spatial overlap flag C LOGICAL NODFLG !OK nodal flag C INTEGER I !Loop variable C INTEGER J !Loop variable C INTEGER IFLAG !Parameter status flag C INTEGER ND !No. of decimal places flag C INTEGER IERR !Error flag C INTEGER NUMSPOTS !No. of spots in list C INTEGER JH !'h' index C INTEGER JK !'k' index C INTEGER JL !'l' index C INTEGER MULT !Multiplicity C REAL DTHR2 !dmin-thresh**2 C REAL XFD !Spot 'x' position C REAL YFD !Spot 'y' position C REAL BIN_CUTOFF(16) !Upper Lambda limits for each bin C REAL LAMBDA !Wavelength of current reflection C REAL WMIN !Lambda-min C REAL WMAX !Lambda-max C CHARACTER*2 ERRSTR !Error string (dummy) C C------------------------------------------------------------------------------- C C C====== Set up bins C CALL LDM_GET_LMIN (IPACK, WMIN, IFLAG, ND, IERR, ERRSTR) CALL LDM_GET_LMAX (IPACK, WMAX, IFLAG, ND, IERR, ERRSTR) DO 20 I = 1 , 16 BIN_CUTOFF(I) = WMIN + I*(WMAX-WMIN)/15.0 LAMBDA_BINS(I) = 0 20 CONTINUE BIN_CUTOFF(16) = 100.0 C C====== Work out histogram C CALL LRL_NUMSPOTS (NUMSPOTS) DO 50 J = 1 , NUMSPOTS CALL LRL_GET (J, JH, JK, JL, XFD, YFD, LAMBDA, DTHR2, MULT, + NODFLG, SPAT, IERR) DO 30 I = 1 , 16 IF (LAMBDA.LT.BIN_CUTOFF(I)) GO TO 40 30 CONTINUE I = 16 40 LAMBDA_BINS(I) = LAMBDA_BINS(I) + 1 50 CONTINUE RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** LAUE_SIMS ** C************************** C C SUBROUTINE LAUE_SIMS C INCLUDE 'implicit_none.finc' C C Purpose: Handle Laue simulations program option C C Author: John W. Campbell, July 1992 C C C Arguments: C C None C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' INCLUDE 'screen_params.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'gnom_rmin.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR INTEGER LENSTR INTEGER INTFP C C====== LOCALS: C LOGICAL SIM LOGICAL GNOM LOGICAL TILTED INTEGER NVIEW INTEGER I INTEGER IVHLIST(4) INTEGER IVH INTEGER ITEM INTEGER IQUIT INTEGER IERR INTEGER KXROOT INTEGER KYROOT INTEGER KERR INTEGER NUMSPOTS INTEGER M_COLR INTEGER M_INTER INTEGER M_GNOMC INTEGER M_GNOMI INTEGER M_DIRECT INTEGER IFLAG INTEGER ND INTEGER ITM INTEGER ITYP INTEGER IP_GNOMR INTEGER IV REAL RMin REAL RMAX REAL DTILT REAL FP CHARACTER*25 NAMES(5) CHARACTER*25 QUITNAM CHARACTER*2 ERRSTR CHARACTER*(MAX_P3SCROLL_CHARS) PVAL CHARACTER*80 STR C LOGICAL SIM !Simulation is displayed flag .TRUE.=yes, .FALSE.=no C LOGICAL GNOM !Last simulation was a gnomonic projection flag C LOGICAL TILTED !Tilted detector flag C INTEGER I !Temporary/loop variable C INTEGER NVIEW !Number of view-objects from which data is to be input C INTEGER IVHLIST(4) !View-object handles list for getting data C INTEGER IVH !View-object handle of view-object returning data C INTEGER ITEM !Item number selected from menu C INTEGER IQUIT !Quit flag C INTEGER IERR !Error flag C INTEGER KXROOT !x position for Laue simulation view-object C INTEGER KYROOT !y position for Laue simulation view-object C INTEGER KERR !Error flag for finding view-object position C INTEGER NUMSPOTS !Number of spots C INTEGER M_COLR !Menu item number for: Colour simulations C INTEGER M_INTER !Menu item number for: Interactive display C INTEGER M_GNOMC !Menu item number for: Gnomonic colour simulations C INTEGER M_GNOMI !Menu item number for: Gnomonic interactive sims. C INTEGER M_DIRECT !Menu item number for: Set Direction C INTEGER IFLAG !Parameter status flag C INTEGER ND !No. of decimal places flag C INTEGER ITM !Item no. modified in parameter table C INTEGER ITYP !Return flag from INTFP or extended LDM param type C INTEGER IP_GNOMR !Parameter table 3 item no. for Gnomonic 'rmin' C INTEGER IV !Integer value C REAL RMIN !LDM 'rmin' parameter C REAL RMAX !LDM 'rmax' parameter C REAL DTILT !Detector tilt angle C REAL FP !Real value C CHARACTER*25 NAMES(5) !Menu item names C CHARACTER*25 QUITNAM !Quit box label C CHARACTER*2 ERRSTR !Error string (dummy) C CHARACTER*(MAX_P3SCROLL_CHARS) PVAL !String for parameter table input value C CHARACTER*80 STR !String DATA NAMES /'Colour Coded Display', + 'Interactive Display', + 'Colour Gnomonic', + 'Interactive Gnomonic', + 'Set Direction'/ DATA QUITNAM /'Return to Main Menu'/ C C------------------------------------------------------------------------------- C C====== Initialisations C SIM = .FALSE. GNOM = .FALSE. TILTED = .FALSE. CALL LDM_GET_DTILT (DTILT, IFLAG, ND) IF (DTILT.NE.0.0.AND.DTILT.NE.180.0) TILTED = .TRUE. IF (GNOMR.EQ.0.0) THEN CALL LDM_GET_RMIN (RMIN, IFLAG, ND) CALL LDM_GET_RMAX (RMAX, IFLAG, ND) GNOMR = RMAX/10.0 IF (GNOMR.LT.RMIN) GNOMR = RMIN END IF C C====== Set up parameter table 3 C IP_GNOMR = 1 WRITE (STR,'(F8.2)') GNOMR CALL LJUST (STR) CALL XDLF_PARAM_TABLE_SETITEM (IVH_PAR3, IP_GNOMR, + XDLSTR('Gnomonic rmin:'), 13, + XDLSTR(STR), LENSTR(STR), 0, 0, IERR) C C====== Get position for the display C CALL XDLF_VIEW_OBJECT_ROOTXY(IVH_PAR1,0,0,KXROOT,KYROOT,KERR) KYROOT = KYROOT - 30 IF (KYROOT.LT.0) KYROOT = 0 C C====== Set up menu C M_COLR = 1 M_INTER = 2 M_GNOMC = 3 M_GNOMI = 4 M_DIRECT = 5 CALL XDLF_MENU_AREA_SETMENU (IVH_MENU, 5, XDLSTR(NAMES), 25, + XDLSTR('Simulations Menu'), 16, + XDLSTR(QUITNAM), 25, 0, IERR) C C====== Set up list of view-object handles C NVIEW = 4 IVHLIST(1) = IVH_MENU IVHLIST(2) = IVH_PAR1 IVHLIST(3) = IVH_PAR2 IVHLIST(4) = IVH_PAR3 C C====== Start event loop C 100 CALL XDLF_GET_EVENTS (NVIEW, IVHLIST, IVH) IF (IVH.EQ.IVH_MENU) THEN C C====== Menu item selected C CALL XDLF_MENU_AREA_GETITEM (IVH_MENU, ITEM, IQUIT) C C====== Quit box selected C IF (IQUIT.EQ.1) THEN CALL XDLF_PARAM_TABLE_CLEARITEMS (IVH_PAR3, IERR) IF (SIM) CALL XDLF_DELETE_VIEW_OBJECT (IVH_SIM, IERR) RETURN END IF C C====== Colour simulation C IF (ITEM.EQ.M_COLR) THEN IF (SIM) CALL XDLF_DELETE_VIEW_OBJECT (IVH_SIM, IERR) CALL CALC_LAUE (.TRUE.) CALL LRL_NUMSPOTS (NUMSPOTS) IF (NUMSPOTS.EQ.0) THEN CALL LMESSAGE(IVH_IOW,'**No Generated Reflections**') GO TO 100 END IF CALL LRL_XDLSIM (IVH_SIM, 0, KXROOT, KYROOT, 1, 1, 300, 0, + 0, 0, IERR) SIM = .TRUE. GNOM = .FALSE. GO TO 100 C C====== Monochrome simulation with soft limit sliders etc. C ELSE IF (ITEM.EQ.M_INTER) THEN IF (SIM) CALL XDLF_DELETE_VIEW_OBJECT (IVH_SIM, IERR) CALL CALC_LAUE (.TRUE.) CALL LRL_NUMSPOTS (NUMSPOTS) IF (NUMSPOTS.EQ.0) THEN CALL LMESSAGE(IVH_IOW,'**No Generated Reflections**') GO TO 100 END IF CALL LRL_XDLSIM (IVH_SIM, 0, KXROOT, KYROOT, 1, 2, 300, 0, + 0, 0, IERR) SIM = .TRUE. GNOM = .FALSE. GO TO 100 C C====== Gnomonic colour simulation C ELSE IF (ITEM.EQ.M_GNOMC) THEN IF (TILTED) THEN CALL ERR_NOTICE(1, + '**Option not available for tilted detector**') GO TO 100 END IF IF (SIM) CALL XDLF_DELETE_VIEW_OBJECT (IVH_SIM, IERR) CALL CALC_LAUE (.TRUE.) CALL LRL_NUMSPOTS (NUMSPOTS) IF (NUMSPOTS.EQ.0) THEN CALL LMESSAGE(IVH_IOW,'**No Generated Reflections**') GO TO 100 END IF CALL LRL_XDLGNM (IVH_SIM, 0, KXROOT, KYROOT, 1, 1, 300, 0, + GNOMR, 0, 0, IERR) SIM = .TRUE. GNOM = .TRUE. GO TO 100 C C====== Gnomonic monochrome simulation with soft limit sliders etc. C ELSE IF (ITEM.EQ.M_GNOMI) THEN IF (TILTED) THEN CALL ERR_NOTICE(1, + '**Option not available for tilted detector**') GO TO 100 END IF IF (SIM) CALL XDLF_DELETE_VIEW_OBJECT (IVH_SIM, IERR) CALL CALC_LAUE (.TRUE.) CALL LRL_NUMSPOTS (NUMSPOTS) IF (NUMSPOTS.EQ.0) THEN CALL LMESSAGE(IVH_IOW,'**No Generated Reflections**') GO TO 100 END IF CALL LRL_XDLGNM (IVH_SIM, 0, KXROOT, KYROOT, 1, 2, 300, 0, + GNOMR, 0, 0, IERR) SIM = .TRUE. GNOM = .TRUE. GO TO 100 C C====== Set Direction C ELSE IF (ITEM.EQ.M_DIRECT) THEN IF (SIM) CALL XDLF_VIEW_OBJECT_RAISE (IVH_BASE, IERR) CALL SET_DIRECTION (IERR) IF (SIM) CALL XDLF_VIEW_OBJECT_RAISE (IVH_SIM, KERR) IF (IERR.NE.0) GO TO 100 IF (SIM) THEN CALL CALC_LAUE (.TRUE.) CALL LRL_NUMSPOTS (NUMSPOTS) IF (NUMSPOTS.EQ.0) THEN CALL LMESSAGE(IVH_IOW,'**No Generated Reflections**') GO TO 100 END IF IF (GNOM) THEN CALL LRL_XDLGNM (IVH_SIM, 0, KXROOT, KYROOT, 1, 1, + 300, 1, GNOMR, 0, 0, IERR) ELSE CALL LRL_XDLSIM (IVH_SIM, 0, KXROOT, KYROOT, 1, 1, + 300, 1, 0, 0, IERR) END IF END IF GO TO 100 END IF C C====== Parameter table 1 input C ELSE IF (IVH.EQ.IVH_PAR1) THEN CALL PAR1_INPUT TILTED = .FALSE. CALL LDM_GET_DTILT (DTILT, IFLAG, ND) IF (DTILT.NE.0.0.AND.DTILT.NE.180.0) TILTED = .TRUE. IF (SIM) THEN CALL CALC_LAUE (.TRUE.) CALL LRL_NUMSPOTS (NUMSPOTS) IF (NUMSPOTS.EQ.0) THEN CALL LMESSAGE(IVH_IOW,'**No Generated Reflections**') GO TO 100 END IF IF (GNOM) THEN IF (TILTED) THEN CALL XDLF_DELETE_VIEW_OBJECT (IVH_SIM, IERR) SIM = .FALSE. GO TO 100 END IF CALL LRL_XDLGNM (IVH_SIM, 0, KXROOT, KYROOT, 1, 1, 300, + 1, GNOMR, 0, 0, IERR) ELSE CALL LRL_XDLSIM (IVH_SIM, 0, KXROOT, KYROOT, 1, 1, 300, + 1, 0, 0, IERR) END IF END IF GO TO 100 C C====== Parameter table 2 input C ELSE IF (IVH.EQ.IVH_PAR2) THEN CALL PAR2_INPUT CALL PAR1_INPUT IF (SIM) THEN CALL CALC_LAUE (.TRUE.) CALL LRL_NUMSPOTS (NUMSPOTS) IF (NUMSPOTS.EQ.0) THEN CALL LMESSAGE(IVH_IOW,'**No Generated Reflections**') GO TO 100 END IF CALL LRL_XDLSIM (IVH_SIM, 0, KXROOT, KYROOT, 1, 1, 300, 1, + 0, 0, IERR) END IF GO TO 100 C C====== Parameter table 3 input C ELSE IF (IVH.EQ.IVH_PAR3) THEN CALL XDLF_PARAM_TABLE_GETVALUE (IVH_PAR3, ITM, + XDLSTR(PVAL), MAX_P3SCROLL_CHARS, IERR) IF (ITM.EQ.IP_GNOMR) THEN ITYP = INTFP (PVAL, FP, IV) IF (ITYP.EQ.0) THEN CALL XDLF_PARAM_TABLE_ERROR (IVH_PAR3, ITM, + XDLSTR('**Invalid Number Format**'), 25, IERR) GO TO 100 END IF IF (FP.LE.0.1) THEN CALL XDLF_PARAM_TABLE_ERROR (IVH_PAR3, ITM, + XDLSTR('**Value must be greater than 0.1**'), 35, IERR) GO TO 100 END IF GNOMR = FP IF (SIM.AND.GNOM) THEN CALL LRL_XDLGNM (IVH_SIM, 0, KXROOT, KYROOT, 1, 1, 300, + 1, GNOMR, 0, 0, IERR) END IF GO TO 100 END IF GO TO 100 END IF GO TO 100 END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C******************************* C** LAUEGEN_PROCESS ** C******************************* C C SUBROUTINE LAUEGEN_PROCESS C INCLUDE 'implicit_none.finc' C C Purpose: Control processing level options of LAUEGEN C C Author: John W. Campbell, October 1993 C C Arguments: C C None C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'prog_flags.finc' INCLUDE 'file_units.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR C C====== LOCALS: C LOGICAL CONT LOGICAL QUIT INTEGER NVIEW INTEGER IVHLIST(4) INTEGER IVHLST2(2) INTEGER IVH INTEGER ITEM INTEGER IQUIT INTEGER IFAIL INTEGER I INTEGER IERR INTEGER M_DISP INTEGER M_SPOTSIZE INTEGER M_REFINE INTEGER M_SOFT INTEGER M_INTEG INTEGER M_WRPARM INTEGER LISTE(2) INTEGER IRET CHARACTER*(MAXFLEN) FILNAM CHARACTER*(MAXFLEN) PAR_FILE CHARACTER*150 CMDLIN C LOGICAL CONT !Continue with writing file flag C LOGICAL QUIT !Program quit flag C INTEGER NVIEW !No. ov view objects for input C INTEGER IVHLIST(4) !View-object handles list C INTEGER IVHLST2(2) !2'nd view-object handles list C INTEGER IVH !Returned view-object handle C INTEGER ITEM !Returned menu item number C INTEGER IQUIT !Quit flag from menu C INTEGER IFAIL !File open failure flag C INTEGER I !Temp/loop variable C INTEGER IERR !Error flag C INTEGER M_DISP !Menu item no.: Display/Measure Image C INTEGER M_SPOTSIZE !Menu item no.: Find Spot Size C INTEGER M_REFINE !Menu item no.: Refine Orientation C INTEGER M_SOFT !Menu item no.: Improve Soft Limits C INTEGER M_INTEG !Menu item no.: Integrate Spots C INTEGER M_WRPARM !Menu item no.: Write Parameters File C INTEGER LISTE(2) !Dummy array for SET_PAR1_VALS call C INTEGER IRET !Return flag from CHECK_INTEGRATED C CHARACTER*(MAXFLEN) FILNAM !Temp. file name string C CHARACTER*(MAXFLEN) PAR_FILE !Parameter (.gen) file name C CHARACTER*150 CMDLIN !Command line C C------------------------------------------------------------------------------- C PROCESS = .TRUE. M_DISP = 1 M_SPOTSIZE = 2 M_REFINE = 3 M_SOFT = 4 M_INTEG = 5 M_WRPARM = 6 CALL LPROMPT (IVH_CMD,'process > ') C C====== Log entry to process and LDM parameters and clear LDM changes flags C IF (IUN_LOG.GT.0) THEN WRITE (IUN_LOG,1000) WRITE (IUN_LOG,1010) CALL LDM_WRITE (IUN_LOG, 3) WRITE (IUN_LOG,1020) END IF CALL LDM_CH_RESET (0) C C====== Set up 'Select Functions' Menu C 100 CALL SET_MENU7 C C====== Get input from Select Functions menu or Parameter table 1 C NVIEW = 4 IVHLIST(1) = IVH_MENU IVHLIST(2) = IVH_PAR1 IVHLIST(3) = IVH_PAR2 IVHLIST(4) = IVH_CMD CALL XDLF_GET_EVENTS (NVIEW, IVHLIST, IVH) IF (IVH.EQ.IVH_MENU) THEN C C====== Menu item selected C CALL XDLF_MENU_AREA_GETITEM (IVH_MENU, ITEM, IQUIT) C C======= Quit selected C IF (IQUIT.EQ.1) THEN CALL XDLF_IO_WINDOW_PRINT (IVH_CMD, XDLSTR(' '), 1, 2, + IERR) CALL CHECK_INTEGRATED (1, 0, IRET) IF (IRET.EQ.2) THEN CALL LPROMPT (IVH_CMD, 'process > ') GO TO 100 END IF PROCESS = .FALSE. RETURN END IF C C====== Display/Measure Image C IF (ITEM.EQ.M_DISP) THEN CALL DISPLAY_OPT GO TO 100 C C====== Determine spot size C ELSE IF (ITEM.EQ.M_SPOTSIZE) THEN CALL LOG_CHANGES (1) CALL LDM_CH_RESET (1) CALL LOG_HEAD ('Determine Spot Size (menu request)',3) CALL SEL_SPOTSIZE GO TO 100 C C====== Refine Orientation C ELSE IF (ITEM.EQ.M_REFINE) THEN CALL LOG_CHANGES (1) CALL LDM_CH_RESET (1) CALL LOG_HEAD ('Refine Orientation',3) CALL SEL_REFINE GO TO 100 C C====== Improve Soft Limits C ELSE IF (ITEM.EQ.M_SOFT) THEN CALL LOG_CHANGES (1) CALL LDM_CH_RESET (1) CALL LOG_HEAD ('Improve Soft Limits (menu request)',3) CALL SET_PROMIN CALL SEL_SOFT GO TO 100 C C====== Integrate Spots C ELSE IF (ITEM.EQ.M_INTEG) THEN CALL LOG_CHANGES (1) CALL LDM_CH_RESET (1) CALL LOG_HEAD ('Integrate Spots (menu request)',3) CALL SET_PROMIN CALL SET_SCALINT CALL SEL_INTEGRATE GO TO 100 C C====== Write Parameters File C ELSE IF (ITEM.EQ.M_WRPARM) THEN 110 CALL LPROMPT + (IVH_IOW, 'File name (default ext=.ldm): ') IVHLST2(1) = IVH_IOW CALL XDLF_GET_EVENTS (1, IVHLST2, IVH) CALL XDLF_IO_WINDOW_GETSTRING (IVH_IOW, XDLSTR(FILNAM), + MAXFLEN, IERR) IF (FILNAM.EQ.' ') GO TO 100 CALL FILEXT (FILNAM, 'ldm', PAR_FILE, I) CALL LGFILE_EXISTS (PAR_FILE, CONT) IF (.NOT.CONT) GO TO 110 IFAIL = 1 CALL CCPDPN (-IUN_GEN, PAR_FILE,'UNKNOWN','F',0,IFAIL) IF (IFAIL.LT.0) THEN CALL LMESSAGE(IVH_IOW,'**Error in opening the file**') GO TO 110 END IF CALL WRITE_PARFIL (PAR_FILE) CLOSE (UNIT=IUN_GEN) GO TO 100 END IF GO TO 100 C C====== Parameter table 1 input C ELSE IF (IVH.EQ.IVH_PAR1) THEN CALL PAR1_INPUT GO TO 100 C C====== Parameter table 2 input C ELSE IF (IVH.EQ.IVH_PAR2) THEN CALL PAR2_INPUT GO TO 100 C C====== Command window input C ELSE IF (IVH.EQ.IVH_CMD) THEN CALL XDLF_IO_WINDOW_GETSTRING (IVH_CMD, XDLSTR(CMDLIN), + 150, IERR) CALL CMD_INPUT (CMDLIN, QUIT) IF (.NOT.PROCESS) THEN CALL CHECK_INTEGRATED (1, 1, IRET) IF (IRET.EQ.2) THEN PROCESS = .TRUE. ELSE RETURN END IF END IF CALL LPROMPT (IVH_CMD, 'process > ') GO TO 100 END IF GO TO 100 C C====== Format statements C 1000 FORMAT (/,'Process Mode Entered',/, + '====================',/) 1010 FORMAT ('Current LDM parameter values:-',/) 1020 FORMAT (' ') END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************* C** LAUEGEN_RIMG ** C************************* C C SUBROUTINE LAUEGEN_RIMG (IPK, IPL, ITYPE, NF_OFF, IMG, MAXIMG, + KERR, KERRSTR) C INCLUDE 'implicit_none.finc' C C Purpose: Open/Read image routine to be passed to auto_refinement routine C LFN_AUTO_REFN or auto soft limit routine LFN_AUTO_SOFT; also C Used in automatic detemination of spotsize and automatic C integration routines. C C Author: John W. Campbell, October 1994 C C Arguments: C INTEGER IPK INTEGER IPL INTEGER ITYPE INTEGER NF_OFF INTEGER IMG(*) INTEGER MAXIMG INTEGER KERR CHARACTER*(*) KERRSTR C C C IPK i (R) Pack number C IPL i (R) Plate number C ITYPE i (M) Image data type as stored C NF_OFF i (M) Fast offset between (slow) rasters of image C IMG(*) i (W) Image array C MAXIMG i (R) Maximum size of image array C KERR i (W) Error return flag: Routine must C set this to 0 if image read was C successful or to a non-zero C value if there was an error. C KERRSTR c (W) Error message string set by the C routine if an error was C encountered when opening/reading image. C C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'film_pack.finc' INCLUDE 'prog_flags.finc' INCLUDE 'file_units.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR INTEGER LENSTR C C====== LOCALS: C INTEGER IFTYPE INTEGER KFLAG INTEGER IERR REAL X_CEN_F REAL Y_CEN_F REAL W_F CHARACTER*(MAXFLEN) FILNAM CHARACTER*2 VALSTR CHARACTER*80 STR C INTEGER IFTYPE !Image file type flag C INTEGER KFLAG !Parameter status flag C INTEGER IERR !Error flag C REAL X_CEN_F !X centre C REAL Y_CEN_F !Y centre C REAL W_F !Omega C CHARACTER*(MAXFLEN) FILNAM !File name C CHARACTER*2 VALSTR !Parameter value string (dummy) C CHARACTER*80 STR !Temp string C C------------------------------------------------------------------------------- C KERR = 0 KERRSTR = ' ' C C====== Set current pack and plate C IPACK = IPK IPLATE = IPL C C====== Open image file C IF (IPACK.EQ.IPACK_OPN.AND.IPLATE.EQ.IPLATE_OPN + .AND.FILM_OPEN) GO TO 100 CALL LDM_GET_IMDAT (VALSTR, IFTYPE, KFLAG) IF (IFTYPE.LT.1.OR.IFTYPE.GT.4) THEN KERR = 1 KERRSTR = 'Cannot handle requested image data type' RETURN END IF IF (FILM_OPEN) THEN IF (IFTYPE.EQ.1) THEN CALL XDLF_CLOSE_FILM_FILE (IFD, IERR) ELSE IF (IFTYPE.EQ.2.OR.IFTYPE.EQ.3.OR.IFTYPE.EQ.4) THEN CALL XDLF_CLOSE_I2 (IFD, IERR) END IF FILM_OPEN = .FALSE. FILM_READ = .FALSE. IPACK_OPN = 0 IPLATE_OPN = 0 END IF CALL LDM_FILENAME (IPACK, IPLATE, FILNAM) IF (FILNAM.EQ.' ') THEN KERR = 1 KERRSTR = 'Blank file name' RETURN END IF STR = FILNAM CALL CCPUPC (STR) IF (STR.EQ.'MISSING') THEN KERR = 1 KERRSTR = 'Image file declared as missing' RETURN END IF IF (IFTYPE.EQ.1) THEN CALL XDLF_OPEN_FILM_FILE (XDLSTR(FILNAM),LENSTR(FILNAM), + IFD, IERR) ELSE IF (IFTYPE.EQ.2.OR.IFTYPE.EQ.3.OR.IFTYPE.EQ.4) THEN CALL XDLF_OPEN_I2(XDLSTR(FILNAM),LENSTR(FILNAM), + IFD, IERR) END IF IF (IERR.NE.0) THEN STR = 'Cannot open file:' CALL STR_ADDS(STR,FILNAM,1) KERR = 1 KERRSTR = STR RETURN END IF FILM_OPEN = .TRUE. IPACK_OPN = IPACK IPLATE_OPN = IPLATE C C====== Read image C 100 IF (.NOT.FILM_READ) CALL READ_IMAGE (1, IMG, MAXIMG, ITYPE, + NF_OFF, KERR, KERRSTR) CALL FILM_CENTRE (X_CEN_F, Y_CEN_F, W_F) RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C******************************* C** LG_CLEARINT_PROMPT ** C******************************* C C SUBROUTINE LG_CLEARINT_PROMPT (LINE, IERR) C INCLUDE 'implicit_none.finc' C C Purpose: Prompt for clear intensities intensities lists command C initiated by lg_clearint commandvia the command line input C C Author: John W. Campbell, January 1996 C C Arguments: C CHARACTER*(*) LINE INTEGER IERR C LINE (M) On input, the remainder of the input line following the command C On output, unchanged unless line starts with '>' in which C case a new line is constructed and returned. C IERR (W) Error flag = 0 OK C = 1 Error C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'prog_flags.finc' INCLUDE 'integ_pars.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR INTEGER NXTTOK C C====== LOCALS: C LOGICAL EOF INTEGER II INTEGER IL INTEGER M1 INTEGER M2 CHARACTER*80 PRMPSTR CHARACTER*120 REPSTR C LOGICAL EOF !End of file flag C INTEGER II !Return flag from next token routine C INTEGER IL !Last character processed of string C INTEGER M1 !Index of first character of token in string C INTEGER M2 !Index of final character of token in string C CHARACTER*80 PRMPSTR !Prompt string C CHARACTER*120 REPSTR !Reply string C C------------------------------------------------------------------------------- CC C====== Check request C IL = 0 II = NXTTOK (LINE, ' ,', IL, M1, M2) IF (II.EQ.0) RETURN IF (LINE(M1:M1).NE.'>') RETURN IF (LG_MODE.EQ.3) THEN CALL CMD_MSG (IVH_CMD, + '**Error** Prompt request invalid in batch/background mode') IERR = 1 RETURN END IF LINE = ' ' PRMPSTR = 'Scope (plate, pack, all) [pack]: ' IF (LG_MODE.EQ.1) THEN CALL LPROMPT (IVH_CMD, PRMPSTR) CALL LREAD (IVH_CMD, REPSTR) ELSE CALL TPROMP (PRMPSTR) CALL TREAD (REPSTR, EOF) IF (EOF) THEN IERR = 1 RETURN END IF END IF CALL STR_ADDS (LINE, REPSTR, 1) RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C******************************** C** LG_INTEGRATE_PROMPT ** C******************************** C C SUBROUTINE LG_INTEGRATE_PROMPT (LINE, IERR) C INCLUDE 'implicit_none.finc' C C Purpose: Prompt for auto-integrate parameters when auto-integration is C initiated via the command line input C C Author: John W. Campbell, January 1996 C C Arguments: C CHARACTER*(*) LINE INTEGER IERR C LINE (M) On input, the remainder of the input line following the command C On output, unchanged unless line starts with '>' in which C case a new line is constructed and returned. C IERR (W) Error flag = 0 OK C = 1 Error C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'prog_flags.finc' INCLUDE 'integ_pars.finc' INCLUDE 'film_pack.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR INTEGER NXTTOK C C====== LOCALS: C LOGICAL EOF LOGICAL PRALL LOGICAL PRALL_SAV LOGICAL PR_ROT LOGICAL PR_ROT_SAV INTEGER II INTEGER IL INTEGER M1 INTEGER M2 INTEGER IFLAG INTEGER ITYP INTEGER ND INTEGER KERR INTEGER IVAL INTEGER ISAV REAL FVAL REAL FP REAL RSAV CHARACTER*60 PRMPSTR CHARACTER*80 REPSTR CHARACTER*20 STR CHARACTER*2 DUMSTR C LOGICAL EOF !End of file flag C LOGICAL PRALL !Profiles for all plates flag C LOGICAL PRALL_SAV !Saves value of PRALL C LOGICAL PR_ROT !Profile rotate flag C LOGICAL PR_ROT_SAV !Saves value of PR_ROT C INTEGER II !Return flag from next token routine C INTEGER IL !Last character processed of string C INTEGER M1 !Index of first character of token in string C INTEGER M2 !Index of final character of token in string C INTEGER IFLAG !Parameter status flag C INTEGER ITYP !Parameter type flag C INTEGER ND !No. of decimal places flag C INTEGER KERR !Error flag C INTEGER IVAL !Integer parameter value C INTEGER ISAV !Save integer parameter value C REAL FVAL !Real parameter value C REAL FP !Real parameter value C REAL RSAV !Save real parameter value C CHARACTER*60 PRMPSTR !Prompt string C CHARACTER*80 REPSTR !Reply string C CHARACTER*20 STR !Parameter value string C CHARACTER*2 DUMSTR !Dummy string C C------------------------------------------------------------------------------- C C====== Get current values for NPROF, PROMIN, IPRF_ALL, NOVLD C IERR = 0 CALL LDM_GET ('NPROF', IPACK, IPLATE, STR, + FP, ND, NPROF, IFLAG, ITYP, KERR, DUMSTR) PRF_ROT = .FALSE. CALL LDM_GET ('PROF_ROTATE', IPACK, IPLATE, STR, + FP, ND, IVAL, IFLAG, ITYP, KERR, DUMSTR) IF (STR.EQ.'yes') PRF_ROT = .TRUE. CALL LDM_GET ('PROMIN', IPACK, IPLATE, STR, + PROMIN, ND, IVAL, IFLAG, ITYP, KERR, DUMSTR) IPRF_ALL = 0 CALL LDM_GET ('PROF_ALL', IPACK, IPLATE, STR, + FP, ND, IVAL, IFLAG, ITYP, KERR, DUMSTR) IF (STR.EQ.'yes') IPRF_ALL = 1 CALL LDM_GET ('OVLIM', IPACK, IPLATE, STR, + FP, ND, NOVLD, IFLAG, ITYP, KERR, DUMSTR) C C====== Check request C IL = 0 II = NXTTOK (LINE, ' ,', IL, M1, M2) IF (II.EQ.0) RETURN IF (LINE(M1:M1).NE.'>') RETURN IF (LG_MODE.EQ.3) THEN CALL CMD_MSG (IVH_CMD, + '**Error** Prompt request invalid in batch/background mode') IERR = 1 RETURN END IF C C====== Prompt for parameters C LINE = ' ' PRMPSTR = 'Scope (plate, pack, all) [pack]: ' IF (LG_MODE.EQ.1) THEN CALL LPROMPT (IVH_CMD, PRMPSTR) CALL LREAD (IVH_CMD, REPSTR) ELSE CALL TPROMP (PRMPSTR) CALL TREAD (REPSTR, EOF) IF (EOF) THEN IERR = 1 RETURN END IF END IF CALL STR_ADDS (LINE, REPSTR, 1) PRMPSTR = 'Number intensity profile bins {nprof}' IVAL = NPROF ISAV = NPROF IF (LG_MODE.EQ.1) THEN CALL IOW_ASKI (IVH_CMD, PRMPSTR, IVAL) ELSE CALL TASKI (PRMPSTR, IVAL, EOF) IF (EOF) THEN IERR = 1 RETURN END IF END IF IF (IVAL.NE.ISAV) THEN CALL STR_ADDS (LINE, 'nprof=', 1) CALL STR_ADDI (LINE, IVAL, 0) END IF PR_ROT = PRF_ROT PR_ROT_SAV = PR_ROT PRMPSTR = 'Rotate profiles if elliptical spots {prof_rotate}' IF (LG_MODE.EQ.1) THEN CALL IOW_ASKQ (IVH_CMD, PRMPSTR, PR_ROT) ELSE CALL TASKQ(PRMPSTR, PR_ROT, EOF) IF (EOF) THEN IERR = 1 RETURN END IF END IF IF (PR_ROT.NEQV.PR_ROT_SAV) THEN CALL STR_ADDS (LINE, 'prof_rotate=', 1) IF (PR_ROT) THEN CALL STR_ADDS (LINE, 'yes', 0) ELSE CALL STR_ADDS (LINE, 'no', 0) END IF END IF PRMPSTR = 'Minimum intensity for profiles {promin}' FVAL = PROMIN RSAV = PROMIN IF (LG_MODE.EQ.1) THEN CALL IOW_ASKF (IVH_CMD, PRMPSTR, FVAL, 1) ELSE CALL TASKF (PRMPSTR, FVAL, 1, EOF) IF (EOF) THEN IERR = 1 RETURN END IF END IF IF (FVAL.NE.RSAV) THEN CALL STR_ADDS (LINE, 'promin=', 1) CALL STR_ADDF (LINE, FVAL, 2, 0) END IF PRALL = .FALSE. IF (IPRF_ALL.EQ.1) PRALL = .TRUE. PRALL_SAV = PRALL PRMPSTR = 'Profiles for all plates in pack {prof_all}' IF (LG_MODE.EQ.1) THEN CALL IOW_ASKQ (IVH_CMD, PRMPSTR, PRALL) ELSE CALL TASKQ(PRMPSTR, PRALL, EOF) IF (EOF) THEN IERR = 1 RETURN END IF END IF IF (PRALL.NEQV.PRALL_SAV) THEN CALL STR_ADDS (LINE, 'prof_all=', 1) IF (PRALL) THEN CALL STR_ADDS (LINE, 'yes', 0) ELSE CALL STR_ADDS (LINE, 'no', 0) END IF END IF PRMPSTR = 'Number of overload pixels allowed in a spot {ovlim}' IVAL = NOVLD ISAV = NOVLD IF (LG_MODE.EQ.1) THEN CALL IOW_ASKI (IVH_CMD, PRMPSTR, IVAL) ELSE CALL TASKI (PRMPSTR, IVAL, EOF) IF (EOF) THEN IERR = 1 RETURN END IF END IF IF (IVAL.NE.ISAV) THEN CALL STR_ADDS (LINE, 'ovlim=', 1) CALL STR_ADDI (LINE, IVAL, 0) END IF RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C***************************** C** LG_REFINE_PROMPT ** C***************************** C C SUBROUTINE LG_REFINE_PROMPT (LINE, IERR) C INCLUDE 'implicit_none.finc' C C Purpose: Prompt for auto-refine parameters when auto-refinement initiated C via the command line input C C Author: John W. Campbell, November 1994 C C Arguments: C CHARACTER*(*) LINE INTEGER IERR C LINE (M) On input, the remainder of the input line following the command C On output, unchanged unless line starts with '>' in which C case a new line is constructed and returned. C IERR (W) Error flag = 0 OK C = 1 Error C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'prog_flags.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR INTEGER NXTTOK C C====== LOCALS: C LOGICAL EOF INTEGER II INTEGER IL INTEGER M1 INTEGER M2 INTEGER NNOD CHARACTER*60 PRMPSTR CHARACTER*80 REPSTR C LOGICAL EOF !End of file flag C INTEGER II !Return flag from next token routine C INTEGER IL !Last character processed of string C INTEGER M1 !Index of first character of token in string C INTEGER M2 !Index of final character of token in string C INTEGER NNOD !Final number of nodals or final nodal index C CHARACTER*60 PRMPSTR !Prompt string C CHARACTER*80 REPSTR !Reply string C C------------------------------------------------------------------------------- C IERR = 0 IL = 0 II = NXTTOK (LINE, ' ,', IL, M1, M2) IF (II.EQ.0) RETURN IF (LINE(M1:M1).NE.'>') RETURN IF (LG_MODE.EQ.3) THEN CALL CMD_MSG (IVH_CMD, + '**Error** Prompt request invalid in batch/background mode') IERR = 1 RETURN END IF LINE = ' ' PRMPSTR = 'Scope (plate, pack, all) [pack]: ' IF (LG_MODE.EQ.1) THEN CALL LPROMPT (IVH_CMD, PRMPSTR) CALL LREAD (IVH_CMD, REPSTR) ELSE CALL TPROMP (PRMPSTR) CALL TREAD (REPSTR, EOF) IF (EOF) THEN IERR = 1 RETURN END IF END IF CALL STR_ADDS (LINE, REPSTR, 1) PRMPSTR = 'Refine cell (cell, nocell) [cell]: ' IF (LG_MODE.EQ.1) THEN CALL LPROMPT (IVH_CMD, PRMPSTR) CALL LREAD (IVH_CMD, REPSTR) ELSE CALL TPROMP (PRMPSTR) CALL TREAD (REPSTR, EOF) IF (EOF) THEN IERR = 1 RETURN END IF END IF CALL STR_ADDS (LINE, REPSTR, 1) PRMPSTR = 'Start number of nodals or nodal index' NNOD = 4 IF (LG_MODE.EQ.1) THEN CALL IOW_ASKI (IVH_CMD, PRMPSTR, NNOD) ELSE CALL TASKI (PRMPSTR, NNOD, EOF) IF (EOF) THEN IERR = 1 RETURN END IF END IF CALL STR_ADDI (LINE, NNOD, 1) PRMPSTR = 'Final number of nodals or nodal index' NNOD = 6 IF (LG_MODE.EQ.1) THEN CALL IOW_ASKI (IVH_CMD, PRMPSTR, NNOD) ELSE CALL TASKI (PRMPSTR, NNOD, EOF) IF (EOF) THEN IERR = 1 RETURN END IF END IF CALL STR_ADDI (LINE, NNOD, 1) RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C***************************** C** LG_SOFT_PROMPT ** C***************************** C C SUBROUTINE LG_SOFT_PROMPT (IOPT, LINE, IERR) C INCLUDE 'implicit_none.finc' C C Purpose: Prompt for soft_limits determination parameters when soft_limits C improvement initiated via the command line input C C Author: John W. Campbell, November 1994 C C Arguments: C INTEGER IOPT CHARACTER*(*) LINE INTEGER IERR C IOPT (R) =1 determining dmin, =2 determining lambda-min C LINE (M) On input, the remainder of the input line following the command C On output, unchanged unless line starts with '>' in which C case a new line is constructed and returned. C IERR (W) Error flag = 0 OK C = 1 Error C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'prog_flags.finc' INCLUDE 'integ_pars.finc' INCLUDE 'auto_soft.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR INTEGER NXTTOK C C====== LOCALS: C LOGICAL EOF LOGICAL IDUM_PRF_ROT LOGICAL PR_ROT LOGICAL PR_ROT_SAV INTEGER II INTEGER IL INTEGER M1 INTEGER M2 INTEGER ISAV INTEGER IVAL INTEGER IDUM_NPROF INTEGER IFLAG INTEGER ITYP INTEGER ND INTEGER KERR REAL FP REAL FVAL REAL RSAV REAL RDUM_PROMIN CHARACTER*60 PRMPSTR CHARACTER*20 REPSTR CHARACTER*20 STR CHARACTER*2 DUMSTR C LOGICAL EOF !End of file flag C LOGICAL IDUM_PRF_ROT !Dummy value for PRF_ROT flag C LOGICAL PR_ROT !Profile rotate flag C LOGICAL PR_ROT_SAV !Saves value of PR_ROT C INTEGER II !Return flag from next token routine C INTEGER IL !Last character processed of string C INTEGER M1 !Index of first character of token in string C INTEGER M2 !Index of final character of token in string C INTEGER ISAV !Saved integer value C INTEGER IVAL !Integer value C INTEGER IDUM_NPROF !dummy value for no. of profile bins C INTEGER IFLAG !Parameter status flag C INTEGER ITYP !Parameter type flag C INTEGER ND !No. of decimal places flag C INTEGER KERR !Error flag C REAL FP !Real parameter value C REAL FVAL !Real value C REAL RSAV !Saved real value C REAL RDUM_PROMIN !Dummy value for PROMIN C CHARACTER*60 PRMPSTR !Prompt string C CHARACTER*20 REPSTR !Reply string C CHARACTER*20 STR !Parameter value string C CHARACTER*2 DUMSTR !Dummy string C C------------------------------------------------------------------------------- C IERR = 0 C C====== Get default parameters C CALL LFN_SOFT_DF (IOPT, MAX_SOFT_BINS, IDUM_NPROF, IDUM_PRF_ROT, + RDUM_PROMIN, FRAC_AUT, SIGTEST_AUT, FRTEST_AUT, + NUMBINS_AUT, BINW_AUT) CALL LDM_GET ('NPROF', 1, 1, STR, + FP, ND, NPROF, IFLAG, ITYP, KERR, DUMSTR) PRF_ROT = .FALSE. CALL LDM_GET ('PROF_ROTATE', 1, 1, STR, + FP, ND, IVAL, IFLAG, ITYP, KERR, DUMSTR) IF (STR.EQ.'yes') PRF_ROT = .TRUE. CALL LDM_GET ('PROMIN', 1, 1, STR, + PROMIN, ND, IVAL, IFLAG, ITYP, KERR, DUMSTR) C C====== Check call C IL = 0 II = NXTTOK (LINE, ' ,', IL, M1, M2) IF (II.EQ.0) RETURN IF (LINE(M1:M1).NE.'>') RETURN IF (LG_MODE.EQ.3) THEN CALL CMD_MSG (IVH_CMD, + '**Error** Prompt request invalid in batch/background mode') IERR = 1 RETURN END IF C C====== Service prompts C LINE = ' ' PRMPSTR = 'Scope (pack, all) [pack]: ' IF (LG_MODE.EQ.1) THEN CALL LPROMPT (IVH_CMD, PRMPSTR) CALL LREAD (IVH_CMD, REPSTR) ELSE CALL TPROMP (PRMPSTR) CALL TREAD (REPSTR, EOF) IF (EOF) THEN IERR = 1 RETURN END IF END IF CALL STR_ADDS (LINE, REPSTR, 1) PRMPSTR = 'Number intensity profile bins {nprof}' IVAL = NPROF ISAV = NPROF IF (LG_MODE.EQ.1) THEN CALL IOW_ASKI (IVH_CMD, PRMPSTR, IVAL) ELSE CALL TASKI (PRMPSTR, IVAL, EOF) IF (EOF) THEN IERR = 1 RETURN END IF END IF IF (IVAL.NE.ISAV) THEN CALL STR_ADDS (LINE, 'nprof=', 1) CALL STR_ADDI (LINE, IVAL, 0) END IF PR_ROT = PRF_ROT PR_ROT_SAV = PR_ROT PRMPSTR = 'Rotate profiles if elliptical spots {prof_rotate}' IF (LG_MODE.EQ.1) THEN CALL IOW_ASKQ (IVH_CMD, PRMPSTR, PR_ROT) ELSE CALL TASKQ(PRMPSTR, PR_ROT, EOF) IF (EOF) THEN IERR = 1 RETURN END IF END IF IF (PR_ROT.NEQV.PR_ROT_SAV) THEN CALL STR_ADDS (LINE, 'prof_rotate=', 1) IF (PR_ROT) THEN CALL STR_ADDS (LINE, 'yes', 0) ELSE CALL STR_ADDS (LINE, 'no', 0) END IF END IF PRMPSTR = 'Minimum intensity for profiles {promin}' FVAL = PROMIN RSAV = PROMIN IF (LG_MODE.EQ.1) THEN CALL IOW_ASKF (IVH_CMD, PRMPSTR, FVAL, 1) ELSE CALL TASKF (PRMPSTR, FVAL, 1, EOF) IF (EOF) THEN IERR = 1 RETURN END IF END IF IF (FVAL.NE.RSAV) THEN CALL STR_ADDS (LINE, 'promin=', 1) CALL STR_ADDF (LINE, FVAL, 2, 0) END IF IF (IOPT.EQ.1) THEN PRMPSTR = 'Number of ''dmin'' bins {nbins}' ELSE PRMPSTR = 'Number of ''lmin'' bins {nbins}' END IF IVAL = NUMBINS_AUT ISAV = NUMBINS_AUT IF (LG_MODE.EQ.1) THEN CALL IOW_ASKI (IVH_CMD, PRMPSTR, IVAL) ELSE CALL TASKI (PRMPSTR, IVAL, EOF) IF (EOF) THEN IERR = 1 RETURN END IF END IF IF (IVAL.NE.ISAV) THEN CALL STR_ADDS (LINE, 'nbins=', 1) CALL STR_ADDI (LINE, IVAL, 0) END IF IF (IOPT.EQ.1) THEN PRMPSTR = 'Bin width for ''dmin'' {binw}' ELSE PRMPSTR = 'Bin width for ''lmin'' {binw}' END IF FVAL = BINW_AUT RSAV = BINW_AUT IF (LG_MODE.EQ.1) THEN CALL IOW_ASKF (IVH_CMD, PRMPSTR, FVAL, 2) ELSE CALL TASKF (PRMPSTR, FVAL, 2, EOF) IF (EOF) THEN IERR = 1 RETURN END IF END IF IF (FVAL.NE.RSAV) THEN CALL STR_ADDS (LINE, 'binw=', 1) CALL STR_ADDF (LINE, FVAL, 4, 0) END IF IF (IOPT.EQ.1) THEN PRMPSTR = 'Start fraction of current ''dmin'' {frac}' ELSE PRMPSTR = 'Start fraction of current ''lmin'' {frac}' END IF FVAL = FRAC_AUT RSAV = FRAC_AUT IF (LG_MODE.EQ.1) THEN CALL IOW_ASKF (IVH_CMD, PRMPSTR, FVAL, 2) ELSE CALL TASKF (PRMPSTR, FVAL, 2, EOF) IF (EOF) THEN IERR = 1 RETURN END IF END IF IF (FVAL.NE.RSAV) THEN CALL STR_ADDS (LINE, 'frac=', 1) CALL STR_ADDF (LINE, FVAL, 3, 0) END IF PRMPSTR = 'Sigma test for significant intensity {sigtest}' FVAL = SIGTEST_AUT RSAV = SIGTEST_AUT IF (LG_MODE.EQ.1) THEN CALL IOW_ASKF (IVH_CMD, PRMPSTR, FVAL, 1) ELSE CALL TASKF (PRMPSTR, FVAL, 1, EOF) IF (EOF) THEN IERR = 1 RETURN END IF END IF IF (FVAL.NE.RSAV) THEN CALL STR_ADDS (LINE, 'sigtest=', 1) CALL STR_ADDF (LINE, FVAL, 2, 0) END IF PRMPSTR = 'Fraction test for soft limit significance {frtest}' FVAL = FRTEST_AUT RSAV = FRTEST_AUT IF (LG_MODE.EQ.1) THEN CALL IOW_ASKF (IVH_CMD, PRMPSTR, FVAL, 2) ELSE CALL TASKF (PRMPSTR, FVAL, 2, EOF) IF (EOF) THEN IERR = 1 RETURN END IF END IF IF (FVAL.NE.RSAV) THEN CALL STR_ADDS (LINE, 'frtest=', 1) CALL STR_ADDF (LINE, FVAL, 2, 0) END IF RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C******************************* C** LG_SPOTSIZE_PROMPT ** C******************************* C C SUBROUTINE LG_SPOTSIZE_PROMPT (LINE, IERR) C INCLUDE 'implicit_none.finc' C C Purpose: Prompt for spot size determination parameters when spot size C determination initiated via the command line input C C Author: John W. Campbell, September 1995 C C Arguments: C CHARACTER*(*) LINE INTEGER IERR C LINE (M) On input, the remainder of the input line following the command C On output, unchanged unless line starts with '>' in which C case a new line is constructed and returned. C IERR (W) Error flag = 0 OK C = 1 Error C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'prog_flags.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR INTEGER NXTTOK C C====== LOCALS: C LOGICAL EOF INTEGER II INTEGER IL INTEGER M1 INTEGER M2 INTEGER ISAV INTEGER NBINS INTEGER IVAL REAL FVAL REAL RSAV REAL SDCUT REAL THRFAC REAL EXPAND CHARACTER*60 PRMPSTR CHARACTER*20 REPSTR CHARACTER*2 VALSTR C LOGICAL EOF !End of file flag C INTEGER II !Return flag from next token routine C INTEGER IL !Last character processed of string C INTEGER M1 !Index of first character of token in string C INTEGER M2 !Index of final character of token in string C INTEGER ISAV !Saved integer value C INTEGER NBINS !No. of angular bins for spot size analysis C INTEGER IVAL !Integer parameter value C REAL FVAL !Real parameter value C REAL RSAV !Saved real value C REAL SDCUT !Standard deviation cutoff C REAL THRFAC !Threshold factor (*background) for spots C REAL EXPAND !Expansion factor: ave obs. -> proposed C CHARACTER*60 PRMPSTR !Prompt string C CHARACTER*20 REPSTR !Reply string C CHARACTER*2 VALSTR !Dummy parameter value string C C------------------------------------------------------------------------------- C IERR = 0 CALL SPOTSIZE_DFLTS (NBINS, SDCUT, THRFAC, EXPAND) IL = 0 II = NXTTOK (LINE, ' ,', IL, M1, M2) IF (II.EQ.0) RETURN IF (LINE(M1:M1).NE.'>') RETURN IF (LG_MODE.EQ.3) THEN CALL CMD_MSG (IVH_CMD, + '**Error** Prompt request invalid in batch/background mode') IERR = 1 RETURN END IF LINE = ' ' PRMPSTR = 'Scope (pack, all) [pack]: ' IF (LG_MODE.EQ.1) THEN CALL LPROMPT (IVH_CMD, PRMPSTR) CALL LREAD (IVH_CMD, REPSTR) ELSE CALL TPROMP (PRMPSTR) CALL TREAD (REPSTR, EOF) IF (EOF) THEN IERR = 1 RETURN END IF END IF CALL STR_ADDS (LINE, REPSTR, 1) PRMPSTR = 'Threshold factor (*background) for search {thresh}' FVAL = THRFAC RSAV = THRFAC IF (LG_MODE.EQ.1) THEN CALL IOW_ASKF (IVH_CMD, PRMPSTR, FVAL, 1) ELSE CALL TASKF (PRMPSTR, FVAL, 1, EOF) IF (EOF) THEN IERR = 1 RETURN END IF END IF IF (FVAL.NE.RSAV) THEN CALL STR_ADDS (LINE, 'thresh=', 1) CALL STR_ADDF (LINE, FVAL, 2, 0) END IF PRMPSTR = 'Number angular analysis bins {nbins}' IVAL = NBINS ISAV = NBINS IF (LG_MODE.EQ.1) THEN CALL IOW_ASKI (IVH_CMD, PRMPSTR, IVAL) ELSE CALL TASKI (PRMPSTR, IVAL, EOF) IF (EOF) THEN IERR = 1 RETURN END IF END IF IF (IVAL.NE.ISAV) THEN CALL STR_ADDS (LINE, 'nbins=', 1) CALL STR_ADDI (LINE, IVAL, 0) END IF PRMPSTR = 'Standard deviation cutoff for good spots {sdcut}' FVAL = SDCUT RSAV = SDCUT IF (LG_MODE.EQ.1) THEN CALL IOW_ASKF (IVH_CMD, PRMPSTR, FVAL, 1) ELSE CALL TASKF (PRMPSTR, FVAL, 1, EOF) IF (EOF) THEN IERR = 1 RETURN END IF END IF IF (FVAL.NE.RSAV) THEN CALL STR_ADDS (LINE, 'sdcut=', 1) CALL STR_ADDF (LINE, FVAL, 2, 0) END IF PRMPSTR = 'Expansion factor - observed->proposed size {expand}' FVAL = EXPAND RSAV = EXPAND IF (LG_MODE.EQ.1) THEN CALL IOW_ASKF (IVH_CMD, PRMPSTR, FVAL, 1) ELSE CALL TASKF (PRMPSTR, FVAL, 1, EOF) IF (EOF) THEN IERR = 1 RETURN END IF END IF IF (FVAL.NE.RSAV) THEN CALL STR_ADDS (LINE, 'expand=', 1) CALL STR_ADDF (LINE, FVAL, 2, 0) END IF RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C******************************* C** LG_WRITEINT_PROMPT ** C******************************* C C SUBROUTINE LG_WRITEINT_PROMPT (LINE, IERR) C INCLUDE 'implicit_none.finc' C C Purpose: Prompt for write intensities files parameters wheninitiated C via the command line input C C Author: John W. Campbell, January 1996 C C Arguments: C CHARACTER*(*) LINE INTEGER IERR C LINE (M) On input, the remainder of the input line following the command C On output, unchanged unless line starts with '>' in which C case a new line is constructed and returned. C IERR (W) Error flag = 0 OK C = 1 Error C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'prog_flags.finc' INCLUDE 'integ_pars.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR INTEGER NXTTOK C C====== LOCALS: C LOGICAL EOF INTEGER II INTEGER IL INTEGER M1 INTEGER M2 INTEGER IVAL INTEGER IFLAG INTEGER ITYP INTEGER KERR INTEGER ND REAL FVAL REAL RSAV REAL FP CHARACTER*80 PRMPSTR CHARACTER*120 REPSTR CHARACTER*2 VALSTR CHARACTER*2 ERRSTR CHARACTER*6 INT_FTYP C LOGICAL EOF !End of file flag C INTEGER II !Return flag from next token routine C INTEGER IL !Last character processed of string C INTEGER M1 !Index of first character of token in string C INTEGER M2 !Index of final character of token in string C INTEGER IVAL !Integer parameter value C INTEGER IFLAG !Parameter status flag C INTEGER ITYP !Parameter type flag C INTEGER KERR !Error flag C INTEGER ND !No. of decimal places flag C REAL FVAL !Real parameter value C REAL RSAV !Saved real value C REAL FP !Real parameter value C CHARACTER*80 PRMPSTR !Prompt string C CHARACTER*120 REPSTR !Reply string C CHARACTER*2 VALSTR !Dummy parameter value string C CHARACTER*2 ERRSTR !Dummy error string C CHARACTER*6 INT_FTYP !File type string C C------------------------------------------------------------------------------- C C C====== Get current values for INT_FTYPE, INT_TEMPLATE & SCALE_INT C IERR = 0 CALL LDM_GET ('INT_FTYPE', 1, 1, INT_FTYP, FP, ND, IVAL, + IFLAG, ITYP, KERR, ERRSTR) INT_TYP = 1 CALL CCPUPC(INT_FTYP) IF (INT_FTYP.EQ.'GE') INT_TYP = 2 CALL LDM_GET ('INT_TEMPLATE', 1, 1, INT_TEMPLATE, + FP, ND, IVAL, IFLAG, ITYP, KERR, ERRSTR) CALL LDM_GET ('SCALE_INT', 1, 1, VALSTR, + SCAL_INT, ND, IVAL, IFLAG, ITYP, KERR, ERRSTR) C C====== Check request C IL = 0 II = NXTTOK (LINE, ' ,', IL, M1, M2) IF (II.EQ.0) RETURN IF (LINE(M1:M1).NE.'>') RETURN IF (LG_MODE.EQ.3) THEN CALL CMD_MSG (IVH_CMD, + '**Error** Prompt request invalid in batch/background mode') IERR = 1 RETURN END IF LINE = ' ' PRMPSTR = 'Scope (pack, all) [pack]: ' IF (LG_MODE.EQ.1) THEN CALL LPROMPT (IVH_CMD, PRMPSTR) CALL LREAD (IVH_CMD, REPSTR) ELSE CALL TPROMP (PRMPSTR) CALL TREAD (REPSTR, EOF) IF (EOF) THEN IERR = 1 RETURN END IF END IF CALL STR_ADDS (LINE, REPSTR, 1) PRMPSTR = 'File type (ge/mtz) {int_ftype} [' INT_FTYP = 'mtz' IF (INT_TYP.EQ.2) INT_FTYP = 'ge' CALL STR_ADDS (PRMPSTR, INT_FTYP, 0) CALL STR_ADDS (PRMPSTR, ']: ', 0) IF (LG_MODE.EQ.1) THEN CALL LPROMPT (IVH_CMD, PRMPSTR) CALL LREAD (IVH_CMD, REPSTR) ELSE CALL TPROMP (PRMPSTR) CALL TREAD (REPSTR, EOF) IF (EOF) THEN IERR = 1 RETURN END IF END IF IF (REPSTR.NE.' ') THEN CALL STR_ADDS (LINE, 'int_ftype=', 1) CALL STR_ADDS (LINE, REPSTR, 0) END IF PRMPSTR = 'File template {int_template} [' CALL STR_ADDS (PRMPSTR, INT_TEMPLATE, 0) CALL STR_ADDS (PRMPSTR, ']: ', 0) IF (LG_MODE.EQ.1) THEN CALL LPROMPT (IVH_CMD, PRMPSTR) CALL LREAD (IVH_CMD, REPSTR) ELSE CALL TPROMP (PRMPSTR) CALL TREAD (REPSTR, EOF) IF (EOF) THEN IERR = 1 RETURN END IF END IF IF (REPSTR.NE.' ') THEN CALL STR_ADDS (LINE, 'int_template=', 1) CALL STR_ADDS (LINE, REPSTR, 0) END IF PRMPSTR = 'Scale factor for output intensities {scale_int}' FVAL = SCAL_INT RSAV = SCAL_INT IF (LG_MODE.EQ.1) THEN CALL IOW_ASKF (IVH_CMD, PRMPSTR, FVAL, 1) ELSE CALL TASKF (PRMPSTR, FVAL, 1, EOF) IF (EOF) THEN IERR = 1 RETURN END IF END IF IF (FVAL.NE.RSAV) THEN CALL STR_ADDS (LINE, 'scale_int=', 1) CALL STR_ADDF (LINE, FVAL, -5, 0) END IF RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C****************************** C** LGFILE_EXISTS ** C****************************** C C SUBROUTINE LGFILE_EXISTS (FILNAM, CONT) C INCLUDE 'implicit_none.finc' C C Purpose: See if output file exists and, if it does ask whether or not C to overwrite it (Interactive commands only) C C Author: John W. Campbell, November 1994 C C Arguments: C CHARACTER*(*) FILNAM LOGICAL CONT C C FILNAM (R) Name of the file C CONT (W) =.TRUE, continue with writing, =.FALSE. do not C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR LOGICAL CCPEXS C C====== LOCALS: C LOGICAL EXISTS C LOGICAL EXISTS !File exists flag C C------------------------------------------------------------------------------- C CONT = .TRUE. EXISTS = CCPEXS (FILNAM) IF (EXISTS) THEN CALL LMESSAGE(IVH_IOW,'**File already exists**') CONT = .FALSE. CALL IOW_ASKQ (IVH_IOW, 'Overwrite file', CONT) END IF RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C******************* C** LJUST ** C******************* C C SUBROUTINE LJUST (CHSTR) C C Purpose: Left jusify text in a character string (eliminate leading blanks) C C Author: John W. Campbell, September 1990 C C Arguments: C CHARACTER*(*) CHSTR C C CHSTR (M) Character string containing the text C C Declarations C ============ C C GLOBALS: C C C LOCALS: C INTEGER NC INTEGER I C INTEGER NC !No. of characters in the string C INTEGER I !Loop counter C C------------------------------------------------------------------------------- C C====== Shift as needed C NC = LEN (CHSTR) DO 100 I = 1, NC IF (CHSTR(I:I).NE.' ') THEN CHSTR = CHSTR(I:NC) RETURN ENDIF 100 CONTINUE RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** LMESSAGE ** C************************** C SUBROUTINE LMESSAGE (IVH_W, CHSTR) C C IMPLICIT NONE C C Purpose: Output a message string to an io-window followed by a newline C C Author: John W. Campbell, September 1990 C C Arguments: C INTEGER IVH_W CHARACTER*(*) CHSTR C C IVH_W (R) View-object handle for the io-window C CHSTR (R) The message string C C Declarations C ============ C C GLOBALS: C INTEGER XDLSTR C C LOCALS: C INTEGER LENS INTEGER I INTEGER IERR INTEGER NCH C INTEGER LENS !Length of the character string C INTEGER I !Loop counter C INTEGER IERR !Error return C INTEGER NCH !No. characters up to last non-blank character C C------------------------------------------------------------------------------- C C====== Find length of message string up to last non-blank C LENS = LEN (CHSTR) NCH = 1 DO 100 I = LENS, 1, -1 IF (CHSTR(I:I).NE.' ') THEN NCH = I GO TO 200 ENDIF 100 CONTINUE C C====== Output the message C 200 CALL XDLF_IO_WINDOW_PRINT (IVH_W, XDLSTR(CHSTR), NCH, 2, IERR) RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** LOG_CHANGES ** C************************** C C SUBROUTINE LOG_CHANGES (ICHAN) C INCLUDE 'implicit_none.finc' C C Purpose: Write changed parameters to log file C C Author: John W. Campbell, April 1994 C C Arguments: C INTEGER ICHAN C C ICHAN (R) Channel no. for reporting changed parameters (1-16) C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'file_units.finc' C C====== FUNCTION TYPES: C LOGICAL LDM_ANY_CH C C====== LOCALS: C C C------------------------------------------------------------------------------- C IF (IUN_LOG.EQ.0) RETURN IF (ICHAN.LT.1.OR.ICHAN.GT.16) RETURN IF (.NOT.LDM_ANY_CH(ICHAN)) RETURN WRITE (IUN_LOG,1000) CALL LDM_WRITE (IUN_LOG, -ICHAN) WRITE (IUN_LOG,1010) RETURN C C====== Format statements C 1000 FORMAT (/,'Changed LDM parameters:-',/) 1010 FORMAT (' ') END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** LOG_HEAD ** C************************** C SUBROUTINE LOG_HEAD (CHSTR, ITYP) C INCLUDE 'implicit_none.finc' C C Purpose: Output heading to log file C C Author: John W. Campbell, October 1993 C C Arguments: C CHARACTER*(*) CHSTR INTEGER ITYP C C CHSTR (R) The message string C ITYP (R) Heading type flag =1, standard (preceeded by 1 blank line) C =2, as for 1 but underlined with '---' C =3, as for 1 but underlined with '===' C C Declarations C ============ C C GLOBALS: C INCLUDE 'file_units.finc' C C LOCALS: C INTEGER LENS INTEGER I INTEGER NCH C INTEGER LENS !Length of the character string C INTEGER I !Loop counter C INTEGER NCH !No. characters up to last non-blank character C C------------------------------------------------------------------------------- C IF (IUN_LOG.EQ.0) RETURN C C====== Find length of message string up to last non-blank C LENS = LEN (CHSTR) NCH = 1 DO 100 I = LENS, 1, -1 IF (CHSTR(I:I).NE.' ') THEN NCH = I GO TO 200 ENDIF 100 CONTINUE C C====== Output the heading C 200 IF (ITYP.LE.3) THEN WRITE(IUN_LOG,1000) WRITE (IUN_LOG,1001) CHSTR(1:NCH) END IF IF (ITYP.EQ.2) THEN WRITE(IUN_LOG,1002) ('-',I=1,NCH) ELSE IF (ITYP.EQ.3) THEN WRITE(IUN_LOG,1002) ('=',I=1,NCH) END IF RETURN C C====== Format statements C 1000 FORMAT (' ') 1001 FORMAT (A) 1002 FORMAT (120A1) END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** LOG_INT_TAB1 ** C************************** C C SUBROUTINE LOG_INT_TAB1 C INCLUDE 'implicit_none.finc' C C Purpose: Output intensity statistics table 1 to log file C C Author: John W. Campbell, January 1996 C C Arguments: C C None C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'film_pack.finc' INCLUDE 'lirl_pars.finc' INCLUDE 'file_units.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR C C====== LOCALS: C INTEGER NS(5) INTEGER NG(5) INTEGER NO(5) INTEGER NN(5) INTEGER NB(5) INTEGER N3(5) INTEGER N10(5) INTEGER IERR REAL AIM(5) REAL AIS(5) C INTEGER NS(5) !No. of spots present for the 5 spot categories C INTEGER NG(5) !No. of spots integrated & good for the 5 spot categories C INTEGER NO(5) !No. of overload spots flagged for the 5 spot categories C INTEGER NN(5) !No. of OK negative intensities for the 5 spot categories C INTEGER NB(5) !No. of bad spots spots flagged for the 5 spot categories C INTEGER N3(5) !No. OK spots with I>3*sig(I) for the 5 spot categories C INTEGER N10(5) !No. OK spots wit I>10*sig(I) for the 5 spot categories C INTEGER IERR !Error flag C REAL AIM(5) !Mean I value for the 5 spot categories (for OK positive C intensities only) C REAL AIS(5) !Mean I/sig(I) values for the 5 spot categories (for C OK positive intensities only) C C------------------------------------------------------------------------------- C CALL LFN_INT_STATS1 (KDX_LIRL, IPACK, IPLATE, NS, NG, NO, NN, + NB, AIM, AIS, N3, N10, IERR) IF (IERR.EQ.0.AND.IUN_LOG.GT.0) THEN CALL LFN_INT_TAB1 (IUN_LOG, 0, KEY_LOG, NS, NG, NO, NN, NB, + AIM, AIS, N3, N10) KEY_LOG = 0 END IF RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** LOG_MSG ** C************************** C SUBROUTINE LOG_MSG (IVH_W, CHSTR, NL) C INCLUDE 'implicit_none.finc' C C Purpose: Output a message string to an io-window or the terminal if C required by the program mode and to the log file C C Author: John W. Campbell, October 1993 C C Arguments: C INTEGER IVH_W CHARACTER*(*) CHSTR INTEGER NL C C IVH_W (R) View-object handle for the io-window C CHSTR (R) The message string C NL (R) No. of blank lines before message when written to log file C C Declarations C ============ C C GLOBALS: C INCLUDE 'prog_flags.finc' INCLUDE 'file_units.finc' C C FUNCTION TYPES: C INTEGER XDLSTR C C LOCALS: C INTEGER LENS INTEGER I INTEGER IERR INTEGER NCH C INTEGER LENS !Length of the character string C INTEGER I !Loop counter C INTEGER IERR !Error return C INTEGER NCH !No. characters up to last non-blank character C C------------------------------------------------------------------------------- C C====== Find length of message string up to last non-blank C LENS = LEN (CHSTR) NCH = 1 DO 100 I = LENS, 1, -1 IF (CHSTR(I:I).NE.' ') THEN NCH = I GO TO 200 ENDIF 100 CONTINUE C C====== Output the message to io/window or terminal if appropriate C 200 IF (LG_MODE.EQ.1) THEN CALL XDLF_IO_WINDOW_PRINT (IVH_W, XDLSTR(CHSTR), NCH, 2, IERR) ELSE IF (LG_MODE.EQ.2) THEN CALL TWRITE (CHSTR) END IF C C====== Now output to log file C IF (IUN_LOG.LE.0) RETURN IF (NL.GT.0) THEN DO 210 I = 1, NL WRITE(IUN_LOG,1000) 210 CONTINUE END IF WRITE (IUN_LOG,1001) CHSTR(1:NCH) RETURN C C====== Format statements C 1000 FORMAT (' ') 1001 FORMAT (A) END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** LPROMPT ** C************************** C SUBROUTINE LPROMPT (IVH_W, CHSTR) C INCLUDE 'implicit_none.finc' C C Purpose: Output a prompt string to an io-window C C Author: John W. Campbell, September 1990 C C Arguments: C INTEGER IVH_W CHARACTER*(*) CHSTR C C IVH_W (R) View-object handle for the io-window C CHSTR (R) The prompt string C C Declarations C ============ C C GLOBALS: C INTEGER XDLSTR C C LOCALS: C INTEGER LENS INTEGER I INTEGER IERR INTEGER NCH C INTEGER LENS !Length of the character string C INTEGER I !Loop counter C INTEGER IERR !Error return C INTEGER NCH !No. characters up to last non-blank character C C------------------------------------------------------------------------------- C C====== Get the length of the string to the last non-blank C LENS = LEN (CHSTR) NCH = 1 DO 100 I = LENS, 1, -1 IF (CHSTR(I:I).NE.' ') THEN NCH = I GO TO 200 ENDIF 100 CONTINUE 200 IF (CHSTR(LENS:LENS).EQ.' '.AND.NCH.LT.LENS) NCH = NCH + 1 C C====== Output the prompt C CALL XDLF_IO_WINDOW_PRINT (IVH_W, XDLSTR(CHSTR), NCH, 0, IERR) RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************ C** LREAD ** C************************ C SUBROUTINE LREAD (IVH_W, CHSTR) C INCLUDE 'implicit_none.finc' C C Purpose: Read reply string from an io-window C C Author: John W. Campbell, November 1994 C C Arguments: C INTEGER IVH_W CHARACTER*(*) CHSTR C C IVH_W (R) View-object handle for the io-window C CHSTR (W) The reply string C C Declarations C ============ C C GLOBALS: C INTEGER XDLSTR C C LOCALS: C INTEGER LENS INTEGER IVH INTEGER IERR INTEGER IVHLIST(2) C INTEGER LENS !Length of the character string C INTEGER IVH !Returned view-object handle C INTEGER IERR !Error return C INTEGER IVHLIST(2) !List of view-object handles C C------------------------------------------------------------------------------- C C====== Get the length of the character sting C LENS = LEN (CHSTR) IVHLIST(1) = IVH_W CALL XDLF_GET_EVENTS (1, IVHLIST, IVH) CALL XDLF_IO_WINDOW_GETSTRING (IVH_W, XDLSTR(CHSTR), LENS, IERR) RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** MATCH_SPOTS ** C************************** C C SUBROUTINE MATCH_SPOTS (IERR) C INCLUDE 'implicit_none.finc' C C Purpose: Display image and match pairs of predicted and observed spots. C C Author: John W. Campbell, July 1991 C C Arguments: C INTEGER IERR C C IERR (W) Error flag =0 OK, =1 cannot open image file or display image C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' INCLUDE 'screen_params.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'ip1_entries.finc' INCLUDE 'prog_flags.finc' INCLUDE 'file_units.finc' INCLUDE 'film_pack.finc' INCLUDE 'image.finc' INCLUDE 'matches.finc' INCLUDE 'spot_box.finc' INCLUDE 'spot_data.finc' INCLUDE 'symbol_types.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR INTEGER LENSTR INTEGER INTFP INTEGER NXTTOK LOGICAL CCPEXS C C====== LOCALS: C LOGICAL EXISTS LOGICAL CONT LOGICAL REPLY LOGICAL CLEAR LOGICAL SPAT LOGICAL NODFLG CHARACTER*2 VALSTR CHARACTER*2 ERRSTR CHARACTER*80 STR CHARACTER*(MAX_P3SCROLL_CHARS) PVAL CHARACTER*(MAXFLEN) FILNAM CHARACTER*(MAXFLEN) MATCH_FILE INTEGER I INTEGER J INTEGER KERR INTEGER IVHLIST(3) INTEGER IVHLST2(2) INTEGER NVIEW INTEGER I_ADD INTEGER I_DEL INTEGER IADDEL INTEGER IPRMEAS INTEGER IDISP INTEGER ITEM INTEGER IVH INTEGER M_ALL INTEGER M_NODALS INTEGER M_CLEAR INTEGER M_INPUT INTEGER M_DELETE INTEGER M_READ INTEGER M_WRITE INTEGER IQUIT INTEGER IDSQLIM INTEGER IDSQMIN INTEGER IXP INTEGER IYP INTEGER ISPIX INTEGER IFPIX INTEGER ID INTEGER ISPOT INTEGER IXSIZ INTEGER IYSIZ INTEGER ITHRESH INTEGER IBG INTEGER NOVER INTEGER ITM INTEGER IP_SBOX INTEGER IP_THRESH INTEGER IV INTEGER ITYP INTEGER IXROOT INTEGER IYROOT INTEGER IRETN INTEGER IFAIL INTEGER IH INTEGER IK INTEGER IL INTEGER M1 INTEGER M2 INTEGER NADD INTEGER NERR INTEGER NVALS INTEGER NXRAST INTEGER NYRAST INTEGER IFLAG INTEGER ND INTEGER JH INTEGER JK INTEGER JL INTEGER MULT INTEGER NUMSPOTS INTEGER IORD INTEGER ISWAP INTEGER LISTE(2) REAL MM_RAST_X REAL MM_RAST_Y REAL VALUES(20) REAL FP REAL CGX REAL CGY REAL OMEGA REAL X_CEN REAL Y_CEN REAL X_CEN_F REAL Y_CEN_F REAL XSPOT_MM REAL YSPOT_MM REAL X_C REAL Y_C REAL XFD REAL YFD REAL ALAM REAL DTHR2 C LOGICAL EXISTS !File exists flag C LOGICAL CONT !Continue to write file flag C LOGICAL REPLY !Yes/no reply flag (.TRUE./.FALSE.) C LOGICAL CLEAR !Clear matches list flag C LOGICAL SPAT !Spatial overlap flag C LOGICAL NODFLG !Nodal spot flag C CHARACTER*2 VALSTR !Parameter value string (dummy) C CHARACTER*2 ERRSTR !Error string (dummy) C CHARACTER*80 STR !Character string for messages C CHARACTER*(MAX_P3SCROLL_CHARS) PVAL !Return string from parameter table 3 C CHARACTER*(MAXFLEN) FILNAM !File name as input C CHARACTER*(MAXFLEN) MATCH_FILE !Spot matches file name C INTEGER I !Temp/loop variable C INTEGER J !Temp/loop variable C INTEGER KERR !Error return flag C INTEGER IVHLIST(3) !List of view-object handles for getting events C INTEGER IVHLST2(2) !Second list of view-objects for getting events C INTEGER NVIEW !Number of view-objects for getting events C INTEGER I_ADD !Add option value flag for IADDEL C INTEGER I_DEL !Delete option value flag for IADDEL C INTEGER IADDEL !Add/Delete matched spots flag (I_ADD or I_DEL) C INTEGER IPRMEAS !Input predicted (1) or measured spot (2) position C INTEGER IDISP !Display predicted spots flag =0 all, =1 nodals C INTEGER ITEM !Menu item number selected C INTEGER IVH !View-object handle of view object returning event C INTEGER M_ALL !Menu item no.: Display all predicted reflections C INTEGER M_NODALS !Menu item no.: Display nodals only C INTEGER M_CLEAR !Menu item no.: Clear matches list C INTEGER M_INPUT !Menu item no.: Input (add) matches C INTEGER M_DELETE !Menu item no.: Delete matches C INTEGER M_READ !Menu item no.: Read matches file C INTEGER M_WRITE !Menu item no.: Write matches file C INTEGER IQUIT !Quit return flag from menu input C INTEGER IDSQLIM !Distance squared tolerance for pixel selection C INTEGER IDSQMIN !Min distance squared founf in pixel selection C INTEGER IXP !Returned x pixel value from film-image display C INTEGER IYP !Returned y pixel value from film-image display C INTEGER ISPIX !Pixel position along slow axis C INTEGER IFPIX !Pixel position along fast axis C INTEGER ID !Distance squared from pixel C INTEGER ISPOT !Index in list of nearest spot/symbol found C INTEGER IXSIZ !Half box size (x) for spot find C INTEGER IYSIZ !Half box size (y) for spot find C INTEGER ITHRESH !Threshold for spot find C INTEGER IBG !Background at spot position C INTEGER NOVER !No. of pixels over threshold value in found spot C INTEGER ITM !Parameter table 2 input item number C INTEGER IP_SBOX !Parameter table 2 item: Match spot box size C INTEGER IP_THRESH !Parameter table 2 item: Match spot threshold C INTEGER IV !Integer value from INTFP routine C INTEGER ITYP !Type of value from INTFP routine C INTEGER IXROOT !X root position for popup notice C INTEGER IYROOT !Y root position for popup notice C INTEGER IRETN !Return flag fro yesno_notice etc. C INTEGER IFAIL !Error flag for CCPDPN routine C INTEGER IH !Reflection h index C INTEGER IK !Reflection k index C INTEGER IL !Reflection l index C INTEGER M1 !Token start position C INTEGER M2 !Token end position C INTEGER NADD !Number of matches added from input matches file C INTEGER NERR !Number of errors reading matches file C INTEGER NVALS !Number of numerical values in matches file record C INTEGER NXRAST !No. x-rasters C INTEGER NYRAST !No. y-rasters C INTEGER IFLAG !Parameter status flag C INTEGER ND !No. of decimal places flag C INTEGER JH !h index C INTEGER JK !k index C INTEGER JL !l index C INTEGER MULT !Multiplicity C INTEGER NUMSPOTS !No. of spots in generated spots list C INTEGER IORD !Axis order flag 1-8 C INTEGER ISWAP !Byte swap flag C INTEGER LISTE(2) !Parameter updates list C REAL MM_RAST_X !mm to x-rasters conversion factor C REAL MM_RAST_Y !mm to y-rastrs conversion factor C REAL VALUES(20) !Numerical values from matches file record C REAL FP !Real value from INTFP routine C REAL CGX !Found x c-of-g of spot (raster units) C REAL CGY !Found y c-of-g of spot (raster units) C REAL OMEGA !Corrected omega (degrees) C REAL X_CEN !Corrected x centre (rasters) C REAL Y_CEN !Corrected y centre (rasters) C REAL X_CEN_F !x centre from fids or input (rasters) C REAL Y_CEN_F !y centre from fids or input (rasters) C REAL XSPOT_MM !Observed spot x position (mm from centre) C REAL YSPOT_MM !Observed spot y position (mm from centre) C REAL X_C !x_c value (mm) C REAL Y_C !y_c value (mm) C REAL XFD !X coordinate on detector (rast) (distort. corrected) C REAL YFD !Y coordinate on detector (rast) (distort. corrected) C REAL ALAM !Wavelength C REAL DTHR2 !dmin-threshold**2 C C------------------------------------------------------------------------------- C C====== Initialisations C CALL LDM_MMRAST (IPACK, IPLATE, MM_RAST_X, MM_RAST_Y) CALL LDM_GET_NXRAS (NXRAST, IFLAG) CALL LDM_GET_NYRAS (NYRAST, IFLAG) CALL LDM_GET_AXORD (VALSTR, IORD, ISWAP, IFLAG) CALL LRL_NUMSPOTS (NUMSPOTS) CALL LDM_GET_STHR (SPOT_INPUT_THRESH, IFLAG, ND) C C====== Set up parameter table 3 C IP_SBOX = 1 IP_THRESH = 2 WRITE (STR,'(F8.2)') SPOT_INPUT_BOX CALL LJUST (STR) CALL XDLF_PARAM_TABLE_SETITEM (IVH_PAR3, IP_SBOX, + XDLSTR('Match box (mm):'), 15, + XDLSTR(STR), LENSTR(STR), 0, 0, KERR) WRITE (STR,'(F8.1)') SPOT_INPUT_THRESH CALL LJUST (STR) CALL XDLF_PARAM_TABLE_SETITEM (IVH_PAR3, IP_THRESH, + XDLSTR('Spot threshold:'), 15, + XDLSTR(STR), LENSTR(STR), 0, 1, KERR) C C====== Check that film centre info is available C CALL CHK_OPN (IERR) IF (IERR.GT.0) RETURN CALL FILM_CENTRE(X_CEN_F,Y_CEN_F,OMEGA) CALL LDM_GET_XC (IPACK, IPLATE, X_C, IFLAG, ND, KERR, ERRSTR) CALL LDM_GET_YC (IPACK, IPLATE, Y_C, IFLAG, ND, KERR, ERRSTR) X_CEN = X_CEN_F + X_C*MM_RAST_X Y_CEN = Y_CEN_F + Y_C*MM_RAST_Y C C====== Display image C CALL SHOW_IMAGE (1, IERR) IF (IERR.EQ.1) RETURN C C====== Set max limit for IDSQMIN to consider as a position match C IDSQLIM = 18*NCMP*NCMP C C====== Determine whether to display all reflns or nodals at start C IDISP = 0 IF (NUMSPOTS.GT.MAX_DISP) THEN CALL FIND_SEL_NODS (1, 1, 1, 1, 0, 0, 0) IDISP = 1 END IF C C====== Display predicted positions C NUM_MATCH = 0 CALL PLOT_SYMBS (IDISP, 1) C C====== Set up Match Spots Options Menu C M_ALL = 1 M_NODALS = 2 M_CLEAR = 3 M_INPUT = 4 M_DELETE = 5 M_READ = 6 M_WRITE = 7 CALL SET_MENU4 C C====== Service Match Spots Menu and Film Image Display C I_ADD = 1 I_DEL = 2 IADDEL = 0 IVHLIST(1) = IVH_MENU IVHLIST(2) = IVH_PAR3 IVHLIST(3) = IVH_FILM NVIEW = 2 100 CALL XDLF_GET_EVENTS(NVIEW,IVHLIST,IVH) C C====== Menu item selected C IF (IVH.EQ.IVH_MENU) THEN CALL XDLF_MENU_AREA_GETITEM(IVH_MENU,ITEM,IQUIT) C C====== Quit selected C IF (IQUIT.EQ.1) THEN CALL XDLF_PARAM_TABLE_CLEARITEMS (IVH_PAR3, KERR) CALL XDLF_IMAGE_SETTINGS (IVH_FILM, MINTHR, MAXTHR, + MONO_THR, ICONTRAST, ICOLOR_OPT, IOVLY_OPT, IBG_OPT, + MAG_OPT, ISHOW_INT, KERR) CALL XDLF_DELETE_VIEW_OBJECT(IVH_FILM,KERR) RETURN END IF C C====== Display all predicted reflections C IF (ITEM.EQ.M_ALL) THEN IF (NUMSPOTS.GT.MAX_DISP) THEN CALL ERR_NOTICE (1,'**Too many reflections to display**') GO TO 100 END IF IDISP = 0 IPRMEAS = 1 CALL XDLF_IMAGE_CLEAR_SYMBOLS (IVH_FILM,KERR) CALL PLOT_SYMBS (IDISP, 1) GO TO 100 C C====== Display nodals only C ELSE IF (ITEM.EQ.M_NODALS) THEN CALL FIND_SEL_NODS (1, 1, 1, 1, 0, 0, 0) IDISP = 1 IPRMEAS = 1 CALL XDLF_IMAGE_CLEAR_SYMBOLS (IVH_FILM,KERR) CALL PLOT_SYMBS (IDISP, 1) GO TO 100 C C====== Clear Matches List C ELSE IF (ITEM.EQ.M_CLEAR) THEN CALL XDLF_IMAGE_CLEAR_SYMBOLS (IVH_FILM,KERR) NUM_MATCH = 0 CALL PLOT_SYMBS (IDISP, 1) NVIEW = 2 GO TO 100 C C====== Input Matches C ELSE IF (ITEM.EQ.M_INPUT) THEN NVIEW = 3 IADDEL = I_ADD IPRMEAS = 1 CALL XDLF_IMAGE_INPUT_MESSAGE (IVH_FILM, + XDLSTR('Input predicted position of matching pair'), + 41,KERR) GO TO 100 C C====== Delete Matches C ELSE IF (ITEM.EQ.M_DELETE) THEN IF (IPRMEAS.EQ.2) THEN CALL XDLF_IMAGE_DEL_SYMBOL (IVH_FILM, + IXPIX_MATCH(NUM_MATCH+1), IYPIX_MATCH(NUM_MATCH+1), + ISYMBTYP(3), ICOLRTYP(3), 1, KERR) END IF NVIEW = 3 IADDEL = I_DEL IPRMEAS = 1 CALL XDLF_IMAGE_INPUT_MESSAGE (IVH_FILM, + XDLSTR( + 'Input predicted position of matching pair to delete'), + 51,KERR) GO TO 100 C C====== Read Matches File C ELSE IF (ITEM.EQ.M_READ) THEN IF (NUMSPOTS.EQ.0) THEN CALL ERR_NOTICE (1,'**No spots predicted**') GO TO 100 END IF CLEAR = .FALSE. CALL XDLF_VIEW_OBJECT_RAISE (IVH_BASE, KERR) IF (NUM_MATCH.GT.0) THEN REPLY = .FALSE. CALL IOW_ASKQ (IVH_IOW, 'Add to existing matches', REPLY) IF (.NOT.REPLY) THEN CALL IOW_ASKQ (IVH_IOW, 'Overwrite existing matches', + REPLY) IF (.NOT.REPLY) THEN CALL XDLF_VIEW_OBJECT_RAISE (IVH_FILM, KERR) GO TO 100 END IF CLEAR = .TRUE. END IF END IF NVIEW = 2 102 CALL LPROMPT + (IVH_IOW, 'File name (default ext=.matches): ') IVHLST2(1) = IVH_IOW CALL XDLF_GET_EVENTS (1, IVHLST2, IVH) CALL XDLF_IO_WINDOW_GETSTRING (IVH_IOW, XDLSTR(FILNAM), + MAXFLEN, KERR) IF (FILNAM.EQ.' ') THEN CALL XDLF_VIEW_OBJECT_RAISE(IVH_FILM, KERR) GO TO 100 END IF CALL FILEXT (FILNAM, 'matches', MATCH_FILE, I) EXISTS = CCPEXS (MATCH_FILE) IF (.NOT.EXISTS) THEN CALL LMESSAGE(IVH_IOW,'**File not found**') GO TO 102 END IF IFAIL = 1 CALL CCPDPN (-IUN_MATCH, MATCH_FILE,'READONLY','F',0,IFAIL) IF (IFAIL.LT.0) THEN CALL LMESSAGE(IVH_IOW,'**Error in opening the file**') GO TO 102 END IF READ (IUN_MATCH,'(A)',END=104) STR J = 0 IF (NXTTOK (STR, ' ', J, M1, M2).EQ.0) THEN CALL LMESSAGE (IVH_IOW, + '**File does not start with ''matches:'' keyword**') CLOSE (IUN_MATCH) GO TO 102 END IF CALL CCPUPC(STR) IF (STR(M1:M2).NE.'MATCHES:') THEN CALL LMESSAGE (IVH_IOW, + '**File does not start with ''matches:'' keyword**') CLOSE (IUN_MATCH) GO TO 102 END IF IF (CLEAR) NUM_MATCH = 0 NERR = 0 NADD = 0 103 READ (IUN_MATCH,'(A)',END=104) STR IF (STR.EQ.' ') GO TO 103 CALL STRVAL (STR, ' =', 20, VALUES, NVALS) IF (NVALS.NE.5) THEN CALL LMESSAGE(IVH_IOW,'**Invalid format in record**') NERR = NERR + 1 GO TO 103 END IF IF (NUM_MATCH.GE.MAX_MATCH) THEN CALL LMESSAGE (IVH_IOW,'**Matches list full**') NERR = NERR + 1 GO TO 104 END IF IH = NINT(VALUES(1)) IK = NINT(VALUES(2)) IL = NINT(VALUES(3)) XSPOT_MM = VALUES(4) YSPOT_MM = VALUES(5) DO 350 I=1,NUMSPOTS CALL LRL_GET (I, JH, JK, JL, XFD, YFD, ALAM, DTHR2, MULT, + NODFLG, SPAT, KERR) IF (IH.EQ.JH.AND.IK.EQ.JK.AND.IL.EQ.JL) THEN NUM_MATCH = NUM_MATCH + 1 IREF_MATCH(NUM_MATCH) = I IXPIX_MATCH(NUM_MATCH)=NINT(XFD) IYPIX_MATCH(NUM_MATCH)=NINT(YFD) XSPOT_MATCH(NUM_MATCH) = X_CEN + XSPOT_MM*MM_RAST_X YSPOT_MATCH(NUM_MATCH) = Y_CEN + YSPOT_MM*MM_RAST_Y IXSP_MATCH(NUM_MATCH) = NINT(XSPOT_MATCH(NUM_MATCH)) IYSP_MATCH(NUM_MATCH) = NINT(YSPOT_MATCH(NUM_MATCH)) NADD = NADD + 1 GO TO 103 END IF 350 CONTINUE STR = '**Cannot find reflection' CALL STR_ADDI (STR, IH, 1) CALL STR_ADDI (STR, IK, 1) CALL STR_ADDI (STR, IL, 1) CALL STR_ADDS (STR, 'in the predicted reflections list**', + 1) CALL LMESSAGE (IVH_IOW, STR) NERR = NERR + 1 GO TO 103 104 CLOSE (IUN_MATCH) STR = 'Number of reflection matches added =' CALL STR_ADDI (STR, NADD, 1) CALL LMESSAGE (IVH_IOW, STR) IF (NERR.GT.0) THEN STR = '**Number of errors =' CALL STR_ADDI (STR, NERR, 1) CALL STR_ADDS (STR,'**',1) CALL LMESSAGE (IVH_IOW, STR) END IF CALL XDLF_IMAGE_CLEAR_SYMBOLS (IVH_FILM, KERR) CALL PLOT_SYMBS (IDISP, 1) IF (NERR.EQ.0) CALL XDLF_VIEW_OBJECT_RAISE(IVH_FILM, KERR) GO TO 100 C C====== Write Matches File C ELSE IF (ITEM.EQ.M_WRITE) THEN CALL NOTICE_POSN (1,IXROOT,IYROOT) NVIEW = 2 IF (NUM_MATCH.LE.0) THEN CALL ERR_NOTICE(1,'**No spots in list of matches**') GO TO 100 END IF CALL XDLF_VIEW_OBJECT_RAISE (IVH_BASE, KERR) 105 CALL LPROMPT + (IVH_IOW, 'File name (default ext=.matches): ') IVHLST2(1) = IVH_IOW CALL XDLF_GET_EVENTS (1, IVHLST2, IVH) CALL XDLF_IO_WINDOW_GETSTRING (IVH_IOW, XDLSTR(FILNAM), + MAXFLEN, KERR) IF (FILNAM.EQ.' ') THEN CALL XDLF_VIEW_OBJECT_RAISE(IVH_FILM, KERR) GO TO 100 END IF CALL FILEXT (FILNAM, 'matches', MATCH_FILE, I) CALL LGFILE_EXISTS (MATCH_FILE, CONT) IF (.NOT.CONT) GO TO 105 IFAIL = 1 CALL CCPDPN (-IUN_MATCH, MATCH_FILE,'UNKNOWN','F',0,IFAIL) IF (IFAIL.LT.0) THEN CALL LMESSAGE(IVH_IOW,'**Error in opening the file**') GO TO 105 END IF WRITE (IUN_MATCH,'(''matches:'')') DO 106 I=1,NUM_MATCH J = IREF_MATCH(I) XSPOT_MM = (XSPOT_MATCH(I)-X_CEN)/MM_RAST_Y YSPOT_MM = (YSPOT_MATCH(I)-Y_CEN)/MM_RAST_Y CALL LRL_GET (J, JH, JK, JL, XFD, YFD, ALAM, DTHR2, MULT, + NODFLG, SPAT, KERR) WRITE (IUN_MATCH,'(3I5,2F8.2)') + JH, JK, JL, + XSPOT_MM, YSPOT_MM 106 CONTINUE CLOSE (IUN_MATCH) CALL XDLF_VIEW_OBJECT_RAISE(IVH_FILM, KERR) GO TO 100 ELSE GO TO 100 END IF C C====== Input from parameter table C ELSE IF (IVH.EQ.IVH_PAR3) THEN CALL XDLF_PARAM_TABLE_GETVALUE (IVH_PAR3, ITM, + XDLSTR(PVAL), MAX_P3SCROLL_CHARS, KERR) IF (ITM.EQ.IP_SBOX) THEN ITYP = INTFP (PVAL, FP, IV) IF (ITYP.EQ.0) THEN CALL XDLF_PARAM_TABLE_ERROR (IVH_PAR3, ITM, + XDLSTR('**Invalid Number Format**'), 25, KERR) GO TO 100 END IF IF (FP.LE.0) THEN CALL XDLF_PARAM_TABLE_ERROR (IVH_PAR3, ITM, + XDLSTR('**Value must be greater than zero**'), 35, KERR) GO TO 100 END IF SPOT_INPUT_BOX = FP WRITE (STR,'(F8.2)') SPOT_INPUT_BOX CALL LJUST(STR) CALL XDLF_PARAM_TABLE_SETVALUE (IVH_PAR3, ITM, + XDLSTR(STR), LENSTR(STR), 0, KERR) ELSE IF (ITM.EQ.IP_THRESH) THEN ITYP = INTFP (PVAL, FP, IV) IF (ITYP.EQ.0) THEN CALL XDLF_PARAM_TABLE_ERROR (IVH_PAR3, ITM, + XDLSTR('**Invalid Number Format**'), 25, KERR) GO TO 100 END IF IF (FP.LE.0) THEN CALL XDLF_PARAM_TABLE_ERROR (IVH_PAR3, ITM, + XDLSTR('**Value must be greater than zero**'), 35, KERR) GO TO 100 END IF SPOT_INPUT_THRESH = FP WRITE (STR,'(F8.1)') SPOT_INPUT_THRESH CALL LJUST(STR) CALL XDLF_PARAM_TABLE_SETVALUE (IVH_PAR3, ITM, + XDLSTR(STR), LENSTR(STR), 0, KERR) CALL LDM_SET_STHR (SPOT_INPUT_THRESH, IERR, ERRSTR) LISTE(1) = IP_STHR CALL SET_PAR1_VALS (1, LISTE) END IF GO TO 100 C C====== Input from film/image-plate image display C ELSE IF (IVH.EQ.IVH_FILM) THEN IF (IADDEL.EQ.I_ADD) THEN IF (IPRMEAS.EQ.1) THEN CALL XDLF_IMAGE_GETPIX_OVLY (IVH_FILM, 1, + IXP, IYP, KERR) IF (NUM_DISP.LE.0) GO TO 100 IDSQMIN = NXRAST*NXRAST + NYRAST*NYRAST ISPOT = 0 DO 200 I=1,NUM_DISP ID = (IXP-IXPIX_DISP(I))**2 + (IYP-IYPIX_DISP(I))**2 IF (ID.GT.IDSQLIM) GO TO 200 IF (ID.LT.IDSQMIN) THEN IF (NUM_MATCH.GT.0) THEN DO 190 J=1,NUM_MATCH IF (IREF_MATCH(J).EQ.IREF_DISP(I)) GO TO 200 190 CONTINUE END IF ISPOT = I IDSQMIN = ID END IF 200 CONTINUE IF (ISPOT.EQ.0) GO TO 100 IF (NUM_MATCH.GE.MAX_MATCH) THEN CALL ERR_NOTICE (0,'**Matches list is full**') GO TO 100 END IF IXPIX_MATCH(NUM_MATCH+1) = IXPIX_DISP(ISPOT) IYPIX_MATCH(NUM_MATCH+1) = IYPIX_DISP(ISPOT) IREF_MATCH(NUM_MATCH+1) = IREF_DISP(ISPOT) XSPOT_MATCH(NUM_MATCH+1) = 0.0 YSPOT_MATCH(NUM_MATCH+1) = 0.0 IXSP_MATCH(NUM_MATCH+1) = 0 IYSP_MATCH(NUM_MATCH+1) = 0 CALL XDLF_IMAGE_DEL_SYMBOL (IVH_FILM, + IXPIX_DISP(ISPOT), IYPIX_DISP(ISPOT), + ISYMBTYP(ISYMB_DISP(ISPOT)), + ICOLRTYP(ISYMB_DISP(ISPOT)), + 1, KERR) CALL XDLF_IMAGE_SYMBOL (IVH_FILM, + IXPIX_MATCH(NUM_MATCH+1), IYPIX_MATCH(NUM_MATCH+1), + ISYMBTYP(3), ICOLRTYP(3), 1, KERR) IPRMEAS = 2 CALL XDLF_IMAGE_INPUT_MESSAGE (IVH_FILM, + XDLSTR('Input observed spot position of matching pair'), + 45,KERR) ELSE IF(IPRMEAS.EQ.2) THEN CALL XDLF_IMAGE_GETPIX (IVH_FILM, IXP, IYP, KERR) IXSIZ = NINT (SPOT_INPUT_BOX*MM_RAST_X) IXSIZ = IXSIZ/2 IF (IXSIZ.LT.1) IXSIZ = 1 IF (IXSIZ.GT.MAX_HALF_BOX) THEN CALL ERR_NOTICE (0,'**Spot box size too large**') GO TO 100 ENDIF IYSIZ = NINT (SPOT_INPUT_BOX*MM_RAST_Y) IYSIZ = IYSIZ/2 IF (IYSIZ.LT.1) IYSIZ = 1 IF (IYSIZ.GT.MAX_HALF_BOX) THEN CALL ERR_NOTICE (0,'**Spot box size too large**') GO TO 100 ENDIF CALL SFPIX (IXP,IYP,ISPIX,IFPIX) CALL XDLF_BG_VALIMG(ISPIX,IFPIX,IMG_BG,ITYPE,NF_BGOFF, + NCMP, IBG, KERR) ITHRESH = IBG + NINT(SPOT_INPUT_THRESH) CALL SPOT_C_OF_G (IXP, IYP, IXSIZ, IYSIZ, ISPOT_DATA, + ISWORK, ITHRESH, IMG, ITYPE, IORD, NFRASTS, + NXRAST, NYRAST, NOVER, + CGX, CGY, KERR) IF (KERR.LT.0) THEN CALL ERR_NOTICE (0,'**Error in spot_c_of_g call**') GO TO 100 ELSE IF (KERR.EQ.2) THEN CALL ERR_NOTICE (0, + '**Spot box outside range of image**') GO TO 100 ELSE IF (NOVER.EQ.0) THEN CALL ERR_NOTICE (0, + '**No pixels above threshold**') GO TO 100 ENDIF IXP = NINT (CGX) IF (IXP.LT.1) IXP = 1 IF (IXP.GT.NXRAST) IXP = NXRAST IYP = NINT (CGY) IF (IYP.LT.1) IYP = 1 IF (IYP.GT.NYRAST) IYP = NYRAST NUM_MATCH = NUM_MATCH + 1 XSPOT_MATCH(NUM_MATCH) = CGX YSPOT_MATCH(NUM_MATCH) = CGY IXSP_MATCH(NUM_MATCH) = IXP IYSP_MATCH(NUM_MATCH) = IYP CALL XDLF_IMAGE_SYMBOL (IVH_FILM, IXP, IYP, + ISYMBTYP(4), ICOLRTYP(4), 2, KERR) IF (KERR.GE.4) THEN CALL ERR_NOTICE (0, + '**Unable to allocate memory for new symbol**') GO TO 100 END IF IPRMEAS = 1 CALL XDLF_IMAGE_INPUT_MESSAGE (IVH_FILM, + XDLSTR('Input predicted position of matching pair'), + 41,KERR) END IF ELSE IF (IADDEL.EQ.I_DEL) THEN CALL XDLF_IMAGE_GETPIX_OVLY (IVH_FILM, 1, + IXP, IYP, KERR) IF (NUM_MATCH.LE.0) GO TO 100 IDSQMIN = NXRAST*NXRAST + NYRAST*NYRAST DO 180 I=1,NUM_MATCH ID = (IXP-IXPIX_MATCH(I))**2 + (IYP-IYPIX_MATCH(I))**2 IF (ID.LT.IDSQMIN) THEN ISPOT = I IDSQMIN = ID END IF 180 CONTINUE IF (IDSQMIN.GT.IDSQLIM) GO TO 100 CALL XDLF_IMAGE_DEL_SYMBOL (IVH_FILM, + IXPIX_MATCH(ISPOT), IYPIX_MATCH(ISPOT), + ISYMBTYP(3), ICOLRTYP(3), 1, KERR) CALL XDLF_IMAGE_DEL_SYMBOL (IVH_FILM, + IXSP_MATCH(ISPOT), IYSP_MATCH(ISPOT), + ISYMBTYP(4), ICOLRTYP(4), 2, KERR) DO 250 I=1,NUM_DISP IF (IREF_DISP(I).EQ.IREF_MATCH(ISPOT)) THEN CALL XDLF_IMAGE_SYMBOL (IVH_FILM, + IXPIX_DISP(I), IYPIX_DISP(I), + ISYMBTYP(ISYMB_DISP(I)), ICOLRTYP(ISYMB_DISP(I)), + 1, KERR) GO TO 260 END IF 250 CONTINUE 260 IF (ISPOT.EQ.NUM_MATCH) THEN NUM_MATCH = NUM_MATCH - 1 ELSE DO 280 I = ISPOT, NUM_MATCH - 1 IREF_MATCH(I) = IREF_MATCH(I+1) IXPIX_MATCH(I) = IXPIX_MATCH(I+1) IYPIX_MATCH(I) = IYPIX_MATCH(I+1) XSPOT_MATCH(I) = XSPOT_MATCH(I+1) YSPOT_MATCH(I) = YSPOT_MATCH(I+1) IXSP_MATCH(I) = IXSP_MATCH(I+1) IYSP_MATCH(I) = IYSP_MATCH(I+1) 280 CONTINUE NUM_MATCH = NUM_MATCH -1 END IF END IF GO TO 100 ELSE GO TO 100 END IF END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** MATCH_TO_OBS ** C************************** C C SUBROUTINE MATCH_TO_OBS C INCLUDE 'implicit_none.finc' C C Purpose: Transfer matched spots list to observed spots list for refinement C C Author: John W. Campbell, January 1991 C C Arguments: C C None C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' C C====== GLOBALS: C INCLUDE 'matches.finc' INCLUDE 'lauegen_observed_spots.finc' C C====== FUNCTION TYPES: C INTEGER IABS C C====== LOCALS: C LOGICAL SPAT LOGICAL NODFLG INTEGER I INTEGER H, K, L INTEGER JH, JK, JL INTEGER MULT INTEGER ISPOT INTEGER IERR REAL ALAM REAL DTHR2 REAL XFD REAL YFD C C LOGICAL SPAT !Spatial overlap flag C LOGICAL NODFLG !Nodal spot flag C INTEGER I !Temp/loop variable C INTEGER H, K, L !Reflection indices C INTEGER JH, JK, JL !Reflection indices (predicted) C INTEGER MULT !Multiplicity C INTEGER ISPOT !Pointer to spot in LRL list C INTEGER IERR !Error flag C REAL ALAM !Lambda C REAL DTHR2 !dmin-threshol**2 C REAL XFD !Predicted x position on detector C REAL YFD !Predicted y position on detector C C------------------------------------------------------------------------------- C IF (NUM_MATCH.GT.0) THEN DO 100 I=1,NUM_MATCH ISPOT = IREF_MATCH(I) CALL LRL_GET (ISPOT, JH, JK, JL, XFD, YFD, ALAM, + DTHR2, MULT, NODFLG, SPAT, IERR) H = JH K = JK L = JL NODAL_H_S(I) = H NODAL_K_S(I) = K NODAL_L_S(I) = L XM_OBS(I) = XSPOT_MATCH(I) YM_OBS(I) = YSPOT_MATCH(I) HKL_KEY(I) = IABS(H) + IABS(K) + IABS(L) 100 CONTINUE END IF NUM_OBS = NUM_MATCH RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** MATS ** C************************** C C SUBROUTINE MATS (AM,AA,AB,AC,AD,AE,AF,CELL) C INCLUDE 'implicit_none.finc' C C Purpose: C C Generalised matrix and derivative builder C the reciprocal cell parameters come in cell(1-6) but only the C unique ones ... cell(1) is astar, cell(2) alphastar for rhombohedra C for example. C am returns the A matrix ... row 1 is components of reciprocal cell C along X, row 2 along Y, row 3 along Z. C aa, ab etc are the derivative matrices for A wrt the unique cell C parameters in order ... thus aa is dA/dastar, ab dA/alphastar for C rhombohedral. C C Modified by Pella Machin and T.Tjahjadi C reset AM,AA,AB,AC,AD,AE,AF TO 0, otherwise problem arise if orientatio C by poles is used after a triclinic case is run because only parameters C relevant to a particular lattice type are reset, the rest remain C unchanged. C C ***This version assumes angles in degrees*** C C Arguments: C REAL AM(3,3) REAL AA(3,3) REAL AB(3,3) REAL AC(3,3) REAL AD(3,3) REAL AE(3,3) REAL AF(3,3) REAL CELL(6) C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' C C====== FUNCTION TYPES: C C C====== LOCALS: C INTEGER I,J,K INTEGER N1,N2,N3 INTEGER IROT, IBEAM, ISYST, IFLAG REAL SI,SJ,SK REAL A,C,S,FUN,COSPSI,TMPRT,COSRHO REAL RL(3),CC(3),SS(3) REAL DA(3,3,3),DB(3,3,3) REAL DTORAD CHARACTER*2 VALSTR C C------------------------------------------------------------------------------- C DTORAD = 3.14159265/180.0 CALL LDM_GET_ROT (VALSTR, IROT, IFLAG) CALL LDM_GET_BEAM (VALSTR, IBEAM, IFLAG) CALL LDM_GET_SYST (VALSTR, ISYST, IFLAG) C C====== Reset matrix elements C DO 30 I = 1 , 3 DO 20 J = 1 , 3 AM(I,J) = 0 AA(I,J) = 0 AB(I,J) = 0 AC(I,J) = 0 AD(I,J) = 0 AE(I,J) = 0 AF(I,J) = 0 20 CONTINUE 30 CONTINUE C C====== I refers to IROT, the crystal rotation axis, z C I = IABS(IROT) SI = 1.0 IF (IROT.LT.0) SI = -1.0 C C====== J refers to IBEAM, the xray beam axis, x C J = IABS(IBEAM) SJ = 1.0 IF (IBEAM.LT.0) SJ = -1.0 C C====== K is therefore the other axis, y C K = 6 - I - J C C====== The sign of k relies on i,j,k and X,Y,Z being right-handed C IF (K.EQ.J+1 .OR. K.EQ.J-2) THEN SK = SI*SJ ELSE SK = -SI*SJ END IF IF (ISYST.EQ.2) THEN C C====== Monoclinic C RL(1) = CELL(1) RL(2) = CELL(2) RL(3) = CELL(3) CC(1) = 0.0 CC(2) = COS(CELL(4)*DTORAD) CC(3) = 0.0 SS(1) = 1.0 SS(2) = SIN(CELL(4)*DTORAD) SS(3) = 1.0 C C====== A matrix C AM(1,J) = SJ*RL(J)*SS(K) AM(1,K) = SJ*RL(K)*CC(I) AM(2,K) = SK*RL(K)*SS(I)*SS(J) AM(3,I) = SI*RL(I) AM(3,J) = SI*RL(J)*CC(K) AM(3,K) = SI*RL(K)*CC(J) C C====== Derivatives wrt reciprocal cell lengths C DO 60 N1 = 1 , 3 DO 50 N2 = 1 , 3 DO 40 N3 = 1 , 3 DA(N1,N2,N3) = 0. 40 CONTINUE 50 CONTINUE 60 CONTINUE DA(3,I,I) = SI DA(1,J,J) = SJ*SS(K) DA(3,J,J) = SI*CC(K) DA(1,K,K) = SJ*CC(I) DA(2,K,K) = SK*SS(I)*SS(J) DA(3,K,K) = SI*CC(J) DO 90 N1 = 1 , 3 DO 80 N2 = 1 , 3 DO 70 N3 = 1 , 3 IF (DA(N1,N2,N3).NE.0.0) THEN IF (N3.EQ.1) AA(N1,N2) = DA(N1,N2,N3) IF (N3.EQ.2) AB(N1,N2) = DA(N1,N2,N3) IF (N3.EQ.3) AC(N1,N2) = DA(N1,N2,N3) END IF 70 CONTINUE 80 CONTINUE 90 CONTINUE C C====== Derivatives wrt reciprocal cell angles (only ss(2) and cc(2)) C IF (I.EQ.2) THEN AD(1,K) = -SJ*RL(K)*SS(I) AD(2,K) = SK*RL(K)*CC(I) END IF IF (J.EQ.2) THEN AD(2,K) = SK*RL(K)*CC(J) AD(3,K) = -SI*RL(K)*SS(J) END IF IF (K.EQ.2) THEN AD(1,J) = SJ*RL(J)*CC(K) AD(3,J) = -SI*RL(J)*SS(K) END IF RETURN ELSE IF (ISYST.EQ.3) THEN C C====== Orthorhombic C RL(1) = CELL(1) RL(2) = CELL(2) RL(3) = CELL(3) AM(1,J) = SJ*RL(J) AM(2,K) = SK*RL(K) AM(3,I) = SI*RL(I) C C====== Derivatives C IF (J.EQ.1) AA(1,1) = SJ IF (K.EQ.1) AA(2,1) = SK IF (I.EQ.1) AA(3,1) = SI IF (J.EQ.2) AB(1,2) = SJ IF (K.EQ.2) AB(2,2) = SK IF (I.EQ.2) AB(3,2) = SI IF (J.EQ.3) AC(1,3) = SJ IF (K.EQ.3) AC(2,3) = SK IF (I.EQ.3) AC(3,3) = SI RETURN ELSE IF (ISYST.EQ.4) THEN C C====== Tetragonal C RL(1) = CELL(1) RL(2) = CELL(1) RL(3) = CELL(2) AM(1,J) = SJ*RL(J) AM(2,K) = SK*RL(K) AM(3,I) = SI*RL(I) C C====== Derivatives C IF (J.EQ.1) AA(1,1) = SJ IF (K.EQ.1) AA(2,1) = SK IF (I.EQ.1) AA(3,1) = SI IF (J.EQ.2) AA(1,2) = SJ IF (K.EQ.2) AA(2,2) = SK IF (I.EQ.2) AA(3,2) = SI IF (J.EQ.3) AB(1,3) = SJ IF (K.EQ.3) AB(2,3) = SK IF (I.EQ.3) AB(3,3) = SI RETURN ELSE IF (ISYST.EQ.5) THEN C C====== Hexagonal C RL(1) = CELL(1) RL(2) = CELL(1) RL(3) = CELL(2) CC(1) = 0.0 CC(2) = 0.0 CC(3) = 0.5 SS(1) = 1.0 SS(2) = 1.0 SS(3) = SQRT(3.)/2. C C====== A matrix C AM(1,J) = SJ*RL(J)*SS(K) AM(1,K) = SJ*RL(K)*CC(I) AM(2,K) = SK*RL(K)*SS(I)*SS(J) AM(3,I) = SI*RL(I) AM(3,J) = SI*RL(J)*CC(K) AM(3,K) = SI*RL(K)*CC(J) C C====== Derivatives wrt reciprocal cell lengths C DO 120 N1 = 1 , 3 DO 110 N2 = 1 , 3 DO 100 N3 = 1 , 3 DA(N1,N2,N3) = 0. 100 CONTINUE 110 CONTINUE 120 CONTINUE DA(3,I,I) = SI DA(1,J,J) = SJ*SS(K) DA(3,J,J) = SI*CC(K) DA(1,K,K) = SJ*CC(I) DA(2,K,K) = SK*SS(I)*SS(J) DA(3,K,K) = SI*CC(J) DO 150 N1 = 1 , 3 DO 140 N2 = 1 , 3 DO 130 N3 = 1 , 3 IF (DA(N1,N2,N3).NE.0.0) THEN IF (N3.EQ.1 .OR. N3.EQ.2) AA(N1,N2) = DA(N1,N2,N3) IF (N3.EQ.3) AB(N1,N2) = DA(N1,N2,N3) END IF 130 CONTINUE 140 CONTINUE 150 CONTINUE RETURN ELSE IF (ISYST.EQ.6) THEN C C====== Rhombohedral C A = CELL(1) C = COS(CELL(2)*DTORAD) S = SIN(CELL(2)*DTORAD) FUN = SQRT(1.-3.*C**2+2.*C**3) AM(1,J) = SJ*A*S AM(1,K) = SJ*A*C*(1.-C)/S AM(2,K) = SK*A*FUN/S AM(3,I) = SI*A AM(3,J) = SI*A*C AM(3,K) = SI*A*C AA(1,J) = SJ*S AA(1,K) = AM(1,K)/A AA(2,K) = AM(2,K)/A AA(3,I) = SI AA(3,J) = SI*C AA(3,K) = SI*C AB(1,J) = SJ*A*C AB(1,K) = SJ*A*(C-(1.-C)/S**2) AB(2,K) = SK*A*(3.*C*(1.-C)/FUN-FUN*C/S**2) AB(3,J) = -SI*A*S AB(3,K) = -SI*A*S RETURN ELSE IF (ISYST.EQ.7) THEN C C====== Cubic C A = CELL(1) AM(1,J) = SJ*A AM(2,K) = SK*A AM(3,I) = SI*A AA(1,J) = SJ AA(2,K) = SK AA(3,I) = SI RETURN ELSE C C====== Triclinic C RL(1) = CELL(1) RL(2) = CELL(2) RL(3) = CELL(3) CC(1) = COS(CELL(4)*DTORAD) CC(2) = COS(CELL(5)*DTORAD) CC(3) = COS(CELL(6)*DTORAD) SS(1) = SIN(CELL(4)*DTORAD) SS(2) = SIN(CELL(5)*DTORAD) SS(3) = SIN(CELL(6)*DTORAD) C C====== See Buerger's Xray Crystallography for the next formulae, p348 C COSPSI = (CC(I)-CC(K)*CC(J))/SS(K) TMPRT = ABS(1.-CC(I)**2-CC(J)**2-CC(K)**2+2.*CC(I)*CC(J)*CC(K)) COSRHO = SQRT(TMPRT)/SS(K) C C====== A matrix C AM(1,J) = SJ*RL(J)*SS(K) AM(1,K) = SJ*RL(K)*COSPSI AM(2,K) = SK*RL(K)*COSRHO AM(3,I) = SI*RL(I) AM(3,J) = SI*RL(J)*CC(K) AM(3,K) = SI*RL(K)*CC(J) C C====== Derivatives wrt reciprocal cell lengths C DO 180 N1 = 1 , 3 DO 170 N2 = 1 , 3 DO 160 N3 = 1 , 3 DA(N1,N2,N3) = 0. DB(N1,N2,N3) = 0. 160 CONTINUE 170 CONTINUE 180 CONTINUE DA(3,I,I) = SI DA(1,J,J) = SJ*SS(K) DA(3,J,J) = SI*CC(K) DA(1,K,K) = SJ*COSPSI DA(2,K,K) = SK*COSRHO DA(3,K,K) = SI*CC(J) DO 210 N1 = 1 , 3 DO 200 N2 = 1 , 3 DO 190 N3 = 1 , 3 IF (DA(N1,N2,N3).NE.0.0) THEN IF (N3.EQ.1) AA(N1,N2) = DA(N1,N2,N3) IF (N3.EQ.2) AB(N1,N2) = DA(N1,N2,N3) IF (N3.EQ.3) AC(N1,N2) = DA(N1,N2,N3) END IF 190 CONTINUE 200 CONTINUE 210 CONTINUE C C====== Derivatives wrt reciprocal cell angles C DB(1,K,I) = -SJ*RL(K)*SS(I)/SS(K) DB(2,K,I) = SK*RL(K)*SS(I)*(CC(I)-CC(J)*CC(K)) + /(SS(K)**2*COSRHO) DB(1,K,J) = SJ*RL(K)*CC(K)*SS(J)/SS(K) DB(2,K,J) = SK*RL(K)*SS(J)*(CC(J)-CC(I)*CC(K)) + /(SS(K)**2*COSRHO) DB(3,K,J) = -SI*RL(K)*SS(J) DB(1,J,K) = SJ*RL(J)*CC(K) DB(1,K,K) = SJ*RL(K)*(CC(J)-CC(K)*CC(I))/SS(K)**2 DB(2,K,K) = SK*RL(K)*((CC(K)-CC(I)*CC(J))/(COSRHO*SS(K))-CC(K) + *COSRHO/SS(K)) DB(3,J,K) = -SI*RL(J)*SS(K) DO 240 N1 = 1 , 3 DO 230 N2 = 1 , 3 DO 220 N3 = 1 , 3 IF (DB(N1,N2,N3).NE.0.0) THEN IF (N3.EQ.1) AD(N1,N2) = DB(N1,N2,N3) IF (N3.EQ.2) AE(N1,N2) = DB(N1,N2,N3) IF (N3.EQ.3) AF(N1,N2) = DB(N1,N2,N3) END IF 220 CONTINUE 230 CONTINUE 240 CONTINUE RETURN END IF END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** MEASURE_IMG ** C************************** C C SUBROUTINE MEASURE_IMG C INCLUDE 'implicit_none.finc' C C Purpose: Measure centre/spot positions etc. for an image C C Author: John W. Campbell, February 1992 C C Note: Assumes image already displayed C C Arguments: C C None C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'symbol_types.finc' INCLUDE 'meas_spots.finc' INCLUDE 'film_pack.finc' INCLUDE 'ip2_entries.finc' INCLUDE 'file_units.finc' INCLUDE 'upd_flags.finc' C C====== FUNCTION TYPES: C LOGICAL CCPEXS INTEGER XDLSTR INTEGER NXTTOK C C====== LOCALS: C LOGICAL EXISTS LOGICAL CONT LOGICAL CLEAR LOGICAL USE_CEN LOGICAL REPLY LOGICAL CENTRE_READ INTEGER I INTEGER J INTEGER NVIEW INTEGER IVHLIST(2) INTEGER IVHLST2(2) INTEGER IVH INTEGER ITEM INTEGER IQUIT INTEGER IERR INTEGER IFAIL INTEGER IXROOT INTEGER IYROOT INTEGER IXPIX INTEGER IYPIX INTEGER IYN INTEGER LISTE(4) INTEGER M_CENT INTEGER M_CONIC INTEGER M_GCEN INTEGER M_SETCEN INTEGER M_INPUT INTEGER M_READ INTEGER M_WRITE INTEGER M_CLEAR INTEGER M_BG INTEGER M1 INTEGER M2 INTEGER NADD INTEGER NERR INTEGER NVALS INTEGER IFID INTEGER IFLAG INTEGER KPACK INTEGER KPLATE REAL VALUES(20) CHARACTER*80 STR CHARACTER*(MAXFLEN) FILNAM CHARACTER*(MAXFLEN) SPOTS_FILE CHARACTER*25 NAMES(9) CHARACTER*25 QUITNAM CHARACTER*2 VALSTR CHARACTER*2 ERRSTR C LOGICAL EXISTS !File exists flag C LOGICAL CONT !Continue writing file flag C LOGICAL CLEAR !Clear current spots list flag C LOGICAL USE_CEN !Use measured centre from input file flag C LOGICAL REPLY !Reply flag C LOGICAL CENTRE_READ !Centre read from file flag C INTEGER I !Temp/loop variable C INTEGER J !Temp/loop variable C INTEGER NVIEW !Number of view-objects from which data is to be input C INTEGER IVHLIST(2) !View-object handles list for getting events C INTEGER IVHLST2(2) !2'nd view-object handles list for getting events C INTEGER IVH !View-object handle of view-object returning data C INTEGER ITEM !Item number selected from menu C INTEGER IQUIT !Quit box selection flag C INTEGER IERR !Error flag C INTEGER IFAIL !File open failure flag C INTEGER IXROOT !X root position for popup notice C INTEGER IYROOT !Y root position for popup notice C INTEGER IXPIX !Input x pixel position from image C INTEGER IYPIX !Input y pixel position from image C INTEGER IYN !Reply flag from YESNO_NOTICE C INTEGER LISTE(4) !List of parameter table entry numbers for update C INTEGER M_CENT !Menu item number for: Cursor in Centre C INTEGER M_CONIC !Menu item number for: Find Conics Centre C INTEGER M_GCEN !Menu item number for: Gnomonic Centre C INTEGER M_SETCEN !Menu item number for: Reset x_cen_f,y_cen_f,x_c,y_c C INTEGER M_INPUT !Menu item number for: Input Spot Positions C INTEGER M_READ !Menu item number for: Read Spots File C INTEGER M_WRITE !Menu item number for: Write Spots File C INTEGER M_CLEAR !Menu item number for: Clear Spots List C INTEGER M_BG !Menu item number for: Get Background Image C INTEGER M1 !Token start position C INTEGER M2 !Token end position C INTEGER NADD !Number of spots added from input spots file C INTEGER NERR !Number of errors reading spots file C INTEGER NVALS !Number of numerical values in spots file record C INTEGER IFID !Fiducials flag C INTEGER IFLAG !Parameter status flag C INTEGER KPACK !Pack no., 0 = all packs C INTEGER KPLATE !Plate no., 0 = all plates C REAL VALUES(20) !Numerical values from spots file record C CHARACTER*80 STR !Temp character string C CHARACTER*(MAXFLEN) FILNAM !File name as input C CHARACTER*(MAXFLEN) SPOTS_FILE !Spots file name C CHARACTER*25 NAMES(9) !Menu item names C CHARACTER*25 QUITNAM !Quit box label C CHARACTER*2 VALSTR !Parameter value string (dummy) C CHARACTER*2 ERRSTR !Error message string (dummy) DATA NAMES /'Cursor in Centre', + 'Find Conics Centre', + 'Gnomonic Centre', + 'Reset x_cen_f, y_cen_f', + 'Input Spot Positions', + 'Read Spots File', + 'Write Spots File', + 'Clear Spots List', + 'Get Background Image'/ DATA QUITNAM /'Measurement Complete'/ C C------------------------------------------------------------------------------- C C====== Set currently measured film/plate flag & clear spots list if needed C IF (IPLATE.NE.IFILM_SPOTS) THEN NUM_INP_SPOTS = 0 IFILM_SPOTS = IPLATE END IF C C====== Display any spots in current input spots list C IF (NUM_INP_SPOTS.GT.0) THEN DO 10 I = 1, NUM_INP_SPOTS CALL XDLF_IMAGE_SYMBOL (IVH_FILM, + IXINP_SPOTS(I), IYINP_SPOTS(I), + ISYMBTYP(6), ICOLRTYP(6), 1, IERR) 10 CONTINUE END IF C C====== Set up menu C M_CENT = 1 M_CONIC = 2 M_GCEN = 3 M_SETCEN = 4 M_INPUT = 5 M_READ = 6 M_WRITE = 7 M_CLEAR = 8 M_BG = 9 50 CALL XDLF_MENU_AREA_SETMENU (IVH_MENU, 9, XDLSTR(NAMES), 25, + XDLSTR('Measure Image Menu'), 18, + XDLSTR(QUITNAM), 25, 0, IERR) C C====== Set up list of view-object handles C NVIEW = 1 IVHLIST(1) = IVH_MENU C C====== Start event loop C 100 CALL XDLF_GET_EVENTS (NVIEW, IVHLIST, IVH) IF (IVH.EQ.IVH_MENU) THEN C C====== Menu item selected C CALL XDLF_MENU_AREA_GETITEM (IVH_MENU, ITEM, IQUIT) C C====== Quit box selected C IF (IQUIT.EQ.1) RETURN C C====== Cursor in Centre C IF (ITEM.EQ.M_CENT) THEN CALL XDLF_IMAGE_DEL_SYMBOL (IVH_FILM, IXCEN_SPOTS, + IYCEN_SPOTS, ISYMBTYP(5), ICOLRTYP(5), 1, IERR) CALL XDLF_IMAGE_INPUT_MESSAGE (IVH_FILM, + XDLSTR('Input Centre Position'), 21, IERR) IVHLST2(1) = IVH_FILM CALL XDLF_GET_EVENTS (1, IVHLST2, IVH) CALL XDLF_IMAGE_GETPIX (IVH_FILM, IXPIX, IYPIX, IERR) XCEN_SPOTS = IXPIX YCEN_SPOTS = IYPIX IXCEN_SPOTS = IXPIX IYCEN_SPOTS = IYPIX CALL XDLF_IMAGE_SYMBOL (IVH_FILM, IXPIX, IYPIX, + ISYMBTYP(5), ICOLRTYP(5), 1, IERR) GO TO 500 C C====== Find Conics Centre C ELSE IF (ITEM.EQ.M_CONIC) THEN CALL CONIC_CENTRE CALL XDLF_IMAGE_CLEAR_SYMBOLS (IVH_FILM, IERR) IF (NUM_INP_SPOTS.GT.0) THEN DO 60 I = 1, NUM_INP_SPOTS CALL XDLF_IMAGE_SYMBOL (IVH_FILM, + IXINP_SPOTS(I), IYINP_SPOTS(I), + ISYMBTYP(6), ICOLRTYP(6), 1, IERR) 60 CONTINUE END IF CALL XDLF_IMAGE_SYMBOL (IVH_FILM, + IXCEN_SPOTS, IYCEN_SPOTS, + ISYMBTYP(5), ICOLRTYP(5), 1, IERR) GO TO 500 C C====== Gnomonic Centre C ELSE IF (ITEM.EQ.M_GCEN) THEN CALL GNOM_CENTRE CALL XDLF_IMAGE_CLEAR_SYMBOLS (IVH_FILM, IERR) IF (NUM_INP_SPOTS.GT.0) THEN DO 70 I = 1, NUM_INP_SPOTS CALL XDLF_IMAGE_SYMBOL (IVH_FILM, + IXINP_SPOTS(I), IYINP_SPOTS(I), + ISYMBTYP(6), ICOLRTYP(6), 1, IERR) 70 CONTINUE END IF CALL XDLF_IMAGE_SYMBOL (IVH_FILM, + IXCEN_SPOTS, IYCEN_SPOTS, + ISYMBTYP(5), ICOLRTYP(5), 1, IERR) GO TO 500 C C====== Reset x_cen_f, y_cen_f C ELSE IF (ITEM.EQ.M_SETCEN) THEN GO TO 510 C C====== Input spots C ELSE IF (ITEM.EQ.M_INPUT) THEN CALL INPUT_SPOTS GOTO 50 C C====== Read Spots File C ELSE IF (ITEM.EQ.M_READ) THEN CLEAR = .FALSE. USE_CEN = .TRUE. CALL XDLF_VIEW_OBJECT_RAISE (IVH_BASE, IERR) IF (NUM_INP_SPOTS.GT.0) THEN REPLY = .FALSE. CALL IOW_ASKQ (IVH_IOW, 'Add to existing spots list', + REPLY) IF (.NOT.REPLY) THEN CALL IOW_ASKQ (IVH_IOW, 'Overwrite existing spots', + REPLY) IF (.NOT.REPLY) THEN CALL XDLF_VIEW_OBJECT_RAISE (IVH_FILM, IERR) GO TO 100 END IF CLEAR = .TRUE. ELSE USE_CEN = .FALSE. CALL IOW_ASKQ (IVH_IOW, + 'Use measured centre from file',USE_CEN) END IF END IF 102 CALL LPROMPT + (IVH_IOW, 'File name (default ext=.spots): ') IVHLST2(1) = IVH_IOW CALL XDLF_GET_EVENTS (1, IVHLST2, IVH) CALL XDLF_IO_WINDOW_GETSTRING (IVH_IOW, XDLSTR(FILNAM), + MAXFLEN, IERR) IF (FILNAM.EQ.' ') THEN CALL XDLF_VIEW_OBJECT_RAISE(IVH_FILM, IERR) GO TO 100 END IF CALL FILEXT (FILNAM, 'spots', SPOTS_FILE, I) EXISTS = CCPEXS (SPOTS_FILE) IF (.NOT.EXISTS) THEN CALL LMESSAGE(IVH_IOW,'**File not found**') GO TO 102 END IF IFAIL = 1 CALL CCPDPN (-IUN_SPOTS, SPOTS_FILE,'READONLY','F',0,IFAIL) IF (IFAIL.LT.0) THEN CALL LMESSAGE(IVH_IOW,'**Error in opening the file**') GO TO 102 END IF READ (IUN_SPOTS,'(A)',END=104) STR J = 0 IF (NXTTOK (STR, ' ', J, M1, M2).EQ.0) THEN CALL LMESSAGE (IVH_IOW, + '**File does not start with ''spots:'' keyword**') CLOSE (IUN_SPOTS) GO TO 102 END IF CALL CCPUPC(STR) IF (STR(M1:M2).NE.'SPOTS:') THEN CALL LMESSAGE (IVH_IOW, + '**File does not start with ''spots:'' keyword**') CLOSE (IUN_SPOTS) GO TO 102 END IF IF (CLEAR) NUM_INP_SPOTS = 0 NERR = 0 NADD = 0 CENTRE_READ = .FALSE. 103 READ (IUN_SPOTS,'(A)',END=104) STR IF (STR.EQ.' ') GO TO 103 CALL STRVAL (STR, ' =', 20, VALUES, NVALS) IF (NVALS.NE.2) THEN CALL LMESSAGE(IVH_IOW,'**Invalid format in record**') NERR = NERR + 1 GO TO 103 END IF IF (.NOT.CENTRE_READ) THEN IF (USE_CEN) THEN XCEN_SPOTS = VALUES(1) YCEN_SPOTS = VALUES(2) IXCEN_SPOTS = NINT(XCEN_SPOTS) IYCEN_SPOTS = NINT(YCEN_SPOTS) END IF CENTRE_READ = .TRUE. GO TO 103 END IF IF (NUM_INP_SPOTS.GE.MAX_MEAS) THEN CALL LMESSAGE (IVH_IOW,'**Spots list full**') NERR = NERR + 1 GO TO 104 END IF NUM_INP_SPOTS = NUM_INP_SPOTS + 1 XINP_SPOTS(NUM_INP_SPOTS) = VALUES(1) YINP_SPOTS(NUM_INP_SPOTS) = VALUES(2) IXINP_SPOTS(NUM_INP_SPOTS) = NINT(XINP_SPOTS(NUM_INP_SPOTS)) IYINP_SPOTS(NUM_INP_SPOTS) = NINT(YINP_SPOTS(NUM_INP_SPOTS)) NADD = NADD + 1 GO TO 103 104 CLOSE (IUN_SPOTS) STR = 'Number of spots added =' CALL STR_ADDI (STR, NADD, 1) CALL LMESSAGE (IVH_IOW, STR) IF (NERR.GT.0) THEN STR = '**Number of errors =' CALL STR_ADDI (STR, NERR, 1) CALL STR_ADDS (STR,'**',1) CALL LMESSAGE (IVH_IOW, STR) END IF CALL XDLF_IMAGE_CLEAR_SYMBOLS (IVH_FILM, IERR) IF (NUM_INP_SPOTS.GT.0) THEN DO 160 I = 1, NUM_INP_SPOTS CALL XDLF_IMAGE_SYMBOL (IVH_FILM, + IXINP_SPOTS(I), IYINP_SPOTS(I), + ISYMBTYP(6), ICOLRTYP(6), 1, IERR) 160 CONTINUE END IF CALL XDLF_IMAGE_SYMBOL (IVH_FILM, + IXCEN_SPOTS, IYCEN_SPOTS, + ISYMBTYP(5), ICOLRTYP(5), 1, IERR) IF (NERR.EQ.0) CALL XDLF_VIEW_OBJECT_RAISE(IVH_FILM, IERR) GO TO 100 C C====== Write spots file C ELSE IF (ITEM.EQ.M_WRITE) THEN CALL NOTICE_POSN (1,IXROOT,IYROOT) IF (NUM_INP_SPOTS.LE.0) THEN CALL ERR_NOTICE(1,'**No input spots**') GO TO 100 END IF CALL XDLF_VIEW_OBJECT_RAISE (IVH_BASE, IERR) 105 CALL LPROMPT + (IVH_IOW, 'File name (default ext=.spots): ') IVHLST2(1) = IVH_IOW CALL XDLF_GET_EVENTS (1, IVHLST2, IVH) CALL XDLF_IO_WINDOW_GETSTRING (IVH_IOW, XDLSTR(FILNAM), + MAXFLEN, IERR) IF (FILNAM.EQ.' ') THEN CALL XDLF_VIEW_OBJECT_RAISE(IVH_FILM, IERR) GO TO 100 END IF CALL FILEXT (FILNAM, 'spots', SPOTS_FILE, I) CALL LGFILE_EXISTS (SPOTS_FILE, CONT) IF (.NOT.CONT) GO TO 105 IFAIL = 1 CALL CCPDPN (-IUN_SPOTS, SPOTS_FILE,'UNKNOWN','F',0,IFAIL) IF (IFAIL.LT.0) THEN CALL LMESSAGE(IVH_IOW,'**Error in opening the file**') GO TO 105 END IF WRITE (IUN_SPOTS,'(''spots:'')') WRITE (IUN_SPOTS,'(2F9.3)') XCEN_SPOTS, YCEN_SPOTS DO 106 I=1,NUM_INP_SPOTS WRITE (IUN_SPOTS,'(2F8.2)') XINP_SPOTS(I), YINP_SPOTS(I) 106 CONTINUE CLOSE (IUN_SPOTS) CALL XDLF_VIEW_OBJECT_RAISE(IVH_FILM, IERR) GO TO 100 C C====== Clear spots list C ELSE IF (ITEM.EQ.M_CLEAR) THEN NUM_INP_SPOTS = 0 CALL XDLF_IMAGE_CLEAR_SYMBOLS (IVH_FILM, IERR) CALL XDLF_IMAGE_SYMBOL (IVH_FILM, + IXCEN_SPOTS, IYCEN_SPOTS, + ISYMBTYP(5), ICOLRTYP(5), 1, IERR) GO TO 100 C C====== Get Background Image C ELSE IF (ITEM.EQ.M_BG) THEN CALL XDLF_VIEW_OBJECT_RAISE (IVH_BASE, IERR) CALL BG_CALC CALL XDLF_VIEW_OBJECT_RAISE (IVH_FILM, IERR) GO TO 50 END IF END IF GO TO 100 C C====== Updates for centre input options C 500 CALL YESNO_NOTICE (1, + 'Update x_cen_f, y_cenf & zero x_c, y_c ?', + IYN) IF (IYN.EQ.2) GO TO 50 510 CALL OTHERS_UPD (2, UPD_CENT, KPACK, KPLATE) CALL LDM_SET_XCENF (KPACK, KPLATE, XCEN_SPOTS, IERR, ERRSTR) CALL LDM_SET_YCENF (KPACK, KPLATE, YCEN_SPOTS, IERR, ERRSTR) CALL OTHERS_UPD (2, UPD_XCYC, KPACK, KPLATE) CALL LDM_SET_XC (KPACK, KPLATE, 0.0, IERR, ERRSTR) CALL LDM_SET_YC (KPACK, KPLATE, 0.0, IERR, ERRSTR) LISTE(1) = IP_XCENF LISTE(2) = IP_YCENF LISTE(3) = IP_XC LISTE(4) = IP_YC CALL SET_PAR2_VALS (4, LISTE) GO TO 50 END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** MINV_AUT ** C************************** C C SUBROUTINE MINV_AUT(A,AI,ICOD) C INCLUDE 'implicit_none.finc' C C Purpose: Any 3*3 matrix inverter C C Author: C C Arguments: C INTEGER ICOD REAL A(3,3) REAL AI(3,3) C C====== Parameter statements C C C====== GLOBALS: C C C====== FUNCTION TYPES: C C C====== LOCALS: C REAL DET INTEGER I,J C C------------------------------------------------------------------------------- C DET = A(1,1)*A(2,2)*A(3,3) + A(1,2)*A(2,3)*A(3,1) + A(1,3)*A(2,1) + *A(3,2) - A(1,2)*A(2,1)*A(3,3) - A(1,1)*A(2,3)*A(3,2) + - A(1,3)*A(2,2)*A(3,1) IF (ABS(DET).LT.0.2E-20) THEN ICOD = 1 RETURN ELSE ICOD = 0 END IF C C ====== Set and transpose co-factors C AI(1,1) = A(2,2)*A(3,3) - A(3,2)*A(2,3) AI(2,1) = A(2,3)*A(3,1) - A(2,1)*A(3,3) AI(3,1) = A(2,1)*A(3,2) - A(3,1)*A(2,2) AI(1,2) = A(1,3)*A(3,2) - A(1,2)*A(3,3) AI(2,2) = A(1,1)*A(3,3) - A(1,3)*A(3,1) AI(3,2) = A(3,1)*A(1,2) - A(1,1)*A(3,2) AI(1,3) = A(1,2)*A(2,3) - A(2,2)*A(1,3) AI(2,3) = A(1,3)*A(2,1) - A(1,1)*A(2,3) AI(3,3) = A(1,1)*A(2,2) - A(1,2)*A(2,1) DO 40 I = 1 , 3 DO 30 J = 1 , 3 AI(I,J) = AI(I,J)/DET 30 CONTINUE 40 CONTINUE RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** MTZ_CHK1 ** C************************** C C SUBROUTINE MTZ_CHK1 (FILNAM, IRET) C INCLUDE 'implicit_none.finc' C C Purpose: Check for presence of MTZ file & whether can be overwritten if C presence C C Author: John W. Campbell, December 1995 C C Arguments: C CHARACTER*(*) FILNAM INTEGER IRET C C FILNAM (R) Name of file C IRET (W) Return flag = 0 file not present C = 1 file present env. var. CCP4_OPEN is not C set to 'UNKNOWN' C = 2 file present env. var. CCP4_OPEN is set C to 'UNKNOWN' C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR LOGICAL CCPEXS C C====== LOCALS: C CHARACTER*50 STR C CHARACTER*50 STR !String C C------------------------------------------------------------------------------- C IRET = 0 IF (.NOT.CCPEXS(FILNAM)) RETURN IRET = 1 CALL UGTENV ('CCP4_OPEN', STR) CALL CCPUPC (STR) IF (STR.EQ.'UNKNOWN') IRET = 2 RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** MTZ_CHK2 ** C************************** C C SUBROUTINE MTZ_CHK2 (FILNAM, IRET) C INCLUDE 'implicit_none.finc' C C Purpose: See if MTZ o/p file can be opened C C Author: John W. Campbell, December 1995 C C Arguments: C CHARACTER*(*) FILNAM INTEGER IRET C C FILNAM (R) Name of file C IRET (W) Return flag = 0 OK C = 1 Cannot open file C to 'UNKNOWN' C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR C C====== LOCALS: C INTEGER I INTEGER IOS C INTEGER I !Return flag from MTZ_CHK1 C INTEGER IOS !File open status flag C C------------------------------------------------------------------------------- C IRET = 0 CALL MTZ_CHK1 (FILNAM, I) IF (I.EQ.1) THEN IRET = 1 RETURN ELSE IF (I.EQ.0) THEN OPEN (UNIT=21, FILE=FILNAM, STATUS='NEW', IOSTAT=IOS) IF (IOS.GT.0) THEN CLOSE(UNIT=21) IRET = 1 RETURN END IF CLOSE (UNIT=21, STATUS='DELETE') RETURN ELSE IF (I.EQ.2) THEN OPEN (UNIT=21, FILE=FILNAM, STATUS='UNKNOWN', ACCESS='DIRECT', + FORM='UNFORMATTED', RECL=2, IOSTAT=IOS) IF (IOS.GT.0) IRET = 1 CLOSE (UNIT=21) END IF RETURN END C LAST UPDATE: C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C****************************** C** NODAL_INDEX ** C****************************** C C INTEGER FUNCTION NODAL_INDEX (H, K, L) C INCLUDE 'implicit_none.finc' C C Purpose: To calculate the "nodal spot selection index" at which a C nodal would be selected. C C Author: Based on code from GENLAUE by Clifton et al. C C Arguments: C INTEGER H INTEGER K INTEGER L C C H (R) h index C K (R) k index C L (R) l index C C====== FUNCTION TYPES: C INTEGER HCF C C====== LOCALS: C INTEGER HCF1, HCF2 INTEGER H1, K1, L1 INTEGER HI, LO C C------------------------------------------------------------------------------ C H1 = H K1 = K L1 = L HCF1 = HCF(H1,K1) HCF2 = HCF(HCF1,L1) H1 = H1/HCF2 K1 = K1/HCF2 L1 = L1/HCF2 C HI = MAX0(H1,K1,L1) LO = MIN0(H1,K1,L1) NODAL_INDEX = MAX0(HI,-LO) C RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** NOTICE_POSN ** C************************** C C SUBROUTINE NOTICE_POSN (ITYP, IXROOT, IYROOT) C INCLUDE 'implicit_none.finc' C C Purpose: Get screen position for a popup_notice for 'lauegen' C C Author: John W. Campbell, August 1991 C C Arguments: C INTEGER ITYP INTEGER IXROOT INTEGER IYROOT C C ITYP (R) = 0, get default notice position C = 1, get position from last selected menu item C = 2, get position from last selected menu item C on autoindexing solutions menu area C = 3. position on command window C IXROOT (W) Root x position for the notice C IYROOT (W) Root y position for the notice C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' C C====== FUNCTION TYPES: C C C====== LOCALS: C INTEGER IERR C C INTEGER IERR !Error return flag C C------------------------------------------------------------------------------- C C====== Initialise C IXROOT = 0 IYROOT = 0 IF (ITYP.EQ.0) THEN C C====== Default position C CALL XDLF_VIEW_OBJECT_ROOTXY (IVH_IOW, 0, 0, IXROOT, IYROOT, + IERR) RETURN ELSE IF (ITYP.EQ.1) THEN C C====== Last menu item selected position C CALL XDLF_MENU_AREA_GETROOTXY (IVH_MENU, IXROOT, IYROOT) RETURN ELSE IF (ITYP.EQ.2) THEN C C====== Last menu item on autoindexing solutions menu area C CALL XDLF_MENU_AREA_GETROOTXY (IVH_MENU_AUT, IXROOT, IYROOT) RETURN ELSE IF (ITYP.EQ.3) THEN C C====== Position on command window C CALL XDLF_VIEW_OBJECT_ROOTXY (IVH_CMD, 0, 0, IXROOT, IYROOT, + IERR) END IF RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** OTHER_REFPARS ** C************************** C C SUBROUTINE OTHER_REFPARS (IPACK, IPLATE, IFLAG, KFLAG) C INCLUDE 'implicit_none.finc' C C Purpose: Update refined parameters for other packs/plates if required C C Author: John W. Campbell, June 1994 C C Arguments: C INTEGER IPACK INTEGER IPLATE INTEGER IFLAG(*) INTEGER KFLAG(*) C C IPACK (R) Pack number C IPLATE (R) Plate number C IFLAG (R) Parameter refine flags, phis, ctof, x_c, y_c, w_c (see C REFINE_CALC) C KFLAG (R) Parameter refine flags for distortion (see REFINE_CALC) C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' C C====== GLOBALS: C INCLUDE 'upd_flags.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR INTEGER LDM_SPDMAX C C====== LOCALS: C INTEGER KPACK INTEGER KPLATE INTEGER IERR INTEGER KERR INTEGER LFLAG INTEGER ND INTEGER DISTOR_TYPE INTEGER I INTEGER MAX_SPD INTEGER IVAL REAL VALUE(2) REAL VAL CHARACTER*2 ERRSTR CHARACTER*2 VALSTR C INTEGER KPACK !Pack number or 0 for all packs C INTEGER KPLATE !Plate number or 0 for all pates C INTEGER IERR !Error flag C INTEGER KERR !Error flag C INTEGER LFLAG !Parameter status flag C INTEGER ND !No. of decimal places flag C INTEGER DISTOR_TYPE !Distortion type flag C INTEGER I !Temp/loop variable C INTEGER MAX_SPD !Maximum polynomial coefficient C INTEGER IVAL !Integer parameter value C REAL VALUE(2) !Real parameter values array C REAL VAL !Real parameter value C CHARACTER*2 ERRSTR !Error string (dummy) C CHARACTER*2 VALSTR !Parameter value string (dummy) C C------------------------------------------------------------------------------- C C C====== Update LDM C MAX_SPD = LDM_SPDMAX(0) IF (IFLAG(1).EQ.1) THEN CALL LDM_GET_PHIX (IPACK, VAL, LFLAG, ND, IERR, ERRSTR) CALL OTHERS_UPD (1, UPD_PHIS, KPACK, KPLATE) CALL LDM_SET_PHIX (KPACK, VAL, KERR, ERRSTR) END IF IF (IFLAG(2).EQ.1) THEN CALL LDM_GET_PHIY (IPACK, VAL, LFLAG, ND, IERR, ERRSTR) CALL OTHERS_UPD (1, UPD_PHIS, KPACK, KPLATE) CALL LDM_SET_PHIY (KPACK, VAL, KERR, ERRSTR) END IF IF (IFLAG(3).EQ.1) THEN CALL LDM_GET_PHIZ (IPACK, VAL, LFLAG, ND, IERR, ERRSTR) CALL OTHERS_UPD (1, UPD_PHIS, KPACK, KPLATE) CALL LDM_SET_PHIZ (KPACK, VAL, KERR, ERRSTR) END IF IF (IFLAG(4).EQ.1) THEN CALL LDM_GET_CTOF (IPACK, IPLATE, VAL, LFLAG, ND, IERR, ERRSTR) CALL OTHERS_UPD (2, UPD_CTOF, KPACK, KPLATE) CALL LDM_SET_CTOF (KPACK, KPLATE, VAL, KERR, ERRSTR) END IF IF (IFLAG(5).EQ.1) THEN CALL LDM_GET_XC (IPACK, IPLATE, VAL, LFLAG, ND, IERR, ERRSTR) CALL OTHERS_UPD (2, UPD_XCYC, KPACK, KPLATE) CALL LDM_SET_XC (KPACK, KPLATE, VAL, KERR, ERRSTR) END IF IF (IFLAG(6).EQ.1) THEN CALL LDM_GET_YC (IPACK, IPLATE, VAL, LFLAG, ND, IERR, ERRSTR) CALL OTHERS_UPD (2, UPD_XCYC, KPACK, KPLATE) CALL LDM_SET_YC (KPACK, KPLATE, VAL, KERR, ERRSTR) END IF IF (IFLAG(7).EQ.1) THEN CALL LDM_GET_WC (IPACK, IPLATE, VAL, LFLAG, ND, IERR, ERRSTR) CALL OTHERS_UPD (2, UPD_WC, KPACK, KPLATE) CALL LDM_SET_WC (KPACK, KPLATE, VAL, KERR, ERRSTR) END IF CALL LDM_GET_DSTOR (VALSTR, DISTOR_TYPE, LFLAG) IF (DISTOR_TYPE.EQ.1) THEN IF (KFLAG(1).EQ.1) THEN CALL LDM_GET_YSCAL (IPACK, IPLATE, VAL, LFLAG, ND, + IERR, ERRSTR) CALL OTHERS_UPD (2, UPD_YSCAL, KPACK, KPLATE) CALL LDM_SET_YSCAL (KPACK, KPLATE, VAL, KERR, ERRSTR) END IF IF (KFLAG(2).EQ.1) THEN CALL LDM_GET_TWIST (IPACK, IPLATE, VAL, LFLAG, ND, + IERR, ERRSTR) CALL OTHERS_UPD (2, UPD_TT, KPACK, KPLATE) CALL LDM_SET_TWIST (KPACK, KPLATE, VAL, KERR, ERRSTR) END IF IF (KFLAG(3).EQ.1) THEN CALL LDM_GET_TILT (IPACK, IPLATE, VAL, LFLAG, ND, + IERR, ERRSTR) CALL OTHERS_UPD (2, UPD_TT, KPACK, KPLATE) CALL LDM_SET_TILT (KPACK, KPLATE, VAL, KERR, ERRSTR) END IF IF (KFLAG(4).EQ.1) THEN CALL LDM_GET_BULGE (IPACK, IPLATE, VAL, LFLAG, ND, + IERR, ERRSTR) CALL OTHERS_UPD (2, UPD_BULG, KPACK, KPLATE) CALL LDM_SET_BULGE (KPACK, KPLATE, VAL, KERR, ERRSTR) END IF ELSE IF (DISTOR_TYPE.EQ.2) THEN IF (KFLAG(1).EQ.1) THEN CALL LDM_GET_YSCAL (IPACK, IPLATE, VAL, LFLAG, ND, + IERR, ERRSTR) CALL OTHERS_UPD (2, UPD_YSCAL, KPACK, KPLATE) CALL LDM_SET_YSCAL (KPACK, KPLATE, VAL, KERR, ERRSTR) END IF IF (KFLAG(2).EQ.1) THEN CALL LDM_GET_TWIST (IPACK, IPLATE, VAL, LFLAG, ND, + IERR, ERRSTR) CALL OTHERS_UPD (2, UPD_TT, KPACK, KPLATE) CALL LDM_SET_TWIST (KPACK, KPLATE, VAL, KERR, ERRSTR) END IF IF (KFLAG(3).EQ.1) THEN CALL LDM_GET_TILT (IPACK, IPLATE, VAL, LFLAG, ND, + IERR, ERRSTR) CALL OTHERS_UPD (2, UPD_TT, KPACK, KPLATE) CALL LDM_SET_TILT (KPACK, KPLATE, VAL, KERR, ERRSTR) END IF IF (KFLAG(4).EQ.1) THEN CALL LDM_GET_ROFF (IPACK, IPLATE, VAL, LFLAG, ND, + IERR, ERRSTR) CALL OTHERS_UPD (2, UPD_RTOFF, KPACK, KPLATE) CALL LDM_SET_ROFF (KPACK, KPLATE, VAL, KERR, ERRSTR) END IF IF (KFLAG(5).EQ.1) THEN CALL LDM_GET_TOFF (IPACK, IPLATE, VAL, LFLAG, ND, + IERR, ERRSTR) CALL OTHERS_UPD (2, UPD_RTOFF, KPACK, KPLATE) CALL LDM_SET_TOFF (KPACK, KPLATE, VAL, KERR, ERRSTR) END IF ELSE IF (DISTOR_TYPE.EQ.3) THEN IF (KFLAG(1).EQ.1) THEN CALL LDM_GET_YSCAL (IPACK, IPLATE, VAL, LFLAG, ND, + IERR, ERRSTR) CALL OTHERS_UPD (2, UPD_YSCAL, KPACK, KPLATE) CALL LDM_SET_YSCAL (KPACK, KPLATE, VAL, KERR, ERRSTR) END IF IF (KFLAG(2).EQ.1) THEN CALL LDM_GET_TWIST (IPACK, IPLATE, VAL, LFLAG, ND, + IERR, ERRSTR) CALL OTHERS_UPD (2, UPD_TT, KPACK, KPLATE) CALL LDM_SET_TWIST (KPACK, KPLATE, VAL, KERR, ERRSTR) END IF IF (KFLAG(3).EQ.1) THEN CALL LDM_GET_TILT (IPACK, IPLATE, VAL, LFLAG, ND, + IERR, ERRSTR) CALL OTHERS_UPD (2, UPD_TT, KPACK, KPLATE) CALL LDM_SET_TILT (KPACK, KPLATE, VAL, KERR, ERRSTR) END IF IF (KFLAG(4).EQ.1) THEN CALL LDM_GET_SPDXY (IPACK, IPLATE, VAL, LFLAG, ND, + IERR, ERRSTR) CALL OTHERS_UPD (2, UPD_SPD, KPACK, KPLATE) CALL LDM_SET_SPDXY (KPACK, KPLATE, VAL, KERR, ERRSTR) END IF IF (KFLAG(5).EQ.1) THEN CALL OTHERS_UPD (2, UPD_SPD, KPACK, KPLATE) CALL LDM_GET_SPDXN (IPACK, IPLATE, IVAL, LFLAG, + IERR, ERRSTR) CALL LDM_SET_SPDXN (KPACK, KPLATE, IVAL, KERR, ERRSTR) CALL LDM_GET_SXMIN (IPACK, IPLATE, VAL, LFLAG, ND, + IERR, ERRSTR) CALL LDM_SET_SXMIN (KPACK, KPLATE, VAL, KERR, ERRSTR) CALL LDM_GET_SXMAX (IPACK, IPLATE, VAL, LFLAG, ND, + IERR, ERRSTR) CALL LDM_SET_SXMAX (KPACK, KPLATE, VAL, KERR, ERRSTR) DO 100 I = 1, MAX_SPD CALL LDM_GET_SPDX (I, IPACK, IPLATE, VALUE, LFLAG, ND, + KERR, ERRSTR) CALL LDM_SET_SPDX (I, KPACK, KPLATE, VALUE, + KERR, ERRSTR) 100 CONTINUE END IF IF (KFLAG(6).EQ.1) THEN CALL OTHERS_UPD (2, UPD_SPD, KPACK, KPLATE) CALL LDM_GET_SPDYN (IPACK, IPLATE, IVAL, LFLAG, + IERR, ERRSTR) CALL LDM_SET_SPDYN (KPACK, KPLATE, IVAL, KERR, ERRSTR) CALL LDM_GET_SYMIN (IPACK, IPLATE, VAL, LFLAG, ND, + IERR, ERRSTR) CALL LDM_SET_SYMIN (KPACK, KPLATE, VAL, KERR, ERRSTR) CALL LDM_GET_SYMAX (IPACK, IPLATE, VAL, LFLAG, ND, + IERR, ERRSTR) CALL LDM_SET_SYMAX (KPACK, KPLATE, VAL, KERR, ERRSTR) DO 110 I = 1, MAX_SPD CALL LDM_GET_SPDY (I, IPACK, IPLATE, VALUE, LFLAG, ND, + KERR, ERRSTR) CALL LDM_SET_SPDY (I, KPACK, KPLATE, VALUE, + KERR, ERRSTR) 110 CONTINUE END IF END IF RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** OTHERS_UPD ** C************************** C C SUBROUTINE OTHERS_UPD (ITYP, UPD_FLAG, KPACK, KPLATE) C INCLUDE 'implicit_none.finc' C C Purpose: Set global pack/plate update flags for parameter updates C as appropriate C C Author: John W. Campbell, June 1994 C C Arguments: C INTEGER ITYP LOGICAL UPD_FLAG INTEGER KPACK INTEGER KPLATE C C ITYP (R) Parameter class =1 pack based parameter (soft limits, phis) C =2 plate based parameter C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'film_pack.finc' INCLUDE 'upd_flags.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR C C====== LOCALS: C INTEGER KEYPLATE INTEGER IFLAG INTEGER IERR CHARACTER*2 ERRSTR C INTEGER KEYPLATE !Key plate C INTEGER IFLAG !Parameter status flag C INTEGER IERR !Error flag C CHARACTER*2 ERRSTR !Error string flag (dummy) C C------------------------------------------------------------------------------- C KPACK = IPACK KPLATE = IPLATE IF (.NOT.UPD_FLAG) RETURN CALL LDM_GET_KEYP (IPACK, KEYPLATE, IFLAG, IERR, ERRSTR) IF (ITYP.EQ.1) THEN IF (IPACK.EQ.1) KPACK = 0 ELSE IF (IPLATE.EQ.KEYPLATE) THEN KPLATE = 0 IF (IPACK.EQ.1) KPACK = 0 END IF END IF RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C******************************* C** PARFIL_ERR ** C******************************* C C SUBROUTINE PARFIL_ERR (ERRSTR, ERRSTR2) C INCLUDE 'implicit_none.finc' C C Purpose: Handle command line read/write LDM parameters files errors errors C C Author: John W. Campbell, January 1996 C C Arguments: C CHARACTER*(*) ERRSTR CHARACTER*(*) ERRSTR2 C C Parameters: C C ERRSTR c (R) Error string (max 80 chars) C ERRSTR2 c (R) Subsidiary error string - may be blank (max 80 C chars) C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'prog_flags.finc' INCLUDE 'file_units.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR INTEGER LENSTR C C====== LOCALS: C CHARACTER*120 STR C LOGICAL EOF !End of file flag C C------------------------------------------------------------------------------- C C C====== Write message to log file if required C IF (IUN_LOG.GT.0) THEN WRITE (IUN_LOG,6010) ERRSTR(1:LENSTR(ERRSTR)) IF (ERRSTR2.NE.' ') WRITE (IUN_LOG,6010) + ERRSTR2(1:LENSTR(ERRSTR2)) END IF C C====== Output message etc. depending on program mode C IF (LG_MODE.EQ.1) THEN STR = '**Error**' CALL STR_ADDS (STR, ERRSTR, 1) CALL LMESSAGE (IVH_CMD, STR) IF (ERRSTR2.NE.' ') THEN STR = '**Error**' CALL STR_ADDS (STR, ERRSTR2, 1) CALL LMESSAGE (IVH_CMD, STR) END IF RETURN ELSE IF (LG_MODE.EQ.2) THEN STR = '**Error**' CALL STR_ADDS (STR, ERRSTR, 1) CALL TWRITE (STR) IF (ERRSTR2.NE.' ') THEN STR = '**Error**' CALL STR_ADDS (STR, ERRSTR2, 1) CALL TWRITE (STR) END IF RETURN END IF RETURN C C====== Format statements C 6000 FORMAT (A) 6010 FORMAT ('**Error** ',A) END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** PAR1_INPUT ** C************************** C C SUBROUTINE PAR1_INPUT C INCLUDE 'implicit_none.finc' C C Purpose: Handle parameter table 1 input C C Author: John W. Campbell, May 1991 C C Arguments: C C None C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' INCLUDE 'screen_params.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'ip1_entries.finc' INCLUDE 'film_pack.finc' INCLUDE 'prog_flags.finc' INCLUDE 'cell_input.finc' INCLUDE 'process_omit.finc' INCLUDE 'upd_flags.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR INTEGER LENSTR INTEGER INTFP C C====== LOCALS: C INTEGER I INTEGER ITEM INTEGER IERR INTEGER LISTE(3) INTEGER KPACK INTEGER KPLATE INTEGER IVAL INTEGER IFLAG INTEGER IPACK_SAV INTEGER IPLATE_SAV INTEGER ITYP INTEGER IV INTEGER ND REAL FP CHARACTER*(MAX_PSCROLL_CHARS) PVAL CHARACTER*80 ERRSTR CHARACTER*2 VALSTR C INTEGER I !Temp/loop variable C INTEGER ITEM !Returned parameter table item number C INTEGER IERR !Error flag C INTEGER LISTE(3) !List of changed parameters array C INTEGER KPACK !Pack number or 0 for all packs C INTEGER KPLATE !Plate number or 0 for all plates C INTEGER IVAL !Integer parameter value C INTEGER IFLAG !Parameter status flag C INTEGER IPACK_SAV !Saves current pack value C INTEGER IPLATE_SAV !Saves current plate value C INTEGER ITYP !Type of number flag C INTEGER IV !Integer value C INTEGER ND !No. of decimal places flag C REAL FP !Real value C CHARACTER*(MAX_PSCROLL_CHARS) PVAL !Returned parameter value string C CHARACTER*80 ERRSTR !Error string C CHARACTER*2 VALSTR !Dummy value string C C------------------------------------------------------------------------------- C C====== Find item number and value C CALL XDLF_PARAM_TABLE_GETVALUE (IVH_PAR1, ITEM, XDLSTR(PVAL), + MAX_PSCROLL_CHARS, IERR) IF (PVAL.EQ.' ') THEN CALL XDLF_PARAM_TABLE_ERROR (IVH_PAR1, ITEM, + XDLSTR('**Value must be given**'), 23, IERR) RETURN END IF C C====== See if value may be changed currently C IF (PROCESS) THEN DO 10 I = 1, NOMITP IF (ITEM.EQ.IP_OMIT(I)) THEN CALL XDLF_PARAM_TABLE_ERROR (IVH_PAR1, ITEM, + XDLSTR('**Cannot change in process mode**'), + 33, IERR) RETURN END IF 10 CONTINUE END IF C C====== Interpret and check validity of the value C C C====== Pack and plate number C IF (ITEM.EQ.IP_PACK) THEN IPACK_SAV = IPACK IPLATE_SAV = IPLATE IF (PVAL(1:1).EQ.'+') THEN IPACK = IPACK + 1 CALL LDM_GET_NUMP (IVAL, IFLAG) IF (IPACK.GT.IVAL) IPACK = IVAL IF (IPACK.LT.1) IPACK = 1 ELSE IF (PVAL(1:1).EQ.'-') THEN IPACK = IPACK - 1 IF (IPACK.LT.1) IPACK = 1 ELSE ITYP = INTFP (PVAL, FP, IV) IF (ITYP.EQ.0.OR.ITYP.EQ.2) THEN CALL XDLF_PARAM_TABLE_ERROR (IVH_PAR1, ITEM, + XDLSTR('**Invalid value syntax**'), 24, IERR) RETURN END IF IF (IV.LE.0) THEN CALL XDLF_PARAM_TABLE_ERROR (IVH_PAR1, ITEM, + XDLSTR('**Value must be greater than zero**'), 35, IERR) RETURN END IF IPACK = IV CALL LDM_GET_NUMP (IVAL, IFLAG) IF (IPACK.GT.IVAL) IPACK = IVAL IF (IPACK.LT.1) IPACK = 1 END IF IF (IPACK.NE.IPACK_SAV) THEN IPLATE = 1 CALL SET_PAR1_VALS (0, LISTE) CALL SET_PAR2_VALS (0, LISTE) ELSE LISTE(1) = IP_PACK CALL SET_PAR1_VALS (1, LISTE) END IF ELSE IF (ITEM.EQ.IP_PLATE) THEN IPLATE_SAV = IPLATE IF (PVAL(1:1).EQ.'+') THEN IPLATE = IPLATE + 1 CALL LDM_GET_NPLAT (IVAL, IFLAG) IF (IPLATE.GT.IVAL) IPLATE = IVAL IF (IPLATE.LT.1) IPLATE = 1 ELSE IF (PVAL(1:1).EQ.'-') THEN IPLATE = IPLATE - 1 IF (IPLATE.LT.1) IPLATE = 1 ELSE ITYP = INTFP (PVAL, FP, IV) IF (ITYP.EQ.0.OR.ITYP.EQ.2) THEN CALL XDLF_PARAM_TABLE_ERROR (IVH_PAR1, ITEM, + XDLSTR('**Invalid value syntax**'), 24, IERR) RETURN END IF IF (IV.LE.0) THEN CALL XDLF_PARAM_TABLE_ERROR (IVH_PAR1, ITEM, + XDLSTR('**Value must be greater than zero**'), 35, IERR) RETURN END IF IPLATE = IV CALL LDM_GET_NPLAT (IVAL, IFLAG) IF (IPLATE.GT.IVAL) IPLATE = IVAL IF (IPLATE.LT.1) IPLATE = 1 END IF LISTE(1) = IP_PLATE CALL SET_PAR1_VALS (1, LISTE) IF (IPLATE.NE.IPLATE_SAV) CALL SET_PAR2_VALS (0, LISTE) C C====== Crystal system or Lattice type C ELSE IF (ITEM.EQ.IP_SYST) THEN CALL LDM_SET ('SYSTEM', IPACK, IPLATE, PVAL, IERR, ERRSTR) IF (IERR.NE.0) GO TO 800 CALL LDM_SET_A (CELL_INPUT(1), IERR, ERRSTR) CALL LDM_SET_B (CELL_INPUT(2), IERR, ERRSTR) CALL LDM_SET_C (CELL_INPUT(3), IERR, ERRSTR) CALL LDM_SET_ALPHA (CELL_INPUT(4), IERR, ERRSTR) CALL LDM_SET_BETA (CELL_INPUT(5), IERR, ERRSTR) CALL LDM_SET_GAMMA (CELL_INPUT(6), IERR, ERRSTR) CALL RESET_CELL LISTE(1) = IP_SYST CALL SET_PAR1_VALS (1, LISTE) ELSE IF (ITEM.EQ.IP_LATT) THEN CALL LDM_SET ('LATTICE', IPACK, IPLATE, PVAL, IERR, ERRSTR) IF (IERR.NE.0) GO TO 800 LISTE(1) = IP_LATT CALL SET_PAR1_VALS (1, LISTE) C C====== Symmetry C ELSE IF (ITEM.EQ.IP_SYMM) THEN CALL XDLF_PARAM_TABLE_ERROR (IVH_PAR1, ITEM, + XDLSTR('**Use command window to change symmetry**'), + 41, IERR) RETURN C C====== Setting axes C ELSE IF (ITEM.EQ.IP_ROT) THEN CALL LDM_SET ('ROTATION_AXIS', IPACK, IPLATE, PVAL, + IERR, ERRSTR) IF (IERR.NE.0) GO TO 800 LISTE(1) = IP_ROT CALL SET_PAR1_VALS (1, LISTE) ELSE IF (ITEM.EQ.IP_BEAM) THEN CALL LDM_SET ('BEAM_AXIS', IPACK, IPLATE, PVAL, IERR, ERRSTR) IF (IERR.NE.0) GO TO 800 LISTE(1) = IP_BEAM CALL SET_PAR1_VALS (1, LISTE) C C====== Pack id C ELSE IF (ITEM.EQ.IP_PACKID) THEN CALL LDM_SET ('PACK_ID', IPACK, IPLATE, PVAL, + IERR, ERRSTR) IF (IERR.NE.0) GO TO 800 LISTE(1) = IP_PACKID CALL SET_PAR1_VALS (1, LISTE) CALL SET_PAR2_VALS (0, LISTE) C C====== Spindle C ELSE IF (ITEM.EQ.IP_SPINDL) THEN CALL LDM_SET ('SPINDLE', IPACK, IPLATE, PVAL, IERR, ERRSTR) IF (IERR.NE.0) GO TO 800 LISTE(1) = IP_SPINDL CALL SET_PAR1_VALS (1, LISTE) C C====== Cell Parameters C ELSE IF (ITEM.EQ.IP_A) THEN CALL LDM_SET ('A', IPACK, IPLATE, PVAL, IERR, ERRSTR) IF (IERR.NE.0) GO TO 800 CALL LDM_GET_A (CELL_INPUT(1), IFLAG, ND) CALL RESET_CELL LISTE(1) = IP_A CALL SET_PAR1_VALS (1, LISTE) ELSE IF (ITEM.EQ.IP_B) THEN CALL LDM_SET ('B', IPACK, IPLATE, PVAL, IERR, ERRSTR) IF (IERR.NE.0) GO TO 800 CALL LDM_GET_B (CELL_INPUT(2), IFLAG, ND) CALL RESET_CELL LISTE(1) = IP_B CALL SET_PAR1_VALS (1, LISTE) ELSE IF (ITEM.EQ.IP_C) THEN CALL LDM_SET ('C', IPACK, IPLATE, PVAL, IERR, ERRSTR) IF (IERR.NE.0) GO TO 800 CALL LDM_GET_C (CELL_INPUT(3), IFLAG, ND) CALL RESET_CELL LISTE(1) = IP_C CALL SET_PAR1_VALS (1, LISTE) ELSE IF (ITEM.EQ.IP_ALPH) THEN CALL LDM_SET ('ALPHA', IPACK, IPLATE, PVAL, IERR, ERRSTR) IF (IERR.NE.0) GO TO 800 CALL LDM_GET_ALPHA (CELL_INPUT(4), IFLAG, ND) CALL RESET_CELL LISTE(1) = IP_ALPH CALL SET_PAR1_VALS (1, LISTE) ELSE IF (ITEM.EQ.IP_BETA) THEN CALL LDM_SET ('BETA', IPACK, IPLATE, PVAL, IERR, ERRSTR) IF (IERR.NE.0) GO TO 800 CALL LDM_GET_BETA (CELL_INPUT(5), IFLAG, ND) CALL RESET_CELL LISTE(1) = IP_BETA CALL SET_PAR1_VALS (1, LISTE) ELSE IF (ITEM.EQ.IP_GAMM) THEN CALL LDM_SET ('GAMMA', IPACK, IPLATE, PVAL, IERR, ERRSTR) IF (IERR.NE.0) GO TO 800 CALL LDM_GET_GAMMA (CELL_INPUT(6), IFLAG, ND) CALL RESET_CELL LISTE(1) = IP_GAMM CALL SET_PAR1_VALS (1, LISTE) C C====== Soft Limits C ELSE IF (ITEM.EQ.IP_WMIN) THEN CALL OTHERS_UPD (1, UPD_LAMS, KPACK, KPLATE) CALL LDM_SET ('LMIN', KPACK, IPLATE, PVAL, IERR, ERRSTR) IF (IERR.NE.0) GO TO 800 LISTE(1) = IP_WMIN CALL SET_PAR1_VALS (1, LISTE) ELSE IF (ITEM.EQ.IP_WMAX) THEN CALL OTHERS_UPD (1, UPD_LAMS, KPACK, KPLATE) CALL LDM_SET ('LMAX', KPACK, IPLATE, PVAL, IERR, ERRSTR) IF (IERR.NE.0) GO TO 800 LISTE(1) = IP_WMAX CALL SET_PAR1_VALS (1, LISTE) ELSE IF (ITEM.EQ.IP_DMIN) THEN CALL OTHERS_UPD (1, UPD_DMIN, KPACK, KPLATE) CALL LDM_SET ('DMIN', KPACK, IPLATE, PVAL, IERR, ERRSTR) IF (IERR.NE.0) GO TO 800 LISTE(1) = IP_DMIN CALL SET_PAR1_VALS (1, LISTE) C C====== Setting Phi's C ELSE IF (ITEM.EQ.IP_PHIX) THEN CALL OTHERS_UPD (1, UPD_PHIS, KPACK, KPLATE) CALL LDM_SET ('PHIX', KPACK, IPLATE, PVAL, IERR, ERRSTR) IF (IERR.NE.0) GO TO 800 LISTE(1) = IP_PHIX CALL SET_PAR1_VALS (1, LISTE) ELSE IF (ITEM.EQ.IP_PHIY) THEN CALL OTHERS_UPD (1, UPD_PHIS, KPACK, KPLATE) CALL LDM_SET ('PHIY', KPACK, IPLATE, PVAL, IERR, ERRSTR) IF (IERR.NE.0) GO TO 800 LISTE(1) = IP_PHIY CALL SET_PAR1_VALS (1, LISTE) ELSE IF (ITEM.EQ.IP_PHIZ) THEN CALL OTHERS_UPD (1, UPD_PHIS, KPACK, KPLATE) CALL LDM_SET ('PHIZ', KPACK, IPLATE, PVAL, IERR, ERRSTR) IF (IERR.NE.0) GO TO 800 LISTE(1) = IP_PHIZ CALL SET_PAR1_VALS (1, LISTE) C C====== Image type C ELSE IF (ITEM.EQ.IP_IMTYP) THEN CALL LDM_SET ('IMAGE_TYPE', IPACK, IPLATE, PVAL, + IERR, ERRSTR) IF (IERR.NE.0) GO TO 800 LISTE(1) = IP_IMTYP CALL SET_PAR1_VALS (1, LISTE) FILM_READ = .FALSE. C C====== Image data type C ELSE IF (ITEM.EQ.IP_IMDAT) THEN CALL LDM_SET ('IMAGE_DATA', IPACK, IPLATE, PVAL, + IERR, ERRSTR) IF (IERR.NE.0) GO TO 800 LISTE(1) = IP_IMDAT CALL SET_PAR1_VALS (1, LISTE) FILM_READ = .FALSE. C C====== Number of packs and plates C ELSE IF (ITEM.EQ.IP_NUMP) THEN CALL LDM_SET ('NUMPACK', IPACK, IPLATE, PVAL, + IERR, ERRSTR) IF (IERR.NE.0) GO TO 800 IPACK = 1 IPLATE = 1 CALL SET_PAR1_VALS (0, LISTE) CALL SET_PAR2_VALS (0, LISTE) ELSE IF (ITEM.EQ.IP_NPLAT) THEN CALL LDM_SET ('NPLATES', IPACK, IPLATE, PVAL, + IERR, ERRSTR) IF (IERR.NE.0) GO TO 800 IPACK = 1 IPLATE = 1 CALL SET_PAR1_VALS (0, LISTE) CALL SET_PAR2_VALS (0, LISTE) C C====== Fiducials option C ELSE IF (ITEM.EQ.IP_FIDT) THEN CALL LDM_SET ('FIDTYPE', IPACK, IPLATE, PVAL, IERR, ERRSTR) IF (IERR.NE.0) GO TO 800 CALL LDM_GET_FIDT (VALSTR, IVAL, IFLAG) IF (IVAL.EQ.1) CALL EDIT_FIDS LISTE(1) = IP_FIDT CALL SET_PAR1_VALS (1, LISTE) C C====== Distortion type C ELSE IF (ITEM.EQ.IP_DISTOR) THEN CALL LDM_SET ('DISTORTION_TYPE', IPACK, IPLATE, PVAL, + IERR, ERRSTR) IF (IERR.NE.0) GO TO 800 LISTE(1) = IP_DISTOR CALL SET_PAR1_VALS (1, LISTE) C C====== Detector geometry C ELSE IF (ITEM.EQ.IP_DGEOM) THEN CALL LDM_SET ('DGEOM', IPACK, IPLATE, PVAL, + IERR, ERRSTR) IF (IERR.NE.0) GO TO 800 LISTE(1) = IP_DGEOM CALL SET_PAR1_VALS (1, LISTE) C C====== Detector tilt C ELSE IF (ITEM.EQ.IP_DTILT) THEN CALL LDM_SET ('DTILT', IPACK, IPLATE, PVAL, + IERR, ERRSTR) IF (IERR.NE.0) GO TO 800 LISTE(1) = IP_DTILT CALL SET_PAR1_VALS (1, LISTE) C C====== Spot epsilon C ELSE IF (ITEM.EQ.IP_EPS) THEN CALL LDM_SET ('SPOT_EPSILON', IPACK, IPLATE, PVAL, + IERR, ERRSTR) IF (IERR.NE.0) GO TO 800 LISTE(1) = IP_EPS CALL SET_PAR1_VALS (1, LISTE) C C====== Thresholds C ELSE IF (ITEM.EQ.IP_STHR) THEN CALL LDM_SET ('STHRESH', IPACK, IPLATE, PVAL, + IERR, ERRSTR) IF (IERR.NE.0) GO TO 800 LISTE(1) = IP_STHR CALL SET_PAR1_VALS (1, LISTE) ELSE IF (ITEM.EQ.IP_OVPIX) THEN CALL LDM_SET ('OVERLOAD_PIXEL', IPACK, IPLATE, PVAL, + IERR, ERRSTR) IF (IERR.NE.0) GO TO 800 LISTE(1) = IP_OVPIX CALL SET_PAR1_VALS (1, LISTE) C C====== Template for file names C ELSE IF (ITEM.EQ.IP_TEMPL) THEN CALL LDM_SET ('TEMPLATE', IPACK, IPLATE, PVAL, + IERR, ERRSTR) IF (IERR.NE.0) GO TO 800 LISTE(1) = IP_TEMPL CALL SET_PAR1_VALS (1, LISTE) CALL SET_PAR2_VALS (0, LISTE) FILM_READ = .FALSE. FILM_OPEN = .FALSE. IPACK_OPN = 0 IPLATE_OPN = 0 C C====== Raster parameters C ELSE IF (ITEM.EQ.IP_NXRAST) THEN CALL LDM_SET ('NXRAST', IPACK, IPLATE, PVAL, IERR, ERRSTR) IF (IERR.NE.0) GO TO 800 LISTE(1) = IP_NXRAST CALL SET_PAR1_VALS (1, LISTE) FILM_READ = .FALSE. ELSE IF (ITEM.EQ.IP_NYRAST) THEN CALL LDM_SET ('NYRAST', IPACK, IPLATE, PVAL, IERR, ERRSTR) IF (IERR.NE.0) GO TO 800 LISTE(1) = IP_NYRAST CALL SET_PAR1_VALS (1, LISTE) FILM_READ = .FALSE. ELSE IF (ITEM.EQ.IP_RAST) THEN CALL LDM_SET ('RASTER_SIZE', IPACK, IPLATE, PVAL, + IERR, ERRSTR) IF (IERR.NE.0) GO TO 800 LISTE(1) = IP_RAST CALL SET_PAR1_VALS (1, LISTE) C C====== Axis order C ELSE IF (ITEM.EQ.IP_AXORD) THEN CALL LDM_SET ('AXORD', IPACK, IPLATE, PVAL, IERR, ERRSTR) IF (IERR.NE.0) GO TO 800 LISTE(1) = IP_AXORD CALL SET_PAR1_VALS (1, LISTE) FILM_READ = .FALSE. C C====== Film radii C ELSE IF (ITEM.EQ.IP_RMIN) THEN CALL LDM_SET ('RMIN', IPACK, IPLATE, PVAL, IERR, ERRSTR) IF (IERR.NE.0) GO TO 800 LISTE(1) = IP_RMIN CALL SET_PAR1_VALS (1, LISTE) ELSE IF (ITEM.EQ.IP_RMAX) THEN CALL LDM_SET ('RMAX', IPACK, IPLATE, PVAL, IERR, ERRSTR) IF (IERR.NE.0) GO TO 800 LISTE(1) = IP_RMAX CALL SET_PAR1_VALS (1, LISTE) C C====== XY Limits C ELSE IF (ITEM.EQ.IP_XLOW) THEN CALL LDM_SET ('XLOW', IPACK, IPLATE, PVAL, IERR, ERRSTR) IF (IERR.NE.0) GO TO 800 LISTE(1) = IP_XLOW CALL SET_PAR1_VALS (1, LISTE) ELSE IF (ITEM.EQ.IP_XHIGH) THEN CALL LDM_SET ('XHIGH', IPACK, IPLATE, PVAL, IERR, ERRSTR) IF (IERR.NE.0) GO TO 800 LISTE(1) = IP_XHIGH CALL SET_PAR1_VALS (1, LISTE) ELSE IF (ITEM.EQ.IP_YLOW) THEN CALL LDM_SET ('YLOW', IPACK, IPLATE, PVAL, IERR, ERRSTR) IF (IERR.NE.0) GO TO 800 LISTE(1) = IP_YLOW CALL SET_PAR1_VALS (1, LISTE) ELSE IF (ITEM.EQ.IP_YHIGH) THEN CALL LDM_SET ('YHIGH', IPACK, IPLATE, PVAL, IERR, ERRSTR) IF (IERR.NE.0) GO TO 800 LISTE(1) = IP_YHIGH CALL SET_PAR1_VALS (1, LISTE) END IF RETURN C C====== Error Conditions C 800 CALL XDLF_PARAM_TABLE_ERROR (IVH_PAR1, ITEM, + XDLSTR(ERRSTR), LENSTR(ERRSTR), IERR) RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** PAR2_INPUT ** C************************** C C SUBROUTINE PAR2_INPUT C INCLUDE 'implicit_none.finc' C C Purpose: Handle parameter table 2 input C C Author: John W. Campbell, May 1991 C C Arguments: C C None C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' INCLUDE 'screen_params.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'ip2_entries.finc' INCLUDE 'film_pack.finc' INCLUDE 'prog_flags.finc' INCLUDE 'upd_flags.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR INTEGER LENSTR C C====== LOCALS: C INTEGER I INTEGER ITEM INTEGER IERR INTEGER IVAL INTEGER IFLAG INTEGER LISTE(3) INTEGER KPACK INTEGER KPLATE INTEGER DISTOR_TYPE CHARACTER*(MAX_P2SCROLL_CHARS) PVAL CHARACTER*80 ERRSTR CHARACTER*2 VALSTR C INTEGER I !Temp/loop variable C INTEGER ITEM !Returned parameter table item number C INTEGER IERR !Error flag C INTEGER IVAL !Integer parameter value C INTEGER IFLAG !Parameter status flag C INTEGER LISTE(3) !List of changed parameters array C INTEGER KPACK !Pack number or 0=all C INTEGER KPLATE !Plate number or 0=all C INTEGER DISTOR_TYPE !Distortion type flag C CHARACTER*(MAX_P2SCROLL_CHARS) PVAL !Returned parameter value string C CHARACTER*80 ERRSTR !Error string C CHARACTER*2 VALSTR !Value string (dummy) C C C------------------------------------------------------------------------------- C C====== Get current distortion type C CALL LDM_GET_DSTOR (VALSTR, DISTOR_TYPE, IFLAG) C C====== Find item number and value C CALL XDLF_PARAM_TABLE_GETVALUE (IVH_PAR2, ITEM, XDLSTR(PVAL), + MAX_P2SCROLL_CHARS, IERR) IF (PVAL.EQ.' ') THEN CALL XDLF_PARAM_TABLE_ERROR (IVH_PAR2, ITEM, + XDLSTR('**Value must be given**'), 23, IERR) RETURN END IF C C====== Interpret and check validity of the value C C C====== Filename C IF (ITEM.EQ.IP_FNAM) THEN CALL LDM_SET ('FILENAME', IPACK, IPLATE, PVAL, IERR, ERRSTR) IF (IERR.NE.0) GO TO 800 LISTE(1) = IP_FNAM CALL SET_PAR2_VALS (1, LISTE) FILM_READ = .FALSE. FILM_OPEN = .FALSE. IPACK_OPN = 0 IPLATE_OPN = 0 C C====== Crystal to film distance C ELSE IF (ITEM.EQ.IP_CTOF) THEN CALL OTHERS_UPD (2, UPD_CTOF, KPACK, KPLATE) CALL LDM_SET ('CTOF', KPACK, KPLATE, PVAL, IERR, ERRSTR) IF (IERR.NE.0) GO TO 800 LISTE(1) = IP_CTOF CALL SET_PAR2_VALS (1, LISTE) C C====== x_cen_f, y_cen_f C ELSE IF (ITEM.EQ.IP_XCENF) THEN CALL OTHERS_UPD (2, UPD_CENT, KPACK, KPLATE) CALL LDM_SET ('X_CEN_F', KPACK, KPLATE, PVAL, IERR, ERRSTR) IF (IERR.NE.0) GO TO 800 LISTE(1) = IP_XCENF CALL SET_PAR2_VALS (1, LISTE) ELSE IF (ITEM.EQ.IP_YCENF) THEN CALL OTHERS_UPD (2, UPD_CENT, KPACK, KPLATE) CALL LDM_SET ('Y_CEN_F', KPACK, KPLATE, PVAL, IERR, ERRSTR) IF (IERR.NE.0) GO TO 800 LISTE(1) = IP_YCENF CALL SET_PAR2_VALS (1, LISTE) C C====== Centre offsets C ELSE IF (ITEM.EQ.IP_XC) THEN CALL OTHERS_UPD (2, UPD_XCYC, KPACK, KPLATE) CALL LDM_SET ('X_C', KPACK, KPLATE, PVAL, IERR, ERRSTR) IF (IERR.NE.0) GO TO 800 LISTE(1) = IP_XC CALL SET_PAR2_VALS (1, LISTE) ELSE IF (ITEM.EQ.IP_YC) THEN CALL OTHERS_UPD (2, UPD_XCYC, KPACK, KPLATE) CALL LDM_SET ('Y_C', KPACK, KPLATE, PVAL, IERR, ERRSTR) IF (IERR.NE.0) GO TO 800 LISTE(1) = IP_YC CALL SET_PAR2_VALS (1, LISTE) ELSE IF (ITEM.EQ.IP_WC) THEN CALL OTHERS_UPD (2, UPD_WC, KPACK, KPLATE) CALL LDM_SET ('W_C', KPACK, KPLATE, PVAL, IERR, ERRSTR) IF (IERR.NE.0) GO TO 800 LISTE(1) = IP_WC CALL SET_PAR2_VALS (1, LISTE) C C====== Raster scaling parameter C ELSE IF (ITEM.EQ.IP_YSCAL) THEN CALL OTHERS_UPD (2, UPD_YSCAL, KPACK, KPLATE) CALL LDM_SET ('Y_SCALE', KPACK, KPLATE, PVAL, IERR, ERRSTR) IF (IERR.NE.0) GO TO 800 LISTE(1) = IP_YSCAL CALL SET_PAR2_VALS (1, LISTE) C C====== Distortion offsets C ELSE IF (ITEM.EQ.IP_TWIST) THEN CALL OTHERS_UPD (2, UPD_TT, KPACK, KPLATE) CALL LDM_SET ('TWIST', KPACK, KPLATE, PVAL, IERR, ERRSTR) IF (IERR.NE.0) GO TO 800 LISTE(1) = IP_TWIST CALL SET_PAR2_VALS (1, LISTE) ELSE IF (ITEM.EQ.IP_TILT) THEN CALL OTHERS_UPD (2, UPD_TT, KPACK, KPLATE) CALL LDM_SET ('TILT', KPACK, KPLATE, PVAL, IERR, ERRSTR) IF (IERR.NE.0) GO TO 800 LISTE(1) = IP_TILT CALL SET_PAR2_VALS (1, LISTE) ELSE IF (ITEM.EQ.IP_BULGE.AND.DISTOR_TYPE.EQ.1) THEN CALL OTHERS_UPD (2, UPD_BULG, KPACK, KPLATE) CALL LDM_SET ('BULGE', KPACK, KPLATE, PVAL, IERR, ERRSTR) IF (IERR.NE.0) GO TO 800 LISTE(1) = IP_BULGE CALL SET_PAR2_VALS (1, LISTE) ELSE IF (ITEM.EQ.IP_ROFF.AND.DISTOR_TYPE.EQ.2) THEN CALL OTHERS_UPD (2, UPD_RTOFF, KPACK, KPLATE) CALL LDM_SET ('ROFF', KPACK, KPLATE, PVAL, IERR, ERRSTR) IF (IERR.NE.0) GO TO 800 LISTE(1) = IP_ROFF CALL SET_PAR2_VALS (1, LISTE) ELSE IF (ITEM.EQ.IP_TOFF.AND.DISTOR_TYPE.EQ.2) THEN CALL OTHERS_UPD (2, UPD_RTOFF, KPACK, KPLATE) CALL LDM_SET ('TOFF', KPACK, KPLATE, PVAL, IERR, ERRSTR) IF (IERR.NE.0) GO TO 800 LISTE(1) = IP_TOFF CALL SET_PAR2_VALS (1, LISTE) ELSE IF (ITEM.EQ.IP_SPDXY.AND.DISTOR_TYPE.EQ.3) THEN CALL OTHERS_UPD (2, UPD_SPD, KPACK, KPLATE) CALL LDM_SET ('SPDXY', KPACK, KPLATE, PVAL, IERR, ERRSTR) IF (IERR.NE.0) GO TO 800 LISTE(1) = IP_SPDXY CALL SET_PAR2_VALS (1, LISTE) ELSE IF (ITEM.EQ.IP_SPDX.AND.DISTOR_TYPE.EQ.3) THEN CALL CCPUPC(PVAL) IF (PVAL.EQ.'EDIT') THEN LISTE(1) = IP_SPDX CALL SET_PAR2_VALS (1, LISTE) CALL EDIT_SPD () ELSE CALL OTHERS_UPD (2, UPD_SPD, KPACK, KPLATE) CALL LDM_SET ('SPDX_N', KPACK, KPLATE, PVAL, + IERR, ERRSTR) IF (IERR.NE.0) GO TO 800 LISTE(1) = IP_SPDX CALL SET_PAR2_VALS (1, LISTE) END IF ELSE IF (ITEM.EQ.IP_SPDY.AND.DISTOR_TYPE.EQ.3) THEN CALL CCPUPC(PVAL) IF (PVAL.EQ.'EDIT') THEN LISTE(1) = IP_SPDY CALL SET_PAR2_VALS (1, LISTE) CALL EDIT_SPD () ELSE CALL OTHERS_UPD (2, UPD_SPD, KPACK, KPLATE) CALL LDM_SET ('SPDY_N', KPACK, KPLATE, PVAL, + IERR, ERRSTR) IF (IERR.NE.0) GO TO 800 LISTE(1) = IP_SPDY CALL SET_PAR2_VALS (1, LISTE) END IF C C====== Spot size/overlap parameters C ELSE IF (ITEM.EQ.IP_STRK_L) THEN CALL OTHERS_UPD (2, UPD_SPOT, KPACK, KPLATE) CALL LDM_SET ('SPOT_LENGTH', KPACK, KPLATE, PVAL, + IERR, ERRSTR) IF (IERR.NE.0) GO TO 800 LISTE(1) = IP_STRK_L CALL SET_PAR2_VALS (1, LISTE) ELSE IF (ITEM.EQ.IP_STRK_W) THEN CALL OTHERS_UPD (2, UPD_SPOT, KPACK, KPLATE) CALL LDM_SET ('SPOT_WIDTH', KPACK, KPLATE, PVAL, + IERR, ERRSTR) IF (IERR.NE.0) GO TO 800 LISTE(1) = IP_STRK_W CALL SET_PAR2_VALS (1, LISTE) ELSE IF (ITEM.EQ.IP_STRK_F) THEN CALL OTHERS_UPD (2, UPD_SPOT, KPACK, KPLATE) CALL LDM_SET ('SPOT_FACTOR', KPACK, KPLATE, PVAL, + IERR, ERRSTR) IF (IERR.NE.0) GO TO 800 LISTE(1) = IP_STRK_F CALL SET_PAR2_VALS (1, LISTE) ELSE IF (ITEM.EQ.IP_STRK_BW) THEN CALL OTHERS_UPD (2, UPD_SPOT, KPACK, KPLATE) CALL LDM_SET ('SPOT_BORDER', KPACK, KPLATE, PVAL, + IERR, ERRSTR) IF (IERR.NE.0) GO TO 800 LISTE(1) = IP_STRK_BW CALL SET_PAR2_VALS (1, LISTE) ELSE IF (ITEM.EQ.IP_DELTA) THEN CALL OTHERS_UPD (2, UPD_SPOT, KPACK, KPLATE) CALL LDM_SET ('SPOT_DELTA', KPACK, KPLATE, PVAL, + IERR, ERRSTR) IF (IERR.NE.0) GO TO 800 LISTE(1) = IP_DELTA CALL SET_PAR2_VALS (1, LISTE) ELSE IF (ITEM.EQ.IP_RFL) THEN CALL LDM_SET ('RFL', IPACK, IPLATE, PVAL, + IERR, ERRSTR) IF (IERR.NE.0) GO TO 800 LISTE(1) = IP_RFL CALL SET_PAR2_VALS (1, LISTE) END IF RETURN C C====== General Error Conditions C 800 CALL XDLF_PARAM_TABLE_ERROR (IVH_PAR2, ITEM, + XDLSTR(ERRSTR), LENSTR(ERRSTR), IERR) RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** PAR_CHK ** C************************** C C SUBROUTINE PAR_CHK (KEYWORD, OK) C INCLUDE 'implicit_none.finc' C C Purpose: Check which LDM parameters may currently be updated (and C indicate which if any cell parameters updated) C C Author: John W. Campbell, October 1993 C C Arguments: C CHARACTER*(*) KEYWORD LOGICAL OK C C KEYWORD (R) LDM parameter name (full) C OK (W) Return .TRUE. if update OK else return .FALSE. C C====== Parameter statements C C C====== GLOBALS: C INCLUDE 'prog_flags.finc' INCLUDE 'view_handles.finc' INCLUDE 'cell_input.finc' INCLUDE 'process_omit.finc' C C====== FUNCTION TYPES: C C C====== LOCALS: C INTEGER I CHARACTER*80 STR C INTEGER I !Temp/loop variable C CHARACTER*80 STR !Message string C C------------------------------------------------------------------------------- C OK = .TRUE. C C====== Set cell change flags C IF (KEYWORD.EQ.'SYSTEM') SYST_CH = .TRUE. IF (KEYWORD.EQ.'A') CELL_CH(1) = .TRUE. IF (KEYWORD.EQ.'B') CELL_CH(2) = .TRUE. IF (KEYWORD.EQ.'C') CELL_CH(3) = .TRUE. IF (KEYWORD.EQ.'ALPHA') CELL_CH(4) = .TRUE. IF (KEYWORD.EQ.'BETA') CELL_CH(5) = .TRUE. IF (KEYWORD.EQ.'GAMMA') CELL_CH(6) = .TRUE. C C====== Disable certain parameter changes when 'PROCESS = .TRUE.' C IF (.NOT.PROCESS) RETURN DO 100 I = 1, NOMITK IF (KEYWORD.EQ.OMIT(I)) THEN STR = '**Error** Cannot change' CALL STR_ADDS (STR, KEYWORD, 1) CALL STR_ADDS (STR, 'in process mode', 1) CALL CMD_MSG (IVH_CMD, STR) OK = .FALSE. RETURN END IF 100 CONTINUE RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** PLOT_DIFF ** C************************** C C SUBROUTINE PLOT_DIFF C INCLUDE 'implicit_none.finc' C C Purpose: Plot difference map C C Author: John W. Campbell, Jan 1992 C C Arguments: C C None C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' INCLUDE 'screen_params.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'prog_flags.finc' INCLUDE 'spot_box.finc' INCLUDE 'image.finc' INCLUDE 'lauegen_observed_spots.finc' INCLUDE 'refine_params.finc' INCLUDE 'file_units.finc' INCLUDE 'spot_data.finc' INCLUDE 'film_pack.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR C C====== LOCALS: C INTEGER I INTEGER IERR INTEGER IBUTTON INTEGER H INTEGER K INTEGER L INTEGER IXPIX INTEGER IYPIX INTEGER ISPIX INTEGER IFPIX INTEGER IX2PIX INTEGER IY2PIX INTEGER IXSIZ INTEGER IYSIZ INTEGER ITHRESH INTEGER IBG INTEGER NOVER INTEGER IVH INTEGER IVHLIST(2) INTEGER ITEM INTEGER IQUIT INTEGER MAGUPD INTEGER IFLAG INTEGER ND INTEGER NXRAST INTEGER NYRAST INTEGER IORD INTEGER ISWAP INTEGER IFTYPE REAL SPOTL REAL SPOTW REAL SPOTB REAL X_C REAL Y_C REAL XFD REAL YFD REAL MM_RAST_X REAL MM_RAST_Y REAL DX REAL DY REAL X_CEN_F REAL Y_CEN_F REAL X_CEN REAL Y_CEN REAL OMEGA REAL XM REAL YM REAL CGX REAL CGY REAL SPOT_B REAL STHRESH REAL DEG_TO_RAD REAL COSOM REAL SINOM REAL ORIENT(3,3) REAL AMAT(3,3) REAL DELTA CHARACTER*20 NAMES(2) CHARACTER*2 VALSTR CHARACTER*2 ERRSTR C INTEGER I !Temp/loop variable C INTEGER IERR !Error flag C INTEGER IBUTTON !Button return from pop-up notice C INTEGER H !Reflection h index C INTEGER K !Reflection k index C INTEGER L !Reflection l index C INTEGER IXPIX !Nearest x pixel position of observed spot C INTEGER IYPIX !Nearest y pixel position of observed spot C INTEGER ISPIX !Pixel position along slow axis C INTEGER IFPIX !Pixel position along fast axis C INTEGER IX2PIX !X end of vector for difference vector C INTEGER IY2PIX !Y end of vector for difference vector C INTEGER IXSIZ !Half box x size for finding spot C INTEGER IYSIZ !Half box y size for finding spot C INTEGER ITHRESH !Threshold above background for finding spots C INTEGER IBG !Background value at spot position C INTEGER NOVER !No. of pixels in box above threshold C INTEGER IVH !View-object handle returned from XDLF_GET_EVENTS C INTEGER IVHLIST(2) !List of view-object handles for getting events C INTEGER ITEM !Menu item number selected C INTEGER IQUIT !Menu selection quit flag C INTEGER MAGUPD !Update magnifying window 1=yes, 0=no C INTEGER IFLAG !Parameter status flag C INTEGER ND !Number of decimal places flag C INTEGER NXRAST !No. x-rasters C INTEGER NYRAST !No. y-rasters C INTEGER IORD !Data order flag C INTEGER ISWAP !Byte swap flag C INTEGER IFTYPE !Image file type C REAL SPOTL !Spot length C REAL SPOTW !Spot width C REAL SPOTB !Spot border C REAL X_C !x_c value (mm) C REAL Y_C !y_c value (mm) C REAL XFD !X coordinate on detector (rast) (distort. corrected) C REAL YFD !Y coordinate on detector (rast) (distort. corrected) C REAL MM_RAST_X !Conversion mm to x-rasters C REAL MM_RAST_Y !Conversion mm to y-rasters C REAL DX !X offset for difference vector C REAL DY !Y offset for difference vector C REAL X_CEN_F !Uncorrected x centre in rasters C REAL Y_CEN_F !Uncorrected y-centre in rasters C REAL X_CEN !Corrected x centre in rasters C REAL Y_CEN !Corrected y centre in rasters C REAL OMEGA !Corrected omega in degrees C REAL XM !Calculated x position of spot in rasters C REAL YM !Calculated y position of spot in rasters C REAL CGX !Found spot c_of_g x position C REAL CGY !Found spot c_of_g y position C REAL SPOT_B !Box size for normal or radially masked spots (mm) C REAL STHRESH !Spot search threshold C REAL DEG_TO_RAD !Conversion factor degrees to radians C REAL COSOM !cos(omega) C REAL SINOM !sin(omega) C REAL ORIENT(3,3) !Orientation matrix C REAL AMAT(3,3) !'A' matrix C REAL DELTA !Spot separation delta C CHARACTER*20 NAMES(2) !Item names for menu C CHARACTER*2 VALSTR !Parameter value string (dummy) C CHARACTER*2 ERRSTR !Error string (dummy) C DATA NAMES/'Continue',' '/ DATA DEG_TO_RAD/0.0174533/ C C------------------------------------------------------------------------------- C C====== Get centre C CALL LDM_MMRAST (IPACK, IPLATE, MM_RAST_X, MM_RAST_Y) CALL LDM_GET_NXRAS (NXRAST, IFLAG) CALL LDM_GET_NYRAS (NYRAST, IFLAG) CALL LDM_GET_AXORD (VALSTR, IORD, ISWAP, IFLAG) IF (ISWAP.EQ.2) IORD = - IORD CALL LDM_GET_IMDAT (VALSTR, IFTYPE, IFLAG) IF (IFTYPE.EQ.1) THEN ITYPE = 1 ELSE IF (IFTYPE.EQ.2) THEN ITYPE = 2 ELSE IF (IFTYPE.EQ.3) THEN ITYPE = 4 ELSE IF (IFTYPE.EQ.4) THEN ITYPE = 2 END IF CALL LDM_GET_STHR (STHRESH, IFLAG, ND) CALL LDM_GET_SPOTD (IPACK, IPLATE, DELTA, IFLAG, ND, + IERR, ERRSTR) CALL LRL_MK_ORIENT (ORIENT) CALL LRL_A_CALC (IPACK, ORIENT, AMAT) CALL CHK_OPN(IERR) IF (IERR.NE.0) RETURN CALL FILM_CENTRE(X_CEN_F,Y_CEN_F,OMEGA) CALL LDM_GET_XC (IPACK, IPLATE, X_C, IFLAG, ND, IERR, ERRSTR) CALL LDM_GET_YC (IPACK, IPLATE, Y_C, IFLAG, ND, IERR, ERRSTR) X_CEN = X_CEN_F + X_C*MM_RAST_X Y_CEN = Y_CEN_F + Y_C*MM_RAST_Y COSOM = COS(OMEGA*DEG_TO_RAD) SINOM = SIN(OMEGA*DEG_TO_RAD) C C====== Display image C CALL SHOW_IMAGE (1, IERR) IF (IERR.EQ.1) RETURN C C====== Get box size for normal or radially streaked spots C CALL LDM_GET_SPOTW (IPACK, IPLATE, SPOTW, IFLAG, ND, + IERR, ERRSTR) IF (SPOTW.NE.0.0) THEN CALL LDM_GET_SPOTL (IPACK, IPLATE, SPOTL, IFLAG, ND, + IERR, ERRSTR) CALL LDM_GET_SPOTB (IPACK, IPLATE, SPOTB, IFLAG, ND, + IERR, ERRSTR) SPOT_B = SPOTL + (2.0 + SPOTB)/MM_RAST_X ELSE SPOT_B = SPOTBOX END IF IXSIZ = NINT(SPOT_B*MM_RAST_X/2.0) IF (IXSIZ.LE.0) IXSIZ = 1 IYSIZ = NINT(SPOT_B*MM_RAST_Y/2.0) IF (IYSIZ.LE.0) IYSIZ = 1 C C====== Get calculated positions & distance errors C MAGUPD = 0 DO 200 I = 1,NUM_REF_SPOTS H = NODAL_H_S(I) K = NODAL_K_S(I) L = NODAL_L_S(I) CALL LRL_CALC_POS(IPACK,IPLATE,X_CEN,Y_CEN,COSOM,SINOM, + AMAT,H,K,L,XFD,YFD,IERR) IXPIX = NINT(XM_OBS(I)) IYPIX = NINT(YM_OBS(I)) CALL SFPIX (IXPIX,IYPIX,ISPIX,IFPIX) CALL XDLF_BG_VALIMG(ISPIX,IFPIX,IMG_BG,ITYPE,NF_BGOFF, + NCMP,IBG, IERR) ITHRESH = IBG + NINT(STHRESH) IF (SPOTW.NE.0.0) THEN CALL SPOT_RADIAL (IXPIX, IYPIX, IXSIZ, IYSIZ, ISPOT_DATA, + ISWORK, ITHRESH, IMG, ITYPE, IORD, + NFRASTS, NXRAST, NYRAST, + X_CEN, Y_CEN, NOVER, + CGX, CGY, IERR) ELSE CALL SPOT_C_OF_G (IXPIX, IYPIX, IXSIZ, IYSIZ, ISPOT_DATA, + ISWORK, ITHRESH, IMG, ITYPE, IORD, NFRASTS, + NXRAST, NYRAST, NOVER, + CGX, CGY, IERR) END IF IF (NOVER.EQ.0.OR.IERR.GT.0) THEN CALL XDLF_IMAGE_SYMBOL(IVH_FILM,IXPIX,IYPIX, + 24,1,1,IERR) ELSE C C====== See if still near old spot on film C IF ( ((CGX-XM_OBS(I))/MM_RAST_X)**2 + + ((CGY-YM_OBS(I))/MM_RAST_Y)**2 + .GT. DELTA**2) THEN CALL XDLF_IMAGE_SYMBOL(IVH_FILM,IXPIX,IYPIX, + 24,1,1,IERR) ELSE CALL XDLF_IMAGE_SYMBOL(IVH_FILM,IXPIX,IYPIX, + 22,5,1,IERR) END IF END IF C C====== Exaggerate vector by a factor of 25 C DX = 25.0*(XFD-XM_OBS(I)) DY = 25.0*(YFD-YM_OBS(I)) IX2PIX = NINT (XM_OBS(I)+DX) IY2PIX = NINT (YM_OBS(I)+DY) IF (I.EQ.NUM_REF_SPOTS) MAGUPD = 1 CALL XDLF_IMAGE_VECT(IVH_FILM,1,IXPIX,IYPIX, + IX2PIX,IY2PIX,5,1,MAGUPD,IERR) 200 CONTINUE C C===== Get continue command from menu C CALL XDLF_MENU_AREA_SETMENU (IVH_MENU, 1, XDLSTR(NAMES), 20, + XDLSTR(' '), -1, XDLSTR(' '), -1, 0, IERR) IVHLIST(1) = IVH_MENU CALL XDLF_GET_EVENTS(1, IVHLIST, IVH) CALL XDLF_MENU_AREA_GETITEM(IVH_MENU, ITEM, IQUIT) CALL XDLF_IMAGE_SETTINGS (IVH_FILM, MINTHR, MAXTHR, + MONO_THR, ICONTRAST, ICOLOR_OPT, IOVLY_OPT, IBG_OPT, + MAG_OPT, ISHOW_INT, IERR) CALL XDLF_DELETE_VIEW_OBJECT(IVH_FILM, IERR) RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C**************************** C** PLOT_SYMBS ** C**************************** C C SUBROUTINE PLOT_SYMBS (IDISP, IMS) C INCLUDE 'implicit_none.finc' C C Purpose: Display symbols (predicted and matched) for matching option C or (predicted and selected) for select reflections option or C predicted positions only C C Author: John W. Campbell, July 1991 C C Arguments: C INTEGER IDISP INTEGER IMS C C IDISP (R) =0 display all reflns, =1 display selected nodals C IMS (R) flag =1 match option C =2 select reflections option C =3 predicted reflections only C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'selrefs.finc' INCLUDE 'matches.finc' INCLUDE 'symbol_types.finc' INCLUDE 'film_pack.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR INTEGER LENSTR C C====== LOCALS: C LOGICAL SPAT LOGICAL NODFLG LOGICAL NODAL CHARACTER*80 STR INTEGER I INTEGER II INTEGER J INTEGER IERR INTEGER NOUT INTEGER IXPIX_TEMP(MAX_DISP) INTEGER IYPIX_TEMP(MAX_DISP) INTEGER ISYMB_TEMP(MAX_DISP) INTEGER ICOLR_TEMP(MAX_DISP) INTEGER IOVLY_TEMP(MAX_DISP) INTEGER JH, JK, JL INTEGER MULT INTEGER ISPOT INTEGER NUMSPOTS REAL ALAM REAL DTHR2 REAL XFD REAL YFD C LOGICAL SPAT !Spatial overlap flag C LOGICAL NODFLG !Nodal spot flag C LOGICAL NODAL !Nodal spot flag C CHARACTER*80 STR !Character string for messages C INTEGER I !Temp/loop variable C INTEGER II !Temp/loop variable C INTEGER J !Temp/loop variable C INTEGER IERR !Error return flag C INTEGER NOUT !No. of symbols to output C INTEGER IXPIX_TEMP(MAX_DISP) !Temp array of symbol x pixels positions C INTEGER IYPIX_TEMP(MAX_DISP) !Temp array of symbol y pixels positions C INTEGER ISYMB_TEMP(MAX_DISP) !Temp array of symbol types C INTEGER ICOLR_TEMP(MAX_DISP) !Temp array of symbol colours C INTEGER IOVLY_TEMP(MAX_DISP) !Temp array of overlay types C INTEGER JH, JK, JL !Reflection indices (predicted) C INTEGER MULT !Multiplicity C INTEGER ISPOT !Pointer to spot in LRL list C INTEGER NUMSPOTS !No. of spots in generated spots list C REAL ALAM !Lambda C REAL DTHR2 !dmin-threshol**2 C REAL XFD !Predicted x position on detector C REAL YFD !Predicted y position on detector C C------------------------------------------------------------------------------- C C====== Display predicted positions C CALL LRL_NUMSPOTS (NUMSPOTS) NUM_DISP = 0 IF (IDISP.EQ.0) THEN IF (NUMSPOTS.LE.0) THEN CALL ERR_NOTICE(0,'**No predicted spots**') RETURN END IF NUM_DISP = NUMSPOTS ELSE IF (NUM_SELECT.LE.0) THEN CALL ERR_NOTICE(0,'**No selected reflections**') RETURN END IF NUM_DISP = NUM_SELECT END IF NOUT = 0 DO 50 I=1,NUM_DISP IF (IDISP.EQ.0) THEN NODAL = .FALSE. ISPOT = I CALL LRL_GET (ISPOT, JH, JK, JL, XFD, YFD, ALAM, + DTHR2, MULT, NODFLG, SPAT, IERR) NODAL = NODFLG ELSE ISPOT = SEL_REFS(I) CALL LRL_GET (ISPOT, JH, JK, JL, XFD, YFD, ALAM, + DTHR2, MULT, NODFLG, SPAT, IERR) NODAL = .TRUE. END IF IREF_DISP(I)=ISPOT IXPIX_DISP(I)=NINT(XFD) IYPIX_DISP(I)=NINT(YFD) ISYMB_DISP(I)=1 IF (NODAL) ISYMB_DISP(I)=2 IF (IMS.NE.3.AND.NUM_MATCH.GT.0) THEN DO 10 II=1,NUM_MATCH IF (IREF_MATCH(II).EQ.ISPOT) GO TO 50 10 CONTINUE END IF NOUT = NOUT + 1 IXPIX_TEMP(NOUT) = IXPIX_DISP(I) IYPIX_TEMP(NOUT) = IYPIX_DISP(I) ISYMB_TEMP(NOUT) = ISYMBTYP(ISYMB_DISP(I)) ICOLR_TEMP(NOUT) = ICOLRTYP(ISYMB_DISP(I)) IOVLY_TEMP(NOUT) = 1 50 CONTINUE IF (NOUT.GT.0) THEN CALL XDLF_IMAGE_SYMBOLS(IVH_FILM,NOUT, + IXPIX_TEMP, IYPIX_TEMP, + ISYMB_TEMP,ICOLR_TEMP,IOVLY_TEMP,0, + IERR) IF (IERR.GT.0) THEN STR = '**Error code' CALL STR_ADDI(STR,IERR,1) CALL STR_ADDS(STR,'from xdl_view symbol plot routine**',1) CALL ERR_NOTICE(0,STR) RETURN END IF END IF IF (IMS.EQ.3) RETURN IF (NUM_MATCH.GT.0) THEN IF (NUM_MATCH.LT.10) THEN DO 100 I=1,NUM_MATCH CALL XDLF_IMAGE_SYMBOL(IVH_FILM, + IXPIX_MATCH(I), IYPIX_MATCH(I), + ISYMBTYP(3),ICOLRTYP(3), + 1, IERR) IF (IERR.GT.0) THEN STR = '**Error code' CALL STR_ADDI(STR,IERR,1) CALL STR_ADDS(STR, + 'from xdl_view symbol plot routine**',1) CALL ERR_NOTICE(0,STR) RETURN END IF IF (IMS.EQ.1) THEN CALL XDLF_IMAGE_SYMBOL(IVH_FILM, + IXSP_MATCH(I), IYSP_MATCH(I), + ISYMBTYP(4),ICOLRTYP(4), + 2, IERR) IF (IERR.GT.0) THEN STR = '**Error code' CALL STR_ADDI(STR,IERR,1) CALL STR_ADDS(STR, + 'from xdl_view symbol plot routine**',1) CALL ERR_NOTICE(0,STR) RETURN END IF END IF 100 CONTINUE ELSE CALL XDLF_IMAGE_SYMBOLS(IVH_FILM,NUM_MATCH, + IXPIX_MATCH, IYPIX_MATCH, + ISYMBTYP(3),ICOLRTYP(3),1,1, + IERR) IF (IERR.GT.0) THEN STR = '**Error code' CALL STR_ADDI(STR,IERR,1) CALL STR_ADDS(STR, + 'from xdl_view symbols plot routine**',1) CALL ERR_NOTICE(0,STR) RETURN END IF IF (IMS.EQ.1) THEN CALL XDLF_IMAGE_SYMBOLS(IVH_FILM,NUM_MATCH, + IXSP_MATCH, IYSP_MATCH, + ISYMBTYP(4),ICOLRTYP(4),2,1, + IERR) IF (IERR.GT.0) THEN STR = '**Error code' CALL STR_ADDI(STR,IERR,1) CALL STR_ADDS(STR, + 'from xdl_view symbols plot routine**',1) CALL ERR_NOTICE(0,STR) RETURN END IF END IF END IF END IF RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C**************************** C** PREPARE_REFIN ** C**************************** C C SUBROUTINE PREPARE_REFIN (IQUIT) C INCLUDE 'implicit_none.finc' C C Purpose: Some preparations before refinement C 1) Select no. of refinement spots to be used C 2) Calculate RMS deviation C 3) Display pre-refinement difference vectors C C Author: John W. Campbell, August 1991 C C Arguments: C INTEGER IQUIT C C IQUIT (W) Returns 0=OK, =1 error (quit refinement) C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' INCLUDE 'screen_params.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'prog_flags.finc' INCLUDE 'lauegen_observed_spots.finc' INCLUDE 'file_units.finc' INCLUDE 'refine_params.finc' INCLUDE 'image.finc' INCLUDE 'film_pack.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR C C====== LOCALS: C LOGICAL DIFFPL INTEGER I INTEGER IXROOT INTEGER IYROOT INTEGER IERR INTEGER IBUTTON INTEGER J INTEGER H INTEGER K INTEGER L INTEGER IXPIX INTEGER IYPIX INTEGER IX2PIX INTEGER IY2PIX INTEGER IVH INTEGER IVHLIST(2) INTEGER ITEM INTEGER MAGUPD INTEGER IFLAG INTEGER ND REAL SUMSQ REAL DIST2 REAL DX REAL DY REAL X_CEN_F REAL Y_CEN_F REAL X_CEN REAL Y_CEN REAL OMEGA REAL ORIENT(3,3) REAL AMAT(3,3) REAL DELTA REAL X_C REAL Y_C REAL XFD REAL YFD REAL COSOM REAL SINOM REAL MM_RAST_X REAL MM_RAST_Y CHARACTER*80 STR CHARACTER*20 NAMES(2) CHARACTER*2 ERRSTR C C LOGICAL DIFFPL !Difference plot required flag C INTEGER I !Temp/loop variable C INTEGER IXROOT !Root x position for view-object C INTEGER IYROOT !Root y position for view-object C INTEGER IERR !Error flag C INTEGER IBUTTON !Button return from pop-up notice C INTEGER J !Pointer to current reflection C INTEGER H !Reflection h index C INTEGER K !Reflection k index C INTEGER L !Reflection l index C INTEGER IXPIX !Nearest x pixel position of observed spot C INTEGER IYPIX !Nearest y pixel position of observed spot C INTEGER IX2PIX !X end of vector for difference vector C INTEGER IY2PIX !Y end of vector for difference vector C INTEGER IVH !View-object handle returned from XDLF_GET_EVENTS C INTEGER IVHLIST(2) !List of view-object handles for getting events C INTEGER ITEM !Menu item number selected C INTEGER MAGUPD !Update magnifying window 1=yes, 0=no C INTEGER IFLAG !Parameter status flag C INTEGER ND !No. of decimal places flag C REAL SUMSQ !Sum of square of obs-calc position differences C REAL DIST2 !Square of obs-calc distance C REAL DX !X offset for difference vector C REAL DY !Y offset for difference vector C REAL X_CEN_F !Uncorrected x centre in rasters C REAL Y_CEN_F !Uncorrected y-centre in rasters C REAL X_CEN !Corrected x centre in rasters C REAL Y_CEN !Corrected y centre in rasters C REAL OMEGA !Corrected omega in degrees C REAL ORIENT(3,3) !Orientation matrix C REAL AMAT(3,3) !'A' matrix C REAL DELTA !Spot separation delta C REAL X_C !x_c value (mm) C REAL Y_C !y_c value (mm) C REAL XFD !X coordinate on detector (rast) (distort. corrected) C REAL YFD !Y coordinate on detector (rast) (distort. corrected) C REAL COSOM !cos(omega) C REAL SINOM !sin(omega) C REAL MM_RAST_X !Conversion mm to x-rasters C REAL MM_RAST_Y !Conversion mm to y-rasters C CHARACTER*80 STR !Temporary o/p message string C CHARACTER*20 NAMES(2) !Item names for menu C CHARACTER*2 ERRSTR !Error string (dummy) C DATA NAMES/'Continue Refinement',' '/ C C------------------------------------------------------------------------------- C DOUBLE PRECISION COSD, SIND EXTERNAL COSD, SIND CALL LDM_MMRAST (IPACK, IPLATE, MM_RAST_X, MM_RAST_Y) CALL LRL_MK_ORIENT (ORIENT) CALL LRL_A_CALC (IPACK, ORIENT, AMAT) CALL LDM_GET_SPOTD (IPACK, IPLATE, DELTA, IFLAG, ND, + IERR, ERRSTR) C C====== Get no. of spots to use in refinement C IF (NUM_OBS.EQ.0) THEN CALL XDLF_VIEW_OBJECT_ROOTXY(IVH_IOW, 0, 0, IXROOT, IYROOT, + IERR) CALL XDLF_POPUP_NOTICE (IXROOT, IYROOT, + XDLSTR('**No spots in refinement list**'), 31, + XDLSTR(' '), -1, XDLSTR('Continue'), 8, + XDLSTR(' '), -1, IFONT, 0, IBUTTON) IQUIT = 1 RETURN END IF 50 NUM_REF_SPOTS = NUM_OBS CALL IOW_ASKI (IVH_IOW, 'Number of spots to use in refinement', + NUM_REF_SPOTS) IF (NUM_REF_SPOTS.LE.0) THEN CALL XDLF_IO_WINDOW_ROOTXY (IVH_IOW, IXROOT, IYROOT, IERR) CALL XDLF_POPUP_NOTICE (IXROOT, IYROOT, + XDLSTR('**Value must be greater than 0**'), 32, + XDLSTR(' '), -1, XDLSTR('Continue'), 8, + XDLSTR(' '), -1, IFONT, 1, IBUTTON) GO TO 50 END IF NUM_REF_SPOTS = MIN(NUM_REF_SPOTS,NUM_OBS) C C====== Index reflections on hkl_key C CALL INDXIV(HKL_KEY,NUM_OBS,REF_NODALS) CALL LFN_CLROBS DO 60 I = 1, NUM_OBS J = REF_NODALS(I) CALL LFN_ADDOBS (NODAL_H_S(J), NODAL_K_S(J), NODAL_L_S(J), + XM_OBS(J), YM_OBS(J), IERR) IF (IERR.GT.0) THEN CALL XDLF_POPUP_NOTICE (IXROOT, IYROOT, + XDLSTR('**Too many refinement observations**'), + 36, XDLSTR(' '), -1, XDLSTR('Continue'), 8, + XDLSTR(' '), -1, IFONT, 0, IBUTTON) GO TO 70 END IF 60 CONTINUE C C====== Initialisations C 70 SUMSQ = 0.0 C C====== See if difference plot required C DIFFPL = .FALSE. CALL IOW_ASKQ(IVH_IOW, 'Difference plot required', DIFFPL) C C====== Get centre C CALL CHK_OPN (IERR) IF (IERR.EQ.1) THEN IQUIT = 1 RETURN END IF CALL FILM_CENTRE(X_CEN_F,Y_CEN_F,OMEGA) COSOM = COSD(OMEGA) SINOM = SIND(OMEGA) CALL LDM_GET_XC (IPACK, IPLATE, X_C, IFLAG, ND, IERR, ERRSTR) CALL LDM_GET_YC (IPACK, IPLATE, Y_C, IFLAG, ND, IERR, ERRSTR) X_CEN = X_CEN_F + X_C*MM_RAST_X Y_CEN = Y_CEN_F + Y_C*MM_RAST_Y C C====== Display image for difference map plot if required C IF (DIFFPL) THEN CALL SHOW_IMAGE (1, IERR) IF (IERR.EQ.1) THEN IQUIT = 1 RETURN END IF C C====== Get calculated positions & distance errors C MAGUPD = 0 DO 200 I = 1,NUM_REF_SPOTS J = REF_NODALS(I) H = NODAL_H_S(J) K = NODAL_K_S(J) L = NODAL_L_S(J) CALL LRL_CALC_POS(IPACK,IPLATE,X_CEN,Y_CEN,COSOM,SINOM, + AMAT,H,K,L,XFD,YFD,IERR) IXPIX = NINT(XM_OBS(J)) IYPIX = NINT(YM_OBS(J)) DIST2 = (XFD-XM_OBS(J))**2 + (YFD-YM_OBS(J))**2 SUMSQ = SUMSQ + DIST2 IF (DIST2.GT.(MM_RAST_X*DELTA)**2) THEN CALL XDLF_IMAGE_SYMBOL(IVH_FILM,IXPIX,IYPIX, + 4,1,1,IERR) CALL XDLF_IMAGE_SYMBOL(IVH_FILM,IXPIX,IYPIX, + 14,1,1,IERR) ELSE CALL XDLF_IMAGE_SYMBOL(IVH_FILM,IXPIX,IYPIX, + 24,5,1,IERR) END IF C C====== Exaggerate vector by a factor of 25 C DX = 25.0*(XFD-XM_OBS(J)) DY = 25.0*(YFD-YM_OBS(J)) IX2PIX = NINT (XM_OBS(J)+DX) IY2PIX = NINT (YM_OBS(J)+DY) IF (I.EQ.NUM_REF_SPOTS) MAGUPD = 1 CALL XDLF_IMAGE_VECT(IVH_FILM,1,IXPIX,IYPIX, + IX2PIX,IY2PIX,5,1,MAGUPD,IERR) 200 CONTINUE C C===== Get continue command from menu C CALL XDLF_MENU_AREA_SETMENU (IVH_MENU, 1, XDLSTR(NAMES), 20, + XDLSTR(' '), -1, XDLSTR('Quit Refinement'), + 15, 0, IERR) IVHLIST(1) = IVH_MENU CALL XDLF_GET_EVENTS(1, IVHLIST, IVH) CALL XDLF_MENU_AREA_GETITEM(IVH_MENU, ITEM, IQUIT) CALL XDLF_IMAGE_SETTINGS (IVH_FILM, MINTHR, MAXTHR, + MONO_THR, ICONTRAST, ICOLOR_OPT, IOVLY_OPT, IBG_OPT, + MAG_OPT, ISHOW_INT, IERR) CALL XDLF_DELETE_VIEW_OBJECT(IVH_FILM, IERR) IF (IQUIT.EQ.1) RETURN ELSE C C====== Get calculated positions & distance errors C DO 300 I = 1,NUM_REF_SPOTS J = REF_NODALS(I) H = NODAL_H_S(J) K = NODAL_K_S(J) L = NODAL_L_S(J) CALL LRL_CALC_POS(IPACK,IPLATE,X_CEN,Y_CEN,COSOM,SINOM, + AMAT,H,K,L,XFD,YFD,IERR) DIST2 = (XFD-XM_OBS(J))**2 + (YFD-YM_OBS(J))**2 SUMSQ = SUMSQ + DIST2 300 CONTINUE END IF C C====== Calculate and save RMS C RMS = SQRT(SUMSQ/NUM_REF_SPOTS)/MM_RAST_X OLD_RMS = RMS STR = 'RMS =' CALL STR_ADDF(STR, RMS, 3, 1) CALL STR_ADDS(STR, 'mm. for the', 1) CALL STR_ADDI(STR, NUM_REF_SPOTS, 1) CALL STR_ADDS(STR,'spots to be used for refining', 1) CALL LMESSAGE(IVH_IOW, STR) RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** READ_IMAGE ** C************************** C C SUBROUTINE READ_IMAGE (ICNTXT, KIMG, MAXIMG, KTYPE, NF_OFF, KERR, + KERRSTR) C INCLUDE 'implicit_none.finc' C C Purpose: Read film/image-plate image and get default background C C Return: Note: FILM_READ will be returned as .FALSE. if error in read C C Author: John W. Campbell, October 1994 C C Arguments: C INTEGER ICNTXT INTEGER KIMG(*) INTEGER MAXIMG INTEGER KTYPE INTEGER NF_OFF INTEGER KERR CHARACTER*(*) KERRSTR C C ICNTXT (R) Context option = 0 normal calls from LAUEGEN C = 1 call via auto-refinement routines C or command line input of soft limit requests C or command line input of spotsize C or command line input of integration C determination C KIMG (W) Image array C MAXIMG (R) Max allowed size of KIMG in words C KTYPE (W) Returns image data storage type option C NF_OFF (W) Returns fast rasters offset between successive slow rasters C KERR (W) Error return flag = 0 OK C = 1 Error C KERRSTR (W) Error string if KERR is non-zero (max 80 chars) C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'prog_flags.finc' INCLUDE 'ip1_entries.finc' INCLUDE 'file_units.finc' INCLUDE 'image.finc' C C====== FUNCTION TYPES: C LOGICAL CCPBYT INTEGER XDLSTR C C====== LOCALS: C INTEGER NPBOX INTEGER IXR INTEGER IYR INTEGER IERR INTEGER NXRAST INTEGER NYRAST INTEGER NXR INTEGER NYR INTEGER NS_RAS INTEGER NF_RAS INTEGER IFLAG INTEGER IFTYPE INTEGER IORD INTEGER ISWAP INTEGER NWORDS INTEGER NBW INTEGER IOPT INTEGER KORD INTEGER NXP INTEGER NYP INTEGER IP INTEGER IVBAR INTEGER LISTE(5) CHARACTER*2 VALSTR CHARACTER*80 STR CHARACTER*2 ERRSTR C C INTEGER NPBOX !Box size in pixels for background strip calcn C INTEGER IXR !Root x position for read image progress bar C INTEGER IYR !Root y position for read image progress bar C INTEGER IERR !Error flag C INTEGER NXRAST !No. x-rasters C INTEGER NYRAST !No. y-rasters C INTEGER NXR !No. x-rasters returned from 'mar' file C INTEGER NYR !No. y-rasters returned from 'mar' file C INTEGER NS_RAS !No. slow rasters C INTEGER NF_RAS !No. fast rasters C INTEGER IFLAG !Parameter status flag C INTEGER IFTYPE !Image type flag C INTEGER IORD !Axis order flag C INTEGER ISWAP !Byte sawp flag C INTEGER NWORDS !No. words required for full image C INTEGER NBW !No. bytes/word C INTEGER IOPT !Background option flag C INTEGER KORD !Order flag for reading data C INTEGER NXP !Minimum image compression required along x C INTEGER NYP !Minimum image compression required along y C INTEGER IVBAR !Handle for progress bar; 0 if not required C INTEGER IP !Count of parameters to update C INTEGER LISTE(5) !List of parameter table entries to be updated C CHARACTER*2 VALSTR !Parameter value string (dummy) C CHARACTER*80 STR !Character string for messages C CHARACTER*2 ERRSTR !Error string (dummy) C C------------------------------------------------------------------------------- C KERR = 0 KERRSTR = ' ' CALL LDM_GET_IMDAT (VALSTR, IFTYPE, IFLAG) CALL LDM_GET_AXORD (VALSTR, IORD, ISWAP, IFLAG) KORD = 1 IF (ISWAP.EQ.2) KORD = -1 IF (ICNTXT.EQ.0) THEN IF (LG_MODE.EQ.1) THEN CALL LMESSAGE(IVH_IOW, + '===Reading image data now===') ELSE IF (LG_MODE.EQ.2) THEN CALL TWRITE('===Reading image data now===') END IF END IF CALL LDM_GET_NXRAS (NXRAST, IFLAG) CALL LDM_GET_NYRAS (NYRAST, IFLAG) IF (.NOT.CCPBYT(NBW)) THEN IF (IFTYPE.GE.1.AND.IFTYPE.LE.4) THEN IF (ICNTXT.EQ.0) CALL LOG_MSG (IVH_IOW, + '**Error** Byte handling not available',1) FILM_READ = .FALSE. KERR = 1 KERRSTR = 'Byte handling not available' RETURN END IF END IF NWORDS = ((NXRAST*NYRAST) + NBW - 1)/NBW IF (NWORDS.GT.MAXIMG) THEN IF (ICNTXT.EQ.0) CALL LOG_MSG (IVH_IOW, + '**Error** Image too big for program',1) FILM_READ = .FALSE. KERR = 1 KERRSTR = 'Image too big for program' RETURN END IF NXP = (NXRAST + MAX_DISP_WIDTH - 1)/MAX_DISP_WIDTH NYP = (NYRAST + MAX_DISP_HEIGHT - 1)/MAX_DISP_HEIGHT NCMP = MAX(NXP,NYP) IXR = 0 IYR = 0 IVBAR = 0 IF (LG_MODE.EQ.1) THEN IF (ICNTXT.EQ.1) THEN CALL XDLF_VIEW_OBJECT_ROOTXY (IVH_CMD,8,35, + IXR,IYR,IERR) ELSE CALL XDLF_VIEW_OBJECT_ROOTXY (IVH_IOW,20,20,IXR,IYR,IERR) END IF IVBAR = IVH_BAR END IF IF (IFTYPE.EQ.1) THEN CALL XDLF_READ_FULL_FILM(IFD,KORD,NXRAST,NYRAST, + IVBAR,IXR,IYR,KIMG,IERR) IF (IERR.GT.0) THEN STR = '**Error** Error in reading record' CALL STR_ADDI(STR,IERR,1) IF (ICNTXT.EQ.0) CALL LOG_MSG(IVH_IOW,STR,1) FILM_READ = .FALSE. KERR = 1 KERRSTR = STR RETURN END IF KTYPE = 1 MINVAL = 0 MAXVAL = 255 MINTHR = 0 MAXTHR = 255 ICONTRAST = 1024 ELSE IF (IFTYPE.EQ.2) THEN CALL XDLF_READ_FULL_I2(IFD,KORD,NXRAST,NYRAST, + IVBAR,IXR,IYR,KIMG, + MINVAL,MAXVAL,IERR) IF (IERR.GT.0) THEN STR = '**Error** Error in reading record' CALL STR_ADDI(STR,IERR,1) IF (ICNTXT.EQ.0) CALL LOG_MSG(IVH_IOW,STR,1) FILM_READ = .FALSE. KERR = 1 KERRSTR = STR RETURN END IF KTYPE = 2 MINTHR = 0 MAXTHR = MAXVAL/20 ICONTRAST = 1024 ELSE IF (IFTYPE.EQ.3) THEN CALL XDLF_RDSQUASH_MAR (IFD,IVBAR,IXR,IYR,KIMG, + NXR,NYR,NS_RAS,NF_RAS, + MINVAL,MAXVAL,IERR) IF (IERR.GT.0) THEN STR = '**Error** Error in reading record' CALL STR_ADDI(STR,IERR,1) IF (ICNTXT.EQ.0) CALL LOG_MSG(IVH_IOW,STR,1) FILM_READ = .FALSE. KERR = 1 KERRSTR = STR RETURN END IF KTYPE = 4 MINTHR = 0 MAXTHR = MAXVAL/20 ICONTRAST = 1024 IP = 0 IF (NXR.NE.NXRAST) THEN NXRAST = NXR CALL LDM_SET_NXRAS (NXR, IERR, ERRSTR) IP = IP + 1 LISTE(IP) = IP_NXRAST END IF IF (NYR.NE.NYRAST) THEN NYRAST = NYR CALL LDM_SET_NYRAS (NXR, IERR, ERRSTR) IP = IP + 1 LISTE(IP) = IP_NYRAST END IF IF (IORD.NE.3) THEN IORD = 3 CALL LDM_SET_AXORD ('-xy',IERR,ERRSTR) IP = IP + 1 LISTE(IP) = IP_AXORD END IF IF (IP.GT.0.AND.LG_MODE.EQ.1) THEN CALL SET_PAR1_VALS (IP, LISTE) END IF NWORDS = ((NXRAST*NYRAST) + NBW - 1)/NBW IF (NWORDS.GT.MAXIMG) THEN IF (ICNTXT.EQ.0) CALL LOG_MSG (IVH_IOW, + '**Error** Image too big for program',1) FILM_READ = .FALSE. KERR = 1 KERRSTR = 'Image too big for program' RETURN END IF NXP = (NXRAST + MAX_DISP_WIDTH - 1)/MAX_DISP_WIDTH NYP = (NYRAST + MAX_DISP_HEIGHT - 1)/MAX_DISP_HEIGHT NCMP = MAX(NXP,NYP) ELSE IF (IFTYPE.EQ.4) THEN CALL XDLF_READ_PFBYTE (IFD,KORD,NXRAST,NYRAST, + IVBAR,IXR,IYR,KIMG, IERR) IF (IERR.GT.0) THEN STR = '**Error** Error in reading record' CALL STR_ADDI(STR,IERR,1) IF (ICNTXT.EQ.0) CALL LOG_MSG(IVH_IOW,STR,1) FILM_READ = .FALSE. KERR = 1 KERRSTR = STR RETURN END IF KTYPE = 2 MINVAL = 0 MAXVAL = 10000 MINTHR = 0 MAXTHR = MAXVAL/20 ICONTRAST = 1024 ELSE FILM_READ = .FALSE. KERR = 1 KERRSTR = 'Invalid image file type' RETURN END IF IF (NCMP.GT.1.AND.LG_MODE.EQ.1.AND.ICNTXT.EQ.0) THEN STR = '*Image will be compressed by' CALL STR_ADDI(STR,NCMP,1) CALL STR_ADDS(STR,'to 1 for display*',1) CALL LMESSAGE(IVH_IOW,STR) END IF IF (ICNTXT.EQ.0) THEN IF (LG_MODE.EQ.1) THEN CALL LMESSAGE(IVH_IOW, + '===Calculating default radial background now===') ELSE IF (LG_MODE.EQ.2) THEN CALL TWRITE + ('===Calculating default radial background now===') END IF END IF IF (IORD.LT.5) THEN NSRASTS = NXRAST NFRASTS = NYRAST IOPT = 2 ELSE NSRASTS = NYRAST NFRASTS = NXRAST IOPT = 1 END IF NF_OFF = NFRASTS NPBOX = 2 * ((NFRASTS/NCMP)/50) + 1 CALL XDLF_BG_STRIP(IMG,KTYPE,NSRASTS,NFRASTS,NFRASTS,NCMP, + NPBOX,50,IOPT,IBGAVE,NBG,IERR) CALL XDLF_BG_RADIMG(KTYPE,NSRASTS/NCMP,NFRASTS/NCMP,NFRASTS/NCMP, + IBGAVE,NBG,IMG_BG,IERR) NF_BGOFF = NFRASTS/NCMP IF (ICNTXT.EQ.0) THEN IF (LG_MODE.EQ.1) THEN CALL LMESSAGE(IVH_IOW,'===Done===') ELSE IF (LG_MODE.EQ.2) THEN CALL TWRITE ('===Done===') END IF END IF FILM_READ = .TRUE. RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** READ_PAR_FILE ** C************************** C C SUBROUTINE READ_PAR_FILE (OPENED, PFIL) C INCLUDE 'implicit_none.finc' C C Purpose: Read in parameters (.gen) file C C Author: John W. Campbell, May 1991 C C Arguments: C LOGICAL OPENED CHARACTER*(*) PFIL C OPENED (R) File already opened (on unit IUN_GEN) flag. If false then C request file name from main i/o window C PFIL (R) Name of file if OPENED = .TRUE. otherwise may be blank C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' INCLUDE 'screen_params.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'ip1_entries.finc' INCLUDE 'ip2_entries.finc' INCLUDE 'prog_flags.finc' INCLUDE 'file_units.finc' INCLUDE 'gnom_rmin.finc' INCLUDE 'film_pack.finc' INCLUDE 'cell_input.finc' INCLUDE 'spot_box.finc' INCLUDE 'get_soft.finc' INCLUDE 'spot_sizes.finc' C C====== FUNCTION TYPES: C LOGICAL CCPEXS INTEGER XDLSTR INTEGER LENSTR C C====== LOCALS: C LOGICAL EXISTS LOGICAL EOF LOGICAL NONLDM LOGICAL IDUM_PRF_ROT INTEGER I INTEGER IERR INTEGER KFLAG INTEGER INDIRECT INTEGER IFAIL INTEGER LISTE (2) INTEGER NVIEW INTEGER IVHLIST(2) INTEGER IVH INTEGER IFLAG INTEGER ND INTEGER IMTYP INTEGER IDUM_NPROF REAL RDUM_PROMIN CHARACTER*2 VALSTR CHARACTER*(MAXFLEN) FILNAM CHARACTER*(MAXFLEN) PAR_FILE CHARACTER*120 STR CHARACTER*80 ERRSTR CHARACTER*80 BADTOK CHARACTER*250 LIN C LOGICAL EXISTS !File exists flag C LOGICAL EOF !End of file flag C LOGICAL NONLDM !Non LDM data found flag C LOGICAL IDUM_PRF_ROT !Dummy rotate profiles flag C INTEGER I !Temp/loop variable C INTEGER IERR !Error flag C INTEGER KFLAG !Flag from LDM_PARSE routine C INTEGER INDIRECT !Indirection level counter for file reads C INTEGER IFAIL !File open error flag C INTEGER NE !No. entries to update in parameter table 1 C INTEGER LISTE (2) !List of entries to update (dummy) C INTEGER NVIEW !No. of view-object for getting events C INTEGER IVHLIST(2) !List of view-object handles for getting events C INTEGER IVH !Returned view-object handle from getting events C INTEGER IFLAG !Parameter status flag C INTEGER ND !Number of decimal places flag C INTEGER IMTYP !Image type flag (LDM) C INTEGER IDUM_NPROF !Dummy value for NPROF (not used by LAUEEGEN) C REAL RDUM_PROMIN !Dummy value for PROMIN (not used by LAUEEGEN) C CHARACTER*2 VALSTR !Parameter value string (dummy) C CHARACTER*(MAXFLEN) FILNAM !Temp file name C CHARACTER*(MAXFLEN) PAR_FILE !Parameters file name C CHARACTER*120 STR !Message string C CHARACTER*80 ERRSTR !Error string C CHARACTER*80 BADTOK !Bad token string C CHARACTER*250 LIN !Input line from file C C C------------------------------------------------------------------------------- C PAR_FILE = PFIL IF (OPENED) GO TO 110 C C====== Read in file name C 100 CALL LPROMPT (IVH_IOW, 'File name (default ext=.ldm): ') NVIEW = 1 IVHLIST(1) = IVH_IOW CALL XDLF_GET_EVENTS (NVIEW, IVHLIST, IVH) CALL XDLF_IO_WINDOW_GETSTRING (IVH_IOW, XDLSTR(FILNAM), + MAXFLEN, IERR) IF (FILNAM.EQ.' ') RETURN CALL FILEXT (FILNAM, 'ldm', PAR_FILE, I) EXISTS = CCPEXS (PAR_FILE) IF (.NOT.EXISTS) THEN CALL LMESSAGE (IVH_IOW, '**File not found**') GO TO 100 END IF IFAIL = 1 CALL CCPDPN (-IUN_GEN, PAR_FILE, 'READONLY', 'F', 0, IFAIL) IF (IFAIL.LT.0) THEN CALL LMESSAGE (IVH_IOW, '**Error in opening file**') GO TO 100 END IF C C====== Reset some default flags C 110 IPACK = 1 IPLATE = 1 FILM_READ = .FALSE. FILM_OPEN = .FALSE. IPACK_OPN = 0 IPLATE_OPN = 0 C C====== Reset default LDM parameters C CALL LDM_RESET (' ', 0, 0, IERR, ERRSTR) C C====== Log name of parameters file C IF (IUN_LOG.GT.0) THEN WRITE (IUN_LOG, 1010) PAR_FILE(1:LENSTR(PAR_FILE)) END IF C C====== Read in parameters file C NONLDM = .FALSE. INDIRECT = 0 150 CALL LDM_READLINE (IUN_GEN, 10, INDIRECT, LIN, EOF, IERR) IF (EOF) GO TO 200 IF (IERR.GT.0) THEN STR = '**Error** LDM_READLINE error, ierr=' CALL STR_ADDI (STR,IERR,0) CALL LMESSAGE(IVH_IOW, STR) GO TO 200 END IF CALL LDM_PARSE (LIN, KFLAG, BADTOK, ERRSTR) IF (KFLAG.LT.0) THEN CALL LMESSAGE (IVH_IOW, '**Error** LDM_PARSE error') STR = 'Line:' CALL STR_ADDS (STR, LIN, 1) CALL LMESSAGE (IVH_IOW, STR) STR = 'Bad token:' CALL STR_ADDS (STR, BADTOK, 1) CALL LMESSAGE (IVH_IOW, STR) STR = 'Error message:' CALL STR_ADDS (STR, ERRSTR, 1) CALL LMESSAGE (IVH_IOW, STR) GO TO 150 END IF IF (KFLAG.EQ.1) NONLDM = .TRUE. GO TO 150 C C====== End of file (or fatal error) C 200 IF (NONLDM) CALL LMESSAGE (IVH_IOW, + '*Warning* Non-LDM data present') C C====== Save input values of cell parameters and reset to be consistent with C====== crystal system C CALL LDM_GET_A (CELL_INPUT(1), IFLAG, ND) CALL LDM_GET_B (CELL_INPUT(2), IFLAG, ND) CALL LDM_GET_C (CELL_INPUT(3), IFLAG, ND) CALL LDM_GET_ALPHA (CELL_INPUT(4), IFLAG, ND) CALL LDM_GET_BETA (CELL_INPUT(5), IFLAG, ND) CALL LDM_GET_GAMMA (CELL_INPUT(6), IFLAG, ND) CALL RESET_CELL CALL LDM_CH_RESET(0) C C====== Update parameter tables C CALL SET_PAR1_VALS (0, LISTE) CALL SET_PAR2_VALS (0, LISTE) CLOSE (IUN_GEN) C C====== Set default spot search box C SPOT_INPUT_BOX = 1.0 C C====== Reset gnomonic radius to 0.0 (undefined) C GNOMR = 0.0 C C====== Reset default soft limit determination parameters C CALL LFN_SOFT_DF (1, MAX_SOFT_BINS, IDUM_NPROF, IDUM_PRF_ROT, + RDUM_PROMIN, SOFT_FRAC, + SOFT_SIGTEST, SOFT_FRTEST, + ISOFT_D_NUMBINS, SOFT_DMIN_WIDTH) CALL LFN_SOFT_DF (2, MAX_SOFT_BINS, IDUM_NPROF, IDUM_PRF_ROT, + RDUM_PROMIN, SOFT_FRAC, + SOFT_SIGTEST, SOFT_FRTEST, + ISOFT_L_NUMBINS, SOFT_LMIN_WIDTH) C C====== Reset default spot size determiantion parameters C CALL SPOTSIZE_DFLTS (ISPOT_NBIN, SPOT_SDCUT, SPOT_THRFAC, + SPOT_EXPAND) C C====== Clear LIRL & integration flags C CALL INIT_LIRL RETURN C C====== Format statements C 1000 FORMAT(A) 1010 FORMAT(/,'Reading New LDM Parameters File',/, + '===============================',//, + 'Name of file: ',A) END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** REFIN_AUT ** C************************** C C SUBROUTINE REFIN_AUT (ISOLN) C INCLUDE 'implicit_none.finc' C C Purpose: Re-refine a stored auto-indexing solution C C Author: J.W. Campbell (based on INDEXL code by M. Elder) C C Arguments: C INTEGER ISOLN C C ISOLN (R) Number of the solution to be re-refined C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'lauegen_auto_params.finc' C C====== FUNCTION TYPES: C C C====== LOCALS: C INTEGER I INTEGER K INTEGER NOBS INTEGER IDET INTEGER IHKL(3,MAX_AUTO_SPOTS) INTEGER ITCNT INTEGER IDIR INTEGER ITIM REAL RMSD REAL DEV REAL DEVSAV REAL SOL(3,3) REAL NEWSOL(3,3) REAL ADJ REAL ANG(3) REAL XC(5,MAX_AUTO_SPOTS) CHARACTER*80 STR C INTEGER I !Temp/loop variable C INTEGER K !Temp/loop variable C INTEGER NOBS !No. of observations for evaluating orientation C and missetting angles C INTEGER IDET !Error flag from EVANGL C INTEGER IHKL(3,MAX_AUTO_SPOTS) !Indices of reflections used C for evaluating orientation C INTEGER ITCNT !Iteration count for refining angles C INTEGER IDIR !Refinement flag C INTEGER ITIM !Refinement flag C REAL RMSD !Rms deviation C REAL DEV !Current rms deviation for solution C REAL DEVSAV !Saved value of DEV from previous iteration C REAL SOL(3,3) !Rotation matrix C REAL NEWSOL(3,3) !New rotation matrix C REAL ADJ !Adjustment step for refining angles C REAL ANG(3) !Current values of missetting angles C REAL XC(5,MAX_AUTO_SPOTS) !Positions of reflections used C for evaluating orientation C (observed and calculated) C CHARACTER*80 STR !String for output messages C C------------------------------------------------------------------------------- C NOBS = STNOBS(ISOLN) DO 100 I = 1 , NOBS IHKL(1,I) = STHKL(ISOLN,1,I) IHKL(2,I) = STHKL(ISOLN,2,I) IHKL(3,I) = STHKL(ISOLN,3,I) XC(1,I) = STXC(ISOLN,1,I) XC(2,I) = STXC(ISOLN,2,I) 100 CONTINUE CALL EVANGL(NOBS,IHKL,XC,ANG,RMSD,DEV,SOL,IDET) IF (IDET.EQ.2) THEN CALL LMESSAGE(IVH_IOW_AUT,'**Cannot refine**') RETURN END IF C C====== Set angles to current refined values C ANG(1) = STANG(ISOLN,1) ANG(2) = STANG(ISOLN,2) ANG(3) = STANG(ISOLN,3) C C====== Perform refinement of angles C ADJ = DEV/20. ITCNT = 0 270 DO 290 K = 1 , 4 I = K IF (I.GT.3) I = I - 3 IDIR = 1 ITIM = 0 280 DEVSAV = DEV ITIM = ITIM + 1 ANG(I) = ANG(I) - ADJ*(IDIR-2) CALL EROTMT(ANG,NEWSOL,SOL,RMSD) CALL EVCOOR(NEWSOL,XC,DEV,NOBS,IDET) ITCNT = ITCNT + 1 IF (ITCNT.GE.100) GO TO 300 IF (DEV.LT.DEVSAV) GO TO 280 ANG(I) = ANG(I) + ADJ*(IDIR-2) DEV = DEVSAV IF (ITIM.LE.1) THEN IF (IDIR.LE.1) THEN IDIR = 3 ITIM = 0 GO TO 280 END IF END IF 290 CONTINUE IF (ADJ.LT.0.02) GO TO 300 ADJ = ADJ/5. GO TO 270 300 STR = 'Starting PhiX =' CALL STR_ADDF(STR,STANG(ISOLN,1),2,1) CALL STR_ADDS(STR,', PhiY =',0) CALL STR_ADDF(STR,STANG(ISOLN,2),2,1) CALL STR_ADDS(STR,', PhiZ =',0) CALL STR_ADDF(STR,STANG(ISOLN,3),2,1) CALL LMESSAGE(IVH_IOW_AUT,STR) STANG(ISOLN,1) = ANG(1) STANG(ISOLN,2) = ANG(2) STANG(ISOLN,3) = ANG(3) STR = 'Refined PhiX =' CALL STR_ADDF(STR,STANG(ISOLN,1),2,1) CALL STR_ADDS(STR,', PhiY =',0) CALL STR_ADDF(STR,STANG(ISOLN,2),2,1) CALL STR_ADDS(STR,', PhiZ =',0) CALL STR_ADDF(STR,STANG(ISOLN,3),2,1) CALL LMESSAGE(IVH_IOW_AUT,STR) STR = 'rms deviation =' CALL STR_ADDF(STR,DEV,3,1) CALL STR_ADDS(STR,'from',1) CALL STR_ADDF(STR,STDEV(ISOLN),3,1) CALL LMESSAGE(IVH_IOW_AUT,STR) STDEV(ISOLN) = DEV RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** REFINE_CALC ** C************************** C C SUBROUTINE REFINE_CALC C INCLUDE 'implicit_none.finc' C C Purpose: Refine setting & cell parameters C C Author: John W. Campbell, September 1993 C C Arguments: C C None C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'ip1_entries.finc' INCLUDE 'prog_flags.finc' INCLUDE 'refine_params.finc' INCLUDE 'film_pack.finc' INCLUDE 'file_units.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR INTEGER LENSTR C C====== LOCALS: C LOGICAL ACCEPT LOGICAL DIFPLT LOGICAL RERUN INTEGER IFLAG(7) INTEGER JFLAG(6) INTEGER KFLAG(6) INTEGER IFCELL INTEGER IQUIT INTEGER IERR INTEGER IFL INTEGER NE INTEGER LISTE(10) INTEGER ND INTEGER KERR REAL OMEGA REAL X_CEN_F REAL Y_CEN_F REAL X_C REAL Y_C REAL TUNE(3) CHARACTER*2 VALSTR CHARACTER*2 ERRSTR CHARACTER*80 MESSAGE CHARACTER*80 STR C C LOGICAL ACCEPT !Accept refined parameters flag C LOGICAL DIFPLT !Output difference plot flag C LOGICAL RERUN !Rerun refinement immediately flag C INTEGER IFLAG(7) !Flags of general parameters selected for C refinement 1=yes, 0=no C INTEGER JFLAG(6) !Flags of cell parameters to be refined C INTEGER KFLAG(6) !Flags of distortion parameters to be C refined C INTEGER IFCELL !Flag if cell to be refined 1=yes, 0=no C INTEGER IQUIT !Quit flag C INTEGER IERR !Error flag C INTEGER IFL !Return flag from refinement routines C INTEGER NE !No. entries to update in parameter tables C INTEGER KERR !Error flag C INTEGER LISTE(10) !List of param entries to update C INTEGER ND !No. of decimal places flag C REAL TUNE(3) !Refinement tuning parameters C REAL OMEGA !Corrected omega (degrees) C REAL X_CEN_F !x centre from fids or input (rasters) C REAL Y_CEN_F !y centre from fids or input (rasters) C REAL X_C !x_c value (mm) C REAL Y_C !y_c value (mm) C CHARACTER*2 VALSTR !Parameter value string (dummy) C CHARACTER*2 ERRSTR !Error string (dummy) C CHARACTER*80 MESSAGE !Message from refinement routine C CHARACTER*80 STR !Temporary string C C C------------------------------------------------------------------------------- C C====== Initialisations C IRFN_TYP = 1 LSR_SHFLM = 0.001 LSR_DSTEP = 1.0D-6 LSR_DAMP = 0.5 POWELL_ACC = 0.000001 CALL FILM_CENTRE(X_CEN_F,Y_CEN_F,OMEGA) CALL LDM_GET_XC (IPACK, IPLATE, X_C, IFLAG, ND, KERR, ERRSTR) CALL LDM_GET_YC (IPACK, IPLATE, Y_C, IFLAG, ND, KERR, ERRSTR) C C====== Get parameters to be refined C 1 CALL GET_REFPARS (IFLAG, JFLAG, KFLAG, IFCELL, IQUIT) IF (IQUIT.EQ.1) RETURN IF (IRFN_TYP.EQ.1) THEN TUNE(1) = LSR_SHFLM TUNE(2) = LSR_DSTEP TUNE(3) = LSR_DAMP ELSE TUNE(1) = POWELL_ACC POWELL_ACC = 0.000001 END IF CALL LDM_SAVERP (IPACK, IPLATE) CALL LFN_RFN (IPACK, IPLATE, IFLAG, JFLAG, KFLAG, + X_CEN_F, Y_CEN_F, + IRFN_TYP, TUNE, RMS, IERR, MESSAGE) CALL LMESSAGE (IVH_IOW, MESSAGE) C C====== Output refined parameters C CALL LFN_SHOW_XDL (IVH_IOW, IPACK, IPLATE, RMS, OLD_RMS) C C====== Log refined parameters if required C IF (IUN_LOG.GT.0) THEN WRITE (IUN_LOG,'('' '')') STR = 'Refinement for pack' CALL STR_ADDI (STR, IPACK, 1) CALL STR_ADDS (STR, ', plate', 0) CALL STR_ADDI (STR, IPLATE, 1) WRITE (IUN_LOG, '(A)') STR(1:LENSTR(STR)) CALL LFN_SHOWREF (IUN_LOG, 0, IPACK, IPLATE, RMS, OLD_RMS) END IF C C====== See if difference plot required C DIFPLT = .FALSE. CALL IOW_ASKQ(IVH_IOW,'Display difference plot',DIFPLT) IF (DIFPLT) THEN CALL PLOT_DIFF ACCEPT = .TRUE. CALL IOW_ASKQ(IVH_IOW, 'Accept refined parameters', ACCEPT) IF (.NOT.ACCEPT) THEN CALL LDM_RESTRP (IPACK, IPLATE) RERUN = .FALSE. CALL IOW_ASKQ(IVH_IOW, + 'Continue refinement with current spots', + RERUN) IF (RERUN) GO TO 1 RETURN END IF ELSE ACCEPT = .TRUE. CALL IOW_ASKQ(IVH_IOW, 'Accept refined parameters', ACCEPT) IF (ACCEPT) THEN CALL LDM_SET_RFL (IPACK, IPLATE, 1, IERR, ERRSTR) ELSE CALL LDM_RESTRP (IPACK, IPLATE) C C====== See if immediate rerun required C RERUN = .FALSE. CALL IOW_ASKQ(IVH_IOW, + 'Continue refinement with current spots', + RERUN) IF (RERUN) GO TO 1 RETURN END IF END IF C C====== Refined parameters accepted, update parameter tables C IF (IFCELL.EQ.1) CALL RESET_CELL NE = 0 NE = NE + 1 LISTE(NE) = IP_PHIX NE = NE + 1 LISTE(NE) = IP_PHIY NE = NE + 1 LISTE(NE) = IP_PHIZ NE = NE + 1 LISTE(NE) = IP_A NE = NE + 1 LISTE(NE) = IP_B NE = NE + 1 LISTE(NE) = IP_C NE = NE + 1 LISTE(NE) = IP_ALPH NE = NE + 1 LISTE(NE) = IP_BETA NE = NE + 1 LISTE(NE) = IP_GAMM CALL SET_PAR1_VALS (NE, LISTE) CALL SET_PAR2_VALS (0, LISTE) C C====== Update other packs/plates if required C CALL OTHER_REFPARS (IPACK, IPLATE, IFLAG, KFLAG) C C====== Save old rms value C OLD_RMS = RMS C C====== See if immediate rerun required C RERUN = .FALSE. CALL IOW_ASKQ(IVH_IOW,'Continue refinement with current spots', + RERUN) IF (RERUN) GO TO 1 RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C***************************** C** REFINE_PROGRESS ** C***************************** C C SUBROUTINE REFINE_PROGRESS (IUN_LOG, ISTAGE, IPACK, IPLATE, IGEN, + NSEARCH, NOBS, OLD_RMS, RMS, RFMSG, + IFLAG, JFLAG, KFLAG) C C INCLUDE 'implicit_none.finc' C C Purpose: Log auto-refinement results C C Author: John W. Campbell, October 1994 C INTEGER IUN_LOG INTEGER ISTAGE INTEGER IPACK INTEGER IPLATE INTEGER IGEN INTEGER NSEARCH INTEGER NOBS REAL OLD_RMS REAL RMS CHARACTER*(*) RFMSG INTEGER IFLAG(*) INTEGER JFLAG(*) INTEGER KFLAG(*) C C Parameters as for LFN_REFN_LOG C C IUN_LOG i (R) Unit number for log file as passed to LFN_AUTO_REFN C ISTAGE i (R) Refinement stage to be logged (ipack, iplate are C always passed unless ISTAGE is 0 or 8; other C parameters which need to be set for a particular C stage are shown in brackets): C C = 0 Main heading for auto C refinement C = 1 Current pack/plate C = 2 'INITIAL SEARCH' phase started C = 3 Start image read C = 4 End image read C = 5 Start spots list generation C = 6 End spots list generation C = 7 Spot generation results C (IGEN) C = 8 Start spots search C = 9 End spots search C = 10 Initial spot search results C for the current plate C (NSEARCH, NOBS, RMS) C = 11 Other spot search results C (NSEARCH, NOBS, RMS) C = 12 'INITIAL REFINEMENT' phase C started C = 13 List of parameters to be C refined (IFLAG, JFLAG, C KFLAG) C = 14 Start refinement cycle C = 15 End refinement cycle C = 16 Refinement results except C for last cycle. C (NOBS, OLD_RMS, RMS, C RFMSG, IFLAG, JFLAG, C KFLAG) C = 17 Refinement results for C last cycle. C (NOBS, OLD_RMS, RMS, C RFMSG, IFLAG, JFLAG, C KFLAG) C = 18 'MAIN REFINEMENT' phase C = 19 'FINAL REFINEMENT' phase C = 20 Refinement completed C C IPACK i (R) Current pack number C IPLATE i (R) Current plate number C IGEN(6) i (R) Counts from reflection generation (the 6 parameters C returned from LRL_COUNTS) C NSEARCH i (R) No. of spots searched for. C NOBS i (R) No. spots found and used in refinement C OLD_RMS i (R) Rms from spot search prior to refinement C RMS i (R) Rms from spot search or refinement C RFMSG c (R) Message string from refinement routine C IFLAG(7) i (R) See LFN_RFN routine C JFLAG(6) i (R) See LFN_RFN routine C KFLAG(6) i (R) SEe LFN_RFN routine C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'ip1_entries.finc' INCLUDE 'prog_flags.finc' INCLUDE 'autorefn_flags.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR INTEGER LENSTR C C====== LOCALS: C LOGICAL RFCL INTEGER I INTEGER J INTEGER ICYC INTEGER IERR INTEGER MAXC INTEGER LFLAG INTEGER IDSTYP INTEGER ISYST INTEGER LCY INTEGER LCP INTEGER LCS INTEGER LRP INTEGER LSP INTEGER LRF INTEGER LRS INTEGER NE INTEGER LISTE(20) INTEGER NCP(7) INTEGER ICOLR REAL TH_XO REAL TH_YO REAL YMX REAL RMS_MIN REAL YY REAL PX1(3) REAL PX2(3) REAL PY(3) REAL SX(3) REAL SY(3) CHARACTER*60 STR CHARACTER*2 VALSTR C LOGICAL RFCL !Refine cell parameters flag C INTEGER I !Temp/loop variable C INTEGER J !Temp/loop variable C INTEGER ICYC !Refinement cycle number C INTEGER IERR !Error flag C INTEGER MAXC !Maximum column no. used in text table C INTEGER LFLAG !Parameter status flag C INTEGER IDSTYP !Distortion type flag C INTEGER ISYST !Crystal system flag C INTEGER LCY !Line number for Cycle output C INTEGER LCP !Line number for Current phase output C INTEGER LCS !Line number for Current step output C INTEGER LRP !Line number for Refineable parameters C INTEGER LSP !Line number for Spot search results C INTEGER LRF !Line number for Refinement cycle results C INTEGER LRS !Line number for Rms summary C INTEGER NE !No. parameters to be updated C INTEGER LISTE(20) !List of parameters to be updated C INTEGER NCP(7) !No. unique cell parms. for crystal systems C INTEGER ICOLR !Colour flag C REAL TH_XO !X origin for 'thermometer' C REAL TH_YO !Y origin for 'thermometer' C REAL YMX !Maximum Y for 'thermometer' C REAL RMS_MIN !Minimum rms found so far for current plate C REAL YY !Y value for current rms for 'thermometer' C REAL PX1(3) !X positions for rms minimum mark (lhs) C REAL PX2(3) !X positions for rms minimum mark (rhs) C REAL PY(3) !Y positions for rms minimum marks C REAL SX(3) !X positions for 'above maximum' marks C REAL SY(3) !Y positions for 'above maximum' marks C CHARACTER*60 STR !Temp string C CHARACTER*2 VALSTR !Dummy value string SAVE RMS_MIN SAVE ICYC DATA NCP/6,4,3,2,2,2,1/ C C------------------------------------------------------------------------------- C C====== Initialisations C TH_XO = 50.0 TH_YO = 50.0 PX1(1) = TH_XO - 4.0 PX1(2) = TH_XO - 12.0 PX1(3) = TH_XO - 12.0 PX2(1) = TH_XO + 4.0 PX2(2) = TH_XO + 12.0 PX2(3) = TH_XO + 12.0 SX(1) = TH_XO - 15.0 SY(1) = TH_YO + 155.0 SX(2) = TH_XO SY(2) = TH_YO + 165.0 SX(3) = TH_XO + 15.0 SY(3) = TH_YO + 155.0 MAXC = 50 LCY = 1 LCP = 3 LCS = 5 LRP = 8 LSP = 19 LRF = 21 LRS = 23 CALL LDM_GET_DSTOR (VALSTR, IDSTYP, LFLAG) CALL LDM_GET_SYST (VALSTR, ISYST, LFLAG) C C====== Update rms results histogram if last cycle for plate C IF (ISTAGE.EQ.17) THEN I = 11*(RMS/.11) + 1 IF (I.LT.1) I = 1 IF (I.GT.11) I = 11 NRMS(I) = NRMS(I) + 1 END IF C C====== Output to auto-refinement screen if X-windows mode & called from menu C====== ===================================================================== C IF (LG_MODE.EQ.1.AND.MEN_INP) THEN C C====== Start of new plate C IF (ISTAGE.EQ.1) THEN CALL XDLF_TEXT_TABLE_CLEARSECT (IVH_AUTR_TAB, 1, 1, + LRS+1, MAXC, IERR) STR = 'Refinement for pack' CALL STR_ADDI (STR, IPACK, 1) CALL STR_ADDS (STR, ', plate',0) CALL STR_ADDI (STR, IPLATE, 1) CALL XDLF_TEXT_TABLE_TEXT (IVH_AUTR_TAB, XDLSTR(STR), + LENSTR(STR), 1, 1, 0, IERR) CALL XDLF_TEXT_TABLE_TEXT (IVH_AUTR_TAB, + XDLSTR('Current phase:'),15, + LCP, 1, 0, IERR) CALL XDLF_TEXT_TABLE_TEXT (IVH_AUTR_TAB, + XDLSTR('Current step:'),13, + LCS, 1, 0, IERR) CALL XDLF_TEXT_TABLE_TEXT (IVH_AUTR_TAB, + XDLSTR('Refineable parameters'), + 21, LRP, 1, 1, IERR) CALL XDLF_TEXT_TABLE_TEXT (IVH_AUTR_TAB, + XDLSTR('phix, phiy, phiz'), 16, + LRP+2, 4, 0, IERR) CALL XDLF_TEXT_TABLE_TEXT (IVH_AUTR_TAB, + XDLSTR('ctof'), 4, + LRP+3, 4, 0, IERR) CALL XDLF_TEXT_TABLE_TEXT (IVH_AUTR_TAB, + XDLSTR('x_c, y_c'), 8, + LRP+4, 4, 0, IERR) CALL XDLF_TEXT_TABLE_TEXT (IVH_AUTR_TAB, + XDLSTR('w_c'), 3, + LRP+5, 4, 0, IERR) CALL XDLF_TEXT_TABLE_TEXT (IVH_AUTR_TAB, + XDLSTR('cell'), 4, + LRP+6, 4, 0, IERR) CALL XDLF_TEXT_TABLE_TEXT (IVH_AUTR_TAB, + XDLSTR('y_scale'), 7, + LRP+7, 4, 0, IERR) CALL XDLF_TEXT_TABLE_TEXT (IVH_AUTR_TAB, + XDLSTR('tilt, twist'), 11, + LRP+8, 4, 0, IERR) CALL XDLF_TEXT_TABLE_TEXT (IVH_AUTR_TAB, + XDLSTR('Refinement rms summary'), + 22, LRS, 1, 1, IERR) CALL XDLF_TEXT_TABLE_TEXT (IVH_AUTR_TAB, + XDLSTR('< .01 .02 .03 .04 .05 .06 .07 .08 .09 .10 >=.10'), + 47, LRS+1, 1, 0, IERR) IF (IDSTYP.EQ.1) THEN CALL XDLF_TEXT_TABLE_TEXT (IVH_AUTR_TAB, + XDLSTR('bulge'), 5, + LRP+9, 4, 0, IERR) ELSE IF (IDSTYP.EQ.2) THEN CALL XDLF_TEXT_TABLE_TEXT (IVH_AUTR_TAB, + XDLSTR('roff, toff'), 10, + LRP+9, 4, 0, IERR) ELSE IF (IDSTYP.EQ.3) THEN CALL XDLF_TEXT_TABLE_TEXT (IVH_AUTR_TAB, + XDLSTR('spd terms'), 9, + LRP+9, 4, 0, IERR) END IF CALL XDLF_GRAPH_WIN_DELETE (IVH_AUTR_GRA, 2, IERR) CALL XDLF_GRAPH_WIN_STYLE (IVH_AUTR_GRA, 2, 2, -1, IERR) CALL XDLF_GRAPH_WIN_RECTANGLE (IVH_AUTR_GRA, + TH_XO-2.5, TH_YO, + TH_XO+2.5, TH_YO+150.0, + 1, IERR) CALL XDLF_GRAPH_WIN_POLYSYMBOL (IVH_AUTR_GRA, SX, SY, 3, + 1, 6.0, 1, IERR) CALL XDLF_GRAPH_WIN_STYLE (IVH_AUTR_GRA, 6, -1, -1, IERR) RMS_MIN = 1000.0 YY = TH_YO+150.0 PY(1) = YY PY(2) = YY+4.0 PY(3) = YY-4.0 CALL XDLF_GRAPH_WIN_POLYGON (IVH_AUTR_GRA, PX1, PY, 3, + 1, IERR) CALL XDLF_GRAPH_WIN_POLYGON (IVH_AUTR_GRA, PX2, PY, 3, + 1, IERR) ICYC = 1 CALL XDLF_TEXT_TABLE_TEXT (IVH_AUTR_TAB, + XDLSTR('Cycle'), 5, + LCY, 40, 0, IERR) CALL XDLF_TEXT_TABLE_TEXT (IVH_AUTR_TAB, + XDLSTR('1'), 1, + LCY, 46, 11, IERR) STR = '==Automatic refinement for pack' CALL STR_ADDI (STR, IPACK, 1) CALL STR_ADDS (STR, ', plate',0) CALL STR_ADDI (STR, IPLATE, 1) CALL STR_ADDS (STR, '==', 0) CALL LMESSAGE (IVH_IOW, STR) C C====== Start of 'Initial Search' phase C ELSE IF (ISTAGE.EQ.2) THEN CALL XDLF_TEXT_TABLE_TEXT (IVH_AUTR_TAB, + XDLSTR('INITIAL SEARCH'), 14, + LCP, 17, 11, IERR) C C====== Start reading image C ELSE IF (ISTAGE.EQ.3) THEN CALL XDLF_TEXT_TABLE_CLEARSECT (IVH_AUTR_TAB, LCS, 15, + LCS, MAXC, IERR) CALL XDLF_TEXT_TABLE_TEXT (IVH_AUTR_TAB, + XDLSTR('Reading image'), + 13, LCS, 15, 11, IERR) C C====== End reading image C ELSE IF (ISTAGE.EQ.4) THEN CALL XDLF_TEXT_TABLE_CLEARSECT (IVH_AUTR_TAB, LCS, 15, + LCS, MAXC, IERR) C C====== Start generating spots list C ELSE IF (ISTAGE.EQ.5) THEN CALL XDLF_TEXT_TABLE_CLEARSECT (IVH_AUTR_TAB, LCS, 15, + LCS, MAXC, IERR) CALL XDLF_TEXT_TABLE_TEXT (IVH_AUTR_TAB, + XDLSTR('Generating spots list'), + 21, LCS, 15, 11, IERR) C C====== End of spots list generation C ELSE IF (ISTAGE.EQ.6) THEN CALL XDLF_TEXT_TABLE_CLEARSECT (IVH_AUTR_TAB, LCS, 15, + LCS, MAXC, IERR) C C====== Start spots search C ELSE IF (ISTAGE.EQ.8) THEN CALL XDLF_TEXT_TABLE_CLEARSECT (IVH_AUTR_TAB, LCS, 15, + LCS, MAXC, IERR) CALL XDLF_TEXT_TABLE_TEXT (IVH_AUTR_TAB, + XDLSTR('Spot search'), + 11, LCS, 15, 11, IERR) C C====== End of spots search C ELSE IF (ISTAGE.EQ.9) THEN CALL XDLF_TEXT_TABLE_CLEARSECT (IVH_AUTR_TAB, LCS, 15, + LCS, MAXC, IERR) C C====== Spot search results first and other times C ELSE IF (ISTAGE.EQ.10.OR.ISTAGE.EQ.11) THEN CALL XDLF_TEXT_TABLE_CLEARSECT (IVH_AUTR_TAB, LSP, 1, + LSP, MAXC, IERR) STR = 'Found' CALL STR_ADDI (STR, NOBS, 1) CALL STR_ADDS (STR, 'of', 1) CALL STR_ADDI (STR, NSEARCH, 1) CALL STR_ADDS (STR, 'spots, rms =', 1) CALL STR_ADDF (STR, RMS, 3, 1) CALL STR_ADDS (STR,'mm',1) CALL XDLF_TEXT_TABLE_TEXT (IVH_AUTR_TAB, + XDLSTR(STR), LENSTR(STR), + LSP, 1, 0, IERR) YMX = 500.0*RMS IF (YMX.GT.150.0) YMX = 150.0 CALL XDLF_GRAPH_WIN_DELETE (IVH_AUTR_GRA, 2, IERR) CALL XDLF_GRAPH_WIN_STYLE (IVH_AUTR_GRA, 2, 2, -1, IERR) CALL XDLF_GRAPH_WIN_RECTANGLE (IVH_AUTR_GRA, + TH_XO-2.5, TH_YO, + TH_XO+2.5, TH_YO+YMX, + 1, IERR) IF (RMS.GT.0.3) CALL XDLF_GRAPH_WIN_POLYSYMBOL + (IVH_AUTR_GRA, SX, SY, 3, + 1, 6.0, 1, IERR) IF (RMS.LT.RMS_MIN) RMS_MIN = RMS YY = 500.0*RMS_MIN IF (YY.GT.150.0) YY = 150.0 YY = TH_YO+YY PY(1) = YY PY(2) = YY+4.0 PY(3) = YY-4.0 CALL XDLF_GRAPH_WIN_STYLE (IVH_AUTR_GRA, 6, -1, -1, IERR) CALL XDLF_GRAPH_WIN_POLYGON (IVH_AUTR_GRA, PX1, PY, 3, + 1, IERR) CALL XDLF_GRAPH_WIN_POLYGON (IVH_AUTR_GRA, PX2, PY, 3, + 1, IERR) IF (ISTAGE.EQ.10) THEN STR = 'At start: Found' CALL STR_ADDI (STR, NOBS, 1) CALL STR_ADDS (STR, 'of', 1) CALL STR_ADDI (STR, NSEARCH, 1) CALL STR_ADDS (STR, 'spots, rms =', 1) CALL STR_ADDF (STR, RMS, 3, 1) CALL STR_ADDS (STR,'mm',1) CALL LMESSAGE (IVH_IOW, STR) END IF C C====== Start of 'Initial Refinement' phase C ELSE IF (ISTAGE.EQ.12) THEN CALL XDLF_TEXT_TABLE_CLEARSECT (IVH_AUTR_TAB, LCP, 17, + LCP, MAXC, IERR) CALL XDLF_TEXT_TABLE_TEXT (IVH_AUTR_TAB, + XDLSTR('INITIAL REFINEMENT'), 18, + LCP, 17, 11, IERR) C C====== List of parameters to be refined C ELSE IF (ISTAGE.EQ.13) THEN CALL XDLF_TEXT_TABLE_CLEARSECT (IVH_AUTR_TAB, LRP+2, 2, + LRP+9, 2, IERR) IF (IFLAG(1).GT.0.OR.IFLAG(2).GT.0.OR.IFLAG(3).GT.0) + CALL XDLF_TEXT_TABLE_SYMBOL (IVH_AUTR_TAB, 1, LRP+2, + 2, 3, IERR) IF (IFLAG(4).GT.0) + CALL XDLF_TEXT_TABLE_SYMBOL (IVH_AUTR_TAB, 1, LRP+3, + 2, 3, IERR) IF (IFLAG(5).GT.0.OR.IFLAG(6).GT.0) + CALL XDLF_TEXT_TABLE_SYMBOL (IVH_AUTR_TAB, 1, LRP+4, + 2, 3, IERR) IF (IFLAG(7).GT.0) + CALL XDLF_TEXT_TABLE_SYMBOL (IVH_AUTR_TAB, 1, LRP+5, + 2, 3, IERR) RFCL = .FALSE. DO 20 I = 1, NCP(ISYST) IF (JFLAG(I).GT.0) RFCL = .TRUE. 20 CONTINUE IF (RFCL) + CALL XDLF_TEXT_TABLE_SYMBOL (IVH_AUTR_TAB, 1, LRP+6, + 2, 3, IERR) IF (KFLAG(1).GT.0) + CALL XDLF_TEXT_TABLE_SYMBOL (IVH_AUTR_TAB, 1, LRP+7, + 2, 3, IERR) IF (KFLAG(2).GT.0.OR.KFLAG(3).GT.0) + CALL XDLF_TEXT_TABLE_SYMBOL (IVH_AUTR_TAB, 1, LRP+8, + 2, 3, IERR) IF (IDSTYP.EQ.1) THEN IF (KFLAG(4).GT.0) + CALL XDLF_TEXT_TABLE_SYMBOL (IVH_AUTR_TAB, 1, LRP+9, + 2, 3, IERR) ELSE IF (IDSTYP.EQ.2) THEN IF (KFLAG(4).GT.0.OR.KFLAG(5).GT.0) + CALL XDLF_TEXT_TABLE_SYMBOL (IVH_AUTR_TAB, 1, LRP+9, + 2, 3, IERR) ELSE IF (IDSTYP.EQ.3) THEN IF (KFLAG(4).GT.0.OR.KFLAG(5).GT.0.OR.KFLAG(6).GT.0) + CALL XDLF_TEXT_TABLE_SYMBOL (IVH_AUTR_TAB, 1, LRP+9, + 2, 3, IERR) END IF C C====== Start of refinement step C ELSE IF (ISTAGE.EQ.14) THEN CALL XDLF_TEXT_TABLE_CLEARSECT (IVH_AUTR_TAB, LCS, 15, + LCS, MAXC, IERR) CALL XDLF_TEXT_TABLE_TEXT (IVH_AUTR_TAB, + XDLSTR('Refining'), + 8, LCS, 15, 11, IERR) C C====== End of refinement step C ELSE IF (ISTAGE.EQ.15) THEN CALL XDLF_TEXT_TABLE_CLEARSECT (IVH_AUTR_TAB, LCS, 15, + LCS, MAXC, IERR) C C====== Refinement results (all cycles) C ELSE IF (ISTAGE.EQ.16.OR.ISTAGE.EQ.17) THEN CALL XDLF_TEXT_TABLE_CLEARSECT (IVH_AUTR_TAB, LRF, 1, + LRF, MAXC, IERR) CALL XDLF_TEXT_TABLE_TEXT (IVH_AUTR_TAB, + XDLSTR('Refined rms ='), 13, + LRF, 1, 0, IERR) STR = ' ' CALL STR_ADDF (STR, RMS, 3, 0) CALL XDLF_TEXT_TABLE_TEXT (IVH_AUTR_TAB, + XDLSTR(STR), LENSTR(STR), + LRF, 15, 11, IERR) I = 16 + LENSTR(STR) STR = 'mm for' CALL STR_ADDI (STR, NOBS, 1) CALL STR_ADDS (STR, 'spots', 1) CALL XDLF_TEXT_TABLE_TEXT (IVH_AUTR_TAB, + XDLSTR(STR), LENSTR(STR), + LRF, I, 0, IERR) YMX = 500.0*RMS IF (YMX.GT.150.0) YMX = 150.0 CALL XDLF_GRAPH_WIN_DELETE (IVH_AUTR_GRA, 2, IERR) CALL XDLF_GRAPH_WIN_STYLE (IVH_AUTR_GRA, 2, 2, -1, IERR) CALL XDLF_GRAPH_WIN_RECTANGLE (IVH_AUTR_GRA, + TH_XO-2.5, TH_YO, + TH_XO+2.5, TH_YO+YMX, + 1, IERR) IF (RMS.GT.0.3) CALL XDLF_GRAPH_WIN_POLYSYMBOL + (IVH_AUTR_GRA, SX, SY, 3, + 1, 6.0, 1, IERR) IF (RMS.LT.RMS_MIN) RMS_MIN = RMS YY = 500.0*RMS_MIN IF (YY.GT.150.0) YY = 150.0 YY = TH_YO+YY PY(1) = YY PY(2) = YY+4.0 PY(3) = YY-4.0 CALL XDLF_GRAPH_WIN_STYLE (IVH_AUTR_GRA, 6, -1, -1, IERR) CALL XDLF_GRAPH_WIN_POLYGON (IVH_AUTR_GRA, PX1, PY, 3, + 1, IERR) CALL XDLF_GRAPH_WIN_POLYGON (IVH_AUTR_GRA, PX2, PY, 3, + 1, IERR) IF (ISTAGE.EQ.16) THEN ICYC = ICYC + 1 CALL XDLF_TEXT_TABLE_CLEARSECT (IVH_AUTR_TAB, LCY, 46, + LCY, MAXC, IERR) STR = ' ' CALL STR_ADDI (STR, ICYC, 0) CALL XDLF_TEXT_TABLE_TEXT (IVH_AUTR_TAB, + XDLSTR(STR), LENSTR(STR), + LCY, 46, 11, IERR) ELSE CALL XDLF_TEXT_TABLE_CLEARSECT (IVH_AUTR_TAB, LCP, 17, + LCP, MAXC, IERR) END IF CALL RESET_CELL NE = 0 NE = NE + 1 LISTE(NE) = IP_PACK NE = NE + 1 LISTE(NE) = IP_PLATE NE = NE + 1 LISTE(NE) = IP_PHIX NE = NE + 1 LISTE(NE) = IP_PHIY NE = NE + 1 LISTE(NE) = IP_PHIZ NE = NE + 1 LISTE(NE) = IP_A NE = NE + 1 LISTE(NE) = IP_B NE = NE + 1 LISTE(NE) = IP_C NE = NE + 1 LISTE(NE) = IP_ALPH NE = NE + 1 LISTE(NE) = IP_BETA NE = NE + 1 LISTE(NE) = IP_GAMM CALL SET_PAR1_VALS (NE, LISTE) CALL SET_PAR2_VALS (0, LISTE) IF (ISTAGE.EQ.17) THEN CALL XDLF_TEXT_TABLE_CLEARSECT (IVH_AUTR_TAB, LRS+2, 1, + LRS+2, MAXC, IERR) DO 40 I = 1, 11 IF (NRMS(I).LE.0) GO TO 40 J = 4*I - 1 IF (I.EQ.11) J = J + 2 WRITE (STR,'(I3)') NRMS(I) ICOLR = 11 IF (I.GT.5) ICOLR = 3 WRITE (STR(1:3),'(I3)') NRMS(I) CALL XDLF_TEXT_TABLE_TEXT (IVH_AUTR_TAB, + XDLSTR(STR), 3, + LRS+2, J, ICOLR, IERR) 40 CONTINUE STR = 'At end: Refined rms =' CALL STR_ADDF (STR, RMS, 3, 1) CALL STR_ADDS (STR, 'mm for', 1) CALL STR_ADDI (STR, NOBS, 1) CALL STR_ADDS (STR, 'spots', 1) CALL LMESSAGE (IVH_IOW, STR) END IF C C====== Start of 'Main Refinement' phase C ELSE IF (ISTAGE.EQ.18) THEN CALL XDLF_TEXT_TABLE_CLEARSECT (IVH_AUTR_TAB, LCP, 17, + LCP, MAXC, IERR) CALL XDLF_TEXT_TABLE_TEXT (IVH_AUTR_TAB, + XDLSTR('MAIN REFINEMENT'), 15, + LCP, 17, 11, IERR) C C====== Start of 'Final Refinement' phase C ELSE IF (ISTAGE.EQ.19) THEN CALL XDLF_TEXT_TABLE_CLEARSECT (IVH_AUTR_TAB, LCP, 17, + LCP, MAXC, IERR) CALL XDLF_TEXT_TABLE_TEXT (IVH_AUTR_TAB, + XDLSTR('FINAL REFINEMENT'), 16, + LCP, 17, 11, IERR) END IF C C====== X-windows mode & called from command window C====== =========================================== C ELSE IF (LG_MODE.EQ.1.AND..NOT.MEN_INP) THEN C C====== Start refinement for the next plate C IF (ISTAGE.EQ.1) THEN STR = '==Refinement for pack' CALL STR_ADDI (STR, IPACK, 1) CALL STR_ADDS (STR, ', plate',0) CALL STR_ADDI (STR, IPLATE, 1) CALL STR_ADDS (STR, '==', 0) CALL LMESSAGE (IVH_IOW, STR) C C====== Start 'Initial Refinement' phase C ELSE IF (ISTAGE.EQ.2) THEN CALL LMESSAGE (IVH_IOW, '==Initial Search Phase==') C C====== Start reading image C ELSE IF (ISTAGE.EQ.3) THEN CALL LMESSAGE (IVH_IOW, '==Reading Image==') C C====== Spot search results C ELSE IF (ISTAGE.EQ.10.OR.ISTAGE.EQ.11) THEN STR = 'Found' CALL STR_ADDI (STR, NOBS, 1) CALL STR_ADDS (STR, 'of', 1) CALL STR_ADDI (STR, NSEARCH, 1) CALL STR_ADDS (STR, 'spots, rms =', 1) CALL STR_ADDF (STR, RMS, 3, 1) CALL STR_ADDS (STR,'mm',1) CALL LMESSAGE (IVH_IOW, STR) C C====== Start of 'Initial Refinement' phase C ELSE IF (ISTAGE.EQ.12) THEN CALL LMESSAGE (IVH_IOW, '==Initial Refinement Phase==') C C====== Refinement results C ELSE IF (ISTAGE.EQ.16.OR.ISTAGE.EQ.17) THEN STR = 'Refined rms =' CALL STR_ADDF (STR, RMS, 3, 1) CALL STR_ADDS (STR, 'mm for', 1) CALL STR_ADDI (STR, NOBS, 1) CALL STR_ADDS (STR, 'spots', 1) CALL LMESSAGE (IVH_IOW, STR) CALL RESET_CELL NE = 0 NE = NE + 1 LISTE(NE) = IP_PACK NE = NE + 1 LISTE(NE) = IP_PLATE NE = NE + 1 LISTE(NE) = IP_PHIX NE = NE + 1 LISTE(NE) = IP_PHIY NE = NE + 1 LISTE(NE) = IP_PHIZ NE = NE + 1 LISTE(NE) = IP_A NE = NE + 1 LISTE(NE) = IP_B NE = NE + 1 LISTE(NE) = IP_C NE = NE + 1 LISTE(NE) = IP_ALPH NE = NE + 1 LISTE(NE) = IP_BETA NE = NE + 1 LISTE(NE) = IP_GAMM CALL SET_PAR1_VALS (NE, LISTE) CALL SET_PAR2_VALS (0, LISTE) C C====== Start of 'Main Refinement' phase C ELSE IF (ISTAGE.EQ.18) THEN CALL LMESSAGE (IVH_IOW, '==Main Refinement Phase==') C C====== Start of 'Final Refinement' phase C ELSE IF (ISTAGE.EQ.19) THEN CALL LMESSAGE (IVH_IOW, '==Final Refinement Phase==') END IF C C====== Terminal mode C====== ============= C ELSE IF (LG_MODE.EQ.2) THEN C C====== Start refinement for the next plate C IF (ISTAGE.EQ.1) THEN STR = '==Refinement for pack' CALL STR_ADDI (STR, IPACK, 1) CALL STR_ADDS (STR, ', plate',0) CALL STR_ADDI (STR, IPLATE, 1) CALL STR_ADDS (STR, '==', 0) CALL TWRITE (STR) C C====== Start 'Initial Refinement' phase C ELSE IF (ISTAGE.EQ.2) THEN CALL TWRITE ('==Initial Search Phase==') C C====== Start reading image C ELSE IF (ISTAGE.EQ.3) THEN CALL TWRITE ('==Reading Image==') C C====== Spot search results C ELSE IF (ISTAGE.EQ.10.OR.ISTAGE.EQ.11) THEN STR = 'Found' CALL STR_ADDI (STR, NOBS, 1) CALL STR_ADDS (STR, 'of', 1) CALL STR_ADDI (STR, NSEARCH, 1) CALL STR_ADDS (STR, 'spots, rms =', 1) CALL STR_ADDF (STR, RMS, 3, 1) CALL STR_ADDS (STR,'mm',1) CALL TWRITE (STR) C C====== Start of 'Initial Refinement' phase C ELSE IF (ISTAGE.EQ.12) THEN CALL TWRITE ('==Initial Refinement Phase==') C C====== Refinement results C ELSE IF (ISTAGE.EQ.16.OR.ISTAGE.EQ.17) THEN STR = 'Refined rms =' CALL STR_ADDF (STR, RMS, 3, 1) CALL STR_ADDS (STR, 'mm for', 1) CALL STR_ADDI (STR, NOBS, 1) CALL STR_ADDS (STR, 'spots', 1) CALL TWRITE (STR) C C====== Start of 'Main Refinement' phase C ELSE IF (ISTAGE.EQ.18) THEN CALL TWRITE ('==Main Refinement Phase==') C C====== Start of 'Final Refinement' phase C ELSE IF (ISTAGE.EQ.19) THEN CALL TWRITE ('==Final Refinement Phase==') END IF END IF C C====== Write to log file if required C====== ============================= C IF (IUN_LOG.GT.0) THEN IF (ISTAGE.EQ.0) THEN WRITE(IUN_LOG,2000) ELSE IF (ISTAGE.EQ.20) THEN WRITE (IUN_LOG,2010) 'Refinement rms summary:' WRITE (IUN_LOG,2020) WRITE (IUN_LOG,2030) STR = ' ' DO 50 I = 1, 11 IF (NRMS(I).LE.0) GO TO 50 J = 4*I - 1 IF (I.EQ.11) J = J + 2 WRITE (STR(J:J+2),'(I3)') NRMS(I) 50 CONTINUE WRITE (IUN_LOG,2010) STR WRITE (IUN_LOG,2020) END IF IF (ISTAGE.NE.7.AND.ISTAGE.NE.13) THEN CALL LFN_REFN_LOG (IUN_LOG, ISTAGE, + IPACK, IPLATE, IGEN, + NSEARCH, NOBS, OLD_RMS, RMS, RFMSG, + IFLAG, JFLAG, KFLAG) END IF END IF END IF RETURN C C====== Format statements C 2000 FORMAT (/,'==Automatic Parameter Refinement==') 2010 FORMAT(A) 2020 FORMAT ('-----------------------------------------------') 2030 FORMAT ('< .01 .02 .03 .04 .05 .06 .07 .08 .09 .10 >=.10') END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** RESET_CELL ** C************************** C C SUBROUTINE RESET_CELL C INCLUDE 'implicit_none.finc' C C Purpose: Reset LDM cell parameters as appropriate for the current C crystal system C C Author: John W. Campbell, October 1993 C C Arguments: C C None C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' C C====== GLOBALS: C C C====== FUNCTION TYPES: C C C====== LOCALS: C INTEGER IFLAG INTEGER ND INTEGER NDA INTEGER NDAL INTEGER IERR INTEGER ISYST REAL CELLP(6) CHARACTER*2 ERRSTR CHARACTER*20 VALSTR C INTEGER IFLAG !Parameter status flag C INTEGER ND !No. of decimal places flag C INTEGER NDA !No. of decimal places flag for 'A' C INTEGER NDAL !No. of decimal places flag for 'ALPHA' C INTEGER IERR !Error flag C INTEGER ISYST !Crystal system no. C REAL CELLP(6) !Cell parameters before reset C CHARACTER*2 ERRSTR !Error string (dummy) C CHARACTER*20 VALSTR !Parameter value string C C------------------------------------------------------------------------------- C CALL LDM_GET_A (CELLP(1), IFLAG, NDA) CALL LDM_GET_B (CELLP(2), IFLAG, ND) CALL LDM_GET_C (CELLP(3), IFLAG, ND) CALL LDM_GET_ALPHA (CELLP(4), IFLAG, NDAL) CALL LDM_GET_BETA (CELLP(5), IFLAG, ND) CALL LDM_GET_GAMMA (CELLP(6), IFLAG, ND) CALL LDM_GET_SYST (VALSTR, ISYST, IFLAG) IF (ISYST.EQ.2) THEN CALL LDM_SET ('ALPHA', 1, 1, '90.0', IERR, ERRSTR) CALL LDM_SET ('GAMMA', 1, 1, '90.0', IERR, ERRSTR) ELSE IF (ISYST.EQ.3) THEN CALL LDM_SET ('ALPHA', 1, 1, '90.0', IERR, ERRSTR) CALL LDM_SET ('BETA', 1, 1, '90.0', IERR, ERRSTR) CALL LDM_SET ('GAMMA', 1, 1, '90.0', IERR, ERRSTR) ELSE IF (ISYST.EQ.4) THEN VALSTR = ' ' CALL STR_ADDF (VALSTR, CELLP(1), NDA, 0) CALL LDM_SET ('B', 1, 1, VALSTR, IERR, ERRSTR) CALL LDM_SET ('ALPHA', 1, 1, '90.0', IERR, ERRSTR) CALL LDM_SET ('BETA', 1, 1, '90.0', IERR, ERRSTR) CALL LDM_SET ('GAMMA', 1, 1, '90.0', IERR, ERRSTR) ELSE IF (ISYST.EQ.5) THEN VALSTR = ' ' CALL STR_ADDF (VALSTR, CELLP(1), NDA, 0) CALL LDM_SET ('B', 1, 1, VALSTR, IERR, ERRSTR) CALL LDM_SET ('ALPHA', 1, 1, '90.0', IERR, ERRSTR) CALL LDM_SET ('BETA', 1, 1, '90.0', IERR, ERRSTR) CALL LDM_SET ('GAMMA', 1, 1, '120.0', IERR, ERRSTR) ELSE IF (ISYST.EQ.6) THEN VALSTR = ' ' CALL STR_ADDF (VALSTR, CELLP(1), NDA, 0) CALL LDM_SET ('B', 1, 1, VALSTR, IERR, ERRSTR) CALL LDM_SET ('C', 1, 1, VALSTR, IERR, ERRSTR) VALSTR = ' ' CALL STR_ADDF (VALSTR, CELLP(4), NDAL, 0) CALL LDM_SET ('BETA', 1, 1, VALSTR, IERR, ERRSTR) CALL LDM_SET ('GAMMA', 1, 1, VALSTR, IERR, ERRSTR) ELSE IF (ISYST.EQ.7) THEN VALSTR = ' ' CALL STR_ADDF (VALSTR, CELLP(1), NDA, 0) CALL LDM_SET ('B', 1, 1, VALSTR, IERR, ERRSTR) CALL LDM_SET ('C', 1, 1, VALSTR, IERR, ERRSTR) CALL LDM_SET ('ALPHA', 1, 1, '90.0', IERR, ERRSTR) CALL LDM_SET ('BETA', 1, 1, '90.0', IERR, ERRSTR) CALL LDM_SET ('GAMMA', 1, 1, '90.0', IERR, ERRSTR) END IF RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** RESTORE_PKPL ** C************************** C C SUBROUTINE RESTORE_PKPL C INCLUDE 'implicit_none.finc' C C Purpose: Restore pack and plate saved via SAVE_PKPL C C Author: John W. Campbell, January 1996 C C Arguments: C C None C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'film_pack.finc' INCLUDE 'prog_flags.finc' INCLUDE 'save_pkpl.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR C C====== LOCALS: C INTEGER LISTE(2) C INTEGER LISTE(2) !List of parameter table entries to be updated C C------------------------------------------------------------------------------- C IPACK = IPACK_SAVE IPLATE = IPLATE_SAVE IF (LG_MODE.EQ.1) THEN CALL SET_PAR1_VALS (0, LISTE) CALL SET_PAR2_VALS (0, LISTE) END IF RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** SAVE_PKPL ** C************************** C C SUBROUTINE SAVE_PKPL C INCLUDE 'implicit_none.finc' C C Purpose: Ssve current pack and plate no. (restore with RESTORE_PKPL) C C Author: John W. Campbell, January 1996 C C Arguments: C C None C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'film_pack.finc' INCLUDE 'save_pkpl.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR C C====== LOCALS: C C C------------------------------------------------------------------------------- C IPACK_SAVE = IPACK IPLATE_SAVE = IPLATE RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** SCREEN_SETUP ** C************************** C C SUBROUTINE SCREEN_SETUP C INCLUDE 'implicit_none.finc' C C Purpose: Set up initial screen C C Author: John W. Campbell, August 1990 C C Arguments: C C None C C====== Parameter statements C INCLUDE 'screen_params.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'ip1_entries.finc' INCLUDE 'ip2_entries.finc' C C====== FUNCTION TYPES: C INTEGER LENSTR INTEGER XDLSTR C C====== LOCALS: C C====== Layout parameters C INTEGER IWIDTH_FRAME INTEGER IHEIGHT_FRAME INTEGER IP1W INTEGER IP1H INTEGER IP2W INTEGER IP2H INTEGER IP3W INTEGER IP3H INTEGER MENW INTEGER MENH INTEGER IOW_W INTEGER IOW_H INTEGER ICMDW INTEGER ICMDH INTEGER IX INTEGER IY INTEGER IW INTEGER IH C INTEGER IWIDTH_FRAME ! Width of the base frame C INTEGER IHEIGHT_FRAME ! Height of the base frame C INTEGER IP1W ! Parameter table 1 width required C INTEGER IP1H ! Parameter table 1 height required C INTEGER IP2W ! Parameter table 2 width required C INTEGER IP2H ! Parameter table 2 height required C INTEGER IP3W ! Parameter table 3 width required C INTEGER IP3H ! Parameter table 3 height required C INTEGER MENW ! Menu width required C INTEGER MENH ! Menu height required C INTEGER IOW_W ! io_window text area width needed C INTEGER IOW_H ! io_window text area height needed C INTEGER ICMDW ! Command window width required C INTEGER ICMDH ! Command window height required C INTEGER IX ! X position for a view-object C INTEGER IY ! Y position for w view-object C INTEGER IW ! Required width for layout or object C INTEGER IH ! Required height for layout or object C C====== Miscellaneous parameters C INTEGER IERR CHARACTER*80 HEADER C C INTEGER IERR !Error return flag C CHARACTER*80 HEADER !Header for title bar C C------------------------------------------------------------------------------- C C C====== Calculate size requirements and layout parameters C CALL XDLF_MENU_AREA_GETSIZE (MAX_MEN_ITMS, MAX_MEN_NAME, + IFONT, 1, MAX_MEN_TITLE, MENW, MENH) CALL XDLF_PARAM_TABLE_GETSIZE (NP1_COLS, NP1_ROWS, + MAX_PNAME_CHARS, MAX_PVAL_CHARS, + 1, IFONT, 1, IP1W, IP1H) CALL XDLF_PARAM_TABLE_GETSIZE (NP2_COLS, NP2_ROWS, + MAX_P2NAME_CHARS, MAX_P2VAL_CHARS, + 1, IFONT, 1, IP2W, IP2H) CALL XDLF_PARAM_TABLE_GETSIZE (NP3_COLS, NP3_ROWS, + MAX_P3NAME_CHARS, MAX_P3VAL_CHARS, + 1, IFONT, 1, IP3W, IP3H) CALL XDLF_IO_WINDOW_GETSIZE (MIN_IOW_COLS, MIN_IOW_ROWS, IFONT, 1, + IOW_W, IOW_H) CALL XDLF_IO_WINDOW_GETSIZE (MIN_CMD_COLS, MIN_CMD_ROWS, IFONT, 1, + ICMDW, ICMDH) C C====== Get layout parameters C CALL XDLF_LAYOUT_INIT (IERR) CALL XDLF_LAYOUT_SET_SINGLE (XDLSTR('menu'), 4, MENW, MENH, + 0, 0, IERR) CALL XDLF_LAYOUT_SET_SINGLE (XDLSTR('par1'), 4, IP1W, IP1H, + 1, 1, IERR) CALL XDLF_LAYOUT_SET_SINGLE (XDLSTR('par2'), 4, IP2W, IP2H, + 2, 1, IERR) CALL XDLF_LAYOUT_SET_SINGLE (XDLSTR('par3'), 4, IP3W, IP3H, + 1, 2, IERR) CALL XDLF_LAYOUT_SET_SINGLE (XDLSTR('iow'), 3, IOW_W, IOW_H, + 0, 0, IERR) CALL XDLF_LAYOUT_SET_SINGLE (XDLSTR('cmd'), 3, ICMDW, ICMDH, + 0, 0, IERR) CALL XDLF_LAYOUT_SET_PAIR (1, 1, XDLSTR('mp3'), 3, + XDLSTR('menu'), 4, + XDLSTR('par3'), 4, + 0, 0, ISEP, 80, IERR) CALL XDLF_LAYOUT_SET_PAIR (1, 1, XDLSTR('iowcmd'), 6, + XDLSTR('iow'), 3, + XDLSTR('cmd'), 3, + 0, 0, ISEP, 80, IERR) CALL XDLF_LAYOUT_SET_PAIR (0, 3, XDLSTR('p1'), 2, + XDLSTR('iowcmd'), 6, + XDLSTR('par2'), 4, + 0, 0, ISEP, 80, IERR) CALL XDLF_LAYOUT_SET_PAIR (1, 2, XDLSTR('p2'), 2, + XDLSTR('par1'), 4, + XDLSTR('p1'), 2, + 0, 0, ISEP, 10, IERR) CALL XDLF_LAYOUT_SET_PAIR (0, 1, XDLSTR('top'), 3, + XDLSTR('mp3'), 3, + XDLSTR('p2'), 2, + 0, 0, ISEP, 10, IERR) CALL XDLF_LAYOUT (XDLSTR('top'), 3, IBORDER, IBORDER, IW, IH, + IERR) C C====== Create main frame C IWIDTH_FRAME = IW + 2*IBORDER IHEIGHT_FRAME = IH + 2*IBORDER HEADER = 'CCLRC Daresbury Laboratory program ''lauegen'' version' CALL STR_ADDS (HEADER, VERSTR, 1) CALL XDLF_BASE_FRAME (IVH_BASE, IWIDTH_FRAME, IHEIGHT_FRAME, + XDLSTR(HEADER), LENSTR(HEADER), XDLSTR('laue'), 4, -1, -1) C C====== Set up parameter table 1 C CALL XDLF_LAYOUT_GET_POSITION (XDLSTR('par1'), 4, IX, IY, + IW, IH, IERR) CALL XDLF_PARAM_TABLE (IVH_PAR1, IVH_BASE, IX, IY, + 0, NP1_COLS, NP1_ROWS, MAX_PNAME_CHARS, + MAX_PVAL_CHARS, MAX_PSCROLL_CHARS, + XDLSTR('Crystallographic/pack Parameters'), 32, + IFONT, 1, IERR) IF (IERR.GT.0) THEN WRITE (6,2002) IERR STOP ENDIF C C====== Set up parameter table 2 C CALL XDLF_LAYOUT_GET_POSITION (XDLSTR('par2'), 4, IX, IY, + IW, IH, IERR) CALL XDLF_PARAM_TABLE (IVH_PAR2, IVH_BASE, IX, IY, + 0, NP2_COLS, NP2_ROWS, MAX_P2NAME_CHARS, + MAX_P2VAL_CHARS, MAX_P2SCROLL_CHARS, + XDLSTR(' '), 1, + IFONT, 1, IERR) IF (IERR.GT.0) THEN WRITE (6,2002) IERR STOP ENDIF C C====== Set up parameter table 3 C CALL XDLF_LAYOUT_GET_POSITION (XDLSTR('par3'), 4, IX, IY, + IW, IH, IERR) CALL XDLF_PARAM_TABLE (IVH_PAR3, IVH_BASE, IX, IY, + 0, NP3_COLS, NP3_ROWS, MAX_P3NAME_CHARS, + MAX_P3VAL_CHARS, MAX_P3SCROLL_CHARS, + XDLSTR(' '), 1, + IFONT, 1, IERR) IF (IERR.GT.0) THEN WRITE (6,2002) IERR STOP ENDIF C C====== Set up menu area C CALL XDLF_LAYOUT_GET_POSITION (XDLSTR('menu'), 4, IX, IY, + IW, IH, IERR) CALL XDLF_MENU_AREA (IVH_MENU, IVH_BASE, IX, IY, 0, + MAX_MEN_ITMS, MAX_MEN_NAME, IFONT, 1, MAX_MEN_TITLE, + IW, IH, IERR) IF (IERR.GT.0) THEN WRITE (6,2003) IERR STOP ENDIF C C====== Set up main io-window area C CALL XDLF_LAYOUT_GET_POSITION (XDLSTR('iow'), 3, IX, IY, + IW, IH, IERR) CALL XDLF_IO_WINDOW (IVH_IOW, IVH_BASE, IX, IY, 0, 0, 0, + IW, IH, IFONT, 100, IERR) IF (IERR.GT.0) THEN WRITE (6,2004) IERR STOP ENDIF C C====== Set up command io-window area C CALL XDLF_LAYOUT_GET_POSITION (XDLSTR('cmd'), 3, IX, IY, + IW, IH, IERR) CALL XDLF_IO_WINDOW (IVH_CMD, IVH_BASE, IX, IY, 0, 0, 0, + IW, IH, IFONT, 100, IERR) IF (IERR.GT.0) THEN WRITE (6,2004) IERR STOP ENDIF CALL XDLF_IO_WINDOW_INPUT_MESSAGE (IVH_CMD, + XDLSTR('Enter command'), 13, IERR) C C====== Return C RETURN C C====== Format statements C 2002 FORMAT (/,'**Error code', I2, ' from xdlf_param_table**') 2003 FORMAT (/,'**Error code', I2, ' from xdlf_menu_area**') 2004 FORMAT (/,'**Error code', I2, ' from xdlf_io_window**') END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** SEARCH_SPOTS ** C************************** C C SUBROUTINE SEARCH_SPOTS (IQUIT) C INCLUDE 'implicit_none.finc' C C Purpose: Search for spots near predicted positions for refinement C C Author: John W. Campbell, January 1992 C C Arguments: C INTEGER IQUIT C C IQUIT (W) Error flag =0 OK, =1, cannot open file for search or no spots C for search or cannot read image C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'ip1_entries.finc' INCLUDE 'prog_flags.finc' INCLUDE 'spot_box.finc' INCLUDE 'image.finc' INCLUDE 'selrefs.finc' INCLUDE 'lauegen_observed_spots.finc' INCLUDE 'file_units.finc' INCLUDE 'spot_data.finc' INCLUDE 'film_pack.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR INTEGER NBITST C C====== LOCALS: C LOGICAL SPAT LOGICAL NODFLG INTEGER I INTEGER IERR INTEGER KERR INTEGER H INTEGER K INTEGER L INTEGER IXC INTEGER IYC INTEGER ISPIX INTEGER IFPIX INTEGER IXSIZ INTEGER IYSIZ INTEGER ITHRESH INTEGER IBG INTEGER NOVER INTEGER CUR_OBS INTEGER ISPOT INTEGER NXRAST INTEGER NYRAST INTEGER NF_OFF INTEGER IORD INTEGER ISWAP INTEGER IFLAG INTEGER ND INTEGER JH INTEGER JK INTEGER JL INTEGER MULT INTEGER NUMSPOTS INTEGER LISTE(2) REAL MM_RAST_X REAL MM_RAST_Y REAL SUMSQ REAL DIST2 REAL X_CEN_F REAL Y_CEN_F REAL X_CEN REAL Y_CEN REAL OMEGA REAL COSOM REAL SINOM REAL DEG_TO_RAD REAL TOO_FAR REAL SPOT_B REAL SPOT_D REAL CGX REAL CGY REAL RMS REAL STHRESH REAL STHRESH_SAV REAL SPOTL REAL SPOTW REAL SPOTB REAL SPOTD REAL X_C REAL Y_C REAL XFD REAL YFD REAL ALAM REAL DTHR2 CHARACTER*80 STR CHARACTER*2 VALSTR CHARACTER*2 ERRSTR C LOGICAL SPAT !Spatial overlap flag C LOGICAL NODFLG !Nodal spot flag C INTEGER I !Temp/loop variable C INTEGER IERR !Error flag C INTEGER KERR !Error flag C INTEGER H !Reflection h index C INTEGER K !Reflection k index C INTEGER L !Reflection l index C INTEGER IXC !Nearest x pixel position of box centre C INTEGER IYC !Nearest y pixel position of box centre C INTEGER ISPIX !Pixel position along slow axis C INTEGER IFPIX !Pixel position along fast axis C INTEGER IXSIZ !Half box x size for finding spot C INTEGER IYSIZ !Half box y size for finding spot C INTEGER ITHRESH !Threshold above background for finding spots C INTEGER IBG !Background value at spot position C INTEGER NOVER !No. of pixels in box above threshold C INTEGER CUR_OBS !Count of spots found C INTEGER ISPOT !Pointer to predicted spots list C INTEGER NXRAST !No. x-rasters C INTEGER NYRAST !No. y-rasters C INTEGER NF_OFF !Offset between start of slow rasters in image C INTEGER IORD !Axis order flag C INTEGER ISWAP !Byte swap flag C INTEGER IFLAG !Parameter status flag C INTEGER ND !No. of decimal places flag C INTEGER JH !h index C INTEGER JK !k index C INTEGER JL !l index C INTEGER MULT !Multiplicity C INTEGER NUMSPOTS !No. of spots in generated spots list C INTEGER LISTE(2) !Parameter update flags C REAL MM_RAST_X !mm to x-rasters conversion factor C REAL MM_RAST_Y !mm to y-rastrs conversion factor C REAL SUMSQ !Sum of square of obs-calc position differences C REAL DIST2 !Square of obs-calc distance C REAL X_CEN_F !Uncorrected x centre in rasters C REAL Y_CEN_F !Uncorrected y-centre in rasters C REAL X_CEN !Corrected x centre in rasters C REAL Y_CEN !Corrected y centre in rasters C REAL OMEGA !Corrected omega in degrees C REAL COSOM !Cos(omega) C REAL SINOM !Sin(omega) C REAL DEG_TO_RAD !Degrees to radians conversion C REAL TOO_FAR !Max shift poss. (mm) with all spot inside box C REAL SPOT_B !Spot box size to use C REAL SPOT_D !Spot diameter to use in closeness calculations C REAL CGX !Found spot c_of_g x position C REAL CGY !Found spot c_of_g y position C REAL RMS !Rms deviation obs. to calc. C REAL STHRESH !Spot search threshold C REAL STHRESH_SAV !Save spot search threshold C REAL SPOTL !Spot length C REAL SPOTW !Spot width C REAL SPOTB !Spot border C REAL SPOTD !Spot delta C REAL X_C !x_c value (mm) C REAL Y_C !y_c value (mm) C REAL XFD !X coordinate on detector (rast) (distort. corrected) C REAL YFD !Y coordinate on detector (rast) (distort. corrected) C REAL ALAM !Wavelength C REAL DTHR2 !dmin-threshold**2 C CHARACTER*80 STR !Temporary o/p message string C CHARACTER*2 VALSTR !Parameter value string (dummy) C CHARACTER*2 ERRSTR !Error string (dummy) C DATA DEG_TO_RAD/0.0174533/ C C------------------------------------------------------------------------------- C IQUIT = 0 CALL LDM_MMRAST (IPACK, IPLATE, MM_RAST_X, MM_RAST_Y) CALL LDM_GET_NXRAS (NXRAST, IFLAG) CALL LDM_GET_NYRAS (NYRAST, IFLAG) CALL LDM_GET_AXORD (VALSTR, IORD, ISWAP, IFLAG) C C====== Check that some spots selected for search C IF (NUM_SELECT.LE.0) THEN CALL ERR_NOTICE(0,'**No reflections selected for search**') IQUIT = 1 RETURN END IF C C====== Open film/image-plate file if needed C CALL CHK_OPN(IERR) IF (IERR.GT.0) THEN IQUIT = 1 RETURN END IF C C====== Read image if not already read C IF (.NOT.FILM_READ) CALL READ_IMAGE (0, IMG, MAX_IMG_WORDS, + ITYPE, NF_OFF, IERR, ERRSTR) IF (.NOT.FILM_READ) THEN IQUIT = 1 RETURN END IF C C====== See if radial masking to be used in spot position determination C CALL LDM_GET_SPOTW (IPACK, IPLATE, SPOTW, IFLAG, ND, IERR, ERRSTR) IF (SPOTW.NE.0.0) THEN USE_RADIAL = .TRUE. CALL IOW_ASKQ(IVH_IOW, + 'Use radial masks in spot position determination',USE_RADIAL) ELSE USE_RADIAL = .FALSE. END IF C C====== Set up box size and spot diameter for local use for normal or C====== radially streaked spots C IF (USE_RADIAL) THEN CALL LDM_GET_SPOTL (IPACK, IPLATE, SPOTL, IFLAG, ND, + IERR, ERRSTR) CALL LDM_GET_SPOTB (IPACK, IPLATE, SPOTB, IFLAG, ND, + IERR, ERRSTR) SPOT_B = SPOTL + (2.0 + SPOTB)/MM_RAST_X SPOT_D = SPOTW ELSE CALL LDM_GET_SPOTL (IPACK, IPLATE, SPOTL, IFLAG, ND, + IERR, ERRSTR) CALL LDM_GET_SPOTD (IPACK, IPLATE, SPOTD, IFLAG, ND, + IERR, ERRSTR) IF (ABS(SPOTL-SPOTL_LAST).GT.0.001.OR. + ABS(SPOTD-SPOTD_LAST).GT.0.001) THEN SPOTBOX = 2.0*SPOTD - SPOTL SPOTD_LAST = SPOTD SPOTL_LAST = SPOTL END IF CALL IOW_ASKF(IVH_IOW,'Box size (mm)',SPOTBOX,2) SPOT_B = SPOTBOX SPOT_D = SPOTL END IF C C====== Too_far (mm) is max. shift possible with all the spot inside box. C TOO_FAR = (SPOT_B - SPOT_D)/2.0 C C====== Get threshold C CALL LDM_GET_STHR (STHRESH, IFLAG, ND) STHRESH_SAV = STHRESH CALL IOW_ASKF(IVH_IOW, + 'Threshold above background for c_of_g calc', + STHRESH,1) IF (STHRESH.NE.STHRESH_SAV) THEN CALL LDM_SET_STHR (STHRESH, IERR, ERRSTR) LISTE(1) = IP_STHR CALL SET_PAR1_VALS (1, LISTE) END IF C C====== Search for reflections C CALL LMESSAGE(IVH_IOW,'===Searching for Reflections===') CUR_OBS = 0 C C====== Prepare for transform from recip. space to scanner space C CALL FILM_CENTRE(X_CEN_F,Y_CEN_F,OMEGA) CALL LDM_GET_XC (IPACK, IPLATE, X_C, IFLAG, ND, KERR, ERRSTR) CALL LDM_GET_YC (IPACK, IPLATE, Y_C, IFLAG, ND, KERR, ERRSTR) X_CEN = X_CEN_F + X_C*MM_RAST_X Y_CEN = Y_CEN_F + Y_C*MM_RAST_Y DEG_TO_RAD = 3.1415926536/180.0 COSOM = COS(OMEGA*DEG_TO_RAD) SINOM = SIN(OMEGA*DEG_TO_RAD) SUMSQ = 0.0 DO 30 I = 1 , NUM_SELECT IXSIZ = MM_RAST_X*SPOT_B/2.0 IYSIZ = MM_RAST_Y*SPOT_B/2.0 ISPOT = SEL_REFS(I) CALL LRL_GET (ISPOT, JH, JK, JL, XFD, YFD, ALAM, + DTHR2, MULT, NODFLG, SPAT, IERR) C C====== Reject if spatially overlapped C IF (.NOT.SPAT) THEN C C====== Round to nearest integer to be in scanner space C IXC = NINT(XFD) IYC = NINT(YFD) C C====== Get background and threshold C CALL SFPIX (IXC,IYC,ISPIX,IFPIX) CALL XDLF_BG_VALIMG(ISPIX,IFPIX,IMG_BG,ITYPE,NF_BGOFF, + NCMP,IBG, IERR) ITHRESH = IBG + NINT(STHRESH) IF (USE_RADIAL) THEN CALL SPOT_RADIAL (IXC, IYC, IXSIZ, IYSIZ, ISPOT_DATA, + ISWORK, ITHRESH, IMG, ITYPE, IORD, + NFRASTS, NXRAST, NYRAST, + X_CEN, Y_CEN, NOVER, + CGX, CGY, IERR) ELSE CALL SPOT_C_OF_G (IXC, IYC, IXSIZ, IYSIZ, ISPOT_DATA, + ISWORK, ITHRESH, IMG, ITYPE, IORD, NFRASTS, + NXRAST, NYRAST, NOVER, + CGX, CGY, IERR) END IF IF (NOVER.GT.0) THEN DIST2 = (XFD-CGX)**2 + (YFD-CGY)**2 C C====== Check each coord to see if some of spot is outside c of g box. C IF (ABS(XFD-CGX).GT.(TOO_FAR*MM_RAST_X)) THEN C C====== Because some of spot is outside box, expect true c of g to be C====== further towards edge of box. An approximation of distance C====== to move is the amount of spot that`s been cut off. C====== ie. (cgx-xfd) + spot_diam/2 - box_size/2 (put into right units) C IXC = CGX + (CGX-XFD) + + ((SPOT_D - SPOT_B)/2.*MM_RAST_X) ELSE IXC = CGX END IF C IF (ABS(YFD-CGY).GT.(TOO_FAR*MM_RAST_Y)) THEN IYC = CGY + (CGY-YFD) + + ((SPOT_D - SPOT_B)/2.*MM_RAST_Y) ELSE IYC = CGY END IF C C====== Re-centre if we didn`t get a true centre of gravity. C IF (ABS(XFD-CGX).GT.(TOO_FAR*MM_RAST_X) .OR. + ABS(YFD-CGY).GT.(TOO_FAR*MM_RAST_Y)) THEN C C====== True c of g should be within a spot radius of here, but C====== make box 1.5 times bigger just in case. C IXSIZ = SPOT_D/2.0*1.5*MM_RAST_X IYSIZ = SPOT_D/2.0*1.5*MM_RAST_Y IF (USE_RADIAL) THEN CALL SPOT_RADIAL (IXC, IYC, IXSIZ, IYSIZ, + ISPOT_DATA, ISWORK, ITHRESH, IMG, ITYPE, + IORD, NFRASTS, NXRAST, NYRAST, + X_CEN, Y_CEN, NOVER, + CGX, CGY, IERR) ELSE CALL SPOT_C_OF_G (IXC, IYC, IXSIZ, IYSIZ, + ISPOT_DATA, ISWORK, ITHRESH, IMG, ITYPE, IORD, + NFRASTS, NXRAST, NYRAST, NOVER, + CGX, CGY, IERR) END IF DIST2 = (XFD-CGX)**2 + (YFD-CGY)**2 END IF END IF IF (NOVER.GT.0) THEN CUR_OBS = CUR_OBS + 1 XM_OBS(CUR_OBS) = CGX YM_OBS(CUR_OBS) = CGY H = JH K = JK L = JL NODAL_H_S(CUR_OBS) = H NODAL_K_S(CUR_OBS) = K NODAL_L_S(CUR_OBS) = L HKL_KEY(CUR_OBS) = IABS(H) + IABS(K) + IABS(L) SUMSQ = SUMSQ + DIST2 END IF END IF 30 CONTINUE C C====== Make sure at least one spot was found C IF (CUR_OBS.LE.0) THEN CALL ERR_NOTICE(0,'**No reflections found in search**') IQUIT = 1 RETURN END IF C C====== Give rms for all spots C RMS = SQRT(SUMSQ/CUR_OBS)/MM_RAST_X STR = 'RMS =' CALL STR_ADDF(STR,RMS,3,1) CALL STR_ADDS(STR,'for',1) CALL STR_ADDI(STR,CUR_OBS,1) CALL STR_ADDS(STR,'spots',1) CALL LMESSAGE(IVH_IOW,STR) C C====== Set NUM_SRCH C NUM_OBS = CUR_OBS RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** SEL_FUNC ** C************************** C C SUBROUTINE SEL_FUNC C INCLUDE 'implicit_none.finc' C C Purpose: Handle input from select functions menu and parameter tables 1&2 C C Author: John W. Campbell, June 1991 C C Arguments: C C None C C====== Parameter statements C INCLUDE 'screen_params.finc' INCLUDE 'lauegen_limits.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'file_units.finc' INCLUDE 'prog_flags.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR C C====== LOCALS: C LOGICAL CONT LOGICAL QUIT INTEGER NVIEW INTEGER IVHLIST(4) INTEGER IVHLST2(2) INTEGER IVH INTEGER ITEM INTEGER IQUIT INTEGER IFAIL INTEGER I INTEGER IERR INTEGER M_RPARM INTEGER M_WRPARM INTEGER M_LAUE INTEGER M_DISP INTEGER M_FIND INTEGER M_PROCESS INTEGER LISTE(2) INTEGER IRET CHARACTER*(MAXFLEN) FILNAM CHARACTER*(MAXFLEN) PAR_FILE CHARACTER*150 CMDLIN C LOGICAL CONT !Continue to write file flag C LOGICAL QUIT !Quit program flag C INTEGER NVIEW !No. ov view objects for input C INTEGER IVHLIST(4) !View-object handles list C INTEGER IVHLST2(2) !2'nd view-object handles list C INTEGER IVH !Returned view-object handle C INTEGER ITEM !Returned menu item number C INTEGER IQUIT !Quit flag from menu C INTEGER IFAIL !File open failure flag C INTEGER I !Temp/loop variable C INTEGER IERR !Error flag C INTEGER M_RPARM !Menu item no.: Read parameters file C INTEGER M_WRPARM !Menu item no.: Write Parameters File C INTEGER M_LAUE !Menu item no.: Simulate Laue Patterns C INTEGER M_DISP !Menu item no.: Display/Measure Film C INTEGER M_FIND !Menu item no.: Find Orientation C INTEGER M_PROCESS !Menu item no.: Process C INTEGER LISTE(2) !Dummy array for SET_PAR1_VALS call C INTEGER IRET !Return flag from CHECK_INTEGRATE C CHARACTER*(MAXFLEN) FILNAM !Temp. file name string C CHARACTER*(MAXFLEN) PAR_FILE !Parameter (.ldm) file name C CHARACTER*150 CMDLIN !Command line C C------------------------------------------------------------------------------- C C C====== Intitialise menu item numbers C M_RPARM = 1 M_WRPARM = 2 M_LAUE = 3 M_DISP = 4 M_FIND = 5 M_PROCESS = 6 CALL LPROMPT (IVH_CMD, '> ') C C====== Set up 'Select Functions' Menu C 100 CALL SET_MENU1 C C====== Get input from Select Functions menu or Parameter table 1 C NVIEW = 4 IVHLIST(1) = IVH_MENU IVHLIST(2) = IVH_PAR1 IVHLIST(3) = IVH_PAR2 IVHLIST(4) = IVH_CMD CALL XDLF_GET_EVENTS (NVIEW, IVHLIST, IVH) IF (IVH.EQ.IVH_MENU) THEN C C====== Menu item selected C CALL XDLF_MENU_AREA_GETITEM (IVH_MENU, ITEM, IQUIT) C C======= Quit selected C IF (IQUIT.EQ.1) THEN CALL CHECK_INTEGRATED (2, 0, IRET) IF (IRET.LT.2) RETURN GO TO 100 END IF C C====== Read parameters file C IF (ITEM.EQ.M_RPARM) THEN CALL CHECK_INTEGRATED (4, 0, IRET) IF (IRET.EQ.2) GO TO 100 CALL READ_PAR_FILE (.FALSE., ' ') GO TO 100 C C====== Write Parameters File C ELSE IF (ITEM.EQ.M_WRPARM) THEN 110 CALL LPROMPT + (IVH_IOW, 'File name (default ext=.ldm): ') IVHLST2(1) = IVH_IOW CALL XDLF_GET_EVENTS (1, IVHLST2, IVH) CALL XDLF_IO_WINDOW_GETSTRING (IVH_IOW, XDLSTR(FILNAM), + MAXFLEN, IERR) IF (FILNAM.EQ.' ') GO TO 100 CALL FILEXT (FILNAM, 'ldm', PAR_FILE, I) CALL LGFILE_EXISTS (PAR_FILE, CONT) IF (.NOT.CONT) GO TO 110 IFAIL = 1 CALL CCPDPN (-IUN_GEN, PAR_FILE,'UNKNOWN','F',0,IFAIL) IF (IFAIL.LT.0) THEN CALL LMESSAGE(IVH_IOW,'**Error in opening the file**') GO TO 110 END IF CALL WRITE_PARFIL (PAR_FILE) CLOSE (UNIT=IUN_GEN) GO TO 100 C C====== Laue Simulations C ELSE IF (ITEM.EQ.M_LAUE) THEN CALL LAUE_SIMS GO TO 100 C C====== Display/Measure Film C ELSE IF (ITEM.EQ.M_DISP) THEN CALL DISPLAY_OPT GO TO 100 C C====== Find Orientation C ELSE IF (ITEM.EQ.M_FIND) THEN CALL AUTO_CNTL GO TO 100 C C====== Process C ELSE IF (ITEM.EQ.M_PROCESS) THEN CALL CHECK_INTEGRATED (5, 0, IRET) CALL XDLF_IO_WINDOW_PRINT (IVH_CMD, XDLSTR(' '), 1, 2, + IERR) CALL LAUEGEN_PROCESS CALL LPROMPT (IVH_CMD, '> ') GO TO 100 END IF GO TO 100 C C====== Parameter table 1 input C ELSE IF (IVH.EQ.IVH_PAR1) THEN CALL PAR1_INPUT GO TO 100 C C====== Parameter table 2 input C ELSE IF (IVH.EQ.IVH_PAR2) THEN CALL PAR2_INPUT GO TO 100 C C====== Command window input C ELSE IF (IVH.EQ.IVH_CMD) THEN CALL XDLF_IO_WINDOW_GETSTRING (IVH_CMD, XDLSTR(CMDLIN), + 150, IERR) CALL CMD_INPUT (CMDLIN, QUIT) IF (PROCESS) THEN CALL CHECK_INTEGRATED (5, 1, IRET) CALL LAUEGEN_PROCESS CALL LPROMPT (IVH_CMD, '> ') GO TO 100 END IF CALL LPROMPT (IVH_CMD, '> ') IF (QUIT) THEN CALL CHECK_INTEGRATED (2, 1, IRET) IF (IRET.LT.2) RETURN END IF GO TO 100 END IF GO TO 100 END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** SEL_INTEGRATE ** C************************** C C SUBROUTINE SEL_INTEGRATE C INCLUDE 'implicit_none.finc' C C Purpose: Integrate Spots control routine C C Author: John W. Campbell, December 1995 C C Arguments: C C None C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' INCLUDE 'screen_params.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'film_pack.finc' INCLUDE 'file_units.finc' INCLUDE 'integ_pars.finc' INCLUDE 'lirl_pars.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR INTEGER INTFP INTEGER LENSTR LOGICAL CCPEXS C C====== LOCALS: C LOGICAL ALL_INT LOGICAL ANY_INT LOGICAL ALL_WRITTEN LOGICAL ANY_PRES LOGICAL EXISTS LOGICAL SKIP_INT INTEGER M_RESET INTEGER M_INTEG INTEGER M_LAST INTEGER M_NEXTPL INTEGER M_AUTOPK INTEGER M_WRINT INTEGER M_NEXTPK INTEGER M_STAT INTEGER NUMP INTEGER NPLATES INTEGER NVIEW INTEGER IVHLIST(4) INTEGER IVH INTEGER ITEM INTEGER IQUIT INTEGER IERR INTEGER IFLAG INTEGER KEYPLATE INTEGER IPL INTEGER IFLG INTEGER IXROOT INTEGER IYROOT INTEGER IBUTTON INTEGER IRET INTEGER JLEN INTEGER ILEN INTEGER IFAIL CHARACTER*2 ERRSTR CHARACTER*(MAXFLEN) FILNAM CHARACTER*(MAXFLEN) MTZ_FILE CHARACTER*(MAXFLEN) GE1_FILE CHARACTER*(MAXFLEN) GE2_FILE C LOGICAL ALL_INT !Intensties present for all plates flag C LOGICAL ANY_INT !Any intensities present flag C LOGICAL ALL_WRITTEN !All intensities for current pack already written C LOGICAL ANY_PRES !.ge1 and/or .ge2 file already present flag C LOGICAL EXISTS !File exists flag C LOGICAL SKIP_INT !Skip plates already integrated flag C INTEGER M_RESET !Menu item no.: Reset to first pack C INTEGER M_INTEG !Menu item no.: Integrate Plate C INTEGER M_LAST !Menu item no.: Examine Last Integration C INGEGER M_NEXTPL !Menu item no.: Select Next Plate C INTEGER M_AUTOPK !Menu item no.: Auto-integrate Pack C INTEGER M_WRINT !Menu item no.: Write Intensities File C INTEGER M_NEXTPK !Menu item no.: Select Next Pack C INTEGER M_STAT !Menu item no.: Integration Status C INTEGER NUMP !No. of packs C INTEGER NPLATES !No. plates/pack C INTEGER NVIEW !No. of view-objects for getting events C INTEGER IVHLIST(4) !List of view-object handles for getting events C INTEGER IVH !Returned view-object handle from getting events C INTEGER ITEM !Item no. from menu selection C INTEGER IQUIT !Quit button flage from menu C INTEGER IERR !Error flag C INTEGER IFLAG !Parameter status flag C INTEGER KEYPLATE !Key plate C INTEGER IPL !Plates loop counter C INTEGER IFLG !Integration status flag C INTEGER IXROOT !X root position for popup notice C INTEGER IYROOT !Y root position for popup notice C INTEGER IBUTTON !Button selected from popup notice C INTEGER IRET !Return flag from MTZ file check routines C INTEGER JLEN !Length of filename up to extension C INTEGER ILEN !Length of filename up to extension C INTEGER IFAIL !File open failure flag C CHARACTER*2 ERRSTR !Error message string (dummy) C CHARACTER*(MAXFLEN) FILNAM !File name C CHARACTER*(MAXFLEN) MTZ_FILE !MTZ file name C CHARACTER*(MAXFLEN) GE1_FILE !.ge1 file name C CHARACTER*(MAXFLEN) GE2_FILE !.ge2 file name C C------------------------------------------------------------------------------- C C====== Check that pack input C CALL LDM_GET_NUMP (NUMP, IFLAG) IF (NUMP.EQ.0) THEN CALL ERR_NOTICE (1, '**Number of packs is zero**') RETURN END IF C C====== Get key plate for current pack C CALL LDM_GET_KEYP (IPACK, KEYPLATE, IFLAG, IERR, ERRSTR) C C====== Clear profiles flags on entry in case parameters affecting LRL C====== generation have been changed. C IPRF_PK = 0 IPRF_PL = 0 C C====== Intitialise menu item numbers C M_RESET = 1 M_INTEG = 2 M_LAST = 3 M_NEXTPL = 4 M_AUTOPK = 5 M_WRINT = 6 M_NEXTPK = 7 M_STAT = 8 C C====== Set up parameter table 3 & return current values for integration C control parameters C CALL INT_PTAB3 (0) C C====== Set up 'Integrate Options' Menu C 100 CALL SET_MENU10 C C====== Get input from 'Integration Options' menu or Parameter tables C NVIEW = 4 IVHLIST(1) = IVH_MENU IVHLIST(2) = IVH_PAR1 IVHLIST(3) = IVH_PAR2 IVHLIST(4) = IVH_PAR3 CALL XDLF_GET_EVENTS (NVIEW, IVHLIST, IVH) IF (IVH.EQ.IVH_MENU) THEN C C====== Menu item selected C CALL XDLF_MENU_AREA_GETITEM (IVH_MENU, ITEM, IQUIT) C C======= Quit (Return to Previous Menu) selected C IF (IQUIT.EQ.1) THEN CALL XDLF_PARAM_TABLE_CLEARITEMS (IVH_PAR3, IERR) RETURN END IF C C====== Reset to first pack and plate C IF (ITEM.EQ.M_RESET) THEN IF (IPACK.EQ.1.AND.IPLATE.EQ.1) GO TO 100 CALL SET_NEWPLATE (1, 1, IERR) CALL INT_PTAB3(2) GO TO 100 C C====== Integrate Plate C ELSE IF (ITEM.EQ.M_INTEG) THEN CALL LOG_CHANGES (1) CALL LDM_CH_RESET (1) CALL INTEGRATE_CALC (KEYPLATE, IERR) CALL LDM_CH_RESET (1) GO TO 100 C C====== Examine Last Integration C ELSE IF (ITEM.EQ.M_LAST) THEN IF (INTEG_LASTPK.EQ.0.OR.INTEG_LASTPL.EQ.0) THEN CALL ERR_NOTICE (1,'**No integration to examine**') GO TO 100 END IF CALL INTEGRATE_SHOW GO TO 100 C C====== Select Next Plate C ELSE IF (ITEM.EQ.M_NEXTPL) THEN CALL SET_NEWPLATE (IPACK, IPLATE+1, IERR) CALL INT_PTAB3(2) GO TO 100 C C====== Auto-integrate Pack C ELSE IF (ITEM.EQ.M_AUTOPK) THEN CALL LOG_CHANGES (1) CALL LDM_CH_RESET (1) SKIP_INT = .FALSE. CALL LDM_GET_NPLAT (NPLATES, IFLAG) ANY_INT = .FALSE. DO 110 IPL = 1, NPLATES CALL INTFLAG_GET (IPACK, IPL, IFLG) IF (IFLG.GT.0) ANY_INT = .TRUE. 110 CONTINUE IF (ANY_INT) THEN SKIP_INT = .TRUE. CALL IOW_ASKQ (IVH_IOW, + 'Skip plates already integrated', SKIP_INT) END IF CALL AUTO_INTEGRATE_CTL (1, SKIP_INT, ' ', 2, + NPROF, PROMIN, PRF_ROT, + IPRF_ALL, NOVLD, IERR) CALL LDM_CH_RESET (1) GO TO 100 C C====== Write Intensities File C ELSE IF (ITEM.EQ.M_WRINT) THEN C C====== See which plates integrated etc. C CALL LDM_GET_NPLAT (NPLATES, IFLAG) ALL_INT = .TRUE. ANY_INT = .FALSE. DO 120 IPL = 1, NPLATES CALL INTFLAG_GET (IPACK, IPL, IFLG) IF (IFLG.EQ.0) ALL_INT = .FALSE. IF (IFLG.GT.0) ANY_INT = .TRUE. 120 CONTINUE IF (.NOT.ANY_INT) THEN CALL ERR_NOTICE (1, + '**No integrated intensities for this pack**') GO TO 100 END IF ALL_WRITTEN = .TRUE. DO 130 IPL = 1, NPLATES CALL INTFLAG_GET (IPACK, IPL, IFLG) IF (IFLG.EQ.1) ALL_WRITTEN = .FALSE. 130 CONTINUE IF (ALL_WRITTEN) THEN CALL NOTICE_POSN(1, IXROOT, IYROOT) CALL XDLF_POPUP_NOTICE (IXROOT, IYROOT, + XDLSTR('*Intensities have already been written*'), 39, + XDLSTR(' '), -1, + XDLSTR('Cancel'), 6, + XDLSTR('Rewrite'), 7, + IFONT, 1, IBUTTON) IF (IBUTTON.EQ.1) GO TO 100 END IF CALL INT_FILNAM (' ', MTZ_FILE) IF (INT_TYP.EQ.1) THEN CALL MTZ_CHK1 (MTZ_FILE, IRET) IF (IRET.EQ.1) THEN CALL ERR_NOTICE (1, + '**MTZ file exists and cannot be overwritten**') GO TO 100 END IF IF (IRET.EQ.2) THEN CALL NOTICE_POSN(1, IXROOT, IYROOT) CALL XDLF_POPUP_NOTICE (IXROOT, IYROOT, + XDLSTR('*Overwrite existing file*'), 25, + XDLSTR(' '), -1, + XDLSTR('Yes'), 3, + XDLSTR('No'), 2, + IFONT, 1, IBUTTON) IF (IBUTTON.EQ.2) GO TO 100 END IF CALL MTZ_CHK2 (MTZ_FILE, IRET) IF (IRET.EQ.1) THEN CALL ERR_NOTICE (1, + '**Cannot open MTZ file**') GO TO 100 END IF ELSE CALL INT_FILNAM (' ', FILNAM) CALL FILEXT (FILNAM, 'xxx', GE1_FILE, ILEN) CALL FILEXT (FILNAM(1:ILEN), 'ge1', GE1_FILE, JLEN) CALL FILEXT (FILNAM(1:ILEN), 'ge2', GE2_FILE, JLEN) ANY_PRES = .FALSE. EXISTS = CCPEXS (GE1_FILE) IF (EXISTS) THEN CALL LMESSAGE(IVH_IOW,'**.ge1 file already exists**') ANY_PRES = .TRUE. END IF EXISTS = CCPEXS (GE2_FILE) IF (EXISTS) THEN CALL LMESSAGE(IVH_IOW,'**.ge2 file already exists**') ANY_PRES = .TRUE. END IF IF (ANY_PRES) THEN CALL NOTICE_POSN(1, IXROOT, IYROOT) CALL XDLF_POPUP_NOTICE (IXROOT, IYROOT, + XDLSTR('*Overwrite existing file(s)*'), 25, + XDLSTR(' '), -1, + XDLSTR('Yes'), 3, + XDLSTR('No'), 2, + IFONT, 1, IBUTTON) IF (IBUTTON.EQ.2) GO TO 100 END IF IFAIL = 1 CALL CCPDPN (-IUN_GE1, GE1_FILE,'UNKNOWN','DU',19,IFAIL) IF (IFAIL.LT.0) THEN CALL ERR_NOTICE (1, + '**Error in opening the .ge1 file**') GO TO 100 END IF IFAIL = 1 CALL CCPDPN (-IUN_GE2, GE2_FILE,'UNKNOWN','DU',2,IFAIL) IF (IFAIL.LT.0) THEN CALL ERR_NOTICE (1, + '**Error in opening the .ge2 file**') GO TO 100 END IF END IF CALL WRITE_INTFILE (IPACK, INT_TYP, SCAL_INT, + MTZ_FILE, GE1_FILE, GE2_FILE, IERR) IF (IERR.EQ.1) THEN CALL ERR_NOTICE (1, + '**Memory allocation error - could not write files**') END IF GO TO 100 C C====== Select next pack C ELSE IF (ITEM.EQ.M_NEXTPK) THEN CALL SET_NEWPLATE (IPACK+1, 1, IERR) CALL INT_PTAB3(2) GO TO 100 C C====== Integration Status C ELSE IF (ITEM.EQ.M_STAT) THEN CALL INTEG_STATUS GO TO 100 END IF GO TO 100 C C====== Parameter table 1 input C ELSE IF (IVH.EQ.IVH_PAR1) THEN CALL PAR1_INPUT IPRF_PK = 0 IPRF_PL = 0 GO TO 100 C C====== Parameter table 2 input C ELSE IF (IVH.EQ.IVH_PAR2) THEN CALL PAR2_INPUT IPRF_PK = 0 IPRF_PL = 0 GO TO 100 C C====== Parameter table 3 input C ELSE IF (IVH.EQ.IVH_PAR3) THEN CALL INT_PTAB3 (1) IPRF_PK = 0 IPRF_PL = 0 GO TO 100 END IF GO TO 100 END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** SEL_REFINE ** C************************** C C SUBROUTINE SEL_REFINE C INCLUDE 'implicit_none.finc' C C Purpose: Handle input select refinement functions menu and parameter tables C 1 and 2 C C Author: John W. Campbell, June 1991 C C Arguments: C C None C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' INCLUDE 'screen_params.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'prog_flags.finc' INCLUDE 'film_pack.finc' INCLUDE 'file_units.finc' INCLUDE 'lauegen_observed_spots.finc' INCLUDE 'spot_box.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR LOGICAL CCPEXS C C====== LOCALS: C LOGICAL EXISTS LOGICAL ANY_PRES LOGICAL CONT LOGICAL RFCL LOGICAL DFLT1 INTEGER NNOD INTEGER NVIEW INTEGER IVHLIST(3) INTEGER IVHLST2(2) INTEGER IVH INTEGER ITEM INTEGER IQUIT INTEGER IERR INTEGER I INTEGER IFAIL INTEGER IPLATE_SAV INTEGER IXROOT INTEGER IYROOT INTEGER IBUTTON INTEGER M_RESET INTEGER M_DISP INTEGER M_MATCH INTEGER M_SEL_SEARCH INTEGER M_NODALS INTEGER M_AUTPL INTEGER M_NEXTPL INTEGER M_AUTPK INTEGER M_WRITEGE INTEGER M_NEXTPK INTEGER LISTE(2) INTEGER NUMSPOTS INTEGER NUMP INTEGER IFLAG INTEGER KEYPLATE CHARACTER*2 ERRSTR CHARACTER*80 STR CHARACTER*(MAXFLEN) FILNAM CHARACTER*(MAXFLEN) GEN_FILE CHARACTER*(MAXFLEN) GE1_FILE CHARACTER*(MAXFLEN) GE2_FILE C C====== Variables for .gen/.ge files... will be removed later C LOGICAL WR_SPAT LOGICAL WR_CLOS LOGICAL DISTOR INTEGER MININT INTEGER PACK_ID INTEGER NUM_SPOTS INTEGER NUM_MULTIPLETS INTEGER NUM_SPATIALS INTEGER NUM_BOTH INTEGER NUM_NODALS C LOGICAL EXISTS !File exists flag C LOGICAL ANY_PRES !Any of the output files exists flag C LOGICAL CONT !Continue writing files flag C LOGICAL RFCL !Refine cell flag for auto-refine C LOGICAL DFLT1 !Default nodal index used for start cycles flag C INTEGER NNOD !Nodal index/no. of nodals flag for auto-refine C INTEGER NVIEW !No. of view objects for input C INTEGER IVHLIST(3) !View-object handles list C INTEGER IVHLST2(2) !2'nd view-object handles list C INTEGER IVH !Returned view-object handle C INTEGER ITEM !Returned menu item number C INTEGER IQUIT !Quit flag from menu C INTEGER IERR !Error flag C INTEGER I !Temp/loop variable C INTEGER IFAIL !Open file failure flag C INTEGER IPLATE_SAV !Saved current film/plate number C INTEGER IXROOT !Root x position for error notice C INTEGER IYROOT !Root y position for error notice C INTEGER IBUTTON !Button return from error notice C INTEGER M_RESET !Menu item no.: Reset to First Pack C INTEGER M_DISP !Menu item no.: Display/Measure Image C INTEGER M_MATCH !Menu item no.: Match Spots and Refine C INTEGER M_SEL_SEARCH !Menu item no.: Select, Search and Refine C INTEGER M_NODALS !Menu item no.: Nodals Search and Refine C INTEGER M_AUTPL !Menu item no.: Auto-refine Plate C INTEGER M_NEXTPL !Menu item no.: Select Next Plate C INTEGER M_AUTPK !Menu item no.: Auto-refine Pack C INTEGER M_WRITEGE !Menu item no.: Write .ge Files C INTEGER M_NEXTPK !Menu item no.: Select Next Pack C INTEGER LISTE(2) !Dummy array for SET_PAR1_VALS call C INTEGER NUMSPOTS !Number of Laue spots generated C INTEGER NUMP !Number of packs C INTEGER IFLAG !Parameter status flag C INTEGER KEYPLATE !Key plate C CHARACTER*2 ERRSTR !Error string C CHARACTER*80 STR !Temporary string C CHARACTER*(MAXFLEN) FILNAM !File name string C CHARACTER*(MAXFLEN) GEN_FILE !.gen file name C CHARACTER*(MAXFLEN) GE1_FILE !.ge1 file name C CHARACTER*(MAXFLEN) GE2_FILE !.ge2 file name C C------------------------------------------------------------------------------- C C====== Check that pack input C CALL LDM_GET_NUMP (NUMP, IFLAG) IF (NUMP.EQ.0) THEN CALL ERR_NOTICE (1, '**Number of packs is zero**') RETURN END IF C C====== Get key plate for current pack C CALL LDM_GET_KEYP (IPACK, KEYPLATE, IFLAG, IERR, ERRSTR) C C====== Zero spot box size calculation parameters C SPOTD_LAST = 0.0 SPOTL_LAST = 0.0 USE_RADIAL = .FALSE. C C====== Intitialise menu item numbers C M_RESET = 1 M_DISP = 2 M_MATCH = 3 M_SEL_SEARCH = 4 M_NODALS = 5 M_AUTPL = 6 M_NEXTPL = 7 M_AUTPK = 8 M_WRITEGE = 9 M_NEXTPK = 10 C C====== Set up 'Refinement Options' Menu C 100 CALL SET_MENU3 C C====== Get input from 'Refinement Options' menu or Parameter tables 1 & 2 C NVIEW = 3 IVHLIST(1) = IVH_MENU IVHLIST(2) = IVH_PAR1 IVHLIST(3) = IVH_PAR2 CALL XDLF_GET_EVENTS (NVIEW, IVHLIST, IVH) IF (IVH.EQ.IVH_MENU) THEN C C====== Menu item selected C CALL XDLF_MENU_AREA_GETITEM (IVH_MENU, ITEM, IQUIT) C C======= Quit (Return to Previous Menu) selected C IF (IQUIT.EQ.1) RETURN C C====== Reset to First Pack C IF (ITEM.EQ.M_RESET) THEN IF (IPACK.EQ.1) GO TO 100 CALL SET_NEWPLATE (1, 0, IERR) CALL LDM_GET_KEYP (IPACK, KEYPLATE, IFLAG, IERR, ERRSTR) GO TO 100 C C====== Display/Measure Image C ELSE IF (ITEM.EQ.M_DISP) THEN CALL DISPLAY_OPT GO TO 100 C C====== Match Spots and Refine C ELSE IF (ITEM.EQ.M_MATCH) THEN CALL CHK_REFINE (IQUIT) IF (IQUIT.EQ.1) GO TO 100 CALL CALC_LAUE (.TRUE.) CALL LRL_NUMSPOTS (NUMSPOTS) IF (NUMSPOTS.EQ.0) THEN CALL LMESSAGE(IVH_IOW,'**No Generated Spots**') GO TO 100 END IF CALL MATCH_SPOTS (IERR) IF (IERR.GT.0) GO TO 100 CALL MATCH_TO_OBS IF (NUM_OBS.EQ.0) GO TO 100 CALL PREPARE_REFIN (IQUIT) IF (IQUIT.EQ.1) GO TO 100 CALL LOG_CHANGES (1) CALL LDM_CH_RESET (1) CALL REFINE_CALC CALL LDM_CH_RESET (1) GO TO 100 C C====== Select, Search and Refine C ELSE IF (ITEM.EQ.M_SEL_SEARCH) THEN CALL CHK_REFINE (IQUIT) IF (IQUIT.EQ.1) GO TO 100 CALL CALC_LAUE (.TRUE.) CALL LRL_NUMSPOTS (NUMSPOTS) IF (NUMSPOTS.EQ.0) THEN CALL LMESSAGE(IVH_IOW,'**No Generated Spots**') GO TO 100 END IF CALL SELECT_REFS (IERR) IF (IERR.GT.0) GO TO 100 CALL SEARCH_SPOTS(IQUIT) IF (IQUIT.EQ.1) GO TO 100 CALL PREPARE_REFIN (IQUIT) IF (IQUIT.EQ.1) GO TO 100 CALL LOG_CHANGES (1) CALL LDM_CH_RESET (1) CALL REFINE_CALC CALL LDM_CH_RESET (1) GO TO 100 C C====== Nodals Search and Refine C ELSE IF (ITEM.EQ.M_NODALS) THEN CALL CHK_REFINE (IQUIT) IF (IQUIT.EQ.1) GO TO 100 CALL CALC_LAUE (.TRUE.) CALL LRL_NUMSPOTS (NUMSPOTS) IF (NUMSPOTS.EQ.0) THEN CALL LMESSAGE(IVH_IOW,'**No Generated Spots**') GO TO 100 END IF CALL FIND_SEL_NODS (1, 0, 1, 1, 0, 0, 0) CALL SEARCH_SPOTS(IQUIT) IF (IQUIT.EQ.1) GO TO 100 CALL PREPARE_REFIN (IQUIT) IF (IQUIT.EQ.1) GO TO 100 CALL LOG_CHANGES (1) CALL LDM_CH_RESET (1) CALL REFINE_CALC CALL LDM_CH_RESET (1) GO TO 100 C C====== Auto-refine plate C ELSE IF (ITEM.EQ.M_AUTPL) THEN CALL CHK_REFINE (IQUIT) IF (IQUIT.EQ.1) GO TO 100 STR = 'plate' RFCL = .FALSE. IF (IPACK.EQ.1.AND.IPLATE.EQ.KEYPLATE) THEN RFCL = .TRUE. CALL IOW_ASKQ (IVH_IOW, 'Refine cell parameters', RFCL) END IF IF (RFCL) THEN CALL STR_ADDS (STR, 'cell', 1) ELSE CALL STR_ADDS (STR, 'nocell', 1) END IF DFLT1 = .TRUE. NNOD = 4 CALL IOW_ASKI (IVH_IOW, 'Start nodal index or no. spots', + NNOD) IF (NNOD.NE.4) THEN CALL STR_ADDI (STR, NNOD, 1) DFLT1 = .FALSE. END IF NNOD = 6 CALL IOW_ASKI (IVH_IOW, 'Final nodal index or no. spots', + NNOD) IF (NNOD.NE.6.OR..NOT.DFLT1) CALL STR_ADDI (STR, NNOD, 1) CALL LOG_CHANGES (1) CALL LDM_CH_RESET (1) CALL AUTO_REFINE_CTL (1, STR, 2, 1, 4, 6) CALL LDM_CH_RESET (1) GO TO 100 C C====== Select Next Plate C ELSE IF (ITEM.EQ.M_NEXTPL) THEN CALL SET_NEWPLATE (IPACK, IPLATE+1, IERR) GO TO 100 C C====== Auto-refine pack C ELSE IF (ITEM.EQ.M_AUTPK) THEN STR = 'pack' RFCL = .FALSE. IF (IPACK.EQ.1) THEN RFCL = .TRUE. CALL IOW_ASKQ (IVH_IOW, 'Refine cell parameters', RFCL) END IF IF (RFCL) THEN CALL STR_ADDS (STR, 'cell', 1) ELSE CALL STR_ADDS (STR, 'nocell', 1) END IF DFLT1 = .TRUE. NNOD = 4 CALL IOW_ASKI (IVH_IOW, 'Start nodal index or no. spots', + NNOD) IF (NNOD.NE.4) THEN CALL STR_ADDI (STR, NNOD, 1) DFLT1 = .FALSE. END IF NNOD = 6 CALL IOW_ASKI (IVH_IOW, 'Final nodal index or no. spots', + NNOD) IF (NNOD.NE.6.OR..NOT.DFLT1) CALL STR_ADDI (STR, NNOD, 1) CALL LOG_CHANGES (1) CALL LDM_CH_RESET (1) CALL AUTO_REFINE_CTL (1, STR, 2, 1, 4, 6) CALL LDM_CH_RESET (1) GO TO 100 C C====== Write .ge Files C ELSE IF (ITEM.EQ.M_WRITEGE) THEN 110 CALL LPROMPT + (IVH_IOW, 'Root name for .gen/.ge1/.ge2 files: ') IVHLST2(1) = IVH_IOW CALL XDLF_GET_EVENTS (1, IVHLST2, IVH) CALL XDLF_IO_WINDOW_GETSTRING (IVH_IOW, XDLSTR(FILNAM), + MAXFLEN, IERR) IF (FILNAM.EQ.' ') GO TO 100 ANY_PRES = .FALSE. CALL FILEXT (FILNAM, 'gen', GEN_FILE, I) EXISTS = CCPEXS (GEN_FILE) IF (EXISTS) THEN CALL LMESSAGE(IVH_IOW,'**.gen file already exists**') ANY_PRES = .TRUE. END IF CALL FILEXT (FILNAM, 'ge1', GE1_FILE, I) EXISTS = CCPEXS (GE1_FILE) IF (EXISTS) THEN CALL LMESSAGE(IVH_IOW,'**.ge1 file already exists**') ANY_PRES = .TRUE. END IF CALL FILEXT (FILNAM, 'ge2', GE2_FILE, I) EXISTS = CCPEXS (GE2_FILE) IF (EXISTS) THEN CALL LMESSAGE(IVH_IOW,'**.ge2 file already exists**') ANY_PRES = .TRUE. END IF IF (ANY_PRES) THEN CONT = .FALSE. CALL IOW_ASKQ (IVH_IOW, 'Overwrite existing files', + CONT) IF (.NOT.CONT) GO TO 110 END IF IFAIL = 1 CALL CCPDPN (-IUN_GEN, GEN_FILE,'UNKNOWN','F',0,IFAIL) IF (IFAIL.LT.0) THEN CALL LMESSAGE(IVH_IOW, + '**Error in opening the .gen file**') GO TO 110 END IF CALL WRITE_GENFIL CLOSE (UNIT=IUN_GEN) IFAIL = 1 CALL CCPDPN (-IUN_GE1, GE1_FILE,'UNKNOWN','DU',19,IFAIL) IF (IFAIL.LT.0) THEN CALL LMESSAGE(IVH_IOW, + '**Error in opening the .ge1 file**') GO TO 110 END IF IFAIL = 1 CALL CCPDPN (-IUN_GE2, GE2_FILE,'UNKNOWN','DU',2,IFAIL) IF (IFAIL.LT.0) THEN CALL LMESSAGE(IVH_IOW, + '**Error in opening the .ge2 file**') GO TO 110 END IF WR_SPAT = .FALSE. CALL IOW_ASKQ(IVH_IOW, + 'Do you want to write spatials to the file',WR_SPAT) WR_CLOS = .FALSE. MININT = 100 CALL IOW_ASKI(IVH_IOW, + 'Enter Min I to by-pass measurements on subsequent plates', + MININT) DISTOR = .FALSE. CALL LDM_GET_PID (IPACK, PACK_ID, IFLAG, IERR, ERRSTR) CALL WRITE_GEFILE (IPACK, IUN_GE1, IUN_GE2, WR_SPAT, + WR_CLOS,DISTOR, MININT, PACK_ID, + KEYPLATE, NUM_SPOTS, NUM_MULTIPLETS, + NUM_SPATIALS, NUM_BOTH, NUM_NODALS) WRITE (STR,6060) NUM_SPOTS CALL LMESSAGE(IVH_IOW,STR) WRITE (STR,6070) NUM_MULTIPLETS CALL LMESSAGE(IVH_IOW,STR) WRITE (STR,6080) NUM_SPATIALS CALL LMESSAGE(IVH_IOW,STR) WRITE (STR,6090) NUM_BOTH CALL LMESSAGE(IVH_IOW,STR) WRITE (STR,6100) NUM_NODALS CALL LMESSAGE(IVH_IOW,STR) GO TO 100 C C====== Select Next Pack C ELSE IF (ITEM.EQ.M_NEXTPK) THEN IF (IPACK.EQ.NUMP) GO TO 100 CALL SET_NEWPLATE (IPACK+1, 1, IERR) CALL LDM_GET_KEYP (IPACK, KEYPLATE, IFLAG, IERR, ERRSTR) GO TO 100 END IF GO TO 100 C C====== Parameter table 1 input C ELSE IF (IVH.EQ.IVH_PAR1) THEN CALL PAR1_INPUT CALL LDM_GET_KEYP (IPACK, KEYPLATE, IFLAG, IERR, ERRSTR) GO TO 100 C C====== Parameter table 2 input C ELSE IF (IVH.EQ.IVH_PAR2) THEN CALL PAR2_INPUT GO TO 100 END IF GO TO 100 C C====== Format statements C 6060 FORMAT ('Summary:',I6,' spots output, of which') 6070 FORMAT (8X,I6,' were multiplets,') 6080 FORMAT (8X,I6,' were spatial overlaps,') 6090 FORMAT (8X,I6,' were both, and') 6100 FORMAT (8X,I6,' were nodals.') END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** SEL_SOFT ** C************************** C C SUBROUTINE SEL_SOFT C INCLUDE 'implicit_none.finc' C C Purpose: Improve soft limits control routine C C Author: John W. Campbell, March 1994 C C Arguments: C C None C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' INCLUDE 'screen_params.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'get_soft.finc' INCLUDE 'film_pack.finc' INCLUDE 'integ_pars.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR INTEGER INTFP INTEGER LENSTR C C====== LOCALS: C INTEGER M_RESET INTEGER M_DMIN INTEGER M_LMIN INTEGER M_NEXT INTEGER IP_NPROF INTEGER IP_ROTAT INTEGER IP_PROMIN INTEGER IP_DNUMB INTEGER IP_DWIDTH INTEGER IP_LNUMB INTEGER IP_LWIDTH INTEGER IP_FRAC INTEGER IP_SIGTEST INTEGER IP_FRTEST INTEGER NUMP INTEGER NVIEW INTEGER IVHLIST(4) INTEGER IVH INTEGER ITM INTEGER ITEM INTEGER IQUIT INTEGER IERR INTEGER ITYP INTEGER IFLAG INTEGER ND INTEGER IV INTEGER KEYPLATE INTEGER ITOG REAL FP REAL DMIN REAL LMIN CHARACTER*(MAX_P3SCROLL_CHARS) PVAL CHARACTER*80 ERRSTR CHARACTER*80 STR C INTEGER M_RESET !Menu item no.: Reset to first pack C INTEGER M_DMIN !Menu item no.: Dmin soft limit determination C INTEGER M_LMIN !Menu item no.: Lmin soft limit determination C INTEGER M_NEXT !Menu item no.: Select next pack C INTEGER IP_NPROF !Parameter table item no.: No. profile bins C INTEGER IP_ROTAT !Parameter table 3 item: Rotate profiles flag C INTEGER IP_PROMIN !Parameter table item no.: Min I for profiles C INTEGER IP_DNUMB !Parameter table item no.: No. 'dmin' bins C INTEGER IP_DWIDTH !Parameter table item no.: 'dmin' bin width C INTEGER IP_LNUMB !Parameter table item no.: No. 'lmin' bins C INTEGER IP_LWIDTH !Parameter table item no.: 'lmin' bin width C INTEGER IP_FRAC !Parameter table item no.: Start soft limit fraction C INTEGER IP_SIGTEST !Parameter table item no.: Significant intensity test C INTEGER IP_FRTEST !Parameter table item no.: Soft limit criterion C INTEGER NUMP !No. of packs C INTEGER NVIEW !No. of view-objects for getting events C INTEGER IVHLIST(4) !List of view-object handles for getting events C INTEGER IVH !Returned view-object handle from getting events C INTEGER ITM !Item no. modified in parameter table C INTEGER ITEM !Item no. from menu selection C INTEGER IQUIT !Quit button flage from menu C INTEGER IERR !Error flag C INTEGER ITYP !Return flag from INTFP or extended LDM param type C INTEGER IFLAG !Parameter status flag C INTEGER ND !No. of decimal places flag C INTEGER IV !Integer value C INTEGER ITOG !Parameter table toggle flag C INTEGER KEYPLATE !Key plate C REAL FP !Real value C REAL DMIN !'dmin' value C REAL LMIN !'lambda-min' value C CHARACTER*(MAX_P3SCROLL_CHARS) PVAL !String for parameter table input value C CHARACTER*80 ERRSTR !Error message string C CHARACTER*80 STR !String C C------------------------------------------------------------------------------- C C====== Check that pack input C CALL LDM_GET_NUMP (NUMP, IFLAG) IF (NUMP.EQ.0) THEN CALL ERR_NOTICE (1, '**Number of packs is zero**') RETURN END IF C C====== Reset to key plate if current plate is not key plate C CALL SET_KEYPLATE C C====== Get key plate for current pack C CALL LDM_GET_KEYP (IPACK, KEYPLATE, IFLAG, IERR, ERRSTR) C C====== Intitialise menu item numbers C M_RESET = 1 M_DMIN = 2 M_LMIN = 3 M_NEXT = 4 C C====== Set up parameter table 3 C IP_NPROF = 1 IP_ROTAT = 2 IP_PROMIN = 3 IP_DNUMB = 4 IP_DWIDTH = 5 IP_LNUMB = 6 IP_LWIDTH = 7 IP_FRAC = 8 IP_SIGTEST = 9 IP_FRTEST = 10 C C====== Get bin width sizes C CALL SOFT_BINS (1, ISOFT_D_NUMBINS, SOFT_DMIN_WIDTH) CALL SOFT_BINS (2, ISOFT_L_NUMBINS, SOFT_LMIN_WIDTH) CALL LDM_GET ('NPROF', 1, 1, STR, + FP, ND, NPROF, IFLAG, ITYP, IERR, ERRSTR) WRITE (STR,'(I8)') NPROF CALL LJUST(STR) CALL XDLF_PARAM_TABLE_SETITEM (IVH_PAR3, IP_NPROF, + XDLSTR('nprof:'), 6, + XDLSTR(STR),25, 0, 1, IERR) PRF_ROT = .FALSE. CALL LDM_GET ('PROF_ROTATE', IPACK, IPLATE, STR, + FP, ND, IV, IFLAG, ITYP, IERR, ERRSTR) IF (STR.EQ.'yes') PRF_ROT = .TRUE. ITOG = 4 IF (PRF_ROT) ITOG = 3 CALL XDLF_PARAM_TABLE_SETITEM (IVH_PAR3, IP_ROTAT, + XDLSTR('prof_rotate:'), 12, + XDLSTR(' '), 1, ITOG, 1, IERR) CALL LDM_GET ('PROMIN', 1, 1, STR, + PROMIN, ND, IV, IFLAG, ITYP, IERR, ERRSTR) WRITE (STR,'(F8.1)') PROMIN CALL LJUST (STR) CALL XDLF_PARAM_TABLE_SETITEM (IVH_PAR3, IP_PROMIN, + XDLSTR('promin:'), 7, + XDLSTR(STR), LENSTR(STR), 0, 1, IERR) WRITE (STR,'(I8)') ISOFT_D_NUMBINS CALL LJUST(STR) CALL XDLF_PARAM_TABLE_SETITEM (IVH_PAR3, IP_DNUMB, + XDLSTR('No. ''dmin'' bins:'), 16, + XDLSTR(STR),25, 0, 0, IERR) WRITE (STR,'(F8.2)') SOFT_DMIN_WIDTH CALL LJUST (STR) CALL XDLF_PARAM_TABLE_SETITEM (IVH_PAR3, IP_DWIDTH, + XDLSTR('Bin width (dmin):'), 17, + XDLSTR(STR), LENSTR(STR), 0, 0, IERR) WRITE (STR,'(I8)') ISOFT_L_NUMBINS CALL LJUST(STR) CALL XDLF_PARAM_TABLE_SETITEM (IVH_PAR3, IP_LNUMB, + XDLSTR('No. ''lmin'' bins:'), 16, + XDLSTR(STR),25, 0, 0, IERR) WRITE (STR,'(F8.2)') SOFT_LMIN_WIDTH CALL LJUST (STR) CALL XDLF_PARAM_TABLE_SETITEM (IVH_PAR3, IP_LWIDTH, + XDLSTR('Bin width (lmin):'), 17, + XDLSTR(STR), LENSTR(STR), 0, 0, IERR) WRITE (STR,'(F8.2)') SOFT_FRAC CALL LJUST (STR) CALL XDLF_PARAM_TABLE_SETITEM (IVH_PAR3, IP_FRAC, + XDLSTR('Start fraction:'), 15, + XDLSTR(STR), LENSTR(STR), 0, 0, IERR) WRITE (STR,'(F8.1)') SOFT_SIGTEST CALL LJUST (STR) CALL XDLF_PARAM_TABLE_SETITEM (IVH_PAR3, IP_SIGTEST, + XDLSTR('Sigma test:'), 11, + XDLSTR(STR), LENSTR(STR), 0, 0, IERR) WRITE (STR,'(F8.2)') SOFT_FRTEST CALL LJUST (STR) CALL XDLF_PARAM_TABLE_SETITEM (IVH_PAR3, IP_FRTEST, + XDLSTR('Fraction test:'), 14, + XDLSTR(STR), LENSTR(STR), 0, 0, IERR) C C====== Set up 'Refinement Options' Menu C 100 CALL SET_MENU8 C C====== Get input from 'Soft Limits Options' menu or Parameter tables 1 & 2 C NVIEW = 4 IVHLIST(1) = IVH_MENU IVHLIST(2) = IVH_PAR1 IVHLIST(3) = IVH_PAR2 IVHLIST(4) = IVH_PAR3 CALL XDLF_GET_EVENTS (NVIEW, IVHLIST, IVH) IF (IVH.EQ.IVH_MENU) THEN C C====== Menu item selected C CALL XDLF_MENU_AREA_GETITEM (IVH_MENU, ITEM, IQUIT) C C======= Quit (Return to Previous Menu) selected C IF (IQUIT.EQ.1) THEN CALL XDLF_PARAM_TABLE_CLEARITEMS (IVH_PAR3, IERR) RETURN END IF C C====== Reset to first pack (and keyplate) C IF (ITEM.EQ.M_RESET) THEN IF (IPACK.EQ.1.AND.IPLATE.EQ.KEYPLATE) GO TO 100 CALL SET_NEWPLATE (1, 0, IERR) GO TO 100 C C====== Determine 'dmin' C ELSE IF (ITEM.EQ.M_DMIN) THEN CALL LOG_CHANGES (1) CALL LDM_CH_RESET (1) CALL SOFT_CALC (1, IERR) CALL LDM_CH_RESET (1) GO TO 100 C C====== Determine 'lmin' C ELSE IF (ITEM.EQ.M_LMIN) THEN CALL LOG_CHANGES (1) CALL LDM_CH_RESET (1) CALL SOFT_CALC (2, IERR) CALL LDM_CH_RESET (1) GO TO 100 C C====== Select next pack C ELSE IF (ITEM.EQ.M_NEXT) THEN CALL SET_NEWPLATE (IPACK+1, 0, IERR) GO TO 100 END IF GO TO 100 C C====== Parameter table 1 input C ELSE IF (IVH.EQ.IVH_PAR1) THEN CALL PAR1_INPUT GO TO 100 C C====== Parameter table 2 input C ELSE IF (IVH.EQ.IVH_PAR2) THEN CALL PAR2_INPUT GO TO 100 C C====== Parameter table 3 input C ELSE IF (IVH.EQ.IVH_PAR3) THEN CALL XDLF_PARAM_TABLE_GETVALUE (IVH_PAR3, ITM, + XDLSTR(PVAL), MAX_P3SCROLL_CHARS, IERR) IF (ITM.EQ.IP_NPROF) THEN CALL LDM_SET ('NPROF', IPACK, IPLATE, PVAL, + IERR, ERRSTR) IF (IERR.NE.0) THEN CALL XDLF_PARAM_TABLE_ERROR (IVH_PAR3, ITM, + XDLSTR(ERRSTR), LENSTR(ERRSTR), IERR) GO TO 100 END IF GO TO 100 ELSE IF (ITM.EQ.IP_ROTAT) THEN CALL LDM_SET ('PROF_ROTATE', IPACK, IPLATE, PVAL, + IERR, ERRSTR) IF (IERR.NE.0) THEN CALL XDLF_PARAM_TABLE_ERROR (IVH_PAR3, ITM, + XDLSTR(ERRSTR), LENSTR(ERRSTR), IERR) GO TO 100 END IF GO TO 100 ELSE IF (ITM.EQ.IP_PROMIN) THEN CALL LDM_SET ('PROMIN', IPACK, IPLATE, PVAL, + IERR, ERRSTR) IF (IERR.NE.0) THEN CALL XDLF_PARAM_TABLE_ERROR (IVH_PAR3, ITM, + XDLSTR(ERRSTR), LENSTR(ERRSTR), IERR) GO TO 100 END IF GO TO 100 ELSE IF (ITM.EQ.IP_DNUMB) THEN ITYP = INTFP (PVAL, FP, IV) IF (ITYP.NE.1) THEN CALL XDLF_PARAM_TABLE_ERROR (IVH_PAR3, ITM, + XDLSTR('**Invalid Integer Format**'), 26, IERR) GO TO 100 END IF IF (IV.LT.0) THEN CALL XDLF_PARAM_TABLE_ERROR (IVH_PAR3, ITM, + XDLSTR('**Must be >= 0**'), 16, IERR) GO TO 100 END IF IF (IV.GT.MAX_SOFT_BINS) THEN STR = '**Number of bins exceeds limit of' CALL STR_ADDI (STR,MAX_SOFT_BINS,1) CALL STR_ADDS (STR,'**',0) CALL XDLF_PARAM_TABLE_ERROR (IVH_PAR3, ITM, + XDLSTR(STR), LENSTR(STR), IERR) GO TO 100 END IF ISOFT_D_NUMBINS = IV WRITE (STR,'(I8)') ISOFT_D_NUMBINS CALL LJUST(STR) CALL XDLF_PARAM_TABLE_SETVALUE (IVH_PAR3, ITM, + XDLSTR(STR), LENSTR(STR), 0, IERR) GO TO 100 ELSE IF (ITM.EQ.IP_DWIDTH) THEN ITYP = INTFP (PVAL, FP, IV) IF (ITYP.EQ.0) THEN CALL XDLF_PARAM_TABLE_ERROR (IVH_PAR3, ITM, + XDLSTR('**Invalid Number Format**'), 25, IERR) GO TO 100 END IF IF (FP.LE.0) THEN CALL XDLF_PARAM_TABLE_ERROR (IVH_PAR3, ITM, + XDLSTR('**Value must be greater than zero**'), 35, IERR) GO TO 100 END IF SOFT_DMIN_WIDTH = FP WRITE (STR,'(F8.2)') SOFT_DMIN_WIDTH CALL LJUST(STR) CALL XDLF_PARAM_TABLE_SETVALUE (IVH_PAR3, ITM, + XDLSTR(STR), LENSTR(STR), 0, IERR) GO TO 100 ELSE IF (ITM.EQ.IP_LNUMB) THEN ITYP = INTFP (PVAL, FP, IV) IF (ITYP.NE.1) THEN CALL XDLF_PARAM_TABLE_ERROR (IVH_PAR3, ITM, + XDLSTR('**Invalid Integer Format**'), 26, IERR) GO TO 100 END IF IF (IV.LT.0) THEN CALL XDLF_PARAM_TABLE_ERROR (IVH_PAR3, ITM, + XDLSTR('**Must be >= 0**'), 16, IERR) GO TO 100 END IF IF (IV.GT.MAX_SOFT_BINS) THEN STR = '**Number of bins exceeds limit of' CALL STR_ADDI (STR,MAX_SOFT_BINS,1) CALL STR_ADDS (STR,'**',0) CALL XDLF_PARAM_TABLE_ERROR (IVH_PAR3, ITM, + XDLSTR(STR), LENSTR(STR), IERR) GO TO 100 END IF ISOFT_L_NUMBINS = IV WRITE (STR,'(I8)') ISOFT_L_NUMBINS CALL LJUST(STR) CALL XDLF_PARAM_TABLE_SETVALUE (IVH_PAR3, ITM, + XDLSTR(STR), LENSTR(STR), 0, IERR) GO TO 100 ELSE IF (ITM.EQ.IP_LWIDTH) THEN ITYP = INTFP (PVAL, FP, IV) IF (ITYP.EQ.0) THEN CALL XDLF_PARAM_TABLE_ERROR (IVH_PAR3, ITM, + XDLSTR('**Invalid Number Format**'), 25, IERR) GO TO 100 END IF IF (FP.LE.0) THEN CALL XDLF_PARAM_TABLE_ERROR (IVH_PAR3, ITM, + XDLSTR('**Value must be greater than zero**'), 35, IERR) GO TO 100 END IF SOFT_LMIN_WIDTH = FP WRITE (STR,'(F8.2)') SOFT_LMIN_WIDTH CALL LJUST(STR) CALL XDLF_PARAM_TABLE_SETVALUE (IVH_PAR3, ITM, + XDLSTR(STR), LENSTR(STR), 0, IERR) GO TO 100 ELSE IF (ITM.EQ.IP_FRAC) THEN ITYP = INTFP (PVAL, FP, IV) IF (ITYP.EQ.0) THEN CALL XDLF_PARAM_TABLE_ERROR (IVH_PAR3, ITM, + XDLSTR('**Invalid Number Format**'), 25, IERR) GO TO 100 END IF IF (FP.LE.0) THEN CALL XDLF_PARAM_TABLE_ERROR (IVH_PAR3, ITM, + XDLSTR('**Value must be greater than zero**'), 35, IERR) GO TO 100 END IF IF (FP.GT.1.0) THEN CALL XDLF_PARAM_TABLE_ERROR (IVH_PAR3, ITM, + XDLSTR('**Value must be <= 1.0**'), 24, IERR) GO TO 100 END IF SOFT_FRAC = FP WRITE (STR,'(F8.2)') SOFT_FRAC CALL LJUST(STR) CALL XDLF_PARAM_TABLE_SETVALUE (IVH_PAR3, ITM, + XDLSTR(STR), LENSTR(STR), 0, IERR) GO TO 100 ELSE IF (ITM.EQ.IP_SIGTEST) THEN ITYP = INTFP (PVAL, FP, IV) IF (ITYP.EQ.0) THEN CALL XDLF_PARAM_TABLE_ERROR (IVH_PAR3, ITM, + XDLSTR('**Invalid Number Format**'), 25, IERR) GO TO 100 END IF IF (FP.LE.0) THEN CALL XDLF_PARAM_TABLE_ERROR (IVH_PAR3, ITM, + XDLSTR('**Value must be greater than zero**'), 35, IERR) GO TO 100 END IF SOFT_SIGTEST = FP WRITE (STR,'(F8.1)') SOFT_SIGTEST CALL LJUST(STR) CALL XDLF_PARAM_TABLE_SETVALUE (IVH_PAR3, ITM, + XDLSTR(STR), LENSTR(STR), 0, IERR) GO TO 100 ELSE IF (ITM.EQ.IP_FRTEST) THEN ITYP = INTFP (PVAL, FP, IV) IF (ITYP.EQ.0) THEN CALL XDLF_PARAM_TABLE_ERROR (IVH_PAR3, ITM, + XDLSTR('**Invalid Number Format**'), 25, IERR) GO TO 100 END IF IF (FP.LE.0) THEN CALL XDLF_PARAM_TABLE_ERROR (IVH_PAR3, ITM, + XDLSTR('**Value must be greater than zero**'), 35, IERR) GO TO 100 END IF IF (FP.GT.1.0) THEN CALL XDLF_PARAM_TABLE_ERROR (IVH_PAR3, ITM, + XDLSTR('**Value must be <= 1.0**'), 24, IERR) GO TO 100 END IF SOFT_FRTEST = FP WRITE (STR,'(F8.2)') SOFT_FRTEST CALL LJUST(STR) CALL XDLF_PARAM_TABLE_SETVALUE (IVH_PAR3, ITM, + XDLSTR(STR), LENSTR(STR), 0, IERR) GO TO 100 END IF GO TO 100 END IF GO TO 100 END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** SEL_SPOTSIZE ** C************************** C C SUBROUTINE SEL_SPOTSIZE C INCLUDE 'implicit_none.finc' C C Purpose: Determine Spot Size control routine C C Author: John W. Campbell, September 1995 C C Arguments: C C None C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' INCLUDE 'screen_params.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'spot_sizes.finc' INCLUDE 'film_pack.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR INTEGER INTFP INTEGER LENSTR C C====== LOCALS: C INTEGER M_RESET INTEGER M_FIND INTEGER M_NEXT INTEGER IP_NBIN INTEGER IP_CUT INTEGER IP_THR INTEGER IP_EXPND INTEGER NUMP INTEGER NVIEW INTEGER IVHLIST(4) INTEGER IVH INTEGER ITM INTEGER ITEM INTEGER IQUIT INTEGER IERR INTEGER ITYP INTEGER IFLAG INTEGER ND INTEGER IV INTEGER KEYPLATE INTEGER IMTYP REAL FP CHARACTER*2 VALSTR CHARACTER*(MAX_P3SCROLL_CHARS) PVAL CHARACTER*80 ERRSTR CHARACTER*80 STR C INTEGER M_RESET !Menu item no.: Reset to first pack C INTEGER M_FIND !Menu item no.: Determine spot size C INTEGER M_NEXT !Menu item no.: Select next pack C INTEGER IP_NBIN !Parameter table item no.: No. angle bins C INTEGER IP_CUT !Parameter table item no.: Standard deviation cutoff C INTEGER IP_THR !Parameter table item no.: Search threshold factor C INTEGER IP_EXPND !Parameter table item no.: Expansion factor C INTEGER NUMP !No. of packs C INTEGER NVIEW !No. of view-objects for getting events C INTEGER IVHLIST(4) !List of view-object handles for getting events C INTEGER IVH !Returned view-object handle from getting events C INTEGER ITM !Item no. modified in parameter table C INTEGER ITEM !Item no. from menu selection C INTEGER IQUIT !Quit button flage from menu C INTEGER IERR !Error flag C INTEGER ITYP !Return flag from INTFP C INTEGER IFLAG !Parameter status flag C INTEGER ND !No. of decimal places flag C INTEGER IV !Integer value C INTEGER KEYPLATE !Key plate C INTEGER IMTYP !Image type flag (LDM) C REAL FP !Real value C CHARACTER*2 VALSTR !Parameter value string (dummy) C CHARACTER*(MAX_P3SCROLL_CHARS) PVAL !String for parameter table input value C CHARACTER*80 ERRSTR !Error message string C CHARACTER*80 STR !String C C------------------------------------------------------------------------------- C C====== Check that pack input C CALL LDM_GET_NUMP (NUMP, IFLAG) IF (NUMP.EQ.0) THEN CALL ERR_NOTICE (1, '**Number of packs is zero**') RETURN END IF C C====== Reset to key plate if current plate is not key plate C CALL SET_KEYPLATE C C====== Get key plate for current pack C CALL LDM_GET_KEYP (IPACK, KEYPLATE, IFLAG, IERR, ERRSTR) C C====== Intitialise menu item numbers C M_RESET = 1 M_FIND = 2 M_NEXT = 3 C C====== Set up parameter table 3 C IP_THR = 1 IP_NBIN = 2 IP_CUT = 3 IP_EXPND = 4 WRITE (STR,'(F8.2)') SPOT_THRFAC CALL LJUST (STR) CALL XDLF_PARAM_TABLE_SETITEM (IVH_PAR3, IP_THR, + XDLSTR('Threshold factor:'), 17, + XDLSTR(STR), LENSTR(STR), 0, 0, IERR) WRITE (STR,'(I8)') ISPOT_NBIN CALL LJUST(STR) CALL XDLF_PARAM_TABLE_SETITEM (IVH_PAR3, IP_NBIN, + XDLSTR('No. angle bins:'), 15, + XDLSTR(STR),25, 0, 0, IERR) WRITE (STR,'(F8.2)') SPOT_SDCUT CALL LJUST (STR) CALL XDLF_PARAM_TABLE_SETITEM (IVH_PAR3, IP_CUT, + XDLSTR('Std Dev cutoff:'), 15, + XDLSTR(STR), LENSTR(STR), 0, 0, IERR) WRITE (STR,'(F8.2)') SPOT_EXPAND CALL LJUST (STR) CALL XDLF_PARAM_TABLE_SETITEM (IVH_PAR3, IP_EXPND, + XDLSTR('Expand by:'), 10, + XDLSTR(STR), LENSTR(STR), 0, 0, IERR) C C====== Set up 'Spotsize Options' Menu C 100 CALL SET_MENU9 C C====== Get input from 'Soft Limits Options' menu or Parameter tables 1 & 2 C NVIEW = 4 IVHLIST(1) = IVH_MENU IVHLIST(2) = IVH_PAR1 IVHLIST(3) = IVH_PAR2 IVHLIST(4) = IVH_PAR3 CALL XDLF_GET_EVENTS (NVIEW, IVHLIST, IVH) IF (IVH.EQ.IVH_MENU) THEN C C====== Menu item selected C CALL XDLF_MENU_AREA_GETITEM (IVH_MENU, ITEM, IQUIT) C C======= Quit (Return to Previous Menu) selected C IF (IQUIT.EQ.1) THEN CALL XDLF_PARAM_TABLE_CLEARITEMS (IVH_PAR3, IERR) RETURN END IF C C====== Reset to first pack (and keyplate) C IF (ITEM.EQ.M_RESET) THEN IF (IPACK.EQ.1.AND.IPLATE.EQ.KEYPLATE) GO TO 100 CALL SET_NEWPLATE (1, 0, IERR) GO TO 100 C C====== Determine spot size C ELSE IF (ITEM.EQ.M_FIND) THEN CALL LOG_CHANGES (1) CALL LDM_CH_RESET (1) CALL SPOTSIZE_CALC (IERR) CALL LDM_CH_RESET (1) GO TO 100 C C====== Select next pack C ELSE IF (ITEM.EQ.M_NEXT) THEN CALL SET_NEWPLATE (IPACK+1, 0, IERR) GO TO 100 END IF GO TO 100 C C====== Parameter table 1 input C ELSE IF (IVH.EQ.IVH_PAR1) THEN CALL PAR1_INPUT GO TO 100 C C====== Parameter table 2 input C ELSE IF (IVH.EQ.IVH_PAR2) THEN CALL PAR2_INPUT GO TO 100 C C====== Parameter table 3 input C ELSE IF (IVH.EQ.IVH_PAR3) THEN CALL XDLF_PARAM_TABLE_GETVALUE (IVH_PAR3, ITM, + XDLSTR(PVAL), MAX_P3SCROLL_CHARS, IERR) IF (ITM.EQ.IP_THR) THEN ITYP = INTFP (PVAL, FP, IV) IF (ITYP.EQ.0) THEN CALL XDLF_PARAM_TABLE_ERROR (IVH_PAR3, ITM, + XDLSTR('**Invalid Number Format**'), 25, IERR) GO TO 100 END IF IF (FP.LE.1.0) THEN CALL XDLF_PARAM_TABLE_ERROR (IVH_PAR3, ITM, + XDLSTR('**Threshold factor must be >1.0**'), + 33, IERR) GO TO 100 END IF SPOT_THRFAC = FP WRITE (STR,'(F8.2)') SPOT_THRFAC CALL LJUST(STR) CALL XDLF_PARAM_TABLE_SETVALUE (IVH_PAR3, ITM, + XDLSTR(STR), LENSTR(STR), 0, IERR) GO TO 100 ELSE IF (ITM.EQ.IP_NBIN) THEN ITYP = INTFP (PVAL, FP, IV) IF (ITYP.NE.1) THEN CALL XDLF_PARAM_TABLE_ERROR (IVH_PAR3, ITM, + XDLSTR('**Invalid Integer Format**'), 26, IERR) GO TO 100 END IF IF (IV.LT.1) THEN CALL XDLF_PARAM_TABLE_ERROR (IVH_PAR3, ITM, + XDLSTR('**Number of bins must be > 0**'), 30, IERR) GO TO 100 END IF IF (IV.GT.64) THEN CALL XDLF_PARAM_TABLE_ERROR (IVH_PAR3, ITM, + XDLSTR('**Number of bins exceeds limit of 64**'), + 38, IERR) GO TO 100 END IF ISPOT_NBIN = IV WRITE (STR,'(I8)') ISPOT_NBIN CALL LJUST(STR) CALL XDLF_PARAM_TABLE_SETVALUE (IVH_PAR3, ITM, + XDLSTR(STR), LENSTR(STR), 0, IERR) GO TO 100 ELSE IF (ITM.EQ.IP_CUT) THEN ITYP = INTFP (PVAL, FP, IV) IF (ITYP.EQ.0) THEN CALL XDLF_PARAM_TABLE_ERROR (IVH_PAR3, ITM, + XDLSTR('**Invalid Number Format**'), 25, IERR) GO TO 100 END IF IF (FP.LE.0) THEN CALL XDLF_PARAM_TABLE_ERROR (IVH_PAR3, ITM, + XDLSTR('**Value must be greater than zero**'), 35, IERR) GO TO 100 END IF SPOT_SDCUT = FP WRITE (STR,'(F8.2)') SPOT_SDCUT CALL LJUST(STR) CALL XDLF_PARAM_TABLE_SETVALUE (IVH_PAR3, ITM, + XDLSTR(STR), LENSTR(STR), 0, IERR) GO TO 100 ELSE IF (ITM.EQ.IP_EXPND) THEN ITYP = INTFP (PVAL, FP, IV) IF (ITYP.EQ.0) THEN CALL XDLF_PARAM_TABLE_ERROR (IVH_PAR3, ITM, + XDLSTR('**Invalid Number Format**'), 25, IERR) GO TO 100 END IF IF (FP.LE.1.0) THEN CALL XDLF_PARAM_TABLE_ERROR (IVH_PAR3, ITM, + XDLSTR('**Value must be greater than 1.0**'), 34, IERR) GO TO 100 END IF SPOT_EXPAND = FP WRITE (STR,'(F8.2)') SPOT_EXPAND CALL LJUST(STR) CALL XDLF_PARAM_TABLE_SETVALUE (IVH_PAR3, ITM, + XDLSTR(STR), LENSTR(STR), 0, IERR) GO TO 100 END IF GO TO 100 END IF GO TO 100 END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** SELECT_REFS ** C************************** C C SUBROUTINE SELECT_REFS (IERR) C INCLUDE 'implicit_none.finc' C C Purpose: Display image, select/edit reflections list for refinement spots C search C C Author: John W. Campbell, February 1992 C C Arguments: C INTEGER IERR C C IERR (W) Error flag =0 OK, =1 error opening image file / displaying image C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' INCLUDE 'screen_params.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'prog_flags.finc' INCLUDE 'file_units.finc' INCLUDE 'film_pack.finc' INCLUDE 'image.finc' INCLUDE 'matches.finc' INCLUDE 'selrefs.finc' INCLUDE 'symbol_types.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR INTEGER LENSTR INTEGER NXTTOK LOGICAL CCPEXS C C====== LOCALS: C LOGICAL EXISTS LOGICAL CONT LOGICAL REPLY LOGICAL CLEAR LOGICAL SPAT LOGICAL NODFLG CHARACTER*2 VALSTR CHARACTER*2 ERRSTR CHARACTER*80 STR CHARACTER*(MAXFLEN) FILNAM CHARACTER*(MAXFLEN) REFLIST_FILE INTEGER I INTEGER J INTEGER KERR INTEGER IVHLIST(3) INTEGER IVHLST2(2) INTEGER NVIEW INTEGER I_ADD INTEGER I_DEL INTEGER IADDEL INTEGER IDISP INTEGER ITEM INTEGER IVH INTEGER M_ALL INTEGER M_NODALS INTEGER M_NODIDX INTEGER M_NODHKL INTEGER M_CLEAR INTEGER M_INPUT INTEGER M_DELETE INTEGER M_READ INTEGER M_WRITE INTEGER IQUIT INTEGER IDSQLIM INTEGER IDSQMIN INTEGER IXP INTEGER IYP INTEGER ISPIX INTEGER IFPIX INTEGER ID INTEGER ISPOT INTEGER IXROOT INTEGER IYROOT INTEGER IFAIL INTEGER IH INTEGER IK INTEGER IL INTEGER M1 INTEGER M2 INTEGER NADD INTEGER NERR INTEGER NVALS INTEGER NXRAST INTEGER NYRAST INTEGER IFLAG INTEGER ND INTEGER JH INTEGER JK INTEGER JL INTEGER MULT INTEGER NUMSPOTS REAL MM_RAST_X REAL MM_RAST_Y REAL VALUES(20) REAL XFD REAL YFD REAL ALAM REAL DTHR2 C LOGICAL EXISTS !File exists flag C LOGICAL CONT !Continue with writing file flag C LOGICAL REPLY !Yes/no reply flag (.TRUE./.FALSE.) C LOGICAL CLEAR !Clear reflections list flag C LOGICAL SPAT !Spatial overlap flag C LOGICAL NODFLG !Nodal spot flag C CHARACTER*2 VALSTR !Parameter value string (dummy) C CHARACTER*2 ERRSTR !Error string (dummy) C CHARACTER*80 STR !Character string for messages C CHARACTER*(MAXFLEN) FILNAM !File name as input C CHARACTER*(MAXFLEN) REFLIST_FILE !Reflections list file name C INTEGER I !Temp/loop variable C INTEGER J !Temp/loop variable C INTEGER KERR !Error return flag C INTEGER IVHLIST(3) !List of view-object handles for getting events C INTEGER IVHLST2(2) !Second list of view-objects for getting events C INTEGER NVIEW !Number of view-objects for getting events C INTEGER I_ADD !Add option value flag for IADDEL C INTEGER I_DEL !Delete option value flag for IADDEL C INTEGER IADDEL !Add/Delete spots flag (I_ADD or I_DEL) C INTEGER IDISP !Display predicted spots flag =0 all, =1 nodals C INTEGER ITEM !Menu item number selected C INTEGER IVH !View-object handle of view object returning event C INTEGER M_ALL !Menu item no.: Display all predicted reflections C INTEGER M_NODALS !Menu item no.: Display nodals only C INTEGER M_NODIDX !Menu item no.: Select by Nodal Index C INTEGER M_NODHKL !Menu item no.: Select by Nodal h,k,l C INTEGER M_CLEAR !Menu item no.: Clear spots list C INTEGER M_INPUT !Menu item no.: Input (add) reflections C INTEGER M_DELETE !Menu item no.: Delete reflections C INTEGER M_READ !Menu item no.: Read reflections list file C INTEGER M_WRITE !Menu item no.: Write reflections list file C INTEGER IQUIT !Quit return flag from menu input C INTEGER IDSQLIM !Distance squared tolerance for pixel selection C INTEGER IDSQMIN !Min distance squared founf in pixel selection C INTEGER IXP !Returned x pixel value from film-image display C INTEGER IYP !Returned y pixel value from film-image display C INTEGER ISPIX !Pixel position along slow axis C INTEGER IFPIX !Pixel position along fast axis C INTEGER ID !Distance squared from pixel C INTEGER ISPOT !Index in list of nearest spot/symbol found C INTEGER IXROOT !X root position for popup notice C INTEGER IYROOT !Y root position for popup notice C INTEGER IFAIL !Error flag for CCPDPN routine C INTEGER IH !Reflection h index C INTEGER IK !Reflection k index C INTEGER IL !Reflection l index C INTEGER M1 !Token start position C INTEGER M2 !Token end position C INTEGER NADD !Number of reflns added from input 'reflist' file C INTEGER NERR !Number of errors reading 'reflist' file C INTEGER NVALS !Number of numerical values in 'reflist' file record C INTEGER NXRAST !No. x-rasters C INTEGER NYRAST !No. y-rasters C INTEGER IFLAG !Parameter status flag C INTEGER ND !No. of decimal places flag C INTEGER JH !h index C INTEGER JK !k index C INTEGER JL !l index C INTEGER MULT !Multiplicity C INTEGER NUMSPOTS !No. of spots in generated spots list C REAL MM_RAST_X !mm to x-rasters conversion factor C REAL MM_RAST_Y !mm to y-rastrs conversion factor C REAL VALUES(20) !Numerical values from 'reflist' file record C REAL XFD !X coordinate on detector (rast) (distort. corrected) C REAL YFD !Y coordinate on detector (rast) (distort. corrected) C REAL ALAM !Wavelength C REAL DTHR2 !dmin-threshold**2 C C------------------------------------------------------------------------------- C C====== Get some parameters C CALL LDM_MMRAST (IPACK, IPLATE, MM_RAST_X, MM_RAST_Y) CALL LDM_GET_NXRAS (NXRAST, IFLAG) CALL LDM_GET_NYRAS (NYRAST, IFLAG) CALL LRL_NUMSPOTS (NUMSPOTS) C C====== Display image C CALL SHOW_IMAGE(1, IERR) IF (IERR.EQ.1) RETURN C C====== Set max limit for IDSQMIN to consider as a position match C IDSQLIM = 18*NCMP*NCMP C C====== Determine whether to display all reflns or nodals at start C IDISP = 0 IF (NUMSPOTS.GT.MAX_DISP) THEN CALL FIND_SEL_NODS (1, 1, 1, 1, 0, 0, 0) IDISP = 1 END IF C C====== Display predicted positions C NUM_MATCH = 0 CALL PLOT_SYMBS (IDISP, 2) C C====== Set up Reflections List Selection Options Menu C M_ALL = 1 M_NODALS = 2 M_NODIDX = 3 M_NODHKL = 4 M_CLEAR = 5 M_INPUT = 6 M_DELETE = 7 M_READ = 8 M_WRITE = 9 CALL SET_MENU5 C C====== Service Reflections List Selection Menu and Film Image Display C I_ADD = 1 I_DEL = 2 IADDEL = 0 IVHLIST(1) = IVH_MENU IVHLIST(2) = IVH_FILM NVIEW = 1 100 CALL XDLF_GET_EVENTS(NVIEW,IVHLIST,IVH) C C====== Menu item selected C IF (IVH.EQ.IVH_MENU) THEN CALL XDLF_MENU_AREA_GETITEM(IVH_MENU,ITEM,IQUIT) C C====== Quit ('End reflections input') selected C IF (IQUIT.EQ.1) THEN CALL XDLF_IMAGE_SETTINGS (IVH_FILM, MINTHR, MAXTHR, + MONO_THR, ICONTRAST, ICOLOR_OPT, IOVLY_OPT, IBG_OPT, + MAG_OPT, ISHOW_INT, KERR) CALL XDLF_DELETE_VIEW_OBJECT(IVH_FILM,KERR) NUM_SELECT = NUM_MATCH IF (NUM_SELECT.GT.0) THEN DO 10 I = 1, NUM_SELECT SEL_REFS(I) = IREF_MATCH(I) 10 CONTINUE END IF RETURN END IF C C====== Display all predicted reflections C IF (ITEM.EQ.M_ALL) THEN IF (NUMSPOTS.GT.MAX_DISP) THEN CALL ERR_NOTICE (1,'**Too many spots to display**') GO TO 100 END IF IDISP = 0 CALL XDLF_IMAGE_CLEAR_SYMBOLS (IVH_FILM,KERR) CALL PLOT_SYMBS (IDISP, 2) GO TO 100 C C====== Display nodals only C ELSE IF (ITEM.EQ.M_NODALS) THEN CALL FIND_SEL_NODS (1, 1, 1, 1, 0, 0, 0) IDISP = 1 CALL XDLF_IMAGE_CLEAR_SYMBOLS (IVH_FILM,KERR) CALL PLOT_SYMBS (IDISP, 2) GO TO 100 C C====== Select by nodal index C ELSE IF (ITEM.EQ.M_NODIDX) THEN CALL FIND_SEL_NODS (1, 1, 1, 1, 0, 0, 0) CALL XDLF_IMAGE_CLEAR_SYMBOLS (IVH_FILM,KERR) NUM_MATCH = 0 DO 20 I = 1, NUM_SELECT NUM_MATCH = NUM_MATCH + 1 IF (NUM_MATCH.GT.MAX_MATCH) THEN IF (NUM_MATCH.EQ.MAX_MATCH+1) THEN STR = '**Selected spots list truncated to' CALL STR_ADDI(STR,MAX_MATCH,1) CALL STR_ADDS(STR,'spots**',1) CALL ERR_NOTICE(0,STR) END IF ELSE J = SEL_REFS(I) IREF_MATCH(NUM_MATCH) = J CALL LRL_GET (J, JH, JK, JL, XFD, YFD, ALAM, + DTHR2, MULT, NODFLG, SPAT, KERR) IXPIX_MATCH(NUM_MATCH)=NINT(XFD) IYPIX_MATCH(NUM_MATCH)=NINT(YFD) END IF 20 CONTINUE NUM_MATCH = MIN (NUM_MATCH,MAX_MATCH) CALL PLOT_SYMBS (IDISP, 2) GO TO 100 C C====== Select by nodal h, k, l C ELSE IF (ITEM.EQ.M_NODHKL) THEN CALL FIND_SEL_NODS (1, 1, 2, 1, 0, 0, 0) CALL XDLF_IMAGE_CLEAR_SYMBOLS (IVH_FILM,KERR) NUM_MATCH = 0 DO 30 I = 1, NUM_SELECT NUM_MATCH = NUM_MATCH + 1 IF (NUM_MATCH.GT.MAX_MATCH) THEN IF (NUM_MATCH.EQ.MAX_MATCH+1) THEN STR = '**Selected spots list truncated to' CALL STR_ADDI(STR,MAX_MATCH,1) CALL STR_ADDS(STR,'spots**',1) CALL ERR_NOTICE(0,STR) END IF ELSE J = SEL_REFS(I) IREF_MATCH(NUM_MATCH) = J CALL LRL_GET (J, JH, JK, JL, XFD, YFD, ALAM, + DTHR2, MULT, NODFLG, SPAT, KERR) IXPIX_MATCH(NUM_MATCH)=NINT(XFD) IYPIX_MATCH(NUM_MATCH)=NINT(YFD) END IF 30 CONTINUE NUM_MATCH = MIN (NUM_MATCH,MAX_MATCH) CALL PLOT_SYMBS (IDISP, 2) GO TO 100 C C====== Clear Matches List C ELSE IF (ITEM.EQ.M_CLEAR) THEN CALL XDLF_IMAGE_CLEAR_SYMBOLS (IVH_FILM,KERR) NUM_MATCH = 0 CALL PLOT_SYMBS (IDISP, 2) NVIEW = 1 GO TO 100 C C====== Input Reflections C ELSE IF (ITEM.EQ.M_INPUT) THEN NVIEW = 2 IADDEL = I_ADD CALL XDLF_IMAGE_INPUT_MESSAGE (IVH_FILM, + XDLSTR( + 'Input predicted position of spot to add'), + 44,KERR) GO TO 100 C C====== Delete Reflections C ELSE IF (ITEM.EQ.M_DELETE) THEN NVIEW = 2 IADDEL = I_DEL CALL XDLF_IMAGE_INPUT_MESSAGE (IVH_FILM, + XDLSTR( + 'Input predicted position of spot to delete'), + 48,KERR) GO TO 100 C C====== Read Reflections List File C ELSE IF (ITEM.EQ.M_READ) THEN IF (NUMSPOTS.EQ.0) THEN CALL ERR_NOTICE (1,'**No spots predicted**') GO TO 100 END IF CLEAR = .FALSE. CALL XDLF_VIEW_OBJECT_RAISE (IVH_BASE, KERR) IF (NUM_MATCH.GT.0) THEN REPLY = .FALSE. CALL IOW_ASKQ (IVH_IOW, + 'Add to existing reflections list', REPLY) IF (.NOT.REPLY) THEN CALL IOW_ASKQ (IVH_IOW, + 'Overwrite existing reflections list', + REPLY) IF (.NOT.REPLY) THEN CALL XDLF_VIEW_OBJECT_RAISE (IVH_FILM, KERR) GO TO 100 END IF CLEAR = .TRUE. END IF END IF NVIEW = 1 102 CALL LPROMPT + (IVH_IOW, 'File name (default ext=.reflist): ') IVHLST2(1) = IVH_IOW CALL XDLF_GET_EVENTS (1, IVHLST2, IVH) CALL XDLF_IO_WINDOW_GETSTRING (IVH_IOW, XDLSTR(FILNAM), + MAXFLEN, KERR) IF (FILNAM.EQ.' ') THEN CALL XDLF_VIEW_OBJECT_RAISE(IVH_FILM, KERR) GO TO 100 END IF CALL FILEXT (FILNAM, 'reflist', REFLIST_FILE, I) EXISTS = CCPEXS (REFLIST_FILE) IF (.NOT.EXISTS) THEN CALL LMESSAGE(IVH_IOW,'**File not found**') GO TO 102 END IF IFAIL = 1 CALL CCPDPN (-IUN_REFLIST, REFLIST_FILE, + 'READONLY','F',0,IFAIL) IF (IFAIL.LT.0) THEN CALL LMESSAGE(IVH_IOW,'**Error in opening the file**') GO TO 102 END IF READ (IUN_REFLIST,'(A)',END=104) STR J = 0 IF (NXTTOK (STR, ' ', J, M1, M2).EQ.0) THEN CALL LMESSAGE (IVH_IOW, + '**File does not start with ''reflist:'' keyword**') CLOSE (IUN_REFLIST) GO TO 102 END IF CALL CCPUPC(STR) IF (STR(M1:M2).NE.'REFLIST:') THEN CALL LMESSAGE (IVH_IOW, + '**File does not start with ''reflist:'' keyword**') CLOSE (IUN_REFLIST) GO TO 102 END IF IF (CLEAR) NUM_MATCH = 0 NERR = 0 NADD = 0 103 READ (IUN_REFLIST,'(A)',END=104) STR IF (STR.EQ.' ') GO TO 103 CALL STRVAL (STR, ' =', 20, VALUES, NVALS) IF (NVALS.NE.3) THEN CALL LMESSAGE(IVH_IOW,'**Invalid format in record**') NERR = NERR + 1 GO TO 103 END IF IF (NUM_MATCH.GE.MAX_MATCH) THEN CALL LMESSAGE (IVH_IOW,'**Reflections list full**') NERR = NERR + 1 GO TO 104 END IF IH = NINT(VALUES(1)) IK = NINT(VALUES(2)) IL = NINT(VALUES(3)) DO 350 I=1,NUMSPOTS CALL LRL_GET (J, JH, JK, JL, XFD, YFD, ALAM, + DTHR2, MULT, NODFLG, SPAT, KERR) IF (IH.EQ.JH.AND.IK.EQ.JK.AND.IL.EQ.JL) THEN NUM_MATCH = NUM_MATCH + 1 IREF_MATCH(NUM_MATCH) = I IXPIX_MATCH(NUM_MATCH)=NINT(XFD) IYPIX_MATCH(NUM_MATCH)=NINT(YFD) NADD = NADD + 1 GO TO 103 END IF 350 CONTINUE STR = '**Cannot find reflection' CALL STR_ADDI (STR, IH, 1) CALL STR_ADDI (STR, IK, 1) CALL STR_ADDI (STR, IL, 1) CALL STR_ADDS (STR, 'in the predicted spots list**', + 1) CALL LMESSAGE (IVH_IOW, STR) NERR = NERR + 1 GO TO 103 104 CLOSE (IUN_REFLIST) STR = 'Number of reflections added =' CALL STR_ADDI (STR, NADD, 1) CALL LMESSAGE (IVH_IOW, STR) IF (NERR.GT.0) THEN STR = '**Number of errors =' CALL STR_ADDI (STR, NERR, 1) CALL STR_ADDS (STR,'**',1) CALL LMESSAGE (IVH_IOW, STR) END IF CALL XDLF_IMAGE_CLEAR_SYMBOLS (IVH_FILM, KERR) CALL PLOT_SYMBS (IDISP, 2) IF (NERR.EQ.0) CALL XDLF_VIEW_OBJECT_RAISE(IVH_FILM, KERR) GO TO 100 C C====== Write Reflections List File C ELSE IF (ITEM.EQ.M_WRITE) THEN CALL NOTICE_POSN (1,IXROOT,IYROOT) NVIEW = 1 IF (NUM_MATCH.LE.0) THEN CALL ERR_NOTICE(1,'**No Reflections in list**') GO TO 100 END IF CALL XDLF_VIEW_OBJECT_RAISE (IVH_BASE, KERR) 105 CALL LPROMPT + (IVH_IOW, 'File name (default ext=.reflist): ') IVHLST2(1) = IVH_IOW CALL XDLF_GET_EVENTS (1, IVHLST2, IVH) CALL XDLF_IO_WINDOW_GETSTRING (IVH_IOW, XDLSTR(FILNAM), + MAXFLEN, KERR) IF (FILNAM.EQ.' ') THEN CALL XDLF_VIEW_OBJECT_RAISE(IVH_FILM, KERR) GO TO 100 END IF CALL FILEXT (FILNAM, 'reflist', REFLIST_FILE, I) CALL LGFILE_EXISTS (REFLIST_FILE, CONT) IF (.NOT.CONT) GO TO 105 IFAIL = 1 CALL CCPDPN (-IUN_REFLIST, REFLIST_FILE, + 'UNKNOWN','F',0,IFAIL) IF (IFAIL.LT.0) THEN CALL LMESSAGE(IVH_IOW,'**Error in opening the file**') GO TO 105 END IF WRITE (IUN_REFLIST,'(''reflist:'')') DO 106 I=1,NUM_MATCH J = IREF_MATCH(I) CALL LRL_GET (J, JH, JK, JL, XFD, YFD, ALAM, + DTHR2, MULT, NODFLG, SPAT, KERR) WRITE (IUN_REFLIST,'(3I5)') JH, JK, JL 106 CONTINUE CLOSE (IUN_REFLIST) CALL XDLF_VIEW_OBJECT_RAISE(IVH_FILM, KERR) GO TO 100 ELSE GO TO 100 END IF GO TO 100 C C====== Input from film/image-plate image display C ELSE IF (IVH.EQ.IVH_FILM) THEN IF (IADDEL.EQ.I_ADD) THEN CALL XDLF_IMAGE_GETPIX_OVLY (IVH_FILM, 1, + IXP, IYP, KERR) IF (NUM_DISP.LE.0) GO TO 100 IDSQMIN = NXRAST*NXRAST + NYRAST*NYRAST ISPOT = 0 DO 200 I=1,NUM_DISP ID = (IXP-IXPIX_DISP(I))**2 + (IYP-IYPIX_DISP(I))**2 IF (ID.GT.IDSQLIM) GO TO 200 IF (ID.LT.IDSQMIN) THEN ISPOT = I IDSQMIN = ID END IF 200 CONTINUE IF (ISPOT.EQ.0) GO TO 100 IF (NUM_MATCH.GE.MAX_MATCH) THEN CALL ERR_NOTICE (0,'**Reflections list is full**') GO TO 100 END IF NUM_MATCH = NUM_MATCH + 1 IXPIX_MATCH(NUM_MATCH) = IXPIX_DISP(ISPOT) IYPIX_MATCH(NUM_MATCH) = IYPIX_DISP(ISPOT) IREF_MATCH(NUM_MATCH) = IREF_DISP(ISPOT) CALL XDLF_IMAGE_DEL_SYMBOL (IVH_FILM, + IXPIX_DISP(ISPOT), IYPIX_DISP(ISPOT), + ISYMBTYP(ISYMB_DISP(ISPOT)), + ICOLRTYP(ISYMB_DISP(ISPOT)), + 1, KERR) CALL XDLF_IMAGE_SYMBOL (IVH_FILM, + IXPIX_MATCH(NUM_MATCH), IYPIX_MATCH(NUM_MATCH), + ISYMBTYP(3), ICOLRTYP(3), 1, KERR) ELSE IF (IADDEL.EQ.I_DEL) THEN CALL XDLF_IMAGE_GETPIX_OVLY (IVH_FILM, 1, + IXP, IYP, KERR) IF (NUM_MATCH.LE.0) GO TO 100 IDSQMIN = NXRAST*NXRAST + NYRAST*NYRAST DO 180 I=1,NUM_MATCH ID = (IXP-IXPIX_MATCH(I))**2 + (IYP-IYPIX_MATCH(I))**2 IF (ID.LT.IDSQMIN) THEN ISPOT = I IDSQMIN = ID END IF 180 CONTINUE IF (IDSQMIN.GT.IDSQLIM) GO TO 100 CALL XDLF_IMAGE_DEL_SYMBOL (IVH_FILM, + IXPIX_MATCH(ISPOT), IYPIX_MATCH(ISPOT), + ISYMBTYP(3), ICOLRTYP(3), 1, KERR) DO 250 I=1,NUM_DISP IF (IREF_DISP(I).EQ.IREF_MATCH(ISPOT)) THEN CALL XDLF_IMAGE_SYMBOL (IVH_FILM, + IXPIX_DISP(I), IYPIX_DISP(I), + ISYMBTYP(ISYMB_DISP(I)), ICOLRTYP(ISYMB_DISP(I)), + 1, KERR) GO TO 260 END IF 250 CONTINUE 260 IF (ISPOT.EQ.NUM_MATCH) THEN NUM_MATCH = NUM_MATCH - 1 ELSE DO 280 I = ISPOT, NUM_MATCH - 1 IREF_MATCH(I) = IREF_MATCH(I+1) IXPIX_MATCH(I) = IXPIX_MATCH(I+1) IYPIX_MATCH(I) = IYPIX_MATCH(I+1) 280 CONTINUE NUM_MATCH = NUM_MATCH - 1 END IF END IF GO TO 100 ELSE GO TO 100 END IF END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** SET_DIRECTION ** C************************** C C SUBROUTINE SET_DIRECTION (IERR) C INCLUDE 'implicit_none.finc' C C Purpose: Calculate (and set) required Phi missetting angles for a simulation C with a requested zone along the X-ray beam C C Author: John W. Campbell, January 1996 C C Arguments: C INTEGER IERR C C IERR (W) Error flag =0 OK C =1 error or option quit without changing setting C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'ip1_entries.finc' INCLUDE 'film_pack.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR C C====== LOCALS: C LOGICAL DEFN INTEGER IH INTEGER IK INTEGER IL INTEGER IDET INTEGER KERR INTEGER NVALS INTEGER LISTE(10) INTEGER IFLAG INTEGER ND REAL VALUES(10) REAL XR REAL YR REAL ZR REAL COSANG1 REAL SINANG1 REAL COSANG2 REAL SINANG2 REAL COSANG3 REAL SINANG3 REAL R1 REAL R2 REAL R3 REAL UBMAT(3,3) REAL UBINV(3,3) REAL RX(3,3) REAL RY(3,3) REAL RYUB(3,3) REAL RZ(3,3) REAL AM(3,3) REAL AMSAV(3,3) REAL BDUM(3,3) REAL ROTM(3,3) REAL PHIS(3) REAL SPINDLE REAL RMSD CHARACTER*2 ERRSTR CHARACTER*80 STR C LOGICAL DEFN !Second zone defined flag C INTEGER IH !'h' index C INTEGER IK !'k' index C INTEGER IL !'l' index C INTEGER IDET !Determinant flag C INTEGER KERR !Error flag C INTEGER NVALS !No. of values decoded from input string C INTEGER LISTE(10) !List of parameter table entries to be updated C INTEGER IFLAG !Parameter status flag C INTEGER ND !No. of decimal places flag C REAL VALUES(10) !Values decoded from input string C REAL XR !Reciprocal lattice 'x' coordinate C REAL YR !Reciprocal lattice 'y' coordinate C REAL ZR !Reciprocal lattice 'x' coordinate C REAL COSANG1 !Cosine of rotation angle 1 C REAL SINANG1 !Sine of rotation angle 1 C REAL COSANG2 !Cosine of rotation angle 2 C REAL SINANG2 !Sine of rotation angle 2 C REAL COSANG3 !Cosine of rotation angle 3 C REAL SINANG3 !Sine of rotation angle 3 C REAL R1 !Projection of 1'st vector onto plane C REAL R2 !Projection of 2'nd vector onto plane C REAL R3 !Projection of 3'rd vector onto plane C REAL UBMAT(3,3) !UB matrix C REAL UBINV(3,3) !Inverse of UB matrix C REAL RX(3,3) !Rotation matrix around 'X' C REAL RY(3,3) !Rotation matrix around 'Y' C REAL RYUB(3,3) !Matrix RY*UB C REAL RZ(3,3) !Rotation matrix around 'Z' C REAL AM(3,3) !Combined setting matrix C REAL AMSAV(3,3) !Saved AM matrix C REAL BDUM(3,3) !Unsued matrix from FNDAND C REAL ROTM(3,3) !Rotations part of matrix C REAL PHIS(3) !Missetting angles derived from ROTM C REAL SPINDLE !Spindle angle C REAL RMSD !Usused RMSD value from FNDANG C CHARACTER*2 ERRSTR !Error string (dummy) C CHARACTER*80 STR !Input string C C------------------------------------------------------------------------------- C IERR = 0 10 CALL LPROMPT (IVH_IOW, 'Indices for zone along beam: ') CALL LREAD (IVH_IOW, STR) CALL STRVAL (STR, ' ,', 10, VALUES, NVALS) IF (NVALS.EQ.0) THEN IERR = 1 RETURN END IF IF (NVALS.NE.3) THEN CALL LMESSAGE(IVH_IOW,'**Invalid indices**') GO TO 10 END IF IH = NINT(VALUES(1)) IK = NINT(VALUES(2)) IL = NINT(VALUES(3)) IF (IH.EQ.0.AND.IK.EQ.0.AND.IL.EQ.0) THEN CALL LMESSAGE(IVH_IOW,'**Invalid indices**') GO TO 10 END IF CALL LRL_MK_ORIENT (UBMAT) C C====== Calculate reciprocal lattice coordinates of the reflection C XR = UBMAT(1,1)*IH + UBMAT(1,2)*IK + UBMAT(1,3)*IL YR = UBMAT(2,1)*IH + UBMAT(2,2)*IK + UBMAT(2,3)*IL ZR = UBMAT(3,1)*IH + UBMAT(3,2)*IK + UBMAT(3,3)*IL C C====== Set R1 = length of projection of r.l. vector onto XZ r.l. plane C R1 = SQRT (XR*XR + ZR*ZR) C C====== Find angle of rotation around Y required to put r.l. into XY plane C COSANG1 = 1.0 SINANG1 = 0.0 IF (R1.GT.0.00001) THEN COSANG1 = XR/R1 SINANG1 = ZR/R1 END IF C C====== Set matrix for rotation around Y C RY(1,1) = COSANG1 RY(1,2) = 0.0 RY(1,3) = SINANG1 RY(2,1) = 0.0 RY(2,2) = 1.0 RY(2,3) = 0.0 RY(3,1) = -SINANG1 RY(3,2) = 0.0 RY(3,3) = COSANG1 C C====== Set matrix RYUB = RY*UB C CALL MTX_MULT (RY, UBMAT, RYUB, 3, 3, 3) C C====== Find r.l. coordinates of vector rotated into XY plane C XR = RYUB(1,1)*IH + RYUB(1,2)*IK + RYUB(1,3)*IL YR = RYUB(2,1)*IH + RYUB(2,2)*IK + RYUB(2,3)*IL ZR = RYUB(3,1)*IH + RYUB(3,2)*IK + RYUB(3,3)*IL C C====== Set R2 = length of projection of rotated r.l. vector onto XYplane C R2 = SQRT (XR*XR + YR*YR) C C====== Find angle of rotation around Z required to put r.l. vector along beam C COSANG2 = XR/R2 SINANG2 = YR/R2 C C====== Set matrix for -ve rotation around Z C RZ(1,1) = COSANG2 RZ(1,2) = SINANG2 RZ(1,3) = 0.0 RZ(2,1) = -SINANG2 RZ(2,2) = COSANG2 RZ(2,3) = 0.0 RZ(3,1) = 0.0 RZ(3,2) = 0.0 RZ(3,3) = 1.0 C C====== Get new matrix AM = RZ*RYUB C CALL MTX_MULT (RZ, RYUB, AM, 3, 3, 3) C C====== See if second direction is to be set C DEFN = .FALSE. 20 CALL IOW_ASKQ (IVH_IOW, 'Define zone to lie in XZ plane', DEFN) IF (DEFN) THEN 30 CALL LPROMPT (IVH_IOW, 'Indices for zone: ') CALL LREAD (IVH_IOW, STR) CALL STRVAL (STR, ' ,', 10, VALUES, NVALS) IF (NVALS.EQ.0) GO TO 20 IF (NVALS.NE.3) THEN CALL LMESSAGE(IVH_IOW,'**Invalid indices**') GO TO 30 END IF IH = NINT(VALUES(1)) IK = NINT(VALUES(2)) IL = NINT(VALUES(3)) IF (IH.EQ.0.AND.IK.EQ.0.AND.IL.EQ.0) THEN CALL LMESSAGE(IVH_IOW,'**Invalid indices**') GO TO 30 END IF C C====== Get r.l. vector for this zone C XR = AM(1,1)*IH + AM(1,2)*IK + AM(1,3)*IL YR = AM(2,1)*IH + AM(2,2)*IK + AM(2,3)*IL ZR = AM(3,1)*IH + AM(3,2)*IK + AM(3,3)*IL C C====== Set R3 = length of projection of r.l. vector onto YZ r.l. plane C R3 = SQRT (YR*YR + ZR*ZR) IF (R3.LT.0.001) THEN CALL LMESSAGE (IVH_IOW, + '**New zone too close to beam direction**') GO TO 20 END IF C C====== Find angle of rotation around X required to put r.l. vector into XZ C====== plane C COSANG3 = ZR/R3 SINANG3 = YR/R3 RX(1,1) = 1.0 RX(1,2) = 0.0 RX(1,3) = 0.0 RX(2,1) = 0.0 RX(2,2) = COSANG3 RX(2,3) = -SINANG3 RX(3,1) = 0.0 RX(3,2) = SINANG3 RX(3,3) = COSANG3 C C====== Get new matrix AM = RX*AM C CALL MTX_PACK (AM, AMSAV, 3, 3, 3, 3) CALL MTX_MULT (RX, AMSAV, AM, 3, 3, 3) END IF C C====== Extract rotations matrix C CALL MTX_INV (UBMAT, UBINV, 3) CALL MTX_MULT (AM, UBINV, ROTM, 3, 3, 3) C C====== Now decode angles C CALL FNDANG (ROTM, PHIS, BDUM, IDET, RMSD) IF (IDET.EQ.2) THEN CALL LMESSAGE (IVH_IOW, '**Program could not decode angles**') IERR = 1 RETURN END IF C C====== Set new values for the angles C CALL LDM_GET_SPIN (IPACK, SPINDLE, IFLAG, ND, KERR, ERRSTR) PHIS(3) = PHIS(3) - SPINDLE CALL LDM_SET_PHIX (IPACK, PHIS(1), KERR, ERRSTR) CALL LDM_SET_PHIY (IPACK, PHIS(2), KERR, ERRSTR) CALL LDM_SET_PHIZ (IPACK, PHIS(3), KERR, ERRSTR) LISTE(1) = IP_PHIX LISTE(2) = IP_PHIY LISTE(3) = IP_PHIZ CALL SET_PAR1_VALS (3, LISTE) RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** SET_KEYPLATE ** C************************** C C SUBROUTINE SET_KEYPLATE C INCLUDE 'implicit_none.finc' C C Purpose: Reset current plate to the key plate for the current pack C C Author: John W. Campbell, January 1992 C C Arguments: C C None C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'ip1_entries.finc' INCLUDE 'film_pack.finc' INCLUDE 'prog_flags.finc' INCLUDE 'file_units.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR C C====== LOCALS: C INTEGER LISTE(2) INTEGER IERR INTEGER IFTYPE INTEGER IFLAG INTEGER NUMP INTEGER NPLATES INTEGER KEYPLATE CHARACTER*2 VALSTR CHARACTER*2 ERRSTR C INTEGER LISTE(2) !Dummy array for SET_PAR2_VALS C INTEGER IERR !Error flag C INTEGER IFTYPE !Image file type 1=byte, 2=i2 C INTEGER IFLAG !Parameter status flag C INTEGER NUMP !Number of packs C INTEGER NPLATES !Number of plates/pack C INTEGER KEYPLATE !Key plate C CHARACTER*2 VALSTR !Parameter value string (dummy) C CHARACTER*2 ERRSTR !Error string (dummy) C C------------------------------------------------------------------------------- C C C====== See if pack is input C CALL LDM_GET_NUMP (NUMP, IFLAG) IF (NUMP.EQ.0) RETURN C C====== Get key plate C CALL LDM_GET_KEYP (IPACK, KEYPLATE, IFLAG, IERR, ERRSTR) C C====== See if film/plate needs to be changed C IF (IPLATE.EQ.KEYPLATE) RETURN C C====== Output warning message C CALL ERR_NOTICE (1,'*Key plate will be re-selected*') C C====== Check that key plate within valid range C CALL LDM_GET_NPLAT (NPLATES, IFLAG) IF (KEYPLATE.LT.1.OR.KEYPLATE.GT.NPLATES) THEN CALL LDM_SET_KEYP (IPACK, 1, IERR, ERRSTR) CALL ERR_NOTICE (1, '**Out of range key plate reset to 1**') KEYPLATE = 1 END IF C C====== Close current film /plate C IF (FILM_OPEN) THEN CALL LDM_GET_IMDAT (VALSTR, IFTYPE, IFLAG) IF (IFTYPE.EQ.1) THEN CALL XDLF_CLOSE_FILM_FILE (IFD, IERR) ELSE IF (IFTYPE.EQ.2.OR.IFTYPE.EQ.3.OR.IFTYPE.EQ.4) THEN CALL XDLF_CLOSE_I2 (IFD, IERR) END IF END IF C C====== Reset flags/parameters for changed film C IPLATE = KEYPLATE LISTE(1) = IP_PLATE CALL SET_PAR1_VALS (1,LISTE) FILM_OPEN = .FALSE. IPACK_OPN = 0 IPLATE_OPN = 0 FILM_READ = .FALSE. CALL SET_PAR2_VALS (0, LISTE) RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** SET_MENU1 ** C************************** C C SUBROUTINE SET_MENU1 C INCLUDE 'implicit_none.finc' C C Purpose: Set up MAIN MENU for 'lauegen' C C Author: John W. Campbell, June 1991 C C Arguments: C C None C C====== GLOBALS: C INCLUDE 'view_handles.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR C C====== LOCALS: C CHARACTER*25 NAMES(6) CHARACTER*25 QUITNAM INTEGER IERR C CHARACTER*25 NAMES(6) !Menu item strings C CHARACTER*25 QUITNAM !Quit box string C INTEGER IERR !Error flag DATA NAMES /'Read Parameters File', + 'Write Parameters File', + 'Laue Simulations', + 'Display/Measure Image', + 'Find Orientation', + 'Process'/ DATA QUITNAM /'Quit Program'/ C C------------------------------------------------------------------------------- C C====== Set up initial menu C CALL XDLF_MENU_AREA_SETMENU (IVH_MENU, 6, XDLSTR(NAMES), 25, + XDLSTR('MAIN MENU'), 9, XDLSTR(QUITNAM), + 25, 0, IERR) RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** SET_MENU10 ** C************************** C C SUBROUTINE SET_MENU10 C INCLUDE 'implicit_none.finc' C C Purpose: Set up 'Integrate Spots' menu for 'lauegen' C C Author: John W. Campbell, December 1995 C C Arguments: C C None C C====== GLOBALS: C INCLUDE 'view_handles.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR C C====== LOCALS: C CHARACTER*25 NAMES(8) CHARACTER*25 QUITNAM INTEGER IERR C CHARACTER*25 NAMES(8) !Menu item strings C CHARACTER*25 QUITNAM !Quit box string C INTEGER IERR !Error flag DATA NAMES /'Reset to First Pack', + 'Integrate Plate', + 'Examine Last Integration', + 'Select Next Plate', + 'Auto-integrate Pack', + 'Write Intensities File', + 'Select Next Pack', + 'Integration Status'/ DATA QUITNAM /'Return to Previous Menu'/ C C------------------------------------------------------------------------------- C C====== Set up menu C CALL XDLF_MENU_AREA_SETMENU (IVH_MENU, 8, XDLSTR(NAMES), 25, + XDLSTR('Integration Options'), 19, XDLSTR(QUITNAM), + 25, 0, IERR) RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** SET_MENU2 ** C************************** C C SUBROUTINE SET_MENU2 C INCLUDE 'implicit_none.finc' C C Purpose: Set up initial menu for 'lauegen' C C Author: John W. Campbell, May 1991 C C Arguments: C C None C C====== GLOBALS: C INCLUDE 'view_handles.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR C C====== LOCALS: C CHARACTER*25 NAMES(2) CHARACTER*25 QUITNAM INTEGER IERR C CHARACTER*25 NAMES(2) !Menu item strings C CHARACTER*25 QUITNAM !Quit box string C INTEGER IERR !Error flag DATA NAMES /'Set Default Parameters', + 'Set Standard Parameters'/ DATA QUITNAM /'Return to Main Menu'/ C C------------------------------------------------------------------------------- C C====== Set up reset/setup menu C CALL XDLF_MENU_AREA_SETMENU (IVH_MENU, 2, XDLSTR(NAMES), 25, + XDLSTR('Setup/Reset Menu'), 16, XDLSTR(QUITNAM), 25, 0, IERR) RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** SET_MENU3 ** C************************** C C SUBROUTINE SET_MENU3 C INCLUDE 'implicit_none.finc' C C Purpose: Set up 'Refinement Options' menu for 'lauegen' C C Author: John W. Campbell, June 1991 C C Arguments: C C None C C====== GLOBALS: C INCLUDE 'view_handles.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR C C====== LOCALS: C CHARACTER*25 NAMES(10) CHARACTER*25 QUITNAM INTEGER IERR C CHARACTER*25 NAMES(10) !Menu item strings C CHARACTER*25 QUITNAM !Quit box string C INTEGER IERR !Error flag DATA NAMES /'Reset to First Pack', + 'Display/Measure Image', + 'Match Spots and Refine', + 'Select, Search and Refine', + 'Nodals Search and Refine', + 'Auto-refine Plate', + 'Select Next Plate', + 'Auto-refine Pack', + 'Write .ge Files', + 'Select Next Pack'/ DATA QUITNAM /'Return to Previous Menu'/ C C------------------------------------------------------------------------------- C C====== Set up menu C CALL XDLF_MENU_AREA_SETMENU (IVH_MENU, 10, XDLSTR(NAMES), 25, + XDLSTR('Refinement Options Menu'), 23, XDLSTR(QUITNAM), + 25, 0, IERR) RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** SET_MENU4 ** C************************** C C SUBROUTINE SET_MENU4 C INCLUDE 'implicit_none.finc' C C Purpose: Set up 'Match Spots Options' menu for 'lauegen' C C Author: John W. Campbell, July 1991 C C Arguments: C C None C C====== GLOBALS: C INCLUDE 'view_handles.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR C C====== LOCALS: C CHARACTER*25 NAMES(7) CHARACTER*25 QUITNAM INTEGER IERR C CHARACTER*25 NAMES(7) !Menu item strings C CHARACTER*25 QUITNAM !Quit box string C INTEGER IERR !Error flag DATA NAMES /'Display All Predicted', + 'Display Nodals Only', + 'Clear Matches List', + 'Input Matches', + 'Delete Matches', + 'Read Matches File', + 'Write Matches File'/ DATA QUITNAM /'End Matches Input'/ C C------------------------------------------------------------------------------- C C====== Set up menu C CALL XDLF_MENU_AREA_SETMENU (IVH_MENU, 7, XDLSTR(NAMES), 25, + XDLSTR('Match Spots Options Menu'), 24, XDLSTR(QUITNAM), + 25, 0, IERR) RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** SET_MENU5 ** C************************** C C SUBROUTINE SET_MENU5 INCLUDE 'implicit_none.finc' C C Purpose: Set up 'Select Reflections' menu for 'lauegen' C C Author: John W. Campbell, February 1992 C C Arguments: C C None C C====== GLOBALS: C INCLUDE 'view_handles.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR C C====== LOCALS: C CHARACTER*25 NAMES(9) CHARACTER*25 QUITNAM INTEGER IERR C CHARACTER*25 NAMES(9) !Menu item strings C CHARACTER*25 QUITNAM !Quit box string C INTEGER IERR !Error flag DATA NAMES /'Display All Predicted', + 'Display Nodals Only', + 'Select by Nodal Index', + 'Select by Nodal h,k,l', + 'Clear Reflections List', + 'Input Reflections', + 'Delete Reflections', + 'Read Reflections File', + 'Write Reflections File'/ DATA QUITNAM /'End Reflections Input'/ C C------------------------------------------------------------------------------- C C====== Set up menu C CALL XDLF_MENU_AREA_SETMENU (IVH_MENU, 9, XDLSTR(NAMES), 25, + XDLSTR('Select Reflections Menu'), 23, XDLSTR(QUITNAM), + 25, 0, IERR) RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** SET_MENU6 ** C************************** C C SUBROUTINE SET_MENU6 INCLUDE 'implicit_none.finc' C C Purpose: Set up 'Autoindexing Solutions' menu for 'lauegen' C C Author: John W. Campbell, March 1992 C C Arguments: C C None C C====== GLOBALS: C INCLUDE 'view_handles.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR C C====== LOCALS: C CHARACTER*25 NAMES(5) CHARACTER*25 QUITNAM INTEGER IERR C CHARACTER*25 NAMES(5) !Menu item strings C CHARACTER*25 QUITNAM !Quit box string C INTEGER IERR !Error flag DATA NAMES /'Select Solution', + 'Show Solution', + 'Refine Solution', + 'List Solution', + 'Save Solution'/ DATA QUITNAM /'End Autoindexing'/ C C------------------------------------------------------------------------------- C C====== Set up menu C CALL XDLF_MENU_AREA_SETMENU (IVH_MENU_AUT, 5, XDLSTR(NAMES), 25, + XDLSTR('Autoindexing Solutions'), 22, XDLSTR(QUITNAM), + 25, 0, IERR) RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** SET_MENU7 ** C************************** C C SUBROUTINE SET_MENU7 C INCLUDE 'implicit_none.finc' C C Purpose: Set up 'process options' menu for 'lauegen' C C Author: John W. Campbell, October 1993 C C Arguments: C C None C C====== GLOBALS: C INCLUDE 'view_handles.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR C C====== LOCALS: C CHARACTER*25 NAMES(6) CHARACTER*25 QUITNAM INTEGER IERR C CHARACTER*25 NAMES(6) !Menu item strings C CHARACTER*25 QUITNAM !Quit box string C INTEGER IERR !Error flag DATA NAMES /'Display/Measure Image', + 'Determine Spot Size', + 'Refine Orientation', + 'Improve Soft Limits', + 'Integrate Spots', + 'Write Parameters File'/ DATA QUITNAM /'End Processing'/ C C------------------------------------------------------------------------------- C C====== Set up menu C CALL XDLF_MENU_AREA_SETMENU (IVH_MENU, 6, XDLSTR(NAMES), 25, + XDLSTR('PROCESSING MENU'), 15, XDLSTR(QUITNAM), + 25, 0, IERR) RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** SET_MENU8 ** C************************** C C SUBROUTINE SET_MENU8 C INCLUDE 'implicit_none.finc' C C Purpose: Set up 'soft limits options' menu for 'lauegen' C C Author: John W. Campbell, March 1994 C C Arguments: C C None C C====== GLOBALS: C INCLUDE 'view_handles.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR C C====== LOCALS: C CHARACTER*25 NAMES(4) CHARACTER*25 QUITNAM INTEGER IERR C CHARACTER*25 NAMES(4) !Menu item strings C CHARACTER*25 QUITNAM !Quit box string C INTEGER IERR !Error flag DATA NAMES /'Reset to First Pack', + 'Determine ''dmin''', + 'Determine ''lambda-min''', + 'Select Next Pack'/ DATA QUITNAM /'Return to Previous Menu'/ C C------------------------------------------------------------------------------- C C====== Set up menu C CALL XDLF_MENU_AREA_SETMENU (IVH_MENU, 4, XDLSTR(NAMES), 25, + XDLSTR('Soft Limits Options'), 19, XDLSTR(QUITNAM), + 25, 0, IERR) RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** SET_MENU9 ** C************************** C C SUBROUTINE SET_MENU9 C INCLUDE 'implicit_none.finc' C C Purpose: Set up 'Determine spot size' menu for 'lauegen' C C Author: John W. Campbell, September 1995 C C Arguments: C C None C C====== GLOBALS: C INCLUDE 'view_handles.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR C C====== LOCALS: C CHARACTER*25 NAMES(3) CHARACTER*25 QUITNAM INTEGER IERR C CHARACTER*25 NAMES(3) !Menu item strings C CHARACTER*25 QUITNAM !Quit box string C INTEGER IERR !Error flag DATA NAMES /'Reset to First Pack', + 'Determine Spot Size', + 'Select Next Pack'/ DATA QUITNAM /'Return to Previous Menu'/ C C------------------------------------------------------------------------------- C C====== Set up menu C CALL XDLF_MENU_AREA_SETMENU (IVH_MENU, 3, XDLSTR(NAMES), 25, + XDLSTR('Spotsize Options'), 16, XDLSTR(QUITNAM), + 25, 0, IERR) RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** SET_NEWPLATE ** C************************** C C SUBROUTINE SET_NEWPLATE (IPK, IPL, IERR) C INCLUDE 'implicit_none.finc' C C Purpose: Reset current pack/plate to a specified one (interactive commands) C C Author: John W. Campbell, march 1994 C C Arguments: C INTEGER IPK INTEGER IPL INTEGER IERR C C IPK (R) New pack number C IPL (R) New plate number (or 0 to set key plate) C IERR (W) Error flag = 0 OK, =1 requested pack/plate not defined C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'ip1_entries.finc' INCLUDE 'film_pack.finc' INCLUDE 'prog_flags.finc' INCLUDE 'file_units.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR C C====== LOCALS: C INTEGER LISTE(2) INTEGER KERR INTEGER IFTYPE INTEGER IFLAG INTEGER NUMP INTEGER KPL INTEGER NPLATES CHARACTER*2 VALSTR CHARACTER*2 ERRSTR C INTEGER LISTE(2) !Array for reset parameters flags C INTEGER KERR !Error flag C INTEGER IFTYPE !Image file type 1=byte, 2=i2 C INTEGER IFLAG !Parameter status flag C INTEGER NUMP !Number of packs C INTEGER KPL !Plate number C INTEGER NPLATES !Number of plates C CHARACTER*2 VALSTR !Parameter value string (dummy) C CHARACTER*2 ERRSTR !Error string (dummy) C C------------------------------------------------------------------------------- C IERR = 0 C C====== See if pack is input C CALL LDM_GET_NUMP (NUMP, IFLAG) IF (NUMP.EQ.0) THEN IF (LG_MODE.EQ.1) CALL ERR_NOTICE + (1, '**Number of packs is zero**') IERR = 1 RETURN END IF C C====== See if pack/plate needs to be changed C IF (IPK.EQ.IPACK.AND.IPL.EQ.IPLATE) RETURN C C====== Check that pack/plate within range C IF (IPK.LT.1.OR.IPK.GT.NUMP) THEN IERR = 1 RETURN END IF KPL = IPL IF (KPL.LE.0) CALL LDM_GET_KEYP (IPK, KPL, IFLAG, KERR, ERRSTR) CALL LDM_GET_NPLAT (NPLATES, IFLAG) IF (KPL.LT.1.OR.KPL.GT.NPLATES) THEN IF (LG_MODE.EQ.1) CALL ERR_NOTICE + (1, '**Key plate out of valid range, reset to 1**') CALL LDM_SET_KEYP (IPK, 1, KERR, ERRSTR) KPL = 1 END IF C C====== Close current film /plate C IF (FILM_OPEN) THEN CALL LDM_GET_IMDAT (VALSTR, IFTYPE, IFLAG) IF (IFTYPE.EQ.1) THEN CALL XDLF_CLOSE_FILM_FILE (IFD, KERR) ELSE IF (IFTYPE.EQ.2.OR.IFTYPE.EQ.3.OR.IFTYPE.EQ.4) THEN CALL XDLF_CLOSE_I2 (IFD, KERR) END IF END IF C C====== Reset flags/parameters for changed film C IPACK = IPK IPLATE = KPL LISTE(1) = IP_PACK LISTE(2) = IP_PLATE CALL SET_PAR1_VALS (2,LISTE) FILM_OPEN = .FALSE. IPACK_OPN = 0 IPLATE_OPN = 0 FILM_READ = .FALSE. CALL SET_PAR2_VALS (0, LISTE) RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** SET_OMIT ** C************************** C C SUBROUTINE SET_OMIT (IOP) C INCLUDE 'implicit_none.finc' C C Purpose: Set list of parameters which may not be changed in processing mode C C Author: John W. Campbell, October 1993 C C Arguments: C INTEGER IOP C C IOP (R) =1 Set LDM keywords C =2 Set Parameter table 1 entry numbers (only after SET_PAR12_NAM C called) C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'ip1_entries.finc' INCLUDE 'process_omit.finc' C C====== FUNCTION TYPES: C C C====== LOCALS: C C C------------------------------------------------------------------------------- C IF (IOP.EQ.1) THEN NOMITK = 17 OMIT(1) = 'SYSTEM' OMIT(2) = 'LATTICE' OMIT(3) = 'SYMMETRY' OMIT(4) = 'BEAM_AXIS' OMIT(5) = 'ROTATION_AXIS' OMIT(6) = 'IMAGE_TYPE' OMIT(7) = 'IMAGE_DATA' OMIT(8) = 'AXORD' OMIT(9) = 'FIDTYPE' OMIT(10) = 'NXRAST' OMIT(11) = 'NYRAST' OMIT(12) = 'RASTER_SIZE' OMIT(13) = 'NUMPACK' OMIT(14) = 'NPLATES' OMIT(15) = 'TEMPLATE' OMIT(16) = 'DGEOM' OMIT(17) = 'DTILT' ELSE IF (IOP.EQ.2) THEN NOMITP = 17 IP_OMIT(1) = IP_SYST IP_OMIT(2) = IP_LATT IP_OMIT(3) = IP_SYMM IP_OMIT(4) = IP_BEAM IP_OMIT(5) = IP_ROT IP_OMIT(6) = IP_IMTYP IP_OMIT(7) = IP_IMDAT IP_OMIT(8) = IP_AXORD IP_OMIT(9) = IP_FIDT IP_OMIT(10) = IP_NXRAST IP_OMIT(11) = IP_NYRAST IP_OMIT(12) = IP_RAST IP_OMIT(13) = IP_NUMP IP_OMIT(14) = IP_NPLAT IP_OMIT(15) = IP_TEMPL IP_OMIT(16) = IP_DGEOM IP_OMIT(17) = IP_DTILT END IF RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C**************************** C** SET_PAR12_NAM ** C**************************** C C SUBROUTINE SET_PAR12_NAM C INCLUDE 'implicit_none.finc' C C Purpose: Set parameter names (and menus) for parameter tables 1&2 and C set item numbers C C Author: John W. Campbell, May 1991 C C Arguments: C C None C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' INCLUDE 'screen_params.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'ip1_entries.finc' INCLUDE 'ip2_entries.finc' INCLUDE 'film_pack.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR C C====== LOCALS: C INTEGER IERR CHARACTER*4 SYST_STR(7) CHARACTER*2 LATT_STR(7) CHARACTER*3 AX_STR(6) CHARACTER*3 FID_STR(2) CHARACTER*9 DSTYP_STR(3) CHARACTER*8 AXORD_STR(16) CHARACTER*6 IMTYP_STR(2) CHARACTER*6 IMDAT_STR(4) CHARACTER*4 DGEOM_STR(2) CHARACTER*20 LABEL CHARACTER*2 BUTSTR C INTEGER IERR !Error flag C CHARACTER*20 LABEL !Label for param table 2 C CHARACTER*4 SYST_STR(7) !Menu for crystal systems C CHARACTER*2 LATT_STR(7) !Menu for Lattice types C CHARACTER*3 AX_STR(6) !Menu for Axis directions C CHARACTER*3 FID_STR(2) !Menu for fiducials options C CHARACTER*9 DSTYP_STR(3) !Menu for distortion type options C CHARACTER*8 AXORD_STR(16) !Menu for axis order options C CHARACTER*6 IMTYP_STR(2) !Image type strings C CHARACTER*6 IMDAT_STR(4) !Image data type strings C CHARACTER*4 DGEOM_STR(2) !Detector geometry type strings C CHARACTER*2 BUTSTR !Button strings DATA SYST_STR /'Tri.', + 'Mon.', + 'Ort.', + 'Tet.', + 'Hex.', + 'Rho.', + 'Cub.'/ DATA LATT_STR /'P ','A ','B ','C ','I ','F ','R '/ DATA AX_STR /'+a*','+b*','+c*','-a*','-b*','-c*'/ DATA FID_STR /'no','yes'/ DATA DSTYP_STR /'standard','r/toff','spdxy'/ DATA AXORD_STR /'+xf+yf ', + '+xf-yf ', + '-xf+yf ', + '-xf-yf ', + '+yf+xf ', + '+yf-xf ', + '-yf+xf ', + '-yf-xf ', + '+xf+yf s', + '+xf-yf s', + '-xf+yf s', + '-xf-yf s', + '+yf+xf s', + '+yf-xf s', + '-yf+xf s', + '-yf-xf s'/ DATA IMTYP_STR /'ip','film'/ DATA IMDAT_STR /'byte','i2','mar','pfbyte'/ DATA DGEOM_STR /'flat','cyl'/ DATA BUTSTR /'+-'/ C C------------------------------------------------------------------------------- C C C====== Set up item numbers (Parameter table 1) C IP_PACK = 1 IP_PLATE = 2 IP_SYST = 4 IP_LATT = 5 IP_SYMM = 6 IP_ROT = 8 IP_BEAM = 9 IP_PACKID = 11 IP_SPINDL = 12 IP_A = 13 IP_B = 14 IP_C = 15 IP_ALPH = 16 IP_BETA = 17 IP_GAMM = 18 IP_WMIN = 19 IP_WMAX = 20 IP_DMIN = 21 IP_PHIX = 22 IP_PHIY = 23 IP_PHIZ = 24 IP_IMTYP = 25 IP_IMDAT = 26 IP_NUMP = 27 IP_NPLAT = 28 IP_FIDT = 29 IP_DISTOR = 30 IP_DGEOM = 31 IP_DTILT = 32 IP_EPS = 33 IP_STHR = 34 IP_OVPIX = 35 IP_TEMPL = 36 IP_NXRAST = 37 IP_NYRAST = 38 IP_RAST = 39 IP_AXORD = 40 IP_RMIN = 42 IP_RMAX = 43 IP_XLOW = 45 IP_XHIGH = 46 IP_YLOW = 47 IP_YHIGH = 48 C C====== Set up item numbers (Parameter table 2) C IP_LABEL = 1 IP_FNAM = 3 IP_CTOF = 4 IP_XCENF = 5 IP_YCENF = 6 IP_XC = 7 IP_YC = 8 IP_WC = 9 IP_YSCAL = 10 IP_TWIST = 11 IP_TILT = 12 IP_BULGE = 13 IP_ROFF = IP_BULGE IP_SPDXY = IP_ROFF IP_TOFF = 14 IP_SPDX = IP_TOFF IP_SPDY = 15 IP_STRK_L = 16 IP_STRK_W = 17 IP_STRK_F = 18 IP_STRK_BW = 19 IP_DELTA = 20 IP_RFL = 21 C C====== Set up parameter item names and any menus required (Table 1) C CALL XDLF_PARAM_TABLE_SETITEM (IVH_PAR1, IP_PACK, + XDLSTR('current pack:'), 13, XDLSTR(' '), 1, 0, 0, IERR) CALL XDLF_PARAM_TABLE_SETBUTTON (IVH_PAR1, IP_PACK, + XDLSTR(BUTSTR), 1, IERR) IF (IERR.NE.0) GO TO 800 CALL XDLF_PARAM_TABLE_SETITEM (IVH_PAR1, IP_PLATE, + XDLSTR('current plate:'), 14, XDLSTR(' '), 1, 0, 0, IERR) CALL XDLF_PARAM_TABLE_SETBUTTON (IVH_PAR1, IP_PLATE, + XDLSTR(BUTSTR), 1, IERR) IF (IERR.NE.0) GO TO 800 CALL XDLF_PARAM_TABLE_SETITEM (IVH_PAR1, IP_SYST, + XDLSTR('system:'), 7, XDLSTR(' '), 1, 0, 0, IERR) IF (IERR.NE.0) GO TO 800 CALL XDLF_PARAM_TABLE_SETMENU (IVH_PAR1, IP_SYST, 7, + XDLSTR(SYST_STR), 4, IERR) IF (IERR.NE.0) GO TO 810 CALL XDLF_PARAM_TABLE_SETITEM (IVH_PAR1, IP_LATT, + XDLSTR('lattice:'), 8, XDLSTR(' '), 1, 0, 0, IERR) IF (IERR.NE.0) GO TO 800 CALL XDLF_PARAM_TABLE_SETMENU (IVH_PAR1, IP_LATT, 7, + XDLSTR(LATT_STR), 2, IERR) IF (IERR.NE.0) GO TO 810 CALL XDLF_PARAM_TABLE_SETITEM (IVH_PAR1, IP_SYMM, + XDLSTR('symmetry:'), 9, XDLSTR(' '), 1, 0, 0, IERR) IF (IERR.NE.0) GO TO 800 CALL XDLF_PARAM_TABLE_SETITEM (IVH_PAR1, IP_ROT, + XDLSTR('rotation axis:'), 14, XDLSTR(' '), 1, 0, 0, IERR) IF (IERR.NE.0) GO TO 800 CALL XDLF_PARAM_TABLE_SETMENU (IVH_PAR1, IP_ROT, 6, + XDLSTR(AX_STR), 3, IERR) IF (IERR.NE.0) GO TO 810 CALL XDLF_PARAM_TABLE_SETITEM (IVH_PAR1, IP_BEAM, + XDLSTR('beam axis:'), 10, XDLSTR(' '), 1, 0, 0, IERR) IF (IERR.NE.0) GO TO 800 CALL XDLF_PARAM_TABLE_SETMENU (IVH_PAR1, IP_BEAM, 6, + XDLSTR(AX_STR), 3, IERR) IF (IERR.NE.0) GO TO 810 CALL XDLF_PARAM_TABLE_SETITEM (IVH_PAR1, IP_PACKID, + XDLSTR('pack id:'), 8, XDLSTR(' '), 1, 0, 0, IERR) IF (IERR.NE.0) GO TO 800 CALL XDLF_PARAM_TABLE_SETITEM (IVH_PAR1, IP_SPINDL, + XDLSTR('spindle (Deg):'), 14, XDLSTR(' '), 1, 0, 0, IERR) IF (IERR.NE.0) GO TO 800 CALL XDLF_PARAM_TABLE_SETITEM (IVH_PAR1, IP_A, + XDLSTR('a (Angstroms):'), 14, XDLSTR(' '), 1, 0, 0, IERR) IF (IERR.NE.0) GO TO 800 CALL XDLF_PARAM_TABLE_SETITEM (IVH_PAR1, IP_B, + XDLSTR('b (Angstroms):'), 14, XDLSTR(' '), 1, 0, 0, IERR) IF (IERR.NE.0) GO TO 800 CALL XDLF_PARAM_TABLE_SETITEM (IVH_PAR1, IP_C, + XDLSTR('c (Angstroms):'), 14, XDLSTR(' '), 1, 0, 0, IERR) IF (IERR.NE.0) GO TO 800 CALL XDLF_PARAM_TABLE_SETITEM (IVH_PAR1, IP_ALPH, + XDLSTR('alpha (Deg):'), 12, XDLSTR(' '), 1, 0, 0, IERR) IF (IERR.NE.0) GO TO 800 CALL XDLF_PARAM_TABLE_SETITEM (IVH_PAR1, IP_BETA, + XDLSTR('beta (Deg):'), 12, XDLSTR(' '), 1, 0, 0, IERR) IF (IERR.NE.0) GO TO 800 CALL XDLF_PARAM_TABLE_SETITEM (IVH_PAR1, IP_GAMM, + XDLSTR('gamma (Deg):'), 12, XDLSTR(' '), 1, 0, 0, IERR) IF (IERR.NE.0) GO TO 800 CALL XDLF_PARAM_TABLE_SETITEM (IVH_PAR1, IP_WMIN, + XDLSTR('lmin (A):'), 9, XDLSTR(' '), 1, 0, 0, IERR) IF (IERR.NE.0) GO TO 800 CALL XDLF_PARAM_TABLE_SETITEM (IVH_PAR1, IP_WMAX, + XDLSTR('lmax (A):'), 9, XDLSTR(' '), 1, 0, 0, IERR) IF (IERR.NE.0) GO TO 800 CALL XDLF_PARAM_TABLE_SETITEM (IVH_PAR1, IP_DMIN, + XDLSTR('dmin (A):'), 9, XDLSTR(' '), 1, 0, 0, IERR) IF (IERR.NE.0) GO TO 800 CALL XDLF_PARAM_TABLE_SETITEM (IVH_PAR1, IP_PHIX, + XDLSTR('phix (Deg):'), 11, XDLSTR(' '), 1, 0, 0, IERR) IF (IERR.NE.0) GO TO 800 CALL XDLF_PARAM_TABLE_SETITEM (IVH_PAR1, IP_PHIY, + XDLSTR('phiy (Deg):'), 11, XDLSTR(' '), 1, 0, 0, IERR) IF (IERR.NE.0) GO TO 800 CALL XDLF_PARAM_TABLE_SETITEM (IVH_PAR1, IP_PHIZ, + XDLSTR('phiz (Deg):'), 11, XDLSTR(' '), 1, 0, 0, IERR) IF (IERR.NE.0) GO TO 800 CALL XDLF_PARAM_TABLE_SETITEM (IVH_PAR1, IP_IMTYP, + XDLSTR('image type:'), 11, XDLSTR(' '), 1, 0, 0, IERR) IF (IERR.NE.0) GO TO 800 CALL XDLF_PARAM_TABLE_SETMENU (IVH_PAR1, IP_IMTYP, 2, + XDLSTR(IMTYP_STR), 6, IERR) IF (IERR.NE.0) GO TO 810 CALL XDLF_PARAM_TABLE_SETITEM (IVH_PAR1, IP_IMDAT, + XDLSTR('image data:'), 11, XDLSTR(' '), 1, 0, 0, IERR) IF (IERR.NE.0) GO TO 800 CALL XDLF_PARAM_TABLE_SETMENU (IVH_PAR1, IP_IMDAT, 4, + XDLSTR(IMDAT_STR), 6, IERR) IF (IERR.NE.0) GO TO 810 CALL XDLF_PARAM_TABLE_SETITEM (IVH_PAR1, IP_NUMP, + XDLSTR('numpack:'), 8, XDLSTR(' '), 1, 0, 0, IERR) IF (IERR.NE.0) GO TO 800 CALL XDLF_PARAM_TABLE_SETITEM (IVH_PAR1, IP_NPLAT, + XDLSTR('nplates:'), 7, XDLSTR(' '), 1, 0, 0, IERR) IF (IERR.NE.0) GO TO 800 CALL XDLF_PARAM_TABLE_SETITEM (IVH_PAR1, IP_FIDT, + XDLSTR('fiducials:'), 10, XDLSTR(' '), 1, 0, 0, IERR) IF (IERR.NE.0) GO TO 800 CALL XDLF_PARAM_TABLE_SETMENU (IVH_PAR1, IP_FIDT, 2, + XDLSTR(FID_STR), 3, IERR) IF (IERR.NE.0) GO TO 810 CALL XDLF_PARAM_TABLE_SETITEM (IVH_PAR1, IP_DISTOR, + XDLSTR('distortion:'), 11, XDLSTR(' '), 1, 0, 0, IERR) IF (IERR.NE.0) GO TO 800 CALL XDLF_PARAM_TABLE_SETMENU (IVH_PAR1, IP_DISTOR, 3, + XDLSTR(DSTYP_STR), 9, IERR) IF (IERR.NE.0) GO TO 810 CALL XDLF_PARAM_TABLE_SETITEM (IVH_PAR1, IP_DGEOM, + XDLSTR('detector geom:'), 14, XDLSTR(' '), 1, 0, 0, IERR) IF (IERR.NE.0) GO TO 800 CALL XDLF_PARAM_TABLE_SETMENU (IVH_PAR1, IP_DGEOM, 2, + XDLSTR(DGEOM_STR), 4, IERR) IF (IERR.NE.0) GO TO 810 CALL XDLF_PARAM_TABLE_SETITEM (IVH_PAR1, IP_DTILT, + XDLSTR('detector tilt:'), 14, XDLSTR(' '), 1, 0, 0, IERR) IF (IERR.NE.0) GO TO 800 CALL XDLF_PARAM_TABLE_SETITEM (IVH_PAR1, IP_EPS, + XDLSTR('spot eps (mm):'), 14, XDLSTR(' '), 1, 0, 0, IERR) IF (IERR.NE.0) GO TO 800 CALL XDLF_PARAM_TABLE_SETITEM (IVH_PAR1, IP_STHR, + XDLSTR('spot thresh:'), 12, XDLSTR(' '), 1, 0, 0, IERR) IF (IERR.NE.0) GO TO 800 CALL XDLF_PARAM_TABLE_SETITEM (IVH_PAR1, IP_OVPIX, + XDLSTR('overload pix:'), 13, XDLSTR(' '), 1, 0, 0, IERR) IF (IERR.NE.0) GO TO 800 CALL XDLF_PARAM_TABLE_SETITEM (IVH_PAR1, IP_TEMPL, + XDLSTR('template:'), 9, XDLSTR(' '), 1, 0, 0, IERR) IF (IERR.NE.0) GO TO 800 CALL XDLF_PARAM_TABLE_SETITEM (IVH_PAR1, IP_NXRAST, + XDLSTR('nxrast:'), 7, XDLSTR(' '), 1, 0, 0, IERR) IF (IERR.NE.0) GO TO 800 CALL XDLF_PARAM_TABLE_SETITEM (IVH_PAR1, IP_NYRAST, + XDLSTR('nyrast:'), 7, XDLSTR(' '), 1, 0, 0, IERR) IF (IERR.NE.0) GO TO 800 CALL XDLF_PARAM_TABLE_SETITEM (IVH_PAR1, IP_RAST, + XDLSTR('raster (mu):'), 12, XDLSTR(' '), 1, 0, 0, IERR) IF (IERR.NE.0) GO TO 800 CALL XDLF_PARAM_TABLE_SETITEM (IVH_PAR1, IP_AXORD, + XDLSTR('axis order:'), 11, XDLSTR(' '), 1, 0, 0, IERR) IF (IERR.NE.0) GO TO 800 CALL XDLF_PARAM_TABLE_SETMENU (IVH_PAR1, IP_AXORD, 14, + XDLSTR(AXORD_STR), 8, IERR) IF (IERR.NE.0) GO TO 810 CALL XDLF_PARAM_TABLE_SETITEM (IVH_PAR1, IP_RMIN, + XDLSTR('rmin (mm):'), 10, XDLSTR(' '), 1, 0, 0, IERR) IF (IERR.NE.0) GO TO 800 CALL XDLF_PARAM_TABLE_SETITEM (IVH_PAR1, IP_RMAX, + XDLSTR('rmax (mm):'), 10, XDLSTR(' '), 1, 0, 0, IERR) IF (IERR.NE.0) GO TO 800 CALL XDLF_PARAM_TABLE_SETITEM (IVH_PAR1, IP_XLOW, + XDLSTR('xlow (ras):'), 12, XDLSTR(' '), 1, 0, 0, IERR) IF (IERR.NE.0) GO TO 800 CALL XDLF_PARAM_TABLE_SETITEM (IVH_PAR1, IP_XHIGH, + XDLSTR('xhigh (ras):'), 12, XDLSTR(' '), 1, 0, 0, IERR) IF (IERR.NE.0) GO TO 800 CALL XDLF_PARAM_TABLE_SETITEM (IVH_PAR1, IP_YLOW, + XDLSTR('ylow (ras):'), 12, XDLSTR(' '), 1, 0, 0, IERR) IF (IERR.NE.0) GO TO 800 CALL XDLF_PARAM_TABLE_SETITEM (IVH_PAR1, IP_YHIGH, + XDLSTR('yhigh (ras):'), 12, XDLSTR(' '), 1, 0, 0, IERR) IF (IERR.NE.0) GO TO 800 C C====== Set up item names for parameter table 2 C LABEL = ' Plate' CALL STR_ADDI (LABEL, IPLATE, 1) CALL XDLF_PARAM_TABLE_SETITEM (IVH_PAR2, IP_LABEL, + XDLSTR(LABEL), 20, XDLSTR(' '), 1, -1, 1, IERR) IF (IERR.NE.0) GO TO 820 CALL XDLF_PARAM_TABLE_SETITEM (IVH_PAR2, IP_FNAM, + XDLSTR('filename:'), 9, XDLSTR(' '), 1, 0, 0, IERR) IF (IERR.NE.0) GO TO 800 CALL XDLF_PARAM_TABLE_SETITEM (IVH_PAR2, IP_CTOF, + XDLSTR('ctof (mm):'), 10, XDLSTR(' '), 1, 0, 0, IERR) IF (IERR.NE.0) GO TO 820 CALL XDLF_PARAM_TABLE_SETITEM (IVH_PAR2, IP_XCENF, + XDLSTR('x_cen_f (ras):'), 14, XDLSTR(' '), 1, 0, 0, IERR) IF (IERR.NE.0) GO TO 820 CALL XDLF_PARAM_TABLE_SETITEM (IVH_PAR2, IP_YCENF, + XDLSTR('y_cen_f (ras):'), 14, XDLSTR(' '), 1, 0, 0, IERR) IF (IERR.NE.0) GO TO 820 CALL XDLF_PARAM_TABLE_SETITEM (IVH_PAR2, IP_XC, + XDLSTR('x_c offset (mm):'), 16, XDLSTR(' '), 1, 0, 0, IERR) IF (IERR.NE.0) GO TO 820 CALL XDLF_PARAM_TABLE_SETITEM (IVH_PAR2, IP_YC, + XDLSTR('y_c offset (mm):'), 16, XDLSTR(' '), 1, 0, 0, IERR) IF (IERR.NE.0) GO TO 820 CALL XDLF_PARAM_TABLE_SETITEM (IVH_PAR2, IP_WC, + XDLSTR('w_c offset (deg):'), 17, XDLSTR(' '), 1, 0, 0, IERR) IF (IERR.NE.0) GO TO 820 CALL XDLF_PARAM_TABLE_SETITEM (IVH_PAR2, IP_YSCAL, + XDLSTR('y_scale:'), 8, XDLSTR(' '), 1, 0, 0, IERR) IF (IERR.NE.0) GO TO 820 CALL XDLF_PARAM_TABLE_SETITEM (IVH_PAR2, IP_TWIST, + XDLSTR('twist (.01deg):'), 15, XDLSTR(' '), 1, 0, 0, IERR) IF (IERR.NE.0) GO TO 820 CALL XDLF_PARAM_TABLE_SETITEM (IVH_PAR2, IP_TILT, + XDLSTR('tilt (.01deg):'), 15, XDLSTR(' '), 1, 0, 0, IERR) IF (IERR.NE.0) GO TO 820 CALL SET_PAR2_DST (IERR) IF (IERR.EQ.2) GO TO 810 IF (IERR.EQ.1) GO TO 820 CALL XDLF_PARAM_TABLE_SETITEM (IVH_PAR2, IP_STRK_L, + XDLSTR('spot length (mm):'), 17, XDLSTR(' '), 1, 0, 0, + IERR) IF (IERR.NE.0) GO TO 820 CALL XDLF_PARAM_TABLE_SETITEM (IVH_PAR2, IP_STRK_W, + XDLSTR('spot width (mm):'), 17, XDLSTR(' '), 1, 0, 0, + IERR) IF (IERR.NE.0) GO TO 820 CALL XDLF_PARAM_TABLE_SETITEM (IVH_PAR2, IP_STRK_F, + XDLSTR('spot factor:'), 12, XDLSTR(' '), 1, 0, 0, IERR) IF (IERR.NE.0) GO TO 820 CALL XDLF_PARAM_TABLE_SETITEM (IVH_PAR2, IP_STRK_BW, + XDLSTR('Spot border (ras):'), 18, XDLSTR(' '), 1, 0, 0, + IERR) IF (IERR.NE.0) GO TO 820 CALL XDLF_PARAM_TABLE_SETITEM (IVH_PAR2, IP_DELTA, + XDLSTR('spot delta (mm):'), 16, XDLSTR(' '), 1, 0, 0, IERR) IF (IERR.NE.0) GO TO 820 CALL XDLF_PARAM_TABLE_SETITEM (IVH_PAR2, IP_RFL, + XDLSTR('refined flag:'), 13, XDLSTR(' '), 1, 0, 0, IERR) IF (IERR.NE.0) GO TO 820 RETURN C C====== Error conditions C 800 WRITE (6,2001) STOP 810 WRITE (6,2002) STOP 820 WRITE (6,2003) STOP C C====== Format statements C 2001 FORMAT (/,' **Error in setting names for first parameter table**') 2002 FORMAT (/,' **Error in setting menus for first parameter table**') 2003 FORMAT (/,' **Error in setting names for 2''nd parameter table**') END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C**************************** C** SET_PAR1_VALS ** C**************************** C C SUBROUTINE SET_PAR1_VALS (NE, LISTE) C INCLUDE 'implicit_none.finc' C C Purpose: Set some or all values in parameter table 1 (from values in C LDM data); C Deal with some parameter dependencies. (Note that cell consistency C routine reset_cell is no longer called from here and needs to be C called if any cell parameter is changed) C C Author: John W. Campbell, May 1991 C C Arguments: C INTEGER NE INTEGER LISTE(*) C NE (R) Number of entries to be updated (0=all) C LISTE (R) Array of parameter table entry numbers for the NE parameters C to be updated. C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' INCLUDE 'screen_params.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'ip1_entries.finc' INCLUDE 'ip2_entries.finc' INCLUDE 'film_pack.finc' INCLUDE 'prog_flags.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR C C====== LOCALS: C LOGICAL CLL LOGICAL CBLANK(6) LOGICAL IPLIST(NP1_COLS*NP1_ROWS) INTEGER I INTEGER NPMAX INTEGER IERR INTEGER LST2(3) INTEGER IVAL INTEGER ISYST INTEGER IFLAG INTEGER ND INTEGER IORD INTEGER ISWAP REAL VALUE REAL CELLP(6) CHARACTER*2 ERRSTR CHARACTER*(MAX_PSCROLL_CHARS) VALSTR CHARACTER*4 SYST_STR(7) C LOGICAL CLL !Flag =.TRUE. cell param(s) to update, =.FALSE. not C LOGICAL CBLANK(6)!Flags to o/p fixed cell params as blanks C LOGICAL IPLIST(NP1_COLS*NP1_ROWS) !Flags for items to be changed C INTEGER I !Temp/loop variable C INTEGER NPMAX !Maximum number of parameters possible in table 1 C INTEGER IERR !Error flag C INTEGER LST2(3) !List of parameter item values to reset C INTEGER IVAL !Integer parameter value C INTEGER ISYST !Crystal system C INTEGER IFLAG !Parameter status flag C INTEGER ND !No. of decimal places flag C INTEGER IORD !Data order flag C INTEGER ISWAP !Byte swap flag C REAL VALUE !Real parameter value C REAL CELLP(6) !Cell parameters C CHARACTER*2 ERRSTR !Dummy error string C CHARACTER*(MAX_PSCROLL_CHARS) VALSTR !Value string for parameter table C CHARACTER*4 SYST_STR(7) !Crystal system strings DATA SYST_STR /'Tri.', + 'Mon.', + 'Ort.', + 'Tet.', + 'Hex.', + 'Rho.', + 'Cub.'/ C C------------------------------------------------------------------------------- C IF (LG_MODE.NE.1) RETURN C C====== Set up flags of parameter items to be changed C NPMAX = NP1_ROWS*NP1_COLS DO 10 I=1,NPMAX IF (NE.EQ.0) THEN IPLIST(I) = .TRUE. ELSE IPLIST(I) = .FALSE. END IF 10 CONTINUE IF (NE.GT.0) THEN DO 20 I=1,NE IF (LISTE(I).GE.1.AND.LISTE(I).LE.NPMAX) + IPLIST(LISTE(I)) = .TRUE. 20 CONTINUE END IF C C====== See if cell parameter(s) included in list C CLL = .FALSE. IF (NE.EQ.0) CLL=.TRUE. IF (NE.GT.0) THEN IF (IPLIST(IP_A)) CLL = .TRUE. IF (IPLIST(IP_B)) CLL = .TRUE. IF (IPLIST(IP_C)) CLL = .TRUE. IF (IPLIST(IP_ALPH)) CLL = .TRUE. IF (IPLIST(IP_BETA)) CLL = .TRUE. IF (IPLIST(IP_GAMM)) CLL = .TRUE. IF (IPLIST(IP_SYST)) CLL = .TRUE. END IF C C====== Update cell parameters (if required) C IF (CLL) THEN DO 30 I=1,6 CBLANK(I) = .FALSE. 30 CONTINUE CALL LDM_GET_A (CELLP(1), IFLAG, ND) CALL LDM_GET_B (CELLP(2), IFLAG, ND) CALL LDM_GET_C (CELLP(3), IFLAG, ND) CALL LDM_GET_ALPHA (CELLP(4), IFLAG, ND) CALL LDM_GET_BETA (CELLP(5), IFLAG, ND) CALL LDM_GET_GAMMA (CELLP(6), IFLAG, ND) CALL LDM_GET_SYST (VALSTR, ISYST, IFLAG) IF (ISYST.EQ.2) THEN CBLANK(4) = .TRUE. CBLANK(6) = .TRUE. ELSE IF (ISYST.EQ.3) THEN CBLANK(4) = .TRUE. CBLANK(5) = .TRUE. CBLANK(6) = .TRUE. ELSE IF (ISYST.EQ.4) THEN CBLANK(2) = .TRUE. CBLANK(4) = .TRUE. CBLANK(5) = .TRUE. CBLANK(6) = .TRUE. ELSE IF (ISYST.EQ.5) THEN CBLANK(2) = .TRUE. CBLANK(4) = .TRUE. CBLANK(5) = .TRUE. CBLANK(6) = .TRUE. ELSE IF (ISYST.EQ.6) THEN CBLANK(2) = .TRUE. CBLANK(3) = .TRUE. CBLANK(5) = .TRUE. CBLANK(6) = .TRUE. ELSE IF (ISYST.EQ.7) THEN CBLANK(2) = .TRUE. CBLANK(3) = .TRUE. CBLANK(4) = .TRUE. CBLANK(5) = .TRUE. CBLANK(6) = .TRUE. END IF WRITE (VALSTR,'(F8.2)') CELLP(1) CALL LJUST(VALSTR) CALL XDLF_PARAM_TABLE_SETVALUE (IVH_PAR1, IP_A, + XDLSTR(VALSTR), MAX_PSCROLL_CHARS, 0, IERR) IF (CBLANK(2)) THEN CALL XDLF_PARAM_TABLE_SETVALUE (IVH_PAR1, IP_B, + XDLSTR(' '), 1, 0, IERR) ELSE WRITE (VALSTR,'(F8.2)') CELLP(2) CALL LJUST(VALSTR) CALL XDLF_PARAM_TABLE_SETVALUE (IVH_PAR1, IP_B, + XDLSTR(VALSTR), MAX_PSCROLL_CHARS, 0, IERR) END IF IF (CBLANK(3)) THEN CALL XDLF_PARAM_TABLE_SETVALUE (IVH_PAR1, IP_C, + XDLSTR(' '), 1, 0, IERR) ELSE WRITE (VALSTR,'(F8.2)') CELLP(3) CALL LJUST(VALSTR) CALL XDLF_PARAM_TABLE_SETVALUE (IVH_PAR1, IP_C, + XDLSTR(VALSTR), MAX_PSCROLL_CHARS, 0, IERR) END IF IF (CBLANK(4)) THEN CALL XDLF_PARAM_TABLE_SETVALUE (IVH_PAR1, IP_ALPH, + XDLSTR(' '), 1, 0, IERR) ELSE WRITE (VALSTR,'(F8.2)') CELLP(4) CALL LJUST(VALSTR) CALL XDLF_PARAM_TABLE_SETVALUE (IVH_PAR1, IP_ALPH, + XDLSTR(VALSTR), MAX_PSCROLL_CHARS, 0, IERR) END IF IF (CBLANK(5)) THEN CALL XDLF_PARAM_TABLE_SETVALUE (IVH_PAR1, IP_BETA, + XDLSTR(' '), 1, 0, IERR) ELSE WRITE (VALSTR,'(F8.2)') CELLP(5) CALL LJUST(VALSTR) CALL XDLF_PARAM_TABLE_SETVALUE (IVH_PAR1, IP_BETA, + XDLSTR(VALSTR), MAX_PSCROLL_CHARS, 0, IERR) END IF IF (CBLANK(6)) THEN CALL XDLF_PARAM_TABLE_SETVALUE (IVH_PAR1, IP_GAMM, + XDLSTR(' '), 1, 0, IERR) ELSE WRITE (VALSTR,'(F8.2)') CELLP(6) CALL LJUST(VALSTR) CALL XDLF_PARAM_TABLE_SETVALUE (IVH_PAR1, IP_GAMM, + XDLSTR(VALSTR), MAX_PSCROLL_CHARS, 0, IERR) END IF CALL LDM_GET_SYST (VALSTR, IVAL, IFLAG) VALSTR = SYST_STR(IVAL) CALL XDLF_PARAM_TABLE_SETVALUE (IVH_PAR1, IP_SYST, + XDLSTR(VALSTR), MAX_PSCROLL_CHARS, 0, IERR) END IF C C====== Update other parameters as required C IF (IPLIST(IP_PACK)) THEN WRITE (VALSTR,'(I8)') IPACK CALL LJUST(VALSTR) CALL XDLF_PARAM_TABLE_SETVALUE (IVH_PAR1, IP_PACK, + XDLSTR(VALSTR), MAX_PSCROLL_CHARS, 0, IERR) END IF IF (IPLIST(IP_PLATE)) THEN WRITE (VALSTR,'(I8)') IPLATE CALL LJUST(VALSTR) CALL XDLF_PARAM_TABLE_SETVALUE (IVH_PAR1, IP_PLATE, + XDLSTR(VALSTR), MAX_PSCROLL_CHARS, 0, IERR) END IF IF (IPLIST(IP_LATT)) THEN CALL LDM_GET_LATT (VALSTR, IVAL, IFLAG) CALL XDLF_PARAM_TABLE_SETVALUE (IVH_PAR1, IP_LATT, + XDLSTR(VALSTR), MAX_PSCROLL_CHARS, 0, IERR) END IF IF (IPLIST(IP_SYMM)) THEN CALL LDM_GET_NSYM (IVAL, IFLAG) IF (IVAL.EQ.0) THEN VALSTR = 'no' ELSE VALSTR = 'yes' END IF CALL XDLF_PARAM_TABLE_SETVALUE (IVH_PAR1, IP_SYMM, + XDLSTR(VALSTR), MAX_PSCROLL_CHARS, 0, IERR) END IF IF (IPLIST(IP_ROT)) THEN CALL LDM_GET_ROT (VALSTR, IVAL, IFLAG) CALL XDLF_PARAM_TABLE_SETVALUE (IVH_PAR1, IP_ROT, + XDLSTR(VALSTR), MAX_PSCROLL_CHARS, 0, IERR) END IF IF (IPLIST(IP_BEAM)) THEN CALL LDM_GET_BEAM (VALSTR, IVAL, IFLAG) CALL XDLF_PARAM_TABLE_SETVALUE (IVH_PAR1, IP_BEAM, + XDLSTR(VALSTR), MAX_PSCROLL_CHARS, 0, IERR) END IF IF (IPLIST(IP_PACKID)) THEN CALL LDM_GET_PID (IPACK, IVAL, IFLAG, IERR, ERRSTR) WRITE (VALSTR,'(I8)') IVAL CALL LJUST(VALSTR) CALL XDLF_PARAM_TABLE_SETVALUE (IVH_PAR1, IP_PACKID, + XDLSTR(VALSTR), MAX_PSCROLL_CHARS, 0, IERR) END IF IF (IPLIST(IP_SPINDL)) THEN CALL LDM_GET_SPIN (IPACK, VALUE, IFLAG, ND, IERR, ERRSTR) WRITE (VALSTR,'(F8.2)') VALUE CALL LJUST(VALSTR) CALL XDLF_PARAM_TABLE_SETVALUE (IVH_PAR1, IP_SPINDL, + XDLSTR(VALSTR), MAX_PSCROLL_CHARS, 0, IERR) END IF IF (IPLIST(IP_WMIN)) THEN CALL LDM_GET_LMIN (IPACK, VALUE, IFLAG, ND, IERR, ERRSTR) WRITE (VALSTR,'(F8.2)') VALUE CALL LJUST(VALSTR) CALL XDLF_PARAM_TABLE_SETVALUE (IVH_PAR1, IP_WMIN, + XDLSTR(VALSTR), MAX_PSCROLL_CHARS, 0, IERR) END IF IF (IPLIST(IP_WMAX)) THEN CALL LDM_GET_LMAX (IPACK, VALUE, IFLAG, ND, IERR, ERRSTR) WRITE (VALSTR,'(F8.2)') VALUE CALL LJUST(VALSTR) CALL XDLF_PARAM_TABLE_SETVALUE (IVH_PAR1, IP_WMAX, + XDLSTR(VALSTR), MAX_PSCROLL_CHARS, 0, IERR) END IF IF (IPLIST(IP_DMIN)) THEN CALL LDM_GET_DMIN (IPACK, VALUE, IFLAG, ND, IERR, ERRSTR) WRITE (VALSTR,'(F8.2)') VALUE CALL LJUST(VALSTR) CALL XDLF_PARAM_TABLE_SETVALUE (IVH_PAR1, IP_DMIN, + XDLSTR(VALSTR), MAX_PSCROLL_CHARS, 0, IERR) END IF IF (IPLIST(IP_PHIX)) THEN CALL LDM_GET_PHIX (IPACK, VALUE, IFLAG, ND, IERR, ERRSTR) WRITE (VALSTR,'(F8.2)') VALUE CALL LJUST(VALSTR) CALL XDLF_PARAM_TABLE_SETVALUE (IVH_PAR1, IP_PHIX, + XDLSTR(VALSTR), MAX_PSCROLL_CHARS, 0, IERR) END IF IF (IPLIST(IP_PHIY)) THEN CALL LDM_GET_PHIY (IPACK, VALUE, IFLAG, ND, IERR, ERRSTR) WRITE (VALSTR,'(F8.2)') VALUE CALL LJUST(VALSTR) CALL XDLF_PARAM_TABLE_SETVALUE (IVH_PAR1, IP_PHIY, + XDLSTR(VALSTR), MAX_PSCROLL_CHARS, 0, IERR) END IF IF (IPLIST(IP_PHIZ)) THEN CALL LDM_GET_PHIZ (IPACK, VALUE, IFLAG, ND, IERR, ERRSTR) WRITE (VALSTR,'(F8.2)') VALUE CALL LJUST(VALSTR) CALL XDLF_PARAM_TABLE_SETVALUE (IVH_PAR1, IP_PHIZ, + XDLSTR(VALSTR), MAX_PSCROLL_CHARS, 0, IERR) END IF IF (IPLIST(IP_IMTYP)) THEN CALL LDM_GET_IMTYP (VALSTR, IVAL, IFLAG) CALL XDLF_PARAM_TABLE_SETVALUE (IVH_PAR1, IP_IMTYP, + XDLSTR(VALSTR), MAX_PSCROLL_CHARS, 0, IERR) END IF IF (IPLIST(IP_IMDAT)) THEN CALL LDM_GET_IMDAT (VALSTR, IVAL, IFLAG) CALL XDLF_PARAM_TABLE_SETVALUE (IVH_PAR1, IP_IMDAT, + XDLSTR(VALSTR), MAX_PSCROLL_CHARS, 0, IERR) END IF IF (IPLIST(IP_NUMP)) THEN CALL LDM_GET_NUMP (IVAL, IFLAG) WRITE (VALSTR,'(I8)') IVAL CALL LJUST(VALSTR) CALL XDLF_PARAM_TABLE_SETVALUE (IVH_PAR1, IP_NUMP, + XDLSTR(VALSTR), MAX_PSCROLL_CHARS, 0, IERR) END IF IF (IPLIST(IP_NPLAT)) THEN CALL LDM_GET_NPLAT (IVAL, IFLAG) WRITE (VALSTR,'(I8)') IVAL CALL LJUST(VALSTR) CALL XDLF_PARAM_TABLE_SETVALUE (IVH_PAR1, IP_NPLAT, + XDLSTR(VALSTR), MAX_PSCROLL_CHARS, 0, IERR) END IF IF (IPLIST(IP_FIDT)) THEN CALL LDM_GET_FIDT (VALSTR, IVAL, IFLAG) CALL XDLF_PARAM_TABLE_SETVALUE (IVH_PAR1, IP_FIDT, + XDLSTR(VALSTR), MAX_PSCROLL_CHARS, 0, IERR) END IF IF (IPLIST(IP_DISTOR)) THEN CALL LDM_GET_DSTOR (VALSTR, IVAL, IFLAG) CALL XDLF_PARAM_TABLE_SETVALUE (IVH_PAR1, IP_DISTOR, + XDLSTR(VALSTR), MAX_PSCROLL_CHARS, 0, IERR) CALL SET_PAR2_DST(IERR) IF (IVAL.EQ.1) THEN LST2(1) = IP_BULGE CALL SET_PAR2_VALS (1, LST2) ELSE IF (IVAL.EQ.2) THEN LST2(1) = IP_ROFF LST2(2) = IP_TOFF CALL SET_PAR2_VALS (2, LST2) ELSE IF (IVAL.EQ.3) THEN LST2(1) = IP_SPDXY LST2(2) = IP_SPDX LST2(3) = IP_SPDY CALL SET_PAR2_VALS (3, LST2) END IF END IF IF (IPLIST(IP_DGEOM)) THEN CALL LDM_GET_DGEOM (VALSTR, IVAL, IFLAG) CALL XDLF_PARAM_TABLE_SETVALUE (IVH_PAR1, IP_DGEOM, + XDLSTR(VALSTR), MAX_PSCROLL_CHARS, 0, IERR) END IF IF (IPLIST(IP_DTILT)) THEN CALL LDM_GET_DTILT (VALUE, IFLAG, ND) WRITE (VALSTR,'(F8.2)') VALUE CALL LJUST(VALSTR) CALL XDLF_PARAM_TABLE_SETVALUE (IVH_PAR1, IP_DTILT, + XDLSTR(VALSTR), MAX_PSCROLL_CHARS, 0, IERR) END IF IF (IPLIST(IP_EPS)) THEN CALL LDM_GET_EPS (VALUE, IFLAG, ND) WRITE (VALSTR,'(F8.2)') VALUE CALL LJUST(VALSTR) CALL XDLF_PARAM_TABLE_SETVALUE (IVH_PAR1, IP_EPS, + XDLSTR(VALSTR), MAX_PSCROLL_CHARS, 0, IERR) END IF IF (IPLIST(IP_STHR)) THEN CALL LDM_GET_STHR (VALUE, IFLAG, ND) WRITE (VALSTR,'(F8.2)') VALUE CALL LJUST(VALSTR) CALL XDLF_PARAM_TABLE_SETVALUE (IVH_PAR1, IP_STHR, + XDLSTR(VALSTR), MAX_PSCROLL_CHARS, 0, IERR) END IF IF (IPLIST(IP_OVPIX)) THEN CALL LDM_GET_OVPIX (IVAL, IFLAG) WRITE (VALSTR,'(I8)') IVAL CALL LJUST(VALSTR) CALL XDLF_PARAM_TABLE_SETVALUE (IVH_PAR1, IP_OVPIX, + XDLSTR(VALSTR), MAX_PSCROLL_CHARS, 0, IERR) END IF IF (IPLIST(IP_TEMPL)) THEN CALL LDM_GET_TEMPL (VALSTR, IFLAG) CALL XDLF_PARAM_TABLE_SETVALUE (IVH_PAR1, IP_TEMPL, + XDLSTR(VALSTR), MAX_PSCROLL_CHARS, 0, IERR) LST2(1) = IP_FNAM CALL SET_PAR2_VALS (1, LST2) END IF IF (IPLIST(IP_NXRAST)) THEN CALL LDM_GET_NXRAS (IVAL, IFLAG) WRITE (VALSTR,'(I8)') IVAL CALL LJUST(VALSTR) CALL XDLF_PARAM_TABLE_SETVALUE (IVH_PAR1, IP_NXRAST, + XDLSTR(VALSTR), MAX_PSCROLL_CHARS, 0, IERR) END IF IF (IPLIST(IP_NYRAST)) THEN CALL LDM_GET_NYRAS (IVAL, IFLAG) WRITE (VALSTR,'(I8)') IVAL CALL LJUST(VALSTR) CALL XDLF_PARAM_TABLE_SETVALUE (IVH_PAR1, IP_NYRAST, + XDLSTR(VALSTR), MAX_PSCROLL_CHARS, 0, IERR) END IF IF (IPLIST(IP_RAST)) THEN CALL LDM_GET_RAST (VALUE, IFLAG, ND) WRITE (VALSTR,'(F8.2)') VALUE CALL LJUST(VALSTR) CALL XDLF_PARAM_TABLE_SETVALUE (IVH_PAR1, IP_RAST, + XDLSTR(VALSTR), MAX_PSCROLL_CHARS, 0, IERR) END IF IF (IPLIST(IP_AXORD)) THEN CALL LDM_GET_AXORD (VALSTR, IORD, ISWAP, IFLAG) CALL XDLF_PARAM_TABLE_SETVALUE (IVH_PAR1, IP_AXORD, + XDLSTR(VALSTR), MAX_PSCROLL_CHARS, 0, IERR) END IF IF (IPLIST(IP_RMIN)) THEN CALL LDM_GET_RMIN (VALUE, IFLAG, ND) WRITE (VALSTR,'(F8.2)') VALUE CALL LJUST(VALSTR) CALL XDLF_PARAM_TABLE_SETVALUE (IVH_PAR1, IP_RMIN, + XDLSTR(VALSTR), MAX_PSCROLL_CHARS, 0, IERR) END IF IF (IPLIST(IP_RMAX)) THEN CALL LDM_GET_RMAX (VALUE, IFLAG, ND) WRITE (VALSTR,'(F8.2)') VALUE CALL LJUST(VALSTR) CALL XDLF_PARAM_TABLE_SETVALUE (IVH_PAR1, IP_RMAX, + XDLSTR(VALSTR), MAX_PSCROLL_CHARS, 0, IERR) END IF IF (IPLIST(IP_XLOW)) THEN CALL LDM_GET_XLOW (VALUE, IFLAG, ND) WRITE (VALSTR,'(F8.2)') VALUE CALL LJUST(VALSTR) CALL XDLF_PARAM_TABLE_SETVALUE (IVH_PAR1, IP_XLOW, + XDLSTR(VALSTR), MAX_PSCROLL_CHARS, 0, IERR) END IF IF (IPLIST(IP_XHIGH)) THEN CALL LDM_GET_XHIGH (VALUE, IFLAG, ND) WRITE (VALSTR,'(F8.2)') VALUE CALL LJUST(VALSTR) CALL XDLF_PARAM_TABLE_SETVALUE (IVH_PAR1, IP_XHIGH, + XDLSTR(VALSTR), MAX_PSCROLL_CHARS, 0, IERR) END IF IF (IPLIST(IP_YLOW)) THEN CALL LDM_GET_YLOW (VALUE, IFLAG, ND) WRITE (VALSTR,'(F8.2)') VALUE CALL LJUST(VALSTR) CALL XDLF_PARAM_TABLE_SETVALUE (IVH_PAR1, IP_YLOW, + XDLSTR(VALSTR), MAX_PSCROLL_CHARS, 0, IERR) END IF IF (IPLIST(IP_YHIGH)) THEN CALL LDM_GET_YHIGH (VALUE, IFLAG, ND) WRITE (VALSTR,'(F8.2)') VALUE CALL LJUST(VALSTR) CALL XDLF_PARAM_TABLE_SETVALUE (IVH_PAR1, IP_YHIGH, + XDLSTR(VALSTR), MAX_PSCROLL_CHARS, 0, IERR) END IF RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C**************************** C** SET_PAR2_DST ** C**************************** C C SUBROUTINE SET_PAR2_DST (IERR) C INCLUDE 'implicit_none.finc' C C Purpose: Set parameter names (and menus) for distortion correction type C dependent parameters C C Author: John W. Campbell, September 1993 C C Arguments: C INTEGER IERR C C IERR (W) Error flag =0 OK, =1 error C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' INCLUDE 'screen_params.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'ip2_entries.finc' INCLUDE 'film_pack.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR C C====== LOCALS: C INTEGER IFLAG INTEGER DISTOR_TYPE CHARACTER*2 VALSTR CHARACTER*4 SPD_STR(2) C INTEGER IFLAG !Parameter status flag C INTEGER DISTOR_TYPE !Distortion type C CHARACTER*2 VALSTR !Dummy value string C CHARACTER*4 SPD_STR(2) !Menu strings for spd items C DATA SPD_STR/'edit',' '/ C C------------------------------------------------------------------------------- C IERR = 0 C C===== Clear distortion type dependent parameter table entries C CALL XDLF_PARAM_TABLE_DELITEM (IVH_PAR2, IP_BULGE, IERR) CALL XDLF_PARAM_TABLE_DELITEM (IVH_PAR2, IP_ROFF, IERR) CALL XDLF_PARAM_TABLE_DELITEM (IVH_PAR2, IP_TOFF, IERR) CALL XDLF_PARAM_TABLE_DELITEM (IVH_PAR2, IP_SPDXY, IERR) CALL XDLF_PARAM_TABLE_DELITEM (IVH_PAR2, IP_SPDX, IERR) CALL XDLF_PARAM_TABLE_DELITEM (IVH_PAR2, IP_SPDY, IERR) C C====== Now set distortion type dependent parameters for current type C CALL LDM_GET_DSTOR (VALSTR, DISTOR_TYPE, IFLAG) IF (DISTOR_TYPE.EQ.1) THEN CALL XDLF_PARAM_TABLE_SETITEM (IVH_PAR2, IP_BULGE, + XDLSTR('bulge (.01deg):'), 15, XDLSTR(' '), 1, 0, 0, IERR) IF (IERR.NE.0) THEN IERR = 1 RETURN END IF ELSE IF (DISTOR_TYPE.EQ.2) THEN CALL XDLF_PARAM_TABLE_SETITEM (IVH_PAR2, IP_ROFF, + XDLSTR('roff (10mu):'), 12, XDLSTR(' '), 1, 0, 0, IERR) IF (IERR.NE.0) THEN IERR = 1 RETURN END IF CALL XDLF_PARAM_TABLE_SETITEM (IVH_PAR2, IP_TOFF, + XDLSTR('toff (10mu):'), 12, XDLSTR(' '), 1, 0, 0, IERR) IF (IERR.NE.0) THEN IERR = 1 RETURN END IF ELSE IF (DISTOR_TYPE.EQ.3) THEN CALL XDLF_PARAM_TABLE_SETITEM (IVH_PAR2, IP_SPDXY, + XDLSTR('spdxy:'), 6, XDLSTR(' '), 1, 0, 0, IERR) IF (IERR.NE.0) THEN IERR = 1 RETURN END IF CALL XDLF_PARAM_TABLE_SETITEM (IVH_PAR2, IP_SPDX, + XDLSTR('spdx_n:'), 7, XDLSTR(' '), 1, 0, 0, IERR) IF (IERR.NE.0) THEN IERR = 1 RETURN END IF CALL XDLF_PARAM_TABLE_SETMENU (IVH_PAR2, IP_SPDX, 1, + XDLSTR(SPD_STR), 8, IERR) IF (IERR.NE.0) THEN IERR = 2 RETURN END IF CALL XDLF_PARAM_TABLE_SETITEM (IVH_PAR2, IP_SPDY, + XDLSTR('spdy_n:'), 12, XDLSTR(' '), 1, 0, 0, IERR) IF (IERR.NE.0) THEN IERR = 1 RETURN END IF CALL XDLF_PARAM_TABLE_SETMENU (IVH_PAR2, IP_SPDY, 1, + XDLSTR(SPD_STR), 8, IERR) IF (IERR.NE.0) THEN IERR = 2 RETURN END IF END IF RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C**************************** C** SET_PAR2_VALS ** C**************************** C C SUBROUTINE SET_PAR2_VALS (NE, LISTE) C INCLUDE 'implicit_none.finc' C C Purpose: Set some or all values in parameter table 2 (from values in C the common blocks); C C Author: John W. Campbell, May 1991 C C Arguments: C INTEGER NE INTEGER LISTE(*) C NE (R) Number of entries to be updated (0=all) C LISTE (R) Array of parameter table entry numbers for the NE parameters C to be updated. C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' INCLUDE 'screen_params.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'ip2_entries.finc' INCLUDE 'film_pack.finc' INCLUDE 'prog_flags.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR C C====== LOCALS: C LOGICAL IPLIST(NP2_COLS*NP2_ROWS) INTEGER I INTEGER NPMAX INTEGER IERR INTEGER IVAL INTEGER IFLAG INTEGER ND INTEGER DISTOR_TYPE REAL VALUE CHARACTER*(MAX_P2SCROLL_CHARS) VALSTR CHARACTER*20 LABEL CHARACTER*2 ERRSTR C LOGICAL IPLIST(NP2_COLS*NP2_ROWS) !Flags for items to be changed C INTEGER I !Temp/loop variable C INTEGER NPMAX !Maximum number of parameters possible in table 2 C INTEGER IERR !Error flag C INTEGER IVAL !Integer parameter value C INTEGER IFLAG !Parameter status flag C INTEGER ND !No. of decimal places flag C INTEGER DISTOR_TYPE !Distortion type flag C REAL VALUE !Real parameter value C CHARACTER*(MAX_P2SCROLL_CHARS) VALSTR !Value string for parameter table C CHARACTER*20 LABEL !Label string for parameter table C CHARACTER*2 ERRSTR !Dummy error string C C C------------------------------------------------------------------------------- C IF (LG_MODE.NE.1) RETURN C C====== Set up flags of parameter items to be changed C NPMAX = NP2_ROWS*NP2_COLS DO 10 I=1,NPMAX IF (NE.EQ.0) THEN IPLIST(I) = .TRUE. ELSE IPLIST(I) = .FALSE. END IF 10 CONTINUE IF (NE.GT.0) THEN DO 20 I=1,NE IF (LISTE(I).GE.1.AND.LISTE(I).LE.NPMAX) + IPLIST(LISTE(I)) = .TRUE. 20 CONTINUE END IF C C====== Update parameters C IF (IPLIST(IP_LABEL)) THEN LABEL = ' Plate' CALL STR_ADDI (LABEL, IPLATE, 1) CALL XDLF_PARAM_TABLE_SETITEM (IVH_PAR2, IP_LABEL, + XDLSTR(LABEL), 20, XDLSTR(' '), 1, -1, 1, IERR) END IF IF (IPLIST(IP_FNAM)) THEN CALL LDM_FILENAME (IPACK, IPLATE, VALSTR) CALL XDLF_PARAM_TABLE_SETVALUE (IVH_PAR2, IP_FNAM, + XDLSTR(VALSTR), MAX_P2SCROLL_CHARS, 0, IERR) END IF IF (IPLIST(IP_CTOF)) THEN CALL LDM_GET_CTOF (IPACK, IPLATE, VALUE, IFLAG, ND, + IERR, ERRSTR) WRITE (VALSTR,'(F8.2)') VALUE CALL LJUST(VALSTR) CALL XDLF_PARAM_TABLE_SETVALUE (IVH_PAR2, IP_CTOF, + XDLSTR(VALSTR), MAX_P2SCROLL_CHARS, 0, IERR) END IF IF (IPLIST(IP_XCENF)) THEN CALL LDM_GET_XCENF (IPACK, IPLATE, VALUE, IFLAG, ND, + IERR, ERRSTR) WRITE (VALSTR,'(F8.2)') VALUE CALL LJUST(VALSTR) CALL XDLF_PARAM_TABLE_SETVALUE (IVH_PAR2, IP_XCENF, + XDLSTR(VALSTR), MAX_P2SCROLL_CHARS, 0, IERR) END IF IF (IPLIST(IP_YCENF)) THEN CALL LDM_GET_YCENF (IPACK, IPLATE, VALUE, IFLAG, ND, + IERR, ERRSTR) WRITE (VALSTR,'(F8.2)') VALUE CALL LJUST(VALSTR) CALL XDLF_PARAM_TABLE_SETVALUE (IVH_PAR2, IP_YCENF, + XDLSTR(VALSTR), MAX_P2SCROLL_CHARS, 0, IERR) END IF IF (IPLIST(IP_XC)) THEN CALL LDM_GET_XC (IPACK, IPLATE, VALUE, IFLAG, ND, + IERR, ERRSTR) WRITE (VALSTR,'(F8.2)') VALUE CALL LJUST(VALSTR) CALL XDLF_PARAM_TABLE_SETVALUE (IVH_PAR2, IP_XC, + XDLSTR(VALSTR), MAX_P2SCROLL_CHARS, 0, IERR) END IF IF (IPLIST(IP_YC)) THEN CALL LDM_GET_YC (IPACK, IPLATE, VALUE, IFLAG, ND, + IERR, ERRSTR) WRITE (VALSTR,'(F8.2)') VALUE CALL LJUST(VALSTR) CALL XDLF_PARAM_TABLE_SETVALUE (IVH_PAR2, IP_YC, + XDLSTR(VALSTR), MAX_P2SCROLL_CHARS, 0, IERR) END IF IF (IPLIST(IP_WC)) THEN CALL LDM_GET_WC (IPACK, IPLATE, VALUE, IFLAG, ND, + IERR, ERRSTR) WRITE (VALSTR,'(F8.2)') VALUE CALL LJUST(VALSTR) CALL XDLF_PARAM_TABLE_SETVALUE (IVH_PAR2, IP_WC, + XDLSTR(VALSTR), MAX_P2SCROLL_CHARS, 0, IERR) END IF IF (IPLIST(IP_YSCAL)) THEN CALL LDM_GET_YSCAL (IPACK, IPLATE, VALUE, IFLAG, ND, + IERR, ERRSTR) WRITE (VALSTR,'(F8.3)') VALUE CALL LJUST(VALSTR) CALL XDLF_PARAM_TABLE_SETVALUE (IVH_PAR2, IP_YSCAL, + XDLSTR(VALSTR), MAX_P2SCROLL_CHARS, 0, IERR) END IF IF (IPLIST(IP_TWIST)) THEN CALL LDM_GET_TWIST (IPACK, IPLATE, VALUE, IFLAG, ND, + IERR, ERRSTR) WRITE (VALSTR,'(F8.2)') VALUE CALL LJUST(VALSTR) CALL XDLF_PARAM_TABLE_SETVALUE (IVH_PAR2, IP_TWIST, + XDLSTR(VALSTR), MAX_P2SCROLL_CHARS, 0, IERR) END IF IF (IPLIST(IP_TILT)) THEN CALL LDM_GET_TILT (IPACK, IPLATE, VALUE, IFLAG, ND, + IERR, ERRSTR) WRITE (VALSTR,'(F8.2)') VALUE CALL LJUST(VALSTR) CALL XDLF_PARAM_TABLE_SETVALUE (IVH_PAR2, IP_TILT, + XDLSTR(VALSTR), MAX_P2SCROLL_CHARS, 0, IERR) END IF CALL LDM_GET_DSTOR (VALSTR, DISTOR_TYPE, IFLAG) IF (IPLIST(IP_BULGE).AND.DISTOR_TYPE.EQ.1) THEN CALL LDM_GET_BULGE (IPACK, IPLATE, VALUE, IFLAG, ND, + IERR, ERRSTR) WRITE (VALSTR,'(F8.2)') VALUE CALL LJUST(VALSTR) CALL XDLF_PARAM_TABLE_SETVALUE (IVH_PAR2, IP_BULGE, + XDLSTR(VALSTR), MAX_P2SCROLL_CHARS, 0, IERR) END IF IF (IPLIST(IP_ROFF).AND.DISTOR_TYPE.EQ.2) THEN CALL LDM_GET_ROFF (IPACK, IPLATE, VALUE, IFLAG, ND, + IERR, ERRSTR) WRITE (VALSTR,'(F8.1)') VALUE CALL LJUST(VALSTR) CALL XDLF_PARAM_TABLE_SETVALUE (IVH_PAR2, IP_ROFF, + XDLSTR(VALSTR), MAX_P2SCROLL_CHARS, 0, IERR) END IF IF (IPLIST(IP_TOFF).AND.DISTOR_TYPE.EQ.2) THEN CALL LDM_GET_TOFF (IPACK, IPLATE, VALUE, IFLAG, ND, + IERR, ERRSTR) WRITE (VALSTR,'(F8.1)') VALUE CALL LJUST(VALSTR) CALL XDLF_PARAM_TABLE_SETVALUE (IVH_PAR2, IP_TOFF, + XDLSTR(VALSTR), MAX_P2SCROLL_CHARS, 0, IERR) END IF IF (IPLIST(IP_SPDXY).AND.DISTOR_TYPE.EQ.3) THEN CALL LDM_GET_SPDXY (IPACK, IPLATE, VALUE, IFLAG, ND, + IERR, ERRSTR) WRITE (VALSTR,'(F8.4)') VALUE CALL LJUST(VALSTR) CALL XDLF_PARAM_TABLE_SETVALUE (IVH_PAR2, IP_SPDXY, + XDLSTR(VALSTR), MAX_P2SCROLL_CHARS, 0, IERR) END IF IF (IPLIST(IP_SPDX).AND.DISTOR_TYPE.EQ.3) THEN CALL LDM_GET_SPDXN (IPACK, IPLATE, IVAL, IFLAG, + IERR, ERRSTR) WRITE (VALSTR,'(I8)') IVAL CALL LJUST(VALSTR) CALL XDLF_PARAM_TABLE_SETVALUE (IVH_PAR2, IP_SPDX, + XDLSTR(VALSTR), MAX_P2SCROLL_CHARS, 0, IERR) END IF IF (IPLIST(IP_SPDY).AND.DISTOR_TYPE.EQ.3) THEN CALL LDM_GET_SPDYN (IPACK, IPLATE, IVAL, IFLAG, + IERR, ERRSTR) WRITE (VALSTR,'(I8)') IVAL CALL LJUST(VALSTR) CALL XDLF_PARAM_TABLE_SETVALUE (IVH_PAR2, IP_SPDY, + XDLSTR(VALSTR), MAX_P2SCROLL_CHARS, 0, IERR) END IF IF (IPLIST(IP_STRK_L)) THEN CALL LDM_GET_SPOTL (IPACK, IPLATE, VALUE, IFLAG, ND, + IERR, ERRSTR) WRITE (VALSTR,'(F8.2)') VALUE CALL LJUST(VALSTR) CALL XDLF_PARAM_TABLE_SETVALUE (IVH_PAR2, IP_STRK_L, + XDLSTR(VALSTR), MAX_P2SCROLL_CHARS, 0, IERR) END IF IF (IPLIST(IP_STRK_W)) THEN CALL LDM_GET_SPOTW (IPACK, IPLATE, VALUE, IFLAG, ND, + IERR, ERRSTR) WRITE (VALSTR,'(F8.2)') VALUE CALL LJUST(VALSTR) CALL XDLF_PARAM_TABLE_SETVALUE (IVH_PAR2, IP_STRK_W, + XDLSTR(VALSTR), MAX_P2SCROLL_CHARS, 0, IERR) END IF IF (IPLIST(IP_STRK_F)) THEN CALL LDM_GET_SPOTF (IPACK, IPLATE, VALUE, IFLAG, ND, + IERR, ERRSTR) WRITE (VALSTR,'(F8.2)') VALUE CALL LJUST(VALSTR) CALL XDLF_PARAM_TABLE_SETVALUE (IVH_PAR2, IP_STRK_F, + XDLSTR(VALSTR), MAX_P2SCROLL_CHARS, 0, IERR) END IF IF (IPLIST(IP_STRK_BW)) THEN CALL LDM_GET_SPOTB (IPACK, IPLATE, VALUE, IFLAG, ND, + IERR, ERRSTR) WRITE (VALSTR,'(F8.1)') VALUE CALL LJUST(VALSTR) CALL XDLF_PARAM_TABLE_SETVALUE (IVH_PAR2, IP_STRK_BW, + XDLSTR(VALSTR), MAX_P2SCROLL_CHARS, 0, IERR) END IF IF (IPLIST(IP_DELTA)) THEN CALL LDM_GET_SPOTD (IPACK, IPLATE, VALUE, IFLAG, ND, + IERR, ERRSTR) WRITE (VALSTR,'(F8.2)') VALUE CALL LJUST(VALSTR) CALL XDLF_PARAM_TABLE_SETVALUE (IVH_PAR2, IP_DELTA, + XDLSTR(VALSTR), MAX_P2SCROLL_CHARS, 0, IERR) END IF IF (IPLIST(IP_RFL)) THEN CALL LDM_GET_RFL (IPACK, IPLATE, IVAL, IFLAG, + IERR, ERRSTR) WRITE (VALSTR,'(I8)') IVAL CALL LJUST(VALSTR) CALL XDLF_PARAM_TABLE_SETVALUE (IVH_PAR2, IP_RFL, + XDLSTR(VALSTR), MAX_P2SCROLL_CHARS, 0, IERR) END IF RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** SET_PROMIN ** C************************** C C SUBROUTINE SET_PROMIN C INCLUDE 'implicit_none.finc' C C Purpose: Set PROMIN parameter value if currently the default 0.0 C C Author: John W. Campbell, January 1996 C C Arguments: C C None C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR C C====== LOCALS: C LOGICAL PROF_ROT INTEGER IVAL INTEGER IFLAG INTEGER ITYP INTEGER IERR INTEGER ND INTEGER NPROF REAL PROMIN CHARACTER*20 STR CHARACTER*80 ERRSTR C LOGICAL PROF_ROT !Rotate profiles flag C INTEGER IVAL !Integer parameter value C INTEGER IFLAG !Parameter status flag C INTEGER ITYP !Parameter type flag C INTEGER IERR !Error flag C INTEGER ND !No. of decimal places flag C INTEGER NPROF !No. of profile bins C REAL PROMIN !Value of PROMIN parameter C CHARACTER*20 STR !Temp string C CHARACTER*80 ERRSTR !Error string C C------------------------------------------------------------------------------- C CALL LDM_GET ('PROMIN', 1, 1, STR, + PROMIN, ND, IVAL, IFLAG, ITYP, IERR, ERRSTR) IF (PROMIN.EQ.0.0) THEN CALL LFN_SAINT_DF (NPROF, PROMIN, PROF_ROT) WRITE (STR,'(F8.1)') PROMIN CALL LJUST(STR) CALL LDM_SET ('PROMIN', 1, 1, STR, IERR, ERRSTR) END IF RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** SET_SCALINT ** C************************** C C SUBROUTINE SET_SCALINT C INCLUDE 'implicit_none.finc' C C Purpose: Set SCALE_INT parameter value if currently the default 0.0 C C Author: John W. Campbell, January 1996 C C Arguments: C C None C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR C C====== LOCALS: C INTEGER IVAL INTEGER IFLAG INTEGER ITYP INTEGER IERR INTEGER ND INTEGER IMTYP REAL SCAL_INT CHARACTER*20 STR CHARACTER*80 ERRSTR C INTEGER IVAL !Integer parameter value C INTEGER IFLAG !Parameter status flag C INTEGER ITYP !Parameter type flag C INTEGER IERR !Error flag C INTEGER ND !No. of decimal places flag C INTEGER IMTYP !Image type flag C REAL SCAL_INT !SCALE_INT value C CHARACTER*20 STR !Temp string C CHARACTER*80 ERRSTR !Error string C C------------------------------------------------------------------------------- C CALL LDM_GET ('SCALE_INT', 1, 1, STR, + SCAL_INT, ND, IVAL, IFLAG, ITYP, IERR, ERRSTR) IF (SCAL_INT.EQ.0.0) THEN CALL LDM_GET_IMTYP (STR, IMTYP, IFLAG) IF (IMTYP.EQ.1) THEN SCAL_INT = 1.0 ELSE SCAL_INT = 0.1 END IF WRITE (STR,'(F8.1)') SCAL_INT CALL LJUST(STR) CALL LDM_SET ('SCALE_INT', 1, 1, STR, IERR, ERRSTR) END IF RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** SET_UPD_FLAGS ** C************************** C C SUBROUTINE SET_UPD_FLAGS(IUPD) C INCLUDE 'implicit_none.finc' C C Purpose: Set flags for automatic update of parameter values for other C packs/plates C C Author: John W. Campbell, June 1994 C C Arguments: C INTEGER IUPD C C IUPD (R) Flag from LAUEGEN_UPD environment variable if set (otherwise C -1) C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' C C====== GLOBALS: C INCLUDE 'file_units.finc' INCLUDE 'upd_flags.finc' C C====== FUNCTION TYPES: C C C====== LOCALS: C INTEGER I C C------------------------------------------------------------------------------- C IF (IUPD.LT.0) THEN UPD_LAMS = .TRUE. UPD_DMIN = .TRUE. UPD_PHIS = .TRUE. UPD_CTOF = .TRUE. UPD_CENT = .TRUE. UPD_XCYC = .TRUE. UPD_WC = .FALSE. UPD_YSCAL = .TRUE. UPD_TT = .TRUE. UPD_BULG = .FALSE. UPD_RTOFF = .TRUE. UPD_SPD = .TRUE. UPD_SPOT = .TRUE. ELSE I = IUPD UPD_LAMS = .FALSE. IF (MOD(I,2).NE.0) UPD_LAMS = .TRUE. I = I/2 UPD_DMIN = .FALSE. IF (MOD(I,2).NE.0) UPD_DMIN = .TRUE. I = I/2 UPD_PHIS = .FALSE. IF (MOD(I,2).NE.0) UPD_PHIS = .TRUE. I = I/2 UPD_CTOF = .FALSE. IF (MOD(I,2).NE.0) UPD_CTOF = .TRUE. I = I/2 UPD_CENT = .FALSE. IF (MOD(I,2).NE.0) UPD_CENT = .TRUE. I = I/2 UPD_XCYC = .FALSE. IF (MOD(I,2).NE.0) UPD_XCYC = .TRUE. I = I/2 UPD_WC = .FALSE. IF (MOD(I,2).NE.0) UPD_WC = .TRUE. I = I/2 UPD_YSCAL = .FALSE. IF (MOD(I,2).NE.0) UPD_YSCAL = .TRUE. I = I/2 UPD_TT = .FALSE. IF (MOD(I,2).NE.0) UPD_TT = .TRUE. I = I/2 UPD_BULG = .FALSE. IF (MOD(I,2).NE.0) UPD_BULG = .TRUE. I = I/2 UPD_RTOFF = .FALSE. IF (MOD(I,2).NE.0) UPD_RTOFF = .TRUE. I = I/2 UPD_SPD = .FALSE. IF (MOD(I,2).NE.0) UPD_SPD = .TRUE. I = I/2 UPD_SPOT = .FALSE. IF (MOD(I,2).NE.0) UPD_SPOT = .TRUE. ENDIF IF (IUN_LOG.LE.0) RETURN IF (IUPD.LE.0) THEN WRITE(IUN_LOG,6000) ELSE WRITE(IUN_LOG,6010) END IF IF (UPD_LAMS) THEN WRITE (IUN_LOG,6020) 'lambda_min, lambda_max' ELSE WRITE (IUN_LOG,6030) 'lambda_min, lambda_max' END IF IF (UPD_DMIN) THEN WRITE (IUN_LOG,6020) 'd_min' ELSE WRITE (IUN_LOG,6030) 'd_min' END IF IF (UPD_PHIS) THEN WRITE (IUN_LOG,6020) 'phix, phiy, phiz' ELSE WRITE (IUN_LOG,6030) 'phix, phiy, phiz' END IF IF (UPD_CTOF) THEN WRITE (IUN_LOG,6020) 'c_to_f' ELSE WRITE (IUN_LOG,6030) 'c_to_f' END IF IF (UPD_CENT) THEN WRITE (IUN_LOG,6020) 'x_cen_f, y_cen_f' ELSE WRITE (IUN_LOG,6030) 'x_cen_f, y_cen_f' END IF IF (UPD_XCYC) THEN WRITE (IUN_LOG,6020) 'x_c, y_c' ELSE WRITE (IUN_LOG,6030) 'x_c, y_c' END IF IF (UPD_WC) THEN WRITE (IUN_LOG,6020) 'w_c' ELSE WRITE (IUN_LOG,6030) 'w_c' END IF IF (UPD_YSCAL) THEN WRITE (IUN_LOG,6020) 'y_scale' ELSE WRITE (IUN_LOG,6030) 'y_scale' END IF IF (UPD_TT) THEN WRITE (IUN_LOG,6020) 'tilt, twist' ELSE WRITE (IUN_LOG,6030) 'tilt, twist' END IF IF (UPD_BULG) THEN WRITE (IUN_LOG,6020) 'bulge' ELSE WRITE (IUN_LOG,6030) 'bulge' END IF IF (UPD_RTOFF) THEN WRITE (IUN_LOG,6020) 'roff, toff' ELSE WRITE (IUN_LOG,6030) 'roff, toff' END IF IF (UPD_SPD) THEN WRITE (IUN_LOG,6020) + 'spd... (polynomial spatial distortion)' ELSE WRITE (IUN_LOG,6030) + 'spd... (polynomial spatial distortion)' END IF IF (UPD_SPOT) THEN WRITE (IUN_LOG,6020) 'spot sizes' ELSE WRITE (IUN_LOG,6030) 'spot sizes' END IF WRITE(IUN_LOG,6040) RETURN C C Format Statements C------------------ C 6000 FORMAT (//,'Automatic parameter update flags (default)',/) 6010 FORMAT (//, + 'Automatic parameter update flags (set using LAUEGEN_UPD)',/) 6020 FORMAT ('Yes: ',A) 6030 FORMAT ('No: ',A) 6040 FORMAT (' ') END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C********************* C** SFPIX ** C********************* C C SUBROUTINE SFPIX (IXPIX, IYPIX, ISPIX, IFPIX) C INCLUDE 'implicit_none.finc' C C Purpose: Convert x,y pixel position to slow, fast axis pixel position C C Author: John W. Campbell, October 1993 C C Arguments: C INTEGER IXPIX INTEGER IYPIX INTEGER ISPIX INTEGER IFPIX C C IXPIX (R) Pixel position wrt x axis C IYPIX (R) Pixel position wrt y axis C ISPIX (W) Pixel position wrt slow axis in stored image C IFPIX (W) Pixel position wrt fast axis in stored image C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' C C====== FUNCTION TYPES: C C C====== LOCALS: C INTEGER IORD INTEGER ISWAP INTEGER NXRAST INTEGER NYRAST INTEGER IFLAG CHARACTER*2 VALSTR C INTEGER IORD !Axis order in stored image 1-8 C INTEGER ISWAP !Byte swap flag C INTEGER NXRAST !No. x-rasters C INTEGER NYRAST !No. y-rasters C INTEGER IFLAG !Parameter status flag C CHARACTER*2 VALSTR !Parameter value string (dummy) C C------------------------------------------------------------------------------- C CALL LDM_GET_AXORD (VALSTR, IORD, ISWAP, IFLAG) CALL LDM_GET_NXRAS (NXRAST, IFLAG) CALL LDM_GET_NYRAS (NYRAST, IFLAG) IF (IORD.EQ.1) THEN ISPIX = IXPIX IFPIX = IYPIX ELSE IF (IORD.EQ.2) THEN ISPIX = IXPIX IFPIX = NYRAST - IYPIX + 1 ELSE IF (IORD.EQ.3) THEN ISPIX = NXRAST - IXPIX + 1 IFPIX = IYPIX ELSE IF (IORD.EQ.4) THEN ISPIX = NXRAST - IXPIX + 1 IFPIX = NYRAST - IYPIX + 1 ELSE IF (IORD.EQ.5) THEN ISPIX = IYPIX IFPIX = IXPIX ELSE IF (IORD.EQ.6) THEN ISPIX = IYPIX IFPIX = NXRAST - IXPIX + 1 ELSE IF (IORD.EQ.7) THEN ISPIX = NYRAST - IYPIX + 1 IFPIX = IXPIX ELSE IF (IORD.EQ.8) THEN ISPIX = NYRAST - IYPIX + 1 IFPIX = NXRAST - IXPIX + 1 ELSE ISPIX = 0 IFPIX = 0 END IF RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** SHOW_IMAGE ** C************************** C C SUBROUTINE SHOW_IMAGE (IPOSN, IERR) C INCLUDE 'implicit_none.finc' C C Purpose: Show film/image-plate image (check opening of file & read C image if needed) C C Author: John W. Campbell, March 1992 C C Arguments: C INTEGER IPOSN INTEGER IERR C C IPOSN (R) Position of image C =1 Position at top left of parameter table 1 C =2 Top left of autoindexing solutions text table C IERR (W) Error flag =0 OK, =1 error C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'prog_flags.finc' INCLUDE 'file_units.finc' INCLUDE 'image.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR C C====== LOCALS: C INTEGER KERR INTEGER IDUMMY(2) INTEGER KXROOT INTEGER KYROOT INTEGER IFLAG INTEGER NXRAST INTEGER NYRAST INTEGER NF_OFF INTEGER IORD INTEGER ISWAP REAL X_CEN_F REAL Y_CEN_F REAL W_F CHARACTER*2 VALSTR CHARACTER*2 ERRSTR C INTEGER KERR !Error flag C INTEGER IDUMMY(2) !Dummy array for film display routine C INTEGER KXROOT !Root window x position for image display C INTEGER KYROOT !Root window y position for image display C INTEGER IFLAG !Parameter status flag C INTEGER NXRAST !No. of x-rasters C INTEGER NYRAST !No. of y-rasters C INTEGER NF_OFF !Offset between start of slow rasters in image C INTEGER IORD !Axis order flag C INTEGER ISWAP !Byte swap flag C REAL X_CEN_F !X centre C REAL Y_CEN_F !Y centre C REAL W_F !Omega C CHARACTER*2 VALSTR !Value string (dummy) C CHARACTER*2 ERRSTR !Error string (dummy) C C------------------------------------------------------------------------------- C C C====== Open film/image-plate file C CALL CHK_OPN(IERR) IF (IERR.GT.0) THEN IERR = 1 RETURN END IF IERR = 0 C C====== Read image if not already read C IF (.NOT.FILM_READ) CALL READ_IMAGE (0, IMG, MAX_IMG_WORDS, + ITYPE, NF_OFF, IERR, ERRSTR) IF (.NOT.FILM_READ) THEN IERR = 1 RETURN END IF CALL FILM_CENTRE (X_CEN_F, Y_CEN_F, W_F) C C====== Display film/image-plate image C KXROOT = 0 KYROOT = 0 IF (IPOSN.EQ.1) THEN CALL XDLF_VIEW_OBJECT_ROOTXY(IVH_PAR1,0,0,KXROOT,KYROOT,KERR) KYROOT = KYROOT - 30 IF (KYROOT.LT.0) KYROOT = 0 ELSE IF (IPOSN.EQ.2) THEN CALL XDLF_VIEW_OBJECT_ROOTXY(IVH_TABL_AUT,0,0,KXROOT,KYROOT, + KERR) KYROOT = KYROOT - 30 IF (KYROOT.LT.0) KYROOT = 0 END IF CALL LDM_GET_NXRAS (NXRAST, IFLAG) CALL LDM_GET_NYRAS (NYRAST, IFLAG) CALL LDM_GET_AXORD (VALSTR, IORD, ISWAP, IFLAG) CALL XDLF_IMAGE (IVH_FILM,0,KXROOT,KYROOT,1,IMG,ITYPE, + NSRASTS,NFRASTS,NFRASTS, + 1,1,NXRAST,NYRAST,-NCMP,IORD,2, + MINVAL,MAXVAL,MINTHR,MAXTHR,0,0, + 1,1,ICONTRAST,1,IERR) CALL XDLF_IMAGE_AXNAMES (IVH_FILM,XDLSTR('xf'),2,XDLSTR('yf'),2, + IERR) CALL XDLF_IMAGE_BACKGROUND(IVH_FILM,IMG_BG,NCMP, + NF_BGOFF,KERR) RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** SHOW_INTSTATS ** C************************** C C SUBROUTINE SHOW_INTSTATS C INCLUDE 'implicit_none.finc' C C Purpose: Show intensity statistics C C Author: John W. Campbell, January 1996 C C Arguments: C C None C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' INCLUDE 'screen_params.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'film_pack.finc' INCLUDE 'lirl_pars.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR INTEGER LENSTR C C====== LOCALS: C INTEGER I INTEGER IVH INTEGER IVHLIST(2) INTEGER IXROOT INTEGER IYROOT INTEGER IERR INTEGER NCOLS INTEGER NROWS INTEGER ICOL INTEGER LL INTEGER IBOLD INTEGER NS(5) INTEGER NG(5) INTEGER NO(5) INTEGER NN(5) INTEGER NB(5) INTEGER N3(5) INTEGER N10(5) REAL AIM(5) REAL AIS(5) CHARACTER*20 NAMES(2) CHARACTER*80 STR C INTEGER I !Temp/loop variable C INTEGER IVH !View-object handle returned from XDLF_GET_EVENTS C INTEGER IVHLIST(2) !List of view-object handles for getting events C INTEGER IXROOT !Root 'x' position for profiles text table C INTEGER IYROOT !Root 'y' position for profiles text table C INTEGER IERR !Error flag C INTEGER NCOLS !No. of columns for text table C INTEGER NROWS !No. of rows for text table C INTEGER ICOL !Column no. for start of text output C INTEGER LL !Length of character string C INTEGER IBOLD !Bold/colour flag C INTEGER NS(5) !No. of spots present for the 5 spot categories C INTEGER NG(5) !No. of spots integrated & good for the 5 spot categories C INTEGER NO(5) !No. of overload spots flagged for the 5 spot categories C INTEGER NN(5) !No. of OK negative intensities for the 5 spot categories C INTEGER NB(5) !No. of bad spots spots flagged for the 5 spot categories C INTEGER N3(5) !No. OK spots with I>3*sig(I) for the 5 spot categories C INTEGER N10(5) !No. OK spots wit I>10*sig(I) for the 5 spot categories C REAL AIM(5) !Mean I value for the 5 spot categories (for OK positive C intensities only) C REAL AIS(5) !Mean I/sig(I) values for the 5 spot categories (for C OK positive intensities only) C CHARACTER*20 NAMES(2) !Item names for menu C CHARACTER*80 STR !Output string DATA NAMES/'Continue',' '/ C C------------------------------------------------------------------------------- C C====== Get statistics C CALL LFN_INT_STATS1 (KDX_LIRL, IPACK, IPLATE, NS, NG, NO, NN, + NB, AIM, AIS, N3, N10, IERR) IF (IERR.NE.0) THEN CALL ERR_NOTICE (1,'**No intensities data found**') RETURN END IF C C====== Create text table and output results C NCOLS = 82 NROWS = 16 CALL XDLF_VIEW_OBJECT_ROOTXY (IVH_PAR1,0,0,IXROOT,IYROOT,IERR) CALL XDLF_TEXT_TABLE (IVH_PROF_TAB, 0, IXROOT, IYROOT, 0, NCOLS, + NROWS, 0, 0, IFONT, IERR) STR = 'Integration statistics for pack' CALL STR_ADDI (STR, IPACK, 1) CALL STR_ADDS (STR, ', plate', 0) CALL STR_ADDI (STR, IPLATE, 1) LL = LENSTR (STR) ICOL = (82-LL)/2+1 CALL XDLF_TEXT_TABLE_TEXT (IVH_PROF_TAB, XDLSTR(STR), LL, + 1, ICOL, 11, IERR) STR = 'Spot type' LL = LENSTR (STR) CALL XDLF_TEXT_TABLE_TEXT (IVH_PROF_TAB, XDLSTR(STR), LL, + 4, 2, 11, IERR) STR= ' Total Good Ovld. Neg. Bad' CALL STR_ADDS (STR, ' Mean Mean Number Number', 0) LL = LENSTR (STR) CALL XDLF_TEXT_TABLE_TEXT (IVH_PROF_TAB, XDLSTR(STR), LL, + 4, 17, 1, IERR) STR = ' Spots Spots Spots Spots Spots' CALL STR_ADDS (STR, ' I I/sigI >3sigI >10sigI', 0) LL = LENSTR (STR) CALL XDLF_TEXT_TABLE_TEXT (IVH_PROF_TAB, XDLSTR(STR), LL, + 5, 17, 1, IERR) STR = 'All spots' LL = LENSTR (STR) IBOLD = 1 CALL XDLF_TEXT_TABLE_TEXT (IVH_PROF_TAB, XDLSTR(STR), LL, + 7, 1, IBOLD, IERR) STR = 'Singles' LL = LENSTR (STR) IBOLD = 3 CALL XDLF_TEXT_TABLE_TEXT (IVH_PROF_TAB, XDLSTR(STR), LL, + 8, 1, IBOLD, IERR) STR = '(sep)' LL = LENSTR (STR) IBOLD = 0 CALL XDLF_TEXT_TABLE_TEXT (IVH_PROF_TAB, XDLSTR(STR), LL, + 8, 9, IBOLD, IERR) STR = 'Multiples' LL = LENSTR (STR) IBOLD = 3 CALL XDLF_TEXT_TABLE_TEXT (IVH_PROF_TAB, XDLSTR(STR), LL, + 9, 1, IBOLD, IERR) STR = '(sep)' LL = LENSTR (STR) IBOLD = 0 CALL XDLF_TEXT_TABLE_TEXT (IVH_PROF_TAB, XDLSTR(STR), LL, + 9, 11, IBOLD, IERR) STR = 'SpOv. Singles' LL = LENSTR (STR) IBOLD = 1 CALL XDLF_TEXT_TABLE_TEXT (IVH_PROF_TAB, XDLSTR(STR), LL, + 10, 1, IBOLD, IERR) STR = 'SpOv. Multiples' LL = LENSTR (STR) IBOLD = 1 CALL XDLF_TEXT_TABLE_TEXT (IVH_PROF_TAB, XDLSTR(STR), LL, + 11, 1, IBOLD, IERR) DO 10 I = 1, 5 WRITE (STR,'(I7)') NS(I) LL = LENSTR (STR) IBOLD = 0 CALL XDLF_TEXT_TABLE_TEXT (IVH_PROF_TAB, XDLSTR(STR), LL, + 6+I, 17, IBOLD, IERR) WRITE (STR,'(I7)') NG(I) LL = LENSTR (STR) IF (I.EQ.2.OR.I.EQ.3) IBOLD = 3 CALL XDLF_TEXT_TABLE_TEXT (IVH_PROF_TAB, XDLSTR(STR), LL, + 6+I, 24, IBOLD, IERR) IBOLD = 0 WRITE (STR,'(3I6,F9.1)') NO(I), NN(I), NB(I), AIM(I) LL = LENSTR (STR) CALL XDLF_TEXT_TABLE_TEXT (IVH_PROF_TAB, XDLSTR(STR), LL, + 6+I, 31, IBOLD, IERR) IF (I.EQ.2.OR.I.EQ.3) IBOLD = 3 WRITE (STR,'(F7.1)') AIS(I) LL = LENSTR (STR) CALL XDLF_TEXT_TABLE_TEXT (IVH_PROF_TAB, XDLSTR(STR), LL, + 6+I, 58, IBOLD, IERR) IBOLD = 0 WRITE (STR,'(I8,I8)') N3(I), N10(I) LL = LENSTR (STR) CALL XDLF_TEXT_TABLE_TEXT (IVH_PROF_TAB, XDLSTR(STR), LL, + 6+I, 65, IBOLD, IERR) 10 CONTINUE STR = 'Key:' IBOLD = 10 LL = LENSTR (STR) CALL XDLF_TEXT_TABLE_TEXT (IVH_PROF_TAB, XDLSTR(STR), LL, + 13, 1, IBOLD, IERR) STR = 'Good = Good spot, measured and not bad/overload' IBOLD = 0 LL = LENSTR (STR) CALL XDLF_TEXT_TABLE_TEXT (IVH_PROF_TAB, XDLSTR(STR), LL, + 13, 6, IBOLD, IERR) STR = ' (sep) = Spatially separated' IBOLD = 0 LL = LENSTR (STR) CALL XDLF_TEXT_TABLE_TEXT (IVH_PROF_TAB, XDLSTR(STR), LL, + 14, 1, IBOLD, IERR) STR = ' Ovld. = Intensity overload' IBOLD = 0 LL = LENSTR (STR) CALL XDLF_TEXT_TABLE_TEXT (IVH_PROF_TAB, XDLSTR(STR), LL, + 15, 1, IBOLD, IERR) STR = ' SpOv. = Spatially overlapped' IBOLD = 0 LL = LENSTR (STR) CALL XDLF_TEXT_TABLE_TEXT (IVH_PROF_TAB, XDLSTR(STR), LL, + 16, 1, IBOLD, IERR) C C===== Get continue command from menu C CALL XDLF_MENU_AREA_SETMENU (IVH_MENU, 1, XDLSTR(NAMES), 20, + XDLSTR(' '), -1, XDLSTR(' '), -1, 0, IERR) IVHLIST(1) = IVH_MENU CALL XDLF_GET_EVENTS(1, IVHLIST, IVH) CALL XDLF_DELETE_VIEW_OBJECT(IVH_PROF_TAB, IERR) RETURN END CC LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** SHOW_PREDICT ** C************************** C C SUBROUTINE SHOW_PREDICT (ITYP) C INCLUDE 'implicit_none.finc' C C Purpose: Show predicted pattern on image C C Author: John W. Campbell, March 1992 C C Note: Assumes that image is already displayed C C Arguments: C INTEGER ITYP C C ITYP (R) Flag = 1 Using main menu area / base frame C = 2 Using autoindexing solutions menu area / base frame C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR C C====== LOCALS: C INTEGER KTYP INTEGER IERR INTEGER IVH_MENU_USE INTEGER IDISP INTEGER M_ALL INTEGER M_NODALS INTEGER NVIEW INTEGER IVHLIST(2) INTEGER IVH INTEGER ITEM INTEGER IQUIT INTEGER NUMSPOTS CHARACTER*25 NAMES(2) CHARACTER*25 QUITNAM C INTEGER KTYP !Flag for notices positioning C INTEGER IERR !Error flag C INTEGER IVH_MENU_USE !View-object handle of menu area to be used C INTEGER IDISP !=0 display all reflections, =1 display nodals C INTEGER M_ALL !Menu item number for display all reflections C INTEGER M_NODALS !Menu item number for display nodals C INTEGER NVIEW !Number of view-objects for getting events C INTEGER IVHLIST(2) !List of view-object handles for getting events C INTEGER IVH !Returned view-object handle from getting events C INTEGER ITEM !Item number selected on menu C INTEGER IQUIT !Quit flag from menu C INTEGER NUMSPOTS !No. of predicted spots C CHARACTER*25 NAMES(2) !Menu item strings C CHARACTER*25 QUITNAM !Quit box string DATA NAMES /'Display All Predicted', + 'Display Nodals Only'/ DATA QUITNAM /'Return to Previous Menu'/ C C------------------------------------------------------------------------------- C C C====== Initialisations C KTYP = 1 IVH_MENU_USE = IVH_MENU IF (ITYP.EQ.2) THEN KTYP = 2 IVH_MENU_USE = IVH_MENU_AUT END IF C C====== Predict reflections if not already done C CALL CALC_LAUE (.TRUE.) C C====== Determine whether to display all reflns or nodals at start C CALL LRL_NUMSPOTS(NUMSPOTS) IDISP = 0 IF (NUMSPOTS.GT.MAX_DISP) THEN CALL FIND_SEL_NODS (ITYP, 1, 1, 1, 0, 0, 0) IDISP = 1 END IF C C====== Display predicted positions C CALL PLOT_SYMBS (IDISP, 3) C C====== Set up Selection Options Menu C M_ALL = 1 M_NODALS = 2 CALL XDLF_MENU_AREA_SETMENU (IVH_MENU_USE, 2, + XDLSTR(NAMES), 25, + XDLSTR('Prediction Menu'), 15, XDLSTR(QUITNAM), 25, 0, IERR) C C====== Service Menu C NVIEW = 1 IVHLIST(1) = IVH_MENU_USE 100 CALL XDLF_GET_EVENTS(NVIEW,IVHLIST,IVH) IF (IVH.EQ.IVH_MENU_USE) THEN CALL XDLF_MENU_AREA_GETITEM(IVH_MENU_USE,ITEM,IQUIT) C C====== Quit selected C IF (IQUIT.EQ.1) THEN CALL XDLF_IMAGE_CLEAR_SYMBOLS (IVH_FILM,IERR) RETURN END IF C C====== Display all predicted reflections C IF (ITEM.EQ.M_ALL) THEN IF (NUMSPOTS.GT.MAX_DISP) THEN CALL ERR_NOTICE (KTYP, + '**Too many spots to display**') GO TO 100 END IF IDISP = 0 CALL XDLF_IMAGE_CLEAR_SYMBOLS (IVH_FILM,IERR) CALL PLOT_SYMBS (IDISP, 3) GO TO 100 C C====== Display nodals only C ELSE IF (ITEM.EQ.M_NODALS) THEN CALL FIND_SEL_NODS (ITYP, 1, 1, 1, 0, 0, 0) IDISP = 1 CALL XDLF_IMAGE_CLEAR_SYMBOLS (IVH_FILM,IERR) CALL PLOT_SYMBS (IDISP, 3) GO TO 100 END IF END IF GO TO 100 END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** SHOW_PROFILES ** C************************** C C SUBROUTINE SHOW_PROFILES C INCLUDE 'implicit_none.finc' C C Purpose: Show current integration profiles C C Author: John W. Campbell, January 1996 C C Arguments: C C None C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' INCLUDE 'screen_params.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR INTEGER LENSTR C C====== LOCALS: C LOGICAL DRAW_PROF LOGICAL PROF_ROT INTEGER M_FIRST INTEGER M_NEXT INTEGER M_PREV INTEGER NVIEW INTEGER IVHLIST(2) INTEGER IVH INTEGER ITEM INTEGER IQUIT INTEGER IERR INTEGER IPK INTEGER IPL INTEGER IPROF_CUR INTEGER NPHALF INTEGER NUMPIX INTEGER NPROFS INTEGER NCOLS INTEGER NROWS INTEGER LL INTEGER I INTEGER IX INTEGER IY INTEGER KCX INTEGER KCY INTEGER IXROOT INTEGER IYROOT INTEGER ICOL INTEGER IROW INTEGER IMASK INTEGER IBOLD INTEGER INUM REAL PROFMAX REAL PRF REAL SC_PRF REAL ANG CHARACTER*25 NAMES(3) CHARACTER*25 QUITNAM CHARACTER*1 NUMCH(16) CHARACTER*25 STR CHARACTER*1 CH C LOGICAL DRAW_PROF !Profile drawing required C LOGICAL PROF_ROT !Rotate profiles flag C INTEGER M_FIRST !Menu item no.: Show first profile C INTEGER M_NEXT !Menu item no.: Show next profile C INTEGER M_PREV !Menu item no.: Show previous profile C INTEGER NVIEW !No. of view-objects for getting events C INTEGER IVHLIST(2) !List of view-object handles for getting events C INTEGER IVH !Returned view-object handle from getting events C INTEGER ITEM !Item no. from menu selection C INTEGER IQUIT !Quit button flage from menu C INTEGER IERR !Error flag C INTEGER IPK !Pack no. from latest profile calculated C INTEGER IPL !Plate no. from latest profile calculated C INTEGER IPROF_CUR !No. of current profile C INTEGER NPHALF !Half width of profile boxes C INTEGER NUMPIX !No. of pixels in profile C INTEGER NPROFS !No. of profile bins C INTEGER NCOLS !No. of columns for profiles text table C INTEGER NROWS !No. of rows for profiles text table C INTEGER LL !Length of character string C INTEGER I !Temp/loop variable C INTEGER IX !Loop counter through 'x' pixels of profile box C INTEGER IY !Loop counter through 'y' pixels of profile box C INTEGER KCX !Centre 'x' character posn in profiles text table C INTEGER KCY !Centre 'y' character posn in profiles text table C INTEGER IXROOT !Root 'x' position for profiles text table C INTEGER IYROOT !Root 'y' position for profiles text table C INTEGER ICOL !Column no. for character in profiles text table C INTEGER IROW !Row no. for character in profiles text table C INTEGER IMASK !Mask value for profile pixel C INTEGER IBOLD !Bold print & colour flag C INTEGER INUM !Character number in table (0-15) C REAL PROFMAX !Maximum picel value in profile C REAL PRF !Profile value of a requested pixel in the profile C REAL SC_PRF !Scale factor for profile C REAL ANG !Angle at start or end of profile bin C CHARACTER*25 NAMES(3) !Menu item names C CHARACTER*25 QUITNAM !Quit button string C CHARACTER*1 NUMCH(16) !Character table for profile print C CHARACTER*25 STR !Temp string C CHARACTER*1 CH !Character for profile pixel o/p DATA NAMES /'Show First Profile', + 'Show Next Profile', + 'Show Previous Profile'/ DATA QUITNAM /'Return to Previous Menu'/ DATA NUMCH/'0','1','2','3','4','5','6','7','8','9', + 'A','B','C','D','E','F'/ C C------------------------------------------------------------------------------- C C C====== Get details of profiles C CALL LFN_GET_PROFPARS (IPK, IPL, NPHALF, NUMPIX, NPROFS, + PROF_ROT) C C====== Set up Profile display window C IPROF_CUR = 1 NCOLS = 4*NPHALF + 3 IF (NCOLS.LT.31) THEN NCOLS = 31 END IF NROWS =2*NPHALF + 5 CALL XDLF_VIEW_OBJECT_ROOTXY (IVH_PAR1,0,0,IXROOT,IYROOT,IERR) CALL XDLF_TEXT_TABLE (IVH_PROF_TAB, 0, IXROOT, IYROOT, 0, NCOLS, + NROWS, 0, 0, IFONT, IERR) DRAW_PROF = .TRUE. STR = 'Pack' CALL STR_ADDI (STR, IPK, 1) CALL STR_ADDS (STR, ', Plate', 0) CALL STR_ADDI (STR, IPL, 1) LL = LENSTR(STR) I = (NCOLS-LL)/2 + 1 CALL XDLF_TEXT_TABLE_TEXT (IVH_PROF_TAB, XDLSTR(STR), LL, + NROWS, I, 10, IERR) KCX = (NCOLS+1)/2 KCY = (NROWS+1)/2 C C====== Set up list of view-object handles C NVIEW = 1 IVHLIST(1) = IVH_MENU C C====== Set up & process menu C M_FIRST = 1 M_NEXT = 2 M_PREV = 3 50 CALL XDLF_MENU_AREA_SETMENU (IVH_MENU, 3, XDLSTR(NAMES), 25, + XDLSTR('Show Profiles Menu'), 18, + XDLSTR(QUITNAM), 25, 0, IERR) C C====== Draw requested profile if needed C IF (DRAW_PROF) THEN CALL XDLF_TEXT_TABLE_CLEAR (IVH_PROF_TAB, IERR) STR = 'Profile' CALL STR_ADDI (STR, IPROF_CUR, 1) LL = LENSTR(STR) I = (NCOLS-LL)/2 + 1 CALL XDLF_TEXT_TABLE_TEXT (IVH_PROF_TAB, XDLSTR(STR), LL, + 1, 1, 11, IERR) STR = '(' ANG = (IPROF_CUR-1)*360.0/FLOAT(NPROFS) CALL STR_ADDF (STR, ANG, 1, 0) CALL STR_ADDS (STR, '-', 0) ANG = IPROF_CUR*360.0/FLOAT(NPROFS) CALL STR_ADDF (STR, ANG, 1, 0) CALL STR_ADDS (STR, 'deg)', 0) LL = LENSTR(STR) CALL XDLF_TEXT_TABLE_TEXT (IVH_PROF_TAB, XDLSTR(STR), LL, + 1, NCOLS-LL+1, 10, IERR) STR = 'Pack' CALL STR_ADDI (STR, IPK, 1) CALL STR_ADDS (STR, ', Plate', 0) CALL STR_ADDI (STR, IPL, 1) LL = LENSTR(STR) I = (NCOLS-LL)/2 + 1 CALL XDLF_TEXT_TABLE_TEXT (IVH_PROF_TAB, XDLSTR(STR), LL, + NROWS, I, 10, IERR) CALL LFN_GET_PROFMAX (IPROF_CUR, PROFMAX, IERR) SC_PRF = 1.0 IF (PROFMAX.GT.0.0) SC_PRF = 15.0/PROFMAX DO 70 IY = -NPHALF, NPHALF DO 60 IX = -NPHALF, NPHALF ICOL = KCX + 2*IX IROW = KCY - IY CALL LFN_GET_PROFPIX (IPROF_CUR, IX, IY, IMASK, + PRF, IERR) IF (IERR.EQ.2.OR.IMASK.EQ.-100) THEN IBOLD = 1 CH = '.' ELSE IF (IMASK.EQ.-1) THEN IBOLD = 1 CH = '*' ELSE INUM = NINT (SC_PRF*PRF) IF (INUM.LT.0) INUM = 0 IF (INUM.GT.15) INUM = 15 CH = NUMCH(INUM+1) IF (IMASK.LE.1) THEN IBOLD = 10 ELSE IF (IMASK.GE.10) THEN IBOLD = 3 ELSE GO TO 60 END IF END IF END IF CALL XDLF_TEXT_TABLE_TEXT (IVH_PROF_TAB, XDLSTR(CH), 1, + IROW, ICOL, IBOLD, IERR) 60 CONTINUE 70 CONTINUE DRAW_PROF = .FALSE. END IF C C C====== Start event loop C 100 CALL XDLF_GET_EVENTS (NVIEW, IVHLIST, IVH) IF (IVH.EQ.IVH_MENU) THEN C C====== Menu item selected C CALL XDLF_MENU_AREA_GETITEM (IVH_MENU, ITEM, IQUIT) C C====== Quit selected C IF (IQUIT.EQ.1) THEN CALL XDLF_DELETE_VIEW_OBJECT (IVH_PROF_TAB, IERR) RETURN END IF C C====== Show First Profile C IF (ITEM.EQ.M_FIRST) THEN IF (IPROF_CUR.NE.1) THEN IPROF_CUR = 1 DRAW_PROF = .TRUE. END IF GO TO 50 C C====== Show Next Profile C ELSE IF (ITEM.EQ.M_NEXT) THEN IF (IPROF_CUR.LT.NPROFS) THEN IPROF_CUR = IPROF_CUR + 1 DRAW_PROF = .TRUE. END IF GO TO 50 C C====== Show Previous Profile C ELSE IF (ITEM.EQ.M_PREV) THEN IF (IPROF_CUR.GT.1) THEN IPROF_CUR = IPROF_CUR - 1 DRAW_PROF = .TRUE. END IF GO TO 50 END IF GO TO 100 END IF GO TO 100 END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************ C** SOFT_BINS ** C************************ C C SUBROUTINE SOFT_BINS (IOPT, NBINS, BINW) C INCLUDE 'implicit_none.finc' C C Purpose: Return soft limits determination default bin parameters based C on current soft limit value C C Author: John W. Campbell, November 1994 C C Arguments: C INTEGER IOPT INTEGER NBINS REAL BINW C C IOPT (R) Soft limit type 1=dmin, 2=lmin C NBINS (W) Number of bins C BINW (W) Bin width C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'film_pack.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR C C====== LOCALS: C LOGICAL IDUM_PRF_ROT INTEGER NPR_DUM REAL PRO_DUM REAL FRAC_DUM REAL SIG_DUM REAL FRT_DUM C LOGICAL IDUM_PRF_ROT !Dummy parameter for PROF_ROT C INTEGER NPR_DUM !Dummy parameter for NPROF C REAL PRO_DUM !Dummy parameter for PROMIN C REAL FRAC_DUM !Dummy parameter for FRAC C REAL SIG_DUM !Dummy parameter for SIGTEST C REAL FRT_DUM !Dummy parameter for FRTEST C C------------------------------------------------------------------------------- C CALL LFN_SOFT_DF (IOPT, MAX_SOFT_BINS, NPR_DUM, IDUM_PRF_ROT, + PRO_DUM, FRAC_DUM, + SIG_DUM, FRT_DUM, NBINS, BINW) RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** SOFT_CALC ** C************************** C C SUBROUTINE SOFT_CALC (IOPT, KQUIT) C INCLUDE 'implicit_none.finc' C C Purpose: Improve soft limits calculation routine C C Author: John W. Campbell, March 1994 C C Arguments: C INTEGER IOPT INTEGER KQUIT C C IOPT (R) Flag =1, determine dmin C =2, determine lambda-min C KQUIT (W) Return flag = 0, OK C = 1, Cannot open image file or cannot read C image C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' INCLUDE 'screen_params.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'ip1_entries.finc' INCLUDE 'get_soft.finc' INCLUDE 'film_pack.finc' INCLUDE 'prog_flags.finc' INCLUDE 'image.finc' INCLUDE 'upd_flags.finc' INCLUDE 'file_units.finc' INCLUDE 'integ_pars.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR INTEGER LENSTR EXTERNAL SOFT_INTEG_PROGRESS LOGICAL LFN_DUMMY_CNCL EXTERNAL LFN_DUMMY_CNCL C C====== LOCALS: C LOGICAL GRAPH_DISP LOGICAL ACCEPT INTEGER I INTEGER M_NORM INTEGER M_HIST INTEGER M_SHOW INTEGER M_ACCEPT INTEGER M_INPUT INTEGER NVIEW INTEGER IVHLIST(2) INTEGER IVH INTEGER ITEM INTEGER IQUIT INTEGER IERR INTEGER JERR INTEGER IWARN INTEGER NXRAST INTEGER NYRAST INTEGER NF_OFF INTEGER IXROOT INTEGER IYROOT INTEGER IBUTTON INTEGER IRFL INTEGER IFLAG INTEGER ND INTEGER IORDER INTEGER ISWAP INTEGER IYN INTEGER LISTE(2) INTEGER NUMBINS INTEGER NTOT_MEAS INTEGER NTOT_GTSIG INTEGER NMEAS(MAX_SOFT_BINS) INTEGER NGTSIG(MAX_SOFT_BINS) INTEGER IBIN_SEL INTEGER KPACK INTEGER KPLATE REAL X_CEN_F REAL Y_CEN_F REAL W_F REAL RBIN(MAX_SOFT_BINS) REAL SOFT_MIN REAL SOFT_MAX REAL SOFT_SEL REAL BIN_WIDTH REAL SHOW_VAL REAL VAL REAL CUR_INT_LOW CHARACTER*2 VALSTR CHARACTER*80 ERRSTR CHARACTER*80 WARNSTR CHARACTER*120 STR CHARACTER*25 NAMES(5) CHARACTER*25 QUITNAM C LOGICAL GRAPH_DISP !Graph is currently displayed flag C LOGICAL ACCEPT !Limit has been accepted C INTEGER I !Temp/loop variable C INTEGER M_NORM !Menu item no.: Normalised Histogram C INTEGER M_HIST !Menu item no.: Un-normalised Histogram C INTEGER M_SHOW !Menu item no.: Show image C INTEGER M_ACCEPT !Menu item no.: Accept new limit C INTEGER M_INPUT !Menu item no.: Input another limit C INTEGER NVIEW !No. of view-objects for getting events C INTEGER IVHLIST(2) !List of view-object handles for getting events C INTEGER IVH !Returned view-object handle from getting events C INTEGER ITEM !Item no. from menu selection C INTEGER IQUIT !Quit button flage from menu C INTEGER IERR !Error flag C INTEGER JERR !Error flag C INTEGER IWARN !warning flag C INTEGER NXRAST !No. x-rasters C INTEGER NYRAST !No. y-rasters C INTEGER NF_OFF !Offset between start of slow rasters in image C INTEGER IXROOT !Root window x position for popup notice C INTEGER IYROOT !Root window y position for popup notice C INTEGER IBUTTON !Button from popup notice C INTEGER IRFL !Plate refined flag = 1 yes, = 0 no C INTEGER IFLAG !Parameter status flag C INTEGER ND !No. of decimal places flag C INTEGER IORDER !Axis order flag C INTEGER ISWAP !Byte swap flag C INTEGER IYN !Yes/no flag C INTEGER LISTE(2) !List of parameter table 1 entries to be updated C INTEGER NUMBINS !No. of bins C INTEGER NTOT_MEAS !Total no. of measured spots C INTEGER NTOT_GTSIG !Total no. of significant spots C INTEGER NMEAS(MAX_SOFT_BINS) !No. measured spots in each statisticss bin C INTEGER NGTSIG(MAX_SOFT_BINS) !No. significant spots in each bin C INTEGER IBIN_SEL !Selected soft limit bin no. C INTEGER KPACK !Pack number, 0 = all packs C INTEGER KPLATE !Plate number, 0 = all plates C REAL X_CEN_F !X centre C REAL Y_CEN_F !Y centre C REAL W_F !Omega C REAL RBIN(MAX_SOFT_BINS) !Significant/measured ratios in each bin C REAL SOFT_MIN !Lower end of soft limit range used C REAL SOFT_MAX !Upper end of soft limit range used C REAL SOFT_SEL !Determined soft limit value C REAL BIN_WIDTH !Bin width for soft limits determination C REAL SHOW_VAL !Value of soft limit for predicted pattern on image C REAL VAL !Temporary value C CUR_INT_LOW !Current low limit used in prediction/integration C CHARACTER*2 VALSTR !Parameter value string (dummy) C CHARACTER*80 ERRSTR !Error message string C CHARACTER*80 WARNSTR !Warning message string C CHARACTER*120 STR !Message string C CHARACTER*25 NAMES(5) !Menu item names C CHARACTER*25 QUITNAM !Quit button string DATA NAMES /'Normalised Histogram', + 'Un-normalised Histogram', + 'Show Results on Image', + 'Accept New Soft Limit', + 'Input Another Limit'/ DATA QUITNAM /'Return to Previous Menu'/ C C------------------------------------------------------------------------------- C C====== Initialisations C KQUIT = 0 C C====== Open film/image-plate file if needed C CALL CHK_OPN(IERR) IF (IERR.GT.0) THEN KQUIT = 1 RETURN END IF C C====== Read image if not already read C IF (.NOT.FILM_READ) CALL READ_IMAGE (0, IMG, MAX_IMG_WORDS, + ITYPE, NF_OFF, JERR, ERRSTR) IF (.NOT.FILM_READ) THEN KQUIT = 1 RETURN END IF CALL FILM_CENTRE (X_CEN_F, Y_CEN_F, W_F) C C====== Check that plate has been refined C CALL LDM_GET_RFL(IPACK, IPLATE, IRFL, IFLAG, IERR, ERRSTR) IF (IRFL.EQ.0) THEN CALL NOTICE_POSN(1, IXROOT, IYROOT) CALL XDLF_POPUP_NOTICE (IXROOT, IYROOT, + XDLSTR('**Plate not yet refined**'), 25, + XDLSTR('Continue in spite of this?'), 26, + XDLSTR('Yes'), 3, + XDLSTR('No'), 2, + IFONT, 1, IBUTTON) IF (IBUTTON.EQ.2) RETURN END IF C C====== Get some image related details C CALL LDM_GET_NXRAS (NXRAST, IFLAG) CALL LDM_GET_NYRAS (NYRAST, IFLAG) CALL LDM_GET_AXORD (VALSTR, IORDER, ISWAP, IFLAG) C C====== Get progress bar position C CALL XDLF_VIEW_OBJECT_ROOTXY (IVH_IOW,20,20,IPROG_X,IPROG_Y,IERR) IPROG_PASS = 0 C C====== Calculate the soft limit C IF (IOPT.EQ.1) THEN NUMBINS = ISOFT_D_NUMBINS BIN_WIDTH = SOFT_DMIN_WIDTH ELSE NUMBINS = ISOFT_L_NUMBINS BIN_WIDTH = SOFT_LMIN_WIDTH END IF CALL LFN_SOFT (IPACK, IPLATE, IOPT, IMG, ITYPE, IORDER, + NFRASTS, NXRAST, NYRAST, PROMIN, + NPROF, PRF_ROT, + SOFT_INTEG_PROGRESS, LFN_DUMMY_CNCL, + SOFT_FRAC, SOFT_SIGTEST, SOFT_FRTEST, + NUMBINS, BIN_WIDTH, + NTOT_MEAS, NTOT_GTSIG, NMEAS, NGTSIG, RBIN, + SOFT_MIN, SOFT_MAX, SOFT_SEL, IBIN_SEL, + IERR, ERRSTR, IWARN, WARNSTR) IB_SEL = IBIN_SEL CALL XDLF_DELETE_VIEW_OBJECT (IVH_BAR, JERR) IF (IERR.NE.0) THEN STR = '**Error**' CALL STR_ADDS (STR, ERRSTR, 1) CALL LMESSAGE (IVH_IOW, STR) END IF IF (IOPT.EQ.1) THEN STR = 'Value determined for ''dmin'' is' ELSE STR = 'Value determined for ''lambda-min'' is' END IF CALL STR_ADDF(STR,SOFT_SEL,2,1) CALL LMESSAGE(IVH_IOW, STR) IF (IWARN.GT.0) THEN STR = '*Warning*' CALL STR_ADDS(STR,WARNSTR,1) CALL LMESSAGE(IVH_IOW,STR) END IF SHOW_VAL = SOFT_SEL CUR_INT_LOW = SOFT_MIN IF (IUN_LOG.GT.0) WRITE(IUN_LOG,'('' '')') IF (IUN_LOG.GT.0) CALL LFN_SOFT_LIST (IUN_LOG, 0, IPACK, IPLATE, + IOPT, PROMIN, NPROF, PRF_ROT, + SOFT_SIGTEST, SOFT_FRTEST, NUMBINS, BIN_WIDTH, + NMEAS, NGTSIG, RBIN, SOFT_MIN, SOFT_MAX, SOFT_SEL, + IBIN_SEL, IWARN, WARNSTR) C C====== Set some flags C GRAPH_DISP = .FALSE. ACCEPT = .FALSE. C C====== Output menu to service results C M_NORM = 1 M_HIST = 2 M_SHOW = 3 M_ACCEPT = 4 M_INPUT = 5 50 CALL XDLF_MENU_AREA_SETMENU (IVH_MENU, 5, XDLSTR(NAMES), 25, + XDLSTR('Soft Limits Results Menu'), 24, + XDLSTR(QUITNAM), 25, 0, IERR) C C====== Set up list of view-object handles C NVIEW = 1 IVHLIST(1) = IVH_MENU C C====== Start event loop C 100 CALL XDLF_GET_EVENTS (NVIEW, IVHLIST, IVH) IF (IVH.EQ.IVH_MENU) THEN C C====== Menu item selected C CALL XDLF_MENU_AREA_GETITEM (IVH_MENU, ITEM, IQUIT) C C====== Quit selected C IF (IQUIT.EQ.1) THEN IF (.NOT.ACCEPT) THEN CALL YESNO_NOTICE (1, + 'No new value selected - still return?', IYN) IF (IYN.EQ.2) GO TO 100 IF (IUN_LOG.GT.0) WRITE(IUN_LOG,1020) END IF IF (GRAPH_DISP) THEN CALL XDLF_DELETE_VIEW_OBJECT (IVH_GRAPH, IERR) END IF RETURN END IF C C====== Delete graph if present unless 'accept' or 'input option C IF (ITEM.NE.M_ACCEPT.AND.ITEM.NE.M_INPUT) THEN IF (GRAPH_DISP) THEN CALL XDLF_DELETE_VIEW_OBJECT (IVH_GRAPH, IERR) GRAPH_DISP = .FALSE. END IF END IF C C====== Output Normalised Histogram C IF (ITEM.EQ.M_NORM) THEN CALL SOFT_HIST (IOPT, 1, NUMBINS, BIN_WIDTH, + SOFT_MIN, SOFT_MAX, SOFT_SEL, IBIN_SEL, + NGTSIG, RBIN) GRAPH_DISP = .TRUE. GO TO 100 C C====== Output Un-normalised Histogram C ELSE IF (ITEM.EQ.M_HIST) THEN CALL SOFT_HIST (IOPT, 0, NUMBINS, BIN_WIDTH, + SOFT_MIN, SOFT_MAX, SOFT_SEL, IBIN_SEL, + NGTSIG, RBIN) GRAPH_DISP = .TRUE. GO TO 100 C C====== Show image C ELSE IF (ITEM.EQ.M_SHOW) THEN CALL SOFT_SHOW (IOPT, SHOW_VAL, CUR_INT_LOW) GO TO 50 C C====== Accept value C ELSE IF (ITEM.EQ.M_ACCEPT) THEN IF (IOPT.EQ.1) THEN CALL LDM_SET_DMIN (IPACK, SOFT_SEL, IERR, ERRSTR) IF (IERR.NE.0) THEN STR = '**Error**' CALL STR_ADDS (STR,ERRSTR,1) CALL ERR_NOTICE (1,STR) END IF ACCEPT = .TRUE. LISTE(1) = IP_DMIN CALL SET_PAR1_VALS (1, LISTE) CALL OTHERS_UPD (1, UPD_DMIN, KPACK, KPLATE) CALL LDM_SET_DMIN (KPACK, SOFT_SEL, IERR, ERRSTR) ELSE IF (IOPT.EQ.2) THEN CALL LDM_SET_LMIN (IPACK, SOFT_SEL, IERR, ERRSTR) IF (IERR.NE.0) THEN STR = '**Error**' CALL STR_ADDS (STR,ERRSTR,1) CALL ERR_NOTICE (1,STR) END IF ACCEPT = .TRUE. LISTE(1) = IP_WMIN CALL SET_PAR1_VALS (1, LISTE) CALL OTHERS_UPD (1, UPD_LAMS, KPACK, KPLATE) CALL LDM_SET_LMIN (KPACK, SOFT_SEL, IERR, ERRSTR) END IF IF (IUN_LOG.GT.0) WRITE(IUN_LOG,1000) SHOW_VAL = SOFT_SEL GO TO 100 C C====== Input another value C ELSE IF (ITEM.EQ.M_INPUT) THEN IF (GRAPH_DISP) THEN CALL XDLF_VIEW_OBJECT_RAISE (IVH_BASE, IERR) END IF 200 VAL = SHOW_VAL IF (IOPT.EQ.1) THEN CALL IOW_ASKF (IVH_IOW,'Input value for ''dmin''', VAL, + 2) CALL LDM_SET_DMIN (IPACK, VAL, IERR, ERRSTR) IF (IERR.NE.0) THEN STR = '**Error**' CALL STR_ADDS (STR,ERRSTR,1) CALL LMESSAGE (IVH_IOW, STR) GO TO 200 END IF SHOW_VAL = VAL ACCEPT = .TRUE. LISTE(1) = IP_DMIN CALL SET_PAR1_VALS (1, LISTE) CALL OTHERS_UPD (1, UPD_DMIN, KPACK, KPLATE) CALL LDM_SET_DMIN (KPACK, VAL, IERR, ERRSTR) IF (IUN_LOG.GT.0) THEN STR = 'New value for dmin input as' CALL STR_ADDF(STR,VAL,2,1) WRITE(IUN_LOG,1010) STR END IF ELSE IF (IOPT.EQ.2) THEN CALL IOW_ASKF (IVH_IOW,'Input value for ''lambda-min''', + VAL, 2) CALL LDM_SET_LMIN (IPACK, VAL, IERR, ERRSTR) IF (IERR.NE.0) THEN STR = '**Error**' CALL STR_ADDS (STR,ERRSTR,1) CALL LMESSAGE (IVH_IOW, STR) GO TO 200 END IF SHOW_VAL = VAL ACCEPT = .TRUE. LISTE(1) = IP_WMIN CALL SET_PAR1_VALS (1, LISTE) CALL OTHERS_UPD (1, UPD_LAMS, KPACK, KPLATE) CALL LDM_SET_LMIN (KPACK, VAL, IERR, ERRSTR) IF (IUN_LOG.GT.0) THEN STR = 'New value for lambda-min input as' CALL STR_ADDF(STR,VAL,2,1) WRITE(IUN_LOG,1010) STR END IF END IF IF (GRAPH_DISP) THEN CALL XDLF_VIEW_OBJECT_RAISE (IVH_GRAPH, IERR) END IF GO TO 100 END IF END IF GO TO 100 C C====== Format statements C 1000 FORMAT('New value accepted',/) 1010 FORMAT(/,A) 1020 FORMAT('No new value accepted',/) END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** SOFT_HIST ** C************************** C C SUBROUTINE SOFT_HIST (IOPT, INORM, NUMBINS, BIN_WIDTH, + SOFT_MIN, SOFT_MAX, SOFT_SEL, ISEL, + NGTSIG, RBIN) C INCLUDE 'implicit_none.finc' C C Purpose: Output histogram of soft limits determination results C C Author: John W. Campbell, March 1994 C C Arguments: C INTEGER IOPT INTEGER INORM INTEGER NUMBINS REAL BIN_WIDTH REAL SOFT_MIN REAL SOFT_MAX REAL SOFT_SEL INTEGER ISEL INTEGER NGTSIG(*) REAL RBIN(*) C C IOPT (R) Option flag =1 dmin, =2 lmin C INORM (R) Normalised histogram =1 yes, =0 un-normalised C NUMBINS (R) Number of bins C BIN_WIDTH (R) Bin width C SOFT_MIN (R) Minimum soft limits value C SOFT_MAX (R) Maximum soft limits value C SOFT_SEL (R) Selected soft limits value C ISEL (R) Selected bin number C NGTSIG (R) No. significant reflections for NUMBINS bins C RBIN() (R) Significant/Measured intensity ratios for NUMBINS bins C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'get_soft.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR INTEGER LENSTR C C====== LOCALS: C LOGICAL MARK_OVER INTEGER I INTEGER KXROOT INTEGER KYROOT INTEGER IERR REAL AX1_DIV REAL X1 REAL X2 REAL Y REAL ARR_H REAL ARR_W REAL ARR_X(3) REAL ARR_Y(3) REAL RBINMAX CHARACTER*80 TITLE C LOGICAL MARK_OVER !Mark value >1.0 on normalised histogram C INTEGER I !Temp/loop variable C INTEGER KXROOT !Root window x position for graphics window C INTEGER KYROOT !Root window y position for graphics window C INTEGER IERR !Error flag C REAL AX1_DIV !Axis 1 divisions width C REAL X1 !Start of histogram box (x axis) C REAL X2 !End of histogram box (x axis) C REAL Y !Height of histogram box (y axis) C REAL ARR_H !Arrow height C REAL ARR_W !Arrow half width C REAL ARR_X(3) !Arrow head x coordinates C REAL ARR_Y(3) !Arrow head y coordinates C REAL RBINMAX !Maximum value is RBIN array C CHARACTER*80 TITLE !Graph title string C C------------------------------------------------------------------------------- C C====== Get required position for graph display C CALL XDLF_VIEW_OBJECT_ROOTXY(IVH_PAR1,0,0,KXROOT,KYROOT,IERR) KYROOT = KYROOT - 30 IF (KYROOT.LT.0) KYROOT = 0 C C====== Get maximum value in RBIN array C RBINMAX = 0.0 DO 10 I = 1, NUMBINS IF (RBIN(I).GT.RBINMAX.AND.NGTSIG(I).GE.10) RBINMAX = RBIN(I) 10 CONTINUE C C====== Create graphics window C CALL XDLF_GRAPH_WIN (IVH_GRAPH, 0, KXROOT, KYROOT, 0, 0, + 600, 400, 0, 0, 2, 0, IERR) C C====== Plot the histogram C IF (INORM.EQ.1) THEN TITLE = 'Normalised Histogram for' ELSE TITLE = 'Histogram for' END IF IF (IOPT.EQ.1) THEN CALL STR_ADDS(TITLE,'''dmin''',1) ELSE IF (IOPT.EQ.2) THEN CALL STR_ADDS(TITLE,'''lambda-dmin''',1) END IF CALL STR_ADDS (TITLE,'determination',1) CALL XDLF_GRAPH_WIN_STYLE (IVH_GRAPH, 0, 1, -1, IERR) CALL XDLF_GRAPH_WIN_MAP (IVH_GRAPH, 0.0, 1.0, + 0.0, 1.0, 0.0, 1.0, 0.0, 1.0, + 0, IERR) CALL XDLF_GRAPH_WIN_STEXT (IVH_GRAPH, 0.5, 0.95, + XDLSTR(TITLE), LENSTR(TITLE), + 0.0, .042, 0, 1, 0.0, IERR) IF (INORM.EQ.1) THEN TITLE = 'I_significant/I_measured ratios (normalised)' ELSE TITLE = 'I_significant/I_measured ratios' END IF CALL XDLF_GRAPH_WIN_STEXT (IVH_GRAPH, 0.5, 0.89, + XDLSTR(TITLE), LENSTR(TITLE), + 0.0, .033, 0, 1, 0.0, IERR) IF (IOPT.EQ.1) THEN TITLE = 'd-spacing' ELSE IF (IOPT.EQ.2) THEN TITLE = 'lambda' END IF CALL STR_ADDS (TITLE,'(Angstroms)',1) CALL XDLF_GRAPH_WIN_STEXT (IVH_GRAPH, 0.5, 0.05, + XDLSTR(TITLE), LENSTR(TITLE), + 0.0, .033, 0, 1, 0.0, IERR) CALL XDLF_GRAPH_WIN_MAP (IVH_GRAPH, SOFT_MIN, SOFT_MAX, + 0.0, 1.0, 0.1, 0.9, 0.15, 0.8, + 0, IERR) IF (NUMBINS.LE.15) THEN CALL XDLF_GRAPH_WIN_AX1 (IVH_GRAPH, SOFT_MIN, 0.0, + SOFT_MAX-SOFT_MIN, NUMBINS, 0.0, + 2, .015, .03, 0, IERR) ELSE I = (NUMBINS-1)/15 + 1 AX1_DIV = I*BIN_WIDTH CALL XDLF_GRAPH_WIN_AX1 (IVH_GRAPH, SOFT_MIN, 0.0, + SOFT_MAX-SOFT_MIN, 0, AX1_DIV, + 2, .015, .03, 0, IERR) END IF CALL XDLF_GRAPH_WIN_AX2 (IVH_GRAPH, SOFT_MIN, 0.0, + 1.0, 10, 0.0, 1, .015, .03, + 0, IERR) C C====== Plot histogram boxes C DO 100 I = 1, NUMBINS X1 = SOFT_MIN + (I-1)*BIN_WIDTH X2 = SOFT_MIN + I*BIN_WIDTH Y = RBIN(I) IF (INORM.EQ.1) Y = Y/RBINMAX MARK_OVER = .FALSE. IF (INORM.EQ.1.AND.Y.GT.1.0) THEN Y = 1.0 MARK_OVER = .TRUE. END IF CALL XDLF_GRAPH_WIN_LINE (IVH_GRAPH, X1, 0.0, X1, Y, IERR) IF (MARK_OVER) THEN CALL XDLF_GRAPH_WIN_STYLE (IVH_GRAPH, 0, 3, -1, IERR) CALL XDLF_GRAPH_WIN_LINE (IVH_GRAPH, X1, Y, X2, Y, IERR) CALL XDLF_GRAPH_WIN_STYLE (IVH_GRAPH, 0, 1, -1, IERR) ELSE CALL XDLF_GRAPH_WIN_LINE (IVH_GRAPH, X1, Y, X2, Y, IERR) END IF CALL XDLF_GRAPH_WIN_LINE (IVH_GRAPH, X2, Y, X2, 0.0, IERR) 100 CONTINUE C C====== Arrow at selected value C ARR_H = 0.1 ARR_W = (SOFT_MAX-SOFT_MIN)/80 Y = RBIN(ISEL) IF (INORM.EQ.1) Y = RBIN(ISEL)/RBINMAX Y = Y + 0.02 ARR_X(1) = SOFT_SEL ARR_Y(1) = Y ARR_X(2) = SOFT_SEL - ARR_W ARR_Y(2) = Y + ARR_H/2.0 ARR_X(3) = SOFT_SEL + ARR_W ARR_Y(3) = Y + ARR_H/2.0 CALL XDLF_GRAPH_WIN_STYLE (IVH_GRAPH, 2, -1, -1, IERR) CALL XDLF_GRAPH_WIN_POLYGON (IVH_GRAPH, ARR_X, ARR_Y, 3, 1, IERR) CALL XDLF_GRAPH_WIN_STYLE (IVH_GRAPH, -1, 2, -1, IERR) CALL XDLF_GRAPH_WIN_LINE (IVH_GRAPH, SOFT_SEL, Y+ARR_H/4.0, + SOFT_SEL, Y+ARR_H, IERR) C C====== Show line at selection criterion C Y = 0.15 IF (INORM.NE.1) Y = Y*RBINMAX CALL XDLF_GRAPH_WIN_STYLE (IVH_GRAPH, 6, 1, -1, IERR) CALL XDLF_GRAPH_WIN_LINE (IVH_GRAPH, SOFT_MIN, Y, SOFT_MAX, Y, + IERR) RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C******************************** C** SOFT_INTEG_PROGRESS ** C******************************** C C SUBROUTINE SOFT_INTEG_PROGRESS (IPASS, NSPOT, ISPOT) C INCLUDE 'implicit_none.finc' C C Purpose: Monitor progess of integration passes for soft limits determinations C C Author: John W. Campbell, March 1994 C C Arguments: C INTEGER IPASS INTEGER NSPOT INTEGER ISPOT C C IPASS (R) Integration pass C NSPOT (R) Total no. spots to integrate C ISPOT (R) No. of last spot integrated C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'get_soft.finc' INCLUDE 'prog_flags.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR C C====== LOCALS: C INTEGER IERR C C INTEGER IERR !Error flag C C------------------------------------------------------------------------------- C IF (IPROG_PASS.EQ.IPASS) THEN IF (LG_MODE.NE.1) RETURN IF (MOD(ISPOT,20).NE.0) RETURN CALL XDLF_PROGRESS_BAR_VALUE (IVH_BAR, ISPOT, IERR) ELSE IF (LG_MODE.EQ.1.AND.IPROG_PASS.GT.0) THEN CALL XDLF_DELETE_VIEW_OBJECT (IVH_BAR, IERR) END IF IF (LG_MODE.EQ.1) THEN IF (IPASS.EQ.1) THEN CALL XDLF_PROGRESS_BAR (IVH_BAR, IPROG_X, IPROG_Y, + XDLSTR('Forming profiles:'), 17, 150, NSPOT, + 2, 1) ELSE IF (IPASS.EQ.2) THEN CALL XDLF_PROGRESS_BAR (IVH_BAR, IPROG_X, IPROG_Y, + XDLSTR('Integrating spots:'), 18, 150, NSPOT, + 2, 5) END IF ELSE IF (LG_MODE.EQ.2) THEN IF (IPASS.EQ.1) THEN CALL TWRITE ('==Forming profiles==') ELSE IF (IPASS.EQ.2) THEN CALL TWRITE ('==Integrating spots==') END IF END IF IPROG_PASS = IPASS END IF RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C*********************** C** SOFT_LIST ** C*********************** C C SUBROUTINE SOFT_LIST (ILOG, ITERM, IPACK, IPLATE, IOPT, + PROMIN, NPROF, PRF_ROT, SIGTEST, FRTEST, + NBINS, BINW, NMEAS, NGTSIG, RBIN, + SOFT_MIN, SOFT_MAX, SOFT_SEL, + IBIN_SEL, IWARN, WARNSTR) C INCLUDE 'implicit_none.finc' C C Purpose: Control listing of soft limits determination results when called C fom command line lg_dmin or lg_lmin commands C C Author: John W. Campbell, November 1994 C C Arguments: C INTEGER ILOG INTEGER ITERM INTEGER IPACK INTEGER IPLATE INTEGER IOPT REAL PROMIN INTEGER NPROF LOGICAL PRF_ROT REAL SIGTEST REAL FRTEST INTEGER NBINS REAL BINW INTEGER NMEAS(*) INTEGER NGTSIG(*) REAL RBIN(*) REAL SOFT_MIN REAL SOFT_MAX REAL SOFT_SEL INTEGER IBIN_SEL INTEGER IWARN CHARACTER*(*) WARNSTR C C Parameters are the same as for LFN_SOFT_LIST C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'ip1_entries.finc' INCLUDE 'file_units.finc' INCLUDE 'prog_flags.finc' INCLUDE 'upd_flags.finc' INCLUDE 'get_soft.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR C C====== LOCALS: C LOGICAL EOF LOGICAL ACCEPT INTEGER IB INTEGER IB_MIN INTEGER IB_MAX INTEGER IERR INTEGER IFLAG INTEGER ND INTEGER KPACK INTEGER KPLATE INTEGER LISTE(2) REAL RATMAX REAL RATNRM REAL SFT_MIN REAL SFT_MAX REAL SOFT_CUR CHARACTER*80 STR CHARACTER*80 ERRSTR C LOGICAL EOF !End of file flag C LOGICAL ACCEPT !Accept new soft limit flag C INTEGER IB !Bin counter C INTEGER IB_MIN !Minimum bin number for mini histogram C INTEGER IB_MAX !Maximum bin number for mini histogram C INTEGER IERR !Error flag C INTEGER IFLAG !Parameter status flag C INTEGER ND !No. of decimal places flag C INTEGER KPACK !Pack number, 0 = all packs C INTEGER KPLATE !Plate number, 0 = all plates C INTEGER LISTE(2) !List of parameters to be updated C REAL RATMAX !Maximum sigificant/measured ratio found C REAL RATNRM !Normalised ratio C REAL SFT_MIN !Minimum soft limit for current bin C REAL SFT_MAX !Maximum soft limit for current bin C REAL SOFT_CUR !Current soft limit value C CHARACTER*80 STR !Temp string C CHARACTER*80 ERRSTR !Error string C C------------------------------------------------------------------------------- C IF (IUN_LOG.GT.0) WRITE(IUN_LOG,'('' '')') IF (IUN_LOG.GT.0) CALL LFN_SOFT_LIST (IUN_LOG, 0, + IPACK, IPLATE, + IOPT, PROMIN, NPROF, PRF_ROT, + SIGTEST, FRTEST, NBINS, BINW, + NMEAS, NGTSIG, RBIN, SOFT_MIN, SOFT_MAX, SOFT_SEL, + IBIN_SEL, IWARN, WARNSTR) IF (LG_MODE.NE.3) THEN RATMAX = 0.0 DO 500 IB = 1, NBINS IF (RBIN(IB).GT.RATMAX.AND.NGTSIG(IB).GE.10) + RATMAX = RBIN(IB) 500 CONTINUE IF (RATMAX.GT.0.0) THEN STR = 'Bin Range Nmeas Nobs Ratio Norm' IF (LG_MODE.EQ.1) THEN CALL LMESSAGE (IVH_IOW, STR) ELSE IF (LG_MODE.EQ.2) THEN CALL TWRITE (STR) END IF IB_MIN = IBIN_SEL - 3 IF (IB_MIN.LT.1) IB_MIN = 1 IB_MAX = IB_MIN + 6 IF (IB_MAX.GT.NBINS) IB_MAX = NBINS DO 510 IB = IB_MIN, IB_MAX SFT_MIN = SOFT_MIN + (IB-1)*BINW SFT_MAX = SFT_MIN + BINW RATNRM = RBIN(IB)/RATMAX WRITE(STR,1200) IB, SFT_MIN, SFT_MAX, NMEAS(IB), + NGTSIG(IB), RBIN(IB), RATNRM IF (IB.EQ.IBIN_SEL) THEN CALL STR_ADDS (STR, '<<<<<<', 3) END IF IF (LG_MODE.EQ.1) THEN CALL LMESSAGE (IVH_IOW, STR) ELSE IF (LG_MODE.EQ.2) THEN CALL TWRITE (STR) END IF 510 CONTINUE END IF END IF IF (IOPT.EQ.1) THEN STR = 'Value determined for ''dmin'' is' ELSE STR = 'Value determined for ''lambda-min'' is' END IF CALL STR_ADDF (STR, SOFT_SEL, 2, 1) IF (IOPT.EQ.1) THEN CALL LDM_GET_DMIN (IPACK, SOFT_CUR, IFLAG, ND, IERR, + ERRSTR) ELSE CALL LDM_GET_LMIN (IPACK, SOFT_CUR, IFLAG, ND, IERR, + ERRSTR) END IF CALL STR_ADDS (STR, '(was',1) CALL STR_ADDF (STR, SOFT_CUR, 2, 1) CALL STR_ADDS (STR, ')',0) IF (LG_MODE.EQ.1) THEN CALL LMESSAGE (IVH_IOW, STR) ELSE IF (LG_MODE.EQ.2) THEN CALL TWRITE (STR) END IF ACCEPT = .TRUE. IF (IWARN.GT.0) THEN STR = '*Warning*' CALL STR_ADDS(STR,WARNSTR,1) ACCEPT = .FALSE. IF (IWARN.EQ.2) ACCEPT = .TRUE. IF (LG_MODE.EQ.1) THEN CALL LMESSAGE (IVH_IOW, STR) CALL IOW_ASKQ(IVH_IOW, 'Accept new value', ACCEPT) ELSE IF (LG_MODE.EQ.2) THEN CALL TWRITE (STR) CALL TASKQ ('Accept new value', ACCEPT, EOF) END IF END IF IF (ACCEPT) THEN IF (IUN_LOG.GT.0) WRITE(IUN_LOG, 1000) IF (IOPT.EQ.1) THEN CALL LDM_SET_DMIN (IPACK, SOFT_SEL, IERR, ERRSTR) LISTE(1) = IP_DMIN CALL SET_PAR1_VALS (1, LISTE) CALL OTHERS_UPD (1, UPD_DMIN, KPACK, KPLATE) CALL LDM_SET_DMIN (KPACK, SOFT_SEL, IERR, ERRSTR) ELSE IF (IOPT.EQ.2) THEN CALL LDM_SET_LMIN (IPACK, SOFT_SEL, IERR, ERRSTR) LISTE(1) = IP_WMIN CALL SET_PAR1_VALS (1, LISTE) CALL OTHERS_UPD (1, UPD_LAMS, KPACK, KPLATE) CALL LDM_SET_LMIN (KPACK, SOFT_SEL, IERR, ERRSTR) END IF ELSE IF (IUN_LOG.GT.0) WRITE(IUN_LOG, 1010) END IF RETURN C C====== Format statements C 1000 FORMAT('New value accepted',/) 1010 FORMAT('New value not accepted',/) 1200 FORMAT(I3,F6.2,' -',F5.2,I6,I6,F7.2,F7.2) END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C*************************** C** SOFT_PROGRESS ** C*************************** C C SUBROUTINE SOFT_PROGRESS (IUN_LOG, IOPT, ISTAGE, IPACK, IPLATE) C INCLUDE 'implicit_none.finc' C C Purpose: Monitor automatic soft limit determination progress C C Author: John W. Campbell, November 1994 C C Arguments: C INTEGER IUN_LOG INTEGER IOPT INTEGER ISTAGE INTEGER IPACK INTEGER IPLATE C C IUN_LOG (R) Unit number for log file C IOPT (R) 1=dmin, 2=lambda-min flag C ISTAGE (R) Stage = 0 Start of new pack C = 1 Starting to read image C = 2 Finished image reading C = 3 Starting actual soft limit C determination for the pack C = 4 Finished soft limit C determination for the pack C IPACK (R) Pack number C IPLATE (R) Plate number C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'prog_flags.finc' INCLUDE 'get_soft.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR C C====== LOCALS: C INTEGER LISTE(2) INTEGER IERR CHARACTER*80 STR C INTEGER LISTE(2) !List of parameters to update C INTEGER IERR !Error flag C CHARACTER*80 STR !Temp. string C C------------------------------------------------------------------------------- C IF (ISTAGE.EQ.0) THEN C C====== Update parameter tables C IF (LG_MODE.EQ.1) THEN CALL SET_PAR1_VALS (0, LISTE) CALL SET_PAR2_VALS (0, LISTE) END IF C C====== Output heading for new pack C IF (IOPT.EQ.1) THEN STR = '==Determining dmin for pack' ELSE STR = '==Determining lambda-min for pack' END IF CALL STR_ADDI (STR, IPACK, 1) CALL STR_ADDS (STR, 'using plate', 1) CALL STR_ADDI (STR, IPLATE, 1) IF (LG_MODE.EQ.1) THEN CALL LMESSAGE (IVH_IOW, STR) ELSE IF (LG_MODE.EQ.2) THEN CALL TWRITE (STR) END IF ELSE IF (ISTAGE.EQ.3) THEN C C====== Get progress bar position C IPROG_X = 0 IPROG_Y = 0 IF (LG_MODE.EQ.1) THEN CALL XDLF_VIEW_OBJECT_ROOTXY (IVH_CMD, 8, 35, + IPROG_X, IPROG_Y, IERR) END IF IPROG_PASS = 0 IF (LG_MODE.EQ.1) CALL CMD_CNCL_BUT ELSE IF (ISTAGE.EQ.4) THEN C C====== Remove progress bar and cancel button C IF (LG_MODE.EQ.1) THEN CALL XDLF_DELETE_VIEW_OBJECT (IVH_BAR, IERR) CALL XDLF_DELETE_VIEW_OBJECT (IVH_CNCL_BUT, IERR) END IF END IF RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C*********************** C** SOFT_SHOW ** C*********************** C C SUBROUTINE SOFT_SHOW (IOPT, SHOW_VAL, CUR_INT_LOW) C INCLUDE 'implicit_none.finc' C C Purpose: Show soft limits results on image C C Author: John W. Campbell, December 1993 C C Arguments: C INTEGER IOPT REAL SHOW_VAL REAL CUR_INT_LOW C C IOPT (R) Soft limit type =1 dmin, =2 lmin C SHOW_VAL (R) Determined or input soft limit value C CUR_INT_LOW (R/W) Current low limit used in prediction/integration C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' INTEGER MAX_TEMP PARAMETER(MAX_TEMP=1000) C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'film_pack.finc' INCLUDE 'get_soft.finc' INCLUDE 'symbol_types.finc' INCLUDE 'image.finc' INCLUDE 'integ_pars.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR EXTERNAL SOFT_INTEG_PROGRESS LOGICAL LFN_DUMMY_CNCL EXTERNAL LFN_DUMMY_CNCL C C====== LOCALS: C LOGICAL SYMBOLS LOGICAL CHANGE LOGICAL NODF LOGICAL SPAT LOGICAL BAD LOGICAL OVL LOGICAL MS LOGICAL DISTOR LOGICAL INTEG INTEGER ISORTED INTEGER IOVTYP INTEGER INTCOD INTEGER NXRAST INTEGER NYRAST INTEGER IORDER INTEGER ISWAP INTEGER M_PRED INTEGER M_LOW INTEGER NVIEW INTEGER IVHLIST(2) INTEGER IVH INTEGER ITEM INTEGER IQUIT INTEGER ND INTEGER IFLAG INTEGER IERR INTEGER JERR INTEGER NUM_SPOTS INTEGER N INTEGER NOUT INTEGER IH INTEGER IK INTEGER IL INTEGER MULT INTEGER ICODE INTEGER ICT INTEGER IXPIX_TEMP(MAX_TEMP) INTEGER IYPIX_TEMP(MAX_TEMP) INTEGER ISYMB_TEMP(MAX_TEMP) INTEGER ICOLR_TEMP(MAX_TEMP) INTEGER IXC INTEGER IYC REAL A REAL B REAL RAD REAL MM_RAST_X REAL MM_RAST_Y REAL XF REAL YF REAL BLAM REAL DTHR REAL X REAL AI REAL ASIG REAL CUR_LOW REAL SOFT_LOW REAL SOFT_HIGH CHARACTER*25 NAMES(2) CHARACTER*25 QUITNAM CHARACTER*80 ERRSTR CHARACTER*120 STR CHARACTER*2 VALSTR C LOGICAL SYMBOLS !Symbols plotted on image flag C LOGICAL CHANGE !Limits changed flag C LOGICAL NODF !OK nodal flag C LOGICAL SPAT !Spatially overlapped flag C LOGICAL BAD !Bad spot flag C LOGICAL OVL !Overload flag C LOGICAL MS !Spot measured flag C LOGICAL DISTOR !Coordinates distortion corrected flag C LOGICAL INTEG !Spots integrated flag C INTEGER ISORTED !Sort order code for spots list C INTEGER IOVTYP !Overlap type C INTEGER INTCOD !Integration code type C INTEGER NXRAST !No. x-rasters C INTEGER NYRAST !No. y-rasters C INTEGER IORDER !Axis order C INTEGER ISWAP !Byte swap flag C INTEGER M_PRED !Menu item no.: Predicted pattern C INTEGER M_LOW !Menu item no.: Low dmin/lmin spots C INTEGER NVIEW !No. of view-objects for getting events C INTEGER IVHLIST(2) !List of view-object handles for getting events C INTEGER IVH !Returned view-object handle from getting events C INTEGER ITEM !Item no. from menu selection C INTEGER IQUIT !Quit button flage from menu C INTEGER ND !No. of decimal places flag C INTEGER IFLAG !Parameter status flag C INTEGER IERR !Error flag C INTEGER JERR !Error flag C INTEGER NUM_SPOTS !No. of generated spots C INTEGER N !Spot no. C INTEGER NOUT !Number of symbols count flag C INTEGER IH !'h' index C INTEGER IK !'k' index C INTEGER IL !'l' index C INTEGER MULT !Multiplicity C INTEGER ICODE !Integration status code C INTEGER ICT !Integration code type C INTEGER IXPIX_TEMP(MAX_TEMP) !x pixel positions of spots C INTEGER IYPIX_TEMP(MAX_TEMP) !y pixel positions of spots C INTEGER ISYMB_TEMP(MAX_TEMP) !Symbol type C INTEGER ICOLR_TEMP(MAX_TEMP) !Color type C INTEGER IXC !Spot centre nearest 'x' pixel C INTEGER IYC !Spot centre nearest 'y' pixel C REAL A !Spot ellipse major axis C REAL B !Spot ellipse minor axis C REAL RAD !Spot radius + 1 pixel C REAL MM_RAST_X !Conversion factor mm to x-rasters C REAL MM_RAST_Y !Conversion factor mm to y-rasters C REAL XF !xf position of spot C REAL YF !yf position of spot C REAL BLAM !Lambda value of spot C REAL DTHR !Dminthresholds2 value of spot C REAL X !Current d/lambda value of spot C REAL AI !Integrated intensity of spot c REAL ASIG !sig(I) of spot C REAL CUR_LOW !Current low soft limit value C REAL SOFT_LOW !Low limit of soft parameter for spots display C REAL SOFT_HIGH !High limit of soft parameter for spots display C CHARACTER*25 NAMES(2) !Menu item names C CHARACTER*25 QUITNAM !Quit button string C CHARACTER*80 ERRSTR !Error string C CHARACTER*120 STR !Message string C CHARACTER*2 VALSTR !Parameter value string (dummy) DATA NAMES /'Show Predicted Pattern', + ' '/ DATA QUITNAM /'Return to Previous Menu'/ C C------------------------------------------------------------------------------- C C====== Get max spot radius + 1 pixel C CALL LDM_MMRAST (IPACK, IPLATE, MM_RAST_X, MM_RAST_Y) CALL LDM_GET_SPOTL (IPACK, IPLATE, A, IFLAG, ND, + IERR, ERRSTR) CALL LDM_GET_SPOTW (IPACK, IPLATE, B, IFLAG, ND, + IERR, ERRSTR) RAD = A IF (B.GT.A) RAD = B RAD = RAD*MM_RAST_X/2.0 + 1.0 C C====== Show image C CALL SHOW_IMAGE (1, IERR) C C====== Output menu to service results C M_PRED = 1 M_LOW = 2 IF (IOPT.EQ.1) THEN NAMES(2) = 'Show low ''dmin'' Spots' ELSE IF (IOPT.EQ.2) THEN NAMES(2) = 'Show low ''lmin'' Spots' END IF SYMBOLS = .FALSE. 50 CALL XDLF_MENU_AREA_SETMENU (IVH_MENU, 2, XDLSTR(NAMES), 25, + XDLSTR('Soft Limits on Image'), 20, + XDLSTR(QUITNAM), 25, 0, IERR) C C====== Set up list of view-object handles C NVIEW = 1 IVHLIST(1) = IVH_MENU C C====== Start event loop C 100 CALL XDLF_GET_EVENTS (NVIEW, IVHLIST, IVH) IF (IVH.EQ.IVH_MENU) THEN C C====== Menu item selected C CALL XDLF_MENU_AREA_GETITEM (IVH_MENU, ITEM, IQUIT) C C====== Quit selected C IF (IQUIT.EQ.1) THEN CALL XDLF_IMAGE_SETTINGS (IVH_FILM, MINTHR, MAXTHR, + MONO_THR, ICONTRAST, ICOLOR_OPT, IOVLY_OPT, IBG_OPT, + MAG_OPT, ISHOW_INT, IERR) CALL XDLF_DELETE_VIEW_OBJECT (IVH_FILM, IERR) RETURN END IF IF (SYMBOLS) THEN CALL XDLF_IMAGE_CLEAR_SYMBOLS (IVH_FILM, IERR) CALL XDLF_IMAGE_CLEAR_VECTS (IVH_FILM, IERR) END IF C C====== Output predicted pattern C IF (ITEM.EQ.M_PRED) THEN CHANGE = .FALSE. IF (SHOW_VAL.LT.CUR_INT_LOW) CHANGE = .TRUE. IF (CHANGE) THEN IF (IOPT.EQ.1) THEN CALL LDM_GET_DMIN (IPACK, CUR_LOW, ND, IFLAG, + IERR, ERRSTR) CALL LDM_SET_DMIN (IPACK, SHOW_VAL, IERR, ERRSTR) ELSE IF (IOPT.EQ.2) THEN CALL LDM_GET_LMIN (IPACK, CUR_LOW, ND, IFLAG, + IERR, ERRSTR) CALL LDM_SET_LMIN (IPACK, SHOW_VAL, IERR, ERRSTR) END IF CUR_INT_LOW = SHOW_VAL CALL LRL_GEN (IPACK, IPLATE, .TRUE., 2, IERR, ERRSTR) END IF CALL LRL_STATUS (NUM_SPOTS, ISORTED, IOVTYP, DISTOR, + INTEG, INTCOD) IF (NUM_SPOTS.GT.0) THEN NOUT = 0 DO 120 N = 1, NUM_SPOTS CALL LRL_GET (N, IH, IK, IL, XF, YF, BLAM, DTHR, + MULT, NODF, SPAT, JERR) CALL LRL_GET_INT (N, AI, ASIG, MS, BAD, OVL, + ICODE, ICT, JERR) IF (IOPT.EQ.1) THEN X = 1.0/SQRT(DTHR) ELSE X = BLAM END IF IF (X.LT.SHOW_VAL) GO TO 120 IF (NOUT.EQ.MAX_TEMP) THEN CALL XDLF_IMAGE_SYMBOLS(IVH_FILM,NOUT, + IXPIX_TEMP, IYPIX_TEMP, + ISYMB_TEMP,ICOLR_TEMP,1,0, + IERR) IF (IERR.GT.0) THEN STR = '**Error code' CALL STR_ADDI(STR,IERR,1) CALL STR_ADDS(STR, + 'from xdl_view symbol plot routine**',1) CALL ERR_NOTICE(0,STR) GO TO 100 END IF NOUT = 0 END IF NOUT = NOUT + 1 IXPIX_TEMP(NOUT) = NINT(XF) IYPIX_TEMP(NOUT) = NINT(YF) IF (NODF) THEN ISYMB_TEMP(NOUT) = ISYMBTYP(2) ICOLR_TEMP(NOUT) = ICOLRTYP(2) ELSE ISYMB_TEMP(NOUT) = ISYMBTYP(1) ICOLR_TEMP(NOUT) = ICOLRTYP(1) END IF 120 CONTINUE IF (NOUT.GT.0) THEN CALL XDLF_IMAGE_SYMBOLS(IVH_FILM,NOUT, + IXPIX_TEMP, IYPIX_TEMP, + ISYMB_TEMP,ICOLR_TEMP,1,0, + IERR) IF (IERR.GT.0) THEN STR = '**Error code' CALL STR_ADDI(STR,IERR,1) CALL STR_ADDS(STR, + 'from xdl_view symbol plot routine**',1) CALL ERR_NOTICE(0,STR) GO TO 100 END IF END IF END IF SYMBOLS = .TRUE. IF (CHANGE) THEN IF (IOPT.EQ.1) THEN CALL LDM_SET_DMIN (IPACK, CUR_LOW, IERR, ERRSTR) ELSE IF (IOPT.EQ.2) THEN CALL LDM_SET_LMIN (IPACK, CUR_LOW, IERR, ERRSTR) END IF END IF GO TO 100 C C====== Output low dmin/lmin spots C ELSE IF (ITEM.EQ.M_LOW) THEN IF (IOPT.EQ.1) THEN CALL LDM_GET_DMIN (IPACK, CUR_LOW, ND, IFLAG, + IERR, ERRSTR) ELSE IF (IOPT.EQ.2) THEN CALL LDM_GET_LMIN (IPACK, CUR_LOW, ND, IFLAG, + IERR, ERRSTR) END IF 200 SOFT_LOW = SHOW_VAL CALL XDLF_VIEW_OBJECT_RAISE (IVH_BASE, IERR) IF (IOPT.EQ.1) THEN CALL IOW_ASKF (IVH_IOW,'Lower limit for d-spacing', + SOFT_LOW, 2) ELSE IF (IOPT.EQ.2) THEN CALL IOW_ASKF (IVH_IOW,'Lower limit for lambda', + SOFT_LOW, 2) END IF CHANGE = .FALSE. IF (SOFT_LOW.LT.CUR_INT_LOW) THEN CHANGE = .TRUE. IF (IOPT.EQ.1) THEN CALL LDM_SET_DMIN (IPACK, SOFT_LOW, IERR, ERRSTR) ELSE IF (IOPT.EQ.2) THEN CALL LDM_SET_LMIN (IPACK, SOFT_LOW, IERR, ERRSTR) END IF IF (IERR.NE.0) THEN STR = '**Error**' CALL STR_ADDS (STR,ERRSTR,1) CALL LMESSAGE (IVH_IOW, STR) GO TO 200 END IF END IF IF (IOPT.EQ.1) THEN SOFT_HIGH = SOFT_LOW + SOFT_DMIN_WIDTH ELSE IF (IOPT.EQ.2) THEN SOFT_HIGH = SOFT_LOW + SOFT_LMIN_WIDTH END IF IF (IOPT.EQ.1) THEN CALL IOW_ASKF (IVH_IOW,'Upper limit for d-spacing', + SOFT_HIGH, 2) ELSE IF (IOPT.EQ.2) THEN CALL IOW_ASKF (IVH_IOW,'Upper limit for lambda', + SOFT_HIGH, 2) END IF CALL XDLF_VIEW_OBJECT_RAISE (IVH_FILM, IERR) IF (CHANGE) THEN CALL LRL_GEN (IPACK, IPLATE, .TRUE., 2, IERR, ERRSTR) CUR_INT_LOW = SOFT_LOW END IF CALL LRL_STATUS (NUM_SPOTS, ISORTED, IOVTYP, DISTOR, + INTEG, INTCOD) IF (.NOT.INTEG) THEN C C====== Re-integrate if needed (do not need to reform profiles) C CALL LDM_GET_NXRAS (NXRAST, IFLAG) CALL LDM_GET_NYRAS (NYRAST, IFLAG) CALL LDM_GET_AXORD (VALSTR, IORDER, ISWAP, IFLAG) CALL XDLF_VIEW_OBJECT_ROOTXY (IVH_IOW,20,20, + IPROG_X,IPROG_Y,IERR) IF (IORDER.LE.4) THEN CALL LRL_SORT (3) ELSE CALL LRL_SORT (4) END IF IPROG_PASS = 0 CALL LFN_SAINT (IPACK, IPLATE, 2, IMG, ITYPE, IORDER, + NFRASTS, NXRAST, NYRAST, PROMIN, NPROF, PRF_ROT, + 0, SOFT_INTEG_PROGRESS, LFN_DUMMY_CNCL, + IERR, ERRSTR) CALL XDLF_DELETE_VIEW_OBJECT (IVH_BAR, JERR) IF (IERR.NE.0) THEN STR = '**Error**' CALL STR_ADDS (STR,ERRSTR,1) CALL LMESSAGE (IVH_IOW, STR) GO TO 100 END IF END IF IF (NUM_SPOTS.GT.0) THEN NOUT = 0 DO 250 N = 1, NUM_SPOTS CALL LRL_GET (N, IH, IK, IL, XF, YF, BLAM, DTHR, + MULT, NODF, SPAT, JERR) CALL LRL_GET_INT (N, AI, ASIG, MS, BAD, OVL, + ICODE, ICT, JERR) IF (IOPT.EQ.1) THEN X = 1.0/SQRT(DTHR) ELSE X = BLAM END IF IF (X.LT.SOFT_LOW.OR.X.GT.SOFT_HIGH) GO TO 250 IF (MULT.GT.1) GO TO 250 IF (SPAT.OR.AI.LE.SOFT_SIGTEST*ASIG) THEN IF (NOUT.EQ.MAX_TEMP) THEN CALL XDLF_IMAGE_SYMBOLS(IVH_FILM,NOUT, + IXPIX_TEMP, IYPIX_TEMP, + ISYMB_TEMP,ICOLR_TEMP,1,0, + IERR) IF (IERR.GT.0) THEN STR = '**Error code' CALL STR_ADDI(STR,IERR,1) CALL STR_ADDS(STR, + 'from xdl_view symbol plot routine**',1) CALL ERR_NOTICE(0,STR) GO TO 100 END IF NOUT = 0 END IF END IF IF (SPAT) THEN NOUT = NOUT + 1 IXPIX_TEMP(NOUT) = NINT(XF) IYPIX_TEMP(NOUT) = NINT(YF) ISYMB_TEMP(NOUT) = ISYMBTYP(10) ICOLR_TEMP(NOUT) = ICOLRTYP(10) ELSE IF (AI.GT.SOFT_SIGTEST*ASIG) THEN IXC = NINT(XF) IYC = NINT(YF) CALL DRAW_CIRC (IVH_FILM, IXC, IYC, RAD, 8, + 1000, ICOLRTYP(9), .FALSE.) ELSE NOUT = NOUT + 1 IXPIX_TEMP(NOUT) = NINT(XF) IYPIX_TEMP(NOUT) = NINT(YF) ISYMB_TEMP(NOUT) = ISYMBTYP(8) ICOLR_TEMP(NOUT) = ICOLRTYP(8) END IF END IF 250 CONTINUE IF (NOUT.GT.0) THEN CALL XDLF_IMAGE_SYMBOLS(IVH_FILM,NOUT, + IXPIX_TEMP, IYPIX_TEMP, + ISYMB_TEMP,ICOLR_TEMP,1,0, + IERR) IF (IERR.GT.0) THEN STR = '**Error code' CALL STR_ADDI(STR,IERR,1) CALL STR_ADDS(STR, + 'from xdl_view symbol plot routine**',1) CALL ERR_NOTICE(0,STR) GO TO 100 END IF END IF END IF SYMBOLS = .TRUE. IF (CHANGE) THEN IF (IOPT.EQ.1) THEN CALL LDM_SET_DMIN (IPACK, CUR_LOW, IERR, ERRSTR) ELSE IF (IOPT.EQ.2) THEN CALL LDM_SET_LMIN (IPACK, CUR_LOW, IERR, ERRSTR) END IF END IF GO TO 100 END IF END IF GO TO 100 END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** SPOT_C_OF_G ** C************************** C SUBROUTINE SPOT_C_OF_G (IXC, IYC, IXSIZ, IYSIZ, IDATA, IWORK, + ITHRESH, IMG, ITYPE, IORDER, NFOFF, + NXRAST, NYRAST, NOVER, CGX, CGY, IERR) C INCLUDE 'implicit_none.finc' C C Purpose: Find the centre of gravity of intensities lying within a C defined box allowing for a constant intensity threshold. C C Author: John W. Campbell, C (Based on a routine from the Daresbury Laboratory Laue C suite program GENLAUE as of September 1990) C C Arguments: C INTEGER IXC INTEGER IYC INTEGER IXSIZ INTEGER IYSIZ INTEGER IDATA(-IYSIZ:IYSIZ,-IXSIZ:IXSIZ) INTEGER IWORK(*) INTEGER ITHRESH INTEGER IMG(*) INTEGER ITYPE INTEGER IORDER INTEGER NFOFF INTEGER NXRAST INTEGER NYRAST INTEGER NOVER REAL CGX REAL CGY INTEGER IERR C C IXC (R) X pixel position for box centre (numbered from 1 up) C IYC (R) Y pixel position for box centre C IXSIZ (R) X box parameter (Box size will be (2*IXSIZ+1) * (2*IYSIZ+1) C IYSIZ (R) Y box parameter (See previous parameter) C IDATA (W) Array to hold read in data. Must be dimensioned to at least C (2*IXSIZ+1) * (2*IYSIZ+1) elements C IWORK (R) Work array (dimensioned to at least larger of C (2*IXSIZ+1) * (2*IYSIZ+1) elements C ITHRESH (R) Intensity threshold C IMG (R) In memory image data C ITYPE (R) Data type in stored image 1=unsigned byte, 2=unsigned two-byte C IORDER (R) Image data order flag (1-8) C NFOFF (R) Offset in pixels between lines in stored image C NXRAST (R) The number of x rasters in the image C NYRAST (R) The number of y-rasters in the image C NOVER (W) Returns the number of pixels over the threshold value C CGX (W) Returns the x coordinate (in raster units) of the c of g C CGY (W) Returns the y coordinate (in raster units) of the c of g C IERR (W) Error flag =0 OK, C =-1 flag error, =-2 byte handling not available C =1 box partly out of range C =2 box completely out of range of image. C C Declarations C ============ C C GLOBALS: C C C LOCALS: C INTEGER IX INTEGER IY INTEGER INTENS REAL SUMX REAL SUMY REAL SUM_INTENS C INTEGER IX !Loop counter over x points C INTEGER IY !Loop counter over y points C INTEGER INTENS !Pixel intensity C REAL SUMX !Sum for cgx calcn. C REAL SUMY !Sum for cgy calcn. C REAL SUM_INTENS !Sum of intensities over threshold C C------------------------------------------------------------------------------- C C====== Initialisations C NOVER = 0 CGX = IXC CGY = IYC C C====== Read spot C CALL LFN_IMG_RECT (IMG, ITYPE, IORDER, NFOFF, + IXC-IXSIZ, IYC-IYSIZ, 2*IXSIZ+1, 2*IYSIZ+1, + NXRAST, NYRAST, 0, IDATA, IWORK, IERR) IF (IERR.LT.0.OR.IERR.GT.1) RETURN C C====== Find Centre of Gravity C SUMX = 0.0 SUMY = 0.0 SUM_INTENS = 0.0 DO 200 IX = -IXSIZ, IXSIZ DO 100 IY = -IYSIZ, IYSIZ INTENS = MAX (0, IDATA(IY,IX) - ITHRESH) IF (INTENS.GT.0) NOVER = NOVER + 1 SUMX = SUMX + IX * INTENS SUMY = SUMY + IY * INTENS SUM_INTENS = SUM_INTENS + INTENS 100 CONTINUE 200 CONTINUE IF (SUM_INTENS.EQ.0.0) RETURN CGX = IXC + SUMX / SUM_INTENS CGY = IYC + SUMY / SUM_INTENS RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** SPOT HIST ** C************************** C SUBROUTINE SPOT_HIST (IOPT, NUMBINS, + N_GOOD, SUM_GOOD, RAST_MM, SIZE_FAC, + SEL_SIZE, Y_SCL_MAX) C INCLUDE 'implicit_none.finc' C C Purpose: Output histogram of spots size determination results C C Author: Don Nguti, September 1995 C C Arguments: C INTEGER IOPT INTEGER NUMBINS INTEGER N_GOOD(*) REAL SUM_GOOD(*) REAL RAST_MM REAL SIZE_FAC REAL SEL_SIZE REAL Y_SCL_MAX C C IOPT i (R) Option flag =1 spot length, =2 spot width C NUMBINS i (R) Number of bins C N_GOOD(*) i (R) Number of good spots in this bin C SUM_GOOD(*) r (R) Sum of spots sizes in this bin C RAST_MM r (R) Raster to mm conversion factor C SIZE_FAC r (R) Size compensation factor C SEL_SIZE r (R) Average spot size over all bins C Y_SCL_MAX r (R) spot size maximum axis length C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR INTEGER LENSTR C C====== LOCALS: C INTEGER I INTEGER KXROOT INTEGER KYROOT INTEGER IERR REAL AX1_DIV REAL X1 REAL X2 REAL Y CHARACTER*80 TITLE C INTEGER I !Temp/loop variable C INTEGER KXROOT !Root window x position for graphics window C INTEGER KYROOT !Root window y position for graphics window C INTEGER IERR !Error flag C REAL AX1_DIV !Axis 1 divisions width C REAL X1 !Start of histogram box (x axis) C REAL X2 !End of histogram box (x axis) C REAL Y !Height of histogram box (y axis) C CHARACTER*80 TITLE !Graph title string C C------------------------------------------------------------------------------- C C====== Get required position for graph display C CALL XDLF_VIEW_OBJECT_ROOTXY(IVH_PAR1,0,0,KXROOT,KYROOT,IERR) KYROOT = KYROOT - 30 IF (KYROOT.LT.0) KYROOT = 0 C C====== Create graphics window C CALL XDLF_GRAPH_WIN (IVH_GRAPH, 0, KXROOT, KYROOT, 0, 0, + 600, 400, 0, 0, 2, 0, IERR) C C====== Plot the histogram C C C====== Write title C TITLE = 'Histogram for' IF (IOPT.EQ.1) THEN CALL STR_ADDS(TITLE,'''spot length''',1) ELSE CALL STR_ADDS(TITLE,'''spot width''',1) END IF CALL STR_ADDS (TITLE,'determination',1) CALL XDLF_GRAPH_WIN_STYLE (IVH_GRAPH, 0, 1, -1, IERR) CALL XDLF_GRAPH_WIN_MAP (IVH_GRAPH, 0.0, 1.0, + 0.0, 1.0, 0.0, 1.0, 0.0, 1.0, + 0, IERR) CALL XDLF_GRAPH_WIN_STEXT (IVH_GRAPH, 0.5, 0.95, + XDLSTR(TITLE), LENSTR(TITLE), + 0.0, .042, 0, 1, 0.0, IERR) TITLE = '(Average measured and proposed sizes)' CALL XDLF_GRAPH_WIN_STEXT (IVH_GRAPH, 0.5, 0.89, + XDLSTR(TITLE), LENSTR(TITLE), + 0.0, .033, 0, 1, 0.0, IERR) C C====== Write y-axis label C IF (IOPT.EQ.1) THEN TITLE = 'Spot length (mm)' ELSE TITLE = 'Spot width (mm)' END IF CALL XDLF_GRAPH_WIN_STEXT (IVH_GRAPH, 0.05, 0.5, + XDLSTR(TITLE), LENSTR(TITLE), + 0.0, .033, 0, 1, 90.0, IERR) C C====== Write x-axis label C TITLE = 'Bin Number' CALL XDLF_GRAPH_WIN_STEXT (IVH_GRAPH, 0.5, 0.05, + XDLSTR(TITLE), LENSTR(TITLE), + 0.0, .033, 0, 1, 0.0, IERR) CALL XDLF_GRAPH_WIN_MAP (IVH_GRAPH, 0.0, REAL(NUMBINS), + 0.0, Y_SCL_MAX, 0.125, 0.925, 0.15, 0.8, + 0, IERR) IF (NUMBINS.LE.32) THEN CALL XDLF_GRAPH_WIN_AX1 (IVH_GRAPH, 0.0, 0.0, + REAL(NUMBINS), NUMBINS, 0.0, + 0, .015, .03, 0, IERR) ELSE I = (NUMBINS-1)/32 + 1 CALL XDLF_GRAPH_WIN_AX1 (IVH_GRAPH, 0.0, 0.0, + REAL(NUMBINS), 0, FLOAT(I), + 0, .015, .03, 0, IERR) END IF CALL XDLF_GRAPH_WIN_AX2 (IVH_GRAPH, 0.0, 0.0, + Y_SCL_MAX, 10, 0.0, 1, .015, .03, + 0, IERR) C C====== Plot histogram boxes C DO 100 I = 1, NUMBINS X1 = I - 1.0 X2 = I Y = SUM_GOOD(I) / N_GOOD(I) Y = Y * RAST_MM *SIZE_FAC CALL XDLF_GRAPH_WIN_LINE (IVH_GRAPH, X1, 0.0, X1, Y, IERR) CALL XDLF_GRAPH_WIN_LINE (IVH_GRAPH, X1, Y/SIZE_FAC, + X2, Y/SIZE_FAC, IERR) CALL XDLF_GRAPH_WIN_STYLE (IVH_GRAPH, 0, 3, -1, IERR) CALL XDLF_GRAPH_WIN_LINE (IVH_GRAPH, X1, Y, X2, Y, IERR) CALL XDLF_GRAPH_WIN_STYLE (IVH_GRAPH, 0, 1, -1, IERR) CALL XDLF_GRAPH_WIN_LINE (IVH_GRAPH, X2, Y, X2, 0.0, IERR) 100 CONTINUE C C====== Show line at selected size C Y = SEL_SIZE * SIZE_FAC * RAST_MM CALL XDLF_GRAPH_WIN_STYLE (IVH_GRAPH, 6, 1, -1, IERR) CALL XDLF_GRAPH_WIN_LINE (IVH_GRAPH, 0.0, Y, + REAL(NUMBINS), Y, IERR) RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** SPOT_PROGRESS ** C************************** C C SUBROUTINE SPOT_PROGRESS (IFLAG, NSTRIP, ISTRIP) C INCLUDE 'implicit_none.finc' C C Purpose: Monitor progess of spot find routine C C Author: John W. Campbell, September 1995 C C Arguments: C INTEGER IFLAG INTEGER NSTRIP INTEGER ISTRIP C C IFLAG (R) = 0 start, =1 in progress, =2 done C NSTRIP (R) Total no. of strips of image to process C ISTRIP (R) Current strip (1 to NSTRIP) C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'spot_sizes.finc' INCLUDE 'prog_flags.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR C C====== LOCALS: C INTEGER IERR C C INTEGER IERR !Error flag C C------------------------------------------------------------------------------- C IF (IFLAG.EQ.0) THEN IF (LG_MODE.EQ.1) THEN CALL XDLF_PROGRESS_BAR (IVH_BAR, ISP_PROGX, ISP_PROGY, + XDLSTR('Finding spots:'), 14, 150, NSTRIP, + 2, 1) PROG_BAR = .TRUE. ELSE IF (LG_MODE.EQ.2) THEN CALL TWRITE ('==Finding spots==') END IF ELSE IF (IFLAG.EQ.1) THEN IF (LG_MODE.NE.1) RETURN IF (MOD(ISTRIP,10).NE.0) RETURN CALL XDLF_PROGRESS_BAR_VALUE (IVH_BAR, ISTRIP, IERR) ELSE IF (IFLAG.EQ.2) THEN IF (LG_MODE.EQ.1) THEN CALL XDLF_DELETE_VIEW_OBJECT (IVH_BAR, IERR) PROG_BAR = .FALSE. ELSE IF (LG_MODE.EQ.2) THEN CALL TWRITE ('==Spot search complete==') END IF END IF RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** SPOT_RADIAL ** C************************** C SUBROUTINE SPOT_RADIAL (IXC, IYC, IXSIZ, IYSIZ, IDATA, + IWORK, ITHRESH, IMG, ITYPE, IORD, NFOFF, + NXRAST, NYRAST, + X_CEN, Y_CEN, NOVER, + CGX, CGY, IERR) C INCLUDE 'implicit_none.finc' C C Purpose: Find the centre of gravity of intensities lying within a C radially masked ellipse allowing for a constant intensity C threshold. C C Author: Based on code from GENLAUE including radial masking code C of T.J. Greengough and A.K. Shrive (Univ. of Keele) C C Arguments: C INTEGER IXC INTEGER IYC INTEGER IXSIZ INTEGER IYSIZ INTEGER IDATA(-IYSIZ:IYSIZ,-IXSIZ:IXSIZ) INTEGER IWORK(*) INTEGER ITHRESH INTEGER IMG(*) INTEGER ITYPE INTEGER IORD INTEGER NFOFF INTEGER NXRAST INTEGER NYRAST REAL X_CEN REAL Y_CEN INTEGER NOVER REAL CGX REAL CGY INTEGER IERR C C IXC (R) X pixel position for box centre (numbered from 1 up) C IYC (R) Y pixel position for box centre C IXSIZ (R) X box parameter (Box size will be (2*IXSIZ+1) * (2*IYSIZ+1) C IYSIZ (R) Y box parameter (See previous parameter) C IDATA (W) Array to hold read in data. Must be dimensioned to at least C (2*IXSIZ+1) * (2*IYSIZ+1) elements C IWORK (R) Work array (dimensioned to at least larger of C (2*IXSIZ+1) * (2*IYSIZ+1) elements C ITHRESH (R) Intensity threshold C IMG (R) In memory image data C ITYPE (R) Data type in stored image 1=unsigned byte, 2=unsigned two-byte C IORD (R) Image data order flag (1-8) C NFOFF (R) Offset in pixels between lines in stored image C NXRAST (R) No. of x-rasters C NYRAST (R) No. y-rasters C X_CEN (R) Corrected 'x' centre position (rasters) C Y_CEN (R) Corrected 'y' centre position (rasters) C NOVER (W) Returns the number of pixels over the threshold value C CGX (W) Returns the x coordinate (in raster units) of the c of g C CGY (W) Returns the y coordinate (in raster units) of the c of g C IERR (W) Error flag =0 OK, C =-1 flag error, =-2 byte handling not available C =1 box partly out of range C =2 box completely out of range of image. C C Declarations C ============ C C C parameter statements C INCLUDE 'lauegen_limits.finc' C C GLOBALS: C INCLUDE 'film_pack.finc' C C LOCALS: C INTEGER IXM INTEGER IYM INTEGER XPN INTEGER YPN INTEGER IMARK INTEGER IX INTEGER IY INTEGER INTENS INTEGER IFLAG INTEGER KERR INTEGER ND REAL SPOTFAC REAL SPOTL REAL SPOTW REAL CTOF REAL MM_RAST_X REAL MM_RAST_Y REAL SUMX REAL SUMY REAL SUM_INTENS REAL PI REAL CMASK REAL RADIUS REAL AMAJOR REAL BMINOR REAL THETA REAL XPRIME REAL YPRIME REAL ELLIP CHARACTER*2 ERRSTR C INTEGER IX !Loop counter over x points C INTEGER IY !Loop counter over y points C INTEGER INTENS !Pixel intensity C INTEGER IXM !x offset of ellipse centre from film centre in rasters C INTEGER IYM !y offset of ellipse centre from film centre in rasters C INTEGER XPN !x offset of current pixel from film centre in rasters C INTEGER YPN !y offset of current pixel from film centre in rasters C INTEGER IMARK !Flag =1 include pixel as part of spot, =0 do not C INTEGER IFLAG !Parameter status flag C INTEGER KERR !Error flag C INTEGER ND !No. of decimal places flag C REAL SPOTFAC !Spot expansion factor C REAL SPOTL !Spot length C REAL SPOTW !Spot width C REAL CTOF !Crystral-film distance C REAL MM_RAST_X !Conversion factor mm to x-rasters C REAL MM_RAST_Y !Conversion factor mm to y-rasters C REAL SUMX !Sum for cgx calcn. C REAL SUMY !Sum for cgy calcn. C REAL SUM_INTENS !Sum of intensities over threshold C REAL PI !Pi C REAL CMASK !1/2 streak length (uncorrected) in rasters C REAL RADIUS !Distance of ellipse centre from film centre (rasters) C REAL AMAJOR !Ellipse major axis (corrected) in rasters C REAL BMINOR !Ellipse minor axis in rasters C REAL THETA !Angle of ellipse major axis wrt. xf (radians) C REAL XPRIME !x' coordinate of current point wrt ellipse axes (rasters) C REAL YPRIME !y' coordinate of current point wrt ellipse axes (rasters) C REAL ELLIP !Value of ellipse function x**2/a**+y**2/b**2 C CHARACTER*2 ERRSTR !Error string (dummy) C C------------------------------------------------------------------------------- C C====== Initialisations C NOVER = 0 CGX = IXC CGY = IYC CALL LDM_GET_SPOTF (IPACK, IPLATE, SPOTFAC, IFLAG, ND, + KERR, ERRSTR) CALL LDM_GET_CTOF (IPACK, IPLATE, CTOF, IFLAG, ND, + KERR, ERRSTR) CALL LDM_GET_SPOTL (IPACK, IPLATE, SPOTL, IFLAG, ND, + KERR, ERRSTR) CALL LDM_GET_SPOTW (IPACK, IPLATE, SPOTW, IFLAG, ND, + KERR, ERRSTR) CALL LDM_MMRAST (IPACK, IPLATE, MM_RAST_X, MM_RAST_Y) C C====== Read spot C CALL LFN_IMG_RECT (IMG, ITYPE, IORD, NFOFF, + IXC-IXSIZ, IYC-IYSIZ, 2*IXSIZ+1, 2*IYSIZ+1, + NXRAST, NYRAST, 0, IDATA, IWORK, IERR) IF (IERR.LT.0.OR.IERR.GT.1) RETURN C C====== Find Centre of Gravity C SUMX = 0.0 SUMY = 0.0 SUM_INTENS = 0.0 C C====== Get offsets in pixels of box centre from pattern centre C IXM = NINT(FLOAT(IXC)-X_CEN) IYM = NINT(FLOAT(IYC)-Y_CEN) C C====== Set up parameters for radial masking calculation C PI = 4.0*ATAN(1.0) CMASK = SPOTL*MM_RAST_X/2.0 RADIUS = SQRT(FLOAT(IXM**2)+FLOAT(IYM**2)) AMAJOR = CMASK*(1.0+SPOTFAC*RADIUS/ + (CTOF*MM_RAST_X)) BMINOR = SPOTW*MM_RAST_X/2.0 IF (IXM.EQ.0) THEN THETA = PI/2.0 IF (IYM.LT.0) THEN THETA = 1.5*PI END IF GO TO 50 END IF THETA = ATAN(FLOAT(IYM)/FLOAT(IXM)) IF (IXM.LT.0) THEN THETA = THETA + PI ELSE IF (IYM.LT.0) THEN THETA = THETA + 2.0*PI END IF 50 CONTINUE C C====== Loop through pixels within box and see if each is within ellipse C DO 200 IX = -IXSIZ, IXSIZ DO 100 IY = -IYSIZ, IYSIZ C C====== Get offsets in pixels of current point from pattern centre C XPN = NINT(FLOAT(IXC+IX)-X_CEN) YPN = NINT(FLOAT(IYC+IY)-Y_CEN) IMARK = 0 XPRIME = (FLOAT(XPN)-IXM)*COS(THETA) XPRIME = XPRIME + (FLOAT(YPN)-IYM)*SIN(THETA) YPRIME = (FLOAT(YPN)-IYM)*COS(THETA) YPRIME = YPRIME - (FLOAT(XPN)-IXM)*SIN(THETA) ELLIP = (XPRIME**2/AMAJOR**2) + (YPRIME**2/BMINOR**2) IF (ELLIP.LE.1.0) IMARK = 1 C C====== Include pixel intensity if within ellipse C IF (IMARK.EQ.1) THEN INTENS = MAX (0, IDATA(IY,IX) - ITHRESH) IF (INTENS.GT.0) NOVER = NOVER + 1 SUMX = SUMX + IX * INTENS SUMY = SUMY + IY * INTENS SUM_INTENS = SUM_INTENS + INTENS END IF 100 CONTINUE 200 CONTINUE IF (SUM_INTENS.EQ.0.0) RETURN CGX = IXC + SUMX / SUM_INTENS CGY = IYC + SUMY / SUM_INTENS RETURN END C C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C****************************** C** SPOTSIZE_CALC ** C****************************** C C SUBROUTINE SPOTSIZE_CALC (KQUIT) C INCLUDE 'implicit_none.finc' C C Purpose: Determine spot sizes calculation routine C C Author: John W. Campbell, September 1995 C C Arguments: C INTEGER KQUIT C C KQUIT (W) Return flag = 0, OK C = 1, Error C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' INCLUDE 'screen_params.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'ip2_entries.finc' INCLUDE 'spot_sizes.finc' INCLUDE 'film_pack.finc' INCLUDE 'prog_flags.finc' INCLUDE 'image.finc' INCLUDE 'symbol_types.finc' INCLUDE 'upd_flags.finc' INCLUDE 'file_units.finc' INCLUDE 'bg_progress.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR INTEGER LENSTR EXTERNAL SPOT_PROGRESS LOGICAL LFN_DUMMY_CNCL EXTERNAL LFN_DUMMY_CNCL EXTERNAL BG_PROGRESS EXTERNAL BG_DUMMY_CNCL C C====== LOCALS: C LOGICAL GRAPH_DISP LOGICAL IMAGE_DISP LOGICAL ACCEPT INTEGER I INTEGER M_SHOW INTEGER M_HIST_L INTEGER M_HIST_W INTEGER M_ACCEPT INTEGER M_INPUT INTEGER NVIEW INTEGER IVHLIST(2) INTEGER IVH INTEGER ITEM INTEGER IQUIT INTEGER IERR INTEGER JERR INTEGER NXRAST INTEGER NYRAST INTEGER NF_OFF INTEGER IXROOT INTEGER IYROOT INTEGER IFLAG INTEGER ND INTEGER IORDER INTEGER ISWAP INTEGER IYN INTEGER LISTE(2) INTEGER KPACK INTEGER KPLATE INTEGER MINDX_SPOT INTEGER NPBOX INTEGER IPCNT INTEGER NUMB_L(64) INTEGER NREJ_L(64) INTEGER NGOOD_L(64) INTEGER NUMB_W(64) INTEGER NREJ_W(64) INTEGER NGOOD_W(64) INTEGER NSPOT INTEGER IBUF(7) REAL X_CEN_F REAL Y_CEN_F REAL W_F REAL MM_RAST_X REAL MM_RAST_Y REAL SPOTL REAL SPOTW REAL X_C REAL Y_C REAL XCEN REAL YCEN REAL RMIN REAL RMAX REAL XLOW REAL XHIGH REAL YLOW REAL YHIGH REAL REXCLUDE REAL SEL_LEN REAL SEL_WID REAL SPT_LEN REAL SPT_WID REAL VAL REAL BIN_S_L(64) REAL BIN_E_L(64) REAL SUM_L (64) REAL VAR_L(64) REAL SDEV_L(64) REAL AVE_L(64) REAL SGOOD_L(64) REAL BIN_S_W(64) REAL BIN_E_W(64) REAL SUM_W (64) REAL VAR_W(64) REAL SDEV_W(64) REAL AVE_W(64) REAL SGOOD_W(64) REAL SX REAL SY REAL SIZ REAL Y_SCL_MAX CHARACTER*2 VALSTR CHARACTER*80 ERRSTR CHARACTER*120 STR CHARACTER*25 NAMES(5) CHARACTER*25 QUITNAM C LOGICAL GRAPH_DISP !Graph is currently displayed flag C LOGICAL IMAGE_DISP !Image is currently displayed flag C LOGICAL ACCEPT !Limit has been accepted C INTEGER I !Temp/loop variable C INTEGER M_SHOW !Menu item no.: Show spots on image C INTEGER M_HIST_L !Menu item no.: Spot length histogram C INTEGER M_HIST_W !Menu item no.: Spot width histogram C INTEGER M_ACCEPT !Menu item no.: Accept new limit C INTEGER M_INPUT !Menu item no.: Input another limit C INTEGER NVIEW !No. of view-objects for getting events C INTEGER IVHLIST(2) !List of view-object handles for getting events C INTEGER IVH !Returned view-object handle from getting events C INTEGER ITEM !Item no. from menu selection C INTEGER IQUIT !Quit button flage from menu C INTEGER IERR !Error flag C INTEGER JERR !Error flag C INTEGER NXRAST !No. x-rasters C INTEGER NYRAST !No. y-rasters C INTEGER NF_OFF !Offset between start of slow rasters in image C INTEGER IXROOT !Root window x position for popup notice C INTEGER IYROOT !Root window y position for popup notice C INTEGER IFLAG !Parameter status flag C INTEGER ND !No. of decimal places flag C INTEGER IORDER !Axis order flag C INTEGER ISWAP !Byte swap flag C INTEGER IYN !Yes/no flag C INTEGER LISTE(2) !List of parameter table 1 entries to be updated C INTEGER KPACK !Pack number, 0 = all packs C INTEGER KPLATE !Plate number, 0 = all plates C INTEGER MINDX_SPOT !Index for spots list in memory records C INTEGER NPBOX !Box size for background searches C INTEGER IPCNT !Percent threshold for background points C INTEGER NUMB_L(64) !Spot length analysis parameters C INTEGER NREJ_L(64) !" C INTEGER NGOOD_L(64) !" C INTEGER NUMB_W(64) !Spot width analysis parameters C INTEGER NREJ_W(64) !" c INTEGER NGOOD_W(64) !" C INTEGER NSPOT !No. of spots found C INTEGER IBUF(7) !Buffer for spot list record C REAL X_CEN_F !X centre C REAL Y_CEN_F !Y centre C REAL W_F !Omega C REAL MM_RAST_X !Conversion mm to x-rasters C REAL MM_RAST_Y !Conversion mm to y-rasters C REAL SPOTL !Spot length C REAL SPOTW !Spot width C REAL X_C !x_c in mm C REAL Y_C !y_c in mm C REAL XCEN !X centre (corrected) in rasters C REAL YCEN !Y centre (corrected) in rasters C REAL RMIN !RMIN parameter converted to rasters C REAL RMAX !RMAX parameter converted to rasters C REAL XLOW !Low x limit in rasters C REAL XHIGH !High x limit in rasters C REAL YLOW !Low y limit in raster C REAL YHIGH !High y limit in rasters C REAL REXCLUDE !Exclusion adjustment to RMIN, RMAX (rasters) C REAL SEL_LEN !Determined spot length (rasters) C REAL SEL_WID !Determined spot width (rasters) C REAL SPT_LEN !Spot length (proposed) in mm C REAL SPT_WID !Spot width (proposed) in mm C REAL VAL !Real value C REAL BIN_S_L(64) !Spot length analysis parameters C REAL BIN_E_L(64) !" C REAL SUM_L (64) !" C REAL VAR_L(64) !" C REAL SDEV_L(64) !" C REAL AVE_L(64) !" C REAL SGOOD_L(64) !" C REAL BIN_S_W(64) !Spot width analysis parameters C REAL BIN_E_W(64) !" C REAL SUM_W (64) !" C REAL VAR_W(64) !" C REAL SDEV_W(64) !" C REAL AVE_W(64) !" C REAL SGOOD_W(64) !" C REAL SX !Spot 'x' position in rasters C REAL SY !Spot 'y' position in rasters C REAL SIZ !Temporary spot size C REAL Y_SCL_MAX !Spot size maximum for o/p histograms C CHARACTER*2 VALSTR !Parameter value string (dummy) C CHARACTER*80 ERRSTR !Error message string C CHARACTER*120 STR !Message string C CHARACTER*25 NAMES(5) !Menu item names C CHARACTER*25 QUITNAM !Quit button string EQUIVALENCE (SX,IBUF(1)), (SY,IBUF(2)) DATA NAMES /'Show Spots on Image', + 'Spot Length Histogram', + 'Spot Width Histogram', + 'Accept New Spot Size', + 'Input Another Size'/ DATA QUITNAM /'Return to Previous Menu'/ C C------------------------------------------------------------------------------- C C====== Initialisations C KQUIT = 0 MINDX_SPOT = -1 C C====== Open film/image-plate file if needed C CALL CHK_OPN(IERR) IF (IERR.GT.0) THEN KQUIT = 1 RETURN END IF C C====== Read image if not already read C IF (.NOT.FILM_READ) CALL READ_IMAGE (0, IMG, MAX_IMG_WORDS, + ITYPE, NF_OFF, JERR, ERRSTR) IF (.NOT.FILM_READ) THEN KQUIT = 1 RETURN END IF C C====== Get progress bar position C CALL XDLF_VIEW_OBJECT_ROOTXY (IVH_IOW,20,20, + IBG_PROGX,IBG_PROGY,IERR) PROG_BG_ON = .FALSE. NPBOX = 2 * ((NFRASTS/NCMP)/50) + 1 IPCNT = 50 CALL XDLF_BG_CALC_PROG (IMG, ITYPE, NSRASTS, NFRASTS, NFRASTS, + NCMP, NPBOX, -IPCNT, IMG_BG, NF_BGOFF, + BG_PROGRESS, BG_DUMMY_CNCL, IERR) IF (PROG_BG_ON) CALL XDLF_DELETE_VIEW_OBJECT (IVH_BAR, IERR) IF (IERR.EQ.2) THEN CALL LMESSAGE (IVH_IOW, '**Search box too big for image**') KQUIT = 1 RETURN END IF CALL FILM_CENTRE (X_CEN_F, Y_CEN_F, W_F) CALL LDM_GET_XC (IPACK, IPLATE, X_C, IFLAG, ND, IERR, ERRSTR) CALL LDM_GET_YC (IPACK, IPLATE, Y_C, IFLAG, ND, IERR, ERRSTR) C C====== Get some image related details C CALL LDM_GET_NXRAS (NXRAST, IFLAG) CALL LDM_GET_NYRAS (NYRAST, IFLAG) CALL LDM_GET_AXORD (VALSTR, IORDER, ISWAP, IFLAG) CALL LDM_MMRAST (IPACK, IPLATE, MM_RAST_X, MM_RAST_Y) CALL LDM_GET_RMIN (RMIN, IFLAG, ND) RMIN = RMIN*MM_RAST_X CALL LDM_GET_RMAX (RMAX, IFLAG, ND) RMAX = RMAX*MM_RAST_X CALL LDM_GET_XLOW (XLOW, IFLAG, ND) CALL LDM_GET_XHIGH (XHIGH, IFLAG, ND) CALL LDM_GET_YLOW (YLOW, IFLAG, ND) CALL LDM_GET_YHIGH (YHIGH, IFLAG, ND) XCEN = X_CEN_F + X_C*MM_RAST_X YCEN = Y_CEN_F + Y_C*MM_RAST_Y C C====== Get progress bar position C CALL XDLF_VIEW_OBJECT_ROOTXY (IVH_IOW,20,20, + ISP_PROGX,ISP_PROGY,IERR) PROG_BAR = .FALSE. C C====== Check that not too many rasters C IF (NXRAST.GT.MAX_RASTS.OR.NYRAST.GT.MAX_RASTS) THEN CALL ERR_NOTICE (1, + '**Too many rasters in image for spot search**') KQUIT = 1 RETURN END IF C C====== Determine the spot sizes C NF_OFF = NFRASTS REXCLUDE = FLOAT(NPBOX*NCMP)/SQRT(2.0) CALL LFN_FINDSPOTS (IMG, ITYPE, IORDER, NF_OFF, + NXRAST, NYRAST, IMG_BG, NF_BGOFF, + NCMP, ISP_DATA, ISP_WORK, XCEN, YCEN, + RMIN, RMAX, + XLOW, XHIGH, YLOW, YHIGH, REXCLUDE, + SPOT_THRFAC, + SPOT_PROGRESS, LFN_DUMMY_CNCL, + MINDX_SPOT, NSPOT, IERR, ERRSTR) IF (IERR.NE.0) THEN STR = '**Error**' CALL STR_ADDS (STR, ERRSTR, 1) CALL LMESSAGE (IVH_IOW, STR) KQUIT = 1 RETURN END IF IF (NSPOT.EQ.0) THEN CALL ERR_NOTICE(1,'**No spots found**') KQUIT = 1 RETURN END IF STR = 'Number of spots found =' CALL STR_ADDI (STR, NSPOT, 1) CALL LMESSAGE (IVH_IOW, STR) CALL LFN_SPOTS_ANALYSE (MINDX_SPOT, 1, SPOT_SDCUT, ISPOT_NBIN, + BIN_S_L, BIN_E_L, SUM_L, NUMB_L, + VAR_L, SDEV_L, AVE_L, NREJ_L, SGOOD_L, + NGOOD_L, SEL_LEN, IERR, ERRSTR) CALL LFN_SPOTS_ANALYSE (MINDX_SPOT, 2, SPOT_SDCUT, ISPOT_NBIN, + BIN_S_W, BIN_E_W, SUM_W, NUMB_W, + VAR_W, SDEV_W, AVE_W, NREJ_W, SGOOD_W, + NGOOD_W, SEL_WID, IERR, ERRSTR) SPT_LEN = SPOT_EXPAND*SEL_LEN/MM_RAST_X SPT_WID = SPOT_EXPAND*SEL_WID/MM_RAST_X STR = 'Proposed spot dimensions are' CALL STR_ADDF(STR, SPOT_EXPAND, 2, 1) CALL STR_ADDS(STR, '*average determined dimensions',0) CALL LMESSAGE(IVH_IOW, STR) STR = 'Value proposed for spot length =' CALL STR_ADDF (STR, SPT_LEN, 2, 1) CALL STR_ADDS (STR, 'mm.', 1) CALL LMESSAGE(IVH_IOW, STR) STR = 'Value proposed for spot width =' CALL STR_ADDF (STR, SPT_WID, 2, 1) CALL STR_ADDS (STR, 'mm.', 1) CALL LMESSAGE(IVH_IOW, STR) IF (IUN_LOG.GT.0) WRITE(IUN_LOG,'('' '')') IF (IUN_LOG.GT.0) CALL LFN_SPOTS_ANA_LIS (IUN_LOG, 0, 1, + ISPOT_NBIN, BIN_S_L, BIN_E_L, SGOOD_L, + NGOOD_L, NREJ_L, SEL_LEN, 1.0/MM_RAST_X, + SPOT_THRFAC, SPOT_SDCUT, SPOT_EXPAND, + IPACK, IPLATE) IF (IUN_LOG.GT.0) CALL LFN_SPOTS_ANA_LIS (IUN_LOG, 0, 2, + ISPOT_NBIN, BIN_S_W, BIN_E_W, SGOOD_W, + NGOOD_W, NREJ_W, SEL_WID, 1.0/MM_RAST_X, + SPOT_THRFAC, SPOT_SDCUT, SPOT_EXPAND, + IPACK, IPLATE) C C====== Get maximum spot size for histograms rounded up to next mm. C Y_SCL_MAX = 0.0 DO 10 I = 1, ISPOT_NBIN IF (NGOOD_L(I).GT.0) THEN SIZ = SPOT_EXPAND*SGOOD_L(I)/NGOOD_L(I) SIZ = SIZ/MM_RAST_X IF (SIZ.GT.Y_SCL_MAX) Y_SCL_MAX = SIZ END IF IF (NGOOD_W(I).GT.0) THEN SIZ = SPOT_EXPAND*SGOOD_W(I)/NGOOD_W(I) SIZ = SIZ/MM_RAST_X IF (SIZ.GT.Y_SCL_MAX) Y_SCL_MAX = SIZ END IF 10 CONTINUE Y_SCL_MAX = FLOAT(INT(1000*Y_SCL_MAX)/1000+1) C C====== Set some flags C GRAPH_DISP = .FALSE. IMAGE_DISP = .FALSE. ACCEPT = .FALSE. C C====== Output menu to service results C M_SHOW = 1 M_HIST_L = 2 M_HIST_W = 3 M_ACCEPT = 4 M_INPUT = 5 50 CALL XDLF_MENU_AREA_SETMENU (IVH_MENU, 5, XDLSTR(NAMES), 25, + XDLSTR('Spot Size Results Menu'), 22, + XDLSTR(QUITNAM), 25, 0, IERR) C C====== Set up list of view-object handles C NVIEW = 1 IVHLIST(1) = IVH_MENU C C====== Start event loop C 100 CALL XDLF_GET_EVENTS (NVIEW, IVHLIST, IVH) IF (IVH.EQ.IVH_MENU) THEN C C====== Menu item selected C CALL XDLF_MENU_AREA_GETITEM (IVH_MENU, ITEM, IQUIT) C C====== Quit selected C IF (IQUIT.EQ.1) THEN IF (.NOT.ACCEPT) THEN CALL YESNO_NOTICE (1, + 'No new value selected - still return?', IYN) IF (IYN.EQ.2) GO TO 100 IF (IUN_LOG.GT.0) WRITE(IUN_LOG,1020) END IF IF (GRAPH_DISP) THEN CALL XDLF_DELETE_VIEW_OBJECT (IVH_GRAPH, IERR) END IF IF (IMAGE_DISP) THEN CALL XDLF_DELETE_VIEW_OBJECT (IVH_FILM, IERR) END IF CALL DMLF_FREE (MINDX_SPOT, IERR) RETURN END IF C C====== Delete graph/image if present unless 'accept' or 'input option C IF (ITEM.NE.M_ACCEPT.AND.ITEM.NE.M_INPUT) THEN IF (GRAPH_DISP) THEN CALL XDLF_DELETE_VIEW_OBJECT (IVH_GRAPH, IERR) GRAPH_DISP = .FALSE. END IF IF (IMAGE_DISP) THEN CALL XDLF_DELETE_VIEW_OBJECT (IVH_FILM, IERR) IMAGE_DISP = .FALSE. END IF END IF C C====== Show spots on image C IF (ITEM.EQ.M_SHOW) THEN CALL SHOW_IMAGE (1, IERR) IF (IERR.NE.0) GO TO 100 IF (NSPOT.GT.0) THEN DO 120 I = 1, NSPOT CALL DMLF_GETREC(MINDX_SPOT,I,IBUF,IERR) CALL XDLF_IMAGE_SYMBOL (IVH_FILM, NINT(SX), NINT(SY), + ISYMBTYP(6), ICOLRTYP(6), 1, IERR) 120 CONTINUE END IF write(6,*)'******show spots here' IMAGE_DISP = .TRUE. GO TO 100 C C====== Output spot length histogram C ELSE IF (ITEM.EQ.M_HIST_L) THEN CALL SPOT_HIST (1, ISPOT_NBIN, + NGOOD_L, SGOOD_L, 1.0/MM_RAST_X, SPOT_EXPAND, + SEL_LEN, Y_SCL_MAX) GRAPH_DISP = .TRUE. GO TO 100 C C====== Output spot width histogram C ELSE IF (ITEM.EQ.M_HIST_W) THEN CALL SPOT_HIST (2, ISPOT_NBIN, + NGOOD_W, SGOOD_W, 1.0/MM_RAST_X, SPOT_EXPAND, + SEL_WID, Y_SCL_MAX) GRAPH_DISP = .TRUE. GO TO 100 C C====== Accept value C ELSE IF (ITEM.EQ.M_ACCEPT) THEN CALL LDM_SET_SPOTL (IPACK, IPLATE, SPT_LEN, IERR, ERRSTR) IF (IERR.NE.0) THEN STR = '**Error**' CALL STR_ADDS (STR,ERRSTR,1) CALL ERR_NOTICE (1,STR) GO TO 100 END IF CALL LDM_SET_SPOTW (IPACK, IPLATE, SPT_WID, IERR, ERRSTR) IF (IERR.NE.0) THEN STR = '**Error**' CALL STR_ADDS (STR,ERRSTR,1) CALL ERR_NOTICE (1,STR) GO TO 100 END IF ACCEPT = .TRUE. LISTE(1) = IP_STRK_L LISTE(2) = IP_STRK_W CALL SET_PAR2_VALS (2, LISTE) CALL OTHERS_UPD (1, UPD_SPOT, KPACK, KPLATE) CALL LDM_SET_SPOTL (KPACK, KPLATE, SPT_LEN, IERR, ERRSTR) CALL LDM_SET_SPOTW (KPACK, KPLATE, SPT_WID, IERR, ERRSTR) IF (IUN_LOG.GT.0) WRITE(IUN_LOG,1000) GO TO 100 C C====== Input other values C ELSE IF (ITEM.EQ.M_INPUT) THEN IF (GRAPH_DISP.OR.IMAGE_DISP) THEN CALL XDLF_VIEW_OBJECT_RAISE (IVH_BASE, IERR) END IF 200 VAL = SPT_LEN CALL IOW_ASKF (IVH_IOW,'Input value for spot length (mm)', + VAL, 2) CALL LDM_SET_SPOTL (IPACK, IPLATE, VAL, IERR, ERRSTR) IF (IERR.NE.0) THEN STR = '**Error**' CALL STR_ADDS (STR,ERRSTR,1) CALL LMESSAGE (IVH_IOW, STR) GO TO 200 END IF SPOTL = VAL 210 VAL = SPT_WID CALL IOW_ASKF (IVH_IOW,'Input value for spot width (mm)', + VAL, 2) CALL LDM_SET_SPOTW (IPACK, IPLATE, VAL, IERR, ERRSTR) IF (IERR.NE.0) THEN STR = '**Error**' CALL STR_ADDS (STR,ERRSTR,1) CALL LMESSAGE (IVH_IOW, STR) GO TO 210 END IF SPOTW = VAL ACCEPT = .TRUE. LISTE(1) = IP_STRK_L LISTE(2) = IP_STRK_W CALL SET_PAR2_VALS (2, LISTE) CALL OTHERS_UPD (1, UPD_SPOT, KPACK, KPLATE) CALL LDM_SET_SPOTL (KPACK, KPLATE, SPOTL, IERR, ERRSTR) CALL LDM_SET_SPOTW (KPACK, KPLATE, SPOTW, IERR, ERRSTR) IF (IUN_LOG.GT.0) THEN STR = 'New value for spot length input as' CALL STR_ADDF(STR,SPOTL,2,1) WRITE(IUN_LOG,1010) STR STR = 'New value for spot width input as' CALL STR_ADDF(STR,SPOTW,2,1) WRITE(IUN_LOG,1010) STR END IF IF (GRAPH_DISP) THEN CALL XDLF_VIEW_OBJECT_RAISE (IVH_GRAPH, IERR) END IF IF (IMAGE_DISP) THEN CALL XDLF_VIEW_OBJECT_RAISE (IVH_FILM, IERR) END IF GO TO 100 END IF END IF GO TO 100 C C====== Format statements C 1000 FORMAT('New values of spot length and spot width accepted',/) 1010 FORMAT(/,A) 1020 FORMAT('No new values of spot length and width accepted',/) END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C*************************** C** SPOTSIZE_DFLTS ** C*************************** C C SUBROUTINE SPOTSIZE_DFLTS (NBIN, SDCUT, THRFAC, EXPAND) C INCLUDE 'implicit_none.finc' C C Purpose: Default parameters for spot sizes calculation routine C C Author: John W. Campbell, September 1995 C C Arguments: C INTEGER NBIN REAL SDCUT REAL THRFAC REAL EXPAND C C NBIN (W) No. of bins for analysis C SDCUT (W) Standard deviation cutoff level for 'good' spots C THRFAC (W) Spot threshold above background factor C EXPAND (W) Expand factor from average measured to proposed spot size C C====== Parameter statements C C C====== GLOBALS: C C C====== FUNCTION TYPES: C C C====== LOCALS: C C C------------------------------------------------------------------------------- C NBIN = 12 SDCUT = 3.5 THRFAC = 2.0 EXPAND = 1.5 RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** WRITE_GEFILE ** C************************** C C SUBROUTINE WRITE_GEFILE (IPACK, IUN_GE1, IUN_GE2, WR_SPAT, + WR_CLOS, DISTOR, MININT, PACK_ID, + KEYPLATE, NUM_SPOTS, NUM_MULTIPLETS, + NUM_SPATIALS, NUM_BOTH, NUM_NODALS) C INCLUDE 'implicit_none.finc' C C Purpose: Write .ge1/.ge2 files C C Author: John W. Campbell, February 1992 C C Note: Output .ge1/.ge2 files must be opened before calling this C routine. They will be closed within this routine. C C Arguments: C INTEGER IPACK INTEGER IUN_GE1 INTEGER IUN_GE2 LOGICAL WR_SPAT LOGICAL WR_CLOS LOGICAL DISTOR INTEGER MININT INTEGER PACK_ID INTEGER KEYPLATE INTEGER NUM_SPOTS INTEGER NUM_MULTIPLETS INTEGER NUM_SPATIALS INTEGER NUM_NODALS INTEGER NUM_BOTH C C IPACK (R) Pack number C IUN_GE1 (R) Unit no. for .ge1 file (already opened) C IUN_GE2 (R) Unit no. for .ge2 file (already opened) C WR_SPAT (R) Write spatials flag C WR_CLOS (R) Write too close spots flag C DISTOR (R) Apply distortion corrections to coordinates flag C MININT (R) Minimum intensity for subsequent films integration C PACK_ID (R) Pack identifier C KEYPLATE (R) Key plate no. C NUM_SPOTS (W) No. of spots written C NUM_MULTIPLETS (W) No. of multiplets C NUM_SPATIALS (W) No. of spatials C NUM_NODALS (W) No. nodals C NUM_BOTH (W) No. both spatial & multiple C C====== Parameter statements C C C====== LOCALS: C LOGICAL SPAT, CLOS, NODFLG INTEGER NODAL_INDEX INTEGER CURRENT_REFLEX, I, J INTEGER II, JJ, KK INTEGER IERR, KERR, IFLAG, ND INTEGER ISPOT, NUMSPOTS INTEGER IBEAM, IROT, DISTOR_TYPE INTEGER LINK_REC INTEGER BINTENS(6), BSIGS(6), PINTENS(6), PSIGS(6) INTEGER M_FLAG, H, K, L, NODIDX, H2, K2, L2 INTEGER IREAL INTEGER IH,IK,IL INTEGER GE1_REC, GE2_REC INTEGER MULTIPLICITY, IX, IY, HKLPAK INTEGER JPACK, NFILM INTEGER MULTI_BINS(21) INTEGER BUFFER(19), BUFFER2(2), MM INTEGER MHKL(4), HKL2(4) INTEGER NODAL_BINS(12) INTEGER BOX(5) INTEGER LAMBDA_BINS(16) INTEGER ISYLAT(2), ISL INTEGER IFAIL, NSING, NSINGOV INTEGER ISYST, LATT INTEGER H_N, K_N, L_N, MINH, MAXH, INCH REAL ALNOD, DTHRNOD REAL CTOF_RATS(6), CTOF REAL PHIS(3), SPINDLE, CTOF_KEYPLATE, DELTA, EPSILON REAL X_C(6), Y_C(6), W_C(6), Y_SCALE(6) REAL TWIST(6), TILT(6), BULGE(6) REAL WMIN, WMAX, DMIN, FILMR REAL RINT REAL BX, BY, BDMIN2 REAL LAMBDA1, LAMBDA2 REAL X_CEN_FS(6) REAL Y_CEN_FS(6) REAL W_FS(6) REAL RCELL(6), CELLC(6), CELL(6) REAL MM_RAST_X, MM_RAST_Y CHARACTER*80 STR, COMPOUND CHARACTER*6 CRYST CHARACTER*2 VALSTR, ERRSTR EQUIVALENCE (IREAL, RINT) EQUIVALENCE (BUFFER(1),BX) EQUIVALENCE (BUFFER(2),BY) EQUIVALENCE (BUFFER(16),LAMBDA1) EQUIVALENCE (BUFFER(18),LAMBDA2) EQUIVALENCE (BUFFER(19),BDMIN2) EQUIVALENCE (MHKL(1),M_FLAG) EQUIVALENCE (MHKL(2),H) EQUIVALENCE (MHKL(3),K) EQUIVALENCE (MHKL(4),L) EQUIVALENCE (HKL2(1),NODIDX) EQUIVALENCE (HKL2(2),H2) EQUIVALENCE (HKL2(3),K2) EQUIVALENCE (HKL2(4),L2) EQUIVALENCE (BUFFER2(2),LAMBDA1) DATA BINTENS, BSIGS, PINTENS, PSIGS /6*-9999, 6*-9999, + 6*-9999, 6*-9999/ C C------------------------------------------------------------------------------ C C C====== Put initialised intensity/sigma values in reflection record buffer C CALL CCPII2(BUFFER(3),BINTENS,6,.TRUE.,.FALSE.) CALL CCPII2(BUFFER(6),BSIGS,6,.TRUE.,.FALSE.) CALL CCPII2(BUFFER(9),PINTENS,6,.TRUE.,.FALSE.) CALL CCPII2(BUFFER(12),PSIGS,6,.TRUE.,.FALSE.) C C====== Zero histograms C NUM_SPOTS = 0 NUM_SPATIALS = 0 NUM_MULTIPLETS = 0 NUM_BOTH = 0 NUM_NODALS = 0 DO 20 I = 1 , 21 MULTI_BINS(I) = 0 20 CONTINUE NSING = 0 NSINGOV = 0 DO 30 I = 1 , 12 NODAL_BINS(I) = 0 30 CONTINUE C C====== Now write .ge1/.ge2 files C GE1_REC = 10 GE2_REC = 0 CALL LRL_GEN (IPACK, 1, DISTOR, 2, IERR, ERRSTR) CALL LRL_NUMSPOTS (NUMSPOTS) DO 40 ISPOT = 1 , NUMSPOTS CALL LRL_GET (ISPOT, H, K, L, BX, BY, LAMBDA1, BDMIN2, + MULTIPLICITY, NODFLG, SPAT, KERR) CALL LRL_GET_XFYFD (ISPOT, BX, BY, KERR) CALL LRL_GET_OVLP (ISPOT, SPAT, CLOS, KERR) M_FLAG = 0 H2 = 0 K2 = 0 L2 = 0 CALL STBITS (M_FLAG,0,5,MULTIPLICITY) IF (SPAT.OR.CLOS) CALL STBITS (M_FLAG,6,1,1) IF (CLOS) CALL STBITS (M_FLAG,7,1,1) IF (NODFLG) CALL STBITS (M_FLAG,5,1,1) IF ((.NOT.SPAT .OR. WR_SPAT) .AND. + (.NOT.CLOS .OR. WR_CLOS)) THEN IF (MULTIPLICITY.EQ.1) THEN C C====== Now write out .ge1 record for the single C GE1_REC = GE1_REC + 1 IF (NODFLG) THEN NUM_NODALS = NUM_NODALS + 1 IH = H IK = K IL = L NODIDX = NODAL_INDEX(IH,IK,IL) NODAL_BINS(NODIDX) = NODAL_BINS(NODIDX) + 1 ELSE NODIDX = 0 END IF LAMBDA2 = 0.0 CALL CCPIBY(BUFFER(15),MHKL,-4) CALL CCPIBY(BUFFER(17),HKL2,-4) WRITE (IUN_GE1,REC=GE1_REC) BUFFER MULTI_BINS(1) = MULTI_BINS(1) + 1 NSING = NSING + 1 IF (SPAT) NUM_SPATIALS = NUM_SPATIALS + 1 ELSE C C====== Multiple C CALL LRL_GET_HARM (ISPOT, H, K, L, H_N, K_N, L_N, + MULTIPLICITY, MINH, MAXH, INCH, + ALNOD, DTHRNOD, IERR) H2 = (MINH+INCH)*H_N K2 = (MINH+INCH)*K_N L2 = (MINH+INCH)*L_N LAMBDA2 = ALNOD/(MINH+INCH) BDMIN2 = DTHRNOD/(MINH) C C====== Update histogram C I = MIN(MULTIPLICITY,21) MULTI_BINS(I) = MULTI_BINS(I) + 1 NUM_MULTIPLETS = NUM_MULTIPLETS + 1 IF (NODFLG) THEN NUM_NODALS = NUM_NODALS + 1 IH = H IK = K IL = L NODIDX = NODAL_INDEX(IH,IK,IL) NODAL_BINS(NODIDX) = NODAL_BINS(NODIDX) + 1 ELSE NODIDX = 0 END IF IF (SPAT) THEN NUM_SPATIALS = NUM_SPATIALS + 1 IF (MULTIPLICITY.GT.1) NUM_BOTH = NUM_BOTH + 1 END IF C C====== Now write out .ge1 record for the multiplet C GE1_REC = GE1_REC + 1 CALL CCPIBY(BUFFER(15),MHKL,-4) CALL CCPIBY(BUFFER(17),HKL2,-4) IF (MULTIPLICITY.LE.2) THEN WRITE (IUN_GE1,REC=GE1_REC) BUFFER ELSE LINK_REC = GE2_REC + 1 IREAL = LINK_REC LAMBDA2 = RINT WRITE (IUN_GE1,REC=GE1_REC) BUFFER C C====== Write out consecutive records to .ge2 file C DO 80 I = 2 , MULTIPLICITY H = (MINH+(I-1)*INCH)*H_N K = (MINH+(I-1)*INCH)*K_N L = (MINH+(I-1)*INCH)*L_N LAMBDA1 = ALNOD/(MINH+(I-1)*INCH) GE2_REC = GE2_REC + 1 CALL CCPIBY(BUFFER2(1),MHKL,-4) WRITE (IUN_GE2,REC=GE2_REC) BUFFER2 80 CONTINUE END IF ENDIF END IF 40 CONTINUE C C====== Finally write out header info, number of spots output C 90 JPACK = 0 NFILM = 0 NUM_SPOTS = GE1_REC - 10 WRITE (IUN_GE1,REC=9) JPACK , NFILM , NUM_SPOTS C C====== Calc cumulative totals C DO 110 I = 1 , 11 NODAL_BINS(I+1) = NODAL_BINS(I+1) + NODAL_BINS(I) 110 CONTINUE C C====== Now write out header C CALL LDM_MMRAST (IPACK, 1, MM_RAST_X, MM_RAST_Y) DO 660 II=1,19 BUFFER(I) = 0 660 CONTINUE DO 666 II=1,6 CALL LDM_GET_XCENF (IPACK, II, X_CEN_FS(II), IFLAG, ND, + IERR, ERRSTR) CALL LDM_GET_YCENF (IPACK, II, Y_CEN_FS(II), IFLAG, ND, + IERR, ERRSTR) W_FS(II) = 0.0 666 CONTINUE CALL LDM_GET_TITLE(COMPOUND, IFLAG) WRITE (IUN_GE1,REC=1) COMPOUND(1:76) CALL LDM_GET_CRYST (CRYST, IFLAG) WRITE (IUN_GE1,REC=2) CRYST , + (X_CEN_FS(II)/MM_RAST_X,II=1,6), + (Y_CEN_FS(JJ)/MM_RAST_Y,JJ=1,6), + (W_FS(I),I=1,5) CALL LDM_GET_SYST (VALSTR, ISYST, IFLAG) CALL LDM_GET_LATT (VALSTR, LATT, IFLAG) ISYLAT(1) = ISYST ISYLAT(2) = LATT CALL CCPII2(ISL,ISYLAT,2,.TRUE.,.FALSE.) CALL LDM_GET_A (CELL(1), IFLAG, ND) CALL LDM_GET_B (CELL(2), IFLAG, ND) CALL LDM_GET_C (CELL(3), IFLAG, ND) CALL LDM_GET_ALPHA (CELL(4),IFLAG, ND) CALL LDM_GET_BETA (CELL(5), IFLAG, ND) CALL LDM_GET_GAMMA (CELL(6), IFLAG, ND) CALL RECCEL(RCELL,CELL,1.0) CALL CELLCX(ISYST,CELLC,RCELL,2,2) CALL LDM_GET_BEAM (VALSTR, IBEAM, IFLAG) CALL LDM_GET_ROT (VALSTR, IROT, IFLAG) WRITE (IUN_GE1,REC=3) W_FS(6) , (BUFFER(I),I=1,9) , CELLC , + ISL, IBEAM, IROT C C====== Initialise integration box parameters C CALL LDM_GET_SPOTD (IPACK, KEYPLATE, DELTA, IFLAG, ND, IERR, + ERRSTR) BOX(1) = DELTA*MM_RAST_X + 1 C C====== Force box size to be odd. C IF (MOD(BOX(1),2).EQ.0) BOX(1) = BOX(1) + 1 BOX(2) = BOX(1) C C====== Cut off a corner 1/4 way along. C BOX(3) = BOX(1)/4 BOX(4) = 1 BOX(5) = BOX(4) CALL LDM_GET_PHIX (IPACK, PHIS(1), IFLAG, ND, IERR, ERRSTR) CALL LDM_GET_PHIY (IPACK, PHIS(2), IFLAG, ND, IERR, ERRSTR) CALL LDM_GET_PHIZ (IPACK, PHIS(3), IFLAG, ND, IERR, ERRSTR) CALL LDM_GET_LMIN (IPACK, WMIN, IFLAG, ND, IERR, ERRSTR) CALL LDM_GET_LMAX (IPACK, WMAX, IFLAG, ND, IERR, ERRSTR) CALL LDM_GET_DMIN (IPACK, DMIN, IFLAG, ND, IERR, ERRSTR) CALL LDM_GET_SPIN (IPACK, SPINDLE, IFLAG, ND, IERR, ERRSTR) CALL LDM_GET_RMAX (FILMR, IFLAG, ND) WRITE (IUN_GE1,REC=4) 1.0/MM_RAST_X, BOX , + (BUFFER(I),I=1,4) , PHIS , + 1.0 , WMIN , WMAX , DMIN , + FILMR , SPINDLE DO 777 II = 1, 6 CALL LDM_GET_XC (IPACK, II, X_C(II), IFLAG, ND, + IERR, ERRSTR) CALL LDM_GET_YC (IPACK, II, Y_C(II), IFLAG, ND, + IERR, ERRSTR) CALL LDM_GET_WC (IPACK, II, W_C(II), IFLAG, ND, + IERR, ERRSTR) 777 CONTINUE WRITE (IUN_GE1,REC=5) (X_C(II),II=1,6), + (Y_C(JJ),JJ=1,6), + (W_C(KK),KK=1,6), + DELTA C C====== Calculate cryst-film ratios C CTOF_RATS(KEYPLATE) = 1.0 CALL LDM_GET_CTOF (IPACK, KEYPLATE, CTOF_KEYPLATE, IFLAG, ND, + IERR, ERRSTR) DO 330 I = 1 , 6 CALL LDM_GET_CTOF (IPACK, I, CTOF, IFLAG, ND, IERR, ERRSTR) CTOF_RATS(I) = CTOF/CTOF_KEYPLATE 330 CONTINUE CALL LDM_GET_DSTOR (VALSTR, DISTOR_TYPE, IFLAG) DO 333 I = 1, 6 CALL LDM_GET_TWIST (IPACK, I, TWIST(I), IFLAG, ND, IERR, + ERRSTR) CALL LDM_GET_TILT (IPACK, I, TILT(I), IFLAG, ND, IERR, ERRSTR) IF (DISTOR_TYPE.EQ.1) THEN CALL LDM_GET_BULGE (IPACK, I, BULGE(I), IFLAG, ND, + IERR, ERRSTR) ELSE BULGE(I) = 0.0 END IF 333 CONTINUE WRITE (IUN_GE1,REC=6) (TWIST(II),II=1,6), + (TILT(JJ),JJ=1,6), + (BULGE(KK),KK=1,6), + CTOF_KEYPLATE DO 334 I = 1, 6 CALL LDM_GET_YSCAL (IPACK, I, Y_SCALE(I), IFLAG, ND, IERR, + ERRSTR) 334 CONTINUE CALL LDM_GET_EPS (EPSILON, IFLAG, ND) WRITE (IUN_GE1,REC=7) (Y_SCALE(II),II=1,6), + CTOF_RATS , MININT , EPSILON WRITE (IUN_GE1,REC=8) (MULTI_BINS(I),I=1,19) CALL LAM_HIST(LAMBDA_BINS) WRITE (IUN_GE1,REC=9) (MULTI_BINS(I),I=20,21) , + (LAMBDA_BINS(I),I=1,16) , 2 WRITE (IUN_GE1,REC=10) PACK_ID , NUM_SPOTS , NUM_MULTIPLETS , + NUM_SPATIALS, NUM_BOTH , NUM_NODALS, + NODAL_BINS C C====== Close .ge1/.ge2 files C CLOSE (UNIT=IUN_GE1) CLOSE (UNIT=IUN_GE2) RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** WRITE_GENFIL ** C************************** C C SUBROUTINE WRITE_GENFIL C INCLUDE 'implicit_none.finc' C C Purpose: Write a .gen file C C Author: John W. Campbell, February 1992 C C Note: File must be opened and closed outside this routine C C Arguments: C C None C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'file_units.finc' INCLUDE 'film_pack.finc' C C====== FUNCTION TYPES: C INTEGER LENSTR C C====== LOCALS: C INTEGER I INTEGER NCP(7) INTEGER IFLAG INTEGER ND INTEGER IERR INTEGER ISYST INTEGER LATT INTEGER IBEAM INTEGER IROT INTEGER DISTOR_TYPE INTEGER NFID INTEGER N1OD INTEGER NXRAST INTEGER NYRAST INTEGER IFLIP INTEGER NSPDX INTEGER NSPDY REAL SPDXY REAL SPDX_MIN REAL SPDX_MAX REAL SPDY_MIN REAL SPDY_MAX REAL SPDX(100) REAL SPDY(100) REAL CELL(6) REAL RCELL(6) REAL CELLC(6) REAL PHIS(3) REAL SPINDLE REAL WMIN REAL WMAX REAL CTOF REAL DMIN REAL FILMR REAL X_C REAL Y_C REAL W_C REAL TWIST REAL TILT REAL BULGE REAL ROFF REAL TOFF REAL Y_SCALE REAL RMIN REAL FIDX1 REAL FIDY1 REAL FIDX2 REAL FIDY2 REAL FIDX3 REAL FIDY3 REAL FIDBOX REAL G1OD REAL BASEOD REAL CURV REAL XCENF REAL YCENF REAL RASTER REAL XLOW REAL XHIGH REAL YLOW REAL YHIGH CHARACTER*80 CELINF CHARACTER*12 FLIP(3) CHARACTER*5 SYSTYP(7) CHARACTER*4 AXTYP(7) CHARACTER*1 LATT_STR(7) CHARACTER*2 ERRSTR CHARACTER*80 STR C INTEGER I !Temp/loop variable C INTEGER NCP(7) !No. of unique cell parameters C INTEGER IFLAG !Parameter status flag C INTEGER ND !No. of decimal places flag C INTEGER IERR !Error flag C INTEGER ISYST !Crystal system C INTEGER LATT !Lattice type C INTEGER IBEAM !Beam axis C INTEGER IROT !Rotation axis C INTEGER DISTOR_TYPE !Distortion type C INTEGER NFID !No. of fiducials C INTEGER N1OD !Film n1od C INTEGER NXRAST !No. x-rasters C INTEGER NYRAST !No. y-rasters C INTEGER IFLIP !Film/image-plate flag C INTEGER NSPDX !Polynomial order spd correction C INTEGER NSPDY !Polynomial order spd correction C REAL SPDXY !xy spd correction C REAL SPDX_MIN !Bound spd correction C REAL SPDX_MAX !Bound spd correction C REAL SPDY_MIN !Bound spd correction C REAL SPDY_MAX !Bound spd correction C REAL SPDX(100) !Polynomial spd correction C REAL SPDY(100) !Polynomial spd correction C REAL CELL(6) !Real cell C REAL RCELL(6) !Reciprocal cell C REAL CELLC(6) !Compressed cell C REAL PHIS(3) !Missetting angles C REAL SPINDLE !Spindle angle C REAL WMIN !Lambda-min C REAL WMAX !Lambda-max C REAL CTOF !Crystal-film distance C REAL DMIN !'dmin' C REAL FILMR !Film radius C REAL X_C !Camera constant x_c C REAL Y_C !Camera constant y_c C REAL W_C !Camera constant w_c C REAL TWIST !Twist C REAL TILT !Tilt C REAL BULGE !Bulge C REAL ROFF !MAR Roff C REAL TOFF !MAR Toff C REAL Y_SCALE !'y_scale' C REAL RMIN !'rmin' C REAL FIDX1 !Fiducials C REAL FIDY1 ! " C REAL FIDX2 ! " C REAL FIDY2 ! " C REAL FIDX3 ! " C REAL FIDY3 ! " C REAL FIDBOX !Fiducials box search size C REAL G1OD !Film g1od C REAL BASEOD !Film baseod C REAL CURV !Film non-linearity C REAL XCENF !Image x-centre C REAL YCENF !Image y-centre C REAL RASTER !Raster size C REAL XLOW !Area limit xlow C REAL XHIGH !Area limit xhigh C REAL YLOW !Area limit ylow C REAL YHIGH !Area limit yhigh C CHARACTER*80 CELINF !Cell information string C CHARACTER*12 FLIP(3) !Film/image-plate flags C CHARACTER*5 SYSTYP(7) !Crystal system strings C CHARACTER*4 AXTYP(7) !Axis strings C CHARACTER*1 LATT_STR(7) !Lattice type strings C CHARACTER*2 ERRSTR !Error string (dummy) C CHARACTER*80 STR !Temp string DATA NCP/6,4,3,2,2,2,1/ DATA FLIP /'film','image-plate',' '/ DATA SYSTYP/'TRICL','MONOC','ORTHO','TETRA','HEXAG','RHOMB', + 'CUBIC'/ DATA AXTYP/'-cst','-bst','-ast',' ','+ast','+bst','+cst'/ DATA LATT_STR /'P','A','B','C','I','F','R'/ C C------------------------------------------------------------------------------- C CALL LDM_GET_TITLE (STR, IFLAG) WRITE (IUN_GEN,'(A)') STR(1:LENSTR(STR)) CALL LDM_GET_CRYST (STR, IFLAG) WRITE (IUN_GEN,'(A)') STR(1:LENSTR(STR)) CALL LDM_GET_SYST (STR, ISYST, IFLAG) CALL LDM_GET_LATT (STR, LATT, IFLAG) CALL LDM_GET_ROT (STR, IROT, IFLAG) CALL LDM_GET_BEAM (STR, IBEAM, IFLAG) CALL LDM_GET_A (CELL(1), IFLAG, ND) CALL LDM_GET_B (CELL(2), IFLAG, ND) CALL LDM_GET_C (CELL(3), IFLAG, ND) CALL LDM_GET_ALPHA (CELL(4), IFLAG, ND) CALL LDM_GET_BETA (CELL(5), IFLAG, ND) CALL LDM_GET_GAMMA (CELL(6), IFLAG, ND) CELINF = ' ' CALL RECCEL(RCELL,CELL,1.0) CALL CELLCX(ISYST,CELLC,RCELL,2,2) IF (ISYST.EQ.1) THEN WRITE (CELINF(1:60),'(3F10.7,3F10.5)') + (CELLC(I),I=1,NCP(ISYST)) ELSE IF (ISYST.EQ.2) THEN WRITE (CELINF(1:60),'(3F10.7,F10.5)') + (CELLC(I),I=1,NCP(ISYST)) ELSE IF (ISYST.EQ.3) THEN WRITE (CELINF(1:60),'(3F10.7)') (CELLC(I),I=1,NCP(ISYST)) ELSE IF (ISYST.EQ.4) THEN WRITE (CELINF(1:60),'(2F10.7)') (CELLC(I),I=1,NCP(ISYST)) ELSE IF (ISYST.EQ.5) THEN WRITE (CELINF(1:60),'(2F10.7)') (CELLC(I),I=1,NCP(ISYST)) ELSE IF (ISYST.EQ.6) THEN WRITE (CELINF(1:60),'(F10.5,F10.5)') + (CELLC(I),I=1,NCP(ISYST)) ELSE IF (ISYST.EQ.7) THEN WRITE (CELINF(1:60),'(F10.7)') (CELLC(I),I=1,NCP(ISYST)) END IF CELINF = CELINF(1:60)//' '//SYSTYP(ISYST) + //' '//LATT_STR(LATT) + //' '//AXTYP(IROT+4)//' '//AXTYP(IBEAM+4) WRITE (IUN_GEN,'(A)') CELINF CALL LDM_GET_PHIX (IPACK, PHIS(1), IFLAG, ND, IERR, ERRSTR) CALL LDM_GET_PHIY (IPACK, PHIS(2), IFLAG, ND, IERR, ERRSTR) CALL LDM_GET_PHIZ (IPACK, PHIS(3), IFLAG, ND, IERR, ERRSTR) WRITE (IUN_GEN,*) PHIS CALL LDM_GET_LMIN (IPACK, WMIN, IFLAG, ND, IERR, ERRSTR) CALL LDM_GET_LMAX (IPACK, WMAX, IFLAG, ND, IERR, ERRSTR) WRITE (IUN_GEN,*) 1.0, WMIN , WMAX CALL LDM_GET_CTOF (IPACK, 1, CTOF, IFLAG, ND, IERR, ERRSTR) CALL LDM_GET_DMIN (IPACK, DMIN, IFLAG, ND, IERR, ERRSTR) CALL LDM_GET_RMAX (FILMR, IFLAG, ND) WRITE (IUN_GEN,*) CTOF , DMIN , FILMR CALL LDM_GET_SPIN (IPACK, SPINDLE, IFLAG, ND, IERR, ERRSTR) WRITE (IUN_GEN,*) SPINDLE CALL LDM_GET_XC (IPACK, 1, X_C, IFLAG, ND, IERR, ERRSTR) CALL LDM_GET_YC (IPACK, 1, Y_C, IFLAG, ND, IERR, ERRSTR) CALL LDM_GET_WC (IPACK, 1, W_C, IFLAG, ND, IERR, ERRSTR) WRITE (IUN_GEN,*) X_C, Y_C, W_C CALL LDM_GET_DSTOR(STR, DISTOR_TYPE, IFLAG) CALL LDM_GET_TWIST (IPACK, 1, TWIST, IFLAG, ND, IERR, ERRSTR) CALL LDM_GET_TILT (IPACK, 1, TILT, IFLAG, ND, IERR, ERRSTR) IF (DISTOR_TYPE.EQ.1) THEN CALL LDM_GET_BULGE (IPACK, 1, BULGE, IFLAG, ND, IERR, ERRSTR) WRITE (IUN_GEN,*) TWIST, TILT, BULGE ELSE IF (DISTOR_TYPE.EQ.2) THEN CALL LDM_GET_ROFF (IPACK, 1, ROFF, IFLAG, ND, IERR, ERRSTR) CALL LDM_GET_TOFF (IPACK, 1, TOFF, IFLAG, ND, IERR, ERRSTR) WRITE (IUN_GEN,*) TWIST, TILT, ROFF, TOFF ELSE WRITE (IUN_GEN,*) TWIST, TILT, 0.0 END IF CALL LDM_GET_YSCAL (IPACK, 1, Y_SCALE, IFLAG, ND, IERR, ERRSTR) WRITE (IUN_GEN,*) Y_SCALE CALL LDM_GET_RMIN (RMIN, IFLAG, ND) WRITE (IUN_GEN,*) RMIN, 0.0 C C====== Convert fid posns to original units, uncentred. C CALL LDM_GET_FIDT (STR, NFID, IFLAG) IF (NFID.EQ.1) NFID = 3 IF (NFID.EQ.3) THEN CALL LDM_GET_FIDX1 (FIDX1, IFLAG, ND) CALL LDM_GET_FIDY1 (FIDY1, IFLAG, ND) CALL LDM_GET_FIDX2 (FIDX2, IFLAG, ND) CALL LDM_GET_FIDY2 (FIDY2, IFLAG, ND) CALL LDM_GET_FIDX3 (FIDX3, IFLAG, ND) CALL LDM_GET_FIDY3 (FIDY3, IFLAG, ND) WRITE (IUN_GEN,'(I2,3(2F8.1))') NFID, FIDX1, FIDY1, + FIDX2, FIDY2, FIDX3, FIDY3 ELSE WRITE (IUN_GEN,'(I2,3(2F8.1))') NFID, 0.0, 0.0, 0.0, 0.0, + 0.0, 0.0 END IF CALL LDM_GET_FBOX (FIDBOX, IFLAG, ND) CALL LDM_GET_N1OD (N1OD, IFLAG) CALL LDM_GET_G1OD (G1OD, IFLAG, ND) CALL LDM_GET_BASE (BASEOD, IFLAG, ND) CALL LDM_GET_NONL (CURV, IFLAG, ND) WRITE (IUN_GEN,'(F6.1,F4.1,I4,3E10.3)') 0.0, FIDBOX, N1OD, + BASEOD, G1OD, CURV CALL LDM_GET_NXRAS (NXRAST, IFLAG) CALL LDM_GET_NYRAS (NYRAST, IFLAG) CALL LDM_GET_XCENF (IPACK, 1, XCENF, IFLAG, ND, IERR, ERRSTR) CALL LDM_GET_YCENF (IPACK, 1, YCENF, IFLAG, ND, IERR, ERRSTR) CALL LDM_GET_RAST (RASTER, IFLAG, ND) CALL LDM_GET_XLOW (XLOW, IFLAG, ND) CALL LDM_GET_XHIGH (XHIGH, IFLAG, ND) CALL LDM_GET_YLOW (YLOW, IFLAG, ND) CALL LDM_GET_YHIGH (YHIGH, IFLAG, ND) CALL LDM_GET_IMTYP (STR, IFLIP, IFLAG) IF (IFLIP.GT.2) IFLIP = 3 WRITE (IUN_GEN,'(2I5,F4.1,2F8.2,F7.2,4F7.1,X,A)') NXRAST, NYRAST, + 2.0, XCENF, YCENF, RASTER, + XLOW, XHIGH, YLOW, YHIGH, FLIP(IFLIP) IF (DISTOR_TYPE.EQ.3) THEN CALL LDM_SPDXY (IPACK, 1, SPDXY, + NSPDX, SPDX_MIN, SPDX_MAX, SPDX, + NSPDY, SPDY_MIN, SPDY_MAX, SPDY, + 100, IERR, ERRSTR) WRITE (IUN_GEN, '(2F10.2,I3,/(4G14.5)))') SPDX_MIN, SPDX_MAX, + NSPDX, (SPDX(I),I=1,MIN(NSPDX,100)) WRITE (IUN_GEN, '(2F10.2,I3,/(4G14.5)))') SPDY_MIN, SPDY_MAX, + NSPDY, (SPDY(I),I=1,MIN(NSPDY,100)) WRITE (IUN_GEN, '(G14.5)') SPDXY END IF RETURN END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** WRITE_INTFILE ** C************************** C C SUBROUTINE WRITE_INTFILE (KPACK, INT_TYPE, SCALE_INT, + MTZ_FILE, GE1_FILE, GE2_FILE, IERR) C INCLUDE 'implicit_none.finc' C C Purpose: Write intensities file C C Author: John W. Campbell, December 1995 C C Note: For .ge1/.ge2 files, they must be opened on units IUN_GE1 and C IUN_GE2 prior to calling this routine; they will be closed C within this routine. If MTZ then check that file can be opened C prior to calling this routine though the open & close will be done C within this routine. C C Arguments: C INTEGER KPACK INTEGER INT_TYPE REAL SCALE_INT CHARACTER*(*) MTZ_FILE CHARACTER*(*) GE1_FILE CHARACTER*(*) GE2_FILE INTEGER IERR C C KPACK (R) Pack no. for data to be written C INT_TYPE (R) Intensities file type flag =1 mtz, =2 .ge1/.ge2 C SCALE_INT (R) Scale factor for output intensities C MTZ_FILE (R) Name of MTZ file if integration file type = 1 C GE1_FILE (R) Name of .ge1 file if integration file type = 2 C GE2_FILE (R) Name of .ge2 file if integration file type = 2 C IERR (W) Error flag =0 OK C =1 Could not write .ge1/.ge2 files - memory C allocation error C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'film_pack.finc' INCLUDE 'file_units.finc' INCLUDE 'lirl_pars.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR INTEGER LENSTR C C====== LOCALS: C LOGICAL SORT_OK LOGICAL RESCALE INTEGER KERR INTEGER NPLATES INTEGER NUM_SPOTS INTEGER NUM_MULTIPLETS INTEGER NUM_SPATIALS INTEGER NUM_BOTH INTEGER NUM_NODALS INTEGER LAMBDA_BINS(16) INTEGER ISORT(5) INTEGER IFLAG INTEGER ND INTEGER NUMSPOTS INTEGER ISPOT INTEGER IH INTEGER IK INTEGER IL INTEGER IPK INTEGER IPL INTEGER KSYM INTEGER MULT INTEGER MINHARM INTEGER MAXHARM INTEGER INCHARM INTEGER ISPAT INTEGER ICLOS INTEGER IMEAS INTEGER IBAD INTEGER IOVLD INTEGER IPACK_ID INTEGER ICODE INTEGER IFLG INTEGER NOVLD REAL CELL(6) REAL ADATA(15) REAL XF REAL YF REAL ALAM REAL AI REAL SIGI REAL FP REAL SCALOUT CHARACTER*80 TITL CHARACTER*80 HSTRNG(2) CHARACTER*30 LABLS(15) CHARACTER*1 CTYPS(15) CHARACTER*2 ERRSTR CHARACTER*80 STR C LOGICAL SORT_OK !Sort was OK flag C LOGICAL RESCALE !Output intensities rescaled flag C INTEGER KERR !Error flag C INTEGER NPLATES !No. plates/pacl C INTEGER NUM_SPOTS !No. spot written to .ge1/.ge2 files C INTEGER NUM_MULTIPLETS !No. multiples written to .ge1/.ge2 files C INTEGER NUM_SPATIALS !No. spatials written to .ge1/.ge2 files C INTEGER NUM_BOTH !No. both spatial & multiple C INTEGER NUM_NODALS !No. nodals written to .ge1/.ge2 files C INTEGER LAMBDA_BINS(16) !Lambda bins histogram C INTEGER ISORT(5) !MTZ column sort flags C INTEGER IFLAG !Parameter status flag C INTEGER ND !No. of decimal places flag C INTEGER NUMSPOTS !No. of spots C INTEGER ISPOT !Spot number C INTEGER IH !'h' index C INTEGER IK !'k' index C INTEGER IL !'l' index C INTEGER IPK !Pack number C INTEGER IPL !Plate number C INTEGER KSYM !Symmetry number/flag C INTEGER MULT !Multiplicity C INTEGER MINHARM !Minimum harmonic C INTEGER MAXHARM !Maximum harmonic C INTEGER INCHARM !Harmonic increment C INTEGER ISPAT !Spatial overlap flag C INTEGER ICLOS !Spots 'too close to integrate' flag C INTEGER IMEAS !Intensity measured flag C INTEGER IBAD !Bad spot flag C INTEGER IOVLD !Overload spot flag C INTEGER IPACK_ID !Pack id C INTEGER ICODE !Integration routine flags code C INTEGER IFLG !Integration flag C INTEGER NOVLD !No. of overload pixels in spot C REAL CELL(6) !Real cell dimensions C REAL ADATA(15) !Reflection data buffer for MTZ file C REAL XF !'x' spot position mm from pattern centre C REAL YF !'y' spot position mm from pattern centre C REAL ALAM !Lambda value C REAL AI !Integrated intensity C REAL SIGI !sig(AI) C REAL FP !Real value C REAL SCALOUT !Used o/p scale factor (.ge1/.ge2 files) C CHARACTER*80 TITL !LDM title C CHARACTER*80 HSTRNG(2) !History string C CHARACTER*30 LABLS(15) !MTZ file labels strings C CHARACTER*1 CTYPS(15) !MTZ file column types flags C CHARACTER*2 ERRSTR !Error string (dummy) C CHARACTER*80 STR !Message string DATA LABLS/'H','K','L','PACK_ID','PLATE','XF','YF','LAMBDA', + 'I','SIGI','MULT','MINHARM','MAXHARM','NOVPIX', + 'FLAGS'/ DATA CTYPS/'H','H','H','B','I','R','R','R','J','Q','I', + 'I','I','R','I'/ C C------------------------------------------------------------------------------- C C====== Initialisations C IERR = 0 C C====== Write intensities file(s) C IF (INT_TYPE.EQ.1) THEN CALL LDM_GET_PID (KPACK, IPACK_ID, IFLAG, KERR, ERRSTR) SORT_OK = .TRUE. CALL LIRLF_SORT (KDX_LIRL, 4, KERR) IF (KERR.NE.0) SORT_OK = .FALSE. CALL LIRLF_SORT (KDX_LIRL, 1, KERR) IF (KERR.NE.0) SORT_OK = .FALSE. IF (SORT_OK) THEN ISORT(1) = 1 ISORT(2) = 2 ISORT(3) = 3 ISORT(4) = 6 ISORT(5) = 0 ELSE ISORT(1) = 0 ISORT(2) = 0 ISORT(3) = 0 ISORT(4) = 0 ISORT(5) = 0 END IF CALL LDM_GET_A (CELL(1), IFLAG, ND) CALL LDM_GET_B (CELL(2), IFLAG, ND) CALL LDM_GET_C (CELL(3), IFLAG, ND) CALL LDM_GET_ALPHA (CELL(4),IFLAG, ND) CALL LDM_GET_BETA (CELL(5), IFLAG, ND) CALL LDM_GET_GAMMA (CELL(6), IFLAG, ND) CALL LWOPEN (1, MTZ_FILE) CALL LWTITL (1, TITL, 0) CALL LWCLAB (1, LABLS, 15, CTYPS, 0) CALL LWCELL (1, CELL) HSTRNG(1) = 'Integration by program LAUEGEN' CALL STR_ADDS (HSTRNG(1),'for pack id =', 1) CALL STR_ADDI (HSTRNG(1), IPACK_ID, 1) CALL LWHIST (1, HSTRNG, 1) CALL LDM_LWSYMM (1) CALL LWSORT (1,ISORT) CALL LIRLF_NUMREFS (KDX_LIRL, NUMSPOTS) IF (NUMSPOTS.GT.0) THEN DO 100 ISPOT = 1, NUMSPOTS CALL LIRLF_GETREF (KDX_LIRL, ISPOT, IH, IK, IL, + IPK, IPL, KSYM, XF, YF, ALAM, + MULT, MINHARM, MAXHARM, INCHARM, + AI, SIGI, ISPAT, ICLOS, IMEAS, IBAD, IOVLD, + ICODE, KERR) CALL LIRLF_GET_OVPIX (KDX_LIRL, ISPOT, NOVLD, KERR) IF (KPACK.NE.IPK) GO TO 100 ADATA(1) = IH ADATA(2) = IK ADATA(3) = IL ADATA(4) = IPACK_ID ADATA(5) = IPL ADATA(6) = XF ADATA(7) = YF ADATA(8) = ALAM ADATA(9) = SCALE_INT*AI ADATA(10) = SCALE_INT*SIGI ADATA(11) = MULT ADATA(12) = MINHARM ADATA(13) = MAXHARM ADATA(14) = NOVLD ADATA(15) = ISPAT + 2*ICLOS + 4*IOVLD + 8*IBAD CALL LWREFL (1, ADATA) 100 CONTINUE END IF CALL LWCLOS (1, 0) IF (IUN_LOG.GT.0) THEN WRITE (IUN_LOG,6010) MTZ_FILE(1:LENSTR(MTZ_FILE)) STR = 'Output scale factor for intensities =' CALL STR_ADDF (STR, SCALE_INT, 4, 1) WRITE (IUN_LOG,6030) STR END IF ELSE CALL LRL_GEN (KPACK, 1, .FALSE., 2, KERR, ERRSTR) CALL LAM_HIST (LAMBDA_BINS) CALL LFN_LIRLGE (KDX_LIRL, IUN_GE1, IUN_GE2, KPACK, SCALE_INT, + LAMBDA_BINS, NUM_SPOTS, NUM_MULTIPLETS, + NUM_SPATIALS, NUM_BOTH, NUM_NODALS, + RESCALE, SCALOUT, IERR) IF (RESCALE) THEN STR = '*Warning* Output scale factor reset to' CALL STR_ADDF (STR, SCALOUT, 4, 1) CALL LOG_MSG (IVH_IOW, STR, 1) END IF IF (IERR.EQ.1) THEN IF (IUN_LOG.GT.0) WRITE (IUN_LOG,6000) RETURN END IF IF (IUN_LOG.GT.0) THEN WRITE (IUN_LOG,6020) GE1_FILE(1:LENSTR(GE1_FILE)), + GE2_FILE(1:LENSTR(GE2_FILE)) STR = 'Output scale factor for intensities =' CALL STR_ADDF (STR, SCALOUT, 4, 1) WRITE (IUN_LOG,6030) STR END IF END IF C C====== Update integration flags C CALL LDM_GET_NPLAT (NPLATES, IFLAG) DO 30 IPL = 1, NPLATES IF (INT_TYPE.EQ.2.AND.IPL.GT.6) GO TO 30 CALL INTFLAG_GET (KPACK, IPL, IFLG) IF (IFLG.EQ.1) CALL INTFLAG_SET (KPACK, IPL, 2) 30 CONTINUE RETURN C C====== Format statements C 6000 FORMAT (/,'**Error** Could not write files', + ' - memory allocation error') 6010 FORMAT (/,'MTZ intensities file written',/, + /,'Name of file: ',A) 6020 FORMAT (/,'Intensities .ge1/.ge2 files written',/, + /,'Name of .ge1 file: ',A, + /,'Name of .ge2 file: ',A) 6030 FORMAT (/,A) END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C************************** C** WRITE_PARFIL ** C************************** C C SUBROUTINE WRITE_PARFIL (PAR_FILE) C INCLUDE 'implicit_none.finc' C C Purpose: Write parameters file C C Author: John W. Campbell, February 1992 C C Note: File must be opened and closed outside this routine C C Arguments: C CHARACTER*(*) PAR_FILE C C PAR_FILE (R) Name of output parameters file C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' INCLUDE 'file_units.finc' C C====== FUNCTION TYPES: C INTEGER LENSTR C C====== LOCALS: C C C------------------------------------------------------------------------------- C C C====== Log name of parameters file C IF (IUN_LOG.GT.0) THEN WRITE (IUN_LOG, 1010) PAR_FILE(1:LENSTR(PAR_FILE)) END IF C C====== Write parameters data C CALL LDM_WRITE (IUN_GEN, 2) RETURN C C====== Format statements C C C====== Format statements C 1010 FORMAT(/,'Writing New LDM Parameters File',/, + '===============================',//, + 'Name of file: ',A) END C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C**************************** C** YESNO_NOTICE ** C**************************** C C SUBROUTINE YESNO_NOTICE (ITYP, MESSAGE, IBUTTON) C INCLUDE 'implicit_none.finc' C C Purpose: Output a popup notice message for 'lauegen' with a C 'Yes' box and a 'No' box C C Author: John W. Campbell, August 1991 C C Arguments: C INTEGER ITYP CHARACTER*(*) MESSAGE INTEGER IBUTTON C C ITYP (R) = 0, Position notice at default position (no arrow on notice) C = 1, Position notice at last selected menu item position (arrow C on notice in this case) C = 2, Position at menu item on autoindexing solutions menu C area C MESSAGE (R) The error message C IBUTTON (W) Returns button selected flag 1=yes, 2=no C C====== Parameter statements C INCLUDE 'lauegen_limits.finc' INCLUDE 'screen_params.finc' C C====== GLOBALS: C INCLUDE 'view_handles.finc' C C====== FUNCTION TYPES: C INTEGER XDLSTR INTEGER LENSTR C C====== LOCALS: C INTEGER IXROOT INTEGER IYROOT INTEGER IARROW C INTEGER IXROOT !X root position for popup notice C INTEGER IYROOT !Y root position for popup notice C INTEGER IARROW !Arrow required flag 0=no, 1=yes C C------------------------------------------------------------------------------- C C====== Get the required position C CALL NOTICE_POSN (ITYP, IXROOT, IYROOT) C C====== Output the popup notice C IARROW = 0 IF (ITYP.EQ.1) IARROW = 1 CALL XDLF_POPUP_NOTICE (IXROOT, IYROOT, + XDLSTR(MESSAGE), LENSTR(MESSAGE), + XDLSTR(' '), -1, + XDLSTR('Yes'), 3, + XDLSTR('No'), 2, + IFONT, IARROW, IBUTTON) RETURN END