C *** PROGRAM: SHADOW (SHADOW00) - PATTERN ANALYSIS PROGRAM C *** VERSION: 860822 (YYMMDD) C * C * AUTHOR: S. A. HOWARD C * DEPARTMENT OF CERAMIC ENGINEERING C * UNIVERISTY OF MISSOURI - ROLLA C * ROLLA, MO 65401 USA C * 314-341-4403 C * C *** SHADOW - MAIN PROGRAM C * CHARACTER QANS*1,QANS2*1,QDATE*9,QTIME*8,QFILE*32 CHARACTER QPTFID*32,QWGTTL*72,QFTITL*80,QWGFID*32,QWGANS*1 PARAMETER ( MEMV = 32, MPTS = 2048 ) PARAMETER ( MPTST2 = MPTS * 2 ) COMMON /REFFLG/ KPROF,KLRNZ,KERRT,KASYM,KBKGR,KBKGD,KAMOR,KCRYS COMMON /LUNS/ ITTI,ITTO,IOFI,IOFO,IOBO,IOPL,IOPO,IOLO,IOSC,IOWG COMMON /SDATA/ KOBS,YANG(MPTS),YOBS(MPTS),YSYN(MPTS),YBKG(MPTS) COMMON /PEAKP/ KNLIN,KNPRM,PLPRM(200,10),KRLIN(200),KLLIN(201) COMMON /SCHDAT/ KNFND,PSIGMA,RELLOW,BIGINT,KNSMO,KFFLT,KFMNT COMMON /WGDATN/ WGBAK(6),WGPRO(4,3),WGRAD(5,2),WGCAL(3) COMMON /BKGDAT/ LDEG,CLY,CLC(6),BKGSDV,IBKCPS,IBKNBK COMMON /REFPAR/ AMOPAR(3),BKGPAR,ASYPAR,CRYPAR(2) COMMON /PLTDAT/ KPPLOT,KPSETS(5),KPTYPE,KPTDEF COMMON /FLDATN/ KFILET,FBANG,FEANG,FAINC,FTIME COMMON /RFREGN/ KNUMRG,KNUMCU,REFREG(200,2) COMMON /WSGDAT/ KWSGLN,WSGPAR(200,12) COMMON /WGDATC/ QWGTTL,QWGFID,QWGANS COMMON /MODEOP/ KMODEO,KSAMEP,KAUTOP COMMON /PEAKDT/ NPEAK,PEAKS(200,4) COMMON /WDATA/ NWAVE,WTABLE(5,2) COMMON /COMSCR/ JUNK(MPTST2) COMMON /PDATA/ BANG, EANG COMMON /DIAGS/ ISENSE(10) COMMON /FLDATC/ QFTITL COMMON /XXFILE/ QPTFID C * C * VAX 11/780 ERROR HANDLING ROUTINES EXTERNAL HDLR CALL LIB$ESTABLISH( HDLR ) I = LIB$SIM_TRAP( SIGARGS, MECHARGS ) C * C * IBM ERROR RECOVERY ROUTINE CIBM CALL ERRSET(207,256,2,2,1,209) C * C * SAY HELLO 1000 CALL DATE( QDATE ) CALL TIME( QTIME ) WRITE(ITTO,1010) QDATE,QTIME(1:5) 1010 FORMAT('1*** SHADOW - Pattern analysis V 860818',4X,A9,2X,A5) IF(KPTDEF.EQ.0) WRITE(ITTO,1012) 1012 FORMAT(/,' Default PLOT file type is UNFORMATTED. Use $file.ext', 1' to write FORMATTED.') IF(KPTDEF.EQ.1) WRITE(ITTO,1014) 1014 FORMAT(/,' Default PLOT file type is FORMATTED. Use $file.ext', 1' to write UNFORMATTED.') WRITE(ITTO,1016) 1016 FORMAT(/,' Program options are given in (), defaults given in <>.' 1,/,' Use a / to get the defaults or if the program hangs on a', 1' read.') C * C * DETERMINE MODE TO OPERATE IN... C * C * KMODEO = 0 - EXECUTE COMMANDS "INTERACTIVE" C * KMODEO = 1 - WRITE COMMAND EXECUTION FILE FOR "BATCH" C * KMODEO = 2 - EXECUTING IN "BATCH MODE" C * KMODEO = 9 - ALLOW DEBUG FLAGS TO BE SET C * WRITE(ITTO,1020) 1020 FORMAT(/,' Execution mode: (I)nteractive or', 1' (B)atch setup ? ') READ(ITTI,1030) QANS,ISENSE 1030 FORMAT(A1,3X,10I1) KMODEO = 0 IF( QANS.EQ.'B' .OR. QANS.EQ.'b' ) KMODEO = 1 IF( QANS.EQ.'E' .OR. QANS.EQ.'e' ) KMODEO = 2 IF( QANS.EQ.'9') KMODEO = 9 IF(KMODEO.EQ.2) WRITE(ITTO,1025) 1025 FORMAT(/,' * Execution mode is BATCH *') C * C * GET FILE NAME FOR BATCH SETUP IF(KMODEO.NE.1) GO TO 2000 WRITE(ITTO,1035) 1035 FORMAT(/,' Name for batch command file ? ') READ(ITTI,1040) QFILE 1040 FORMAT(A32) CVAX C OPEN(UNIT=IOBO,FILE=QFILE,STATUS='UNKNOWN',FORM='FORMATTED', C 1 ERR=1050,CARRIAGECONTROL='LIST') CVAX CIBM OPEN(UNIT=IOBO,FILE=QFILE,STATUS='UNKNOWN',FORM='FORMATTED', 1 ERR=1050) CIBM WRITE(IOBO,1045) ISENSE 1045 FORMAT('E',3X,10I1,T40,'Batch mode') GO TO 3000 1050 STOP '--Unable to open file for batch command ouput' C * C ** DEBUG SETUP C * 2000 IF(KMODEO.NE.9) GO TO 3000 WRITE(ITTO,1) 1 FORMAT(/,'*****> DIAGONOSTICS INPUT') WRITE(ITTO,2) 2 FORMAT(/,' SHOW PROFILE GENERATION ? (0)-NO, (1)-YES ') READ(ITTI,*) ISENSE(1) WRITE(ITTO,3) 3 FORMAT(' SHOW REFINEMENT PARAMETERS ? (0)-NO, (1)-YES ') READ(ITTI,*) ISENSE(2) WRITE(ITTO,4) 4 FORMAT(' SHOW PEAK SEARCH PARAMETERS ? (0)-NO, (1)-YES ') READ(ITTI,*) ISENSE(3) WRITE(ITTO,5) 5 FORMAT(' LEAST-SQAURES OUTPUT ? (0)-NONE, (1)-PARTIAL, (2)-FULL ') READ(ITTI,*) ISENSE(4) WRITE(ITTO,6) 6 FORMAT(' SHOW BAKCKGROUND PARAMETERS ? (0)-NO, (1)- YES ') READ(ITTI,*) ISENSE(5) C * C ** INITIALIZE PROGRAM PARAMETERS C * 3000 KSAMEP = 0 KAUTOP = 0 KWSGLN = 0 DO 3010 I=1,200 DO 3010 I2=1,11 3010 WSGPAR(I,I2) = 0.0 C * C ** GET THE INSTRUMENTAL PARAMETERS C * CALL GETWSG C * C ** GET THE INPUT PATTERN FILE PARAMETERS C * 4000 NPEAK = 0 CALL INITIO( ICODE ) IF(ICODE.NE.0) GO TO 9000 C * C ** DETERMINE THE BACKGROUND FOR THIS PATTERN C * CALL BKGDET C * C ** DETERMINE FUNCTION TO PERFORM C * 6000 KPTYPE = KPTDEF IF(KMODEO.NE.2) WRITE(ITTO,6010) 6010 FORMAT(//,' SHADOW performs the following functions:',//, 1' S(S) - Search for peaks (and setup refinement regions)',/, 1' R - Refine peak parameters by profile fitting',/, 1' A(S) - Auto setup for refinement (with auto peak search)',/, 1' N - Open new pattern for analysis',/, 1' L - Line list functions',/, 1' P - Read/write parameter file',/, 1' E - Exit program',//, 1' Function ? ') READ(ITTI,6020) QANS,QANS2 6020 FORMAT(2A1) IF( QANS.EQ.'E' .OR. QANS.EQ.'e' ) GO TO 9000 IF( QANS.EQ.'S' .OR. QANS.EQ.'s' ) GO TO 7000 IF( QANS.EQ.'R' .OR. QANS.EQ.'r' ) GO TO 8000 IF( QANS.EQ.'N' .OR. QANS.EQ.'n' ) GO TO 10000 IF( QANS.EQ.'P' .OR. QANS.EQ.'p' ) GO TO 11000 IF( QANS.EQ.'L' .OR. QANS.EQ.'l' ) GO TO 12000 IF( QANS.EQ.'A' .OR. QANS.EQ.'a' ) GO TO 13000 GO TO 6000 C * C ** PERFORM PEAK SEARCH FUNCTION C * 7000 IF( QANS2.EQ.'S' .OR. QANS2.EQ.'s' ) KAUTOP = 2 IF( QANS2.EQ.'R' .OR. QANS2.EQ.'r' ) KAUTOP = 3 CALL PKSRCH KAUTOP = 0 GO TO 6000 C * C ** PERFORM THE REFINEMENT FUNCTION C * 8000 IF(KMODEO.EQ.1) WRITE(IOBO,8010) 8010 FORMAT('Refine',T40,'Profile refinement') CALL PKREFN GO TO 6000 C * C ** READ/WRITE PARAMETER FILE C * 11000 IF(KMODEO.EQ.1) WRITE(IOBO,11010) 11010 FORMAT('Parameters',T40,'Use parameter file') CALL PARAMS GO TO 6000 C * C *** OPEN NEW PATTERN FILE C * 10000 IF(KMODEO.EQ.1) WRITE(IOBO,10010) 10010 FORMAT('New',T40,'Open new pattern file') GO TO 4000 C * C ** EVALUATE INSTRUMENTAL PARAMETERS C * 12000 IF(KMODEO.EQ.1) WRITE(IOBO,12010) 12010 FORMAT('List',T40,'Internal line list') CALL WSGEVL GO TO 6000 C * C ** AUTOPILOT OPERATION: SETUP FOR BATCH SEARCH AND REFINE C * 13000 IF(KMODEO.NE.0) THEN WRITE(ITTO,13010) 13010 FORMAT(/,' --Autopilot can only be invoked in immediate', 1 ' execution mode') GO TO 6000 ENDIF WRITE(ITTO,13020) 13020 FORMAT(/,' *** Going to autopilot') KAUTOP = 1 C * C * GET FILE NAME FOR BATCH SETUP KMODEO = 1 WRITE(ITTO,1035) READ(ITTI,1040) QFILE CVAX C OPEN(UNIT=IOBO,FILE=QFILE,STATUS='UNKNOWN',FORM='FORMATTED', C 1 ERR=1050,CARRIAGECONTROL='LIST') CVAX CIBM OPEN(UNIT=IOBO,FILE=QFILE,STATUS='UNKNOWN',FORM='FORMATTED', 1 ERR=1050) CIBM WRITE(IOBO,1045) ISENSE C * C * THE FOLLOWING HAS TO BE SET UP CALL GETWSG CALL INITIO( ICODE ) IF(ICODE.NE.0) GO TO 13090 CALL BKGDET C * C * CALL PKSRCH TO DETERMINE ESTIMATES FOR REGIONS AND LINE POSITIONS C * SEARCH PERFORMED ONLY IF S WAS INCLUDED IN COMMAND IF( QANS2.EQ.'S' .OR. QANS2.EQ.'s' ) CALL PKSRCH IF(NPEAK.LT.1) THEN WRITE(ITTO,13030) 13030 FORMAT(/,' --No lines from search: Aborting autopilot') GO TO 13090 ENDIF IF(KNUMRG.LT.1) THEN WRITE(ITTO,13040) 13040 FORMAT(/,' --No regions from search: Aborting autopilot') GO TO 13090 ENDIF C * C * CALL PKREFN TO REFINE LINE POSITIONS WRITE(IOBO,8010) CALL PKREFN C * C * WRITE THE LINE PARAMETERS WRITE(IOBO,12010) CALL WSGEVL C * C * CALL PARAMS TO WRITE REFINED LINE PARAMETERS WRITE(IOBO,11010) CALL PARAMS C * C * TURN OFF AUTOPILOT FLAG AND CLOSE BATCH FILE 13090 KAUTOP = 0 KMODEO = 0 WRITE(IOBO,9010) CLOSE(UNIT=IOBO) WRITE(ITTO,13092) 13092 FORMAT(/,' *** Autopilot off') GO TO 6000 C * C ** THATS ALL FOLKS... EXIT STAGE RIGHT C * 9000 IF(KMODEO.EQ.1) THEN WRITE(IOBO,9010) 9010 FORMAT('Exit',T40,'Program termination') CLOSE(UNIT=IOBO) ENDIF WRITE(ITTO,9060) 9060 FORMAT(/,'** Normal termination of SHADOW **') C CALL EXIT STOP END C *** CALCPH - POSITION AND HEIGHT FOR A SATELLITE LINE C * SUBROUTINE CALCPH( TT1, YI1, N, TTN, YIN ) PARAMETER ( DTORD2=8.72664626E-03, RTODT2=114.591559) COMMON /WDATA/ NWAVE,WTABLE(5,2) C * TTN = SIN( TT1 * DTORD2 ) TTN = RTODT2 * ASIN( WTABLE(N,1)/WTABLE(1,1) * TTN ) YIN = YI1 * WTABLE(N,2) RETURN END C *** CORPOS - TWO-THETA LINE CORRECTION FROM INSTRUMENTAL PARAMETERS C * C * TT-COR = TT-OBS + CORPOS( TT-OBS ) C * FUNCTION CORPOS( TTOBS ) COMMON /WGDATN/ WGBAK(6),WGPRO(4,3),WGRAD(5,2),WGCAL(3) C * CORPOS = WGCAL(1) + WGCAL(2)*TTOBS + WGCAL(3)*TTOBS**2 C * RETURN END C *** BKGLVL - GENERATION OF BACKGROUND C * SUBROUTINE BKGLVL( TARGET ) C * C * KBKGR = 0 => BACKGROUND IS ASSUMED ZERO C * = 1 => ADDITIVE BACKGROUND OFFSET BEING REFINED C * = 2 => CALCULATED BACKGROUND IS MOVED TO TARGET C * = 3 => REFINE FIXED BACKGROUND SHAPE OFFSET C * C * IF THE BACKGROUND HAS NOT BEEN EVALUATED... DAREA IS ZEROED. C * PARAMETER ( DTOR=1.745329252E-02, RTOD=5.729577951E+01 ) PARAMETER ( MEMV = 32, MPTS = 2048 ) COMMON /REFFLG/ KPROF,KLRNZ,KERRT,KASYM,KBKGR,KBKGD,KAMOR,KCRYS COMMON /SDATA/ KOBS,YANG(MPTS),YOBS(MPTS),YSYN(MPTS),YBKG(MPTS) COMMON /BKGDAT/ LDEG,CLY,CLC(6),BKGSDV,IBKCPS,IBKNBK COMMON /REFPAR/ AMOPAR(3),BKGPAR,ASYPAR,CRYPAR(2) DIMENSION TARGET(MPTS) EQUIVALENCE (CLC(1),PC1),(CLC(2),PC2),(CLC(3),PC3),(CLC(4),PC4) C * C * IF KBKGR=0,1,3 THEN USE KBKGR TO DETERMINE ACTION IF(KBKGR.EQ.0) GO TO 2000 IF(KBKGR.EQ.1) GO TO 3000 IF(KBKGR.EQ.3) GO TO 1000 C * C * BACKGROUND MUST HAVE BEEN DETERMINED IF KBKGR=2 IF(KBKGD.NE.1) GO TO 2000 IF(KBKGR.EQ.2) GO TO 1000 STOP '--BKGLVL: INVALID VALUE OF KBKGR: ABORT' C * C ** CALCULATED BACKGROUND USED C * C * DETERMINE THE ADDITIVE CONSTANT BASED ON THE TYPE OF BACKGROUND 1000 OFFSET = CLY IF(KBKGR.EQ.3) OFFSET = BKGPAR IF(LDEG.EQ.0) GO TO 1100 C * C * SPAN THE ENTIRE RANGE WITH THE POLYNOMIAL BACKGROUND C * C * CALCULATE THE EXPECTED INTENSITIES IF(LDEG.EQ.1) THEN DO 1011 I=1,KOBS 1011 TARGET(I) = OFFSET + PC1*YANG(I) ELSE IF(LDEG.EQ.2) THEN DO 1012 I=1,KOBS ANG = YANG(I) TARGET(I) = OFFSET + (PC2*ANG + PC1)*ANG 1012 CONTINUE ELSE IF(LDEG.EQ.3) THEN DO 1013 I=1,KOBS ANG = YANG(I) TARGET(I) = OFFSET + ((PC3*ANG + PC2)*ANG + PC1)*ANG 1013 CONTINUE ELSE DO 1014 I=1,KOBS ANG = YANG(I) TARGET(I) = OFFSET + (((PC4*ANG + PC3)*ANG + PC2)*ANG + PC1)*ANG 1014 CONTINUE ENDIF GO TO 9000 C * C ** SPAN THE ENTIRE RANGE WITH THE FIXED BACKGROUND SHAPE C * 1100 TMP = ( 2.0**(1.0/PC3) - 1.0 ) / ( (PC2/2.0)**2 ) DO 1110 I=1,KOBS 1110 TARGET(I) = PC1/(1.0+TMP*YANG(I)**2)**PC3 + PC4*YANG(I) + OFFSET GO TO 9000 C * C ** BACKGROUND IS ZERO... C * 2000 DO 2010 I=1,KOBS 2010 TARGET(I) = 0.0 GO TO 9000 C * C ** ADDITIVE OFFSET BEING REFINED C * 3000 DO 3010 I=1,KOBS 3010 TARGET(I) = BKGPAR C * 9000 RETURN END C *** FUNCTION CPUSEC - RETURNS CPU EXECUTION TIME IN SECONDS C * C * ARGUMENT IS USED FOR DELTA TIME INTERVALS C * FUNCTION CPUSEC( START ) C * CVAX ISTAT = LIB$STAT_TIMER(2,ITIME) CVAX TIME = FLOAT( ITIME ) / 100.0 CVAX CPUSEC = TIME - START CPUSEC = 0.0 C * RETURN END C *** DATE - DUMMY DATE ROUTINE C * C SUBROUTINE DATE( QDATE ) C CHARACTER QDATE*9 C QDATE = 'dd-mmm-yy' c RETURN C END C *** TIME - DUMMY TIME ROUTINE C * C SUBROUTINE TIME( QTIME ) C CHARACTER QTIME*8 C QTIME = 'hh:mm:ss' C RETURN C END C *** BLOCK DATA C * BLOCK DATA C * C * LOGICAL UNIT ASSIGNMENTS: C * ITTI - TERMINAL INPUT ITTO - TERMINAL OUTPUT C * IOFI - PATTERN INPUT IOFO - PATTERN FILE OUTPUT C * IOSC - SCRATCH FILE (OUT/IN) IOPL - PLOT FILE OUTPUT C * IOBO - BATCH COMMAND FILE OUTPUT IOPO - PARAMETER FILE (IN/OUT) C * IDLO - LINE FILE OUTPUT (IN/OUT) IOWG - INST PARAMETER FILE (IN/OUT C * KPTYPE - PLOT FILE: 0 - UNFORMATTED, 1 - FORMATTED C * COMMON /LUNS/ ITTI,ITTO,IOFI,IOFO,IOBO,IOPL,IOPO,IOLO,IOSC,IOWG COMMON /PLTDAT/ KPPLOT,KPSETS(5),KPTYPE,KPTDEF DATA ITTI / 5 / DATA ITTO / 6 / DATA IOFI / 10 / DATA IOFO / 11 / DATA IOBO / 12 / DATA IOPL / 13 / DATA IOPO / 14 / DATA IOLO / 15 / DATA IOSC / 16 / DATA IOWG / 17 / DATA KPTDEF / 0 / END C *** PROGRAM: SHADOW (SHADOW10) C *** VERSION: 860822 (YYMMDD) C * C *** BKGDET - BACKGROUND DETERMINATION C * SUBROUTINE BKGDET C * LOGICAL LOFLAG CHARACTER QJUNK*1 PARAMETER ( MEMV = 32, MPTS = 2048 ) PARAMETER ( DTOR = 0.01745329252 ) COMMON /REFFLG/ KPROF,KLRNZ,KERRT,KASYM,KBKGR,KBKGD,KAMOR,KCRYS COMMON /LUNS/ ITTI,ITTO,IOFI,IOFO,IOBO,IOPL,IOPO,IOLO,IOSC,IOWG COMMON /SDATA/ KOBS,YANG(MPTS),YOBS(MPTS),YSYN(MPTS),YBKG(MPTS) COMMON /WGDATN/ WGBAK(6),WGPRO(4,3),WGRAD(5,2),WGCAL(3) COMMON /BKGDAT/ LDEG,CLY,CLC(6),BKGSDV,IBKCPS,IBKNBK COMMON /FLDATN/ KFILET,FBANG,FEANG,FAINC,FTIME COMMON /MODEOP/ KMODEO,KSAMEP,KAUTOP COMMON /DIAGS/ ISENSE(10) DIMENSION XDATA(10), PCOEFF(10) EQUIVALENCE ( PCOEFF(1), PC1 ), ( PCOEFF(2), PC2 ), 1 ( PCOEFF(3), PC3 ), ( PCOEFF(4), PC4 ) C * IF(KMODEO.EQ.2) THEN WRITE(ITTO,1) 1 FORMAT(//,8X,'* * * B A C K G R O U N D D E T E R M I N', 1 ' A T I O N * * *') ELSE WRITE(ITTO,2) 2 FORMAT(/,' * Background determination') ENDIF C * C * INITIALIZE BACKGROUND PARAMETERS IF AUTOPILOT IS OFF IF(KAUTOP.NE.1) THEN IBKCPS = 0 KBKGD = 0 KBKGR = 0 LDEG = 0 BKGSDV = 0.0 CLY = 0.0 DO 11 I=1,6 11 CLC(I) = 0.0 IWGT = 0 ENDIF C * C * GET THE TYPE OF BACKGROUND TO EVALUATE C * 100 IF( KMODEO.NE.2 .AND. KAUTOP.NE.1 ) WRITE(ITTO,105) 105 FORMAT(/,' Type of background for evaluation:',/, 1 5X,' -1 None',/, 1 5X,' 0 Refine fixed shape background offset',/, 1 5X,' 1-4 Polynomial',//, 1 ' Background model ? <0> ') IF(KAUTOP.NE.1) THEN IF(LDEG.NE.2) THEN LDEG = 0 READ(ITTI,*) LDEG ELSE READ(ITTI,110) LDEG 110 FORMAT(I2) ENDIF ENDIF IF( LDEG.LT.-1 .OR. LDEG.GT.4 ) GO TO 100 IF(KMODEO.EQ.1) WRITE(IOBO,112) LDEG 112 FORMAT(I2,T40,'Background model') IF( KMODEO.EQ.2 .OR. KAUTOP.EQ.1 ) WRITE(ITTO,114) LDEG 114 FORMAT(/,' Background evaluated: ',I2) IF(LDEG.EQ.-1) GO TO 9000 C * C * IF AUTOPILOT IS ON-> MODEL WRITTEN TO BATCH FILE, EXIT IF(KAUTOP.EQ.1) GO TO 9000 C * C * SKIP THE FILES HEADER RECORDS 200 REWIND IOFI IF(KFILET.EQ.0) NSKIP = 3 IF(KFILET.EQ.1) NSKIP = 3 DO 210 I=1,NSKIP IF(KFILET.EQ.0) THEN READ(IOFI,215) QJUNK 215 FORMAT(A1) ELSE READ(IOFI) QJUNK ENDIF 210 CONTINUE C * C * DETERMINE NUMBER OF POINTS IN SEGMENT C * 1100 NLIMIT = MIN( 2048, MPTS ) NHID = NINT( (FEANG-FBANG)/FAINC ) + 1 IF(NHID.GT.NLIMIT*10) THEN WRITE(ITTO,1102) NLIMIT 1102 FORMAT(/,' -Background limited to ',I4,' points') NHID = NLIMIT * 10 ENDIF NHIR = NHID / 10 IF(NHIR.LT.1) STOP'ERROR-TOO FEW POINTS IN PATTERN' NHIP = NLIMIT / NHIR IF(NHIP.EQ.0) STOP'ERROR-TOO MANY POINTS IN PATTERN' IF(NHIP.GT.10) NHIP = 10 IF(ISENSE(5).NE.0) WRITE(ITTO,9990) NHID,NHIR,NHIP 9990 FORMAT(' NHID,NHIR,NHIP = ',3I6) NINTVL = 10 / NHIP IF(NINTVL.EQ.10) NINTVL = 1 NTOGET = 1 + ( NHIP - 1 ) * NINTVL C * C * READ PATTERN SEGMENTS FOR BACKGROUND DATA C * KOBS = 0 IF(KFILET.EQ.0) THEN DO 1110 I=1,NHIR READ(IOFI,1112,END=1134) (XDATA(J),J=1,NTOGET,NINTVL) 1112 FORMAT(10F7.0) ABREC = FBANG + 10.0*REAL(I-1)*FAINC - FAINC DO 1114 J=1,NTOGET,NINTVL KOBS = KOBS + 1 YANG(KOBS) = ABREC + REAL(J) * FAINC YOBS(KOBS) = XDATA(J) 1114 CONTINUE 1110 CONTINUE ELSE DO 1120 I=1,NHIR READ(IOFI,END=1134) (XDATA(J),J=1,NTOGET,NINTVL) ABREC = FBANG + 10.0*REAL(I-1)*FAINC - FAINC DO 1122 J=1,NTOGET,NINTVL KOBS = KOBS + 1 YANG(KOBS) = ABREC + REAL(J) * FAINC YOBS(KOBS) = XDATA(J) 1122 CONTINUE 1120 CONTINUE ENDIF 1138 WRITE(ITTO,1130) NHIR,NHIP,KOBS 1130 FORMAT(/,' Records read ',I5,' Points/record ',I2, 1' Total number of points ',I5) GO TO 1132 1134 WRITE(ITTO,1136) 1136 FORMAT(/, 1' --The end-of-file was unexpectedly hit while reading the', 1' pattern file.') GO TO 1138 C * C * SET TSIGMA, SIGMA LEVEL ABOVE WHICH TO REJECT POINTS 1132 TSIGMA = 1.75 IF(ISENSE(5).NE.0) THEN WRITE(ITTO,9991) 9991 FORMAT(/,' ENTER TSIGMA: ') ANS = 0.0 READ(ITTI,*) ANS IF(ANS.GT.0.) TSIGMA = ANS ENDIF C * C * DETERMINE TYPE OF BACKGROUND DETERMINATION... C * IF(LDEG.EQ.0) GO TO 4000 C * C ** THE BACKGROUND WILL BE EVALUATED AS A POLYNOMIAL. THE DEGREE INPU C ** WILL BE USED AND ANY POINTS OUTSIDE OF THE LIMITS WILL BE REJECTED C * C * GENERATE THE WEIGHTING FACTORS IN YBKG 1300 IF(IWGT.NE.0) THEN DO 1302 I=1,KOBS 1302 YBKG(I) = 1.0 / AMAX1( 1.0, YOBS(I) ) ENDIF NCYCLE = 0 NTDEL = 0 LOFLAG = .FALSE. YDUM = 0.0 C * C * COMPUTE COEFFICIENTS FOR BEST FIT 1305 PSDEV = PFIT(YANG,YOBS,YBKG,KOBS,LDEG,YDUM,PYINT,PCOEFF,IWGT) C * C * CALCULATE THE EXPECTED INTENSITIES IF(LDEG.EQ.1) THEN DO 1311 I=1,KOBS 1311 YSYN(I) = PYINT + PC1*YANG(I) ELSE IF(LDEG.EQ.2) THEN DO 1312 I=1,KOBS ANG = YANG(I) YSYN(I) = PYINT + (PC2*ANG + PC1)*ANG 1312 CONTINUE ELSE IF(LDEG.EQ.3) THEN DO 1313 I=1,KOBS ANG = YANG(I) YSYN(I) = PYINT + ((PC3*ANG + PC2)*ANG + PC1)*ANG 1313 CONTINUE ELSE DO 1314 I=1,KOBS ANG = YANG(I) YSYN(I) = PYINT + (((PC4*ANG + PC3)*ANG + PC2)*ANG + PC1)*ANG 1314 CONTINUE ENDIF C * C * ELIMINATE POINTS TSIGMA SIGMA ABOVE COMPUTED LINE NDEL = 0 DO 1320 I=1,KOBS C * C * CALCULATE THE EXPECTED INTENSITY AND SIGMA LIMIT YCALC = AMAX1( YSYN(I), 0.0 ) PLIM = TSIGMA * SQRT(YCALC) C * C * REJECT IF ABOVE LIMIT IF(YOBS(I).GT.(YCALC+PLIM)) GO TO 1335 C * C * REJECT IF BELOW LIMIT IF(.NOT.LOFLAG) GO TO 1320 IF(YOBS(I).GT.(YCALC-PLIM)) GO TO 1320 C * C * MARK POINT FOR FUTURE REMOVAL FROM LIST 1335 YANG(I) = 0.0 NDEL = NDEL + 1 C * 1320 CONTINUE C * C * COMPRESS LIST IF(NDEL.EQ.0) GO TO 1360 NTEMP = KOBS KOBS = 0 DO 1340 I=1,NTEMP IF(YANG(I).EQ.0.0) GO TO 1340 KOBS = KOBS + 1 IF(KOBS.EQ.I) GO TO 1340 YANG(KOBS) = YANG(I) YOBS(KOBS) = YOBS(I) YBKG(KOBS) = YBKG(I) 1340 CONTINUE C * C * REPEAT ON SECOND ROUND REJECTING POINTS BELOW TSIGMA*SIGMA 1360 IF(ISENSE(5).NE.0) WRITE(ITTO,9992) KOBS,NTEMP,NDEL 9992 FORMAT(' KOBS,NTEMP,NDEL: ',3I6) NTDEL = NTDEL + NDEL NCYCLE = NCYCLE + 1 IF(NDEL.GT.0) GO TO 1305 IF(LOFLAG) GO TO 1370 LOFLAG = .TRUE. GO TO 1305 C * C * COPY THE COEFFICIENTS TO COMMON 1370 CLY = PYINT DO 1380 I=1,LDEG 1380 CLC(I) = PCOEFF(I) C * C * WRITE THE POLYNOMIAL BACKGROUND INFO WRITE(ITTO,1382) 1382 FORMAT(/,' Background evaluation; Polynomial approximation:') WRITE(ITTO,1384) NCYCLE,KOBS,NTDEL 1384 FORMAT(' Cycles = ',I3,' Points used = ',I4,' Deleted = ',I4) WRITE(ITTO,131) CLY/FTIME, (CLC(I),I,I=1,LDEG) 131 FORMAT(/,' BKG(2THETA) = ',SP,E13.6, 1 4(/,17X,SP,E13.6,' * 2THETA**',S,I1)) C * C * COMPUTE THE TOTAL STANDARD DEVIATION FOR THE BACKGROUND 1400 BKGSDV = 0.0 DO 1410 I=1,KOBS 1410 BKGSDV = BKGSDV + 1.0 / AMAX1( 1.0, YOBS(I) ) BKGSDV = SQRT( 1.0 / BKGSDV ) WRITE(ITTO,1450) BKGSDV/FTIME 1450 FORMAT(/,' Standard deviation of background = ',F10.6) C * C * FLAG THE BACKGROUND DETERMINATION PROCESS COMPLETE KBKGD = 1 GO TO 9000 C * C ** FIXED BACKGROUND SHAPE.... ONLY ADJUST ADDITIVE CONSTANT C * 4000 DO 4001 I=1,4 4001 CLC(I) = WGBAK(I) NCYCLE = 0 NTDEL = 0 LOFLAG = .FALSE. C * C * CALCULATE THE BACKGROUND IN YSYN, WEIGHTS IN YBKG TMP = ( 2.0**(1.0/CLC(3)) - 1.0 ) / ( (CLC(2)/2.0)**2 ) DO 4002 I=1,KOBS TEMP = CLC(1) / ( 1.0 + TMP * YANG(I)**2 )**CLC(3) YSYN(I) = TEMP + CLC(4)*YANG(I) YBKG(I) = 1.0 / AMAX1( 1.0, YOBS(I) ) 4002 CONTINUE C * C * COMPUTE THE AVERAGES AND STANDARD DEVIATION 4005 BCKGND = 0.0 SWGT = 0.0 IF(IWGT.EQ.0) THEN DO 4006 I=1,KOBS BCKGND = BCKGND + ( YOBS(I)-YSYN(I) ) SWGT = SWGT + YBKG(I) 4006 CONTINUE BCKGND = BCKGND / REAL( KOBS ) ELSE DO 4007 I=1,KOBS BCKGND = BCKGND + YBKG(I) * ( YOBS(I)-YSYN(I) ) SWGT = SWGT + YBKG(I) 4007 CONTINUE BCKGND = BCKGND / SWGT ENDIF CZZZ IF(BCKGND.LT.0.0) BCKGND = 0.0 BKGVAR = 1.0 / SWGT BKGSDV = SQRT( BKGVAR ) IF(ISENSE(5).NE.0) WRITE(ITTO,9993) BCKGND/FTIME,BKGSDV/FTIME 9993 FORMAT(' BCKGND = ',F8.4,' SIGMA = ',F8.4) TSIGMA = 2.00 C * C * ELIMINATE POINTS TSIGMA SIGMA ABOVE COMPUTED LINE NDEL = 0 DO 4010 I=1,KOBS YCALC = YSYN(I) + BCKGND YHI = YCALC + TSIGMA * SQRT( YCALC ) IF(YOBS(I).GT.YHI) GO TO 4012 IF(.NOT.LOFLAG) GO TO 4010 YLO = YCALC - TSIGMA * SQRT( YCALC ) IF(YOBS(I).GT.YLO) GO TO 4010 4012 YANG(I) = 0.0 NDEL = NDEL + 1 4010 CONTINUE C * C * COMPRESS LIST IF(NDEL.EQ.0) GO TO 4100 NTEMP = KOBS KOBS = 0 DO 4040 I=1,NTEMP IF(YANG(I).EQ.0.0) GO TO 4040 KOBS = KOBS + 1 IF(KOBS.EQ.I) GO TO 4040 YANG(KOBS) = YANG(I) YOBS(KOBS) = YOBS(I) YSYN(KOBS) = YSYN(I) YBKG(KOBS) = YBKG(I) 4040 CONTINUE C * 4100 IF(ISENSE(5).NE.0) WRITE(ITTO,9992) KOBS,NTEMP,NDEL NTDEL = NTDEL + NDEL NCYCLE = NCYCLE + 1 IF(NDEL.GT.0) GO TO 4005 IF(LOFLAG) GO TO 4200 LOFLAG = .TRUE. GO TO 4005 C * C * COPY THE BACKGROUND OFFSET TO COMMON 4200 CLY = BCKGND C * C * WRITE THE FIXED SHAPE BACKGROUND INFO WRITE(ITTO,4210) 4210 FORMAT(/,' Background evaluation with predetermined shape') WRITE(ITTO,1384) NCYCLE,KOBS,NTDEL WRITE(ITTO,4230) CLY/FTIME,BKGSDV/FTIME 4230 FORMAT(' Background offset = ',F8.4,' Sigma = ',F8.4) C * C * FLAG BACKGROUND DETERMINED KBKGD = 1 C * C * PROCESS COMPLETE... RETURN 9000 RETURN END C *** PFIT C * C * FUNCTION PFIT FITS AN NTH DEGREE LINEAR LEAST-SQUARES C * POLYNOMIAL CURVE TO THE M DATA POINTS CONTAINED IN THE C * X AND Y ARRAYS. RETURNED ARE THE STANDARD DEVIATION C * OF THE POINTS ABOUT THE REGRESSION CURVE AS THE VALUE C * OF THE FUNCTION AND THE Y INTERCEPT AND POLYNOMIAL C * COEFFICIENTS IN THE CALLING ARGUMENTS. IF THE VALUE C * OF N IS POSITIVE THEN THE POLYNOMIAL IS EVALUATED SO THE C * Y INTERCEPT IS REFINED AS A VARIABLE. HOWEVER, IF THE C * VALUE OF N IS NEGATIVE THEN THE Y INTERCEPT IS PINNED AT C * THE VALUE YINTCP AND THE SYSTEM OF SIMULTANEOUS USED C * TO DETERMINE THE REGRESSION COEFFICIENTS ARE EVALUATED C * ACCORDINGLY. C * C * C * CALLING ARGUMENTS: C * C * X = X DATA ARRAY C * Y = Y DATA ARRAY C * W = WEIGHTING FOR Y VALUES C * M = NUMBER OF POINTS IN REGRESSION C * N = DEGREE OF POLYNOMIAL FIT. IF N IS POSITIVE THE Y C * INTERCEPT VALUE IS REFINED. IF N IS NEGATIVE THEN C * THE POLYNOMIAL CURVE WILL BE REFINED SUCH THAT C * THE VALUE OF YINTCP WILL BE THE Y INTERCEPT. C * YINTCP = THE PINNED Y INTERCEPT C * IWGT = 0 - NO WEIGHTING 1 - WEIGHTING C * C * RETURN ARGUMENTS: C * C * PFIT = STANDARD DEVIATION OF THE POINTS ABOUT THE C * REGRESSION CURVE. C * PYINT = THE Y INTERCEPT OF THE REGRESSION CURVE. C * PB = THE REGRESSION COEFFICIENTS, LOW TO HIGH POWER. C * FUNCTION PFIT( X, Y, W, M, N, YINTCP, PYINT, PB, IWGT ) C * IMPLICIT REAL*8 (A-H,O-Z) REAL*4 PFIT, X(M), Y(M), W(M), YINTCP, PYINT, PB(10) DIMENSION C(11,11), SX(20), SYX(10), CYX(10), B(10) C * C * NDEG IS THE DEGREE OF THE POLYNOMIAL TO FIT NDEG = IABS( N ) C * C * INITIALIZE THE FUNCTION VALUE TO A LARGE NUMBER PFIT = 1.0E15 C * C * THE NUMBER OF POINTS MUST BE TWO GREATER THAN THE POWER IF(M.LT.NDEG+2) RETURN C * C * FIRST THROUGH TENTH DEGREE FIT ONLY IF( NDEG.LT.1 .OR. NDEG.GT.10 ) STOP'PFIT: BAD N' C * C * COMPUTE CONSTANTS FM = DBLE( M ) NTWO = 2 * NDEG NP1 = NDEG + 1 NP2 = NDEG + 2 C * C * INITIALIZE VARIABLES SY = 0.0 SYY = 0.0 DO 1 I=1,NDEG NPI = NDEG + I SX(I) = 0.0 SX(NPI) = 0.0 1 SYX(I) = 0.0 C * C * COMPUTE SUMS AND PRODUCTS WITHOUT WEIGHTS 2000 IF(IWGT.EQ.0) THEN DO 2010 I = 1,M SY = SY + Y(I) SYY = SYY + ( Y(I) * Y(I) ) DUM = 1.0 DO 2020 J = 1,NDEG DUM = DUM * X(I) SX(J) = SX(J) + DUM 2020 SYX(J) = SYX(J) + ( Y(I) * DUM ) DO 2010 J = NP1,NTWO DUM = DUM * X(I) 2010 SX(J) = SX(J) + DUM ELSE C * COMPUTE SUMS AND PRODUCTS WITH WEIGHTS FM = 0.0 DO 2030 I = 1,M FM = FM + W(I) SY = SY + ( W(I) * Y(I) ) SYY = SYY + ( W(I) * Y(I) * Y(I) ) DUM = W(I) DO 2040 J = 1,NDEG DUM = DUM * X(I) SX(J) = SX(J) + DUM 2040 SYX(J) = SYX(J) + ( Y(I) * DUM ) DO 2030 J = NP1,NTWO DUM = DUM * X(I) 2030 SX(J) = SX(J) + DUM ENDIF C * C * EXECUTE ACCORDING TO THE SIGN OF N. IF POSITIVE THEN REFINE THE C * Y INTERCEPT VALUE. IF NOT THEN NO REFINEMENT IS NECESSARY. IF(N.LT.0) GO TO 100 C * C * CREATE COEFFICIENT MATRIX DO 5 I = 1,NDEG CYX(I) = SYX(I) - ( SY * SX(I) / FM ) C(I,NP1) = CYX(I) DO 5 J = 1,NDEG IPJ = I + J 5 C(I,J) = SX(IPJ) - ( SX(I) * SX(J) / FM ) C * C * CALL SIMUL TO SOLVE SIMULTANEOUS EQUATIONS DET = SIMUL( NDEG, C, B, 11 ) C WRITE(7,300)DET C300 FORMAT(' THE DETERMINANT EQUALS ',F10.2) IF(DET.NE.0.0) GO TO 8 RETURN C * C * COMPUTE INTERCEPT YINT AND STANDARD DEVIATION SDEV 8 CYY = SYY - SY * SY / FM DO 9 I=1,NDEG SY = SY - B(I) * SX(I) 9 CYY = CYY - B(I) * CYX(I) PYINT = SY / FM DENOM = M - NDEG - 1 PFIT = DSQRT( DABS( CYY / DENOM ) ) GO TO 200 C * C * COMPUTE THE POLYNOMIAL WITH THE PINNED INTERCEPT C * C * CREATE COEFFICIENT MATRIX 100 DO 110 I=1,NDEG CYX(I) = SYX(I) - SY * SX(I) / FM DO 120 J=1,NDEG IPJ = I + J 120 C(I,J) = SX(IPJ) 110 C(I,NP1) = SYX(I) - YINTCP * SX(I) C * C * CALL SIMUL TO SOLVE SIMULTANEOUS EQUATIONS DET = SIMUL( NDEG, C, B, 11 ) C WRITE(7,300) DET IF(DET.NE.0.0) GO TO 130 RETURN C * C * RETURN THE Y INTERCEPT VALUE 130 PYINT = YINTCP C * C * COMPUTE STANDARD DEVIATION CYY = SYY - SY * SY / FM DO 150 I=1,NDEG 150 CYY = CYY - B(I) * CYX(I) DENOM = M - NDEG - 1 PFIT = DSQRT( DABS( CYY / DENOM ) ) C * C * TRANSFER THE COEFFICIENTS 200 DO 210 I=1,NDEG 210 PB(I) = B(I) C * RETURN END C *** FUNCTION SIMUL C * C * FUNCTION SIMUL SOLVES SIMULTANEOUS LINEAR EQUATIONS WHICH ARE C * SOLVED IN PLACE. THE GAUSS-JORDEN COMPLETE ELIMINATION METHOD C * IS EMPLOYED WITH THE MAXIMUM PIVOT STRATEGY. ROW AND COLUMN C * SUBSCRIPTS OF SUCCESSIVE PIVOT ELEMENTS ARE SAVED IN ORDER IN C * THE IROW AND JCOL ARRAYS RESPECTIVELY. K IS THE PIVOT COUNTER, C * PIVOT THE ALGEBRAIC VALUE OF THE PIVOT ELEMENT, MAX C * THE NUMBER OF COLUMNS IN A AND DETER THE DETERMINANT OF THE C * COEFFICIENT MATRIX. THE SOLUTIONS ARE COMPUTED IN THE (N+1)TH C * COLUMN OF A AND THEN UNSCRAMBLED AND PUT IN PROPER ORDER IN C * X(1)...X(N) USING THE PIVOT SUBSCRIPT INFORMATION AVAILABLE C * IN THE IROW AND JCOL ARRAYS, THE SIGN OF THE DETERMINANT IS C * ASJUSTED, IF NECESSARY, BY DETERIMINING IF AN ODD OR EVEN NUMBER C * OF PAIRWISE INTERCHANGES IS REQUIRED TO PUT THE ELEMENTS OF THE C * JORD ARRAY IN ASCENDING SEQUENCE WHERE JORD(IROW(I))=JCOL(I). C * FUNCTION SIMUL COMPUTES THE VALUE OF THE DETERMINANT AND C * IS RETURNED AS THE VALUE OF THE FUNCTION. SHOULD THE POTENTIAL C * PIVOT OF LARGEST MAGNITUDE BE SMALLER IN MAGNITUDE THAN EPS, C * THE MATRIX IS CONSIDERED TO BE SINGULAR AND A TRUE ZERO IS C * RETURNED AS THE VALUE OF THE FUNCTION. C * FUNCTION SIMUL( N, A, X, NRC ) C * IMPLICIT REAL*8 (A-H,O-Z) COMMON /LUNS/ ITTI,ITTO,IOFI,IOFO,IOBO,IOPL,IOPO,IOLO,IOSC,IOWG DIMENSION IROW(30),JCOL(30),JORD(30),A(NRC,NRC),X(N) DATA EPS/1.00E-20/ C * MAX=N+1 C * C * INSURE N IS LESS THAN 30 IF(N.GT.30) STOP'SIMUL: N TOO LARGE' C * C * BEGIN ELIMINATION PROCEDURE 5 DETER=1.0 DO 18 K=1,N KM1=K-1 C * C * SEARCH FOR PIVOT ELEMENT PIVOT=0.0 DO 11 I=1,N DO 11 J=1,N C * SCAN IROW AND JCOL ARRAYS FOR INVALID PIVOT SUBSCRIPTS IF(K.EQ.1) GO TO 9 DO 8 ISCAN=1,KM1 DO 8 JSCAN=1,KM1 IF(I.EQ.IROW(ISCAN))GO TO 11 8 IF(J.EQ.JCOL(JSCAN))GO TO 11 9 IF(DABS(A(I,J)).LE.DABS(PIVOT))GO TO 11 PIVOT=A(I,J) IROW(K)=I JCOL(K)=J 11 CONTINUE C * C * INSURE THAT THE SELECTED PIVOT ELEMENT IS LARGER THAN EPS IF(DABS(PIVOT).GT.EPS)GO TO 13 WRITE(ITTO,100) 100 FORMAT(/,' -SIMUL: WARNING - PIVOT ELEMENT TOO SMALL') SIMUL=0.0 RETURN C * C * UPDATE THE DETERMINATE VALUE 13 IROWK=IROW(K) JCOLK=JCOL(K) DETER=DETER*PIVOT C * C * NORMALIZE PIVOT ROW ELEMENTS DO 14 J=1,MAX 14 A(IROWK,J)=A(IROWK,J)/PIVOT C * C * CARRY OUT ELIMINATION AND CARRY OUT INVERSE A(IROWK,JCOLK)=1.0/PIVOT DO 18 I=1,N AIJCK=A(I,JCOLK) IF(I.EQ.IROWK)GO TO 18 A(I,JCOLK)=-AIJCK/PIVOT DO 17 J=1,MAX 17 IF(J.NE.JCOLK) A(I,J)=A(I,J)-AIJCK*A(IROWK,J) 18 CONTINUE C * C * ORDER SOLUTION VALUES AND CREATE JORD ARRAY DO 20 I=1,N IROWI=IROW(I) JCOLI=JCOL(I) JORD(IROWI)=JCOLI 20 X(JCOLI)=A(IROWI,MAX) C * C * ADJUST THE SIGN OF THE DETERMINANT INTCH=0 NM1=N-1 DO 22 I=1,NM1 IP1=I+1 DO 22 J=IP1,N IF(JORD(J).GE.JORD(I))GO TO 22 JTEMP=JORD(J) JORD(J)=JORD(I) JORD(I)=JTEMP INTCH=INTCH+1 22 CONTINUE IF(INTCH/2*2.NE.INTCH) DETER=-DETER C * C * RETURN WITH RESULTS 24 SIMUL = DETER RETURN END C *** PROGRAM: SHADOW (SHADOW20) C *** VERSION: 860822 (YYMMDD) C * C *** GETWSG - GET INSTRUMENT RELATED PARAMETERS C * SUBROUTINE GETWSG C * CHARACTER LINE72*72,LINEID*10,QWGTTL*72,QWGFID*32,QWGANS*1 CHARACTER FILEID*20, FILEXX*20, QDATE*9, QTIME*8 PARAMETER ( FILEID = '*** INS CALIBRATION' ) COMMON /LUNS/ ITTI,ITTO,IOFI,IOFO,IOBO,IOPL,IOPO,IOLO,IOSC,IOWG COMMON /WGDATN/ WGBAK(6),WGPRO(4,3),WGRAD(5,2),WGCAL(3) COMMON /MODEOP/ KMODEO,KSAMEP,KAUTOP COMMON /WGDATC/ QWGTTL,QWGFID,QWGANS COMMON /WDATA/ NWAVE,WTABLE(5,2) DIMENSION WCU(5,2), BKF(6), FF(3), FB(3), SF(3), SB(3) EQUIVALENCE ( LINE72(1:20), FILEXX ) DATA WCU/ 1.540598, 1.544435, 1.534380, 0.0, 0.0, 1 1.00 , 0.50 , 0.01 , 0.0, 0.0/ DATA BKF(1)/ 0.168128E+4 / DATA BKF(2)/ 0.211972E+1 / DATA BKF(3)/ 0.713281E+0 / DATA BKF(4)/ 0.628660E-1 / DATA BKF(5)/-0.184998E+1 / DATA BKF(6)/ 0.000000E+0 / DATA FF/ 0.236949E-2,-0.203249E-3, 0.108885E-2/ DATA FB/ 0.620709E-3, 0.144402E-3, 0.137567E-2/ DATA SF/ 0.183509E+1,-0.137454E-1, 0.544673E-4/ DATA SB/ 0.103232E+1,-0.145803E-2, 0.423803E-5/ C * C * IF IN AUTOMODE BASE ACTION ON PREVIOUSLY ANSWERED QUESTION IF(KAUTOP.NE.0) GO TO 1199 C * C * SET DEFAULTS WAVELENGTHS 1000 DO 1010 I=1,5 WTABLE(I,1) = WCU(I,1) WTABLE(I,2) = WCU(I,2) 1010 CONTINUE NWAVE = 3 C * C * SET THE DEFAULT BACKGROUND COEFFICIENTS DO 1020 I=1,6 1020 WGBAK(I) = BKF(I) C * C * SET THE DEFAULT INSTRUMENTAL PROFILE PARAMETERS DO 1030 I=1,3 WGPRO(1,I) = FF(I) WGPRO(2,I) = SF(I) WGPRO(3,I) = FB(I) WGPRO(4,I) = SB(I) 1030 CONTINUE C * C * SET THE DEFAULT DELTA 2THETA COEFFICIENTS DO 1040 I=1,3 1040 WGCAL(I) = 0.0 C * C * INDICATE DEFAULT PARAMETERS HAVE BEEN USED QWGTTL = 'DEFAULT PROGRAM PARAMETERS' C * C * GET THE INFORMATION REGARDING THE INSTRUMENT 1100 WRITE(ITTO,1110) 1110 FORMAT(/,' The standard Cu radiation wavelengths are default.') 1120 WRITE(ITTO,1130) 1130 FORMAT(/,' Wavelength Relative intensity') DO 1140 I=1,NWAVE 1140 WRITE(ITTO,1150) WTABLE(I,1), WTABLE(I,2) 1150 FORMAT(2X,F8.5,9X,F6.4) 1160 IF(KMODEO.NE.2) WRITE(ITTO,1170) 1170 FORMAT(/,' A - Accept wavelengths',/, 1 ' S - Set new wavelengths',/, 1 ' R - Read instrument calibration file',//, 1 ' Choice ? ') READ(ITTI,1180) QWGANS,QWGFID 1180 FORMAT(A1,A32) IF(QWGFID.EQ.' ') QWGFID = 'WSGDAT' IF( QWGANS.NE.'A' .AND. QWGANS.NE.'a' .AND. 1 QWGANS.NE.'S' .AND. QWGANS.NE.'s' ) QWGANS = 'R' IF( QWGANS.EQ.'R' .AND. QWGFID(1:3).NE.'WSG') THEN WRITE(ITTO,1182) QWGFID 1182 FORMAT(/,' -Instrument data file name must begin with "WSG":', 1 ' Using WSGDAT') QWGFID = 'WSGDAT' ENDIF C * C * CONFIRM THE RESPONSE 1199 IF(KMODEO.EQ.1) WRITE(IOBO,1190) QWGANS,QWGFID 1190 FORMAT(A1,A32,T40,'(A)ccept, (S)et or (R)ead') IF( KMODEO.EQ.2 .OR. KAUTOP.NE.0 ) WRITE(ITTO,1195) QWGANS,QWGFID 1195 FORMAT(/,' Wavelengths: (A)ccept, (S)et or (R)ead: ', 1 A1,1X,A32) C * C * DO IT IF( (QWGANS.EQ.'A'.OR.QWGANS.EQ.'a') .AND. KAUTOP.NE.0 )GO TO 9000 IF( (QWGANS.EQ.'R'.OR.QWGANS.EQ.'r') .AND. KAUTOP.NE.0 )GO TO 9000 IF( QWGANS.EQ.'A' .OR. QWGANS.EQ.'a' ) GO TO 1300 IF( QWGANS.EQ.'R' .OR. QWGANS.EQ.'r' ) GO TO 2000 C * C ** GET THE NEW RADIATION WAVELENGTHS C * C * C * INDICATE RADIATION PARAMETERS HAVE BEEN SET 1200 QWGTTL = 'RADIATION PARAMETERS SET BY OPERATOR' C * IF( KMODEO.NE.2 .AND. KAUTOP.EQ.0 ) THEN WRITE(ITTO,1210) 1210 FORMAT(/,' Enter the new wavelengths in (A) and relative', 1 ' intensities by pairs.',/,' A blank line ends input. ',/) ELSE WRITE(ITTO,1212) 1212 FORMAT(/,' Radiation data has been set as follows:',/) ENDIF DO 1220 I=1,5 IF(KAUTOP.EQ.0) THEN IF(KMODEO.NE.2) THEN WRITE(ITTO,1222) 1222 FORMAT(' Wavelength, Relative intensity ? ') WTABLE(I,1) = 0.0 WTABLE(I,2) = 0.0 READ(ITTI,*) WTABLE(I,1),WTABLE(I,2) ELSE READ(ITTI,1230) WTABLE(I,1), WTABLE(I,2) 1230 FORMAT(F10.6,F7.4) ENDIF ELSE WTABLE(I,1) = WTABLE(I,1) * 1.0E10 ENDIF IF(WTABLE(I,1).EQ.0.0) WTABLE(I,2) = 0.0 IF(KMODEO.EQ.1) WRITE(IOBO,1240) WTABLE(I,1),WTABLE(I,2) 1240 FORMAT(F10.6,F7.4,T40,' Wavelength entry') IF(WTABLE(I,1).EQ.0.0) GO TO 1300 IF( KMODEO.EQ.2 .OR. KAUTOP.NE.0 ) WRITE(ITTO,1242) WTABLE(I,1), 1 WTABLE(I,2) 1242 FORMAT(' Wavelength ',F10.6,' Relative Intensity ',F7.4) NWAVE = I 1220 CONTINUE C * C * SCALE WAVELENGTH VALUES TO ANGSTROMS 1300 DO 1310 I=1,NWAVE WTABLE(I,1) = WTABLE(I,1) * 1.0E-10 WGRAD(I,1) = WTABLE(I,1) 1310 WGRAD(I,2) = WTABLE(I,2) GO TO 9000 C * C ** READ THE INSTRUMENT CALIBRATION FILE, DEFAULT IS 'WSGDAT' C * 2000 IF( QWGFID.NE.'WSGDAT' .AND. KMODEO.NE.2 ) WRITE(ITTO,2002) QWGFID 2002 FORMAT(/,' Reading instrument data from: ',A32) CVAX C OPEN(UNIT=IOWG,FILE=QWGFID,STATUS='OLD',ERR=2010,READONLY) CVAX CIBM OPEN(UNIT=IOWG,FILE=QWGFID,STATUS='OLD',ERR=2010) CIBM GO TO 2100 2010 WRITE(ITTO,2020) 2020 FORMAT(' --Instrument data file does not exist:', 1' Use INSCAL to create one') GO TO 1160 C * C * A FILE IS THERE... DETERMINE IF IT IS A PARAMETER FILE 2100 READ(IOWG,2112,END=2115) LINE72 2112 FORMAT(1X,A72) IF(FILEID.EQ.FILEXX) GO TO 2200 C * FILE EXISTS BUT NOT AN INSTRUMENT DATA FILE... 2115 WRITE(ITTO,2120) 2120 FORMAT(' --File is not an instrument calibration file') CLOSE(UNIT=IOWG) GO TO 1160 C * C * READ THE CALIBRATION FILE HEADER 2200 READ(IOWG,2112) QWGTTL C * C * READ THE RADIATION WAVELENGTHS NWAVE = 0 DO 2210 I=1,5 READ(IOWG,2220) LINEID,WGRAD(I,1),WGRAD(I,2),Z,QDATE,QTIME 2220 FORMAT(1X,A10,3(1X,E13.6),1X,A9,1X,A8) IF(WGRAD(I,1).GT.0.0) THEN NWAVE = NWAVE + 1 WTABLE(NWAVE,1) = WGRAD(I,1) WTABLE(NWAVE,2) = WGRAD(I,2) WTABLE(NWAVE,1) = WTABLE(NWAVE,1) * 1.0E-10 WGRAD(I,1) = WGRAD(I,1) * 1.0E-10 ENDIF 2210 CONTINUE C * C * READ THE BACKGROUND DATA READ(IOWG,2220) LINEID,(WGBAK(I),I=1,3),QDATE,QTIME READ(IOWG,2220) LINEID,(WGBAK(I),I=4,6),QDATE,QTIME C * C * READ THE INSTRUMENT PROFILE DATA DO 2240 I=1,4 READ(IOWG,2220) LINEID,T1,T2,T3,QDATE,QTIME IF( T1.EQ.0.0 .AND. T2.EQ.0.0 .AND. T3.EQ.0.0 ) GO TO 2240 WGPRO(I,1) = T1 WGPRO(I,2) = T2 WGPRO(I,3) = T3 2240 CONTINUE C * C * READ THE CALIBRATION CURVE PARAMETERS READ(IOWG,2220) LINEID,(WGCAL(I),I=1,3),QDATE,QTIME C * CLOSE(UNIT=IOWG) C * 9000 RETURN END C *** INITIO - GET PATTERN FILE PARAMETERS C * SUBROUTINE INITIO( KODE ) C * C * EXIT PARAMETER KODE: 0 => OPERATION SUCCESFUL, FILE OPEN C * 1 => OPERATION UNSUCCESFUL, FILE NOT OPEN C * C * CHARACTER QDATE*9, QTIME*8, QPTFID*32, QANS*1, QFTITL*80 COMMON /LUNS/ ITTI,ITTO,IOFI,IOFO,IOBO,IOPL,IOPO,IOLO,IOSC,IOWG COMMON /FLDATN/ KFILET,FBANG,FEANG,FAINC,FTIME COMMON /MODEOP/ KMODEO,KSAMEP,KAUTOP COMMON /XXFILE/ QPTFID COMMON /FLDATC/ QFTITL C * C * GET THE DATA FILE NAME... QUIT IF BLANK C * 1000 KODE = 0 IF(KAUTOP.NE.1) THEN CLOSE(UNIT=IOFI) IF(KMODEO.NE.2) WRITE(ITTO,1010) 1010 FORMAT(/,' The name of the pattern file ? ') READ(ITTI,1020) QPTFID 1020 FORMAT(A32) ENDIF IF(KMODEO.EQ.1) WRITE(IOBO,1025) QPTFID 1025 FORMAT(A32,T40,'Pattern file name') IF( KMODEO.EQ.2 .OR. KAUTOP.EQ.1 ) WRITE(ITTO,1035) QPTFID 1035 FORMAT(/,' Pattern file: ',A32) IF(QPTFID(1:1).NE.' ') GO TO 1030 KODE = 1 GO TO 9000 C * C * GET THE DATA FILE TYPE C * 1030 IF(KAUTOP.NE.1) THEN IF(KMODEO.NE.2) WRITE(ITTO,1040) 1040 FORMAT(' (F)ormatted or (U)nformatted file type ? ') READ(ITTI,1050) QANS 1050 FORMAT(A1) ELSE QANS = 'F' IF(KFILET.EQ.1) QANS = 'U' ENDIF IF( QANS.EQ.'U' .OR. QANS.EQ.'u' ) THEN KFILET = 1 ELSE QANS = 'F' KFILET = 0 ENDIF IF(KMODEO.EQ.1) WRITE(IOBO,1051) QANS 1051 FORMAT(A1,T40,' Formatted/unformatted file') IF( KMODEO.EQ.2 .OR. KAUTOP.EQ.1 ) WRITE(ITTO,1052) QANS 1052 FORMAT(' Pattern file is formatted/unformatted: ',A1) IF(KAUTOP.EQ.1) GO TO 9000 C * C * OPEN FILE AND GET PATTERN PARAMETERS IF(KFILET.EQ.0) THEN CVAX C OPEN(UNIT=IOFI,FILE=QPTFID,STATUS='OLD',READONLY, C 1 FORM='FORMATTED',ERR=1070) CVAX CIBM OPEN(UNIT=IOFI,FILE=QPTFID,STATUS='OLD', 1 FORM='FORMATTED',ERR=1070) CIBM READ(IOFI,2010) QFTITL 2010 FORMAT(A80) READ(IOFI,2030) QDATE,QTIME 2030 FORMAT(A9,A8) READ(IOFI,2050) FBANG,FEANG,FAINC,FTIME 2050 FORMAT(4F10.4) ELSE CVAX C OPEN(UNIT=IOFI,FILE=QPTFID,STATUS='OLD',READONLY, C 1 FORM='UNFORMATTED',ERR=1070) CVAX CIBM OPEN(UNIT=IOFI,FILE=QPTFID,STATUS='OLD', 1 FORM='UNFORMATTED',ERR=1070) CIBM READ(IOFI) QFTITL READ(IOFI) QDATE,QTIME READ(IOFI) FBANG,FEANG,FAINC,FTIME ENDIF C * 2000 WRITE(ITTO,2001) 2001 FORMAT(/,' The run time parameters for this file are:') WRITE(ITTO,2020) QFTITL(1:72) 2020 FORMAT(/,1X,A72) WRITE(ITTO,2040) QDATE,QTIME 2040 FORMAT(/,' Pattern recorded Date: ',A9,' Time: ',A8) WRITE(ITTO,2060) FBANG,FEANG,FAINC,FTIME 2060 FORMAT(/,' Starting angle : ',F8.4, 1 ' Ending angle : ',F8.4,/, 1 ' Angle increment: ',F8.4, 1 ' Step time : ',F8.4) GO TO 9000 C * C * AN ERROR OCCURED ON FILE OPENING 1070 WRITE(ITTO,1080) 1080 FORMAT(' --File busy or not there') KODE = 1 C * C * EXIT STAGE RIGHT 9000 RETURN END C *** PARAMS - READ OR WRITE PARAMETER FILE C * SUBROUTINE PARAMS C * LOGICAL EXISTS, LAPPND, LHTEOF CHARACTER IOFILE*8,IDBACK*8,IDSEAR*8,IDREFN*8,LINE72*72,LINEID*8 CHARACTER WGBACK*10, WGPROF*10, WGWAVE*10, WGCALB*10, IDWSGP*10 CHARACTER PRFILE*32,QPTFID*32,LINEPT*32,QRW*1,QANS*1,QWGTTL*72 CHARACTER QDATE*9,QTIME*8,WID*1 PARAMETER ( IOFILE = '***FILE:' ) PARAMETER ( IDREFN = '*REFINE:' ) PARAMETER ( IDSEAR = '*SEARCH:' ) PARAMETER ( IDBACK = '*BAKGND:' ) PARAMETER ( IDWSGP = '*PROFIL:' ) PARAMETER ( WGBACK = 'BACKGROUND' ) PARAMETER ( WGPROF = 'PROFILES ' ) PARAMETER ( WGWAVE = 'RADIATION ' ) PARAMETER ( WGCALB = 'DELTA 2THT' ) PARAMETER ( DTORD2=8.72664626E-3, RTODT2=114.591559 ) COMMON /REFFLG/ KPROF,KLRNZ,KERRT,KASYM,KBKGR,KBKGD,KAMOR,KCRYS COMMON /LUNS/ ITTI,ITTO,IOFI,IOFO,IOBO,IOPL,IOPO,IOLO,IOSC,IOWG COMMON /SCHDAT/ KNFND,PSIGMA,RELLOW,BIGINT,KNSMO,KFFLT,KFMNT COMMON /WGDATN/ WGBAK(6),WGPRO(4,3),WGRAD(5,2),WGCAL(3) COMMON /BKGDAT/ LDEG,CLY,CLC(6),BKGSDV,IBKCPS,IBKNBK COMMON /WSGDAT/ KWSGLN,WSGPAR(200,12) COMMON /PEAKDT/ NPEAK,PEAKS(200,4) COMMON /WDATA/ NWAVE,WTABLE(5,2) COMMON /MODEOP/ KMODEO,KSAMEP,KAUTOP COMMON /WGDATC/ QWGTTL COMMON /XXFILE/ QPTFID EQUIVALENCE ( LINE72(1: 8), LINEID ) EQUIVALENCE ( LINE72(9:40), LINEPT ) C * C ** GET FILE NAME AND DETERMINE MODE OF OPERATION C * 1000 IF(KMODEO.EQ.2) THEN WRITE(ITTO,1002) 1002 FORMAT('1',6X,'* * * P A R A M E T E R F I L E F U N C', 1 ' T I O N S * * *') ELSE WRITE(ITTO,1004) 1004 FORMAT(/,' * Parameter file functions') ENDIF IF(KAUTOP.EQ.0) THEN IF(KMODEO.NE.2) WRITE(ITTO,1010) 1010 FORMAT(/,' Parameter file name ? ') READ(ITTI,1020) PRFILE 1020 FORMAT(A32) ELSE PRFILE = 'AUTOPRM' ENDIF IF(KMODEO.EQ.1) WRITE(IOBO,1030) PRFILE 1030 FORMAT(A32,T40,' File name') IF( KMODEO.EQ.2 .OR. KAUTOP.NE.0 ) WRITE(ITTO,1040) PRFILE 1040 FORMAT(/,' File name: ',A32) IF(PRFILE(1:1).EQ.' ') GO TO 9000 IF(KAUTOP.EQ.0) THEN IF(KMODEO.NE.2) WRITE(ITTO,1050) 1050 FORMAT(' (R)ead or (W)rite parameter file ? ') READ(ITTI,1060) QRW 1060 FORMAT(A1) ELSE QRW = 'W' ENDIF IF( QRW.NE.'W' .AND. QRW.NE.'w' ) QRW = 'R' IF(KMODEO.EQ.1) WRITE(IOBO,1070) QRW 1070 FORMAT(A1,T40,' Read/write') IF( KMODEO.EQ.2 .OR. KAUTOP.NE.0 ) WRITE(ITTO,1080) QRW 1080 FORMAT(' Read or write to parameter file: ',A1) C * C ** CHECK FILE FOR EXISTANCE AND CORRECT ID FOR CURRENT FILE C * C * TEST FOR FILE EXISTANCE C INQUIRE(FILE=PRFILE,EXIST=EXISTS) C IF(EXISTS) GO TO 2200 C IF( QRW.EQ.'W' .OR. QRW.EQ.'w' ) GO TO 2100 CIBM IF YOU HAVE AN NON-IBM MACHINE, THEN REMOVE THE CIBM FOLLOWING STATEMENTS AND USE THE INQUIRE STATEMENT ABOVE. IF(KAUTOP.EQ.0) THEN IF(KMODEO.NE.2) WRITE(ITTO,2010) 2010 FORMAT(' Does this parameter file currently exist ? ') READ(ITTI,1060) QANS ELSE QANS = 'N' ENDIF IF( QANS.NE.'N' .AND. QANS.NE.'n' ) QANS = 'Y' IF(KMODEO.EQ.1) WRITE(IOBO,2020) QANS 2020 FORMAT(A1,T40,' Parameter file exists') IF( KMODEO.EQ.2 .OR. KAUTOP.NE.0 ) WRITE(ITTO,2030) QANS 2030 FORMAT(' Parameter file exists: ',A1) C * C * CHECK FOR AUTOPILOT AND/OR FILE EXISTANCE IF(KAUTOP.NE.0) GO TO 6000 IF( QANS.EQ.'Y' .OR. QANS.EQ.'y' ) GO TO 2200 IF( QRW.EQ.'W' .OR. QRW.EQ.'w' ) GO TO 2100 CIBM C * C * FILE DOES NOT EXIST WRITE(ITTO,2040) 2040 FORMAT(' --File does not exist and read specified: Abort') GO TO 9000 C * C * FILE DOES NOT EXIST AND WRITE SPECIFIED... START A NEW ONE CVAX C2100 OPEN(UNIT=IOPO,FILE=PRFILE,STATUS='NEW',FORM='FORMATTED', C 1CARRIAGECONTROL='LIST') CIBM 2100 OPEN(UNIT=IOPO,FILE=PRFILE,STATUS='UNKNOWN',FORM='FORMATTED') CIBM CALL DATE(QDATE) CALL TIME(QTIME) WRITE(IOPO,2110) IOFILE,QPTFID,QDATE,QTIME 2110 FORMAT(1X,A8,A32,5X,'Created:',1X,A9,1X,A8) CLOSE(UNIT=IOPO) C * C * A FILE IS THERE... DETERMINE IF IT IS A PARAMETER FILE 2200 OPEN(UNIT=IOPO,FILE=PRFILE,STATUS='OLD',ERR=2240) READ(IOPO,2210,END=2220) LINE72 2210 FORMAT(1X,A72) CLOSE(UNIT=IOPO) IF(LINEID.EQ.IOFILE) GO TO 2300 2220 WRITE(ITTO,2230) 2230 FORMAT(' --File does not exist or is not a parameter file.') GO TO 9000 2240 WRITE(ITTO,2250) 2250 FORMAT(' --File does not exist: abort.') GO TO 9000 C * C * PARAMETER FILE EXISTS... CHECK FOR CORRECT ID 2300 IF(LINEPT.EQ.QPTFID) GO TO 2400 WRITE(ITTO,2310) LINEPT 2310 FORMAT(' -Parameter file for: ',A32,'. Use this file ? ') READ(ITTI,1060) QANS IF( QANS.NE.'Y' .AND. QANS.NE.'y' ) QANS='N' IF(KMODEO.EQ.1) WRITE(IOBO,2320) QANS 2320 FORMAT(A1,T40,' Use foreign file') IF(KMODEO.EQ.2) WRITE(ITTO,2330) QANS 2330 FORMAT(' Use foreign file: ',A1) IF( QANS.EQ.'Y' .OR. QANS.EQ.'y' ) GO TO 2400 CLOSE (UNIT=IOPO) GO TO 9000 C * C * DO REQUESTED FUNCTION 2400 IF( QRW.EQ.'R' .OR. QRW.EQ.'r' ) GO TO 3000 IF( QRW.EQ.'W' .OR. QRW.EQ.'w' ) GO TO 6000 C * HMMMM.... WE SHOULD NOT BE HERE GO TO 9000 C * C ***** READ THE PARAMETER FILE C * 3000 OPEN(UNIT=IOPO,FILE=PRFILE,STATUS='OLD',FORM='FORMATTED') C * C ** GET THE BACKGROUND INFORMATION C * 3002 READ(IOPO,2210,END=4000) LINE72 IF(LINEID.NE.IDBACK) GO TO 3002 IF(KMODEO.NE.2) WRITE(ITTO,3004) 3004 FORMAT(/,' Read background parameters ? ') READ(ITTI,1060) QANS IF( QANS.NE.'N' .AND. QANS.NE.'n' ) QANS = 'Y' IF(KMODEO.EQ.1) WRITE(IOBO,3006) QANS 3006 FORMAT(A1,T40,' Read background params') IF(KMODEO.EQ.2) WRITE(ITTO,3008) QANS 3008 FORMAT(' Read background params: ',A1) IF( QANS.EQ.'N' .OR. QANS.EQ.'n' ) GO TO 4000 C * C * BACKGROUND FOUND... READ IT. READ(IOPO,3010) LDEG,KBKGD,BKGSDV,CLY 3010 FORMAT(//,30X,I3,1X,I1,24X,E13.6,//,22X,E13.6) DO 3020 I=1,5,2 IP1 = I + 1 READ(IOPO,3030) CLC(I),CLC(IP1) 3030 FORMAT(22X,E13.6,24X,E13.6) 3020 CONTINUE C * C ** GET THE PEAK SEARCH RESULTS C * 4000 REWIND (UNIT=IOPO) 4002 READ(IOPO,2210,END=5000) LINE72 IF(LINEID.NE.IDSEAR) GO TO 4002 IF(KMODEO.NE.2) WRITE(ITTO,4004) 4004 FORMAT(' Read peak search results ? ') READ(ITTI,1060) QANS IF( QANS.NE.'N' .AND. QANS.NE.'n' ) QANS = 'Y' IF(KMODEO.EQ.1) WRITE(IOBO,4006) QANS 4006 FORMAT(A1,T40,' Read search params') IF(KMODEO.EQ.2) WRITE(ITTO,4008) QANS 4008 FORMAT(' Read search parameters: ',A1) IF( QANS.EQ.'N' .OR. QANS.EQ.'n' ) GO TO 5000 C * C * GET THE PARAMETERS USED IN THE SEARCH READ(IOPO,4010) PSIGMA,RELLOW,KNFND,KNSMO,KFFLT,KFMNT 4010 FORMAT(//,27X,F5.2,27X,F5.2,2(/,27X,I5,27X,I5),///) C * C * GET THE PEAK INFORMATION BIGINT = 0.0 NPEAK = 0 4030 READ(IOPO,4040,END=4100) IP,POS,LAMBDA,HGT,DSP,RI 4040 FORMAT(1X,I3,2X,F9.4,4X,I1,2X,F10.4,2X,F9.4,2X,F9.4) IF(IP.EQ.999) GO TO 5000 NPEAK = NPEAK + 1 PEAKS(NPEAK,1) = POS - CORPOS( POS ) PEAKS(NPEAK,2) = HGT BIGINT = AMAX1( BIGINT, HGT ) PEAKS(IP,4) = MAX( LAMBDA, 1 ) GO TO 4030 4100 WRITE(ITTO,4110) 4110 FORMAT(/,' -Premature EOF hit: Continuing') C * C ** GET THE REFINED LINE PARAMETERS C * 5000 REWIND (UNIT=IOPO) 5002 READ(IOPO,2210,END=11000) LINE72 IF(LINEID.NE.IDREFN) GO TO 5002 IF(KMODEO.NE.2) WRITE(ITTO,5004) 5004 FORMAT(' Read refined line results ? ') READ(ITTI,1060) QANS IF( QANS.NE.'N' .AND. QANS.NE.'n' ) QANS = 'Y' IF(KMODEO.EQ.1) WRITE(IOBO,5006) QANS 5006 FORMAT(A1,T40,' Read refined lines') IF(KMODEO.EQ.2) WRITE(ITTO,5008) QANS 5008 FORMAT(' Read refined line params: ',A1) IF( QANS.EQ.'N' .OR. QANS.EQ.'n' ) GO TO 11000 C * C * SKIP THE HEADER RECORDS READ(IOPO,5009) 5009 FORMAT(///) C * C * GET THE REFINED LINE INFORMATION BIGINT = 0.0 NPEAK = 0 5010 READ(IOPO,4040,END=5100) IP,POS,LAMBDA,HGT,DSP,RI IF(IP.EQ.999) GO TO 11000 NPEAK = NPEAK + 1 PEAKS(NPEAK,1) = POS - CORPOS( POS ) PEAKS(NPEAK,2) = HGT BIGINT = AMAX1( BIGINT, HGT ) PEAKS(IP,4) = MAX( LAMBDA, 1 ) GO TO 5010 5100 WRITE(ITTO,4110) C * C ** GET THE INSTRUMENT PARAMETERS FROM THE FILE C * 11000 REWIND (UNIT=IOPO) 11002 READ(IOPO,2210,END=9000) LINE72 IF(LINEID.NE.IDWSGP) GO TO 11002 IF(KMODEO.NE.2) WRITE(ITTO,11004) 11004 FORMAT(' Read instrument parameters ? ') READ(ITTI,1060) QANS IF( QANS.NE.'N' .AND. QANS.NE.'n' ) QANS = 'Y' IF(KMODEO.EQ.1) WRITE(IOBO,11006) QANS 11006 FORMAT(A1,T40,' Read instrument parameters') IF(KMODEO.EQ.2) WRITE(ITTO,11008) QANS 11008 FORMAT(' Read instrument parameters: ',A1) IF( QANS.EQ.'N' .OR. QANS.EQ.'n' ) GO TO 9000 C * C * BYPASS HEADER RECORD AND READ FILE IDENTIFIER 11100 READ(IOPO,2210) LINE72 READ(IOPO,2210) QWGTTL C * C * READ THE RADIATION PARAMETERS DO 11120 I=1,5 11120 READ(IOPO,11130) LINEID,WGRAD(I,1),WGRAD(I,2),ZERO,QDATE,QTIME 11130 FORMAT(1X,A10,3(1X,E13.6),1X,A9,1X,A8) C * C * READ THE BACKGROUND PARAMETERS READ(IOPO,11130) LINEID,(WGBAK(I),I=1,3),QDATE,QTIME READ(IOPO,11130) LINEID,(WGBAK(I),I=4,6),QDATE,QTIME C * C * READ THE PROFILE CALIBRATION PARAMETERS READ(IOPO,11130) LINEID,(WGPRO(1,I),I=1,3),QDATE,QTIME READ(IOPO,11130) LINEID,(WGPRO(2,I),I=1,3),QDATE,QTIME READ(IOPO,11130) LINEID,(WGPRO(3,I),I=1,3),QDATE,QTIME READ(IOPO,11130) LINEID,(WGPRO(4,I),I=1,3),QDATE,QTIME C * C * READ THE TWO-THETA ERROR CURVE READ(IOPO,11130) LINEID,(WGCAL(I),I=1,3),QDATE,QTIME GO TO 9000 C * C ***** WRITE PARAMETERS C * C ** WRITE THE BACKGROUND PARAMETERS C * 6000 IF(KAUTOP.EQ.0) THEN IF(KMODEO.NE.2) WRITE(ITTO,6002) 6002 FORMAT(/,' Write background parameters ? ') READ(ITTI,1060) QANS ELSE QANS = 'Y' ENDIF IF( QANS.NE.'Y' .AND. QANS.NE.'y' ) QANS = 'N' IF(KMODEO.EQ.1) WRITE(IOBO,6004) QANS 6004 FORMAT(A1,T40,' Write background params') IF( KMODEO.EQ.2 .OR. KAUTOP.NE.0 ) WRITE(ITTO,6006) QANS 6006 FORMAT(' Write background params: ',A1) IF( QANS.NE.'Y' .AND. QANS.NE.'y' .OR. KAUTOP.NE.0 ) GO TO 7000 C * C * OPEN OLD AND SCRATCH FILES OPEN(UNIT=IOPO,FILE=PRFILE,STATUS='OLD') CVAX C OPEN(UNIT=IOSC,FILE='FIXED80',STATUS='NEW',FORM='FORMATTED', C 1CARRIAGECONTROL='LIST') CVAX CIBM OPEN(UNIT=IOSC,FILE='FIXED80',STATUS='UNKNOWN',FORM='FORMATTED') CIBM C * C * COPY OLD FILE... BYPASS OLD BACKGROUND PARAMETERS 6100 READ(IOPO,2210,END=6130) LINE72 IF(LINEID.EQ.IDBACK) GO TO 6110 WRITE(IOSC,2210) LINE72 GO TO 6100 6110 WRITE(ITTO,6112) 6112 FORMAT(' -Replacing existing background parameters') 6115 READ(IOPO,2210,END=6130) LINE72 IF(LINEID.NE.IDBACK) GO TO 6115 GO TO 6100 6130 CLOSE(UNIT=IOPO) C * C * WRITE THE NEW PARAMETERS 6200 CALL DATE( QDATE ) CALL TIME( QTIME ) WRITE(IOSC,6210) IDBACK,QDATE,QTIME 6210 FORMAT(1X,A8,36X,'Recorded:',1X,A9,1X,A8) WRITE(IOSC,6220) 6220 FORMAT(' * Background parameters:') WRITE(IOSC,6230) LDEG,KBKGD,BKGSDV,CLY 6230 FORMAT(/' Background form : ',8X,I3,1X,I1,2X, 1 ' Standard deviation : ',E13.6,//, 1 ' Background constant: ',E13.6) DO 6240 I=1,5,2 IP1 = I + 1 WRITE(IOSC,6250) I,CLC(I),IP1,CLC(IP1) 6240 CONTINUE 6250 FORMAT(' Coefficient ',I4,' : ',E13.6,2X, 1 ' Coefficient ',I4,' : ',E13.6) WRITE(IOSC,6210) IDBACK,QDATE,QTIME C * C * COPY THE TEMP FILE BACK TO THE PERMANENT FILE 6300 REWIND (UNIT=IOSC) CVAX C OPEN(UNIT=IOPO,FILE=PRFILE,STATUS='NEW',FORM='FORMATTED', C 1CARRIAGECONTROL='LIST') CVAX CIBM OPEN(UNIT=IOPO,FILE=PRFILE,STATUS='UNKNOWN',FORM='FORMATTED') CIBM 6310 READ(IOSC,2210,END=6399) LINE72 WRITE(IOPO,2210) LINE72 GO TO 6310 6399 CLOSE(UNIT=IOPO) CLOSE(UNIT=IOSC) C * C ** WRITE THE PEAK SEARCH PARAMETERS AND PEAKS FOUND C * 7000 IF(KAUTOP.EQ.0) THEN IF(KMODEO.NE.2) WRITE(ITTO,7002) 7002 FORMAT(' Write search results ? ') READ(ITTI,1060) QANS ELSE QANS = 'N' ENDIF IF( QANS.NE.'Y' .AND. QANS.NE.'y' ) QANS = 'N' IF(KMODEO.EQ.1) WRITE(IOBO,7004) QANS 7004 FORMAT(A1,T40,' Write search results') IF( KMODEO.EQ.2 .OR. KAUTOP.NE.0 ) WRITE(ITTO,7006) QANS 7006 FORMAT(' Write search results: ',A1) IF( QANS.NE.'Y' .AND. QANS.NE.'y' .OR. KAUTOP.NE.0 ) GO TO 8000 C * C * OPEN OLD AND NEW FILES OPEN(UNIT=IOPO,FILE=PRFILE,STATUS='OLD') CVAX C OPEN(UNIT=IOSC,FILE='FIXED80',STATUS='NEW',FORM='FORMATTED', C 1CARRIAGECONTROL='LIST') CVAX CIBM OPEN(UNIT=IOSC,FILE='FIXED80',STATUS='UNKNOWN',FORM='FORMATTED') CIBM C * C * COPY OLD FILE... BYPASS OLD SEARCH SECTION 7100 READ(IOPO,2210,END=7120) LINE72 IF(LINEID.EQ.IDSEAR) GO TO 7110 WRITE(IOSC,2210) LINE72 GO TO 7100 7110 WRITE(ITTO,7112) 7112 FORMAT(' -Replacing existing search results') 7115 READ(IOPO,2210,END=7120) LINE72 IF(LINEID.NE.IDSEAR) GO TO 7115 GO TO 7100 7120 CLOSE(UNIT=IOPO) C * C * WRITE THE PARAMETERS USED IN THE SEARCH 7200 CALL DATE( QDATE ) CALL TIME( QTIME ) WRITE(IOSC,6210) IDSEAR,QDATE,QTIME WRITE(IOSC,7220) 7220 FORMAT(' * Peak search results:') WRITE(IOSC,7230) PSIGMA,RELLOW,KNFND,KNSMO,KFFLT,KFMNT 7230 FORMAT(/2X,' STD devation threshold: ',F5.2, 1 2X,' Min relative intensity: ',F5.2,/, 1 2X,' Points used for search: ',I5, 1 2X,' Points used for smooth: ',I5,/, 1 2X,' Filter type : ',I5, 1 2X,' Filter moment : ',I5) C * C * LIST THE PEAK PARAMETERS WRITE(IOSC,7250) 7250 FORMAT(/,' NO. TWO-THETA REF INT. (CPS) D SPACING REL. INT.', 1 /,' --- --------- --- ---------- --------- ---------') C * C * HAVE ANY PEAKS BEEN DETECTED? IF(NPEAK.EQ.0) GO TO 7300 C * C * PRINT ALL THE PEAK INFORMATION BIGINT = 0.0 DO 7255 I=1,NPEAK 7255 IF(PEAKS(I,2).GT.BIGINT) BIGINT = PEAKS(I,2) BIGINT = BIGINT / 100.0 DO 7260 IP=1,NPEAK POSC = PEAKS(IP,1) + CORPOS( PEAKS(IP,1) ) RI = PEAKS(IP,2) / BIGINT LAMBDA = INT( PEAKS(IP,4) ) DSP = WTABLE(LAMBDA,1) / ( 2.0*SIN(POSC*DTORD2) ) * 1.0E10 WRITE(WID,7270) LAMBDA 7270 FORMAT(I1) IF(WID.EQ.'1') WID = ' ' WRITE(IOSC,7280)IP,POSC,WID,PEAKS(IP,2),DSP,RI 7280 FORMAT(' ',I3,2X,F9.4,4X,A1,2X,F10.4,2X,F9.4,2X,F9.4) 7260 CONTINUE C * C * WRITE END OF LIST MARKER 7300 WRITE(IOSC,7310) 7310 FORMAT(1X,'999') WRITE(IOSC,6210) IDSEAR,QDATE,QTIME C * C * COPY THE TEMP FILE BACK TO THE PERMANENT FILE 7400 REWIND (UNIT=IOSC) CVAX C OPEN(UNIT=IOPO,FILE=PRFILE,STATUS='NEW',FORM='FORMATTED', C 1CARRIAGECONTROL='LIST') CVAX CIBM OPEN(UNIT=IOPO,FILE=PRFILE,STATUS='UNKNOWN',FORM='FORMATTED') CIBM 7410 READ(IOSC,2210,END=7499) LINE72 WRITE(IOPO,2210) LINE72 GO TO 7410 7499 CLOSE(UNIT=IOPO) CLOSE(UNIT=IOSC) C * C ** WRITE THE REFINED LINE RESULTS C * 8000 IF(KAUTOP.EQ.0) THEN IF(KMODEO.NE.2) WRITE(ITTO,8002) 8002 FORMAT(' Write refined line results ? ') READ(ITTI,1060) QANS ELSE QANS = 'Y' ENDIF IF( QANS.NE.'Y' .AND. QANS.NE.'y' .AND. 1 QANS.NE.'A' .AND. QANS.NE.'a' ) QANS = 'N' IF(KMODEO.EQ.1) WRITE(IOBO,8004) QANS 8004 FORMAT(A1,T40,' Write refined line results') IF( KMODEO.EQ.2 .OR. KAUTOP.NE.0 ) WRITE(ITTO,8006) QANS 8006 FORMAT(' Write refined line results: ',A1) IF( QANS.NE.'Y' .AND. QANS.NE.'y' .AND. 1 QANS.NE.'A' .AND. QANS.NE.'a' .OR. KAUTOP.NE.0 ) GO TO 10000 C * C * OPEN OLD AND NEW FILES OPEN(UNIT=IOPO,FILE=PRFILE,STATUS='OLD') CVAX C OPEN(UNIT=IOSC,FILE='FIXED80',STATUS='NEW',FORM='FORMATTED', C 1CARRIAGECONTROL='LIST') CVAX CIBM OPEN(UNIT=IOSC,FILE='FIXED80',STATUS='UNKNOWN',FORM='FORMATTED') CIBM C * C * EXAMINE OLD FILE... COPY OR BYPASS EXISTING LINE PARAMETERS C * C * LOOK FOR EXISTING DATA 8100 LAPPND = .FALSE. LHTEOF = .TRUE. NOLDLN = 0 8102 READ(IOPO,2210,END=8200) LINE72 IF(LINEID.EQ.IDREFN) GO TO 8110 WRITE(IOSC,2210) LINE72 GO TO 8102 C * C * EXISTING DATA FOUND... COPY OR BYPASS 8110 LHTEOF = .FALSE. IF( QANS.EQ.'A' .OR. QANS.EQ.'a' ) LAPPND = .TRUE. IF(.NOT.LAPPND) WRITE(ITTO,8112) 8112 FORMAT(' -Replacing existing refinement results') IF(LAPPND) WRITE(ITTO,8114) 8114 FORMAT(' -Adding to exsiting refinement results') C * BYPASS THE HEADER RECORDS IF(LAPPND) WRITE(IOSC,2210) LINE72 DO 8120 I=1,4 READ(IOPO,2210,END=8199) LINE72 IF(LAPPND) WRITE(IOSC,2210) LINE72 8120 CONTINUE C * GO THROUGH INDIVIDUAL LINE PARAMETERS 8130 READ(IOPO,2210,END=8199) LINE72 IF( .NOT.LAPPND .AND. LINEID.NE.IDREFN ) GO TO 8130 IF( .NOT.LAPPND .AND. LINEID.EQ.IDREFN ) GO TO 8200 READ(LINE72(1:3),8140) NTEMP 8140 FORMAT(I3) IF(NTEMP.NE.999) THEN WRITE(IOSC,2210) LINE72 NOLDLN = NTEMP GO TO 8130 ENDIF READ(IOPO,2210,END=8252) LINE72 GO TO 8252 C * C * UNEXPECTED EOF HIT... ABORT OPERATION 8199 WRITE(ITTO,8198) 8198 FORMAT(' --Unexpected EOF hit: Aborting operation') CLOSE(UNIT=IOPO) CLOSE(UNIT=IOSC) GO TO 10000 C * C * WRITE THE REFINED LINE PARAMTERS 8200 CALL DATE( QDATE ) CALL TIME( QTIME ) WRITE(IOSC,6210) IDREFN,QDATE,QTIME WRITE(IOSC,8220) 8220 FORMAT(' * Refined line positions and intensities:') C * C * LIST THE LINE POSITIONS AND INTENSITIES WRITE(IOSC,8250) 8250 FORMAT(/,' NO. TWO-THETA REF INT. (CPS) D SPACING REL. INT.', 1 /,' --- --------- --- ---------- --------- ---------') C * C * HAVE ANY LINE BEEN REFINED? 8252 IF(KWSGLN.EQ.0) GO TO 8300 C * C * WRITE ALL THE REFINED LINE INFORMATION BIGINT = 0.0 DO 8255 I=1,KWSGLN 8255 IF(WSGPAR(I,2).GT.BIGINT) BIGINT = WSGPAR(I,2) BIGINT = BIGINT / 100.0 DO 8260 IP=1,KWSGLN POSC = WSGPAR(IP,1) + CORPOS( WSGPAR(IP,1) ) RI = WSGPAR(IP,2) / BIGINT LAMBDA = NINT( WSGPAR(IP,12) ) DSP = WTABLE(LAMBDA,1) / ( 2.0*SIN(POSC*DTORD2) ) * 1.0E10 WRITE(WID,7270) LAMBDA IF(WID.EQ.'1') WID = ' ' WRITE(IOSC,7280) IP+NOLDLN,POSC,WID,WSGPAR(IP,2),DSP,RI 8260 CONTINUE C * C * WRITE END OF LIST MARKER 8300 WRITE(IOSC,7310) WRITE(IOSC,6210) IDREFN,QDATE,QTIME C * C * COPY ANY MORE DATA FROM OLD FILE TO NEW 8310 IF(LHTEOF) GO TO 8399 READ(IOPO,2210,END=8399) LINE72 WRITE(IOSC,2210) LINE72 GO TO 8310 8399 CLOSE(UNIT=IOPO) C * C * COPY THE TEMP FILE BACK TO THE PERMANENT FILE 8400 REWIND (UNIT=IOSC) CVAX C OPEN(UNIT=IOPO,FILE=PRFILE,STATUS='NEW',FORM='FORMATTED', C 1CARRIAGECONTROL='LIST') CVAX CIBM OPEN(UNIT=IOPO,FILE=PRFILE,STATUS='UNKNOWN',FORM='FORMATTED') CIBM 8410 READ(IOSC,2210,END=8499) LINE72 WRITE(IOPO,2210) LINE72 GO TO 8410 8499 CLOSE(UNIT=IOPO) CLOSE(UNIT=IOSC) C * C ** WRITE THE INSTRUMENT PARAMETERS C * 10000 IF(KAUTOP.EQ.0) THEN IF(KMODEO.NE.2) WRITE(ITTO,10002) 10002 FORMAT(' Write current instrument parameters ? ') READ(ITTI,1060) QANS ELSE QANS = 'Y' ENDIF IF( QANS.NE.'Y' .AND. QANS.NE.'y' ) QANS = 'N' IF(KMODEO.EQ.1) WRITE(IOBO,10004) QANS 10004 FORMAT(A1,T40,' Write instrument parameters') IF( KMODEO.EQ.2 .OR. KAUTOP.NE.0 ) WRITE(ITTO,10006) QANS 10006 FORMAT(' Write current instrument parameters: ',A1) IF( QANS.NE.'Y' .AND. QANS.NE.'y' .OR. KAUTOP.NE.0 ) GO TO 9000 C * C * OPEN OLD AND NEW FILES OPEN(UNIT=IOPO,FILE=PRFILE,STATUS='OLD') CVAX C OPEN(UNIT=IOSC,FILE='FIXED80',STATUS='NEW',FORM='FORMATTED', C 1CARRIAGECONTROL='LIST') CVAX CIBM OPEN(UNIT=IOSC,FILE='FIXED80',STATUS='UNKNOWN',FORM='FORMATTED') CIBM C * C * COPY OLD FILE... BYPASS EXISTING INSTRUMENT PARAMETERS 10100 READ(IOPO,2210,END=10120) LINE72 IF(LINEID.EQ.IDWSGP) GO TO 10110 WRITE(IOSC,2210) LINE72 GO TO 10100 10110 WRITE(ITTO,10112) 10112 FORMAT(' -Replacing existing instrument parameters') 10115 READ(IOPO,2210,END=10120) LINE72 IF(LINEID.NE.IDWSGP) GO TO 10115 GO TO 10100 10120 CLOSE(UNIT=IOPO) C * CALL DATE( QDATE ) CALL TIME( QTIME ) WRITE(IOSC,6210) IDWSGP,QDATE,QTIME WRITE(IOSC,10130) 10130 FORMAT(' * INS PARAMETERS:') WRITE(IOSC,2210) QWGTTL C * C * READ THE RADIATION PARAMETERS 10200 ZERO = 0.0 DO 10220 I=1,5 10220 WRITE(IOSC,10230) WGWAVE,WGRAD(I,1),WGRAD(I,2),ZERO,QDATE,QTIME 10230 FORMAT(1X,A10,3(1X,E13.6),1X,A9,1X,A8) C * C * READ THE BACKGROUND PARAMETERS WRITE(IOSC,10230) WGBACK,(WGBAK(I),I=1,3),QDATE,QTIME WRITE(IOSC,10230) WGBACK,(WGBAK(I),I=4,6),QDATE,QTIME C * C * READ THE PROFILE PARAMETERS WRITE(IOSC,10230) WGPROF,(WGPRO(1,I),I=1,3),QDATE,QTIME WRITE(IOSC,10230) WGPROF,(WGPRO(2,I),I=1,3),QDATE,QTIME WRITE(IOSC,10230) WGPROF,(WGPRO(3,I),I=1,3),QDATE,QTIME WRITE(IOSC,10230) WGPROF,(WGPRO(4,I),I=1,3),QDATE,QTIME C * C * READ THE TWO-THETA ERROR CURVE WRITE(IOSC,10230) WGCALB,(WGCAL(I),I=1,3),QDATE,QTIME C * C * WRITE END-OF-DATA MARKER WRITE(IOSC,6210) IDWSGP,QDATE,QTIME C * C * COPY THE TEMP FILE BACK TO THE PERMANENT FILE 10300 REWIND (UNIT=IOSC) CVAX C OPEN(UNIT=IOPO,FILE=PRFILE,STATUS='NEW',FORM='FORMATTED', C 1CARRIAGECONTROL='LIST') CVAX CIBM OPEN(UNIT=IOPO,FILE=PRFILE,STATUS='UNKNOWN',FORM='FORMATTED') CIBM 10310 READ(IOSC,2210,END=9000) LINE72 WRITE(IOPO,2210) LINE72 GO TO 10310 C * C * FINISIO 9000 CLOSE(UNIT=IOPO) CLOSE(UNIT=IOSC) RETURN END C *** WSGEVL - EVALUATE PARAMETERS ASSOCIATED WITH THE INSTRUMENT C * SUBROUTINE WSGEVL C * LOGICAL EXISTS, LPLOTS CHARACTER FILEID*17, FILEXX*17, LINEID*10, LINEXX*10 CHARACTER QANS*1, QDATE*9, QTIME*8, LINE*72, QFTITL*80 CHARACTER QTITLS(4)*20, QFILE*32 CHARACTER WSGSET*18, WSGSXX*18 PARAMETER ( FILEID = '*** PROFILE DATA ' , LINEID = '** SET ID ' ) PARAMETER ( DTORD2=8.726646260E-3, RTODT2=114.591559 ) PARAMETER ( DTOR =1.745329252E-2, RTOD =57.29577951 ) PARAMETER ( MEMV = 32, MPTS = 2048 ) COMMON /LUNS/ ITTI,ITTO,IOFI,IOFO,IOBO,IOPL,IOPO,IOLO,IOSC,IOWG COMMON /WGDATN/ WGBAK(6),WGPRO(4,3),WGRAD(5,2),WGCAL(3) COMMON /FLDATN/ KFILET,FBANG,FEANG,FAINC,FTIME COMMON /PLTDAT/ KPPLOT,KPSETS(5),KPTYPE,KPTDEF COMMON /WSGDAT/ KWSGLN,WSGPAR(200,12) COMMON /MODEOP/ KMODEO,KSAMEP,KAUTOP COMMON /WDATA/ NWAVE,WTABLE(5,2) COMMON /COMSCR/ X(MPTS),Y(MPTS) COMMON /FLDATC/ QFTITL DIMENSION NCPLOT(4),OFFSET(4),NUMPEN(4),MARKER(4) EQUIVALENCE ( LINE(2:18) , FILEXX ) EQUIVALENCE ( LINE(2:11) , LINEXX ) EQUIVALENCE ( LINE(14:31), WSGSXX ) DATA QTITLS(1)/'OBSERVED FWHM VALUES'/ DATA QTITLS(2)/'SIZE ONLY FIT '/ DATA QTITLS(3)/'STRAIN ONLY FIT '/ DATA QTITLS(4)/'SIZE AND STRAIN FIT '/ C * C * DETERMINE FUNCTION 1000 IF(KMODEO.EQ.2) THEN WRITE(ITTO,1002) 1002 FORMAT('1',11X,'* * * L I N E L I S T F U N C T I O N S', 1 ' * * *') ELSE WRITE(ITTO,1004) 1004 FORMAT(/,' * Line list functions') ENDIF WRITE(ITTO,1006) KWSGLN 1006 FORMAT(/,' Total number of lines in list is :',I3) IF( KMODEO.NE.2 .AND. KAUTOP.EQ.0 ) WRITE(ITTO,1010) 1010 FORMAT(/,' C - Clear line list',/, 1 ' S - Size and/or strain analysis from line list',/, 1 ' W - Write line list to profile data file',//, 1 ' Choice ? ') IF(KAUTOP.EQ.0) THEN READ(ITTI,1020) QANS 1020 FORMAT(A1) ELSE QANS = 'W' ENDIF IF(KMODEO.EQ.1) WRITE(IOBO,1030) QANS 1030 FORMAT(A1,T40,' (C)lear, (S)ize/strain, (W)rite') IF( QANS.NE.'C' .AND. QANS.NE.'c' .AND. 1 QANS.NE.'S' .AND. QANS.NE.'s' .AND. 1 QANS.NE.'W' .AND. QANS.NE.'w' ) GO TO 9000 IF( KMODEO.EQ.2 .OR. KAUTOP.NE.0 ) WRITE(ITTO,1040) QANS 1040 FORMAT(/,' (C)lear, (S)ize/strain analysis, (W)rite lines: ',A1) C * C * DO IT 1200 IF( QANS.EQ.'C' .OR. QANS.EQ.'c' ) GO TO 2000 IF( QANS.EQ.'S' .OR. QANS.EQ.'s' ) GO TO 3000 IF( QANS.EQ.'W' .OR. QANS.EQ.'w' ) GO TO 4000 GO TO 9000 C * C ** CLEAR THE LINE LIST C * 2000 DO 2010 I=1,200 DO 2010 I2=1,11 2010 WSGPAR(I,I2) = 0.0 KWSGLN = 0 GO TO 9000 C * C ** EVALUATE SIZE AND/OR STRAIN C * C * DATA CAN BE PLOTTED. CHECK FOR PLOTTING BY NAME... 3000 LPLOTS = .FALSE. IF(KMODEO.NE.2) WRITE(ITTO,3010) 3010 FORMAT(' Plot file name ? (* = NONE) ') READ(ITTI,3020) QFILE 3020 FORMAT(A32) IF( QFILE.EQ.' ' .OR. QFILE.EQ.'/' ) QFILE = 'CPLOT' IF(KMODEO.EQ.1) THEN WRITE(IOBO,3022) QFILE 3022 FORMAT(A32,T40,' Plot file name (*=NO PLOTS)') WRITE(ITTO,3024) 3024 FORMAT(/,' -Batch setup active: Command recorded') GO TO 9000 ENDIF IF(KMODEO.EQ.2) WRITE(ITTO,3026) QFILE 3026 FORMAT(' Plot file name (*=NONE): ',A32) IF(QFILE.EQ.'*') GO TO 3100 IF(KPTYPE.EQ.0) THEN OPEN(UNIT=IOPL,FILE=QFILE,STATUS='NEW',FORM='UNFORMATTED', 1 ERR=3030) ELSE CVAX C OPEN(UNIT=IOPL,FILE=QFILE,STATUS='NEW',FORM='FORMATTED', C 1 CARRIAGECONTROL='LIST',ERR=3030) CVAX CIBM OPEN(UNIT=IOPL,FILE=QFILE,STATUS='UNKNOWN',FORM='FORMATTED', 1 ERR=3030) CIBM ENDIF LPLOTS = .TRUE. GO TO 3050 3030 WRITE(ITTO,3040) 3040 FORMAT(' --Can not open specified plot file') GO TO 3100 C * C * SET DEFAULT PARAMETERS C * OBSERVED DATA 3050 KPSETS(1) = 1 NCPLOT(1) = -1 OFFSET(1) = 0.0 NUMPEN(1) = 1 MARKER(1) = 1 C * SIZE ONLY FIT KPSETS(2) = 2 NCPLOT(2) = 1 OFFSET(2) = 0.0 NUMPEN(2) = 2 MARKER(2) = 1 C * STRAIN ONLY FIT KPSETS(3) = 3 NCPLOT(3) = 1 OFFSET(3) = 0.0 NUMPEN(3) = 3 MARKER(3) = 1 C * SIZE AND STRAIN FIT KPSETS(4) = 4 NCPLOT(4) = 1 OFFSET(4) = 0.0 NUMPEN(4) = 4 MARKER(4) = 1 C * C * DETERMINE THE RANGE FOR THE PLOT FILE OUTPUT NPTS = 0 STRT = 180.0 FINS = 0.0 DO 3060 I=1,KWSGLN IF(WSGPAR(I,3).LT.0.0002) GO TO 3060 NPTS = NPTS + 1 X(NPTS) = WSGPAR(I,1) + CORPOS( WSGPAR(I,1) ) Y(NPTS) = WSGPAR(I,3) IF(X(NPTS).LT.STRT) STRT = X(NPTS) IF(X(NPTS).GT.FINS) FINS = X(NPTS) 3060 CONTINUE IF(NPTS.EQ.0) THEN STRT = 0.0 FINS = 0.0 ENDIF STRT = AINT( STRT/10.0 ) * 10.0 FINS = AINT( FINS/10.0 ) * 10.0 + 10.0 C * NUMSTS = 4 NPLOTS = 1 IAXIS = 0 DPI = 2.0 IFS = 2 KYID = 3 C * C * WRITE THE INITIAL INFORMATION TO THE PLOT FILE IF(KPTYPE.EQ.0) THEN WRITE(IOPL) QFTITL WRITE(IOPL) STRT,FINS,FAINC WRITE(IOPL) NUMSTS,NPLOTS,IAXIS,DPI,IFS,KYID WRITE(IOPL) QTITLS(1),NCPLOT(1),OFFSET(1),NUMPEN(1),MARKER(1) WRITE(IOPL) QTITLS(2),NCPLOT(2),OFFSET(2),NUMPEN(2),MARKER(2) WRITE(IOPL) QTITLS(3),NCPLOT(3),OFFSET(3),NUMPEN(3),MARKER(3) WRITE(IOPL) QTITLS(4),NCPLOT(4),OFFSET(4),NUMPEN(4),MARKER(4) ELSE WRITE(IOPL,3062) QFTITL 3062 FORMAT(A80) WRITE(IOPL,3064) STRT,FINS,FAINC 3064 FORMAT(3F10.4) WRITE(IOPL,3066) NUMSTS,NPLOTS,IAXIS,DPI,IFS,KYID 3066 FORMAT(3I6,F6.2,2I6) WRITE(IOPL,3068) QTITLS(1),NCPLOT(1),OFFSET(1),NUMPEN(1), 1 MARKER(1) 3068 FORMAT(A20,I6,F6.2,2I6) WRITE(IOPL,3068) QTITLS(2),NCPLOT(2),OFFSET(2),NUMPEN(2), 1 MARKER(2) WRITE(IOPL,3068) QTITLS(3),NCPLOT(3),OFFSET(3),NUMPEN(3), 1 MARKER(3) WRITE(IOPL,3068) QTITLS(4),NCPLOT(4),OFFSET(4),NUMPEN(4), 1 MARKER(4) ENDIF C * C * DETERMINE IF THERE ARE ENOUGH POINTS TO EVALUATE IF(NPTS.LT.1) THEN WRITE(ITTO,3070) 3070 FORMAT(' --Not enough points for any type of analysis') CLOSE(UNIT=IOPL) GO TO 9000 ENDIF C * C * WRITE THE RAW DATA TO THE PLOT FILE IF(KPTYPE.EQ.0) THEN WRITE(IOPL) KPSETS(1),NPTS,0.0 WRITE(IOPL) (X(I),Y(I),I=1,NPTS) ELSE WRITE(IOPL,3072) KPSETS(1),NPTS,0.0 3072 FORMAT(I6,I6,F10.4) WRITE(IOPL,3074) (X(I),Y(I),I=1,NPTS) 3074 FORMAT(2F10.4) ENDIF C * C * EVALUATE SIZE 3100 NPTS = 0 DO 3110 I=1,KWSGLN IF(WSGPAR(I,3).LT.0.0002) GO TO 3110 TT = WSGPAR(I,1) + CORPOS( WSGPAR(I,1) ) NPTS = NPTS + 1 X(NPTS) = RTOD * WTABLE(1,1) / COS( TT * DTORD2 ) Y(NPTS) = WSGPAR(I,3) 3110 CONTINUE CALL LINREG( X, Y, NPTS, SL, YINT, SLONLY, SDEV ) SIZE = 1.0E9 / SLONLY WRITE(ITTO,3120) SIZE 3120 FORMAT(/,' X-ray crystallite size :',F15.4,' NM', 1 ' * SIZE ONLY *') IF(.NOT.LPLOTS) GO TO 3200 NPTS = 100 FINC = ( FINS - STRT ) / REAL( NPTS-1 ) DO 3130 I=1,NPTS X(I) = STRT + REAL(I-1) * FINC X(I) = X(I) + CORPOS( X(I) ) Y(I) = RTOD * WTABLE(1,1) * 1.0E9 / ( SIZE * COS(X(I)*DTORD2) ) 3130 CONTINUE IF(KPTYPE.EQ.0) THEN WRITE(IOPL) KPSETS(2),NPTS,0.0 WRITE(IOPL) (X(I),Y(I),I=1,NPTS) ELSE WRITE(IOPL,3072) KPSETS(2),NPTS,0.0 WRITE(IOPL,3074) (X(I),Y(I),I=1,NPTS) ENDIF C * C * EVALUATE STRAIN 3200 NPTS = 0 DO 3210 I=1,KWSGLN IF(WSGPAR(I,3).LT.0.0002) GO TO 3210 TT = WSGPAR(I,1) + CORPOS( WSGPAR(I,1) ) NPTS = NPTS + 1 X(NPTS) = RTOD * 4.0 * TAN( TT * DTORD2 ) Y(NPTS) = WSGPAR(I,3) 3210 CONTINUE CALL LINREG( X, Y, NPTS, SL, YINT, SLONLY, SDEV ) STRAIN = SLONLY WRITE(ITTO,3220) STRAIN 3220 FORMAT(/,' X-ray strain (delta-d/d) :',F15.8,' ', 1 ' * STRAIN ONLY *') IF(.NOT.LPLOTS) GO TO 3300 NPTS = 100 FINC = ( FINS - STRT ) / REAL( NPTS-1 ) DO 3230 I=1,NPTS X(I) = STRT + REAL(I-1) * FINC X(I) = X(I) + CORPOS( X(I) ) Y(I) = RTOD * 4.0 * STRAIN * TAN( X(I) * DTORD2 ) 3230 CONTINUE IF(KPTYPE.EQ.0) THEN WRITE(IOPL) KPSETS(3),NPTS,0.0 WRITE(IOPL) (X(I),Y(I),I=1,NPTS) ELSE WRITE(IOPL,3072) KPSETS(3),NPTS,0.0 WRITE(IOPL,3074) (X(I),Y(I),I=1,NPTS) ENDIF C * C * EVALUATE BOTH SIZE AND STRAIN 3300 NPTS = 0 DO 3310 I=1,KWSGLN IF(WSGPAR(I,3).LT.0.0002) GO TO 3310 NPTS = NPTS + 1 TT = WSGPAR(I,1) + CORPOS( WSGPAR(I,1) ) X(NPTS) = RTOD * 4.0 * SIN( TT * DTORD2 ) Y(NPTS) = WSGPAR(I,3) * COS( TT * DTORD2 ) 3310 CONTINUE IF(NPTS.LT.2) THEN WRITE(ITTO,3312) 3312 FORMAT(/,' -Too few points to evaluate size/strain ', 1 'simultaneously') IF(LPLOTS) CLOSE(UNIT=IOPL) GO TO 9000 ENDIF CALL LINREG( X, Y, NPTS, SL, YINT, SLONLY, SDEV ) STRAIN = SL SIZE = RTOD * WTABLE(1,1) * 1.0E9 / YINT WRITE(ITTO,3320) SIZE,STRAIN 3320 FORMAT(/,' X-ray crystallite size :',F15.4,' NM', 1 ' * SIZE AND STRAIN *',/, 1 ' X-RAY STRAIN (DELTA-D/D) :',F15.8,' ', 1 ' * SIZE AND STRAIN *') IF(.NOT.LPLOTS) GO TO 9000 NPTS = 100 FINC = ( FINS - STRT ) / REAL( NPTS-1 ) DO 3330 I=1,NPTS X(I) = STRT + REAL(I-1) * FINC X(I) = X(I) + CORPOS( X(I) ) Y(I) = RTOD * WTABLE(1,1) / ( SIZE*1.0E-9 * COS(X(I)*DTORD2) ) 1 + RTOD * 4.0 * STRAIN * TAN( X(I) * DTORD2 ) 3330 CONTINUE IF(KPTYPE.EQ.0) THEN WRITE(IOPL) KPSETS(4),NPTS,STRT WRITE(IOPL) (X(I),Y(I),I=1,NPTS) ELSE WRITE(IOPL,3072) KPSETS(4),NPTS,STRT WRITE(IOPL,3074) (X(I),Y(I),I=1,NPTS) ENDIF CLOSE(UNIT=IOPL) GO TO 9000 C * C ** WRITE TO PROFILE DATA FILE C * 4000 IF( KMODEO.NE.2 .AND. KAUTOP.EQ.0 ) WRITE(ITTO,4010) 4010 FORMAT(/,' Profile file name ? ') IF(KAUTOP.EQ.0) THEN READ(ITTI,4020) QFILE 4020 FORMAT(A32) ELSE QFILE = 'AUTOPRO' ENDIF IF( QFILE.EQ.' ' .OR. QFILE.EQ.'/' ) QFILE = 'WSGPRO' IF(KMODEO.EQ.1) WRITE(IOBO,4030) QFILE 4030 FORMAT(A32,T40,' Profile file name') IF( KMODEO.EQ.2 .OR. KAUTOP.NE.0 ) WRITE(ITTO,4040) QFILE 4040 FORMAT(' File name: ',A32) C * C ** GET THE DATA SET IDENTIFIER IF( KMODEO.NE.2 .AND. KAUTOP.EQ.0 ) WRITE(ITTO,4050) 4050 FORMAT(/,' 18 character set identifier ? ') IF(KAUTOP.EQ.0) THEN READ(ITTI,4060) WSGSET 4060 FORMAT(A18) ELSE WSGSET = 'WRITTEN BY AUTO' ENDIF IF(KMODEO.EQ.1) WRITE(IOBO,4070) WSGSET 4070 FORMAT(A18,T40,' Date set ID') IF( KMODEO.EQ.2 .OR. KAUTOP.NE.0 ) WRITE(ITTO,4080) WSGSET 4080 FORMAT(' Data set identifier: ',A18) C * C * IF BATCH SETUP... WE ARE FINISHED IF(KMODEO.EQ.1) THEN CIBM QANS = 'N' WRITE(IOBO,4130) QANS CIBM WRITE(ITTO,3024) GO TO 9000 ENDIF C * C * TEST FOR FILE EXISTANCE CVAX C INQUIRE(FILE=QFILE,EXIST=EXISTS) C IF(.NOT.EXISTS) GO TO 4300 CVAX CIBM IF YOU HAVE AN NON-IBM MACHINE, THEN REMOVE THE CIBM FOLLOWING STATEMENTS AND USE THE INQUIRE STATEMENT ABOVE. IF(KMODEO.NE.2) WRITE(ITTO,4110) 4110 FORMAT(' Does this profile file currently exist ? ') READ(ITTI,1020) QANS IF( QANS.NE.'N' .AND. QANS.NE.'n' ) QANS = 'Y' IF(KMODEO.EQ.1) WRITE(IOBO,4130) QANS 4130 FORMAT(A1,T40,' Profile file exists') IF(KMODEO.EQ.2) WRITE(ITTO,4140) QANS 4140 FORMAT(' Profile file exists: ',A1) IF( QANS.EQ.'N' .OR. QANS.EQ.'n' ) GO TO 4300 CIBM C * C * A FILE IS THERE... DETERMINE IF IT IS A PROFILE FILE 4200 OPEN(UNIT=IOLO,FILE=QFILE,STATUS='OLD',ERR=4220) READ(IOLO,4210,END=4220) LINE 4210 FORMAT(A72) IF(FILEXX.EQ.FILEID) GO TO 4400 C * FILE EXISTS BUT NOT A PROFILE DATA FILE... 4220 WRITE(ITTO,4230) 4230 FORMAT(' --File is not a profile data file.') CLOSE(UNIT=IOLO) GO TO 9000 C * C * PROFILE FILE DOES NOT EXIST... CREATE ONE CVAX C4300 OPEN(UNIT=IOLO,FILE=QFILE,STATUS='NEW',FORM='FORMATTED', C 1CARRIAGECONTROL='LIST') CVAX CIBM 4300 OPEN(UNIT=IOLO,FILE=QFILE,STATUS='NEW',FORM='FORMATTED') CIBM CALL DATE(QDATE) CALL TIME(QTIME) WRITE(IOLO,4310) FILEID,QDATE,QTIME 4310 FORMAT(1X,A17,29X,'Filed:',1X,A9,1X,A8) C * C * OPEN TEMPORARY FILE TO COPY EXISTING DATA 4400 REWIND (UNIT=IOLO) CVAX C OPEN(UNIT=IOSC,FILE='FIXED80',STATUS='NEW',FORM='FORMATTED', C 1CARRIAGECONTROL='LIST') CVAX CIBM OPEN(UNIT=IOSC,FILE='FIXED80',STATUS='UNKNOWN',FORM='FORMATTED') CIBM C * C * COPY OLD FILE... BYPASS OLD DATA SET WITH SAME NAME 4500 READ(IOLO,4210,END=4510) LINE IF(WSGSET.EQ.WSGSXX) GO TO 4520 4550 WRITE(IOSC,4210) LINE GO TO 4500 4520 WRITE(ITTO,4530) 4530 FORMAT(' -Replacing profile data set with same identifier') 4540 READ(IOLO,4210,END=4510) LINE IF(WSGSET.NE.WSGSXX) GO TO 4540 GO TO 4500 4510 CLOSE(UNIT=IOLO) C * C * WRITE THE NEW PARAMETERS 4600 CALL DATE(QDATE) CALL TIME(QTIME) WRITE(IOSC,4610) LINEID,WSGSET,KWSGLN,QDATE,QTIME 4610 FORMAT(1X,A10,1X,'>',A18,'< ',I3,' LINES ',A9,1X,A8) DO 4620 I=1,KWSGLN 4620 WRITE(IOSC,4630) WSGPAR(I,1),WSGPAR(I,2),INT(WSGPAR(I,11)), 1 (WSGPAR(I,J),J=3,10) 4630 FORMAT(1X,F8.4,2X,F10.2,10X,'Profile: ',I3,/, 1 2(6X,E13.6,1X,E13.6,1X,E13.6,1X,E13.6,/)) WRITE(IOSC,4610) LINEID,WSGSET,KWSGLN,QDATE,QTIME C * C * COPY THE TEMP FILE BACK TO THE PERMANENT FILE 4700 REWIND (UNIT=IOSC) CVAX C OPEN(UNIT=IOLO,FILE=QFILE,STATUS='NEW',FORM='FORMATTED', C 1CARRIAGECONTROL='LIST') CVAX CIBM OPEN(UNIT=IOLO,FILE=QFILE,STATUS='UNKNOWN',FORM='FORMATTED') CIBM 4710 READ(IOSC,4210,END=4799) LINE WRITE(IOLO,4210) LINE GO TO 4710 4799 CLOSE(UNIT=IOLO) CLOSE(UNIT=IOSC) C * C * SUBJOB COMPLETE 9000 RETURN END C *** LINREG - CARRIES OUT A LINEAR REGRESSION ANALYSIS C * SUBROUTINE LINREG( X, Y, NPTS, SLOPE, YINT, SLONLY, STDEV) C * IMPLICIT DOUBLE PRECISION (A-H,O-Z) REAL X,Y,SLOPE,YINT,STDEV,SLONLY DIMENSION X(NPTS),Y(NPTS) C * C * CRUNCH DATA Z = DBLE( NPTS ) SUMX = 0.0D00 SUMY = 0.0D00 SUMXY = 0.0D00 SUMXS = 0.0D00 SUMYS = 0.0D00 DO 100 J=1,NPTS SUMX = SUMX + X(J) SUMXS = SUMXS + X(J)**2 SUMY = SUMY + Y(J) SUMYS = SUMYS + Y(J)**2 SUMXY = SUMXY + X(J)*Y(J) 100 CONTINUE XBAR = SUMX/Z YBAR = SUMY/Z XS1 = Z*SUMXY - SUMX*SUMY XS2 = Z*SUMXS - SUMX*SUMX DSLOPE = XS1/XS2 DSLONL = SUMXY/SUMXS DYINT = YBAR - DSLOPE*XBAR IF(NPTS.GT.2) THEN VY1 = ( SUMXY - XBAR*SUMY )**2 VY2 = SUMXS - XBAR*SUMX VARY = ( SUMYS - YBAR*SUMY - VY1/VY2 ) / ( Z - 2.D00 ) DSTDEV = DSQRT( VARY ) ELSE VARY = 99.99 DSTDEV = 99.99 ENDIF C * C * COMPUTE COEFFICIENT OF DETERMINATION C * C RS0 = ( SUMXY - (SUMX*SUMY)/Z )**2 C RS1 = SUMXS - (SUMX**2)/Z C RS2 = SUMYS - (SUMY**2)/Z C RSQ = RS0 / ( RS1*RS2 ) C * C * RETURN SLOPE = DSLOPE SLONLY = DSLONL YINT = DYINT STDEV = DSTDEV RETURN END C *** PROGRAM: SHADOW (SHADOW30) C *** VERSION: 860822 (YYMMDD) C * C *** PKREFN - PERFORM PROFILE REFINEMENT C * SUBROUTINE PKREFN C * LOGICAL LFIRST, LBYPAS CHARACTER QANS*1, QFTITL*80 PARAMETER ( DTOR=1.745329252E-02, RTOD=57.29577951 ) PARAMETER ( DTORD2=8.72664626E-03 ) PARAMETER ( MEMV = 32, MPTS = 2048 ) PARAMETER ( MEMVP1 = MEMV+1, MEMVT2 = MEMV*2 ) PARAMETER ( MEMSCR = 12000 ) COMMON /REFFLG/ KPROF,KLRNZ,KERRT,KASYM,KBKGR,KBKGD,KAMOR,KCRYS COMMON /LUNS/ ITTI,ITTO,IOFI,IOFO,IOBO,IOPL,IOPO,IOLO,IOSC,IOWG COMMON /SDATA/ KOBS,YANG(MPTS),YOBS(MPTS),YSYN(MPTS),YBKG(MPTS) COMMON /PEAKP/ KNLIN,KNPRM,PLPRM(200,10),KRLIN(200),KLLIN(201) COMMON /VECTOR/ NVECS,BVECS(MEMVT2),BMINS(MEMV),BMAXS(MEMV) COMMON /PLTDAT/ KPPLOT,KPSETS(5),KPTYPE,KPTDEF COMMON /FLDATN/ KFILET,FBANG,FEANG,FAINC,FTIME COMMON /SCRTCH/ SCRDAT(MEMSCR),IPOINT(MEMV,4) COMMON /WSGDAT/ KWSGLN,WSGPAR(200,12) COMMON /MODEOP/ KMODEO,KSAMEP,KAUTOP COMMON /OPTRES/ RERR,RESID,ICON,ITER COMMON /MATRIX/ AMAT(MEMV,MEMVP1) C * C * SET FIRST PASS THROUGH FLAG AND OPEN SCRATCH FILE LFIRST = .TRUE. OPEN(UNIT=IOSC,STATUS='SCRATCH',FORM='UNFORMATTED') KNUMCU = 0 C * 1000 IF(KMODEO.EQ.2) THEN WRITE(ITTO,1001) 1001 FORMAT('1',14X,'* * * P R O F I L E R E F I N E M E N T', 1 ' * * *') ELSE WRITE(ITTO,1002) 1002 FORMAT(/,' * Profile refinement') ENDIF C * C * SET A DEFAULT PROFILE-SHAPE-FUNCTION JKPROF = 11 C * C *** PARAMETER INITIALIZATION C * 1100 KPROF = JKPROF CALL PROINT( LFIRST ) JKPROF = KPROF IF(NVECS.EQ.0) GO TO 9000 C * C *** PLOT FILE INITIALIZATION C * IF(LFIRST) CALL RFPLOT C * C * SELECTION OF REFINEMENT TECHNIQUE C * 1400 LBYPAS = .FALSE. IREFN = 1 IF(KAUTOP.NE.1) THEN IF(KMODEO.NE.2) WRITE(ITTO,1410) 1410 FORMAT(/,' Refinement, (G)auss-Newton, (M)arquardt or', 1 ' (B)ypass ? ') READ(ITTI,1720) QANS ELSE QANS = 'G' ENDIF IF( QANS.EQ.'B' .OR. QANS.EQ.'b' ) THEN LBYPAS = .TRUE. ELSE IF( QANS.EQ.'M' .OR. QANS.EQ.'m' ) THEN IREFN = 0 ELSE QANS = 'G' ENDIF IF(KMODEO.EQ.1) WRITE(IOBO,1417) QANS 1417 FORMAT(A1,T40,'Refinement: (G)auss (M)arq (B)ypass') IF( KMODEO.EQ.2 .OR. KAUTOP.EQ.1 ) WRITE(ITTO,1420) QANS 1420 FORMAT(' (G)auss-Newton, (M)arquardt or (B)ypass refinement: ',A1) C * C ** PERFORM PROFILE REFINEMENT C * C * BYPASS REFINEMENT OF THIS REGION IF BYPASS FLAG SET IF(LBYPAS) THEN WRITE(ITTO,1416) 1416 FORMAT(/,' -Bypassing refinement of this region') GO TO 1700 ENDIF C * C * BYPASS REFINEMENT OF THIS REGION IF IN BATCH SETUP MODE IF(KMODEO.EQ.1) THEN WRITE(ITTO,1430) 1430 FORMAT(/,' -Batch setup mode active, bypassing refinement') GO TO 1700 ENDIF C * C * MAXIMUM ITERATION LIMIT 1500 ITER = 20 C * C * REFINE THE LINE PARAMETERS WITH MARQUARDT TECHNIQUE CALL BSOLVE( IREFN ) C * C * PULL THE OPTIMIZED PARAMETERS FROM BVECS CALL PMSORT( BVECS ) C * C * MAKE THE BACKGROUND AVAILABLE IF( KBKGR.EQ.1 .OR. KBKGR.EQ.3 ) CALL BKGLVL( YBKG ) C * C * OUTPUT THE RESULTS CALL PRMOUT C * C * CYCLE THROUGH AGAIN.... C * 1700 IF(KAUTOP.NE.1) THEN IF(KMODEO.NE.2)WRITE(ITTO,1710) 1710 FORMAT(/,' Add line(s) and/or repeat refinement ? ') READ(ITTI,1720) QANS 1720 FORMAT(A1) ELSE QANS = 'N' ENDIF IF( QANS.NE.'Y' .AND. QANS.NE.'y' ) QANS = 'N' IF(KMODEO.EQ.1) WRITE(IOBO,1730) QANS 1730 FORMAT(A1,T40,'Repeat refinement cycle') IF( KMODEO.EQ.2 .OR. KAUTOP.EQ.1 ) WRITE(ITTO,1735) QANS 1735 FORMAT(/,' Repeat refinement cycle: ',A1) IF( QANS.NE.'Y' .AND. QANS.NE.'y' ) GO TO 1800 C * ADD ADDITIONAL REFLECTIONS IF REQUESTED IF(KAUTOP.NE.1) CALL PKADD GO TO 1400 C * C ** RECORD THE REFINED LINE PARAMETERS C * 1800 IF(LBYPAS) GO TO 1900 DO 1810 I=1,KNLIN KWSGLN = MIN( KWSGLN+1, 200 ) DO 1820 I2=1,KNPRM 1820 WSGPAR(KWSGLN,I2) = PLPRM(I,I2) WSGPAR(KWSGLN,2) = WSGPAR(KWSGLN,2) / FTIME WSGPAR(KWSGLN,11) = REAL( KPROF ) WSGPAR(KWSGLN,12) = REAL( KRLIN(I) ) IF(KCRYS.GT.0) WSGPAR(KWSGLN,3) = PLPRM(I,3) 1810 CONTINUE C * C * GENERATE THE PLOT RESULTS IF( KPPLOT.GT.0 .AND. KMODEO.NE.1 ) CALL PRMPLT C * C * SPLIT COMPOUND LINES IF NOT ALREADY DONE IF( KPPLOT.EQ.0 .AND. KMODEO.NE.1 ) CALL PKSPLT C * C * WRITE THE CORRECTED PATTERN... 1900 IF(LFIRST) CALL PATWRI C * C * DO IT ALL AGAIN LFIRST = .FALSE. GO TO 1100 C * C * EXIT EXIT EXIT EXIT EXIT RETURN 9000 IF(KPPLOT.NE.0) CLOSE(UNIT=IOPL) CLOSE(UNIT=IOSC) RETURN END C **** PMSORT - PULLS LINE PARAMETERS FROM THE OPTIMIZATION ARRAYS C * SUBROUTINE PMSORT( PAIN ) C * PARAMETER ( MEMV = 32, MPTS = 2048 ) PARAMETER ( MEMVP1 = MEMV+1, MEMVT2 = MEMV*2 ) COMMON /REFFLG/ KPROF,KLRNZ,KERRT,KASYM,KBKGR,KBKGD,KAMOR,KCRYS COMMON /LUNS/ ITTI,ITTO,IOFI,IOFO,IOBO,IOPL,IOPO,IOLO,IOSC,IOWG COMMON /SDATA/ KOBS,YANG(MPTS),YOBS(MPTS),YSYN(MPTS),YBKG(MPTS) COMMON /PEAKP/ KNLIN,KNPRM,PLPRM(200,10),KRLIN(200),KLLIN(201) COMMON /REFPAR/ AMOPAR(3),BKGPAR,ASYPAR,CRYPAR(2) COMMON /DIAGS/ ISENSE(10) DIMENSION PAIN(MEMVT2) C * C * THE DATA COMES OUT BY KNPRMS FOR THE LINE ENTRIES. C * IF KPROF IS NEGATIVE THEN ALL PROFILES HAVE THE SAME VALUES FOR ALL C * VARIABLES EXCEPT THAT EACH WILL HAVE ITS OWN POSITION AND HEIGHT. C * 400 NEXT = 0 IF(KNLIN.EQ.0) GO TO 500 C * C * GET THE REGULAR COEFFICIENTS IF(KPROF.LT.0) GO TO 450 DO 410 I=1,KNLIN DO 420 J=1,KNPRM NEXT = NEXT + 1 PLPRM(I,J) = PAIN(NEXT) 420 CONTINUE 410 CONTINUE GO TO 500 C * C * GET THE COEFFICIENTS FOR THE CONSTRAINED CURVES 450 DO 460 J=1,KNPRM NEXT = NEXT + 1 PLPRM(1,J) = PAIN(NEXT) 460 CONTINUE IF(KNLIN.GT.1) THEN DO 470 I=2,KNLIN NEXT = NEXT + 1 PLPRM(I,1) = PAIN(NEXT) NEXT = NEXT + 1 PLPRM(I,2) = PAIN(NEXT) DO 480 J=3,KNPRM 480 PLPRM(I,J) = PLPRM(1,J) 470 CONTINUE ENDIF C * C * RECOVER BACKGROUND IF IT IS BEING REFINED 500 IF( KBKGR.EQ.1 .OR. KBKGR.EQ.3 ) THEN NEXT = NEXT + 1 BKGPAR = PAIN(NEXT) ENDIF C * C * RECOVER ASYMMETRY PARAMETER IF BEING REFINED IF(KASYM.NE.0) THEN NEXT = NEXT + 1 ASYPAR = PAIN(NEXT) ENDIF C * C * RECOVER THE AMORPHOUS PROFILE PARAMETERS IF BEING REFINED IF(KAMOR.NE.0) THEN DO 560 I=1,3 NEXT = NEXT + 1 AMOPAR(I) = PAIN(NEXT) 560 CONTINUE ENDIF C * C * RECOVER PARTICLE SIZE PARAMETER IF( KCRYS.EQ.1 .OR. KCRYS.EQ.3 ) THEN NEXT = NEXT + 1 CRYPAR(1) = PAIN(NEXT) ENDIF C * C * RECOVER PARTICLE STRAIN PARAMETER IF( KCRYS.EQ.2 .OR. KCRYS.EQ.3 ) THEN NEXT = NEXT + 1 CRYPAR(2) = PAIN(NEXT) ENDIF C * C * OUTPUT PARAMETER VALUES 700 IF(ISENSE(2).EQ.0) GO TO 9000 NS = 1 NE = KNPRM DO 710 I=1,KNLIN WRITE(ITTO,720) I,(PAIN(J),J=NS,NE) 720 FORMAT(1X,I3,2X,F8.4,2X,F10.2,:,/,6X,2(4(1X,E12.5),/)) NS = NS + KNPRM NE = NE + KNPRM 710 CONTINUE IF(KASYM.EQ.1) WRITE(ITTO,730) ASYPAR 730 FORMAT(' ASYPAR = ',F10.4) IF(KAMOR.EQ.1) WRITE(ITTO,740) AMOPAR 740 FORMAT(' AMOPAR = ',3(1X,F10.4)) IF(KCRYS.GT.0) WRITE(ITTO,750) CRYPAR 750 FORMAT(' CRYPAR = ',2(1X,F15.4)) IF(KBKGR.EQ.1) WRITE(ITTO,760) BKGPAR 760 FORMAT(' BKGPAR = ',F10.4) C * 9000 RETURN END C *** SHADOW - GENERATE THE PROFILE IN TARGET ARRAY C * C * IF IPNUM = - 1 GENERATE THE AMORPHOUS PROFILE ONLY C * IF IPNUM = 0 GENERATE BACKGROUND ONLY C * IF IPNUM = N GENERATE THE NTH PROFILE ONLY C * IF IPNUM = 999 GENERATE ALL PROFILES AND BACKGROUND C * SUBROUTINE SHADOW( TARGET, IPNUM, ILO, IHI ) C * CHARACTER QFTITL*80 PARAMETER ( DTOR=1.745329252E-02, RTOD=57.29577951 ) PARAMETER ( DTORD2=8.72664626E-03 ) PARAMETER ( SQRTPI=1.772453851 ) PARAMETER ( PEPS = 0.1000 ) PARAMETER ( MEMV = 32, MPTS = 2048 ) COMMON /REFFLG/ KPROF,KLRNZ,KERRT,KASYM,KBKGR,KBKGD,KAMOR,KCRYS COMMON /LUNS/ ITTI,ITTO,IOFI,IOFO,IOBO,IOPL,IOPO,IOLO,IOSC,IOWG COMMON /SDATA/ KOBS,YANG(MPTS),YOBS(MPTS),YSYN(MPTS),YBKG(MPTS) COMMON /PEAKP/ KNLIN,KNPRM,PLPRM(200,10),KRLIN(200),KLLIN(201) COMMON /REFPAR/ AMOPAR(3),BKGPAR,ASYPAR,CRYPAR(2) COMMON /FLDATN/ KFILET,FBANG,FEANG,FAINC,FTIME COMMON /WDATA/ NWAVE,WTABLE(5,2) COMMON /PDATA/ BANG, EANG COMMON /DIAGS/ ISENSE(10) COMMON /FLDATC/ QFTITL DIMENSION TARGET(MPTS) C * C ** TARGET IS ALWAYS ZEROED BEFORE USE C * 100 DO 110 I=1,KOBS 110 TARGET(I) = 0.0 C * C ** IF AN AMORPHOUS PROFILE IS USED... GENERATE IT NOW C * 300 IF(KAMOR.EQ.0) GO TO 400 IF( IPNUM.NE.999 .AND. IPNUM.NE.-1 ) GO TO 400 TT = AMOPAR(1) YI = AMOPAR(2) AX = AMOPAR(3) CALL GAUSSN(TARGET,1,TT,YI,AX,ILO,IHI) IF(IPNUM.EQ.999) KLLIN(KNLIN+1) = IHI*16384 + ILO IF(IPNUM.EQ.-1) GO TO 800 C * C * REPEAT FOR ALL LINES IN THE PATTERN C * 400 DO 410 IPEAK = 1,KNLIN C * C * DONT GENERATE ANY UNECESSARY LINES... IF( IPNUM.NE.IPEAK .AND. IPNUM.NE.999 ) GO TO 410 C * C * SORT PEAK PARAMETERS TT = PLPRM( IPEAK, 1 ) YI = PLPRM( IPEAK, 2 ) AX = PLPRM( IPEAK, 3 ) BX = PLPRM( IPEAK, 4 ) CX = PLPRM( IPEAK, 5 ) DX = PLPRM( IPEAK, 6 ) EX = PLPRM( IPEAK, 7 ) FX = PLPRM( IPEAK, 8 ) GX = PLPRM( IPEAK, 9 ) HX = PLPRM( IPEAK,10 ) C * C * FIND THE CENTER OF THIS PROFILE ICNTR = INT( (TT-YANG(1))/FAINC + 0.1 ) + 1 C * C * SYNTHESIZE CORRECT PROFILE 700 JKPROF = IABS( KPROF ) GO TO(1000,2000,3000,4000,5000,6000,7000,8000,9000, 1 10000,11000,12000,13000,14000,14000,14000),JKPROF C * C ** GENERATE A LORENTZIAN PROFILE C * 1000 TMP = 1.0 / (AX/2.0)**2 C * LOW ANGLE SIDE ILO = 1 IF(ICNTR.LT.1) GO TO 1100 DO 1010 IP=ICNTR,1,-1 XP = YI / ( 1.0 + TMP * ( YANG(IP)-TT )**2 ) IF(KASYM.EQ.1) XP = XP * SYMFAC( YANG(IP), TT ) IF(XP.LT.PEPS) GO TO 1020 TARGET(IP) = TARGET(IP) + XP C IF(ISENSE(1).EQ.1)WRITE(ITTO,1)YANG(IP),YOBS(IP),TARGET(IP) C1 FORMAT(' ANG,OBS,YINT = ',F8.2,2X,F8.2,2X,F8.2) 1010 CONTINUE IP = 0 1020 ILO = MIN( IP+1, ICNTR ) C * HIGH ANGLE SIDE 1100 IHI = KOBS IF(ICNTR.GE.KOBS) GO TO 420 DO 1130 IP=ICNTR+1,KOBS XP = YI / ( 1.0 + TMP * ( YANG(IP)-TT )**2 ) IF(KASYM.EQ.1) XP = XP * SYMFAC( YANG(IP), TT ) IF(XP.LT.PEPS) GO TO 1140 TARGET(IP) = TARGET(IP) + XP C IF(ISENSE(1).EQ.1)WRITE(ITTO,1)YANG(IP),YOBS(IP),TARGET(IP) 1130 CONTINUE IP = KOBS + 1 1140 IHI = MAX( IP-1, ICNTR+1 ) GO TO 420 C * C ** MODIFIED LORENTZIAN C * 2000 TMP = 0.4142135624 / (AX/2.0)**2 C * LOW ANGLE SIDE ILO = 1 IF(ICNTR.LT.1) GO TO 2100 DO 2010 IP=ICNTR,1,-1 XP = YI / ( 1.0 + TMP * ( YANG(IP)-TT )**2 )**2 IF(KASYM.EQ.1) XP = XP * SYMFAC( YANG(IP), TT ) IF(XP.LT.PEPS) GO TO 2020 TARGET(IP) = TARGET(IP) + XP C IF(ISENSE(1).EQ.1)WRITE(ITTO,1)YANG(IP),YOBS(IP),TARGET(IP) 2010 CONTINUE IP = 0 2020 ILO = MIN( IP+1, ICNTR ) C * HIGH ANGLE SIDE 2100 IHI = KOBS IF(ICNTR.GE.KOBS) GO TO 420 DO 2130 IP=ICNTR+1,KOBS XP = YI / ( 1.0 + TMP * ( YANG(IP)-TT )**2 )**2 IF(KASYM.EQ.1) XP = XP * SYMFAC( YANG(IP), TT ) IF(XP.LT.PEPS) GO TO 2140 TARGET(IP) = TARGET(IP) + XP C IF(ISENSE(1).EQ.1)WRITE(ITTO,1)YANG(IP),YOBS(IP),TARGET(IP) 2130 CONTINUE IP = KOBS + 1 2140 IHI = MAX( IP-1, ICNTR+1 ) GO TO 420 C * C ** INTERMEDIATE LORENTZIAN C * 3000 TMP = 0.587401052 / (AX/2.0)**2 C * LOW ANGLE SIDE ILO = 1 IF(ICNTR.LT.1) GO TO 3100 DO 3010 IP=ICNTR,1,-1 XP = YI / ( 1.0 + TMP * ( YANG(IP)-TT )**2 )**1.5 IF(KASYM.EQ.1) XP = XP * SYMFAC( YANG(IP), TT ) IF(XP.LT.PEPS) GO TO 3120 TARGET(IP) = TARGET(IP) + XP C IF(ISENSE(1).EQ.1)WRITE(ITTO,1)YANG(IP),YOBS(IP),TARGET(IP) 3010 CONTINUE IP = 0 3120 ILO = MIN( IP+1, ICNTR ) C * HIGH ANGLE SIDE 3100 IHI = KOBS IF(ICNTR.GE.KOBS) GO TO 420 DO 3130 IP=ICNTR+1,KOBS XP = YI / ( 1.0 + TMP * ( YANG(IP)-TT )**2 )**1.5 IF(KASYM.EQ.1) XP = XP * SYMFAC( YANG(IP), TT ) IF(XP.LT.PEPS) GO TO 3140 TARGET(IP) = TARGET(IP) + XP C IF(ISENSE(1).EQ.1)WRITE(ITTO,1)YANG(IP),YOBS(IP),TARGET(IP) 3130 CONTINUE IP = KOBS + 1 3140 IHI = MAX( IP-1, ICNTR+1 ) GO TO 420 C * C ** PEARSON VII C * 4000 CALL PEARSN(TARGET,0,TT,YI,AX,BX,AX,BX,ILO,IHI) GO TO 420 C * C ** GAUSSIAN C * 5000 CALL GAUSSN(TARGET,0,TT,YI,AX,ILO,IHI) GO TO 420 C * C ** VOIGT PROFILE, AX=BETAG, BX=BETAC C * 6000 ILO = 1 IF(ICNTR.LT.1) GO TO 6100 DO 6010 IP=ICNTR,1,-1 ARG1 = SQRTPI * ABS( YANG(IP)-TT ) / AX ARG2 = BX / ( SQRTPI * AX ) XP = YI * BX * CERRFC( ARG1, ARG2 ) IF(KASYM.EQ.1) XP = XP * SYMFAC( YANG(IP), TT ) IF(XP.LT.PEPS) GO TO 6020 TARGET(IP) = TARGET(IP) + XP C IF(ISENSE(1).EQ.1)WRITE(ITTO,1)YANG(IP),YOBS(IP),TARGET(IP) 6010 CONTINUE IP = 1 6020 ILO = MIN( IP+1, ICNTR ) C * HIGH ANGLE SIDE 6100 IHI = KOBS IF(ICNTR.GE.KOBS) GO TO 420 DO 6130 IP=ICNTR+1,KOBS ARG1 = SQRTPI * ABS( YANG(IP)-TT ) / AX ARG2 = BX / ( SQRTPI * AX ) XP = YI * BX * CERRFC( ARG1, ARG2 ) IF(KASYM.EQ.1) XP = XP * SYMFAC( YANG(IP), TT ) IF(XP.LT.PEPS) GO TO 6140 TARGET(IP) = TARGET(IP) + XP C IF(ISENSE(1).EQ.1)WRITE(ITTO,1)YANG(IP),YOBS(IP),TARGET(IP) 6130 CONTINUE IP = KOBS + 1 6140 IHI = MAX( IP-1, ICNTR+1 ) GO TO 420 C * C ** SPLIT PEARSON VII C * 7000 CALL PEARSN(TARGET,0,TT,YI,AX,BX,CX,DX,ILO,IHI) GO TO 420 C * C ** INTERMEDIATE LORENTZIAN WITH ALPHA2 REFLECTION C * C * ALPHA 1 REFLECTION 8000 AW = FNFWHM(TT,1) + AX BC = FNSHAP(TT,1) CW = FNFWHM(TT,2) + AX DC = FNSHAP(TT,2) CALL PEARSN(TARGET,0,TT,YI,AW,BC,CW,DC,ILO,IHI) C * A2 IF(NWAVE.GT.1) THEN CALL CALCPH(TT,YI,2,T2,Y2) IF(KLRNZ.EQ.1) Y2 = Y2 * ( PLORNZ(T2)/PLORNZ(TT) ) CALL PEARSN(TARGET,0,T2,Y2,AW,BC,CW,DC,JLO,JHI) IF(JLO.LT.ILO) ILO = JLO IF(JHI.GT.IHI) IHI = JHI ENDIF C * A3 C IF(NWAVE.GT.2) THEN C CALL CALCPH(TT,YI,3,T3,Y3) C IF(KLRNZ.EQ.1) Y3 = Y3 * ( PLORNZ(T3)/PLORNZ(TT) ) C CALL PEARSN(TARGET,0,T3,Y3,AW,BC,CW,DC,JLO,JHI) C IF(JLO.LT.ILO) ILO = JLO C IF(JHI.GT.IHI) IHI = JHI C ENDIF GO TO 420 C * C ** SPVII WITH A2,A3 AND NO CONSTRAINED PARAMETERS C * C * A1 9000 CALL PEARSN(TARGET,0,TT,YI,AX,BX,CX,DX,ILO,IHI) C * A2 IF(NWAVE.GT.1) THEN CALL CALCPH(TT,YI,2,T2,Y2) IF(KLRNZ.EQ.1) Y2 = Y2 * ( PLORNZ(T2)/PLORNZ(TT) ) CALL PEARSN(TARGET,0,T2,Y2,EX,FX,GX,HX,JLO,JHI) IF(JLO.LT.ILO) ILO = JLO IF(JHI.GT.IHI) IHI = JHI ENDIF C * A3 IF(NWAVE.GT.2) THEN CALL CALCPH(TT,YI,3,T3,Y3) IF(KLRNZ.EQ.1) Y3 = Y3 * ( PLORNZ(T3)/PLORNZ(TT) ) CALL PEARSN(TARGET,0,T3,Y3,AX,BX,CX,DX,JLO,JHI) IF(JLO.LT.ILO) ILO = JLO IF(JHI.GT.IHI) IHI = JHI ENDIF GO TO 420 C * C ** SPVII WITH A2,A3 AND CONSTRAINED SHAPE FACTORS C * C * A1 10000 CALL PEARSN(TARGET,0,TT,YI,AX,BX,CX,DX,ILO,IHI) C * A2 IF(NWAVE.GT.1) THEN CALL CALCPH(TT,YI,2,T2,Y2) IF(KLRNZ.EQ.1) Y2 = Y2 * ( PLORNZ(T2)/PLORNZ(TT) ) CALL PEARSN(TARGET,0,T2,Y2,EX,BX,FX,DX,JLO,JHI) IF(JLO.LT.ILO) ILO = JLO IF(JHI.GT.IHI) IHI = JHI ENDIF C * A3 IF(NWAVE.GT.2) THEN CALL CALCPH(TT,YI,3,T3,Y3) IF(KLRNZ.EQ.1) Y3 = Y3 * ( PLORNZ(T3)/PLORNZ(TT) ) CALL PEARSN(TARGET,0,T3,Y3,AX,BX,CX,DX,JLO,JHI) IF(JLO.LT.ILO) ILO = JLO IF(JHI.GT.IHI) IHI = JHI ENDIF GO TO 420 C * C ** SPVII WITH A2,A3 AND CONSTRAINED FWHM AND SHAPE FACTORS C * C * A1 11000 CALL PEARSN(TARGET,0,TT,YI,AX,BX,CX,DX,ILO,IHI) C * A2 IF(NWAVE.GT.1) THEN CALL CALCPH(TT,YI,2,T2,Y2) IF(KLRNZ.EQ.1) Y2 = Y2 * ( PLORNZ(T2)/PLORNZ(TT) ) CALL PEARSN(TARGET,0,T2,Y2,AX,BX,CX,DX,JLO,JHI) IF(JLO.LT.ILO) ILO = JLO IF(JHI.GT.IHI) IHI = JHI ENDIF C * A3 IF(NWAVE.GT.2) THEN CALL CALCPH(TT,YI,3,T3,Y3) IF(KLRNZ.EQ.1) Y3 = Y3 * ( PLORNZ(T3)/PLORNZ(TT) ) CALL PEARSN(TARGET,0,T3,Y3,AX,BX,CX,DX,JLO,JHI) IF(JLO.LT.ILO) ILO = JLO IF(JHI.GT.IHI) IHI = JHI ENDIF GO TO 420 C * C * SPVII WITH CALCULATED FWHM AND VARIABLE SHAPE FACTORS C * C * A1 12000 WF = FNFWHM(TT,1) WB = FNFWHM(TT,2) CALL PEARSN(TARGET,0,TT,YI,WF,AX,WB,BX,ILO,IHI) C * A2 IF(NWAVE.GT.1) THEN CALL CALCPH(TT,YI,2,T2,Y2) IF(KLRNZ.EQ.1) Y2 = Y2 * ( PLORNZ(T2)/PLORNZ(TT) ) CALL PEARSN(TARGET,0,T2,Y2,WF,AX,WB,BX,JLO,JHI) IF(JLO.LT.ILO) ILO = JLO IF(JHI.GT.IHI) IHI = JHI ENDIF C * A3 IF(NWAVE.GT.2) THEN CALL CALCPH(TT,YI,3,T3,Y3) IF(KLRNZ.EQ.1) Y3 = Y3 * ( PLORNZ(T3)/PLORNZ(TT) ) CALL PEARSN(TARGET,0,T3,Y3,WF,AX,WB,BX,JLO,JHI) IF(JLO.LT.ILO) ILO = JLO IF(JHI.GT.IHI) IHI = JHI ENDIF GO TO 420 C * C ** SPVII WITH A2,A3 AND CONSTRAINED FWHM AND SHAPE FACTORS C * C * A1 13000 AC = FNFWHM(TT,1) BC = FNSHAP(TT,1) CC = FNFWHM(TT,2) DC = FNSHAP(TT,2) CALL PEARSN(TARGET,0,TT,YI,AC,BC,CC,DC,ILO,IHI) C * A2 IF(NWAVE.GT.1) THEN CALL CALCPH(TT,YI,2,T2,Y2) IF(KLRNZ.EQ.1) Y2 = Y2 * ( PLORNZ(T2)/PLORNZ(TT) ) CALL PEARSN(TARGET,0,T2,Y2,AC,BC,CC,DC,JLO,JHI) IF(JLO.LT.ILO) ILO = JLO IF(JHI.GT.IHI) IHI = JHI ENDIF C * A3 IF(NWAVE.GT.2) THEN CALL CALCPH(TT,YI,3,T3,Y3) IF(KLRNZ.EQ.1) Y3 = Y3 * ( PLORNZ(T3)/PLORNZ(TT) ) CALL PEARSN(TARGET,0,T3,Y3,AC,BC,CC,DC,JLO,JHI) IF(JLO.LT.ILO) ILO = JLO IF(JHI.GT.IHI) IHI = JHI ENDIF GO TO 420 C * C ** GENERATE A CONVOLUTE C * 14000 IF(KCRYS.EQ.0) GO TO 14100 C * IF CONSTRAINED BROADENING IS USED... USE INTEGRAL BREADTH BETA TTC = TT + CORPOS( TT ) THETAR = TTC * DTORD2 BSIZE = 0.0 BSTRN = 0.0 IF( KCRYS.EQ.1 .OR. KCRYS.EQ.3 ) THEN BSIZE = RTOD * WTABLE(1,1) / ( CRYPAR(1) * COS(THETAR) ) ENDIF IF( KCRYS.EQ.2 .OR. KCRYS.EQ.3 ) THEN BSTRN = RTOD * 4.0 * CRYPAR(2) * TAN(THETAR) ENDIF IF(JKPROF.EQ.14) AX = BSIZE + BSTRN IF(JKPROF.EQ.15) AX = SQRT( BSIZE**2 + BSTRN**2 ) PLPRM(IPEAK,3) = AX C * C * CONVERT INTEGRAL-BREADTH TO FWHM 14100 IF( JKPROF.EQ.14 .OR. JKPROF.EQ.16 ) FWHM = 0.6366197724 * AX IF(JKPROF.EQ.15) FWHM = 0.9394372786 * AX IF(JKPROF.EQ.16) FWHM2 = 0.9394372786 * BX CALL WSGSS(TARGET,TT,YI,FWHM,FWHM2,ILO,IHI) C * C ** SET END OF PARAMETER POINTERS 420 IF(IPNUM.EQ.999) KLLIN(IPEAK) = IHI*16384 + ILO 410 CONTINUE C * 800 RETURN END C *** PEARSN - GENERATE A SPLIT-PEARSON VII PROFILE C * SUBROUTINE PEARSN(TARGET,IFLAG,TTHT,YMAX,AX,BX,CX,DX,ILO,IHI) C * CHARACTER QFTITL*80 PARAMETER ( PEPS = 0.1000 , CONEPS = 0.00001 ) PARAMETER ( MEMV = 32, MPTS = 2048 ) COMMON /REFFLG/ KPROF,KLRNZ,KERRT,KASYM,KBKGR,KBKGD,KAMOR,KCRYS COMMON /SDATA/ KOBS,YANG(MPTS),YOBS(MPTS),YSYN(MPTS),YBKG(MPTS) COMMON /LUNS/ ITTI,ITTO,IOFI,IOFO,IOBO,IOPL,IOPO,IOLO,IOSC,IOWG COMMON /CONDAT/ CIA(4097),CII(4097),CONINC,KCONLO,KCONHI COMMON /FLDATN/ KFILET,FBANG,FEANG,FAINC,FTIME COMMON /DIAGS/ ISENSE(10) COMMON /FLDATC/ QFTITL DIMENSION TARGET(MPTS) C * C * IF IFLAG IS SET THEN GENERATE A SPVII FOR CONVOLUTION IF( IFLAG .NE. 0 ) GO TO 3000 C * C * FIND THE CENTER OF THIS PEAK ICNTR = INT( (TTHT-YANG(1))/FAINC + 0.10 ) + 1 C * C * CHOOSE CODE BASED ON MAXIMUM EFFICIENCY... PPEPS = PEPS * FTIME IF(KASYM.EQ.1) GO TO 2000 C * C ** SPLIT PEARSON VII WITHOUT ASYMMETRY C * TMP = ( 2.0**(1.0/BX) - 1.0 ) / ( (AX/2.0)**2 ) C * LOW ANGLE SIDE ILO = 1 IF(ICNTR.LT.1) GO TO 1100 DO 1010 IP=ICNTR,1,-1 YC = YMAX / ( 1.0 + TMP * ( YANG(IP)-TTHT )**2 )**BX IF(YC.LT.PPEPS) GO TO 1020 TARGET(IP) = TARGET(IP) + YC C IF(ISENSE(1).EQ.1) WRITE(ITTO,1) YANG(IP),YOBS(IP),TARGET(IP) C1 FORMAT(' ANG,OBS,TARGET = ',F8.2,2X,F8.2,2X,F8.2) 1010 CONTINUE IP = 0 1020 ILO = MIN( IP+1, ICNTR ) C * HIGH ANGLE SIDE 1100 IHI = KOBS IF(ICNTR.GE.KOBS) GO TO 9000 TMP = ( 2.0**(1.0/DX) - 1.0 ) / ( (CX/2.0)**2 ) DO 1130 IP=ICNTR+1,KOBS YC = YMAX / ( 1.0 + TMP * ( YANG(IP)-TTHT )**2 )**DX IF(YC.LT.PPEPS) GO TO 1140 TARGET(IP) = TARGET(IP) + YC C IF(ISENSE(1).EQ.1) WRITE(ITTO,1) YANG(IP),YOBS(IP),YINT(IP) 1130 CONTINUE IP = KOBS + 1 1140 IHI = MAX( IP-1, ICNTR+1 ) GO TO 9000 C * C ** SPLIT PEARSON VII WITH ASYMMETRY C * C * LOW ANGLE SIDE 2000 ILO = 1 IF(ICNTR.LT.1) GO TO 2100 TMP = ( 2.0**(1.0/BX) - 1.0 ) / ( (AX/2.0)**2 ) DO 2010 IP=ICNTR,1,-1 YC = YMAX / ( 1.0 + TMP * ( YANG(IP)-TTHT )**2 )**BX YC = YC * SYMFAC( YANG(IP), TTHT ) IF(YC.LT.PPEPS) GO TO 2020 TARGET(IP) = TARGET(IP) + YC C IF(ISENSE(1).EQ.1) WRITE(ITTO,1) YANG(IP),YOBS(IP),YINT(IP) 2010 CONTINUE IP = 0 2020 ILO = MIN( IP+1, ICNTR ) C * HIGH ANGLE SIDE 2100 IHI = KOBS IF(ICNTR.GE.KOBS) GO TO 9000 TMP = ( 2.0**(1.0/DX) - 1.0 ) / ( (CX/2.0)**2 ) DO 2130 IP=ICNTR+1,KOBS YC = YMAX / ( 1.0 + TMP * ( YANG(IP)-TTHT )**2 )**DX YC = YC * SYMFAC( YANG(IP), TTHT ) IF(YC.LT.PPEPS) GO TO 2140 TARGET(IP) = TARGET(IP) + YC C IF(ISENSE(1).EQ.1) WRITE(ITTO,1) YANG(IP),YOBS(IP),YINT(IP) 2130 CONTINUE IP = KOBS + 1 2140 IHI = MAX( IP-1, ICNTR+1 ) GO TO 9000 C * C ** GENERATE AN SPVII FOR CONVOLUTION C * C * FIND THE CENTER OF THIS PEAK 3000 ICNTR = INT( (TTHT-CIA(1))/CONINC + 0.10 ) + 1 C * C * LOW ANGLE SIDE ILO = KCONLO IF(ICNTR.LT.KCONLO) GO TO 3100 TMP = ( 2.0**(1.0/BX) - 1.0 ) / ( (AX/2.0)**2 ) DO 3010 IP=ICNTR,KCONLO,-1 YC = YMAX / ( 1.0 + TMP * ( CIA(IP)-TTHT )**2 )**BX IF(YC.LT.CONEPS) GO TO 3020 CII(IP) = CII(IP) + YC C IF(ISENSE(1).EQ.1) WRITE(ITTO,2) CIA(IP),CII(IP) C2 FORMAT(' CIA,CII = ',F8.2,2X,F8.2) 3010 CONTINUE IP = KCONLO - 1 3020 ILO = MIN( IP+1, ICNTR ) C * HIGH ANGLE SIDE 3100 IHI = KCONHI IF(ICNTR.GE.KCONHI) GO TO 9000 TMP = ( 2.0**(1.0/DX) - 1.0 ) / ( (CX/2.0)**2 ) DO 3130 IP=ICNTR+1,KCONHI YC = YMAX / ( 1.0 + TMP * ( CIA(IP)-TTHT )**2 )**DX IF(YC.LT.CONEPS) GO TO 3140 CII(IP) = CII(IP) + YC C IF(ISENSE(1).EQ.1) WRITE(ITTO,2) CIA(IP),CII(IP) 3130 CONTINUE IP = KCONHI + 1 3140 IHI = MAX( IP-1, ICNTR+1 ) C * 9000 RETURN END C *** GAUSSN - GENERATE A GAUSSIAN PROFILE IN THE TARGET ARRAY C * SUBROUTINE GAUSSN(TARGET,IFLG,XPOS,YM,FWHM,ILO,IHI) C * CHARACTER QFTITL*80 PARAMETER ( PEPS = 0.1000 ) PARAMETER ( MEMV = 32, MPTS = 2048 ) COMMON /DIAGS/ ISENSE(10) COMMON /REFFLG/ KPROF,KLRNZ,KERRT,KASYM,KBKGR,KBKGD,KAMOR,KCRYS COMMON /LUNS/ ITTI,ITTO,IOFI,IOFO,IOBO,IOPL,IOPO,IOLO,IOSC,IOWG COMMON /SDATA/ KOBS,YANG(MPTS),YOBS(MPTS),YSYN(MPTS),YBKG(MPTS) COMMON /FLDATN/ KFILET,FBANG,FEANG,FAINC,FTIME COMMON /FLDATC/ QFTITL DIMENSION TARGET(MPTS) C * C * SET CONSTANTS YMAX = YM IA = 0 IF( KASYM.EQ.1 .AND. IFLG.EQ.0 ) IA = 1 C * C * FIND THE CENTER OF THIS PEAK ICNTR = INT( (XPOS-YANG(1))/FAINC + 0.10 ) + 1 C * C * LOW ANGLE SIDE 1000 TMP = -0.6931471806 / (FWHM/2.0)**2 ILO = 1 IF(ICNTR.LT.1) GO TO 1100 DO 1010 IP=ICNTR,1,-1 XP = YMAX * EXP( TMP * ( YANG(IP)-XPOS )**2 ) IF(IA.EQ.1) XP = XP * SYMFAC( YANG(IP), XPOS ) IF(XP.LT.PEPS) GO TO 1020 TARGET(IP) = TARGET(IP) + XP C IF(ISENSE(1).EQ.1) WRITE(ITTO,1) YANG(IP),YOBS(IP),TARGET(IP) C1 FORMAT(' ANG,OBS,SYN = ',F8.2,2X,F8.2,2X,F8.2) 1010 CONTINUE IP = 0 1020 ILO = MIN( IP+1, ICNTR ) C * HIGH ANGLE SIDE 1100 IHI = KOBS IF(ICNTR.GE.KOBS) GO TO 9000 DO 1130 IP=ICNTR+1,KOBS XP = YMAX * EXP( TMP * ( YANG(IP)-XPOS )**2 ) IF(IA.EQ.1) XP = XP * SYMFAC( YANG(IP), XPOS ) IF(XP.LT.PEPS) GO TO 1140 TARGET(IP) = TARGET(IP) + XP C IF(ISENSE(1).EQ.1) WRITE(ITTO,1) YANG(IP),YOBS(IP),TARGET(IP) 1130 CONTINUE IP = KOBS + 1 1140 IHI = MAX( IP-1, ICNTR+1 ) C * 9000 RETURN END C *** FUNCTION FNFWHM - GENERATE FWHM VALUES FOR PROFILES C * FUNCTION FNFWHM( ANGLE, ISIDE ) PARAMETER ( DTORD2 = 0.87266463E-2 ) COMMON /WGDATN/ WGBAK(6),WGPRO(4,3),WGRAD(5,2),WGCAL(3) C * C * GENERATE VALUE FOR FRONT SIDE OF PROFILE IF(ISIDE.EQ.1) THEN TANTHT = TAN( ANGLE * DTORD2 ) TEMP = WGPRO(1,1) + WGPRO(1,2)*TANTHT + WGPRO(1,3)*TANTHT**2 FNFWHM = SQRT( TEMP ) * 2.0 ENDIF C * C * GENERATE VALUE FOR BACK SIDE OF PROFILE IF(ISIDE.EQ.2) THEN TANTHT = TAN( ANGLE * DTORD2 ) TEMP = WGPRO(3,1) + WGPRO(3,2)*TANTHT + WGPRO(3,3)*TANTHT**2 FNFWHM = SQRT( TEMP ) * 2.0 ENDIF C * RETURN END C *** FUNCTION FNSHAP - GENERATE EXPONENTIAL PARAMETER FOR PROFILES C * FUNCTION FNSHAP( ANGLE, ISIDE ) COMMON /WGDATN/ WGBAK(6),WGPRO(4,3),WGRAD(5,2),WGCAL(3) C * C * GENERATE VALUE FOR FRONT SIDE OF PROFILE IF(ISIDE.EQ.1) THEN FNSHAP = WGPRO(2,1) + WGPRO(2,2)*ANGLE + WGPRO(2,3)*ANGLE**2 ENDIF C * C * GENERATE VALUE FOR BACK SIDE OF PROFILE IF(ISIDE.EQ.2) THEN FNSHAP = WGPRO(4,1) + WGPRO(4,2)*ANGLE + WGPRO(4,3)*ANGLE**2 ENDIF C * RETURN END C *** FUNCTION PLORNZ - LORENTZ/POLARIZATION FACTOR AT X TWO-THETA C * FUNCTION PLORNZ( TWOTHT ) PARAMETER ( DTOR=1.745329252E-02 ) PARAMETER ( GC=0.8001525593 ) C * C * THIS IS THE LORENTZ-POLARIZATION CORRECTED FOR GR MONOCHROMETER ANG = TWOTHT * DTOR ANGD2 = ANG / 2.0 PLORNZ = (1.+GC*COS(ANG)**2) / (COS(ANGD2)*SIN(ANGD2)**2) C * RETURN END C *** FUNCTION SYMFAC C * C * PROVIDES SYMMETRY FACTOR FOR PEAK AT THETAB, EVALUATED C * AT ANGLE THETAX. WE WILL PULL THE SYMMETRY FACTOR C * FROM THE COMMON ASYPAR PARAMETER. C * FUNCTION SYMFAC( THETAX, THETAB ) PARAMETER ( DTORD2=8.72664625E-03 ) COMMON /REFFLG/ KPROF,KLRNZ,KERRT,KASYM,KBKGR,KBKGD,KAMOR,KCRYS COMMON /LUNS/ ITTI,ITTO,IOFI,IOFO,IOBO,IOPL,IOPO,IOLO,IOSC,IOWG COMMON /REFPAR/ AMOPAR(3),BKGPAR,ASYPAR,CRYPAR(2) COMMON /DIAGS/ ISENSE(10) C * DELTHT = THETAX - THETAB DELSQR = DELTHT**2 TANTHT = TAN( THETAB * DTORD2 ) TMP = ASYPAR * DELSQR / TANTHT SYMFAC = 1.0 IF(THETAX.GT.THETAB) SYMFAC = 1.0 - TMP IF(THETAX.LE.THETAB) SYMFAC = 1.0 + TMP C * C IF(ISENSE(1).NE.0) WRITE(ITTO,100) THETAX,SYMFAC C100 FORMAT(' THETAX, SYMFAC = ',F8.4,2X,F8.4) 200 RETURN END C *** FUNCTION CERRFC C * FUNCTION CERRFC( XVAL, YVAL ) C * DOUBLE PRECISION XPASS,YPASS,UPASS,VPASS C * C * THE ARGUMENTS PASSED TO WSER,WINT ARE DOUBLE PRECISION XPASS = DBLE( XVAL ) YPASS = DBLE( YVAL ) C * C * CALL THE CORRECT FUNCTION FOR GENERATING THE COMPLEX ERROR FUNCTION IF(YPASS.GT.0.75) GO TO 1030 IF(XPASS.GT.1./YPASS) GO TO 1030 CALL WSER( XPASS, YPASS, UPASS, VPASS ) GO TO 2000 1030 CALL WINT( XPASS, YPASS, UPASS, VPASS ) C * C * RETURN THE VALUE 2000 CERRFC = SNGL( UPASS ) C WRITE(6,2010) XVAL,YVAL,XPASS,YPASS,FUNCT C2010 FORMAT(' X,Y,F = ',5F10.4) RETURN END C *** SUBROUTINE WSER C * C * THIS PROGRAM CALCULATES THE REAL AND THE IMAGINARY PART OF THE FUNC C * C * W(Z) = SQRT(PI) * EXP(-Z*Z) * (1-ERF(-1*Z)) C * C * (COMPLEX ERROR FUNCTION, C.F. ABROMOWITZ & STEGNUN, HANDBOOK OF C * MATHMATICAL FUNCTIONS, P. 295) C * C * WSER USES A SERIES EXPANSION IN TERMS OF THE IMAGINARY ARGUMENT. C * C * SUBROUTINE NEEDED: FDAW - DAWSONS' INTEGRAL C * C * * FROM: T. SUNDIUS, J. OF RAMAN SPECTR. 1 (1973) 471-488. * C * SUBROUTINE WSER( X, Y, UXY, VXY ) C * IMPLICIT DOUBLE PRECISION (A-H,O-Z) VPI = 1.772453851 EPS = 5.0E-9 U0 = VPI * DEXP( -X*X ) V0 = 2.0 * FDAW( X ) U1 = -2.0 * X * U0 V1 = 2.0 * ( 1.0 - X * V0 ) I = 0 YI = 1.0 UXY = U0 VXY = V0 SU = 1.0 SV = 1.0 2 SU = -SU U = SU * V1 V = SV * U1 4 I = I + 1 IF (I-30) 6,6,10 6 XI = I YI = YI * Y / XI DU = U * YI DV = V * YI IF( DABS(DU)-EPS ) 7,7,9 7 IF( DABS(DV)-EPS ) 10,10,9 9 UXY = UXY + DU VXY = VXY + DV U = U1 U1 = -2.0 * ( XI*U0 + X*U1 ) U0 = U V = V1 V1 = -2.0 * ( XI*V0 + X*V1 ) V0 = V IF( MOD(I,2) ) 8,2,8 8 SV = -SV U = SU * U1 V = SV * V1 GO TO 4 10 RETURN END C *** SUBROUTINE WINT C * C * THIS PROGRAM CALCULATES THE REAL AND THE IMAGINARY PART OF THE FUNC C * C * W(Z) = SQRT(PI) * EXP(-Z*Z) * (1-ERF(-1*Z)) C * C * (COMPLEX ERROR FUNCTION, C.F. ABROMOWITZ & STEGNUN, HANDBOOK OF C * MATHMATICAL FUNCTIONS, P. 297) C * C * WINT USES NUMERICAL INTEGRATION USING A 96-POINT HERMITE-GAUSS INTE C * FORMULA. (SHAO, CHEN & FRANK, IBM TECHNICAL REPORT 00.1100, 1964) C * C * * FROM: T. SUNDIUS, J. OF RAMAN SPECTR. 1 (1973) 471-488. * C * SUBROUTINE WINT( XI, Y, UXY, VXY ) C * IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION X(18), W(18) DATA X(01),X(02),X(03)/1.13068883E-1,3.39236619E-1,5.65494366E-1/ DATA X(04),X(05),X(06)/7.91902479E-1,1.01852183E+0,1.24541404E+0/ DATA X(07),X(08),X(09)/1.47264168E+0,1.70026852E+0,1.92835978E+0/ DATA X(10),X(11),X(12)/2.15698239E+0,2.38620523E+0,2.61609953E+0/ DATA X(13),X(14),X(15)/2.84673908E+0,3.07820069E+0,3.31056454E+0/ DATA X(16),X(17),X(18)/3.54391464E+0,3.77833931E+0,4.01393176E+0/ DATA W(01),W(02),W(03)/2.23270023E-1,2.01613013E-1,1.64379631E-1/ DATA W(04),W(05),W(06)/1.20983117E-1,8.03539501E-2,4.81399067E-2/ DATA W(07),W(08),W(09)/2.60003403E-2,1.26513751E-2,5.54163129E-3/ DATA W(10),W(11),W(12)/2.18313198E-3,7.72695822E-4,2.45418093E-4/ DATA W(13),W(14),W(15)/6.98543244E-5,1.77918059E-5,4.04823318E-6/ DATA W(16),W(17),W(18)/8.21354455E-7,1.48296941E-7,2.37736621E-8/ C * VPI = 1.772453851 UXY = 0.0 VXY = 0.0 YSQ = Y * Y C * DO 1 I=1,18 X1 = XI - X(I) X2 = XI + X(I) Y1 = W(I) / ( YSQ + X1*X1 ) Y2 = W(I) / ( YSQ + X2*X2 ) UXY = UXY + Y1 + Y2 1 VXY = VXY + Y1*X1 + Y2*X2 C * UXY = Y * UXY/VPI VXY = VXY/VPI RETURN END C *** FUNCTION FDAW C * C * THIS PROGRAM CALCULATED DAWSONS INTEGRAL C * C * EXP(-X*X) * INT(O-X)*(EXP(-T*T)*DT) C * C * ACCORDING TO APPROXIMATIONS BY CODY,PACIORED & THACHER (MATH. C * COMPT. 24 (1970) 171-178) C * C * FOUR ARGUMENT REGIONS ARE CONSIDERED: C * (A) ABS(X) .LE. 2.5 C * (B) ABS(X) .GT. 2.5 .OR. ABS(X) .LE. 3.5 C * (C) ABS(X) .GT. 3.5 .OR. ABS(X) .LE. 5.0 C * (D) ABS(X) .GT. 5.0 C * C * * FROM: T. SUNDIUS, J. OF RAMAN SPECTR. 1 (1973) 471-488. * C * FUNCTION FDAW( X ) C * IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION P(6),Q(6),A1(5),B1(4),A2(4),B2(3),A3(4),B3(3) DATA P(1),P(2),P(3)/ 1.08326559E+4,-1.28405832E+3, 4.19672902E+2/ DATA P(4),P(5),P(6)/-1.51982152E+1, 1.67795116E+0,-2.38594566E-2/ DATA Q(1),Q(2),Q(3)/ 1.08326559E+4, 5.93771277E+3, 1.48943557E+3/ DATA Q(4),Q(5),Q(6)/ 2.19728332E+2, 1.99422336E+1, 1.00000000E+0/ DATA A1(1),A1(2),A1(3)/5.00652754E-1,-4.91605366E+0,4.07068102E+0/ DATA A1(4),A1(5),B1(1)/-1.26817902E+1,3.47393743E+0,2.14221966E-1/ DATA B1(2),B1(3),B1(4)/3.73902764E+1,1.38216341E+1,8.87619387E+1/ DATA A2(1),A2(2),A2(3)/5.00009652E-1,-1.58539350E0,-1.03850248E+1/ DATA A2(4),B2(1),B2(2)/-4.10832338E0,2.49246324E-1,-5.37142730E-1/ DATA B2(3),A3(1),A3(2)/1.77617781E+1,5.00000002E-1,-2.50017117E0/ DATA A3(3),A3(4),B3(1)/-4.67312022E0,-1.11952164E+1,7.49999191E-1/ DATA B3(2),B3(3) /-2.48787659E+0,-4.12544066E+0/ C * X2 = X * X AX = DABS( X ) IF( AX-2.5 ) 6,6,2 2 IF( AX-3.5 ) 12,12,4 4 IF( AX-5.0 ) 16,16,20 C * 6 Y1 = P(6) DO 8 I=1,5 J = 6 - I 8 Y1 = P(J) + X2*Y1 Y2 = Q(6) DO 10 I=1,5 J = 6 - I 10 Y2 = Q(J) + X2*Y2 FDAW = X * Y1/Y2 GO TO 24 C * 12 Y = A1(5) DO 14 I=1,4 J = 5 - I 14 Y = A1(J) + B1(J)/(X2+Y) FDAW = Y/X GO TO 24 C * 16 Y = A2(4) DO 18 I=1,3 J = 4 - I 18 Y = A2(J) + B2(J)/(X2+Y) FDAW = Y/X GO TO 24 C * 20 Y = A3(4) DO 22 I=1,3 J = 4 - I 22 Y = A3(J) + B3(J)/(X2+Y) FDAW = ( 1.0+ Y/X2 ) / X / 2.0 24 RETURN END C *** WSGSS - GENERATE A CONVOLUTE. (LORENTZ,GAUSSIAN) * INSTRUMENT. C * SUBROUTINE WSGSS(TARGET,TT,YI,AX,BX,ILO,IHI) C * LOGICAL LPATCH DOUBLE PRECISION DPS PARAMETER ( PRSC = 1.128379167 ) PARAMETER ( PEPS = 0.1000 ) PARAMETER ( MEMV = 32, MPTS = 2048 ) COMMON /REFFLG/ KPROF,KLRNZ,KERRT,KASYM,KBKGR,KBKGD,KAMOR,KCRYS COMMON /LUNS/ ITTI,ITTO,IOFI,IOFO,IOBO,IOPL,IOPO,IOLO,IOSC,IOWG COMMON /SDATA/ KOBS,YANG(MPTS),YOBS(MPTS),YSYN(MPTS),YBKG(MPTS) COMMON /CONDAT/ CIA(4097),CII(4097),CONINC,KCONLO,KCONHI COMMON /FLDATN/ KFILET,FBANG,FEANG,FAINC,FTIME COMMON /WDATA/ NWAVE,WTABLE(5,2) COMMON /DIAGS/ ISENSE(10) DIMENSION TARGET(MPTS) DIMENSION CSI(512) C * C * INITIALIZE SOME PARAMETERS LPATCH = .FALSE. IK = IABS( KPROF ) - 2 ILO = 1 IHI = 1 C * C ** DETERMINE THE INTERVAL FOR CONVOLUTE PROFILE GENERATION. SPAN C * COVERS THE MINIMUM OF THE REFINEMENT SEGMENT OR *RANGE* DEGREES C * 1000 NSPAN = ( 3072 - 1026 ) + 1 SPAN = REAL(NSPAN-1) * FAINC RANGE = AMAX1( AMIN1( 4.0, YANG(KOBS)-YANG(1) ), FAINC ) KCINC = MAX( INT(SPAN/RANGE), 1 ) CONINC = FAINC / REAL(KCINC) CDBG WRITE(99,'(''RANGE,KCINC,CONINC= '',F8.4,I5,F9.6)') CDBG 1 RANGE,KCINC,CONINC C * C * MID-POINT OF INSTRUMENT PROFILE IS WEIGHTED A1,A2 AVERAGE TW = TT IF( NWAVE.GT.1 .AND. KOBS.GT.1 ) THEN CALL CALCPH(TT,YI,2,T2,Y2) TW = ( TT + TT + T2 ) / 3.0 ENDIF C * C * DEFINE THE APPROXIMATE CENTER POINT OF THE CONVOLUTE PROFILE KCNTR = INT( (TW-YANG(1))/FAINC + 0.1 ) + 1 C * C * POINTS THAT MAY BE GENERATED TO THE LOW AND HIGH ANGLE SIDE NNPTLO = KCNTR - ( 2049 - 1026 ) / KCINC NNPTHI = KCNTR + ( 3072 - 2049 ) / KCINC CDBG WRITE(99,'(''KCNTR,NNPTLO,NNPTHI= '',3I5)') KCNTR,NNPTLO,NNPTHI IF( NNPTLO.GT.KOBS .OR. NNPTHI.LT.1 ) THEN WRITE(ITTO,14002) TT,KCNTR,NNPTLO,NNPTHI 14002 FORMAT( 1 ' -Line at ',F6.2,' degrees is out of refinement region',/, 1 ' ( KCNTR = ',I4,' NNPTLO = ',I4,' NNPTHI = ',I4,' )') GO TO 9000 ENDIF NNPTLO = MAX( NNPTLO, 1 ) NNPTHI = MIN( NNPTHI, KOBS ) CDBG WRITE(99,'('' NNPTLO,NNPTHI= '',2I5)') NNPTLO,NNPTHI C * C * INITIALIZE THE ANGLE, INTENSITY ARRAYS FOR THE INSTRUMENT PROFILE XS = YANG(1) + REAL(KCNTR-1)*FAINC - 2048.0*CONINC - CONINC DO 14015 I=1,4097 CIA(I) = XS + REAL(I)*CONINC CII(I) = 0.0 14015 CONTINUE C * C * STARTING AND ENDING POINTS IN CONVOLUTE PROFILE ARRAY NNSGLO = 2049 - ( KCNTR - NNPTLO ) * KCINC NNSGHI = 2049 + ( NNPTHI - KCNTR ) * KCINC CDBG WRITE(99,'('' NNSEGLO,HI= '',2I5)') NNSGLO,NNSGHI C * C ** GENERATE THE SPECIMEN PROFILE C * C * NOTE: THE NORMALIZING FACTOR DOES NOT NEED TO APPEAR IN THE PSF C * SINCE LATER DIVISION BY SMPSUM WILL NEGATE IT. WE ARE, IN EFFECT, C * GENERATING A NORMALIZED PROFILE. C * 2000 P2T = CIA(1) - CONINC FWHM = AX IF(LPATCH) FWHM = BX CDBG WRITE(99,'('' FWHM (SPEC) = '',G13.6)') FWHM C * C * GENERATE A LORENTZIAN IF( IK.EQ.12 .OR. ( IK.EQ.14 .AND. .NOT.LPATCH ) ) THEN TMULT = 4.0 / FWHM**2 CREDUN TNORM = 0.636619772 / FWHM SMPSUM = 1.0 PLIM = 0.0025 DO 2010 IP=1,512 CSI(IP) = 1.0 / ( 1.0 + TMULT * ( CIA(IP)-P2T )**2 ) IF(ISENSE(1).NE.0) WRITE(ITTO,11) CIA(IP),CSI(IP) 11 FORMAT(' CIA,CSI = ',F8.4,2X,F8.6) IF(CSI(IP).LT.PLIM) GO TO 2030 SMPSUM = SMPSUM + CSI(IP) + CSI(IP) 2010 CONTINUE IP = 513 ENDIF C * C * GENERATE A GAUSSIAN IF( IK.EQ.13 .OR. LPATCH ) THEN TMULT = -2.772588722 / FWHM**2 CREDUN TNORM = 0.939437279 / FWHM SMPSUM = 1.0 PLIM = 0.0050 DO 2020 IP=1,512 CSI(IP) = EXP( TMULT * ( CIA(IP)-P2T )**2 ) IF(CSI(IP).LT.PLIM) GO TO 2030 SMPSUM = SMPSUM + CSI(IP) + CSI(IP) 2020 CONTINUE IP = 513 ENDIF C * C * SET NUMBER OF POINTS IN SPECIMEN PROFILE WIDTH, NORMALIZING FACTOR 2030 ISWID = IP CDBG WRITE(99,'('' ISWID,SMPSUM='',I5,2F8.4)')ISWID,SMPSUM,CSI(ISWID-1) SMPSUM = 1.0 / SMPSUM C * C * IF LPATCH THEN ALL THINGS HAVE BEEN TAKEN CARE OF IF(LPATCH) GO TO 14200 C * C ** GENERATE THE INSTRUMENTAL PROFILE C * C * DETERMINE POSSIBLE LIMITS ON INSTRUMENT PROFILES BASED ON WIDTH OF C * PATTERN SEGMENT AND SPECIMEN PROFILE 14100 KCONLO = NNSGLO - ( ISWID - 1 ) KCONLO = MAX( 1, MIN( KCONLO, 4097 ) ) KCONHI = NNSGHI + ( ISWID - 1 ) KCONHI = MAX( 1, MIN( KCONHI, 4097 ) ) CDBG WRITE(99,'(''KCONLO,KCONHI= '',2I5)') KCONLO,KCONHI C * C * RETRIEVE PROFILE COEFFICIENTS AND CALC NORMALIZING FACTORS Y1 = 100.0 AC = FNFWHM( TT, 1 ) BC = FNSHAP( TT, 1 ) CC = FNFWHM( TT, 2 ) DC = FNSHAP( TT, 2 ) P1 = GAMMA(BC) P2 = SQRT( 2.0**(1.0/BC) - 1.0 ) P3 = GAMMA(BC-0.5) PNL = 0.5 / ( PRSC * P1 * P2 / ( P3 * AC ) ) P1 = GAMMA(DC) P2 = SQRT( 2.0**(1.0/DC) - 1.0 ) P3 = GAMMA(DC-0.5) PNH = 0.5 / ( PRSC * P1 * P2 / ( P3 * CC ) ) C * C * GENERATE THE PROFILE AND CALCULATE THE OVERALL AREA C * A1 CALL PEARSN(CII,1,TT,Y1,AC,BC,CC,DC,IILO,IIHI) PAREA = Y1 * ( PNL + PNH ) C * A2 IF(NWAVE.GT.1) THEN CALL CALCPH(TT,Y1,2,T2,Y2) IF(KLRNZ.EQ.1) Y2 = Y2 * ( PLORNZ(T2)/PLORNZ(TT) ) CALL PEARSN(CII,1,T2,Y2,AC,BC,CC,DC,JILO,JIHI) PAREA = PAREA + Y2 * ( PNL + PNH ) IF(JILO.LT.IILO) IILO = JILO IF(JIHI.GT.IIHI) IIHI = JIHI ENDIF C * A3 IF(NWAVE.GT.2) THEN CALL CALCPH(TT,Y1,3,T3,Y3) IF(KLRNZ.EQ.1) Y3 = Y3 * ( PLORNZ(T3)/PLORNZ(TT) ) CALL PEARSN(CII,1,T3,Y3,AC,BC,CC,DC,JILO,JIHI) PAREA = PAREA + Y3 * ( PNL + PNH ) IF(JILO.LT.IILO) IILO = JILO IF(JIHI.GT.IIHI) IIHI = JIHI ENDIF C * C * NORMALIZE THE INSTRUMENT PROFILE CDBG WRITE(99,'(''IILO,IIHI,PAREA = '',2I5,F8.2)')IILO,IIHI,PAREA IF(PAREA.GT.0.0) THEN PAREA = 1.0 / PAREA ELSE PAREA = 0.0 ENDIF DO 14110 I=IILO,IIHI 14110 CII(I) = CII(I) * PAREA C * C ** CONVOLUTE THE SAMPLE PROFILE WITH THE INSTRUMENTAL PROFILES C * 14200 ILO = 0 IHI = 0 C * C * DETERMINE OVERALL LIMITS FOR CONVOLUTION AND OFFSET FOR OBS DATA ISTRT = NNSGLO IEND = NNSGHI IPNT = NNPTLO - 1 CDBG WRITE(99,'(''ISTRT,IPNT,IEND = '',3I5)') ISTRT,IPNT,IEND C * C ** GENERATE CONVOLUTE PROFILE C * 15000 DO 15010 NSC = ISTRT,IEND,KCINC DPS = DBLE( CII(NSC) ) DO 15020 NS = 1,(ISWID-1) 15020 DPS = DPS + CSI(NS) * ( CII(NSC-NS) + CII(NSC+NS) ) YC = SNGL(DPS) * ( YI * SMPSUM ) IPNT = IPNT + 1 IF(ISENSE(1).NE.0) WRITE(ITTO,1) YANG(IPNT),YOBS(IPNT),YC 1 FORMAT(' ANG,OBS,YINT = ',F8.4,2X,F8.2,2X,G13.6) IF(YC.LT.PEPS) GO TO 15010 TARGET(IPNT) = TARGET(IPNT) + YC IF(ILO.EQ.0) ILO = IPNT IHI = IPNT 15010 CONTINUE IF(ILO.EQ.0) ILO = 1 IF(IHI.EQ.0) IHI = 1 C * C * CHECK FOR PROFILE #14. TWO CONVOLUTIONS TO BE PERFORMED C * 8000 IF( IK.NE.14 .OR. LPATCH ) GO TO 9000 LPATCH = .TRUE. GO TO 2000 C * 9000 RETURN END C *** GAMMA - DUMMY GAMMA FUNCTION ROUTINE C * FUNCTION GAMMA( X ) PARAMETER ( A0 = +0.944484E+1 ) PARAMETER ( A1 = -0.369213E+2 ) PARAMETER ( A2 = +0.717266E+2 ) PARAMETER ( A3 = -0.789921E+2 ) PARAMETER ( A4 = +0.532151E+2 ) PARAMETER ( A5 = -0.226184E+2 ) PARAMETER ( A6 = +0.608133E+1 ) PARAMETER ( A7 = -0.100099E+1 ) PARAMETER ( A8 = +0.918978E-1 ) PARAMETER ( A9 = -0.359081E-2 ) GAMMA = A0+ 1((((((((A9*X+A8)*X+A7)*X+A6)*X+A5)*X+A4)*X+A3)*X+A2)*X+A1)*X RETURN END C *** PROINT (31) - INITIALIZE PROFILE REFINEMENT PARAMETERS C * SUBROUTINE PROINT( LFIRST ) C * LOGICAL LFIRST,LUSEM CHARACTER QANS*1, QFTITL*80 PARAMETER ( MEMV = 32, MPTS = 2048 ) PARAMETER ( MEMVP1 = MEMV+1, MEMVT2 = MEMV*2 ) COMMON /REFFLG/ KPROF,KLRNZ,KERRT,KASYM,KBKGR,KBKGD,KAMOR,KCRYS COMMON /LUNS/ ITTI,ITTO,IOFI,IOFO,IOBO,IOPL,IOPO,IOLO,IOSC,IOWG COMMON /SDATA/ KOBS,YANG(MPTS),YOBS(MPTS),YSYN(MPTS),YBKG(MPTS) COMMON /PEAKP/ KNLIN,KNPRM,PLPRM(200,10),KRLIN(200),KLLIN(201) COMMON /VECTOR/ NVECS,BVECS(MEMVT2),BMINS(MEMV),BMAXS(MEMV) COMMON /BKGDAT/ LDEG,CLY,CLC(6),BKGSDV,IBKCPS,IBKNBK COMMON /REFPAR/ AMOPAR(3),BKGPAR,ASYPAR,CRYPAR(2) COMMON /FLDATN/ KFILET,FBANG,FEANG,FAINC,FTIME COMMON /RFREGN/ KNUMRG,KNUMCU,REFREG(200,2) COMMON /MODEOP/ KMODEO,KSAMEP,KAUTOP COMMON /PEAKDT/ NPEAK,PEAKS(200,4) COMMON /PDATA/ BANG, EANG COMMON /FLDATC/ QFTITL C * C ** INITIALIZE NUMBER OF PARAMETERS TO ZERO C * NVECS = 0 C * C ** GET ANGLES FOR THE REFINEMENT REGION. C * 900 KOBS = 0 START = 0.0 END = 0.0 IF(KAUTOP.NE.1) THEN IF(KMODEO.NE.2) THEN WRITE(ITTO,910) 910 FORMAT(/,' Angular region for refinement ? ') READ(ITTI,*) START,END ELSE READ(ITTI,920) START,END 920 FORMAT(2F10.4) ENDIF ELSE KNUMCU = KNUMCU + 1 IF(KNUMCU.LE.KNUMRG) THEN START = REFREG(KNUMCU,1) - 0.5 END = REFREG(KNUMCU,2) + 0.5 ENDIF ENDIF IF( START.EQ.0.0 .AND. END.EQ.0.0 ) THEN IF(KMODEO.EQ.1) WRITE(IOBO,930) START,END 930 FORMAT(F10.4,F10.4,T40,'Refinement region') IF( KMODEO.EQ.2 .OR. KAUTOP.EQ.1 ) WRITE(ITTO,932) 932 FORMAT(//,' * End of profile refinement') GO TO 9000 ENDIF START = AMAX1( START, FBANG ) END = AMIN1( END, FEANG ) IF(END.LE.START) GO TO 900 NTEMP = NINT( (END-START)/FAINC ) + 1 IF(NTEMP.LE.MPTS) GO TO 950 WRITE(ITTO,940) 940 FORMAT(/,' --Too many points in interval to evaluate') GO TO 900 C * C * VALID REGION SPECIFIED. IF NOT LFIRST SIGNAL BEGINNING OF REFINE 950 IF(.NOT.LFIRST.AND.(KMODEO.EQ.2.OR.KAUTOP.EQ.1)) WRITE(ITTO,952) 952 FORMAT('1',14X,'* * * P R O F I L E R E F I N E M E N T', 1 ' * * *') C * C * CALL DINPUT TO GET THE REQUESTED DATA IF(KMODEO.EQ.1) WRITE(IOBO,930) START,END IF(KMODEO.NE.1) THEN CALL DINPUT( START, END ) WRITE(ITTO,960) BANG,EANG,KOBS 960 FORMAT(/,' Beginning angle: ',F8.4,' Ending angle: ',F8.4, 1 ' Points in interval: ',I4) ELSE BANG = START EANG = END WRITE(ITTO,960) BANG,EANG,NTEMP ENDIF C * C ** GET THE LINE PARAMETERS C * C * SET THE NUMBER OF LINES IN PARAMETER LIST TO ZERO KNLIN = 0 C * C * IF BATCH MODE... READ LINE POSITIONS IF(KMODEO.EQ.2) GO TO 2200 C * C * IF SEARCH HAS BEEN PERFORMED... USE THESE AS INPUT IF(NPEAK.GT.0) GO TO 2000 C * C * SEARCH THE INTERVAL FOR THE MAXIMUM POINT... 1000 IF(KMODEO.EQ.1) CALL DINPUT( START, END ) IHIGH = 1 DO 1010 I = 2,KOBS 1010 IF(YOBS(I).GT.YOBS(IHIGH)) IHIGH = I PLPRM(1,1) = YANG(IHIGH) PLPRM(1,2) = YOBS(IHIGH) KRLIN(1) = 1 PLPRM(1,1) = PLPRM(1,1) + CORPOS( PLPRM(1,1) ) PLPRM(1,2) = PLPRM(1,2)/FTIME WRITE(ITTO,1020) PLPRM(1,1),PLPRM(1,2),KRLIN(1) 1020 FORMAT(/,' Angle = ',F8.4,' Intensity = ',F10.2, 1 ' Wavelength = ',I2,/,' New values ? ') A = 0.0 B = 0.0 IREF = 0 READ(ITTI,*) A,B,IREF IF(A.GT.0.00) PLPRM(1,1) = A IF(B.GT.0.00) PLPRM(1,2) = B IF(IREF.GT.0) KRLIN(1) = IREF KNLIN = 1 IF(KMODEO.EQ.1) WRITE(IOBO,1035) PLPRM(1,1),PLPRM(1,2),KRLIN(1) 1035 FORMAT(F10.4,F10.2,I2,T40,'Initial line entry') PLPRM(1,1) = PLPRM(1,1) - CORPOS( PLPRM(1,1) ) PLPRM(1,2) = PLPRM(1,2) * FTIME GO TO 2200 C * C * USE PEAK SEARCH LIST FOR LINE ENTRIES C * 2000 IF(KAUTOP.NE.1) THEN WRITE(ITTO,2010) 2010 FORMAT(/,' * Use the following options for lines found in the', 1 ' peak search:',//, 1 ' (A)ccept, (R)eject, (M)anual entry, or (U)se all',/) LUSEM = .FALSE. ELSE LUSEM = .TRUE. ENDIF DO 2070 I=1,NPEAK IF( PEAKS(I,1).LT.BANG .OR. PEAKS(I,1).GT.EANG ) GO TO 2070 POSC = PEAKS(I,1) + CORPOS( PEAKS(I,1) ) IREF = INT( PEAKS(I,4) ) WRITE(ITTO,2025) I,POSC,PEAKS(I,2),IREF 2025 FORMAT(' Line ',I3,' Angle: ',F8.4,' Intensity: ',F10.2, 1 ' Wavelength: ',I2) IF( IREF.NE.1 .AND. KAUTOP.EQ.1 ) THEN WRITE(ITTO,2028) 2028 FORMAT(' -AUTOPILOT: Rejected; line not alpha-1') GO TO 2070 ENDIF IF(.NOT.LUSEM) THEN WRITE(ITTO,2026) 2026 FORMAT(' (R/A/E,U) ? ') READ(ITTI,2011) QANS 2011 FORMAT(A1) IF( QANS.EQ.'E' .OR. QANS.EQ.'e' ) GO TO 2200 IF( QANS.EQ.'U' .OR. QANS.EQ.'u' ) LUSEM = .TRUE. ENDIF 2012 IF( QANS.EQ.'A' .OR. QANS.EQ.'a' .OR. LUSEM ) THEN IF(KMODEO.EQ.1) WRITE(IOBO,2027) POSC,PEAKS(I,2),IREF 2027 FORMAT(F10.4,F10.2,I2,T40,'Line entry via pksrch') KNLIN = KNLIN + 1 PLPRM(KNLIN,1) = PEAKS(I,1) PLPRM(KNLIN,2) = PEAKS(I,2) * FTIME KRLIN(KNLIN) = IREF ENDIF 2070 CONTINUE C * C * GET OTHER PEAK PARAMETERS IF REQUESTED 2200 A = 0.0 B = 0.0 IREF = 0 IF(KAUTOP.NE.1) THEN IF(KMODEO.NE.2) WRITE(ITTO,2210) 2210 FORMAT(/,' Additional lines ? (Angle, Intensity, Wavelength)', 1 ' ') 2220 IF(KMODEO.NE.2) THEN READ(ITTI,*) A,B,IREF ELSE READ(ITTI,1030) A,B,IREF 1030 FORMAT(F10.4,F10.2,I2) ENDIF ENDIF IF(IREF.EQ.0) IREF = 1 IF(KMODEO.EQ.1) WRITE(IOBO,2225) A,B,IREF 2225 FORMAT(F10.4,F10.2,I2,T40,'Manual line entry') IF( A.EQ.0.0 .OR. B.EQ.0.0 ) GO TO 3000 IF( A.EQ.-1.0 .AND. B.EQ.-1.0 ) THEN IHIGH = 1 DO 2227 I = 2,KOBS 2227 IF(YOBS(I).GT.YOBS(IHIGH)) IHIGH = I A = YANG(IHIGH) B = YOBS(IHIGH) / FTIME ENDIF KNLIN = KNLIN + 1 POSC = A - CORPOS( A ) PLPRM(KNLIN,1) = POSC PLPRM(KNLIN,2) = B * FTIME KRLIN(KNLIN) = IREF WRITE(ITTO,2230) A,B,IREF 2230 FORMAT(' Line entry: Angle ',F8.4,' Intensity ',F10.2, 1' Wavelength ',I2) GO TO 2200 C * C ** THIS IS THE START OF THE REFINEMENT PARAMETER CRITERION SELECTION C * C * IF THIS IS THE FIRST TIME IN THE ROUTINE THEN ASK ALL THE QUESTIONS C * AND RECORD ALL THE ANSWERS. ON THE SUBSEQUENT ENTRIES TO THIS SUB- C * ROUTINE USE THE LAST SET OF PARAMETERS. C * C * GET PROFILE FUNCTION TO USE C * 3000 IF( KMODEO.NE.2 .AND. KAUTOP.NE.1 ) WRITE(ITTO,3010) 3010 FORMAT(/,' Profile selection for refinement:',//, 1 ' 1 - Lorentzian',/, 1 ' 2 - Modified Lorentzian',/, 1 ' 3 - Intermediate Lorenztian',/, 1 ' 4 - Pearson VII',/, 1 ' 5 - Gaussian',/, 1 ' 6 - Voigt',/, 1 ' 7 - Split Pearson VII',/, 1 ' 8 - Intermediate Lorentzian with alpha2 reflection',/, 1 ' 9 - SPVII with a2,a3: no constrained parameters',/, 1 ' 10 - SPVII with a2,a3: shape factors a1=a2=a3',/, 1 ' 11 - SPVII with a2,a3: shape and fwhm a1=a2=a3',/, 1 ' 12 - SPVII with a2,a3: calc fwhms, shapes a1=a2=a3',/, 1 ' 13 - SPVII with a2,a3: calc fwhms and shape factors',/, 1 ' 14 - Lorentzian convoluted with instrumental profile',/, 1 ' 15 - Gaussian convoluted with instrumental profile',/, 1 ' 16 - Gaussian*Lorentzian*instrumental profile') JKPROF = KPROF KPROF = 0 IF(KAUTOP.NE.1) THEN IF(KMODEO.NE.2) THEN WRITE(ITTO,3015) JKPROF 3015 FORMAT(/,' Profile? <',I3,'> ') READ(ITTI,*) KPROF ELSE READ(ITTI,3020) KPROF 3020 FORMAT(I3) ENDIF ENDIF IF( IABS(KPROF).LT.1 .OR. IABS(KPROF).GT.16 ) KPROF = JKPROF C * C * NEGATIVE PROFILE # MEANS ALL PROFILES WILL LOOK THE SAME IF( KMODEO.EQ.2 .OR. KAUTOP.EQ.1 ) WRITE(ITTO,3030) KPROF 3030 FORMAT(/,' Profile function selected: ',I3) IF(KMODEO.EQ.1) WRITE(IOBO,3040) KPROF 3040 FORMAT(I3,T40,'Profile') C * C * DETERMINE FUNCTIONAL FORM FOR CONVOLUTED PROFILES C * KCRYS = 0 IF( IABS(KPROF).NE.14 .AND. IABS(KPROF).NE.15 ) GO TO 2400 IF(.NOT.LFIRST) THEN KCRYS = JKCRYS GO TO 2400 ENDIF C * C * BROADENING IS A FUNCTION OF CRYSTALLITE SIZE IF(KMODEO.NE.2) WRITE(ITTO,3050) 3050 FORMAT(' Use crystallite size broadening ? ') READ(ITTI,2011) QANS IF( QANS.EQ.'Y' .OR. QANS.EQ.'y' ) THEN KCRYS = 1 KPROF = IABS( KPROF ) ELSE QANS = 'N' ENDIF JKCRYS = KCRYS IF(KMODEO.EQ.1) WRITE(IOBO,3052) QANS 3052 FORMAT(A1,T40,' Crystallite size broadening') IF( KMODEO.EQ.2 .OR. KAUTOP.EQ.1 ) WRITE(ITTO,3054) QANS 3054 FORMAT(' Crystallite size broadening used: ',A1) C * C * BROADENING IS A FUNCTION OF CRYSTALLITE STRAIN IF(KMODEO.NE.2) WRITE(ITTO,3060) 3060 FORMAT(' Use crystallite strain broadening ? ') READ(ITTI,2011) QANS IF( QANS.EQ.'Y' .OR. QANS.EQ.'y' ) THEN KCRYS = KCRYS + 2 KPROF = IABS( KPROF ) ELSE QANS = 'N' ENDIF JKCRYS = KCRYS IF(KMODEO.EQ.1) WRITE(IOBO,3062) QANS 3062 FORMAT(A1,T40,' Crystallite strain broadening') IF( KMODEO.EQ.2 .OR. KAUTOP.EQ.1 ) WRITE(ITTO,3064) QANS 3064 FORMAT(' Crystallite strain broadening used: ',A1) C * C ** ADD REFLECTIONS DUE TO OTHER WAVELENGTHS IF REQUESTED C * C * DONT TRY TO ADD REFS FOR PROFILES WITH REFS BUILT IN 2400 IF(IABS(KPROF).GT.7) GO TO 3100 NOLD = KNLIN DO 2410 I=1,NOLD 2410 CALL PCALC( I ) C * C ** ADDITIONAL REFINEMENT CRITERIA C * C * APPLICATION OF PATTERN ASYMMETRY FACTOR 3100 IF(.NOT.LFIRST) THEN KASYM = JKASYM GO TO 3200 ENDIF IF(KAUTOP.NE.1) THEN IF(KMODEO.NE.2) WRITE(ITTO,3110) 3110 FORMAT(/,' Apply pattern asymmetry factor ? ') READ(ITTI,2011) QANS ELSE QANS = 'N' ENDIF IF( QANS.EQ.'Y' .OR. QANS.EQ.'y' ) THEN KASYM = 1 ELSE QANS = 'N' KASYM = 0 ENDIF JKASYM = KASYM IF(KMODEO.EQ.1) WRITE(IOBO,3115) QANS 3115 FORMAT(A1,T40,'Apply asymmetry factor') IF( KMODEO.EQ.2 .OR. KAUTOP.EQ.1 ) WRITE(ITTO,3120) QANS 3120 FORMAT(' Profile asymmetry correction applied: ',A1) C * C * CORRECT TO LORENTZ/POLARIZTION FACTORS? 3200 IF(.NOT.LFIRST) THEN KLRNZ = JKLRNZ GO TO 3300 ENDIF IF(KAUTOP.NE.1) THEN IF(KMODEO.NE.2) WRITE(ITTO,3210) 3210 FORMAT(' Correct lines for l/p factors ? ') READ(ITTI,2011) QANS ELSE QANS = 'Y' ENDIF IF( QANS.EQ.'N' .OR. QANS.EQ.'n' ) THEN KLRNZ = 0 ELSE QANS = 'Y' KLRNZ = 1 ENDIF JKLRNZ = KLRNZ IF(KMODEO.EQ.1) WRITE(IOBO,3215) QANS 3215 FORMAT(A1,T40,'Correct for l/p factors') IF( KMODEO.EQ.2 .OR. KAUTOP.EQ.1 ) WRITE(ITTO,3230) QANS 3230 FORMAT(' L/P correction factors applied to profiles: ',A1) C * C * SELECTION OF ERROR CRITERION 3300 IF(.NOT.LFIRST) THEN KERRT = JKERRT GO TO 3400 ENDIF IF(KAUTOP.NE.1) THEN IF(KMODEO.NE.2) WRITE(ITTO,3310) 3310 FORMAT(' Use weighted error criterion Rwp ? ') READ(ITTI,2011) QANS ELSE QANS = 'Y' ENDIF IF( QANS.EQ.'N' .OR. QANS.EQ.'n' ) THEN KERRT = 0 ELSE QANS = 'Y' KERRT = 1 ENDIF JKERRT = KERRT IF(KMODEO.EQ.1) WRITE(IOBO,3315) QANS 3315 FORMAT(A1,T40,'Use weighted error criterion') IF( KMODEO.EQ.2 .OR. KAUTOP.EQ.1 ) WRITE(ITTO,3330) QANS 3330 FORMAT(' Weighted error criterion for refinement: ',A1) C * C ** TYPE OF BACKGROUND TO USE DURING REFINEMENT C * C * HAS BACKGROUND BEEN DETERMINED... IF SO USE IT? 3400 IF(.NOT.LFIRST) THEN KBKGR = JKBKGR GO TO 1900 ENDIF IF(KBKGD.EQ.0) GO TO 3430 IF(KAUTOP.NE.1) THEN IF(KMODEO.NE.2) WRITE(ITTO,3410) 3410 FORMAT(' Use calculated background ? ') READ(ITTI,2011) QANS ELSE QANS = 'Y' ENDIF IF( QANS.NE.'N' .AND. QANS.NE.'n' ) QANS = 'Y' IF(KMODEO.EQ.1) WRITE(IOBO,3422) QANS 3422 FORMAT(A1,T40,'Use calc background') IF( QANS.EQ.'N' .OR. QANS.EQ.'n' ) GO TO 3450 KBKGR = 2 JKBKGR = KBKGR IF( KMODEO.EQ.2 .OR. KAUTOP.EQ.1 ) WRITE(ITTO,3425) 3425 FORMAT(' Calculated background used') GO TO 1900 C * C * REFINE FIXED SHAPE BACKGROUND OFFSET 3450 IF(KAUTOP.NE.1) THEN IF(KMODEO.NE.2) WRITE(ITTO,3452) 3452 FORMAT(' Refine fixed shape offset ? ') READ(ITTI,2011) QANS ELSE QANS = 'Y' ENDIF IF( QANS.NE.'N' .AND. QANS.NE.'n' ) QANS = 'Y' IF(KMODEO.EQ.1) WRITE(IOBO,3454) QANS 3454 FORMAT(A1,T40,' Refine fixed shape offset') IF( QANS.EQ.'N' .OR. QANS.EQ.'n' ) GO TO 3430 KBKGR = 3 JKBKGR = KBKGR IF( KMODEO.EQ.2 .OR. KAUTOP.EQ.1 ) WRITE(ITTO,3456) 3456 FORMAT(' Refining fixed background shape offset') GO TO 1900 C * C * REFINE OR LEAVE ZERO? 3430 IF(KATUOP.NE.1) THEN IF(KMODEO.NE.2) WRITE(ITTO,3440) 3440 FORMAT(' Background (Z)ero or (R)efine additive value? ') READ(ITTI,2011) QANS ELSE QANS = 'R' ENDIF IF( QANS.EQ.'Z' .OR. QANS.EQ.'z' ) THEN KBKGR = 0 ELSE QANS = 'R' KBKGR = 1 ENDIF JKBKGR = KBKGR IF(KMODEO.EQ.1) WRITE(IOBO,3441) QANS 3441 FORMAT(A1,T40,'(Z)ero or (R)efine background') IF( KMODEO.EQ.2 .OR. KAUTOP.EQ.1 ) WRITE(ITTO,3442) QANS 3442 FORMAT(' Background (Z)ero or (R)efined: ',A1) C * C * INCLUDE AN AMORPHOUS PROFILE IF SELECTED C * 1900 IF(KAUTOP.NE.1) THEN IF(KMODEO.NE.2) WRITE(ITTO,1910) 1910 FORMAT(' Include an amorphous profile in pattern ? ') READ(ITTI,2011) QANS ELSE QANS = 'N' ENDIF IF( QANS.EQ.'Y' .OR. QANS.EQ.'y' ) THEN KAMOR = 1 ELSE QANS = 'N' KAMOR = 0 ENDIF JKAMOR = KAMOR IF(KMODEO.EQ.1) WRITE(IOBO,1912) QANS 1912 FORMAT(A1,T40,'Include amorphous profile') IF((KMODEO.EQ.2.OR.KAUTOP.EQ.1).AND.QANS.NE.'Y') WRITE(ITTO,1914) 1914 FORMAT(' No amorphous profile included in refinement') IF(KAMOR.NE.0) THEN IF(KMODEO.NE.2) THEN WRITE(ITTO,1920) 1920 FORMAT(/,' Initial estimates of parameters are needed here.', 1 /,' Two-theta, Intensity and fwhm for this profile ? ') AMOPAR(1) = 0.0 AMOPAR(2) = 0.0 AMOPAR(3) = 0.0 READ(ITTI,*) (AMOPAR(I),I=1,3) ELSE READ(ITTI,1930) (AMOPAR(I),I=1,3) 1930 FORMAT(F10.4,F10.2,F7.2) ENDIF IF(KMODEO.EQ.1) WRITE(IOBO,1932) (AMOPAR(I),I=1,3) 1932 FORMAT(F10.4,F10.2,F7.2,T40,'Amorphous profile parameters') IF(KMODEO.EQ.2.OR.KAUTOP.EQ.1) WRITE(ITTO,1934)(AMOPAR(I),I=1,3) 1934 FORMAT(' Amorphous profile parameters:', 1 ' POS ',F8.4,' HGT ',F8.2,' FWHM ',F5.2) AMOPAR(1) = AMOPAR(1) - CORPOS( AMOPAR(1) ) AMOPAR(2) = AMOPAR(2) * FTIME ENDIF C * C * INITIALIZE THE PARAMETERS AND THEIR LIMITS C * C * IF IN AUTO MODE DONT SET UP PARAMETERS 4000 IF(KAUTOP.NE.0) THEN NVECS = 1 GO TO 9100 ENDIF C * C * INITIALIZE THE PROFILE PARAMETERS NVECS = 0 DO 4010 I=1,KNLIN 4010 CALL PRINIT( I ) C * C * BACKGROUND 4100 IF(KBKGR.EQ.1.OR.KBKGR.EQ.3) THEN IF(KBKGD.EQ.1) THEN BKGPAR = CLY ELSE BKGPAR = 5.0000 * FTIME ENDIF NVECS = NVECS + 1 BVECS(NVECS) = BKGPAR BMINS(NVECS) = -10000.00 BMAXS(NVECS) = 10000.00 * FTIME ENDIF C * C * PATTERN ASYMMETRY FACTOR IF(KASYM.NE.0) THEN ASYPAR = 0.10 NVECS = NVECS + 1 BVECS(NVECS) = ASYPAR BMINS(NVECS) = 0.0001 BMAXS(NVECS) = 1.00E+30 ENDIF C * C * AMORPHOUS PROFILE PARAMETERS- POS,INT,FWHM IF(KAMOR.NE.0) THEN NVECS = NVECS + 1 BVECS(NVECS) = AMOPAR(1) BMINS(NVECS) = AMOPAR(1) - 2.0 BMAXS(NVECS) = AMOPAR(1) + 2.0 NVECS = NVECS + 1 BVECS(NVECS) = AMOPAR(2) BMINS(NVECS) = 0.0001 BMAXS(NVECS) = AMOPAR(2) * 10.0 NVECS = NVECS + 1 BVECS(NVECS) = AMOPAR(3) BMINS(NVECS) = 0.0001 BMAXS(NVECS) = AMOPAR(3) * 5.0 ENDIF C * C * CRYSTALLITE SIZE PARAMETER (IN NANOMETERS) IF( KCRYS.EQ.1 .OR. KCRYS.EQ.3 ) THEN CRYPAR(1) = 500.0E-9 IF(KCRYS.EQ.3) CRYPAR(1) = 600.0E-9 NVECS = NVECS + 1 BVECS(NVECS) = CRYPAR(1) BMINS(NVECS) = 0.1E-9 BMAXS(NVECS) = 4000.0E-9 ENDIF C * C * CRYSTALLITE STRAIN PARAMETER IF( KCRYS.EQ.2 .OR. KCRYS.EQ.3 ) THEN CRYPAR(2) = 0.0005 IF(KCRYS.EQ.3) CRYPAR(2) = 0.0001 NVECS = NVECS + 1 BVECS(NVECS) = CRYPAR(2) BMINS(NVECS) = 1.0E-6 BMAXS(NVECS) = 1.0 ENDIF C * C * CHECK FOR EXCEEDING NUMBER OF PARAMETERS FOR REFINEMENT 9000 IF(NVECS.LE.MEMV) GO TO 9100 WRITE(ITTO,9010) NVECS,MEMV 9010 FORMAT(/,' --NUMBER OF PARAMETERS (',I3,') EXCEEDS THE CURRENT', 1' PROGRAM LIMIT OF ',I3,/, 1' CHANGE THE VALUE OF *MEMV* ON ALL PARAMETER CARDS TO SUIT', 1' YOUR NEEDS',/) STOP '--ABORT: NUMBER OF PARAMETERS EXCEEDS PROGRAM LIMIT' C * 9100 RETURN END C *** PRINIT - INITIALIZE PROFILE PARAMETERS C * SUBROUTINE PRINIT( NPOINT ) C * CHARACTER QFTITL*80 PARAMETER ( MEMV = 32, MPTS = 2048 ) PARAMETER ( MEMVP1 = MEMV+1, MEMVT2 = MEMV*2 ) PARAMETER ( DTOR=1.745329252E-2, RTOD=5.729577951E+1 ) COMMON /REFFLG/ KPROF,KLRNZ,KERRT,KASYM,KBKGR,KBKGD,KAMOR,KCRYS COMMON /LUNS/ ITTI,ITTO,IOFI,IOFO,IOBO,IOPL,IOPO,IOLO,IOSC,IOWG COMMON /PEAKP/ KNLIN,KNPRM,PLPRM(200,10),KRLIN(200),KLLIN(201) COMMON /VECTOR/ NVECS,BVECS(MEMVT2),BMINS(MEMV),BMAXS(MEMV) COMMON /FLDATN/ KFILET,FBANG,FEANG,FAINC,FTIME COMMON /WDATA/ NWAVE,WTABLE(5,2) COMMON /FLDATC/ QFTITL C * C * ALL PROFILES GET ANGLES AND INTENSITIES SET C * C * CONSTRAINTS ON ANGLES -> NO MORE THAN 0.2 DEGREES TWO-THETA TTHT = PLPRM(NPOINT,1) BMINS(NVECS+1) = TTHT - 0.2 BMAXS(NVECS+1) = TTHT + 0.2 C * C * FWHM VALUES AND EXPONENT VALUES PPL = FNFWHM( TTHT, 1) PPH = FNFWHM( TTHT, 2) PP = 0.5 * ( PPL + PPH ) PEL = FNSHAP( TTHT, 1) PEH = FNSHAP( TTHT, 2) PE = 0.5 * ( PEL + PEH ) C * C * CONSTRAINTS ON INTENSITIES JK = IABS( KPROF ) BMINS(NVECS+2) = 0.2500 BMAXS(NVECS+2) = 2.0 * PLPRM(NPOINT,2) IF(JK.EQ.14.OR.JK.EQ.15.OR.JK.EQ.6) BMAXS(NVECS+2) = 1.0E10 C * C * IF USING -VE PROFILE AND THIS LINE NOT THE FIRST PARAMS ARE SET IF( KPROF.LT.0 .AND. NPOINT.GT.1 )GO TO 9000 C * C * SELECT PROPER PROFILE FUNCTION GO TO(10,10,10,40,10,60,70,80,90,100,110,120,130,140,140,150),JK C * C * GAUSSIAN AND NORMAL, MODIFIED, AND INTERMEDIATE LORENZTIAN 10 KNPRM = 3 C * ACOEFF - FULL WIDTH AT HALF MAXIMUM PLPRM(NPOINT,3) = PP BMINS(NVECS+3) = 0.0010 BMAXS(NVECS+3) = 5.0000 GO TO 9000 C * C * PEARSON VII 40 KNPRM = 4 C * ACOEFF - FULL WIDTH AT HALF MAX PLPRM(NPOINT,3) = PP BMINS(NVECS+3) = 0.0010 BMAXS(NVECS+3) = 5.0000 C * BCOEFF - EXPONENT PLPRM(NPOINT,4) = PE BMINS(NVECS+4) = 0.5000 BMAXS(NVECS+4) = 5.0000 GO TO 9000 C * C * VOIGT PROFILE 60 KNPRM = 4 C * BETA-G -> GAUSSIAN BREADTH PARAMETER PLPRM(NPOINT,3) = PP / 2.0 BMINS(NVECS+3) = 0.0001 BMAXS(NVECS+3) = 4.0000 C * BETA-C -> LORENTZIAN BREADTH PARAMETER PLPRM(NPOINT,4) = PP / 2.0 BMINS(NVECS+4) = 0.0001 BMAXS(NVECS+4) = 4.0000 GO TO 9000 C * C * SPLIT PEARSON VII 70 KNPRM = 6 C * ACOEFF - FULL WIDTH AT HALF MAX PLPRM(NPOINT,3) = PPL BMINS(NVECS+3) = 0.0010 BMAXS(NVECS+3) = 5.0000 C * BCOEFF - EXPONENT PLPRM(NPOINT,4) = PEL BMINS(NVECS+4) = 0.5000 BMAXS(NVECS+4) = 5.0000 C * CCOEFF - FULL WIDTH AT HALF MAX PLPRM(NPOINT,5) = PPH BMINS(NVECS+5) = 0.0010 BMAXS(NVECS+5) = 5.0000 C * DCOEFF - EXPONENT PLPRM(NPOINT,6) = PEH BMINS(NVECS+6) = 0.5000 BMAXS(NVECS+6) = 5.0000 GO TO 9000 C * C * INTERMEDIATE LORENTZIAN WITH ALPHA2 REFLECTION 80 KNPRM = 3 C * ACOEFF - FULL WIDTH AT HALF MAXIMUM INTENSITY, ALPHA1 PLPRM(NPOINT,3) = 0.001 BMINS(NVECS+3) = 0.0000 - 0.1 * PP BMAXS(NVECS+3) = 0.4000 IF(TTHT.LT.15.0) BMAXS(NVECS+3) = 2.0000 GO TO 9000 C * C * SPLIT PEARSON VII WITH ALPHA 2 REFLECTION 90 KNPRM = 10 C * ACOEFF - FULL WIDTH AT HALF MAX, ALPHA1 PLPRM(NPOINT,3) = PPL BMINS(NVECS+3) = 0.0010 BMAXS(NVECS+3) = 5.0000 C * BCOEFF - EXPONENT, ALPHA1 PLPRM(NPOINT,4) = PEL BMINS(NVECS+4) = 0.5000 BMAXS(NVECS+4) = 5.0000 C * CCOEFF - FULL WIDTH AT HALF MAX, ALPHA 1 BACK PLPRM(NPOINT,5) = PPH BMINS(NVECS+5) = 0.0010 BMAXS(NVECS+5) = 5.0000 C * DCOEFF - EXPONENT, ALPHA 1 PLPRM(NPOINT,6) = PEH BMINS(NVECS+6) = 0.5000 BMAXS(NVECS+6) = 5.0000 C * ECOEFF - FULL WIDTH AT HALF MAX, ALPHA2 FRONT PLPRM(NPOINT,7) = PPL BMINS(NVECS+7) = 0.0010 BMAXS(NVECS+7) = 5.0000 C * FCOEFF - EXPONENT, ALPHA2 PLPRM(NPOINT,8) = PEL BMINS(NVECS+8) = 0.5000 BMAXS(NVECS+8) = 5.0000 C * GCOEFF - FULL WIDTH AT HALF MAX, ALPHA 2 BACK PLPRM(NPOINT,9) = PPH BMINS(NVECS+9) = 0.0010 BMAXS(NVECS+9) = 5.0000 C * HCOEFF - EXPONENT, ALPHA 2 PLPRM(NPOINT,10) = PEH BMINS(NVECS+10) = 0.5000 BMAXS(NVECS+10) = 5.0000 GO TO 9000 C * C * CONSTRAINED PEARSON WITH REFLECTION 100 KNPRM = 8 C * ACOEFF - FULL WIDTH AT HALF MAX, ALPHA1 FRONT PLPRM(NPOINT,3) = PPL BMINS(NVECS+3) = 0.0010 BMAXS(NVECS+3) = 5.0000 C * BCOEFF - EXPONENT, ALPHA1 PLPRM(NPOINT,4) = PEL BMINS(NVECS+4) = 0.5000 BMAXS(NVECS+4) = 5.0000 C * CCOEFF - FULL WIDTH AT HALF MAX, ALPHA 1 BACK PLPRM(NPOINT,5) = PPH BMINS(NVECS+5) = 0.0010 BMAXS(NVECS+5) = 5.0000 C * DCOEFF - EXPONENT, ALPHA 1 PLPRM(NPOINT,6) = PEH BMINS(NVECS+6) = 0.5000 BMAXS(NVECS+6) = 5.0000 C * ECOEFF - FULL WIDTH AT HALF MAX, ALPHA2 FRONT PLPRM(NPOINT,7) = PPL BMINS(NVECS+7) = 0.0010 BMAXS(NVECS+7) = 5.0000 C * FCOEFF - FULL WIDTH AT HALF MAX, ALPHA 2 BACK PLPRM(NPOINT,8) = PPH BMINS(NVECS+8) = 0.0010 BMAXS(NVECS+8) = 5.0000 GO TO 9000 C * C * CONSTRAINED PEARSON WITH REFLECTION 110 KNPRM = 6 C * ACOEFF - FULL WIDTH AT HALF MAX, ALPHA1 AND ALPHA2 FRONT PLPRM(NPOINT,3) = PPL BMINS(NVECS+3) = 0.0100 BMAXS(NVECS+3) = 5.0000 C * BCOEFF - EXPONENT, ALPHA1 AND ALPHA2 PLPRM(NPOINT,4) = PEL BMINS(NVECS+4) = 0.5000 BMAXS(NVECS+4) = 5.0000 C * CCOEFF - FULL WIDTH AT HALF MAX, ALPHA 1 AND ALPHA2 BACK PLPRM(NPOINT,5) = PPH BMINS(NVECS+5) = 0.0100 BMAXS(NVECS+5) = 5.0000 C * DCOEFF - EXPONENT, ALPHA 1 AND ALPHA2 PLPRM(NPOINT,6) = PEH BMINS(NVECS+6) = 0.5000 BMAXS(NVECS+6) = 5.0000 GO TO 9000 C * C * CONSTRAINED PEARSON WITH REFLECTION, CALC FWHM, REFINED SF 120 KNPRM = 4 C * ACOEFF - EXPONENT, ALPHA1,2 FRONT PLPRM(NPOINT,3) = PEL BMINS(NVECS+3) = 0.5000 BMAXS(NVECS+3) = 5.0000 C * BCOEFF - EXPONENT ALPHA1,2 BACK PLPRM(NPOINT,4) = PEH BMINS(NVECS+4) = 0.5000 BMAXS(NVECS+4) = 5.0000 GO TO 9000 C * C * PEARSON VII, FULLY CONSTRAINED 130 KNPRM = 2 GO TO 9000 C * C * CONVOLUTION PRODUCT... LORENTZIAN OR GAUSSIAN WITH INSTRUMENT 140 KNPRM = 2 C * ACOEFF - INTEGRAL BREADTH OF THE SPECIMEN PROFILE C * INITIAL ESTIMATES ARE OBTAINED FROM THE SCHERRER EQUATION. IF(KCRYS.NE.0) GO TO 9000 KNPRM = 3 SIZE = 500.0E-9 AX = RTOD * WTABLE(1,1) / ( SIZE * COS(TTHT/2.*DTOR) ) IF(AX.LT.0.005) AX = 0.005 PLPRM(NPOINT,3) = AX BMINS(NVECS+3) = 0.00001 BMAXS(NVECS+3) = 10.00000 GO TO 9000 C * C * CONVOLUTION PRODUCT... LORENTZIAN OR GAUSSIAN WITH INSTRUMENT 150 KNPRM = 2 C * ACOEFF - INTEGRAL BREADTH OF THE SPECIMEN PROFILE C * INITIAL ESTIMATES ARE OBTAINED FROM THE SCHERRER EQUATION. IF(KCRYS.NE.0) GO TO 9000 KNPRM = 4 SIZE = 500.0E-9 AX = RTOD * WTABLE(1,1) / ( SIZE * COS(TTHT/2.0*DTOR) ) IF(AX.LT.0.005) AX = 0.005 PLPRM(NPOINT,3) = AX / 2.0 BMINS(NVECS+3) = 0.00001 BMAXS(NVECS+3) = 10.00000 PLPRM(NPOINT,4) = AX / 2.0 BMINS(NVECS+4) = 0.00001 BMAXS(NVECS+4) = 10.00000 C * C * COPY PLPRM TO BVECS... INITIAL OPTIMIZATION VECTOR C * C * COPY PARAMETERS FOR INDIVIDUAL PROFILES 9000 IF( NPOINT.NE.1 .AND. KPROF.LT.0 )GO TO 9050 DO 9010 I=1,KNPRM NVECS = NVECS + 1 BVECS(NVECS) = PLPRM(NPOINT,I) 9010 CONTINUE GO TO 9999 C * C * COPY PARAMETERS FOR FULLY CONSTRAINED PROFILES 9050 DO 9060 I=1,2 NVECS = NVECS + 1 BVECS(NVECS) = PLPRM(NPOINT,I) 9060 CONTINUE DO 9070 I=3,KNPRM 9070 PLPRM(NPOINT,I) = PLPRM(1,I) C * C * THE PROFILE PARAMETERS ARE INITIALIZED 9999 RETURN END C *** RFPLOT - INITIALIZES PLOTTING FOR THE REFINEMENT PHASE C * SUBROUTINE RFPLOT C * LOGICAL LNOMOR CHARACTER QFILE*32, ITITLS(5)*20, QANS*1, QFTITL*80 PARAMETER ( MEMV = 32, MPTS = 2048 ) PARAMETER ( MAXREC = MPTS/10 ) COMMON /LUNS/ ITTI,ITTO,IOFI,IOFO,IOBO,IOPL,IOPO,IOLO,IOSC,IOWG COMMON /SDATA/ KOBS,YANG(MPTS),YOBS(MPTS),YSYN(MPTS),YBKG(MPTS) COMMON /FLDATN/ KFILET,FBANG,FEANG,FAINC,FTIME COMMON /PLTDAT/ KPPLOT,KPSETS(5),KPTYPE,KPTDEF COMMON /MODEOP/ KMODEO,KSAMEP,KAUTOP COMMON /PDATA/ BANG, EANG COMMON /FLDATC/ QFTITL DIMENSION NCPLOT(5),OFFSET(5),NUMPEN(5),MARKER(5),XDATA(10) DATA ITITLS(1)/'OBSERVED PATTERN '/ DATA ITITLS(2)/'REFINED PATTERN '/ DATA ITITLS(3)/'DIFFERENCE PATTERN '/ DATA ITITLS(4)/'CALCULATED PROFILES '/ DATA ITITLS(5)/'ALPHA 1 PATTERN '/ C * C * DETERMINE WHETHER A PLOTTING FILE IS TO BE GENERATED C * 1000 KPPLOT = 0 DO 1005 I=1,5 KPSETS(I) = 0 NCPLOT(I) = 0 OFFSET(I) = 0.0 NUMPEN(I) = 0 MARKER(I) = 0 1005 CONTINUE IF(KAUTOP.NE.1) THEN IF(KMODEO.NE.2) WRITE(ITTO,1010) 1010 FORMAT(/,' Do you want plotting after refinement ? ') READ(ITTI,1020) QANS 1020 FORMAT(A1) ELSE QANS = 'Y' ENDIF IF( QANS.NE.'Y' .AND. QANS.NE.'y' ) QANS = 'N' IF(KMODEO.EQ.1) WRITE(IOBO,1030) QANS 1030 FORMAT(A1,T40,'Plotting after refinement') IF( QANS.EQ.'Y' .OR. QANS.EQ.'y' ) GO TO 2000 IF((KMODEO.EQ.2.OR.KAUTOP.EQ.1).AND.QANS.NE.'Y') WRITE(ITTO,1040) 1040 FORMAT(' No ploting after refinement') GO TO 9000 C * C * GET THE OUTPUT FILE NAME AND OPEN IT 2000 KPPLOT = 1 IF(KAUTOP.NE.1) THEN IF(KMODEO.NE.2) WRITE(ITTO,2010) 2010 FORMAT(' Plot file name ? ') READ(ITTI,2020) QFILE 2020 FORMAT(A32) ELSE QFILE = 'RPLOT' ENDIF IF( QFILE(1:1).EQ.'$' .AND. KPTYPE.EQ.0 ) THEN WRITE(ITTO,2022) 2022 FORMAT(' -Plot file type changed for formatted') KPTYPE = 1 QFILE(1:) = QFILE(2:) ENDIF IF( QFILE(1:1).EQ.'$' .AND. KPTYPE.EQ.1 ) THEN WRITE(ITTO,2024) 2024 FORMAT(' -Plot file type changed for unformatted') KPTYPE = 0 QFILE(1:) = QFILE(2:) ENDIF IF( QFILE.EQ.' ' .OR. QFILE.EQ.'/' ) QFILE = 'RPLOT' IF(KMODEO.EQ.1) THEN WRITE(IOBO,2030) QFILE 2030 FORMAT(A32,T40,' Plot file name') GO TO 3000 ENDIF IF( KMODEO.EQ.2 .OR. KAUTOP.EQ.1 ) WRITE(ITTO,2040) QFILE 2040 FORMAT(' Refinement plot data stored on: ',A32) IF(KPTYPE.EQ.0) THEN OPEN(UNIT=IOPL,FILE=QFILE,STATUS='UNKNOWN',FORM='UNFORMATTED', 1 ERR=2100) ELSE OPEN(UNIT=IOPL,FILE=QFILE,STATUS='UNKNOWN',FORM='FORMATTED', 1 ERR=2100) ENDIF GO TO 3000 2100 WRITE(ITTO,2110) 2110 FORMAT(' --Can not open plot file: No plot data will be written') KPPLOT = 0 GO TO 9000 C * C ** USE DEFAULT PARAMS OR SET THEM INDIVIDUALLY.... C * 3000 IF(KAUTOP.NE.1) THEN IF(KMODEO.NE.2) WRITE(ITTO,3010) 3010 FORMAT(' Do you want the default plots ? ') READ(ITTI,1020) QANS ELSE QANS = 'Y' ENDIF IF( QANS.NE.'N' .AND. QANS.NE.'n' ) QANS = 'Y' IF(KMODEO.EQ.1) WRITE(IOBO,3020) QANS 3020 FORMAT(A1,T40,' Default plot set') IF( KMODEO.EQ.2 .OR. KAUTOP.EQ.1 ) WRITE(ITTO,3030) QANS 3030 FORMAT(' Generate the default refinement plots: ',A1) IF(QANS.EQ.'N') GO TO 3200 C * C ** SET DEFAULT PARAMETERS C * NUMSTS = 3 C * RAW KPSETS(1) = 1 NCPLOT(1) = 1 OFFSET(1) = 0.0 NUMPEN(1) = 2 MARKER(1) = 0 C * REFINED KPSETS(2) = 2 NCPLOT(2) = 1 OFFSET(2) = 0.0 NUMPEN(2) = 3 MARKER(2) = 0 C * DIFFERENCE KPSETS(3) = 0 NCPLOT(3) = 0 OFFSET(3) = 0.0 NUMPEN(3) = 0 MARKER(3) = 0 C * PROFILES KPSETS(4) = 3 NCPLOT(4) = 1 OFFSET(4) = 0.0 NUMPEN(4) = 4 MARKER(4) = 0 C * CORRECTED KPSETS(5) = 0 NCPLOT(5) = 0 OFFSET(5) = 0.0 NUMPEN(5) = 0 MARKER(5) = 0 C * AXIS NPLOTS = 1 IAXIS = 0 FS = 1200.0 DPI = 2. GO TO 5000 C * C ** GET THE NON STANDARD PLOTTING PARAMETERS C * C * TELL THEM HOW TO DO IT 3200 NUMSTS = 0 IF(KMODEO.NE.2)WRITE(ITTO,3210) 3210 FORMAT(/,' The following questions pertain to plotting of the', 1 ' results.',/,' Enter <+N,0 or -N> for plotting of every', 1 ' Nth point in the data set.',//, 1 3X,' +N => Draw lines between each Nth point',/, 1 3X,' 0 => Skips the data set',/, 1 3X,' -N => Draw dots at each Nth point',//, 1 ' Follow N with a value for the offset (in inches) to', 1 ' separate',/,' the data groups. e.g., .75 displaces the data', 1 ' set .75 inches.',//, 1 ' The final parameter specifies the pen to use in plotting', 1 ' the data set.') C * C * RAW PATTERN 3300 KPSETS(1) = 0 NCPLOT(1) = 0 OFFSET(1) = 0.0 NUMPEN(1) = 0 MARKER(1) = 0 IF(KMODEO.NE.2) THEN WRITE(ITTO,3310) 3310 FORMAT(/,' Raw data ? <0,0.0,0> ') READ(ITTI,*) NCPLOT(1),OFFSET(1),NUMPEN(1) ELSE READ(ITTI,3320) NCPLOT(1),OFFSET(1),NUMPEN(1) 3320 FORMAT(I3,F5.2,I3) ENDIF IF(NCPLOT(1).NE.0) THEN NUMSTS = NUMSTS + 1 KPSETS(1) = NUMSTS ENDIF IF(KMODEO.EQ.1) WRITE(IOBO,3330)NCPLOT(1),OFFSET(1),NUMPEN(1) 3330 FORMAT(I3,F5.2,I3,T40,' Plot params') C * C * CALCULATED PATTERN 3400 KPSETS(2) = 0 NCPLOT(2) = 0 OFFSET(2) = 0.0 NUMPEN(2) = 0 MARKER(2) = 0 IF(KMODEO.NE.2) THEN WRITE(ITTO,3410) 3410 FORMAT(' Calculated pattern ? <0,0.0,0> ') READ(ITTI,*) NCPLOT(2),OFFSET(2),NUMPEN(2) ELSE READ(ITTI,3320) NCPLOT(2),OFFSET(2),NUMPEN(2) ENDIF IF(NCPLOT(2).NE.0) THEN NUMSTS = NUMSTS + 1 KPSETS(2) = NUMSTS ENDIF IF(KMODEO.EQ.1) WRITE(IOBO,3330)NCPLOT(2),OFFSET(2),NUMPEN(2) C * C * DIFFERENCE PATTERN 3500 KPSETS(3) = 0 NCPLOT(3) = 0 OFFSET(3) = 0.0 NUMPEN(3) = 0 MARKER(3) = 0 IF(KMODEO.NE.2) THEN WRITE(ITTO,3510) 3510 FORMAT(' Difference pattern ? <0,0.0,0> ') READ(ITTI,*) NCPLOT(3),OFFSET(3),NUMPEN(3) ELSE READ(ITTI,3320) NCPLOT(3),OFFSET(3),NUMPEN(3) ENDIF IF(NCPLOT(3).NE.0) THEN NUMSTS = NUMSTS + 1 KPSETS(3) = NUMSTS ENDIF IF(KMODEO.EQ.1) WRITE(IOBO,3330)NCPLOT(3),OFFSET(3),NUMPEN(3) C * C * INDIVIDUAL PROFILES 3600 KPSETS(4) = 0 NCPLOT(4) = 0 OFFSET(4) = 0.0 NUMPEN(4) = 0 MARKER(4) = 0 IF(KMODEO.NE.2) THEN WRITE(ITTO,3610) 3610 FORMAT(' Calculated profiles ? <0,0.0,0> ') READ(ITTI,*) NCPLOT(4),OFFSET(4),NUMPEN(4) ELSE READ(ITTI,3320) NCPLOT(4),OFFSET(4),NUMPEN(4) ENDIF IF(NCPLOT(4).NE.0) THEN NUMSTS = NUMSTS + 1 KPSETS(4) = NUMSTS ENDIF IF(KMODEO.EQ.1) WRITE(IOBO,3330)NCPLOT(4),OFFSET(4),NUMPEN(4) C * C * ALPHA 1 PATTERN 3700 KPSETS(5) = 0 NCPLOT(5) = 0 OFFSET(5) = 0.0 NUMPEN(5) = 0 MARKER(5) = 0 IF(KMODEO.NE.2) THEN WRITE(ITTO,3710) 3710 FORMAT(' Alpha 1 pattern ? <0,0.0,0> ') READ(ITTI,*) NCPLOT(5),OFFSET(5),NUMPEN(5) ELSE READ(ITTI,3320) NCPLOT(5),OFFSET(5),NUMPEN(5) ENDIF IF(NCPLOT(5).NE.0) THEN NUMSTS = NUMSTS + 1 KPSETS(5) = NUMSTS ENDIF IF(KMODEO.EQ.1) WRITE(IOBO,3330)NCPLOT(5),OFFSET(5),NUMPEN(5) C * C ** AXIS INFORMATION C * 4000 IF(KMODEO.NE.2) THEN WRITE(ITTO,4002) 4002 FORMAT(/,' Number of plots per page ? (1 OR 2) <1> ') NPLOTS = 1 READ(ITTI,*) NPLOTS ELSE READ(ITTI,4004) NPLOTS 4004 FORMAT(I2) ENDIF IF(NPLOTS.EQ.0) NPLOTS = 1 IF( NPLOTS.LT.-2 .OR. NPLOTS.GT.2 ) NPLOTS = 1 IF(KMODEO.EQ.1) WRITE(IOBO,4006) NPLOTS 4006 FORMAT(I2,T40,' Plots per page') DPI = 2.0 IF(NPLOTS.LT.0) THEN IF(KMODEO.NE.2) THEN WRITE(ITTO,4010) 4010 FORMAT(' Degrees per inch for two-theta axis ? <2.0> ') READ(ITTI,*) DPI ELSE READ(ITTI,4012) DPI 4012 FORMAT(F6.2) ENDIF IF(DPI.LE.0.0) DPI = 2.0 IF(KMODEO.EQ.1) WRITE(IOBO,4014) DPI 4014 FORMAT(F6.2,T40,' Deg/inch two-theta') ENDIF C * 4040 IF(KMODEO.NE.2) WRITE(ITTO,4042) 4042 FORMAT(' Draw the axis system ? ') READ(ITTI,1020) QANS IAXIS = 0 IF( QANS.EQ.'N' .OR. QANS.EQ.'n' ) IAXIS = 1 IF(KMODEO.EQ.1) WRITE(IOBO,4050) QANS 4050 FORMAT(A1,T40,' Draw axis system') C * IF(KMODEO.NE.2) THEN WRITE(ITTO,4060) 4060 FORMAT(' Full scale value for intensity axis ? <1200.0> ') READ(ITTI,*) FS ELSE READ(ITTI,4022) FS 4022 FORMAT(F8.2) ENDIF IF(FS.LE.0.0) FS = 1200.0 IF(KMODEO.EQ.1) WRITE(IOBO,4070) FS 4070 FORMAT(F8.2,T40,' Full scale') C * C ** WRITE THE INITIAL INFORMATION TO THE PLOT FILE C * C * IF BATCH SETUP... DONT WRITE FILE 5000 IF(KMODEO.EQ.1) GO TO 9000 C * C * WRITE THE FILE HEADER KYID = 0 IF(KPTYPE.EQ.0) THEN WRITE(IOPL) QFTITL WRITE(IOPL) BANG,EANG,FAINC WRITE(IOPL) NUMSTS,NPLOTS,IAXIS,DPI,FS,KYID DO 5010 I=1,5 IF(KPSETS(I).EQ.0) GO TO 5010 WRITE(IOPL) ITITLS(I),NCPLOT(I),OFFSET(I),NUMPEN(I),MARKER(I) 5010 CONTINUE ELSE WRITE(IOPL,5020) QFTITL 5020 FORMAT(A80) WRITE(IOPL,5030) BANG,EANG,FAINC 5030 FORMAT(3F10.4) WRITE(IOPL,5040) NUMSTS,NPLOTS,IAXIS,DPI,FS,KYID 5040 FORMAT(3I6,F6.2,2I6) DO 5050 I=1,5 IF(KPSETS(I).EQ.0) GO TO 5050 WRITE(IOPL,5060) ITITLS(I),NCPLOT(I),OFFSET(I),NUMPEN(I), 1 MARKER(I) 5060 FORMAT(A20,I6,F6.2,2I6) 5050 CONTINUE ENDIF C * C ** PUT THE RAW DATA IN THE PLOT FILE NOW... C * 6000 IF(KPSETS(1).EQ.0) GO TO 9000 C * C * SKIP HEADER AND SKIP RECORDS REWIND (UNIT=IOFI) IF(KFILET.EQ.0) THEN DO 6010 I=1,3 6010 READ(IOFI,6020) JUNK 6020 FORMAT(1A1) ELSE DO 6030 I=1,3 6030 READ(IOFI) JUNK ENDIF C * C * READ THE INPUT RECORDS 6100 NTOGO = NINT( (FEANG-FBANG) / FAINC ) + 1 NGONE = 0 NTOTAL = 0 6105 NPASS = 0 LNOMOR = .TRUE. DO 6110 I=1,MAXREC IF(KFILET.EQ.0) THEN READ(IOFI,6120,END=6200) XDATA 6120 FORMAT(10F7.0) ELSE READ(IOFI,END=6200) XDATA ENDIF DO 6130 J=1,10 NPASS = NPASS + 1 YSYN(NPASS) = XDATA(J) NTOTAL = NTOTAL + 1 IF(NTOTAL.EQ.NTOGO) GO TO 6200 6130 CONTINUE 6110 CONTINUE LNOMOR = .FALSE. 6200 ANGLE = FBANG + REAL(NGONE) * FAINC IF(KPTYPE.EQ.0) THEN WRITE(IOPL) KPSETS(1),NPASS,ANGLE WRITE(IOPL) (YSYN(I)/FTIME,I=1,NPASS) ELSE WRITE(IOPL,6210) KPSETS(1),NPASS,ANGLE 6210 FORMAT(I6,I6,F10.4) WRITE(IOPL,6220) (YSYN(I)/FTIME,I=1,NPASS) 6220 FORMAT(10F8.1) ENDIF NGONE = NGONE + NPASS IF(.NOT.LNOMOR) GO TO 6105 C * C * INITIALIZATION COMPLETE... EXIT 9000 RETURN END C *** PCALC C * C * PCALC ADDS LINES CORRESPONDING TO THE WAVELENGTHS IN THE C * WAVELENGTH TABLE. ARGUMENT IPEAK POINTS TO THE LINE C * THAT WILL HAVE REFLECTIONS ADDED. C * SUBROUTINE PCALC( IPEAK ) C * CHARACTER QANS*1, QFTITL*80 COMMON /LUNS/ ITTI,ITTO,IOFI,IOFO,IOBO,IOPL,IOPO,IOLO,IOSC,IOWG COMMON /PEAKP/ KNLIN,KNPRM,PLPRM(200,10),KRLIN(200),KLLIN(201) COMMON /FLDATN/ KFILET,FBANG,FEANG,FAINC,FTIME COMMON /WDATA/ NWAVE,WTABLE(5,2) COMMON /MODEOP/ KMODEO,KSAMEP,KAUTOP COMMON /FLDATC/ QFTITL C * C * DO NOT EXECUTE IF THERE IS ONLY ONE WAVELENGTH TABLED IF(NWAVE.EQ.1) GO TO 600 C * C * ADD REFLECTIONS DUE TO ADDITIONAL WAVELENGTHS IF(KMODEO.NE.2) WRITE(ITTO,100)IPEAK,PLPRM(IPEAK,1), 1 PLPRM(IPEAK,2)/FTIME,KRLIN(IPEAK) 100 FORMAT(/,' Line ',I2,': Ang = ',F6.2,' Int = ',F8.2, 1' Wavelength = ',I2) IF(KMODEO.NE.2)WRITE(ITTO,105) 105 FORMAT(' Add reflections ? ') READ(ITTI,110) QANS 110 FORMAT(A1) IF( QANS.NE.'Y' .AND. QANS.NE.'y' ) QANS = 'N' IF(KMODEO.EQ.1) WRITE(IOBO,107) QANS,IPEAK 107 FORMAT(A1,T40,'Reflections for line ',I3) IF( QANS.NE.'Y' .AND. QANS.NE.'y' ) GO TO 600 C * RTOD = 360.00 / ( 2.00 * 3.141592653590 ) PANG = PLPRM(IPEAK,1) PMAX = PLPRM(IPEAK,2) C * C * LIST NEW PARAMETERS WRITE(ITTO,130) PANG,PMAX/FTIME 130 FORMAT(' Primary line 1 at: ',F10.4,' Intensity: ',F10.4) C * C * USE THE FIRST WAVELENGTH TO DETERMINE THE CORRESPONDING D-SPACING RAD = (PANG/2.0) / 360.00 * ( 2.00 * 3.141592653590 ) DSP = WTABLE(1,1) / ( 2.00 * SIN(RAD) ) C * C * ADD ADDITIONAL LINES CORRESPONDING TO OTHER WAVELENGTHS DO 500 I=2,NWAVE C * C * DETERMINE THE BRAGG ANGLE AND INTENSITY FOR REQUESTED WAVELENGTH WPOS = 2.00 * RTOD * ASIN( WTABLE(I,1)/(2.00*DSP) ) WINT = PMAX * WTABLE(I,2) WRITE(ITTO,140) I,WPOS,WINT/FTIME 140 FORMAT(' Reflection ',I1,' at: ',F10.4,' Intensity: ',F10.4) KNLIN = KNLIN + 1 PLPRM(KNLIN,1) = WPOS PLPRM(KNLIN,2) = WINT KRLIN(KNLIN) = I 500 CONTINUE C * 600 RETURN END C *** DINPUT - FETCH REQUESTED SCAN DATA FROM PATTERN FILE C * SUBROUTINE DINPUT( START, END ) C * C * WHERE: START = REQUESTED STARTING ANGLE C * END = REQUESTED ENDING ANGLE C * CHARACTER QJUNK*1, QFTITL*80 PARAMETER ( MEMV = 32, MPTS = 2048 ) COMMON /LUNS/ ITTI,ITTO,IOFI,IOFO,IOBO,IOPL,IOPO,IOLO,IOSC,IOWG COMMON /SDATA/ KOBS,YANG(MPTS),YOBS(MPTS),YSYN(MPTS),YBKG(MPTS) COMMON /FLDATN/ KFILET,FBANG,FEANG,FAINC,FTIME COMMON /PDATA/ BANG, EANG COMMON /FLDATC/ QFTITL DIMENSION XDATA(10) C * KOBS = 0 NSKIPB = INT( (START-FBANG)/FAINC + 0.1 ) BANG = FBANG + REAL(NSKIPB) * FAINC NRSKIP = NSKIPB / 10 NPSKIP = NSKIPB - NRSKIP * 10 NSKIPE = NINT( (END-FBANG)/FAINC ) EANG = FBANG + REAL(NSKIPE) * FAINC NTOGET = NSKIPE - NSKIPB + 1 C * C * SKIP RECORDS AT BEGINNING OF THE FILE REWIND (UNIT=IOFI) NRSKIP = NRSKIP + 3 IF(KFILET.EQ.0) THEN DO 2010 I=1,NRSKIP 2010 READ(IOFI,2012) QJUNK 2012 FORMAT(1A1) ELSE DO 2014 I=1,NRSKIP 2014 READ(IOFI) QJUNK ENDIF C * C * READ NEXT RECORD IF ANY POINTS ARE ON IT IF(NPSKIP.EQ.0) GO TO 2040 IF(KFILET.EQ.0) THEN READ(IOFI,2025) XDATA 2025 FORMAT(10F7.0) ELSE READ(IOFI) XDATA ENDIF DO 2032 I = (NPSKIP+1), 10 KOBS = KOBS +1 YOBS(KOBS) = XDATA(I) IF(KOBS.EQ.NTOGET) GO TO 3000 2032 CONTINUE C * C * KEEP READING UNTIL THE PROPER NUMBER OF POINTS HAVE BEEN READ 2040 IF(KFILET.EQ.0) THEN 2100 READ(IOFI,2025,END=2300) XDATA DO 2160 J = 1, 10 KOBS = KOBS + 1 YOBS(KOBS) = XDATA(J) IF(KOBS.EQ.NTOGET) GO TO 3000 2160 CONTINUE GO TO 2100 ELSE 2200 READ(IOFI,END=2300) XDATA DO 2262 J = 1, 10 KOBS = KOBS + 1 YOBS(KOBS) = XDATA(J) IF(KOBS.EQ.NTOGET) GO TO 3000 2262 CONTINUE GO TO 2200 ENDIF C * 2300 WRITE(ITTO,2310) KOBS 2310 FORMAT(/,' -EOF was prematurely hit. Points read = ',I4) C * C * ASSOCIATE ANGLES WITH INTENSITIES C * 3000 BANG = BANG - FAINC DO 3010 I=1,KOBS 3010 YANG(I) = BANG + REAL(I) * FAINC BANG = YANG( 1) EANG = YANG(KOBS) C * 9000 RETURN END C *** PROGRAM: SHADOW (SHADOW32) C *** VERSION: 880228 (YYMMDD) C * C *** BSOLVE - LEAST-SQUARES OPTIMIZATION ALGORITHM C * SUBROUTINE BSOLVE( IMODE ) C * LOGICAL LMARQ,LTOCOM DOUBLE PRECISION PHI,PH,PRESID,OBSTOT,DG,DN,GN,COSG,GAMM,DPSUM PARAMETER ( MEMV = 32, MPTS = 2048 ) PARAMETER ( MEMSCR = 12000 ) PARAMETER ( MEMVP1 = MEMV+1, MEMVT2 = MEMV*2 ) COMMON /REFFLG/ KPROF,KLRNZ,KERRT,KASYM,KBKGR,KBKGD,KAMOR,KCRYS COMMON /LUNS/ ITTI,ITTO,IOFI,IOFO,IOBO,IOPL,IOPO,IOLO,IOSC,IOWG COMMON /SDATA/ KOBS,YANG(MPTS),YOBS(MPTS),YSYN(MPTS),YBKG(MPTS) COMMON /PEAKP/ KNLIN,KNPRM,PLPRM(200,10),KRLIN(200),KLLIN(201) COMMON /DERDAT/ DERIVS(MPTS),ZCALC(MPTS),NCLINE,NCSTRT,NCFINI COMMON /VECTOR/ NVECS,BVECS(MEMVT2),BMINS(MEMV),BMAXS(MEMV) COMMON /SCRTCH/ SCRDAT(MEMSCR),IPOINT(MEMV,4) COMMON /OPTRES/ RERR,RESID,ICON,ITER COMMON /MODEOP/ KMODEO,KSAMEP,KAUTOP COMMON /MATRIX/ AMAT(MEMV,MEMVP1) COMMON /DIAGS/ ISENSE(10) COMMON WGTS(MPTS), ZDIFF(MPTS) DIMENSION AKP2(MEMV),ACKP2(MEMV),PRMS(MEMVT2) C * C ** SETUP FOR REFINEMENT C * C * SET MAX ITERATION LIMIT ITERLM = 999 IF( ITER.GT.0 .AND. ITER.LT.1000 ) ITERLM = ITER ITER = 0 ITER1 = 0 C * C * MAKE SURE WE DONT TRY TO EXCEED THE NUMBER OF VARIABLES POSSIBLE 100 WRITE(ITTO,110) NVECS,ITERLM 110 FORMAT(/, 1 ' Variables for refinement: ',I3,' Iteration limit: ',I3,/) IF(NVECS.GT.MEMV) THEN WRITE(ITTO,120) MEMV 120 FORMAT(/, 1 ' --Number of variables exceeds program limit of ',I3, 1 ', Refinement skipped.') ICON = -4 GO TO 9000 ENDIF C * C ** MODE OF OPERATION. REGULAR GAUSS-NEWTON OR MARQUARDT LMARQ = IMODE.EQ.0 C * C * INITIALIZE VARIABLES N = KOBS K = NVECS KP1 = K + 1 FNU = 2.0 FL = 1.00 RRLX = 0.5 RLX = 1.0 TAU = 0.001 EPS = 0.001 PH = 1.0D20 ICON = 999 C * C * CAN PARAMETERS BE TRANSFERRED TO THE SCRATCH ARRAY? LTOCOM = ( K * KP1 ) .LE. MEMSCR C * C * DETERMINE DENOMINATOR FOR THE ERROR AND WEIGHTS IF NECESSARY 1000 OBSTOT = 0.0 IF(KERRT.EQ.0) THEN DO 1005 I=1,N 1005 OBSTOT = OBSTOT + YOBS(I)**2 ELSE DO 1010 I=1,N WGTS(I) = 1.0 / AMAX1( 1.0, YOBS(I) ) OBSTOT = OBSTOT + WGTS(I)*YOBS(I)**2 1010 CONTINUE ENDIF C * C * COPY ORIGINAL PARAMETERS 1015 DO 1020 J1=1,K PRMS(J1) = BVECS(J1) J1PK = J1 + K COLD PRMS(J1PK) = ABS( BVECS(J1) ) + 1.0E-2 PRMS(J1PK) = AMAX1( BVECS(J1), 1.0E-10 ) BVECS(J1PK) = 0.0 1020 CONTINUE C * C * MAKE SURE CURRENT BACKGROUND IS CORRECT. BACKGROUND FOR KBKGR C * EQUAL TO 1 OR 3 GENERATED AT SECTION LABELED 1700. IF( KBKGR.NE.1 .AND. KBKGR.NE.3 ) CALL BKGLVL( YBKG ) C * C * GENERATE CALCULATED PATTERN AND EVALUATE BEGINNING ERROR GO TO 1700 C * C ** DETERMINE DERIVATIVES C * C * IF ONLY ONE LINE BEING REFINED, OR JUST THE AMORPHOUS PROFILE, C * COPY THE LINE TO ZCALC AND SET NCLINE 1100 IF( KNLIN.GT.1 .OR. ( KNLIN.EQ.1 .AND. KAMOR.NE.0 ) ) THEN NCLINE = 0 ELSE DO 1102 I=1,KOBS 1102 ZCALC(I) = YSYN(I) NCLINE = 1 IF(KNLIN.EQ.0) NCLINE = -1 NCFINI = KLLIN(1)/16384 NCSTRT = KLLIN(1) - NCFINI*16384 ENDIF C * C * CALCULATE (WEIGHTED) DIFFERENCE IN ZDIFF IF(KERRT.EQ.0) THEN DO 1104 I=1,KOBS 1104 ZDIFF(I) = YOBS(I) - YSYN(I) - YBKG(I) ELSE DO 1106 I=1,KOBS 1106 ZDIFF(I) = WGTS(I) * ( YOBS(I) - YSYN(I) - YBKG(I) ) ENDIF C * C * INIT THE SCRATCH MEMORY CALL SCRMEM( FUNK1, JUNK2, JUNK3, JUNK4, 0 ) C * C * REPEAT FOR EACH PARAMETER DO 1110 J1=1,K C * C * DETERMINE INCREMENTAL PARAMETER SHIFTS DO 1120 J2=1,K 1120 PRMS(J2) = BVECS(J2) DEN = 0.00001 * AMAX1( ABS(PRMS(J1)), PRMS(J1+K) ) IF( (PRMS(J1)+DEN) .LE. BMAXS(J1) ) THEN PRMS(J1) = PRMS(J1) + DEN ELSE PRMS(J1) = PRMS(J1) - DEN DEN = -DEN ENDIF C * C * DETERMINE DERIVATIVES WITH PARAMETER SHIFT CALL GENDER( PRMS, J1, DEN, ISTART, IFINIS ) C * C * WRITE THE DERIVATIVES TO THE SCRATCH MEMORY CALL SCRMEM( DERIVS, ISTART, IFINIS, J1, 1 ) C * C * CALCULATE LAST MATRIX COLUMN DPSUM = 0.0D00 DO 1225 J2=ISTART,IFINIS 1225 DPSUM = DPSUM + DPROD( DERIVS(J2), ZDIFF(J2) ) AMAT(J1,KP1) = SNGL( DPSUM ) C * C * NEXT PARAMETER 1110 CONTINUE C * C ** SET UP CORRECTION EQUATIONS C * C * REPEAT FOR ALL PARAMETERS 1200 DO 1210 J1=1,K C * C * RETRIEVE THE DERIVATIVES FROM SCRATCH MEMORY CALL SCRMEM( YSYN, ISTAR0, IFINI0, J1, -1 ) C * C * DETERMINE THE DIAGONAL COMPONENT DPSUM = 0.0D00 IF(KERRT.EQ.0) THEN DO 1238 J3=ISTAR0,IFINI0 1238 DPSUM = DPSUM + DPROD( YSYN(J3), YSYN(J3) ) ELSE DO 1235 J3=ISTAR0,IFINI0 1235 DPSUM = DPSUM + DBLE(WGTS(J3)) * DPROD( YSYN(J3), YSYN(J3) ) ENDIF AMAT(J1,J1) = SNGL( DPSUM ) IF(J1.EQ.K) GO TO 1210 C * C * IF ERROR IS WEIGHTED THEN WEIGHT YSYN NOW IF(KERRT.NE.0) THEN DO 1236 I=ISTAR0,IFINI0 1236 YSYN(I) = DPROD( YSYN(I), WGTS(I) ) ENDIF C * C * DETERMINE OFF-DIAGONAL ELEMENTS DO 1230 J2=J1+1,K AMAT(J1,J2) = 0.0 AMAT(J2,J1) = 0.0 CALL SCRMEM( ZCALC, ISTAR1, IFINI1, J2, -1 ) C * DETERMINE OVERLAP REGION OF DERIVATIVE SETS I0 = IFINI0 - ISTAR1 I1 = IFINI1 - ISTAR0 IF( I0.LT.1 .OR. I1.LT.1 ) GO TO 1230 ISTAR2 = MAX0( ISTAR0, ISTAR1 ) IFINI2 = MIN0( IFINI0, IFINI1 ) C * FIND NUMERICAL VALUES DPSUM = 0.0D00 DO 1253 J3=ISTAR2,IFINI2 1253 DPSUM = DPSUM + DPROD( YSYN(J3), ZCALC(J3) ) AMAT(J1,J2) = SNGL( DPSUM ) AMAT(J2,J1) = SNGL( DPSUM ) 1230 CONTINUE C * C * NEXT SET OF ELEMENTS 1210 CONTINUE C * C ** CORRECT FOR NEAR ZERO DIAGONAL ELEMENT DO 1260 J1=1,K IF(AMAT(J1,J1).GT.1.0E-20) GO TO 1260 IF(ITER1.EQ.0) WRITE(ITTO,1265) J1,ITER 1265 FORMAT(' Parameter: ',I3,' Eliminated on cycle ',I4) DO 1270 J3=1,KP1 1270 AMAT(J1,J3) = 0.0 AMAT(J1,J1) = 1.0 1260 CONTINUE C * C * EXIT HERE IF JUST SETTING UP NORMAL EQUATION MATRIX IF(ITER1.EQ.1) GO TO 2260 C * C * CALCULATE VECTOR COMPONENT GN = 0.0 IF(LMARQ) THEN DO 1255 J1=1,K 1255 GN = GN + AMAT(J1,KP1)**2 ENDIF C * C ** SCALE CORRECTION EQUATIONS C * 1300 DO 1310 J1=1,K 1310 AKP2(J1) = SQRT( AMAT(J1,J1) ) DO 1314 J1=1,K AMAT(J1,KP1) = AMAT(J1,KP1) / AKP2(J1) DO 1316 J2=1,K AMAT(J1,J2) = AMAT(J1,J2) / ( AKP2(J1)*AKP2(J2) ) 1316 CONTINUE 1314 CONTINUE C * C * VERIFY MATRIX IF(ISENSE(4).GT.0) THEN WRITE(ITTO,1317) (J1,J1=1,K) 1317 FORMAT(/,6X,30(1X,I3)) DO 1320 J1=1,K 1320 WRITE(ITTO,4) J1,(NINT(AMAT(J1,LL)*100.0),LL=1,K) 4 FORMAT(1X,I3,2X,30(1X,I3)) ENDIF C * C ** DETERMINE LAMBDA AND ADD TO DIAGONAL ELEMENTS C * C * WRITE THE A MATRIX TO THE SCRATCH FILE FOR POSSIBLE LATER USE 1400 IF(LMARQ) THEN C * IF(LTOCOM) THEN NTEMP = 0 DO 1402 J1=1,K DO 1402 J2=1,KP1 NTEMP = NTEMP + 1 SCRDAT(NTEMP) = AMAT(J1,J2) 1402 CONTINUE ELSE REWIND (UNIT=IOSC) WRITE(IOSC) ((AMAT(J1,J2),J1=1,K),J2=1,KP1) ENDIF C * C * DECREASE THE SIZE OF FL FL = FL / FNU C * C * ADD TO DIAGONAL 1415 DO 1425 J1=1,K 1425 AMAT(J1,J1) = AMAT(J1,J1) + FL C * ENDIF C * C ** SOLVE CORRECTION EQUATIONS C * 1500 DO 1510 L1=1,K L1P1 = L1 + 1 DO 1515 L2=L1P1,KP1 IF(AMAT(L1,L1).EQ.0.0) THEN WRITE(ITTO,1502) 1502 FORMAT(' -BSOLVE: Avoiding zero division in matrix solution.') GO TO 1516 ENDIF AMAT(L1,L2) = AMAT(L1,L2) / AMAT(L1,L1) 1515 CONTINUE 1516 DO 1520 L3=1,K IF( L1-L3 ) 1530,1520,1530 1530 DO 1525 L4=L1P1,KP1 1525 AMAT(L3,L4) = AMAT(L3,L4) - AMAT(L1,L4) * AMAT(L3,L1) 1520 CONTINUE 1510 CONTINUE C * C ** SOLVE FOR NEXT SOLUTION VECTOR AND APPLY CONSTRAINTS C * C * SOLVE FOR NEXT SET OF PARAMETERS 1600 DN = 0.0 DG = 0.0 DO 1610 J1=1,K ACKP2(J1) = AMAT(J1,KP1) / AKP2(J1) IF(ISENSE(4).EQ.2) WRITE(ITTO,6) J1,ACKP2(J1) 6 FORMAT(' PARAMETER ',I3,' ADJUSTMENT ',E13.6) BPADJ = BVECS(J1) + ACKP2(J1) IF(BPADJ.GT.BMAXS(J1)) WRITE(ITTO,10) J1,BPADJ,BMAXS(J1) 10 FORMAT(' Parameter ',I3,': Calculated Value ',E13.6, 1 ' Max limit ',E13.6) BPADJ = AMIN1( BMAXS(J1), BPADJ ) IF(BPADJ.LT.BMINS(J1)) WRITE(ITTO,11) J1,BPADJ,BMINS(J1) 11 FORMAT(' Parameter ',I3,': Calculated Value ',E13.6, 1 ' Min limit ',E13.6) PRMS(J1) = AMAX1( BMINS(J1), BPADJ ) IF(LMARQ) THEN DG = DG + ACKP2(J1) * AMAT(J1,KP1) * AKP2(J1) DN = DN + ACKP2(J1) * ACKP2(J1) ENDIF 1610 CONTINUE C * C * FACTORS FOR THE MARQUARDT ANALYSIS IF(LMARQ) THEN COSG = DG / DSQRT( DN*GN ) IF(ISENSE(4).EQ.2) WRITE(ITTO,7) COSG 7 FORMAT(' COSG = ',E13.6) JGAM = 0 IF( COSG ) 1615,1620,1620 1615 JGAM = 2 COSG = -COSG 1620 IF(COSG.GT.1.0) COSG = 1.00 GAMM = DATAN( DSQRT(1.00-COSG*COSG)/COSG ) GAMM = GAMM * 180.00 / 3.1415926531615 IF(JGAM.GT.0) GAMM = 180.0 - GAMM IF(ISENSE(4).EQ.2) WRITE(ITTO,5)GAMM 5 FORMAT(' GAMM = ',E13.6) ENDIF C * C ** EVALUATE FUNCTION AND FIND NEW ERROR C * C * GENERATE PROFILES WITH NEW SET OF PARAMETERS 1700 CALL PMSORT( PRMS ) CALL SHADOW( YSYN, 999, ILO, IHI ) IF( KBKGR.EQ.1 .OR. KBKGR.EQ.3 ) CALL BKGLVL( YBKG ) C * C * DETERMINE THE SUM-OF-SQUARES ERROR PRESID = 0.0 IF(KERRT.EQ.0) THEN DO 1710 J1=1,N 1710 PRESID = PRESID + ( YOBS(J1) - YSYN(J1) - YBKG(J1) )**2 ELSE DO 1760 J1=1,N 1760 PRESID = PRESID + WGTS(J1)*( YOBS(J1) - YSYN(J1) - YBKG(J1) )**2 ENDIF PHI = DSQRT( PRESID / OBSTOT ) IF(PHI.LT.PH) THEN IF(LMARQ) THEN WRITE(ITTO,2) ITER,PHI*100.0,FL 2 FORMAT(' Iteration = ',I3,' Error =',F7.2,' Weight = ',F11.6) ELSE WRITE(ITTO,3) ITER,PHI*100.0,RLX 3 FORMAT(' Iteration = ',I3,' Error =',F7.2,' Relax = ',F8.6) ENDIF ENDIF IF(PHI.LT.1.0E-10) GO TO 2200 IF(ITER.EQ.0) GO TO 2120 IF(PHI.GE.PH) GO TO 2000 IF(.NOT.LMARQ) RLX = 1.0 C * C ** TEST FOR CONVERGENCE C * C * EPSILON TEST FOR CONVERGENCE BASED ON DEVIATION OF PARAMETERS 1800 ICON = 0 DO 1810 J1=1,K DELTA = ABS( PRMS(J1) - BVECS(J1) ) IF( DELTA/(TAU+ABS(PRMS(J1))) .GT. EPS ) ICON = ICON + 1 1810 CONTINUE IF(ISENSE(4).EQ.2) WRITE(ITTO,8) ICON 8 FORMAT(' ICON = ',I3) C * C * TESTS FOR MARQUARDT PARAMETERS C * IF(.NOT.LMARQ) GO TO 2100 IF(ICON.NE.0) GO TO 1900 C * C * GAMMA EPSILON TEST (IS LAMBDA LARGE?) IF( FL.GT.1.0 .AND. GAMM.LE.45.0 ) THEN ICON = -3 WRITE(ITTO,1820) ICON,GAMM,FL 1820 FORMAT(' *BSOLVE* GAMM,FL = ',I2,2X,F10.4,1X,E12.6) ENDIF GO TO 2100 C * C * GAMMA LAMBDA TEST (HAVE THE TWO SOLUTIONS VECTORS DIVERGED?) 1900 IF( FL.GT.1.0 .AND. GAMM.GT.90.0 ) THEN ICON = -2 WRITE(ITTO,1825) ICON,GAMM,FL 1825 FORMAT(' *BSOLVE ABORT* GAMM,FL = ',I2,2X,F10.4,1X,E12.6) ENDIF GO TO 2100 C * C ** ERROR INCREASED... TAKE APPROPRIATE ACTION C * 2000 IF(LMARQ) THEN C * C * INCREASE FL IF THE LIMIT HAS NOT BEEN HIT IF(FL.GT.1000.0) THEN ICON = -1 WRITE(ITTO,2010) 2010 FORMAT(' -Maximum limit for diagonal weight hit: Halting', 1 ' refinement') PHI = PH GO TO 2200 ELSE FL = FL * FNU IF(LTOCOM) THEN NTEMP = 0 DO 2020 J1=1,K DO 2020 J2=1,KP1 NTEMP = NTEMP + 1 AMAT(J1,J2) = SCRDAT(NTEMP) 2020 CONTINUE ELSE REWIND (UNIT=IOSC) READ(IOSC) ((AMAT(J1,J2),J1=1,K),J2=1,KP1) ENDIF GO TO 1415 ENDIF C * ELSE C * C * DECREASE RELAXATION FACTOR RLX IF THE LIMIT HAS NOT BEEN HIT IF(RLX.LT.0.001) THEN WRITE(ITTO,2030) 2030 FORMAT(' -Minimum limit for the relaxation factor hit:', 1 ' Refinement halted') ICON = -1 PHI = PH GO TO 2200 ELSE RLX = RLX * RRLX DO 2040 J1=1,K BPADJ = BVECS(J1) + ( ACKP2(J1) * RLX ) BPADJ = AMIN1( BMAXS(J1), BPADJ ) PRMS(J1) = AMAX1( BMINS(J1), BPADJ ) 2040 CONTINUE GO TO 1700 ENDIF C * ENDIF C * C ** UPDATE THE VALUES FOR PARAMETERS AND BEST ERROR PH C * 2100 DO 2110 J2=1,K 2110 BVECS(J2) = PRMS(J2) 2120 PH = PHI RESID = SNGL( PRESID ) C * C * BEGIN TERMINATION PROCEDURE IF WE HAVE CONVERGED OR ERRORED IF(ICON.LT.1) GO TO 2200 C * C * GO FOR NEXT ITERATION IF THE LIMIT HAS NOT BEEN HIT ITER = ITER + 1 IF(ITER.LE.ITERLM) GO TO 1100 WRITE(ITTO,2130) 2130 FORMAT(' -Iteration limit hit: Halting refinement') ITER = ITER - 1 ICON = -5 C * C ** RETURN WITH RESULTS C * 2200 RERR = SNGL( PHI ) C * C * BACK FOR ONE MORE PASS TO SET UP FOR ERROR ANALYSIS ITER1 = 1 GO TO 1100 2260 CALL CHOL( AMAT, MEMV, MEMVP1, K, BVECS ) C * 9000 RETURN END C *** SCRMEM - HANDLE SCRATCH MEMORY REQUIREMENTS FOR REF. ALGORITHMS C * SUBROUTINE SCRMEM( DATAIN, IBEG, IEND, ISET, ICODE ) C * C * ICODE: 0 -> INITIALIZE C * +1 -> STORE C * -1 -> RETRIEVE C * C * SET PARAMETER MEMSCR TO WHATEVER ROOM IS AVAILABLE/NECESSARY. C * SETTING MEMSCR TO 1 HAS ALL DERIVATIVES WRITTEN TO SCRATCH FILE. C * VIRTUAL MACHINES.... THIS ONE'S FOR YOU! C * PARAMETER ( MEMV = 32, MPTS = 2048 ) PARAMETER ( MEMSCR = 12000 ) COMMON /LUNS/ ITTI,ITTO,IOFI,IOFO,IOBO,IOPL,IOPO,IOLO,IOSC,IOWG COMMON /SCRTCH/ SCRDAT(MEMSCR),IPOINT(MEMV,4) DIMENSION DATAIN(MPTS) C * C ** RESET POINTERS ( ICODE = 0 ) C * 1000 IF(ICODE.NE.0) GO TO 2000 DO 1010 I=1,MEMV IPOINT(I,1) = 0 IPOINT(I,2) = 0 IPOINT(I,3) = 0 IPOINT(I,4) = 0 1010 CONTINUE IMLAST = 0 REWIND (UNIT=IOSC) IFLAST = 0 IFCURR = 0 GO TO 9000 C * C ** MOVE DATA FROM *DATAIN* TO *SCRDAT* OR *DISK* IF *SCRDAT* IS FULL C * 2000 IF(ICODE.NE.1) GO TO 3000 C * C * CHECK THAT INDICATED DATA SET IS EMPTY IF( IPOINT(ISET,1).EQ.0 .AND. IPOINT(ISET,2).EQ.0 ) GO TO 2100 WRITE(ITTO,2010) ISET 2010 FORMAT(' --WRITE REQUESTED TO SET ',I3,' BUT DATA SET EXISTS') STOP C * C * DETERMINE IF THIS DATA SET CAN BE STORED IN *SCRDAT* 2100 NSTORE = IEND - IBEG + 1 IF(IMLAST+NSTORE.LE.MEMSCR) GO TO 2900 C * C * THE CURRENT FILE-SET MUST BE THE SAME AS THE LAST-FILE SET. C * WRITES TO FILE MUST BE SEQUENTIAL IF(IFLAST.EQ.IFCURR) GO TO 2200 WRITE(ITTO,2030) ISET,IFLAST,IFCURR 2030 FORMAT(' -INVALID REQUEST TO WRITE SET ',I3,' IFLAST ',I3, 1 ' IFCURR ',I3) STOP C * C * STORE THE DATA ON *DISK* 2200 IFLAST = IFLAST + 1 IFCURR = IFLAST IPOINT(ISET,1) = -IFCURR IPOINT(ISET,2) = -IFCURR IPOINT(ISET,3) = IBEG IPOINT(ISET,4) = IEND WRITE(IOSC) IBEG,IEND,(DATAIN(I),I=IBEG,IEND) WRITE(ITTO,9876) ISET 9876 FORMAT(' Set ',I4,' written to disk') GO TO 9000 C * C * STORE THE REQUESTED DATA IN *SCRDAT* 2900 IPOINT(ISET,1) = IMLAST + 1 DO 2910 I=IBEG,IEND IMLAST = IMLAST + 1 SCRDAT(IMLAST) = DATAIN(I) 2910 CONTINUE IPOINT(ISET,2) = IMLAST IPOINT(ISET,3) = IBEG IPOINT(ISET,4) = IEND GO TO 9000 C * C ** RETRIEVE DATA FROM *SCRDAT* OR *DISK* C * 3000 IF(ICODE.NE.-1) GO TO 8000 C * C * DETERMINE IF DATA SET EXISTS IF( IPOINT(ISET,1).NE.0 .AND. IPOINT(ISET,2).NE.0 ) GO TO 3100 WRITE(ITTO,3010) ISET 3010 FORMAT(' --REQUEST FOR DATA SET ',I3,' INVALID: NO SUCH SET') STOP C * C * DETERMINE IF DATA SET IS IN *SCRDAT* OR ON *DISK* 3100 IF( IPOINT(ISET,1).GT.0 .AND. IPOINT(ISET,2).GT.0 ) GO TO 3900 C * C * DETERMINE WHICH SET ON *DISK* IS TO BE RETRIEVED NDISK = -IPOINT(ISET,1) C * C * IF THE CURRENT-SET IS ONE LESS THAN NDISK THEN NEXT READ IS CORRECT IF(IFCURR.EQ.NDISK-1) GO TO 3200 C * C * IF IFCURR IS > OR = TO NDISK THEN WE MUST REWIND IF(IFCURR.GE.NDISK) REWIND (UNIT=IOSC) IFCURR = 0 C * C * DETERMINE NUMBER OF SETS TO BYPASS FOR CORRECT SET NSKIP = NDISK - IFCURR - 1 IF(NSKIP.GT.0) THEN DO 3120 I=1,NSKIP READ(IOSC) AJUNK IFCURR = IFCURR + 1 3120 CONTINUE ENDIF C * C * READ THE DATA SET 3200 READ(IOSC) IBEG,IEND,(DATAIN(I),I=IBEG,IEND) IFCURR = IFCURR + 1 GO TO 9000 C * C * RETRIEVE THE DATA FROM *SCRDAT* 3900 IBEG = IPOINT(ISET,3) IEND = IPOINT(ISET,4) NPNT = IPOINT(ISET,1) DO 3910 I=IBEG,IEND DATAIN(I) = SCRDAT(NPNT) NPNT = NPNT + 1 3910 CONTINUE GO TO 9000 C * C ** UNKNOWN REQUEST CODE C * 8000 WRITE(ITTO,8010) ICODE 8010 FORMAT(' --UNKNOWN REQUEST CODE:',I6) C * C * RETURN RETURN RETURN 9000 RETURN END C *** GENDER - GENERATE DERIVATIVES FOR THE OPTIMIZATION ALGORITHMS C * SUBROUTINE GENDER( PAIN, IPRM, DELTA, IDSTR, IDEND ) C * LOGICAL LSKIP PARAMETER ( MEMV = 32, MPTS = 2048 ) PARAMETER ( MEMVP1 = MEMV+1, MEMVT2 = MEMV*2 ) PARAMETER ( DTORD2=8.72664626E-03, RTODT2=114.591559) PARAMETER ( DTOR =1.745329252E-02, RTOD = 57.29577951 ) COMMON /REFFLG/ KPROF,KLRNZ,KERRT,KASYM,KBKGR,KBKGD,KAMOR,KCRYS COMMON /LUNS/ ITTI,ITTO,IOFI,IOFO,IOBO,IOPL,IOPO,IOLO,IOSC,IOWG COMMON /SDATA/ KOBS,YANG(MPTS),YOBS(MPTS),YSYN(MPTS),YBKG(MPTS) COMMON /PEAKP/ KNLIN,KNPRM,PLPRM(200,10),KRLIN(200),KLLIN(201) COMMON /DERDAT/ DERIVS(MPTS),ZCALC(MPTS),NCLINE,NCSTRT,NCFINI COMMON /VECTOR/ NVECS,BVECS(MEMVT2),BMINS(MEMV),BMAXS(MEMV) COMMON /REFPAR/ AMOPAR(3),BKGPAR,ASYPAR,CRYPAR(2) COMMON /WDATA/ NWAVE,WTABLE(5,2) COMMON /DIAGS/ ISENSE(10) DIMENSION PAIN(MEMVT2) C * C ** DETERMINE WHICH PARAMETER IS BEING VARIED C * C * DERIVATIVES REQUIRED FOR A LINE PARAMETER? 1000 IF(KNLIN.GT.0) THEN IF(KPROF.GT.0) THEN NEXT = KNLIN * KNPRM ELSE NEXT = KNPRM + ( KNLIN - 1 ) * 2 ENDIF IF(IPRM.LE.NEXT) GO TO 2000 ELSE NEXT = 0 ENDIF C * C * BACKGROUND? 1100 IF( KBKGR.EQ.1 .OR. KBKGR.EQ.3 ) THEN NEXT = NEXT + 1 IF(NEXT.EQ.IPRM) GO TO 5000 ENDIF C * C * ASYMMETRY? IF(KASYM.NE.0) THEN NEXT = NEXT + 1 IF(NEXT.EQ.IPRM) GO TO 3000 ENDIF C * C * AMORPHOUS PROFILE PARAMETERS? IF(KAMOR.NE.0) THEN NEXT = NEXT + 3 IF(IPRM.LE.NEXT) GO TO 4000 ENDIF C * C * PARTICLE SIZE PARAMETER? IF( KCRYS.EQ.1 .OR. KCRYS.EQ.3 ) THEN NEXT = NEXT + 1 NSS = 1 IF(NEXT.EQ.IPRM) GO TO 3000 NSS = 0 ENDIF C * C * PARTICLE STRAIN PARAMETER? IF( KCRYS.EQ.2 .OR. KCRYS.EQ.3 ) THEN NEXT = NEXT + 1 NSS = 2 IF(NEXT.EQ.IPRM) GO TO 3000 NSS = 0 ENDIF C * C * NO OTHER PARAMETERS: SOMETHING WRONG IDSTR = 1 IDEND = 1 DERIVS(1) = 0.0 WRITE(ITTO,1010) IPRM 1010 FORMAT(/,' GENDER: INCORRECT PARAMETER SPECIFIED = ',I6) GO TO 9000 C * C ** GENERATE THE NECESSARY PART OF THE PATTERN C * C * GENERATE THE LINE PARAMETERS C * (NOTE: WHEN REFINING, CALC PTN W/ LST ST PRMS IS IN ZCALC) C * C * DETERINE WHICH LINE WE ARE WORKING WITH 2000 IF(KPROF.GT.0) THEN ILINE = (IPRM-1) / KNPRM + 1 ELSE IF(IPRM.GT.KNPRM) THEN ILINE = (IPRM-KNPRM-1) / 2 + 2 ELSE ILINE = 1 ENDIF ENDIF C * C * IF THE LINE GENERATED BY THE LAST SET OF PARAMETERS IS NOT IN ZCALC C * THEN GENERATE IT 2010 IF(ILINE.EQ.NCLINE) THEN NBS = NCSTRT NBE = NCFINI ELSE CALL PMSORT( BVECS ) CALL SHADOW( ZCALC, ILINE, NBS, NBE ) NCLINE = ILINE NCSTRT = NBS NCFINI = NBE ENDIF C * C * GENERATE THE LINE WITH THE NEW SET OF PARAMETERS AND RANGE FOR C * DERIVATIVES CALL PMSORT( PAIN ) CALL SHADOW( YSYN, ILINE, NAS, NAE ) IDSTR = MIN( NBS, NAS ) IDEND = MAX( NBE, NAE ) GO TO 8000 C * C * GENERATE FULL PATTERN FOR ASYMMETRY OR CRYSTALLITE PARAMETERS C * 3000 IF(NCLINE.NE.999) THEN CALL PMSORT( BVECS ) CALL SHADOW( ZCALC, 999, ILO, IHI ) NCLINE = 999 ENDIF SIZE = 0.0 STRAIN = 0.0 IF( NSS.EQ.1 ) THEN SIZE = BVECS(NEXT) IF( KCRYS.EQ.3 ) STRAIN = BVECS(NEXT+1) ENDIF IF( NSS.EQ.2 ) THEN STRAIN = BVECS(NEXT) IF( KCRYS.EQ.3 ) SIZE = BVECS(NEXT-1) ENDIF CDBG WRITE(99,'('' SIZE,STRAIN = '',2G13.6)') SIZE,STRAIN CDBG WRITE(99,'('' NEXT,NSS,DELTA = '',2I5,G13.6)') NEXT,NSS,DELTA THTRMD = ( (YANG(1)+YANG(KOBS))/2.0 ) * DTORD2 BBMD = RTOD * 4.0 * STRAIN * TAN(THTRMD) IF(SIZE.GT.0.0) BBMD = BBMD + 1 RTOD * WTABLE(1,1) / ( COS(THTRMD) * SIZE ) DBB = BBMD * 0.00010 IF(NSS.EQ.1) THEN DELTA = -(COS(THTRMD)*SIZE**2) / (RTOD*WTABLE(1,1)) * DBB CDBG WRITE(99,'('' SIZE: B,DB,S,DS='',4G13.6)') BBMD,DBB,SIZE,DELTA ENDIF IF(NSS.EQ.2) THEN DELTA = DBB / ( RTOD * 4.0 * TAN(THTRMD) ) CDBG WRITE(99,'('' STRA: B,DB,S,DS='',4G13.6)')BBMD,DBB,STRAIN,DELTA ENDIF CDBG WRITE(99,'('' P,B,DELTA = '',3G14.7)')PAIN(NEXT),BVECS(NEXT),DELTA PAIN(NEXT) = BVECS(NEXT) + DELTA CALL PMSORT( PAIN ) CALL SHADOW( YSYN, 999, ILO, IHI ) IDSTR = 1 IDEND = KOBS GO TO 8000 C * C * GENERATE AMORPHOUS PROFILE C * C * IF THE AMORPHOUS PROFILE IS NOT IN ZCALC THEN GENERATE IT 4000 IF(NCLINE.EQ.-1) THEN NBS = NCSTRT NBE = NCFINI ELSE CALL PMSORT( BVECS ) CALL SHADOW( ZCALC, -1, NBS, NBE ) NCLINE = -1 NCSTRT = NBS NCFINI = NBE ENDIF C * C * GENERATE THE LINE WITH THE NEW SET OF PARAMETERS AND RANGE FOR C * DERIVATIVES CALL PMSORT( PAIN ) CALL SHADOW( YSYN, -1, NAS, NAE ) IDSTR = MIN( NBS, NAS ) IDEND = MAX( NBE, NAE ) GO TO 8000 C * C * GENERATE BACKGROUND PARAMETERS C * NOTE: BACKGROUND WITH BVECS IS IN YBKG. JUST USE PAIN NOW. C * C * GENERATE NEW BKG IN DERIVS 5000 CALL PMSORT( PAIN ) CALL BKGLVL( DERIVS ) C * C * DETERMINE OPTIMUM RANGE FOR DERIVATIVES IDSTR = 1 IDEND = KOBS DO 5030 I=IDSTR,IDEND 5030 IF(DERIVS(I).NE.YBKG(I)) GO TO 5040 IDSTR = 1 IDEND = 1 DERIVS(1) = 0.0 GO TO 9000 5040 IDSTR = I DO 5050 I=IDEND,IDSTR,-1 5050 IF(DERIVS(I).NE.YBKG(I)) GO TO 5060 IDSTR = 1 IDEND = 1 DERIVS(1) = 0.0 GO TO 9000 C * C * GENERATE DERIVATIVES 5060 IDEND = I DO 5070 I=IDSTR,IDEND 5070 DERIVS(I) = ( DERIVS(I) - YBKG(I) ) / DELTA GO TO 9000 C * C ** CALCULATE DERIVATIVES FOR ALL PARAMETERS EXCEPT BACKGROUND C * C * CAN WE SAVE SOME ROOM AND EFFORT? 8000 DO 8010 I=IDSTR,IDEND 8010 IF(ZCALC(I).NE.YSYN(I)) GO TO 8020 IDSTR = 1 IDEND = 1 DERIVS(1) = 0.0 GO TO 9000 8020 IDSTR = I DO 8030 I=IDEND,IDSTR,-1 8030 IF(ZCALC(I).NE.YSYN(I)) GO TO 8040 IDSTR = 1 IDEND = 1 DERIVS(1) = 0.0 GO TO 9000 8040 IDEND = I C * C * CALCULATE THE DERIVATIVES 8200 DO 8210 I=IDSTR,IDEND 8210 DERIVS(I) = ( YSYN(I) - ZCALC(I) ) / DELTA C * 9000 RETURN END C *** CHOL - DETERMINE THE INVERSE OF AN NXN POSITIVE-SYMMETRIC MATRIX C * IN PLACE USING THE CHOLESKY METHOD C * C * CODED BY S.A.HOWARD C * UNIVERSITY OF MISSOURI- ROLLA C * C * ARGUMENTS: S - (A)SYMMETRIC MATRIX S(NCOL,NROW) C * NROW - NUMBER OF ROWS IN MATRIX S C * NCOL - NUMBER OF COLUMNS IN MATRIX S C * NE - S OF S(NE,NE) IS TO BE INVERTED C * SUBROUTINE CHOL( S, NROW, NCOL, NE, PARAMS ) C * PARAMETER ( MEMV = 32, MPTS = 2048 ) PARAMETER ( MEMVP1 = MEMV+1, MEMVT2 = MEMV*2 ) DOUBLE PRECISION DPSUM COMMON /SDATA/ KOBS,YANG(MPTS),YOBS(MPTS),YSYN(MPTS),YBKG(MPTS) COMMON /LUNS/ ITTI,ITTO,IOFI,IOFO,IOBO,IOPL,IOPO,IOLO,IOSC,IOWG COMMON /OPTRES/ RERR,RESID,ICON,ITER DIMENSION S(NROW,NCOL),PARAMS(MEMVT2) C * C ** USE CHOLESKY'S METHOD OF DETERMINING THE FACTORED MATRIX S C * FROM THE SYMMETRIC, POSITIVE DEFINITE MATRIX S (IN PLACE) C * C WRITE(ITTO,120) 'START',( ( S(LR,LC),LC=1,NE),LR=1,NE) 1000 IF(S(1,1).LE.0.0) GO TO 1065 SD = SQRT( S(1,1) ) DO 1010 J=2,NE 1010 S(1,J) = S(1,J) / SD S(1,1) = SD C * C * REPEAT 2->NE DO 1020 I=2,NE C * C * DIAGONAL ELEMENTS DPSUM = 0.0D00 DO 1030 K=1,I-1 DPSUM = DPSUM + S(K,I)**2 1030 CONTINUE SUM = SNGL(DPSUM) IF(SUM.GE.S(I,I)) GO TO 1065 S(I,I) = SQRT( S(I,I) - SUM ) C * C * OFF DIAGONAL ELEMENTS DO 1050 J=I+1,NE DPSUM = 0.0D00 DO 1060 K=1,I-1 DPSUM = DPSUM + S(K,I)*S(K,J) 1060 CONTINUE S(I,J) = ( S(I,J) - SNGL(DPSUM) ) / S(I,I) 1050 CONTINUE C * 1020 CONTINUE GO TO 1075 C * C * ERROR... MATRIX CAN NOT BE FACTORED 1065 WRITE(ITTO,1067) 1067 FORMAT(/,' -CHOL:Matrix can not be factored. No ESDs calculated') GO TO 9000 C * C * MOVE TO LOWER DIAGONAL SYMMETRIC 1075 DO 1070 I=2,NE DO 1080 J=1,I-1 S(I,J) = S(J,I) S(J,I) = 0.0 1080 CONTINUE 1070 CONTINUE C WRITE(ITTO,120) 'FACTR',( ( S(LR,LC),LC=1,NE),LR=1,NE) C * C ** INVERTING THE SYMMETRIC S MATRIX IN PLACE C ** THIS IS AN OPTIMIZED GAUSS-JORDEN ELIMINATION C * C * DO FOR THE ENTIRE SERIES OF EQUATIONS 2000 S(1,1) = 1.0 / S(1,1) DO 2010 K=2,NE KM1 = K - 1 IF(S(K,K).LT.1.E-20) STOP'ERROR: PIVOT TOO SMALL' C * C * NORMALIZE BY THE DIAGONAL ELEMENT SD = 1.0 / S(K,K) DO 2020 I=1,KM1 S(K,I) = S(K,I) * SD 2020 CONTINUE S(K,K) = SD C * C * REDUCE DO 2030 I=1,KM1 DPSUM = 0.0D00 DO 2040 J=I,KM1 DPSUM = DPSUM + S(K,J) * S(J,I) 2040 CONTINUE S(K,I) = -DPSUM 2030 CONTINUE C * 2010 CONTINUE C WRITE(ITTO,120) 'INVER',( ( S(LR,LC),LC=1,NE),LR=1,NE) C120 FORMAT(' S ='A5,(/,X,F10.4)) C * C ** NOW MULTIPLY THE S MATRIX BY ITS TRANSPOSE TO OBTAIN THE DESIRED C ** INVERSION( S-ORIGINAL ) C * 3000 DO 3010 I=1,NE DO 3020 K=1,I DPSUM = 0.0D00 DO 3030 J=I,NE DPSUM = DPSUM + S(J,I) * S(J,K) 3030 CONTINUE S(I,K) = SNGL( DPSUM ) S(K,I) = S(I,K) 3020 CONTINUE 3010 CONTINUE C WRITE(ITTO,120) 'FINAL',( ( S(LR,LC),LC=1,NE),LR=1,NE) C * C ** RETURN THE UNCERTAINTY FOR THE COMPONENTS IN THE PARAMS VECTOR. C ** THIS IS BASED ON THE VARIANCES BY LEAST SQUARES STATISTICS. C * C * THE POPULATION VARIANCE 4000 VERR = RESID / REAL( KOBS - NE ) C * C * THE VARIANCE FOR EACH OF THE COMPONENTS DO 4010 I=1,NE NEPI = NE + I 4010 PARAMS(NEPI) = SQRT( S(I,I) * VERR ) C * 9000 RETURN END *** subroutine prmout goes here *** C *** PRMPLT - GENERATE REFINEMENT PLOT FILE OUTPUT C * SUBROUTINE PRMPLT C * PARAMETER ( MEMV = 32, MPTS = 2048 ) COMMON /LUNS/ ITTI,ITTO,IOFI,IOFO,IOBO,IOPL,IOPO,IOLO,IOSC,IOWG COMMON /SDATA/ KOBS,YANG(MPTS),YOBS(MPTS),YSYN(MPTS),YBKG(MPTS) COMMON /REFFLG/ KPROF,KLRNZ,KERRT,KASYM,KBKGR,KBKGD,KAMOR,KCRYS COMMON /PEAKP/ KNLIN,KNPRM,PLPRM(200,10),KRLIN(200),KLLIN(201) COMMON /BKGDAT/ LDEG,CLY,CLC(6),BKGSDV,IBKCPS,IBKNBK COMMON /FLDATN/ KFILET,FBANG,FEANG,FAINC,FTIME COMMON /PLTDAT/ KPPLOT,KPSETS(5),KPTYPE,KPTDEF COMMON /MODEOP/ KMODEO,KSAMEP,KAUTOP COMMON /WDATA/ NWAVE,WTABLE(5,2) C * C * CALCULATED PATTERN... IF(KPSETS(2).NE.0) THEN CALL SHADOW( YSYN, 999, IDUM1, IDUM2 ) DO 1002 I=1,KOBS 1002 YSYN(I) = YSYN(I) + YBKG(I) IF(KPTYPE.EQ.0) THEN WRITE(IOPL) KPSETS(2),KOBS,YANG(1) WRITE(IOPL) (YSYN(I)/FTIME,I=1,KOBS) ELSE WRITE(IOPL,1010) KPSETS(2),KOBS,YANG(1) 1010 FORMAT(I6,I6,F10.4) WRITE(IOPL,1020) (YSYN(I)/FTIME,I=1,KOBS) 1020 FORMAT(10F8.1) ENDIF ENDIF C * C * DIFFERENCE PATTERN... IF(KPSETS(3).NE.0) THEN IF(KPSETS(2).EQ.0) THEN CALL SHADOW( YSYN, 999, IDUM1, IDUM2 ) DO 1845 I=1,KOBS 1845 YSYN(I) = YSYN(I) + YBKG(I) ENDIF DO 1850 I=1,KOBS 1850 YSYN(I) = ( YOBS(I) - YSYN(I) ) / FTIME IF(KPTYPE.EQ.0) THEN WRITE(IOPL) KPSETS(3),KOBS,YANG(1) WRITE(IOPL) (YSYN(I),I=1,KOBS) ELSE WRITE(IOPL,1010) KPSETS(3),KOBS,YANG(1) WRITE(IOPL,1020) (YSYN(I),I=1,KOBS) ENDIF ENDIF C * C * INDIVIDUALIZE THE PROFILES HERE IF YOU WANT TO SEE ALPHA LINES C * DRAWN SEPARATELY C CALL PKSPLT C * C * GENERATE INDIVIDUAL PROFILES AND PLOT THEM C * IF(KPSETS(4).EQ.0) GO TO 99 C * JK = IABS( KPROF ) DO 1870 I=1,KNLIN CALL SHADOW( YSYN, I, ILO, IHI ) C * C * CALCULATED FWHM VALUES PPL = FNFWHM( PLPRM(I,1), 1) PPH = FNFWHM( PLPRM(I,1), 2) C * C * SELECT PROPER PROFILE FUNCTION GO TO(10,10,10,40,10,60,70,80,90,100,110,120,130,140,140,150),JK STOP 'PRMPLT: A GOTO ERROR OCCURRED, PLEASE CHECK' C * C * GAUSSIAN AND NORMAL, MODIFIED, AND INTERMEDIATE LORENZTIAN C * ACOEFF - FULL WIDTH AT HALF MAXIMUM 10 PPL = PLPRM(I,3) PPH = PPL GO TO 1880 C * C * PEARSON VII C * ACOEFF - FULL WIDTH AT HALF MAX 40 PPL = PLPRM(I,3) PPH = PPL GO TO 1880 C * C * VOIGT PROFILE 60 PPL = 0.5 PPH = PPL GO TO 1880 C * C * SPLIT PEARSON VII C * ACOEFF - FULL WIDTH AT HALF MAX 70 PPL = PLPRM(I,3) C * CCOEFF - FULL WIDTH AT HALF MAX PPH = PLPRM(I,5) GO TO 1880 C * C * SPLIT PEARSON VII WITH CALC FWHM+DELTA, CALC SF C * ACOEFF - DELTA FOR FULL WIDTH AT HALF MAXIMUM INTENSITY 80 PPL = PPL + PLPRM(I,3) PPH = PPH + PLPRM(I,3) GO TO 1880 C * C * SPLIT PEARSON VII WITH ALPHA 2 REFLECTION C * ACOEFF - FULL WIDTH AT HALF MAX, ALPHA1 FRONT 90 PPL = PLPRM(I,3) C * CCOEFF - FULL WIDTH AT HALF MAX, ALPHA 1 BACK PPH = PLPRM(I,5) C * ECOEFF - FULL WIDTH AT HALF MAX, ALPHA2 FRONT PPL = AMAX1( PLPRM(I,7), PPL ) C * GCOEFF - FULL WIDTH AT HALF MAX, ALPHA 2 BACK PPH = AMAX1( PLPRM(I,9), PPH ) GO TO 1880 C * C * CONSTRAINED PEARSON WITH REFLECTION C * ACOEFF - FULL WIDTH AT HALF MAX, ALPHA1 FRONT 100 PPL = PLPRM(I,3) C * CCOEFF - FULL WIDTH AT HALF MAX, ALPHA 1 BACK PPH = PLPRM(I,5) C * ECOEFF - FULL WIDTH AT HALF MAX, ALPHA2 FRONT PPL = AMAX1( PLPRM(I,7), PPL ) C * FCOEFF - FULL WIDTH AT HALF MAX, ALPHA 2 BACK PPH = AMAX1( PLPRM(I,8), PPH ) GO TO 1880 C * C * CONSTRAINED PEARSON WITH REFLECTION C * ACOEFF - FULL WIDTH AT HALF MAX, ALPHA1 AND ALPHA2 FRONT 110 PPL = PLPRM(I,3) C * CCOEFF - FULL WIDTH AT HALF MAX, ALPHA 1 AND ALPHA2 BACK PPH = PLPRM(I,5) GO TO 1880 C * C * CONSTRAINED PEARSON WITH REFLECTION, CALC FWHM, REFINED SF 120 GO TO 1880 C * C * PEARSON VII, FULLY CONSTRAINED 130 GO TO 1880 C * C * CONVOLUTION PRODUCT... LORENTZIAN OR GAUSSIAN WITH INSTRUMENT 140 PPL = 0.5 PPH = 0.5 GO TO 1880 C * C * CONVOLUTION PRODUCT... LORENTZIAN OR GAUSSIAN WITH INSTRUMENT 150 PPL = 0.5 PPH = 0.5 C * C * DETERMINE RANGE FOR PLOTTING BASED ON PROFILE HALF WIDTHS 1880 IPPL = 8 * NINT( PPL / FAINC ) IPPH = 8 * NINT( PPH / FAINC ) IPP = MAX( IPPL, IPPH ) C * A1 ICNTR = INT( (PLPRM(I,1)-YANG(1))/FAINC + 0.1 ) + 1 IILO = ICNTR - IPP IIHI = ICNTR + IPP IF(JK.LT.8) GO TO 1882 C * A2 IF(NWAVE.GT.1) THEN CALL CALCPH(PLPRM(I,1),PLPRM(I,2),2,T2,Y2) ICNTR = INT( (T2-YANG(1))/FAINC + 0.1 ) + 1 IILO = MIN( ICNTR-IPP, IILO ) IIHI = MAX( ICNTR+IPP, IIHI ) ENDIF C * A3 IF(NWAVE.GT.2) THEN CALL CALCPH(PLPRM(I,1),PLPRM(I,2),3,T2,Y2) ICNTR = INT( (T2-YANG(1))/FAINC + 0.1 ) + 1 IILO = MIN( ICNTR-IPP, IILO ) IIHI = MAX( ICNTR+IPP, IIHI ) ENDIF C * 1882 IILO = MAX( IILO, ILO ) IIHI = MIN( IIHI, IHI ) ND = IIHI - IILO + 1 C * IF(KPTYPE.EQ.0) THEN WRITE(IOPL) KPSETS(4),ND,YANG(IILO) WRITE(IOPL) (YSYN(J)/FTIME,J=IILO,IIHI) ELSE WRITE(IOPL,1010) KPSETS(4),ND,YANG(IILO) WRITE(IOPL,1020) (YSYN(J)/FTIME,J=IILO,IIHI) ENDIF 1870 CONTINUE C * GENERATE THE AMORPHOUS PROFILE IF(KAMOR.NE.0) THEN CALL SHADOW( YSYN, -1, ILO, IHI ) ND = IHI - ILO + 1 IF(KPTYPE.EQ.0) THEN WRITE(IOPL) KPSETS(4),ND,YANG(ILO) WRITE(IOPL) (YSYN(I)/FTIME,I=ILO,IHI) ELSE WRITE(IOPL,1010) KPSETS(4),ND,YANG(ILO) WRITE(IOPL,1020) (YSYN(I)/FTIME,I=ILO,IHI) ENDIF ENDIF C * C * PROFILES MUST BE INDIVIDUALIZED BY THIS POINT SO THE ALPHA-1 C * PATTERN CAN BE DRAW. IF DONE HERE ITS NOT NECESSARY TO DO IT C * USING THE ABOVE CALL TO PKSPLT. USE ONE OR THE OTHER. 99 CALL PKSPLT C * C * ALPHA 1 PATTERN IF(KPSETS(5).NE.0) THEN CALL PATSUB NSET = 5 IF(KPTYPE.EQ.0) THEN WRITE(IOPL) KPSETS(5),KOBS,YANG(1) WRITE(IOPL) (YSYN(I)/FTIME,I=1,KOBS) ELSE WRITE(IOPL,1010) KPSETS(5),KOBS,YANG(1) WRITE(IOPL,1020) (YSYN(I)/FTIME,I=1,KOBS) ENDIF ENDIF C * C * EXIT 9000 RETURN END C *** SINTGR - INTEGRATION BY SIMPSONS METHOD C * SUBROUTINE SINTGR( A ) C * PARAMETER ( MEMV = 32, MPTS = 2048 ) COMMON /SDATA/ KOBS,YANG(MPTS),YOBS(MPTS),YSYN(MPTS),YBKG(MPTS) COMMON /FLDATN/ KFILET,FBANG,FEANG,FAINC,FTIME C * C * INSURE THAT NPOINT IS ODD (OR AN EVEN NUMBER OF INTERVALS IS USED). AREA = 0.0 NTEMP = (KOBS/2)*2 + 1 IF(NTEMP.LT.5) GO TO 9000 C * C * AREA UNDER THE PROFILE SUM2 = 0.0 SUM4 = 0.0 DO 1010 J=2,NTEMP-1,2 1010 SUM4 = SUM4 + YSYN(J) DO 1020 J=3,NTEMP-2,2 1020 SUM2 = SUM2 + YSYN(J) A = (FAINC/3.0) * ( YSYN(1) + YSYN(NTEMP) + 4.0*SUM4 + 2.0*SUM2 ) C * C * INTEGRATED.... 9000 RETURN END C *** PKADD - ADDS ANOTHER LINE TO THE CURRENT PEAK LIST C * SUBROUTINE PKADD C * PARAMETER ( MEMV = 32, MPTS = 2048 ) PARAMETER ( MEMVP1 = MEMV+1, MEMVT2 = MEMV*2 ) COMMON /LUNS/ ITTI,ITTO,IOFI,IOFO,IOBO,IOPL,IOPO,IOLO,IOSC,IOWG COMMON /REFFLG/ KPROF,KLRNZ,KERRT,KASYM,KBKGR,KBKGD,KAMOR,KCRYS COMMON /PEAKP/ KNLIN,KNPRM,PLPRM(200,10),KRLIN(200),KLLIN(201) COMMON /VECTOR/ NVECS,BVECS(MEMVT2),BMINS(MEMV),BMAXS(MEMV) COMMON /MODEOP/ KMODEO,KSAMEP,KAUTOP DIMENSION AMCOPY(3,3) DIMENSION CRYVEC(2),CRYMIN(2),CRYMAX(2) C * C * GET NUMBER OF LINES TO ADD TO CURRENT PROFILE 1000 NADD = 0 IF(KAUTOP.NE.1) THEN IF(KMODEO.NE.2) THEN WRITE(ITTO,1010) 1010 FORMAT(/,' Number of lines being added to region ? <0> ') READ(ITTI,*) NADD ELSE READ(ITTI,1020) NADD 1020 FORMAT(I3) ENDIF ENDIF IF(KMODEO.EQ.1) WRITE(IOBO,1030) NADD 1030 FORMAT(I3,T40,'Number of lines being added') IF(NADD.EQ.0) GO TO 9000 C * C * TO KEEP THE PROFILE PARAMETERS AT THE FRONT OF THE LIST, PULL THE C * BACKGROUND, ASYMMETRY, AND AMORPHOUS PROFILE AND THE CRYSTALLITE C * PARAMETERS FROM THE LIST. C * C * BACKGROUND PARAMETER 1100 NTEMP = KNLIN * KNPRM IF(KBKGR.EQ.1.OR.KBKGR.EQ.3) THEN NTEMP = NTEMP + 1 BKGVEC = BVECS(NTEMP) BKGMIN = BMINS(NTEMP) BKGMAX = BMAXS(NTEMP) NVECS = NVECS - 1 ENDIF C * C * ASYMMETRY PARAMETER IF(KASYM.EQ.1) THEN NTEMP = NTEMP + 1 ASYVEC = BVECS(NTEMP) ASYMIN = BMINS(NTEMP) ASYMAX = BMAXS(NTEMP) NVECS = NVECS - 1 ENDIF C * C * AMORPHOUS PROFILE PARAMETERS IF(KAMOR.EQ.1) THEN DO 1170 I=1,3 NTEMP = NTEMP + 1 AMCOPY(I,1) = BVECS(NTEMP) AMCOPY(I,2) = BMINS(NTEMP) AMCOPY(I,3) = BMAXS(NTEMP) NVECS = NVECS - 1 1170 CONTINUE ENDIF C * C * CRYSTALLITE SIZE PARAMTER IF(KCRYS.EQ.1.OR.KCRYS.EQ.3) THEN NTEMP = NTEMP + 1 CRYVEC(1) = BVECS(NTEMP) CRYMIN(1) = BMINS(NTEMP) CRYMAX(1) = BMAXS(NTEMP) NVECS = NVECS - 1 ENDIF C * C * CRYSTALLITE STRAIN PARAMTER IF(KCRYS.EQ.2.OR.KCRYS.EQ.3) THEN NTEMP = NTEMP + 1 CRYVEC(2) = BVECS(NTEMP) CRYMIN(2) = BMINS(NTEMP) CRYMAX(2) = BMAXS(NTEMP) NVECS = NVECS - 1 ENDIF C * C * ADD NADD LINES TO CURRENT NUMBER OF LINES IN THE PROFILE. C * IN ADDITION TO THESE NEW LINES... CHECK FOR WAVELENGTH REFLECTIONS. C * 2000 NORIG = KNLIN DO 2010 I=1,NADD KNLIN = KNLIN + 1 IF(KMODEO.NE.2) THEN WRITE(ITTO,2020) KNLIN 2020 FORMAT(/,' Position and intensity for line ',I3,' ? ') PLPRM(KNLIN,1) = 0.0 PLPRM(KNLIN,2) = 0.0 READ(ITTI,*) PLPRM(KNLIN,1),PLPRM(KNLIN,2) ELSE READ(ITTI,2030) PLPRM(KNLIN,1),PLPRM(KNLIN,2) 2030 FORMAT(2F10.4) WRITE(ITTO,2050) PLPRM(KNLIN,1),PLPRM(KNLIN,2) 2050 FORMAT(/,' New line added: Pos = ',F8.4,' Intensity = ',F8.2) ENDIF IF(KMODEO.EQ.1) WRITE(IOBO,2040) PLPRM(KNLIN,1),PLPRM(KNLIN,2) 2040 FORMAT(2F10.4,T40,' New line added') PLPRM(KNLIN,2) = PLPRM(KNLIN,2) * FTIME NOLD = KNLIN CALL PCALC( KNLIN ) DO 2060 J=NOLD,KNLIN 2060 PLPRM(J,1) = PLPRM(J,1) - CORPOS( PLPRM(J,1) ) 2010 CONTINUE C * C * NOW INITIALIZE THE PARAMETERS FOR THESE PROFILES C * 3000 DO 3010 I=NORIG+1,KNLIN CALL PRINIT( I ) 3010 CONTINUE C * C * AND FINALLY... ADD OTHER PARAMETERS TO THE LIST C * C * BACKGROUND PARAMETER 4000 NTEMP = KNLIN * KNPRM IF(KBKGR.EQ.1.OR.KBKGR.EQ.3) THEN NTEMP = NTEMP + 1 BVECS(NTEMP) = BKGVEC BMINS(NTEMP) = BKGMIN BMAXS(NTEMP) = BKGMAX NVECS = NVECS + 1 ENDIF C * C * ASYMMETRY PARAMETER IF(KASYM.EQ.1) THEN NTEMP = NTEMP + 1 BVECS(NTEMP) = ASYVEC BMINS(NTEMP) = ASYMIN BMAXS(NTEMP) = ASYMAX NVECS = NVECS + 1 ENDIF C * C * AMORPHOUS PROFILE PARAMETERS IF(KAMOR.EQ.1) THEN DO 4070 I=1,3 NTEMP = NTEMP + 1 BVECS(NTEMP) = AMCOPY(I,1) BMINS(NTEMP) = AMCOPY(I,2) BMAXS(NTEMP) = AMCOPY(I,3) NVECS = NVECS + 1 4070 CONTINUE ENDIF C * C * CRYSTALLITE SIZE PARAMETER IF(KCRYS.EQ.1.OR.KCRYS.EQ.3) THEN NTEMP = NTEMP + 1 BVECS(NTEMP) = CRYVEC(1) BMINS(NTEMP) = CRYMIN(1) BMAXS(NTEMP) = CRYMAX(1) NVECS = NVECS + 1 ENDIF C * C * CRYSTALLITE STRAIN PARAMETER IF(KCRYS.EQ.2.OR.KCRYS.EQ.3) THEN NTEMP = NTEMP + 1 BVECS(NTEMP) = CRYVEC(2) BMINS(NTEMP) = CRYMIN(2) BMAXS(NTEMP) = CRYMAX(2) NVECS = NVECS + 1 ENDIF C * 9000 RETURN END C *** PKSPLT - SPLIT COMPOUND PROFILES TO COMPONENT PROFILES C * SUBROUTINE PKSPLT C * PARAMETER ( DTORD2=8.72664626E-03, RTODT2=114.591559 ) PARAMETER ( DTOR =1.745329252E-02, RTOD= 57.29577951 ) COMMON /LUNS/ ITTI,ITTO,IOFI,IOFO,IOBO,IOPL,IOPO,IOLO,IOSC,IOWG COMMON /REFFLG/ KPROF,KLRNZ,KERRT,KASYM,KBKGR,KBKGD,KAMOR,KCRYS COMMON /PEAKP/ KNLIN,KNPRM,PLPRM(200,10),KRLIN(200),KLLIN(201) COMMON /REFPAR/ AMOPAR(3),BKGPAR,ASYPAR,CRYPAR(2) COMMON /WDATA/ NWAVE,WTABLE(5,2) COMMON /COMSCR/ PN(200,10) C * C * WRITE SETUP INFO WRITE(ITTO,1) KPROF, KNLIN 1 FORMAT(/,' PKSPLT=> Entry: Profile: ',I3,' Lines: ',I3) JK = IABS( KPROF ) C * C * SPLIT PEARSON VII WITH ALPHA2 C * C * SORT PARAMETERS 1000 IF(JK.NE.9) GO TO 2000 NTMP = 0 DO 1010 I=1,KNLIN C * ALPHA1 REFLECTION NTMP = NTMP +1 PN(NTMP,1) = PLPRM(I,1) PN(NTMP,2) = PLPRM(I,2) PN(NTMP,3) = PLPRM(I,3) PN(NTMP,4) = PLPRM(I,4) PN(NTMP,5) = PLPRM(I,5) PN(NTMP,6) = PLPRM(I,6) KRLIN(NTMP) = 1 C * ALPHA2 REFLECTION IF(NWAVE.GT.1) THEN NTMP = NTMP + 1 CALL CALCPH(PLPRM(I,1),PLPRM(I,2),2,PN(NTMP,1),PN(NTMP,2)) PN(NTMP,3) = PLPRM(I,7) PN(NTMP,4) = PLPRM(I,8) PN(NTMP,5) = PLPRM(I,9) PN(NTMP,6) = PLPRM(I,10) KRLIN(NTMP) = 2 ENDIF C * ALPHA3 REFLECTION IF(NWAVE.GT.2) THEN NTMP = NTMP + 1 CALL CALCPH(PLPRM(I,1),PLPRM(I,2),3,PN(NTMP,1),PN(NTMP,2)) PN(NTMP,3) = PLPRM(I,3) PN(NTMP,4) = PLPRM(I,4) PN(NTMP,5) = PLPRM(I,5) PN(NTMP,6) = PLPRM(I,6) KRLIN(NTMP) = 3 ENDIF 1010 CONTINUE C * RETURN PROPER PARAMETERS KPROF = 7 KNLIN = NTMP KNPRM = 6 GO TO 8000 C * C * SPLIT PEARSON VII WITH CONSTRAINED FWHM C * C * SORT PARAMETERS 2000 IF(JK.NE.10) GO TO 3000 NTMP = 0 DO 2010 I=1,KNLIN C * ALPHA1 REFLECTION NTMP = NTMP + 1 PN(NTMP,1) = PLPRM(I,1) PN(NTMP,2) = PLPRM(I,2) PN(NTMP,3) = PLPRM(I,3) PN(NTMP,4) = PLPRM(I,4) PN(NTMP,5) = PLPRM(I,5) PN(NTMP,6) = PLPRM(I,6) KRLIN(NTMP) = 1 C * ALPHA2 REFLECTION IF(NWAVE.GT.1) THEN NTMP = NTMP + 1 CALL CALCPH(PLPRM(I,1),PLPRM(I,2),2,PN(NTMP,1),PN(NTMP,2)) PN(NTMP,3) = PLPRM(I,7) PN(NTMP,4) = PLPRM(I,3) PN(NTMP,5) = PLPRM(I,8) PN(NTMP,6) = PLPRM(I,4) KRLIN(NTMP) = 2 ENDIF C * ALPHA3 REFLECTION IF(NWAVE.GT.2) THEN NTMP = NTMP + 1 CALL CALCPH(PLPRM(I,1),PLPRM(I,2),3,PN(NTMP,1),PN(NTMP,2)) PN(NTMP,3) = PLPRM(I,3) PN(NTMP,4) = PLPRM(I,4) PN(NTMP,5) = PLPRM(I,5) PN(NTMP,6) = PLPRM(I,6) KRLIN(NTMP) = 3 ENDIF 2010 CONTINUE C * RETURN PROPER PARAMETERS KPROF = 7 KNLIN = NTMP KNPRM = 6 GO TO 8000 C * C * SPLIT PEARSON VII WITH CONSTRAINED FWHM AND SHAPE FACTORS C * C * SORT PARAMETERS 3000 IF(JK.NE.11) GO TO 4000 NTMP = 0 DO 3010 I=1,KNLIN C * ALPHA1 REFLECTION NTMP = NTMP + 1 PN(NTMP,1) = PLPRM(I,1) PN(NTMP,2) = PLPRM(I,2) PN(NTMP,3) = PLPRM(I,3) PN(NTMP,4) = PLPRM(I,4) PN(NTMP,5) = PLPRM(I,5) PN(NTMP,6) = PLPRM(I,6) KRLIN(NTMP) = 1 C * ALPHA2 REFLECTION IF(NWAVE.GT.1) THEN NTMP = NTMP + 1 CALL CALCPH(PLPRM(I,1),PLPRM(I,2),2,PN(NTMP,1),PN(NTMP,2)) PN(NTMP,3) = PLPRM(I,3) PN(NTMP,4) = PLPRM(I,4) PN(NTMP,5) = PLPRM(I,5) PN(NTMP,6) = PLPRM(I,6) KRLIN(NTMP) = 2 ENDIF C * ALPHA3 REFLECTION IF(NWAVE.GT.2) THEN NTMP = NTMP + 1 CALL CALCPH(PLPRM(I,1),PLPRM(I,2),3,PN(NTMP,1),PN(NTMP,2)) PN(NTMP,3) = PLPRM(I,3) PN(NTMP,4) = PLPRM(I,4) PN(NTMP,5) = PLPRM(I,5) PN(NTMP,6) = PLPRM(I,6) KRLIN(NTMP) = 3 ENDIF 3010 CONTINUE C * RETURN PROPER PARAMETERS KPROF = 7 KNLIN = NTMP KNPRM = 6 GO TO 8000 C * C * SPLIT PEARSON VII WITH CONSTRAINED SHAPE FACTORS C * C * SORT PARAMETERS 4000 IF(JK.NE.12) GO TO 6000 NTMP = 0 DO 4010 I=1,KNLIN WF = FNFWHM( PLPRM(I,1), 1 ) WB = FNFWHM( PLPRM(I,1), 2 ) C * ALPHA1 REFLECTION NTMP = NTMP + 1 PN(NTMP,1) = PLPRM(I,1) PN(NTMP,2) = PLPRM(I,2) PN(NTMP,3) = WF PN(NTMP,4) = PLPRM(I,3) PN(NTMP,5) = WB PN(NTMP,6) = PLPRM(I,4) KRLIN(NTMP) = 1 C * ALPHA2 REFLECTION IF(NWAVE.GT.1) THEN NTMP = NTMP + 1 CALL CALCPH(PLPRM(I,1),PLPRM(I,2),2,PN(NTMP,1),PN(NTMP,2)) PN(NTMP,3) = WF PN(NTMP,4) = PLPRM(I,3) PN(NTMP,5) = WB PN(NTMP,6) = PLPRM(I,4) KRLIN(NTMP) = 2 ENDIF C * ALPHA3 REFLECTION IF(NWAVE.GT.2) THEN NTMP = NTMP + 1 CALL CALCPH(PLPRM(I,1),PLPRM(I,2),3,PN(NTMP,1),PN(NTMP,2)) PN(NTMP,3) = WF PN(NTMP,4) = PLPRM(I,3) PN(NTMP,5) = WB PN(NTMP,6) = PLPRM(I,4) KRLIN(NTMP) = 3 ENDIF 4010 CONTINUE C * RETURN PROPER PARAMETERS KPROF = 7 KNLIN = NTMP KNPRM = 6 GO TO 8000 C * C * SPLIT PEARSON VII, CALCULATED FWHM AND SHAPE FACTORS C * C * SORT PARAMETERS 6000 IF(JK.NE.13)GO TO 6100 NTMP = 0 DO 6010 I=1,KNLIN ANGLE = PLPRM(I,1) AC = FNFWHM( ANGLE, 1 ) BC = FNSHAP( ANGLE, 1 ) CC = FNFWHM( ANGLE, 2 ) DC = FNSHAP( ANGLE, 2 ) C * ALPHA1 REFLECTION NTMP = NTMP + 1 PN(NTMP,1) = PLPRM(I,1) PN(NTMP,2) = PLPRM(I,2) PN(NTMP,3) = AC PN(NTMP,4) = BC PN(NTMP,5) = CC PN(NTMP,6) = DC KRLIN(NTMP) = 1 C * ALPHA2 REFLECTION IF(NWAVE.GT.1) THEN NTMP = NTMP + 1 CALL CALCPH(PLPRM(I,1),PLPRM(I,2),2,PN(NTMP,1),PN(NTMP,2)) PN(NTMP,3) = AC PN(NTMP,4) = BC PN(NTMP,5) = CC PN(NTMP,6) = DC KRLIN(NTMP) = 2 ENDIF C * ALPHA3 REFLECTION IF(NWAVE.GT.2) THEN NTMP = NTMP + 1 CALL CALCPH(PLPRM(I,1),PLPRM(I,2),3,PN(NTMP,1),PN(NTMP,2)) PN(NTMP,3) = AC PN(NTMP,4) = BC PN(NTMP,5) = CC PN(NTMP,6) = DC KRLIN(NTMP) = 3 ENDIF 6010 CONTINUE C * RETURN PROPER PARAMETERS KPROF = 7 KNLIN = NTMP KNPRM = 6 GO TO 8000 C * C ** CONVOLUTE PROFILES USING INSTRUMENTAL * SPECIMEN C * C * SORT PARAMETERS 6100 IF( JK.NE.14 .AND. JK.NE.15 ) GO TO 7000 C * IF CONVOLUTE PROFILES ARE TO BE SHOWN.... USE NEXT LINE. C * OTHERWISE THE PROFILES SHOWN ARE THOSE OF THE SPECIMEN. GO TO 7000 C * GENERATE THE CORRECT SPECIMEN PROFILE PARAMETERS 6101 NTMP = 0 DO 6110 I=1,KNLIN AX = PLPRM(I,3) C * IF CONSTRAINED BROADENING IS USED... THEN CALCULATE BETA IF(KCRYS.EQ.0) GO TO 6120 TTC = PLPRM(I,1) + CORPOS( PLPRM(I,1) ) THETAR = TTC * DTORD2 BETA = 0.0 IF( KCRYS.EQ.1 .OR. KCRYS.EQ.3 ) THEN BETA = RTOD * WTABLE(1,1) / CRYPAR(1) / COS(THETAR) ENDIF IF( KCRYS.EQ.2 .OR. KCRYS.EQ.3 ) THEN BETA = BETA + RTOD * 4.0 * CRYPAR(2) * TAN(THETAR) ENDIF C * CONVERT INTEGRAL-BREADTH TO FWHM IF(JK.EQ.14) AX = 0.6366197724 * BETA IF(JK.EQ.15) AX = 0.9394372786 * BETA C * ALPHA1 REFLECTION 6120 NTMP = NTMP + 1 PN(NTMP,1) = PLPRM(I,1) PN(NTMP,2) = PLPRM(I,2) PN(NTMP,3) = AX KRLIN(NTMP) = 1 6110 CONTINUE C * RETURN PROPER PARAMETERS IF(JK.EQ.14) KPROF = 1 IF(JK.EQ.15) KPROF = 5 KNLIN = NTMP KNPRM = 3 GO TO 8000 C * C ** INTERMEDIATE LORENTZIAN WITH ALPHA 2 REFLECTION C * C * SORT PARAMETERS 7000 IF(JK.NE.8) GO TO 9000 NTMP = 0 DO 7010 I=1,KNLIN ANGLE = PLPRM(I,1) AX = FNFWHM(ANGLE,1) + PLPRM(I,3) BX = FNSHAP(ANGLE,1) CX = FNFWHM(ANGLE,2) + PLPRM(I,3) DX = FNSHAP(ANGLE,2) C * ALPHA1 REFLECTION NTMP = NTMP + 1 PN(NTMP,1) = PLPRM(I,1) PN(NTMP,2) = PLPRM(I,2) PN(NTMP,3) = AX PN(NTMP,4) = BX PN(NTMP,5) = CX PN(NTMP,6) = DX KRLIN(NTMP) = 1 C * ALPHA2 REFLECTION IF(NWAVE.GT.1) THEN NTMP = NTMP + 1 CALL CALCPH(PLPRM(I,1),PLPRM(I,2),2,PN(NTMP,1),PN(NTMP,2)) PN(NTMP,3) = AX PN(NTMP,4) = BX PN(NTMP,5) = CX PN(NTMP,6) = DX KRLIN(NTMP) = 2 ENDIF 7010 CONTINUE C * RETURN PROPER PARAMETERS KPROF = 7 KNLIN = NTMP KNPRM = 6 C * C * PUT SPLIT LINES BACK INTO PLPRM ARRAY 8000 DO 8010 I=1,KNLIN DO 8020 J=1,KNPRM PLPRM(I,J) = PN(I,J) 8020 CONTINUE 8010 CONTINUE C * C * RETURN TO MAIN 9000 KPROF = IABS( KPROF ) WRITE(ITTO,9001) KPROF,KNLIN 9001 FORMAT(10X,'Exit : Profile: ',I3,' Lines: ',I3) RETURN END C *** PATWRI - GENERATE ALPHA-1 PATTERN AND WRITES IT TO A FILE C * SUBROUTINE PATWRI C * LOGICAL ASCII CHARACTER QDATE*9, QTIME*8, QFILE*20, QANS*1, QTITLE*80 PARAMETER ( MEMV = 32, MPTS = 2048 ) COMMON /LUNS/ ITTI,ITTO,IOFI,IOFO,IOBO,IOPL,IOPO,IOLO,IOSC,IOWG COMMON /SDATA/ KOBS,YANG(MPTS),YOBS(MPTS),YSYN(MPTS),YBKG(MPTS) COMMON /FLDATN/ KFILET,FBANG,FEANG,FAINC,FTIME COMMON /MODEOP/ KMODEO,KSAMEP,KAUTOP COMMON /PDATA/ BANG, EANG DIMENSION XDATA(10) C * 100 IF(KAUTOP.NE.1) THEN IF(KMODEO.NE.2) WRITE(ITTO,110) 110 FORMAT(/,' Write alpha-1 pattern to a file ? ') READ(ITTI,1050) QANS ELSE QANS = 'N' ENDIF IF( QANS.NE.'Y' .AND. QANS.NE.'y' ) QANS = 'N' IF(KMODEO.EQ.1) WRITE(IOBO,120) QANS 120 FORMAT(A1,T40,'Output alpha-1 pattern') IF( KMODEO.EQ.2 .OR. KAUTOP.EQ.1 ) WRITE(ITTO,130) QANS 130 FORMAT(/,' Output alpha-1 pattern: ',A1) IF( QANS.EQ.'N' .OR. QANS.EQ.'n' ) GO TO 9000 C * C ** OPEN THE OUTPUT DATA FILE C * C * GET THE DATA FILE NAME... QUIT IF BLANK 1000 IF(KMODEO.NE.2) WRITE(ITTO,1010) 1010 FORMAT(' What is the name for the output file ? ') READ(ITTI,1020) QFILE 1020 FORMAT(A20) IF(KMODEO.EQ.1) WRITE(IOBO,1025) QFILE 1025 FORMAT(A20,T40,' Pattern file name') IF(KMODEO.EQ.2) WRITE(ITTO,1035) QFILE 1035 FORMAT(/,' Alpha 1 corrected pattern file:',A20) IF(QFILE(1:1).NE.' ') GO TO 1030 GO TO 9000 C * C * GET THE DATA FILE TYPE 1030 IF(KMODEO.NE.2) WRITE(ITTO,1040) 1040 FORMAT(' (F)ormatted or (U)nformatted output file ? ') READ(ITTI,1050) QANS 1050 FORMAT(A1) ASCII = .NOT.( QANS.EQ.'U' .OR. QANS.EQ.'u' ) IF(ASCII) QANS = 'F' IF(KMODEO.EQ.1) WRITE(IOBO,1051) QANS 1051 FORMAT(A1,T40,' Formatted/unformatted file type') IF(KMODEO.EQ.2) WRITE(ITTO,1052) QANS 1052 FORMAT(' Output file is formatted/unformatted: ',A1) C * C ** VERIFY THE FILE PARAMTERS C * 1100 IF(KMODEO.NE.2) WRITE(ITTO,1120) 1120 FORMAT(' The title for the pattern ? ') READ(ITTI,1130) QTITLE 1130 FORMAT(A80) IF(KMODEO.EQ.1) WRITE(IOBO,1130) QTITLE IF(KMODEO.EQ.2) WRITE(ITTO,1140) QTITLE(1:72) 1140 FORMAT(1X,A72) WRITE(ITTO,1110) BANG,EANG,FAINC,FTIME 1110 FORMAT(/,' The run time parameters for this file are:',//, 1 ' Starting angle : ',F10.4,/, 1 ' Ending angle : ',F10.4,/, 1 ' Angle increment : ',F10.4,/, 1 ' Step time : ',F10.4) C * C * IF WE ARE RUNNING BATCH SETUP... EXIT HERE C * IF(KMODEO.EQ.1) GO TO 9000 C * C * OPEN THE ASCII OUTPUT DATA FILE IF(ASCII) THEN OPEN(UNIT=IOFO,FILE=QFILE,STATUS='NEW',ERR=1070, 1 FORM='FORMATTED') ELSE OPEN(UNIT=IOFO,FILE=QFILE,STATUS='NEW',ERR=1070, 1 FORM='UNFORMATTED') ENDIF GO TO 2000 C * C * AN ERROR OCCURED ON FILE OPENING 1070 WRITE(ITTO,1080) 1080 FORMAT(/,' -Unable to open output pattern file; Continuing') GO TO 9000 C * C * GET THE DATE AND TIME OF PATTERN CREATION C * 2000 CALL DATE( QDATE ) CALL TIME( QTIME ) WRITE(ITTO,2020) QDATE,QTIME 2020 FORMAT(/,' Time of pattern creation: ',A9,2X,A8) C * C * WRITE THE FILE HEADERS C * 3000 IF(ASCII) THEN WRITE(IOFO,1130) QTITLE WRITE(IOFO,3010) QDATE,QTIME WRITE(IOFO,3020) BANG,EANG,FAINC,FTIME 3010 FORMAT(A9,A8) 3020 FORMAT(4F10.4) ELSE WRITE(IOFO) QTITLE WRITE(IOFO) QDATE,QTIME WRITE(IOFO) BANG,EANG,FAINC,FTIME ENDIF C * C * SUBTRACT THE ALPHA2,3 FROM THE PATTERN C * 4000 CALL PATSUB C * C * WRITE THE PATTERN TO THE FILE C * 5000 IP = 0 5010 DO 5020 I=1,10 5020 XDATA(I) = 0.0 DO 5030 I=1,10 IP = IP + 1 IF(IP.GT.KOBS) GO TO 5040 XDATA(I) = YSYN(IP) 5030 CONTINUE 5040 IF(ASCII) THEN WRITE(IOFO,5060) XDATA 5060 FORMAT(10F7.2) ELSE WRITE(IOFO) XDATA ENDIF IF(IP.LT.KOBS) GO TO 5010 C * C * CLOSE THE OUTPUT FILE AND EXIT STAGE RIGHT CLOSE(UNIT=IOFO) 9000 RETURN END C *** PATSUB - GENERATES THE ALPHA-1 PATTERN C * SUBROUTINE PATSUB C * PARAMETER ( MEMV = 32, MPTS = 2048 ) COMMON /LUNS/ ITTI,ITTO,IOFI,IOFO,IOBO,IOPL,IOPO,IOLO,IOSC,IOWG COMMON /SDATA/ KOBS,YANG(MPTS),YOBS(MPTS),YSYN(MPTS),YBKG(MPTS) COMMON /PEAKP/ KNLIN,KNPRM,PLPRM(200,10),KRLIN(200),KLLIN(201) COMMON /MODEOP/ KMODEO,KSAMEP,KAUTOP COMMON /COMSCR/ PN(200,10) DIMENSION NRCOPY(200) C * C * COPY THE ORIGINAL PARAMETERS C * 1000 DO 1010 I=1,KNLIN NRCOPY(I) = KRLIN(I) DO 1020 J=1,KNPRM 1020 PN(I,J) = PLPRM(I,J) 1010 CONTINUE NLCOPY = KNLIN NPCOPY = KNPRM C * C * SUBTRACT THE ALPHA2,3 FROM THE PATTERN C * 4000 NSTART = KNLIN NTEMP = KNLIN KRLIN(KNLIN+1) = -1 C * C * CHECK FOR ALPHA1 DO 4010 I0=1,KNLIN 4005 IF(KRLIN(I0).EQ.-1) GO TO 4050 IF(KRLIN(I0).NE. 1) GO TO 4010 C * C * REMOVE LINE FROM PARAMETER LIST DO 4020 I1=I0,NTEMP I1P1 = I1 + 1 DO 4030 I2=1,KNPRM 4030 PLPRM(I1,I2) = PLPRM(I1P1,I2) KRLIN(I1) = KRLIN(I1P1) 4020 CONTINUE NTEMP = NTEMP - 1 GO TO 4005 4010 CONTINUE C * 4050 KNLIN = NTEMP WRITE(ITTO,4055) NSTART - KNLIN 4055 FORMAT(/,' Lines remaining in pattern: ',I3) C * C * SYNTHESIZE THE PATTERN IN YSYN CALL SHADOW( YSYN, 999, IDUM1, IDUM2 ) DO 4057 I=1,KOBS 4057 YSYN(I) = YSYN(I) + YBKG(I) C * C * SUBTRACT THE TWO PATTERNS DO 4060 I=1,KOBS 4060 YSYN(I) = YOBS(I) - YSYN(I) C * C * RESTORE THE ORIGINAL PARAMETERS C * 2000 DO 2010 I=1,KNLIN KRLIN(I) = NRCOPY(I) DO 2020 J=1,KNPRM 2020 PLPRM(I,J) = PN(I,J) 2010 CONTINUE KNLIN = NLCOPY KNPRM = NPCOPY C * C * THATS ALL.... 9000 RETURN END C *** PROGRAM: SHADOW (SHADOW40) C *** VERSION: 860822 (YYMMDD) C * C *** PKSRCH - FIND DIFFRACTION LINES IN THE SCAN DATA C * C * PROGRAMMER: S. A. HOWARD C * DEPARTMENT OF CERAMICS C * UNIVERISTY OF MISSOURI- ROLLA C * SUBROUTINE PKSRCH C * LOGICAL LFIRST, LLAST CHARACTER QWID*1 PARAMETER ( DTORD2=8.72664626E-03, RTODT2=114.591559 ) PARAMETER ( MEMV = 32, MPTS = 2048 ) PARAMETER ( MAXREC = MPTS / 10 ) COMMON /LUNS/ ITTI,ITTO,IOFI,IOFO,IOBO,IOPL,IOPO,IOLO,IOSC,IOWG COMMON /REFFLG/ KPROF,KLRNZ,KERRT,KASYM,KBKGR,KBKGD,KAMOR,KCRYS COMMON /SDATA/ KOBS,YANG(MPTS),YOBS(MPTS),YSYN(MPTS),YBKG(MPTS) COMMON /SCHDAT/ KNFND,PSIGMA,RELLOW,BIGINT,KNSMO,KFFLT,KFMNT COMMON /WGDATN/ WGBAK(6),WGPRO(4,3),WGRAD(5,2),WGCAL(3) COMMON /BKGDAT/ LDEG,CLY,CLC(6),BKGSDV,IBKCPS,IBKNBK COMMON /PLTDAT/ KPPLOT,KPSETS(5),KPTYPE,KPTDEF COMMON /FLDATN/ KFILET,FBANG,FEANG,FAINC,FTIME COMMON /RFREGN/ KNUMRG,KNUMCU,REFREG(200,2) COMMON /COMSCR/ THTCOR(MPTS),DSPACE(MPTS) COMMON /MODEOP/ KMODEO,KSAMEP,KAUTOP COMMON /PEAKDT/ NPEAK,PEAKS(200,4) COMMON /WDATA/ NWAVE,WTABLE(5,2) COMMON /SCHANG/ KBEGPT, KENDPT COMMON /PDATA/ BANG, EANG DIMENSION XDATA(10),OVRLAP(80,2) C * C * PEAKDT - (1) POSITION 2THETA C * (2) INTENSITY C * (3) WIDTH OF PEAK IN MULTIPLES OF STEP WIDTH C * (4) WAVELENGTH IN WAVE TABLE CAUSING THIS REFLECTION C * C ** GET THE ANGULAR RANGE FOR THE SEARCH C * C * GET THE APPROXIMATE ANGLES OVER WHICH TO SEARCH 1000 WRITE(ITTO,1001) 1001 FORMAT(/,' * Search criteria:') IF(KAUTOP.NE.1) THEN WRITE(ITTO,1005) 1005 FORMAT(/,' Angular region for search ? ') BANG = 0.0 EANG = 0.0 READ(ITTI,*) BANG,EANG ELSE BANG = FBANG EANG = FEANG ENDIF IF(BANG.LE.0.0) BANG = FBANG IF(EANG.LE.0.0) EANG = FEANG BANGP = BANG EANGP = EANG BANG = AMAX1( BANG, FBANG ) EANG = AMIN1( EANG, FEANG ) IF(BANG.GE.EANG) GO TO 1000 C * C * DETERMINE THE NUMBER OF RECORDS TO SKIP AT BEGINNING NSKIP = INT( (BANG-FBANG)/FAINC + 0.10 ) / 10 C * C * DETERMINE THE BEGINNING ANGLE ANGLE = FBANG + REAL(NSKIP*10) * FAINC BANG = ANGLE C * C * DETERMINE THE TOTAL NUMBER OF RECORDS TO BE READ NREC = NINT( (EANG-BANG) / FAINC ) / 10 + 1 EANG = BANG + FAINC * REAL( NREC * 10 ) - FAINC IF(EANG.GT.FEANG) EANG = FEANG WRITE(ITTO,1015) BANG,EANG 1015 FORMAT(/,' Angles for search: ',F8.4,' to ',F8.4,' 2theta') C * C ** GET THE SEARCH PARAMETERS 2000 CALL SRCPRM C * C ** GET PLOTTING PARAMETERS C * 3000 CALL SRPLOT( BANGP, EANGP ) C * C ** INITIALIZE PEAK/POINTS COUNTERS AND FIRST-PASS-THRU FLAG IF(KAUTOP.NE.3) THEN NPEAK = 0 BIGINT = 0.0 ENDIF KOBS = 0 LFIRST = .TRUE. KNUMRG = 0 C * C ** LOAD THE BUFFER; USE AN INTEGRAL NUMBER OF RECORDS C * C * REWIND DATA FILE TO BEGINNING REWIND (UNIT=IOFI) C * C * SKIP HEADER AND SKIP RECORDS IF(KFILET.EQ.0) THEN NTEMP = NSKIP + 3 DO 4002 I=1,NTEMP 4002 READ(IOFI,4020) QWID 4020 FORMAT(1A1) ELSE NTEMP = NSKIP + 3 DO 4004 I=1,NTEMP 4004 READ(IOFI) QWID ENDIF C * C * DETERMINE THE NUMBER OF RECORDS TO READ ON FIRST PASS NREAD = MIN( NREC, MAXREC ) NREC = NREC - NREAD C * C * READ THE INPUT RECORDS 4030 TEMP = ANGLE - FAINC IF(KFILET.EQ.0) THEN DO 4040 I=1,NREAD READ(IOFI,4042,END=4062) XDATA 4042 FORMAT(10F7.0) DO 4044 K=1,10 KOBS = KOBS + 1 YANG(KOBS) = TEMP + REAL(KOBS) * FAINC YOBS(KOBS) = XDATA(K) 4044 CONTINUE 4040 CONTINUE ELSE DO 4050 I=1,NREAD READ(IOFI,END=4062) XDATA DO 4052 K=1,10 KOBS = KOBS + 1 YANG(KOBS) = TEMP + REAL(KOBS) * FAINC YOBS(KOBS) = XDATA(K) 4052 CONTINUE 4050 CONTINUE ENDIF KMAX = INT( (EANG-ANGLE)/FAINC + 0.10 ) + 1 IF(KOBS.GT.KMAX) KOBS = KMAX GO TO 4060 4062 WRITE(ITTO,4064) 4064 FORMAT(/, 1' --The end-of-file was unexpectedly hit while reading the', 1' pattern file.') NREC = 0 C * C * SET LAST PASS THROUGH FLAG BASED ON NREC - RECORDS REMAINING 4060 LLAST = NREC.EQ.0 C * C * SET INDEX POINTER BASED ON LFIRST AND LLAST FLAGS KBEGPT = 41 IF(LFIRST) KBEGPT = 1 LFIRST = .FALSE. KENDPT = KOBS - 39 IF(LLAST) KENDPT = KOBS KNNNPT = KENDPT - KBEGPT + 1 C * C * RECORD LAST EIGHTY (80) POINTS FOR OVERLAP IF(.NOT.LLAST) THEN DO 4070 I=1,80 OVRLAP(I,1) = YANG(KOBS-80+I) OVRLAP(I,2) = YOBS(KOBS-80+I) 4070 CONTINUE ENDIF C * C * WRITE SEGMENT BEING EVALUATED WRITE(ITTO,4080) YANG(KBEGPT),YANG(KENDPT),KNNNPT 4080 FORMAT(/,' Segment: ',F8.4,' to ',F8.4,' Points = ',I4) C * C * WRITE RAW DATA TO PLOT FILE IF(KPSETS(1).NE.0) THEN IF(KPTYPE.EQ.0) THEN WRITE(IOPL) KPSETS(1),KNNNPT,YANG(KBEGPT) WRITE(IOPL) (YOBS(I)/FTIME,I=KBEGPT,KENDPT) ELSE WRITE(IOPL,4090) KPSETS(1),KNNNPT,YANG(KBEGPT) 4090 FORMAT(I6,I6,F10.4) WRITE(IOPL,4092) (YOBS(I)/FTIME,I=KBEGPT,KENDPT) 4092 FORMAT(10F8.1) ENDIF ENDIF C * C ** APPLY THE DIGITAL FILTER TO THE DATA C * C * KFFLT = 1: BROMBA/ZIEGLER FILTER... RECURSIVE, INTEGER AND FAST C * KFFLT = 2: SAVITSKY/GOLAY... NONRECURSIVE C * NOTE: SCRATCH ARRAYS ARE USED IN DGFILT C * IF(KFFLT.EQ.1) THEN CALL DGFILT( KFMNT, KNSMO ) ELSE IF(KFFLT.EQ.2) THEN CALL SVGOLY( KNSMO, 0 ) ELSE DO 6080 I=1,KOBS 6080 YSYN(I) = YOBS(I) GO TO 5000 ENDIF C * C * CALCULATE THE R FACTOR FOR SMOOTHING R0 = 0.0 R1 = 0.0 DO 6090 I=KBEGPT,KENDPT WGT = 1.0 / AMAX1( YOBS(I), 1.0 ) R0 = R0 + YOBS(I) R1 = R1 + WGT * ( YOBS(I) - YSYN(I) )**2 6090 CONTINUE R0 = SQRT( R1 / R0 ) WRITE(ITTO,6092) R0 6092 FORMAT(' Rwp after smoothing the raw data = ',F9.4) C * C * WRITE SMOOTHED DATA TO PLOT FILE IF(KPSETS(4).NE.0) THEN IF(KPTYPE.EQ.0) THEN WRITE(IOPL) KPSETS(4),KNNNPT,YANG(KBEGPT) WRITE(IOPL) (YSYN(I)/FTIME,I=KBEGPT,KENDPT) ELSE WRITE(IOPL,4090) KPSETS(4),KNNNPT,YANG(KBEGPT) WRITE(IOPL,4092) (YSYN(I)/FTIME,I=KBEGPT,KENDPT) ENDIF ENDIF C * C ** REMOVE BACKGROUND IF BACKGROUND HAS BEEN DETERMINED C * 5000 IF(KBKGD.NE.1) THEN WRITE(ITTO,5010) 5010 FORMAT(' No background adjustment made on this segment') GO TO 7000 ELSE KBKGR = 2 ENDIF C * C * GENERATE THE BACKGROUND IN YBKG ICODE = 0 CALL BKGLVL( YBKG ) C * C * CORRECT YOBS FOR BACKGROUND, GENERATE THE THRESHOLD LEVEL IN YBKG C * AND CORRECT YSYN FOR THE THRESHOLD WRITE(ITTO,5020) 5020 FORMAT(' Subtracting background from segment') DO 5030 I=1,KOBS CYOBS = YOBS(I) YOBS(I) = CYOBS - YBKG(I) YBKG(I) = YBKG(I) + PSIGMA * SQRT( AMAX1(YBKG(I),0.0) + CYOBS ) YSYN(I) = YSYN(I) - YBKG(I) 5030 CONTINUE C * C * WRITE BACKGROUND CORRECTED DATA TO PLOT FILE IF(KPSETS(2).NE.0) THEN IF(KPTYPE.EQ.0) THEN WRITE(IOPL) KPSETS(2),KNNNPT,YANG(KBEGPT) WRITE(IOPL) (YOBS(I)/FTIME,I=KBEGPT,KENDPT) ELSE WRITE(IOPL,4090) KPSETS(2),KNNNPT,YANG(KBEGPT) WRITE(IOPL,4092) (YOBS(I)/FTIME,I=KBEGPT,KENDPT) ENDIF ENDIF C * C * WRITE THRESHOLD TO PLOT FILE IF(KPSETS(3).NE.0) THEN IF(KPTYPE.EQ.0) THEN WRITE(IOPL) KPSETS(3),KNNNPT,YANG(KBEGPT) WRITE(IOPL) (YBKG(I)/FTIME,I=KBEGPT,KENDPT) ELSE WRITE(IOPL,4090) KPSETS(3),KNNNPT,YANG(KBEGPT) WRITE(IOPL,4092) (YBKG(I)/FTIME,I=KBEGPT,KENDPT) ENDIF ENDIF C * C ** PERFORM PEAK DETECTION ON THIS SEGMENT C * 7000 IF(KAUTOP.NE.3) CALL PKFIND C * C * NOW REJECT PEAKS OF TOO LOW INTENSITY IF(NPEAK.LT.2) GO TO 7100 YMIN = RELLOW * BIGINT DO 7010 I=1,NPEAK 7010 IF(PEAKS(I,2).LT.YMIN) PEAKS(I,1) = 0.0 NTEMP = NPEAK NPEAK = 0 DO 7020 I=1,NTEMP IF(PEAKS(I,1).EQ.0.0) GO TO 7020 NPEAK = NPEAK + 1 IF(NPEAK.EQ.I) GO TO 7020 PEAKS(NPEAK,1) = PEAKS(I,1) PEAKS(NPEAK,2) = PEAKS(I,2) PEAKS(NPEAK,3) = PEAKS(I,3) PEAKS(NPEAK,4) = PEAKS(I,4) 7020 CONTINUE C * C ** DETERMINE REGIONS FOR REFINEMENT WHEN AUTOPILOT FLAG IS ON C * 7100 IF(KAUTOP.NE.0) CALL SETREG( 0 ) C * C ** LOAD NEXT SEGMENT FOR SEARCH C * C * TEST FOR REMAINING RECORDS 8000 IF(LLAST) GO TO 9000 C * C * COPY THE LAST EIGHTY (80) POINTS TO FRONT OF BUFFER DO 8010 I=1,80 YANG(I) = OVRLAP(I,1) YOBS(I) = OVRLAP(I,2) YSYN(I) = YOBS(I) 8010 CONTINUE C * C * UPDATE ANGLE FOR NEXT SEGMENT AND KOBS KOBS = 80 ANGLE = YANG(1) C * C * SET RECORD INDICATOR, NOTE: 80 POINTS IS 8 RECORDS NREAD = MIN( NREC, (MAXREC-8) ) NREC = NREC - NREAD GO TO 4030 C * C ** CHECK FOR WHICH REFLECTION WRT WAVELENGTH IS PRESENT. C ** CALCULATE ALL OTHER POSITIONS BASED ON THE WAVELENGTHS TABLED, C ** ALLOWANCES: INTENSITY 20%, POSITION 2 ANGULAR INCREMENTS. C * 9000 IF(NWAVE.LT.2) GO TO 9090 C * C * CHECK ALL PEAKS DELMAX = 2.0 * FAINC DO 9010 I0=1,NPEAK C * C * CHECK ALL WAVELENGTHS DO 9020 LAMBDA=2,NWAVE CALL CALCPH(PEAKS(I0,1),PEAKS(I0,2),LAMBDA,PN,YN) C * C * CHECK ALL PEAKS FOR A MATCH DO 9030 I1=1,NPEAK IF( ABS(PEAKS(I1,1)-PN) .GT. DELMAX )GO TO 9030 RIDIFF = ABS( 1. - YN/PEAKS(I1,2) ) IF(RIDIFF.GT.0.20) GO TO 9030 PEAKS(I1,4) = REAL(LAMBDA) 9030 CONTINUE 9020 CONTINUE 9010 CONTINUE C * C * CALL SETREG TO CLEANUP THE REFINEMENT REGIONS IF AUTOPILOT IS ON 9090 IF(KAUTOP.NE.0) CALL SETREG( 1 ) C * C ** LIST PEAK SEARCH RESULTS C * C * PRINT THE HEADER 9100 WRITE(ITTO,9105) 9105 FORMAT(//,6X,'***** P E A K S E A R C H R E S U L T S', 1 ' *****') C * C * LIST THE PARAMETERS USED IN THE SEARCH RELLOW = RELLOW * 100.0 WRITE(ITTO,9107)PSIGMA,RELLOW,KNFND,KNSMO,KFFLT,KFMNT 9107 FORMAT(/,2X,' Std devation threshold: ',F5.2, 1 2X,' Min relative intensity: ',F5.2,/, 1 2X,' Points used for search: ',I5, 1 2X,' Points used for smooth: ',I5,/, 1 2X,' Filter type : ',I5, 1 2X,' Filter moment : ',I5) C * C * HAVE ANY PEAKS BEEN DETECTED? IF(NPEAK.EQ.0) GO TO 9200 C * C * HAS THE CALIBRATION CURVE BEEN APPLIED? TEMP = ABS(WGCAL(1)) + ABS(WGCAL(2)) + ABS(WGCAL(3)) IF(TEMP.GT.0.0) WRITE(ITTO,9108) 9108 FORMAT(/,' * 2theta calibration curve applied to positions') C * C * LIST THE PEAK PARAMETERS WRITE(ITTO,9115) 9115 FORMAT(//,' No. Two-theta Ref Peak (CPS) D spacing Rel. peak' 1 ,' Peak width Region' 1 ,/,' --- --------- --- ---------- --------- ---------' 1 ,' ---------- ------') C * C * PRINT ALL THE PEAK INFORMATION DO 9120 IP=1,NPEAK POS = PEAKS(IP,1) IF(KAUTOP.NE.0) THEN DO 9130 IR=1,KNUMRG 9130 IF( POS.GE.REFREG(IR,1) .AND. POS.LE.REFREG(IR,2) ) GO TO 9135 IR = 999 ELSE IR = 0 ENDIF 9135 RI = PEAKS(IP,2) / BIGINT * 100.0 POS = POS + CORPOS( POS ) IF(KAUTOP.NE.3) PEAKS(IP,2) = PEAKS(IP,2) / FTIME LAMBDA = INT( PEAKS(IP,4) ) DSP = WTABLE(LAMBDA,1) / ( 2.0*SIN(POS*DTORD2) ) * 1.0E10 WRITE(QWID,9125) LAMBDA 9125 FORMAT(I1) IF(QWID.EQ.'1') QWID = ' ' WRITE(ITTO,9140) IP,POS,QWID,PEAKS(IP,2),DSP,RI,PEAKS(IP,3),IR 9140 FORMAT(' ',I3,2X,F9.4,4X,A1,2X,F10.4,2X,F9.4,2X,F9.4,2X,F9.4, 1 4X,I3) THTCOR(IP) = POS DSPACE(IP) = DSP 9120 CONTINUE C * C * IF THE PEAK LOCATION MARKERS ARE BEING PLOTTED... IF(KPSETS(5).NE.0) THEN IF(KPTYPE.EQ.0) THEN WRITE(IOPL) KPSETS(5),NPEAK,PEAKS(1,1) WRITE(IOPL) (PEAKS(I,1),PEAKS(I,2),THTCOR(I),DSPACE(I), 1 INT(PEAKS(I,4)),I=1,NPEAK) ELSE WRITE(IOPL,4090) KPSETS(5),NPEAK,PEAKS(1,1) WRITE(IOPL,9102) (PEAKS(I,1),PEAKS(I,2),THTCOR(I),DSPACE(I), 1 INT(PEAKS(I,4)),I=1,NPEAK) 9102 FORMAT(4F10.4,I2) ENDIF ENDIF C * GO TO 9900 C * C * NO PEAKS HAVE BEEN FOUND IN THIS INTERVAL.... 9200 WRITE(ITTO,9210) 9210 FORMAT(/,' ',15X,'--- No peaks detected ---') C * C * EXIT STAGE LEFT 9900 IF(KPPLOT.NE.0) CLOSE(IOPL) RETURN END C *** SRCPRM - DETERMINE PARAMETERS FOR THE SEARCH C * SUBROUTINE SRCPRM C * CHARACTER QANS*1 COMMON /LUNS/ ITTI,ITTO,IOFI,IOFO,IOBO,IOPL,IOPO,IOLO,IOSC,IOWG COMMON /REFFLG/ KPROF,KLRNZ,KERRT,KASYM,KBKGR,KBKGD,KAMOR,KCRYS COMMON /SCHDAT/ KNFND,PSIGMA,RELLOW,BIGINT,KNSMO,KFFLT,KFMNT COMMON /FLDATN/ KFILET,FBANG,FEANG,FAINC,FTIME COMMON /MODEOP/ KMODEO,KSAMEP,KAUTOP C * C ** DETERMINE WHETHER THIS IS A STANDARD SEARCH C * 2000 IF(KAUTOP.EQ.1) THEN WRITE(ITTO,2002) 2002 FORMAT(/,' Standard search parameters in use') GO TO 2100 ENDIF WRITE(ITTO,2005) 2005 FORMAT(/,' Perform standard search ? ') READ(ITTI,2010) QANS 2010 FORMAT(A1) IF( QANS.EQ.'N' .OR. QANS.EQ.'n' ) GO TO 3000 C * C ** SET THE DEFAULT PARAMETERS C * 2100 PSIGMA = 3.0 RELLOW = 0.01 IF(KBKGD.EQ.1) RELLOW = 0.000001 KFFLT = 1 KFMNT = 2 KNFND = 5 IF(FAINC.LE.0.02) KNFND = 7 IF(FAINC.LE.0.01) KNFND = 9 KNSMO = KNFND IF(KAUTOP.EQ.1) THEN PSIGMA = 5.0 RELLOW = 0.02 KNFND = KNFND + 2 KNSMO = KNSMO + 2 ENDIF GO TO 9000 C * C ** GET THE NON STANDARD PEAK SEARCH PARAMETERS C * C * SIGMA ABOVE BACKGROUND FOR ACCEPTANCE 3000 WRITE(ITTO,3005) 3005 FORMAT(/,' Sigma above background for peak acceptance ? <3.0> ') PSIGMA = 3.0 READ(ITTI,*) PSIGMA IF(PSIGMA.LE.0.0) PSIGMA = 3.0 C * C * MINIMUM RELATIVE INTENSITY DEFREL = 1.0 IF(KBKGD.EQ.1) DEFREL = 0.00001 WRITE(ITTO,3010) DEFREL 3010 FORMAT(' Minimum relative intensity accepted ? <',F5.2,'> ') RELLOW = DEFREL READ(ITTI,*) RELLOW IF(RELLOW.LE.0.0) RELLOW = DEFREL RELLOW = RELLOW / 100.0 C * C * NUMBER OF POINTS USED TO FIND PEAKS KNFND = 5 IF(FAINC.LE.0.02) KNFND = 7 IF(FAINC.LE.0.01) KNFND = 9 WRITE(ITTO,3015) KNFND 3015 FORMAT(' Number of points for peak detection ? (5-25) <',I2,'> ') NTEMP = 0 READ(ITTI,*) NTEMP IF(NTEMP.GT.0) KNFND = NTEMP KNFND = (KNFND/2) * 2 + 1 IF(KNFND.LT.5) KNFND = 5 IF(KNFND.GT.25) KNFND = 25 C * C * GET PARAMETERS FOR FILTERING TECHNIQUE C * C * GET THE TYPE OF FILTER WRITE(ITTO,3025) 3025 FORMAT(/, 1 ' Filter: 1 - Bromba/Ziegler (recursive)',/, 1 9X,'2 - Savitsky/Golay (nonrecursive)',/, 1 9X,'3 - No filtering',//, 1 ' Type of smoothing algorithm ? <1> ') KFFLT = 1 READ(ITTI,*) KFFLT IF( KFFLT.LT.1 .OR. KFFLT.GT.3 ) KFFLT = 1 C * C * SET UP THE BROMBA/ZIEGLER FILTER MOMENT KFMNT = 2 IF(KFFLT.NE.1) GO TO 3030 WRITE(ITTO,3035) 3035 FORMAT(/,' Smoothing filter moment+1 ? (1,3,5) <3> ') KFMNT = 3 READ(ITTI,*) KFMNT KFMNT = KFMNT - 1 IF( KFMNT.NE.0 .AND. KFMNT.NE.2 .AND. KFMNT.NE.4 ) KFMNT = 2 C * C * FILTER WIDTH SHOULD BE PEAK FWHM.... 3030 IF(KFFLT.GT.2) GO TO 9000 KNSMO = KNFND WRITE(ITTO,3040) KNSMO 3040 FORMAT(/,' Number of points full-width of filter ? (5-25) ', 1 ' <',I2,'> ') NTEMP = 0 READ(ITTI,*) NTEMP IF(NTEMP.GT.0) KNSMO = NTEMP KNSMO = (KNSMO/2) * 2 + 1 IF(KNSMO.LT.5) KNSMO = 5 IF(KNSMO.GT.25) KNSMO = 25 C * C * PARAMETER SETUP COMPLETE 9000 RETURN END C *** PKFIND - SLIDING SECOND ORDER POLYNOMIAL PEAK FINDER C * SUBROUTINE PKFIND C * PARAMETER ( MEMV = 32, MPTS = 2048 ) COMMON /LUNS/ ITTI,ITTO,IOFI,IOFO,IOBO,IOPL,IOPO,IOLO,IOSC,IOWG COMMON /SDATA/ KOBS,YANG(MPTS),YOBS(MPTS),YSYN(MPTS),YBKG(MPTS) COMMON /SCHDAT/ KNFND,PSIGMA,RELLOW,BIGINT,KNSMO,KFFLT,KFMNT COMMON /FLDATN/ KFILET,FBANG,FEANG,FAINC,FTIME COMMON /PEAKDT/ NPEAK,PEAKS(200,4) COMMON /SCHANG/ KBEGPT, KENDPT COMMON /DIAGS/ ISENSE(10) C * C * COMPUTE CONSTANTS FOR PEAK DETECTION 1000 MIDPNT = ( KNFND + 1 ) / 2 I02 = 0 I04 = 0 DO 1010 I=1,KNFND I02 = I02 + ( I-MIDPNT )**2 I04 = I04 + ( I-MIDPNT )**4 1010 CONTINUE NI1I02 = KNFND * I04 - I02**2 FI02 = REAL( I02 ) FI04 = REAL( I04 ) FNI1I2 = REAL( NI1I02 ) FKNFND = REAL( KNFND ) PCLOSE = FAINC * REAL( KNFND / 2 ) C * C * MINIMUM RELATIVE INTENSITY FOR FURTHER CONSIDERATION YMIN = BIGINT * RELLOW C * C * COMPUTE CONSTANTS FOR THE INTERVAL NOFFST = KNFND / 2 NSTART = KBEGPT - NOFFST IF(NSTART.LT.1) NSTART = 1 NFINIS = KOBS - KNFND + 1 NTEMP = ( NFINIS + NOFFST ) - KENDPT IF(NTEMP.GT.0) NFINIS = NFINIS - NTEMP C * 1300 DO 1310 I=NSTART,NFINIS C * C * COMPUTE INDEX POINTER, POINT UNDER CONSIDERATION. NPOINT = NOFFST + I C * C * REJECT POINT IF LOWER THAN THERESHOLD IF(YSYN(NPOINT).LT.0.0) GO TO 1310 C * C * REJECT POINT IF LOWER THAN MINIMUM INTENSITY IF(YOBS(NPOINT).LT.YMIN) GO TO 1310 C * C * COMPUTE SUMS FOR EVALUATION 1400 FJ0 = 0.0 FJ1 = 0.0 FJ2 = 0.0 DO 1410 NP=1,KNFND NPP = NP + I - 1 FACT = REAL( NP - MIDPNT ) YNPP = YSYN(NPP) FJ0 = FJ0 + YNPP FJ1 = FJ1 + FACT * YNPP FJ2 = FJ2 + FACT * ( FACT * YNPP ) 1410 CONTINUE C * C * COMPUTE COEFFICIENTS FNJJI = FKNFND * FJ2 - FJ0 * FI02 A0 = ( FJ0 * FNI1I2 - FNJJI ) / ( FKNFND * FNI1I2 ) A1 = FJ1 / ( FI02 * FAINC ) A2 = FNJJI / ( FNI1I2 * FAINC**2 ) C * C * INSURE DOWNWARDS CONCAVITY DET = A1**2 - 4.0 * A2 * A0 IF(DET.LT.0.0) GO TO 1310 C * C * CALCULATE OFFSET FROM OBSERVED MAX TO PREDICTED DELTA = -A1 / ( 2.0 * A2 + 0.000001 ) IF( ABS(DELTA) .GT. FAINC ) GO TO 1310 C * C * CONSIDER THIS A PEAK PL = YANG(NPOINT) + DELTA PI = YOBS(NPOINT) C * C * DETERMINE IF THIS IS THE HIGHEST PEAK SO FAR IF(PI.GT.BIGINT) THEN BIGINT = PI YMIN = BIGINT * RELLOW ENDIF C * C * FIND ROOTS ON BOTH SIDES OF PEAK IDIR = -1 1460 ICU = I 1462 ICU = ICU + IDIR IF(ICU.LT.NSTART) GO TO 1466 IF(ICU.GT.NFINIS) GO TO 1468 FJ0 = 0.0 FJ1 = 0.0 FJ2 = 0.0 DO 1464 NP=1,KNFND NPP = NP + ICU - 1 FACT = REAL( NP - MIDPNT ) YNPP = YSYN(NPP) FJ0 = FJ0 + YNPP FJ1 = FJ1 + FACT * YNPP FJ2 = FJ2 + FACT * ( FACT * YNPP ) 1464 CONTINUE C * COMPUTE COEFFICIENTS, IF CONCAVE DOWN TRY NEXT POINT FNJJI = FKNFND * FJ2 - FJ0 * FI02 A0 = ( FJ0 * FNI1I2 - FNJJI ) / ( FKNFND * FNI1I2 ) A1 = FJ1 / ( FI02 * FAINC ) A2 = FNJJI / ( FNI1I2 * FAINC**2 ) DET = A1**2 - 4.0 * A2 * A0 IF(DET.GE.0.0) GO TO 1462 C * CHANGE DIRECTIONS IF BACKWARDS HAS BEEN SEARCHED 1466 IF(IDIR.EQ.-1) THEN ILO = NOFFST + ( ICU + 1 ) IDIR = 1 GO TO 1460 ENDIF C * DETERMINE WIDTH 1468 IHI = NOFFST + ( ICU - 1 ) PWID = YANG(IHI) - YANG(ILO) IF(ISENSE(3).NE.0) 1WRITE(ITTO,1430) YANG(NPOINT),YANG(ILO),YANG(IHI),DELTA,PWID 1430 FORMAT(' 2THT BEG END, D2THT, WID = ',5F10.4) C * C * CHECK FOR ADJACENT PEAKS, REPLACE WITH HIGHEST IF(NPEAK.LT.1) GO TO 1440 IF( (PL-PEAKS(NPEAK,1)) .GT. PCLOSE ) GO TO 1440 IF(PI.LT.PEAKS(NPEAK,2)) GO TO 1310 PEAKS(NPEAK,1) = PL PEAKS(NPEAK,2) = PI PEAKS(NPEAK,3) = PWID GO TO 1310 C * C * THERE ARE > 200 PEAKS SO FAR, REMOVE THE LOWEST 1440 IF(NPEAK.LT.200) GO TO 1450 LOWEST = 1 DO 1455 ILOW = 2,NPEAK 1455 IF(PEAKS(ILOW,2).LT.PEAKS(LOWEST,2)) LOWEST = ILOW IF(LOWEST.EQ.NPEAK) GO TO 1472 DO 1470 ISHIFT=LOWEST,NPEAK-1 IP1 = ISHIFT + 1 PEAKS(ISHIFT,1) = PEAKS(IP1,1) PEAKS(ISHIFT,2) = PEAKS(IP1,2) PEAKS(ISHIFT,3) = PEAKS(IP1,3) 1470 CONTINUE 1472 NPEAK = NPEAK - 1 C * C * RECORD THE NEW PEAK PARAMETERS 1450 NPEAK = NPEAK + 1 PEAKS(NPEAK,1) = PL PEAKS(NPEAK,2) = PI PEAKS(NPEAK,3) = PWID PEAKS(NPEAK,4) = 1.0 C * C * NEXT POINT IN SEGMENT 1310 CONTINUE C * C * PEAK FINDING COMPLETE RETURN END C *** SETREG - SET REGIONS FOR REFINEMENT C * SUBROUTINE SETREG( ICODE ) C * PARAMETER ( MEMV = 32, MPTS = 2048 ) PARAMETER ( OVRMIN = 1.0 ) COMMON /LUNS/ ITTI,ITTO,IOFI,IOFO,IOBO,IOPL,IOPO,IOLO,IOSC,IOWG COMMON /SDATA/ KOBS,YANG(MPTS),YOBS(MPTS),YSYN(MPTS),YBKG(MPTS) COMMON /SCHDAT/ KNFND,PSIGMA,RELLOW,BIGINT,KNSMO,KFFLT,KFMNT COMMON /FLDATN/ KFILET,FBANG,FEANG,FAINC,FTIME COMMON /RFREGN/ KNUMRG,KNUMCU,REFREG(200,2) COMMON /PEAKDT/ NPEAK,PEAKS(200,4) COMMON /SCHANG/ KBEGPT, KENDPT COMMON /DIAGS/ ISENSE(10) C * C * IF ICODE=0 FIND REGIONS, ICODE=1 THEN CLEAN UP IF(ICODE.EQ.1) GO TO 5000 C * C ** FIND SEGMENT ABOVE BACKGROUND LEVEL C * 1000 N1 = KBEGPT N2 = KBEGPT C * C * FIND STARTING POINT 1010 IF(N1.GT.KENDPT) GO TO 2000 IF(YSYN(N1).GT.0.0001) GO TO 1020 N1 = N1 + 1 GO TO 1010 C * C * FIND ENDING POINT 1020 N2 = N1 + 1 1030 IF(N2.GT.KENDPT) GO TO 1040 IF(YSYN(N2).LT.0.0001) GO TO 1050 N2 = N2 + 1 GO TO 1030 C * C * FOUND END OF REGION ABOVE BACKGROUND 1050 N2 = N2 - 1 KNUMRG = KNUMRG + 1 REFREG(KNUMRG,1) = YANG(N1) REFREG(KNUMRG,2) = YANG(N2) C WRITE(ITTO,1052) YANG(N1),YANG(N2),N2-N1+1 C1052 FORMAT(' REGION FOUND: RANGE ',F8.4,' TO ',F8.4,' DEGREES, ',I4, C 1 ' POINTS') N1 = N2 + 1 GO TO 1010 C * C * END POINT OF REGION NOT WITHIN CURRENT SEGMENT 1040 N2 = N2 - 1 KNUMRG = KNUMRG + 1 REFREG(KNUMRG,1) = YANG(N1) REFREG(KNUMRG,2) = YANG(N2) C WRITE(ITTO,1042) YANG(N1),YANG(N2),N2-N1+1 C1042 FORMAT(' END OF SEGMENT HIT: RANGE ',F8.4,' TO ',F8.4,' DEGREES ', C 1 I4,' POINTS') C * C ** DETERMINE MAJOR SEGMENTS BASED ON OVRMIN DEGREE OVERLAP C * 2000 IF(KNUMRG.LT.2) GO TO 9000 NUMOLD = KNUMRG KNUMRG = 1 DO 2010 I=2,NUMOLD 2015 IF(REFREG(I,1).EQ.0.0) GO TO 9000 OVR = REFREG(I,1) - REFREG(I-1,2) IF(OVR.GT.OVRMIN) GO TO 2020 C * COMBINE REGION AND COMPRESS LIST REFREG(KNUMRG,1) = REFREG(I-1,1) REFREG(KNUMRG,2) = REFREG(I ,2) IF(I.LT.NUMOLD) THEN DO 2030 J=I+1,NUMOLD REFREG(J-1,1) = REFREG(J,1) REFREG(J-1,2) = REFREG(J,2) 2030 CONTINUE ENDIF REFREG(NUMOLD,1) = 0.0 REFREG(NUMOLD,2) = 0.0 GO TO 2015 C * COPY REGION 2020 KNUMRG = KNUMRG + 1 REFREG(KNUMRG,1) = REFREG(I,1) REFREG(KNUMRG,2) = REFREG(I,2) 2010 CONTINUE GO TO 9000 C * C ** FINAL CLEAN UP. REGIONS MUST HAVE LINES. C * 5000 WRITE(ITTO,5002) 5002 FORMAT(/,' * Regions for refinement will be as follows:',/) NUMOLD = KNUMRG KNUMRG = 0 DO 5010 I=1,NUMOLD LINES = 0 DO 5020 J=1,NPEAK 5020 IF( PEAKS(J,1).GE.REFREG(I,1) .AND. PEAKS(J,1).LE.REFREG(I,2) ) 1 LINES = LINES + 1 IF(LINES.EQ.0) GO TO 5010 KNUMRG = KNUMRG + 1 REFREG(KNUMRG,1) = REFREG(I,1) REFREG(KNUMRG,2) = REFREG(I,2) NPTS = NINT( (REFREG(KNUMRG,2)-REFREG(KNUMRG,1))/FAINC ) + 1 WRITE(ITTO,5030) REFREG(I,1),REFREG(I,2),NPTS,LINES 5010 CONTINUE 5030 FORMAT(' Region ',F8.4,' to ',F8.4,' Points ',I4,' Lines ',I3) C * C * REGION SETUP COMPLETE 9000 RETURN END C ** SRPLOT - SET UP PLOT FILE FOR SEARCH PHASE C * SUBROUTINE SRPLOT( STRT, FINS ) C * CHARACTER QTITLS(5)*20, QFILE*32, QANS*1, QFTITL*80 COMMON /LUNS/ ITTI,ITTO,IOFI,IOFO,IOBO,IOPL,IOPO,IOLO,IOSC,IOWG COMMON /FLDATN/ KFILET,FBANG,FEANG,FAINC,FTIME COMMON /PLTDAT/ KPPLOT,KPSETS(5),KPTYPE,KPTDEF COMMON /MODEOP/ KMODEO,KSAMEP,KAUTOP COMMON /FLDATC/ QFTITL DIMENSION NCPLOT(5),OFFSET(5),NUMPEN(5),MARKER(5) DATA QTITLS(1)/'Observed pattern '/ DATA QTITLS(2)/'Bkg corr pattern '/ DATA QTITLS(3)/'Threshold level '/ DATA QTITLS(4)/'Filtered pattern '/ DATA QTITLS(5)/'Peak location marker'/ C * 1000 KPPLOT = 0 DO 1010 I=1,5 KPSETS(I) = 0 NCPLOT(I) = 0 OFFSET(I) = 0.0 NUMPEN(I) = 0 MARKER(I) = 0 1010 CONTINUE C * C * DETERMINE WHETHER A PLOTTING FILE IS TO BE GENERATED IF(KAUTOP.NE.1) THEN WRITE(ITTO,1020) 1020 FORMAT(/,' Produce plotting from the search phase ? ') READ(ITTI,1030) QANS 1030 FORMAT(1A1) ELSE QANS = 'Y' ENDIF IF( QANS.EQ.'Y' .OR. QANS.EQ.'y' ) KPPLOT = 1 IF(KPPLOT.EQ.0) GO TO 9000 C * C * GET THE OUTPUT FILE NAME AND OPEN IT 1035 IF(KAUTOP.NE.1) THEN WRITE(ITTO,1040) 1040 FORMAT(' Plot file name ? ') READ(ITTI,1050) QFILE 1050 FORMAT(A32) ELSE QFILE = 'SPLOT' WRITE(ITTO,1051) QFILE 1051 FORMAT(/,' Plot data written to: ',A32) ENDIF IF( QFILE(1:1).EQ.'$' .AND. KPTYPE.EQ.0 ) THEN WRITE(ITTO,1052) 1052 FORMAT(' -Plot file type changed to formatted') KPTYPE = 1 QFILE(1:) = QFILE(2:) ENDIF IF( QFILE(1:1).EQ.'$' .AND. KPTYPE.EQ.1 ) THEN WRITE(ITTO,1054) 1054 FORMAT(' -Plot file type changed to unformatted') KPTYPE = 0 QFILE(1:) = QFILE(2:) ENDIF IF( QFILE.EQ.' ' .OR. QFILE.EQ.'/' ) QFILE = 'SPLOT' IF(KPTYPE.EQ.0) THEN OPEN(UNIT=IOPL,FILE=QFILE,STATUS='UNKNOWN',FORM='UNFORMATTED', 1 ERR=1060) ELSE OPEN(UNIT=IOPL,FILE=QFILE,STATUS='UNKNOWN',FORM='FORMATTED', 1 ERR=1060) ENDIF GO TO 2000 1060 WRITE(ITTO,1070) 1070 FORMAT(' --Can not open specified plot file') GO TO 1035 C * C * USE DEFAULT PARAMS OR SET THEM INDIVIDUALLY.... C * 2000 IF(KAUTOP.NE.1) THEN WRITE(ITTO,2010) 2010 FORMAT(' Do you want the default plot package ? ') READ(ITTI,1030) QANS ELSE QANS = 'Y' WRITE(ITTO,2012) 2012 FORMAT(' Default plot parameters used') ENDIF IF( QANS.EQ.'N' .OR. QANS.EQ.'n' ) GO TO 2100 C * C * SET DEFAULT PARAMETERS C * NUMSTS = 3 C * KPSETS(1) = 1 NCPLOT(1) = 1 OFFSET(1) = 0.0 NUMPEN(1) = 2 MARKER(1) = 0 C * KPSETS(2) = 0 NCPLOT(2) = 0 OFFSET(2) = 0.0 NUMPEN(2) = 0 MARKER(2) = 0 C * KPSETS(3) = 2 NCPLOT(3) = 10 OFFSET(3) = 0.0 NUMPEN(3) = 3 MARKER(3) = 0 C * KPSETS(4) = 0 NCPLOT(4) = 0 OFFSET(4) = 0.0 NUMPEN(4) = 0 MARKER(4) = 0 C * KPSETS(5) = 3 NCPLOT(5) = 1 OFFSET(5) = 0.0 NUMPEN(5) = 4 MARKER(5) = 2 C * NPLOTS = 1 IAXIS = 0 FS = 1200.0 DPI = 2. GO TO 3000 C * C * TELL THEM HOW ITS DONE 2100 NUMSTS = 0 WRITE(ITTO,2115) 2115 FORMAT(/,' The following questions pertain to plotting of the', 1 ' search results.',/,' Enter <+N,0 or -N> for plotting of every', 1 ' Nth point in the data set',//, 1 3X,' +N => Draw lines between each Nth point',/, 1 3X,' 0 => Skips the data set.',/, 1 3X,' -N => Draw dots at each Nth point',//, 1 ' Follow N with a value for the offset (in inches) to', 1 ' separate',/,' the data groups. e.g., .75 displaces the data', 1 ' set .75 inches.',//, 1 ' The final parameter specifies the pen to use in plotting', 1 ' the data set') C * C * RAW PATTERN KPSETS(1) = 0 NCPLOT(1) = 0 OFFSET(1) = 0.0 NUMPEN(1) = 0 MARKER(1) = 0 WRITE(ITTO,2120) 2120 FORMAT(/,' Raw data ? <0,0.0,0> ') READ(ITTI,*) NCPLOT(1),OFFSET(1),NUMPEN(1) IF(NCPLOT(1).NE.0) THEN NUMSTS = NUMSTS + 1 KPSETS(1) = NUMSTS ENDIF C * C * THRESHOLD CORRECTED PATTERN KPSETS(2) = 0 NCPLOT(2) = 0 OFFSET(2) = 0.0 NUMPEN(2) = 0 MARKER(2) = 0 WRITE(ITTO,2140) 2140 FORMAT(' Threshold corrected data ? <0,0.0,0> ') READ(ITTI,*) NCPLOT(2),OFFSET(2),NUMPEN(2) IF(NCPLOT(2).NE.0) THEN NUMSTS = NUMSTS + 1 KPSETS(2) = NUMSTS ENDIF C * C * THE THRESHOLD LEVEL KPSETS(3) = 0 NCPLOT(3) = 0 OFFSET(3) = 0.0 NUMPEN(3) = 0 MARKER(3) = 0 WRITE(ITTO,2150) 2150 FORMAT(' Threshold level ? <0,0.0,0> ') READ(ITTI,*) NCPLOT(3),OFFSET(3),NUMPEN(3) IF(NCPLOT(3).NE.0) THEN NUMSTS = NUMSTS + 1 KPSETS(3) = NUMSTS ENDIF C * C * THE FILTERED PATTERN KPSETS(4) = 0 NCPLOT(4) = 0 OFFSET(4) = 0.0 NUMPEN(4) = 0 MARKER(4) = 0 WRITE(ITTO,2160) 2160 FORMAT(' Smoothed data ? <0,0.0,0> ') READ(ITTI,*) NCPLOT(4),OFFSET(4),NUMPEN(4) IF(NCPLOT(4).NE.0) THEN NUMSTS = NUMSTS + 1 KPSETS(4) = NUMSTS ENDIF C * C * PEAK LOCATION MARKERS KPSETS(5) = 0 NCPLOT(5) = 0 OFFSET(5) = 0.0 NUMPEN(5) = 0 MARKER(5) = 2 WRITE(ITTO,2170) 2170 FORMAT(' Peak location markers ? <0,0.0,0> ') READ(ITTI,*) NCPLOT(5),OFFSET(5),NUMPEN(5) IF(NCPLOT(5).NE.0) THEN NCPLOT(5) = 1 NUMSTS = NUMSTS + 1 KPSETS(5) = NUMSTS ENDIF C * C * THE AXIS INFORMATION C * WRITE(ITTO,2265) 2265 FORMAT(/,' Number of plots per page ? (1 OR 2) <1> ') READ(ITTI,*) NPLOTS IF(NPLOTS.EQ.0) NPLOTS = 1 IF( NPLOTS.LT.-2 .OR. NPLOTS.GT.2 ) NPLOTS = 1 DPI = 2.0 IF(NPLOTS.LT.0) THEN WRITE(ITTO,2266) 2266 FORMAT(' Degrees per inch for two-theta axis ? <2.0> ') READ(ITTI,*) DPI IF(DPI.LE.0.0) DPI = 2.0 ENDIF WRITE(ITTO,2270) 2270 FORMAT(' Draw the axis system ? ') READ(ITTI,1030) QANS IAXIS = 0 IF( QANS.EQ.'N' .OR. QANS.EQ.'n' ) IAXIS = 1 WRITE(ITTO,2280) 2280 FORMAT(' Full scale value for plot ? <1200.0> ') FS = 1200.0 READ(ITTI,*) FS IF(FS.LE.0.0) FS = 1200.0 C * C * WRITE THE INITIAL INFORMATION TO THE PLOT FILE 3000 KYID = 0 IF(KPTYPE.EQ.0) THEN WRITE(IOPL) QFTITL WRITE(IOPL) STRT,FINS,FAINC WRITE(IOPL) NUMSTS,NPLOTS,IAXIS,DPI,FS,KYID DO 3010 I=1,5 IF(KPSETS(I).EQ.0) GO TO 3010 WRITE(IOPL) QTITLS(I),NCPLOT(I),OFFSET(I),NUMPEN(I),MARKER(I) 3010 CONTINUE ELSE WRITE(IOPL,3020) QFTITL 3020 FORMAT(A80) WRITE(IOPL,3030) STRT,FINS,FAINC 3030 FORMAT(3F10.4) WRITE(IOPL,3040) NUMSTS,NPLOTS,IAXIS,DPI,FS,KYID 3040 FORMAT(3I6,F6.2,2I6) DO 3050 I=1,5 IF(KPSETS(I).EQ.0) GO TO 3050 WRITE(IOPL,3060) QTITLS(I),NCPLOT(I),OFFSET(I),NUMPEN(I), 1 MARKER(I) 3060 FORMAT(A20,I6,F6.2,2I6) 3050 CONTINUE ENDIF C * C * THATS IT 9000 RETURN END C *** DGFILT - DIGITAL FILTERING C * C * ALGORITHM ADAPTED FROM: C * C * M. U. A. BROMBA AND H. ZIEGLER, ANAL CHEMISTRY, C * VOL. 51, NO. 11 SEPTEMBER 1979 C * C * CODED BY: S.A. HOWARD C * UNIVERSITY OF MISSOURI- ROLLA C * C * YOBS - INPUT DATA ARRAY TO BE SMOOTHED C * DTOUT - OUTPUT SMOOTHED DATA ARRAY C * NDATA - NUMBER OF DATA POINTS IN ARRAYS C * M - FILTER MOMENT: 0, 2 OR 4 ORDER C * NF - FULL WIDTH OF SMOOTHING FILTER C * SUBROUTINE DGFILT( M, NF ) C * PARAMETER ( MEMV = 32, MPTS = 2048 ) COMMON /SDATA/ KOBS,YANG(MPTS),YOBS(MPTS),YSYN(MPTS),YBKG(MPTS) COMMON /COMSCR/ IK(MPTS), IL(MPTS) C * C * APPLY THE DIGITAL FILTER TO THE DATA C * C * CALCULATE THE NORMALIZING INTEGER DENOMINATORS AND STARTING PTS 1700 N = NF / 2 NT2 = N * 2 IF(M.EQ.0) THEN IMULT = NT2 + 1 KSTART = N + 1 + 1 ENDIF IF(M.EQ.2) THEN IMULT = (NT2-1) * (NT2+1) * (NT2+3) / 3 KSTART = N + 3 + 1 ENDIF IF(M.EQ.4) THEN IMULT = 4 * (NT2-3)*(NT2-1)*(NT2+1)*(NT2+3)*(NT2+5) / 15 KSTART = N + 5 + 1 ENDIF C * C * COMPUTE LIMITS OF FILTER APPLICATION TO DATA ARRAY KINIT = KSTART + N KEND = KOBS - N C * C * MOVE DATA INTO INTEGER ARRAY DO 1710 K=1,KOBS 1710 IK(K) = NINT( YOBS(K) ) C * C * INITIALIZE THE FILTER IKK = IK(KINIT) ILL = IKK * IMULT DO 1715 K=1,KINIT-1 IK(K) = IKK IL(K) = ILL 1715 CONTINUE IL(KINIT) = ILL C * C * APPLY THE DIGITAL FILTER TO THE DATA IF(M.EQ.2) GO TO 1730 IF(M.EQ.4) GO TO 1740 C * C * APPLY ZERO ORDER FILTER 1720 DO 1725 K=KSTART,KEND 1725 IL(K) = IL(K-1) + ( IK(K+N) - IK(K-N-1) ) GO TO 1750 C * C * APPLY SECOND ORDER FILTER 1730 NT2M1 = NT2 - 1 NM1 = N - 1 NT2P3 = NT2 + 3 NP2 = N + 2 N0 = NT2M1 * NM1 N1 = NT2P3 * NT2M1 N2 = NT2P3 * NP2 DO 1735 K=KSTART,KEND I1 = IL(K-3) I2 = 3 * ( IL(K-2) - IL(K-1) ) I3 = N0 * ( IK(K+N) - IK(K-N-3) ) I4 = N1 * ( IK(K+N-1) - IK(K-N-2) ) I5 = N2 * ( IK(K+N-2) - IK(K-N-1) ) IL(K) = I1 - I2 - I3 + I4 - I5 1735 CONTINUE GO TO 1750 C * C * APPLY FOURTH ORDER FILTER 1740 NT2M1 = NT2 - 1 NT2M3 = NT2 - 3 NM2 = N - 2 NM1 = N - 1 NT2P5 = NT2 + 5 NT2M4 = NT2 - 4 NT2S6N = 6 * N * N + 6 * N - 22 NT2P6 = NT2 + 6 NT2P3 = NT2 + 3 NP3 = N + 3 NP2 = N + 2 N0 = NT2M1 * NT2M3 * NM2 * NM1 * 2 N1 = NT2P5 * NT2M1 * NT2M3 * NT2M4 * 2 N2 = NT2P5 * NT2M3 * NT2S6N * 2 N3 = NT2P6 * NT2P5 * NT2P3 * NT2M3 * 2 N4 = NT2P5 * NT2P3 * NP3 * NP2 * 2 DO 1745 K=KSTART,KEND I1 = IL(K-5) I2 = 5 * ( IL(K-4) - IL(K-1) ) I3 = 10 * ( IL(K-3) - IL(K-2) ) I4 = N0 * ( IK(K+N) - IK(K-N-5) ) I5 = N1 * ( IK(K+N-1) - IK(K-N-4) ) I6 = N2 * ( IK(K+N-2) - IK(K-N-3) ) I7 = N3 * ( IK(K+N-3) - IK(K-N-2) ) I8 = N4 * ( IK(K+N-4) - IK(K-N-1) ) IL(K) = I1 - I2 + I3 + I4 - I5 + I6 - I7 + I8 1745 CONTINUE C * C * COMPUTE SMOOTHED VALUES... ONLY IN SMOOTHED REGION 1750 FMULT = 1.0 / REAL( IMULT ) DO 1760 K=KSTART,KEND 1760 YSYN(K) = REAL( IL(K) ) * FMULT C * C * FILL GAPS AT BEGINING AND END OF SMOOTHED INTERVAL DO 1770 K=1,KINIT 1770 YSYN(K) = YOBS(K) DO 1780 K=KEND+1,KOBS 1780 YSYN(K) = YOBS(K) C * C * RETURN... DATA FILTERED 1900 RETURN END SUBROUTINE SVGOLY( NSMO, INDEX ) C C C PROGRAMMER: C.L. MALLORY C ALFRED UNIVERSITY C C ROUTINE TO PERFORM A SMOOTHING FUNCTION AS DESCRIBED BY C SAVITZKY AND GOLAY, ANAL. CHEM., VOL36, 8, 1627 (1964) AND AS MODIFIED C STEINIER, TREMONIA, AND DELTOUR, ANAL. CHEM., VOL44, 11, 1909 (1972) C C NOTE ** IT WILL ONLY PERFORM THE 2ND & 3RD SMOOTH AND THE 2ND & 3RD D C SINCE THAT IS ALL I PLUGGED INTO THE MACHINE. C C ARGUMENT DEFINITION: C YRAW - RAW DATA ARRAY. C YSMO - RETURNED, EITHER SMOOTHED OR DERIV. DATA. C NPTS - THE NUMBER OF POINTS IN THE YRAW ARRAY C NSMO - THE NUMBER OF POINTS TO USE IN SMOOTHING, ODD. C INDEX - INDICATION OF WHAT IS TO BE PERFORMED. C 0 - PERFORM THE SMOOTHING FUNCTION. C 1 - PERFORM THE DERIVATIVE FUNCTION. C C C VARIABLE DEFINITION: C ICON - ARRAY HOLDING THE CONVOLUTING INTEGERS USED IN SMOOTHING. C ID2 - ARRAY HOLDING THE SECOND DERIVATIVE CONVOLUTING INTEGERS. C RNORMS - ARRAY HOLDING THE VALUES OF THE SMOOTHING NORM. C RNORMD - ARRAY HOLDING THE VALUES OF THE DERIVATIVE NORM. C PARAMETER ( MEMV = 32, MPTS = 2048 ) COMMON /SDATA/ KOBS,YANG(MPTS),YOBS(MPTS),YSYN(MPTS),YBKG(MPTS) DIMENSION ICON(13,11),ID2(13,11),RNORMS(11),RNORMD(11) C DATA ICON/-3,12,17,0,0,0,0,0,0,0,0,0,0, 1 -2,3,6,7,0,0,0,0,0,0,0,0,0, 1 -21,14,39,54,59,0,0,0,0,0,0,0,0, 1 -36,9,44,69,84,89,0,0,0,0,0,0,0, 1 -11,0,9,16,21,24,25,0,0,0,0,0,0, 1 -78,-13,42,87,122,147,162,167,0,0,0,0,0, 1 -21,-6,7,18,27,34,39,42,43,0,0,0,0, 1 -136,-51,24,89,144,189,224,249,264,269,0,0,0, 1 -171,-76,9,84,149,204,249,284,309,324,329,0,0, 1 -42,-21,-2,15,30,43,54,63,70,75,78,79,0, 1 -253,-138,-33,62,147,222,287,343,387,422,447,462,467/ C DATA ID2/2,-1,-2,0,0,0,0,0,0,0,0,0,0, 1 5,0,-3,-4,0,0,0,0,0,0,0,0,0, 1 28,7,-8,-17,-20,0,0,0,0,0,0,0,0, 1 15,6,-1,-6,-9,-10,0,0,0,0,0,0,0, 1 22,11,2,-5,-10,-13,-14,0,0,0,0,0,0, 1 91,52,19,-8,-29,-44,-53,-56,0,0,0,0,0, 1 40,25,12,1,-8,-15,-20,-23,-24,0,0,0,0, 1 51,34,19,6,-5,-14,-21,-26,-29,-30,0,0,0, 1 190,133,82,37,-2,-35,-62,-83,-98,-107,-110,0,0, 1 77,56,37,20,5,-8,-19,-28,-35,-40,-43,-44,0, 1 92,69,48,29,12,-3,-16,-27,-36,-43,-48,-51,-52/ C DATA RNORMS/35.,21.,231.,429.,143.,1105.,323., 1 2261.,3059.,805.,5175./ C DATA RNORMD/7.,42.,462.,429.,1001.,6188.,3876.,6783., 1 33649.,17710.,26910./ C C THE PROGRAM CAN ONLY HANDLE FROM A 5 TO 25 POINT SMOOTH. C MAKE SURE THAT THE NUMBERS ARE INSIDE THESE LIMITS. C ALSO MAKE THE NUMBER AN ODD NUMBER IF IT ISN'T. NPT = (NSMO/2) * 2 + 1 IF(NPT.LT. 5) NPT = 5 IF(NPT.GT.25) NPT = 25 C * C GENERATE ARRAY POINTERS. N = NPT / 2 N1 = N - 1 N2 = N + 1 K = NPT - 1 NPNT = N + 1 NFINI = KOBS - 2 * N C * C PERFORM THE DESIRED FUNCTION. IF(INDEX.EQ.1) GO TO 20 C * C SMOOTH THE DATA. DO 10 INDY =1,NFINI K = NPT - 1 SUM = 0.0 DO 15 I=1,N IP = INDY + I - 1 SUM = SUM + ICON(I,N1) * ( YOBS(IP) + YOBS(IP+K) ) K = K - 2 15 CONTINUE YSYN(NPNT) = ( SUM + ICON(N2,N1) * YOBS(IP+N2) ) / RNORMS(N1) NPNT = NPNT + 1 10 CONTINUE GO TO 30 C * C PERFORM THE DERIVATIVE FUNCTION. 20 DO 21 INDY=1,NFINI K = NPT - 1 SUM = 0.0 DO 25 I=1,N IP = INDY + I - 1 SUM = SUM + ID2(I,N1) * ( YOBS(IP) + YOBS(IP+K) ) K = K - 2 25 CONTINUE YSYN(NPNT) = ( SUM + ID2(N2,N1) * YOBS(IP+N2) ) / RNORMD(N1) NPNT = NPNT + 1 21 CONTINUE C * C * THATS IT... 30 RETURN END