CD-Section: LSP Based Convenience Routines C These are a set of routines used to call various Laue Scaling Module C (LSM) routines with parameters derived internally from the Laue C Scaling Parameter (LSP) set of keywords. CD-end C LAST UPDATE: C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C****************************** C** LSM_PARSETUP_LSP ** C****************************** C CD-Routine: Set up other LSM parameters - LSM_PARSETUP_LSP C This routine may be used instead of LSM_PARSETUP if the program using the C LSM is based on an LSP keyworded file from which the required parameter C values are to be taken. Remember to call this routine again if any C of the relevant LSP parameter values may have changed. CD-end CD-Fortran: SUBROUTINE LSM_PARSETUP_LSP (KDX, IERR, ERRSTR) CD-end C INCLUDE 'implicit_none.finc' C INTEGER KDX INTEGER IERR CHARACTER*(*) ERRSTR C CD-Parameters: C KDX i (R) The index of the LSP keyworded parameter set. C IERR i (W) Error flag = 0 OK C = 1 Error C ERRSTR c (W) Error string if IERR is non-zero (max 80 characters) CD-end C C Implementation note: Sets 'markup required' flag C Implementation note: Sets 'more than one plate defined' flag C Implementation note: Sets 'minimum crystal-film/plate distance' variable C C C====== PARAMETERS: C INCLUDE 'limits.finc' C C====== GLOBALS: C INCLUDE 'lsm_flags.finc' INCLUDE 'other_scale.finc' INCLUDE 'scp.finc' INCLUDE 'use_reflns.finc' INCLUDE 'ref_flags.finc' INCLUDE 'rout_arrays.finc' C C====== FUNCTION TYPES: C INTEGER KDMSTR INTEGER LENSTR C C====== LOCALS: C INTEGER KERR INTEGER I INTEGER J INTEGER NUM_INP INTEGER ISTAT INTEGER ITYP INTEGER ND(MAXCOEFFS) INTEGER IVAL(10) INTEGER MAXE REAL FVAL(MAXVARR) CHARACTER*80 STR CHARACTER*70 VALSTR LOGICAL CTOFFL C INTEGER KERR ! Error return flag C INTEGER I ! Temp/loop variable C INTEGER J ! Temp/loop variable C INTEGER ISTAT ! Parameter status flag C INTEGER ND(MAXCOEFFS) ! No. of decimal places flags array C INTEGER IVAL(10) ! Integer values array C INTEGER MAXE ! Max length for error string C REAL FVAL(MAXVARR) ! Real values array C CHARACTER*80 STR ! Temporary string C CHARACTER*70 VALSTR ! Dummy value string C LOGICAL CTOFFL 1 Flag for CTOF check C C------------------------------------------------------------------------------ C C====== Set 'markup-required' flag C MARKUP_REQUIRED = .TRUE. MAXE = 80 IERR = 0 ERRSTR = ' ' CYLINDER = .FALSE. C C====== Get other LSP parameters C VALSTR = ' ' STR = 'TITLE' CALL KDMF_GETVALSTR (KDX, KDMSTR(STR), LENSTR(STR), + 1, 1, 70, KDMSTR(VALSTR), ISTAT, + ITYP, KDMSTR(ERRSTR), MAXE, KERR) IF (KERR.NE.0) GOTO 810 TITLE_STR = VALSTR STR = 'A' CALL KDMF_GETVALUE (KDX, KDMSTR(STR),LENSTR(STR), 1, 1, + 2, KDMSTR(VALSTR), FVAL, ND, IVAL, + NUM_INP, ISTAT, ITYP, KDMSTR(ERRSTR), + MAXE, KERR) IF (KERR.NE.0) GOTO 810 IF (FVAL(1).EQ.0.0) GOTO 830 A = FVAL(1) STR = 'B' CALL KDMF_GETVALUE (KDX, KDMSTR(STR),LENSTR(STR), 1, 1, + 2, KDMSTR(VALSTR), FVAL, ND, IVAL, + NUM_INP, ISTAT, ITYP, KDMSTR(ERRSTR), + MAXE, KERR) IF (KERR.NE.0) GOTO 810 B = FVAL(1) STR = 'C' CALL KDMF_GETVALUE (KDX, KDMSTR(STR),LENSTR(STR), 1, 1, + 2, KDMSTR(VALSTR), FVAL, ND, IVAL, + NUM_INP, ISTAT, ITYP, KDMSTR(ERRSTR), + MAXE, KERR) IF (KERR.NE.0) GOTO 810 C = FVAL(1) STR = 'ALPHA' CALL KDMF_GETVALUE (KDX, KDMSTR(STR),LENSTR(STR), 1, 1, + 2, KDMSTR(VALSTR), FVAL, ND, IVAL, + NUM_INP, ISTAT, ITYP, KDMSTR(ERRSTR), + MAXE, KERR) IF (KERR.NE.0) GOTO 810 ALPHA = FVAL(1) STR = 'BETA' CALL KDMF_GETVALUE (KDX, KDMSTR(STR),LENSTR(STR), 1, 1, + 2, KDMSTR(VALSTR), FVAL, ND, IVAL, + NUM_INP, ISTAT, ITYP, KDMSTR(ERRSTR), + MAXE, KERR) IF (KERR.NE.0) GOTO 810 BETA = FVAL(1) STR = 'GAMMA' CALL KDMF_GETVALUE (KDX, KDMSTR(STR),LENSTR(STR), 1, 1, + 2, KDMSTR(VALSTR), FVAL, ND, IVAL, + NUM_INP, ISTAT, ITYP, KDMSTR(ERRSTR), + MAXE, KERR) IF (KERR.NE.0) GOTO 810 GAMMA = FVAL(1) STR = 'NUMIMAGES' CALL KDMF_GETVALUE (KDX, KDMSTR(STR),LENSTR(STR), 1, 1, + 2, KDMSTR(VALSTR), FVAL, ND, IVAL, + NUM_INP, ISTAT, ITYP, KDMSTR(ERRSTR), + MAXE, KERR) IF (KERR.NE.0) GOTO 810 NPK = IVAL(1) IF (NPK.EQ.0) GOTO 820 PLFLAG = .FALSE. STR = 'NPLATES' DO 50 I = 1, MAXPACK CALL KDMF_GETVALUE (KDX, KDMSTR(STR),LENSTR(STR), I, 1, + 2, KDMSTR(VALSTR), FVAL, ND, IVAL, + NUM_INP, ISTAT, ITYP, KDMSTR(ERRSTR), + MAXE, KERR) IF (KERR.NE.0) GOTO 810 NPL(I) = IVAL(1) IF (NPL(I).GT.1) PLFLAG = .TRUE. 50 CONTINUE STR = 'SPINDLES' CALL KDMF_GETVALUE (KDX, KDMSTR(STR),LENSTR(STR), 1, 1, + 2, KDMSTR(VALSTR), FVAL, ND, IVAL, + NUM_INP, ISTAT, ITYP, KDMSTR(ERRSTR), + MAXE, KERR) IF (KERR.NE.0) GOTO 810 DO 10 I = 1, MAXPACK SPINDLE(I) = (I-1)*FVAL(1) 10 CONTINUE STR = 'SPINDLE_ANGLE' CALL KDMF_GETVALUE (KDX, KDMSTR(STR),LENSTR(STR), 1, 1, + 2, KDMSTR(VALSTR), FVAL, ND, IVAL, + NUM_INP, ISTAT, ITYP, KDMSTR(ERRSTR), + MAXE, KERR) IF (KERR.NE.0) GOTO 810 IF (FVAL(1).NE.0.0) THEN DO 20 I = 1, MAXPACK SPINDLE(I) = FVAL(1)+(I-1)*FVAL(2) 20 CONTINUE END IF STR = 'CTOF' CTOFFL = .TRUE. DO 40 I = 1, MAXPACK DO 30 J = 1, MAXPLATES CALL KDMF_GETVALUE (KDX, KDMSTR(STR),LENSTR(STR), I, J, + 2, KDMSTR(VALSTR), FVAL, ND, IVAL, + NUM_INP, ISTAT, ITYP, KDMSTR(ERRSTR), + MAXE, KERR) IF (KERR.NE.0) GOTO 810 CTOF(I,J) = FVAL(1) IF (CTOF(I,J).NE.0.0) CTOFFL = .FALSE. 30 CONTINUE 40 CONTINUE IF (CTOFFL) GOTO 820 STR = 'IMAGE_SIZE' CALL KDMF_GETVALUE (KDX, KDMSTR(STR),LENSTR(STR), 1, 1, + 2, KDMSTR(VALSTR), FVAL, ND, IVAL, + NUM_INP, ISTAT, ITYP, KDMSTR(ERRSTR), + MAXE, KERR) IF (KERR.NE.0) GOTO 810 IMAGESIZE(1) = FVAL(1) IMAGESIZE(2) = FVAL(2) IF (FVAL(1).EQ.0.0.OR.FVAL(2).EQ.0.0) GO TO 820 STR = 'DETECTOR' CALL KDMF_GETVALSTR (KINDX, KDMSTR(STR), LENSTR(STR), 1, 1, + 8, KDMSTR(VALSTR), ISTAT, + ITYP, KDMSTR(ERRSTR), MAXE, KERR) IF (KERR.NE.0) GOTO 810 CALL CCPUPC(VALSTR) IF (INDEX(VALSTR,'CYLINDER').NE.0) THEN CYLINDER = .TRUE. ELSE CYLINDER = .FALSE. END IF RETURN C C====== Error conditions C 810 ERRSTR = 'Error code' CALL STR_ADDI (ERRSTR, KERR, 1) CALL STR_ADDS (ERRSTR, 'from kdmf_getvalue routine',1) IERR = 1 RETURN 820 ERRSTR = 'Keyword' CALL STR_ADDS (ERRSTR, STR, 1) CALL STR_ADDS (ERRSTR, 'has zero value(s)',1) IERR = 1 RETURN 830 ERRSTR = 'No lattice parameters set' IERR = 1 RETURN END