source: trunk/fsource/powsubs/psvoigt.for @ 210

Last change on this file since 210 was 210, checked in by vondreele, 12 years ago

un fix includes

File size: 2.4 KB
Line 
1      SUBROUTINE PSVOIGT(DX,SIG,GAM,FUNC,DFDX,DFDS,DFDG)
2
3!PURPOSE: Compute function & derivatives pseudovoigt
4!pseudo Voigt P.Tompson, D.E. Cox & J.B. Hastings (1987). J. Appl. Cryst.,20,79-83
5
6      INCLUDE       '../INCLDS/COPYRIGT.FOR' 
7
8!PSEUDOCODE:
9
10!CALLING ARGUMENTS:
11
12      REAL*4        DX                  !Delta-x from center
13      REAL*4        SIG                 !Gaussian variance
14      REAL*4        GAM                 !Lorentzian FWHM
15      REAL*4        FUNC                !Value of pseudo-Voigt at DX
16      REAL*4        DFDX                !dF/dx
17      REAL*4        DFDS                !dF/ds
18      REAL*4        DFDG                !dF/dg
19
20!INCLUDE STATEMENTS:
21
22!LOCAL VARIABLES:
23
24      REAL*4        COFG(6),COFL(6)     !Linear combination coeffs
25      REAL*4        ACOFG(7),ACOFL(7)   
26      REAL*4        GNORM               !Gaussian Normalization constant
27      REAL*4        COFT(6),COFN(3)     
28
29!SUBROUTINES CALLED:
30
31!FUNCTION DEFINITIONS:
32
33!DATA STATEMENTS:
34
35      DATA STOFW/2.35482005/            !2*SQRT(2LN2)
36      DATA SQ2PI/2.506628275/            !SQRT(2PI)
37      DATA COFT/1.0,2.69269,2.42843,4.47163,0.07842,1.0/
38      DATA COFN/1.36603,-0.47719,0.11116/
39      DATA ITYPE/1/
40
41!CODE:
42
43      SQSG = MAX(SQRT(SIG),0.001)
44      FWHG = STOFW*SQSG
45      PGL = FWHG**5
46      SUMHM = PGL
47      DSDL = 0.0
48      DSDG = 0.0
49      DO ITRM=1,5
50        PGL = PGL/FWHG
51        DSDL = DSDL+FLOAT(ITRM)*COFT(ITRM+1)*PGL
52        DSDG = DSDG+FLOAT(6-ITRM)*COFT(ITRM)*PGL
53        PGL = PGL*GAM
54        SUMHM = SUMHM+COFT(ITRM+1)*PGL
55      END DO
56      FWHM = EXP(0.2*LOG(SUMHM))
57      FRAC = GAM/FWHM
58      DEDF = 0.0
59      PF = 1.0
60      ETA = 0.0
61      DO ITRM=1,3
62        DEDF = DEDF+FLOAT(ITRM)*COFN(ITRM)*PF
63        PF = PF*FRAC
64        ETA = ETA+COFN(ITRM)*PF
65      END DO
66      CALL LORENTZ(DX,FWHM,TL,DTLDT,DTLDFW)
67      SIGP = (FWHM/STOFW)**2
68      EX = MAX(-20.0,-0.5*DX**2/SIGP)
69      TG = STOFW*EXP(EX)/(SQ2PI*FWHM)
70      FUNC = ETA*TL+(1.0-ETA)*TG
71
72      TS = -2.0*(1.0-ETA)*TG*(EX+0.5)/FWHM
73      DFDX = ETA*DTLDT-(1.0-ETA)*TG*DX/SIGP
74
75      DFWDG = 0.2*DSDG*FWHM/SUMHM
76      DFRDG = -FRAC*DFWDG/FWHM
77      DFDS = DEDF*DFRDG*(TL-TG)+(ETA*DTLDFW+TS)*DFWDG
78      DFDS = 0.5*DFDS*STOFW/SQSG
79
80      DFWDL = 0.2*DSDL*FWHM/SUMHM
81      DFRDL = (1.0-FRAC*DFWDL)/FWHM
82      DFDG = DEDF*DFRDL*(TL-TG)+(ETA*DTLDFW+TS)*DFWDL
83
84      RETURN
85      END
Note: See TracBrowser for help on using the repository browser.