source: trunk/fsource/pydiffax.for @ 2188

Last change on this file since 2188 was 2188, checked in by vondreele, 7 years ago
File size: 6.9 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      DO J=1,NATP
17        WRITE(atom_l(J),'(A4)') ATYPES(J)
18        DO I=1,9
19          x_sf(I,J) = SFDAT(I,J)
20        END DO
21C        print *,ATYPES(J),(x_sf(I,J),I=1,9)
22      END DO
23      intp_F = .TRUE.
24      n_atoms = NATP
25      RETURN
26      END
27       
28      SUBROUTINE PYGETCLAY(CNTRLS,LAUESYM,WDTH,NST,STSEQ)
29       
30Cf2py intent(in) CNTRLS
31Cf2py intent(in) LAUESYM
32Cf2py intent(in) WDTH
33Cf2py intent(in) NST
34Cf2py intent(in) STSEQ
35cf2py depend(NST) STSEQ
36     
37      INCLUDE 'DIFFaXsubs/DIFFaX.par'
38      INCLUDE 'DIFFaXsubs/DIFFaX.inc'
39
40      CHARACTER*12 LAUESYM
41      INTEGER*4 CNTRLS(7),NST,STSEQ(NST),I
42      REAL*8 WDTH(2)                 
43      LOGICAL*4 ok,GETLAY
44      EXTERNAL GETLAY
45                                     
46      PI = FOUR * atan(ONE)
47      PI2 = TWO * PI
48      DEG2RAD = PI / ONE_EIGHTY
49      RAD2DEG = ONE_EIGHTY / PI
50      rad_type = X_RAY
51      lambda = 0.1
52      trim_origin = .TRUE.
53      blurring = NONE
54      loglin = 1
55      tolerance = 0.01
56      finite_width = .TRUE.
57      Wa = WDTH(1)*10000.
58      Wb = WDTH(2)*10000.
59      IF (Wa.GE.10000.) finite_width = .FALSE.
60      WRITE(pnt_grp,'(A12)') LAUESYM
61      SymGrpNo = CNTRLS(1)
62      check_sym = .TRUE.
63C CNTRLS = [laueId,planeId,lmax,mult,StkType,StkParm,ranSeed]
64      bitdepth = 16
65      ok = .TRUE.
66      scaleint = FLOAT(CNTRLS(4))
67C fill in stacking seq stuff                 
68      IF (CNTRLS(5).NE.0) THEN
69        xplcit = .TRUE.
70        recrsv = .FALSE.
71        IF (CNTRLS(6).EQ.1) THEN
72            rndm = .TRUE.
73        ELSE
74            rndm = .FALSE.
75            l_cnt = NST
76            DO I=1,NST
77              l_seq(I) = STSEQ(I)
78            END DO       
79        END IF   
80      ELSE
81        recrsv = .TRUE.
82        xplcit = .FALSE.
83        IF (CNTRLS(6).NE.0) THEN
84            l_cnt = CNTRLS(7)
85            inf_thick = .FALSE.
86        ELSE
87            inf_thick = .TRUE.
88        END IF
89      END IF
90      IF (rndm) ok = GETLAY()
91      RETURN
92      END
93           
94      SUBROUTINE PYCELLAYER(CELL,NATM,ATMTP,ATMXOU,NU,LSYM,NL,LNUM)
95                   
96Cf2py intent(in) CELL
97Cf2py intent(in) NATM
98Cf2py intent(in) ATMTP
99Cf2py intent(in) ATMXOU
100cf2py depend(NATM) ATMTP,ATMXOU
101Cf2py intent(in) NU
102Cf2py intent(in) LSYM
103Cf2py depend(NU) LSYM
104Cf2py intent(in) NL
105Cf2py intent(in) LNUM
106Cf2py depend(NL) LNUM
107                       
108      INCLUDE 'DIFFaXsubs/DIFFaX.par'
109      INCLUDE 'DIFFaXsubs/DIFFaX.inc'
110
111      INTEGER*4 NATM,NL,LNUM(NL),NU,LSYM(NU)
112      CHARACTER*4 ATMTP(NATM)
113      REAL*8  CELL(4),ATMXOU(8,NATM)
114      INTEGER*4 I,J,K,IL,IA
115
116C fill Common - cell stuff & finish symmetry stuff
117      cell_a = CELL(1)
118      cell_b = CELL(2)
119      cell_c = CELL(3)
120      cell_gamma = CELL(4)*DEG2RAD
121C fill common layer stuff - atoms & symm
122C      print *,NL,LNUM,NU,LSYM
123      DO I=1,NATM
124        IL = NINT(ATMXOU(1,I))
125        IA = NINT(ATMXOU(2,I))       
126        a_type(IA,IL) = NINT(ATMXOU(3,I))
127C        print *,ATMTP(I),IL,IA,a_type(IA,IL),(ATMXOU(j,I),j=4,6)
128        a_number(IA,IL) = IA
129        WRITE(a_name(IA,IL),'(A4)') ATMTP(I)
130        DO K=1,3
131            a_pos(K,IA,IL) = ATMXOU(K+3,I)
132        END DO
133        high_atom(IL) = max(high_atom(IL),a_pos(3,IA,IL))
134        low_atom(IL) = min(low_atom(IL),a_pos(3,IA,IL))
135        IF (LSYM(IL).EQ.CENTRO) THEN
136            high_atom(IL) = MAX(high_atom(IL),-a_pos(3,IA,IL))
137            low_atom(IL) = MIN(low_atom(IL),-a_pos(3,IA,IL))
138        END IF
139        a_occup(IA,IL) = ATMXOU(7,I)
140        a_B(IA,IL) = ATMXOU(8,I)
141        l_n_atoms(IL) = IA
142        l_symmetry(IL) = LSYM(IL)
143      END DO
144C      print *,IL,high_atom(IL),low_atom(IL)
145      n_actual = IL
146      n_layers = NL
147      DO I=1,NL
148        l_actual(I) = LNUM(I)
149        DO J=1,NL
150            Bs_zero(J,I) = .TRUE.
151        END DO
152      END DO
153      all_Bs_zero = .TRUE.
154      RETURN
155      END
156
157      SUBROUTINE PYGETTRANS(NL,TRP,TRX)
158     
159Cf2py intent(in) NL
160Cf2py intent(in) TRP
161Cf2py intent(in) TRX
162Cf2py depend(NL) TRP,TRX
163     
164     
165      INCLUDE 'DIFFaXsubs/DIFFaX.par'
166      INCLUDE 'DIFFaXsubs/DIFFaX.inc'
167       
168      INTEGER*4 I,J,K
169      INTEGER*4 NL
170      REAL*4  TRP(NL,NL),TRX(NL,NL,3)
171                               
172C fill common transitions stuff
173      DO J=1,NL
174        DO I=1,NL
175          l_alpha(J,I) = TRP(I,J)
176          DO K=1,3
177            l_r(K,J,I) = TRX(I,J,K)
178          END DO
179        END DO
180      END DO
181      RETURN
182      END
183       
184           
185      SUBROUTINE PYGETSADP(CNTRLS,NSADP,SADP,HKLIM,INCR)
186       
187Cf2py intent(in) CNTRLS
188Cf2py intent(in) NSADP
189Cf2py intent(in/out) SADP
190Cf2py depend(NSADP) SADP
191Cf2py intent(out) HKLIM
192Cf2py intent(out) INCR
193   
194      INCLUDE 'DIFFaXsubs/DIFFaX.par'
195      INCLUDE 'DIFFaXsubs/DIFFaX.inc'
196
197      INTEGER*4 CNTRLS(7),NSADP,GET_SYM,i_plane,hk_lim,i,j,k
198      INTEGER*4 HKLIM
199      REAL*8 SADP(NSADP),AGLQ16,l_upper,INCR
200      LOGICAL ok,GET_G
201       
202      EXTERNAL AGLQ16,GET_SYM,GET_G                 
203                   
204      i_plane = CNTRLS(2)
205      l_upper = CNTRLS(3)
206C      print *,n_actual,(l_n_atoms(i),i=1,n_actual)
207C      do j=1,n_actual
208C        do i=1,l_n_atoms(j)
209C          print *,a_name(i,j),(a_pos(k,i,j),k=1,3)
210C        end do
211C      end do
212C      print *, recrsv,inf_thick,xplcit,rndm,l_cnt,has_l_mirror
213C      do i=1,n_layers
214C      print *,' layer',i
215C         do j=1,n_layers
216C            print *,'layer',j,l_alpha(i,j),(l_r(k,i,j),k=1,3)
217C         end do
218C      end do
219      ok = .TRUE.
220       
221C      print *,cell_a,cell_b,cell_c,cell_gamma,pnt_grp,SymGrpNo
222c      DoSymDump = .TRUE.
223      CALL SPHCST()
224      CALL DETUN()
225      ok = GET_G()
226      CALL OPTIMZ('GSAS-II',ok)
227C      print *,lambda,max_angle,h_bnd,k_bnd,l_bnd,no_trials,
228C     1  rad_type,X_RAY,n_atoms
229C      print *,(l_g(j),j=1,n_layers)
230C      do j=1,n_layers
231C        print *,(hx_ky(i,j),i=1,l_n_atoms(j))
232C        print *,(mat(i,j),i=1,n_layers)
233C        print *,(mat1(i,j),i=1,n_layers)
234C        print *,(l_phi(i,j),i=1,n_layers)
235C      end do
236      CALL GETSAD(AGLQ16,i_plane,l_upper,hk_lim,'GSAS-II',ok)
237      HKLIM = hk_lim+1
238      INCR = dble(SADSIZE/2)/l_upper
239      if (i_plane.eq.1) then
240        INCR = INCR*sqrt(a0/c0)
241      else if (i_plane.eq.2) then
242        INCR = INCR*sqrt(b0/c0)
243      else if (i_plane.eq.3) then
244        INCR = INCR*sqrt((a0+b0+d0)/c0)
245      else if (i_plane.eq.4) then
246        INCR = INCR*sqrt((a0+b0-d0)/c0)
247      end if
248      do I=1,NSADP
249        SADP(i) = spec(i)
250      end do
251      RETURN
252      END
Note: See TracBrowser for help on using the repository browser.