216 lines
9.1 KiB
Fortran
216 lines
9.1 KiB
Fortran
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
|