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