source: trunk/fsource/pydiffax.for @ 2191

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

reduce printing from DIFFaX routines - new fortran binaries
fix bug in PWDR simulation
begin CalcStackingPWDR to call GETSPEC from DIFFaXsubs

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