source: trunk/fsource/pydiffax.for @ 2197

Last change on this file since 2197 was 2197, checked in by vondreele, 6 years ago

replace pyd files for binwin2.7 & binwin64-2.7
implement new pyGetSpc routine for PWDR simulations - checked against DIFFaX
Add a transition probability normalizer button
change transition plots from DCLICK to CLICK - much nicer
invoke G2frame.G2plotNB.RaisePageNoRefresh?(Page) in a number of places to get plots to appear on demand
fix layer plotting issues after normal structure plots made

File size: 9.6 KB
Line 
1      SUBROUTINE PYLOADSCF(NATP,ATYPES,SFDAT)
2       
3Cf2py intent(in) NATP
4Cf2py intent(in) ATYPES
5Cf2py intent(in) SFDAT
6cf2py depend(NATP) ATYPES,SFDAT
7           
8      INCLUDE 'DIFFaXsubs/DIFFaX.par'
9      INCLUDE 'DIFFaXsubs/DIFFaX.inc'
10               
11      INTEGER*4 NATP,I,J
12      CHARACTER*4 ATYPES(NATP)
13      REAL*4  SFDAT(9,NATP)
14               
15C fill common x-ray scattering factors
16      debug = .FALSE.
17      DO J=1,NATP
18        WRITE(atom_l(J),'(A4)') ATYPES(J)
19        DO I=1,9
20          x_sf(I,J) = SFDAT(I,J)
21        END DO
22        if (debug) print '(1x,a4,9f10.6)',ATYPES(J),(x_sf(I,J),I=1,9)
23      END DO
24      intp_F = .TRUE.
25      n_atoms = NATP
26      RETURN
27      END
28       
29      SUBROUTINE PYGETINST(LAMB,TTHMIN,TTHMAX,DELTTH)
30       
31Cf2py intent(in) LAMB
32Cf2py intent(in) TTHMIN
33Cf2py intent(in) TTHMAX
34Cf2py intent(in) DELTTH
35   
36      INCLUDE 'DIFFaXsubs/DIFFaX.par'
37      INCLUDE 'DIFFaXsubs/DIFFaX.inc'
38
39      REAL*8 LAMB,TTHMIN,TTHMAX,DELTTH
40       
41      lambda = lamb
42      th2_min = TTHMIN*DEG2RAD
43      th2_max = TTHMAX*DEG2RAD
44      d_theta = DELTTH*HALF*DEG2RAD
45       
46      RETURN
47      END
48       
49      SUBROUTINE PYGETCLAY(CNTRLS,LAUESYM,WDTH,NST,STSEQ)
50       
51Cf2py intent(in) CNTRLS
52Cf2py intent(in) LAUESYM
53Cf2py intent(in) WDTH
54Cf2py intent(in) NST
55Cf2py intent(in) STSEQ
56cf2py depend(NST) STSEQ
57     
58      INCLUDE 'DIFFaXsubs/DIFFaX.par'
59      INCLUDE 'DIFFaXsubs/DIFFaX.inc'
60
61      CHARACTER*12 LAUESYM
62      INTEGER*4 CNTRLS(7),NST,STSEQ(NST),I
63      REAL*8 WDTH(2)                 
64      LOGICAL*4 ok,GETLAY
65      EXTERNAL GETLAY
66                                     
67      PI = FOUR * atan(ONE)
68      PI2 = TWO * PI
69      DEG2RAD = PI / ONE_EIGHTY
70      RAD2DEG = ONE_EIGHTY / PI
71      rad_type = X_RAY
72      lambda = 0.1
73      trim_origin = .TRUE.
74      blurring = NONE
75      loglin = 1
76      tolerance = 0.01
77      finite_width = .TRUE.
78      Wa = WDTH(1)*10000.
79      Wb = WDTH(2)*10000.
80      IF (Wa.GE.10000.) finite_width = .FALSE.
81      WRITE(pnt_grp,'(A12)') LAUESYM
82      SymGrpNo = CNTRLS(1)
83      check_sym = .TRUE.
84      full_shrp = 1
85      full_brd = 1
86C CNTRLS = [laueId,planeId,lmax,mult,StkType,StkParm,ranSeed]
87      bitdepth = 16
88      ok = .TRUE.
89      scaleint = FLOAT(CNTRLS(4))
90C fill in stacking seq stuff                 
91      IF (CNTRLS(5).NE.0) THEN
92        xplcit = .TRUE.
93        recrsv = .FALSE.
94        IF (CNTRLS(6).EQ.1) THEN
95            rndm = .TRUE.
96        ELSE
97            rndm = .FALSE.
98            l_cnt = NST
99            DO I=1,NST
100              l_seq(I) = STSEQ(I)
101            END DO       
102        END IF   
103      ELSE
104        recrsv = .TRUE.
105        xplcit = .FALSE.
106        IF (CNTRLS(6).NE.0) THEN
107            l_cnt = CNTRLS(6)
108            inf_thick = .FALSE.
109        ELSE
110            inf_thick = .TRUE.
111        END IF
112      END IF
113      IF (rndm) ok = GETLAY()
114      RETURN
115      END
116           
117      SUBROUTINE PYCELLAYER(CELL,NATM,ATMTP,ATMXOU,NU,LSYM,NL,LNUM)
118                   
119Cf2py intent(in) CELL
120Cf2py intent(in) NATM
121Cf2py intent(in) ATMTP
122Cf2py intent(in) ATMXOU
123cf2py depend(NATM) ATMTP,ATMXOU
124Cf2py intent(in) NU
125Cf2py intent(in) LSYM
126Cf2py depend(NU) LSYM
127Cf2py intent(in) NL
128Cf2py intent(in) LNUM
129Cf2py depend(NL) LNUM
130                       
131      INCLUDE 'DIFFaXsubs/DIFFaX.par'
132      INCLUDE 'DIFFaXsubs/DIFFaX.inc'
133
134      INTEGER*4 NATM,NL,LNUM(NL),NU,LSYM(NU)
135      CHARACTER*4 ATMTP(NATM)
136      REAL*8  CELL(4),ATMXOU(8,NATM)
137      INTEGER*4 I,J,K,IL,IA
138
139C fill Common - cell stuff & finish symmetry stuff
140      cell_a = CELL(1)
141      cell_b = CELL(2)
142      cell_c = CELL(3)
143      cell_gamma = CELL(4)*DEG2RAD
144C fill common layer stuff - atoms & symm
145      DO I=1,NATM
146        IL = NINT(ATMXOU(1,I))
147        IA = NINT(ATMXOU(2,I))       
148        a_type(IA,IL) = NINT(ATMXOU(3,I))
149        a_number(IA,IL) = IA
150        WRITE(a_name(IA,IL),'(A4)') ATMTP(I)
151        DO K=1,3
152            a_pos(K,IA,IL) = ATMXOU(K+3,I)
153        END DO
154        high_atom(IL) = max(high_atom(IL),a_pos(3,IA,IL))
155        low_atom(IL) = min(low_atom(IL),a_pos(3,IA,IL))
156        IF (LSYM(IL).EQ.CENTRO) THEN
157            high_atom(IL) = MAX(high_atom(IL),-a_pos(3,IA,IL))
158            low_atom(IL) = MIN(low_atom(IL),-a_pos(3,IA,IL))
159        END IF
160        a_occup(IA,IL) = ATMXOU(7,I)
161        a_B(IA,IL) = ATMXOU(8,I)
162        l_n_atoms(IL) = IA
163        l_symmetry(IL) = LSYM(IL)
164      END DO
165      n_actual = IL
166      n_layers = NL
167      DO I=1,NL
168        l_actual(I) = LNUM(I)
169        DO J=1,NL
170            Bs_zero(J,I) = .TRUE.
171        END DO
172      END DO
173      all_Bs_zero = .TRUE.
174      RETURN
175      END
176
177      SUBROUTINE PYGETTRANS(NL,TRP,TRX)
178     
179Cf2py intent(in) NL
180Cf2py intent(in) TRP
181Cf2py intent(in) TRX
182Cf2py depend(NL) TRP,TRX
183     
184     
185      INCLUDE 'DIFFaXsubs/DIFFaX.par'
186      INCLUDE 'DIFFaXsubs/DIFFaX.inc'
187       
188      INTEGER*4 I,J,K
189      INTEGER*4 NL
190      REAL*4  TRP(NL,NL),TRX(NL,NL,3)
191                               
192C fill common transitions stuff
193      DO J=1,NL
194        DO I=1,NL
195          l_alpha(J,I) = TRP(I,J)
196          DO K=1,3
197            l_r(K,J,I) = TRX(I,J,K)
198          END DO
199        END DO
200      END DO
201      RETURN
202      END
203       
204      SUBROUTINE PYGETSPC(CNTRLS,NSADP,SADP)
205       
206Cf2py intent(in) CNTRLS
207Cf2py intent(in) NSADP
208Cf2py intent(in/out) SADP
209Cf2py depend(NSADP) SADP
210           
211      INCLUDE 'DIFFaXsubs/DIFFaX.par'
212      INCLUDE 'DIFFaXsubs/DIFFaX.inc'
213
214      INTEGER*4 CNTRLS(7),NSADP,I,j,k
215      REAL*8 SADP(NSADP),AGLQ16
216      LOGICAL GETSPC,ok
217       
218      EXTERNAL AGLQ16,GETSPC
219
220
221C      print *,n_actual,(l_n_atoms(i),i=1,n_actual)
222C      do j=1,n_actual
223C        do i=1,l_n_atoms(j)
224C          print *,a_name(i,j),(a_pos(k,i,j),k=1,3)
225C        end do
226C      end do
227c      print *, recrsv,inf_thick,xplcit,rndm,l_cnt,has_l_mirror
228C      do i=1,n_layers
229C      print *,' layer',i
230C         do j=1,n_layers
231C            print *,'layer',j,l_alpha(i,j),(l_r(k,i,j),k=1,3)
232C         end do
233C      end do
234c      print *,cell_a,cell_b,cell_c,cell_gamma,pnt_grp,SymGrpNo
235c      DoSymDump = .TRUE.
236   
237      ok = .TRUE.
238      CALL SPHCST()
239      CALL DETUN()
240      CALL OPTIMZ('GSAS-II',ok)
241       
242C      print *,lambda,max_angle,h_bnd,k_bnd,l_bnd,no_trials,
243C     1  rad_type,X_RAY,n_atoms
244C      print *,(l_g(j),j=1,n_layers)
245C      do j=1,n_layers
246C        print *,(hx_ky(i,j),i=1,l_n_atoms(j))
247C        print *,(mat(i,j),i=1,n_layers)
248C        print *,(mat1(i,j),i=1,n_layers)
249C        print *,(l_phi(i,j),i=1,n_layers)
250C      end do
251       
252      ok = GETSPC(AGLQ16,'GSAS-II')             
253      DO I=1,NSADP
254        SADP(I) = spec(I)
255      END DO
256      RETURN
257      END
258       
259      SUBROUTINE PYPROFILE(U,V,W,HW,BLUR,NBRD,BRDSPC)
260       
261Cf2py intent(in) U
262Cf2py intent(in) V
263Cf2py intent(in) W
264Cf2py intent(in) HW
265Cf2py intent(in) NBRD
266Cf2py intent(in/out) BRDSPC
267Cf2py depend(NBRD) BRDSPC
268               
269      INCLUDE 'DIFFaXsubs/DIFFaX.par'
270      INCLUDE 'DIFFaXsubs/DIFFaX.inc'
271       
272      INTEGER*4 BLUR,i,NBRD   
273      REAL*8 U,V,W,HW,BRDSPC(NBRD),tth_min
274       
275      tth_min = ZERO
276           
277      if (blur.eq.GAUSS) then
278        FWHM = HW
279        call GAUSSN(tth_min)
280      else if (blur.eq.PV_GSS) then
281        pv_u = U
282        pv_v = V
283        pv_w = W
284        pv_gamma = ZERO
285        call PV(tth_min)
286      end if
287      do i=1,NBRD
288        BRDSPC(i) = brd_spc(i)
289      end do
290       
291      RETURN
292      END
293       
294      SUBROUTINE PYGETSADP(CNTRLS,NSADP,SADP,HKLIM,INCR,NBLK)
295       
296Cf2py intent(in) CNTRLS
297Cf2py intent(in) NSADP
298Cf2py intent(in/out) SADP
299Cf2py depend(NSADP) SADP
300Cf2py intent(out) HKLIM
301Cf2py intent(out) INCR
302Cf2py intent(out) NBLK
303   
304      INCLUDE 'DIFFaXsubs/DIFFaX.par'
305      INCLUDE 'DIFFaXsubs/DIFFaX.inc'
306
307      INTEGER*4 CNTRLS(7),NSADP,i_plane,hk_lim,i,j,k
308      INTEGER*4 HKLIM,NBLK
309      REAL*8 SADP(NSADP),AGLQ16,l_upper,INCR
310      LOGICAL ok
311       
312      EXTERNAL AGLQ16                 
313                   
314      i_plane = CNTRLS(2)
315      l_upper = CNTRLS(3)
316C      print *,n_actual,(l_n_atoms(i),i=1,n_actual)
317C      do j=1,n_actual
318C        do i=1,l_n_atoms(j)
319C          print *,a_name(i,j),(a_pos(k,i,j),k=1,3)
320C        end do
321C      end do
322c      print *, recrsv,inf_thick,xplcit,rndm,l_cnt,has_l_mirror
323C      do i=1,n_layers
324C      print *,' layer',i
325C         do j=1,n_layers
326C            print *,'layer',j,l_alpha(i,j),(l_r(k,i,j),k=1,3)
327C         end do
328C      end do
329      ok = .TRUE.
330       
331c      print *,cell_a,cell_b,cell_c,cell_gamma,pnt_grp,SymGrpNo
332c      DoSymDump = .TRUE.
333      CALL SPHCST()
334      CALL DETUN()
335      CALL OPTIMZ('GSAS-II',ok)
336C      print *,lambda,max_angle,h_bnd,k_bnd,l_bnd,no_trials,
337C     1  rad_type,X_RAY,n_atoms
338C      print *,(l_g(j),j=1,n_layers)
339C      do j=1,n_layers
340C        print *,(hx_ky(i,j),i=1,l_n_atoms(j))
341C        print *,(mat(i,j),i=1,n_layers)
342C        print *,(mat1(i,j),i=1,n_layers)
343C        print *,(l_phi(i,j),i=1,n_layers)
344C      end do
345      CALL GETSAD(AGLQ16,i_plane,l_upper,hk_lim,'GSAS-II',ok)
346      NBLK = sadblock
347      HKLIM = hk_lim+1
348      INCR = dble(SADSIZE/2)/l_upper
349      if (i_plane.eq.1) then
350        INCR = INCR*sqrt(a0/c0)
351      else if (i_plane.eq.2) then
352        INCR = INCR*sqrt(b0/c0)
353      else if (i_plane.eq.3) then
354        INCR = INCR*sqrt((a0+b0+d0)/c0)
355      else if (i_plane.eq.4) then
356        INCR = INCR*sqrt((a0+b0-d0)/c0)
357      end if
358      do I=1,NSADP
359        SADP(i) = spec(i)
360      end do
361      RETURN
362      END
363
364           
Note: See TracBrowser for help on using the repository browser.