source: trunk/fsource/pydiffax.for @ 2189

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

comment out import pydiffax since g77 version woun't compile (argh)

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