linse/sics
0
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

PSI sics-cvs-psi_pre-ansto

Browse Source
This commit is contained in:
koennecke
2003-06-13 00:00:00 +00:00
committed by Douglas Clowes
parent 2e3ddfb6c6
commit 3ffd0d8af4
1099 changed files with 318432 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

215
difrac/dhgen.f Normal file
View File

@@ -0,0 +1,215 @@
C-----------------------------------------------------------------------
C Subroutine to generate and print the DH matrices
C-----------------------------------------------------------------------
SUBROUTINE DHGEN
INCLUDE 'COMDIF'
DIMENSION IDHM(3,4,4),IDHC(3,4),ISET(25),IDHN(4,14),JDHM(3,4,16),
$ INDH(14),JDHN(4),JUNK(8)
EQUIVALENCE (JUNK(1),D12), (JUNK(2),ILOW), (JUNK(3),IHIGH),
$ (JUNK(4),IDEL), (JUNK(5),IWARN),(JUNK(6),SUM),
$ (JUNK(7),FRAC1),(JUNK(8),IPRFLG)
C-----------------------------------------------------------------------
C The 16 possible DH matrices
C-----------------------------------------------------------------------
DATA JDHM / 0,0,0, 1,0,0, 0,1,0, 0,0,1,
$ -1,0,1, -1,0,0, 0,1,0, 0,0,1,
$ -1,1,0, -1,0,0, 0,1,0, 0,0,-1,
$ 0,1,-1, 1,0,0, 0,1,0, 0,0,-1,
$ 0,0,0, 1,0,0, 1,1,0, 0,0,1,
$ 0,0,0, 1,0,0, 1,1,0, 1,1,1,
$ 1,2,0, 0,1,0, 1,1,0, 1,1,1,
$ 1,2,0, 0,1,0, 1,1,0, 0,0,1,
$ 0,1,1, 0,1,0, 1,1,0, 0,0,1,
$ 1,1,-1, 1,0,0, 1,1,0, 0,0,-1,
$ 0,1,1, 0,1,0, -1,1,0, 0,0,1,
$ 1,2,0, 1,1,0, 0,1,0, 0,0,1,
$ 0,0,0, 1,0,0, 1,0,-1, 1,1,1,
$ 1,1,0, 1,0,-1, 0,0,-1, 1,1,1,
$ 0,-1,-2, 1,0,0, 1,0,-1,-1,-1,-1,
$ 1,0,-2, 1,0,-1, 0,0,-1,-1,-1,-1/
DATA INDH/4,2,1,2,1,4,2,3,2,2,2,1,2,1/
C-----------------------------------------------------------------------
C -1 2/m mmm 4/m
C 4/mmm R-3 R-3m -3
C -31m -3m1 6/m 6/mmm
C m3 m3m
C-----------------------------------------------------------------------
DATA IDHN/ 1, 2, 3, 4, 1, 2, 0, 0, 1, 0, 0, 0, 5,12, 0, 0,
$ 5, 0, 0, 0, 13,14,15,16, 13,14, 0, 0, 5,12,11, 0,
$ 5, 9, 0, 0, 5,10, 0, 0, 5, 8, 0, 0, 5, 0, 0, 0,
$ 6, 7, 0, 0, 6, 0, 0, 0/
C-----------------------------------------------------------------------
C Select the proper segment information
C-----------------------------------------------------------------------
NUMDH = INDH(LAUENO)
DO 100 I = 1,4
JDHN(I) = IDHN(I,LAUENO)
100 CONTINUE
C-----------------------------------------------------------------------
C Output the independent set
C-----------------------------------------------------------------------
DO 120 N = 1,NUMDH
DO 120 I = 1,3
DO 120 J = 1,4
M = JDHN(N)
IDHM(I,J,N) = JDHM(I,J,M)
120 CONTINUE
IF (LAUENO .EQ. 2) THEN
DO 130 N = 1,NUMDH
DO 130 J = 1,4
SAVE = IDHM(2,J,N)
IDHM(2,J,N) = IDHM(NAXIS,J,N)
IDHM(NAXIS,J,N) = SAVE
130 CONTINUE
ENDIF
C-----------------------------------------------------------------------
C If in Automatic Alignment mode, skip the questions (???)
C-----------------------------------------------------------------------
C 140 IF (KI .EQ. 'O2') GO TO 260
C-----------------------------------------------------------------------
C Do DH stuff in GO mode only
C-----------------------------------------------------------------------
IF (KI .EQ. 'GO') THEN
C-----------------------------------------------------------------------
C Any changes to the DH sequences ?
C-----------------------------------------------------------------------
WRITE (COUT,9000)
CALL YESNO ('N',ANS)
IF (ANS .EQ. 'Y') THEN
140 WRITE (COUT,10000)
CALL GWRITE (ITP,' ')
WRITE (COUT,11000) (L,((IDHM(I,J,L),I=1,3),J=1,4),L=1,NUMDH)
CALL GWRITE (ITP,' ')
C-----------------------------------------------------------------------
C Alter the order of the DH vectors ?
C-----------------------------------------------------------------------
WRITE (COUT,12000)
CALL YESNO ('N',ANS)
IF (ANS .EQ. 'Y') THEN
WRITE (COUT,13000)
CALL FREEFM (ITR)
NSET = IFREE(1)
NSMIN = NSET
NSMAX = NSET
IF (NSET .EQ. 0) THEN
NSMIN = 1
NSMAX = NUMDH
ENDIF
150 WRITE (COUT,15000)
CALL FREEFM (ITR)
I1 = IFREE(1)
I2 = IFREE(2)
I3 = IFREE(3)
IF (I1*I2*I3 .NE. 6) GO TO 150
DO 160 NSET = NSMIN,NSMAX
DO 160 I = 1,3
SAVE1 = IDHM(I,I1+1,NSET)
SAVE2 = IDHM(I,I2+1,NSET)
SAVE3 = IDHM(I,I3+1,NSET)
IDHM(I,2,NSET) = SAVE1
IDHM(I,3,NSET) = SAVE2
IDHM(I,4,NSET) = SAVE3
160 CONTINUE
GO TO 140
ENDIF
C-----------------------------------------------------------------------
C Print the DH matrices for the various sets
C-----------------------------------------------------------------------
NSET = 0
WRITE (COUT,17000)
CALL YESNO ('N',ANS)
IF (ANS .EQ. 'Y') THEN
WRITE (LPT,19000)
C-----------------------------------------------------------------------
C Calculate the symmetry-related matrices and print them
C-----------------------------------------------------------------------
DO 190 M = 1,NSYM
DO 190 L = 1,NUMDH
LDH = JDHN(L)
DO 180 K = 1,4
DO 180 J = 1,3
IDHC(J,K) = 0
DO 180 I = 1,3
IDHC(J,K) = IDHC(J,K)+IDHM(I,K,L)*JRT(I,J,M)
180 CONTINUE
WRITE (LPT,21000) M,L,IDHC
190 CONTINUE
ENDIF
C-----------------------------------------------------------------------
C Propose the pointer mode
C-----------------------------------------------------------------------
WRITE (COUT,22000)
CALL YESNO ('Y',ANS)
NSET = 0
IF (ANS .EQ. 'N') THEN
200 WRITE (COUT,23000)
CALL FREEFM (ITR)
DO 210 I = 1,12
ISET(I) = IFREE(I)
210 CONTINUE
DO 220 I = 13,25
ISET(I) = 0
220 CONTINUE
WRITE (COUT,23100)
CALL YESNO ('N',ANS)
IF (ANS .EQ. 'Y') THEN
WRITE (COUT,23200)
CALL FREEFM (ITR)
DO 230 I = 1,13
ISET(I+12) = IFREE(I)
230 CONTINUE
ENDIF
C-----------------------------------------------------------------------
C Find the number of pointers typed
C-----------------------------------------------------------------------
DO 240 NSET = 1,25
IF (ISET(NSET) .EQ. 0) GO TO 250
240 CONTINUE
NSET = NSET + 1
250 NSET = NSET - 1
C-----------------------------------------------------------------------
C Output them
C-----------------------------------------------------------------------
WRITE (COUT,24000) (ISET(I),I = 1,NSET)
CALL GWRITE (ITP,' ')
WRITE (COUT,25000)
CALL YESNO ('Y',ANS)
IF (ANS .EQ. 'N') GO TO 200
WRITE (LPT,26000)
WRITE (LPT,24000) (ISET(I),I = 1,NSET)
IHO(5) = 1
ENDIF
ENDIF
ENDIF
C-----------------------------------------------------------------------
C Write all this information on the IDATA file
C-----------------------------------------------------------------------
260 WRITE (IID,REC=4) LATCEN,NUMDH,IDHM,NSYM,
$ NSET,ISET,LAUENO,NAXIS,ICENT
WRITE (IID,REC=5) (((JRT(I,J,K),I = 1,3),J = 1,4),K = 1, 6)
WRITE (IID,REC=6) (((JRT(I,J,K),I = 1,3),J = 1,4),K = 7,12)
WRITE (IID,REC=7) (((JRT(I,J,K),I = 1,3),J = 1,4),K = 13,18)
WRITE (IID,REC=8) (((JRT(I,J,K),I = 1,3),J = 1,4),K = 19,24)
RETURN
9000 FORMAT (' Do you wish to change the order of data-collection',
$ ' (N) ? ',$)
10000 FORMAT (/' DH Segment',15X,'Slow',16X,'Fast'/
$ 28X,'1',9X,'2',9X,'3')
11000 FORMAT (5X,I3,5X,3I3,'/',3I3,'/',3I3,'/',3I3)
12000 FORMAT (' Do you wish to alter the h,k,l collection order',
$ ' (N) ? ',$)
13000 FORMAT (' In which segment (All) ? ',$)
15000 FORMAT (' Type the order of collection, slowest first.',/,
$ '(e.g. 3,1,2 means 3 slowest and 2 fastest) ',$)
17000 FORMAT (' Do you wish to print the DH matrices (N) ? ',$)
19000 FORMAT (6X,'Set # Segment # St Ref Slow',18X,'Fast',/)
21000 FORMAT (2I10,5X,4(3I3,2X))
22000 FORMAT (' Do you wish to collect the sets in the order',
$ ' 1,-1,2,-2,... (Y) ? ',$)
23000 FORMAT (' Type a sequence of up to 12 set numbers on one line')
23100 FORMAT (' Any more set numbers to type (N) ? ',$)
23200 FORMAT (' Type up to another 13 set numbers on one line')
24000 FORMAT (12I5,/,13I5)
25000 FORMAT (' Is this sequence OK (Y) ? ',$)
26000 FORMAT (///' The sequence of DH sets for data collection is :--')
END